summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNo author <no_author@ocaml.org>2003-12-01 00:27:30 +0000
committerNo author <no_author@ocaml.org>2003-12-01 00:27:30 +0000
commitbbc1c339f4b0de238e8024fb632ecb30bcc686de (patch)
tree0615819bbabbe4ae4195a43751c5f892199e9527
parente0d554119941c6fd0852feee85681bd3e5feb1ad (diff)
downloadocaml-bbc1c339f4b0de238e8024fb632ecb30bcc686de.tar.gz
This commit was manufactured by cvs2svn to create branch 'newoolab'.
git-svn-id: http://caml.inria.fr/svn/ocaml/branches/newoolab@5988 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
-rw-r--r--.cvsignore13
-rw-r--r--.depend772
-rw-r--r--Changes1657
-rw-r--r--INSTALL263
-rw-r--r--INSTALL.MPW89
-rw-r--r--LICENSE618
-rw-r--r--Makefile671
-rw-r--r--Makefile.Mac488
-rw-r--r--Makefile.Mac.depend548
-rw-r--r--Makefile.nt622
-rw-r--r--README144
-rw-r--r--README.win32248
-rw-r--r--Upgrading109
-rw-r--r--asmrun/.cvsignore33
-rw-r--r--asmrun/.depend498
-rw-r--r--asmrun/Makefile195
-rw-r--r--asmrun/Makefile.nt77
-rw-r--r--asmrun/alpha.S440
-rw-r--r--asmrun/amd64.S335
-rw-r--r--asmrun/arm.S339
-rw-r--r--asmrun/fail.c172
-rw-r--r--asmrun/hppa.S550
-rw-r--r--asmrun/i386.S326
-rw-r--r--asmrun/i386nt.asm278
-rw-r--r--asmrun/ia64.S530
-rw-r--r--asmrun/m68k.S244
-rw-r--r--asmrun/mips.s386
-rw-r--r--asmrun/power-aix.S513
-rw-r--r--asmrun/power-elf.S421
-rw-r--r--asmrun/power-rhapsody.S416
-rw-r--r--asmrun/roots.c297
-rw-r--r--asmrun/signals.c677
-rw-r--r--asmrun/sparc.S398
-rw-r--r--asmrun/stack.h105
-rw-r--r--asmrun/startup.c158
-rw-r--r--boot/.cvsignore4
-rwxr-xr-xboot/ocamlcbin948084 -> 0 bytes
-rwxr-xr-xboot/ocamllexbin147675 -> 0 bytes
-rw-r--r--camlp4/CHANGES851
-rw-r--r--camlp4/ICHANGES20
-rw-r--r--camlp4/Makefile190
-rw-r--r--camlp4/Makefile.Mac204
-rw-r--r--camlp4/boot/.cvsignore5
-rw-r--r--camlp4/camlp4/.cvsignore6
-rw-r--r--camlp4/camlp4/.depend21
-rw-r--r--camlp4/camlp4/Makefile71
-rw-r--r--camlp4/camlp4/Makefile.Mac69
-rw-r--r--camlp4/camlp4/Makefile.Mac.depend15
-rw-r--r--camlp4/camlp4/argl.ml424
-rw-r--r--camlp4/camlp4/ast2pt.ml867
-rw-r--r--camlp4/camlp4/ast2pt.mli23
-rw-r--r--camlp4/camlp4/mLast.mli211
-rw-r--r--camlp4/camlp4/pcaml.ml457
-rw-r--r--camlp4/camlp4/pcaml.mli157
-rw-r--r--camlp4/camlp4/quotation.ml33
-rw-r--r--camlp4/camlp4/quotation.mli48
-rw-r--r--camlp4/camlp4/reloc.ml289
-rw-r--r--camlp4/camlp4/reloc.mli16
-rw-r--r--camlp4/camlp4/spretty.ml481
-rw-r--r--camlp4/camlp4/spretty.mli54
-rw-r--r--camlp4/compile/.cvsignore4
-rw-r--r--camlp4/compile/.depend4
-rw-r--r--camlp4/compile/Makefile45
-rw-r--r--camlp4/compile/comp_head.ml70
-rw-r--r--camlp4/compile/comp_trail.ml33
-rw-r--r--camlp4/compile/compile.ml571
-rwxr-xr-xcamlp4/compile/compile.sh27
-rw-r--r--camlp4/config/.cvsignore2
-rw-r--r--camlp4/config/Makefile-nt.cnf7
-rw-r--r--camlp4/config/Makefile.tpl28
-rw-r--r--camlp4/config/config.mpw50
-rwxr-xr-xcamlp4/config/configure_batch113
-rw-r--r--camlp4/etc/.cvsignore6
-rw-r--r--camlp4/etc/.depend73
-rw-r--r--camlp4/etc/Makefile107
-rw-r--r--camlp4/etc/Makefile.Mac71
-rw-r--r--camlp4/etc/Makefile.Mac.depend40
-rw-r--r--camlp4/etc/lib.sml384
-rw-r--r--camlp4/etc/mkcamlp4.mpw.tpl33
-rwxr-xr-xcamlp4/etc/mkcamlp4.sh.tpl33
-rw-r--r--camlp4/etc/pa_extfold.ml42
-rw-r--r--camlp4/etc/pa_extfun.ml123
-rw-r--r--camlp4/etc/pa_format.ml39
-rw-r--r--camlp4/etc/pa_fstream.ml163
-rw-r--r--camlp4/etc/pa_ifdef.ml87
-rw-r--r--camlp4/etc/pa_lefteval.ml239
-rw-r--r--camlp4/etc/pa_lisp.ml684
-rw-r--r--camlp4/etc/pa_lispr.ml665
-rw-r--r--camlp4/etc/pa_o.ml1293
-rw-r--r--camlp4/etc/pa_ocamllex.ml344
-rw-r--r--camlp4/etc/pa_olabl.ml2005
-rw-r--r--camlp4/etc/pa_oop.ml154
-rw-r--r--camlp4/etc/pa_op.ml330
-rw-r--r--camlp4/etc/pa_ru.ml46
-rw-r--r--camlp4/etc/pa_scheme.ml1002
-rw-r--r--camlp4/etc/pa_schemer.ml1067
-rw-r--r--camlp4/etc/pa_sml.ml947
-rw-r--r--camlp4/etc/parserify.ml301
-rw-r--r--camlp4/etc/parserify.mli12
-rw-r--r--camlp4/etc/pr_depend.ml327
-rw-r--r--camlp4/etc/pr_extend.ml514
-rw-r--r--camlp4/etc/pr_extfun.ml92
-rw-r--r--camlp4/etc/pr_null.ml16
-rw-r--r--camlp4/etc/pr_o.ml2062
-rw-r--r--camlp4/etc/pr_op.ml503
-rw-r--r--camlp4/etc/pr_op_main.ml214
-rw-r--r--camlp4/etc/pr_r.ml1898
-rw-r--r--camlp4/etc/pr_rp.ml504
-rw-r--r--camlp4/etc/pr_rp_main.ml206
-rw-r--r--camlp4/etc/pr_scheme.ml813
-rw-r--r--camlp4/etc/pr_schp_main.ml119
-rw-r--r--camlp4/etc/q_phony.ml49
-rw-r--r--camlp4/lib/.cvsignore3
-rw-r--r--camlp4/lib/.depend20
-rw-r--r--camlp4/lib/Makefile48
-rw-r--r--camlp4/lib/Makefile.Mac46
-rw-r--r--camlp4/lib/Makefile.Mac.depend13
-rw-r--r--camlp4/lib/extfold.ml91
-rw-r--r--camlp4/lib/extfold.mli24
-rw-r--r--camlp4/lib/extfun.ml109
-rw-r--r--camlp4/lib/extfun.mli36
-rw-r--r--camlp4/lib/fstream.ml77
-rw-r--r--camlp4/lib/fstream.mli60
-rw-r--r--camlp4/lib/gramext.ml565
-rw-r--r--camlp4/lib/gramext.mli81
-rw-r--r--camlp4/lib/grammar.ml1064
-rw-r--r--camlp4/lib/grammar.mli209
-rw-r--r--camlp4/lib/plexer.ml1006
-rw-r--r--camlp4/lib/plexer.mli72
-rw-r--r--camlp4/lib/stdpp.ml79
-rw-r--r--camlp4/lib/stdpp.mli37
-rw-r--r--camlp4/lib/token.ml229
-rw-r--r--camlp4/lib/token.mli133
-rw-r--r--camlp4/man/.cvsignore2
-rw-r--r--camlp4/man/Makefile28
-rw-r--r--camlp4/man/Makefile.Mac31
-rw-r--r--camlp4/man/camlp4.1.tpl302
-rw-r--r--camlp4/man/camlp4.help.tpl1
-rw-r--r--camlp4/meta/.cvsignore3
-rw-r--r--camlp4/meta/.depend16
-rw-r--r--camlp4/meta/Makefile59
-rw-r--r--camlp4/meta/Makefile.Mac50
-rw-r--r--camlp4/meta/Makefile.Mac.depend12
-rwxr-xr-xcamlp4/meta/mk_q_MLast.sh12
-rw-r--r--camlp4/meta/pa_extend.ml916
-rw-r--r--camlp4/meta/pa_extend_m.ml26
-rw-r--r--camlp4/meta/pa_ifdef.ml85
-rw-r--r--camlp4/meta/pa_macro.ml251
-rw-r--r--camlp4/meta/pa_r.ml943
-rw-r--r--camlp4/meta/pa_rp.ml318
-rw-r--r--camlp4/meta/pr_dump.ml52
-rw-r--r--camlp4/meta/q_MLast.ml1501
-rw-r--r--camlp4/ocaml_src/.cvsignore1
-rw-r--r--camlp4/ocaml_src/camlp4/.cvsignore3
-rw-r--r--camlp4/ocaml_src/camlp4/.depend21
-rw-r--r--camlp4/ocaml_src/camlp4/Makefile71
-rw-r--r--camlp4/ocaml_src/camlp4/Makefile.Mac69
-rw-r--r--camlp4/ocaml_src/camlp4/Makefile.Mac.depend15
-rw-r--r--camlp4/ocaml_src/camlp4/argl.ml406
-rw-r--r--camlp4/ocaml_src/camlp4/ast2pt.ml880
-rw-r--r--camlp4/ocaml_src/camlp4/ast2pt.mli23
-rw-r--r--camlp4/ocaml_src/camlp4/mLast.mli211
-rw-r--r--camlp4/ocaml_src/camlp4/pcaml.ml464
-rw-r--r--camlp4/ocaml_src/camlp4/pcaml.mli158
-rw-r--r--camlp4/ocaml_src/camlp4/quotation.ml33
-rw-r--r--camlp4/ocaml_src/camlp4/quotation.mli48
-rw-r--r--camlp4/ocaml_src/camlp4/reloc.ml337
-rw-r--r--camlp4/ocaml_src/camlp4/reloc.mli16
-rw-r--r--camlp4/ocaml_src/camlp4/spretty.ml465
-rw-r--r--camlp4/ocaml_src/camlp4/spretty.mli59
-rw-r--r--camlp4/ocaml_src/lib/.depend20
-rw-r--r--camlp4/ocaml_src/lib/Makefile48
-rw-r--r--camlp4/ocaml_src/lib/Makefile.Mac46
-rw-r--r--camlp4/ocaml_src/lib/Makefile.Mac.depend13
-rw-r--r--camlp4/ocaml_src/lib/extfold.ml124
-rw-r--r--camlp4/ocaml_src/lib/extfold.mli24
-rw-r--r--camlp4/ocaml_src/lib/extfun.ml105
-rw-r--r--camlp4/ocaml_src/lib/extfun.mli37
-rw-r--r--camlp4/ocaml_src/lib/fstream.ml84
-rw-r--r--camlp4/ocaml_src/lib/fstream.mli60
-rw-r--r--camlp4/ocaml_src/lib/gramext.ml531
-rw-r--r--camlp4/ocaml_src/lib/gramext.mli79
-rw-r--r--camlp4/ocaml_src/lib/grammar.ml1119
-rw-r--r--camlp4/ocaml_src/lib/grammar.mli200
-rw-r--r--camlp4/ocaml_src/lib/plexer.ml1258
-rw-r--r--camlp4/ocaml_src/lib/plexer.mli72
-rw-r--r--camlp4/ocaml_src/lib/stdpp.ml99
-rw-r--r--camlp4/ocaml_src/lib/stdpp.mli37
-rw-r--r--camlp4/ocaml_src/lib/token.ml223
-rw-r--r--camlp4/ocaml_src/lib/token.mli133
-rw-r--r--camlp4/ocaml_src/meta/.cvsignore2
-rw-r--r--camlp4/ocaml_src/meta/.depend16
-rw-r--r--camlp4/ocaml_src/meta/Makefile59
-rw-r--r--camlp4/ocaml_src/meta/Makefile.Mac50
-rw-r--r--camlp4/ocaml_src/meta/Makefile.Mac.depend12
-rw-r--r--camlp4/ocaml_src/meta/pa_extend.ml2027
-rw-r--r--camlp4/ocaml_src/meta/pa_extend_m.ml40
-rw-r--r--camlp4/ocaml_src/meta/pa_ifdef.ml216
-rw-r--r--camlp4/ocaml_src/meta/pa_macro.ml392
-rw-r--r--camlp4/ocaml_src/meta/pa_r.ml2814
-rw-r--r--camlp4/ocaml_src/meta/pa_rp.ml641
-rw-r--r--camlp4/ocaml_src/meta/pr_dump.ml48
-rw-r--r--camlp4/ocaml_src/meta/q_MLast.ml4700
-rw-r--r--camlp4/ocaml_src/odyl/.cvsignore2
-rw-r--r--camlp4/ocaml_src/odyl/.depend6
-rw-r--r--camlp4/ocaml_src/odyl/Makefile61
-rw-r--r--camlp4/ocaml_src/odyl/Makefile.Mac49
-rw-r--r--camlp4/ocaml_src/odyl/Makefile.Mac.depend4
-rw-r--r--camlp4/ocaml_src/odyl/odyl.ml50
-rw-r--r--camlp4/ocaml_src/odyl/odyl_main.ml77
-rw-r--r--camlp4/ocaml_src/odyl/odyl_main.mli13
-rw-r--r--camlp4/ocaml_src/tools/camlp4_comm.mpw27
-rwxr-xr-xcamlp4/ocaml_src/tools/camlp4_comm.sh9
-rw-r--r--camlp4/ocaml_src/tools/extract_crc.mpw3
-rw-r--r--camlp4/ocaml_src/tools/ocamlc.mpw3
-rwxr-xr-xcamlp4/ocaml_src/tools/ocamlc.sh8
-rwxr-xr-xcamlp4/ocaml_src/tools/ocamlopt.sh8
-rw-r--r--camlp4/ocaml_stuff/otherlibs/dynlink/.depend0
-rw-r--r--camlp4/ocaml_stuff/parsing/.depend2
-rw-r--r--camlp4/ocaml_stuff/utils/.depend2
-rw-r--r--camlp4/ocpp/.cvsignore3
-rw-r--r--camlp4/ocpp/.depend0
-rw-r--r--camlp4/ocpp/Makefile25
-rw-r--r--camlp4/ocpp/Makefile.Mac41
-rw-r--r--camlp4/ocpp/ocpp.ml140
-rw-r--r--camlp4/odyl/.cvsignore4
-rw-r--r--camlp4/odyl/.depend6
-rw-r--r--camlp4/odyl/Makefile61
-rw-r--r--camlp4/odyl/Makefile.Mac49
-rw-r--r--camlp4/odyl/Makefile.Mac.depend4
-rw-r--r--camlp4/odyl/odyl.ml51
-rw-r--r--camlp4/odyl/odyl_main.ml82
-rw-r--r--camlp4/odyl/odyl_main.mli13
-rwxr-xr-xcamlp4/tools/apply.sh31
-rw-r--r--camlp4/tools/camlp4_comm.mpw53
-rwxr-xr-xcamlp4/tools/camlp4_comm.sh38
-rwxr-xr-xcamlp4/tools/conv.sh22
-rw-r--r--camlp4/tools/extract_crc.mpw3
-rwxr-xr-xcamlp4/tools/extract_crc.sh0
-rw-r--r--camlp4/tools/ocamlc.mpw3
-rwxr-xr-xcamlp4/tools/ocamlc.sh8
-rwxr-xr-xcamlp4/tools/ocamlopt.sh8
-rw-r--r--camlp4/top/.cvsignore1
-rw-r--r--camlp4/top/.depend14
-rw-r--r--camlp4/top/Makefile52
-rw-r--r--camlp4/top/Makefile.Mac60
-rw-r--r--camlp4/top/Makefile.Mac.depend2
-rw-r--r--camlp4/top/camlp4_top.ml172
-rw-r--r--camlp4/top/oprint.ml597
-rw-r--r--camlp4/top/rprint.ml422
-rw-r--r--config/.cvsignore4
-rw-r--r--config/Makefile-templ310
-rw-r--r--config/Makefile.mingw123
-rw-r--r--config/Makefile.msvc129
-rw-r--r--config/auto-aux/align.c103
-rw-r--r--config/auto-aux/ansi.c21
-rw-r--r--config/auto-aux/async_io.c60
-rw-r--r--config/auto-aux/bytecopy.c34
-rw-r--r--config/auto-aux/dblalign.c55
-rw-r--r--config/auto-aux/divmod.c47
-rw-r--r--config/auto-aux/elf.c26
-rw-r--r--config/auto-aux/endian.c41
-rw-r--r--config/auto-aux/getgroups.c32
-rw-r--r--config/auto-aux/gethostbyaddr.c51
-rw-r--r--config/auto-aux/gethostbyname.c41
-rwxr-xr-xconfig/auto-aux/hasgot28
-rw-r--r--config/auto-aux/ia32sse2.c22
-rw-r--r--config/auto-aux/int64align.c56
-rw-r--r--config/auto-aux/longlong.c43
-rwxr-xr-xconfig/auto-aux/runtest8
-rw-r--r--config/auto-aux/schar.c23
-rw-r--r--config/auto-aux/schar2.c23
-rwxr-xr-xconfig/auto-aux/searchpath9
-rwxr-xr-xconfig/auto-aux/sharpbang2
-rwxr-xr-xconfig/auto-aux/sharpbang22
-rw-r--r--config/auto-aux/sighandler.c23
-rw-r--r--config/auto-aux/signals.c68
-rw-r--r--config/auto-aux/sizes.c23
-rw-r--r--config/auto-aux/solaris-ld7
-rw-r--r--config/auto-aux/stackov.c68
-rw-r--r--config/auto-aux/tclversion.c8
-rwxr-xr-xconfig/auto-aux/trycompile7
-rw-r--r--config/config.Mac76
-rwxr-xr-xconfig/gnu/config.guess1366
-rwxr-xr-xconfig/gnu/config.sub1375
-rw-r--r--config/m-MacOS.h33
-rw-r--r--config/m-nt.h34
-rw-r--r--config/m-templ.h81
-rw-r--r--config/s-MacOS.h20
-rw-r--r--config/s-nt.h29
-rw-r--r--config/s-templ.h207
-rwxr-xr-xconfigure1533
-rw-r--r--debugger/.cvsignore4
-rw-r--r--debugger/.depend189
-rw-r--r--debugger/Makefile114
-rw-r--r--debugger/breakpoints.ml222
-rw-r--r--debugger/breakpoints.mli61
-rw-r--r--debugger/checkpoints.ml85
-rw-r--r--debugger/checkpoints.mli58
-rw-r--r--debugger/command_line.ml1084
-rw-r--r--debugger/command_line.mli22
-rw-r--r--debugger/debugcom.ml278
-rw-r--r--debugger/debugcom.mli102
-rw-r--r--debugger/debugger_config.ml75
-rw-r--r--debugger/debugger_config.mli35
-rw-r--r--debugger/envaux.ml83
-rw-r--r--debugger/envaux.mli33
-rw-r--r--debugger/eval.ml207
-rw-r--r--debugger/eval.mli40
-rw-r--r--debugger/events.ml65
-rw-r--r--debugger/events.mli31
-rw-r--r--debugger/exec.ml50
-rw-r--r--debugger/exec.mli19
-rw-r--r--debugger/frames.ml129
-rw-r--r--debugger/frames.mli55
-rw-r--r--debugger/history.ml44
-rw-r--r--debugger/history.mli20
-rw-r--r--debugger/input_handling.ml148
-rw-r--r--debugger/input_handling.mli63
-rw-r--r--debugger/int64ops.ml26
-rw-r--r--debugger/int64ops.mli26
-rw-r--r--debugger/lexer.mll98
-rw-r--r--debugger/loadprinter.ml172
-rw-r--r--debugger/loadprinter.mli34
-rw-r--r--debugger/main.ml132
-rw-r--r--debugger/parameters.ml35
-rw-r--r--debugger/parameters.mli26
-rw-r--r--debugger/parser.mly239
-rw-r--r--debugger/parser_aux.mli34
-rw-r--r--debugger/pattern_matching.ml251
-rw-r--r--debugger/pattern_matching.mli21
-rw-r--r--debugger/pos.ml37
-rw-r--r--debugger/pos.mli15
-rw-r--r--debugger/primitives.ml194
-rw-r--r--debugger/primitives.mli86
-rw-r--r--debugger/printval.ml111
-rw-r--r--debugger/printval.mli33
-rw-r--r--debugger/program_loading.ml114
-rw-r--r--debugger/program_loading.mli34
-rw-r--r--debugger/program_management.ml157
-rw-r--r--debugger/program_management.mli27
-rw-r--r--debugger/show_information.ml94
-rw-r--r--debugger/show_information.mli26
-rw-r--r--debugger/show_source.ml79
-rw-r--r--debugger/show_source.mli23
-rw-r--r--debugger/source.ml153
-rw-r--r--debugger/source.mli58
-rw-r--r--debugger/symbols.ml169
-rw-r--r--debugger/symbols.mli44
-rw-r--r--debugger/time_travel.ml642
-rw-r--r--debugger/time_travel.mli36
-rw-r--r--debugger/trap_barrier.ml47
-rw-r--r--debugger/trap_barrier.mli27
-rw-r--r--debugger/unix_tools.ml141
-rw-r--r--debugger/unix_tools.mli34
-rw-r--r--driver/compile.ml121
-rw-r--r--driver/compile.mli24
-rw-r--r--driver/errors.ml69
-rw-r--r--driver/errors.mli18
-rw-r--r--driver/main.ml156
-rw-r--r--driver/main.mli17
-rw-r--r--driver/main_args.ml156
-rw-r--r--driver/main_args.mli66
-rw-r--r--driver/ocamlcomp.sh.in5
-rw-r--r--driver/optcompile.ml110
-rw-r--r--driver/optcompile.mli24
-rw-r--r--driver/opterrors.ml71
-rw-r--r--driver/opterrors.mli17
-rw-r--r--driver/optmain.ml204
-rw-r--r--driver/optmain.mli17
-rw-r--r--driver/pparse.ml81
-rw-r--r--driver/pparse.mli22
-rw-r--r--emacs/.cvsignore2
-rw-r--r--emacs/Makefile64
-rw-r--r--emacs/README198
-rw-r--r--emacs/README.itz177
-rw-r--r--emacs/caml-compat.el28
-rw-r--r--emacs/caml-emacs.el29
-rw-r--r--emacs/caml-font.el125
-rw-r--r--emacs/caml-help.el815
-rw-r--r--emacs/caml-hilit.el53
-rw-r--r--emacs/caml-types.el572
-rw-r--r--emacs/caml-xemacs.el39
-rw-r--r--emacs/caml.el1894
-rw-r--r--emacs/camldebug.el754
-rw-r--r--emacs/inf-caml.el348
-rw-r--r--emacs/ocamltags.in128
-rw-r--r--lex/.cvsignore6
-rw-r--r--lex/.depend32
-rw-r--r--lex/Makefile71
-rw-r--r--lex/Makefile.Mac63
-rw-r--r--lex/Makefile.Mac.depend17
-rw-r--r--lex/Makefile.nt73
-rw-r--r--lex/common.ml153
-rw-r--r--lex/common.mli25
-rw-r--r--lex/compact.ml234
-rw-r--r--lex/compact.mli33
-rw-r--r--lex/cset.ml94
-rw-r--r--lex/cset.mli32
-rw-r--r--lex/lexer.mli20
-rw-r--r--lex/lexer.mll273
-rw-r--r--lex/lexgen.ml1174
-rw-r--r--lex/lexgen.mli59
-rw-r--r--lex/main.ml102
-rw-r--r--lex/output.ml140
-rw-r--r--lex/output.mli25
-rw-r--r--lex/outputbis.ml193
-rw-r--r--lex/outputbis.mli21
-rw-r--r--lex/parser.mly174
-rw-r--r--lex/syntax.ml44
-rw-r--r--lex/syntax.mli41
-rw-r--r--lex/table.ml56
-rw-r--r--lex/table.mli33
-rw-r--r--maccaml/.cvsignore12
-rw-r--r--maccaml/Makefile.Mac121
-rw-r--r--maccaml/Makefile.Mac.depend2032
-rw-r--r--maccaml/SHORTCUTS9
-rw-r--r--maccaml/WASTE/.cvsignore1
-rw-r--r--maccaml/WASTE/Makefile507
-rw-r--r--maccaml/WASTE/README5
-rw-r--r--maccaml/aboutbox.c125
-rw-r--r--maccaml/appleevents.c147
-rw-r--r--maccaml/appli.r808
-rw-r--r--maccaml/clipboard.c40
-rw-r--r--maccaml/drag.c241
-rw-r--r--maccaml/dummy_fragment.c1
-rw-r--r--maccaml/errors.c114
-rw-r--r--maccaml/events.c319
-rw-r--r--maccaml/files.c427
-rw-r--r--maccaml/glue.c557
-rw-r--r--maccaml/graph.c1179
-rw-r--r--maccaml/lcontrols.c246
-rw-r--r--maccaml/lib.c35
-rw-r--r--maccaml/main.c125
-rw-r--r--maccaml/main.h264
-rw-r--r--maccaml/mcmemory.c31
-rw-r--r--maccaml/mcmisc.c24
-rw-r--r--maccaml/menus.c339
-rw-r--r--maccaml/modalfilter.c83
-rw-r--r--maccaml/ocaml.r479
-rw-r--r--maccaml/ocamlconstants.h187
-rw-r--r--maccaml/ocamlmkappli89
-rw-r--r--maccaml/prefs.c127
-rw-r--r--maccaml/prim_bigarray18
-rw-r--r--maccaml/prim_graph41
-rw-r--r--maccaml/prim_num28
-rw-r--r--maccaml/prim_str8
-rw-r--r--maccaml/print.c131
-rw-r--r--maccaml/scroll.c325
-rw-r--r--maccaml/windows.c852
-rw-r--r--man/Makefile22
-rw-r--r--man/ocaml.help138
-rw-r--r--man/ocaml.m101
-rw-r--r--man/ocamlc.m247
-rw-r--r--man/ocamlcp.m88
-rw-r--r--man/ocamldebug.m37
-rw-r--r--man/ocamldep.m79
-rw-r--r--man/ocamllex.m71
-rw-r--r--man/ocamlmktop.m85
-rw-r--r--man/ocamlopt.m230
-rw-r--r--man/ocamlprof.m57
-rw-r--r--man/ocamlrun.m130
-rw-r--r--man/ocamlyacc.m71
-rw-r--r--ocamldoc/.cvsignore16
-rw-r--r--ocamldoc/.depend222
-rw-r--r--ocamldoc/Changes.txt101
-rw-r--r--ocamldoc/Makefile361
-rw-r--r--ocamldoc/Makefile.nt344
-rw-r--r--ocamldoc/ocamldoc.hva10
-rw-r--r--ocamldoc/ocamldoc.sty60
-rw-r--r--ocamldoc/odoc.ml128
-rw-r--r--ocamldoc/odoc_analyse.ml448
-rw-r--r--ocamldoc/odoc_analyse.mli32
-rw-r--r--ocamldoc/odoc_args.ml306
-rw-r--r--ocamldoc/odoc_args.mli181
-rw-r--r--ocamldoc/odoc_ast.ml1536
-rw-r--r--ocamldoc/odoc_ast.mli104
-rw-r--r--ocamldoc/odoc_class.ml253
-rw-r--r--ocamldoc/odoc_comments.ml315
-rw-r--r--ocamldoc/odoc_comments.mli57
-rw-r--r--ocamldoc/odoc_comments_global.ml48
-rw-r--r--ocamldoc/odoc_comments_global.mli47
-rw-r--r--ocamldoc/odoc_control.ml13
-rw-r--r--ocamldoc/odoc_cross.ml815
-rw-r--r--ocamldoc/odoc_cross.mli17
-rw-r--r--ocamldoc/odoc_dag2html.ml1756
-rw-r--r--ocamldoc/odoc_dag2html.mli31
-rw-r--r--ocamldoc/odoc_dep.ml219
-rw-r--r--ocamldoc/odoc_dot.ml130
-rw-r--r--ocamldoc/odoc_env.ml245
-rw-r--r--ocamldoc/odoc_env.mli76
-rw-r--r--ocamldoc/odoc_exception.ml32
-rw-r--r--ocamldoc/odoc_global.ml22
-rw-r--r--ocamldoc/odoc_global.mli20
-rw-r--r--ocamldoc/odoc_html.ml2018
-rw-r--r--ocamldoc/odoc_info.ml254
-rw-r--r--ocamldoc/odoc_info.mli1032
-rw-r--r--ocamldoc/odoc_inherit.ml13
-rw-r--r--ocamldoc/odoc_latex.ml986
-rw-r--r--ocamldoc/odoc_latex_style.ml76
-rw-r--r--ocamldoc/odoc_lexer.mll411
-rw-r--r--ocamldoc/odoc_man.ml941
-rw-r--r--ocamldoc/odoc_merge.ml953
-rw-r--r--ocamldoc/odoc_merge.mli32
-rw-r--r--ocamldoc/odoc_messages.ml309
-rw-r--r--ocamldoc/odoc_misc.ml454
-rw-r--r--ocamldoc/odoc_misc.mli112
-rw-r--r--ocamldoc/odoc_module.ml510
-rw-r--r--ocamldoc/odoc_name.ml162
-rw-r--r--ocamldoc/odoc_name.mli66
-rw-r--r--ocamldoc/odoc_ocamlhtml.mll544
-rw-r--r--ocamldoc/odoc_opt.ml82
-rw-r--r--ocamldoc/odoc_parameter.ml131
-rw-r--r--ocamldoc/odoc_parser.mly158
-rw-r--r--ocamldoc/odoc_scan.ml156
-rw-r--r--ocamldoc/odoc_search.ml632
-rw-r--r--ocamldoc/odoc_search.mli199
-rw-r--r--ocamldoc/odoc_see_lexer.mll102
-rw-r--r--ocamldoc/odoc_sig.ml1330
-rw-r--r--ocamldoc/odoc_sig.mli176
-rw-r--r--ocamldoc/odoc_str.ml231
-rw-r--r--ocamldoc/odoc_str.mli45
-rw-r--r--ocamldoc/odoc_texi.ml1193
-rw-r--r--ocamldoc/odoc_text.ml144
-rw-r--r--ocamldoc/odoc_text.mli24
-rw-r--r--ocamldoc/odoc_text_lexer.mll730
-rw-r--r--ocamldoc/odoc_text_parser.mly215
-rw-r--r--ocamldoc/odoc_to_text.ml537
-rw-r--r--ocamldoc/odoc_type.ml52
-rw-r--r--ocamldoc/odoc_types.ml130
-rw-r--r--ocamldoc/odoc_types.mli130
-rw-r--r--ocamldoc/odoc_value.ml133
-rwxr-xr-xocamldoc/remove_DEBUG8
-rw-r--r--ocamldoc/runocamldoc12
-rw-r--r--otherlibs/bigarray/.cvsignore3
-rw-r--r--otherlibs/bigarray/.depend17
-rw-r--r--otherlibs/bigarray/Makefile74
-rw-r--r--otherlibs/bigarray/Makefile.Mac53
-rw-r--r--otherlibs/bigarray/Makefile.Mac.depend42
-rw-r--r--otherlibs/bigarray/Makefile.nt84
-rw-r--r--otherlibs/bigarray/bigarray.h81
-rw-r--r--otherlibs/bigarray/bigarray.ml226
-rw-r--r--otherlibs/bigarray/bigarray.mli756
-rw-r--r--otherlibs/bigarray/bigarray_stubs.c1073
-rw-r--r--otherlibs/bigarray/mmap_unix.c117
-rw-r--r--otherlibs/bigarray/mmap_win32.c116
-rw-r--r--otherlibs/db/.depend2
-rw-r--r--otherlibs/dbm/.cvsignore1
-rw-r--r--otherlibs/dbm/.depend2
-rw-r--r--otherlibs/dbm/Makefile73
-rw-r--r--otherlibs/dbm/cldbm.c166
-rw-r--r--otherlibs/dbm/dbm.ml58
-rw-r--r--otherlibs/dbm/dbm.mli80
-rw-r--r--otherlibs/dynlink/.cvsignore1
-rw-r--r--otherlibs/dynlink/.depend10
-rw-r--r--otherlibs/dynlink/Makefile61
-rw-r--r--otherlibs/dynlink/Makefile.Mac56
-rw-r--r--otherlibs/dynlink/Makefile.Mac.depend4
-rw-r--r--otherlibs/dynlink/Makefile.nt62
-rw-r--r--otherlibs/dynlink/dynlink.ml248
-rw-r--r--otherlibs/dynlink/dynlink.mli129
-rw-r--r--otherlibs/dynlink/extract_crc.ml53
-rw-r--r--otherlibs/graph/.cvsignore1
-rw-r--r--otherlibs/graph/.depend48
-rw-r--r--otherlibs/graph/Makefile75
-rw-r--r--otherlibs/graph/Makefile.Mac40
-rw-r--r--otherlibs/graph/Makefile.Mac.depend4
-rw-r--r--otherlibs/graph/color.c230
-rw-r--r--otherlibs/graph/draw.c131
-rw-r--r--otherlibs/graph/dump_img.c55
-rw-r--r--otherlibs/graph/events.c287
-rw-r--r--otherlibs/graph/fill.c88
-rw-r--r--otherlibs/graph/graphics.ml228
-rw-r--r--otherlibs/graph/graphics.mli374
-rw-r--r--otherlibs/graph/graphicsX11.ml42
-rw-r--r--otherlibs/graph/graphicsX11.mli31
-rw-r--r--otherlibs/graph/image.c105
-rw-r--r--otherlibs/graph/image.h29
-rw-r--r--otherlibs/graph/libgraph.h84
-rw-r--r--otherlibs/graph/make_img.c95
-rw-r--r--otherlibs/graph/open.c366
-rw-r--r--otherlibs/graph/point_col.c32
-rw-r--r--otherlibs/graph/sound.c34
-rw-r--r--otherlibs/graph/subwindow.c45
-rw-r--r--otherlibs/graph/text.c84
-rw-r--r--otherlibs/labltk/.cvsignore4
-rw-r--r--otherlibs/labltk/Changes13
-rw-r--r--otherlibs/labltk/Makefile80
-rw-r--r--otherlibs/labltk/Makefile.nt59
-rw-r--r--otherlibs/labltk/README152
-rw-r--r--otherlibs/labltk/Widgets.src2271
-rw-r--r--otherlibs/labltk/browser/.cvsignore2
-rw-r--r--otherlibs/labltk/browser/.depend66
-rw-r--r--otherlibs/labltk/browser/Makefile64
-rw-r--r--otherlibs/labltk/browser/Makefile.nt70
-rw-r--r--otherlibs/labltk/browser/README170
-rw-r--r--otherlibs/labltk/browser/dummyUnix.mli27
-rw-r--r--otherlibs/labltk/browser/dummyWin.mli15
-rw-r--r--otherlibs/labltk/browser/editor.ml671
-rw-r--r--otherlibs/labltk/browser/editor.mli20
-rw-r--r--otherlibs/labltk/browser/fileselect.ml290
-rw-r--r--otherlibs/labltk/browser/fileselect.mli39
-rw-r--r--otherlibs/labltk/browser/help.ml168
-rw-r--r--otherlibs/labltk/browser/help.txt166
-rw-r--r--otherlibs/labltk/browser/jg_bind.ml28
-rw-r--r--otherlibs/labltk/browser/jg_bind.mli21
-rw-r--r--otherlibs/labltk/browser/jg_box.ml82
-rw-r--r--otherlibs/labltk/browser/jg_button.ml25
-rw-r--r--otherlibs/labltk/browser/jg_completion.ml53
-rw-r--r--otherlibs/labltk/browser/jg_completion.mli25
-rw-r--r--otherlibs/labltk/browser/jg_config.ml40
-rw-r--r--otherlibs/labltk/browser/jg_config.mli17
-rw-r--r--otherlibs/labltk/browser/jg_entry.ml27
-rw-r--r--otherlibs/labltk/browser/jg_memo.ml35
-rw-r--r--otherlibs/labltk/browser/jg_memo.mli19
-rw-r--r--otherlibs/labltk/browser/jg_menu.ml42
-rw-r--r--otherlibs/labltk/browser/jg_message.ml111
-rw-r--r--otherlibs/labltk/browser/jg_message.mli33
-rw-r--r--otherlibs/labltk/browser/jg_multibox.ml185
-rw-r--r--otherlibs/labltk/browser/jg_multibox.mli35
-rw-r--r--otherlibs/labltk/browser/jg_text.ml104
-rw-r--r--otherlibs/labltk/browser/jg_text.mli28
-rw-r--r--otherlibs/labltk/browser/jg_tk.ml24
-rw-r--r--otherlibs/labltk/browser/jg_toplevel.ml25
-rw-r--r--otherlibs/labltk/browser/lexical.ml143
-rw-r--r--otherlibs/labltk/browser/lexical.mli20
-rw-r--r--otherlibs/labltk/browser/list2.ml23
-rw-r--r--otherlibs/labltk/browser/main.ml132
-rw-r--r--otherlibs/labltk/browser/mytypes.mli29
-rw-r--r--otherlibs/labltk/browser/searchid.ml532
-rw-r--r--otherlibs/labltk/browser/searchid.mli45
-rw-r--r--otherlibs/labltk/browser/searchpos.ml875
-rw-r--r--otherlibs/labltk/browser/searchpos.mli78
-rw-r--r--otherlibs/labltk/browser/setpath.ml162
-rw-r--r--otherlibs/labltk/browser/setpath.mli25
-rw-r--r--otherlibs/labltk/browser/shell.ml367
-rw-r--r--otherlibs/labltk/browser/shell.mli46
-rw-r--r--otherlibs/labltk/browser/typecheck.ml181
-rw-r--r--otherlibs/labltk/browser/typecheck.mli23
-rw-r--r--otherlibs/labltk/browser/useunix.ml69
-rw-r--r--otherlibs/labltk/browser/useunix.mli23
-rw-r--r--otherlibs/labltk/browser/viewer.ml636
-rw-r--r--otherlibs/labltk/browser/viewer.mli31
-rw-r--r--otherlibs/labltk/browser/winmain.c18
-rw-r--r--otherlibs/labltk/builtin/LICENSE19
-rw-r--r--otherlibs/labltk/builtin/builtin_FilePattern.ml20
-rw-r--r--otherlibs/labltk/builtin/builtin_GetBitmap.ml22
-rw-r--r--otherlibs/labltk/builtin/builtin_GetCursor.ml61
-rw-r--r--otherlibs/labltk/builtin/builtin_GetPixel.ml28
-rw-r--r--otherlibs/labltk/builtin/builtin_ScrollValue.ml22
-rw-r--r--otherlibs/labltk/builtin/builtin_bind.ml469
-rw-r--r--otherlibs/labltk/builtin/builtin_bindtags.ml21
-rw-r--r--otherlibs/labltk/builtin/builtin_font.ml4
-rw-r--r--otherlibs/labltk/builtin/builtin_grab.ml3
-rw-r--r--otherlibs/labltk/builtin/builtin_index.ml92
-rw-r--r--otherlibs/labltk/builtin/builtin_palette.ml20
-rw-r--r--otherlibs/labltk/builtin/builtin_text.ml50
-rw-r--r--otherlibs/labltk/builtin/builtina_empty.ml0
-rw-r--r--otherlibs/labltk/builtin/builtinf_GetPixel.ml23
-rw-r--r--otherlibs/labltk/builtin/builtinf_bind.ml133
-rw-r--r--otherlibs/labltk/builtin/builtini_GetBitmap.ml28
-rw-r--r--otherlibs/labltk/builtin/builtini_GetCursor.ml55
-rw-r--r--otherlibs/labltk/builtin/builtini_GetPixel.ml43
-rw-r--r--otherlibs/labltk/builtin/builtini_ScrollValue.ml45
-rw-r--r--otherlibs/labltk/builtin/builtini_bind.ml136
-rw-r--r--otherlibs/labltk/builtin/builtini_bindtags.ml29
-rw-r--r--otherlibs/labltk/builtin/builtini_font.ml3
-rw-r--r--otherlibs/labltk/builtin/builtini_grab.ml2
-rw-r--r--otherlibs/labltk/builtin/builtini_index.ml140
-rw-r--r--otherlibs/labltk/builtin/builtini_palette.ml19
-rw-r--r--otherlibs/labltk/builtin/builtini_text.ml64
-rw-r--r--otherlibs/labltk/builtin/canvas_bind.ml52
-rw-r--r--otherlibs/labltk/builtin/canvas_bind.mli16
-rw-r--r--otherlibs/labltk/builtin/dialog.ml45
-rw-r--r--otherlibs/labltk/builtin/dialog.mli24
-rw-r--r--otherlibs/labltk/builtin/image.ml33
-rw-r--r--otherlibs/labltk/builtin/image.mli9
-rw-r--r--otherlibs/labltk/builtin/optionmenu.ml54
-rw-r--r--otherlibs/labltk/builtin/optionmenu.mli21
-rw-r--r--otherlibs/labltk/builtin/rawimg.ml142
-rw-r--r--otherlibs/labltk/builtin/rawimg.mli44
-rw-r--r--otherlibs/labltk/builtin/report.ml17
-rw-r--r--otherlibs/labltk/builtin/selection_handle_set.ml41
-rw-r--r--otherlibs/labltk/builtin/selection_handle_set.mli13
-rw-r--r--otherlibs/labltk/builtin/selection_own_set.ml29
-rw-r--r--otherlibs/labltk/builtin/selection_own_set.mli12
-rw-r--r--otherlibs/labltk/builtin/text_tag_bind.ml55
-rw-r--r--otherlibs/labltk/builtin/text_tag_bind.mli13
-rw-r--r--otherlibs/labltk/builtin/winfo_contained.ml13
-rw-r--r--otherlibs/labltk/builtin/winfo_contained.mli11
-rw-r--r--otherlibs/labltk/camltk/.cvsignore3
-rw-r--r--otherlibs/labltk/camltk/Makefile45
-rw-r--r--otherlibs/labltk/camltk/Makefile.gen46
-rw-r--r--otherlibs/labltk/camltk/Makefile.gen.nt46
-rw-r--r--otherlibs/labltk/camltk/Makefile.nt43
-rw-r--r--otherlibs/labltk/camltk/modules80
-rw-r--r--otherlibs/labltk/compiler/.cvsignore11
-rw-r--r--otherlibs/labltk/compiler/.depend28
-rw-r--r--otherlibs/labltk/compiler/Makefile63
-rw-r--r--otherlibs/labltk/compiler/Makefile.nt63
-rw-r--r--otherlibs/labltk/compiler/code.mli22
-rw-r--r--otherlibs/labltk/compiler/compile.ml1074
-rw-r--r--otherlibs/labltk/compiler/copyright15
-rw-r--r--otherlibs/labltk/compiler/flags.ml17
-rw-r--r--otherlibs/labltk/compiler/intf.ml191
-rw-r--r--otherlibs/labltk/compiler/lexer.mll170
-rw-r--r--otherlibs/labltk/compiler/maincompile.ml418
-rw-r--r--otherlibs/labltk/compiler/parser.mly330
-rw-r--r--otherlibs/labltk/compiler/pp.ml23
-rw-r--r--otherlibs/labltk/compiler/ppexec.ml60
-rw-r--r--otherlibs/labltk/compiler/pplex.mli18
-rw-r--r--otherlibs/labltk/compiler/pplex.mll57
-rw-r--r--otherlibs/labltk/compiler/ppparse.ml36
-rw-r--r--otherlibs/labltk/compiler/ppyac.mly52
-rw-r--r--otherlibs/labltk/compiler/printer.ml173
-rw-r--r--otherlibs/labltk/compiler/tables.ml427
-rw-r--r--otherlibs/labltk/compiler/tsort.ml89
-rw-r--r--[-rwxr-xr-x]otherlibs/labltk/example/.gitignore (renamed from camlp4/ocaml_src/tools/extract_crc.sh)0
-rw-r--r--otherlibs/labltk/examples_camltk/.cvsignore8
-rw-r--r--otherlibs/labltk/examples_camltk/Makefile52
-rw-r--r--otherlibs/labltk/examples_camltk/Makefile.nt38
-rw-r--r--otherlibs/labltk/examples_camltk/addition.ml53
-rw-r--r--otherlibs/labltk/examples_camltk/eyes.ml67
-rw-r--r--otherlibs/labltk/examples_camltk/fileinput.ml35
-rw-r--r--otherlibs/labltk/examples_camltk/fileopen.ml56
-rw-r--r--otherlibs/labltk/examples_camltk/helloworld.ml37
-rw-r--r--otherlibs/labltk/examples_camltk/images/CamlBook.gifbin15167 -> 0 bytes
-rw-r--r--otherlibs/labltk/examples_camltk/images/Lambda2.back.gifbin53441 -> 0 bytes
-rw-r--r--otherlibs/labltk/examples_camltk/images/dojoji.back.gifbin49934 -> 0 bytes
-rw-r--r--otherlibs/labltk/examples_camltk/jptest.ml23
-rw-r--r--otherlibs/labltk/examples_camltk/mytext.ml63
-rw-r--r--otherlibs/labltk/examples_camltk/socketinput.ml43
-rw-r--r--otherlibs/labltk/examples_camltk/taddition.ml53
-rw-r--r--otherlibs/labltk/examples_camltk/tetris.ml685
-rw-r--r--otherlibs/labltk/examples_camltk/text.ml55
-rw-r--r--otherlibs/labltk/examples_camltk/winskel.ml63
-rw-r--r--otherlibs/labltk/examples_labltk/.cvsignore8
-rw-r--r--otherlibs/labltk/examples_labltk/Lambda2.back.gifbin53441 -> 0 bytes
-rw-r--r--otherlibs/labltk/examples_labltk/Makefile53
-rw-r--r--otherlibs/labltk/examples_labltk/Makefile.nt50
-rw-r--r--otherlibs/labltk/examples_labltk/README20
-rw-r--r--otherlibs/labltk/examples_labltk/calc.ml129
-rw-r--r--otherlibs/labltk/examples_labltk/clock.ml133
-rw-r--r--otherlibs/labltk/examples_labltk/demo.ml167
-rw-r--r--otherlibs/labltk/examples_labltk/eyes.ml65
-rw-r--r--otherlibs/labltk/examples_labltk/hello.ml38
-rwxr-xr-xotherlibs/labltk/examples_labltk/hello.tcl5
-rw-r--r--otherlibs/labltk/examples_labltk/lang.ml75
-rw-r--r--otherlibs/labltk/examples_labltk/taquin.ml143
-rw-r--r--otherlibs/labltk/examples_labltk/tetris.ml710
-rw-r--r--otherlibs/labltk/frx/.depend38
-rw-r--r--otherlibs/labltk/frx/Makefile51
-rw-r--r--otherlibs/labltk/frx/Makefile.nt53
-rw-r--r--otherlibs/labltk/frx/README2
-rw-r--r--otherlibs/labltk/frx/frx_after.ml24
-rw-r--r--otherlibs/labltk/frx/frx_after.mli17
-rw-r--r--otherlibs/labltk/frx/frx_color.ml35
-rw-r--r--otherlibs/labltk/frx/frx_color.mli16
-rw-r--r--otherlibs/labltk/frx/frx_ctext.ml66
-rw-r--r--otherlibs/labltk/frx/frx_ctext.mli25
-rw-r--r--otherlibs/labltk/frx/frx_dialog.ml115
-rw-r--r--otherlibs/labltk/frx/frx_dialog.mli22
-rw-r--r--otherlibs/labltk/frx/frx_entry.ml42
-rw-r--r--otherlibs/labltk/frx/frx_entry.mli31
-rw-r--r--otherlibs/labltk/frx/frx_fileinput.ml40
-rw-r--r--otherlibs/labltk/frx/frx_fillbox.ml65
-rw-r--r--otherlibs/labltk/frx/frx_fillbox.mli31
-rw-r--r--otherlibs/labltk/frx/frx_fit.ml83
-rw-r--r--otherlibs/labltk/frx/frx_fit.mli29
-rw-r--r--otherlibs/labltk/frx/frx_focus.ml26
-rw-r--r--otherlibs/labltk/frx/frx_focus.mli18
-rw-r--r--otherlibs/labltk/frx/frx_font.ml51
-rw-r--r--otherlibs/labltk/frx/frx_font.mli20
-rw-r--r--otherlibs/labltk/frx/frx_group.ml22
-rw-r--r--otherlibs/labltk/frx/frx_lbutton.ml50
-rw-r--r--otherlibs/labltk/frx/frx_lbutton.mli24
-rw-r--r--otherlibs/labltk/frx/frx_listbox.ml92
-rw-r--r--otherlibs/labltk/frx/frx_listbox.mli32
-rw-r--r--otherlibs/labltk/frx/frx_mem.ml89
-rw-r--r--otherlibs/labltk/frx/frx_mem.mli22
-rw-r--r--otherlibs/labltk/frx/frx_misc.ml69
-rw-r--r--otherlibs/labltk/frx/frx_misc.mli21
-rw-r--r--otherlibs/labltk/frx/frx_req.ml198
-rw-r--r--otherlibs/labltk/frx/frx_req.mli43
-rw-r--r--otherlibs/labltk/frx/frx_rpc.ml55
-rw-r--r--otherlibs/labltk/frx/frx_rpc.mli25
-rw-r--r--otherlibs/labltk/frx/frx_selection.ml45
-rw-r--r--otherlibs/labltk/frx/frx_selection.mli17
-rw-r--r--otherlibs/labltk/frx/frx_synth.ml88
-rw-r--r--otherlibs/labltk/frx/frx_synth.mli31
-rw-r--r--otherlibs/labltk/frx/frx_text.ml229
-rw-r--r--otherlibs/labltk/frx/frx_text.mli46
-rw-r--r--otherlibs/labltk/frx/frx_toplevel.mli17
-rw-r--r--otherlibs/labltk/frx/frx_widget.ml24
-rw-r--r--otherlibs/labltk/frx/frx_widget.mli18
-rw-r--r--otherlibs/labltk/jpf/Makefile77
-rw-r--r--otherlibs/labltk/jpf/Makefile.nt75
-rw-r--r--otherlibs/labltk/jpf/README2
-rw-r--r--otherlibs/labltk/jpf/balloon.ml102
-rw-r--r--otherlibs/labltk/jpf/balloon.mli24
-rw-r--r--otherlibs/labltk/jpf/balloontest.ml32
-rw-r--r--otherlibs/labltk/jpf/fileselect.ml368
-rw-r--r--otherlibs/labltk/jpf/fileselect.mli37
-rw-r--r--otherlibs/labltk/jpf/jpf_font.ml218
-rw-r--r--otherlibs/labltk/jpf/jpf_font.mli54
-rw-r--r--otherlibs/labltk/jpf/shell.ml36
-rw-r--r--otherlibs/labltk/jpf/shell.mli17
-rw-r--r--otherlibs/labltk/labl.gifbin1533 -> 0 bytes
-rw-r--r--otherlibs/labltk/labltk/.cvsignore3
-rw-r--r--otherlibs/labltk/labltk/Makefile43
-rw-r--r--otherlibs/labltk/labltk/Makefile.gen45
-rw-r--r--otherlibs/labltk/labltk/Makefile.gen.nt40
-rw-r--r--otherlibs/labltk/labltk/Makefile.nt43
-rw-r--r--otherlibs/labltk/labltk/modules77
-rw-r--r--otherlibs/labltk/lib/.cvsignore8
-rw-r--r--otherlibs/labltk/lib/Makefile74
-rw-r--r--otherlibs/labltk/lib/Makefile.nt60
-rw-r--r--otherlibs/labltk/support/.depend24
-rw-r--r--otherlibs/labltk/support/Makefile59
-rw-r--r--otherlibs/labltk/support/Makefile.common26
-rw-r--r--otherlibs/labltk/support/Makefile.common.nt29
-rw-r--r--otherlibs/labltk/support/Makefile.nt69
-rw-r--r--otherlibs/labltk/support/camltk.h56
-rw-r--r--otherlibs/labltk/support/camltkwrap.ml77
-rw-r--r--otherlibs/labltk/support/camltkwrap.mli251
-rw-r--r--otherlibs/labltk/support/cltkCaml.c83
-rw-r--r--otherlibs/labltk/support/cltkDMain.c247
-rw-r--r--otherlibs/labltk/support/cltkEval.c245
-rw-r--r--otherlibs/labltk/support/cltkEvent.c55
-rw-r--r--otherlibs/labltk/support/cltkFile.c158
-rw-r--r--otherlibs/labltk/support/cltkImg.c115
-rw-r--r--otherlibs/labltk/support/cltkMain.c181
-rw-r--r--otherlibs/labltk/support/cltkMisc.c64
-rw-r--r--otherlibs/labltk/support/cltkTimer.c45
-rw-r--r--otherlibs/labltk/support/cltkUtf.c89
-rw-r--r--otherlibs/labltk/support/cltkVar.c128
-rw-r--r--otherlibs/labltk/support/cltkWait.c102
-rw-r--r--otherlibs/labltk/support/fileevent.ml81
-rw-r--r--otherlibs/labltk/support/fileevent.mli25
-rw-r--r--otherlibs/labltk/support/protocol.ml276
-rw-r--r--otherlibs/labltk/support/protocol.mli115
-rw-r--r--otherlibs/labltk/support/rawwidget.ml176
-rw-r--r--otherlibs/labltk/support/rawwidget.mli109
-rw-r--r--otherlibs/labltk/support/slave.ml51
-rw-r--r--otherlibs/labltk/support/support.ml48
-rw-r--r--otherlibs/labltk/support/support.mli21
-rw-r--r--otherlibs/labltk/support/textvariable.ml152
-rw-r--r--otherlibs/labltk/support/textvariable.mli45
-rw-r--r--otherlibs/labltk/support/timer.ml58
-rw-r--r--otherlibs/labltk/support/timer.mli23
-rw-r--r--otherlibs/labltk/support/tkwait.ml22
-rw-r--r--otherlibs/labltk/support/widget.ml23
-rw-r--r--otherlibs/labltk/support/widget.mli109
-rw-r--r--otherlibs/labltk/tkanim/.cvsignore2
-rw-r--r--otherlibs/labltk/tkanim/.depend2
-rw-r--r--otherlibs/labltk/tkanim/Makefile70
-rw-r--r--otherlibs/labltk/tkanim/Makefile.nt78
-rw-r--r--otherlibs/labltk/tkanim/README5
-rw-r--r--otherlibs/labltk/tkanim/cltkaniminit.c28
-rw-r--r--otherlibs/labltk/tkanim/gifanimtest.ml71
-rw-r--r--otherlibs/labltk/tkanim/mmm.anim.gifbin18501 -> 0 bytes
-rw-r--r--otherlibs/labltk/tkanim/tkAnimGIF.c911
-rw-r--r--otherlibs/labltk/tkanim/tkAppInit.c141
-rw-r--r--otherlibs/labltk/tkanim/tkanim.ml230
-rw-r--r--otherlibs/labltk/tkanim/tkanim.mli95
-rw-r--r--otherlibs/macosunix/.cvsignore71
-rw-r--r--otherlibs/macosunix/Makefile.Mac152
-rw-r--r--otherlibs/macosunix/Makefile.Mac.depend872
-rw-r--r--otherlibs/macosunix/macosunix.c119
-rw-r--r--otherlibs/macosunix/macosunix_startup.ml17
-rw-r--r--otherlibs/macosunix/macosunix_startup.mli16
-rw-r--r--otherlibs/macosunix/unix-primitives113
-rw-r--r--otherlibs/macosunix/unixsupport.h43
-rw-r--r--otherlibs/num/.cvsignore3
-rw-r--r--otherlibs/num/.depend35
-rw-r--r--otherlibs/num/.depend.nt56
-rw-r--r--otherlibs/num/Makefile86
-rw-r--r--otherlibs/num/Makefile.Mac64
-rw-r--r--otherlibs/num/Makefile.Mac.depend33
-rw-r--r--otherlibs/num/Makefile.nt97
-rw-r--r--otherlibs/num/README55
-rw-r--r--otherlibs/num/arith_flags.ml25
-rw-r--r--otherlibs/num/arith_flags.mli20
-rw-r--r--otherlibs/num/arith_status.ml100
-rw-r--r--otherlibs/num/arith_status.mli60
-rw-r--r--otherlibs/num/big_int.ml603
-rw-r--r--otherlibs/num/big_int.mli143
-rw-r--r--otherlibs/num/bignum/.cvsignore1
-rw-r--r--otherlibs/num/bng.c434
-rw-r--r--otherlibs/num/bng.h156
-rw-r--r--otherlibs/num/bng_alpha.c23
-rw-r--r--otherlibs/num/bng_amd64.c196
-rw-r--r--otherlibs/num/bng_digit.c171
-rw-r--r--otherlibs/num/bng_ia32.c412
-rw-r--r--otherlibs/num/bng_mips.c24
-rw-r--r--otherlibs/num/bng_ppc.c86
-rw-r--r--otherlibs/num/bng_sparc.c77
-rw-r--r--otherlibs/num/int_misc.ml36
-rw-r--r--otherlibs/num/int_misc.mli25
-rw-r--r--otherlibs/num/nat.h19
-rw-r--r--otherlibs/num/nat.ml570
-rw-r--r--otherlibs/num/nat.mli71
-rw-r--r--otherlibs/num/nat_stubs.c369
-rw-r--r--otherlibs/num/num.ml396
-rw-r--r--otherlibs/num/num.mli171
-rw-r--r--otherlibs/num/ratio.ml577
-rw-r--r--otherlibs/num/ratio.mli88
-rw-r--r--otherlibs/num/string_misc.ml20
-rw-r--r--otherlibs/num/string_misc.mli16
-rw-r--r--otherlibs/num/test/.depend10
-rw-r--r--otherlibs/num/test/Makefile61
-rw-r--r--otherlibs/num/test/Makefile.Mac40
-rw-r--r--otherlibs/num/test/Makefile.Mac.depend10
-rw-r--r--otherlibs/num/test/Makefile.nt59
-rw-r--r--otherlibs/num/test/end_test.ml1
-rw-r--r--otherlibs/num/test/test.ml77
-rw-r--r--otherlibs/num/test/test_big_ints.ml468
-rw-r--r--otherlibs/num/test/test_bng.c408
-rw-r--r--otherlibs/num/test/test_io.ml64
-rw-r--r--otherlibs/num/test/test_nats.ml142
-rw-r--r--otherlibs/num/test/test_nums.ml220
-rw-r--r--otherlibs/num/test/test_ratios.ml928
-rw-r--r--otherlibs/str/.cvsignore3
-rw-r--r--otherlibs/str/.depend7
-rw-r--r--otherlibs/str/Makefile75
-rw-r--r--otherlibs/str/Makefile.Mac53
-rw-r--r--otherlibs/str/Makefile.Mac.depend16
-rw-r--r--otherlibs/str/Makefile.nt83
-rw-r--r--otherlibs/str/str.ml716
-rw-r--r--otherlibs/str/str.mli239
-rw-r--r--otherlibs/str/strstubs.c527
-rw-r--r--otherlibs/systhreads/.cvsignore3
-rw-r--r--otherlibs/systhreads/.depend27
-rw-r--r--otherlibs/systhreads/Makefile102
-rw-r--r--otherlibs/systhreads/Makefile.Mac78
-rw-r--r--otherlibs/systhreads/Makefile.Mac.depend131
-rw-r--r--otherlibs/systhreads/Makefile.nt96
-rw-r--r--otherlibs/systhreads/Tests/Makefile44
-rw-r--r--otherlibs/systhreads/Tests/Makefile.nt43
-rw-r--r--otherlibs/systhreads/condition.ml20
-rw-r--r--otherlibs/systhreads/condition.mli53
-rw-r--r--otherlibs/systhreads/event.ml274
-rw-r--r--otherlibs/systhreads/event.mli82
-rw-r--r--otherlibs/systhreads/mutex.ml20
-rw-r--r--otherlibs/systhreads/mutex.mli50
-rw-r--r--otherlibs/systhreads/posix.c820
-rw-r--r--otherlibs/systhreads/thread.mli111
-rw-r--r--otherlibs/systhreads/threadUnix.ml59
-rw-r--r--otherlibs/systhreads/threadUnix.mli85
-rw-r--r--otherlibs/systhreads/thread_posix.ml73
-rw-r--r--otherlibs/systhreads/thread_win32.ml75
-rw-r--r--otherlibs/systhreads/win32.c719
-rw-r--r--otherlibs/threads/.cvsignore3
-rw-r--r--otherlibs/threads/.depend27
-rw-r--r--otherlibs/threads/Makefile126
-rw-r--r--otherlibs/threads/Tests/.cvsignore1
-rw-r--r--otherlibs/threads/Tests/Makefile38
-rw-r--r--otherlibs/threads/Tests/close.ml14
-rw-r--r--otherlibs/threads/Tests/sieve.ml33
-rw-r--r--otherlibs/threads/Tests/sorts.ml228
-rw-r--r--otherlibs/threads/Tests/test1.ml57
-rw-r--r--otherlibs/threads/Tests/test2.ml15
-rw-r--r--otherlibs/threads/Tests/test3.ml8
-rw-r--r--otherlibs/threads/Tests/test4.ml13
-rw-r--r--otherlibs/threads/Tests/test5.ml21
-rw-r--r--otherlibs/threads/Tests/test6.ml17
-rw-r--r--otherlibs/threads/Tests/test7.ml28
-rw-r--r--otherlibs/threads/Tests/test8.ml46
-rw-r--r--otherlibs/threads/Tests/test9.ml26
-rw-r--r--otherlibs/threads/Tests/testA.ml24
-rw-r--r--otherlibs/threads/Tests/testexit.ml22
-rw-r--r--otherlibs/threads/Tests/testio.ml119
-rw-r--r--otherlibs/threads/Tests/testsieve.ml42
-rw-r--r--otherlibs/threads/Tests/testsignal.ml13
-rw-r--r--otherlibs/threads/Tests/testsignal2.ml10
-rw-r--r--otherlibs/threads/Tests/testsocket.ml31
-rw-r--r--otherlibs/threads/Tests/token1.ml36
-rw-r--r--otherlibs/threads/Tests/token2.ml36
-rw-r--r--otherlibs/threads/Tests/torture.ml46
-rw-r--r--otherlibs/threads/condition.ml36
-rw-r--r--otherlibs/threads/condition.mli53
-rw-r--r--otherlibs/threads/event.ml274
-rw-r--r--otherlibs/threads/event.mli82
-rw-r--r--otherlibs/threads/marshal.ml57
-rw-r--r--otherlibs/threads/mutex.ml39
-rw-r--r--otherlibs/threads/mutex.mli50
-rw-r--r--otherlibs/threads/pervasives.ml528
-rw-r--r--otherlibs/threads/scheduler.c876
-rw-r--r--otherlibs/threads/thread.ml141
-rw-r--r--otherlibs/threads/thread.mli141
-rw-r--r--otherlibs/threads/threadUnix.ml60
-rw-r--r--otherlibs/threads/threadUnix.mli89
-rw-r--r--otherlibs/threads/unix.ml929
-rw-r--r--otherlibs/unix/.cvsignore1
-rw-r--r--otherlibs/unix/.depend283
-rw-r--r--otherlibs/unix/Makefile92
-rw-r--r--otherlibs/unix/accept.c52
-rw-r--r--otherlibs/unix/access.c51
-rw-r--r--otherlibs/unix/addrofstr.c44
-rw-r--r--otherlibs/unix/alarm.c23
-rw-r--r--otherlibs/unix/bind.c40
-rw-r--r--otherlibs/unix/chdir.c25
-rw-r--r--otherlibs/unix/chmod.c27
-rw-r--r--otherlibs/unix/chown.c25
-rw-r--r--otherlibs/unix/chroot.c25
-rw-r--r--otherlibs/unix/close.c23
-rw-r--r--otherlibs/unix/closedir.c29
-rw-r--r--otherlibs/unix/connect.c43
-rw-r--r--otherlibs/unix/cst2constr.c26
-rw-r--r--otherlibs/unix/cst2constr.h20
-rw-r--r--otherlibs/unix/cstringv.c32
-rw-r--r--otherlibs/unix/dup.c25
-rw-r--r--otherlibs/unix/dup2.c49
-rw-r--r--otherlibs/unix/envir.c26
-rw-r--r--otherlibs/unix/errmsg.c49
-rw-r--r--otherlibs/unix/execv.c32
-rw-r--r--otherlibs/unix/execve.c35
-rw-r--r--otherlibs/unix/execvp.c51
-rw-r--r--otherlibs/unix/exit.c26
-rw-r--r--otherlibs/unix/fchmod.c34
-rw-r--r--otherlibs/unix/fchown.c33
-rw-r--r--otherlibs/unix/fcntl.c77
-rw-r--r--otherlibs/unix/fork.c26
-rw-r--r--otherlibs/unix/ftruncate.c45
-rw-r--r--otherlibs/unix/getcwd.c57
-rw-r--r--otherlibs/unix/getegid.c22
-rw-r--r--otherlibs/unix/geteuid.c22
-rw-r--r--otherlibs/unix/getgid.c22
-rw-r--r--otherlibs/unix/getgr.c56
-rw-r--r--otherlibs/unix/getgroups.c48
-rw-r--r--otherlibs/unix/gethost.c167
-rw-r--r--otherlibs/unix/gethostname.c57
-rw-r--r--otherlibs/unix/getlogin.c29
-rw-r--r--otherlibs/unix/getpeername.c40
-rw-r--r--otherlibs/unix/getpid.c22
-rw-r--r--otherlibs/unix/getppid.c22
-rw-r--r--otherlibs/unix/getproto.c70
-rw-r--r--otherlibs/unix/getpw.c65
-rw-r--r--otherlibs/unix/getserv.c76
-rw-r--r--otherlibs/unix/getsockname.c40
-rw-r--r--otherlibs/unix/gettimeofday.c37
-rw-r--r--otherlibs/unix/getuid.c22
-rw-r--r--otherlibs/unix/gmtime.c93
-rw-r--r--otherlibs/unix/itimer.c74
-rw-r--r--otherlibs/unix/kill.c29
-rw-r--r--otherlibs/unix/link.c23
-rw-r--r--otherlibs/unix/listen.c34
-rw-r--r--otherlibs/unix/lockf.c110
-rw-r--r--otherlibs/unix/lseek.c57
-rw-r--r--otherlibs/unix/mkdir.c25
-rw-r--r--otherlibs/unix/mkfifo.c49
-rw-r--r--otherlibs/unix/nice.c50
-rw-r--r--otherlibs/unix/open.c57
-rw-r--r--otherlibs/unix/opendir.c31
-rw-r--r--otherlibs/unix/pipe.c29
-rw-r--r--otherlibs/unix/putenv.c45
-rw-r--r--otherlibs/unix/read.c38
-rw-r--r--otherlibs/unix/readdir.c36
-rw-r--r--otherlibs/unix/readlink.c47
-rw-r--r--otherlibs/unix/rename.c25
-rw-r--r--otherlibs/unix/rewinddir.c38
-rw-r--r--otherlibs/unix/rmdir.c23
-rw-r--r--otherlibs/unix/select.c109
-rw-r--r--otherlibs/unix/sendrecv.c139
-rw-r--r--otherlibs/unix/setgid.c23
-rw-r--r--otherlibs/unix/setsid.c30
-rw-r--r--otherlibs/unix/setuid.c23
-rw-r--r--otherlibs/unix/shutdown.c39
-rw-r--r--otherlibs/unix/signals.c105
-rw-r--r--otherlibs/unix/sleep.c26
-rw-r--r--otherlibs/unix/socket.c48
-rw-r--r--otherlibs/unix/socketaddr.c110
-rw-r--r--otherlibs/unix/socketaddr.h44
-rw-r--r--otherlibs/unix/socketpair.c45
-rw-r--r--otherlibs/unix/sockopt.c236
-rw-r--r--otherlibs/unix/stat.c140
-rw-r--r--otherlibs/unix/strofaddr.c36
-rw-r--r--otherlibs/unix/symlink.c33
-rw-r--r--otherlibs/unix/termios.c316
-rw-r--r--otherlibs/unix/time.c24
-rw-r--r--otherlibs/unix/times.c44
-rw-r--r--otherlibs/unix/truncate.c45
-rw-r--r--otherlibs/unix/umask.c24
-rw-r--r--otherlibs/unix/unix.ml776
-rw-r--r--otherlibs/unix/unix.mli1206
-rw-r--r--otherlibs/unix/unixLabels.ml18
-rw-r--r--otherlibs/unix/unixLabels.mli1242
-rw-r--r--otherlibs/unix/unixsupport.c285
-rw-r--r--otherlibs/unix/unixsupport.h25
-rw-r--r--otherlibs/unix/unlink.c23
-rw-r--r--otherlibs/unix/utimes.c71
-rw-r--r--otherlibs/unix/wait.c101
-rw-r--r--otherlibs/unix/write.c56
-rw-r--r--otherlibs/win32graph/Makefile.nt94
-rw-r--r--otherlibs/win32graph/dib.c496
-rw-r--r--otherlibs/win32graph/draw.c784
-rw-r--r--otherlibs/win32graph/libgraph.h86
-rw-r--r--otherlibs/win32graph/open.c400
-rw-r--r--otherlibs/win32unix/.cvsignore3
-rw-r--r--otherlibs/win32unix/.depend5
-rw-r--r--otherlibs/win32unix/Makefile.nt120
-rw-r--r--otherlibs/win32unix/accept.c67
-rw-r--r--otherlibs/win32unix/bind.c34
-rw-r--r--otherlibs/win32unix/channels.c43
-rw-r--r--otherlibs/win32unix/close.c33
-rw-r--r--otherlibs/win32unix/close_on.c46
-rw-r--r--otherlibs/win32unix/connect.c38
-rw-r--r--otherlibs/win32unix/createprocess.c87
-rw-r--r--otherlibs/win32unix/dup.c34
-rw-r--r--otherlibs/win32unix/dup2.c43
-rw-r--r--otherlibs/win32unix/errmsg.c44
-rw-r--r--otherlibs/win32unix/getpeername.c35
-rw-r--r--otherlibs/win32unix/getpid.c24
-rw-r--r--otherlibs/win32unix/getsockname.c32
-rw-r--r--otherlibs/win32unix/gettimeofday.c35
-rw-r--r--otherlibs/win32unix/link.c42
-rw-r--r--otherlibs/win32unix/listen.c27
-rw-r--r--otherlibs/win32unix/lockf.c206
-rw-r--r--otherlibs/win32unix/lseek.c76
-rw-r--r--otherlibs/win32unix/mkdir.c24
-rwxr-xr-xotherlibs/win32unix/nonblock.c42
-rw-r--r--otherlibs/win32unix/open.c66
-rw-r--r--otherlibs/win32unix/pipe.c45
-rw-r--r--otherlibs/win32unix/read.c55
-rw-r--r--otherlibs/win32unix/rename.c29
-rw-r--r--otherlibs/win32unix/select.c99
-rw-r--r--otherlibs/win32unix/sendrecv.c133
-rw-r--r--otherlibs/win32unix/shutdown.c32
-rw-r--r--otherlibs/win32unix/sleep.c27
-rw-r--r--otherlibs/win32unix/socket.c55
-rw-r--r--otherlibs/win32unix/socketaddr.h38
-rw-r--r--otherlibs/win32unix/sockopt.c157
-rw-r--r--otherlibs/win32unix/startup.c43
-rw-r--r--otherlibs/win32unix/stat.c93
-rw-r--r--otherlibs/win32unix/system.c41
-rw-r--r--otherlibs/win32unix/unix.ml797
-rw-r--r--otherlibs/win32unix/unixsupport.c259
-rw-r--r--otherlibs/win32unix/unixsupport.h54
-rw-r--r--otherlibs/win32unix/windir.c80
-rw-r--r--otherlibs/win32unix/winwait.c62
-rw-r--r--otherlibs/win32unix/write.c64
-rw-r--r--parsing/.cvsignore7
-rw-r--r--parsing/asttypes.mli36
-rw-r--r--parsing/lexer.mli36
-rw-r--r--parsing/lexer.mll514
-rw-r--r--parsing/linenum.mli23
-rw-r--r--parsing/linenum.mll74
-rw-r--r--parsing/location.ml239
-rw-r--r--parsing/location.mli54
-rw-r--r--parsing/longident.ml38
-rw-r--r--parsing/longident.mli23
-rw-r--r--parsing/parse.ml64
-rw-r--r--parsing/parse.mli21
-rw-r--r--parsing/parser.mly1505
-rw-r--r--parsing/parsetree.mli272
-rw-r--r--parsing/printast.ml684
-rw-r--r--parsing/printast.mli20
-rw-r--r--parsing/syntaxerr.ml41
-rw-r--r--parsing/syntaxerr.mli26
-rw-r--r--test/.cvsignore2
-rw-r--r--test/.depend28
-rw-r--r--test/KB/equations.ml115
-rw-r--r--test/KB/equations.mli32
-rw-r--r--test/KB/kb.ml188
-rw-r--r--test/KB/kb.mli29
-rw-r--r--test/KB/kbmain.ml81
-rw-r--r--test/KB/orderings.ml99
-rw-r--r--test/KB/orderings.mli31
-rw-r--r--test/KB/terms.ml137
-rw-r--r--test/KB/terms.mli31
-rw-r--r--test/Lex/.cvsignore5
-rw-r--r--test/Lex/gram_aux.ml47
-rw-r--r--test/Lex/grammar.mly114
-rw-r--r--test/Lex/lexgen.ml266
-rw-r--r--test/Lex/main.ml118
-rw-r--r--test/Lex/output.ml169
-rw-r--r--test/Lex/scan_aux.ml60
-rw-r--r--test/Lex/scanner.mll132
-rw-r--r--test/Lex/syntax.ml40
-rw-r--r--test/Lex/testmain.ml48
-rw-r--r--test/Lex/testscanner.mll135
-rw-r--r--test/Makefile195
-rw-r--r--test/Makefile.Mac125
-rw-r--r--test/Makefile.Mac.depend28
-rw-r--r--test/Moretest/.cvsignore2
-rw-r--r--test/Moretest/.depend6
-rw-r--r--test/Moretest/Makefile177
-rw-r--r--test/Moretest/Makefile.Mac76
-rw-r--r--test/Moretest/Makefile.Mac.depend4
-rw-r--r--test/Moretest/arrays.ml86
-rw-r--r--test/Moretest/bigarrays.ml720
-rw-r--r--test/Moretest/bigarrf.f26
-rw-r--r--test/Moretest/bigarrfml.ml63
-rw-r--r--test/Moretest/bigarrfstub.c60
-rw-r--r--test/Moretest/bigints.ml12
-rw-r--r--test/Moretest/bounds.ml28
-rw-r--r--test/Moretest/boxedints.ml569
-rw-r--r--test/Moretest/callbackprim.c54
-rw-r--r--test/Moretest/cmcaml.ml17
-rw-r--r--test/Moretest/cmmain.c21
-rw-r--r--test/Moretest/cmstub.c17
-rw-r--r--test/Moretest/equality.ml71
-rw-r--r--test/Moretest/fftba.ml191
-rw-r--r--test/Moretest/float.ml1
-rw-r--r--test/Moretest/globroots.ml25
-rw-r--r--test/Moretest/globrootsprim.c29
-rw-r--r--test/Moretest/graph_example.ml131
-rw-r--r--test/Moretest/graph_test.ml288
-rw-r--r--test/Moretest/includestruct.ml92
-rw-r--r--test/Moretest/intext.ml452
-rw-r--r--test/Moretest/intextaux.c13
-rw-r--r--test/Moretest/io.ml101
-rw-r--r--test/Moretest/manyargs.ml18
-rw-r--r--test/Moretest/manyargsprim.c24
-rw-r--r--test/Moretest/md5.ml219
-rw-r--r--test/Moretest/morematch.ml1107
-rw-r--r--test/Moretest/multdef.ml2
-rw-r--r--test/Moretest/multdef.mli3
-rw-r--r--test/Moretest/patmatch.ml78
-rw-r--r--test/Moretest/recvalues.ml38
-rw-r--r--test/Moretest/regexp.ml975
-rw-r--r--test/Moretest/sets.ml39
-rw-r--r--test/Moretest/signals.ml32
-rw-r--r--test/Moretest/stackoverflow.ml15
-rw-r--r--test/Moretest/syserror.ml1
-rw-r--r--test/Moretest/tailcalls.ml28
-rw-r--r--test/Moretest/tcallback.ml69
-rw-r--r--test/Moretest/testrandom.ml13
-rw-r--r--test/Moretest/tscanf.ml826
-rw-r--r--test/Moretest/usemultdef.ml1
-rw-r--r--test/Moretest/warnings.ml44
-rw-r--r--test/Moretest/wc.ml54
-rw-r--r--test/Results/almabench.fast.out8
-rw-r--r--test/Results/almabench.out8
-rw-r--r--test/Results/bdd.out1
-rw-r--r--test/Results/boyer.out1
-rw-r--r--test/Results/fft.fast.runtest4
-rw-r--r--test/Results/fft.fast.runtest.Mac12
-rw-r--r--test/Results/fft.runtest4
-rw-r--r--test/Results/fft.runtest.Mac12
-rw-r--r--test/Results/fib.out1
-rw-r--r--test/Results/genlex.runtest5
-rw-r--r--test/Results/genlex.runtest.Mac7
-rw-r--r--test/Results/hamming.out100
-rw-r--r--test/Results/kb.out273
-rw-r--r--test/Results/nucleic.out1
-rw-r--r--test/Results/quicksort.fast.out2
-rw-r--r--test/Results/quicksort.out2
-rw-r--r--test/Results/runtest1
-rw-r--r--test/Results/sieve.out1
-rw-r--r--test/Results/soli.fast.out50
-rw-r--r--test/Results/soli.out50
-rw-r--r--test/Results/sorts.out198
-rw-r--r--test/Results/takc.out1
-rw-r--r--test/Results/taku.out1
-rw-r--r--test/alloc.ml51
-rw-r--r--test/almabench.ml324
-rw-r--r--test/bdd.ml231
-rw-r--r--test/boyer.ml907
-rw-r--r--test/fft.ml188
-rw-r--r--test/fib.ml24
-rw-r--r--test/hamming.ml105
-rw-r--r--test/nucleic.ml3236
-rw-r--r--test/quicksort.ml92
-rw-r--r--test/sieve.ml56
-rw-r--r--test/soli.ml111
-rw-r--r--test/sorts.ml4477
-rw-r--r--test/takc.ml23
-rw-r--r--test/taku.ml22
-rw-r--r--test/testinterp/.cvsignore3
-rw-r--r--test/testinterp/Makefile.Mac37
-rw-r--r--test/testinterp/addbytecode.mpw42
-rw-r--r--test/testinterp/coverage133
-rw-r--r--test/testinterp/lib.ml42
-rw-r--r--test/testinterp/no68k.rez1
-rw-r--r--test/testinterp/noppc.rez1
-rw-r--r--test/testinterp/runtest.mpw105
-rw-r--r--test/testinterp/t000.ml7
-rw-r--r--test/testinterp/t010-const0.ml8
-rw-r--r--test/testinterp/t010-const1.ml8
-rw-r--r--test/testinterp/t010-const2.ml8
-rw-r--r--test/testinterp/t010-const3.ml8
-rw-r--r--test/testinterp/t011-constint.ml8
-rw-r--r--test/testinterp/t020.ml10
-rw-r--r--test/testinterp/t021-pushconst1.ml10
-rw-r--r--test/testinterp/t021-pushconst2.ml10
-rw-r--r--test/testinterp/t021-pushconst3.ml10
-rw-r--r--test/testinterp/t022-pushconstint.ml10
-rw-r--r--test/testinterp/t040-makeblock1.ml13
-rw-r--r--test/testinterp/t040-makeblock2.ml15
-rw-r--r--test/testinterp/t040-makeblock3.ml17
-rw-r--r--test/testinterp/t041-makeblock.ml19
-rw-r--r--test/testinterp/t050-getglobal.ml8
-rw-r--r--test/testinterp/t050-pushgetglobal.ml10
-rw-r--r--test/testinterp/t051-getglobalfield.ml13
-rw-r--r--test/testinterp/t051-pushgetglobalfield.ml15
-rw-r--r--test/testinterp/t060-raise.ml15
-rw-r--r--test/testinterp/t070-branch.ml20
-rw-r--r--test/testinterp/t070-branchif.ml20
-rw-r--r--test/testinterp/t070-branchifnot.ml18
-rw-r--r--test/testinterp/t071-boolnot.ml19
-rw-r--r--test/testinterp/t080-eq.ml21
-rw-r--r--test/testinterp/t080-geint.ml21
-rw-r--r--test/testinterp/t080-gtint.ml20
-rw-r--r--test/testinterp/t080-leint.ml21
-rw-r--r--test/testinterp/t080-ltint.ml20
-rw-r--r--test/testinterp/t080-neq.ml20
-rw-r--r--test/testinterp/t090-acc0.ml25
-rw-r--r--test/testinterp/t090-acc1.ml27
-rw-r--r--test/testinterp/t090-acc2.ml29
-rw-r--r--test/testinterp/t090-acc3.ml31
-rw-r--r--test/testinterp/t090-acc4.ml33
-rw-r--r--test/testinterp/t090-acc5.ml35
-rw-r--r--test/testinterp/t090-acc6.ml37
-rw-r--r--test/testinterp/t090-acc7.ml39
-rw-r--r--test/testinterp/t091-acc.ml41
-rw-r--r--test/testinterp/t092-pushacc.ml38
-rw-r--r--test/testinterp/t092-pushacc0.ml22
-rw-r--r--test/testinterp/t092-pushacc1.ml24
-rw-r--r--test/testinterp/t092-pushacc2.ml26
-rw-r--r--test/testinterp/t092-pushacc3.ml28
-rw-r--r--test/testinterp/t092-pushacc4.ml30
-rw-r--r--test/testinterp/t092-pushacc5.ml32
-rw-r--r--test/testinterp/t092-pushacc6.ml34
-rw-r--r--test/testinterp/t092-pushacc7.ml36
-rw-r--r--test/testinterp/t093-pushacc.ml38
-rw-r--r--test/testinterp/t100-pushtrap.ml21
-rw-r--r--test/testinterp/t101-poptrap.ml21
-rw-r--r--test/testinterp/t110-addint.ml26
-rw-r--r--test/testinterp/t110-andint.ml22
-rw-r--r--test/testinterp/t110-asrint-1.ml22
-rw-r--r--test/testinterp/t110-asrint-2.ml22
-rw-r--r--test/testinterp/t110-divint-1.ml22
-rw-r--r--test/testinterp/t110-divint-2.ml22
-rw-r--r--test/testinterp/t110-divint-3.ml33
-rw-r--r--test/testinterp/t110-lslint.ml22
-rw-r--r--test/testinterp/t110-lsrint.ml22
-rw-r--r--test/testinterp/t110-modint-1.ml22
-rw-r--r--test/testinterp/t110-modint-2.ml34
-rw-r--r--test/testinterp/t110-mulint.ml22
-rw-r--r--test/testinterp/t110-negint.ml25
-rw-r--r--test/testinterp/t110-offsetint.ml21
-rw-r--r--test/testinterp/t110-orint.ml22
-rw-r--r--test/testinterp/t110-subint.ml26
-rw-r--r--test/testinterp/t110-xorint.ml22
-rw-r--r--test/testinterp/t120-getstringchar.ml22
-rw-r--r--test/testinterp/t121-setstringchar.ml31
-rw-r--r--test/testinterp/t130-getvectitem.ml24
-rw-r--r--test/testinterp/t130-vectlength.ml23
-rw-r--r--test/testinterp/t131-setvectitem.ml33
-rw-r--r--test/testinterp/t140-switch-1.ml32
-rw-r--r--test/testinterp/t140-switch-2.ml32
-rw-r--r--test/testinterp/t140-switch-3.ml31
-rw-r--r--test/testinterp/t140-switch-4.ml31
-rw-r--r--test/testinterp/t141-switch-5.ml38
-rw-r--r--test/testinterp/t141-switch-6.ml38
-rw-r--r--test/testinterp/t141-switch-7.ml37
-rw-r--r--test/testinterp/t142-switch-8.ml34
-rw-r--r--test/testinterp/t142-switch-9.ml34
-rw-r--r--test/testinterp/t142-switch-A.ml34
-rw-r--r--test/testinterp/t150-push-1.ml24
-rw-r--r--test/testinterp/t150-push-2.ml39
-rw-r--r--test/testinterp/t160-closure.ml19
-rw-r--r--test/testinterp/t161-apply1.ml42
-rw-r--r--test/testinterp/t162-return.ml21
-rw-r--r--test/testinterp/t163.ml23
-rw-r--r--test/testinterp/t164-apply2.ml24
-rw-r--r--test/testinterp/t164-apply3.ml25
-rw-r--r--test/testinterp/t165-apply.ml28
-rw-r--r--test/testinterp/t170-envacc2.ml37
-rw-r--r--test/testinterp/t170-envacc3.ml42
-rw-r--r--test/testinterp/t170-envacc4.ml47
-rw-r--r--test/testinterp/t171-envacc.ml52
-rw-r--r--test/testinterp/t172-pushenvacc1.ml34
-rw-r--r--test/testinterp/t172-pushenvacc2.ml37
-rw-r--r--test/testinterp/t172-pushenvacc3.ml42
-rw-r--r--test/testinterp/t172-pushenvacc4.ml47
-rw-r--r--test/testinterp/t173-pushenvacc.ml52
-rw-r--r--test/testinterp/t180-appterm1.ml35
-rw-r--r--test/testinterp/t180-appterm2.ml38
-rw-r--r--test/testinterp/t180-appterm3.ml39
-rw-r--r--test/testinterp/t181-appterm.ml40
-rw-r--r--test/testinterp/t190-makefloatblock-1.ml17
-rw-r--r--test/testinterp/t190-makefloatblock-2.ml18
-rw-r--r--test/testinterp/t190-makefloatblock-3.ml19
-rw-r--r--test/testinterp/t191-vectlength.ml26
-rw-r--r--test/testinterp/t192-getfloatfield-1.ml23
-rw-r--r--test/testinterp/t192-getfloatfield-2.ml23
-rw-r--r--test/testinterp/t193-setfloatfield-1.ml36
-rw-r--r--test/testinterp/t193-setfloatfield-2.ml36
-rw-r--r--test/testinterp/t200-getfield0.ml25
-rw-r--r--test/testinterp/t200-getfield1.ml26
-rw-r--r--test/testinterp/t200-getfield2.ml27
-rw-r--r--test/testinterp/t200-getfield3.ml28
-rw-r--r--test/testinterp/t201-getfield.ml29
-rw-r--r--test/testinterp/t210-setfield0.ml36
-rw-r--r--test/testinterp/t210-setfield1.ml38
-rw-r--r--test/testinterp/t210-setfield2.ml40
-rw-r--r--test/testinterp/t210-setfield3.ml42
-rw-r--r--test/testinterp/t211-setfield.ml44
-rw-r--r--test/testinterp/t220-assign.ml27
-rw-r--r--test/testinterp/t230-check_signals.ml28
-rw-r--r--test/testinterp/t240-c_call1.ml21
-rw-r--r--test/testinterp/t240-c_call2.ml22
-rw-r--r--test/testinterp/t240-c_call3.ml23
-rw-r--r--test/testinterp/t240-c_call4.ml32
-rw-r--r--test/testinterp/t240-c_call5.ml33
-rw-r--r--test/testinterp/t250-closurerec-1.ml19
-rw-r--r--test/testinterp/t250-closurerec-2.ml29
-rw-r--r--test/testinterp/t251-pushoffsetclosure0.ml39
-rw-r--r--test/testinterp/t251-pushoffsetclosure2.ml34
-rw-r--r--test/testinterp/t251-pushoffsetclosurem2.ml34
-rw-r--r--test/testinterp/t252-pushoffsetclosure.ml38
-rw-r--r--test/testinterp/t253-offsetclosure0.ml34
-rw-r--r--test/testinterp/t253-offsetclosure2.ml34
-rw-r--r--test/testinterp/t253-offsetclosurem2.ml34
-rw-r--r--test/testinterp/t254-offsetclosure.ml37
-rw-r--r--test/testinterp/t260-offsetref.ml31
-rw-r--r--test/testinterp/t270-push_retaddr.ml36
-rw-r--r--test/testinterp/t300-getmethod.ml5885
-rw-r--r--test/testinterp/t310-alloc-1.ml1587
-rw-r--r--test/testinterp/t310-alloc-2.ml2313
-rw-r--r--test/testinterp/t320-gc-1.ml1589
-rw-r--r--test/testinterp/t320-gc-2.ml1589
-rw-r--r--test/testinterp/t320-gc-3.ml1589
-rw-r--r--test/testinterp/t330-compact-1.ml15
-rw-r--r--test/testinterp/t330-compact-2.ml755
-rw-r--r--test/testinterp/t330-compact-3.ml1589
-rw-r--r--test/testinterp/t330-compact-4.ml1589
-rw-r--r--test/testinterp/t340-weak.ml2551
-rw-r--r--test/testinterp/t350-heapcheck.ml2554
-rw-r--r--test/testinterp/t360-stacks-1.ml43
-rw-r--r--test/testinterp/t360-stacks-2.ml54
-rw-r--r--testasmcomp/.cvsignore5
-rw-r--r--testasmcomp/.depend17
-rw-r--r--testasmcomp/Makefile159
-rw-r--r--testasmcomp/alpha.S62
-rw-r--r--testasmcomp/amd64.S53
-rw-r--r--testasmcomp/arith.cmm222
-rw-r--r--testasmcomp/arm.S45
-rw-r--r--testasmcomp/checkbound.cmm21
-rw-r--r--testasmcomp/fib.cmm19
-rw-r--r--testasmcomp/hppa.S162
-rw-r--r--testasmcomp/i386.S56
-rw-r--r--testasmcomp/i386nt.asm67
-rw-r--r--testasmcomp/ia64.S118
-rw-r--r--testasmcomp/integr.cmm30
-rw-r--r--testasmcomp/lexcmm.mli24
-rw-r--r--testasmcomp/lexcmm.mll228
-rw-r--r--testasmcomp/m68k.S59
-rw-r--r--testasmcomp/main.c126
-rw-r--r--testasmcomp/main.ml60
-rw-r--r--testasmcomp/mainarith.c304
-rw-r--r--testasmcomp/mips.s71
-rw-r--r--testasmcomp/parsecmm.mly325
-rw-r--r--testasmcomp/parsecmmaux.ml40
-rw-r--r--testasmcomp/parsecmmaux.mli26
-rw-r--r--testasmcomp/power-aix.S152
-rw-r--r--testasmcomp/power-elf.S131
-rw-r--r--testasmcomp/power-rhapsody.S129
-rw-r--r--testasmcomp/quicksort.cmm43
-rw-r--r--testasmcomp/quicksort2.cmm49
-rw-r--r--testasmcomp/soli.cmm109
-rw-r--r--testasmcomp/sparc.S41
-rw-r--r--testasmcomp/tagged-fib.cmm19
-rw-r--r--testasmcomp/tagged-integr.cmm45
-rw-r--r--testasmcomp/tagged-quicksort.cmm46
-rw-r--r--testasmcomp/tagged-tak.cmm23
-rw-r--r--testasmcomp/tak.cmm23
-rw-r--r--testlabl/.cvsignore1
-rw-r--r--testlabl/Makefile17
-rw-r--r--testlabl/bugs/yamagata021012.ml193
-rw-r--r--testlabl/dirs_multimatch1
-rw-r--r--testlabl/dirs_poly1
-rw-r--r--testlabl/mixin.ml146
-rw-r--r--testlabl/mixin2.ml179
-rw-r--r--testlabl/mixin3.ml173
-rw-r--r--testlabl/multimatch.ml157
-rw-r--r--testlabl/newlabels.ps1458
-rw-r--r--testlabl/poly.exp332
-rw-r--r--testlabl/poly.exp2339
-rw-r--r--testlabl/poly.ml468
-rw-r--r--testlabl/printers.ml11
-rw-r--r--testlabl/tests.ml22
-rw-r--r--testobjects/Exemples.exp301
-rw-r--r--testobjects/Exemples.ml333
-rw-r--r--testobjects/Makefile25
-rw-r--r--testobjects/Tests.exp228
-rw-r--r--testobjects/Tests.ml316
-rw-r--r--tools/.cvsignore22
-rw-r--r--tools/.depend49
-rw-r--r--tools/Characters16
-rw-r--r--tools/DoMake61
-rw-r--r--tools/MakeDepend17
-rw-r--r--tools/Makefile264
-rw-r--r--tools/Makefile.Mac137
-rw-r--r--tools/Makefile.Mac.depend30
-rw-r--r--tools/Makefile.nt172
-rw-r--r--tools/OCamlc-custom10
-rw-r--r--tools/Time10
-rw-r--r--tools/addlabels.ml451
-rw-r--r--tools/checkstack.c41
-rw-r--r--tools/cleanup-header15
-rw-r--r--tools/cvt_emit.mll84
-rw-r--r--tools/depend.ml291
-rw-r--r--tools/depend.mli23
-rw-r--r--tools/dumpapprox.ml100
-rw-r--r--tools/dumpobj.ml534
-rw-r--r--tools/keywords.r121
-rw-r--r--tools/lexer299.mll472
-rw-r--r--tools/lexer301.mll474
-rw-r--r--tools/magic11
-rw-r--r--tools/make-opcodes2
-rw-r--r--tools/make-opcodes.Mac14
-rwxr-xr-xtools/make-package-macosx52
-rw-r--r--tools/objinfo.ml101
-rw-r--r--tools/ocaml299to3.ml139
-rw-r--r--tools/ocamlcp.ml134
-rw-r--r--tools/ocamldep.ml228
-rw-r--r--tools/ocamlmklib.mlp250
-rw-r--r--tools/ocamlmktop.ml17
-rw-r--r--tools/ocamlmktop.tpl26
-rw-r--r--tools/ocamlprof.ml482
-rwxr-xr-xtools/ocamlsize49
-rw-r--r--tools/primreq.ml90
-rw-r--r--tools/profiling.ml53
-rw-r--r--tools/profiling.mli19
-rw-r--r--tools/scrapelabels.ml289
-rw-r--r--toplevel/expunge.ml83
-rw-r--r--toplevel/genprintval.ml363
-rw-r--r--toplevel/genprintval.mli52
-rw-r--r--toplevel/topdirs.ml297
-rw-r--r--toplevel/topdirs.mli34
-rw-r--r--toplevel/toploop.ml409
-rw-r--r--toplevel/toploop.mli107
-rw-r--r--toplevel/topmain.ml90
-rw-r--r--toplevel/topmain.mli17
-rw-r--r--toplevel/topstart.ml15
-rw-r--r--toplevel/trace.ml144
-rw-r--r--toplevel/trace.mli35
-rw-r--r--typing/btype.ml465
-rw-r--r--typing/btype.mli147
-rw-r--r--typing/ctype.ml3243
-rw-r--r--typing/ctype.mli238
-rw-r--r--typing/datarepr.ml96
-rw-r--r--typing/datarepr.mli34
-rw-r--r--typing/env.ml784
-rw-r--r--typing/env.mli139
-rw-r--r--typing/ident.ml172
-rw-r--r--typing/ident.mli57
-rw-r--r--typing/includeclass.ml104
-rw-r--r--typing/includeclass.mli31
-rw-r--r--typing/includecore.ml123
-rw-r--r--typing/includecore.mli31
-rw-r--r--typing/includemod.ml376
-rw-r--r--typing/includemod.mli46
-rw-r--r--typing/mtype.ml179
-rw-r--r--typing/mtype.mli32
-rw-r--r--typing/oprint.ml453
-rw-r--r--typing/oprint.mli24
-rw-r--r--typing/outcometree.mli96
-rw-r--r--typing/parmatch.ml1617
-rw-r--r--typing/parmatch.mli52
-rw-r--r--typing/path.ml49
-rw-r--r--typing/path.mli29
-rw-r--r--typing/predef.ml187
-rw-r--r--typing/predef.mli65
-rw-r--r--typing/primitive.ml56
-rw-r--r--typing/primitive.mli26
-rw-r--r--typing/printtyp.ml1000
-rw-r--r--typing/printtyp.mli67
-rw-r--r--typing/stypes.ml130
-rw-r--r--typing/stypes.mli33
-rw-r--r--typing/subst.ml295
-rw-r--r--typing/subst.mli51
-rw-r--r--typing/typeclass.ml1495
-rw-r--r--typing/typeclass.mli78
-rw-r--r--typing/typecore.ml2028
-rw-r--r--typing/typecore.mli108
-rw-r--r--typing/typedecl.ml717
-rw-r--r--typing/typedecl.mli69
-rw-r--r--typing/typedtree.ml228
-rw-r--r--typing/typedtree.mli164
-rw-r--r--typing/typemod.ml842
-rw-r--r--typing/typemod.mli54
-rw-r--r--typing/types.ml193
-rw-r--r--typing/types.mli195
-rw-r--r--typing/typetexp.ml597
-rw-r--r--typing/typetexp.mli60
-rw-r--r--utils/.cvsignore1
-rw-r--r--utils/ccomp.ml99
-rw-r--r--utils/ccomp.mli22
-rw-r--r--utils/clflags.ml87
-rw-r--r--utils/config.mli111
-rw-r--r--utils/config.mlp77
-rw-r--r--utils/consistbl.ml57
-rw-r--r--utils/consistbl.mli60
-rw-r--r--utils/misc.ml183
-rw-r--r--utils/misc.mli94
-rw-r--r--utils/tbl.ml104
-rw-r--r--utils/tbl.mli30
-rw-r--r--utils/terminfo.ml25
-rw-r--r--utils/terminfo.mli25
-rw-r--r--utils/warnings.ml148
-rw-r--r--utils/warnings.mli43
-rw-r--r--win32caml/Makefile52
-rw-r--r--win32caml/inria.h115
-rw-r--r--win32caml/inriares.h48
-rw-r--r--win32caml/libgraph.h108
-rw-r--r--win32caml/menu.c592
-rw-r--r--win32caml/ocaml.c816
-rw-r--r--win32caml/ocaml.icobin766 -> 0 bytes
-rw-r--r--win32caml/ocaml.rc114
-rw-r--r--win32caml/startocaml.c364
-rw-r--r--yacc/.cvsignore3
-rw-r--r--yacc/Makefile46
-rw-r--r--yacc/Makefile.Mac54
-rw-r--r--yacc/Makefile.nt49
-rw-r--r--yacc/closure.c283
-rw-r--r--yacc/defs.h377
-rw-r--r--yacc/error.c313
-rw-r--r--yacc/lalr.c663
-rw-r--r--yacc/lr0.c621
-rw-r--r--yacc/main.c402
-rw-r--r--yacc/mkpar.c366
-rw-r--r--yacc/output.c984
-rw-r--r--yacc/reader.c1839
-rw-r--r--yacc/skeleton.c58
-rw-r--r--yacc/symtab.c129
-rw-r--r--yacc/verbose.c350
-rw-r--r--yacc/warshall.c96
1631 files changed, 0 insertions, 281639 deletions
diff --git a/.cvsignore b/.cvsignore
deleted file mode 100644
index 25b3103837..0000000000
--- a/.cvsignore
+++ /dev/null
@@ -1,13 +0,0 @@
-.cvsignore
-.depend
-configure
-ocamlc
-ocamlc.opt
-expunge
-ocaml
-ocamlopt
-ocamlopt.opt
-ocamlcomp.sh
-ocamlcompopt.sh
-package-macosx
-.DS_Store
diff --git a/.depend b/.depend
deleted file mode 100644
index bf99d6fa8f..0000000000
--- a/.depend
+++ /dev/null
@@ -1,772 +0,0 @@
-utils/ccomp.cmo: utils/clflags.cmo utils/config.cmi utils/misc.cmi \
- utils/ccomp.cmi
-utils/ccomp.cmx: utils/clflags.cmx utils/config.cmx utils/misc.cmx \
- utils/ccomp.cmi
-utils/clflags.cmo: utils/config.cmi
-utils/clflags.cmx: utils/config.cmx
-utils/config.cmo: utils/config.cmi
-utils/config.cmx: utils/config.cmi
-utils/consistbl.cmo: utils/consistbl.cmi
-utils/consistbl.cmx: utils/consistbl.cmi
-utils/misc.cmo: utils/misc.cmi
-utils/misc.cmx: utils/misc.cmi
-utils/tbl.cmo: utils/tbl.cmi
-utils/tbl.cmx: utils/tbl.cmi
-utils/terminfo.cmo: utils/terminfo.cmi
-utils/terminfo.cmx: utils/terminfo.cmi
-utils/warnings.cmo: utils/warnings.cmi
-utils/warnings.cmx: utils/warnings.cmi
-parsing/lexer.cmi: parsing/location.cmi parsing/parser.cmi
-parsing/location.cmi: utils/warnings.cmi
-parsing/parse.cmi: parsing/parsetree.cmi
-parsing/parser.cmi: parsing/parsetree.cmi
-parsing/parsetree.cmi: parsing/asttypes.cmi parsing/location.cmi \
- parsing/longident.cmi
-parsing/printast.cmi: parsing/parsetree.cmi
-parsing/syntaxerr.cmi: parsing/location.cmi
-parsing/lexer.cmo: parsing/location.cmi utils/misc.cmi parsing/parser.cmi \
- utils/warnings.cmi parsing/lexer.cmi
-parsing/lexer.cmx: parsing/location.cmx utils/misc.cmx parsing/parser.cmx \
- utils/warnings.cmx parsing/lexer.cmi
-parsing/linenum.cmo: utils/misc.cmi parsing/linenum.cmi
-parsing/linenum.cmx: utils/misc.cmx parsing/linenum.cmi
-parsing/location.cmo: parsing/linenum.cmi utils/terminfo.cmi \
- utils/warnings.cmi parsing/location.cmi
-parsing/location.cmx: parsing/linenum.cmx utils/terminfo.cmx \
- utils/warnings.cmx parsing/location.cmi
-parsing/longident.cmo: utils/misc.cmi parsing/longident.cmi
-parsing/longident.cmx: utils/misc.cmx parsing/longident.cmi
-parsing/parse.cmo: parsing/lexer.cmi parsing/location.cmi parsing/parser.cmi \
- parsing/syntaxerr.cmi parsing/parse.cmi
-parsing/parse.cmx: parsing/lexer.cmx parsing/location.cmx parsing/parser.cmx \
- parsing/syntaxerr.cmx parsing/parse.cmi
-parsing/parser.cmo: parsing/asttypes.cmi utils/clflags.cmo \
- parsing/location.cmi parsing/longident.cmi parsing/parsetree.cmi \
- parsing/syntaxerr.cmi parsing/parser.cmi
-parsing/parser.cmx: parsing/asttypes.cmi utils/clflags.cmx \
- parsing/location.cmx parsing/longident.cmx parsing/parsetree.cmi \
- parsing/syntaxerr.cmx parsing/parser.cmi
-parsing/printast.cmo: parsing/asttypes.cmi parsing/location.cmi \
- parsing/longident.cmi parsing/parsetree.cmi parsing/printast.cmi
-parsing/printast.cmx: parsing/asttypes.cmi parsing/location.cmx \
- parsing/longident.cmx parsing/parsetree.cmi parsing/printast.cmi
-parsing/syntaxerr.cmo: parsing/location.cmi parsing/syntaxerr.cmi
-parsing/syntaxerr.cmx: parsing/location.cmx parsing/syntaxerr.cmi
-typing/btype.cmi: parsing/asttypes.cmi typing/path.cmi typing/types.cmi
-typing/ctype.cmi: parsing/asttypes.cmi typing/env.cmi typing/ident.cmi \
- typing/path.cmi typing/types.cmi
-typing/datarepr.cmi: parsing/asttypes.cmi typing/path.cmi typing/types.cmi
-typing/env.cmi: utils/consistbl.cmi typing/ident.cmi parsing/longident.cmi \
- typing/path.cmi typing/types.cmi
-typing/includeclass.cmi: typing/ctype.cmi typing/env.cmi typing/typedtree.cmi \
- typing/types.cmi
-typing/includecore.cmi: typing/env.cmi typing/ident.cmi typing/typedtree.cmi \
- typing/types.cmi
-typing/includemod.cmi: typing/ctype.cmi typing/env.cmi typing/ident.cmi \
- typing/typedtree.cmi typing/types.cmi
-typing/mtype.cmi: typing/env.cmi typing/ident.cmi typing/path.cmi \
- typing/types.cmi
-typing/oprint.cmi: typing/outcometree.cmi
-typing/outcometree.cmi: parsing/asttypes.cmi
-typing/parmatch.cmi: typing/env.cmi parsing/location.cmi typing/typedtree.cmi \
- typing/types.cmi
-typing/path.cmi: typing/ident.cmi
-typing/predef.cmi: typing/ident.cmi typing/path.cmi typing/types.cmi
-typing/printtyp.cmi: typing/ident.cmi parsing/longident.cmi \
- typing/outcometree.cmi typing/path.cmi typing/types.cmi
-typing/stypes.cmi: parsing/location.cmi typing/typedtree.cmi
-typing/subst.cmi: typing/ident.cmi typing/path.cmi typing/types.cmi
-typing/typeclass.cmi: parsing/asttypes.cmi typing/ctype.cmi typing/env.cmi \
- typing/ident.cmi parsing/location.cmi parsing/longident.cmi \
- parsing/parsetree.cmi typing/typedtree.cmi typing/types.cmi
-typing/typecore.cmi: parsing/asttypes.cmi typing/env.cmi typing/ident.cmi \
- parsing/location.cmi parsing/longident.cmi parsing/parsetree.cmi \
- typing/path.cmi typing/typedtree.cmi typing/types.cmi
-typing/typedecl.cmi: typing/env.cmi typing/ident.cmi parsing/location.cmi \
- parsing/longident.cmi parsing/parsetree.cmi typing/path.cmi \
- typing/types.cmi
-typing/typedtree.cmi: parsing/asttypes.cmi typing/env.cmi typing/ident.cmi \
- parsing/location.cmi typing/path.cmi typing/primitive.cmi \
- typing/types.cmi
-typing/typemod.cmi: typing/env.cmi typing/ident.cmi typing/includemod.cmi \
- parsing/location.cmi parsing/longident.cmi parsing/parsetree.cmi \
- typing/typedtree.cmi typing/types.cmi
-typing/types.cmi: parsing/asttypes.cmi typing/ident.cmi typing/path.cmi \
- typing/primitive.cmi
-typing/typetexp.cmi: typing/env.cmi parsing/location.cmi \
- parsing/longident.cmi parsing/parsetree.cmi typing/path.cmi \
- typing/types.cmi
-typing/btype.cmo: utils/misc.cmi typing/path.cmi typing/types.cmi \
- typing/btype.cmi
-typing/btype.cmx: utils/misc.cmx typing/path.cmx typing/types.cmx \
- typing/btype.cmi
-typing/ctype.cmo: parsing/asttypes.cmi typing/btype.cmi utils/clflags.cmo \
- typing/env.cmi typing/ident.cmi parsing/longident.cmi utils/misc.cmi \
- typing/path.cmi typing/subst.cmi typing/types.cmi typing/ctype.cmi
-typing/ctype.cmx: parsing/asttypes.cmi typing/btype.cmx utils/clflags.cmx \
- typing/env.cmx typing/ident.cmx parsing/longident.cmx utils/misc.cmx \
- typing/path.cmx typing/subst.cmx typing/types.cmx typing/ctype.cmi
-typing/datarepr.cmo: parsing/asttypes.cmi utils/misc.cmi typing/predef.cmi \
- typing/types.cmi typing/datarepr.cmi
-typing/datarepr.cmx: parsing/asttypes.cmi utils/misc.cmx typing/predef.cmx \
- typing/types.cmx typing/datarepr.cmi
-typing/env.cmo: parsing/asttypes.cmi typing/btype.cmi utils/config.cmi \
- utils/consistbl.cmi typing/datarepr.cmi typing/ident.cmi \
- parsing/longident.cmi utils/misc.cmi typing/path.cmi typing/predef.cmi \
- typing/subst.cmi utils/tbl.cmi typing/types.cmi typing/env.cmi
-typing/env.cmx: parsing/asttypes.cmi typing/btype.cmx utils/config.cmx \
- utils/consistbl.cmx typing/datarepr.cmx typing/ident.cmx \
- parsing/longident.cmx utils/misc.cmx typing/path.cmx typing/predef.cmx \
- typing/subst.cmx utils/tbl.cmx typing/types.cmx typing/env.cmi
-typing/ident.cmo: typing/ident.cmi
-typing/ident.cmx: typing/ident.cmi
-typing/includeclass.cmo: typing/ctype.cmi typing/printtyp.cmi \
- typing/types.cmi typing/includeclass.cmi
-typing/includeclass.cmx: typing/ctype.cmx typing/printtyp.cmx \
- typing/types.cmx typing/includeclass.cmi
-typing/includecore.cmo: parsing/asttypes.cmi typing/btype.cmi \
- typing/ctype.cmi utils/misc.cmi typing/path.cmi typing/predef.cmi \
- typing/typedtree.cmi typing/types.cmi typing/includecore.cmi
-typing/includecore.cmx: parsing/asttypes.cmi typing/btype.cmx \
- typing/ctype.cmx utils/misc.cmx typing/path.cmx typing/predef.cmx \
- typing/typedtree.cmx typing/types.cmx typing/includecore.cmi
-typing/includemod.cmo: typing/ctype.cmi typing/env.cmi typing/ident.cmi \
- typing/includeclass.cmi typing/includecore.cmi utils/misc.cmi \
- typing/mtype.cmi typing/path.cmi typing/printtyp.cmi typing/subst.cmi \
- utils/tbl.cmi typing/typedtree.cmi typing/types.cmi typing/includemod.cmi
-typing/includemod.cmx: typing/ctype.cmx typing/env.cmx typing/ident.cmx \
- typing/includeclass.cmx typing/includecore.cmx utils/misc.cmx \
- typing/mtype.cmx typing/path.cmx typing/printtyp.cmx typing/subst.cmx \
- utils/tbl.cmx typing/typedtree.cmx typing/types.cmx typing/includemod.cmi
-typing/mtype.cmo: typing/btype.cmi typing/ctype.cmi typing/env.cmi \
- typing/ident.cmi typing/path.cmi typing/types.cmi typing/mtype.cmi
-typing/mtype.cmx: typing/btype.cmx typing/ctype.cmx typing/env.cmx \
- typing/ident.cmx typing/path.cmx typing/types.cmx typing/mtype.cmi
-typing/oprint.cmo: parsing/asttypes.cmi typing/outcometree.cmi \
- typing/oprint.cmi
-typing/oprint.cmx: parsing/asttypes.cmi typing/outcometree.cmi \
- typing/oprint.cmi
-typing/parmatch.cmo: parsing/asttypes.cmi typing/btype.cmi typing/ctype.cmi \
- typing/datarepr.cmi typing/env.cmi typing/ident.cmi parsing/location.cmi \
- utils/misc.cmi typing/path.cmi typing/predef.cmi typing/typedtree.cmi \
- typing/types.cmi utils/warnings.cmi typing/parmatch.cmi
-typing/parmatch.cmx: parsing/asttypes.cmi typing/btype.cmx typing/ctype.cmx \
- typing/datarepr.cmx typing/env.cmx typing/ident.cmx parsing/location.cmx \
- utils/misc.cmx typing/path.cmx typing/predef.cmx typing/typedtree.cmx \
- typing/types.cmx utils/warnings.cmx typing/parmatch.cmi
-typing/path.cmo: typing/ident.cmi typing/path.cmi
-typing/path.cmx: typing/ident.cmx typing/path.cmi
-typing/predef.cmo: parsing/asttypes.cmi typing/btype.cmi typing/ident.cmi \
- typing/path.cmi typing/types.cmi typing/predef.cmi
-typing/predef.cmx: parsing/asttypes.cmi typing/btype.cmx typing/ident.cmx \
- typing/path.cmx typing/types.cmx typing/predef.cmi
-typing/primitive.cmo: utils/misc.cmi typing/primitive.cmi
-typing/primitive.cmx: utils/misc.cmx typing/primitive.cmi
-typing/printtyp.cmo: parsing/asttypes.cmi typing/btype.cmi utils/clflags.cmo \
- typing/ctype.cmi typing/env.cmi typing/ident.cmi parsing/longident.cmi \
- utils/misc.cmi typing/oprint.cmi typing/outcometree.cmi typing/path.cmi \
- typing/predef.cmi typing/primitive.cmi typing/types.cmi \
- typing/printtyp.cmi
-typing/printtyp.cmx: parsing/asttypes.cmi typing/btype.cmx utils/clflags.cmx \
- typing/ctype.cmx typing/env.cmx typing/ident.cmx parsing/longident.cmx \
- utils/misc.cmx typing/oprint.cmx typing/outcometree.cmi typing/path.cmx \
- typing/predef.cmx typing/primitive.cmx typing/types.cmx \
- typing/printtyp.cmi
-typing/stypes.cmo: utils/clflags.cmo parsing/location.cmi typing/printtyp.cmi \
- typing/typedtree.cmi typing/stypes.cmi
-typing/stypes.cmx: utils/clflags.cmx parsing/location.cmx typing/printtyp.cmx \
- typing/typedtree.cmx typing/stypes.cmi
-typing/subst.cmo: typing/btype.cmi typing/ident.cmi utils/misc.cmi \
- typing/path.cmi utils/tbl.cmi typing/types.cmi typing/subst.cmi
-typing/subst.cmx: typing/btype.cmx typing/ident.cmx utils/misc.cmx \
- typing/path.cmx utils/tbl.cmx typing/types.cmx typing/subst.cmi
-typing/typeclass.cmo: parsing/asttypes.cmi typing/btype.cmi utils/clflags.cmo \
- typing/ctype.cmi typing/env.cmi typing/ident.cmi typing/includeclass.cmi \
- parsing/location.cmi parsing/longident.cmi utils/misc.cmi \
- typing/parmatch.cmi parsing/parsetree.cmi typing/path.cmi \
- typing/predef.cmi typing/printtyp.cmi typing/stypes.cmi \
- typing/typecore.cmi typing/typedecl.cmi typing/typedtree.cmi \
- typing/types.cmi typing/typetexp.cmi utils/warnings.cmi \
- typing/typeclass.cmi
-typing/typeclass.cmx: parsing/asttypes.cmi typing/btype.cmx utils/clflags.cmx \
- typing/ctype.cmx typing/env.cmx typing/ident.cmx typing/includeclass.cmx \
- parsing/location.cmx parsing/longident.cmx utils/misc.cmx \
- typing/parmatch.cmx parsing/parsetree.cmi typing/path.cmx \
- typing/predef.cmx typing/printtyp.cmx typing/stypes.cmx \
- typing/typecore.cmx typing/typedecl.cmx typing/typedtree.cmx \
- typing/types.cmx typing/typetexp.cmx utils/warnings.cmx \
- typing/typeclass.cmi
-typing/typecore.cmo: parsing/asttypes.cmi typing/btype.cmi utils/clflags.cmo \
- typing/ctype.cmi typing/env.cmi typing/ident.cmi parsing/location.cmi \
- parsing/longident.cmi utils/misc.cmi typing/parmatch.cmi \
- parsing/parsetree.cmi typing/path.cmi typing/predef.cmi \
- typing/primitive.cmi typing/printtyp.cmi typing/stypes.cmi \
- typing/typedtree.cmi typing/types.cmi typing/typetexp.cmi \
- utils/warnings.cmi typing/typecore.cmi
-typing/typecore.cmx: parsing/asttypes.cmi typing/btype.cmx utils/clflags.cmx \
- typing/ctype.cmx typing/env.cmx typing/ident.cmx parsing/location.cmx \
- parsing/longident.cmx utils/misc.cmx typing/parmatch.cmx \
- parsing/parsetree.cmi typing/path.cmx typing/predef.cmx \
- typing/primitive.cmx typing/printtyp.cmx typing/stypes.cmx \
- typing/typedtree.cmx typing/types.cmx typing/typetexp.cmx \
- utils/warnings.cmx typing/typecore.cmi
-typing/typedecl.cmo: parsing/asttypes.cmi typing/btype.cmi utils/clflags.cmo \
- utils/config.cmi typing/ctype.cmi typing/env.cmi typing/ident.cmi \
- typing/includecore.cmi parsing/location.cmi parsing/longident.cmi \
- utils/misc.cmi parsing/parsetree.cmi typing/path.cmi typing/predef.cmi \
- typing/primitive.cmi typing/printtyp.cmi typing/subst.cmi \
- typing/typedtree.cmi typing/types.cmi typing/typetexp.cmi \
- typing/typedecl.cmi
-typing/typedecl.cmx: parsing/asttypes.cmi typing/btype.cmx utils/clflags.cmx \
- utils/config.cmx typing/ctype.cmx typing/env.cmx typing/ident.cmx \
- typing/includecore.cmx parsing/location.cmx parsing/longident.cmx \
- utils/misc.cmx parsing/parsetree.cmi typing/path.cmx typing/predef.cmx \
- typing/primitive.cmx typing/printtyp.cmx typing/subst.cmx \
- typing/typedtree.cmx typing/types.cmx typing/typetexp.cmx \
- typing/typedecl.cmi
-typing/typedtree.cmo: parsing/asttypes.cmi typing/env.cmi typing/ident.cmi \
- parsing/location.cmi utils/misc.cmi typing/path.cmi typing/primitive.cmi \
- typing/types.cmi typing/typedtree.cmi
-typing/typedtree.cmx: parsing/asttypes.cmi typing/env.cmx typing/ident.cmx \
- parsing/location.cmx utils/misc.cmx typing/path.cmx typing/primitive.cmx \
- typing/types.cmx typing/typedtree.cmi
-typing/typemod.cmo: utils/clflags.cmo utils/config.cmi typing/ctype.cmi \
- typing/env.cmi typing/ident.cmi typing/includemod.cmi \
- parsing/location.cmi parsing/longident.cmi utils/misc.cmi \
- typing/mtype.cmi parsing/parsetree.cmi typing/path.cmi \
- typing/printtyp.cmi typing/stypes.cmi typing/subst.cmi \
- typing/typeclass.cmi typing/typecore.cmi typing/typedecl.cmi \
- typing/typedtree.cmi typing/types.cmi typing/typemod.cmi
-typing/typemod.cmx: utils/clflags.cmx utils/config.cmx typing/ctype.cmx \
- typing/env.cmx typing/ident.cmx typing/includemod.cmx \
- parsing/location.cmx parsing/longident.cmx utils/misc.cmx \
- typing/mtype.cmx parsing/parsetree.cmi typing/path.cmx \
- typing/printtyp.cmx typing/stypes.cmx typing/subst.cmx \
- typing/typeclass.cmx typing/typecore.cmx typing/typedecl.cmx \
- typing/typedtree.cmx typing/types.cmx typing/typemod.cmi
-typing/types.cmo: parsing/asttypes.cmi typing/ident.cmi utils/misc.cmi \
- typing/path.cmi typing/primitive.cmi typing/types.cmi
-typing/types.cmx: parsing/asttypes.cmi typing/ident.cmx utils/misc.cmx \
- typing/path.cmx typing/primitive.cmx typing/types.cmi
-typing/typetexp.cmo: typing/btype.cmi typing/ctype.cmi typing/env.cmi \
- parsing/location.cmi parsing/longident.cmi utils/misc.cmi \
- parsing/parsetree.cmi typing/path.cmi typing/printtyp.cmi utils/tbl.cmi \
- typing/types.cmi utils/warnings.cmi typing/typetexp.cmi
-typing/typetexp.cmx: typing/btype.cmx typing/ctype.cmx typing/env.cmx \
- parsing/location.cmx parsing/longident.cmx utils/misc.cmx \
- parsing/parsetree.cmi typing/path.cmx typing/printtyp.cmx utils/tbl.cmx \
- typing/types.cmx utils/warnings.cmx typing/typetexp.cmi
-bytecomp/bytegen.cmi: bytecomp/instruct.cmi bytecomp/lambda.cmi
-bytecomp/bytelink.cmi: bytecomp/emitcode.cmi bytecomp/symtable.cmi
-bytecomp/bytepackager.cmi: typing/ident.cmi
-bytecomp/emitcode.cmi: typing/ident.cmi bytecomp/instruct.cmi \
- bytecomp/lambda.cmi
-bytecomp/instruct.cmi: typing/env.cmi typing/ident.cmi bytecomp/lambda.cmi \
- typing/types.cmi
-bytecomp/lambda.cmi: parsing/asttypes.cmi typing/env.cmi typing/ident.cmi \
- typing/path.cmi typing/primitive.cmi typing/types.cmi
-bytecomp/matching.cmi: typing/ident.cmi bytecomp/lambda.cmi \
- parsing/location.cmi typing/typedtree.cmi
-bytecomp/printinstr.cmi: bytecomp/instruct.cmi
-bytecomp/printlambda.cmi: bytecomp/lambda.cmi
-bytecomp/simplif.cmi: bytecomp/lambda.cmi
-bytecomp/symtable.cmi: bytecomp/emitcode.cmi typing/ident.cmi
-bytecomp/translclass.cmi: typing/ident.cmi bytecomp/lambda.cmi \
- parsing/location.cmi typing/typedtree.cmi
-bytecomp/translcore.cmi: parsing/asttypes.cmi typing/ident.cmi \
- bytecomp/lambda.cmi parsing/location.cmi typing/path.cmi \
- typing/primitive.cmi typing/typedtree.cmi typing/types.cmi
-bytecomp/translmod.cmi: typing/ident.cmi bytecomp/lambda.cmi \
- parsing/location.cmi typing/typedtree.cmi
-bytecomp/translobj.cmi: typing/ident.cmi bytecomp/lambda.cmi
-bytecomp/typeopt.cmi: bytecomp/lambda.cmi typing/path.cmi \
- typing/typedtree.cmi
-bytecomp/bytegen.cmo: parsing/asttypes.cmi utils/config.cmi typing/ident.cmi \
- bytecomp/instruct.cmi bytecomp/lambda.cmi utils/misc.cmi \
- typing/primitive.cmi bytecomp/switch.cmi typing/types.cmi \
- bytecomp/bytegen.cmi
-bytecomp/bytegen.cmx: parsing/asttypes.cmi utils/config.cmx typing/ident.cmx \
- bytecomp/instruct.cmx bytecomp/lambda.cmx utils/misc.cmx \
- typing/primitive.cmx bytecomp/switch.cmx typing/types.cmx \
- bytecomp/bytegen.cmi
-bytecomp/bytelibrarian.cmo: bytecomp/bytelink.cmi utils/clflags.cmo \
- utils/config.cmi bytecomp/emitcode.cmi utils/misc.cmi \
- bytecomp/bytelibrarian.cmi
-bytecomp/bytelibrarian.cmx: bytecomp/bytelink.cmx utils/clflags.cmx \
- utils/config.cmx bytecomp/emitcode.cmx utils/misc.cmx \
- bytecomp/bytelibrarian.cmi
-bytecomp/bytelink.cmo: bytecomp/bytesections.cmi utils/ccomp.cmi \
- utils/clflags.cmo utils/config.cmi utils/consistbl.cmi bytecomp/dll.cmi \
- bytecomp/emitcode.cmi typing/ident.cmi bytecomp/instruct.cmi \
- utils/misc.cmi bytecomp/opcodes.cmo bytecomp/symtable.cmi \
- bytecomp/bytelink.cmi
-bytecomp/bytelink.cmx: bytecomp/bytesections.cmx utils/ccomp.cmx \
- utils/clflags.cmx utils/config.cmx utils/consistbl.cmx bytecomp/dll.cmx \
- bytecomp/emitcode.cmx typing/ident.cmx bytecomp/instruct.cmx \
- utils/misc.cmx bytecomp/opcodes.cmx bytecomp/symtable.cmx \
- bytecomp/bytelink.cmi
-bytecomp/bytepackager.cmo: bytecomp/bytegen.cmi bytecomp/bytelink.cmi \
- utils/clflags.cmo utils/config.cmi bytecomp/emitcode.cmi typing/env.cmi \
- typing/ident.cmi bytecomp/instruct.cmi utils/misc.cmi \
- bytecomp/translmod.cmi typing/typemod.cmi bytecomp/bytepackager.cmi
-bytecomp/bytepackager.cmx: bytecomp/bytegen.cmx bytecomp/bytelink.cmx \
- utils/clflags.cmx utils/config.cmx bytecomp/emitcode.cmx typing/env.cmx \
- typing/ident.cmx bytecomp/instruct.cmx utils/misc.cmx \
- bytecomp/translmod.cmx typing/typemod.cmx bytecomp/bytepackager.cmi
-bytecomp/bytesections.cmo: utils/config.cmi bytecomp/bytesections.cmi
-bytecomp/bytesections.cmx: utils/config.cmx bytecomp/bytesections.cmi
-bytecomp/dll.cmo: utils/config.cmi utils/misc.cmi bytecomp/dll.cmi
-bytecomp/dll.cmx: utils/config.cmx utils/misc.cmx bytecomp/dll.cmi
-bytecomp/emitcode.cmo: parsing/asttypes.cmi typing/btype.cmi \
- utils/clflags.cmo utils/config.cmi typing/env.cmi typing/ident.cmi \
- bytecomp/instruct.cmi bytecomp/lambda.cmi bytecomp/meta.cmi \
- utils/misc.cmi bytecomp/opcodes.cmo bytecomp/translmod.cmi \
- bytecomp/emitcode.cmi
-bytecomp/emitcode.cmx: parsing/asttypes.cmi typing/btype.cmx \
- utils/clflags.cmx utils/config.cmx typing/env.cmx typing/ident.cmx \
- bytecomp/instruct.cmx bytecomp/lambda.cmx bytecomp/meta.cmx \
- utils/misc.cmx bytecomp/opcodes.cmx bytecomp/translmod.cmx \
- bytecomp/emitcode.cmi
-bytecomp/instruct.cmo: typing/env.cmi typing/ident.cmi bytecomp/lambda.cmi \
- typing/types.cmi bytecomp/instruct.cmi
-bytecomp/instruct.cmx: typing/env.cmx typing/ident.cmx bytecomp/lambda.cmx \
- typing/types.cmx bytecomp/instruct.cmi
-bytecomp/lambda.cmo: parsing/asttypes.cmi typing/env.cmi typing/ident.cmi \
- utils/misc.cmi typing/path.cmi typing/primitive.cmi typing/types.cmi \
- bytecomp/lambda.cmi
-bytecomp/lambda.cmx: parsing/asttypes.cmi typing/env.cmx typing/ident.cmx \
- utils/misc.cmx typing/path.cmx typing/primitive.cmx typing/types.cmx \
- bytecomp/lambda.cmi
-bytecomp/matching.cmo: parsing/asttypes.cmi typing/btype.cmi typing/ident.cmi \
- bytecomp/lambda.cmi parsing/location.cmi utils/misc.cmi \
- typing/parmatch.cmi typing/predef.cmi typing/primitive.cmi \
- bytecomp/printlambda.cmi bytecomp/switch.cmi typing/typedtree.cmi \
- bytecomp/typeopt.cmi typing/types.cmi bytecomp/matching.cmi
-bytecomp/matching.cmx: parsing/asttypes.cmi typing/btype.cmx typing/ident.cmx \
- bytecomp/lambda.cmx parsing/location.cmx utils/misc.cmx \
- typing/parmatch.cmx typing/predef.cmx typing/primitive.cmx \
- bytecomp/printlambda.cmx bytecomp/switch.cmx typing/typedtree.cmx \
- bytecomp/typeopt.cmx typing/types.cmx bytecomp/matching.cmi
-bytecomp/meta.cmo: bytecomp/meta.cmi
-bytecomp/meta.cmx: bytecomp/meta.cmi
-bytecomp/printinstr.cmo: typing/ident.cmi bytecomp/instruct.cmi \
- bytecomp/lambda.cmi bytecomp/printlambda.cmi bytecomp/printinstr.cmi
-bytecomp/printinstr.cmx: typing/ident.cmx bytecomp/instruct.cmx \
- bytecomp/lambda.cmx bytecomp/printlambda.cmx bytecomp/printinstr.cmi
-bytecomp/printlambda.cmo: parsing/asttypes.cmi typing/ident.cmi \
- bytecomp/lambda.cmi typing/primitive.cmi typing/types.cmi \
- bytecomp/printlambda.cmi
-bytecomp/printlambda.cmx: parsing/asttypes.cmi typing/ident.cmx \
- bytecomp/lambda.cmx typing/primitive.cmx typing/types.cmx \
- bytecomp/printlambda.cmi
-bytecomp/runtimedef.cmo: bytecomp/runtimedef.cmi
-bytecomp/runtimedef.cmx: bytecomp/runtimedef.cmi
-bytecomp/simplif.cmo: parsing/asttypes.cmi utils/clflags.cmo typing/ident.cmi \
- bytecomp/lambda.cmi bytecomp/simplif.cmi
-bytecomp/simplif.cmx: parsing/asttypes.cmi utils/clflags.cmx typing/ident.cmx \
- bytecomp/lambda.cmx bytecomp/simplif.cmi
-bytecomp/switch.cmo: bytecomp/switch.cmi
-bytecomp/switch.cmx: bytecomp/switch.cmi
-bytecomp/symtable.cmo: parsing/asttypes.cmi bytecomp/bytesections.cmi \
- utils/clflags.cmo bytecomp/dll.cmi bytecomp/emitcode.cmi typing/ident.cmi \
- bytecomp/lambda.cmi bytecomp/meta.cmi utils/misc.cmi typing/predef.cmi \
- bytecomp/runtimedef.cmi utils/tbl.cmi bytecomp/symtable.cmi
-bytecomp/symtable.cmx: parsing/asttypes.cmi bytecomp/bytesections.cmx \
- utils/clflags.cmx bytecomp/dll.cmx bytecomp/emitcode.cmx typing/ident.cmx \
- bytecomp/lambda.cmx bytecomp/meta.cmx utils/misc.cmx typing/predef.cmx \
- bytecomp/runtimedef.cmx utils/tbl.cmx bytecomp/symtable.cmi
-bytecomp/translclass.cmo: parsing/asttypes.cmi utils/clflags.cmo \
- typing/ident.cmi bytecomp/lambda.cmi parsing/location.cmi \
- bytecomp/matching.cmi utils/misc.cmi bytecomp/translcore.cmi \
- bytecomp/translobj.cmi typing/typedtree.cmi bytecomp/typeopt.cmi \
- typing/types.cmi bytecomp/translclass.cmi
-bytecomp/translclass.cmx: parsing/asttypes.cmi utils/clflags.cmx \
- typing/ident.cmx bytecomp/lambda.cmx parsing/location.cmx \
- bytecomp/matching.cmx utils/misc.cmx bytecomp/translcore.cmx \
- bytecomp/translobj.cmx typing/typedtree.cmx bytecomp/typeopt.cmx \
- typing/types.cmx bytecomp/translclass.cmi
-bytecomp/translcore.cmo: parsing/asttypes.cmi typing/btype.cmi \
- utils/clflags.cmo utils/config.cmi typing/env.cmi typing/ident.cmi \
- bytecomp/lambda.cmi parsing/location.cmi bytecomp/matching.cmi \
- utils/misc.cmi typing/path.cmi typing/predef.cmi typing/primitive.cmi \
- bytecomp/translobj.cmi typing/typedtree.cmi bytecomp/typeopt.cmi \
- typing/types.cmi bytecomp/translcore.cmi
-bytecomp/translcore.cmx: parsing/asttypes.cmi typing/btype.cmx \
- utils/clflags.cmx utils/config.cmx typing/env.cmx typing/ident.cmx \
- bytecomp/lambda.cmx parsing/location.cmx bytecomp/matching.cmx \
- utils/misc.cmx typing/path.cmx typing/predef.cmx typing/primitive.cmx \
- bytecomp/translobj.cmx typing/typedtree.cmx bytecomp/typeopt.cmx \
- typing/types.cmx bytecomp/translcore.cmi
-bytecomp/translmod.cmo: parsing/asttypes.cmi utils/config.cmi \
- typing/ctype.cmi typing/env.cmi typing/ident.cmi bytecomp/lambda.cmi \
- parsing/location.cmi utils/misc.cmi typing/mtype.cmi typing/path.cmi \
- typing/predef.cmi typing/primitive.cmi typing/printtyp.cmi \
- bytecomp/translclass.cmi bytecomp/translcore.cmi bytecomp/translobj.cmi \
- typing/typedtree.cmi typing/types.cmi bytecomp/translmod.cmi
-bytecomp/translmod.cmx: parsing/asttypes.cmi utils/config.cmx \
- typing/ctype.cmx typing/env.cmx typing/ident.cmx bytecomp/lambda.cmx \
- parsing/location.cmx utils/misc.cmx typing/mtype.cmx typing/path.cmx \
- typing/predef.cmx typing/primitive.cmx typing/printtyp.cmx \
- bytecomp/translclass.cmx bytecomp/translcore.cmx bytecomp/translobj.cmx \
- typing/typedtree.cmx typing/types.cmx bytecomp/translmod.cmi
-bytecomp/translobj.cmo: parsing/asttypes.cmi typing/env.cmi typing/ident.cmi \
- bytecomp/lambda.cmi parsing/longident.cmi utils/misc.cmi \
- bytecomp/translobj.cmi
-bytecomp/translobj.cmx: parsing/asttypes.cmi typing/env.cmx typing/ident.cmx \
- bytecomp/lambda.cmx parsing/longident.cmx utils/misc.cmx \
- bytecomp/translobj.cmi
-bytecomp/typeopt.cmo: parsing/asttypes.cmi typing/ctype.cmi typing/env.cmi \
- typing/ident.cmi bytecomp/lambda.cmi utils/misc.cmi typing/path.cmi \
- typing/predef.cmi typing/primitive.cmi typing/typedtree.cmi \
- typing/types.cmi bytecomp/typeopt.cmi
-bytecomp/typeopt.cmx: parsing/asttypes.cmi typing/ctype.cmx typing/env.cmx \
- typing/ident.cmx bytecomp/lambda.cmx utils/misc.cmx typing/path.cmx \
- typing/predef.cmx typing/primitive.cmx typing/typedtree.cmx \
- typing/types.cmx bytecomp/typeopt.cmi
-asmcomp/asmgen.cmi: asmcomp/cmm.cmi bytecomp/lambda.cmi
-asmcomp/asmlink.cmi: asmcomp/compilenv.cmi
-asmcomp/clambda.cmi: parsing/asttypes.cmi typing/ident.cmi \
- bytecomp/lambda.cmi
-asmcomp/closure.cmi: asmcomp/clambda.cmi bytecomp/lambda.cmi
-asmcomp/cmm.cmi: typing/ident.cmi
-asmcomp/cmmgen.cmi: asmcomp/clambda.cmi asmcomp/cmm.cmi
-asmcomp/codegen.cmi: asmcomp/cmm.cmi
-asmcomp/comballoc.cmi: asmcomp/mach.cmi
-asmcomp/compilenv.cmi: asmcomp/clambda.cmi typing/ident.cmi
-asmcomp/emit.cmi: asmcomp/cmm.cmi asmcomp/linearize.cmi
-asmcomp/interf.cmi: asmcomp/mach.cmi
-asmcomp/linearize.cmi: asmcomp/mach.cmi asmcomp/reg.cmi
-asmcomp/liveness.cmi: asmcomp/mach.cmi
-asmcomp/mach.cmi: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/reg.cmi
-asmcomp/printcmm.cmi: asmcomp/cmm.cmi
-asmcomp/printlinear.cmi: asmcomp/linearize.cmi
-asmcomp/printmach.cmi: asmcomp/mach.cmi asmcomp/reg.cmi
-asmcomp/proc.cmi: asmcomp/mach.cmi asmcomp/reg.cmi
-asmcomp/reg.cmi: asmcomp/cmm.cmi
-asmcomp/reload.cmi: asmcomp/mach.cmi
-asmcomp/reloadgen.cmi: asmcomp/mach.cmi asmcomp/reg.cmi
-asmcomp/schedgen.cmi: asmcomp/linearize.cmi asmcomp/mach.cmi
-asmcomp/scheduling.cmi: asmcomp/linearize.cmi
-asmcomp/selectgen.cmi: asmcomp/arch.cmo asmcomp/cmm.cmi typing/ident.cmi \
- asmcomp/mach.cmi asmcomp/reg.cmi utils/tbl.cmi
-asmcomp/selection.cmi: asmcomp/cmm.cmi asmcomp/mach.cmi
-asmcomp/spill.cmi: asmcomp/mach.cmi
-asmcomp/split.cmi: asmcomp/mach.cmi
-asmcomp/arch.cmo: utils/config.cmi utils/misc.cmi
-asmcomp/arch.cmx: utils/config.cmx utils/misc.cmx
-asmcomp/asmgen.cmo: utils/clflags.cmo asmcomp/closure.cmi asmcomp/cmm.cmi \
- asmcomp/cmmgen.cmi asmcomp/coloring.cmi asmcomp/comballoc.cmi \
- utils/config.cmi asmcomp/emit.cmi asmcomp/emitaux.cmi asmcomp/interf.cmi \
- asmcomp/linearize.cmi asmcomp/liveness.cmi asmcomp/mach.cmi \
- utils/misc.cmi asmcomp/printcmm.cmi asmcomp/printlinear.cmi \
- asmcomp/printmach.cmi asmcomp/proc.cmi asmcomp/reg.cmi asmcomp/reload.cmi \
- asmcomp/scheduling.cmi asmcomp/selection.cmi asmcomp/spill.cmi \
- asmcomp/split.cmi asmcomp/asmgen.cmi
-asmcomp/asmgen.cmx: utils/clflags.cmx asmcomp/closure.cmx asmcomp/cmm.cmx \
- asmcomp/cmmgen.cmx asmcomp/coloring.cmx asmcomp/comballoc.cmx \
- utils/config.cmx asmcomp/emit.cmx asmcomp/emitaux.cmx asmcomp/interf.cmx \
- asmcomp/linearize.cmx asmcomp/liveness.cmx asmcomp/mach.cmx \
- utils/misc.cmx asmcomp/printcmm.cmx asmcomp/printlinear.cmx \
- asmcomp/printmach.cmx asmcomp/proc.cmx asmcomp/reg.cmx asmcomp/reload.cmx \
- asmcomp/scheduling.cmx asmcomp/selection.cmx asmcomp/spill.cmx \
- asmcomp/split.cmx asmcomp/asmgen.cmi
-asmcomp/asmlibrarian.cmo: asmcomp/asmlink.cmi utils/ccomp.cmi \
- asmcomp/clambda.cmi utils/clflags.cmo asmcomp/compilenv.cmi \
- utils/config.cmi utils/misc.cmi asmcomp/asmlibrarian.cmi
-asmcomp/asmlibrarian.cmx: asmcomp/asmlink.cmx utils/ccomp.cmx \
- asmcomp/clambda.cmx utils/clflags.cmx asmcomp/compilenv.cmx \
- utils/config.cmx utils/misc.cmx asmcomp/asmlibrarian.cmi
-asmcomp/asmlink.cmo: asmcomp/asmgen.cmi utils/ccomp.cmi utils/clflags.cmo \
- asmcomp/cmmgen.cmi asmcomp/compilenv.cmi utils/config.cmi \
- utils/consistbl.cmi asmcomp/emit.cmi asmcomp/emitaux.cmi \
- parsing/location.cmi utils/misc.cmi asmcomp/proc.cmi \
- bytecomp/runtimedef.cmi asmcomp/asmlink.cmi
-asmcomp/asmlink.cmx: asmcomp/asmgen.cmx utils/ccomp.cmx utils/clflags.cmx \
- asmcomp/cmmgen.cmx asmcomp/compilenv.cmx utils/config.cmx \
- utils/consistbl.cmx asmcomp/emit.cmx asmcomp/emitaux.cmx \
- parsing/location.cmx utils/misc.cmx asmcomp/proc.cmx \
- bytecomp/runtimedef.cmx asmcomp/asmlink.cmi
-asmcomp/asmpackager.cmo: asmcomp/asmgen.cmi asmcomp/asmlink.cmi \
- utils/ccomp.cmi asmcomp/clambda.cmi asmcomp/compilenv.cmi \
- utils/config.cmi typing/env.cmi typing/ident.cmi bytecomp/lambda.cmi \
- parsing/location.cmi utils/misc.cmi utils/tbl.cmi bytecomp/translmod.cmi \
- typing/typemod.cmi asmcomp/asmpackager.cmi
-asmcomp/asmpackager.cmx: asmcomp/asmgen.cmx asmcomp/asmlink.cmx \
- utils/ccomp.cmx asmcomp/clambda.cmx asmcomp/compilenv.cmx \
- utils/config.cmx typing/env.cmx typing/ident.cmx bytecomp/lambda.cmx \
- parsing/location.cmx utils/misc.cmx utils/tbl.cmx bytecomp/translmod.cmx \
- typing/typemod.cmx asmcomp/asmpackager.cmi
-asmcomp/clambda.cmo: parsing/asttypes.cmi typing/ident.cmi \
- bytecomp/lambda.cmi asmcomp/clambda.cmi
-asmcomp/clambda.cmx: parsing/asttypes.cmi typing/ident.cmx \
- bytecomp/lambda.cmx asmcomp/clambda.cmi
-asmcomp/closure.cmo: parsing/asttypes.cmi asmcomp/clambda.cmi \
- utils/clflags.cmo asmcomp/compilenv.cmi typing/ident.cmi \
- bytecomp/lambda.cmi utils/misc.cmi typing/primitive.cmi \
- bytecomp/switch.cmi utils/tbl.cmi asmcomp/closure.cmi
-asmcomp/closure.cmx: parsing/asttypes.cmi asmcomp/clambda.cmx \
- utils/clflags.cmx asmcomp/compilenv.cmx typing/ident.cmx \
- bytecomp/lambda.cmx utils/misc.cmx typing/primitive.cmx \
- bytecomp/switch.cmx utils/tbl.cmx asmcomp/closure.cmi
-asmcomp/cmm.cmo: asmcomp/arch.cmo typing/ident.cmi asmcomp/cmm.cmi
-asmcomp/cmm.cmx: asmcomp/arch.cmx typing/ident.cmx asmcomp/cmm.cmi
-asmcomp/cmmgen.cmo: asmcomp/arch.cmo parsing/asttypes.cmi asmcomp/clambda.cmi \
- utils/clflags.cmo asmcomp/cmm.cmi asmcomp/compilenv.cmi utils/config.cmi \
- typing/ident.cmi bytecomp/lambda.cmi utils/misc.cmi typing/primitive.cmi \
- asmcomp/proc.cmi bytecomp/switch.cmi typing/types.cmi asmcomp/cmmgen.cmi
-asmcomp/cmmgen.cmx: asmcomp/arch.cmx parsing/asttypes.cmi asmcomp/clambda.cmx \
- utils/clflags.cmx asmcomp/cmm.cmx asmcomp/compilenv.cmx utils/config.cmx \
- typing/ident.cmx bytecomp/lambda.cmx utils/misc.cmx typing/primitive.cmx \
- asmcomp/proc.cmx bytecomp/switch.cmx typing/types.cmx asmcomp/cmmgen.cmi
-asmcomp/codegen.cmo: asmcomp/cmm.cmi asmcomp/coloring.cmi asmcomp/emit.cmi \
- asmcomp/interf.cmi asmcomp/linearize.cmi asmcomp/liveness.cmi \
- asmcomp/printcmm.cmi asmcomp/printlinear.cmi asmcomp/printmach.cmi \
- asmcomp/reg.cmi asmcomp/reload.cmi asmcomp/spill.cmi asmcomp/split.cmi \
- asmcomp/codegen.cmi
-asmcomp/codegen.cmx: asmcomp/cmm.cmx asmcomp/coloring.cmx asmcomp/emit.cmx \
- asmcomp/interf.cmx asmcomp/linearize.cmx asmcomp/liveness.cmx \
- asmcomp/printcmm.cmx asmcomp/printlinear.cmx asmcomp/printmach.cmx \
- asmcomp/reg.cmx asmcomp/reload.cmx asmcomp/spill.cmx asmcomp/split.cmx \
- asmcomp/codegen.cmi
-asmcomp/coloring.cmo: asmcomp/proc.cmi asmcomp/reg.cmi asmcomp/coloring.cmi
-asmcomp/coloring.cmx: asmcomp/proc.cmx asmcomp/reg.cmx asmcomp/coloring.cmi
-asmcomp/comballoc.cmo: utils/config.cmi asmcomp/mach.cmi asmcomp/reg.cmi \
- asmcomp/comballoc.cmi
-asmcomp/comballoc.cmx: utils/config.cmx asmcomp/mach.cmx asmcomp/reg.cmx \
- asmcomp/comballoc.cmi
-asmcomp/compilenv.cmo: asmcomp/clambda.cmi utils/config.cmi typing/env.cmi \
- typing/ident.cmi utils/misc.cmi asmcomp/compilenv.cmi
-asmcomp/compilenv.cmx: asmcomp/clambda.cmx utils/config.cmx typing/env.cmx \
- typing/ident.cmx utils/misc.cmx asmcomp/compilenv.cmi
-asmcomp/emit.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/compilenv.cmi \
- utils/config.cmi asmcomp/emitaux.cmi asmcomp/linearize.cmi \
- parsing/location.cmi asmcomp/mach.cmi utils/misc.cmi asmcomp/proc.cmi \
- asmcomp/reg.cmi asmcomp/emit.cmi
-asmcomp/emit.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx asmcomp/compilenv.cmx \
- utils/config.cmx asmcomp/emitaux.cmx asmcomp/linearize.cmx \
- parsing/location.cmx asmcomp/mach.cmx utils/misc.cmx asmcomp/proc.cmx \
- asmcomp/reg.cmx asmcomp/emit.cmi
-asmcomp/emitaux.cmo: asmcomp/emitaux.cmi
-asmcomp/emitaux.cmx: asmcomp/emitaux.cmi
-asmcomp/interf.cmo: asmcomp/mach.cmi utils/misc.cmi asmcomp/proc.cmi \
- asmcomp/reg.cmi asmcomp/interf.cmi
-asmcomp/interf.cmx: asmcomp/mach.cmx utils/misc.cmx asmcomp/proc.cmx \
- asmcomp/reg.cmx asmcomp/interf.cmi
-asmcomp/linearize.cmo: asmcomp/cmm.cmi asmcomp/mach.cmi utils/misc.cmi \
- asmcomp/proc.cmi asmcomp/reg.cmi asmcomp/linearize.cmi
-asmcomp/linearize.cmx: asmcomp/cmm.cmx asmcomp/mach.cmx utils/misc.cmx \
- asmcomp/proc.cmx asmcomp/reg.cmx asmcomp/linearize.cmi
-asmcomp/liveness.cmo: asmcomp/mach.cmi utils/misc.cmi asmcomp/printmach.cmi \
- asmcomp/proc.cmi asmcomp/reg.cmi asmcomp/liveness.cmi
-asmcomp/liveness.cmx: asmcomp/mach.cmx utils/misc.cmx asmcomp/printmach.cmx \
- asmcomp/proc.cmx asmcomp/reg.cmx asmcomp/liveness.cmi
-asmcomp/mach.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/reg.cmi \
- asmcomp/mach.cmi
-asmcomp/mach.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx asmcomp/reg.cmx \
- asmcomp/mach.cmi
-asmcomp/printcmm.cmo: asmcomp/cmm.cmi typing/ident.cmi asmcomp/printcmm.cmi
-asmcomp/printcmm.cmx: asmcomp/cmm.cmx typing/ident.cmx asmcomp/printcmm.cmi
-asmcomp/printlinear.cmo: asmcomp/linearize.cmi asmcomp/mach.cmi \
- asmcomp/printmach.cmi asmcomp/printlinear.cmi
-asmcomp/printlinear.cmx: asmcomp/linearize.cmx asmcomp/mach.cmx \
- asmcomp/printmach.cmx asmcomp/printlinear.cmi
-asmcomp/printmach.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/mach.cmi \
- asmcomp/printcmm.cmi asmcomp/proc.cmi asmcomp/reg.cmi \
- asmcomp/printmach.cmi
-asmcomp/printmach.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx asmcomp/mach.cmx \
- asmcomp/printcmm.cmx asmcomp/proc.cmx asmcomp/reg.cmx \
- asmcomp/printmach.cmi
-asmcomp/proc.cmo: asmcomp/arch.cmo utils/ccomp.cmi utils/clflags.cmo \
- asmcomp/cmm.cmi utils/config.cmi asmcomp/mach.cmi utils/misc.cmi \
- asmcomp/reg.cmi asmcomp/proc.cmi
-asmcomp/proc.cmx: asmcomp/arch.cmx utils/ccomp.cmx utils/clflags.cmx \
- asmcomp/cmm.cmx utils/config.cmx asmcomp/mach.cmx utils/misc.cmx \
- asmcomp/reg.cmx asmcomp/proc.cmi
-asmcomp/reg.cmo: asmcomp/cmm.cmi asmcomp/reg.cmi
-asmcomp/reg.cmx: asmcomp/cmm.cmx asmcomp/reg.cmi
-asmcomp/reload.cmo: asmcomp/reloadgen.cmi asmcomp/reload.cmi
-asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reload.cmi
-asmcomp/reloadgen.cmo: asmcomp/mach.cmi utils/misc.cmi asmcomp/reg.cmi \
- asmcomp/reloadgen.cmi
-asmcomp/reloadgen.cmx: asmcomp/mach.cmx utils/misc.cmx asmcomp/reg.cmx \
- asmcomp/reloadgen.cmi
-asmcomp/schedgen.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/linearize.cmi \
- asmcomp/mach.cmi utils/misc.cmi asmcomp/reg.cmi asmcomp/schedgen.cmi
-asmcomp/schedgen.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx asmcomp/linearize.cmx \
- asmcomp/mach.cmx utils/misc.cmx asmcomp/reg.cmx asmcomp/schedgen.cmi
-asmcomp/scheduling.cmo: asmcomp/arch.cmo asmcomp/mach.cmi \
- asmcomp/schedgen.cmi asmcomp/scheduling.cmi
-asmcomp/scheduling.cmx: asmcomp/arch.cmx asmcomp/mach.cmx \
- asmcomp/schedgen.cmx asmcomp/scheduling.cmi
-asmcomp/selectgen.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi typing/ident.cmi \
- asmcomp/mach.cmi utils/misc.cmi asmcomp/proc.cmi asmcomp/reg.cmi \
- utils/tbl.cmi asmcomp/selectgen.cmi
-asmcomp/selectgen.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx typing/ident.cmx \
- asmcomp/mach.cmx utils/misc.cmx asmcomp/proc.cmx asmcomp/reg.cmx \
- utils/tbl.cmx asmcomp/selectgen.cmi
-asmcomp/selection.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/mach.cmi \
- utils/misc.cmi asmcomp/reg.cmi asmcomp/selectgen.cmi \
- asmcomp/selection.cmi
-asmcomp/selection.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx asmcomp/mach.cmx \
- utils/misc.cmx asmcomp/reg.cmx asmcomp/selectgen.cmx \
- asmcomp/selection.cmi
-asmcomp/spill.cmo: asmcomp/mach.cmi utils/misc.cmi asmcomp/proc.cmi \
- asmcomp/reg.cmi asmcomp/spill.cmi
-asmcomp/spill.cmx: asmcomp/mach.cmx utils/misc.cmx asmcomp/proc.cmx \
- asmcomp/reg.cmx asmcomp/spill.cmi
-asmcomp/split.cmo: asmcomp/mach.cmi utils/misc.cmi asmcomp/reg.cmi \
- asmcomp/split.cmi
-asmcomp/split.cmx: asmcomp/mach.cmx utils/misc.cmx asmcomp/reg.cmx \
- asmcomp/split.cmi
-driver/compile.cmi: typing/env.cmi
-driver/optcompile.cmi: typing/env.cmi
-driver/compile.cmo: bytecomp/bytegen.cmi utils/ccomp.cmi utils/clflags.cmo \
- utils/config.cmi bytecomp/emitcode.cmi typing/env.cmi typing/ident.cmi \
- utils/misc.cmi parsing/parse.cmi driver/pparse.cmi parsing/printast.cmi \
- bytecomp/printinstr.cmi bytecomp/printlambda.cmi typing/printtyp.cmi \
- bytecomp/simplif.cmi bytecomp/translmod.cmi typing/typedtree.cmi \
- typing/typemod.cmi utils/warnings.cmi driver/compile.cmi
-driver/compile.cmx: bytecomp/bytegen.cmx utils/ccomp.cmx utils/clflags.cmx \
- utils/config.cmx bytecomp/emitcode.cmx typing/env.cmx typing/ident.cmx \
- utils/misc.cmx parsing/parse.cmx driver/pparse.cmx parsing/printast.cmx \
- bytecomp/printinstr.cmx bytecomp/printlambda.cmx typing/printtyp.cmx \
- bytecomp/simplif.cmx bytecomp/translmod.cmx typing/typedtree.cmx \
- typing/typemod.cmx utils/warnings.cmx driver/compile.cmi
-driver/errors.cmo: bytecomp/bytelibrarian.cmi bytecomp/bytelink.cmi \
- bytecomp/bytepackager.cmi typing/ctype.cmi typing/env.cmi \
- typing/includemod.cmi parsing/lexer.cmi parsing/location.cmi \
- driver/pparse.cmi bytecomp/symtable.cmi parsing/syntaxerr.cmi \
- bytecomp/translclass.cmi bytecomp/translcore.cmi bytecomp/translmod.cmi \
- typing/typeclass.cmi typing/typecore.cmi typing/typedecl.cmi \
- typing/typemod.cmi typing/typetexp.cmi utils/warnings.cmi \
- driver/errors.cmi
-driver/errors.cmx: bytecomp/bytelibrarian.cmx bytecomp/bytelink.cmx \
- bytecomp/bytepackager.cmx typing/ctype.cmx typing/env.cmx \
- typing/includemod.cmx parsing/lexer.cmx parsing/location.cmx \
- driver/pparse.cmx bytecomp/symtable.cmx parsing/syntaxerr.cmx \
- bytecomp/translclass.cmx bytecomp/translcore.cmx bytecomp/translmod.cmx \
- typing/typeclass.cmx typing/typecore.cmx typing/typedecl.cmx \
- typing/typemod.cmx typing/typetexp.cmx utils/warnings.cmx \
- driver/errors.cmi
-driver/main.cmo: bytecomp/bytelibrarian.cmi bytecomp/bytelink.cmi \
- bytecomp/bytepackager.cmi utils/clflags.cmo driver/compile.cmi \
- utils/config.cmi driver/errors.cmi driver/main_args.cmi utils/misc.cmi \
- utils/warnings.cmi driver/main.cmi
-driver/main.cmx: bytecomp/bytelibrarian.cmx bytecomp/bytelink.cmx \
- bytecomp/bytepackager.cmx utils/clflags.cmx driver/compile.cmx \
- utils/config.cmx driver/errors.cmx driver/main_args.cmx utils/misc.cmx \
- utils/warnings.cmx driver/main.cmi
-driver/main_args.cmo: driver/main_args.cmi
-driver/main_args.cmx: driver/main_args.cmi
-driver/optcompile.cmo: asmcomp/asmgen.cmi utils/ccomp.cmi utils/clflags.cmo \
- asmcomp/compilenv.cmi utils/config.cmi typing/env.cmi typing/ident.cmi \
- utils/misc.cmi parsing/parse.cmi driver/pparse.cmi parsing/printast.cmi \
- bytecomp/printlambda.cmi typing/printtyp.cmi bytecomp/simplif.cmi \
- bytecomp/translmod.cmi typing/typedtree.cmi typing/typemod.cmi \
- utils/warnings.cmi driver/optcompile.cmi
-driver/optcompile.cmx: asmcomp/asmgen.cmx utils/ccomp.cmx utils/clflags.cmx \
- asmcomp/compilenv.cmx utils/config.cmx typing/env.cmx typing/ident.cmx \
- utils/misc.cmx parsing/parse.cmx driver/pparse.cmx parsing/printast.cmx \
- bytecomp/printlambda.cmx typing/printtyp.cmx bytecomp/simplif.cmx \
- bytecomp/translmod.cmx typing/typedtree.cmx typing/typemod.cmx \
- utils/warnings.cmx driver/optcompile.cmi
-driver/opterrors.cmo: asmcomp/asmgen.cmi asmcomp/asmlibrarian.cmi \
- asmcomp/asmlink.cmi asmcomp/asmpackager.cmi asmcomp/compilenv.cmi \
- typing/ctype.cmi typing/env.cmi typing/includemod.cmi parsing/lexer.cmi \
- parsing/location.cmi driver/pparse.cmi parsing/syntaxerr.cmi \
- bytecomp/translclass.cmi bytecomp/translcore.cmi bytecomp/translmod.cmi \
- typing/typeclass.cmi typing/typecore.cmi typing/typedecl.cmi \
- typing/typemod.cmi typing/typetexp.cmi utils/warnings.cmi \
- driver/opterrors.cmi
-driver/opterrors.cmx: asmcomp/asmgen.cmx asmcomp/asmlibrarian.cmx \
- asmcomp/asmlink.cmx asmcomp/asmpackager.cmx asmcomp/compilenv.cmx \
- typing/ctype.cmx typing/env.cmx typing/includemod.cmx parsing/lexer.cmx \
- parsing/location.cmx driver/pparse.cmx parsing/syntaxerr.cmx \
- bytecomp/translclass.cmx bytecomp/translcore.cmx bytecomp/translmod.cmx \
- typing/typeclass.cmx typing/typecore.cmx typing/typedecl.cmx \
- typing/typemod.cmx typing/typetexp.cmx utils/warnings.cmx \
- driver/opterrors.cmi
-driver/optmain.cmo: asmcomp/arch.cmo asmcomp/asmlibrarian.cmi \
- asmcomp/asmlink.cmi asmcomp/asmpackager.cmi utils/clflags.cmo \
- utils/config.cmi utils/misc.cmi driver/optcompile.cmi \
- driver/opterrors.cmi asmcomp/printmach.cmi utils/warnings.cmi \
- driver/optmain.cmi
-driver/optmain.cmx: asmcomp/arch.cmx asmcomp/asmlibrarian.cmx \
- asmcomp/asmlink.cmx asmcomp/asmpackager.cmx utils/clflags.cmx \
- utils/config.cmx utils/misc.cmx driver/optcompile.cmx \
- driver/opterrors.cmx asmcomp/printmach.cmx utils/warnings.cmx \
- driver/optmain.cmi
-driver/pparse.cmo: utils/ccomp.cmi utils/clflags.cmo parsing/location.cmi \
- utils/misc.cmi driver/pparse.cmi
-driver/pparse.cmx: utils/ccomp.cmx utils/clflags.cmx parsing/location.cmx \
- utils/misc.cmx driver/pparse.cmi
-toplevel/genprintval.cmi: typing/env.cmi typing/outcometree.cmi \
- typing/path.cmi typing/types.cmi
-toplevel/topdirs.cmi: parsing/longident.cmi
-toplevel/toploop.cmi: typing/env.cmi parsing/location.cmi \
- parsing/longident.cmi typing/outcometree.cmi parsing/parsetree.cmi \
- typing/path.cmi typing/types.cmi utils/warnings.cmi
-toplevel/trace.cmi: typing/env.cmi parsing/longident.cmi typing/path.cmi \
- typing/types.cmi
-toplevel/expunge.cmo: bytecomp/bytesections.cmi typing/ident.cmi \
- utils/misc.cmi bytecomp/runtimedef.cmi bytecomp/symtable.cmi
-toplevel/expunge.cmx: bytecomp/bytesections.cmx typing/ident.cmx \
- utils/misc.cmx bytecomp/runtimedef.cmx bytecomp/symtable.cmx
-toplevel/genprintval.cmo: typing/btype.cmi typing/ctype.cmi \
- typing/datarepr.cmi typing/env.cmi typing/ident.cmi parsing/longident.cmi \
- utils/misc.cmi typing/outcometree.cmi typing/path.cmi typing/predef.cmi \
- typing/printtyp.cmi typing/types.cmi toplevel/genprintval.cmi
-toplevel/genprintval.cmx: typing/btype.cmx typing/ctype.cmx \
- typing/datarepr.cmx typing/env.cmx typing/ident.cmx parsing/longident.cmx \
- utils/misc.cmx typing/outcometree.cmi typing/path.cmx typing/predef.cmx \
- typing/printtyp.cmx typing/types.cmx toplevel/genprintval.cmi
-toplevel/topdirs.cmo: utils/clflags.cmo utils/config.cmi utils/consistbl.cmi \
- typing/ctype.cmi bytecomp/dll.cmi bytecomp/emitcode.cmi typing/env.cmi \
- typing/ident.cmi parsing/longident.cmi bytecomp/meta.cmi utils/misc.cmi \
- bytecomp/opcodes.cmo typing/path.cmi typing/printtyp.cmi \
- bytecomp/symtable.cmi toplevel/toploop.cmi toplevel/trace.cmi \
- typing/types.cmi utils/warnings.cmi toplevel/topdirs.cmi
-toplevel/topdirs.cmx: utils/clflags.cmx utils/config.cmx utils/consistbl.cmx \
- typing/ctype.cmx bytecomp/dll.cmx bytecomp/emitcode.cmx typing/env.cmx \
- typing/ident.cmx parsing/longident.cmx bytecomp/meta.cmx utils/misc.cmx \
- bytecomp/opcodes.cmx typing/path.cmx typing/printtyp.cmx \
- bytecomp/symtable.cmx toplevel/toploop.cmx toplevel/trace.cmx \
- typing/types.cmx utils/warnings.cmx toplevel/topdirs.cmi
-toplevel/toploop.cmo: typing/btype.cmi bytecomp/bytegen.cmi utils/clflags.cmo \
- driver/compile.cmi utils/config.cmi utils/consistbl.cmi bytecomp/dll.cmi \
- bytecomp/emitcode.cmi typing/env.cmi driver/errors.cmi \
- toplevel/genprintval.cmi typing/ident.cmi parsing/lexer.cmi \
- parsing/location.cmi parsing/longident.cmi bytecomp/meta.cmi \
- utils/misc.cmi typing/oprint.cmi typing/outcometree.cmi parsing/parse.cmi \
- parsing/parsetree.cmi typing/path.cmi typing/predef.cmi \
- parsing/printast.cmi bytecomp/printinstr.cmi bytecomp/printlambda.cmi \
- typing/printtyp.cmi bytecomp/simplif.cmi bytecomp/symtable.cmi \
- bytecomp/translmod.cmi typing/typecore.cmi typing/typedtree.cmi \
- typing/typemod.cmi typing/types.cmi utils/warnings.cmi \
- toplevel/toploop.cmi
-toplevel/toploop.cmx: typing/btype.cmx bytecomp/bytegen.cmx utils/clflags.cmx \
- driver/compile.cmx utils/config.cmx utils/consistbl.cmx bytecomp/dll.cmx \
- bytecomp/emitcode.cmx typing/env.cmx driver/errors.cmx \
- toplevel/genprintval.cmx typing/ident.cmx parsing/lexer.cmx \
- parsing/location.cmx parsing/longident.cmx bytecomp/meta.cmx \
- utils/misc.cmx typing/oprint.cmx typing/outcometree.cmi parsing/parse.cmx \
- parsing/parsetree.cmi typing/path.cmx typing/predef.cmx \
- parsing/printast.cmx bytecomp/printinstr.cmx bytecomp/printlambda.cmx \
- typing/printtyp.cmx bytecomp/simplif.cmx bytecomp/symtable.cmx \
- bytecomp/translmod.cmx typing/typecore.cmx typing/typedtree.cmx \
- typing/typemod.cmx typing/types.cmx utils/warnings.cmx \
- toplevel/toploop.cmi
-toplevel/topmain.cmo: utils/clflags.cmo utils/config.cmi driver/errors.cmi \
- utils/misc.cmi toplevel/topdirs.cmi toplevel/toploop.cmi \
- utils/warnings.cmi toplevel/topmain.cmi
-toplevel/topmain.cmx: utils/clflags.cmx utils/config.cmx driver/errors.cmx \
- utils/misc.cmx toplevel/topdirs.cmx toplevel/toploop.cmx \
- utils/warnings.cmx toplevel/topmain.cmi
-toplevel/topstart.cmo: toplevel/topmain.cmi
-toplevel/topstart.cmx: toplevel/topmain.cmx
-toplevel/trace.cmo: typing/ctype.cmi parsing/longident.cmi bytecomp/meta.cmi \
- utils/misc.cmi typing/path.cmi typing/predef.cmi typing/printtyp.cmi \
- toplevel/toploop.cmi typing/types.cmi toplevel/trace.cmi
-toplevel/trace.cmx: typing/ctype.cmx parsing/longident.cmx bytecomp/meta.cmx \
- utils/misc.cmx typing/path.cmx typing/predef.cmx typing/printtyp.cmx \
- toplevel/toploop.cmx typing/types.cmx toplevel/trace.cmi
diff --git a/Changes b/Changes
deleted file mode 100644
index b0cb25c666..0000000000
--- a/Changes
+++ /dev/null
@@ -1,1657 +0,0 @@
-Objective Caml 3.07:
---------------------
-
-Language features:
-- Experimental support for recursive module definitions
- module rec A : SIGA = StructA and B : SIGB = StructB and ...
-- Support for "private types", or more exactly concrete data types
- with private constructors or labels. These data types can be
- de-structured normally in pattern matchings, but values of these
- types cannot be constructed directly outside of their defining module.
-- Added integer literals of types int32, nativeint, int64
- (written with an 'l', 'n' or 'L' suffix respectively).
-
-Type-checking:
-- Allow polymorphic generalization of covariant parts of expansive
- expressions. For instance, if f: unit -> 'a list, "let x = f ()"
- gives "x" the generalized type forall 'a. 'a list, instead of '_a list
- as before.
-- The typing of polymorphic variants in pattern matching has changed.
- It is intended to be more regular, sticking to the principle of "closing
- only the variants which would be otherwise incomplete". Two potential
- consequences: (1) some types may be left open which were closed before,
- and the resulting type might not match the interface anymore (expected to
- be rare); (2) in some cases an incomplete match may be generated.
-- Lots of bug fixes in the handling of polymorphism and recursion inside
- types.
-- Added a new "-dtypes" option to ocamlc/ocamlopt, and an emacs extension
- "emacs/caml-types.el". The compiler option saves inferred type information
- to file *.annot, and the emacs extension allows the user to look at the
- type of any subexpression in the source file. Works even in the case
- of a type error (all the types computed up to the error are available).
- This new feature is also supported by ocamlbrowser.
-- Disable "method is overriden" warning when the method was explicitely
- redefined as virtual beforehand (i.e. not through inheritance). Typing
- and semantics are unchanged.
-
-Both compilers:
-- Added option "-dtypes" to dump detailed type information to a file.
-- The "-i" option no longer generates compiled files, it only prints
- the inferred types.
-- The sources for the module named "Mod" can be placed either in Mod.ml or
- in mod.ml.
-- Compilation of "let rec" on non-functional values: tightened some checks,
- relaxed some other checks.
-- Fixed wrong code that was generated for "for i = a to max_int"
- or "for i = a downto min_int".
-- An explicit interface Mod.mli can now be provided for the module obtained
- by ocamlc -pack -o Mod.cmo ... or ocamlopt -pack -o Mod.cmx ...
-- Revised internal handling of source code locations, now handles
- preprocessed code better.
-- Pattern-matching bug on float literals fixed.
-- Minor improvements on pattern-matching over variants.
-- More efficient compilation of string comparisons and the "compare" function.
-- More compact code generated for arrays of constants.
-- Fixed GC bug with mutable record fields of type "exn".
-- Added warning "E" for "fragile patterns": pattern matchings that would
- not be flagged as partial if new constructors were added to the data type.
-
-Bytecode compiler:
-- Added option -vmthread to select the threads library with VM-level
- scheduling. The -thread option now selects the system threads library.
-
-Native-code compiler:
-- New port: AMD64 (Opteron).
-- Fixed instruction selection bug on expressions of the kind (raise Exn)(arg).
-- Several bug fixes in ocamlopt -pack (tracking of imported modules,
- command line too long).
-- Signal handling bug fixed.
-- x86 port:
- Added -ffast-math option to use inline trigo and log functions.
- Small performance tweaks for the Pentium 4.
- Fixed illegal "imul" instruction generated by reloading phase.
-- Sparc port:
- Enhanced code generation for Sparc V8 (option -march=v8) and
- Sparc V9 (option -march=v9).
- Profiling support added for Solaris.
-- PowerPC port:
- Keep stack 16-aligned for compatibility with C calling conventions.
-
-Toplevel interactive system:
-- Tightened interface consistency checks between .cmi files, .cm[oa] files
- loaded by #load, and the running toplevel.
-- #trace on mutually-recursive functions was broken, works again.
-- Look for .ocamlinit file in home directory in addition to the current dir.
-
-Standard library:
-- Match_failure and Assert_failure exceptions now report
- (file, line, column), instead of (file, starting char, ending char).
-- float_of_string, int_of_string: some ill-formed input strings were not
- rejected.
-- Added format concatenation, string_of_format, format_of_string.
-- Module Arg: added new option handlers Set_string, Set_int, Set_float,
- Symbol, Tuple.
-- Module Format: tag handling is now turned off by default,
- use [Format.set_tags true] to activate.
-- Modules Lexing and Parsing: added better handling of positions
- in source file. Added function Lexing.flush_input.
-- Module Scanf: %n and %N formats to count characters / items read so far;
- assorted bug fixes, %! to match end of input. New ``_'' special
- flag to skip reresulting value.
-- Module Format: tags are not activated by default.
-- Modules Set and Map: fixed bugs causing trees to become unbalanced.
-- Module Printf: less restrictive typing of kprintf.
-- Module Random: better seeding; functions to generate random int32, int64,
- nativeint; added support for explicit state management.
-- Module Sys: added Sys.readdir for reading the contents of a directory.
-
-Runtime system:
-- output_value/input_value: fixed bug with large blocks (>= 4 Mwords)
- produced on a 64-bit platform and incorrectly read back on a 32-bit
- platform.
-- Fixed memory compaction bug involving input_value.
-- Added MacOS X support for dynamic linking of C libraries.
-- Improved stack backtraces on uncaught exceptions.
-- Fixed float alignment problem on Sparc V9 with gcc 3.2.
-
-Other libraries:
-- Dynlink:
- By default, dynamically-loaded code now has access to all
- modules defined by the program; new functions Dynlink.allow_only
- and Dynlink.prohibit implement access control.
- Fixed Dynlink problem with files generated with ocamlc -pack.
- Protect against references to modules not yet fully initialized.
-- LablTK/CamlTK: added support for TCL/TK 8.4.
-- Str: reimplemented regexp matching engine, now less buggy, faster,
- and LGPL instead of GPL.
-- Graphics: fixed draw_rect and fill_rect bug under X11.
-- System threads and bytecode threads libraries can be both installed.
-- System threads: better implementation of Thread.exit.
-- Bytecode threads: fixed two library initialization bugs.
-- Unix: make Unix.openfile blocking to account for named pipes;
- GC bug in Unix.*stat fixed; fixed problem with Unix.dup2 on Windows.
-
-Ocamllex:
-- Can name parts of the matched input text, e.g.
- "0" (['0'-'7']+ as s) { ... s ... }
-
-Ocamldebug:
-- Handle programs that run for more than 2^30 steps.
-
-Emacs mode:
-- Added file caml-types.el to interactively display the type information
- saved by option -dtypes.
-
-Win32 ports:
-- Cygwin port: recognize \ as directory separator in addition to /
-- MSVC port: ocamlopt -pack works provided GNU binutils are installed.
-- Graphics library: fixed bug in Graphics.blit_image; improved event handling.
-
-OCamldoc:
-- new ty_code field for types, to keep code of a type (with option -keep-code)
-- new ex_code field for types, to keep code of an exception
- (with option -keep-code)
-- some fixes in html generation
-- don't overwrite existing style.css file when generating HTML
-- create the ocamldoc.sty file when generating LaTeX (if nonexistent)
-- man pages are now installed in man/man3 rather than man/mano
-- fix: empty [] in generated HTML indexes
-
-
-Objective Caml 3.06:
---------------------
-
-Type-checking:
-- Apply value restriction to polymorphic record fields.
-
-Run-time system:
-- Fixed GC bug affecting lazy values.
-
-Both compilers:
-- Added option "-version" to print just the version number.
-- Fixed wrong dependencies in .cmi generated with the -pack option.
-
-Native-code compiler:
-- Fixed wrong return value for inline bigarray assignments.
-
-Libraries:
-- Unix.getsockopt: make sure result is a valid boolean.
-
-Tools:
-- ocamlbrowser: improved error reporting; small Win32 fixes.
-
-Windows ports:
-- Fixed two problems with the Mingw port under Cygwin 1.3.
-
-
-Objective Caml 3.05:
---------------------
-
-Language features:
-- Support for polymorphic methods and record fields.
-- Allows _ separators in integer and float literals, e.g. 1_000_000.
-
-Type-checker:
-- New flag -principal to enforce principality of type inference.
-- Fixed subtle typing bug with higher-order functors.
-- Fixed several complexity problems; changed (again) the behaviour of
- simple coercions.
-- Fixed various bugs with objects and polymorphic variants.
-- Improved some error messages.
-
-Both compilers:
-- Added option "-pack" to assemble several compilation units as one unit
- having the given units as sub-modules.
-- More precise detection of unused sub-patterns in "or" patterns.
-- Warnings for ill-formed \ escapes in string and character literals.
-- Protect against spaces and other special characters in directory names.
-- Added interface consistency check when building a .cma or .cmxa library.
-- Minor reduction in code size for class initialization code.
-- Added option "-nostdlib" to ignore standard library entirely.
-
-Bytecode compiler:
-- Fixed issue with ocamlc.opt and dynamic linking.
-
-Native-code compiler:
-- Added link-time check for multiply-defined module names.
-- Fixed GC bug related to constant constructors of polymorphic variant types.
-- Fixed compilation bug for top-level "include" statements.
-- PowerPC port: work around limited range for relative branches,
- thus removing assembler failures on large functions.
-- IA64 port: fixed code generation bug for 3-way constructor matching.
-
-Toplevel interactive system:
-- Can load object files given on command line before starting up.
-- ocamlmktop: minimized possibility of name clashes with user-provided modules.
-
-Run-time system:
-- Minor garbage collector no longer recursive.
-- Better support for lazy data in the garbage collector.
-- Fixed issues with the heap compactor.
-- Fixed issues with finalized Caml values.
-- The type "int64" is now supported on all platforms: we use software
- emulation if the C compiler doesn't support 64-bit integers.
-- Support for float formats that are neither big-endian nor little-endian
- (one known example: the ARM).
-- Fixed bug in callback*_exn functions in the exception-catching case.
-- Work around gcc 2.96 bug on RedHat 7.2 and Mandrake 8.0, 8.1 among others.
-- Stub DLLs now installed in subdir stublibs/ of standard library dir.
-
-Standard library:
-- Protect against integer overflow in sub-string and sub-array bound checks.
-- New module Complex implementing arithmetic over complex numbers.
-- New module Scanf implementing format-based scanning a la scanf() in C.
-- Module Arg: added alternate entry point Arg.parse_argv.
-- Modules Char, Int32, Int64, Nativeint, String: added type "t" and function
- "compare" so that these modules can be used directly with e.g. Set.Make.
-- Module Digest: fixed issue with Digest.file on large files (>= 1Gb);
- added Digest.to_hex.
-- Module Filename: added Filename.open_temp_file to atomically create and
- open the temp file; improved security of Filename.temp_file.
-- Module Genlex: allow _ as first character of an identifier.
-- Module Lazy: more efficient implementation.
-- Module Lexing: improved performances for very large tokens.
-- Module List: faster implementation of sorting functions.
-- Module Printf:
- added %S and %C formats (quoted, escaped strings and characters);
- added kprintf (calls user-specified continuation on formatted string).
-- Module Queue: faster implementation (courtesy of François Pottier).
-- Module Random: added Random.bool.
-- Module Stack: added Stack.is_empty.
-- Module Pervasives:
- added sub-module LargeFile to support files larger than 1Gb
- (file offsets are int64 rather than int);
- opening in "append" mode automatically sets "write" mode;
- files are now opened in close-on-exec mode;
- string_of_float distinguishes its output from a plain integer;
- faster implementation of input_line for long lines.
-- Module Sys:
- added Sys.ocaml_version containing the OCaml version number;
- added Sys.executable_name containing the (exact) path of the
- file being executable;
- Sys.argv.(0) is now unchanged w.r.t. what was provided as 0-th argument
- by the shell.
-- Module Weak: added weak hash tables.
-
-Other libraries:
-- Bigarray:
- support for bigarrays of complex numbers;
- added functions Genarray.dims,
- {Genarray,Array1,Array2,Array3}.{kind,layout}.
-- Dynlink: fixed bug with loading of mixed-mode Caml/C libraries.
-- LablTK:
- now supports also the CamlTK API (no labels);
- support for Activate and Deactivate events;
- support for virtual events;
- added UTF conversion;
- export the tcl interpreter as caml value, to avoid DLL dependencies.
-- Unix:
- added sub-module LargeFile to support files larger than 1Gb
- (file offsets are int64 rather than int);
- added POSIX opening flags (O_NOCTTY, O_*SYNC);
- use reentrant functions for gethostbyname and gethostbyaddr when available;
- fixed bug in Unix.close_process and Unix.close_process_full;
- removed some overhead in Unix.select.
-
-Tools:
-- ocamldoc (the documentation generator) is now part of the distribution.
-- Debugger: now supports the option -I +dir.
-- ocamllex: supports the same identifiers as ocamlc; warns for
- bad \ escapes in strings and characters.
-- ocamlbrowser:
- recenter the module boxes when showing a cross-reference;
- include the current directory in the ocaml path.
-
-Windows port:
-- Can now compile with Mingw (the GNU compilers without the Cygwin
- runtime library) in addition to MSVC.
-- Toplevel GUI: wrong filenames were given to #use and #load commands;
- read_line() was buggy for short lines (2 characters or less).
-- OCamlBrowser: now fully functional.
-- Graphics library: fixed several bugs in event handling.
-- Threads library: fixed preemption bug.
-- Unix library: better handling of the underlying differences between
- sockets and regular file descriptors;
- added Unix.lockf and a better Unix.rename (thanks to Tracy Camp).
-- LablTk library: fixed a bug in Fileinput
-
-
-Objective Caml 3.04:
---------------------
-
-Type-checker:
-- Allowed coercing self to the type of the current class, avoiding
- an obscure error message about "Self type cannot be unified..."
-
-Both compilers:
-- Use OCAMLLIB environment variable to find standard library, falls
- back on CAMLLIB if not defined.
-- Report out-of-range ASCII escapes in character or string literals
- such as "\256".
-
-Byte-code compiler:
-- The -use-runtime and -make-runtime flags are back by popular demand
- (same behavior as in 3.02).
-- Dynamic loading (of the C part of mixed Caml/C libraries): arrange that
- linking in -custom mode uses the static libraries for the C parts,
- not the shared libraries, for maximal robustness and compatibility with
- 3.02.
-
-Native-code compiler:
-- Fixed bug in link-time consistency checking.
-
-Tools:
-- ocamlyacc: added parser debugging support (set OCAMLRUNPARAM=p to get
- a trace of the pushdown automaton actions).
-- ocamlcp: was broken in 3.03 (Sys_error), fixed.
-
-Run-time system:
-- More work on dynamic loading of the C part of mixed Caml/C libraries.
-- On uncaught exception, flush output channels before printing exception
- message and backtrace.
-- Corrected several errors in exception backtraces.
-
-Standard library:
-- Pervasives: integer division and modulus are now fully specified
- on negative arguments (with round-towards-zero semantics).
-- Pervasives.float_of_string: now raises Failure on ill-formed input.
-- Pervasives: added useful float constants max_float, min_float, epsilon_float.
-- printf functions in Printf and Format: added % formats for int32, nativeint,
- int64; "*" in width and precision specifications now supported
- (contributed by Thorsten Ohl).
-- Added Hashtbl.copy, Stack.copy.
-- Hashtbl: revised resizing strategy to avoid quadratic behavior
- on Hashtbl.add.
-- New module MoreLabels providing labelized versions of modules
- Hashtbl, Map and Set.
-- Pervasives.output_value and Marshal.to_* : improved hashing strategy
- for internal data structures, avoid excessive slowness on
- quasi-linearly-allocated inputs.
-
-Other libraries:
-- Num: fixed bug in big integer exponentiation (Big_int.power_*).
-
-Windows port:
-- New GUI for interactive toplevel (Jacob Navia).
-- The Graphics library is now available for stand-alone executables
- (Jacob Navia).
-- Unix library: improved reporting of system error codes.
-- Fixed error in "globbing" of * and ? patterns on command line.
-
-Emacs mode: small fixes; special color highlighting for ocamldoc comments.
-
-License: added special exception to the LGPL'ed code (libraries and
- runtime system) allowing unrestricted linking, whether static or dynamic.
-
-
-Objective Caml 3.03 ALPHA:
---------------------------
-
-Language:
-- Removed built-in syntactic sugar for streams and stream patterns
- [< ... >], now supported via CamlP4, which is now included in the
- distribution.
-- Switched the default behaviour to labels mode (labels are compulsory),
- but allows omitting labels when a function application is complete.
- -nolabels mode is available but deprecated for programming.
- (See also scrapelabels and addlabels tools below.)
-- Removed all labels in the standard libraries, except labltk.
- Labelized versions are kept for ArrayLabels, ListLabels, StringLabels
- and UnixLabels. "open StdLabels" gives access to the first three.
-- Extended polymorphic variant type syntax, allowing union types and
- row abbreviations for both sub- and super-types. #t deprecated in types.
-- See the Upgrading file for how to adapt to all the changes above.
-
-Type-checker:
-- Fixed obscure bug in module typing causing the type-checker to loop
- on signatures of the form
- module type M
- module A: sig module type T = sig module T: M end end
- module B: A.T
-- Improved efficiency of module type-checking via lazy computation of
- certain signature summary information.
-- An empty polymorphic variant type is now an error.
-
-Both compilers:
-- Fixed wrong code generated for "struct include M ... end" when M
- contains one or several "external" declarations.
-
-Byte-code compiler:
-- Protect against VM stack overflow caused by module initialization code
- with many local variables.
-- Support for dynamic loading of the C part of mixed Caml/C libraries.
-- Removed the -use-runtime and -make-runtime flags, obsoleted by dynamic
- loading of C libraries.
-
-Native-code compiler:
-- Attempt to recover gracefully from system stack overflow. Currently
- works on x86 under Linux and BSD.
-- Alpha: work around "as" bug in Tru64 5.1.
-
-Toplevel environment:
-- Revised printing of inferred types and evaluation results
- so that an external printer (e.g. Camlp4's) can be hooked in.
-
-Tools:
-- The CamlP4 pre-processor-pretty-printer is now included in the standard
- distribution.
-- New tool ocamlmklib to help build mixed Caml/C libraries.
-- New tool scrapelabels and addlabels, to either remove (non-optional)
- labels in interfaces, or automatically add them in the definitions.
- They provide easy transition from classic mode ocaml 3.02 sources,
- depending on whether you want to keep labels or not.
-- ocamldep: added -pp option to handle preprocessed source files.
-
-Run-time system:
-- Support for dynamic loading of the C part of mixed Caml/C libraries.
- Currently works under Linux, FreeBSD, Windows, Tru64, Solaris and Irix.
-- Implemented registration of global C roots with a skip list,
- runs much faster when there are many global C roots.
-- Autoconfiguration script: fixed wrong detection of Mac OS X; problem
- with the Sparc, gcc 3.0, and float alignment fixed.
-
-Standard library:
-- Added Pervasives.flush_all to flush all opened output channels.
-
-Other libraries:
-- All libraries revised to allow dynamic loading of the C part.
-- Graphics under X Windows: revised event handling, should no longer lose
- mouse events between two calls to wait_next_event(); wait_next_event()
- now interruptible by signals.
-- Bigarrays: fixed bug in marshaling of big arrays.
-
-Windows port:
-- Fixed broken Unix.{get,set}sockopt*
-
-
-
-Objective Caml 3.02:
---------------------
-
-Both compilers:
-- Fixed embarrassing bug in pattern-matching compilation
- (affected or-patterns containing variable bindings).
-- More optimizations in pattern-matching compilation.
-
-Byte-code compiler:
-- Protect against VM stack overflow caused by functions with many local
- variables.
-
-Native-code compiler:
-- Removed re-sharing of string literals, causes too many surprises with
- in-place string modifications.
-- Corrected wrong compilation of toplevel "include" statements.
-- Fixed bug in runtime function "callbackN_exn".
-- Signal handlers receive the conventional signal number as argument
- instead of the system signal number (same behavior as with the
- bytecode compiler).
-- ARM port: fixed issue with immediate operand overflow in large functions.
-
-Toplevel environment:
-- User-definer printers (for #install_printer) now receive as first argument
- the pretty-printer formatter where to print their second argument.
- Old printers (with only one argument) still supported for backward
- compatibility.
-
-Standard library:
-- Module Hashtbl: added Hashtbl.fold.
-
-Other libraries:
-- Dynlink: better error reporting in add_interfaces for missing .cmi files.
-- Graphics: added more drawing functions (multiple points, polygons,
- multiple lines, splines).
-- Bytecode threads: the module Unix is now thread-safe, ThreadUnix is
- deprecated. Unix.exec* now resets standard descriptors to blocking mode.
-- Native threads: fixed a context-switch-during-GC problem causing
- certain C runtime functions to fail, most notably input_value.
-- Unix.inet_addr_of_string: call inet_aton() when available so as to
- handle correctly the address 255.255.255.255.
-- Unix: added more getsockopt and setsockopt functions to get/set
- options that have values other than booleans.
-- Num: added documentation for the Big_int module.
-
-Tools:
-- ocamldep: fixed wrong dependency issue with nested modules.
-
-Run-time system:
-- Removed floating-point error at start-up on some non-IEEE platforms
- (e.g. FreeBSD prior to 4.0R).
-- Stack backtrace mechanism now works for threads that terminate on
- an uncaught exception.
-
-Auto-configuration:
-- Updated config.guess and config.sub scripts, should recognize a greater
- number of recent platform.
-
-Windows port:
-- Fixed broken Unix.waitpid. Unix.file_descr can now be compared or hashed.
-- Toplevel application: issue with spaces in name of stdlib directory fixed.
-
-MacOS 9 port:
-- Removed the last traces of support for 68k
-
-
-Objective Caml 3.01:
---------------------
-
-New language features:
-- Variables are allowed in "or" patterns, e.g.
- match l with [t] | [_;t] -> ... t ...
-- "include <structure expression>" 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 +<subdir> to search a subdirectory <subdir> 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 = <big list>;; let x = 1;;" allows <big list> to be reclaimed.)
-- Revised the tracing facility so that for standard library functions,
- only calls from user code are traced, not calls from the system.
-- Added a "*" prompt when within a comment.
-
-Runtime system:
-- Fixed portability issue on bcopy() vs memmove(), affecting Linux RedHat 7.0
- in particular.
-- Structural comparisons (=, <>, <, <=, >, >=, compare) reimplemented
- so as to avoid overflowing the C stack.
-- Input/output functions: arrange so that reads and writes on closed
- in_channel or out_channel raise Sys_error immediately.
-
-Standard library:
-- Module Gc: changed some counters to float in order to avoid overflow;
- added alarms
-- Module Hashtbl: added Hashtbl.replace.
-- Module Int64: added bits_of_float, float_of_bits (access to IEEE 754
- representation of floats).
-- Module List: List.partition now tail-rec;
- improved memory behavior of List.stable_sort.
-- Module Nativeint: added Nativeint.size (number of bits in a nativeint).
-- Module Obj: fixed incorrect resizing of float arrays in Obj.resize.
-- Module Pervasives: added float constants "infinity", "neg_infinity", "nan";
- added a "classify_float" function to test a float for NaN, infinity, etc.
-- Pervasives.input_value: fixed bug affecting shared custom objects.
-- Pervasives.output_value: fixed size bug affecting "int64" values.
-- Pervasives.int_of_string, {Int32,Int64,Nativeint}.of_string:
- fixed bug causing bad digits to be accepted without error.
-- Module Random: added get_state and set_state to checkpoint the generator.
-- Module Sys: signal handling functions are passed the system-independent
- signal number rather than the raw system signal number whenever possible.
-- Module Weak: added Weak.get_copy.
-
-Other libraries:
-- Bigarray: added Bigarray.reshape to take a view of the elements of a
- bigarray with different dimensions or number of dimensions;
- fixed bug causing "get" operations to be unavailable in custom
- toplevels including Bigarray.
-- Dynlink: raise an error instead of crashing when the loaded module
- refers to the not-yet-initialized module performing a dynlink operation.
-- Bytecode threads: added a thread-safe version of the Marshal module;
- fixed a rare GC bug in the thread scheduler.
-- POSIX threads: fixed compilation problem with threads.cmxa.
-- Both thread libraries: better tail-recursion in Event.sync.
-- Num library: fixed bug in square roots (Nat.sqrt_nat, Big_int.sqrt_big_int).
-
-Tools:
-- ocamldep: fixed missing dependencies on labels of record patterns and
- record construction operations
-
-Win32 port:
-- Unix.waitpid now implements the WNOHANG option.
-
-Mac OS ports:
-- Mac OS X public beta is supported.
-- Int64.format works on Mac OS 8/9.
-
-
-Objective Caml 3.00:
---------------------
-
-Language:
-- OCaml/OLabl merger:
- * Support for labeled and optional arguments for functions and classes.
- * Support for variant types (sum types compared by structure).
- See tutorial (chapter 2 of the OCaml manual) for more information.
-- Syntactic change: "?" in stream error handlers changed to "??".
-- Added exception renaming in structures (exception E = F).
-- (OCaml 2.99/OLabl users only) Label syntax changed to preserve
- backward compatibility with 2.0x (labeled function application
- is f ~lbl:arg instead of f lbl:arg). A tool is provided to help
- convert labelized programs to OCaml 3.00.
-
-Both compilers:
-- Option -labels to select commuting label mode (labels are mandatory,
- but labeled arguments can be passed in a different order than in
- the definition of the function; in default mode, labels may be omitted,
- but argument reordering is only allowed for optional arguments).
-- Libraries (.cma and .cmxa files) now "remember" C libraries given
- at library construction time, and add them back at link time.
- Allows linking with e.g. just unix.cma instead of
- unix.cma -custom -cclib -lunix
-- Revised printing of error messages, now use Format.fprintf; no visible
- difference for users, but could facilitate internationalization later.
-- Fixed bug in unboxing of records containing only floats.
-- Fixed typing bug involving applicative functors as components of modules.
-- Better error message for inconsistencies between compiled interfaces.
-
-Bytecode compiler:
-- New "modular" format for bytecode executables; no visible differences
- for users, but will facilitate further extensions later.
-- Fixed problems in signal handling.
-
-Native-code compiler:
-- Profiling support on x86 under FreeBSD
-- Open-coding and unboxing optimizations for the new integer types
- int32, int64, nativeint, and for bigarrays.
-- Fixed instruction selection bug with "raise" appearing in arguments
- of strict operators, e.g. "1 + raise E".
-- Better error message when linking incomplete/incorrectly ordered set
- of .cmx files.
-- Optimized scanning of global roots during GC, can reduce total running
- time by up to 8% on GC-intensive programs.
-
-Interactive toplevel:
-- Better printing of exceptions, including arguments, when possible.
-- Fixed rare GC bug occurring during interpretation of scripts.
-- Added consistency checks between interfaces and implementations
- during #load.
-
-Run-time system:
-- Added support for "custom" heap blocks (heap blocks carrying
- C functions for finalization, comparison, hashing, serialization
- and deserialization).
-- Support for finalisation functions written in Caml.
-
-Standard library:
-- New modules Int32, Int64, Nativeint for 32-bit, 64-bit and
- platform-native integers
-- Module Array: added Array.sort, Array.stable_sort.
-- Module Gc: added Gc.finalise to attach Caml finalisation functions to
- arbitrary heap-allocated data.
-- Module Hashtbl: do not bomb when resizing very large table.
-- Module Lazy: raise Lazy.Undefined when a lazy evaluation needs itself.
-- Module List: added List.sort, List.stable_sort; fixed bug in List.rev_map2.
-- Module Map: added mapi (iteration with key and data).
-- Module Set: added iterators for_all, exists, filter, partition.
-- Module Sort: still here but deprecated in favor of new sorting functions
- in Array and List.
-- Module Stack: added Stack.top
-- Module String: fixed boundary condition on String.rindex_from
-- Added labels on function arguments where appropriate.
-
-New libraries and tools:
-- ocamlbrowser: graphical browser for OCaml sources and compiled interfaces,
- supports cross-referencing, editing, running the toplevel.
-- LablTK: GUI toolkit based on TK, using labeled and optional arguments,
- easier to use than CamlTK.
-- Bigarray: large, multi-dimensional numerical arrays, facilitate
- interfacing with C/Fortran numerical code, efficient support for
- advanced array operations such as slicing and memory-mapping of files.
-
-Other libraries:
-- Bytecode threads: timer-based preemption was broken, works back again;
- fixed bug in Pervasives.input_line; exported Thread.yield.
-- System threads: several GC / reentrancy bugs fixed in buffered I/O
- and Unix I/O; revised Thread.join implementation for strict POSIX
- conformance; exported Thread.yield.
-- Graphics: added support for double buffering; added, current_x, current_y,
- rmoveto, rlineto, and draw_rect.
-- Num: fixed bug in Num.float_of_num.
-- Str: worked around potential symbol conflicts with C standard library.
-- Dbm: fixed bug with Dbm.iter on empty database.
-
-New or updated ports:
-- Alpha/Digital Unix: lifted 256M limitation on total memory space
- induced by -taso
-- Port to AIX 4.3 on PowerPC
-- Port to HPUX 10 on HPPA
-- Deprecated 680x0 / SunOS port
-
-Macintosh port:
-- Implemented the Unix and Thread libraries.
-- The toplevel application does not work on 68k Macintoshes; maybe
- later if there's a demand.
-- Added a new tool, ocamlmkappli, to build an application from a
- program written in O'Caml.
-
-
-Objective Caml 2.04:
---------------------
-
-- C interface: corrected inconsistent change in the CAMLparam* macros.
-- Fixed internal error in ocamlc -g.
-- Fixed type-checking of "S with ...", where S is a module type name
- abbreviating another module type name.
-- ocamldep: fixed stdout/stderr mismatch after failing on one file.
-- Random.self_init more random.
-- Windows port:
- - Toplevel application: fixed spurious crash on exit.
- - Native-code compiler: fixed bug in assembling certain
- floating-point constants (masm doesn't grok 2e5, wants 2.0e5).
-
-Objective Caml 2.03:
---------------------
-
-New ports:
-- Ported to BeOS / Intel x86 (bytecode and native-code).
-- BSD / Intel x86 port now supports both a.out and ELF binary formats.
-- Added support for {Net,Open}BSD / Alpha.
-- Revamped Rhapsody port, now works on MacOS X server.
-
-Syntax:
-- Warning for "(*)" and "*)" outside comment.
-- Removed "#line LINENO", too ambiguous with a method invocation;
- the equivalent "# LINENO" is still supported.
-
-Typing:
-- When an incomplete pattern-matching is detected, report also a
- value or value template that is not covered by the cases of
- the pattern-matching.
-- Several bugs in class type matching and in type error reporting fixed.
-- Added an option -rectypes to support general recursive types,
- not just those involving object types.
-
-Bytecode compiler:
-- Minor cleanups in the bytecode emitter.
-- Do not remove "let x = y" bindings in -g mode; makes it easier to
- debug the code.
-
-Native-code compiler:
-- Fixed bug in grouping of allocations performed in the same basic block.
-- Fixed bug in constant propagation involving expressions containing
- side-effects.
-- Fixed incorrect code generation for "for" loops whose upper bound is
- a reference assigned inside the loop.
-- MIPS code generator: work around a bug in the IRIX 6 assembler.
-
-Toplevel:
-- Fixed incorrect redirection of standard formatter to stderr
- while executing toplevel scripts.
-
-Standard library:
-- Added List.rev_map, List.rev_map2.
-- Documentation of List functions now says which functions are
- tail-rec, and how much stack space is needed for non-tailrec functions.
-- Wrong type for Printf.bprintf fixed.
-- Fixed weird behavior of Printf.sprintf and Printf.bprintf in case of
- partial applications.
-- Added Random.self_init, which initializes the PRNG from the system date.
-- Sort.array: serious bugs fixed.
-- Stream.count: fixed incorrect behavior with ocamlopt.
-
-Run-time system and external interface:
-- Fixed weird behavior of signal handlers w.r.t. signal masks and exceptions
- raised from the signal handler.
-- Fixed bug in the callback*_exn() functions.
-
-Debugger:
-- Fixed wrong printing of float record fields and elements of float arrays.
-- Supports identifiers starting with '_'.
-
-Profiler:
-- Handles .mli files, so ocamlcp can be used to replace ocamlc (e.g. in a
- makefile).
-- Now works on programs that use stream expressions and stream parsers.
-
-Other libraries:
-- Graphics: under X11, treat all mouse buttons equally; fixed problem
- with current font reverting to the default font when the graphics
- window is resized.
-- Str: fixed reentrancy bugs in Str.replace and Str.full_split.
-- Bytecode threads: set standard I/O descriptors to non-blocking mode.
-- OS threads: revised implementation of Thread.wait_signal.
-- All threads: added Event.wrap_abort, Event.choose [].
-- Unix.localtime, Unix.gmtime: check for errors.
-- Unix.create_process: now supports arbitrary redirections of std descriptors.
-- Added Unix.open_process_full.
-- Implemented Unix.chmod under Windows.
-- Big_int.square_big_int now gives the proper sign to its result.
-
-Others:
-- ocamldep: don't stop at first error, skip to next file.
-- Emacs mode: updated with Garrigue and Zimmerman's snapshot of 1999/10/18.
-- configure script: added -prefix option.
-- Windows toplevel application: fixed problem with graphics library
- not loading properly.
-
-
-Objective Caml 2.02:
---------------------
-
-* Type system:
- - Check that all components of a signature have unique names.
- - Fixed bug in signature matching involving a type component and
- a module component, both sharing an abstract type.
- - Bug involving recursive classes constrained by a class type fixed.
- - Fixed bugs in printing class types and in printing unification errors.
-
-* Compilation:
- - Changed compilation scheme for "{r with lbl = e}" when r has many fields
- so as to avoid code size explosion.
-
-* Native-code compiler:
- - Better constant propagation in boolean expressions and in conditionals.
- - Removal of unused arguments during function inlining.
- - Eliminated redundant tagging/untagging in bit shifts.
- - Static allocation of closures for functions without free variables,
- reduces the size of initialization code.
- - Revised compilation scheme for definitions at top level of compilation
- units, so that top level functions have no free variables.
- - Coalesced multiple allocations of heap blocks inside one expression
- (e.g. x :: y :: z allocates the two conses in one step).
- - Ix86: better handling of large integer constants in instruction selection.
- - MIPS: fixed wrong asm generated for String.length "literal".
-
-* Standard library:
- - Added the "ignore" primitive function, which just throws away its
- argument and returns "()". It allows to write
- "ignore(f x); y" if "f x" doesn't have type unit and you don't
- want the warning caused by "f x; y".
- - Added the "Buffer" module (extensible string buffers).
- - Module Format: added formatting to buffers and to strings.
- - Added "mem" functions (membership test) to Hashtbl and Map.
- - Module List: added find, filter, partition.
- Renamed remove and removeq to remove_assoc and remove_assq.
- - Module Marshal: fixed bug in marshaling functions when passed functional
- values defined by mutual recursion with other functions.
- - Module Printf: added Printf.bprintf (print to extensible buffer);
- added %i format as synonymous for %d (as per the docs).
- - Module Sort: added Sort.array (Quicksort).
-
-* Runtime system:
- - New callback functions for callbacks with arbitrary many arguments
- and for catching Caml exceptions escaping from a callback.
-
-* The ocamldep dependency generator: now performs full parsing of the
- sources, taking into account the scope of module bindings.
-
-* The ocamlyacc parser generator: fixed sentinel error causing wrong
- tables to be generated in some cases.
-
-* The str library:
- - Added split_delim, full_split as variants of split that control
- more precisely what happens to delimiters.
- - Added replace_matched for separate matching and replacement operations.
-
-* The graphics library:
- - Bypass color lookup for 16 bpp and 32 bpp direct-color displays.
- - Larger color cache.
-
-* The thread library:
- - Bytecode threads: more clever use of non-blocking I/O, makes I/O
- operations faster.
- - POSIX threads: gcc-ism removed, should now compile on any ANSI C compiler.
- - Both: avoid memory leak in the Event module when a communication
- offer is never selected.
-
-* The Unix library:
- - Fixed inversion of ctime and mtime in Unix.stat, Unix.fstat, Unix.lstat.
- - Unix.establish_connection: properly reclaim socket if connect fails.
-
-* The DBM library: no longer crashes when calling Dbm.close twice.
-
-* Emacs mode:
- - Updated with Garrigue and Zimmerman's latest version.
- - Now include an "ocamltags" script for using etags on OCaml sources.
-
-* Win32 port:
- - Fixed end-of-line bug in ocamlcp causing problems with generated sources.
-
-
-Objective Caml 2.01:
---------------------
-
-* Typing:
- - Added warning for expressions of the form "a; b" where a does not have
- type "unit"; catches silly mistake such as
- "record.lbl = newval; ..." instead of "record.lbl <- newval; ...".
- - Typing bug in "let module" fixed.
-
-* Compilation:
- - Fixed bug in compilation of recursive and mutually recursive classes.
- - Option -w to turn specific warnings on/off.
- - Option -cc to choose the C compiler used with ocamlc -custom and ocamlopt.
-
-* Bytecode compiler and bytecode interpreter:
- - Intel x86: removed asm declaration causing "fixed or forbidden register
- spilled" error with egcs and gcc 2.8 (but not with gcc 2.7, go figure).
- - Revised handling of debugging information, allows faster linking with -g.
-
-* Native-code compiler:
- - Fixed bugs in integer constant propagation.
- - Out-of-bound accesses in array and strings now raise an Invalid_argument
- exception (like the bytecode system) instead of stopping the program.
- - Corrected scheduling of bound checks.
- - Port to the StrongARM under Linux (e.g. Corel Netwinder).
- - I386: fixed bug in profiled code (ocamlopt -p).
- - Mips: switched to -n32 model under IRIX; dropped the Ultrix port.
- - Sparc: simplified the addressing modes, allows for better scheduling.
- - Fixed calling convention bug for Pervasives.modf.
-
-* Toplevel:
- - #trace works again.
- - ocamlmktop: use matching ocamlc, not any ocamlc from the search path.
-
-* Memory management:
- - Fixed bug in heap expansion that could cause the GC to loop.
-
-* C interface:
- - New macros CAMLparam... and CAMLlocal... to simplify the handling
- of local roots in C code.
- - Simplified procedure for allocating and filling Caml blocks from C.
- - Declaration of string_length in <caml/mlvalues.h>.
-
-* Standard library:
- - Module Format: added {get,set}_all_formatter_output_functions,
- formatter_of_out_channel, and the control sequence @<n> in printf.
- - Module List: added mem_assoc, mem_assq, remove, removeq.
- - Module Pervasives: added float_of_int (synonymous for float),
- int_of_float (truncate), int_of_char (Char.code), char_of_int (Char.chr),
- bool_of_string.
- - Module String: added contains, contains_from, rcontains_from.
-
-* Unix library:
- - Unix.lockf: added F_RLOCK, F_TRLOCK; use POSIX locks whenever available.
- - Unix.tc{get,set}attr: added non-standard speeds 57600, 115200, 230400.
- - Unix.chroot: added.
-
-* Threads:
- - Bytecode threads: improved speed of I/O scheduling.
- - Native threads: fixed a bug involving signals and exceptions
- generated from C.
-
-* The "str" library:
- - Added Str.string_partial_match.
- - Bumped size of internal stack.
-
-* ocamlyacc: emit correct '# lineno' directive for prelude part of .mly file.
-
-* Emacs editing mode: updated with Jacques Garrigue's newest code.
-
-* Windows port:
- - Added support for the "-cclib -lfoo" option (instead of
- -cclib /full/path/libfoo.lib as before).
- - Threads: fixed a bug at initialization time.
-
-* Macintosh port: source code for Macintosh application merged in.
-
-
-Objective Caml 2.00:
---------------------
-
-* Language:
- - New class language. See http://caml.inria.fr/ocaml/refman/
- for a tutorial (chapter 2) and for the reference manual (section 4.9).
- - Local module definitions "let module X = <module-expr> in <expr>".
- - 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 <id> = <regexp>" to name regular expressions
- (inspired by Christian Lindig's patch).
-
-* ocamlyacc:
- - Better error recovery in presence of EOF tokens.
- - Error messages in generated .ml file now point to .mly source.
- - Generated .ml file now type-safe even without the generated .mli file.
-
-* The Unix library:
- - Use float instead of int to represent Unix times (number of seconds
- from the epoch). This fixes a year 2005 problem on 32-bit platforms.
- Functions affected: stat, lstat, fstat, time, gmtime, localtime,
- mktime, utimes.
- - Added putenv.
- - Better handling of "unknown" error codes (EUNKNOWNERR).
- - Fixed endianness bug in getservbyport.
- - win32unix (the Win32 implementation of the Unix library) now has
- the same interface as the unix implementation, this allows exchange
- of compiled .cmo and .cmi files between Unix and Win32.
-
-* The thread libraries:
- - Bytecode threads: bug with escaping exceptions fixed.
- - System threads (POSIX, Win32): malloc/free bug fixed; signal bug fixed.
- - Both: added Thread.wait_signal to wait synchronously for signals.
-
-* The graph library: bigger color cache.
-
-* The str library: added Str.quote, Str.regexp_string,
- Str.regexp_string_case_fold.
-
-* Emacs mode:
- - Fixed bug with paragraph fill.
- - Fixed bug with next-error under Emacs 20.
-
-
-Objective Caml 1.07:
---------------------
-
-* Native-code compiler:
- - Revised interface between generated code and GC, fixes serious GC
- problems with signals and native threads.
- - Added "-thread" option for compatibility with ocamlc.
-
-* Debugger: correctly print instance variables of objects.
-
-* Run-time system: ported to OpenBSD.
-
-* Standard library: fixed wrong interface for Marshal.to_buffer and
- Obj.unmarshal.
-
-* Num library: added Intel x86 optimized asm code (courtesy of
- Bernard Serpette).
-
-* Thread libraries:
- - Native threads: fixed GC bugs and installation procedure.
- - Bytecode threads: fixed problem with "Marshal" module.
- - Both: added Event.always.
-
-* MS Windows port: better handling of long command lines in Sys.command
-
-Objective Caml 1.06:
---------------------
-
-* Language:
- - Added two new keywords: "assert" (check assertion) and "lazy"
- (delay evaluation).
- - Allow identifiers to start with "_" (such identifiers are treated
- as lowercase idents).
-
-* Objects:
- - Added "protected" methods (visible only from subclasses, can be hidden
- in class type declared in module signature).
- - Objects can be compared using generic comparison functions.
- - Fixed compilation of partial application of object constructors.
-
-* Type system:
- - Occur-check now more strict (all recursions must traverse an object).
- - A few bugs fixed.
-
-* Run-time system:
- - A heap compactor was implemented, so long-running programs can now
- fight fragmentation.
- - The meaning of the "space_overhead" parameter has changed.
- - The macros Push_roots and Pop_roots are superseded by Begin_roots* and
- End_roots.
- - Bytecode executable includes list of primitives used, avoids crashes
- on version mismatch.
- - Reduced startup overhead for marshalling, much faster marshalling of
- small objects.
- - New exception Stack_overflow distinct from Out_of_memory.
- - Maximum stack size configurable.
- - I/O revised for compatibility with compactor and with native threads.
- - All C code ANSIfied (new-style function declarations, etc).
- - Threaded code work on all 64-bit processors, not just Alpha/Digital Unix.
- - Better printing of uncaught exceptions.
-
-* Both compilers:
- - Parsing: more detailed reporting of syntax errors (e.g. shows
- unmatched opening parenthesis on missing closing parenthesis).
- - Check consistency between interfaces (.cmi).
- - Revised rules for determining dependencies between modules.
- - Options "-verbose" for printing calls to C compiler, "-noassert"
- for turning assertion checks off.
-
-* Native-code compiler:
- - Machine-dependent parts rewritten using inheritance instead of
- parameterized modules.
- - GC bug in value let rec fixed.
- - Port to Linux/Alpha.
- - Sparc: cleaned up use of %g registers, now compatible with Solaris threads.
-
-* Top-level interactive system:
- - Can execute Caml script files given on command line.
- - Reads commands from ./.ocamlinit on startup.
- - Now thread-compatible.
-
-* Standard library:
- - New library module: Lazy (delayed computations).
- - New library module: Marshal. Allows marshalling to strings and
- transmission of closures between identical programs (SPMD parallelism).
- - Filename: "is_absolute" is superseded by "is_implicit" and "is_relative".
- To adapt old programs, change "is_absolute x" to "not (is_implicit x)"
- (but the new "is_relative" is NOT the opposite of the old "is_absolute").
- - Array, Hashtbl, List, Map, Queue, Set, Stack, Stream:
- the "iter" functions now take as argument a unit-returning function.
- - Format: added "printf" interface to the formatter (see the documentation).
- Revised behaviour of simple boxes: no more than one new line is output
- when consecutive break hints should lead to multiple line breaks.
- - Stream: revised implementation, renamed Parse_failure to Failure and
- Parse_error to Error (don't you love gratuitous changes?).
- - String: added index, rindex, index_from, rindex_from.
- - Array: added mapi, iteri, fold_left, fold_right, init.
- - Added Map.map, Set.subset, Printexc.to_string.
-
-* ocamllex: lexers generated by ocamllex can now handle all characters,
- including '\000'.
-
-* ocamlyacc: fixed bug with function closures returned by parser rules.
-
-* Debugger:
- - Revised generation of events.
- - Break on function entrance.
- - New commands start/previous.
- - The command loadprinter now try to recursively load required
- modules.
- - Numerous small fixes.
-
-* External libraries:
- - systhreads: can now use POSIX threads; POSIX and Win32 threads are
- now supported by the native-code compiler.
- - dbm and graph: work in native code.
- - num: fixed bug in Nat.nat_of_string.
- - str: fixed deallocation bug with case folding.
- - win32unix: use Win32 handles instead of (buggy) VC++ emulation of Unix
- file handles; added gettimeofday.
-
-* Emacs editing mode and debugger interface updated to July '97 version.
-
-Objective Caml 1.05:
---------------------
-
-* Typing: fixed several bugs causing spurious type errors.
-
-* Native-code compiler: fixed instruction selection bug causing GC to
-see ill-formed pointers; fixed callbacks to support invocation from a
-main program in C.
-
-* Standard library: fixed String.lowercase; Weak now resists integers.
-
-* Toplevel: multiple phrases without intermediate ";;" now really supported;
-fixed value printing problems where the wrong printer was selected.
-
-* Debugger: fixed printing problem with local references; revised
-handling of checkpoints; various other small fixes.
-
-* Macintosh port: fixed signed division problem in bytecomp/emitcode.ml
-
-Objective Caml 1.04:
---------------------
-
-* Replay debugger ported from Caml Light; added debugger support in
- compiler (option -g) and runtime system. Debugger is alpha-quality
- and needs testing.
-
-* Parsing:
- - Support for "# linenum" directives.
- - At toplevel, allow several phrases without intermediate ";;".
-
-* Typing:
- - Allow constraints on datatype parameters, e.g.
- type 'a foo = ... constraint 'a = 'b * 'c.
- - Fixed bug in signature matching in presence of free type variables '_a.
- - Extensive cleanup of internals of type inference.
-
-* Native-code compilation:
- - Inlining of small functions at point of call (fairly conservative).
- - MIPS code generator ported to SGI IRIX 6.
- - Better code generated for large integer constants.
- - Check for urgent GC when allocating large objects in major heap.
- - PowerPC port: better scheduling, reduced TOC consumption.
- - HPPA port: handle long conditional branches gracefully,
- several span-dependent bugs fixed.
-
-* Standard library:
- - More floating-point functions (all ANSI C float functions now available).
- - Hashtbl: added functorial interface (allow providing own equality
- and hash functions); rehash when resizing, avoid memory leak on
- Hashtbl.remove.
- - Added Char.uppercase, Char.lowercase, String.uppercase, String.lowercase,
- String.capitalize, String.uncapitalize.
- - New module Weak for manipulating weak pointers.
- - New module Callback for registering closures and exceptions to be
- used from C.
-
-* Foreign interface:
- - Better support for callbacks (C calling Caml), exception raising
- from C, and main() in C. Added function to remove a global root.
- - Option -output-obj to package Caml code as a C library.
-
-* Thread library: fixed bug in timed_read and timed_write operations;
- Lexing.from_function and Lexing.from_channel now reentrant.
-
-* Unix interface: renamed EACCESS to EACCES (the POSIX name); added setsid;
- fixed bug in inet_addr_of_string for 64-bit platforms.
-
-* Ocamlyacc: default error function no longer prevents error recovery.
-
-* Ocamllex: fixed reentrancy problem w.r.t. exceptions during refill;
- fixed output problem (\r\r\n) under Win32.
-
-* Macintosh port:
- - The makefiles are provided for compiling and installing O'Caml on
- a Macintosh with MPW 3.4.1.
- - An application with the toplevel in a window is forthcoming.
-
-* Windows NT/95 port: updated toplevel GUI to that of Caml Light 0.73.
-
-* Emacs editing mode and debugger interface included in distribution.
-
-
-Objective Caml 1.03:
---------------------
-
-* Typing:
- - bug with type names escaping their scope via unification with
- non-generalized type variables '_a completely fixed;
- - fixed bug in occur check : it was too restrictive;
- - fixed bug of coercion operators;
- - check that no two types of the same name are generated in a module
- (there was no check for classes);
- - "#install_printer" works again;
- - fixed bug in printing of subtyping errors;
- - in class interfaces, construct "method m" (without type) change
- the status of method m from abstract to concrete;
- - in a recursive definition of class interfaces, a class can now
- inherit from a previous class;
- - typing of a method make use of an eventual previously given type
- of this method, yielding clearer type errors.
-
-* Compilation (ocamlc and ocamlopt):
- - fixed bug in compilation of classes.
-
-* Native-code compilation:
- - optimization of functions taking tuples of arguments;
- - code emitter for the Motorola 680x0 processors (retrocomputing week);
- - Alpha/OSF1: generate frame descriptors, avoids crashes when e.g.
- exp() or log() cause a domain error; fixed bug with
- String.length "literal";
- - Sparc, Mips, HPPA: removed marking of scanned stack frames
- (benefits do not outweight cost).
-
-* Standard library:
- - Arg.parse now prints documentation for command-line options;
- - I/O buffers (types in_channel and out_channel) now heap-allocated,
- avoids crashing when closing a channel several times;
- - Overflow bug in compare() fixed;
- - GC bug in raising Sys_error from I/O functions fixed;
- - Parsing.symbol_start works even for epsilon productions.
-
-* Foreign interface: main() in C now working, fixed bug in library
- order at link time.
-
-* Thread library: guard against calling thread functions before Thread.create.
-
-* Unix library: fixed getsockopt, setsockopt, open_process_{in,out}.
-
-* Perl-free, cpp-free, cholesterol-free installation procedure.
-
-
-Objective Caml 1.02:
---------------------
-* Typing:
- - fixed bug with type names escaping their scope via unification
- with non-generalized type variables '_a;
- - keep #class abbreviations longer;
- - faster checking of well-formed abbreviation definitions;
- - stricter checking of "with" constraints over signatures (arity
- mismatch, overriding of an already manifest type).
-
-* Compilation (ocamlc and ocamlopt):
- - fixed bug in compilation of recursive classes;
- - [|...|] and let...rec... allowed inside definitions of recursive
- data structures;
-
-* Bytecode compilation: fixed overflow in linker for programs with
- more than 65535 globals and constants.
-
-* Native-code compilation:
- - ocamlopt ported to HPPA under HP/UX, Intel x86 under Solaris 2,
- PowerMacintosh under MkLinux;
- - fixed two bugs related to floating-point arrays (one with "t array"
- where t is an abstract type implemented as float, one with
- comparison between two float arrays on 32 bit platforms);
- - fixed reloading/spilling problem causing non-termination of
- register allocation;
- - fixed bugs in handling of () causing loss of tail recursion;
- - fixed reloading bug in indirect calls.
-
-* Windows NT/95 port:
- - complete port of the threads library (Pascal Cuoq);
- - partial port of the Unix library (Pascal Cuoq);
- - expansion of *, ? and @ on the command line.
-
-* Standard library:
- - bug in in List.exists2 fixed;
- - bug in "Random.int n" for very large n on 64-bit machines fixed;
- - module Format: added a "general purpose" type of box (open_box);
- can output on several formatters at the same time.
-
-* The "threads" library:
- - implementation on top of native threads available for Win32 and
- POSIX 1003.1c;
- - added -thread option to select a thread-safe version of the
- standard library, the ThreadIO module is no longer needed.
-
-* The "graph" library: avoid invalid pixmaps when doing
- open_graph/close_graph several times.
-
-* The "dynlink" library: support for "private" (no re-export) dynamic loading.
-
-* ocamlyacc: skip '...' character literals correctly.
-
-* C interface: C code linked with O'Caml code can provide its own main()
- and call caml_main() later.
-
-
-Objective Caml 1.01:
---------------------
-* Typing: better report of type incompatibilities;
- non-generalizable type variables in a struct...end no longer flagged
- immediately as an error;
- name clashes during "open" avoided.
-
-* Fixed bug in output_value where identical data structures
- could have different external representations; this bug caused wrong
- "inconsistent assumptions" errors when checking compatibility of
- interfaces at link-time.
-
-* Standard library: fixed bug in Array.blit on overlapping array sections
-
-* Unmarshaling from strings now working.
-
-* ocamlc, ocamlopt: new flags -intf and -impl to force compilation as
- an implementation/an interface, regardless of file extension;
- overflow bug on wide-range integer pattern-matchings fixed.
-
-* ocamlc: fixed bytecode generation bug causing problems with compilation
- units defining more than 256 values
-
-* ocamlopt, all platforms:
- fixed GC bug in "let rec" over data structures;
- link startup file first, fixes "undefined symbol" errors with some
- libraries.
-
-* ocamlopt, Intel x86:
- more efficient calling sequence for calling C functions;
- floating-point wars, chapter 5: don't use float stack for holding
- float pseudo-registers, stack-allocating them is just as efficient.
-
-* ocamlopt, Alpha and Intel x86: more compact calling sequence for garbage
- collection.
-
-* ocamllex: generated automata no longer use callbacks for refilling
- the input buffer (works better with threads); character literals
- correctly skipped inside actions.
-
-* ocamldep: "-I" directories now searched in the right order
-
-* Thread library: incompatibilities with callbacks, signals, and
- dynamic linking removed; scheduling bug with Thread.wait fixed.
-
-* New "dbm" library, interfaces with NDBM.
-
-* Object-oriented extensions:
- instance variables can now be omitted in class types;
- some error messages have been made clearer;
- several bugs fixes.
-
-Objective Caml 1.00:
---------------------
-
-* Merge of Jerome Vouillon and Didier Remy's object-oriented
-extensions.
-
-* All libraries: all "new" functions renamed to "create" because "new"
-is now a reserved keyword.
-
-* Compilation of "or" patterns (pat1 | pat2) completely revised to
-avoid code size explosion.
-
-* Compiler support for preprocessing source files (-pp flag).
-
-* Library construction: flag -linkall to force linking of all units in
-a library.
-
-* Native-code compiler: port to the Sparc under NetBSD.
-
-* Toplevel: fixed bug when tracing several times the same function
-under different names.
-
-* New format for marshaling arbitrary data structures, allows
-marshaling to/from strings.
-
-* Standard library: new module Genlex (configurable lexer for streams)
-
-* Thread library: much better support for I/O and blocking system calls.
-
-* Graphics library: faster reclaimation of unused pixmaps.
-
-* Unix library: new functions {set,clear}_nonblock, {set,clear}_close_on_exec,
-{set,get}itimer, inet_addr_any, {get,set}sockopt.
-
-* Dynlink library: added support for linking libraries (.cma files).
-
-Caml Special Light 1.15:
-------------------------
-
-* Caml Special Light now runs under Windows NT and 95. Many thanks to
-Kevin Gallo (Microsoft Research) who contributed his initial port.
-
-* csllex now generates tables for a table-driven automaton.
-The resulting lexers are smaller and run faster.
-
-* Completely automatic configuration script.
-
-* Typing: more stringent checking of module type definitions against
-manifest module type specifications.
-
-* Toplevel: recursive definitions of values now working.
-
-* Native-code compiler, all platforms:
- toplevel "let"s with refutable patterns now working;
- fixed bug in assignment to float record fields;
- direct support for floating-point negation and absolute value.
-
-* Native-code compiler, x86: fixed bug with tail calls (with more than
-4 arguments) from a function with a one-word stack frame.
-
-* Native-code compiler, Sparc: problem with -compact fixed.
-
-* Thread library: support for non-blocking writes; scheduler revised.
-
-* Unix library: bug in gethostbyaddr fixed; bounds checking for read,
-write, etc.
-
-Caml Special Light 1.14:
-------------------------
-
-* cslopt ported to the PowerPC/RS6000 architecture. Better support for
-AIX in the bytecode system as well.
-
-* cslopt, all platforms: fixed bug in live range splitting around catch/exit.
-
-* cslopt for the Intel (floating-point wars, chapter 4):
-implemented Ershov's algorithm to minimize floating-point stack usage;
-out-of-order pops fixed.
-
-* Several bug fixes in callbacks and signals.
-
-Caml Special Light 1.13:
-------------------------
-
-* Pattern-matching compilation revised to factor out accesses inside
-matched structures.
-
-* Callbacks and signals now supported in cslopt.
-Signals are only detected at allocation points, though.
-Added callback functions with 2 and 3 arguments.
-
-* More explicit error messages when a native-code program aborts due
-to array or string bound violations.
-
-* In patterns, "C _" allowed even if the constructor C has several arguments.
-
-* && and || allowed as alternate syntax for & and or.
-
-* cslopt for the Intel: code generation for floating-point
-operations entirely redone for the third time (a pox on whomever at
-Intel decided to organize the floating-point registers as a stack).
-
-* cslopt for the Sparc: don't use Sparc V8 smul and sdiv instructions,
-emulation on V7 processors is abysmal.
-
-Caml Special Light 1.12:
-------------------------
-
-* Fixed an embarrassing bug with references to floats.
-
-Caml Special Light 1.11:
-------------------------
-
-* Streams and stream parsers a la Caml Light are back (thanks to
-Daniel de Rauglaudre).
-
-* User-level concurrent threads, with low-level shared memory primitives
-(locks and conditions) as well as channel-based communication primitives
-with first-class synchronous events, in the style of Reppy's CML.
-
-* The native-code compiler has been ported to the HP PA-RISC processor
-running under NextStep (sorry, no HPUX, its linker keeps dumping
-core on me).
-
-* References not captured in a function are optimized into variables.
-
-* Fixed several bugs related to exceptions.
-
-* Floats behave a little more as specified in the IEEE standard
-(believe it or not, but x < y is not the negation of x >= y).
-
-* Lower memory consumption for the native-code compiler.
-
-Caml Special Light 1.10:
-------------------------
-
-* Many bug fixes (too many to list here).
-
-* Module language: introduction of a "with module" notation over
-signatures for concise sharing of all type components of a signature;
-better support for concrete types in signatures.
-
-* Native-code compiler: the Intel 386 version has been ported to
-NextStep and FreeBSD, and generates better code (especially for
-floats)
-
-* Tools and libraries: the Caml Light profiler and library for
-arbitrary-precision arithmetic have been ported (thanks to John
-Malecki and Victor Manuel Gulias Fernandez); better docs for the Unix
-and regexp libraries.
-
-Caml Special Light 1.07:
-------------------------
-
-* Syntax: optional ;; allowed in compilation units and structures
-(back by popular demand)
-
-* cslopt:
-generic handling of float arrays fixed
-direct function application when the function expr is not a path fixed
-compilation of "let rec" over values fixed
-multiple definitions of a value name in a module correctly handled
-no calls to ranlib in Solaris
-
-* csltop: #trace now working
-
-* Standard library: added List.memq; documentation of Array fixed.
-
-Caml Special Light 1.06:
-------------------------
-
-* First public release.
diff --git a/INSTALL b/INSTALL
deleted file mode 100644
index 2fc5a30295..0000000000
--- a/INSTALL
+++ /dev/null
@@ -1,263 +0,0 @@
- Installing Objective Caml on a Unix machine
- -------------------------------------------
-
-PREREQUISITES
-
-* The GNU C compiler gcc is recommended, as the bytecode
- interpreter takes advantage of gcc-specific features to enhance
- performance.
-
-* Under HP/UX, the GNU C compiler gcc, the GNU assembler gas, and GNU make
- are all *required*. The vendor-provided compiler, assembler and make
- have major problems.
-
-* Under MacOS X, before you begin, you must raise the limit on the
- stack size with one of the following commands:
-
- limit stacksize 64M # if your shell is zsh or tcsh
- ulimit -s 65536 # if your shell is bash
-
-
-INSTALLATION INSTRUCTIONS
-
-1- Configure the system. From the top directory, do:
-
- ./configure
-
-This generates the three configuration files "Makefile", "m.h" and "s.h"
-in the config/ subdirectory.
-
-The "configure" script accepts the following options:
-
--bindir <dir> (default: /usr/local/bin)
- Directory where the binaries will be installed
-
--libdir <dir> (default: /usr/local/lib/ocaml)
- Directory where the Caml library will be installed
-
--mandir <dir> (default: /usr/local/man/man1)
- Directory where the manual pages will be installed
-
--prefix <dir> (default: /usr/local)
- Set bindir, libdir and mandir to
- <dir>/bin, <dir>/lib/ocaml, <dir>/man/man1 respectively.
-
--cc <C compiler and options> (default: gcc if available, cc otherwise)
- C compiler to use for building the system
-
--libs <extra libraries> (default: none)
- Extra libraries to link with the system
-
--no-curses
- Do not use the curses library.
-
--host <hosttype> (default: determined automatically)
- The type of the host machine, in GNU's "configuration name"
- format (CPU-COMPANY-SYSTEM). This info is generally determined
- automatically by the "configure" script, and rarely ever
- needs to be provided by hand. The installation instructions
- for gcc or emacs contain a complete list of configuration names.
-
--x11include <include_dir> (default: determined automatically)
--x11lib <lib_dir> (default: determined automatically)
- Location of the X11 include directory (e.g. /usr/X11R6/include)
- and the X11 library directory (e.g. /usr/X11R6/lib).
-
--tkdefs <cpp flags> (default: none)
--tklibs <flags and libraries> (default: determined automatically)
- These options specify where to find the Tcl/Tk libraries for
- LablTk. "-tkdefs" helps to find the headers, and "-tklibs"
- the C libraries. "-tklibs" may contain either only -L/path and
- -Wl,... flags, in which case the library names are determined
- automatically, or the actual libraries, which are used as given.
- Example: for a Japanese tcl/tk whose headers are in specific
- directories and libraries in /usr/local/lib, you can use
- ./configure -tklibs "-L/usr/local/lib -ltk8.0jp -ltcl8.0jp"
- -tkdefs "-I/usr/local/include/tcl8.0jp -I/usr/local/include/tk8.0jp"
-
--tk-no-x11
- Build LablTk without using X11. This option is needed on Cygwin.
-
--no-tk
- Do not attempt to build LablTk.
-
--no-pthread
- Do not attempt to use POSIX threads.
-
--verbose
- Verbose output of the configuration tests. Use it if the outcome
- of configure is not what you were expecting.
-
-Examples:
- ./configure -prefix /usr/bin
- ./configure -bindir /usr/bin -libdir /usr/lib/ocaml -mandir /usr/man/manl
- ./configure -cc "acc -fast" -libs "-lucb"
- # For Sun Solaris with the acc compiler
- ./configure -cc "xlc_r -D_AIX43 -Wl,-bexpall,-brtl -qmaxmem=8192"
- # For AIX 4.3 with the IBM compiler
-
-If something goes wrong during the automatic configuration, or if the
-generated files cause errors later on, then look at the template files
-
- config/Makefile-templ
- config/m-templ.h
- config/s-templ.h
-
-for guidance on how to edit the generated files by hand.
-
-2- From the top directory, do:
-
- make world
-
-This builds the Objective Caml bytecode compiler for the first time.
-This phase is fairly verbose; consider redirecting the output to a file:
-
- make world > log.world 2>&1 # in sh
- make world >& log.world # in csh
-
-3- (Optional) To be sure everything works well, you can try to
-bootstrap the system --- that is, to recompile all Objective Caml
-sources with the newly created compiler. From the top directory, do:
-
- make bootstrap
-
-or, better:
-
- make bootstrap > log.bootstrap 2>&1 # in sh
- make bootstrap >& log.bootstrap # in csh
-
-The "make bootstrap" checks that the bytecode programs compiled with
-the new compiler are identical to the bytecode programs compiled with
-the old compiler. If this is the case, you can be pretty sure the
-system has been correctly compiled. Otherwise, this does not
-necessarily mean something went wrong. The best thing to do is to try
-a second bootstrapping phase: just do "make bootstrap" again. It will
-either crash almost immediately, or re-re-compile everything correctly
-and reach the fixpoint.
-
-4- If your platform is supported by the native-code compiler (as
-reported during the autoconfiguration), you can now build the
-native-code compiler. From the top directory, do:
-
- make opt
-or:
- make opt > log.opt 2>&1 # in sh
- make opt >& log.opt # in csh
-
-5- (Optional) If you want to give the native-code compiler a serious
-test, you can try to compile the Objective Caml compilers with the
-native-code compiler (they are compiled to bytecode by default).
-Just do:
-
- make opt.opt
-
-Later, you can compile your programs to bytecode using ocamlc.opt
-instead of ocamlc, and to native-code using ocamlopt.opt instead of
-ocamlopt. The ".opt" compilers should run faster than the normal
-compilers, especially on large input files, but they may take longer
-to start due to increased code size. If compilation times are an issue on
-your programs, try the ".opt" compilers to see if they make a
-significant difference.
-
-An alternative, and faster approach to steps 2 to 5 is
-
- make world.opt # to build using native-code compilers
-
-The result is equivalent to "make world opt opt.opt", but this may
-fail if anything goes wrong in native-code generation.
-
-6- You can now install the Objective Caml system. This will create the
-following commands (in the binary directory selected during
-autoconfiguration):
-
- ocamlc the batch bytecode compiler
- ocamlopt the batch native-code compiler (if supported)
- ocamlrun the runtime system for the bytecode compiler
- ocamlyacc the parser generator
- ocamllex the lexer generator
- ocaml the interactive, toplevel-based system
- ocamlmktop a tool to make toplevel systems that integrate
- user-defined C primitives and Caml code
- ocamldebug the source-level replay debugger
- ocamldep generator of "make" dependencies for Caml sources
- ocamldoc documentation generator
- ocamlprof execution count profiler
- ocamlcp the bytecode compiler in profiling mode
-
-and also, if you built them during step 5,
-
- ocamlc.opt the batch bytecode compiler compiled with ocamlopt
- ocamlopt.opt the batch native-code compiler compiled with ocamlopt
- ocamllex.opt the lexer generator compiled with ocamlopt
-
-From the top directory, become superuser and do:
-
- umask 022 # make sure to give read & execute permission to all
- make install
-
-7- Installation is complete. Time to clean up. From the toplevel
-directory, do "make clean".
-
-8- (Optional) The emacs/ subdirectory contains Emacs-Lisp files for an
-Objective Caml editing mode and an interface for the debugger. To
-install these files, change to the emacs/ subdirectory and do
-
- make EMACSDIR=<directory where to install the files> install
-or
- make install
-
-In the latter case, the destination directory defaults to the
-"site-lisp" directory of your Emacs installation.
-
-9- After installation, do *not* strip the ocamldebug and ocamlbrowser
-executables. (These are mixed-mode executables, containing both
-compiled C code and Caml bytecode; stripping erases the bytecode!)
-Other executables such as ocamlrun can safely be stripped.
-
-IF SOMETHING GOES WRONG:
-
-Read the "common problems" and "machine-specific hints" section at the
-end of this file.
-
-Check the files m.h and s.h in config/. Wrong endianness or alignment
-constraints in m.h will immediately crash the bytecode interpreter.
-
-If you get a "segmentation violation" signal, check the limits on the
-stack size and data segment size (type "limit" under csh or
-"ulimit -a" under bash). Make sure the limit on the stack size is
-at least 4M.
-
-Try recompiling the runtime system with optimizations turned off
-(change CFLAGS in byterun/Makefile and asmrun/Makefile).
-The runtime system contains some complex, atypical pieces of C code
-that can uncover bugs in optimizing compilers. Alternatively, try
-another C compiler (e.g. gcc instead of the vendor-supplied cc).
-
-You can also build a debug version of the runtime system. Go to the
-byterun/ directory and do "make ocamlrund". Then, copy ocamlrund to
-../boot/ocamlrun, and try again. This version of the runtime system
-contains lots of assertions and sanity checks that could help you
-pinpoint the problem.
-
-
-COMMON PROBLEMS:
-
-* The Makefiles use the "include" directive, which is not supported by
-all versions of make. Use GNU make if this is a problem.
-
-* The Makefiles assume that make execute commands by calling /bin/sh. They
-won't work if /bin/csh is called instead. You may have to unset the SHELL
-environment variable, or set it to /bin/sh.
-
-* gcc 2.7.2.1 generates incorrect code for the runtime system in -O mode
-on some Intel x86 platforms (e.g. Linux RedHat 4.1 and 4.2).
-If this causes a problem, the solution is to upgrade to 2.7.2.3 or above.
-
-* Some versions of gcc 2.96 for the Intel x86 (as found in RedHat 7.2,
-Mandrake 8.0 and Mandrake 8.1) generates incorrect code for the runtime
-system. The "configure" script tries to work around this problem.
-
-* On HP 9000/700 machines under HP/UX 9. Some versions of cc are
-unable to compile correctly the runtime system (wrong code is
-generated for (x - y) where x is a pointer and y an integer).
-Fix: use gcc.
diff --git a/INSTALL.MPW b/INSTALL.MPW
deleted file mode 100644
index ce65b945f5..0000000000
--- a/INSTALL.MPW
+++ /dev/null
@@ -1,89 +0,0 @@
-# $Id$
-
-
- ### Installing Objective Caml on a Macintosh with MPW ###
-
-
-
-# This file describes how to install and recompile Objective Caml
-# in the MPW environment under MacOS 7, 8, 9. For MacOS X, see
-# the instructions for Unix machines in the file INSTALL.
-
-
-# PREREQUISITES
-
-# You need MPW 3.5 (with MrC) and Universal Interfaces version 3.3.2
-# You need WASTE version 1.3
-#
-# MPW is available from Apple's FTP site at:
-# <ftp://ftp.apple.com/devworld/Tool_Chest/Core_Mac_OS_Tools/MPW_etc./>
-#
-# WASTE 1.3 is available from:
-# <ftp://ftp.inria.fr/INRIA/caml-light/WASTE-1.3.sit.bin>
-
-
-# INSTALLATION INSTRUCTIONS
-#
-# To install Objective Caml in your MPW environment, follow this script.
-# Read the comments and execute the commands. If you run the commands
-# without changing anything, you'll get a reasonable default configuration.
-
-# Before you start, you must put the WASTE 1.3 distribution folder
-# into the :maccaml:WASTE: folder.
-
-
-# Go to the directory where you found this file.
-
-Directory "`echo "{active}" | streamedit -e '1 replace /[Â:]*°/ ""'`"
-
-# Set the O'Caml configuration files.
-
-Duplicate -y :config:s-MacOS.h :config:s.h
-Duplicate -y :config:m-MacOS.h :config:m.h
-
-# Copy some useful scripts to your Commands directory.
-# DoMake is absolutely needed for installation
-# Characters is only needed by the executable error messages
-
-Duplicate :tools:DoMake :tools:Characters "{MPW}User Commands:"
-
-# NOTE: if you have MakeDepend from a previous version of O'Caml, you
-# must remove it from "{MPW}User Commands:". It is not needed any more
-# since MPW 3.5 has a MakeDepend command.
-
-
-# Build the WASTE libraries:
-
-Directory ":maccaml:WASTE:WASTE 1.3 Distribution:"
-DoMake -f ::Makefile WASTELib.x ·· "{worksheet}"
-Directory ::::
-
-# Edit ":config:config.Mac" to change the configuration.
-# (mostly, the destination folders for installation)
-
-Open :config:config.Mac
-
-# Set the configuration variables.
-
-Execute :config:config.Mac
-
-# O'Caml needs an environment variable to find its library files.
-# (the value is taken from the configuration variables)
-
-Set -e CAMLLIB "{LIBDIR}"
-
-# Make it persistent.
-
-Set CAMLLIB > "{MPW}Startup Items:OCaml"
-
-# Now you're all set. Build the files and install everything.
-# For more explanations on these steps, see the file INSTALL.
-
-begin
- DoMake world
- DoMake bootstrap
- DoMake install
-end ·· "{worksheet}"
-
-# If you want syntax coloring in MPW Shell, use ResEdit to copy the
-# resources from :tools:keywords into the shell.
diff --git a/LICENSE b/LICENSE
deleted file mode 100644
index bd3dbe83e4..0000000000
--- a/LICENSE
+++ /dev/null
@@ -1,618 +0,0 @@
-In the following, "the Library" refers to all files marked "Copyright
-INRIA" in the following directories and their sub-directories:
-
- asmrun, byterun, camlp4, config, maccaml, otherlibs, stdlib, win32caml
-
-and "the Compiler" refers to all files marked "Copyright INRIA" in the
-other directories and their sub-directories.
-
-The Compiler is distributed under the terms of the Q Public License
-version 1.0 (included below).
-
-The Library is distributed under the terms of the GNU Library General
-Public License version 2 (included below).
-
-As a special exception to the GNU Library General Public License, you
-may link, statically or dynamically, a "work that uses the Library"
-with a publicly distributed version of the Library to produce an
-executable file containing portions of the Library, and distribute
-that executable file under terms of your choice, without any of the
-additional requirements listed in clause 6 of the GNU Library General
-Public License. By "a publicly distributed version of the Library",
-we mean either the unmodified Library as distributed by INRIA, or a
-modified version of the Library that is distributed under the
-conditions defined in clause 3 of the GNU Library General Public
-License. This exception does not however invalidate any other reasons
-why the executable file might be covered by the GNU Library General
-Public License.
-
-----------------------------------------------------------------------
-
- THE Q PUBLIC LICENSE version 1.0
-
- Copyright (C) 1999 Troll Tech AS, Norway.
- Everyone is permitted to copy and
- distribute this license document.
-
-The intent of this license is to establish freedom to share and change
-the software regulated by this license under the open source model.
-
-This license applies to any software containing a notice placed by the
-copyright holder saying that it may be distributed under the terms of
-the Q Public License version 1.0. Such software is herein referred to
-as the Software. This license covers modification and distribution of
-the Software, use of third-party application programs based on the
-Software, and development of free software which uses the Software.
-
- Granted Rights
-
-1. You are granted the non-exclusive rights set forth in this license
-provided you agree to and comply with any and all conditions in this
-license. Whole or partial distribution of the Software, or software
-items that link with the Software, in any form signifies acceptance of
-this license.
-
-2. You may copy and distribute the Software in unmodified form
-provided that the entire package, including - but not restricted to -
-copyright, trademark notices and disclaimers, as released by the
-initial developer of the Software, is distributed.
-
-3. You may make modifications to the Software and distribute your
-modifications, in a form that is separate from the Software, such as
-patches. The following restrictions apply to modifications:
-
- a. Modifications must not alter or remove any copyright notices
- in the Software.
-
- b. When modifications to the Software are released under this
- license, a non-exclusive royalty-free right is granted to the
- initial developer of the Software to distribute your
- modification in future versions of the Software provided such
- versions remain available under these terms in addition to any
- other license(s) of the initial developer.
-
-4. You may distribute machine-executable forms of the Software or
-machine-executable forms of modified versions of the Software,
-provided that you meet these restrictions:
-
- a. You must include this license document in the distribution.
-
- b. You must ensure that all recipients of the machine-executable
- forms are also able to receive the complete machine-readable
- source code to the distributed Software, including all
- modifications, without any charge beyond the costs of data
- transfer, and place prominent notices in the distribution
- explaining this.
-
- c. You must ensure that all modifications included in the
- machine-executable forms are available under the terms of this
- license.
-
-5. You may use the original or modified versions of the Software to
-compile, link and run application programs legally developed by you or
-by others.
-
-6. You may develop application programs, reusable components and other
-software items that link with the original or modified versions of the
-Software. These items, when distributed, are subject to the following
-requirements:
-
- a. You must ensure that all recipients of machine-executable
- forms of these items are also able to receive and use the
- complete machine-readable source code to the items without any
- charge beyond the costs of data transfer.
-
- b. You must explicitly license all recipients of your items to
- use and re-distribute original and modified versions of the
- items in both machine-executable and source code forms. The
- recipients must be able to do so without any charges whatsoever,
- and they must be able to re-distribute to anyone they choose.
-
- c. If the items are not available to the general public, and the
- initial developer of the Software requests a copy of the items,
- then you must supply one.
-
- Limitations of Liability
-
-In no event shall the initial developers or copyright holders be
-liable for any damages whatsoever, including - but not restricted to -
-lost revenue or profits or other direct, indirect, special, incidental
-or consequential damages, even if they have been advised of the
-possibility of such damages, except to the extent invariable law, if
-any, provides otherwise.
-
- No Warranty
-
-The Software and this license document are provided AS IS with NO
-WARRANTY OF ANY KIND, INCLUDING THE WARRANTY OF DESIGN,
-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-
- Choice of Law
-
-This license is governed by the Laws of France. Disputes shall be
-settled by the Court of Versailles.
-
-----------------------------------------------------------------------
-
- GNU LIBRARY GENERAL PUBLIC LICENSE
- Version 2, June 1991
-
- Copyright (C) 1991 Free Software Foundation, Inc.
- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
-[This is the first released version of the library GPL. It is
- numbered 2 because it goes with version 2 of the ordinary GPL.]
-
- Preamble
-
- The licenses for most software are designed to take away your
-freedom to share and change it. By contrast, the GNU General Public
-Licenses are intended to guarantee your freedom to share and change
-free software--to make sure the software is free for all its users.
-
- This license, the Library General Public License, applies to some
-specially designated Free Software Foundation software, and to any
-other libraries whose authors decide to use it. You can use it for
-your libraries, too.
-
- When we speak of free software, we are referring to freedom, not
-price. Our General Public Licenses are designed to make sure that you
-have the freedom to distribute copies of free software (and charge for
-this service if you wish), that you receive source code or can get it
-if you want it, that you can change the software or use pieces of it
-in new free programs; and that you know you can do these things.
-
- To protect your rights, we need to make restrictions that forbid
-anyone to deny you these rights or to ask you to surrender the rights.
-These restrictions translate to certain responsibilities for you if
-you distribute copies of the library, or if you modify it.
-
- For example, if you distribute copies of the library, whether gratis
-or for a fee, you must give the recipients all the rights that we gave
-you. You must make sure that they, too, receive or can get the source
-code. If you link a program with the library, you must provide
-complete object files to the recipients so that they can relink them
-with the library, after making changes to the library and recompiling
-it. And you must show them these terms so they know their rights.
-
- Our method of protecting your rights has two steps: (1) copyright
-the library, and (2) offer you this license which gives you legal
-permission to copy, distribute and/or modify the library.
-
- Also, for each distributor's protection, we want to make certain
-that everyone understands that there is no warranty for this free
-library. If the library is modified by someone else and passed on, we
-want its recipients to know that what they have is not the original
-version, so that any problems introduced by others will not reflect on
-the original authors' reputations.
-
- Finally, any free program is threatened constantly by software
-patents. We wish to avoid the danger that companies distributing free
-software will individually obtain patent licenses, thus in effect
-transforming the program into proprietary software. To prevent this,
-we have made it clear that any patent must be licensed for everyone's
-free use or not licensed at all.
-
- Most GNU software, including some libraries, is covered by the ordinary
-GNU General Public License, which was designed for utility programs. This
-license, the GNU Library General Public License, applies to certain
-designated libraries. This license is quite different from the ordinary
-one; be sure to read it in full, and don't assume that anything in it is
-the same as in the ordinary license.
-
- The reason we have a separate public license for some libraries is that
-they blur the distinction we usually make between modifying or adding to a
-program and simply using it. Linking a program with a library, without
-changing the library, is in some sense simply using the library, and is
-analogous to running a utility program or application program. However, in
-a textual and legal sense, the linked executable is a combined work, a
-derivative of the original library, and the ordinary General Public License
-treats it as such.
-
- Because of this blurred distinction, using the ordinary General
-Public License for libraries did not effectively promote software
-sharing, because most developers did not use the libraries. We
-concluded that weaker conditions might promote sharing better.
-
- However, unrestricted linking of non-free programs would deprive the
-users of those programs of all benefit from the free status of the
-libraries themselves. This Library General Public License is intended to
-permit developers of non-free programs to use free libraries, while
-preserving your freedom as a user of such programs to change the free
-libraries that are incorporated in them. (We have not seen how to achieve
-this as regards changes in header files, but we have achieved it as regards
-changes in the actual functions of the Library.) The hope is that this
-will lead to faster development of free libraries.
-
- The precise terms and conditions for copying, distribution and
-modification follow. Pay close attention to the difference between a
-"work based on the library" and a "work that uses the library". The
-former contains code derived from the library, while the latter only
-works together with the library.
-
- Note that it is possible for a library to be covered by the ordinary
-General Public License rather than by this special one.
-
- GNU LIBRARY GENERAL PUBLIC LICENSE
- TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
-
- 0. This License Agreement applies to any software library which
-contains a notice placed by the copyright holder or other authorized
-party saying it may be distributed under the terms of this Library
-General Public License (also called "this License"). Each licensee is
-addressed as "you".
-
- A "library" means a collection of software functions and/or data
-prepared so as to be conveniently linked with application programs
-(which use some of those functions and data) to form executables.
-
- The "Library", below, refers to any such software library or work
-which has been distributed under these terms. A "work based on the
-Library" means either the Library or any derivative work under
-copyright law: that is to say, a work containing the Library or a
-portion of it, either verbatim or with modifications and/or translated
-straightforwardly into another language. (Hereinafter, translation is
-included without limitation in the term "modification".)
-
- "Source code" for a work means the preferred form of the work for
-making modifications to it. For a library, complete source code means
-all the source code for all modules it contains, plus any associated
-interface definition files, plus the scripts used to control compilation
-and installation of the library.
-
- Activities other than copying, distribution and modification are not
-covered by this License; they are outside its scope. The act of
-running a program using the Library is not restricted, and output from
-such a program is covered only if its contents constitute a work based
-on the Library (independent of the use of the Library in a tool for
-writing it). Whether that is true depends on what the Library does
-and what the program that uses the Library does.
-
- 1. You may copy and distribute verbatim copies of the Library's
-complete source code as you receive it, in any medium, provided that
-you conspicuously and appropriately publish on each copy an
-appropriate copyright notice and disclaimer of warranty; keep intact
-all the notices that refer to this License and to the absence of any
-warranty; and distribute a copy of this License along with the
-Library.
-
- You may charge a fee for the physical act of transferring a copy,
-and you may at your option offer warranty protection in exchange for a
-fee.
-
- 2. You may modify your copy or copies of the Library or any portion
-of it, thus forming a work based on the Library, and copy and
-distribute such modifications or work under the terms of Section 1
-above, provided that you also meet all of these conditions:
-
- a) The modified work must itself be a software library.
-
- b) You must cause the files modified to carry prominent notices
- stating that you changed the files and the date of any change.
-
- c) You must cause the whole of the work to be licensed at no
- charge to all third parties under the terms of this License.
-
- d) If a facility in the modified Library refers to a function or a
- table of data to be supplied by an application program that uses
- the facility, other than as an argument passed when the facility
- is invoked, then you must make a good faith effort to ensure that,
- in the event an application does not supply such function or
- table, the facility still operates, and performs whatever part of
- its purpose remains meaningful.
-
- (For example, a function in a library to compute square roots has
- a purpose that is entirely well-defined independent of the
- application. Therefore, Subsection 2d requires that any
- application-supplied function or table used by this function must
- be optional: if the application does not supply it, the square
- root function must still compute square roots.)
-
-These requirements apply to the modified work as a whole. If
-identifiable sections of that work are not derived from the Library,
-and can be reasonably considered independent and separate works in
-themselves, then this License, and its terms, do not apply to those
-sections when you distribute them as separate works. But when you
-distribute the same sections as part of a whole which is a work based
-on the Library, the distribution of the whole must be on the terms of
-this License, whose permissions for other licensees extend to the
-entire whole, and thus to each and every part regardless of who wrote
-it.
-
-Thus, it is not the intent of this section to claim rights or contest
-your rights to work written entirely by you; rather, the intent is to
-exercise the right to control the distribution of derivative or
-collective works based on the Library.
-
-In addition, mere aggregation of another work not based on the Library
-with the Library (or with a work based on the Library) on a volume of
-a storage or distribution medium does not bring the other work under
-the scope of this License.
-
- 3. You may opt to apply the terms of the ordinary GNU General Public
-License instead of this License to a given copy of the Library. To do
-this, you must alter all the notices that refer to this License, so
-that they refer to the ordinary GNU General Public License, version 2,
-instead of to this License. (If a newer version than version 2 of the
-ordinary GNU General Public License has appeared, then you can specify
-that version instead if you wish.) Do not make any other change in
-these notices.
-
- Once this change is made in a given copy, it is irreversible for
-that copy, so the ordinary GNU General Public License applies to all
-subsequent copies and derivative works made from that copy.
-
- This option is useful when you wish to copy part of the code of
-the Library into a program that is not a library.
-
- 4. You may copy and distribute the Library (or a portion or
-derivative of it, under Section 2) in object code or executable form
-under the terms of Sections 1 and 2 above provided that you accompany
-it with the complete corresponding machine-readable source code, which
-must be distributed under the terms of Sections 1 and 2 above on a
-medium customarily used for software interchange.
-
- If distribution of object code is made by offering access to copy
-from a designated place, then offering equivalent access to copy the
-source code from the same place satisfies the requirement to
-distribute the source code, even though third parties are not
-compelled to copy the source along with the object code.
-
- 5. A program that contains no derivative of any portion of the
-Library, but is designed to work with the Library by being compiled or
-linked with it, is called a "work that uses the Library". Such a
-work, in isolation, is not a derivative work of the Library, and
-therefore falls outside the scope of this License.
-
- However, linking a "work that uses the Library" with the Library
-creates an executable that is a derivative of the Library (because it
-contains portions of the Library), rather than a "work that uses the
-library". The executable is therefore covered by this License.
-Section 6 states terms for distribution of such executables.
-
- When a "work that uses the Library" uses material from a header file
-that is part of the Library, the object code for the work may be a
-derivative work of the Library even though the source code is not.
-Whether this is true is especially significant if the work can be
-linked without the Library, or if the work is itself a library. The
-threshold for this to be true is not precisely defined by law.
-
- If such an object file uses only numerical parameters, data
-structure layouts and accessors, and small macros and small inline
-functions (ten lines or less in length), then the use of the object
-file is unrestricted, regardless of whether it is legally a derivative
-work. (Executables containing this object code plus portions of the
-Library will still fall under Section 6.)
-
- Otherwise, if the work is a derivative of the Library, you may
-distribute the object code for the work under the terms of Section 6.
-Any executables containing that work also fall under Section 6,
-whether or not they are linked directly with the Library itself.
-
- 6. As an exception to the Sections above, you may also compile or
-link a "work that uses the Library" with the Library to produce a
-work containing portions of the Library, and distribute that work
-under terms of your choice, provided that the terms permit
-modification of the work for the customer's own use and reverse
-engineering for debugging such modifications.
-
- You must give prominent notice with each copy of the work that the
-Library is used in it and that the Library and its use are covered by
-this License. You must supply a copy of this License. If the work
-during execution displays copyright notices, you must include the
-copyright notice for the Library among them, as well as a reference
-directing the user to the copy of this License. Also, you must do one
-of these things:
-
- a) Accompany the work with the complete corresponding
- machine-readable source code for the Library including whatever
- changes were used in the work (which must be distributed under
- Sections 1 and 2 above); and, if the work is an executable linked
- with the Library, with the complete machine-readable "work that
- uses the Library", as object code and/or source code, so that the
- user can modify the Library and then relink to produce a modified
- executable containing the modified Library. (It is understood
- that the user who changes the contents of definitions files in the
- Library will not necessarily be able to recompile the application
- to use the modified definitions.)
-
- b) Accompany the work with a written offer, valid for at
- least three years, to give the same user the materials
- specified in Subsection 6a, above, for a charge no more
- than the cost of performing this distribution.
-
- c) If distribution of the work is made by offering access to copy
- from a designated place, offer equivalent access to copy the above
- specified materials from the same place.
-
- d) Verify that the user has already received a copy of these
- materials or that you have already sent this user a copy.
-
- For an executable, the required form of the "work that uses the
-Library" must include any data and utility programs needed for
-reproducing the executable from it. However, as a special exception,
-the source code distributed need not include anything that is normally
-distributed (in either source or binary form) with the major
-components (compiler, kernel, and so on) of the operating system on
-which the executable runs, unless that component itself accompanies
-the executable.
-
- It may happen that this requirement contradicts the license
-restrictions of other proprietary libraries that do not normally
-accompany the operating system. Such a contradiction means you cannot
-use both them and the Library together in an executable that you
-distribute.
-
- 7. You may place library facilities that are a work based on the
-Library side-by-side in a single library together with other library
-facilities not covered by this License, and distribute such a combined
-library, provided that the separate distribution of the work based on
-the Library and of the other library facilities is otherwise
-permitted, and provided that you do these two things:
-
- a) Accompany the combined library with a copy of the same work
- based on the Library, uncombined with any other library
- facilities. This must be distributed under the terms of the
- Sections above.
-
- b) Give prominent notice with the combined library of the fact
- that part of it is a work based on the Library, and explaining
- where to find the accompanying uncombined form of the same work.
-
- 8. You may not copy, modify, sublicense, link with, or distribute
-the Library except as expressly provided under this License. Any
-attempt otherwise to copy, modify, sublicense, link with, or
-distribute the Library is void, and will automatically terminate your
-rights under this License. However, parties who have received copies,
-or rights, from you under this License will not have their licenses
-terminated so long as such parties remain in full compliance.
-
- 9. You are not required to accept this License, since you have not
-signed it. However, nothing else grants you permission to modify or
-distribute the Library or its derivative works. These actions are
-prohibited by law if you do not accept this License. Therefore, by
-modifying or distributing the Library (or any work based on the
-Library), you indicate your acceptance of this License to do so, and
-all its terms and conditions for copying, distributing or modifying
-the Library or works based on it.
-
- 10. Each time you redistribute the Library (or any work based on the
-Library), the recipient automatically receives a license from the
-original licensor to copy, distribute, link with or modify the Library
-subject to these terms and conditions. You may not impose any further
-restrictions on the recipients' exercise of the rights granted herein.
-You are not responsible for enforcing compliance by third parties to
-this License.
-
- 11. If, as a consequence of a court judgment or allegation of patent
-infringement or for any other reason (not limited to patent issues),
-conditions are imposed on you (whether by court order, agreement or
-otherwise) that contradict the conditions of this License, they do not
-excuse you from the conditions of this License. If you cannot
-distribute so as to satisfy simultaneously your obligations under this
-License and any other pertinent obligations, then as a consequence you
-may not distribute the Library at all. For example, if a patent
-license would not permit royalty-free redistribution of the Library by
-all those who receive copies directly or indirectly through you, then
-the only way you could satisfy both it and this License would be to
-refrain entirely from distribution of the Library.
-
-If any portion of this section is held invalid or unenforceable under any
-particular circumstance, the balance of the section is intended to apply,
-and the section as a whole is intended to apply in other circumstances.
-
-It is not the purpose of this section to induce you to infringe any
-patents or other property right claims or to contest validity of any
-such claims; this section has the sole purpose of protecting the
-integrity of the free software distribution system which is
-implemented by public license practices. Many people have made
-generous contributions to the wide range of software distributed
-through that system in reliance on consistent application of that
-system; it is up to the author/donor to decide if he or she is willing
-to distribute software through any other system and a licensee cannot
-impose that choice.
-
-This section is intended to make thoroughly clear what is believed to
-be a consequence of the rest of this License.
-
- 12. If the distribution and/or use of the Library is restricted in
-certain countries either by patents or by copyrighted interfaces, the
-original copyright holder who places the Library under this License may add
-an explicit geographical distribution limitation excluding those countries,
-so that distribution is permitted only in or among countries not thus
-excluded. In such case, this License incorporates the limitation as if
-written in the body of this License.
-
- 13. The Free Software Foundation may publish revised and/or new
-versions of the Library General Public License from time to time.
-Such new versions will be similar in spirit to the present version,
-but may differ in detail to address new problems or concerns.
-
-Each version is given a distinguishing version number. If the Library
-specifies a version number of this License which applies to it and
-"any later version", you have the option of following the terms and
-conditions either of that version or of any later version published by
-the Free Software Foundation. If the Library does not specify a
-license version number, you may choose any version ever published by
-the Free Software Foundation.
-
- 14. If you wish to incorporate parts of the Library into other free
-programs whose distribution conditions are incompatible with these,
-write to the author to ask for permission. For software which is
-copyrighted by the Free Software Foundation, write to the Free
-Software Foundation; we sometimes make exceptions for this. Our
-decision will be guided by the two goals of preserving the free status
-of all derivatives of our free software and of promoting the sharing
-and reuse of software generally.
-
- NO WARRANTY
-
- 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
-WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
-EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
-OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
-KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
-LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
-THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
-
- 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
-WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
-AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
-FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
-CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
-LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
-RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
-FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
-SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
-DAMAGES.
-
- END OF TERMS AND CONDITIONS
-
- Appendix: How to Apply These Terms to Your New Libraries
-
- If you develop a new library, and you want it to be of the greatest
-possible use to the public, we recommend making it free software that
-everyone can redistribute and change. You can do so by permitting
-redistribution under these terms (or, alternatively, under the terms of the
-ordinary General Public License).
-
- To apply these terms, attach the following notices to the library. It is
-safest to attach them to the start of each source file to most effectively
-convey the exclusion of warranty; and each file should have at least the
-"copyright" line and a pointer to where the full notice is found.
-
- <one line to give the library's name and a brief 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 Library General Public
- License as published by the Free Software Foundation; either
- version 2 of the License, or (at your option) any later version.
-
- This library is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- Library General Public License for more details.
-
- You should have received a copy of the GNU Library General Public
- License along with this library; if not, write to the Free
- Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- MA 02111-1307, USA
-
-Also add information on how to contact you by electronic and paper mail.
-
-You should also get your employer (if you work as a programmer) or your
-school, if any, to sign a "copyright disclaimer" for the library, if
-necessary. Here is a sample; alter the names:
-
- Yoyodyne, Inc., hereby disclaims all copyright interest in the
- library `Frob' (a library for tweaking knobs) written by James Random Hacker.
-
- <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
deleted file mode 100644
index 5683940e55..0000000000
--- a/Makefile
+++ /dev/null
@@ -1,671 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-# The main Makefile
-
-include config/Makefile
-include stdlib/StdlibModules
-
-CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot
-CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib
-COMPFLAGS=-warn-error A $(INCLUDES)
-LINKFLAGS=
-
-CAMLYACC=boot/ocamlyacc
-YACCFLAGS=-v
-CAMLLEX=boot/ocamlrun boot/ocamllex
-CAMLDEP=boot/ocamlrun tools/ocamldep
-DEPFLAGS=$(INCLUDES)
-CAMLRUN=byterun/ocamlrun
-SHELL=/bin/sh
-MKDIR=mkdir -p
-
-INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver \
- -I toplevel
-
-UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \
- utils/clflags.cmo utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \
- utils/consistbl.cmo
-
-OPTUTILS=$(UTILS)
-
-PARSING=parsing/linenum.cmo parsing/location.cmo parsing/longident.cmo \
- parsing/syntaxerr.cmo parsing/parser.cmo \
- parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo
-
-TYPING=typing/ident.cmo typing/path.cmo \
- typing/primitive.cmo typing/types.cmo \
- typing/btype.cmo typing/oprint.cmo \
- typing/subst.cmo typing/predef.cmo \
- typing/datarepr.cmo typing/env.cmo \
- typing/typedtree.cmo typing/ctype.cmo \
- typing/printtyp.cmo typing/includeclass.cmo \
- typing/mtype.cmo typing/includecore.cmo \
- typing/includemod.cmo typing/parmatch.cmo \
- typing/typetexp.cmo typing/stypes.cmo typing/typecore.cmo \
- typing/typedecl.cmo typing/typeclass.cmo \
- typing/typemod.cmo
-
-COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \
- bytecomp/typeopt.cmo bytecomp/switch.cmo bytecomp/matching.cmo \
- bytecomp/translobj.cmo bytecomp/translcore.cmo \
- bytecomp/translclass.cmo bytecomp/translmod.cmo \
- bytecomp/simplif.cmo bytecomp/runtimedef.cmo
-
-BYTECOMP=bytecomp/meta.cmo bytecomp/instruct.cmo bytecomp/bytegen.cmo \
- bytecomp/printinstr.cmo bytecomp/opcodes.cmo bytecomp/emitcode.cmo \
- bytecomp/bytesections.cmo bytecomp/dll.cmo bytecomp/symtable.cmo \
- bytecomp/bytelink.cmo bytecomp/bytelibrarian.cmo bytecomp/bytepackager.cmo
-
-ASMCOMP=asmcomp/arch.cmo asmcomp/cmm.cmo asmcomp/printcmm.cmo \
- asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \
- asmcomp/clambda.cmo asmcomp/compilenv.cmo \
- asmcomp/closure.cmo asmcomp/cmmgen.cmo \
- asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \
- asmcomp/comballoc.cmo asmcomp/liveness.cmo \
- asmcomp/spill.cmo asmcomp/split.cmo \
- asmcomp/interf.cmo asmcomp/coloring.cmo \
- asmcomp/reloadgen.cmo asmcomp/reload.cmo \
- asmcomp/printlinear.cmo asmcomp/linearize.cmo \
- asmcomp/schedgen.cmo asmcomp/scheduling.cmo \
- asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \
- asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo
-
-DRIVER=driver/pparse.cmo driver/errors.cmo driver/compile.cmo \
- driver/main_args.cmo driver/main.cmo
-
-OPTDRIVER= driver/pparse.cmo driver/opterrors.cmo driver/optcompile.cmo \
- driver/optmain.cmo
-
-TOPLEVEL=driver/pparse.cmo driver/errors.cmo driver/compile.cmo \
- toplevel/genprintval.cmo toplevel/toploop.cmo \
- toplevel/trace.cmo toplevel/topdirs.cmo toplevel/topmain.cmo
-
-TOPLEVELLIB=toplevel/toplevellib.cma
-TOPLEVELSTART=toplevel/topstart.cmo
-
-COMPOBJS=$(UTILS) $(PARSING) $(TYPING) $(COMP) $(BYTECOMP) $(DRIVER)
-
-TOPLIB=$(UTILS) $(PARSING) $(TYPING) $(COMP) $(BYTECOMP) $(TOPLEVEL)
-
-TOPOBJS=$(TOPLEVELLIB) $(TOPLEVELSTART)
-
-OPTOBJS=$(OPTUTILS) $(PARSING) $(TYPING) $(COMP) $(ASMCOMP) $(OPTDRIVER)
-
-EXPUNGEOBJS=utils/misc.cmo utils/tbl.cmo \
- utils/config.cmo utils/clflags.cmo \
- typing/ident.cmo typing/path.cmo typing/types.cmo typing/btype.cmo \
- typing/predef.cmo bytecomp/runtimedef.cmo bytecomp/bytesections.cmo \
- bytecomp/dll.cmo bytecomp/symtable.cmo toplevel/expunge.cmo
-
-PERVASIVES=$(STDLIB_MODULES) outcometree topdirs toploop
-
-# For users who don't read the INSTALL file
-defaultentry:
- @echo "Please refer to the installation instructions in file INSTALL."
- @echo "If you've just unpacked the distribution, something like"
- @echo " ./configure"
- @echo " make world"
- @echo " make opt"
- @echo " make install"
- @echo "should work. But see the file INSTALL for more details."
-
-# Recompile the system using the bootstrap compiler
-all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml \
- otherlibraries camlp4out $(DEBUGGER) ocamldoc
-
-# The compilation of ocaml will fail if the runtime has changed.
-# Never mind, just do make bootstrap to reach fixpoint again.
-
-# Compile everything the first time
-world: coldstart all
-
-# Compile also native code compiler and libraries, fast
-world.opt: coldstart opt.opt
-
-# Core bootstrapping cycle
-coreboot:
-# Save the original bootstrap compiler
- $(MAKE) backup
-# Promote the new compiler but keep the old runtime
-# This compiler runs on boot/ocamlrun and produces bytecode for
-# byterun/ocamlrun
- $(MAKE) promote-cross
-# Rebuild ocamlc and ocamllex (run on byterun/ocamlrun)
- $(MAKE) partialclean
- $(MAKE) ocamlc ocamllex
-# Rebuild the library (using byterun/ocamlrun ./ocamlc)
- $(MAKE) library-cross
-# Promote the new compiler and the new runtime
- $(MAKE) promote
-# Rebuild the core system
- $(MAKE) partialclean
- $(MAKE) core
-# Check if fixpoint reached
- $(MAKE) compare
-
-# Bootstrap and rebuild the whole system.
-bootstrap:
- $(MAKE) coreboot
- $(MAKE) all
- $(MAKE) compare
-
-LIBFILES=stdlib.cma std_exit.cmo *.cmi camlheader
-
-# Start up the system from the distribution compiler
-coldstart:
- cd byterun; $(MAKE) all
- cp byterun/ocamlrun$(EXE) boot/ocamlrun$(EXE)
- cd yacc; $(MAKE) all
- cp yacc/ocamlyacc$(EXE) boot/ocamlyacc$(EXE)
- cd stdlib; $(MAKE) COMPILER=../boot/ocamlc all
- cd stdlib; cp $(LIBFILES) ../boot
- if test -f boot/libcamlrun.a; then :; else \
- ln -s ../byterun/libcamlrun.a boot/libcamlrun.a; fi
- if test -d stdlib/caml; then :; else \
- ln -s ../byterun stdlib/caml; fi
-
-# Build the core system: the minimum needed to make depend and bootstrap
-core : runtime ocamlc ocamllex ocamlyacc ocamltools library
-
-# Save the current bootstrap compiler
-MAXSAVED=boot/Saved/Saved.prev/Saved.prev/Saved.prev/Saved.prev/Saved.prev
-backup:
- if test -d boot/Saved; then : ; else mkdir boot/Saved; fi
- if test -d $(MAXSAVED); then rm -r $(MAXSAVED); else : ; fi
- mv boot/Saved boot/Saved.prev
- mkdir boot/Saved
- mv boot/Saved.prev boot/Saved/Saved.prev
- cp boot/ocamlrun$(EXE) boot/Saved
- mv boot/ocamlc boot/ocamllex boot/ocamlyacc$(EXE) boot/Saved
- cd boot; cp $(LIBFILES) Saved
-
-# Promote the newly compiled system to the rank of cross compiler
-# (Runs on the old runtime, produces code for the new runtime)
-promote-cross:
- cp ocamlc boot/ocamlc
- cp lex/ocamllex boot/ocamllex
- cp yacc/ocamlyacc$(EXE) boot/ocamlyacc$(EXE)
- cd stdlib; cp $(LIBFILES) ../boot
-
-# Promote the newly compiled system to the rank of bootstrap compiler
-# (Runs on the new runtime, produces code for the new runtime)
-promote: promote-cross
- cp byterun/ocamlrun$(EXE) boot/ocamlrun$(EXE)
-
-# Restore the saved bootstrap compiler if a problem arises
-restore:
- mv boot/Saved/* boot
- rmdir boot/Saved
- mv boot/Saved.prev boot/Saved
-
-# Check if fixpoint reached
-compare:
- @if cmp boot/ocamlc ocamlc && cmp boot/ocamllex lex/ocamllex; \
- then echo "Fixpoint reached, bootstrap succeeded."; \
- else echo "Fixpoint not reached, try one more bootstrapping cycle."; \
- fi
-
-# Remove old bootstrap compilers
-cleanboot:
- rm -rf boot/Saved/Saved.prev/*
-
-# Compile the native-code compiler
-opt-core:runtimeopt ocamlopt libraryopt
-opt: runtimeopt ocamlopt libraryopt otherlibrariesopt camlp4opt
-
-# Native-code versions of the tools
-opt.opt: checkstack core ocaml opt-core ocamlc.opt otherlibraries camlp4out \
- $(DEBUGGER) ocamldoc ocamlopt.opt otherlibrariesopt \
- camlp4opt ocamllex.opt ocamltoolsopt.opt camlp4optopt ocamldoc.opt
-
-# Installation
-install: FORCE
- if test -d $(BINDIR); then : ; else $(MKDIR) $(BINDIR); fi
- if test -d $(LIBDIR); then : ; else $(MKDIR) $(LIBDIR); fi
- if test -d $(STUBLIBDIR); then : ; else $(MKDIR) $(LIBDIR)/stublibs; fi
- if test -d $(MANDIR)/man$(MANEXT); then : ; else $(MKDIR) $(MANDIR)/man$(MANEXT); fi
- cd $(LIBDIR); rm -f dllbigarray.so dlllabltk.so dllnums.so \
- dllthreads.so dllunix.so dllgraphics.so dllmldbm.so dllstr.so \
- dlltkanim.so
- cd byterun; $(MAKE) install
- echo "$(STUBLIBDIR)" > $(LIBDIR)/ld.conf
- echo "$(LIBDIR)" >> $(LIBDIR)/ld.conf
- cp ocamlc $(BINDIR)/ocamlc$(EXE)
- cp ocaml $(BINDIR)/ocaml$(EXE)
- cd stdlib; $(MAKE) install
- cp lex/ocamllex $(BINDIR)/ocamllex$(EXE)
- cp yacc/ocamlyacc$(EXE) $(BINDIR)/ocamlyacc$(EXE)
- cp toplevel/toplevellib.cma $(LIBDIR)/toplevellib.cma
- cp expunge $(LIBDIR)/expunge$(EXE)
- cp typing/outcometree.cmi typing/outcometree.mli $(LIBDIR)
- cp toplevel/topstart.cmo $(LIBDIR)
- cp toplevel/toploop.cmi toplevel/topdirs.cmi toplevel/topmain.cmi $(LIBDIR)
- cd tools; $(MAKE) install
- -cd man; $(MAKE) install
- for i in $(OTHERLIBRARIES); do \
- (cd otherlibs/$$i; $(MAKE) install) || exit $$?; \
- done
- cd ocamldoc; $(MAKE) install
- if test -f ocamlopt; then $(MAKE) installopt; else :; fi
- cd camlp4; $(MAKE) install BINDIR=$(BINDIR) LIBDIR=$(LIBDIR) MANDIR=$(MANDIR)
- if test -f debugger/ocamldebug; then (cd debugger; $(MAKE) install); \
- else :; fi
-
-# Installation of the native-code compiler
-installopt:
- cd asmrun; $(MAKE) install
- cp ocamlopt $(BINDIR)/ocamlopt$(EXE)
- cd stdlib; $(MAKE) installopt
- cd ocamldoc; $(MAKE) installopt
- for i in $(OTHERLIBRARIES); do (cd otherlibs/$$i; $(MAKE) installopt) || exit $$?; done
- if test -f ocamlc.opt; \
- then cp ocamlc.opt $(BINDIR)/ocamlc.opt$(EXE); else :; fi
- if test -f ocamlopt.opt; \
- then cp ocamlopt.opt $(BINDIR)/ocamlopt.opt$(EXE); else :; fi
- if test -f lex/ocamllex.opt; \
- then cp lex/ocamllex.opt $(BINDIR)/ocamllex.opt$(EXE); else :; fi
-
-clean:: partialclean
-
-# The compiler
-
-ocamlc: $(COMPOBJS)
- $(CAMLC) $(LINKFLAGS) -o ocamlc $(COMPOBJS)
- @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlc|' \
- driver/ocamlcomp.sh.in > ocamlcomp.sh
- @chmod +x ocamlcomp.sh
-
-partialclean::
- rm -f ocamlc ocamlcomp.sh
-
-# The native-code compiler
-
-ocamlopt: $(OPTOBJS)
- $(CAMLC) $(LINKFLAGS) -o ocamlopt $(OPTOBJS)
- @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlopt|' \
- driver/ocamlcomp.sh.in > ocamlcompopt.sh
- @chmod +x ocamlcompopt.sh
-
-partialclean::
- rm -f ocamlopt ocamlcompopt.sh
-
-# The toplevel
-
-ocaml: $(TOPOBJS) expunge
- $(CAMLC) $(LINKFLAGS) -linkall -o ocaml.tmp $(TOPOBJS)
- - $(CAMLRUN) ./expunge ocaml.tmp ocaml $(PERVASIVES)
- rm -f ocaml.tmp
-
-toplevel/toplevellib.cma: $(TOPLIB)
- $(CAMLC) -a -o $@ $(TOPLIB)
-
-partialclean::
- rm -f ocaml toplevel/toplevellib.cma
-
-# The configuration file
-
-utils/config.ml: utils/config.mlp config/Makefile
- @rm -f utils/config.ml
- sed -e 's|%%LIBDIR%%|$(LIBDIR)|' \
- -e 's|%%BYTERUN%%|$(BINDIR)/ocamlrun|' \
- -e 's|%%CCOMPTYPE%%|cc|' \
- -e 's|%%BYTECC%%|$(BYTECC) $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS)|' \
- -e 's|%%BYTELINK%%|$(BYTECC) $(BYTECCLINKOPTS)|' \
- -e 's|%%NATIVECC%%|$(NATIVECC) $(NATIVECCCOMPOPTS)|' \
- -e 's|%%NATIVELINK%%|$(NATIVECC) $(NATIVECCLINKOPTS)|' \
- -e 's|%%PARTIALLD%%|ld -r $(NATIVECCLINKOPTS)|' \
- -e 's|%%PACKLD%%|ld -r $(NATIVECCLINKOPTS)|' \
- -e 's|%%BYTECCLIBS%%|$(BYTECCLIBS)|' \
- -e 's|%%NATIVECCLIBS%%|$(NATIVECCLIBS)|' \
- -e 's|%%RANLIBCMD%%|$(RANLIBCMD)|' \
- -e 's|%%BINUTILS_NM%%|$(BINUTILS_NM)|' \
- -e 's|%%CC_PROFILE%%|$(CC_PROFILE)|' \
- -e 's|%%BINUTILS_OBJCOPY%%|$(BINUTILS_OBJCOPY)|' \
- -e 's|%%ARCH%%|$(ARCH)|' \
- -e 's|%%MODEL%%|$(MODEL)|' \
- -e 's|%%SYSTEM%%|$(SYSTEM)|' \
- -e 's|%%EXT_OBJ%%|.o|' \
- -e 's|%%EXT_ASM%%|.s|' \
- -e 's|%%EXT_LIB%%|.a|' \
- -e 's|%%EXT_DLL%%|.so|' \
- utils/config.mlp > utils/config.ml
- @chmod -w utils/config.ml
-
-partialclean::
- rm -f utils/config.ml
-
-beforedepend:: utils/config.ml
-
-# The parser
-
-parsing/parser.mli parsing/parser.ml: parsing/parser.mly
- $(CAMLYACC) $(YACCFLAGS) parsing/parser.mly
-
-partialclean::
- rm -f parsing/parser.mli parsing/parser.ml parsing/parser.output
-
-beforedepend:: parsing/parser.mli parsing/parser.ml
-
-# The lexer
-
-parsing/lexer.ml: parsing/lexer.mll
- $(CAMLLEX) parsing/lexer.mll
-
-partialclean::
- rm -f parsing/lexer.ml
-
-beforedepend:: parsing/lexer.ml
-
-# The auxiliary lexer for counting line numbers
-
-parsing/linenum.ml: parsing/linenum.mll
- $(CAMLLEX) parsing/linenum.mll
-
-partialclean::
- rm -f parsing/linenum.ml
-
-beforedepend:: parsing/linenum.ml
-
-# The bytecode compiler compiled with the native-code compiler
-
-ocamlc.opt: $(COMPOBJS:.cmo=.cmx)
- cd asmrun; $(MAKE) meta.o dynlink.o
- $(CAMLOPT) $(LINKFLAGS) -ccopt "$(BYTECCLINKOPTS)" -o ocamlc.opt \
- $(COMPOBJS:.cmo=.cmx) \
- asmrun/meta.o asmrun/dynlink.o -cclib "$(BYTECCLIBS)"
- @sed -e 's|@compiler@|$$topdir/ocamlc.opt|' \
- driver/ocamlcomp.sh.in > ocamlcomp.sh
- @chmod +x ocamlcomp.sh
-
-partialclean::
- rm -f ocamlc.opt
-
-# The native-code compiler compiled with itself
-
-ocamlopt.opt: $(OPTOBJS:.cmo=.cmx)
- $(CAMLOPT) $(LINKFLAGS) -o ocamlopt.opt $(OPTOBJS:.cmo=.cmx)
- @sed -e 's|@compiler@|$$topdir/ocamlopt.opt|' \
- driver/ocamlcomp.sh.in > ocamlcompopt.sh
- @chmod +x ocamlcompopt.sh
-
-partialclean::
- rm -f ocamlopt.opt
-
-$(OPTOBJS:.cmo=.cmx): ocamlopt
-
-# The numeric opcodes
-
-bytecomp/opcodes.ml: byterun/instruct.h
- sed -n -e '/^enum/p' -e 's/,//g' -e '/^ /p' byterun/instruct.h | \
- awk -f tools/make-opcodes > bytecomp/opcodes.ml
-
-partialclean::
- rm -f bytecomp/opcodes.ml
-
-beforedepend:: bytecomp/opcodes.ml
-
-# The predefined exceptions and primitives
-
-byterun/primitives:
- cd byterun; $(MAKE) primitives
-
-bytecomp/runtimedef.ml: byterun/primitives byterun/fail.h
- (echo 'let builtin_exceptions = [|'; \
- sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$$| \1;|p' byterun/fail.h | \
- sed -e '$$s/;$$//'; \
- echo '|]'; \
- echo 'let builtin_primitives = [|'; \
- sed -e 's/.*/ "&";/' -e '$$s/;$$//' byterun/primitives; \
- echo '|]') > bytecomp/runtimedef.ml
-
-partialclean::
- rm -f bytecomp/runtimedef.ml
-
-beforedepend:: bytecomp/runtimedef.ml
-
-# Choose the right machine-dependent files
-
-asmcomp/arch.ml: asmcomp/$(ARCH)/arch.ml
- ln -s $(ARCH)/arch.ml asmcomp/arch.ml
-
-partialclean::
- rm -f asmcomp/arch.ml
-
-beforedepend:: asmcomp/arch.ml
-
-asmcomp/proc.ml: asmcomp/$(ARCH)/proc.ml
- ln -s $(ARCH)/proc.ml asmcomp/proc.ml
-
-partialclean::
- rm -f asmcomp/proc.ml
-
-beforedepend:: asmcomp/proc.ml
-
-asmcomp/selection.ml: asmcomp/$(ARCH)/selection.ml
- ln -s $(ARCH)/selection.ml asmcomp/selection.ml
-
-partialclean::
- rm -f asmcomp/selection.ml
-
-beforedepend:: asmcomp/selection.ml
-
-asmcomp/reload.ml: asmcomp/$(ARCH)/reload.ml
- ln -s $(ARCH)/reload.ml asmcomp/reload.ml
-
-partialclean::
- rm -f asmcomp/reload.ml
-
-beforedepend:: asmcomp/reload.ml
-
-asmcomp/scheduling.ml: asmcomp/$(ARCH)/scheduling.ml
- ln -s $(ARCH)/scheduling.ml asmcomp/scheduling.ml
-
-partialclean::
- rm -f asmcomp/scheduling.ml
-
-beforedepend:: asmcomp/scheduling.ml
-
-# Preprocess the code emitters
-
-asmcomp/emit.ml: asmcomp/$(ARCH)/emit.mlp tools/cvt_emit
- $(CAMLRUN) tools/cvt_emit < asmcomp/$(ARCH)/emit.mlp > asmcomp/emit.ml \
- || { rm -f asmcomp/emit.ml; exit 2; }
-
-partialclean::
- rm -f asmcomp/emit.ml
-
-beforedepend:: asmcomp/emit.ml
-
-tools/cvt_emit: tools/cvt_emit.mll
- cd tools; $(MAKE) CAMLC="../$(CAMLRUN) ../ocamlc -I ../stdlib" cvt_emit
-
-# The "expunge" utility
-
-expunge: $(EXPUNGEOBJS)
- $(CAMLC) $(LINKFLAGS) -o expunge $(EXPUNGEOBJS)
-
-partialclean::
- rm -f expunge
-
-# The runtime system for the bytecode compiler
-
-runtime:
- cd byterun; $(MAKE) all
- if test -f stdlib/libcamlrun.a; then :; else \
- ln -s ../byterun/libcamlrun.a stdlib/libcamlrun.a; fi
-clean::
- cd byterun; $(MAKE) clean
- rm -f stdlib/libcamlrun.a
- rm -f stdlib/caml
-alldepend::
- cd byterun; $(MAKE) depend
-
-# The runtime system for the native-code compiler
-
-runtimeopt:
- cd asmrun; $(MAKE) all
- if test -f stdlib/libasmrun.a; then :; else \
- ln -s ../asmrun/libasmrun.a stdlib/libasmrun.a; fi
-clean::
- cd asmrun; $(MAKE) clean
- rm -f stdlib/libasmrun.a
-alldepend::
- cd asmrun; $(MAKE) depend
-
-# The library
-
-library: ocamlc
- cd stdlib; $(MAKE) all
-library-cross:
- cd stdlib; $(MAKE) RUNTIME=../byterun/ocamlrun all
-libraryopt:
- cd stdlib; $(MAKE) allopt
-partialclean::
- cd stdlib; $(MAKE) clean
-alldepend::
- cd stdlib; $(MAKE) depend
-
-# The lexer and parser generators
-
-ocamllex: ocamlyacc ocamlc
- cd lex; $(MAKE) all
-ocamllex.opt: ocamlopt
- cd lex; $(MAKE) allopt
-partialclean::
- cd lex; $(MAKE) clean
-alldepend::
- cd lex; $(MAKE) depend
-
-ocamlyacc:
- cd yacc; $(MAKE) all
-clean::
- cd yacc; $(MAKE) clean
-
-# Tools
-
-ocamltools: ocamlc ocamlyacc ocamllex
- cd tools; $(MAKE) all
-ocamltoolsopt.opt: ocamlc.opt ocamlyacc ocamllex
- cd tools; $(MAKE) opt.opt
-partialclean::
- cd tools; $(MAKE) clean
-alldepend::
- cd tools; $(MAKE) depend
-
-# OCamldoc
-
-ocamldoc: ocamlc ocamlyacc ocamllex
- cd ocamldoc && $(MAKE) all
-ocamldoc.opt: ocamlc.opt ocamlyacc ocamllex
- cd ocamldoc && $(MAKE) opt.opt
-partialclean::
- cd ocamldoc && $(MAKE) clean
-alldepend::
- cd ocamldoc && $(MAKE) depend
-
-# The extra libraries
-
-otherlibraries:
- for i in $(OTHERLIBRARIES); do \
- (cd otherlibs/$$i; $(MAKE) RUNTIME=$(RUNTIME) all) || exit $$?; \
- done
-otherlibrariesopt:
- for i in $(OTHERLIBRARIES); do \
- (cd otherlibs/$$i; $(MAKE) allopt) || exit $$?; \
- done
-partialclean::
- for i in $(OTHERLIBRARIES); do \
- (cd otherlibs/$$i; $(MAKE) partialclean); \
- done
-clean::
- for i in $(OTHERLIBRARIES); do (cd otherlibs/$$i; $(MAKE) clean); done
-alldepend::
- for i in $(OTHERLIBRARIES); do (cd otherlibs/$$i; $(MAKE) depend); done
-
-# The replay debugger
-
-ocamldebugger: ocamlc ocamlyacc ocamllex
- cd debugger; $(MAKE) all
-partialclean::
- cd debugger; $(MAKE) clean
-alldepend::
- cd debugger; $(MAKE) depend
-
-# Camlp4
-
-camlp4out: ocamlc
- cd camlp4; $(MAKE) all
-camlp4opt: ocamlopt
- cd camlp4; $(MAKE) opt
-camlp4optopt: ocamlopt
- cd camlp4; $(MAKE) opt.opt
-partialclean::
- cd camlp4; $(MAKE) clean
-alldepend::
- cd camlp4; $(MAKE) depend
-
-# Check that the stack limit is reasonable.
-
-checkstack:
- @if $(BYTECC) -o tools/checkstack tools/checkstack.c; \
- then tools/checkstack; \
- else :; \
- fi
- @rm -f tools/checkstack
-
-# Make MacOS X package
-
-package-macosx: FORCE
- make BINDIR="`pwd`"/package-macosx/root$(BINDIR) \
- LIBDIR="`pwd`"/package-macosx/root$(LIBDIR) \
- MANDIR="`pwd`"/package-macosx/root$(MANDIR) install
- tools/make-package-macosx
-clean::
- rm -rf package-macosx/root package-macosx/*.pkg package-macosx/*.dmg
-
-# Default rules
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.ml.cmo:
- $(CAMLC) $(COMPFLAGS) -c $<
-
-.mli.cmi:
- $(CAMLC) $(COMPFLAGS) -c $<
-
-.ml.cmx:
- $(CAMLOPT) $(COMPFLAGS) -c $<
-
-partialclean::
- rm -f utils/*.cm[iox] utils/*.[so] utils/*~
- rm -f parsing/*.cm[iox] parsing/*.[so] parsing/*~
- rm -f typing/*.cm[iox] typing/*.[so] typing/*~
- rm -f bytecomp/*.cm[iox] bytecomp/*.[so] bytecomp/*~
- rm -f asmcomp/*.cm[iox] asmcomp/*.[so] asmcomp/*~
- rm -f driver/*.cm[iox] driver/*.[so] driver/*~
- rm -f toplevel/*.cm[iox] toplevel/*.[so] toplevel/*~
- rm -f tools/*.cm[iox] tools/*.[so] tools/*~
- rm -f *~
-
-depend: beforedepend
- (for d in utils parsing typing bytecomp asmcomp driver toplevel; \
- do $(CAMLDEP) $(DEPFLAGS) $$d/*.mli $$d/*.ml; \
- done) > .depend
-
-alldepend:: depend
-
-FORCE:
-
-include .depend
diff --git a/Makefile.Mac b/Makefile.Mac
deleted file mode 100644
index 9fa3f69b66..0000000000
--- a/Makefile.Mac
+++ /dev/null
@@ -1,488 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-# The main Makefile
-
-MacVersion = "Mac{MAJOR}.{MINOR}.{BUGFIX}{STAGE}{REV}"
-
-CAMLC = :boot:ocamlrun :boot:ocamlc -I :boot:
-COMPFLAGS = {INCLUDES}
-LINKFLAGS =
-CAMLYACC = :boot:ocamlyacc
-YACCFLAGS =
-CAMLLEX = :boot:ocamlrun :boot:ocamllex
-CAMLDEP = :boot:ocamlrun :tools:ocamldep
-DEPFLAGS = {INCLUDES}
-CAMLRUN = :byterun:ocamlrun
-
-INCLUDES = -I :utils: -I :parsing: -I :typing: -I :bytecomp: ¶
- -I :driver: -I :toplevel:
-
-UTILS = :utils:misc.cmo :utils:tbl.cmo :utils:config.cmo ¶
- :utils:clflags.cmo :utils:terminfo.cmo :utils:ccomp.cmo ¶
- :utils:warnings.cmo
-
-PARSING = :parsing:linenum.cmo :parsing:location.cmo :parsing:longident.cmo ¶
- :parsing:syntaxerr.cmo :parsing:parser.cmo ¶
- :parsing:lexer.cmo :parsing:parse.cmo :parsing:printast.cmo
-
-TYPING = :typing:ident.cmo :typing:path.cmo ¶
- :typing:primitive.cmo :typing:types.cmo ¶
- :typing:btype.cmo ¶
- :typing:subst.cmo :typing:predef.cmo ¶
- :typing:datarepr.cmo :typing:env.cmo ¶
- :typing:typedtree.cmo ¶
- :typing:ctype.cmo :typing:printtyp.cmo ¶
- :typing:includeclass.cmo ¶
- :typing:mtype.cmo :typing:includecore.cmo ¶
- :typing:includemod.cmo :typing:parmatch.cmo ¶
- :typing:typetexp.cmo :typing:typecore.cmo ¶
- :typing:typedecl.cmo :typing:typeclass.cmo ¶
- :typing:typemod.cmo
-
-COMP = :bytecomp:lambda.cmo :bytecomp:printlambda.cmo ¶
- :bytecomp:typeopt.cmo :bytecomp:switch.cmo :bytecomp:matching.cmo ¶
- :bytecomp:translobj.cmo :bytecomp:translcore.cmo ¶
- :bytecomp:translclass.cmo :bytecomp:translmod.cmo ¶
- :bytecomp:simplif.cmo :bytecomp:runtimedef.cmo
-
-BYTECOMP = :bytecomp:meta.cmo :bytecomp:instruct.cmo :bytecomp:bytegen.cmo ¶
- :bytecomp:printinstr.cmo :bytecomp:opcodes.cmo :bytecomp:emitcode.cmo ¶
- :bytecomp:bytesections.cmo :bytecomp:dll.cmo ¶
- :bytecomp:symtable.cmo :bytecomp:bytelink.cmo :bytecomp:bytelibrarian.cmo
-
-DRIVER = :driver:errors.cmo :driver:compile.cmo :driver:main_args.cmo ¶
- :driver:main.cmo
-
-TOPLEVEL = :driver:errors.cmo :driver:compile.cmo ¶
- :toplevel:genprintval.cmo :toplevel:toploop.cmo ¶
- :toplevel:trace.cmo :toplevel:topdirs.cmo
-
-TOPLEVELMAIN = :toplevel:topmain.cmo
-
-COMPOBJS = {UTILS} {PARSING} {TYPING} {COMP} {BYTECOMP} {DRIVER}
-
-TOPLIB = {UTILS} {PARSING} {TYPING} {COMP} {BYTECOMP} {TOPLEVEL}
-
-EXPUNGEOBJS = :utils:misc.cmo :utils:tbl.cmo ¶
- :utils:config.cmo :utils:clflags.cmo ¶
- :typing:ident.cmo :typing:path.cmo ¶
- :typing:types.cmo :typing:btype.cmo :typing:predef.cmo ¶
- :bytecomp:runtimedef.cmo :bytecomp:bytesections.cmo ¶
- :bytecomp:dll.cmo :bytecomp:symtable.cmo ¶
- :toplevel:expunge.cmo
-
-PERVASIVES = arg array buffer callback char digest filename format gc hashtbl ¶
- lexing list map obj parsing pervasives printexc printf queue random ¶
- set sort stack string stream sys oo genlex topdirs toploop weak lazy ¶
- marshal int32 int64 nativeint outcometree
-
-# Recompile the system using the bootstrap compiler
-all Ä runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml ¶
- otherlibraries camlp4out maccaml
-
-# The compilation of ocaml will fail if the runtime has changed.
-# Never mind, just do make bootstrap to reach fixpoint again.
-
-# Compile everything the first time
-world Ä
- domake coldstart
- domake all
-
-# Complete bootstrapping cycle
-bootstrap Ä
- # Save the original bootstrap compiler
- domake backup
- # Promote the new compiler but keep the old runtime
- # This compiler runs on :boot:ocamlrun and produces bytecode for
- # :byterun:ocamlrun
- domake promote-cross
- # Rebuild ocamlc and ocamllex (run on :byterun:ocamlrun)
- domake partialclean
- domake ocamlc ocamllex
- # Rebuild the library (using :byterun:ocamlrun :ocamlc)
- domake library-cross
- # Promote the new compiler and the new runtime
- domake promote
- # Rebuild everything, including ocaml and the tools
- domake partialclean
- domake all
- # Check if fixpoint reached
- domake compare
-
-LIBFILES = :stdlib.cma :std_exit.cmo :Å.cmi camlheader
-
-# Start up the system from the distribution compiler
-coldstart Ä
- directory :byterun; domake all; directory ::
- duplicate -y :byterun:ocamlrun :boot:ocamlrun
- directory :yacc; domake all; directory ::
- duplicate -y :yacc:ocamlyacc :boot:ocamlyacc
- directory :stdlib
- domake -d COMPILER=::boot:ocamlc all
- duplicate -y {LIBFILES} ::boot:
- directory ::
-
-# Build the core system: the minimum needed to make depend and bootstrap
-core Ä runtime ocamlc ocamllex ocamlyacc ocamltools library
-
-# Save the current bootstrap compiler
-backup Ä
- if `exists -d :boot:Saved:` == ""
- newfolder :boot:Saved:
- end
- move :boot:Saved: :boot:Saved.prev:
- newfolder :boot:Saved:
- move :boot:Saved.prev: :boot:Saved:Saved.prev:
- duplicate -y :boot:ocamlrun :boot:Saved:
- move :boot:ocamlc :boot:ocamllex :boot:ocamlyacc :boot:Saved:
- directory :boot; duplicate -y {LIBFILES} :Saved:; directory ::
-
-# Promote the newly compiled system to the rank of cross compiler
-# (Runs on the old runtime, produces code for the new runtime)
-promote-cross Ä
- duplicate -y :ocamlc :boot:ocamlc
- duplicate -y :lex:ocamllex :boot:ocamllex
- duplicate -y :yacc:ocamlyacc :boot:ocamlyacc
- directory :stdlib
- duplicate -y {LIBFILES} ::boot: || set status 0
- directory ::
-
-# Promote the newly compiled system to the rank of bootstrap compiler
-# (Runs on the new runtime, produces code for the new runtime)
-promote Ä promote-cross
- duplicate -y :byterun:ocamlrun :boot:ocamlrun
-
-clean ÄÄ
- delete -i :boot:Å.cm[aio] || set status 0
- delete -i :boot:camlheader :boot:ocamlrun :boot:ocamlyacc
-
-# Restore the saved bootstrap compiler if a problem arises
-restore Ä
- move -y :boot:Saved:Å :boot:
- delete -y :boot:Saved:
- move -y :boot:Saved.prev: :boot:Saved:
-
-# Check if fixpoint reached
-compare Ä
- set exit 0
- equal -q :boot:ocamlc :ocamlc && equal -q :boot:ocamllex :lex:ocamllex
- if {status}
- echo "¶nFixpoint not reached, try one more bootstrapping cycle.¶n"
- else
- echo "¶nFixpoint reached, bootstrap succeeded.¶n"
- end
-
-# Remove old bootstrap compilers
-cleanboot Ä
- delete -i -y :boot:Saved:Saved.prev:Å || set status 0
-
-
-install Ä $OutOfDate
- flush
- for i in "{BINDIR}" "{LIBDIR}" "{APPLIDIR}" "{APPLIDIR}stdlib:"
- if "`exists -d "{i}"`" == ""
- newfolder "{i}"
- end
- end
- directory :byterun:
- domake install
- directory ::
- duplicate -y :ocamlc "{BINDIR}ocamlc"
- duplicate -y :ocaml "{BINDIR}ocaml"
- directory :stdlib:
- domake install
- directory ::
- duplicate -y :lex:ocamllex "{BINDIR}ocamllex"
- duplicate -y :yacc:ocamlyacc "{BINDIR}ocamlyacc"
- duplicate -y toplevellib.cma expunge "{LIBDIR}"
- duplicate -y :typing:outcometree.cmi :typing:outcometree.mli "{LIBDIR}"
- duplicate -y :toplevel:topmain.cmo "{LIBDIR}topmain.cmo"
- duplicate -y :toplevel:toploop.cmi :toplevel:topdirs.cmi "{LIBDIR}"
- directory :tools:
- domake install
- directory ::
- directory :camlp4:
- execute :config:config.mpw
- domake install -d LIBDIR="{LIBDIR}camlp4:"
- directory ::
- duplicate -y :man:ocaml.help "{HELPFILE}"
- for i in {OTHERLIBRARIES}
- directory :otherlibs:{i}
- domake install
- directory :::
- end
- duplicate -y "{LIBDIR}"Å "{APPLIDIR}stdlib:"
- duplicate -y :test:Moretest:graph_example.ml "{APPLIDIR}"
- directory :maccaml:
- domake install
- directory ::
-
-clean ÄÄ partialclean
-
-
-# The compiler
-
-ocamlc Ä {COMPOBJS}
- {CAMLC} {LINKFLAGS} -o ocamlc {COMPOBJS}
-
-partialclean ÄÄ
- delete -i ocamlc
-
-
-# The toplevel
-
-ocaml Ä toplevellib.cma {TOPLEVELMAIN} expunge
- {CAMLC} {LINKFLAGS} -linkall -o ocaml.tmp toplevellib.cma {TOPLEVELMAIN}
- {CAMLRUN} :expunge ocaml.tmp ocaml {PERVASIVES} || set status 0
- delete -i ocaml.tmp
-
-toplevellib.cma Ä {TOPLIB}
- {CAMLC} -a -o toplevellib.cma {TOPLIB}
-
-partialclean ÄÄ
- delete -i ocaml toplevellib.cma
-
-
-# The configuration file
-
-:utils:config.ml Ä :utils:config.mlp :config:config.Mac
- delete -i :utils:config.ml
- streamedit -e "/let version =/ replace /¶¶¶"°/ ¶"/{MacVersion}¶¶¶"¶"" ¶
- -e "1,$ replace /%%BYTERUN%%/ ¶"{BINDIR}ocamlrun¶"" ¶
- -e "1,$ replace /%%LIBDIR%%/ ¶"{LIBDIR}¶"" ¶
- -e "1,$ replace /%%EXT_OBJ%%/ '.o'" ¶
- -e "1,$ replace /%%EXT_LIB%%/ '.x'" ¶
- :utils:config.mlp > :utils:config.ml
-
-partialclean ÄÄ
- delete -i :utils:config.ml
-
-beforedepend ÄÄ :utils:config.ml
-
-
-# The parser
-
-:parsing:parser.mli Ä :parsing:parser.ml
- echo -n
-
-:parsing:parser.ml Ä :parsing:parser.mly
- {CAMLYACC} {YACCFLAGS} :parsing:parser.mly
-
-partialclean ÄÄ
- delete -i :parsing:parser.mli :parsing:parser.ml :parsing:parser.output
-
-beforedepend ÄÄ :parsing:parser.mli :parsing:parser.ml
-
-
-# The lexer
-
-:parsing:lexer.ml Ä :parsing:lexer.mll
- streamedit -e "1,$ replace /¶¶''\223'¶¶'-¶¶''\246'¶¶'/ '' -c °" ¶
- -e "1,$ replace /¶¶''\248'¶¶'-¶¶''\255'¶¶'/ '' -c °" ¶
- -e "1,$ replace /¶¶''\192'¶¶'-¶¶''\214'¶¶'/ '' -c °" ¶
- -e "1,$ replace /¶¶''\216'¶¶'-¶¶''\222'¶¶'/ '' -c °" ¶
- -e "1,$ replace /¶¶''\216'¶¶'-¶¶''\246'¶¶'/ '' -c °" ¶
- <:parsing:lexer.mll >:parsing:lexer_tmp.mll
- {CAMLLEX} :parsing:lexer_tmp.mll
- rename -y :parsing:lexer_tmp.ml :parsing:lexer.ml
-
-partialclean ÄÄ
- delete -i :parsing:lexer.ml
-
-beforedepend ÄÄ :parsing:lexer.ml
-
-
-# The auxiliary lexer for counting line numbers
-
-:parsing:linenum.ml Ä :parsing:linenum.mll
- {CAMLLEX} :parsing:linenum.mll
-
-partialclean ÄÄ
- delete -i :parsing:linenum.ml
-
-beforedepend ÄÄ :parsing:linenum.ml
-
-
-# The numeric opcodes
-
-:bytecomp:opcodes.ml Ä :byterun:instruct.h
- :tools:make-opcodes.Mac :byterun:instruct.h :bytecomp:opcodes.ml
-
-partialclean ÄÄ
- delete -i :bytecomp:opcodes.ml
-
-beforedepend ÄÄ :bytecomp:opcodes.ml
-
-
-# The predefined exceptions and primitives
-
-:byterun:primitives Ä
- directory :byterun:
- domake primitives
- directory ::
-
-:bytecomp:runtimedef.ml Ä :byterun:primitives :byterun:fail.h
- (echo 'let builtin_exceptions = [|' ; ¶
- streamedit -d -e '/¶/¶* (¶"[A-Za-z_]*¶")¨0 ¶*¶/°/ print ¨0 ";"' :byterun:fail.h | ¶
- streamedit -e '$ replace /;°/ "|]"'; ¶
- echo 'let builtin_primitives = [|'; ¶
- streamedit -e "1,$ replace /(Å)¨0/ ' ¶"' ¨0 '¶";'" -e '$ replace /;°/ "|]"' :byterun:primitives; ¶
- ) > :bytecomp:runtimedef.ml
-
-partialclean ÄÄ
- delete -i :bytecomp:runtimedef.ml
-
-beforedepend ÄÄ :bytecomp:runtimedef.ml
-
-
-# The "expunge" utility
-
-expunge Ä {EXPUNGEOBJS}
- {CAMLC} {LINKFLAGS} -o expunge {EXPUNGEOBJS}
-
-partialclean ÄÄ
- delete -i expunge
-
-
-# The runtime system for the bytecode compiler
-
-runtime Ä
- directory :byterun:; domake all; directory ::
-clean ÄÄ
- directory :byterun:; domake clean; directory ::
-alldepend ÄÄ
- directory :byterun:; domake depend; directory ::
-
-
-# The library
-
-library Ä ocamlc
- directory :stdlib; domake all; directory ::
-library-cross Ä
- directory :stdlib; domake -d RUNTIME=::byterun:ocamlrun all; directory ::
-partialclean ÄÄ
- directory :stdlib; domake clean; directory ::
-alldepend ÄÄ
- directory :stdlib; domake depend; directory ::
-
-
-# The lexer and parser generators
-
-ocamllex Ä ocamlyacc ocamlc
- directory :lex; domake all; directory ::
-partialclean ÄÄ
- directory :lex; domake clean; directory ::
-alldepend ÄÄ
- directory :lex; domake depend; directory ::
-
-ocamlyacc Ä
- directory :yacc; domake all; directory ::
-clean ÄÄ
- directory :yacc; domake clean; directory ::
-
-
-# Tools
-
-ocamltools Ä ocamlc ocamlyacc ocamllex
- directory :tools; domake all; directory ::
-partialclean ÄÄ
- directory :tools; domake clean; directory ::
-alldepend ÄÄ
- directory :tools; domake depend; directory ::
-
-
-# The extra libraries
-
-otherlibraries Ä
- for i in {OTHERLIBRARIES}
- directory :otherlibs:{i}; domake all; directory :::
- end
-partialclean ÄÄ
- for i in {OTHERLIBRARIES}
- directory :otherlibs:{i}; domake partialclean; directory :::
- end
-clean ÄÄ
- for i in {OTHERLIBRARIES}
- directory :otherlibs:{i}; domake clean; directory :::
- end
-alldepend ÄÄ
- for i in {OTHERLIBRARIES}
- directory :otherlibs:{i}; domake depend; directory :::
- end
-
-
-# Camlp4
-
-camlp4out Ä ocamlc
- directory :camlp4:
- execute :config:config.mpw
- domake all
- directory ::
-
-partialclean ÄÄ
- directory :camlp4:
- execute :config:config.mpw
- domake clean
- directory ::
-
-alldepend ÄÄ
- directory :camlp4:
- execute :config:config.mpw
- domake depend
- directory ::
-
-# The standalone application
-
-maccaml Ä
- directory :maccaml:; domake all; directory ::
-partialclean ÄÄ
- directory :maccaml:; domake partialclean; directory ::
-clean ÄÄ
- directory :maccaml:; domake clean; directory ::
-alldepend ÄÄ
- directory :maccaml:; domake depend; directory ::
-
-
-# Clean up the test directory
-
-clean ÄÄ
- if `exists :test:`
- directory :test:; domake clean; directory ::
- end
-
-
-# Default rules
-
-.cmo Ä .ml
- {CAMLC} {COMPFLAGS} -c {depdir}{default}.ml
-
-.cmi Ä .mli
- {CAMLC} {COMPFLAGS} -c {depdir}{default}.mli
-
-partialclean ÄÄ
- for i in utils parsing typing bytecomp driver toplevel tools
- delete -i :{i}:Å.cm[io] || set status 0
- end
-
-depend Ä beforedepend
- for d in utils parsing typing bytecomp driver toplevel
- {CAMLDEP} {DEPFLAGS} :{d}:Å.mli :{d}:Å.ml
- end > Makefile.Mac.depend
-
-alldepend ÄÄ depend
-
-
-# Make sure the config file was executed
-dummy Ä {OTHERLIBRARIES}
diff --git a/Makefile.Mac.depend b/Makefile.Mac.depend
deleted file mode 100644
index ecc9ddd1f8..0000000000
--- a/Makefile.Mac.depend
+++ /dev/null
@@ -1,548 +0,0 @@
-:bytecomp:dll.cmo Ä :bytecomp:dll.cmi
-:utils:ccomp.cmoÄ :utils:clflags.cmo :utils:config.cmi :utils:misc.cmi ¶
- :utils:ccomp.cmi
-:utils:ccomp.cmxÄ :utils:clflags.cmx :utils:config.cmx :utils:misc.cmx ¶
- :utils:ccomp.cmi
-:utils:clflags.cmoÄ :utils:config.cmi
-:utils:clflags.cmxÄ :utils:config.cmx
-:utils:config.cmoÄ :utils:config.cmi
-:utils:config.cmxÄ :utils:config.cmi
-:utils:misc.cmoÄ :utils:misc.cmi
-:utils:misc.cmxÄ :utils:misc.cmi
-:utils:tbl.cmoÄ :utils:tbl.cmi
-:utils:tbl.cmxÄ :utils:tbl.cmi
-:utils:terminfo.cmoÄ :utils:terminfo.cmi
-:utils:terminfo.cmxÄ :utils:terminfo.cmi
-:utils:warnings.cmoÄ :utils:warnings.cmi
-:utils:warnings.cmxÄ :utils:warnings.cmi
-:parsing:lexer.cmiÄ :parsing:parser.cmi
-:parsing:location.cmiÄ :utils:warnings.cmi
-:parsing:parse.cmiÄ :parsing:parsetree.cmi
-:parsing:parser.cmiÄ :parsing:parsetree.cmi
-:parsing:parsetree.cmiÄ :parsing:asttypes.cmi :parsing:location.cmi ¶
- :parsing:longident.cmi
-:parsing:printast.cmiÄ :parsing:parsetree.cmi
-:parsing:pstream.cmiÄ :parsing:parsetree.cmi
-:parsing:syntaxerr.cmiÄ :parsing:location.cmi
-:parsing:lexer.cmoÄ :parsing:location.cmi :utils:misc.cmi :parsing:parser.cmi ¶
- :utils:warnings.cmi :parsing:lexer.cmi
-:parsing:lexer.cmxÄ :parsing:location.cmx :utils:misc.cmx :parsing:parser.cmx ¶
- :utils:warnings.cmx :parsing:lexer.cmi
-:parsing:linenum.cmoÄ :utils:misc.cmi :parsing:linenum.cmi
-:parsing:linenum.cmxÄ :utils:misc.cmx :parsing:linenum.cmi
-:parsing:location.cmoÄ :parsing:linenum.cmi :utils:terminfo.cmi ¶
- :utils:warnings.cmi :parsing:location.cmi
-:parsing:location.cmxÄ :parsing:linenum.cmx :utils:terminfo.cmx ¶
- :utils:warnings.cmx :parsing:location.cmi
-:parsing:longident.cmoÄ :utils:misc.cmi :parsing:longident.cmi
-:parsing:longident.cmxÄ :utils:misc.cmx :parsing:longident.cmi
-:parsing:parse.cmoÄ :parsing:lexer.cmi :parsing:location.cmi ¶
- :parsing:parser.cmi :parsing:syntaxerr.cmi :parsing:parse.cmi
-:parsing:parse.cmxÄ :parsing:lexer.cmx :parsing:location.cmx ¶
- :parsing:parser.cmx :parsing:syntaxerr.cmx :parsing:parse.cmi
-:parsing:parser.cmoÄ :parsing:asttypes.cmi :utils:clflags.cmo ¶
- :parsing:location.cmi :parsing:longident.cmi :parsing:parsetree.cmi ¶
- :parsing:pstream.cmi :parsing:syntaxerr.cmi :parsing:parser.cmi
-:parsing:parser.cmxÄ :parsing:asttypes.cmi :utils:clflags.cmx ¶
- :parsing:location.cmx :parsing:longident.cmx :parsing:parsetree.cmi ¶
- :parsing:pstream.cmx :parsing:syntaxerr.cmx :parsing:parser.cmi
-:parsing:printast.cmoÄ :parsing:asttypes.cmi :parsing:location.cmi ¶
- :parsing:longident.cmi :parsing:parsetree.cmi :parsing:printast.cmi
-:parsing:printast.cmxÄ :parsing:asttypes.cmi :parsing:location.cmx ¶
- :parsing:longident.cmx :parsing:parsetree.cmi :parsing:printast.cmi
-:parsing:pstream.cmoÄ :parsing:asttypes.cmi :parsing:location.cmi ¶
- :parsing:longident.cmi :parsing:parsetree.cmi :parsing:pstream.cmi
-:parsing:pstream.cmxÄ :parsing:asttypes.cmi :parsing:location.cmx ¶
- :parsing:longident.cmx :parsing:parsetree.cmi :parsing:pstream.cmi
-:parsing:syntaxerr.cmoÄ :parsing:location.cmi :parsing:syntaxerr.cmi
-:parsing:syntaxerr.cmxÄ :parsing:location.cmx :parsing:syntaxerr.cmi
-:typing:btype.cmiÄ :parsing:asttypes.cmi :typing:path.cmi :typing:types.cmi
-:typing:ctype.cmiÄ :parsing:asttypes.cmi :typing:env.cmi :typing:ident.cmi ¶
- :typing:path.cmi :typing:types.cmi
-:typing:datarepr.cmiÄ :parsing:asttypes.cmi :typing:path.cmi ¶
- :typing:types.cmi
-:typing:env.cmiÄ :typing:ident.cmi :parsing:longident.cmi :typing:path.cmi ¶
- :typing:types.cmi
-:typing:includeclass.cmiÄ :typing:ctype.cmi :typing:env.cmi ¶
- :typing:typedtree.cmi :typing:types.cmi
-:typing:includecore.cmiÄ :typing:env.cmi :typing:ident.cmi ¶
- :typing:typedtree.cmi :typing:types.cmi
-:typing:includemod.cmiÄ :typing:ctype.cmi :typing:env.cmi :typing:ident.cmi ¶
- :typing:typedtree.cmi :typing:types.cmi
-:typing:mtype.cmiÄ :typing:env.cmi :typing:ident.cmi :typing:path.cmi ¶
- :typing:types.cmi
-:typing:parmatch.cmiÄ :typing:env.cmi :parsing:location.cmi ¶
- :typing:typedtree.cmi :typing:types.cmi
-:typing:path.cmiÄ :typing:ident.cmi
-:typing:predef.cmiÄ :typing:ident.cmi :typing:path.cmi :typing:types.cmi
-:typing:printtyp.cmiÄ :typing:ident.cmi :parsing:longident.cmi ¶
- :typing:outcometree.cmi :typing:path.cmi :typing:types.cmi
-:typing:subst.cmiÄ :typing:ident.cmi :typing:path.cmi :typing:types.cmi
-:typing:typeclass.cmiÄ :parsing:asttypes.cmi :typing:ctype.cmi ¶
- :typing:env.cmi :typing:ident.cmi :parsing:location.cmi ¶
- :parsing:longident.cmi :parsing:parsetree.cmi :typing:typedtree.cmi ¶
- :typing:types.cmi
-:typing:typecore.cmiÄ :parsing:asttypes.cmi :typing:env.cmi :typing:ident.cmi ¶
- :parsing:location.cmi :parsing:longident.cmi :parsing:parsetree.cmi ¶
- :typing:typedtree.cmi :typing:types.cmi
-:typing:typedecl.cmiÄ :typing:env.cmi :typing:ident.cmi :parsing:location.cmi ¶
- :parsing:longident.cmi :parsing:parsetree.cmi :typing:path.cmi ¶
- :typing:types.cmi
-:typing:typedtree.cmiÄ :parsing:asttypes.cmi :typing:env.cmi ¶
- :typing:ident.cmi :parsing:location.cmi :typing:path.cmi ¶
- :typing:primitive.cmi :typing:types.cmi
-:typing:typemod.cmiÄ :typing:env.cmi :typing:ident.cmi :typing:includemod.cmi ¶
- :parsing:location.cmi :parsing:longident.cmi :parsing:parsetree.cmi ¶
- :typing:typedtree.cmi :typing:types.cmi
-:typing:types.cmiÄ :parsing:asttypes.cmi :typing:ident.cmi :typing:path.cmi ¶
- :typing:primitive.cmi
-:typing:typetexp.cmiÄ :typing:env.cmi :parsing:location.cmi ¶
- :parsing:longident.cmi :parsing:parsetree.cmi :typing:types.cmi
-:typing:btype.cmoÄ :utils:misc.cmi :typing:path.cmi :typing:types.cmi ¶
- :typing:btype.cmi
-:typing:btype.cmxÄ :utils:misc.cmx :typing:path.cmx :typing:types.cmx ¶
- :typing:btype.cmi
-:typing:ctype.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi :utils:clflags.cmo ¶
- :typing:env.cmi :typing:ident.cmi :parsing:longident.cmi :utils:misc.cmi ¶
- :typing:path.cmi :typing:subst.cmi :typing:types.cmi :typing:ctype.cmi
-:typing:ctype.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx :utils:clflags.cmx ¶
- :typing:env.cmx :typing:ident.cmx :parsing:longident.cmx :utils:misc.cmx ¶
- :typing:path.cmx :typing:subst.cmx :typing:types.cmx :typing:ctype.cmi
-:typing:datarepr.cmoÄ :parsing:asttypes.cmi :utils:misc.cmi ¶
- :typing:predef.cmi :typing:types.cmi :typing:datarepr.cmi
-:typing:datarepr.cmxÄ :parsing:asttypes.cmi :utils:misc.cmx ¶
- :typing:predef.cmx :typing:types.cmx :typing:datarepr.cmi
-:typing:env.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi :utils:config.cmi ¶
- :typing:datarepr.cmi :typing:ident.cmi :parsing:longident.cmi ¶
- :utils:misc.cmi :typing:path.cmi :typing:predef.cmi :typing:subst.cmi ¶
- :utils:tbl.cmi :typing:types.cmi :typing:env.cmi
-:typing:env.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx :utils:config.cmx ¶
- :typing:datarepr.cmx :typing:ident.cmx :parsing:longident.cmx ¶
- :utils:misc.cmx :typing:path.cmx :typing:predef.cmx :typing:subst.cmx ¶
- :utils:tbl.cmx :typing:types.cmx :typing:env.cmi
-:typing:ident.cmoÄ :typing:ident.cmi
-:typing:ident.cmxÄ :typing:ident.cmi
-:typing:includeclass.cmoÄ :typing:ctype.cmi :typing:printtyp.cmi ¶
- :typing:types.cmi :typing:includeclass.cmi
-:typing:includeclass.cmxÄ :typing:ctype.cmx :typing:printtyp.cmx ¶
- :typing:types.cmx :typing:includeclass.cmi
-:typing:includecore.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶
- :typing:ctype.cmi :utils:misc.cmi :typing:path.cmi :typing:predef.cmi ¶
- :typing:typedtree.cmi :typing:types.cmi :typing:includecore.cmi
-:typing:includecore.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶
- :typing:ctype.cmx :utils:misc.cmx :typing:path.cmx :typing:predef.cmx ¶
- :typing:typedtree.cmx :typing:types.cmx :typing:includecore.cmi
-:typing:includemod.cmoÄ :typing:ctype.cmi :typing:env.cmi :typing:ident.cmi ¶
- :typing:includeclass.cmi :typing:includecore.cmi :utils:misc.cmi ¶
- :typing:mtype.cmi :typing:path.cmi :typing:printtyp.cmi :typing:subst.cmi ¶
- :utils:tbl.cmi :typing:typedtree.cmi :typing:types.cmi ¶
- :typing:includemod.cmi
-:typing:includemod.cmxÄ :typing:ctype.cmx :typing:env.cmx :typing:ident.cmx ¶
- :typing:includeclass.cmx :typing:includecore.cmx :utils:misc.cmx ¶
- :typing:mtype.cmx :typing:path.cmx :typing:printtyp.cmx :typing:subst.cmx ¶
- :utils:tbl.cmx :typing:typedtree.cmx :typing:types.cmx ¶
- :typing:includemod.cmi
-:typing:mtype.cmoÄ :typing:btype.cmi :typing:ctype.cmi :typing:env.cmi ¶
- :typing:ident.cmi :typing:path.cmi :typing:types.cmi :typing:mtype.cmi
-:typing:mtype.cmxÄ :typing:btype.cmx :typing:ctype.cmx :typing:env.cmx ¶
- :typing:ident.cmx :typing:path.cmx :typing:types.cmx :typing:mtype.cmi
-:typing:parmatch.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶
- :typing:ctype.cmi :typing:datarepr.cmi :typing:env.cmi :typing:ident.cmi ¶
- :parsing:location.cmi :utils:misc.cmi :typing:path.cmi ¶
- :typing:typedtree.cmi :typing:types.cmi :utils:warnings.cmi ¶
- :typing:parmatch.cmi
-:typing:parmatch.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶
- :typing:ctype.cmx :typing:datarepr.cmx :typing:env.cmx :typing:ident.cmx ¶
- :parsing:location.cmx :utils:misc.cmx :typing:path.cmx ¶
- :typing:typedtree.cmx :typing:types.cmx :utils:warnings.cmx ¶
- :typing:parmatch.cmi
-:typing:path.cmoÄ :typing:ident.cmi :typing:path.cmi
-:typing:path.cmxÄ :typing:ident.cmx :typing:path.cmi
-:typing:predef.cmoÄ :typing:btype.cmi :typing:ident.cmi :typing:path.cmi ¶
- :typing:types.cmi :typing:predef.cmi
-:typing:predef.cmxÄ :typing:btype.cmx :typing:ident.cmx :typing:path.cmx ¶
- :typing:types.cmx :typing:predef.cmi
-:typing:primitive.cmoÄ :utils:misc.cmi :typing:primitive.cmi
-:typing:primitive.cmxÄ :utils:misc.cmx :typing:primitive.cmi
-:typing:printtyp.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶
- :utils:clflags.cmo :typing:ctype.cmi :typing:env.cmi :typing:ident.cmi ¶
- :parsing:longident.cmi :utils:misc.cmi :typing:outcometree.cmi ¶
- :typing:path.cmi :typing:predef.cmi :typing:primitive.cmi ¶
- :typing:types.cmi :typing:printtyp.cmi
-:typing:printtyp.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶
- :utils:clflags.cmx :typing:ctype.cmx :typing:env.cmx :typing:ident.cmx ¶
- :parsing:longident.cmx :utils:misc.cmx :typing:outcometree.cmi ¶
- :typing:path.cmx :typing:predef.cmx :typing:primitive.cmx ¶
- :typing:types.cmx :typing:printtyp.cmi
-:typing:subst.cmoÄ :typing:btype.cmi :typing:ident.cmi :utils:misc.cmi ¶
- :typing:path.cmi :utils:tbl.cmi :typing:types.cmi :typing:subst.cmi
-:typing:subst.cmxÄ :typing:btype.cmx :typing:ident.cmx :utils:misc.cmx ¶
- :typing:path.cmx :utils:tbl.cmx :typing:types.cmx :typing:subst.cmi
-:typing:typeclass.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶
- :utils:clflags.cmo :typing:ctype.cmi :typing:env.cmi :typing:ident.cmi ¶
- :typing:includeclass.cmi :parsing:location.cmi :parsing:longident.cmi ¶
- :utils:misc.cmi :typing:parmatch.cmi :parsing:parsetree.cmi ¶
- :typing:path.cmi :typing:predef.cmi :typing:printtyp.cmi ¶
- :typing:typecore.cmi :typing:typedecl.cmi :typing:typedtree.cmi ¶
- :typing:types.cmi :typing:typetexp.cmi :utils:warnings.cmi ¶
- :typing:typeclass.cmi
-:typing:typeclass.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶
- :utils:clflags.cmx :typing:ctype.cmx :typing:env.cmx :typing:ident.cmx ¶
- :typing:includeclass.cmx :parsing:location.cmx :parsing:longident.cmx ¶
- :utils:misc.cmx :typing:parmatch.cmx :parsing:parsetree.cmi ¶
- :typing:path.cmx :typing:predef.cmx :typing:printtyp.cmx ¶
- :typing:typecore.cmx :typing:typedecl.cmx :typing:typedtree.cmx ¶
- :typing:types.cmx :typing:typetexp.cmx :utils:warnings.cmx ¶
- :typing:typeclass.cmi
-:typing:typecore.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶
- :utils:clflags.cmo :typing:ctype.cmi :typing:env.cmi :typing:ident.cmi ¶
- :parsing:location.cmi :parsing:longident.cmi :utils:misc.cmi ¶
- :typing:parmatch.cmi :parsing:parsetree.cmi :typing:path.cmi ¶
- :typing:predef.cmi :typing:primitive.cmi :typing:printtyp.cmi ¶
- :typing:typedtree.cmi :typing:types.cmi :typing:typetexp.cmi ¶
- :utils:warnings.cmi :typing:typecore.cmi
-:typing:typecore.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶
- :utils:clflags.cmx :typing:ctype.cmx :typing:env.cmx :typing:ident.cmx ¶
- :parsing:location.cmx :parsing:longident.cmx :utils:misc.cmx ¶
- :typing:parmatch.cmx :parsing:parsetree.cmi :typing:path.cmx ¶
- :typing:predef.cmx :typing:primitive.cmx :typing:printtyp.cmx ¶
- :typing:typedtree.cmx :typing:types.cmx :typing:typetexp.cmx ¶
- :utils:warnings.cmx :typing:typecore.cmi
-:typing:typedecl.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶
- :utils:clflags.cmo :utils:config.cmi :typing:ctype.cmi :typing:env.cmi ¶
- :typing:ident.cmi :typing:includecore.cmi :parsing:location.cmi ¶
- :parsing:longident.cmi :utils:misc.cmi :parsing:parsetree.cmi ¶
- :typing:path.cmi :typing:predef.cmi :typing:primitive.cmi ¶
- :typing:printtyp.cmi :typing:subst.cmi :typing:typedtree.cmi ¶
- :typing:types.cmi :typing:typetexp.cmi :typing:typedecl.cmi
-:typing:typedecl.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶
- :utils:clflags.cmx :utils:config.cmx :typing:ctype.cmx :typing:env.cmx ¶
- :typing:ident.cmx :typing:includecore.cmx :parsing:location.cmx ¶
- :parsing:longident.cmx :utils:misc.cmx :parsing:parsetree.cmi ¶
- :typing:path.cmx :typing:predef.cmx :typing:primitive.cmx ¶
- :typing:printtyp.cmx :typing:subst.cmx :typing:typedtree.cmx ¶
- :typing:types.cmx :typing:typetexp.cmx :typing:typedecl.cmi
-:typing:typedtree.cmoÄ :parsing:asttypes.cmi :typing:env.cmi ¶
- :typing:ident.cmi :parsing:location.cmi :utils:misc.cmi :typing:path.cmi ¶
- :typing:primitive.cmi :typing:types.cmi :typing:typedtree.cmi
-:typing:typedtree.cmxÄ :parsing:asttypes.cmi :typing:env.cmx ¶
- :typing:ident.cmx :parsing:location.cmx :utils:misc.cmx :typing:path.cmx ¶
- :typing:primitive.cmx :typing:types.cmx :typing:typedtree.cmi
-:typing:typemod.cmoÄ :utils:clflags.cmo :utils:config.cmi :typing:ctype.cmi ¶
- :typing:env.cmi :typing:ident.cmi :typing:includemod.cmi ¶
- :parsing:location.cmi :parsing:longident.cmi :utils:misc.cmi ¶
- :typing:mtype.cmi :parsing:parsetree.cmi :typing:path.cmi ¶
- :typing:printtyp.cmi :typing:subst.cmi :typing:typeclass.cmi ¶
- :typing:typecore.cmi :typing:typedecl.cmi :typing:typedtree.cmi ¶
- :typing:types.cmi :typing:typemod.cmi
-:typing:typemod.cmxÄ :utils:clflags.cmx :utils:config.cmx :typing:ctype.cmx ¶
- :typing:env.cmx :typing:ident.cmx :typing:includemod.cmx ¶
- :parsing:location.cmx :parsing:longident.cmx :utils:misc.cmx ¶
- :typing:mtype.cmx :parsing:parsetree.cmi :typing:path.cmx ¶
- :typing:printtyp.cmx :typing:subst.cmx :typing:typeclass.cmx ¶
- :typing:typecore.cmx :typing:typedecl.cmx :typing:typedtree.cmx ¶
- :typing:types.cmx :typing:typemod.cmi
-:typing:types.cmoÄ :parsing:asttypes.cmi :typing:ident.cmi :utils:misc.cmi ¶
- :typing:path.cmi :typing:primitive.cmi :typing:types.cmi
-:typing:types.cmxÄ :parsing:asttypes.cmi :typing:ident.cmx :utils:misc.cmx ¶
- :typing:path.cmx :typing:primitive.cmx :typing:types.cmi
-:typing:typetexp.cmoÄ :typing:btype.cmi :typing:ctype.cmi :typing:env.cmi ¶
- :parsing:location.cmi :parsing:longident.cmi :utils:misc.cmi ¶
- :parsing:parsetree.cmi :typing:printtyp.cmi :utils:tbl.cmi ¶
- :typing:types.cmi :typing:typetexp.cmi
-:typing:typetexp.cmxÄ :typing:btype.cmx :typing:ctype.cmx :typing:env.cmx ¶
- :parsing:location.cmx :parsing:longident.cmx :utils:misc.cmx ¶
- :parsing:parsetree.cmi :typing:printtyp.cmx :utils:tbl.cmx ¶
- :typing:types.cmx :typing:typetexp.cmi
-:bytecomp:bytegen.cmiÄ :bytecomp:instruct.cmi :bytecomp:lambda.cmi
-:bytecomp:bytelink.cmiÄ :bytecomp:emitcode.cmi :bytecomp:symtable.cmi
-:bytecomp:emitcode.cmiÄ :typing:ident.cmi :bytecomp:instruct.cmi ¶
- :bytecomp:lambda.cmi
-:bytecomp:instruct.cmiÄ :typing:env.cmi :typing:ident.cmi ¶
- :bytecomp:lambda.cmi :typing:types.cmi
-:bytecomp:lambda.cmiÄ :parsing:asttypes.cmi :typing:env.cmi :typing:ident.cmi ¶
- :typing:path.cmi :typing:primitive.cmi :typing:types.cmi
-:bytecomp:matching.cmiÄ :typing:ident.cmi :bytecomp:lambda.cmi ¶
- :parsing:location.cmi :typing:typedtree.cmi
-:bytecomp:printinstr.cmiÄ :bytecomp:instruct.cmi
-:bytecomp:printlambda.cmiÄ :bytecomp:lambda.cmi
-:bytecomp:simplif.cmiÄ :bytecomp:lambda.cmi
-:bytecomp:symtable.cmiÄ :bytecomp:emitcode.cmi :typing:ident.cmi
-:bytecomp:translclass.cmiÄ :typing:ident.cmi :bytecomp:lambda.cmi ¶
- :parsing:location.cmi :typing:typedtree.cmi
-:bytecomp:translcore.cmiÄ :parsing:asttypes.cmi :typing:ident.cmi ¶
- :bytecomp:lambda.cmi :parsing:location.cmi :typing:path.cmi ¶
- :typing:primitive.cmi :typing:typedtree.cmi :typing:types.cmi
-:bytecomp:translmod.cmiÄ :typing:ident.cmi :bytecomp:lambda.cmi ¶
- :typing:typedtree.cmi
-:bytecomp:translobj.cmiÄ :typing:ident.cmi :bytecomp:lambda.cmi
-:bytecomp:typeopt.cmiÄ :bytecomp:lambda.cmi :typing:path.cmi ¶
- :typing:typedtree.cmi
-:bytecomp:bytegen.cmoÄ :parsing:asttypes.cmi :utils:config.cmi ¶
- :typing:ident.cmi :bytecomp:instruct.cmi :bytecomp:lambda.cmi ¶
- :utils:misc.cmi :typing:primitive.cmi :bytecomp:switch.cmi ¶
- :typing:types.cmi :bytecomp:bytegen.cmi
-:bytecomp:bytegen.cmxÄ :parsing:asttypes.cmi :utils:config.cmx ¶
- :typing:ident.cmx :bytecomp:instruct.cmx :bytecomp:lambda.cmx ¶
- :utils:misc.cmx :typing:primitive.cmx :bytecomp:switch.cmx ¶
- :typing:types.cmx :bytecomp:bytegen.cmi
-:bytecomp:bytelibrarian.cmoÄ :utils:clflags.cmo :utils:config.cmi ¶
- :bytecomp:emitcode.cmi :utils:misc.cmi :bytecomp:bytelibrarian.cmi
-:bytecomp:bytelibrarian.cmxÄ :utils:clflags.cmx :utils:config.cmx ¶
- :bytecomp:emitcode.cmx :utils:misc.cmx :bytecomp:bytelibrarian.cmi
-:bytecomp:bytelink.cmoÄ :bytecomp:bytesections.cmi :utils:ccomp.cmi ¶
- :utils:clflags.cmo :utils:config.cmi :bytecomp:emitcode.cmi ¶
- :typing:ident.cmi :bytecomp:instruct.cmi :utils:misc.cmi ¶
- :bytecomp:opcodes.cmo :bytecomp:symtable.cmi :bytecomp:bytelink.cmi
-:bytecomp:bytelink.cmxÄ :bytecomp:bytesections.cmx :utils:ccomp.cmx ¶
- :utils:clflags.cmx :utils:config.cmx :bytecomp:emitcode.cmx ¶
- :typing:ident.cmx :bytecomp:instruct.cmx :utils:misc.cmx ¶
- :bytecomp:opcodes.cmx :bytecomp:symtable.cmx :bytecomp:bytelink.cmi
-:bytecomp:bytesections.cmoÄ :utils:config.cmi :bytecomp:bytesections.cmi
-:bytecomp:bytesections.cmxÄ :utils:config.cmx :bytecomp:bytesections.cmi
-:bytecomp:emitcode.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶
- :utils:clflags.cmo :utils:config.cmi :typing:env.cmi :typing:ident.cmi ¶
- :bytecomp:instruct.cmi :bytecomp:lambda.cmi :bytecomp:meta.cmi ¶
- :utils:misc.cmi :bytecomp:opcodes.cmo :bytecomp:translmod.cmi ¶
- :bytecomp:emitcode.cmi
-:bytecomp:emitcode.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶
- :utils:clflags.cmx :utils:config.cmx :typing:env.cmx :typing:ident.cmx ¶
- :bytecomp:instruct.cmx :bytecomp:lambda.cmx :bytecomp:meta.cmx ¶
- :utils:misc.cmx :bytecomp:opcodes.cmx :bytecomp:translmod.cmx ¶
- :bytecomp:emitcode.cmi
-:bytecomp:instruct.cmoÄ :typing:env.cmi :typing:ident.cmi ¶
- :bytecomp:lambda.cmi :typing:types.cmi :bytecomp:instruct.cmi
-:bytecomp:instruct.cmxÄ :typing:env.cmx :typing:ident.cmx ¶
- :bytecomp:lambda.cmx :typing:types.cmx :bytecomp:instruct.cmi
-:bytecomp:lambda.cmoÄ :parsing:asttypes.cmi :typing:env.cmi :typing:ident.cmi ¶
- :utils:misc.cmi :typing:path.cmi :typing:primitive.cmi :typing:types.cmi ¶
- :bytecomp:lambda.cmi
-:bytecomp:lambda.cmxÄ :parsing:asttypes.cmi :typing:env.cmx :typing:ident.cmx ¶
- :utils:misc.cmx :typing:path.cmx :typing:primitive.cmx :typing:types.cmx ¶
- :bytecomp:lambda.cmi
-:bytecomp:matching.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶
- :typing:ident.cmi :bytecomp:lambda.cmi :parsing:location.cmi ¶
- :utils:misc.cmi :typing:parmatch.cmi :typing:predef.cmi ¶
- :typing:primitive.cmi :bytecomp:printlambda.cmi :bytecomp:switch.cmi ¶
- :typing:typedtree.cmi :bytecomp:typeopt.cmi :typing:types.cmi ¶
- :bytecomp:matching.cmi
-:bytecomp:matching.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶
- :typing:ident.cmx :bytecomp:lambda.cmx :parsing:location.cmx ¶
- :utils:misc.cmx :typing:parmatch.cmx :typing:predef.cmx ¶
- :typing:primitive.cmx :bytecomp:printlambda.cmx :bytecomp:switch.cmx ¶
- :typing:typedtree.cmx :bytecomp:typeopt.cmx :typing:types.cmx ¶
- :bytecomp:matching.cmi
-:bytecomp:meta.cmoÄ :bytecomp:meta.cmi
-:bytecomp:meta.cmxÄ :bytecomp:meta.cmi
-:bytecomp:printinstr.cmoÄ :typing:ident.cmi :bytecomp:instruct.cmi ¶
- :bytecomp:lambda.cmi :bytecomp:printlambda.cmi :bytecomp:printinstr.cmi
-:bytecomp:printinstr.cmxÄ :typing:ident.cmx :bytecomp:instruct.cmx ¶
- :bytecomp:lambda.cmx :bytecomp:printlambda.cmx :bytecomp:printinstr.cmi
-:bytecomp:printlambda.cmoÄ :parsing:asttypes.cmi :typing:ident.cmi ¶
- :bytecomp:lambda.cmi :typing:primitive.cmi :typing:types.cmi ¶
- :bytecomp:printlambda.cmi
-:bytecomp:printlambda.cmxÄ :parsing:asttypes.cmi :typing:ident.cmx ¶
- :bytecomp:lambda.cmx :typing:primitive.cmx :typing:types.cmx ¶
- :bytecomp:printlambda.cmi
-:bytecomp:runtimedef.cmoÄ :bytecomp:runtimedef.cmi
-:bytecomp:runtimedef.cmxÄ :bytecomp:runtimedef.cmi
-:bytecomp:simplif.cmoÄ :parsing:asttypes.cmi :utils:clflags.cmo ¶
- :typing:ident.cmi :bytecomp:lambda.cmi :bytecomp:simplif.cmi
-:bytecomp:simplif.cmxÄ :parsing:asttypes.cmi :utils:clflags.cmx ¶
- :typing:ident.cmx :bytecomp:lambda.cmx :bytecomp:simplif.cmi
-:bytecomp:switch.cmoÄ :bytecomp:switch.cmi
-:bytecomp:switch.cmxÄ :bytecomp:switch.cmi
-:bytecomp:symtable.cmoÄ :parsing:asttypes.cmi :bytecomp:bytesections.cmi ¶
- :utils:clflags.cmo :bytecomp:emitcode.cmi :typing:ident.cmi ¶
- :bytecomp:lambda.cmi :bytecomp:meta.cmi :utils:misc.cmi ¶
- :typing:predef.cmi :bytecomp:runtimedef.cmi :utils:tbl.cmi ¶
- :bytecomp:symtable.cmi
-:bytecomp:symtable.cmxÄ :parsing:asttypes.cmi :bytecomp:bytesections.cmx ¶
- :utils:clflags.cmx :bytecomp:emitcode.cmx :typing:ident.cmx ¶
- :bytecomp:lambda.cmx :bytecomp:meta.cmx :utils:misc.cmx ¶
- :typing:predef.cmx :bytecomp:runtimedef.cmx :utils:tbl.cmx ¶
- :bytecomp:symtable.cmi
-:bytecomp:translclass.cmoÄ :parsing:asttypes.cmi :typing:ident.cmi ¶
- :bytecomp:lambda.cmi :parsing:location.cmi :bytecomp:matching.cmi ¶
- :utils:misc.cmi :bytecomp:translcore.cmi :bytecomp:translobj.cmi ¶
- :typing:typedtree.cmi :bytecomp:typeopt.cmi :typing:types.cmi ¶
- :bytecomp:translclass.cmi
-:bytecomp:translclass.cmxÄ :parsing:asttypes.cmi :typing:ident.cmx ¶
- :bytecomp:lambda.cmx :parsing:location.cmx :bytecomp:matching.cmx ¶
- :utils:misc.cmx :bytecomp:translcore.cmx :bytecomp:translobj.cmx ¶
- :typing:typedtree.cmx :bytecomp:typeopt.cmx :typing:types.cmx ¶
- :bytecomp:translclass.cmi
-:bytecomp:translcore.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶
- :utils:clflags.cmo :utils:config.cmi :typing:env.cmi :typing:ident.cmi ¶
- :bytecomp:lambda.cmi :parsing:location.cmi :bytecomp:matching.cmi ¶
- :utils:misc.cmi :typing:path.cmi :typing:predef.cmi :typing:primitive.cmi ¶
- :bytecomp:translobj.cmi :typing:typedtree.cmi :bytecomp:typeopt.cmi ¶
- :typing:types.cmi :bytecomp:translcore.cmi
-:bytecomp:translcore.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶
- :utils:clflags.cmx :utils:config.cmx :typing:env.cmx :typing:ident.cmx ¶
- :bytecomp:lambda.cmx :parsing:location.cmx :bytecomp:matching.cmx ¶
- :utils:misc.cmx :typing:path.cmx :typing:predef.cmx :typing:primitive.cmx ¶
- :bytecomp:translobj.cmx :typing:typedtree.cmx :bytecomp:typeopt.cmx ¶
- :typing:types.cmx :bytecomp:translcore.cmi
-:bytecomp:translmod.cmoÄ :parsing:asttypes.cmi :typing:ident.cmi ¶
- :bytecomp:lambda.cmi :utils:misc.cmi :typing:path.cmi ¶
- :typing:primitive.cmi :bytecomp:translclass.cmi :bytecomp:translcore.cmi ¶
- :bytecomp:translobj.cmi :typing:typedtree.cmi :typing:types.cmi ¶
- :bytecomp:translmod.cmi
-:bytecomp:translmod.cmxÄ :parsing:asttypes.cmi :typing:ident.cmx ¶
- :bytecomp:lambda.cmx :utils:misc.cmx :typing:path.cmx ¶
- :typing:primitive.cmx :bytecomp:translclass.cmx :bytecomp:translcore.cmx ¶
- :bytecomp:translobj.cmx :typing:typedtree.cmx :typing:types.cmx ¶
- :bytecomp:translmod.cmi
-:bytecomp:translobj.cmoÄ :parsing:asttypes.cmi :typing:env.cmi ¶
- :typing:ident.cmi :bytecomp:lambda.cmi :parsing:longident.cmi ¶
- :utils:misc.cmi :bytecomp:translobj.cmi
-:bytecomp:translobj.cmxÄ :parsing:asttypes.cmi :typing:env.cmx ¶
- :typing:ident.cmx :bytecomp:lambda.cmx :parsing:longident.cmx ¶
- :utils:misc.cmx :bytecomp:translobj.cmi
-:bytecomp:typeopt.cmoÄ :parsing:asttypes.cmi :typing:ctype.cmi ¶
- :typing:env.cmi :typing:ident.cmi :bytecomp:lambda.cmi :utils:misc.cmi ¶
- :typing:path.cmi :typing:predef.cmi :typing:primitive.cmi ¶
- :typing:typedtree.cmi :typing:types.cmi :bytecomp:typeopt.cmi
-:bytecomp:typeopt.cmxÄ :parsing:asttypes.cmi :typing:ctype.cmx ¶
- :typing:env.cmx :typing:ident.cmx :bytecomp:lambda.cmx :utils:misc.cmx ¶
- :typing:path.cmx :typing:predef.cmx :typing:primitive.cmx ¶
- :typing:typedtree.cmx :typing:types.cmx :bytecomp:typeopt.cmi
-:driver:compile.cmiÄ :typing:env.cmi
-:driver:optcompile.cmiÄ :typing:env.cmi
-:driver:compile.cmoÄ :bytecomp:bytegen.cmi :utils:ccomp.cmi ¶
- :utils:clflags.cmo :utils:config.cmi :bytecomp:emitcode.cmi ¶
- :typing:env.cmi :parsing:location.cmi :utils:misc.cmi :parsing:parse.cmi ¶
- :parsing:printast.cmi :bytecomp:printinstr.cmi :bytecomp:printlambda.cmi ¶
- :typing:printtyp.cmi :bytecomp:simplif.cmi :bytecomp:translmod.cmi ¶
- :typing:typedtree.cmi :typing:typemod.cmi :utils:warnings.cmi ¶
- :driver:compile.cmi
-:driver:compile.cmxÄ :bytecomp:bytegen.cmx :utils:ccomp.cmx ¶
- :utils:clflags.cmx :utils:config.cmx :bytecomp:emitcode.cmx ¶
- :typing:env.cmx :parsing:location.cmx :utils:misc.cmx :parsing:parse.cmx ¶
- :parsing:printast.cmx :bytecomp:printinstr.cmx :bytecomp:printlambda.cmx ¶
- :typing:printtyp.cmx :bytecomp:simplif.cmx :bytecomp:translmod.cmx ¶
- :typing:typedtree.cmx :typing:typemod.cmx :utils:warnings.cmx ¶
- :driver:compile.cmi
-:driver:errors.cmoÄ :bytecomp:bytelibrarian.cmi :bytecomp:bytelink.cmi ¶
- :typing:ctype.cmi :typing:env.cmi :typing:includemod.cmi ¶
- :parsing:lexer.cmi :parsing:location.cmi :bytecomp:symtable.cmi ¶
- :parsing:syntaxerr.cmi :bytecomp:translclass.cmi :bytecomp:translcore.cmi ¶
- :typing:typeclass.cmi :typing:typecore.cmi :typing:typedecl.cmi ¶
- :typing:typemod.cmi :typing:typetexp.cmi :utils:warnings.cmi ¶
- :driver:errors.cmi
-:driver:errors.cmxÄ :bytecomp:bytelibrarian.cmx :bytecomp:bytelink.cmx ¶
- :typing:ctype.cmx :typing:env.cmx :typing:includemod.cmx ¶
- :parsing:lexer.cmx :parsing:location.cmx :bytecomp:symtable.cmx ¶
- :parsing:syntaxerr.cmx :bytecomp:translclass.cmx :bytecomp:translcore.cmx ¶
- :typing:typeclass.cmx :typing:typecore.cmx :typing:typedecl.cmx ¶
- :typing:typemod.cmx :typing:typetexp.cmx :utils:warnings.cmx ¶
- :driver:errors.cmi
-:driver:main.cmoÄ :bytecomp:bytelibrarian.cmi :bytecomp:bytelink.cmi ¶
- :utils:clflags.cmo :driver:compile.cmi :utils:config.cmi ¶
- :driver:errors.cmi :driver:main_args.cmi :utils:warnings.cmi ¶
- :driver:main.cmi
-:driver:main.cmxÄ :bytecomp:bytelibrarian.cmx :bytecomp:bytelink.cmx ¶
- :utils:clflags.cmx :driver:compile.cmx :utils:config.cmx ¶
- :driver:errors.cmx :driver:main_args.cmx :utils:warnings.cmx ¶
- :driver:main.cmi
-:driver:main_args.cmoÄ :driver:main_args.cmi
-:driver:main_args.cmxÄ :driver:main_args.cmi
-:driver:optcompile.cmoÄ :utils:ccomp.cmi :utils:clflags.cmo :utils:config.cmi ¶
- :typing:env.cmi :parsing:location.cmi :utils:misc.cmi :parsing:parse.cmi ¶
- :parsing:printast.cmi :bytecomp:printlambda.cmi :typing:printtyp.cmi ¶
- :bytecomp:simplif.cmi :bytecomp:translmod.cmi :typing:typedtree.cmi ¶
- :typing:typemod.cmi :utils:warnings.cmi :driver:optcompile.cmi
-:driver:optcompile.cmxÄ :utils:ccomp.cmx :utils:clflags.cmx :utils:config.cmx ¶
- :typing:env.cmx :parsing:location.cmx :utils:misc.cmx :parsing:parse.cmx ¶
- :parsing:printast.cmx :bytecomp:printlambda.cmx :typing:printtyp.cmx ¶
- :bytecomp:simplif.cmx :bytecomp:translmod.cmx :typing:typedtree.cmx ¶
- :typing:typemod.cmx :utils:warnings.cmx :driver:optcompile.cmi
-:driver:opterrors.cmoÄ :typing:ctype.cmi :typing:env.cmi ¶
- :typing:includemod.cmi :parsing:lexer.cmi :parsing:location.cmi ¶
- :parsing:syntaxerr.cmi :bytecomp:translclass.cmi :bytecomp:translcore.cmi ¶
- :typing:typeclass.cmi :typing:typecore.cmi :typing:typedecl.cmi ¶
- :typing:typemod.cmi :typing:typetexp.cmi :utils:warnings.cmi ¶
- :driver:opterrors.cmi
-:driver:opterrors.cmxÄ :typing:ctype.cmx :typing:env.cmx ¶
- :typing:includemod.cmx :parsing:lexer.cmx :parsing:location.cmx ¶
- :parsing:syntaxerr.cmx :bytecomp:translclass.cmx :bytecomp:translcore.cmx ¶
- :typing:typeclass.cmx :typing:typecore.cmx :typing:typedecl.cmx ¶
- :typing:typemod.cmx :typing:typetexp.cmx :utils:warnings.cmx ¶
- :driver:opterrors.cmi
-:driver:optmain.cmoÄ :utils:clflags.cmo :utils:config.cmi ¶
- :driver:optcompile.cmi :driver:opterrors.cmi :utils:warnings.cmi ¶
- :driver:optmain.cmi
-:driver:optmain.cmxÄ :utils:clflags.cmx :utils:config.cmx ¶
- :driver:optcompile.cmx :driver:opterrors.cmx :utils:warnings.cmx ¶
- :driver:optmain.cmi
-:toplevel:genprintval.cmiÄ :typing:env.cmi :typing:outcometree.cmi ¶
- :typing:path.cmi :typing:types.cmi
-:toplevel:topdirs.cmiÄ :parsing:longident.cmi
-:toplevel:toploop.cmiÄ :typing:env.cmi :parsing:location.cmi ¶
- :parsing:longident.cmi :typing:outcometree.cmi :parsing:parsetree.cmi ¶
- :typing:path.cmi :typing:types.cmi :utils:warnings.cmi
-:toplevel:trace.cmiÄ :typing:env.cmi :parsing:longident.cmi :typing:path.cmi ¶
- :typing:types.cmi
-:toplevel:expunge.cmoÄ :bytecomp:bytesections.cmi :typing:ident.cmi ¶
- :utils:misc.cmi :bytecomp:runtimedef.cmi :bytecomp:symtable.cmi
-:toplevel:expunge.cmxÄ :bytecomp:bytesections.cmx :typing:ident.cmx ¶
- :utils:misc.cmx :bytecomp:runtimedef.cmx :bytecomp:symtable.cmx
-:toplevel:genprintval.cmoÄ :typing:btype.cmi :typing:ctype.cmi ¶
- :typing:datarepr.cmi :typing:env.cmi :typing:ident.cmi ¶
- :parsing:longident.cmi :utils:misc.cmi :typing:outcometree.cmi ¶
- :typing:path.cmi :typing:predef.cmi :typing:printtyp.cmi ¶
- :typing:types.cmi :toplevel:genprintval.cmi
-:toplevel:genprintval.cmxÄ :typing:btype.cmx :typing:ctype.cmx ¶
- :typing:datarepr.cmx :typing:env.cmx :typing:ident.cmx ¶
- :parsing:longident.cmx :utils:misc.cmx :typing:outcometree.cmi ¶
- :typing:path.cmx :typing:predef.cmx :typing:printtyp.cmx ¶
- :typing:types.cmx :toplevel:genprintval.cmi
-:toplevel:topdirs.cmoÄ :bytecomp:bytelink.cmi :utils:clflags.cmo ¶
- :utils:config.cmi :typing:ctype.cmi :bytecomp:emitcode.cmi ¶
- :typing:env.cmi :typing:ident.cmi :parsing:longident.cmi ¶
- :bytecomp:meta.cmi :utils:misc.cmi :bytecomp:opcodes.cmo :typing:path.cmi ¶
- :typing:printtyp.cmi :bytecomp:symtable.cmi :toplevel:toploop.cmi ¶
- :toplevel:trace.cmi :typing:types.cmi :utils:warnings.cmi ¶
- :toplevel:topdirs.cmi
-:toplevel:topdirs.cmxÄ :bytecomp:bytelink.cmx :utils:clflags.cmx ¶
- :utils:config.cmx :typing:ctype.cmx :bytecomp:emitcode.cmx ¶
- :typing:env.cmx :typing:ident.cmx :parsing:longident.cmx ¶
- :bytecomp:meta.cmx :utils:misc.cmx :bytecomp:opcodes.cmx :typing:path.cmx ¶
- :typing:printtyp.cmx :bytecomp:symtable.cmx :toplevel:toploop.cmx ¶
- :toplevel:trace.cmx :typing:types.cmx :utils:warnings.cmx ¶
- :toplevel:topdirs.cmi
-:toplevel:toploop.cmoÄ :bytecomp:bytegen.cmi :utils:clflags.cmo ¶
- :driver:compile.cmi :utils:config.cmi :bytecomp:emitcode.cmi ¶
- :typing:env.cmi :driver:errors.cmi :toplevel:genprintval.cmi ¶
- :typing:ident.cmi :parsing:lexer.cmi :parsing:location.cmi ¶
- :parsing:longident.cmi :bytecomp:meta.cmi :utils:misc.cmi ¶
- :typing:outcometree.cmi :parsing:parse.cmi :parsing:parsetree.cmi ¶
- :typing:path.cmi :typing:predef.cmi :parsing:printast.cmi ¶
- :bytecomp:printinstr.cmi :bytecomp:printlambda.cmi :typing:printtyp.cmi ¶
- :bytecomp:simplif.cmi :bytecomp:symtable.cmi :bytecomp:translmod.cmi ¶
- :typing:typedtree.cmi :typing:typemod.cmi :typing:types.cmi ¶
- :utils:warnings.cmi :toplevel:toploop.cmi
-:toplevel:toploop.cmxÄ :bytecomp:bytegen.cmx :utils:clflags.cmx ¶
- :driver:compile.cmx :utils:config.cmx :bytecomp:emitcode.cmx ¶
- :typing:env.cmx :driver:errors.cmx :toplevel:genprintval.cmx ¶
- :typing:ident.cmx :parsing:lexer.cmx :parsing:location.cmx ¶
- :parsing:longident.cmx :bytecomp:meta.cmx :utils:misc.cmx ¶
- :typing:outcometree.cmi :parsing:parse.cmx :parsing:parsetree.cmi ¶
- :typing:path.cmx :typing:predef.cmx :parsing:printast.cmx ¶
- :bytecomp:printinstr.cmx :bytecomp:printlambda.cmx :typing:printtyp.cmx ¶
- :bytecomp:simplif.cmx :bytecomp:symtable.cmx :bytecomp:translmod.cmx ¶
- :typing:typedtree.cmx :typing:typemod.cmx :typing:types.cmx ¶
- :utils:warnings.cmx :toplevel:toploop.cmi
-:toplevel:topmain.cmoÄ :utils:clflags.cmo :utils:config.cmi :utils:misc.cmi ¶
- :toplevel:toploop.cmi :utils:warnings.cmi
-:toplevel:topmain.cmxÄ :utils:clflags.cmx :utils:config.cmx :utils:misc.cmx ¶
- :toplevel:toploop.cmx :utils:warnings.cmx
-:toplevel:trace.cmoÄ :typing:ctype.cmi :parsing:longident.cmi ¶
- :bytecomp:meta.cmi :utils:misc.cmi :typing:path.cmi :typing:predef.cmi ¶
- :typing:printtyp.cmi :toplevel:toploop.cmi :typing:types.cmi ¶
- :toplevel:trace.cmi
-:toplevel:trace.cmxÄ :typing:ctype.cmx :parsing:longident.cmx ¶
- :bytecomp:meta.cmx :utils:misc.cmx :typing:path.cmx :typing:predef.cmx ¶
- :typing:printtyp.cmx :toplevel:toploop.cmx :typing:types.cmx ¶
- :toplevel:trace.cmi
diff --git a/Makefile.nt b/Makefile.nt
deleted file mode 100644
index a69385439d..0000000000
--- a/Makefile.nt
+++ /dev/null
@@ -1,622 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-# The main Makefile
-
-include config/Makefile
-include stdlib/StdlibModules
-
-CAMLC=boot/ocamlrun boot/ocamlc -I boot
-CAMLOPT=boot/ocamlrun ./ocamlopt -I stdlib
-COMPFLAGS=$(INCLUDES)
-LINKFLAGS=
-CAMLYACC=boot/ocamlyacc
-YACCFLAGS=
-CAMLLEX=boot/ocamlrun boot/ocamllex
-CAMLDEP=boot/ocamlrun tools/ocamldep
-DEPFLAGS=$(INCLUDES)
-CAMLRUN=byterun/ocamlrun
-
-INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver -I toplevel
-
-UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \
- utils/clflags.cmo utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \
- utils/consistbl.cmo
-
-OPTUTILS=$(UTILS)
-
-PARSING=parsing/linenum.cmo parsing/location.cmo parsing/longident.cmo \
- parsing/syntaxerr.cmo parsing/parser.cmo \
- parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo
-
-TYPING=typing/ident.cmo typing/path.cmo \
- typing/primitive.cmo typing/types.cmo \
- typing/btype.cmo typing/oprint.cmo \
- typing/subst.cmo typing/predef.cmo \
- typing/datarepr.cmo typing/env.cmo \
- typing/typedtree.cmo typing/ctype.cmo \
- typing/printtyp.cmo typing/includeclass.cmo \
- typing/mtype.cmo typing/includecore.cmo \
- typing/includemod.cmo typing/parmatch.cmo \
- typing/typetexp.cmo typing/stypes.cmo typing/typecore.cmo \
- typing/typedecl.cmo typing/typeclass.cmo \
- typing/typemod.cmo
-
-COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \
- bytecomp/typeopt.cmo bytecomp/switch.cmo bytecomp/matching.cmo \
- bytecomp/translobj.cmo bytecomp/translcore.cmo \
- bytecomp/translclass.cmo bytecomp/translmod.cmo \
- bytecomp/simplif.cmo bytecomp/runtimedef.cmo
-
-BYTECOMP=bytecomp/meta.cmo bytecomp/instruct.cmo bytecomp/bytegen.cmo \
- bytecomp/printinstr.cmo bytecomp/opcodes.cmo bytecomp/emitcode.cmo \
- bytecomp/bytesections.cmo bytecomp/dll.cmo bytecomp/symtable.cmo \
- bytecomp/bytelink.cmo bytecomp/bytelibrarian.cmo bytecomp/bytepackager.cmo
-
-ASMCOMP=asmcomp/arch.cmo asmcomp/cmm.cmo asmcomp/printcmm.cmo \
- asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \
- asmcomp/clambda.cmo asmcomp/compilenv.cmo \
- asmcomp/closure.cmo asmcomp/cmmgen.cmo \
- asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \
- asmcomp/comballoc.cmo asmcomp/liveness.cmo \
- asmcomp/spill.cmo asmcomp/split.cmo \
- asmcomp/interf.cmo asmcomp/coloring.cmo \
- asmcomp/reloadgen.cmo asmcomp/reload.cmo \
- asmcomp/printlinear.cmo asmcomp/linearize.cmo \
- asmcomp/schedgen.cmo asmcomp/scheduling.cmo \
- asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \
- asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo
-
-DRIVER=driver/pparse.cmo driver/errors.cmo driver/compile.cmo \
- driver/main_args.cmo driver/main.cmo
-
-OPTDRIVER=driver/pparse.cmo driver/opterrors.cmo driver/optcompile.cmo \
- driver/optmain.cmo
-
-TOPLEVEL=driver/pparse.cmo driver/errors.cmo driver/compile.cmo \
- toplevel/genprintval.cmo toplevel/toploop.cmo \
- toplevel/trace.cmo toplevel/topdirs.cmo toplevel/topmain.cmo
-
-TOPLEVELLIB=toplevel/toplevellib.cma
-TOPLEVELSTART=toplevel/topstart.cmo
-
-COMPOBJS=$(UTILS) $(PARSING) $(TYPING) $(COMP) $(BYTECOMP) $(DRIVER)
-
-TOPLIB=$(UTILS) $(PARSING) $(TYPING) $(COMP) $(BYTECOMP) $(TOPLEVEL)
-
-TOPOBJS=$(TOPLEVELLIB) $(TOPLEVELSTART)
-
-OPTOBJS=$(OPTUTILS) $(PARSING) $(TYPING) $(COMP) $(ASMCOMP) $(OPTDRIVER)
-
-EXPUNGEOBJS=utils/misc.cmo utils/tbl.cmo \
- utils/config.cmo utils/clflags.cmo \
- typing/ident.cmo typing/path.cmo typing/types.cmo typing/btype.cmo \
- typing/predef.cmo bytecomp/runtimedef.cmo bytecomp/bytesections.cmo \
- bytecomp/dll.cmo \
- bytecomp/symtable.cmo toplevel/expunge.cmo
-
-PERVASIVES=$(STDLIB_MODULES) topdirs toploop outcometree
-
-# For users who don't read the INSTALL file
-defaultentry:
- @echo "Please refer to the installation instructions in file README.win32."
-
-# Recompile the system using the bootstrap compiler
-all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml otherlibraries ocamldoc.byte camlp4out win32gui
-
-# The compilation of ocaml will fail if the runtime has changed.
-# Never mind, just do make bootstrap to reach fixpoint again.
-
-# Compile everything the first time
-world: coldstart all
-
-# Complete bootstrapping cycle
-bootstrap:
-# Save the original bootstrap compiler
- $(MAKEREC) backup
-# Promote the new compiler but keep the old runtime
-# This compiler runs on boot/ocamlrun and produces bytecode for byterun/ocamlrun
- $(MAKEREC) promote-cross
-# Rebuild ocamlc and ocamllex (run on byterun/ocamlrun)
- $(MAKEREC) partialclean
- $(MAKEREC) ocamlc ocamllex
-# Rebuild the library (using byterun/ocamlrun ./ocamlc)
- $(MAKEREC) library-cross
-# Promote the new compiler and the new runtime
- $(MAKEREC) promote
-# Rebuild everything, including ocaml and the tools
- $(MAKEREC) partialclean
- $(MAKEREC) all
-# Check if fixpoint reached
- $(MAKEREC) compare
-
-LIBFILES=stdlib.cma std_exit.cmo *.cmi camlheader
-
-# Start up the system from the distribution compiler
-coldstart:
- cd byterun ; $(MAKEREC) all
- cp byterun/ocamlrun.exe boot/ocamlrun.exe
- cp byterun/ocamlrun.dll boot/ocamlrun.dll
- cd yacc ; $(MAKEREC) all
- cp yacc/ocamlyacc.exe boot/ocamlyacc.exe
- cd stdlib ; $(MAKEREC) COMPILER=../boot/ocamlc all
- cd stdlib ; cp $(LIBFILES) ../boot
-
-# Build the core system: the minimum needed to make depend and bootstrap
-core : runtime ocamlc ocamllex ocamlyacc ocamltools library
-
-# Save the current bootstrap compiler
-MAXSAVED=boot/Saved/Saved.prev/Saved.prev/Saved.prev/Saved.prev/Saved.prev
-backup:
- mkdir -p boot/Saved
- if test -d $(MAXSAVED); then rm -r $(MAXSAVED); fi
- mv boot/Saved boot/Saved.prev
- mkdir boot/Saved
- mv boot/Saved.prev boot/Saved/Saved.prev
- cp boot/ocamlrun.exe boot/Saved/ocamlrun.exe
- cd boot ; mv ocamlc ocamllex ocamlyacc.exe Saved
- cd boot ; cp $(LIBFILES) Saved
-
-# Promote the newly compiled system to the rank of cross compiler
-# (Runs on the old runtime, produces code for the new runtime)
-promote-cross:
- cp ocamlc boot/ocamlc
- cp lex/ocamllex boot/ocamllex
- cp yacc/ocamlyacc.exe boot/ocamlyacc.exe
- cd stdlib ; cp $(LIBFILES) ../boot
-
-# Promote the newly compiled system to the rank of bootstrap compiler
-# (Runs on the new runtime, produces code for the new runtime)
-promote: promote-cross
- cp byterun/ocamlrun.exe boot/ocamlrun.exe
-
-# Restore the saved bootstrap compiler if a problem arises
-restore:
- cd boot/Saved ; mv * ..
- rmdir boot/Saved
- mv boot/Saved.prev boot/Saved
-
-# Check if fixpoint reached
-compare:
- - cmp -i 4096 boot/ocamlc ocamlc
- - cmp -i 4096 boot/ocamllex lex/ocamllex
-
-# Remove old bootstrap compilers
-cleanboot:
- rm -rf boot/Saved/Saved.prev/*
-
-# Compile the native-code compiler
-opt: runtimeopt ocamlopt libraryopt otherlibrariesopt camlp4opt
-
-# Native-code versions of the tools
-opt.opt: ocamlc.opt ocamlopt.opt ocamllex.opt ocamltoolsopt.opt \
- camlp4optopt ocamldoc.opt
-
-# Installation
-install: installbyt installopt
-
-installbyt:
- mkdir -p $(BINDIR)
- mkdir -p $(LIBDIR)
- cd byterun ; $(MAKEREC) install
- echo "$(STUBLIBDIR)" > $(LIBDIR)/ld.conf
- echo "$(LIBDIR)" >> $(LIBDIR)/ld.conf
- cp ocamlc $(BINDIR)/ocamlc.exe
- cp ocaml $(BINDIR)/ocaml.exe
- cd stdlib ; $(MAKEREC) install
- cp lex/ocamllex $(BINDIR)/ocamllex.exe
- cp yacc/ocamlyacc.exe $(BINDIR)/ocamlyacc.exe
- cp toplevel/toplevellib.cma $(LIBDIR)/toplevellib.cma
- cp expunge $(LIBDIR)/expunge.exe
- cp typing/outcometree.cmi typing/outcometree.mli $(LIBDIR)
- cp toplevel/topstart.cmo $(LIBDIR)
- cp toplevel/toploop.cmi toplevel/topdirs.cmi toplevel/topmain.cmi $(LIBDIR)
- cd tools ; $(MAKEREC) install
- cd ocamldoc ; $(MAKEREC) install
- mkdir -p $(STUBLIBDIR)
- for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i install; done
- cd win32caml ; $(MAKE) install
- cd camlp4 ; make install
- cp README $(DISTRIB)/Readme.gen
- cp README.win32 $(DISTRIB)/Readme.win
- cp LICENSE $(DISTRIB)/License.txt
- cp Changes $(DISTRIB)/Changes.txt
-
-# Installation of the native-code compiler
-installopt:
- cd asmrun ; $(MAKEREC) install
- cp ocamlopt $(BINDIR)/ocamlopt.exe
- cd stdlib ; $(MAKEREC) installopt
- cd ocamldoc ; $(MAKEREC) installopt
- for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i installopt; done
- if test -f ocamlc.opt; \
- then cp ocamlc.opt $(BINDIR)/ocamlc.opt.exe; else :; fi
- if test -f ocamlopt.opt; \
- then cp ocamlopt.opt $(BINDIR)/ocamlopt.opt.exe; else :; fi
- if test -f lex/ocamllex.opt; \
- then cp lex/ocamllex.opt $(BINDIR)/ocamllex.opt.exe; else :; fi
-
-clean:: partialclean
-
-# The compiler
-
-ocamlc: $(COMPOBJS)
- $(CAMLC) $(LINKFLAGS) -o ocamlc $(COMPOBJS)
- @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlc|' \
- driver/ocamlcomp.sh.in > ocamlcomp.sh
- @chmod +x ocamlcomp.sh
-
-partialclean::
- rm -f ocamlc
-
-# The native-code compiler
-
-ocamlopt: $(OPTOBJS)
- $(CAMLC) $(LINKFLAGS) -o ocamlopt $(OPTOBJS)
- @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlopt|' \
- driver/ocamlcomp.sh.in > ocamlcompopt.sh
- @chmod +x ocamlcompopt.sh
-
-partialclean::
- rm -f ocamlopt
-
-# The toplevel
-
-ocaml: $(TOPOBJS) expunge
- $(CAMLC) $(LINKFLAGS) -linkall -o ocaml.tmp $(TOPOBJS)
- - $(CAMLRUN) ./expunge ocaml.tmp ocaml $(PERVASIVES)
- rm -f ocaml.tmp
-
-toplevel/toplevellib.cma: $(TOPLIB)
- $(CAMLC) -a -o $@ $(TOPLIB)
-
-partialclean::
- rm -f ocaml
-
-# The configuration file
-
-utils/config.ml: utils/config.mlp config/Makefile
- @rm -f utils/config.ml
- sed -e "s|%%LIBDIR%%|$(LIBDIR)|" \
- -e "s|%%BYTERUN%%|ocamlrun|" \
- -e 's|%%CCOMPTYPE%%|$(CCOMPTYPE)|' \
- -e "s|%%BYTECC%%|$(BYTECC) $(BYTECCCOMPOPTS)|" \
- -e "s|%%BYTELINK%%|$(BYTECC) $(BYTECCLINKOPTS)|" \
- -e "s|%%NATIVECC%%|$(NATIVECC) $(NATIVECCCOMPOPTS)|" \
- -e "s|%%NATIVELINK%%|$(NATIVECC) $(NATIVECCLINKOPTS)|" \
- -e "s|%%PARTIALLD%%|$(PARTIALLD)|" \
- -e "s|%%PACKLD%%|$(PACKLD)|" \
- -e "s|%%BYTECCLIBS%%|$(BYTECCLIBS)|" \
- -e "s|%%NATIVECCLIBS%%|$(NATIVECCLIBS)|" \
- -e 's|%%RANLIBCMD%%|$(RANLIBCMD)|' \
- -e 's|%%BINUTILS_NM%%|$(BINUTILS_NM)|' \
- -e 's|%%BINUTILS_OBJCOPY%%|$(BINUTILS_OBJCOPY)|' \
- -e "s|%%ARCH%%|$(ARCH)|" \
- -e "s|%%MODEL%%|$(MODEL)|" \
- -e "s|%%SYSTEM%%|$(SYSTEM)|" \
- -e "s|%%EXT_OBJ%%|.$(O)|" \
- -e "s|%%EXT_ASM%%|.$(S)|" \
- -e "s|%%EXT_LIB%%|.$(A)|" \
- -e "s|%%EXT_DLL%%|.dll|" \
- utils/config.mlp > utils/config.ml
- @chmod -w utils/config.ml
-
-partialclean::
- rm -f utils/config.ml
-
-beforedepend:: utils/config.ml
-
-# The parser
-
-parsing/parser.mli parsing/parser.ml: parsing/parser.mly
- $(CAMLYACC) $(YACCFLAGS) parsing/parser.mly
-
-partialclean::
- rm -f parsing/parser.mli parsing/parser.ml parsing/parser.output
-
-beforedepend:: parsing/parser.mli parsing/parser.ml
-
-# The lexer
-
-parsing/lexer.ml: parsing/lexer.mll
- $(CAMLLEX) parsing/lexer.mll
-
-partialclean::
- rm -f parsing/lexer.ml
-
-beforedepend:: parsing/lexer.ml
-
-# The auxiliary lexer for counting line numbers
-
-parsing/linenum.ml: parsing/linenum.mll
- $(CAMLLEX) parsing/linenum.mll
-
-partialclean::
- rm -f parsing/linenum.ml
-
-beforedepend:: parsing/linenum.ml
-
-# The bytecode compiler compiled with the native-code compiler
-
-ocamlc.opt: $(COMPOBJS:.cmo=.cmx)
- cd asmrun ; $(MAKEREC) meta.$(O) dynlink.$(O)
- $(CAMLOPT) $(LINKFLAGS) -o ocamlc.opt $(COMPOBJS:.cmo=.cmx) asmrun/meta.$(O) asmrun/dynlink.$(O)
-
-partialclean::
- rm -f ocamlc.opt
-
-# The native-code compiler compiled with itself
-
-ocamlopt.opt: $(OPTOBJS:.cmo=.cmx)
- $(CAMLOPT) $(LINKFLAGS) -o ocamlopt.opt $(OPTOBJS:.cmo=.cmx)
-
-partialclean::
- rm -f ocamlopt.opt
-
-$(OPTOBJS:.cmo=.cmx): ocamlopt
-
-# The numeric opcodes
-
-bytecomp/opcodes.ml: byterun/instruct.h
- sed -n -e "/^enum/p" -e "s|,||g" -e "/^ /p" byterun/instruct.h | \
- gawk -f tools/make-opcodes > bytecomp/opcodes.ml
-
-partialclean::
- rm -f bytecomp/opcodes.ml
-
-beforedepend:: bytecomp/opcodes.ml
-
-# The predefined exceptions and primitives
-
-byterun/primitives:
- cd byterun ; $(MAKEREC) primitives
-
-bytecomp/runtimedef.ml: byterun/primitives byterun/fail.h
- (echo 'let builtin_exceptions = [|'; \
- sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$$| \1;|p' byterun/fail.h | \
- sed -e '$$s/;$$//'; \
- echo '|]'; \
- echo 'let builtin_primitives = [|'; \
- sed -e 's/.*/ "&";/' -e '$$s/;$$//' byterun/primitives; \
- echo '|]') > bytecomp/runtimedef.ml
-
-partialclean::
- rm -f bytecomp/runtimedef.ml
-
-beforedepend:: bytecomp/runtimedef.ml
-
-# Choose the right machine-dependent files
-
-asmcomp/arch.ml: asmcomp/$(ARCH)/arch.ml
- cp asmcomp/$(ARCH)/arch.ml asmcomp/arch.ml
-
-partialclean::
- rm -f asmcomp/arch.ml
-
-beforedepend:: asmcomp/arch.ml
-
-ifeq ($(TOOLCHAIN),msvc)
-ASMCOMP_PROC=asmcomp/$(ARCH)/proc_nt.ml
-ASMCOMP_EMIT=asmcomp/$(ARCH)/emit_nt.mlp
-else
-ASMCOMP_PROC=asmcomp/$(ARCH)/proc.ml
-ASMCOMP_EMIT=asmcomp/$(ARCH)/emit.mlp
-endif
-
-asmcomp/proc.ml: $(ASMCOMP_PROC)
- cp $(ASMCOMP_PROC) asmcomp/proc.ml
-
-partialclean::
- rm -f asmcomp/proc.ml
-
-beforedepend:: asmcomp/proc.ml
-
-asmcomp/selection.ml: asmcomp/$(ARCH)/selection.ml
- cp asmcomp/$(ARCH)/selection.ml asmcomp/selection.ml
-
-partialclean::
- rm -f asmcomp/selection.ml
-
-beforedepend:: asmcomp/selection.ml
-
-asmcomp/reload.ml: asmcomp/$(ARCH)/reload.ml
- cp asmcomp/$(ARCH)/reload.ml asmcomp/reload.ml
-
-partialclean::
- rm -f asmcomp/reload.ml
-
-beforedepend:: asmcomp/reload.ml
-
-asmcomp/scheduling.ml: asmcomp/$(ARCH)/scheduling.ml
- cp asmcomp/$(ARCH)/scheduling.ml asmcomp/scheduling.ml
-
-partialclean::
- rm -f asmcomp/scheduling.ml
-
-beforedepend:: asmcomp/scheduling.ml
-
-# Preprocess the code emitters
-
-asmcomp/emit.ml: $(ASMCOMP_EMIT) tools/cvt_emit
- boot/ocamlrun tools/cvt_emit < $(ASMCOMP_EMIT) > asmcomp/emit.ml
-
-partialclean::
- rm -f asmcomp/emit.ml
-
-beforedepend:: asmcomp/emit.ml
-
-tools/cvt_emit: tools/cvt_emit.mll
- cd tools ; $(MAKEREC) cvt_emit
-
-# The "expunge" utility
-
-expunge: $(EXPUNGEOBJS)
- $(CAMLC) $(LINKFLAGS) -o expunge $(EXPUNGEOBJS)
-
-partialclean::
- rm -f expunge
-
-# The runtime system for the bytecode compiler
-
-runtime: makeruntime stdlib/libcamlrun.$(A)
-
-makeruntime:
- cd byterun ; $(MAKEREC) all
-stdlib/libcamlrun.$(A): byterun/libcamlrun.$(A)
- cp byterun/libcamlrun.$(A) stdlib/libcamlrun.$(A)
-clean::
- cd byterun ; $(MAKEREC) clean
- rm -f stdlib/libcamlrun.$(A)
-alldepend::
- cd byterun ; $(MAKEREC) depend
-
-# The runtime system for the native-code compiler
-
-runtimeopt: makeruntimeopt stdlib/libasmrun.$(A)
-
-makeruntimeopt:
- cd asmrun ; $(MAKEREC) all
-stdlib/libasmrun.$(A): asmrun/libasmrun.$(A)
- cp asmrun/libasmrun.$(A) stdlib/libasmrun.$(A)
-clean::
- cd asmrun ; $(MAKEREC) clean
- rm -f stdlib/libasmrun.$(A)
-alldepend::
- cd asmrun ; $(MAKEREC) depend
-
-# The library
-
-library:
- cd stdlib ; $(MAKEREC) all
-library-cross:
- cd stdlib ; $(MAKEREC) RUNTIME=../byterun/ocamlrun all
-libraryopt:
- cd stdlib ; $(MAKEREC) allopt
-partialclean::
- cd stdlib ; $(MAKEREC) clean
-alldepend::
- cd stdlib ; $(MAKEREC) depend
-
-# The lexer and parser generators
-
-ocamllex:
- cd lex ; $(MAKEREC) all
-ocamllex.opt:
- cd lex ; $(MAKEREC) allopt
-partialclean::
- cd lex ; $(MAKEREC) clean
-alldepend::
- cd lex ; $(MAKEREC) depend
-
-ocamlyacc:
- cd yacc ; $(MAKEREC) all
-clean::
- cd yacc ; $(MAKEREC) clean
-
-# Tools
-
-ocamltools:
- cd tools ; $(MAKEREC) all
-ocamltoolsopt.opt:
- cd tools ; $(MAKEREC) opt.opt
-partialclean::
- cd tools ; $(MAKEREC) clean
-alldepend::
- cd tools ; $(MAKEREC) depend
-
-# OCamldoc
-
-ocamldoc.byte:
- cd ocamldoc ; $(MAKEREC) all
-ocamldoc.opt:
- cd ocamldoc ; $(MAKEREC) opt.opt
-partialclean::
- cd ocamldoc ; $(MAKEREC) clean
-alldepend::
- cd ocamldoc ; $(MAKEREC) depend
-
-# The extra libraries
-
-otherlibraries:
- for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i all; done
-otherlibrariesopt:
- for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i allopt; done
-partialclean::
- for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i partialclean; done
-clean::
- for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i clean; done
-alldepend::
- for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i depend; done
-
-# Camlp4
-
-camlp4out:
- cd camlp4/config ; \
- (cat Makefile.tpl; \
- echo 'EXE=.exe'; \
- echo 'O=$(O)'; \
- echo 'A=$(A)'; \
- echo 'OPT='; \
- echo 'OTOP=../..'; \
- echo 'OLIBDIR=$$(OTOP)/boot'; \
- echo 'BINDIR=$(BINDIR)'; \
- echo 'LIBDIR=$(LIBDIR)'; \
- echo 'MANDIR=' ) > Makefile
- cd camlp4 ; $(MAKE)
-camlp4opt:
- cd camlp4 ; $(MAKE) opt
-camlp4optopt:
- cd camlp4; $(MAKE) opt.opt
-partialclean::
- cd camlp4 ; $(MAKE) clean
-
-# The Win32 toplevel GUI
-
-win32gui:
- cd win32caml ; $(MAKE) all
-
-clean::
- cd win32caml ; $(MAKE) clean
-
-# Default rules
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.ml.cmo:
- $(CAMLC) $(COMPFLAGS) -c $<
-
-.mli.cmi:
- $(CAMLC) $(COMPFLAGS) -c $<
-
-.ml.cmx:
- $(CAMLOPT) $(COMPFLAGS) -c $<
-
-partialclean::
- rm -f utils/*.cm* utils/*.$(O) utils/*.$(S)
- rm -f parsing/*.cm* parsing/*.$(O) parsing/*.$(S)
- rm -f typing/*.cm* typing/*.$(O) typing/*.$(S)
- rm -f bytecomp/*.cm* bytecomp/*.$(O) bytecomp/*.$(S)
- rm -f asmcomp/*.cm* asmcomp/*.$(O) asmcomp/*.$(S)
- rm -f driver/*.cm* driver/*.$(O) driver/*.$(S)
- rm -f toplevel/*.cm* toplevel/*.$(O) toplevel/*.$(S)
- rm -f tools/*.cm* tools/*.$(O) tools/*.$(S)
-
-depend: beforedepend
- (for d in utils parsing typing bytecomp asmcomp driver toplevel; \
- do $(CAMLDEP) $(DEPFLAGS) $$d/*.mli $$d/*.ml; \
- done) > .depend
-
-alldepend:: depend
-
-include .depend
diff --git a/README b/README
deleted file mode 100644
index 400812aa55..0000000000
--- a/README
+++ /dev/null
@@ -1,144 +0,0 @@
-OVERVIEW:
-
-Objective Caml is an implementation of the ML language, based on
-the Caml Light dialect extended with a complete class-based object system
-and a powerful module system in the style of Standard ML.
-
-Objective Caml comprises two compilers. One generates bytecode
-which is then interpreted by a C program. This compiler runs quickly,
-generates compact code with moderate memory requirements, and is
-portable to essentially any 32 or 64 bit Unix platform. Performance of
-generated programs is quite good for a bytecoded implementation:
-almost twice as fast as Caml Light 0.7. This compiler can be used
-either as a standalone, batch-oriented compiler that produces
-standalone programs, or as an interactive, toplevel-based system.
-
-The other compiler generates high-performance native code for a number
-of processors. Compilation takes longer and generates bigger code, but
-the generated programs deliver excellent performance, while retaining
-the moderate memory requirements of the bytecode compiler. The
-native-code compiler currently runs on the following platforms:
-
- Intel/AMD Pentium processors: PCs under Linux, FreeBSD, NetBSD,
- OpenBSD, Windows, NextStep, Solaris 2, BeOS.
- PowerPC processors: PowerMacintosh under MacOS X and LinuxPPC,
- IBM RS6000 and PowerPC workstations under AIX 4.3
- AMD64 (Opteron) processors: PCs under Linux.
- Alpha processors: Digital/Compaq/HP Alpha machines under
- Digital Unix/Compaq Tru64, Linux, NetBSD and OpenBSD.
- Sparc processors: Sun Sparc machines under Solaris 2, NetBSD, Linux
- Mips processors: SGI workstations and mainframes under IRIX 6
- Intel IA64 processors: HP stations under Linux
- HP PA-RISC processors: HP 9000/700 under HPUX 10
- Strong ARM processors: Corel Netwinder under Linux
-
-Other operating systems for the processors above have not been tested,
-but the compiler may work under other operating systems with little work.
-
-Before the introduction of objects, Objective Caml was known as Caml
-Special Light. Objective Caml is almost upwards compatible with Caml
-Special Light, except for a few additional reserved keywords that have
-forced some renaming of standard library functions.
-
-CONTENTS:
-
- Changes what's new with each release
- INSTALL instructions for installation
- INSTALL.MPW infos on the Macintosh MPW port of Objective Caml
- LICENSE license and copyright notice
- Makefile main Makefile
- README this file
- README.win32 infos on the MS Windows 98/ME/NT/2000 ports of O.Caml
- asmcomp/ native-code compiler and linker
- asmrun/ native-code runtime library
- boot/ bootstrap compiler
- bytecomp/ bytecode compiler and linker
- byterun/ bytecode interpreter and runtime system
- config/ autoconfiguration stuff
- debugger/ source-level replay debugger
- driver/ driver code for the compilers
- emacs/ Caml editing mode and debugger interface for GNU Emacs
- lex/ lexer generator
- maccaml/ the Macintosh GUI
- ocamldoc/ documentation generator
- otherlibs/ several external libraries
- parsing/ syntax analysis
- stdlib/ standard library
- tools/ various utilities
- toplevel/ interactive system
- typing/ typechecking
- utils/ utility libraries
- yacc/ parser generator
-
-COPYRIGHT:
-
-All files marked "Copyright INRIA" in this distribution are copyright
-1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 Institut National de
-Recherche en Informatique et en Automatique (INRIA) and distributed
-under the conditions stated in file LICENSE.
-
-INSTALLATION:
-
-See the file INSTALL for installation instructions on Unix, Linux and
-MacOS X machines. For MS Windows, see README.win32.
-For the MacOS 7, 8, 9, see INSTALL.MPW.
-
-DOCUMENTATION:
-
-The Objective Caml manual is distributed in HTML, PDF, Postscript,
-DVI, and Emacs Info files. It is available on the World Wide Web, at
-
- http://caml.inria.fr/
-
-AVAILABILITY:
-
-The complete Objective Caml distribution can be accessed through a Web
-browser at
-
- http://caml.inria.fr/
-
-or by anonymous FTP:
-
- host: ftp.inria.fr
- directory: INRIA/caml-light
-
-KEEPING IN TOUCH WITH THE CAML COMMUNITY:
-
-There exists a mailing list of users of the Caml implementations
-developed at INRIA. The purpose of this list is to share
-experience, exchange ideas (and even code), and report on applications
-of the Caml language. Messages can be written in English or in
-French. The list has about 500 subscribers.
-
-Messages to the list should be sent to:
-
- caml-list@inria.fr
-
-If you wish to subscribe to this list, please send a message to:
-
- caml-list-request@inria.fr
-
-with the single word "subscribe" in the body of the message.
-
-Archives of the list are available on the World Wide Web at URL
-http://caml.inria.fr/
-
-The Usenet news groups comp.lang.ml and comp.lang.functional
-also contains discussions about the ML family of programming languages,
-including Caml.
-
-BUG REPORTS AND USER FEEDBACK:
-
-Send your bug reports by E-mail to:
-
- caml-bugs@inria.fr
-
-or report them using the Web interface to the bug-tracking system
-at http://caml.inria.fr/bin/caml-bugs
-
-To be effective, bug reports should include a complete program
-(preferably small) that exhibits the unexpected behavior, and the
-configuration you are using (machine type, etc).
-
-You can also contact the implementors directly at caml@inria.fr.
-
diff --git a/README.win32 b/README.win32
deleted file mode 100644
index c872c3ebb5..0000000000
--- a/README.win32
+++ /dev/null
@@ -1,248 +0,0 @@
- Release notes on the MS Windows ports of Objective Caml
- -------------------------------------------------------
-
-Starting with OCaml 3.05, there are no less than three ports of
-Objective Caml for MS Windows available:
- - a native Win32 port, built with the Microsoft development tools;
- - a native Win32 port, built with the Cygwin/MinGW development tools;
- - a port consisting of the Unix sources compiled under the Cygwin
- Unix-like environment for Windows.
-
-Here is a summary of the main differences between these ports:
-
- Native MS Native MinGW Cygwin
-Third-party software required
- - for base bytecode system none none none
- - for ocamlc -custom MSVC Cygwin Cygwin
- - for native-code generation MSVC+MASM Cygwin Cygwin
-
-Speed of bytecode interpreter 70% 100% 100%
-
-Replay debugger no no yes
-
-The Unix library partial partial full
-
-The Threads library yes yes yes
-
-The Graphics library yes yes no
-
-Restrictions on generated executables? none none yes (*)
-
-(*) Cygwin-generated .exe files refer to a DLL that is distributed under
-the GPL. Thus, these .exe files can only be distributed under a license
-that is compatible with the GPL. Executables generated by MSVC or by
-MinGW have no such restrictions.
-
-The remainder of this document gives more information on each port.
-
-------------------------------------------------------------------------------
-
- The native Win32 port built with Microsoft Visual C
- ---------------------------------------------------
-
-REQUIREMENTS:
-
-This port runs under MS Windows NT, 2000 and XP.
-Windows 95, 98 and ME are also supported, but less reliably.
-
-The base bytecode system (ocamlc, ocaml, ocamllex, ocamlyacc, ...)
-runs without any additional tools.
-
-Statically linking Caml bytecode with C code (ocamlc -custom) requires the
-Microsoft Visual C++ compiler. Dynamic loading of DLLs is
-supported out of the box, without additional software.
-
-The native-code compiler (ocamlopt) requires Visual C++ and the
-Microsoft assembler MASM version 6.11 or later. MASM can be
-downloaded for free from Microsoft's Web site; for directions, see
- http://www.easystreet.com/~jkirwan/pctools.html
- or http://www2.dgsys.com/~raymoon/faq/masm.html
- or the comp.lang.asm.x86 FAQ.
-
-The LablTk GUI requires Tcl/Tk 8.3. Windows binaries are
-available from http://prdownloads.sourceforge.net/tcl/tcl832.exe.
-
-
-INSTALLATION:
-
-The binary distribution is a self-installing executable archive.
-Just run it and it should install OCaml automatically.
-
-If you are using Windows 95, 98 or ME, you need to adjust environment
-variables as follows:
- - add the "bin" subdirectory of the OCaml installation directory
- to the PATH variable;
- - set the OCAMLLIB variable to the "lib" subdirectory of the
- OCaml installation directory.
-For instance, if you installed OCaml in C:\Program Files\Objective Caml,
-add the following two lines at the end of C:\autoexec.bat:
-
- set PATH=%PATH%;"C:\Program Files\Objective Caml\bin"
- set OCAMLLIB=C:\Program Files\Objective Caml\lib
-
-No such tweaking of environment variables is needed under NT, 2000 and XP.
-
-To run programs that use the LablTK GUI, the directory where the
-DLLs tk83.dll and tcl83.dll were installed (by the Tcl/Tk
-installer) must be added to the PATH environment variable.
-
-To compile programs that use the LablTK GUI, the directory where the
-libraries tk83.lib and tcl83.lib were installed (by the Tcl/Tk
-installer) must be added to the library search path in the LIB
-environment variable. E.g. if Tcl/Tk was installed in C:\tcl, add
-"C:\tcl\lib" to the LIB environment variable.
-
-
-RECOMPILATION FROM THE SOURCES:
-
-The command-line tools can be recompiled from the Unix source
-distribution (ocaml-X.YZ.tar.gz), which also contains the files modified
-for Windows.
-
-You will need the following software components to perform the recompilation:
-- Windows NT, 2000, or XP (we advise against compiling under Windows 95/98/ME)
-- Visual C++ version 6 or 7
-- MASM version 6.11 (see above)
-- The CygWin port of GNU tools, available from
- http://sourceware.cygnus.com/cygwin/
-- TCL/TK version 8.3 (for the LablTK GUI) (see above).
-
-Remember to add the directory where the libraries tk83.lib and
-tcl83.lib were installed (by the Tcl/Tk installer) to the LIB variable
-(library search path).
-
-To recompile, start a Cygwin shell and change to the top-level
-directory of the OCaml distribution. Then, do
-
- cp config/m-nt.h config/m.h
- cp config/s-nt.h config/s.h
- cp config/Makefile.msvc config/Makefile
-
-Then, edit config/Makefile as needed, following the comments in this file.
-Normally, the only variables that need to be changed are
- PREFIX where to install everything
- TK_ROOT where TCL/TK was installed
-
-Finally, use "make -f Makefile.nt" to build the system, e.g.
-
- make -f Makefile.nt world
- make -f Makefile.nt bootstrap
- make -f Makefile.nt opt
- make -f Makefile.nt install
-
-
-NOTES:
-
-* The VC++ compiler does not implement "computed gotos", and therefore
-generates inefficient code for byterun/interp.c. Consequently, the
-performance of bytecode programs is about 2/3 of that obtained under
-Unix/GCC or Cygwin or Mingw on similar hardware.
-
-* Libraries available in this port: "num", "str", "threads", "graphics",
-"labltk", and large parts of "unix".
-
-* The replay debugger is not supported.
-
-CREDITS:
-
-The initial port of Caml Special Light (the ancestor of Objective Caml)
-to Windows NT was done by Kevin Gallo at Microsoft Research, who
-kindly contributed his changes to the Caml project.
-
-The graphical user interface for the toplevel is due to Jacob Navia.
-
-------------------------------------------------------------------------------
-
- The native Win32 port built with Mingw
- --------------------------------------
-
-REQUIREMENTS:
-
-This port runs under MS Windows NT, 2000 and XP.
-Windows 95, 98 and ME are also supported, but less reliably.
-
-The base bytecode system (ocamlc, ocaml, ocamllex, ocamlyacc, ...)
-runs without any additional tools.
-
-The native-code compiler (ocamlopt), as well as static linking of
-Caml bytecode with C code (ocamlc -custom), require
-the Cygwin development tools, available at
- http://sources.redhat.com/cygwin/
-
-The LablTk GUI requires Tcl/Tk 8.3. Windows binaries are
-available from http://prdownloads.sourceforge.net/tcl/tcl832.exe.
-
-
-INSTALLATION:
-
-There is no binary distribution yet, so please follow the compilation
-instructions below.
-
-
-RECOMPILATION FROM THE SOURCES:
-
-You will need the following software components to perform the recompilation:
-- Windows NT, 2000, or XP (we advise against compiling under Windows 95/98/ME)
-- Cygwin: http://sourceware.cygnus.com/cygwin/
-- TCL/TK version 8.3 (see above).
-
-Start a Cygwin shell and unpack the source distribution
-(ocaml-X.YZ.tar.gz) with "tar xzf". Change to the top-level
-directory of the OCaml distribution. Then, do
-
- cp config/m-nt.h config/m.h
- cp config/s-nt.h config/s.h
- cp config/Makefile.mingw config/Makefile
-
-Then, edit config/Makefile as needed, following the comments in this file.
-Normally, the only variables that need to be changed are
- PREFIX where to install everything
- TK_ROOT where TCL/TK was installed
-
-Finally, use "make -f Makefile.nt" to build the system, e.g.
-
- make -f Makefile.nt world
- make -f Makefile.nt bootstrap
- make -f Makefile.nt opt
- make -f Makefile.nt opt.opt
- make -f Makefile.nt install
-
-
-NOTES:
-
-* Libraries available in this port: "num", "str", "threads", "graphics",
- "labltk", and large parts of "unix".
-
-* The replay debugger is not supported.
-
-------------------------------------------------------------------------------
-
- The Cygwin port of Objective Caml
- ---------------------------------
-
-REQUIREMENTS:
-
-This port requires the Cygwin environment from Cygnus/RedHat, which
-is freely available at:
- http://sources.redhat.com/cygwin/
-
-This port runs under all versions of MS Windows supported by Cygwin.
-
-
-INSTALLATION:
-
-For various reasons, no binary distribution of this port is available.
-You need to recompile from the source distribution.
-
-
-RECOMPILATION FROM THE SOURCES:
-
-Just follow the instructions for Unix machines given in the file INSTALL.
-
-
-NOTES:
-
-The libraries available in this port are "num", "str", "threads",
-"unix" and "labltk". "graph" is not available yet.
-The replay debugger is supported.
-
diff --git a/Upgrading b/Upgrading
deleted file mode 100644
index fac604233a..0000000000
--- a/Upgrading
+++ /dev/null
@@ -1,109 +0,0 @@
-
- FAQ: how to upgrade from Objective Caml 3.02 to 3.03
-
-I Installation
-
-Q1: When compiling the distribution, I am getting strange linking
- errors in otherlibraries.
-
-A1: This is probably a problem with dynamic linking. You can disable
- it with ./configure -no-shared-libs. If you really want to use
- shared libraries, look in the manual pages of your system for how
- to get some debugging output from the dynamic linker.
-
-II Non-label changes
-
-Q2: I get a syntax error when I try to compile a program using stream
- parsers.
-
-A2: Stream parser now require camlp4. It is included in the
- distribution, and you just need to use "ocamlc -pp camlp4o" in
- place of "ocamlc". You can also use it under the toplevel with
- #load"camlp4o.cma".
-
-Q3: I get a warning when I use the syntax "#variant" inside type
- expressions.
-
-A3: The new syntax is [< variant], which just a special case of
- the more general new syntax, which allows type expressions like
- [ variant1 | variant2] or [> variant]. See the reference manual
- for details.
-
-III Label changes
-
-Q4: I was using labels before, and now I get lots of type errors.
-
-A4: The handling of labels changed with 3.03-alpha. The new default
- is a more flexible version of the commuting label mode, allowing
- one to omit labels in total applications. There is still a
- -nolabels mode, but it does not allow non-optional labels in
- applications (this was unsound).
- To keep full compatibility with Objective Caml 2, labels were
- removed from the standard libraries. Some labelized libraries are
- kept as StdLabels (contains Array, List and String), MoreLabels
- (contains Hashtbl, Map and Set), and UnixLabels.
- Note that MoreLabels' status is not yet decided.
-
-Q5: Why isn't there a ThreadUnixLabels module ?
-
-A5: ThreadUnix is deprecated. It only calls directly the Unix module.
-
-Q6: I was using commuting label mode, how can I upgrade ?
-
-A6: The new behaviour is compatible with commuting label mode, but
- standard libraries have no labels. You can add the following
- lines at the beginning of your files (according to your needs):
- open Stdlabels
- open MoreLabels
- module Unix = UnixLabels
- Alternatively, if you already have a common module opened by
- everybody, you can add these:
- include StdLabels
- include MoreLabels
- module Unix = UnixLabels
-
- You will then need to remove labels in functions from other modules.
- This can be automated by using the scrapelabels tool, installed
- in the Objective Caml library directory, which both removes labels
- and inserts needed `open' clauses (see -help for details).
- $CAMLLIB/scrapelabels -keepstd *.ml
- or
- $CAMLLIB/scrapelabels -keepmore *.ml
- Note that scrapelabels is not guaranteed to be sound for commuting
- label programs, since it will just remove labels, and not reorder
- arguments.
-
-Q7: I was using a few labels in classic mode, and now I get all these
- errors. I just want to get rid of all these silly labels.
-
-A7: scrapelabels will do it for you.
- $CAMLLIB/scrapelabels [-all] *.ml
- $CAMLLIB/scrapelabels -intf *.mli
- You should specify the -all option only if you are sure that your
- sources do not contain calls to functions with optional
- parameters, as those labels would also be removed.
-
-Q8: I was using labels in classic mode, and I was actually pretty fond
- of them. How much more labels will I have to write now ? How can I
- convert my programs and libraries ?
-
-A8: The new default mode is more flexible than the original commuting
- mode, so that you shouldn't see too much differences when using
- labeled libraries. Labels are only compulsory in partial
- applications (including the special case of function with an
- unkwnown return type), or if you wrote some of them.
-
- On the other hand, for definitions, labels present in the
- interface must also be present in the implementation.
- The addlabels tool can help you to do that. Suppose that you have
- mymod.ml and mymod.mli, where mymod.mli adds some labels. Then
- doing
- $CAMLLIB/addlabels mymod.ml
- will insert labels from the interface inside the implementation.
- It also takes care of inserting them in recursive calls, as
- the return type of the function is not known while typing it.
-
- If you used labels from standard libraries, you will also have
- problems with them. You can proceed as described in A6. Since you
- used classic mode, you do not need to bother about changed
- argument order. \ No newline at end of file
diff --git a/asmrun/.cvsignore b/asmrun/.cvsignore
deleted file mode 100644
index ee21b35990..0000000000
--- a/asmrun/.cvsignore
+++ /dev/null
@@ -1,33 +0,0 @@
-main.c
-misc.c
-freelist.c
-major_gc.c
-minor_gc.c
-memory.c
-alloc.c
-array.c
-compare.c
-ints.c
-floats.c
-str.c
-io.c
-extern.c
-intern.c
-hash.c
-sys.c
-parsing.c
-gc_ctrl.c
-terminfo.c
-md5.c
-obj.c
-lexing.c
-printexc.c
-callback.c
-weak.c
-compact.c
-finalise.c
-custom.c
-meta.c
-globroots.c
-unix.c
-dynlink.c
diff --git a/asmrun/.depend b/asmrun/.depend
deleted file mode 100644
index 63c99b5b41..0000000000
--- a/asmrun/.depend
+++ /dev/null
@@ -1,498 +0,0 @@
-alloc.o: alloc.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/custom.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \
- ../byterun/gc.h ../byterun/minor_gc.h ../byterun/stacks.h
-array.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \
- ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \
- ../byterun/freelist.h ../byterun/minor_gc.h
-callback.o: callback.c ../byterun/callback.h ../byterun/mlvalues.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \
- ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h
-compact.o: compact.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/finalise.h ../byterun/roots.h ../byterun/misc.h \
- ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/gc_ctrl.h ../byterun/weak.h
-compare.o: compare.c ../byterun/custom.h ../byterun/mlvalues.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \
- ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h
-custom.o: custom.c ../byterun/alloc.h ../byterun/misc.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
- ../byterun/custom.h ../byterun/fail.h ../byterun/memory.h \
- ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h
-dynlink.o: dynlink.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \
- ../byterun/dynlink.h ../byterun/fail.h ../byterun/memory.h \
- ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h ../byterun/osdeps.h ../byterun/prims.h
-extern.o: extern.c ../byterun/alloc.h ../byterun/misc.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
- ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \
- ../byterun/intext.h ../byterun/io.h ../byterun/memory.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/reverse.h
-fail.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \
- ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/printexc.h ../byterun/signals.h stack.h ../byterun/roots.h
-finalise.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \
- ../byterun/fail.h ../byterun/roots.h ../byterun/memory.h \
- ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h ../byterun/signals.h
-floats.o: floats.c ../byterun/alloc.h ../byterun/misc.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
- ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/reverse.h ../byterun/stacks.h
-freelist.o: freelist.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \
- ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h
-gc_ctrl.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
- ../byterun/compact.h ../byterun/custom.h ../byterun/finalise.h \
- ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/gc_ctrl.h ../byterun/stacks.h
-globroots.o: globroots.c ../byterun/memory.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/gc.h ../byterun/mlvalues.h \
- ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h ../byterun/globroots.h
-hash.o: hash.c ../byterun/mlvalues.h ../byterun/config.h ../config/m.h \
- ../config/s.h ../byterun/misc.h ../byterun/custom.h ../byterun/memory.h \
- ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h
-intern.o: intern.c ../byterun/alloc.h ../byterun/misc.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
- ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \
- ../byterun/intext.h ../byterun/io.h ../byterun/memory.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/reverse.h ../byterun/md5.h
-ints.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/custom.h \
- ../byterun/fail.h ../byterun/intext.h ../byterun/io.h \
- ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \
- ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/int64_native.h
-io.o: io.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \
- ../byterun/custom.h ../byterun/fail.h ../byterun/io.h \
- ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \
- ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/signals.h \
- ../byterun/sys.h
-lexing.o: lexing.c ../byterun/fail.h ../byterun/misc.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
- ../byterun/stacks.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h
-main.o: main.c ../byterun/misc.h ../byterun/config.h ../config/m.h \
- ../config/s.h ../byterun/mlvalues.h ../byterun/sys.h
-major_gc.o: major_gc.c ../byterun/compact.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/misc.h ../byterun/custom.h \
- ../byterun/mlvalues.h ../byterun/fail.h ../byterun/finalise.h \
- ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/gc_ctrl.h ../byterun/weak.h
-md5.o: md5.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \
- ../byterun/md5.h ../byterun/io.h ../byterun/reverse.h
-memory.o: memory.c ../byterun/fail.h ../byterun/misc.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
- ../byterun/freelist.h ../byterun/gc.h ../byterun/gc_ctrl.h \
- ../byterun/major_gc.h ../byterun/memory.h ../byterun/minor_gc.h \
- ../byterun/signals.h
-meta.o: meta.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \
- ../byterun/fix_code.h ../byterun/interp.h ../byterun/major_gc.h \
- ../byterun/freelist.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/minor_gc.h ../byterun/prims.h ../byterun/stacks.h
-minor_gc.o: minor_gc.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \
- ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \
- ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h ../byterun/gc_ctrl.h ../byterun/signals.h
-misc.o: misc.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h
-obj.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \
- ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/memory.h ../byterun/minor_gc.h ../byterun/prims.h
-parsing.o: parsing.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/mlvalues.h ../byterun/misc.h ../byterun/memory.h \
- ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h ../byterun/alloc.h
-printexc.o: printexc.c ../byterun/backtrace.h ../byterun/mlvalues.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \
- ../byterun/callback.h ../byterun/debugger.h ../byterun/fail.h \
- ../byterun/printexc.h
-roots.o: roots.c ../byterun/finalise.h ../byterun/roots.h \
- ../byterun/misc.h ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/globroots.h stack.h
-signals.o: signals.c ../byterun/alloc.h ../byterun/misc.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
- ../byterun/callback.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/fail.h ../byterun/signals.h stack.h ../byterun/sys.h
-startup.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \
- ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \
- ../byterun/gc_ctrl.h ../byterun/osdeps.h ../byterun/printexc.h \
- ../byterun/sys.h
-str.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h
-sys.o: sys.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \
- ../byterun/debugger.h ../byterun/fail.h ../byterun/instruct.h \
- ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \
- ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \
- ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h
-terminfo.o: terminfo.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \
- ../byterun/fail.h ../byterun/io.h
-unix.o: unix.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \
- ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h ../byterun/osdeps.h
-weak.o: weak.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \
- ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \
- ../byterun/freelist.h ../byterun/minor_gc.h
-alloc.d.o: alloc.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/custom.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \
- ../byterun/gc.h ../byterun/minor_gc.h ../byterun/stacks.h
-array.d.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \
- ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \
- ../byterun/freelist.h ../byterun/minor_gc.h
-callback.d.o: callback.c ../byterun/callback.h ../byterun/mlvalues.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \
- ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h
-compact.d.o: compact.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/finalise.h ../byterun/roots.h ../byterun/misc.h \
- ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/gc_ctrl.h ../byterun/weak.h
-compare.d.o: compare.c ../byterun/custom.h ../byterun/mlvalues.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \
- ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h
-custom.d.o: custom.c ../byterun/alloc.h ../byterun/misc.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
- ../byterun/custom.h ../byterun/fail.h ../byterun/memory.h \
- ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h
-dynlink.d.o: dynlink.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \
- ../byterun/dynlink.h ../byterun/fail.h ../byterun/memory.h \
- ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h ../byterun/osdeps.h ../byterun/prims.h
-extern.d.o: extern.c ../byterun/alloc.h ../byterun/misc.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
- ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \
- ../byterun/intext.h ../byterun/io.h ../byterun/memory.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/reverse.h
-fail.d.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \
- ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/printexc.h ../byterun/signals.h stack.h ../byterun/roots.h
-finalise.d.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \
- ../byterun/fail.h ../byterun/roots.h ../byterun/memory.h \
- ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h ../byterun/signals.h
-floats.d.o: floats.c ../byterun/alloc.h ../byterun/misc.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
- ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/reverse.h ../byterun/stacks.h
-freelist.d.o: freelist.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \
- ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h
-gc_ctrl.d.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
- ../byterun/compact.h ../byterun/custom.h ../byterun/finalise.h \
- ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/gc_ctrl.h ../byterun/stacks.h
-globroots.d.o: globroots.c ../byterun/memory.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/gc.h ../byterun/mlvalues.h \
- ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h ../byterun/globroots.h
-hash.d.o: hash.c ../byterun/mlvalues.h ../byterun/config.h ../config/m.h \
- ../config/s.h ../byterun/misc.h ../byterun/custom.h ../byterun/memory.h \
- ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h
-intern.d.o: intern.c ../byterun/alloc.h ../byterun/misc.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
- ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \
- ../byterun/intext.h ../byterun/io.h ../byterun/memory.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/reverse.h ../byterun/md5.h
-ints.d.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/custom.h \
- ../byterun/fail.h ../byterun/intext.h ../byterun/io.h \
- ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \
- ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/int64_native.h
-io.d.o: io.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \
- ../byterun/custom.h ../byterun/fail.h ../byterun/io.h \
- ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \
- ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/signals.h \
- ../byterun/sys.h
-lexing.d.o: lexing.c ../byterun/fail.h ../byterun/misc.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
- ../byterun/stacks.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h
-main.d.o: main.c ../byterun/misc.h ../byterun/config.h ../config/m.h \
- ../config/s.h ../byterun/mlvalues.h ../byterun/sys.h
-major_gc.d.o: major_gc.c ../byterun/compact.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/misc.h ../byterun/custom.h \
- ../byterun/mlvalues.h ../byterun/fail.h ../byterun/finalise.h \
- ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/gc_ctrl.h ../byterun/weak.h
-md5.d.o: md5.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \
- ../byterun/md5.h ../byterun/io.h ../byterun/reverse.h
-memory.d.o: memory.c ../byterun/fail.h ../byterun/misc.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
- ../byterun/freelist.h ../byterun/gc.h ../byterun/gc_ctrl.h \
- ../byterun/major_gc.h ../byterun/memory.h ../byterun/minor_gc.h \
- ../byterun/signals.h
-meta.d.o: meta.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \
- ../byterun/fix_code.h ../byterun/interp.h ../byterun/major_gc.h \
- ../byterun/freelist.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/minor_gc.h ../byterun/prims.h ../byterun/stacks.h
-minor_gc.d.o: minor_gc.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \
- ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \
- ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h ../byterun/gc_ctrl.h ../byterun/signals.h
-misc.d.o: misc.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h
-obj.d.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \
- ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/memory.h ../byterun/minor_gc.h ../byterun/prims.h
-parsing.d.o: parsing.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/mlvalues.h ../byterun/misc.h ../byterun/memory.h \
- ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h ../byterun/alloc.h
-printexc.d.o: printexc.c ../byterun/backtrace.h ../byterun/mlvalues.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \
- ../byterun/callback.h ../byterun/debugger.h ../byterun/fail.h \
- ../byterun/printexc.h
-roots.d.o: roots.c ../byterun/finalise.h ../byterun/roots.h \
- ../byterun/misc.h ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/globroots.h stack.h
-signals.d.o: signals.c ../byterun/alloc.h ../byterun/misc.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
- ../byterun/callback.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/fail.h ../byterun/signals.h stack.h ../byterun/sys.h
-startup.d.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \
- ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \
- ../byterun/gc_ctrl.h ../byterun/osdeps.h ../byterun/printexc.h \
- ../byterun/sys.h
-str.d.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h
-sys.d.o: sys.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \
- ../byterun/debugger.h ../byterun/fail.h ../byterun/instruct.h \
- ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \
- ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \
- ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h
-terminfo.d.o: terminfo.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \
- ../byterun/fail.h ../byterun/io.h
-unix.d.o: unix.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \
- ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h ../byterun/osdeps.h
-weak.d.o: weak.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \
- ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \
- ../byterun/freelist.h ../byterun/minor_gc.h
-alloc.p.o: alloc.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/custom.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \
- ../byterun/gc.h ../byterun/minor_gc.h ../byterun/stacks.h
-array.p.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \
- ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \
- ../byterun/freelist.h ../byterun/minor_gc.h
-callback.p.o: callback.c ../byterun/callback.h ../byterun/mlvalues.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \
- ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h
-compact.p.o: compact.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/finalise.h ../byterun/roots.h ../byterun/misc.h \
- ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/gc_ctrl.h ../byterun/weak.h
-compare.p.o: compare.c ../byterun/custom.h ../byterun/mlvalues.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \
- ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h
-custom.p.o: custom.c ../byterun/alloc.h ../byterun/misc.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
- ../byterun/custom.h ../byterun/fail.h ../byterun/memory.h \
- ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h
-dynlink.p.o: dynlink.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \
- ../byterun/dynlink.h ../byterun/fail.h ../byterun/memory.h \
- ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h ../byterun/osdeps.h ../byterun/prims.h
-extern.p.o: extern.c ../byterun/alloc.h ../byterun/misc.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
- ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \
- ../byterun/intext.h ../byterun/io.h ../byterun/memory.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/reverse.h
-fail.p.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \
- ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/printexc.h ../byterun/signals.h stack.h ../byterun/roots.h
-finalise.p.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \
- ../byterun/fail.h ../byterun/roots.h ../byterun/memory.h \
- ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h ../byterun/signals.h
-floats.p.o: floats.c ../byterun/alloc.h ../byterun/misc.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
- ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/reverse.h ../byterun/stacks.h
-freelist.p.o: freelist.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \
- ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h
-gc_ctrl.p.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
- ../byterun/compact.h ../byterun/custom.h ../byterun/finalise.h \
- ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/gc_ctrl.h ../byterun/stacks.h
-globroots.p.o: globroots.c ../byterun/memory.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/gc.h ../byterun/mlvalues.h \
- ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h ../byterun/globroots.h
-hash.p.o: hash.c ../byterun/mlvalues.h ../byterun/config.h ../config/m.h \
- ../config/s.h ../byterun/misc.h ../byterun/custom.h ../byterun/memory.h \
- ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h
-intern.p.o: intern.c ../byterun/alloc.h ../byterun/misc.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
- ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \
- ../byterun/intext.h ../byterun/io.h ../byterun/memory.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/reverse.h ../byterun/md5.h
-ints.p.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/custom.h \
- ../byterun/fail.h ../byterun/intext.h ../byterun/io.h \
- ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \
- ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/int64_native.h
-io.p.o: io.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \
- ../byterun/custom.h ../byterun/fail.h ../byterun/io.h \
- ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \
- ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/signals.h \
- ../byterun/sys.h
-lexing.p.o: lexing.c ../byterun/fail.h ../byterun/misc.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
- ../byterun/stacks.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h
-main.p.o: main.c ../byterun/misc.h ../byterun/config.h ../config/m.h \
- ../config/s.h ../byterun/mlvalues.h ../byterun/sys.h
-major_gc.p.o: major_gc.c ../byterun/compact.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/misc.h ../byterun/custom.h \
- ../byterun/mlvalues.h ../byterun/fail.h ../byterun/finalise.h \
- ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/gc_ctrl.h ../byterun/weak.h
-md5.p.o: md5.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \
- ../byterun/md5.h ../byterun/io.h ../byterun/reverse.h
-memory.p.o: memory.c ../byterun/fail.h ../byterun/misc.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
- ../byterun/freelist.h ../byterun/gc.h ../byterun/gc_ctrl.h \
- ../byterun/major_gc.h ../byterun/memory.h ../byterun/minor_gc.h \
- ../byterun/signals.h
-meta.p.o: meta.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \
- ../byterun/fix_code.h ../byterun/interp.h ../byterun/major_gc.h \
- ../byterun/freelist.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/minor_gc.h ../byterun/prims.h ../byterun/stacks.h
-minor_gc.p.o: minor_gc.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \
- ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \
- ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h ../byterun/gc_ctrl.h ../byterun/signals.h
-misc.p.o: misc.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h
-obj.p.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \
- ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/memory.h ../byterun/minor_gc.h ../byterun/prims.h
-parsing.p.o: parsing.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/mlvalues.h ../byterun/misc.h ../byterun/memory.h \
- ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h ../byterun/alloc.h
-printexc.p.o: printexc.c ../byterun/backtrace.h ../byterun/mlvalues.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \
- ../byterun/callback.h ../byterun/debugger.h ../byterun/fail.h \
- ../byterun/printexc.h
-roots.p.o: roots.c ../byterun/finalise.h ../byterun/roots.h \
- ../byterun/misc.h ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/globroots.h stack.h
-signals.p.o: signals.c ../byterun/alloc.h ../byterun/misc.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
- ../byterun/callback.h ../byterun/memory.h ../byterun/gc.h \
- ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/fail.h ../byterun/signals.h stack.h ../byterun/sys.h
-startup.p.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \
- ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \
- ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \
- ../byterun/gc_ctrl.h ../byterun/osdeps.h ../byterun/printexc.h \
- ../byterun/sys.h
-str.p.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h
-sys.p.o: sys.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \
- ../byterun/debugger.h ../byterun/fail.h ../byterun/instruct.h \
- ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \
- ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \
- ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h
-terminfo.p.o: terminfo.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \
- ../byterun/fail.h ../byterun/io.h
-unix.p.o: unix.c ../byterun/config.h ../config/m.h ../config/s.h \
- ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \
- ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \
- ../byterun/minor_gc.h ../byterun/osdeps.h
-weak.p.o: weak.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
- ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \
- ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \
- ../byterun/freelist.h ../byterun/minor_gc.h
diff --git a/asmrun/Makefile b/asmrun/Makefile
deleted file mode 100644
index ee94d50ed7..0000000000
--- a/asmrun/Makefile
+++ /dev/null
@@ -1,195 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-include ../config/Makefile
-
-CC=$(NATIVECC)
-FLAGS=-I../byterun -DNATIVE_CODE -DTARGET_$(ARCH) -DSYS_$(SYSTEM)
-CFLAGS=$(FLAGS) -O $(NATIVECCCOMPOPTS)
-DFLAGS=$(FLAGS) -g -DDEBUG $(NATIVECCCOMPOPTS)
-PFLAGS=$(FLAGS) -pg -O -DPROFILING $(NATIVECCPROFOPTS)
-
-COBJS=startup.o main.o fail.o roots.o globroots.o signals.o \
- misc.o freelist.o major_gc.o minor_gc.o memory.o alloc.o compare.o ints.o \
- floats.o str.o array.o io.o extern.o intern.o hash.o sys.o parsing.o \
- gc_ctrl.o terminfo.o md5.o obj.o lexing.o printexc.o callback.o weak.o \
- compact.o finalise.o custom.o unix.o
-
-ASMOBJS=$(ARCH).o
-
-OBJS=$(COBJS) $(ASMOBJS)
-DOBJS=$(COBJS:.o=.d.o) $(ASMOBJS)
-POBJS=$(COBJS:.o=.p.o) $(ASMOBJS:.o=.p.o)
-
-all: libasmrun.a all-$(PROFILING)
-
-libasmrun.a: $(OBJS)
- rm -f libasmrun.a
- ar rc libasmrun.a $(OBJS)
- $(RANLIB) libasmrun.a
-
-libasmrund.a: $(DOBJS)
- rm -f libasmrund.a
- ar rc libasmrund.a $(DOBJS)
- $(RANLIB) libasmrund.a
-
-all-noprof:
-
-all-prof: libasmrunp.a
-
-libasmrunp.a: $(POBJS)
- rm -f libasmrunp.a
- ar rc libasmrunp.a $(POBJS)
- $(RANLIB) libasmrunp.a
-
-install: install-default install-$(PROFILING)
-
-install-default:
- cp libasmrun.a $(LIBDIR)/libasmrun.a
- cd $(LIBDIR); $(RANLIB) libasmrun.a
-
-install-noprof:
- rm -f $(LIBDIR)/libasmrunp.a; ln -s libasmrun.a $(LIBDIR)/libasmrunp.a
-
-install-prof:
- cp libasmrunp.a $(LIBDIR)/libasmrunp.a
- cd $(LIBDIR); $(RANLIB) libasmrunp.a
-
-power.o: power-$(SYSTEM).o
- cp power-$(SYSTEM).o power.o
-
-power.p.o: power-$(SYSTEM).o
- cp power-$(SYSTEM).o power.p.o
-
-main.c: ../byterun/main.c
- ln -s ../byterun/main.c main.c
-misc.c: ../byterun/misc.c
- ln -s ../byterun/misc.c misc.c
-freelist.c: ../byterun/freelist.c
- ln -s ../byterun/freelist.c freelist.c
-major_gc.c: ../byterun/major_gc.c
- ln -s ../byterun/major_gc.c major_gc.c
-minor_gc.c: ../byterun/minor_gc.c
- ln -s ../byterun/minor_gc.c minor_gc.c
-memory.c: ../byterun/memory.c
- ln -s ../byterun/memory.c memory.c
-alloc.c: ../byterun/alloc.c
- ln -s ../byterun/alloc.c alloc.c
-array.c: ../byterun/array.c
- ln -s ../byterun/array.c array.c
-compare.c: ../byterun/compare.c
- ln -s ../byterun/compare.c compare.c
-ints.c: ../byterun/ints.c
- ln -s ../byterun/ints.c ints.c
-floats.c: ../byterun/floats.c
- ln -s ../byterun/floats.c floats.c
-str.c: ../byterun/str.c
- ln -s ../byterun/str.c str.c
-io.c: ../byterun/io.c
- ln -s ../byterun/io.c io.c
-extern.c: ../byterun/extern.c
- ln -s ../byterun/extern.c extern.c
-intern.c: ../byterun/intern.c
- ln -s ../byterun/intern.c intern.c
-hash.c: ../byterun/hash.c
- ln -s ../byterun/hash.c hash.c
-sys.c: ../byterun/sys.c
- ln -s ../byterun/sys.c sys.c
-parsing.c: ../byterun/parsing.c
- ln -s ../byterun/parsing.c parsing.c
-gc_ctrl.c: ../byterun/gc_ctrl.c
- ln -s ../byterun/gc_ctrl.c gc_ctrl.c
-terminfo.c: ../byterun/terminfo.c
- ln -s ../byterun/terminfo.c terminfo.c
-md5.c: ../byterun/md5.c
- ln -s ../byterun/md5.c md5.c
-obj.c: ../byterun/obj.c
- ln -s ../byterun/obj.c obj.c
-lexing.c: ../byterun/lexing.c
- ln -s ../byterun/lexing.c lexing.c
-printexc.c: ../byterun/printexc.c
- ln -s ../byterun/printexc.c printexc.c
-callback.c: ../byterun/callback.c
- ln -s ../byterun/callback.c callback.c
-weak.c: ../byterun/weak.c
- ln -s ../byterun/weak.c weak.c
-compact.c: ../byterun/compact.c
- ln -s ../byterun/compact.c compact.c
-finalise.c: ../byterun/finalise.c
- ln -s ../byterun/finalise.c finalise.c
-custom.c: ../byterun/custom.c
- ln -s ../byterun/custom.c custom.c
-meta.c: ../byterun/meta.c
- ln -s ../byterun/meta.c meta.c
-globroots.c: ../byterun/globroots.c
- ln -s ../byterun/globroots.c globroots.c
-unix.c: ../byterun/unix.c
- ln -s ../byterun/unix.c unix.c
-dynlink.c: ../byterun/dynlink.c
- ln -s ../byterun/dynlink.c dynlink.c
-
-LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \
- compare.c ints.c floats.c str.c io.c extern.c intern.c hash.c sys.c \
- parsing.c gc_ctrl.c terminfo.c md5.c obj.c lexing.c printexc.c callback.c \
- weak.c compact.c finalise.c meta.c custom.c main.c globroots.c unix.c \
- dynlink.c
-
-clean::
- rm -f $(LINKEDFILES)
-
-# For HPUX, we can't use gcc as ASPP because it may have been configured with
-# the vendor's assembler
-hppa.o: hppa.S
- gcc -traditional -E -DSYS_$(SYSTEM) -o hppa.s hppa.S
- gas -o hppa.o hppa.s || { rm -f hppa.s; exit 2; }
- rm -f hppa.s
-
-.SUFFIXES: .S .d.o .p.o
-
-.S.o:
- $(ASPP) $(ASPPFLAGS) -o $*.o $*.S || \
- { echo "If your assembler produced syntax errors, it is probably unhappy with the"; echo "preprocessor. Check your assembler, or try producing $*.o by hand."; exit 2; }
-
-.S.p.o:
- $(ASPP) $(ASPPFLAGS) $(ASPPPROFFLAGS) -o $*.p.o $*.S
-
-.c.d.o:
- @ if test -f $*.o; then mv $*.o $*.f.o; else :; fi
- $(CC) -c $(DFLAGS) $<
- mv $*.o $*.d.o
- @ if test -f $*.f.o; then mv $*.f.o $*.o; else :; fi
-
-.c.p.o:
- @ if test -f $*.o; then mv $*.o $*.f.o; else :; fi
- $(CC) -c $(PFLAGS) $<
- mv $*.o $*.p.o
- @ if test -f $*.f.o; then mv $*.f.o $*.o; else :; fi
-
-.s.o:
- $(ASPP) $(ASPPFLAGS) -o $*.o $*.s
-
-.s.p.o:
- $(ASPP) $(ASPPFLAGS) $(ASPPPROFFLAGS) -o $*.p.o $*.s
-
-clean::
- rm -f *.o *.a *~
-
-depend: $(COBJS:.o=.c) ${LINKEDFILES}
- gcc -MM $(FLAGS) *.c > .depend
- gcc -MM $(FLAGS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' >> .depend
- gcc -MM $(FLAGS) -DDEBUG *.c | sed -e 's/\.o/.p.o/' >> .depend
-
-include .depend
-
diff --git a/asmrun/Makefile.nt b/asmrun/Makefile.nt
deleted file mode 100644
index d505b25a96..0000000000
--- a/asmrun/Makefile.nt
+++ /dev/null
@@ -1,77 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-include ../config/Makefile
-
-CC=$(NATIVECC)
-CFLAGS=-I../byterun -DNATIVE_CODE -DTARGET_$(ARCH) -DSYS_$(SYSTEM) $(NATIVECCCOMPOPTS)
-
-COBJS=startup.$(O) main.$(O) fail.$(O) roots.$(O) signals.$(O) \
- misc.$(O) freelist.$(O) major_gc.$(O) minor_gc.$(O) memory.$(O) alloc.$(O) \
- compare.$(O) ints.$(O) floats.$(O) str.$(O) array.$(O) io.$(O) extern.$(O) \
- intern.$(O) hash.$(O) sys.$(O) parsing.$(O) gc_ctrl.$(O) terminfo.$(O) \
- md5.$(O) obj.$(O) lexing.$(O) win32.$(O) printexc.$(O) callback.$(O) \
- weak.$(O) compact.$(O) finalise.$(O) custom.$(O) globroots.$(O)
-
-LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \
- compare.c ints.c floats.c str.c io.c extern.c intern.c hash.c sys.c \
- parsing.c gc_ctrl.c terminfo.c md5.c obj.c lexing.c printexc.c callback.c \
- weak.c compact.c meta.c finalise.c custom.c main.c globroots.c \
- dynlink.c
-
-ifeq ($(TOOLCHAIN),mingw)
-ASMOBJS=i386.o
-else
-ASMOBJS=i386nt.obj
-endif
-
-OBJS=$(COBJS) $(ASMOBJS)
-
-all: libasmrun.$(A)
-
-libasmrun.$(A): $(OBJS)
- $(call MKLIB,libasmrun.$(A), $(OBJS))
-
-i386nt.obj: i386nt.asm
- ml /nologo /coff /Cp /c /Foi386nt.obj i386nt.asm
-
-i386.o: i386.S
- $(CC) -c -DSYS_$(SYSTEM) i386.S
-
-install:
- cp libasmrun.$(A) $(LIBDIR)
-
-$(LINKEDFILES): %.c: ../byterun/%.c
- cp ../byterun/$*.c $*.c
-
-# Need special compilation rule so as not to do -I../byterun
-win32.$(O): ../byterun/win32.c
- $(CC) -c $(NATIVECCCOMPOPTS) -DNATIVE_CODE ../byterun/win32.c
-
-.SUFFIXES: .c .$(O)
-
-.c.$(O):
- $(CC) $(CFLAGS) -c $<
-
-clean::
- rm -f $(LINKEDFILES)
-
-clean::
- rm -f *.$(O) *.$(A) *~
-
-.depend.nt:
- sed -e 's/\.o/.$(O)/g' .depend > .depend.nt
-
-include .depend.nt
diff --git a/asmrun/alpha.S b/asmrun/alpha.S
deleted file mode 100644
index 99c71dd8d6..0000000000
--- a/asmrun/alpha.S
+++ /dev/null
@@ -1,440 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Asm part of the runtime system, Alpha processor */
-
-/* Allocation */
-
- .text
- .globl caml_alloc2
- .globl caml_alloc3
- .globl caml_alloc
- .globl caml_call_gc
-
-/* Note: the profiling code sets $27 to the address of the "normal" entrypoint.
- So don't pass parameters to those routines in $27. */
-
-/* caml_alloc* : all code generator registers preserved,
- $gp preserved, $27 not necessarily valid on entry */
-
- .globl caml_alloc1
- .ent caml_alloc1
- .align 3
-caml_alloc1:
- .prologue 0
- subq $13, 16, $13
- cmpult $13, $14, $25
- bne $25, $100
- ret ($26)
-$100: ldiq $25, 16
- br $110
- .end caml_alloc1
-
- .globl caml_alloc2
- .ent caml_alloc2
- .align 3
-caml_alloc2:
- .prologue 0
- subq $13, 24, $13
- cmpult $13, $14, $25
- bne $25, $101
- ret ($26)
-$101: ldiq $25, 24
- br $110
- .end caml_alloc2
-
- .globl caml_alloc3
- .ent caml_alloc3
- .align 3
-caml_alloc3:
- .prologue 0
- subq $13, 32, $13
- cmpult $13, $14, $25
- bne $25, $102
- ret ($26)
-$102: ldiq $25, 32
- br $110
- .end caml_alloc3
-
- .globl caml_alloc
- .ent caml_alloc
- .align 3
-caml_alloc:
- .prologue 0
- subq $13, $25, $13
- .set noat
- cmpult $13, $14, $at
- bne $at, $110
- .set at
- ret ($26)
- .end caml_alloc
-
- .globl caml_call_gc
- .ent caml_call_gc
- .align 3
-caml_call_gc:
- .prologue 0
- ldiq $25, 0
-$110: lda $sp, -0x200($sp)
- /* 0x200 = 32*8 (ints) + 32*8 (floats) */
- stq $26, 0x1F8($sp) /* return address */
- stq $gp, 0x1F0($sp) /* caller's $gp */
- stq $25, 0x1E8($sp) /* desired size */
- /* Rebuild $gp */
- br $27, $103
-$103: ldgp $gp, 0($27)
- /* Record lowest stack address, return address, GC regs */
- stq $26, caml_last_return_address
- lda $24, 0x200($sp)
- stq $24, caml_bottom_of_stack
- lda $24, 0x100($sp)
- stq $24, caml_gc_regs
- /* Save current allocation pointer for debugging purposes */
-$113: stq $13, young_ptr
- /* Save trap pointer in case an exception is raised (e.g. sighandler) */
- stq $15, caml_exception_pointer
- /* Save all integer regs used by the code generator in the context */
- stq $0, 0 * 8 ($24)
- stq $1, 1 * 8 ($24)
- stq $2, 2 * 8 ($24)
- stq $3, 3 * 8 ($24)
- stq $4, 4 * 8 ($24)
- stq $5, 5 * 8 ($24)
- stq $6, 6 * 8 ($24)
- stq $7, 7 * 8 ($24)
- stq $8, 8 * 8 ($24)
- stq $9, 9 * 8 ($24)
- stq $10, 10 * 8 ($24)
- stq $11, 11 * 8 ($24)
- stq $12, 12 * 8 ($24)
- stq $16, 16 * 8 ($24)
- stq $17, 17 * 8 ($24)
- stq $18, 18 * 8 ($24)
- stq $19, 19 * 8 ($24)
- stq $20, 20 * 8 ($24)
- stq $21, 21 * 8 ($24)
- stq $22, 22 * 8 ($24)
- /* Save all float regs that are not callee-save on the stack */
- stt $f0, 0 * 8 ($sp)
- stt $f1, 1 * 8 ($sp)
- stt $f10, 10 * 8 ($sp)
- stt $f11, 11 * 8 ($sp)
- stt $f12, 12 * 8 ($sp)
- stt $f13, 13 * 8 ($sp)
- stt $f14, 14 * 8 ($sp)
- stt $f15, 15 * 8 ($sp)
- stt $f16, 16 * 8 ($sp)
- stt $f17, 17 * 8 ($sp)
- stt $f18, 18 * 8 ($sp)
- stt $f19, 19 * 8 ($sp)
- stt $f20, 20 * 8 ($sp)
- stt $f21, 21 * 8 ($sp)
- stt $f22, 22 * 8 ($sp)
- stt $f23, 23 * 8 ($sp)
- stt $f24, 24 * 8 ($sp)
- stt $f25, 25 * 8 ($sp)
- stt $f26, 26 * 8 ($sp)
- stt $f27, 27 * 8 ($sp)
- stt $f29, 29 * 8 ($sp)
- stt $f30, 30 * 8 ($sp)
- /* Call the garbage collector */
- jsr garbage_collection
- ldgp $gp, 0($26)
- /* Restore all regs used by the code generator */
- lda $24, 0x100($sp)
- ldq $0, 0 * 8 ($24)
- ldq $1, 1 * 8 ($24)
- ldq $2, 2 * 8 ($24)
- ldq $3, 3 * 8 ($24)
- ldq $4, 4 * 8 ($24)
- ldq $5, 5 * 8 ($24)
- ldq $6, 6 * 8 ($24)
- ldq $7, 7 * 8 ($24)
- ldq $8, 8 * 8 ($24)
- ldq $9, 9 * 8 ($24)
- ldq $10, 10 * 8 ($24)
- ldq $11, 11 * 8 ($24)
- ldq $12, 12 * 8 ($24)
- ldq $16, 16 * 8 ($24)
- ldq $17, 17 * 8 ($24)
- ldq $18, 18 * 8 ($24)
- ldq $19, 19 * 8 ($24)
- ldq $20, 20 * 8 ($24)
- ldq $21, 21 * 8 ($24)
- ldq $22, 22 * 8 ($24)
- ldt $f0, 0 * 8 ($sp)
- ldt $f1, 1 * 8 ($sp)
- ldt $f10, 10 * 8 ($sp)
- ldt $f11, 11 * 8 ($sp)
- ldt $f12, 12 * 8 ($sp)
- ldt $f13, 13 * 8 ($sp)
- ldt $f14, 14 * 8 ($sp)
- ldt $f15, 15 * 8 ($sp)
- ldt $f16, 16 * 8 ($sp)
- ldt $f17, 17 * 8 ($sp)
- ldt $f18, 18 * 8 ($sp)
- ldt $f19, 19 * 8 ($sp)
- ldt $f20, 20 * 8 ($sp)
- ldt $f21, 21 * 8 ($sp)
- ldt $f22, 22 * 8 ($sp)
- ldt $f23, 23 * 8 ($sp)
- ldt $f24, 24 * 8 ($sp)
- ldt $f25, 25 * 8 ($sp)
- ldt $f26, 26 * 8 ($sp)
- ldt $f27, 27 * 8 ($sp)
- ldt $f29, 29 * 8 ($sp)
- ldt $f30, 30 * 8 ($sp)
- /* Reload new allocation pointer and allocation limit */
- ldq $13, young_ptr
- ldq $14, young_limit
- /* Allocate space for the block */
- ldq $25, 0x1E8($sp)
- subq $13, $25, $13
- cmpult $13, $14, $25 /* Check that we have enough free space */
- bne $25, $113 /* If not, call GC again */
- /* Say that we are back into Caml code */
- stq $31, caml_last_return_address
- /* Return to caller */
- ldq $26, 0x1F8($sp)
- ldq $gp, 0x1F0($sp)
- lda $sp, 0x200($sp)
- ret ($26)
-
- .end caml_call_gc
-
-/* Call a C function from Caml */
-/* Function to call is in $25 */
-
- .globl caml_c_call
- .ent caml_c_call
- .align 3
-caml_c_call:
- .prologue 0
- /* Preserve return address and caller's $gp in callee-save registers */
- mov $26, $9
- mov $gp, $10
- /* Rebuild $gp */
- br $27, $104
-$104: ldgp $gp, 0($27)
- /* Record lowest stack address and return address */
- lda $11, caml_last_return_address
- stq $26, 0($11)
- stq $sp, caml_bottom_of_stack
- /* Make the exception handler and alloc ptr available to the C code */
- lda $12, young_ptr
- stq $13, 0($12)
- lda $14, young_limit
- stq $15, caml_exception_pointer
- /* Call the function */
- mov $25, $27
- jsr ($25)
- /* Reload alloc ptr and alloc limit */
- ldq $13, 0($12) /* $12 still points to young_ptr */
- ldq $14, 0($14) /* $14 still points to young_limit */
- /* Say that we are back into Caml code */
- stq $31, 0($11) /* $11 still points to caml_last_return_address */
- /* Restore $gp */
- mov $10, $gp
- /* Return */
- ret ($9)
-
- .end caml_c_call
-
-/* Start the Caml program */
-
- .globl caml_start_program
- .ent caml_start_program
- .align 3
-caml_start_program:
- ldgp $gp, 0($27)
- lda $25, caml_program
-
-/* Code shared with callback* */
-$107:
- /* Save return address */
- lda $sp, -128($sp)
- stq $26, 0($sp)
- /* Save all callee-save registers */
- stq $9, 8($sp)
- stq $10, 16($sp)
- stq $11, 24($sp)
- stq $12, 32($sp)
- stq $13, 40($sp)
- stq $14, 48($sp)
- stq $15, 56($sp)
- stt $f2, 64($sp)
- stt $f3, 72($sp)
- stt $f4, 80($sp)
- stt $f5, 88($sp)
- stt $f6, 96($sp)
- stt $f7, 104($sp)
- stt $f8, 112($sp)
- stt $f9, 120($sp)
- /* Set up a callback link on the stack. */
- lda $sp, -32($sp)
- ldq $0, caml_bottom_of_stack
- stq $0, 0($sp)
- ldq $1, caml_last_return_address
- stq $1, 8($sp)
- ldq $1, caml_gc_regs
- stq $1, 16($sp)
- /* Set up a trap frame to catch exceptions escaping the Caml code */
- lda $sp, -16($sp)
- ldq $15, caml_exception_pointer
- stq $15, 0($sp)
- lda $0, $109
- stq $0, 8($sp)
- mov $sp, $15
- /* Reload allocation pointers */
- ldq $13, young_ptr
- ldq $14, young_limit
- /* We are back into Caml code */
- stq $31, caml_last_return_address
- /* Call the Caml code */
- mov $25, $27
-$108: jsr ($25)
- /* Reload $gp, masking off low bit in retaddr (might have been marked) */
- bic $26, 1, $26
- ldgp $gp, 4($26)
- /* Pop the trap frame, restoring caml_exception_pointer */
- ldq $15, 0($sp)
- stq $15, caml_exception_pointer
- lda $sp, 16($sp)
- /* Pop the callback link, restoring the global variables */
-$112: ldq $24, 0($sp)
- stq $24, caml_bottom_of_stack
- ldq $25, 8($sp)
- stq $25, caml_last_return_address
- ldq $24, 16($sp)
- stq $24, caml_gc_regs
- lda $sp, 32($sp)
- /* Update allocation pointer */
- stq $13, young_ptr
- /* Reload callee-save registers */
- ldq $9, 8($sp)
- ldq $10, 16($sp)
- ldq $11, 24($sp)
- ldq $12, 32($sp)
- ldq $13, 40($sp)
- ldq $14, 48($sp)
- ldq $15, 56($sp)
- ldt $f2, 64($sp)
- ldt $f3, 72($sp)
- ldt $f4, 80($sp)
- ldt $f5, 88($sp)
- ldt $f6, 96($sp)
- ldt $f7, 104($sp)
- ldt $f8, 112($sp)
- ldt $f9, 120($sp)
- /* Return to caller */
- ldq $26, 0($sp)
- lda $sp, 128($sp)
- ret ($26)
-
- /* The trap handler */
-$109: ldgp $gp, 0($26)
- /* Save exception pointer */
- stq $15, caml_exception_pointer
- /* Encode exception bucket as an exception result */
- or $0, 2, $0
- /* Return it */
- br $112
-
- .end caml_start_program
-
-/* Raise an exception from C */
-
- .globl raise_caml_exception
- .ent raise_caml_exception
- .align 3
-raise_caml_exception:
- ldgp $gp, 0($27)
- mov $16, $0 /* Move exn bucket */
- ldq $13, young_ptr
- ldq $14, young_limit
- stq $31, caml_last_return_address /* We're back into Caml */
- ldq $sp, caml_exception_pointer
- ldq $15, 0($sp)
- ldq $26, 8($sp)
- lda $sp, 16($sp)
- jmp $25, ($26) /* Keep retaddr in $25 to help debugging */
- .end raise_caml_exception
-
-/* Callback from C to Caml */
-
- .globl callback_exn
- .ent callback_exn
- .align 3
-callback_exn:
- /* Initial shuffling of arguments */
- ldgp $gp, 0($27)
- mov $16, $25
- mov $17, $16 /* first arg */
- mov $25, $17 /* environment */
- ldq $25, 0($25) /* code pointer */
- br $107
- .end callback_exn
-
- .globl callback2_exn
- .ent callback2_exn
- .align 3
-callback2_exn:
- ldgp $gp, 0($27)
- mov $16, $25
- mov $17, $16 /* first arg */
- mov $18, $17 /* second arg */
- mov $25, $18 /* environment */
- lda $25, caml_apply2
- br $107
- .end callback2_exn
-
- .globl callback3_exn
- .ent callback3_exn
- .align 3
-callback3_exn:
- ldgp $gp, 0($27)
- mov $16, $25
- mov $17, $16 /* first arg */
- mov $18, $17 /* second arg */
- mov $19, $18 /* third arg */
- mov $25, $19 /* environment */
- lda $25, caml_apply3
- br $107
- .end callback3_exn
-
-/* Glue code to call array_bound_error */
-
- .globl caml_array_bound_error
- .ent caml_array_bound_error
- .align 3
-caml_array_bound_error:
- br $27, $111
-$111: ldgp $gp, 0($27)
- lda $25, array_bound_error
- br caml_c_call /* never returns */
- .end caml_array_bound_error
-
-#if defined(SYS_digital)
- .rdata
-#else
- .section .rodata
-#endif
- .globl system__frametable
-system__frametable:
- .quad 1 /* one descriptor */
- .quad $108 + 4 /* return address into callback */
- .word -1 /* negative frame size => use callback link */
- .word 0 /* no roots here */
- .align 3
diff --git a/asmrun/amd64.S b/asmrun/amd64.S
deleted file mode 100644
index 8168ee7dfa..0000000000
--- a/asmrun/amd64.S
+++ /dev/null
@@ -1,335 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 2003 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Asm part of the runtime system, AMD64 processor */
-/* Must be preprocessed by cpp */
-
-#define FUNCTION_ALIGN 4
-
-#define FUNCTION(name) \
- .globl name; \
- .type name,@function; \
- .align FUNCTION_ALIGN; \
- name:
-
- .text
-
-/* Allocation */
-
-FUNCTION(caml_call_gc)
- /* Record lowest stack address and return address */
- movq 0(%rsp), %rax
- movq %rax, caml_last_return_address(%rip)
- leaq 8(%rsp), %rax
- movq %rax, caml_bottom_of_stack(%rip)
- /* Save young_ptr, caml_exception_pointer */
- movq %r15, young_ptr(%rip)
- movq %r14, caml_exception_pointer(%rip)
- /* Build array of registers, save it into caml_gc_regs */
-.L105:
- pushq %r13
- pushq %r12
- pushq %rbp
- pushq %r11
- pushq %r10
- pushq %r9
- pushq %r8
- pushq %rcx
- pushq %rdx
- pushq %rsi
- pushq %rdi
- pushq %rbx
- pushq %rax
- movq %rsp, caml_gc_regs
- /* Save floating-point registers */
- subq $(16*8), %rsp
- movlpd %xmm0, 0*8(%rsp)
- movlpd %xmm1, 1*8(%rsp)
- movlpd %xmm2, 2*8(%rsp)
- movlpd %xmm3, 3*8(%rsp)
- movlpd %xmm4, 4*8(%rsp)
- movlpd %xmm5, 5*8(%rsp)
- movlpd %xmm6, 6*8(%rsp)
- movlpd %xmm7, 7*8(%rsp)
- movlpd %xmm8, 8*8(%rsp)
- movlpd %xmm9, 9*8(%rsp)
- movlpd %xmm10, 10*8(%rsp)
- movlpd %xmm11, 11*8(%rsp)
- movlpd %xmm12, 12*8(%rsp)
- movlpd %xmm13, 13*8(%rsp)
- movlpd %xmm14, 14*8(%rsp)
- movlpd %xmm15, 15*8(%rsp)
- /* Call the garbage collector */
- call garbage_collection
- /* Restore all regs used by the code generator */
- movlpd 0*8(%rsp), %xmm0
- movlpd 1*8(%rsp), %xmm1
- movlpd 2*8(%rsp), %xmm2
- movlpd 3*8(%rsp), %xmm3
- movlpd 4*8(%rsp), %xmm4
- movlpd 5*8(%rsp), %xmm5
- movlpd 6*8(%rsp), %xmm6
- movlpd 7*8(%rsp), %xmm7
- movlpd 8*8(%rsp), %xmm8
- movlpd 9*8(%rsp), %xmm9
- movlpd 10*8(%rsp), %xmm10
- movlpd 11*8(%rsp), %xmm11
- movlpd 12*8(%rsp), %xmm12
- movlpd 13*8(%rsp), %xmm13
- movlpd 14*8(%rsp), %xmm14
- movlpd 15*8(%rsp), %xmm15
- addq $(16*8), %rsp
- popq %rax
- popq %rbx
- popq %rdi
- popq %rsi
- popq %rdx
- popq %rcx
- popq %r8
- popq %r9
- popq %r10
- popq %r11
- popq %rbp
- popq %r12
- popq %r13
- /* Restore young_ptr, caml_exception_pointer */
- movq young_ptr(%rip), %r15
- movq caml_exception_pointer(%rip), %r14
- /* Return to caller */
- ret
-
-FUNCTION(caml_alloc1)
- subq $16, %r15
- cmpq young_limit(%rip), %r15
- jb .L100
- ret
-.L100:
- movq 0(%rsp), %rax
- movq %rax, caml_last_return_address(%rip)
- leaq 8(%rsp), %rax
- movq %rax, caml_bottom_of_stack(%rip)
- subq $8, %rsp
- call .L105
- addq $8, %rsp
- jmp caml_alloc1
-
-FUNCTION(caml_alloc2)
- subq $24, %r15
- cmpq young_limit(%rip), %r15
- jb .L101
- ret
-.L101:
- movq 0(%rsp), %rax
- movq %rax, caml_last_return_address(%rip)
- leaq 8(%rsp), %rax
- movq %rax, caml_bottom_of_stack(%rip)
- subq $8, %rsp
- call .L105
- addq $8, %rsp
- jmp caml_alloc2
-
-FUNCTION(caml_alloc3)
- subq $32, %r15
- cmpq young_limit(%rip), %r15
- jb .L102
- ret
-.L102:
- movq 0(%rsp), %rax
- movq %rax, caml_last_return_address(%rip)
- leaq 8(%rsp), %rax
- movq %rax, caml_bottom_of_stack(%rip)
- subq $8, %rsp
- call .L105
- addq $8, %rsp
- jmp caml_alloc3
-
-FUNCTION(caml_alloc)
- subq %rax, %r15
- cmpq young_limit(%rip), %r15
- jb .L103
- ret
-.L103:
- pushq %rax /* save desired size */
- movq 8(%rsp), %rax
- movq %rax, caml_last_return_address(%rip)
- leaq 16(%rsp), %rax
- movq %rax, caml_bottom_of_stack(%rip)
- call .L105
- popq %rax /* recover desired size */
- jmp caml_alloc
-
-/* Call a C function from Caml */
-
-FUNCTION(caml_c_call)
- /* Record lowest stack address and return address */
- popq %r12
- movq %r12, caml_last_return_address(%rip)
- movq %rsp, caml_bottom_of_stack(%rip)
- /* Make the exception handler and alloc ptr available to the C code */
- movq %r15, young_ptr(%rip)
- movq %r14, caml_exception_pointer(%rip)
- /* Call the function (address in %rax) */
- call *%rax
- /* Reload alloc ptr */
- movq young_ptr(%rip), %r15
- /* Return to caller */
- pushq %r12
- ret
-
-/* Start the Caml program */
-
-FUNCTION(caml_start_program)
- /* Save callee-save registers */
- pushq %rbx
- pushq %rbp
- pushq %r12
- pushq %r13
- pushq %r14
- pushq %r15
- subq $8, %rsp /* stack 16-aligned */
- /* Initial entry point is caml_program */
- leaq caml_program(%rip), %r12
- /* Common code for caml_start_program and callback* */
-.L106:
- /* Build a callback link */
- subq $8, %rsp /* stack 16-aligned */
- pushq caml_gc_regs(%rip)
- pushq caml_last_return_address(%rip)
- pushq caml_bottom_of_stack(%rip)
- /* Setup alloc ptr and exception ptr */
- movq young_ptr(%rip), %r15
- movq caml_exception_pointer(%rip), %r14
- /* Build an exception handler */
- lea .L108(%rip), %r13
- pushq %r13
- pushq %r14
- movq %rsp, %r14
- /* Call the Caml code */
- call *%r12
-.L107:
- /* Pop the exception handler */
- popq %r14
- popq %r12 /* dummy register */
-.L109:
- /* Update alloc ptr and exception ptr */
- movq %r15, young_ptr(%rip)
- movq %r14, caml_exception_pointer(%rip)
- /* Pop the callback link, restoring the global variables */
- popq caml_bottom_of_stack(%rip)
- popq caml_last_return_address(%rip)
- popq caml_gc_regs(%rip)
- addq $8, %rsp
- /* Restore callee-save registers. */
- addq $8, %rsp
- popq %r15
- popq %r14
- popq %r13
- popq %r12
- popq %rbp
- popq %rbx
- /* Return to caller. */
- ret
-.L108:
- /* Exception handler*/
- /* Mark the bucket as an exception result and return it */
- orq $2, %rax
- jmp .L109
-
-/* Raise an exception from C */
-
-FUNCTION(raise_caml_exception)
- movq %rdi, %rax
- movq caml_exception_pointer(%rip), %rsp
- popq caml_exception_pointer(%rip)
- ret
-
-/* Callback from C to Caml */
-
-FUNCTION(callback_exn)
- /* Save callee-save registers */
- pushq %rbx
- pushq %rbp
- pushq %r12
- pushq %r13
- pushq %r14
- pushq %r15
- subq $8, %rsp /* stack 16-aligned */
- /* Initial loading of arguments */
- movq %rdi, %rbx /* closure */
- movq %rsi, %rax /* argument */
- movq 0(%rbx), %r12 /* code pointer */
- jmp .L106
-
-FUNCTION(callback2_exn)
- /* Save callee-save registers */
- pushq %rbx
- pushq %rbp
- pushq %r12
- pushq %r13
- pushq %r14
- pushq %r15
- subq $8, %rsp /* stack 16-aligned */
- /* Initial loading of arguments */
- /* closure stays in %rdi */
- movq %rsi, %rax /* first argument */
- movq %rdx, %rbx /* second argument */
- leaq caml_apply2(%rip), %r12 /* code pointer */
- jmp .L106
-
-FUNCTION(callback3_exn)
- /* Save callee-save registers */
- pushq %rbx
- pushq %rbp
- pushq %r12
- pushq %r13
- pushq %r14
- pushq %r15
- subq $8, %rsp /* stack 16-aligned */
- /* Initial loading of arguments */
- movq %rsi, %rax /* first argument */
- movq %rdx, %rbx /* second argument */
- movq %rdi, %rsi /* closure */
- movq %rcx, %rdi /* third argument */
- leaq caml_apply3(%rip), %r12 /* code pointer */
- jmp .L106
-
-FUNCTION(caml_array_bound_error)
- /* Make the exception handler and alloc ptr available to the C code */
- movq %r15, young_ptr(%rip)
- movq %r14, caml_exception_pointer(%rip)
- jmp array_bound_error
-
- .data
- .globl system__frametable
- .type system__frametable,@object
- .align 8
-system__frametable:
- .quad 1 /* one descriptor */
- .quad .L107 /* return address into callback */
- .value -1 /* negative frame size => use callback link */
- .value 0 /* no roots here */
- .align 8
-
- .section .rodata.cst8,"aM",@progbits,8
- .globl caml_negf_mask
- .type caml_negf_mask,@object
- .align 16
-caml_negf_mask:
- .quad 0x8000000000000000, 0
- .globl caml_absf_mask
- .type caml_absf_mask,@object
- .align 16
-caml_absf_mask:
- .quad 0x7FFFFFFFFFFFFFFF, 0xFFFFFFFFFFFFFFFF
diff --git a/asmrun/arm.S b/asmrun/arm.S
deleted file mode 100644
index c465636b5d..0000000000
--- a/asmrun/arm.S
+++ /dev/null
@@ -1,339 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1998 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Asm part of the runtime system, ARM processor */
-
-trap_ptr .req r11
-alloc_ptr .req r8
-alloc_limit .req r9
-sp .req r13
-lr .req r14
-pc .req r15
-
- .text
-
-/* Allocation functions and GC interface */
-
- .global caml_call_gc
-caml_call_gc:
- /* Record return address */
- /* We can use r10 as a temp reg since it's not live here */
- ldr r10, .Lcaml_last_return_address
- str lr, [r10, #0]
- /* Branch to shared GC code */
- bl .Linvoke_gc
- /* Restart allocation sequence (4 instructions before) */
- sub lr, lr, #16
- mov pc, lr
-
- .global caml_alloc1
-caml_alloc1:
- ldr r10, [alloc_limit, #0]
- sub alloc_ptr, alloc_ptr, #8
- cmp alloc_ptr, r10
- movcs pc, lr /* Return if alloc_ptr >= alloc_limit */
- /* Record return address */
- ldr r10, .Lcaml_last_return_address
- str lr, [r10, #0]
- /* Invoke GC */
- bl .Linvoke_gc
- /* Try again */
- b caml_alloc1
-
- .global caml_alloc2
-caml_alloc2:
- ldr r10, [alloc_limit, #0]
- sub alloc_ptr, alloc_ptr, #12
- cmp alloc_ptr, r10
- movcs pc, lr /* Return if alloc_ptr >= alloc_limit */
- /* Record return address */
- ldr r10, .Lcaml_last_return_address
- str lr, [r10, #0]
- /* Invoke GC */
- bl .Linvoke_gc
- /* Try again */
- b caml_alloc2
-
- .global caml_alloc3
-caml_alloc3:
- ldr r10, [alloc_limit, #0]
- sub alloc_ptr, alloc_ptr, #16
- cmp alloc_ptr, r10
- movcs pc, lr /* Return if alloc_ptr >= alloc_limit */
- /* Record return address */
- ldr r10, .Lcaml_last_return_address
- str lr, [r10, #0]
- /* Invoke GC */
- bl .Linvoke_gc
- /* Try again */
- b caml_alloc3
-
- .global caml_alloc
-caml_alloc:
- str r12, [sp, #-4]!
- ldr r12, [alloc_limit, #0]
- sub alloc_ptr, alloc_ptr, r10
- cmp alloc_ptr, r12
- ldr r12, [sp], #4
- movcs pc, lr /* Return if alloc_ptr >= alloc_limit */
- /* Record return address and desired size */
- ldr alloc_limit, .Lcaml_last_return_address
- str lr, [alloc_limit, #0]
- str r10, .Lcaml_requested_size
- /* Invoke GC */
- bl .Linvoke_gc
- /* Try again */
- ldr r10, .Lcaml_requested_size
- b caml_alloc
-
-/* Shared code to invoke the GC */
-.Linvoke_gc:
- /* Record lowest stack address */
- ldr r10, .Lcaml_bottom_of_stack
- str sp, [r10, #0]
- /* Save integer registers and return address on stack */
- stmfd sp!, {r0,r1,r2,r3,r4,r5,r6,r7,r10,r12,lr}
- /* Store pointer to saved integer registers in caml_gc_regs */
- ldr r10, .Lcaml_gc_regs
- str sp, [r10, #0]
- /* Save non-callee-save float registers */
- stfd f0, [sp, #-8]!
- stfd f1, [sp, #-8]!
- stfd f2, [sp, #-8]!
- stfd f3, [sp, #-8]!
- /* Save current allocation pointer for debugging purposes */
- ldr r10, .Lyoung_ptr
- str alloc_ptr, [r10, #0]
- /* Save trap pointer in case an exception is raised during GC */
- ldr r10, .Lcaml_exception_pointer
- str trap_ptr, [r10, #0]
- /* Call the garbage collector */
- bl garbage_collection
- /* Restore the registers from the stack */
- ldfd f4, [sp], #8
- ldfd f5, [sp], #8
- ldfd f6, [sp], #8
- ldfd f7, [sp], #8
- ldmfd sp!, {r0,r1,r2,r3,r4,r5,r6,r7,r10,r12}
- /* Reload return address */
- ldr r10, .Lcaml_last_return_address
- ldr lr, [r10, #0]
- /* Say that we are back into Caml code */
- mov alloc_ptr, #0
- str alloc_ptr, [r10, #0]
- /* Reload new allocation pointer and allocation limit */
- ldr r10, .Lyoung_ptr
- ldr alloc_ptr, [r10, #0]
- ldr alloc_limit, .Lyoung_limit
- /* Return to caller */
- ldmfd sp!, {pc}
-
-/* Call a C function from Caml */
-/* Function to call is in r10 */
-
- .global caml_c_call
-caml_c_call:
- /* Preserve return address in callee-save register r4 */
- mov r4, lr
- /* Record lowest stack address and return address */
- ldr r5, .Lcaml_last_return_address
- ldr r6, .Lcaml_bottom_of_stack
- str lr, [r5, #0]
- str sp, [r6, #0]
- /* Make the exception handler and alloc ptr available to the C code */
- ldr r6, .Lyoung_ptr
- ldr r7, .Lcaml_exception_pointer
- str alloc_ptr, [r6, #0]
- str trap_ptr, [r7, #0]
- /* Call the function */
- mov lr, pc
- mov pc, r10
- /* Reload alloc ptr */
- ldr alloc_ptr, [r6, #0] /* r6 still points to young_ptr */
- /* Say that we are back into Caml code */
- mov r6, #0
- str r6, [r5, #0] /* r5 still points to caml_last_return_address */
- /* Return */
- mov pc, r4
-
-/* Start the Caml program */
-
- .global caml_start_program
-caml_start_program:
- ldr r10, .Lcaml_program
-
-/* Code shared with callback* */
-/* Address of Caml code to call is in r10 */
-/* Arguments to the Caml code are in r0...r3 */
-
-.Ljump_to_caml:
- /* Save return address and callee-save registers */
- stmfd sp!, {r4,r5,r6,r7,r8,r9,r11,lr}
- stfd f7, [sp, #-8]!
- stfd f6, [sp, #-8]!
- stfd f5, [sp, #-8]!
- stfd f4, [sp, #-8]!
- /* Setup a callback link on the stack */
- sub sp, sp, #4*3
- ldr r4, .Lcaml_bottom_of_stack
- ldr r4, [r4, #0]
- str r4, [sp, #0]
- ldr r4, .Lcaml_last_return_address
- ldr r4, [r4, #0]
- str r4, [sp, #4]
- ldr r4, .Lcaml_gc_regs
- ldr r4, [r4, #0]
- str r4, [sp, #8]
- /* Setup a trap frame to catch exceptions escaping the Caml code */
- sub sp, sp, #4*2
- ldr r4, .Lcaml_exception_pointer
- ldr r4, [r4, #0]
- str r4, [sp, #0]
- ldr r4, .LLtrap_handler
- str r4, [sp, #4]
- mov trap_ptr, sp
- /* Reload allocation pointers */
- ldr r4, .Lyoung_ptr
- ldr alloc_ptr, [r4, #0]
- ldr alloc_limit, .Lyoung_limit
- /* We are back into Caml code */
- ldr r4, .Lcaml_last_return_address
- mov r5, #0
- str r5, [r4, #0]
- /* Call the Caml code */
- mov lr, pc
- mov pc, r10
-.Lcaml_retaddr:
- /* Pop the trap frame, restoring caml_exception_pointer */
- ldr r4, .Lcaml_exception_pointer
- ldr r5, [sp, #0]
- str r5, [r4, #0]
- add sp, sp, #2 * 4
- /* Pop the callback link, restoring the global variables */
-.Lreturn_result:
- ldr r4, .Lcaml_bottom_of_stack
- ldr r5, [sp, #0]
- str r5, [r4, #0]
- ldr r4, .Lcaml_last_return_address
- ldr r5, [sp, #4]
- str r5, [r4, #0]
- ldr r4, .Lcaml_gc_regs
- ldr r5, [sp, #8]
- str r5, [r4, #0]
- add sp, sp, #4*3
- /* Update allocation pointer */
- ldr r4, .Lyoung_ptr
- str alloc_ptr, [r4, #0]
- /* Reload callee-save registers and return */
- ldfd f4, [sp], #8
- ldfd f5, [sp], #8
- ldfd f6, [sp], #8
- ldfd f7, [sp], #8
- ldmfd sp!, {r4,r5,r6,r7,r8,r9,r11,pc}
-
- /* The trap handler */
-.Ltrap_handler:
- /* Save exception pointer */
- ldr r4, .Lcaml_exception_pointer
- str trap_ptr, [r4, #0]
- /* Encode exception bucket as an exception result */
- orr r0, r0, #2
- /* Return it */
- b .Lreturn_result
-
-/* Raise an exception from C */
-
- .global raise_caml_exception
-raise_caml_exception:
- /* Reload Caml allocation pointers */
- ldr r1, .Lyoung_ptr
- ldr alloc_ptr, [r1, #0]
- ldr alloc_limit, .Lyoung_limit
- /* Say we're back into Caml */
- ldr r1, .Lcaml_last_return_address
- mov r2, #0
- str r2, [r1, #0]
- /* Cut stack at current trap handler */
- ldr r1, .Lcaml_exception_pointer
- ldr sp, [r1, #0]
- /* Pop previous handler and addr of trap, and jump to it */
- ldmfd sp!, {trap_ptr, pc}
-
-/* Callback from C to Caml */
-
- .global callback_exn
-callback_exn:
- /* Initial shuffling of arguments (r0 = closure, r1 = first arg) */
- mov r10, r0
- mov r0, r1 /* r0 = first arg */
- mov r1, r10 /* r1 = closure environment */
- ldr r10, [r10, #0] /* code pointer */
- b .Ljump_to_caml
-
- .global callback2_exn
-callback2_exn:
- /* Initial shuffling of arguments (r0 = closure, r1 = arg1, r2 = arg2) */
- mov r10, r0
- mov r0, r1 /* r0 = first arg */
- mov r1, r2 /* r1 = second arg */
- mov r2, r10 /* r2 = closure environment */
- ldr r10, .Lcaml_apply2
- b .Ljump_to_caml
-
- .global callback3_exn
-callback3_exn:
- /* Initial shuffling of arguments */
- /* (r0 = closure, r1 = arg1, r2 = arg2, r3 = arg3) */
- mov r10, r0
- mov r0, r1 /* r0 = first arg */
- mov r1, r2 /* r1 = second arg */
- mov r2, r3 /* r2 = third arg */
- mov r3, r10 /* r3 = closure environment */
- ldr r10, .Lcaml_apply3
- b .Ljump_to_caml
-
- .global caml_array_bound_error
-caml_array_bound_error:
- /* Load address of array_bound_error in r10 */
- ldr r10, .Larray_bound_error
- /* Call that function */
- b caml_c_call
-
-/* Global references */
-
-.Lcaml_last_return_address: .word caml_last_return_address
-.Lcaml_bottom_of_stack: .word caml_bottom_of_stack
-.Lcaml_gc_regs: .word caml_gc_regs
-.Lyoung_ptr: .word young_ptr
-.Lyoung_limit: .word young_limit
-.Lcaml_exception_pointer: .word caml_exception_pointer
-.Lcaml_program: .word caml_program
-.LLtrap_handler: .word .Ltrap_handler
-.Lcaml_apply2: .word caml_apply2
-.Lcaml_apply3: .word caml_apply3
-.Lcaml_requested_size: .word 0
-.Larray_bound_error: .word array_bound_error
-
-/* GC roots for callback */
-
- .data
-
- .global system__frametable
-system__frametable:
- .word 1 /* one descriptor */
- .word .Lcaml_retaddr /* return address into callback */
- .short -1 /* negative frame size => use callback link */
- .short 0 /* no roots */
- .align 2
diff --git a/asmrun/fail.c b/asmrun/fail.c
deleted file mode 100644
index 0c79b7f157..0000000000
--- a/asmrun/fail.c
+++ /dev/null
@@ -1,172 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Raising exceptions from C. */
-
-#include <signal.h>
-#include "alloc.h"
-#include "fail.h"
-#include "io.h"
-#include "gc.h"
-#include "memory.h"
-#include "mlvalues.h"
-#include "printexc.h"
-#include "signals.h"
-#include "stack.h"
-#include "roots.h"
-
-/* The globals holding predefined exceptions */
-
-typedef value caml_generated_constant[1];
-
-extern caml_generated_constant Out_of_memory, Sys_error, Failure,
- Invalid_argument, End_of_file, Division_by_zero, Not_found,
- Match_failure, Sys_blocked_io, Stack_overflow;
-extern caml_generated_constant
- bucket_Out_of_memory, bucket_Stack_overflow;
-
-/* Exception raising */
-
-extern void raise_caml_exception (value bucket) Noreturn;
-
-char * caml_exception_pointer = NULL;
-
-void mlraise(value v)
-{
- Unlock_exn();
- if (caml_exception_pointer == NULL) fatal_uncaught_exception(v);
-
-#ifndef Stack_grows_upwards
-#define PUSHED_AFTER <
-#else
-#define PUSHED_AFTER >
-#endif
- while (local_roots != NULL &&
- (char *) local_roots PUSHED_AFTER caml_exception_pointer) {
- local_roots = local_roots->next;
- }
-#undef PUSHED_AFTER
-
- raise_caml_exception(v);
-}
-
-void raise_constant(value tag)
-{
- value bucket;
- Begin_root (tag);
- bucket = alloc_small (1, 0);
- Field(bucket, 0) = tag;
- End_roots ();
- mlraise(bucket);
-}
-
-void raise_with_arg(value tag, value arg)
-{
- value bucket;
- Begin_roots2 (tag, arg);
- bucket = alloc_small (2, 0);
- Field(bucket, 0) = tag;
- Field(bucket, 1) = arg;
- End_roots ();
- mlraise(bucket);
-}
-
-void raise_with_string(value tag, char *msg)
-{
- raise_with_arg(tag, copy_string(msg));
-}
-
-void failwith (char *msg)
-{
- raise_with_string((value) Failure, msg);
-}
-
-void invalid_argument (char *msg)
-{
- raise_with_string((value) Invalid_argument, msg);
-}
-
-/* To raise Out_of_memory, we can't use raise_constant,
- because it allocates and we're out of memory...
- We therefore use a statically-allocated bucket constructed
- by the ocamlopt linker.
- This works OK because the exception value for Out_of_memory is also
- statically allocated out of the heap.
- The same applies to Stack_overflow. */
-
-void raise_out_of_memory(void)
-{
- mlraise((value) &bucket_Out_of_memory);
-}
-
-void raise_stack_overflow(void)
-{
- mlraise((value) &bucket_Stack_overflow);
-}
-
-void raise_sys_error(value msg)
-{
- raise_with_arg((value) Sys_error, msg);
-}
-
-void raise_end_of_file(void)
-{
- raise_constant((value) End_of_file);
-}
-
-void raise_zero_divide(void)
-{
- raise_constant((value) Division_by_zero);
-}
-
-void raise_not_found(void)
-{
- raise_constant((value) Not_found);
-}
-
-void raise_sys_blocked_io(void)
-{
- raise_constant((value) Sys_blocked_io);
-}
-
-/* We allocate statically the bucket for the exception because we can't
- do a GC before the exception is raised (lack of stack descriptors
- for the ccall to array_bound_error */
-
-#define BOUND_MSG "index out of bounds"
-#define BOUND_MSG_LEN (sizeof(BOUND_MSG) - 1)
-
-static struct {
- header_t hdr;
- value exn;
- value arg;
-} array_bound_error_bucket;
-
-static struct {
- header_t hdr;
- char data[BOUND_MSG_LEN + sizeof(value)];
-} array_bound_error_msg = { 0, BOUND_MSG };
-
-void array_bound_error(void)
-{
- mlsize_t wosize = (BOUND_MSG_LEN + sizeof(value)) / sizeof(value);
- mlsize_t offset_index = Bsize_wsize(wosize) - 1;
- array_bound_error_msg.hdr = Make_header(wosize, String_tag, Caml_white);
- array_bound_error_msg.data[offset_index] = offset_index - BOUND_MSG_LEN;
- array_bound_error_bucket.hdr = Make_header(2, 0, Caml_white);
- array_bound_error_bucket.exn = (value) Invalid_argument;
- array_bound_error_bucket.arg = (value) array_bound_error_msg.data;
- mlraise((value) &array_bound_error_bucket.exn);
-}
diff --git a/asmrun/hppa.S b/asmrun/hppa.S
deleted file mode 100644
index 59daa91c73..0000000000
--- a/asmrun/hppa.S
+++ /dev/null
@@ -1,550 +0,0 @@
-;*********************************************************************
-;* *
-;* Objective Caml *
-;* *
-;* Xavier Leroy, projet Cristal, INRIA Rocquencourt *
-;* *
-;* Copyright 1996 Institut National de Recherche en Informatique et *
-;* en Automatique. All rights reserved. This file is distributed *
-;* under the terms of the GNU Library General Public License, with *
-;* the special exception on linking described in file ../LICENSE. *
-;* *
-;*********************************************************************
-
-; $Id$
-
-; Asm part of the runtime system for the HP PA-RISC processor.
-; Must be preprocessed by cpp
-
-#ifdef SYS_hpux
-#define G(x) x
-#define CODESPACE .code
-#define CODE_ALIGN 4
-#define EXPORT_CODE(x) .export x, entry, priv_lev=3
-#define EXPORT_DATA(x) .export x, data
-#define STARTPROC .proc ! .callinfo frame=0, no_calls ! .entry
-#define ENDPROC .exit ! .procend
-#define LOADHIGH(x) addil LR%x-$global$, %r27
-#define LOW(x) RR%x-$global$
-#define LOADHIGHLABEL(x) ldil LR%x, %r1
-#define LOWLABEL(x) RR%x
-#endif
-
-#ifdef SYS_nextstep
-#define G(x) _##x
-#define CODESPACE .text
-#define CODE_ALIGN 2
-#define EXPORT_CODE(x) .globl x
-#define EXPORT_DATA(x) .globl x
-#define STARTPROC
-#define ENDPROC
-#define LOADHIGH(x) ldil L`x, %r1
-#define LOW(x) R`x
-#define LOADHIGHLABEL(x) ldil L`x, %r1
-#define LOWLABEL(x) R`x
-#endif
-
-#ifdef SYS_hpux
- .space $PRIVATE$
- .subspa $DATA$,quad=1,align=8,access=31
- .subspa $BSS$,quad=1,align=8,access=31,zero,sort=82
- .space $TEXT$
- .subspa $LIT$,quad=0,align=8,access=44
- .subspa $CODE$,quad=0,align=8,access=44,code_only
- .import $global$, data
- .import $$dyncall, millicode
- .import garbage_collection, code
- .import caml_program, code
- .import mlraise, code
- .import caml_apply2, code
- .import caml_apply3, code
- .import array_bound_error, code
-
-young_limit .comm 8
-young_ptr .comm 8
-caml_bottom_of_stack .comm 8
-caml_last_return_address .comm 8
-caml_gc_regs .comm 8
-caml_exception_pointer .comm 8
-caml_required_size .comm 8
-#endif
-
-#ifdef SYS_nextstep
- .comm G(young_limit), 8
- .comm G(young_ptr), 8
- .comm G(caml_bottom_of_stack), 8
- .comm G(caml_last_return_address), 8
- .comm G(caml_gc_regs), 8
- .comm G(caml_exception_pointer), 8
- .comm G(caml_required_size), 8
-#endif
-
-; Allocation functions
-
- CODESPACE
- .align CODE_ALIGN
- EXPORT_CODE(G(caml_alloc))
-G(caml_alloc):
- STARTPROC
-; Required size in %r29
- ldw 0(%r4), %r1
- sub %r3, %r29, %r3
- comb,<<,n %r3, %r1, G(caml_call_gc) ; nullify if taken (forward br.)
- bv 0(%r2)
- nop
- ENDPROC
-
- EXPORT_CODE(G(caml_call_gc))
-G(caml_call_gc):
- STARTPROC
-; Save required size (%r29)
- LOADHIGH(G(caml_required_size))
- stw %r29, LOW(G(caml_required_size))(%r1)
-; Save current allocation pointer for debugging purposes
- LOADHIGH(G(young_ptr))
- stw %r3, LOW(G(young_ptr))(%r1)
-; Record lowest stack address
- LOADHIGH(G(caml_bottom_of_stack))
- stw %r30, LOW(G(caml_bottom_of_stack))(%r1)
-; Record return address
- LOADHIGH(G(caml_last_return_address))
- stw %r2, LOW(G(caml_last_return_address))(%r1)
-; Save the exception handler (if e.g. a sighandler raises)
- LOADHIGH(G(caml_exception_pointer))
- stw %r5, LOW(G(caml_exception_pointer))(%r1)
-; Reserve stack space
-; 0x1C0 = 4 * 32 (int regs) + 8 * 32 (float regs) + 64 (for calling C)
- ldo 0x1C0(%r30), %r30
-; Save caml_gc_regs
-L100: ldo -(64 + 4*32)(%r30), %r31
- LOADHIGH(G(caml_gc_regs))
- stw %r31, LOW(G(caml_gc_regs))(%r1)
-; Save all regs used by the code generator
- copy %r31, %r1
- stws,ma %r6, 4(%r1)
- stws,ma %r7, 4(%r1)
- stws,ma %r8, 4(%r1)
- stws,ma %r9, 4(%r1)
- stws,ma %r10, 4(%r1)
- stws,ma %r11, 4(%r1)
- stws,ma %r12, 4(%r1)
- stws,ma %r13, 4(%r1)
- stws,ma %r14, 4(%r1)
- stws,ma %r15, 4(%r1)
- stws,ma %r16, 4(%r1)
- stws,ma %r17, 4(%r1)
- stws,ma %r18, 4(%r1)
- stws,ma %r19, 4(%r1)
- stws,ma %r20, 4(%r1)
- stws,ma %r21, 4(%r1)
- stws,ma %r22, 4(%r1)
- stws,ma %r23, 4(%r1)
- stws,ma %r24, 4(%r1)
- stws,ma %r25, 4(%r1)
- stws,ma %r26, 4(%r1)
- stws,ma %r28, 4(%r1)
- ldo -0x1C0(%r30), %r1
- fstds,ma %fr4, 8(%r1)
- fstds,ma %fr5, 8(%r1)
- fstds,ma %fr6, 8(%r1)
- fstds,ma %fr7, 8(%r1)
- fstds,ma %fr8, 8(%r1)
- fstds,ma %fr9, 8(%r1)
- fstds,ma %fr10, 8(%r1)
- fstds,ma %fr11, 8(%r1)
- fstds,ma %fr12, 8(%r1)
- fstds,ma %fr13, 8(%r1)
- fstds,ma %fr14, 8(%r1)
- fstds,ma %fr15, 8(%r1)
- fstds,ma %fr16, 8(%r1)
- fstds,ma %fr17, 8(%r1)
- fstds,ma %fr18, 8(%r1)
- fstds,ma %fr19, 8(%r1)
- fstds,ma %fr20, 8(%r1)
- fstds,ma %fr21, 8(%r1)
- fstds,ma %fr22, 8(%r1)
- fstds,ma %fr23, 8(%r1)
- fstds,ma %fr24, 8(%r1)
- fstds,ma %fr25, 8(%r1)
- fstds,ma %fr26, 8(%r1)
- fstds,ma %fr27, 8(%r1)
- fstds,ma %fr28, 8(%r1)
- fstds,ma %fr29, 8(%r1)
- fstds,ma %fr30, 8(%r1)
-
-; Call the garbage collector
-#ifdef SYS_nextstep
- ldil L`G(garbage_collection), %r1
- ble R`G(garbage_collection)(4, %r1)
- copy %r31, %r2
-#else
- bl G(garbage_collection), %r2
- nop
-#endif
-
-; Restore all regs used by the code generator
- ldo -(64 + 4*32)(%r30), %r1
- ldws,ma 4(%r1), %r6
- ldws,ma 4(%r1), %r7
- ldws,ma 4(%r1), %r8
- ldws,ma 4(%r1), %r9
- ldws,ma 4(%r1), %r10
- ldws,ma 4(%r1), %r11
- ldws,ma 4(%r1), %r12
- ldws,ma 4(%r1), %r13
- ldws,ma 4(%r1), %r14
- ldws,ma 4(%r1), %r15
- ldws,ma 4(%r1), %r16
- ldws,ma 4(%r1), %r17
- ldws,ma 4(%r1), %r18
- ldws,ma 4(%r1), %r19
- ldws,ma 4(%r1), %r20
- ldws,ma 4(%r1), %r21
- ldws,ma 4(%r1), %r22
- ldws,ma 4(%r1), %r23
- ldws,ma 4(%r1), %r24
- ldws,ma 4(%r1), %r25
- ldws,ma 4(%r1), %r26
- ldws,ma 4(%r1), %r28
- ldo -0x1C0(%r30), %r1
- fldds,ma 8(%r1), %fr4
- fldds,ma 8(%r1), %fr5
- fldds,ma 8(%r1), %fr6
- fldds,ma 8(%r1), %fr7
- fldds,ma 8(%r1), %fr8
- fldds,ma 8(%r1), %fr9
- fldds,ma 8(%r1), %fr10
- fldds,ma 8(%r1), %fr11
- fldds,ma 8(%r1), %fr12
- fldds,ma 8(%r1), %fr13
- fldds,ma 8(%r1), %fr14
- fldds,ma 8(%r1), %fr15
- fldds,ma 8(%r1), %fr16
- fldds,ma 8(%r1), %fr17
- fldds,ma 8(%r1), %fr18
- fldds,ma 8(%r1), %fr19
- fldds,ma 8(%r1), %fr20
- fldds,ma 8(%r1), %fr21
- fldds,ma 8(%r1), %fr22
- fldds,ma 8(%r1), %fr23
- fldds,ma 8(%r1), %fr24
- fldds,ma 8(%r1), %fr25
- fldds,ma 8(%r1), %fr26
- fldds,ma 8(%r1), %fr27
- fldds,ma 8(%r1), %fr28
- fldds,ma 8(%r1), %fr29
- fldds,ma 8(%r1), %fr30
-
-; Reload the allocation pointer
- LOADHIGH(G(young_ptr))
- ldw LOW(G(young_ptr))(%r1), %r3
-; Allocate space for block
- LOADHIGH(G(caml_required_size))
- ldw LOW(G(caml_required_size))(%r1), %r29
- ldw 0(%r4), %r1
- sub %r3, %r29, %r3
- comb,<< %r3, %r1, L100
- nop
-; Return to caller
- LOADHIGH(G(caml_last_return_address))
- ldw LOW(G(caml_last_return_address))(%r1), %r2
- bv 0(%r2)
- ldo -0x1C0(%r30), %r30
- ENDPROC
-
-; Call a C function from Caml
-; Function to call is in %r22
-
- .align CODE_ALIGN
-#ifdef SYS_hpux
- .export G(caml_c_call), ENTRY, ARGW0=GR, ARGW1=GR, ARGW2=GR, ARGW3=GR
-#else
- EXPORT_CODE(G(caml_c_call))
-#endif
-G(caml_c_call):
- STARTPROC
-; Record lowest stack address
- LOADHIGH(G(caml_bottom_of_stack))
- stw %r30, LOW(G(caml_bottom_of_stack))(%r1)
-; Record return address
- LOADHIGH(G(caml_last_return_address))
- stw %r2, LOW(G(caml_last_return_address))(%r1)
-; Save the exception handler
- LOADHIGH(G(caml_exception_pointer))
- stw %r5, LOW(G(caml_exception_pointer))(%r1)
-; Save the allocation pointer
- LOADHIGH(G(young_ptr))
- stw %r3, LOW(G(young_ptr))(%r1)
-; Call the C function
-#ifdef SYS_hpux
- bl $$dyncall, %r31
-#else
- ble 0(4, %r22)
-#endif
- copy %r31, %r2 ; in delay slot
-; Reload return address
- LOADHIGH(G(caml_last_return_address))
- ldw LOW(G(caml_last_return_address))(%r1), %r2
-; Reload allocation pointer
- LOADHIGH(G(young_ptr))
-; Return to caller
- bv 0(%r2)
- ldw LOW(G(young_ptr))(%r1), %r3 ; in delay slot
- ENDPROC
-
-; Start the Caml program
-
- .align CODE_ALIGN
- EXPORT_CODE(G(caml_start_program))
-G(caml_start_program):
- STARTPROC
- LOADHIGH(G(caml_program))
- ldo LOW(G(caml_program))(%r1), %r22
-
-; Code shared with callback*
-L102:
-; Save return address
- stw %r2,-20(%r30)
- ldo 256(%r30), %r30
-; Save the callee-save registers
- ldo -32(%r30), %r1
- stws,ma %r3, -4(%r1)
- stws,ma %r4, -4(%r1)
- stws,ma %r5, -4(%r1)
- stws,ma %r6, -4(%r1)
- stws,ma %r7, -4(%r1)
- stws,ma %r8, -4(%r1)
- stws,ma %r9, -4(%r1)
- stws,ma %r10, -4(%r1)
- stws,ma %r11, -4(%r1)
- stws,ma %r12, -4(%r1)
- stws,ma %r13, -4(%r1)
- stws,ma %r14, -4(%r1)
- stws,ma %r15, -4(%r1)
- stws,ma %r16, -4(%r1)
- stws,ma %r17, -4(%r1)
- stws,ma %r18, -4(%r1)
- fstds,ma %fr12, -8(%r1)
- fstds,ma %fr13, -8(%r1)
- fstds,ma %fr14, -8(%r1)
- fstds,ma %fr15, -8(%r1)
- fstds,ma %fr16, -8(%r1)
- fstds,ma %fr17, -8(%r1)
- fstds,ma %fr18, -8(%r1)
- fstds,ma %fr19, -8(%r1)
- fstds,ma %fr20, -8(%r1)
- fstds,ma %fr21, -8(%r1)
- fstds,ma %fr22, -8(%r1)
- fstds,ma %fr23, -8(%r1)
- fstds,ma %fr24, -8(%r1)
- fstds,ma %fr25, -8(%r1)
- fstds,ma %fr26, -8(%r1)
- fstds,ma %fr27, -8(%r1)
- fstds,ma %fr28, -8(%r1)
- fstds,ma %fr29, -8(%r1)
- fstds,ma %fr30, -8(%r1)
- fstds,ma %fr31, -8(%r1)
-; Set up a callback link
- ldo 16(%r30), %r30
- LOADHIGH(G(caml_bottom_of_stack))
- ldw LOW(G(caml_bottom_of_stack))(%r1), %r1
- stw %r1, -16(%r30)
- LOADHIGH(G(caml_last_return_address))
- ldw LOW(G(caml_last_return_address))(%r1), %r1
- stw %r1, -12(%r30)
- LOADHIGH(G(caml_gc_regs))
- ldw LOW(G(caml_gc_regs))(%r1), %r1
- stw %r1, -8(%r30)
-; Set up a trap frame to catch exceptions escaping the Caml code
- ldo 8(%r30), %r30
- LOADHIGH(G(caml_exception_pointer))
- ldw LOW(G(caml_exception_pointer))(%r1), %r1
- stw %r1, -8(%r30)
- LOADHIGHLABEL(L103)
- ldo LOWLABEL(L103)(%r1), %r1
- stw %r1, -4(%r30)
- copy %r30, %r5
-; Reload allocation pointers
- LOADHIGH(G(young_ptr))
- ldw LOW(G(young_ptr))(%r1), %r3
- LOADHIGH(G(young_limit))
- ldo LOW(G(young_limit))(%r1), %r4
-; Call the Caml code
- ble 0(4, %r22)
- copy %r31, %r2
-L104:
-; Pop the trap frame
- ldw -8(%r30), %r31
- LOADHIGH(G(caml_exception_pointer))
- stw %r31, LOW(G(caml_exception_pointer))(%r1)
- ldo -8(%r30), %r30
-; Pop the callback link
-L105:
- ldw -16(%r30), %r31
- LOADHIGH(G(caml_bottom_of_stack))
- stw %r31, LOW(G(caml_bottom_of_stack))(%r1)
- ldw -12(%r30), %r31
- LOADHIGH(G(caml_last_return_address))
- stw %r31, LOW(G(caml_last_return_address))(%r1)
- ldw -8(%r30), %r31
- LOADHIGH(G(caml_gc_regs))
- stw %r31, LOW(G(caml_gc_regs))(%r1)
- ldo -16(%r30), %r30
-; Save allocation pointer
- LOADHIGH(G(young_ptr))
- stw %r3, LOW(G(young_ptr))(%r1)
-; Move result where C function expects it
- copy %r26, %r28
-; Reload callee-save registers
- ldo -32(%r30), %r1
- ldws,ma -4(%r1), %r3
- ldws,ma -4(%r1), %r4
- ldws,ma -4(%r1), %r5
- ldws,ma -4(%r1), %r6
- ldws,ma -4(%r1), %r7
- ldws,ma -4(%r1), %r8
- ldws,ma -4(%r1), %r9
- ldws,ma -4(%r1), %r10
- ldws,ma -4(%r1), %r11
- ldws,ma -4(%r1), %r12
- ldws,ma -4(%r1), %r13
- ldws,ma -4(%r1), %r14
- ldws,ma -4(%r1), %r15
- ldws,ma -4(%r1), %r16
- ldws,ma -4(%r1), %r17
- ldws,ma -4(%r1), %r18
- fldds,ma -8(%r1), %fr12
- fldds,ma -8(%r1), %fr13
- fldds,ma -8(%r1), %fr14
- fldds,ma -8(%r1), %fr15
- fldds,ma -8(%r1), %fr16
- fldds,ma -8(%r1), %fr17
- fldds,ma -8(%r1), %fr18
- fldds,ma -8(%r1), %fr19
- fldds,ma -8(%r1), %fr20
- fldds,ma -8(%r1), %fr21
- fldds,ma -8(%r1), %fr22
- fldds,ma -8(%r1), %fr23
- fldds,ma -8(%r1), %fr24
- fldds,ma -8(%r1), %fr25
- fldds,ma -8(%r1), %fr26
- fldds,ma -8(%r1), %fr27
- fldds,ma -8(%r1), %fr28
- fldds,ma -8(%r1), %fr29
- fldds,ma -8(%r1), %fr30
- fldds,ma -8(%r1), %fr31
-; Return to C
- ldo -256(%r30), %r30
- ldw -20(%r30), %r2
- bv 0(%r2)
- nop
-; The trap handler
-L103:
-; Save exception pointer
- LOADHIGH(G(caml_exception_pointer))
- stw %r5, LOW(G(caml_exception_pointer))(%r1)
-; Encode exception bucket as an exception result and return it
- ldi 2, %r1
- or %r26, %r1, %r26
-; Return it
- b L105
- nop
-
-; Re-raise the exception through mlraise, to clean up local C roots
- ldo 64(%r30), %r30
-#ifdef SYS_nextstep
- ldil L`G(mlraise), %r1
- ble R`G(mlraise)(4, %r1)
- copy %r31, %r2
-#else
- bl G(mlraise), %r2
- nop
-#endif
- ENDPROC
-
-; Raise an exception from C
-
- .align CODE_ALIGN
- EXPORT_CODE(G(raise_caml_exception))
-G(raise_caml_exception):
- STARTPROC
-; Cut the stack
- LOADHIGH(G(caml_exception_pointer))
- ldw LOW(G(caml_exception_pointer))(%r1), %r30
-; Reload allocation registers
- LOADHIGH(G(young_ptr))
- ldw LOW(G(young_ptr))(%r1), %r3
- LOADHIGH(G(young_limit))
- ldo LOW(G(young_limit))(%r1), %r4
-; Raise the exception
- ldw -4(%r30), %r1
- ldw -8(%r30), %r5
- bv 0(%r1)
- ldo -8(%r30), %r30 ; in delay slot
- ENDPROC
-
-; Callbacks C -> ML
-
- .align CODE_ALIGN
- EXPORT_CODE(G(callback_exn))
-G(callback_exn):
- STARTPROC
-; Initial shuffling of arguments
- copy %r26, %r1 ; Closure
- copy %r25, %r26 ; Argument
- copy %r1, %r25
- b L102
- ldw 0(%r1), %r22 ; Code to call (in delay slot)
- ENDPROC
-
- .align CODE_ALIGN
- EXPORT_CODE(G(callback2_exn))
-G(callback2_exn):
- STARTPROC
- copy %r26, %r1 ; Closure
- copy %r25, %r26 ; First argument
- copy %r24, %r25 ; Second argument
- copy %r1, %r24
- LOADHIGH(G(caml_apply2))
- b L102
- ldo LOW(G(caml_apply2))(%r1), %r22
- ENDPROC
-
- .align CODE_ALIGN
- EXPORT_CODE(G(callback3_exn))
-G(callback3_exn):
- STARTPROC
- copy %r26, %r1 ; Closure
- copy %r25, %r26 ; First argument
- copy %r24, %r25 ; Second argument
- copy %r23, %r24 ; Third argument
- copy %r1, %r23
- LOADHIGH(G(caml_apply3))
- b L102
- ldo LOW(G(caml_apply3))(%r1), %r22
- ENDPROC
-
- .align CODE_ALIGN
- EXPORT_CODE(G(caml_array_bound_error))
-G(caml_array_bound_error):
- STARTPROC
-; Load address of array_bound_error in %r22
-#ifdef SYS_hpux
- ldil LR%array_bound_error, %r22
- ldo RR%array_bound_error(%r22), %r22
-#else
- ldil L`_array_bound_error, %r22
- ldo R`_array_bound_error(%r22), %r22
-#endif
-; Reserve 48 bytes of stack space and jump to caml_c_call
- b G(caml_c_call)
- ldo 48(%r30), %r30 /* in delay slot */
- ENDPROC
-
- .data
- EXPORT_DATA(G(system__frametable))
-G(system__frametable):
- .long 1 /* one descriptor */
- .long L104 + 3 /* return address into callback */
- .short -1 /* negative frame size => use callback link */
- .short 0 /* no roots */
diff --git a/asmrun/i386.S b/asmrun/i386.S
deleted file mode 100644
index f89ed37425..0000000000
--- a/asmrun/i386.S
+++ /dev/null
@@ -1,326 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Asm part of the runtime system, Intel 386 processor */
-/* Must be preprocessed by cpp */
-
-/* Linux/BSD with ELF binaries and Solaris do not prefix identifiers with _.
- Linux/BSD with a.out binaries and NextStep do. */
-
-#if defined(SYS_solaris)
-#define CONCAT(a,b) a/**/b
-#else
-#define CONCAT(a,b) a##b
-#endif
-
-#if defined(SYS_linux_elf) || defined(SYS_bsd_elf) \
- || defined(SYS_solaris) || defined(SYS_beos)
-#define G(x) x
-#define LBL(x) CONCAT(.L,x)
-#else
-#define G(x) CONCAT(_,x)
-#define LBL(x) CONCAT(L,x)
-#endif
-
-#if defined(SYS_linux_elf) || defined(SYS_bsd_elf) \
- || defined(SYS_solaris) || defined(SYS_beos) || defined(SYS_cygwin) \
- || defined(SYS_mingw)
-#define FUNCTION_ALIGN 4
-#else
-#define FUNCTION_ALIGN 2
-#endif
-
-#if defined(PROFILING)
-#if defined(SYS_linux_elf)
-#define PROFILE_CAML \
- pushl %ebp; movl %esp, %ebp; pushl %eax; pushl %ecx; pushl %edx; \
- call mcount; \
- popl %edx; popl %ecx; popl %eax; popl %ebp
-#define PROFILE_C \
- pushl %ebp; movl %esp, %ebp; call mcount; popl %ebp
-#elif defined(SYS_bsd_elf)
-#define PROFILE_CAML \
- pushl %ebp; movl %esp, %ebp; pushl %eax; pushl %ecx; pushl %edx; \
- call .mcount; \
- popl %edx; popl %ecx; popl %eax; popl %ebp
-#define PROFILE_C \
- pushl %ebp; movl %esp, %ebp; call .mcount; popl %ebp
-#endif
-#else
-#define PROFILE_CAML
-#define PROFILE_C
-#endif
-
-/* Allocation */
-
- .text
- .globl G(caml_call_gc)
- .globl G(caml_alloc1)
- .globl G(caml_alloc2)
- .globl G(caml_alloc3)
- .globl G(caml_alloc)
-
-G(caml_call_gc):
- PROFILE_CAML
- /* Record lowest stack address and return address */
- movl 0(%esp), %eax
- movl %eax, G(caml_last_return_address)
- leal 4(%esp), %eax
- movl %eax, G(caml_bottom_of_stack)
- /* Build array of registers, save it into caml_gc_regs */
-LBL(105):
- pushl %ebp
- pushl %edi
- pushl %esi
- pushl %edx
- pushl %ecx
- pushl %ebx
- pushl %eax
- movl %esp, G(caml_gc_regs)
- /* Call the garbage collector */
- call G(garbage_collection)
- /* Restore all regs used by the code generator */
- popl %eax
- popl %ebx
- popl %ecx
- popl %edx
- popl %esi
- popl %edi
- popl %ebp
- /* Return to caller */
- ret
-
- .align FUNCTION_ALIGN
-G(caml_alloc1):
- PROFILE_CAML
- movl G(young_ptr), %eax
- subl $8, %eax
- movl %eax, G(young_ptr)
- cmpl G(young_limit), %eax
- jb LBL(100)
- ret
-LBL(100):
- movl 0(%esp), %eax
- movl %eax, G(caml_last_return_address)
- leal 4(%esp), %eax
- movl %eax, G(caml_bottom_of_stack)
- call LBL(105)
- jmp G(caml_alloc1)
-
- .align FUNCTION_ALIGN
-G(caml_alloc2):
- PROFILE_CAML
- movl G(young_ptr), %eax
- subl $12, %eax
- movl %eax, G(young_ptr)
- cmpl G(young_limit), %eax
- jb LBL(101)
- ret
-LBL(101):
- movl 0(%esp), %eax
- movl %eax, G(caml_last_return_address)
- leal 4(%esp), %eax
- movl %eax, G(caml_bottom_of_stack)
- call LBL(105)
- jmp G(caml_alloc2)
-
- .align FUNCTION_ALIGN
-G(caml_alloc3):
- PROFILE_CAML
- movl G(young_ptr), %eax
- subl $16, %eax
- movl %eax, G(young_ptr)
- cmpl G(young_limit), %eax
- jb LBL(102)
- ret
-LBL(102):
- movl 0(%esp), %eax
- movl %eax, G(caml_last_return_address)
- leal 4(%esp), %eax
- movl %eax, G(caml_bottom_of_stack)
- call LBL(105)
- jmp G(caml_alloc3)
-
- .align FUNCTION_ALIGN
-G(caml_alloc):
- PROFILE_CAML
- subl G(young_ptr), %eax /* eax = size - young_ptr */
- negl %eax /* eax = young_ptr - size */
- cmpl G(young_limit), %eax
- jb LBL(103)
- movl %eax, G(young_ptr)
- ret
-LBL(103):
- subl G(young_ptr), %eax /* eax = - size */
- negl %eax /* eax = size */
- pushl %eax /* save desired size */
- subl %eax, G(young_ptr) /* must update young_ptr */
- movl 4(%esp), %eax
- movl %eax, G(caml_last_return_address)
- leal 8(%esp), %eax
- movl %eax, G(caml_bottom_of_stack)
- call LBL(105)
- popl %eax /* recover desired size */
- jmp G(caml_alloc)
-
-/* Call a C function from Caml */
-
- .globl G(caml_c_call)
- .align FUNCTION_ALIGN
-G(caml_c_call):
- PROFILE_CAML
- /* Record lowest stack address and return address */
- movl (%esp), %edx
- movl %edx, G(caml_last_return_address)
- leal 4(%esp), %edx
- movl %edx, G(caml_bottom_of_stack)
- /* Call the function (address in %eax) */
- jmp *%eax
-
-/* Start the Caml program */
-
- .globl G(caml_start_program)
- .align FUNCTION_ALIGN
-G(caml_start_program):
- PROFILE_C
- /* Save callee-save registers */
- pushl %ebx
- pushl %esi
- pushl %edi
- pushl %ebp
- /* Initial entry point is caml_program */
- movl $ G(caml_program), %esi
- /* Common code for caml_start_program and callback* */
-LBL(106):
- /* Build a callback link */
- pushl G(caml_gc_regs)
- pushl G(caml_last_return_address)
- pushl G(caml_bottom_of_stack)
- /* Build an exception handler */
- pushl $ LBL(108)
- pushl G(caml_exception_pointer)
- movl %esp, G(caml_exception_pointer)
- /* Call the Caml code */
- call *%esi
-LBL(107):
- /* Pop the exception handler */
- popl G(caml_exception_pointer)
- popl %esi /* dummy register */
-LBL(109):
- /* Pop the callback link, restoring the global variables */
- popl G(caml_bottom_of_stack)
- popl G(caml_last_return_address)
- popl G(caml_gc_regs)
- /* Restore callee-save registers. */
- popl %ebp
- popl %edi
- popl %esi
- popl %ebx
- /* Return to caller. */
- ret
-LBL(108):
- /* Exception handler*/
- /* Mark the bucket as an exception result and return it */
- orl $2, %eax
- jmp LBL(109)
-
-/* Raise an exception from C */
-
- .globl G(raise_caml_exception)
- .align FUNCTION_ALIGN
-G(raise_caml_exception):
- PROFILE_C
- movl 4(%esp), %eax
- movl G(caml_exception_pointer), %esp
- popl G(caml_exception_pointer)
- ret
-
-/* Callback from C to Caml */
-
- .globl G(callback_exn)
- .align FUNCTION_ALIGN
-G(callback_exn):
- PROFILE_C
- /* Save callee-save registers */
- pushl %ebx
- pushl %esi
- pushl %edi
- pushl %ebp
- /* Initial loading of arguments */
- movl 20(%esp), %ebx /* closure */
- movl 24(%esp), %eax /* argument */
- movl 0(%ebx), %esi /* code pointer */
- jmp LBL(106)
-
- .globl G(callback2_exn)
- .align FUNCTION_ALIGN
-G(callback2_exn):
- PROFILE_C
- /* Save callee-save registers */
- pushl %ebx
- pushl %esi
- pushl %edi
- pushl %ebp
- /* Initial loading of arguments */
- movl 20(%esp), %ecx /* closure */
- movl 24(%esp), %eax /* first argument */
- movl 28(%esp), %ebx /* second argument */
- movl $ G(caml_apply2), %esi /* code pointer */
- jmp LBL(106)
-
- .globl G(callback3_exn)
- .align FUNCTION_ALIGN
-G(callback3_exn):
- PROFILE_C
- /* Save callee-save registers */
- pushl %ebx
- pushl %esi
- pushl %edi
- pushl %ebp
- /* Initial loading of arguments */
- movl 20(%esp), %edx /* closure */
- movl 24(%esp), %eax /* first argument */
- movl 28(%esp), %ebx /* second argument */
- movl 32(%esp), %ecx /* third argument */
- movl $ G(caml_apply3), %esi /* code pointer */
- jmp LBL(106)
-
- .globl G(caml_array_bound_error)
- .align FUNCTION_ALIGN
-G(caml_array_bound_error):
- /* Empty the floating-point stack */
- ffree %st(0)
- ffree %st(1)
- ffree %st(2)
- ffree %st(3)
- ffree %st(4)
- ffree %st(5)
- ffree %st(6)
- ffree %st(7)
- /* Branch to array_bound_error */
- jmp G(array_bound_error)
-
- .data
- .globl G(system__frametable)
-G(system__frametable):
- .long 1 /* one descriptor */
- .long LBL(107) /* return address into callback */
-#ifndef SYS_solaris
- .word -1 /* negative frame size => use callback link */
- .word 0 /* no roots here */
-#else
- .value -1 /* negative frame size => use callback link */
- .value 0 /* no roots here */
-#endif
diff --git a/asmrun/i386nt.asm b/asmrun/i386nt.asm
deleted file mode 100644
index 9ef28aeffc..0000000000
--- a/asmrun/i386nt.asm
+++ /dev/null
@@ -1,278 +0,0 @@
-;*********************************************************************
-;
-; Objective Caml
-;
-; Xavier Leroy, projet Cristal, INRIA Rocquencourt
-;
-; Copyright 1996 Institut National de Recherche en Informatique et
-; en Automatique. All rights reserved. This file is distributed
-; under the terms of the GNU Library General Public License, with
-; the special exception on linking described in file ../LICENSE.
-;
-;*********************************************************************
-
-; $Id$
-
-; Asm part of the runtime system, Intel 386 processor, Intel syntax
-
- .386
- .MODEL FLAT
-
- EXTERN _garbage_collection: PROC
- EXTERN _mlraise: PROC
- EXTERN _caml_apply2: PROC
- EXTERN _caml_apply3: PROC
- EXTERN _caml_program: PROC
- EXTERN _array_bound_error: PROC
- EXTERN _young_limit: DWORD
- EXTERN _young_ptr: DWORD
- EXTERN _caml_bottom_of_stack: DWORD
- EXTERN _caml_last_return_address: DWORD
- EXTERN _caml_gc_regs: DWORD
- EXTERN _caml_exception_pointer: DWORD
-
-; Allocation
-
- .CODE
- PUBLIC _caml_alloc1
- PUBLIC _caml_alloc2
- PUBLIC _caml_alloc3
- PUBLIC _caml_alloc
- PUBLIC _caml_call_gc
-
-_caml_call_gc:
- ; Record lowest stack address and return address
- mov eax, [esp]
- mov _caml_last_return_address, eax
- lea eax, [esp+4]
- mov _caml_bottom_of_stack, eax
- ; Save all regs used by the code generator
-L105: push ebp
- push edi
- push esi
- push edx
- push ecx
- push ebx
- push eax
- mov _caml_gc_regs, esp
- ; Call the garbage collector
- call _garbage_collection
- ; Restore all regs used by the code generator
- pop eax
- pop ebx
- pop ecx
- pop edx
- pop esi
- pop edi
- pop ebp
- ; Return to caller
- ret
-
- ALIGN 4
-_caml_alloc1:
- mov eax, _young_ptr
- sub eax, 8
- mov _young_ptr, eax
- cmp eax, _young_limit
- jb L100
- ret
-L100: mov eax, [esp]
- mov _caml_last_return_address, eax
- lea eax, [esp+4]
- mov _caml_bottom_of_stack, eax
- call L105
- jmp _caml_alloc1
-
- ALIGN 4
-_caml_alloc2:
- mov eax, _young_ptr
- sub eax, 12
- mov _young_ptr, eax
- cmp eax, _young_limit
- jb L101
- ret
-L101: mov eax, [esp]
- mov _caml_last_return_address, eax
- lea eax, [esp+4]
- mov _caml_bottom_of_stack, eax
- call L105
- jmp _caml_alloc2
-
- ALIGN 4
-_caml_alloc3:
- mov eax, _young_ptr
- sub eax, 16
- mov _young_ptr, eax
- cmp eax, _young_limit
- jb L102
- ret
-L102: mov eax, [esp]
- mov _caml_last_return_address, eax
- lea eax, [esp+4]
- mov _caml_bottom_of_stack, eax
- call L105
- jmp _caml_alloc3
-
- ALIGN 4
-_caml_alloc:
- sub eax, _young_ptr ; eax = size - young_ptr
- neg eax ; eax = young_ptr - size
- cmp eax, _young_limit
- jb L103
- mov _young_ptr, eax
- ret
-L103: sub eax, _young_ptr ; eax = - size
- neg eax ; eax = size
- push eax ; save desired size
- sub _young_ptr, eax ; must update young_ptr
- mov eax, [esp+4]
- mov _caml_last_return_address, eax
- lea eax, [esp+8]
- mov _caml_bottom_of_stack, eax
- call L105
- pop eax ; recover desired size
- jmp _caml_alloc
-
-; Call a C function from Caml
-
- PUBLIC _caml_c_call
- ALIGN 4
-_caml_c_call:
- ; Record lowest stack address and return address
- mov edx, [esp]
- mov _caml_last_return_address, edx
- lea edx, [esp+4]
- mov _caml_bottom_of_stack, edx
- ; Call the function (address in %eax)
- jmp eax
-
-; Start the Caml program
-
- PUBLIC _caml_start_program
- ALIGN 4
-_caml_start_program:
- ; Save callee-save registers
- push ebx
- push esi
- push edi
- push ebp
- ; Initial code pointer is caml_program
- mov esi, offset _caml_program
-
-; Code shared between caml_start_program and callback*
-
-L106:
- ; Build a callback link
- push _caml_gc_regs
- push _caml_last_return_address
- push _caml_bottom_of_stack
- ; Build an exception handler
- push L108
- push _caml_exception_pointer
- mov _caml_exception_pointer, esp
- ; Call the Caml code
- call esi
-L107:
- ; Pop the exception handler
- pop _caml_exception_pointer
- pop esi ; dummy register
-L109:
- ; Pop the callback link, restoring the global variables
- ; used by caml_c_call
- pop _caml_bottom_of_stack
- pop _caml_last_return_address
- pop _caml_gc_regs
- ; Restore callee-save registers.
- pop ebp
- pop edi
- pop esi
- pop ebx
- ; Return to caller.
- ret
-L108:
- ; Exception handler
- ; Mark the bucket as an exception result and return it
- or eax, 2
- jmp L109
-
-; Raise an exception from C
-
- PUBLIC _raise_caml_exception
- ALIGN 4
-_raise_caml_exception:
- mov eax, [esp+4]
- mov esp, _caml_exception_pointer
- pop _caml_exception_pointer
- ret
-
-; Callback from C to Caml
-
- PUBLIC _callback_exn
- ALIGN 4
-_callback_exn:
- ; Save callee-save registers
- push ebx
- push esi
- push edi
- push ebp
- ; Initial loading of arguments
- mov ebx, [esp+20] ; closure
- mov eax, [esp+24] ; argument
- mov esi, [ebx] ; code pointer
- jmp L106
-
- PUBLIC _callback2_exn
- ALIGN 4
-_callback2_exn:
- ; Save callee-save registers
- push ebx
- push esi
- push edi
- push ebp
- ; Initial loading of arguments
- mov ecx, [esp+20] ; closure
- mov eax, [esp+24] ; first argument
- mov ebx, [esp+28] ; second argument
- mov esi, offset _caml_apply2 ; code pointer
- jmp L106
-
- PUBLIC _callback3_exn
- ALIGN 4
-_callback3_exn:
- ; Save callee-save registers
- push ebx
- push esi
- push edi
- push ebp
- ; Initial loading of arguments
- mov edx, [esp+20] ; closure
- mov eax, [esp+24] ; first argument
- mov ebx, [esp+28] ; second argument
- mov ecx, [esp+32] ; third argument
- mov esi, offset _caml_apply3 ; code pointer
- jmp L106
-
- PUBLIC _caml_array_bound_error
- ALIGN 4
-_caml_array_bound_error:
- ; Empty the floating-point stack
- ffree st(0)
- ffree st(1)
- ffree st(2)
- ffree st(3)
- ffree st(4)
- ffree st(5)
- ffree st(6)
- ffree st(7)
- ; Branch to array_bound_error
- jmp _array_bound_error
-
- .DATA
- PUBLIC _system__frametable
-_system__frametable LABEL DWORD
- DWORD 1 ; one descriptor
- DWORD L107 ; return address into callback
- WORD -1 ; negative frame size => use callback link
- WORD 0 ; no roots here
-
- END
diff --git a/asmrun/ia64.S b/asmrun/ia64.S
deleted file mode 100644
index 66e1620a92..0000000000
--- a/asmrun/ia64.S
+++ /dev/null
@@ -1,530 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Asm part of the runtime system, Alpha processor */
-
-#undef BROKEN_POSTINCREMENT
-
-#define ADDRGLOBAL(reg,symb) \
- add reg = @ltoff(symb), gp;; ld8 reg = [reg]
-#define LOADGLOBAL(reg,symb) \
- add r3 = @ltoff(symb), gp;; ld8 r3 = [r3];; ld8 reg = [r3]
-#define STOREGLOBAL(reg,symb) \
- add r3 = @ltoff(symb), gp;; ld8 r3 = [r3];; st8 [r3] = reg
-
-#define ST8OFF(a,b,d) st8 [a] = b, d
-#define LD8OFF(a,b,d) ld8 a = [b], d
-#define STFDOFF(a,b,d) stfd [a] = b, d
-#define LDFDOFF(a,b,d) ldfd a = [b], d
-#define STFSPILLOFF(a,b,d) stf.spill [a] = b, d
-#define LDFFILLOFF(a,b,d) ldf.fill a = [b], d
-
-#define SAVE2(a,b) ST8OFF(r2, a, 16); ST8OFF(r3, b, 16)
-#define SAVE4(a,b,c,d) SAVE2(a,b);; SAVE2(c,d)
-#define SAVE8(a,b,c,d,e,f,g,h) SAVE4(a,b,c,d);; SAVE4(e,f,g,h)
-
-#define LOAD2(a,b) LD8OFF(a, r2, 16); LD8OFF(b, r3, 16)
-#define LOAD4(a,b,c,d) LOAD2(a,b);; LOAD2(c,d)
-#define LOAD8(a,b,c,d,e,f,g,h) LOAD4(a,b,c,d);; LOAD4(e,f,g,h)
-
-#define FSAVE2(a,b) STFDOFF(r2, a, 16); STFDOFF(r3, b, 16)
-#define FSAVE4(a,b,c,d) FSAVE2(a,b);; FSAVE2(c,d)
-#define FSAVE8(a,b,c,d,e,f,g,h) FSAVE4(a,b,c,d);; FSAVE4(e,f,g,h)
-
-#define FLOAD2(a,b) LDFDOFF(a, r2, 16); LDFDOFF(b, r3, 16)
-#define FLOAD4(a,b,c,d) FLOAD2(a,b);; FLOAD2(c,d)
-#define FLOAD8(a,b,c,d,e,f,g,h) FLOAD4(a,b,c,d);; FLOAD4(e,f,g,h)
-
-#define FSPILL2(a,b) STFSPILLOFF(r2, a, 32); STFSPILLOFF(r3, b, 32)
-#define FSPILL4(a,b,c,d) FSPILL2(a,b);; FSPILL2(c,d)
-#define FSPILL8(a,b,c,d,e,f,g,h) FSPILL4(a,b,c,d);; FSPILL4(e,f,g,h)
-
-#define FFILL2(a,b) LDFFILLOFF(a, r2, 32); LDFFILLOFF(b, r3, 32)
-#define FFILL4(a,b,c,d) FFILL2(a,b);; FFILL2(c,d)
-#define FFILL8(a,b,c,d,e,f,g,h) FFILL4(a,b,c,d);; FFILL4(e,f,g,h)
-
-/* Allocation */
- .text
-
- .global caml_alloc#
- .proc caml_alloc#
- .align 16
-
-/* caml_alloc: all code generator registers preserved,
- gp preserved, r2 = requested size */
-
-caml_alloc:
- sub r4 = r4, r2 ;;
- cmp.ltu p0, p6 = r4, r5
- (p6) br.ret.sptk b0 ;;
- /* Stash return address at sp (in stack scratch area) */
- mov r3 = b0 ;;
- st8 [sp] = r3
- /* Call GC */
- br.call.sptk b0 = caml_call_gc# ;;
- /* Return to caller */
- ld8 r3 = [sp] ;;
- mov b0 = r3 ;;
- br.ret.sptk b0
-
- .endp caml_alloc#
-
-/* caml_call_gc: all code generator registers preserved,
- gp preserved, r2 = requested size */
-
- .global caml_call_gc#
- .proc caml_call_gc#
- .align 16
-caml_call_gc:
- /* Allocate stack frame */
- add sp = -(16 + 16 + 80*8 + 42*8), sp ;;
-
- /* Save requested size and GP on stack */
- add r3 = 16, sp ;;
- ST8OFF(r3, r2, 8) ;;
- st8 [r3] = gp
-
- /* Record lowest stack address, return address, GC regs */
- mov r2 = b0 ;;
- STOREGLOBAL(r2, caml_last_return_address#)
- add r2 = (16 + 16 + 80*8 + 42*8), sp ;;
- STOREGLOBAL(r2, caml_bottom_of_stack#)
- add r2 = (16 + 16), sp ;;
- STOREGLOBAL(r2, caml_gc_regs#)
-
- /* Save all integer regs used by the code generator in the context */
-.L100: add r3 = 8, r2 ;;
- SAVE4(r8,r9,r10,r11) ;;
- SAVE8(r16,r17,r18,r19,r20,r21,r22,r23) ;;
- SAVE8(r24,r25,r26,r27,r28,r29,r30,r31) ;;
- SAVE8(r32,r33,r34,r35,r36,r37,r38,r39) ;;
- SAVE8(r40,r41,r42,r43,r44,r45,r46,r47) ;;
- SAVE8(r48,r49,r50,r51,r52,r53,r54,r55) ;;
- SAVE8(r56,r57,r58,r59,r60,r61,r62,r63) ;;
- SAVE8(r64,r65,r66,r67,r68,r69,r70,r71) ;;
- SAVE8(r72,r73,r74,r75,r76,r77,r78,r79) ;;
- SAVE8(r80,r81,r82,r83,r84,r85,r86,r87) ;;
- SAVE4(r88,r89,r90,r91) ;;
-
- /* Save all floating-point registers not preserved by C */
- FSAVE2(f6,f7) ;;
- FSAVE8(f8,f9,f10,f11,f12,f13,f14,f15) ;;
- FSAVE8(f32,f33,f34,f35,f36,f37,f38,f39) ;;
- FSAVE8(f40,f41,f42,f43,f44,f45,f46,f47) ;;
- FSAVE8(f48,f49,f50,f51,f52,f53,f54,f55) ;;
- FSAVE8(f56,f57,f58,f59,f60,f61,f62,f63) ;;
-
- /* Save current allocation pointer for debugging purposes */
- STOREGLOBAL(r4, young_ptr#)
-
- /* Save trap pointer in case an exception is raised */
- STOREGLOBAL(r6, caml_exception_pointer#)
-
- /* Call the garbage collector */
- br.call.sptk b0 = garbage_collection# ;;
-
- /* Restore gp */
- add r3 = 24, sp ;;
- ld8 gp = [r3]
-
- /* Restore all integer regs from GC context */
- add r2 = (16 + 16), sp ;;
- add r3 = 8, r2 ;;
- LOAD4(r8,r9,r10,r11) ;;
- LOAD8(r16,r17,r18,r19,r20,r21,r22,r23) ;;
- LOAD8(r24,r25,r26,r27,r28,r29,r30,r31) ;;
- LOAD8(r32,r33,r34,r35,r36,r37,r38,r39) ;;
- LOAD8(r40,r41,r42,r43,r44,r45,r46,r47) ;;
- LOAD8(r48,r49,r50,r51,r52,r53,r54,r55) ;;
- LOAD8(r56,r57,r58,r59,r60,r61,r62,r63) ;;
- LOAD8(r64,r65,r66,r67,r68,r69,r70,r71) ;;
- LOAD8(r72,r73,r74,r75,r76,r77,r78,r79) ;;
- LOAD8(r80,r81,r82,r83,r84,r85,r86,r87) ;;
- LOAD4(r88,r89,r90,r91) ;;
-
- /* Restore all floating-point registers not preserved by C */
- FLOAD2(f6,f7) ;;
- FLOAD8(f8,f9,f10,f11,f12,f13,f14,f15) ;;
- FLOAD8(f32,f33,f34,f35,f36,f37,f38,f39) ;;
- FLOAD8(f40,f41,f42,f43,f44,f45,f46,f47) ;;
- FLOAD8(f48,f49,f50,f51,f52,f53,f54,f55) ;;
- FLOAD8(f56,f57,f58,f59,f60,f61,f62,f63) ;;
-
- /* Reload new allocation pointer and allocation limit */
- LOADGLOBAL(r4, young_ptr#)
- LOADGLOBAL(r5, young_limit#)
-
- /* Allocate space for the block */
- add r3 = 16, sp ;;
- ld8 r2 = [r3] ;;
- sub r4 = r4, r2 ;;
- cmp.ltu p6, p0 = r4, r5 /* enough space? */
- (p6) br.cond.spnt .L100 ;; /* no: call GC again */
-
- /* Reload return address and say that we are back into Caml code */
- ADDRGLOBAL(r3, caml_last_return_address#) ;;
- ld8 r2 = [r3]
- st8 [r3] = r0 ;;
-
- /* Return to caller */
- mov b0 = r2
- add sp = (16 + 16 + 80*8 + 42*8), sp ;;
- br.ret.sptk b0
-
- .endp caml_call_gc#
-
-/* Call a C function from Caml */
-/* Function to call is in r2 */
-
- .global caml_c_call#
- .proc caml_c_call#
- .align 16
-
-caml_c_call:
- /* The Caml code that called us does not expect any
- code-generator registers to be preserved */
-
- /* Recover entry point from the function pointer in r2 */
- LD8OFF(r3, r2, 8) ;;
- mov b6 = r3
-
- /* Preserve gp in r7 */
- mov r7 = gp
-
- /* Record lowest stack address and return address */
- mov r14 = b0
- STOREGLOBAL(sp, caml_bottom_of_stack#) ;;
- STOREGLOBAL(r14, caml_last_return_address#)
-
- /* Make the exception handler and alloc ptr available to the C code */
- STOREGLOBAL(r4, young_ptr#)
- STOREGLOBAL(r6, caml_exception_pointer#)
-
- /* Recover gp from the function pointer in r2 */
- ld8 gp = [r2]
-
- /* Call the function */
- br.call.sptk b0 = b6 ;;
-
- /* Restore gp */
- mov gp = r7 ;;
-
- /* Reload alloc ptr and alloc limit */
- LOADGLOBAL(r4, young_ptr#)
- LOADGLOBAL(r5, young_limit#)
-
- /* Reload return address and say that we are back into Caml code */
- ADDRGLOBAL(r3, caml_last_return_address#) ;;
- ld8 r2 = [r3]
- st8 [r3] = r0 ;;
-
- /* Return to caller */
- mov b0 = r2 ;;
- br.ret.sptk b0
-
- .endp caml_c_call#
-
-/* Start the Caml program */
-
- .global caml_start_program#
- .proc caml_start_program#
- .align 16
-
-caml_start_program:
- ADDRGLOBAL(r2, caml_program#) ;;
- mov b6 = r2
-
- /* Code shared with callback* */
-.L103:
- /* Allocate 64 "out" registers (for the Caml code) and no locals */
- alloc r3 = ar.pfs, 0, 0, 64, 0
- add sp = -(56 * 8), sp ;;
-
- /* Save all callee-save registers on stack */
- add r2 = 16, sp ;;
- ST8OFF(r2, r3, 8) /* 0 : ar.pfs */
- mov r3 = b0 ;;
- ST8OFF(r2, r3, 8) ;; /* 1 : return address */
- ST8OFF(r2, gp, 8) /* 2 : gp */
- mov r3 = pr ;;
- ST8OFF(r2, r3, 8) /* 3 : predicates */
- mov r3 = ar.fpsr ;;
- ST8OFF(r2, r3, 8) /* 4 : ar.fpsr */
- mov r3 = ar.unat ;;
- ST8OFF(r2, r3, 8) /* 5 : ar.unat */
- mov r3 = ar.lc ;;
- ST8OFF(r2, r3, 8) /* 6 : ar.lc */
- mov r3 = b1 ;;
- ST8OFF(r2, r3, 8) /* 7 - 11 : b1 - b5 */
- mov r3 = b2 ;;
- ST8OFF(r2, r3, 8)
- mov r3 = b3 ;;
- ST8OFF(r2, r3, 8)
- mov r3 = b4 ;;
- ST8OFF(r2, r3, 8)
- mov r3 = b5 ;;
- ST8OFF(r2, r3, 8) ;;
-
- add r3 = 8, r2 ;;
- SAVE4(r4,r5,r6,r7) ;; /* 12 - 15 : r4 - r7 */
-
- add r3 = 16, r2 ;; /* 16 - 55 : f2 - f5, f16 - f31 */
- FSPILL4(f2,f3,f4,f5) ;;
- FSPILL8(f16,f17,f18,f19,f20,f21,f22,f23) ;;
- FSPILL8(f24,f25,f26,f27,f28,f29,f30,f31) ;;
-
- /* Set up a callback link on the stack. In addition to
- the normal callback link contents (saved values of
- caml_bottom_of_stack, caml_last_return_address and
- caml_gc_regs), we also save there caml_saved_bsp
- and caml_saved_rnat */
- add sp = -48, sp
- LOADGLOBAL(r3, caml_bottom_of_stack#)
- add r2 = 16, sp ;;
- ST8OFF(r2, r3, 8)
- LOADGLOBAL(r3, caml_last_return_address#) ;;
- ST8OFF(r2, r3, 8)
- LOADGLOBAL(r3, caml_gc_regs#) ;;
- ST8OFF(r2, r3, 8)
- LOADGLOBAL(r3, caml_saved_bsp#) ;;
- ST8OFF(r2, r3, 8)
- LOADGLOBAL(r3, caml_saved_rnat#) ;;
- ST8OFF(r2, r3, 8)
-
- /* Set up a trap frame to catch exceptions escaping the Caml code */
- mov r6 = sp
- add sp = -16, sp ;;
- LOADGLOBAL(r3, caml_exception_pointer#)
- add r2 = 16, sp ;;
- ST8OFF(r2, r3, 8)
-.L110: mov r3 = ip ;;
- add r3 = .L101 - .L110, r3 ;;
- ST8OFF(r2, r3, 8) ;;
-
- /* Save ar.bsp, flush register window, and save ar.rnat */
- mov r2 = ar.bsp ;;
- STOREGLOBAL(r2, caml_saved_bsp#) ;;
- mov r14 = ar.rsc ;;
- and r2 = ~0x3, r14;; /* set rsc.mode = 0 */
- mov ar.rsc = r2 ;; /* RSE is in enforced lazy mode */
- flushrs ;; /* must be first instr in group */
- mov r2 = ar.rnat ;;
- STOREGLOBAL(r2, caml_saved_rnat#)
- mov ar.rsc = r14 /* restore original RSE mode */
-
- /* Reload allocation pointers */
- LOADGLOBAL(r4, young_ptr#)
- LOADGLOBAL(r5, young_limit#)
-
- /* We are back into Caml code */
- STOREGLOBAL(r0, caml_last_return_address#)
-
- /* Call the Caml code */
- br.call.sptk b0 = b6 ;;
-.L102:
-
- /* Pop the trap frame, restoring caml_exception_pointer */
- add sp = 16, sp ;;
- ld8 r2 = [sp] ;;
- STOREGLOBAL(r2, caml_exception_pointer#)
-
-.L104:
- /* Pop the callback link, restoring the global variables */
- add r14 = 16, sp ;;
- LD8OFF(r2, r14, 8) ;;
- STOREGLOBAL(r2, caml_bottom_of_stack#)
- LD8OFF(r2, r14, 8) ;;
- STOREGLOBAL(r2, caml_last_return_address#)
- LD8OFF(r2, r14, 8) ;;
- STOREGLOBAL(r2, caml_gc_regs#)
- LD8OFF(r2, r14, 8) ;;
- STOREGLOBAL(r2, caml_saved_bsp#)
- LD8OFF(r2, r14, 8) ;;
- STOREGLOBAL(r2, caml_saved_rnat#)
- add sp = 48, sp
-
- /* Update allocation pointer */
- STOREGLOBAL(r4, young_ptr#)
-
- /* Restore all callee-save registers from stack */
- add r2 = 16, sp ;;
- LD8OFF(r3, r2, 8) ;; /* 0 : ar.pfs */
- mov ar.pfs = r3
- LD8OFF(r3, r2, 8) ;; /* 1 : return address */
- mov b0 = r3
- LD8OFF(gp, r2, 8) ;; /* 2 : gp */
- LD8OFF(r3, r2, 8) ;; /* 3 : predicates */
- mov pr = r3, -1
- LD8OFF(r3, r2, 8) ;; /* 4 : ar.fpsr */
- mov ar.fpsr = r3
- LD8OFF(r3, r2, 8) ;; /* 5 : ar.unat */
- mov ar.unat = r3
- LD8OFF(r3, r2, 8) ;; /* 6 : ar.lc */
- mov ar.lc = r3
- LD8OFF(r3, r2, 8) ;; /* 7 - 11 : b1 - b5 */
- mov b1 = r3
- LD8OFF(r3, r2, 8) ;;
- mov b2 = r3
- LD8OFF(r3, r2, 8) ;;
- mov b3 = r3
- LD8OFF(r3, r2, 8) ;;
- mov b4 = r3
- LD8OFF(r3, r2, 8) ;;
- mov b5 = r3
-
- add r3 = 8, r2 ;;
- LOAD4(r4,r5,r6,r7) ;; /* 12 - 15 : r4 - r7 */
-
- add r3 = 16, r2 ;; /* 16 - 55 : f2 - f5, f16 - f31 */
- FFILL4(f2,f3,f4,f5) ;;
- FFILL8(f16,f17,f18,f19,f20,f21,f22,f23) ;;
- FFILL8(f24,f25,f26,f27,f28,f29,f30,f31) ;;
-
- /* Pop stack frame and return */
- add sp = (56 * 8), sp
- br.ret.sptk.many b0 ;;
-
- /* The trap handler */
-.L101:
- /* Save exception pointer */
- STOREGLOBAL(r6, caml_exception_pointer#)
-
- /* Encode exception bucket as exception result */
- or r8 = 2, r8
-
- /* Return it */
- br.sptk .L104 ;;
-
- .endp caml_start_program#
-
-/* Raise an exception from C */
-
- .global raise_caml_exception#
- .proc raise_caml_exception#
- .align 16
-raise_caml_exception:
- /* Allocate 64 "out" registers (for the Caml code) and no locals */
- /* Since we don't return, don't bother saving the PFS */
- alloc r2 = ar.pfs, 0, 0, 64, 0
-
- /* Move exn bucket where Caml expects it */
- mov r8 = r32 ;;
-
- /* Perform "context switch" as per the Software Conventions Guide,
- chapter 10 */
- flushrs ;; /* flush dirty registers to stack */
- mov r14 = ar.rsc ;;
- and r2 = ~0x3, r14;; /* set rsc.mode = 0 */
- dep r2 = r0, r2, 16, 4 ;; /* clear rsc.loadrs */
- mov ar.rsc = r2 ;; /* RSE is in enforced lazy mode */
- invala ;; /* Invalidate ALAT */
- LOADGLOBAL(r2, caml_saved_bsp#) ;;
- mov ar.bspstore = r2 /* Restore ar.bspstore */
- LOADGLOBAL(r2, caml_saved_rnat#) ;;
- mov ar.rnat = r2 /* Restore ar.rnat */
- mov ar.rsc = r14 ;; /* Restore original RSE mode */
-
- /* Reload allocation pointers and exception pointer */
- LOADGLOBAL(r4, young_ptr#)
- LOADGLOBAL(r5, young_limit#)
- LOADGLOBAL(r6, caml_exception_pointer#)
-
- /* Say that we're back into Caml */
- STOREGLOBAL(r0, caml_last_return_address#)
-
- /* Raise the exception proper */
- mov sp = r6
- add r2 = 8, r6 ;;
- ld8 r6 = [r6]
- ld8 r2 = [r2] ;;
- mov b6 = r2 ;;
-
- /* Branch to handler. Must use a call so as to set up the
- CFM and PFS correctly. */
- br.call.sptk.many b0 = b6
-
- .endp raise_caml_exception
-
-/* Callbacks from C to Caml */
-
- .global callback_exn#
- .proc callback_exn#
- .align 16
-callback_exn:
- /* Initial shuffling of arguments */
- ld8 r3 = [r32] /* code pointer */
- mov r2 = r32
- mov r32 = r33 ;; /* first arg */
- mov r33 = r2 /* environment */
- mov b6 = r3
- br.sptk .L103 ;;
-
- .endp callback_exn#
-
- .global callback2_exn#
- .proc callback2_exn#
- .align 16
-callback2_exn:
- /* Initial shuffling of arguments */
- ADDRGLOBAL(r3, caml_apply2) /* code pointer */
- mov r2 = r32
- mov r32 = r33 /* first arg */
- mov r33 = r34 ;; /* second arg */
- mov r34 = r2 /* environment */
- mov b6 = r3
- br.sptk .L103 ;;
-
- .endp callback2_exn#
-
- .global callback3_exn#
- .proc callback3_exn#
- .align 16
-callback3_exn:
- /* Initial shuffling of arguments */
- ADDRGLOBAL(r3, caml_apply3) /* code pointer */
- mov r2 = r32
- mov r32 = r33 /* first arg */
- mov r33 = r34 /* second arg */
- mov r34 = r35 ;; /* third arg */
- mov r35 = r2 /* environment */
- mov b6 = r3
- br.sptk .L103 ;;
-
- .endp callback3_exn#
-
-/* Glue code to call array_bound_error */
-
- .global caml_array_bound_error#
- .proc caml_array_bound_error#
- .align 16
-caml_array_bound_error:
- ADDRGLOBAL(r2, @fptr(array_bound_error#))
- br.sptk caml_c_call /* never returns */
-
- .rodata
-
- .global system__frametable#
- .type system__frametable#, @object
- .size system__frametable#, 8
-system__frametable:
- data8 1 /* one descriptor */
- data8 .L102 /* return address into callback */
- data2 -1 /* negative frame size => use callback link */
- data2 0 /* no roots here */
- .align 8
-
-/* Global variables used by raise_caml_exception */
-
- .common caml_saved_bsp#, 8, 8
- .common caml_saved_rnat#, 8, 8
diff --git a/asmrun/m68k.S b/asmrun/m68k.S
deleted file mode 100644
index 85de3fb3dc..0000000000
--- a/asmrun/m68k.S
+++ /dev/null
@@ -1,244 +0,0 @@
-|***********************************************************************
-|* *
-|* Objective Caml *
-|* *
-|* Xavier Leroy, projet Cristal, INRIA Rocquencourt *
-|* *
-|* Copyright 1996 Institut National de Recherche en Informatique et *
-|* en Automatique. All rights reserved. This file is distributed *
-|* under the terms of the GNU Library General Public License, with *
-|* the special exception on linking described in file ../LICENSE. *
-|* *
-|***********************************************************************
-
-| $Id$
-
-| Asm part of the runtime system, Motorola 68k processor
-
- .comm _caml_requested_size, 4
-
-| Allocation
-
- .text
- .globl _caml_call_gc
- .globl _caml_alloc1
- .globl _caml_alloc2
- .globl _caml_alloc3
- .globl _caml_alloc
-
-_caml_call_gc:
- | Save desired size
- movel d5, _caml_requested_size
- | Record lowest stack address and return address
- movel a7@, _caml_last_return_address
- movel a7, d5
- addql #4, d5
- movel d5, _caml_bottom_of_stack
- | Record current allocation pointer (for debugging)
- movel d6, _young_ptr
- | Save all regs used by the code generator
- movel d4, a7@-
- movel d3, a7@-
- movel d2, a7@-
- movel d1, a7@-
- movel d0, a7@-
- movel a6, a7@-
- movel a5, a7@-
- movel a4, a7@-
- movel a3, a7@-
- movel a2, a7@-
- movel a1, a7@-
- movel a0, a7@-
- movel a7, _caml_gc_regs
- fmovem fp0-fp7, a7@-
- | Call the garbage collector
- jbsr _garbage_collection
- | Restore all regs used by the code generator
- fmovem a7@+, fp0-fp7
- movel a7@+, a0
- movel a7@+, a1
- movel a7@+, a2
- movel a7@+, a3
- movel a7@+, a4
- movel a7@+, a5
- movel a7@+, a6
- movel a7@+, d0
- movel a7@+, d1
- movel a7@+, d2
- movel a7@+, d3
- movel a7@+, d4
- | Reload allocation pointer and allocate block
- movel _young_ptr, d6
- subl _caml_requested_size, d6
- | Return to caller
- rts
-
-_caml_alloc1:
- subql #8, d6
- cmpl _young_limit, d6
- bcs L100
- rts
-L100: moveq #8, d5
- bra _caml_call_gc
-
-_caml_alloc2:
- subl #12, d6
- cmpl _young_limit, d6
- bcs L101
- rts
-L101: moveq #12, d5
- bra _caml_call_gc
-
-_caml_alloc3:
- subl #16, d6
- cmpl _young_limit, d6
- bcs L102
- rts
-L102: moveq #16, d5
- bra _caml_call_gc
-
-_caml_alloc:
- subl d5, d6
- cmpl _young_limit, d6
- bcs _caml_call_gc
- rts
-
-| Call a C function from Caml
-
- .globl _caml_c_call
-
-_caml_c_call:
- | Record lowest stack address and return address
- movel a7@+, _caml_last_return_address
- movel a7, _caml_bottom_of_stack
- | Save allocation pointer and exception pointer
- movel d6, _young_ptr
- movel d7, _caml_exception_pointer
- | Call the function (address in a0)
- jbsr a0@
- | Reload allocation pointer
- movel _young_ptr, d6
- | Return to caller
- movel _caml_last_return_address, a1
- jmp a1@
-
-| Start the Caml program
-
- .globl _caml_start_program
-
-_caml_start_program:
- | Save callee-save registers
- moveml a2-a6/d2-d7, a7@-
- fmovem fp2-fp7, a7@-
- | Initial code point is caml_program
- lea _caml_program, a5
-
-| Code shared between caml_start_program and callback*
-
-L106:
- | Build a callback link
- movel _caml_gc_regs, a7@-
- movel _caml_last_return_address, a7@-
- movel _caml_bottom_of_stack, a7@-
- | Build an exception handler
- pea L108
- movel _caml_exception_pointer, a7@-
- movel a7, d7
- | Load allocation pointer
- movel _young_ptr, d6
- | Call the Caml code
- jbsr a5@
-L107:
- | Move result where C code expects it
- movel a0, d0
- | Save allocation pointer
- movel d6, _young_ptr
- | Pop the exception handler
- movel a7@+, _caml_exception_pointer
- addql #4, a7
-L109:
- | Pop the callback link, restoring the global variables
- | used by caml_c_call
- movel a7@+, _caml_bottom_of_stack
- movel a7@+, _caml_last_return_address
- movel a7@+, _caml_gc_regs
- | Restore callee-save registers and return
- fmovem a7@+, fp2-fp7
- moveml a7@+, a2-a6/d2-d7
- unlk a6
- rts
-L108:
- | Exception handler
- | Save allocation pointer and exception pointer
- movel d6, _young_ptr
- movel d7, _caml_exception_pointer
- | Encode exception bucket as an exception result
- movel a0, d0
- orl #2, d0
- | Return it
- bra L109
-
-| Raise an exception from C
-
- .globl _raise_caml_exception
-_raise_caml_exception:
- movel a7@(4), a0 | exception bucket
- movel _young_ptr, d6
- movel _caml_exception_pointer, a7
- movel a7@+, d7
- rts
-
-| Callback from C to Caml
-
- .globl _callback_exn
-_callback_exn:
- link a6, #0
- | Save callee-save registers
- moveml a2-a6/d2-d7, a7@-
- fmovem fp2-fp7, a7@-
- | Initial loading of arguments
- movel a6@(8), a1 | closure
- movel a6@(12), a0 | argument
- movel a1@(0), a5 | code pointer
- bra L106
-
- .globl _callback2_exn
-_callback2_exn:
- link a6, #0
- | Save callee-save registers
- moveml a2-a6/d2-d7, a7@-
- fmovem fp2-fp7, a7@-
- | Initial loading of arguments
- movel a6@(8), a2 | closure
- movel a6@(12), a0 | first argument
- movel a6@(16), a1 | second argument
- lea _caml_apply2, a5 | code pointer
- bra L106
-
- .globl _callback3_exn
-_callback3_exn:
- link a6, #0
- | Save callee-save registers
- moveml a2-a6/d2-d7, a7@-
- fmovem fp2-fp7, a7@-
- | Initial loading of arguments
- movel a6@(8), a3 | closure
- movel a6@(12), a0 | first argument
- movel a6@(16), a1 | second argument
- movel a6@(20), a2 | third argument
- lea _caml_apply3, a5 | code pointer
- bra L106
-
- .globl _caml_array_bound_error
-_caml_array_bound_error:
- | Load address of array_bound_error in a0 and call it
- lea _array_bound_error, a0
- bra _caml_c_call
-
- .data
- .globl _system__frametable
-_system__frametable:
- .long 1 | one descriptor
- .long L107 | return address into callback
- .word -1 | negative frame size => use callback link
- .word 0 | no roots here
diff --git a/asmrun/mips.s b/asmrun/mips.s
deleted file mode 100644
index 26853c0d8d..0000000000
--- a/asmrun/mips.s
+++ /dev/null
@@ -1,386 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Asm part of the runtime system, Mips processor, IRIX n32 conventions */
-
-/* Allocation */
-
- .text
-
- .globl caml_call_gc
- .ent caml_call_gc
-
-caml_call_gc:
- /* Reserve stack space for registers and saved $gp */
- /* 32 * 8 = 0x100 for float regs
- 22 * 4 = 0x58 for integer regs
- 8 = 0x8 for saved $gp ====> 0x160 total */
- subu $sp, $sp, 0x160
- /* Reinit $gp */
- .cpsetup $25, 0x158, caml_call_gc
- /* Record return address */
- sw $31, caml_last_return_address
- /* Record lowest stack address */
- addu $24, $sp, 0x160
- sw $24, caml_bottom_of_stack
- /* Save pointer to register array */
- addu $24, $sp, 0x100
- sw $24, caml_gc_regs
- /* Save current allocation pointer for debugging purposes */
- sw $22, young_ptr
- /* Save the exception handler (if e.g. a sighandler raises) */
- sw $30, caml_exception_pointer
- /* Save all regs used by the code generator on the stack */
- sw $2, 2 * 4($24)
- sw $3, 3 * 4($24)
- sw $4, 4 * 4($24)
- sw $5, 5 * 4($24)
- sw $6, 6 * 4($24)
- sw $7, 7 * 4($24)
- sw $8, 8 * 4($24)
- sw $9, 9 * 4($24)
- sw $10, 10 * 4($24)
- sw $11, 11 * 4($24)
- sw $12, 12 * 4($24)
- sw $13, 13 * 4($24)
- sw $14, 14 * 4($24)
- sw $15, 15 * 4($24)
- sw $16, 16 * 4($24)
- sw $17, 17 * 4($24)
- sw $18, 18 * 4($24)
- sw $19, 19 * 4($24)
- sw $20, 20 * 4($24)
- sw $21, 21 * 4($24)
- s.d $f0, 0 * 8($sp)
- s.d $f1, 1 * 8($sp)
- s.d $f2, 2 * 8($sp)
- s.d $f3, 3 * 8($sp)
- s.d $f4, 4 * 8($sp)
- s.d $f5, 5 * 8($sp)
- s.d $f6, 6 * 8($sp)
- s.d $f7, 7 * 8($sp)
- s.d $f8, 8 * 8($sp)
- s.d $f9, 9 * 8($sp)
- s.d $f10, 10 * 8($sp)
- s.d $f11, 11 * 8($sp)
- s.d $f12, 12 * 8($sp)
- s.d $f13, 13 * 8($sp)
- s.d $f14, 14 * 8($sp)
- s.d $f15, 15 * 8($sp)
- s.d $f16, 16 * 8($sp)
- s.d $f17, 17 * 8($sp)
- s.d $f18, 18 * 8($sp)
- s.d $f19, 19 * 8($sp)
- s.d $f20, 20 * 8($sp)
- s.d $f21, 21 * 8($sp)
- s.d $f22, 22 * 8($sp)
- s.d $f23, 23 * 8($sp)
- s.d $f24, 24 * 8($sp)
- s.d $f25, 25 * 8($sp)
- s.d $f26, 26 * 8($sp)
- s.d $f27, 27 * 8($sp)
- s.d $f28, 28 * 8($sp)
- s.d $f29, 29 * 8($sp)
- s.d $f30, 30 * 8($sp)
- s.d $f31, 31 * 8($sp)
- /* Call the garbage collector */
- jal garbage_collection
- /* Restore all regs used by the code generator */
- addu $24, $sp, 0x100
- lw $2, 2 * 4($24)
- lw $3, 3 * 4($24)
- lw $4, 4 * 4($24)
- lw $5, 5 * 4($24)
- lw $6, 6 * 4($24)
- lw $7, 7 * 4($24)
- lw $8, 8 * 4($24)
- lw $9, 9 * 4($24)
- lw $10, 10 * 4($24)
- lw $11, 11 * 4($24)
- lw $12, 12 * 4($24)
- lw $13, 13 * 4($24)
- lw $14, 14 * 4($24)
- lw $15, 15 * 4($24)
- lw $16, 16 * 4($24)
- lw $17, 17 * 4($24)
- lw $18, 18 * 4($24)
- lw $19, 19 * 4($24)
- lw $20, 20 * 4($24)
- lw $21, 21 * 4($24)
- l.d $f0, 0 * 8($sp)
- l.d $f1, 1 * 8($sp)
- l.d $f2, 2 * 8($sp)
- l.d $f3, 3 * 8($sp)
- l.d $f4, 4 * 8($sp)
- l.d $f5, 5 * 8($sp)
- l.d $f6, 6 * 8($sp)
- l.d $f7, 7 * 8($sp)
- l.d $f8, 8 * 8($sp)
- l.d $f9, 9 * 8($sp)
- l.d $f10, 10 * 8($sp)
- l.d $f11, 11 * 8($sp)
- l.d $f12, 12 * 8($sp)
- l.d $f13, 13 * 8($sp)
- l.d $f14, 14 * 8($sp)
- l.d $f15, 15 * 8($sp)
- l.d $f16, 16 * 8($sp)
- l.d $f17, 17 * 8($sp)
- l.d $f18, 18 * 8($sp)
- l.d $f19, 19 * 8($sp)
- l.d $f20, 20 * 8($sp)
- l.d $f21, 21 * 8($sp)
- l.d $f22, 22 * 8($sp)
- l.d $f23, 23 * 8($sp)
- l.d $f24, 24 * 8($sp)
- l.d $f25, 25 * 8($sp)
- l.d $f26, 26 * 8($sp)
- l.d $f27, 27 * 8($sp)
- l.d $f28, 28 * 8($sp)
- l.d $f29, 29 * 8($sp)
- l.d $f30, 30 * 8($sp)
- l.d $f31, 31 * 8($sp)
- /* Reload new allocation pointer and allocation limit */
- lw $22, young_ptr
- lw $23, young_limit
- /* Reload return address */
- lw $31, caml_last_return_address
- /* Say that we are back into Caml code */
- sw $0, caml_last_return_address
- /* Adjust return address to restart the allocation sequence */
- subu $31, $31, 16
- /* Return */
- .cpreturn
- addu $sp, $sp, 0x160
- j $31
-
- .end caml_call_gc
-
-/* Call a C function from Caml */
-
- .globl caml_c_call
- .ent caml_c_call
-
-caml_c_call:
- /* Function to call is in $24 */
- /* Set up $gp, saving caller's $gp in callee-save register $19 */
- .cpsetup $25, $19, caml_c_call
- /* Preload addresses of interesting global variables
- in callee-save registers */
- la $16, caml_last_return_address
- la $17, young_ptr
- /* Save return address, bottom of stack, alloc ptr, exn ptr */
- sw $31, 0($16) /* caml_last_return_address */
- sw $sp, caml_bottom_of_stack
- sw $22, 0($17) /* young_ptr */
- sw $30, caml_exception_pointer
- /* Call C function */
- move $25, $24
- jal $24
- /* Reload return address, alloc ptr, alloc limit */
- lw $31, 0($16) /* caml_last_return_address */
- lw $22, 0($17) /* young_ptr */
- lw $23, young_limit /* young_limit */
- /* Zero caml_last_return_address, indicating we're back in Caml code */
- sw $0, 0($16) /* caml_last_return_address */
- /* Restore $gp and return */
- move $gp, $19
- j $31
- .end caml_c_call
-
-/* Start the Caml program */
-
- .globl caml_start_program
- .globl stray_exn_handler
- .ent caml_start_program
-caml_start_program:
- /* Reserve space for callee-save registers */
- subu $sp, $sp, 0x90
- /* Setup $gp */
- .cpsetup $25, 0x80, caml_start_program
- /* Load in $24 the code address to call */
- la $24, caml_program
- /* Code shared with callback* */
-$103:
- /* Save return address */
- sd $31, 0x88($sp)
- /* Save all callee-save registers */
- sd $16, 0x0($sp)
- sd $17, 0x8($sp)
- sd $18, 0x10($sp)
- sd $19, 0x18($sp)
- sd $20, 0x20($sp)
- sd $21, 0x28($sp)
- sd $22, 0x30($sp)
- sd $23, 0x38($sp)
- sd $30, 0x40($sp)
- s.d $f20, 0x48($sp)
- s.d $f22, 0x50($sp)
- s.d $f24, 0x58($sp)
- s.d $f26, 0x60($sp)
- s.d $f28, 0x68($sp)
- s.d $f30, 0x70($sp)
- /* Set up a callback link on the stack. */
- subu $sp, $sp, 16
- lw $2, caml_bottom_of_stack
- sw $2, 0($sp)
- lw $3, caml_last_return_address
- sw $3, 4($sp)
- lw $4, caml_gc_regs
- sw $4, 8($sp)
- /* Set up a trap frame to catch exceptions escaping the Caml code */
- subu $sp, $sp, 16
- lw $30, caml_exception_pointer
- sw $30, 0($sp)
- la $2, $105
- sw $2, 4($sp)
- sw $gp, 8($sp)
- move $30, $sp
- /* Reload allocation pointers */
- lw $22, young_ptr
- lw $23, young_limit
- /* Say that we are back into Caml code */
- sw $0, caml_last_return_address
- /* Call the Caml code */
- move $25, $24
- jal $24
-$104:
- /* Pop the trap frame, restoring caml_exception_pointer */
- lw $24, 0($sp)
- sw $24, caml_exception_pointer
- addu $sp, $sp, 16
-$106:
- /* Pop the callback link, restoring the global variables */
- lw $24, 0($sp)
- sw $24, caml_bottom_of_stack
- lw $25, 4($sp)
- sw $25, caml_last_return_address
- lw $24, 8($sp)
- sw $24, caml_gc_regs
- addu $sp, $sp, 16
- /* Update allocation pointer */
- sw $22, young_ptr
- /* Reload callee-save registers and return */
- ld $31, 0x88($sp)
- ld $16, 0x0($sp)
- ld $17, 0x8($sp)
- ld $18, 0x10($sp)
- ld $19, 0x18($sp)
- ld $20, 0x20($sp)
- ld $21, 0x28($sp)
- ld $22, 0x30($sp)
- ld $23, 0x38($sp)
- ld $30, 0x40($sp)
- l.d $f20, 0x48($sp)
- l.d $f22, 0x50($sp)
- l.d $f24, 0x58($sp)
- l.d $f26, 0x60($sp)
- l.d $f28, 0x68($sp)
- l.d $f30, 0x70($sp)
- .cpreturn
- addu $sp, $sp, 0x90
- j $31
-
- /* The trap handler: encode exception bucket as an exception result
- and return it */
-$105:
- sw $30, caml_exception_pointer
- or $2, $2, 2
- b $106
-
- .end caml_start_program
-
-/* Raise an exception from C */
-
- .globl raise_caml_exception
- .ent raise_caml_exception
-raise_caml_exception:
- /* Setup $gp, discarding caller's $gp (we won't return) */
- .cpsetup $25, $24, raise_caml_exception
- /* Branch to exn handler */
- move $2, $4
- lw $22, young_ptr
- lw $23, young_limit
- lw $sp, caml_exception_pointer
- lw $30, 0($sp)
- lw $24, 4($sp)
- lw $gp, 8($sp)
- addu $sp, $sp, 16
- j $24
-
- .end raise_caml_exception
-
-/* Callback from C to Caml */
-
- .globl callback_exn
- .ent callback_exn
-callback_exn:
- subu $sp, $sp, 0x90
- .cpsetup $25, 0x80, callback_exn
- /* Initial shuffling of arguments */
- move $9, $4 /* closure */
- move $8, $5 /* argument */
- lw $24, 0($4) /* code pointer */
- b $103
- .end callback_exn
-
- .globl callback2_exn
- .ent callback2_exn
-callback2_exn:
- subu $sp, $sp, 0x90
- .cpsetup $25, 0x80, callback2_exn
- /* Initial shuffling of arguments */
- move $10, $4 /* closure */
- move $8, $5 /* first argument */
- move $9, $6 /* second argument */
- la $24, caml_apply2 /* code pointer */
- b $103
-
- .end callback2_exn
-
- .globl callback3_exn
- .ent callback3_exn
-callback3_exn:
- subu $sp, $sp, 0x90
- .cpsetup $25, 0x80, callback3_exn
- /* Initial shuffling of arguments */
- move $11, $4 /* closure */
- move $8, $5 /* first argument */
- move $9, $6 /* second argument */
- move $10, $7 /* third argument */
- la $24, caml_apply3 /* code pointer */
- b $103
-
- .end callback3_exn
-
-/* Glue code to call array_bound_error */
-
- .globl caml_array_bound_error
- .ent caml_array_bound_error
-
-caml_array_bound_error:
- /* Setup $gp, discarding caller's $gp (we won't return) */
- .cpsetup $25, $24, caml_array_bound_error
- la $24, array_bound_error
- jal caml_c_call /* never returns */
-
- .end caml_array_bound_error
-
- .rdata
- .globl system__frametable
-system__frametable:
- .word 1 /* one descriptor */
- .word $104 /* return address into callback */
- .half -1 /* negative frame size => use callback link */
- .half 0 /* no roots here */
diff --git a/asmrun/power-aix.S b/asmrun/power-aix.S
deleted file mode 100644
index 3baa5f9665..0000000000
--- a/asmrun/power-aix.S
+++ /dev/null
@@ -1,513 +0,0 @@
-#*********************************************************************
-#* *
-#* Objective Caml *
-#* *
-#* Xavier Leroy, projet Cristal, INRIA Rocquencourt *
-#* *
-#* Copyright 1996 Institut National de Recherche en Informatique et *
-#* en Automatique. All rights reserved. This file is distributed *
-#* under the terms of the GNU Library General Public License, with *
-#* the special exception on linking described in file ../LICENSE. *
-#* *
-#*********************************************************************
-
-# $Id$
-
- .csect .text[PR]
-
-#### Invoke the garbage collector. r0 contains the return address
-
- .globl .caml_call_gc
-.caml_call_gc:
- # Set up stack frame
- stwu 1, -0x1C0(1)
- # 0x1C0 = 4*32 (int regs) + 8*32 (float regs) + 64 (space for C call)
- # Record last return address into Caml code
- lwz 11, L..caml_last_return_address(2)
- stw 0, 0(11)
- # Record return address into call_gc stub code
- mflr 0
- stw 0, 0x1C0+8(1)
- # Record lowest stack address
- lwz 11, L..caml_bottom_of_stack(2)
- addi 0, 1, 0x1C0
- stw 0, 0(11)
- # Record pointer to register array
- lwz 11, L..caml_gc_regs(2)
- addi 0, 1, 8*32 + 64
- stw 0, 0(11)
- # Save current allocation pointer for debugging purposes
- lwz 11, L..young_ptr(2)
- stw 31, 0(11)
- # Save exception pointer (if e.g. a sighandler raises)
- lwz 11, L..caml_exception_pointer(2)
- stw 29, 0(11)
- # Save all registers used by the code generator
- addi 11, 1, 8*32 + 64 - 4
- stwu 3, 4(11)
- stwu 4, 4(11)
- stwu 5, 4(11)
- stwu 6, 4(11)
- stwu 7, 4(11)
- stwu 8, 4(11)
- stwu 9, 4(11)
- stwu 10, 4(11)
- stwu 14, 4(11)
- stwu 15, 4(11)
- stwu 16, 4(11)
- stwu 17, 4(11)
- stwu 18, 4(11)
- stwu 19, 4(11)
- stwu 20, 4(11)
- stwu 21, 4(11)
- stwu 22, 4(11)
- stwu 23, 4(11)
- stwu 24, 4(11)
- stwu 25, 4(11)
- stwu 26, 4(11)
- stwu 27, 4(11)
- stwu 28, 4(11)
- addi 11, 1, 64 - 8
- stfdu 1, 8(11)
- stfdu 2, 8(11)
- stfdu 3, 8(11)
- stfdu 4, 8(11)
- stfdu 5, 8(11)
- stfdu 6, 8(11)
- stfdu 7, 8(11)
- stfdu 8, 8(11)
- stfdu 9, 8(11)
- stfdu 10, 8(11)
- stfdu 11, 8(11)
- stfdu 12, 8(11)
- stfdu 13, 8(11)
- stfdu 14, 8(11)
- stfdu 15, 8(11)
- stfdu 16, 8(11)
- stfdu 17, 8(11)
- stfdu 18, 8(11)
- stfdu 19, 8(11)
- stfdu 20, 8(11)
- stfdu 21, 8(11)
- stfdu 22, 8(11)
- stfdu 23, 8(11)
- stfdu 24, 8(11)
- stfdu 25, 8(11)
- stfdu 26, 8(11)
- stfdu 27, 8(11)
- stfdu 28, 8(11)
- stfdu 29, 8(11)
- stfdu 30, 8(11)
- stfdu 31, 8(11)
- # Call the GC
- bl .garbage_collection
- or 0, 0, 0
- # Reload new allocation pointer and allocation limit
- lwz 11, L..young_ptr(2)
- lwz 31, 0(11)
- lwz 11, L..young_limit(2)
- lwz 30, 0(11)
- # Restore all regs used by the code generator
- addi 11, 1, 8*32 + 64 - 4
- lwzu 3, 4(11)
- lwzu 4, 4(11)
- lwzu 5, 4(11)
- lwzu 6, 4(11)
- lwzu 7, 4(11)
- lwzu 8, 4(11)
- lwzu 9, 4(11)
- lwzu 10, 4(11)
- lwzu 14, 4(11)
- lwzu 15, 4(11)
- lwzu 16, 4(11)
- lwzu 17, 4(11)
- lwzu 18, 4(11)
- lwzu 19, 4(11)
- lwzu 20, 4(11)
- lwzu 21, 4(11)
- lwzu 22, 4(11)
- lwzu 23, 4(11)
- lwzu 24, 4(11)
- lwzu 25, 4(11)
- lwzu 26, 4(11)
- lwzu 27, 4(11)
- lwzu 28, 4(11)
- addi 11, 1, 64 - 8
- lfdu 1, 8(11)
- lfdu 2, 8(11)
- lfdu 3, 8(11)
- lfdu 4, 8(11)
- lfdu 5, 8(11)
- lfdu 6, 8(11)
- lfdu 7, 8(11)
- lfdu 8, 8(11)
- lfdu 9, 8(11)
- lfdu 10, 8(11)
- lfdu 11, 8(11)
- lfdu 12, 8(11)
- lfdu 13, 8(11)
- lfdu 14, 8(11)
- lfdu 15, 8(11)
- lfdu 16, 8(11)
- lfdu 17, 8(11)
- lfdu 18, 8(11)
- lfdu 19, 8(11)
- lfdu 20, 8(11)
- lfdu 21, 8(11)
- lfdu 22, 8(11)
- lfdu 23, 8(11)
- lfdu 24, 8(11)
- lfdu 25, 8(11)
- lfdu 26, 8(11)
- lfdu 27, 8(11)
- lfdu 28, 8(11)
- lfdu 29, 8(11)
- lfdu 30, 8(11)
- lfdu 31, 8(11)
- # Return to caller (the stub code), leaving return address into
- # Caml code in the link register
- lwz 0, 0x1C0+8(1)
- mtctr 0
- lwz 11, L..caml_last_return_address(2)
- lwz 0, 0(11)
- addic 0, 0, -16 # Restart the allocation (4 instructions)
- mtlr 0
- # Say we are back into Caml code
- li 12, 0
- stw 12, 0(11) # 11 still points to caml_last_return_address
- # Deallocate stack frame
- addi 1, 1, 0x1C0
- # Return
- bctr
-
-#### Call a C function from Caml
-
- .globl .caml_c_call
-.caml_c_call:
- # Save return address in 25
- mflr 25
- # Record lowest stack address and return address
- lwz 27, L..caml_bottom_of_stack(2)
- lwz 24, L..caml_last_return_address(2)
- stw 1, 0(27)
- stw 25, 0(24)
- # Make the exception handler and alloc ptr available to the C code
- lwz 27, L..young_ptr(2)
- lwz 26, L..caml_exception_pointer(2)
- stw 31, 0(27)
- stw 29, 0(26)
- # Preserve RTOC and return address in callee-save registers
- # The C function will preserve them, and the Caml code does not
- # expect them to be preserved
- # Return address is in 25, RTOC is in 26, pointer to young_ptr in 27,
- # pointer to caml_last_return_address is in 24
- # Call the function (descriptor in 11)
- lwz 0, 0(11)
- mr 26, 2
- mtlr 0
- lwz 2, 4(11)
- lwz 11, 8(11)
- blrl
- # Restore return address
- mtlr 25
- # Restore RTOC
- mr 2, 26
- # Reload allocation pointer
- lwz 31, 0(27) # 27 still points to young_ptr
- # Say we are back into Caml code
- li 12, 0
- stw 12, 0(24) # 24 still points to caml_last_return_address
- # Return to caller
- blr
-
-#### Raise an exception from C
-
- .globl .raise_caml_exception
-.raise_caml_exception:
- # Reload Caml global registers
- lwz 4, L..caml_exception_pointer(2)
- lwz 5, L..young_ptr(2)
- lwz 6, L..young_limit(2)
- lwz 1, 0(4)
- lwz 31, 0(5)
- lwz 30, 0(6)
- # Say we are back into Caml code
- lwz 4, L..caml_last_return_address(2)
- li 0, 0
- stw 0, 0(4)
- # Pop trap frame
- lwz 0, 0(1)
- lwz 29, 4(1)
- mtlr 0
- lwz 2, 20(1)
- addi 1, 1, 32
- # Branch to handler
- blr
-
-#### Start the Caml program
-
- .globl .caml_start_program
-.caml_start_program:
- lwz 11, L..caml_program(2)
-
-#### Code shared between caml_start_program and callback*
-
-L..102:
- mflr 0
- # Save return address
- stw 0, 8(1)
- # Save all callee-save registers
- stw 13, -76(1)
- stw 14, -72(1)
- stw 15, -68(1)
- stw 16, -64(1)
- stw 17, -60(1)
- stw 18, -56(1)
- stw 19, -52(1)
- stw 20, -48(1)
- stw 21, -44(1)
- stw 22, -40(1)
- stw 23, -36(1)
- stw 24, -32(1)
- stw 25, -28(1)
- stw 26, -24(1)
- stw 27, -20(1)
- stw 28, -16(1)
- stw 29, -12(1)
- stw 30, -8(1)
- stw 31, -4(1)
- stfd 14, -224(1)
- stfd 15, -216(1)
- stfd 16, -208(1)
- stfd 17, -200(1)
- stfd 18, -192(1)
- stfd 19, -184(1)
- stfd 20, -176(1)
- stfd 21, -168(1)
- stfd 22, -160(1)
- stfd 23, -152(1)
- stfd 24, -144(1)
- stfd 25, -136(1)
- stfd 26, -128(1)
- stfd 27, -120(1)
- stfd 28, -112(1)
- stfd 29, -104(1)
- stfd 30, -96(1)
- stfd 31, -88(1)
- # Allocate and link stack frame
- stwu 1, -288(1)
- # Set up a callback link
- addi 1, 1, -32
- lwz 9, L..caml_bottom_of_stack(2)
- lwz 10, L..caml_last_return_address(2)
- lwz 12, L..caml_gc_regs(2)
- lwz 9, 0(9)
- lwz 10, 0(10)
- lwz 12, 0(12)
- stw 9, 0(1)
- stw 10, 4(1)
- stw 12, 8(1)
- # Build an exception handler to catch exceptions escaping out of Caml
- bl L..103
- b L..104
-L..103:
- addi 1, 1, -32
- lwz 9, L..caml_exception_pointer(2)
- mflr 0
- lwz 29, 0(9)
- stw 0, 0(1)
- stw 29, 4(1)
- stw 2, 20(1)
- mr 29, 1
- # Reload allocation pointers
- lwz 9, L..young_ptr(2)
- lwz 10, L..young_limit(2)
- lwz 31, 0(9)
- lwz 30, 0(10)
- # Say we are back into Caml code
- lwz 9, L..caml_last_return_address(2)
- li 0, 0
- stw 0, 0(9)
- # Call the Caml code
- lwz 0, 0(11)
- stw 2, 20(1)
- mtlr 0
- lwz 2, 4(11)
-L..105:
- blrl
- lwz 2, 20(1)
- # Pop the trap frame, restoring caml_exception_pointer
- lwz 9, 4(1)
- lwz 10, L..caml_exception_pointer(2)
- addi 1, 1, 32
- stw 9, 0(10)
- # Pop the callback link, restoring the global variables
-L..106:
- lwz 7, 0(1)
- lwz 8, 4(1)
- lwz 9, 8(1)
- lwz 10, L..caml_bottom_of_stack(2)
- lwz 11, L..caml_last_return_address(2)
- lwz 12, L..caml_gc_regs(2)
- stw 7, 0(10)
- stw 8, 0(11)
- stw 9, 0(12)
- addi 1, 1, 32
- # Update allocation pointer
- lwz 11, L..young_ptr(2)
- stw 31, 0(11)
- # Deallocate stack frame
- addi 1, 1, 288
- # Restore callee-save registers
- lwz 13, -76(1)
- lwz 14, -72(1)
- lwz 15, -68(1)
- lwz 16, -64(1)
- lwz 17, -60(1)
- lwz 18, -56(1)
- lwz 19, -52(1)
- lwz 20, -48(1)
- lwz 21, -44(1)
- lwz 22, -40(1)
- lwz 23, -36(1)
- lwz 24, -32(1)
- lwz 25, -28(1)
- lwz 26, -24(1)
- lwz 27, -20(1)
- lwz 28, -16(1)
- lwz 29, -12(1)
- lwz 30, -8(1)
- lwz 31, -4(1)
- lfd 14, -224(1)
- lfd 15, -216(1)
- lfd 16, -208(1)
- lfd 17, -200(1)
- lfd 18, -192(1)
- lfd 19, -184(1)
- lfd 20, -176(1)
- lfd 21, -168(1)
- lfd 22, -160(1)
- lfd 23, -152(1)
- lfd 24, -144(1)
- lfd 25, -136(1)
- lfd 26, -128(1)
- lfd 27, -120(1)
- lfd 28, -112(1)
- lfd 29, -104(1)
- lfd 30, -96(1)
- lfd 31, -88(1)
- # Reload return address
- lwz 0, 8(1)
- mtlr 0
- # Return
- blr
- # The trap handler:
-L..104:
- # Update caml_exception_pointer
- lwz 9, L..caml_exception_pointer(2)
- stw 29, 0(9)
- # Encode exception bucket as an exception result and return it
- ori 3, 3, 2
- b L..106
-
-#### Callback from C to Caml
-
- .globl .callback_exn
-.callback_exn:
- # Initial shuffling of arguments
- mr 0, 3 # Closure
- mr 3, 4 # Argument
- mr 4, 0
- lwz 11, 0(4) # Code pointer
- b L..102
-
- .globl .callback2_exn
-.callback2_exn:
- mr 0, 3 # Closure
- mr 3, 4 # First argument
- mr 4, 5 # Second argument
- mr 5, 0
- lwz 11, L..caml_apply2(2)
- b L..102
-
- .globl .callback3_exn
-.callback3_exn:
- mr 0, 3 # Closure
- mr 3, 4 # First argument
- mr 4, 5 # Second argument
- mr 5, 6 # Third argument
- mr 6, 0
- lwz 11, L..caml_apply3(2)
- b L..102
-
-#### Frame table
-
- .csect .data[RW]
- .globl system__frametable
-system__frametable:
- .long 1 # one descriptor
- .long L..105 + 4 # return address into callback
- .short -1 # negative size count => use callback link
- .short 0 # no roots here
-
-#### TOC entries
-
- .toc
-L..young_limit:
- .tc young_limit[TC], young_limit
-L..young_ptr:
- .tc young_ptr[TC], young_ptr
-L..caml_bottom_of_stack:
- .tc caml_bottom_of_stack[TC], caml_bottom_of_stack
-L..caml_last_return_address:
- .tc caml_last_return_address[TC], caml_last_return_address
-L..caml_gc_regs:
- .tc caml_gc_regs[TC], caml_gc_regs
-L..caml_exception_pointer:
- .tc caml_exception_pointer[TC], caml_exception_pointer
-L..gc_entry_regs:
- .tc gc_entry_regs[TC], gc_entry_regs
-L..gc_entry_float_regs:
- .tc gc_entry_float_regs[TC], gc_entry_float_regs
-L..caml_program:
- .tc caml_program[TC], caml_program
-L..caml_apply2:
- .tc caml_apply2[TC], caml_apply2
-L..caml_apply3:
- .tc caml_apply3[TC], caml_apply3
-
-#### Function closures
-
- .csect caml_call_gc[DS]
-caml_call_gc:
- .long .caml_call_gc, TOC[tc0], 0
-
- .globl caml_c_call
- .csect caml_c_call[DS]
-caml_c_call:
- .long .caml_c_call, TOC[tc0], 0
-
- .globl raise_caml_exception
- .csect raise_caml_exception[DS]
-raise_caml_exception:
- .long .raise_caml_exception, TOC[tc0], 0
-
- .globl caml_start_program
- .csect caml_start_program[DS]
-caml_start_program:
- .long .caml_start_program, TOC[tc0], 0
-
- .globl callback_exn
- .csect callback_exn[DS]
-callback_exn:
- .long .callback_exn, TOC[tc0], 0
-
- .globl callback2_exn
- .csect callback2_exn[DS]
-callback2_exn:
- .long .callback2_exn, TOC[tc0], 0
-
- .globl callback3_exn
- .csect callback3_exn[DS]
-callback3_exn:
- .long .callback3_exn, TOC[tc0], 0
diff --git a/asmrun/power-elf.S b/asmrun/power-elf.S
deleted file mode 100644
index 52f3441cdb..0000000000
--- a/asmrun/power-elf.S
+++ /dev/null
@@ -1,421 +0,0 @@
-/*********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/*********************************************************************/
-
-/* $Id$ */
-
-#define Addrglobal(reg,glob) \
- addis reg, 0, glob@ha; \
- addi reg, reg, glob@l
-#define Loadglobal(reg,glob,tmp) \
- addis tmp, 0, glob@ha; \
- lwz reg, glob@l(tmp)
-#define Storeglobal(reg,glob,tmp) \
- addis tmp, 0, glob@ha; \
- stw reg, glob@l(tmp)
-
- .section ".text"
-
-/* Invoke the garbage collector. */
-
- .globl caml_call_gc
- .type caml_call_gc, @function
-caml_call_gc:
- /* Set up stack frame */
- stwu 1, -0x1A0(1)
- /* 0x1A0 = 4*32 (int regs) + 8*32 (float regs) + 32 (space for C call) */
- /* Record return address into Caml code */
- mflr 0
- Storeglobal(0, caml_last_return_address, 11)
- /* Record lowest stack address */
- addi 0, 1, 0x1A0
- Storeglobal(0, caml_bottom_of_stack, 11)
- /* Record pointer to register array */
- addi 0, 1, 8*32 + 32
- Storeglobal(0, caml_gc_regs, 11)
- /* Save current allocation pointer for debugging purposes */
- Storeglobal(31, young_ptr, 11)
- /* Save exception pointer (if e.g. a sighandler raises) */
- Storeglobal(29, caml_exception_pointer, 11)
- /* Save all registers used by the code generator */
- addi 11, 1, 8*32 + 32 - 4
- stwu 3, 4(11)
- stwu 4, 4(11)
- stwu 5, 4(11)
- stwu 6, 4(11)
- stwu 7, 4(11)
- stwu 8, 4(11)
- stwu 9, 4(11)
- stwu 10, 4(11)
- stwu 14, 4(11)
- stwu 15, 4(11)
- stwu 16, 4(11)
- stwu 17, 4(11)
- stwu 18, 4(11)
- stwu 19, 4(11)
- stwu 20, 4(11)
- stwu 21, 4(11)
- stwu 22, 4(11)
- stwu 23, 4(11)
- stwu 24, 4(11)
- stwu 25, 4(11)
- stwu 26, 4(11)
- stwu 27, 4(11)
- stwu 28, 4(11)
- addi 11, 1, 32 - 8
- stfdu 1, 8(11)
- stfdu 2, 8(11)
- stfdu 3, 8(11)
- stfdu 4, 8(11)
- stfdu 5, 8(11)
- stfdu 6, 8(11)
- stfdu 7, 8(11)
- stfdu 8, 8(11)
- stfdu 9, 8(11)
- stfdu 10, 8(11)
- stfdu 11, 8(11)
- stfdu 12, 8(11)
- stfdu 13, 8(11)
- stfdu 14, 8(11)
- stfdu 15, 8(11)
- stfdu 16, 8(11)
- stfdu 17, 8(11)
- stfdu 18, 8(11)
- stfdu 19, 8(11)
- stfdu 20, 8(11)
- stfdu 21, 8(11)
- stfdu 22, 8(11)
- stfdu 23, 8(11)
- stfdu 24, 8(11)
- stfdu 25, 8(11)
- stfdu 26, 8(11)
- stfdu 27, 8(11)
- stfdu 28, 8(11)
- stfdu 29, 8(11)
- stfdu 30, 8(11)
- stfdu 31, 8(11)
- /* Call the GC */
- bl garbage_collection
- /* Reload new allocation pointer and allocation limit */
- Loadglobal(31, young_ptr, 11)
- Loadglobal(30, young_limit, 11)
- /* Restore all regs used by the code generator */
- addi 11, 1, 8*32 + 32 - 4
- lwzu 3, 4(11)
- lwzu 4, 4(11)
- lwzu 5, 4(11)
- lwzu 6, 4(11)
- lwzu 7, 4(11)
- lwzu 8, 4(11)
- lwzu 9, 4(11)
- lwzu 10, 4(11)
- lwzu 14, 4(11)
- lwzu 15, 4(11)
- lwzu 16, 4(11)
- lwzu 17, 4(11)
- lwzu 18, 4(11)
- lwzu 19, 4(11)
- lwzu 20, 4(11)
- lwzu 21, 4(11)
- lwzu 22, 4(11)
- lwzu 23, 4(11)
- lwzu 24, 4(11)
- lwzu 25, 4(11)
- lwzu 26, 4(11)
- lwzu 27, 4(11)
- lwzu 28, 4(11)
- addi 11, 1, 32 - 8
- lfdu 1, 8(11)
- lfdu 2, 8(11)
- lfdu 3, 8(11)
- lfdu 4, 8(11)
- lfdu 5, 8(11)
- lfdu 6, 8(11)
- lfdu 7, 8(11)
- lfdu 8, 8(11)
- lfdu 9, 8(11)
- lfdu 10, 8(11)
- lfdu 11, 8(11)
- lfdu 12, 8(11)
- lfdu 13, 8(11)
- lfdu 14, 8(11)
- lfdu 15, 8(11)
- lfdu 16, 8(11)
- lfdu 17, 8(11)
- lfdu 18, 8(11)
- lfdu 19, 8(11)
- lfdu 20, 8(11)
- lfdu 21, 8(11)
- lfdu 22, 8(11)
- lfdu 23, 8(11)
- lfdu 24, 8(11)
- lfdu 25, 8(11)
- lfdu 26, 8(11)
- lfdu 27, 8(11)
- lfdu 28, 8(11)
- lfdu 29, 8(11)
- lfdu 30, 8(11)
- lfdu 31, 8(11)
- /* Return to caller, restarting the allocation */
- Loadglobal(0, caml_last_return_address, 11)
- addic 0, 0, -16 /* Restart the allocation (4 instructions) */
- mtlr 0
- /* Say we are back into Caml code */
- li 12, 0
- Storeglobal(12, caml_last_return_address, 11)
- /* Deallocate stack frame */
- addi 1, 1, 0x1A0
- /* Return */
- blr
-
-/* Call a C function from Caml */
-
- .globl caml_c_call
- .type caml_c_call, @function
-caml_c_call:
- /* Save return address */
- mflr 25
- /* Get ready to call C function (address in 11) */
- mtlr 11
- /* Record lowest stack address and return address */
- Storeglobal(1, caml_bottom_of_stack, 12)
- Storeglobal(25, caml_last_return_address, 12)
- /* Make the exception handler and alloc ptr available to the C code */
- Storeglobal(31, young_ptr, 11)
- Storeglobal(29, caml_exception_pointer, 11)
- /* Call the function (address in link register) */
- blrl
- /* Restore return address (in 25, preserved by the C function) */
- mtlr 25
- /* Reload allocation pointer and allocation limit*/
- Loadglobal(31, young_ptr, 11)
- Loadglobal(30, young_limit, 11)
- /* Say we are back into Caml code */
- li 12, 0
- Storeglobal(12, caml_last_return_address, 11)
- /* Return to caller */
- blr
-
-/* Raise an exception from C */
-
- .globl raise_caml_exception
- .type raise_caml_exception, @function
-raise_caml_exception:
- /* Reload Caml global registers */
- Loadglobal(1, caml_exception_pointer, 11)
- Loadglobal(31, young_ptr, 11)
- Loadglobal(30, young_limit, 11)
- /* Say we are back into Caml code */
- li 0, 0
- Storeglobal(0, caml_last_return_address, 11)
- /* Pop trap frame */
- lwz 0, 0(1)
- lwz 29, 4(1)
- mtlr 0
- addi 1, 1, 16
- /* Branch to handler */
- blr
-
-/* Start the Caml program */
-
- .globl caml_start_program
- .type caml_start_program, @function
-caml_start_program:
- Addrglobal(12, caml_program)
-
-/* Code shared between caml_start_program and callback */
-.L102:
- /* Allocate and link stack frame */
- stwu 1, -256(1)
- /* Save return address */
- mflr 0
- stw 0, 256+4(1)
- /* Save all callee-save registers */
- /* GPR 14 at sp+16 ... GPR 31 at sp+84
- FPR 14 at sp+92 ... FPR 31 at sp+228 */
- addi 11, 1, 16-4
- stwu 14, 4(11)
- stwu 15, 4(11)
- stwu 16, 4(11)
- stwu 17, 4(11)
- stwu 18, 4(11)
- stwu 19, 4(11)
- stwu 20, 4(11)
- stwu 21, 4(11)
- stwu 22, 4(11)
- stwu 23, 4(11)
- stwu 24, 4(11)
- stwu 25, 4(11)
- stwu 26, 4(11)
- stwu 27, 4(11)
- stwu 28, 4(11)
- stwu 29, 4(11)
- stwu 30, 4(11)
- stwu 31, 4(11)
- stfdu 14, 8(11)
- stfdu 15, 8(11)
- stfdu 16, 8(11)
- stfdu 17, 8(11)
- stfdu 18, 8(11)
- stfdu 19, 8(11)
- stfdu 20, 8(11)
- stfdu 21, 8(11)
- stfdu 22, 8(11)
- stfdu 23, 8(11)
- stfdu 24, 8(11)
- stfdu 25, 8(11)
- stfdu 26, 8(11)
- stfdu 27, 8(11)
- stfdu 28, 8(11)
- stfdu 29, 8(11)
- stfdu 30, 8(11)
- stfdu 31, 8(11)
- /* Set up a callback link */
- addi 1, 1, -16
- Loadglobal(9, caml_bottom_of_stack, 11)
- Loadglobal(10, caml_last_return_address, 11)
- Loadglobal(11, caml_gc_regs, 11)
- stw 9, 0(1)
- stw 10, 4(1)
- stw 11, 8(1)
- /* Build an exception handler to catch exceptions escaping out of Caml */
- bl .L103
- b .L104
-.L103:
- addi 1, 1, -16
- mflr 0
- stw 0, 0(1)
- Loadglobal(11, caml_exception_pointer, 11)
- stw 11, 4(1)
- mr 29, 1
- /* Reload allocation pointers */
- Loadglobal(31, young_ptr, 11)
- Loadglobal(30, young_limit, 11)
- /* Say we are back into Caml code */
- li 0, 0
- Storeglobal(0, caml_last_return_address, 11)
- /* Call the Caml code */
- mtlr 12
-.L105:
- blrl
- /* Pop the trap frame, restoring caml_exception_pointer */
- lwz 9, 4(1)
- Storeglobal(9, caml_exception_pointer, 11)
- addi 1, 1, 16
- /* Pop the callback link, restoring the global variables */
-.L106:
- lwz 9, 0(1)
- lwz 10, 4(1)
- lwz 11, 8(1)
- Storeglobal(9, caml_bottom_of_stack, 12)
- Storeglobal(10, caml_last_return_address, 12)
- Storeglobal(11, caml_gc_regs, 12)
- addi 1, 1, 16
- /* Update allocation pointer */
- Storeglobal(31, young_ptr, 11)
- /* Restore callee-save registers */
- addi 11, 1, 16-4
- lwzu 14, 4(11)
- lwzu 15, 4(11)
- lwzu 16, 4(11)
- lwzu 17, 4(11)
- lwzu 18, 4(11)
- lwzu 19, 4(11)
- lwzu 20, 4(11)
- lwzu 21, 4(11)
- lwzu 22, 4(11)
- lwzu 23, 4(11)
- lwzu 24, 4(11)
- lwzu 25, 4(11)
- lwzu 26, 4(11)
- lwzu 27, 4(11)
- lwzu 28, 4(11)
- lwzu 29, 4(11)
- lwzu 30, 4(11)
- lwzu 31, 4(11)
- lfdu 14, 8(11)
- lfdu 15, 8(11)
- lfdu 16, 8(11)
- lfdu 17, 8(11)
- lfdu 18, 8(11)
- lfdu 19, 8(11)
- lfdu 20, 8(11)
- lfdu 21, 8(11)
- lfdu 22, 8(11)
- lfdu 23, 8(11)
- lfdu 24, 8(11)
- lfdu 25, 8(11)
- lfdu 26, 8(11)
- lfdu 27, 8(11)
- lfdu 28, 8(11)
- lfdu 29, 8(11)
- lfdu 30, 8(11)
- lfdu 31, 8(11)
- /* Reload return address */
- lwz 0, 256+4(1)
- mtlr 0
- /* Return */
- addi 1, 1, 256
- blr
-
- /* The trap handler: */
-.L104:
- /* Update caml_exception_pointer */
- Storeglobal(29, caml_exception_pointer, 11)
- /* Encode exception bucket as an exception result and return it */
- ori 3, 3, 2
- b .L106
-
-/* Callback from C to Caml */
-
- .globl callback_exn
- .type callback_exn, @function
-callback_exn:
- /* Initial shuffling of arguments */
- mr 0, 3 /* Closure */
- mr 3, 4 /* Argument */
- mr 4, 0
- lwz 12, 0(4) /* Code pointer */
- b .L102
-
- .globl callback2_exn
- .type callback2_exn, @function
-callback2_exn:
- mr 0, 3 /* Closure */
- mr 3, 4 /* First argument */
- mr 4, 5 /* Second argument */
- mr 5, 0
- Addrglobal(12, caml_apply2)
- b .L102
-
- .globl callback3_exn
- .type callback3_exn, @function
-callback3_exn:
- mr 0, 3 /* Closure */
- mr 3, 4 /* First argument */
- mr 4, 5 /* Second argument */
- mr 5, 6 /* Third argument */
- mr 6, 0
- Addrglobal(12, caml_apply3)
- b .L102
-
-/* Frame table */
-
- .section ".data"
- .globl system__frametable
- .type system__frametable, @object
-system__frametable:
- .long 1 /* one descriptor */
- .long .L105 + 4 /* return address into callback */
- .short -1 /* negative size count => use callback link */
- .short 0 /* no roots here */
-
diff --git a/asmrun/power-rhapsody.S b/asmrun/power-rhapsody.S
deleted file mode 100644
index 0d56983df5..0000000000
--- a/asmrun/power-rhapsody.S
+++ /dev/null
@@ -1,416 +0,0 @@
-/*********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/*********************************************************************/
-
-/* $Id$ */
-
-.macro Addrglobal /* reg, glob */
- addis $0, 0, ha16($1)
- addi $0, $0, lo16($1)
-.endmacro
-.macro Loadglobal /* reg,glob,tmp */
- addis $2, 0, ha16($1)
- lwz $0, lo16($1)($2)
-.endmacro
-.macro Storeglobal /* reg,glob,tmp */
- addis $2, 0, ha16($1)
- stw $0, lo16($1)($2)
-.endmacro
-
- .text
-
-/* Invoke the garbage collector. */
-
- .globl _caml_call_gc
-_caml_call_gc:
- /* Set up stack frame */
- stwu r1, -0x1A0(r1)
- /* 0x1A0 = 4*32 (int regs) + 8*32 (float regs) + 32 (space for C call) */
- /* Record return address into Caml code */
- mflr r0
- Storeglobal r0, _caml_last_return_address, r11
- /* Record lowest stack address */
- addi r0, r1, 0x1A0
- Storeglobal r0, _caml_bottom_of_stack, r11
- /* Record pointer to register array */
- addi r0, r1, 8*32 + 32
- Storeglobal r0, _caml_gc_regs, r11
- /* Save current allocation pointer for debugging purposes */
- Storeglobal r31, _young_ptr, r11
- /* Save exception pointer (if e.g. a sighandler raises) */
- Storeglobal r29, _caml_exception_pointer, r11
- /* Save all registers used by the code generator */
- addi r11, r1, 8*32 + 32 - 4
- stwu r3, 4(r11)
- stwu r4, 4(r11)
- stwu r5, 4(r11)
- stwu r6, 4(r11)
- stwu r7, 4(r11)
- stwu r8, 4(r11)
- stwu r9, 4(r11)
- stwu r10, 4(r11)
- stwu r14, 4(r11)
- stwu r15, 4(r11)
- stwu r16, 4(r11)
- stwu r17, 4(r11)
- stwu r18, 4(r11)
- stwu r19, 4(r11)
- stwu r20, 4(r11)
- stwu r21, 4(r11)
- stwu r22, 4(r11)
- stwu r23, 4(r11)
- stwu r24, 4(r11)
- stwu r25, 4(r11)
- stwu r26, 4(r11)
- stwu r27, 4(r11)
- stwu r28, 4(r11)
- addi r11, r1, 32 - 8
- stfdu f1, 8(r11)
- stfdu f2, 8(r11)
- stfdu f3, 8(r11)
- stfdu f4, 8(r11)
- stfdu f5, 8(r11)
- stfdu f6, 8(r11)
- stfdu f7, 8(r11)
- stfdu f8, 8(r11)
- stfdu f9, 8(r11)
- stfdu f10, 8(r11)
- stfdu f11, 8(r11)
- stfdu f12, 8(r11)
- stfdu f13, 8(r11)
- stfdu f14, 8(r11)
- stfdu f15, 8(r11)
- stfdu f16, 8(r11)
- stfdu f17, 8(r11)
- stfdu f18, 8(r11)
- stfdu f19, 8(r11)
- stfdu f20, 8(r11)
- stfdu f21, 8(r11)
- stfdu f22, 8(r11)
- stfdu f23, 8(r11)
- stfdu f24, 8(r11)
- stfdu f25, 8(r11)
- stfdu f26, 8(r11)
- stfdu f27, 8(r11)
- stfdu f28, 8(r11)
- stfdu f29, 8(r11)
- stfdu f30, 8(r11)
- stfdu f31, 8(r11)
- /* Call the GC */
- bl _garbage_collection
- /* Reload new allocation pointer and allocation limit */
- Loadglobal r31, _young_ptr, r11
- Loadglobal r30, _young_limit, r11
- /* Restore all regs used by the code generator */
- addi r11, r1, 8*32 + 32 - 4
- lwzu r3, 4(r11)
- lwzu r4, 4(r11)
- lwzu r5, 4(r11)
- lwzu r6, 4(r11)
- lwzu r7, 4(r11)
- lwzu r8, 4(r11)
- lwzu r9, 4(r11)
- lwzu r10, 4(r11)
- lwzu r14, 4(r11)
- lwzu r15, 4(r11)
- lwzu r16, 4(r11)
- lwzu r17, 4(r11)
- lwzu r18, 4(r11)
- lwzu r19, 4(r11)
- lwzu r20, 4(r11)
- lwzu r21, 4(r11)
- lwzu r22, 4(r11)
- lwzu r23, 4(r11)
- lwzu r24, 4(r11)
- lwzu r25, 4(r11)
- lwzu r26, 4(r11)
- lwzu r27, 4(r11)
- lwzu r28, 4(r11)
- addi r11, r1, 32 - 8
- lfdu f1, 8(r11)
- lfdu f2, 8(r11)
- lfdu f3, 8(r11)
- lfdu f4, 8(r11)
- lfdu f5, 8(r11)
- lfdu f6, 8(r11)
- lfdu f7, 8(r11)
- lfdu f8, 8(r11)
- lfdu f9, 8(r11)
- lfdu f10, 8(r11)
- lfdu f11, 8(r11)
- lfdu f12, 8(r11)
- lfdu f13, 8(r11)
- lfdu f14, 8(r11)
- lfdu f15, 8(r11)
- lfdu f16, 8(r11)
- lfdu f17, 8(r11)
- lfdu f18, 8(r11)
- lfdu f19, 8(r11)
- lfdu f20, 8(r11)
- lfdu f21, 8(r11)
- lfdu f22, 8(r11)
- lfdu f23, 8(r11)
- lfdu f24, 8(r11)
- lfdu f25, 8(r11)
- lfdu f26, 8(r11)
- lfdu f27, 8(r11)
- lfdu f28, 8(r11)
- lfdu f29, 8(r11)
- lfdu f30, 8(r11)
- lfdu f31, 8(r11)
- /* Return to caller, restarting the allocation */
- Loadglobal r0, _caml_last_return_address, r11
- addic r0, r0, -16 /* Restart the allocation (4 instructions) */
- mtlr r0
- /* Say we are back into Caml code */
- li r12, 0
- Storeglobal r12, _caml_last_return_address, r11
- /* Deallocate stack frame */
- addi r1, r1, 0x1A0
- /* Return */
- blr
-
-/* Call a C function from Caml */
-
- .globl _caml_c_call
-_caml_c_call:
- /* Save return address */
- mflr r25
- /* Get ready to call C function (address in 11) */
- mtlr r11
- /* Record lowest stack address and return address */
- Storeglobal r1, _caml_bottom_of_stack, r12
- Storeglobal r25, _caml_last_return_address, r12
- /* Make the exception handler and alloc ptr available to the C code */
- Storeglobal r31, _young_ptr, r11
- Storeglobal r29, _caml_exception_pointer, r11
- /* Call the function (address in link register) */
- blrl
- /* Restore return address (in 25, preserved by the C function) */
- mtlr r25
- /* Reload allocation pointer and allocation limit*/
- Loadglobal r31, _young_ptr, r11
- Loadglobal r30, _young_limit, r11
- /* Say we are back into Caml code */
- li r12, 0
- Storeglobal r12, _caml_last_return_address, r11
- /* Return to caller */
- blr
-
-/* Raise an exception from C */
-
- .globl _raise_caml_exception
-_raise_caml_exception:
- /* Reload Caml global registers */
- Loadglobal r1, _caml_exception_pointer, r11
- Loadglobal r31, _young_ptr, r11
- Loadglobal r30, _young_limit, r11
- /* Say we are back into Caml code */
- li r0, 0
- Storeglobal r0, _caml_last_return_address, r11
- /* Pop trap frame */
- lwz r0, 0(r1)
- lwz r29, 4(r1)
- mtlr r0
- addi r1, r1, 16
- /* Branch to handler */
- blr
-
-/* Start the Caml program */
-
- .globl _caml_start_program
-_caml_start_program:
- Addrglobal r12, _caml_program
-
-/* Code shared between caml_start_program and callback */
-L102:
- /* Allocate and link stack frame */
- stwu r1, -256(r1)
- /* Save return address */
- mflr r0
- stw r0, 256+4(r1)
- /* Save all callee-save registers */
- /* GPR 14 at sp+16 ... GPR 31 at sp+84
- FPR 14 at sp+92 ... FPR 31 at sp+228 */
- addi r11, r1, 16-4
- stwu r14, 4(r11)
- stwu r15, 4(r11)
- stwu r16, 4(r11)
- stwu r17, 4(r11)
- stwu r18, 4(r11)
- stwu r19, 4(r11)
- stwu r20, 4(r11)
- stwu r21, 4(r11)
- stwu r22, 4(r11)
- stwu r23, 4(r11)
- stwu r24, 4(r11)
- stwu r25, 4(r11)
- stwu r26, 4(r11)
- stwu r27, 4(r11)
- stwu r28, 4(r11)
- stwu r29, 4(r11)
- stwu r30, 4(r11)
- stwu r31, 4(r11)
- stfdu f14, 8(r11)
- stfdu f15, 8(r11)
- stfdu f16, 8(r11)
- stfdu f17, 8(r11)
- stfdu f18, 8(r11)
- stfdu f19, 8(r11)
- stfdu f20, 8(r11)
- stfdu f21, 8(r11)
- stfdu f22, 8(r11)
- stfdu f23, 8(r11)
- stfdu f24, 8(r11)
- stfdu f25, 8(r11)
- stfdu f26, 8(r11)
- stfdu f27, 8(r11)
- stfdu f28, 8(r11)
- stfdu f29, 8(r11)
- stfdu f30, 8(r11)
- stfdu f31, 8(r11)
- /* Set up a callback link */
- addi r1, r1, -16
- Loadglobal r9, _caml_bottom_of_stack, r11
- Loadglobal r10, _caml_last_return_address, r11
- Loadglobal r11, _caml_gc_regs, r11
- stw r9, 0(r1)
- stw r10, 4(r1)
- stw r11, 8(r1)
- /* Build an exception handler to catch exceptions escaping out of Caml */
- bl L103
- b L104
-L103:
- addi r1, r1, -16
- mflr r0
- stw r0, 0(r1)
- Loadglobal r11, _caml_exception_pointer, r11
- stw r11, 4(r1)
- mr r29, r1
- /* Reload allocation pointers */
- Loadglobal r31, _young_ptr, r11
- Loadglobal r30, _young_limit, r11
- /* Say we are back into Caml code */
- li r0, 0
- Storeglobal r0, _caml_last_return_address, r11
- /* Call the Caml code */
- mtlr r12
-L105:
- blrl
- /* Pop the trap frame, restoring caml_exception_pointer */
- lwz r9, 4(r1)
- Storeglobal r9, _caml_exception_pointer, r11
- addi r1, r1, 16
- /* Pop the callback link, restoring the global variables */
-L106:
- lwz r9, 0(r1)
- lwz r10, 4(r1)
- lwz r11, 8(r1)
- Storeglobal r9, _caml_bottom_of_stack, r12
- Storeglobal r10, _caml_last_return_address, r12
- Storeglobal r11, _caml_gc_regs, r12
- addi r1, r1, 16
- /* Update allocation pointer */
- Storeglobal r31, _young_ptr, r11
- /* Restore callee-save registers */
- addi r11, r1, 16-4
- lwzu r14, 4(r11)
- lwzu r15, 4(r11)
- lwzu r16, 4(r11)
- lwzu r17, 4(r11)
- lwzu r18, 4(r11)
- lwzu r19, 4(r11)
- lwzu r20, 4(r11)
- lwzu r21, 4(r11)
- lwzu r22, 4(r11)
- lwzu r23, 4(r11)
- lwzu r24, 4(r11)
- lwzu r25, 4(r11)
- lwzu r26, 4(r11)
- lwzu r27, 4(r11)
- lwzu r28, 4(r11)
- lwzu r29, 4(r11)
- lwzu r30, 4(r11)
- lwzu r31, 4(r11)
- lfdu f14, 8(r11)
- lfdu f15, 8(r11)
- lfdu f16, 8(r11)
- lfdu f17, 8(r11)
- lfdu f18, 8(r11)
- lfdu f19, 8(r11)
- lfdu f20, 8(r11)
- lfdu f21, 8(r11)
- lfdu f22, 8(r11)
- lfdu f23, 8(r11)
- lfdu f24, 8(r11)
- lfdu f25, 8(r11)
- lfdu f26, 8(r11)
- lfdu f27, 8(r11)
- lfdu f28, 8(r11)
- lfdu f29, 8(r11)
- lfdu f30, 8(r11)
- lfdu f31, 8(r11)
- /* Reload return address */
- lwz r0, 256+4(r1)
- mtlr r0
- /* Return */
- addi r1, r1, 256
- blr
-
- /* The trap handler: */
-L104:
- /* Update caml_exception_pointer */
- Storeglobal r29, _caml_exception_pointer, r11
- /* Encode exception bucket as an exception result and return it */
- ori r3, r3, 2
- b L106
-
-/* Callback from C to Caml */
-
- .globl _callback_exn
-_callback_exn:
- /* Initial shuffling of arguments */
- mr r0, r3 /* Closure */
- mr r3, r4 /* Argument */
- mr r4, r0
- lwz r12, 0(r4) /* Code pointer */
- b L102
-
- .globl _callback2_exn
-_callback2_exn:
- mr r0, r3 /* Closure */
- mr r3, r4 /* First argument */
- mr r4, r5 /* Second argument */
- mr r5, r0
- Addrglobal r12, _caml_apply2
- b L102
-
- .globl _callback3_exn
-_callback3_exn:
- mr r0, r3 /* Closure */
- mr r3, r4 /* First argument */
- mr r4, r5 /* Second argument */
- mr r5, r6 /* Third argument */
- mr r6, r0
- Addrglobal r12, _caml_apply3
- b L102
-
-/* Frame table */
-
- .const
- .globl _system__frametable
-_system__frametable:
- .long 1 /* one descriptor */
- .long L105 + 4 /* return address into callback */
- .short -1 /* negative size count => use callback link */
- .short 0 /* no roots here */
-
diff --git a/asmrun/roots.c b/asmrun/roots.c
deleted file mode 100644
index f56ebf150b..0000000000
--- a/asmrun/roots.c
+++ /dev/null
@@ -1,297 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* To walk the memory roots for garbage collection */
-
-#include "finalise.h"
-#include "globroots.h"
-#include "memory.h"
-#include "major_gc.h"
-#include "minor_gc.h"
-#include "misc.h"
-#include "mlvalues.h"
-#include "stack.h"
-#include "roots.h"
-
-/* Roots registered from C functions */
-
-struct caml__roots_block *local_roots = NULL;
-
-void (*scan_roots_hook) (scanning_action) = NULL;
-
-/* The hashtable of frame descriptors */
-
-typedef struct {
- unsigned long retaddr;
- short frame_size;
- short num_live;
- short live_ofs[1];
-} frame_descr;
-
-static frame_descr ** frame_descriptors = NULL;
-static int frame_descriptors_mask;
-
-#define Hash_retaddr(addr) \
- (((unsigned long)(addr) >> 3) & frame_descriptors_mask)
-
-static void init_frame_descriptors(void)
-{
- long num_descr, tblsize, i, j, len;
- long * tbl;
- frame_descr * d;
- unsigned long h;
-
- /* Count the frame descriptors */
- num_descr = 0;
- for (i = 0; caml_frametable[i] != 0; i++)
- num_descr += *(caml_frametable[i]);
-
- /* The size of the hashtable is a power of 2 greater or equal to
- 2 times the number of descriptors */
- tblsize = 4;
- while (tblsize < 2 * num_descr) tblsize *= 2;
-
- /* Allocate the hash table */
- frame_descriptors =
- (frame_descr **) stat_alloc(tblsize * sizeof(frame_descr *));
- for (i = 0; i < tblsize; i++) frame_descriptors[i] = NULL;
- frame_descriptors_mask = tblsize - 1;
-
- /* Fill the hash table */
- for (i = 0; caml_frametable[i] != 0; i++) {
- tbl = caml_frametable[i];
- len = *tbl;
- d = (frame_descr *)(tbl + 1);
- for (j = 0; j < len; j++) {
- h = Hash_retaddr(d->retaddr);
- while (frame_descriptors[h] != NULL) {
- h = (h+1) & frame_descriptors_mask;
- }
- frame_descriptors[h] = d;
- d = (frame_descr *)
- (((unsigned long)d +
- sizeof(char *) + sizeof(short) + sizeof(short) +
- sizeof(short) * d->num_live + sizeof(frame_descr *) - 1)
- & -sizeof(frame_descr *));
- }
- }
-}
-
-/* Communication with [caml_start_program] and [caml_call_gc]. */
-
-char * caml_bottom_of_stack = NULL; /* no stack initially */
-unsigned long caml_last_return_address = 1; /* not in Caml code initially */
-value * caml_gc_regs;
-long caml_globals_inited = 0;
-static long caml_globals_scanned = 0;
-
-/* Call [oldify_one] on (at least) all the roots that point to the minor
- heap. */
-void oldify_local_roots (void)
-{
- char * sp;
- unsigned long retaddr;
- value * regs;
- frame_descr * d;
- unsigned long h;
- int i, j, n, ofs;
- short * p;
- value glob;
- value * root;
- struct global_root * gr;
- struct caml__roots_block *lr;
-
- /* The global roots */
- for (i = caml_globals_scanned;
- i <= caml_globals_inited && caml_globals[i] != 0;
- i++) {
- glob = caml_globals[i];
- for (j = 0; j < Wosize_val(glob); j++){
- Oldify (&Field (glob, j));
- }
- }
- caml_globals_scanned = caml_globals_inited;
-
- /* The stack and local roots */
- if (frame_descriptors == NULL) init_frame_descriptors();
- sp = caml_bottom_of_stack;
- retaddr = caml_last_return_address;
- regs = caml_gc_regs;
- if (sp != NULL) {
- while (1) {
- /* Find the descriptor corresponding to the return address */
- h = Hash_retaddr(retaddr);
- while(1) {
- d = frame_descriptors[h];
- if (d->retaddr == retaddr) break;
- h = (h+1) & frame_descriptors_mask;
- }
- if (d->frame_size >= 0) {
- /* Scan the roots in this frame */
- for (p = d->live_ofs, n = d->num_live; n > 0; n--, p++) {
- ofs = *p;
- if (ofs & 1) {
- root = regs + (ofs >> 1);
- } else {
- root = (value *)(sp + ofs);
- }
- Oldify (root);
- }
- /* Move to next frame */
-#ifndef Stack_grows_upwards
- sp += d->frame_size;
-#else
- sp -= d->frame_size;
-#endif
- retaddr = Saved_return_address(sp);
-#ifdef Already_scanned
- /* Stop here if the frame has been scanned during earlier GCs */
- if (Already_scanned(sp, retaddr)) break;
- /* Mark frame as already scanned */
- Mark_scanned(sp, retaddr);
-#endif
- } else {
- /* This marks the top of a stack chunk for an ML callback.
- Skip C portion of stack and continue with next ML stack chunk. */
- struct caml_context * next_context = Callback_link(sp);
- sp = next_context->bottom_of_stack;
- retaddr = next_context->last_retaddr;
- regs = next_context->gc_regs;
- /* A null sp means no more ML stack chunks; stop here. */
- if (sp == NULL) break;
- }
- }
- }
- /* Local C roots */
- for (lr = local_roots; lr != NULL; lr = lr->next) {
- for (i = 0; i < lr->ntables; i++){
- for (j = 0; j < lr->nitems; j++){
- root = &(lr->tables[i][j]);
- Oldify (root);
- }
- }
- }
- /* Global C roots */
- for (gr = caml_global_roots.forward[0]; gr != NULL; gr = gr->forward[0]) {
- Oldify (gr->root);
- }
- /* Finalised values */
- final_do_young_roots (&oldify_one);
- /* Hook */
- if (scan_roots_hook != NULL) (*scan_roots_hook)(oldify_one);
-}
-
-/* Call [darken] on all roots */
-
-void darken_all_roots (void)
-{
- do_roots (darken);
-}
-
-void do_roots (scanning_action f)
-{
- int i, j;
- value glob;
- struct global_root * gr;
-
- /* The global roots */
- for (i = 0; caml_globals[i] != 0; i++) {
- glob = caml_globals[i];
- for (j = 0; j < Wosize_val(glob); j++)
- f (Field (glob, j), &Field (glob, j));
- }
- /* The stack and local roots */
- if (frame_descriptors == NULL) init_frame_descriptors();
- do_local_roots(f, caml_bottom_of_stack, caml_last_return_address,
- caml_gc_regs, local_roots);
- /* Global C roots */
- for (gr = caml_global_roots.forward[0]; gr != NULL; gr = gr->forward[0]) {
- f(*(gr->root), gr->root);
- }
- /* Finalised values */
- final_do_strong_roots (f);
- /* Hook */
- if (scan_roots_hook != NULL) (*scan_roots_hook)(f);
-}
-
-void do_local_roots(scanning_action f, char * bottom_of_stack,
- unsigned long last_retaddr, value * gc_regs,
- struct caml__roots_block * local_roots)
-{
- char * sp;
- unsigned long retaddr;
- value * regs;
- frame_descr * d;
- unsigned long h;
- int i, j, n, ofs;
- short * p;
- value * root;
- struct caml__roots_block *lr;
-
- sp = bottom_of_stack;
- retaddr = last_retaddr;
- regs = gc_regs;
- if (sp != NULL) {
- while (1) {
- /* Find the descriptor corresponding to the return address */
- h = Hash_retaddr(retaddr);
- while(1) {
- d = frame_descriptors[h];
- if (d->retaddr == retaddr) break;
- h = (h+1) & frame_descriptors_mask;
- }
- if (d->frame_size >= 0) {
- /* Scan the roots in this frame */
- for (p = d->live_ofs, n = d->num_live; n > 0; n--, p++) {
- ofs = *p;
- if (ofs & 1) {
- root = regs + (ofs >> 1);
- } else {
- root = (value *)(sp + ofs);
- }
- f (*root, root);
- }
- /* Move to next frame */
-#ifndef Stack_grows_upwards
- sp += d->frame_size;
-#else
- sp -= d->frame_size;
-#endif
- retaddr = Saved_return_address(sp);
-#ifdef Mask_already_scanned
- retaddr = Mask_already_scanned(retaddr);
-#endif
- } else {
- /* This marks the top of a stack chunk for an ML callback.
- Skip C portion of stack and continue with next ML stack chunk. */
- struct caml_context * next_context = Callback_link(sp);
- sp = next_context->bottom_of_stack;
- retaddr = next_context->last_retaddr;
- regs = next_context->gc_regs;
- /* A null sp means no more ML stack chunks; stop here. */
- if (sp == NULL) break;
- }
- }
- }
- /* Local C roots */
- for (lr = local_roots; lr != NULL; lr = lr->next) {
- for (i = 0; i < lr->ntables; i++){
- for (j = 0; j < lr->nitems; j++){
- root = &(lr->tables[i][j]);
- f (*root, root);
- }
- }
- }
-}
diff --git a/asmrun/signals.c b/asmrun/signals.c
deleted file mode 100644
index c05e9c73f0..0000000000
--- a/asmrun/signals.c
+++ /dev/null
@@ -1,677 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <signal.h>
-#include <stdio.h>
-#if defined(TARGET_sparc) && defined(SYS_solaris)
-#include <ucontext.h>
-#endif
-#include "alloc.h"
-#include "callback.h"
-#include "memory.h"
-#include "minor_gc.h"
-#include "misc.h"
-#include "mlvalues.h"
-#include "fail.h"
-#include "signals.h"
-#include "stack.h"
-#include "sys.h"
-#ifdef HAS_STACK_OVERFLOW_DETECTION
-#include <sys/time.h>
-#include <sys/resource.h>
-#endif
-
-extern char * code_area_start, * code_area_end;
-
-#define In_code_area(pc) \
- ((char *)(pc) >= code_area_start && (char *)(pc) <= code_area_end)
-
-#ifdef _WIN32
-typedef void (*sighandler)(int sig);
-extern sighandler win32_signal(int sig, sighandler action);
-#define signal(sig,act) win32_signal(sig,act)
-#endif
-
-#if defined(TARGET_power) && defined(SYS_rhapsody)
-
- #include <sys/utsname.h>
-
- #define STRUCT_SIGCONTEXT void
- #define CONTEXT_GPR(ctx, regno) (*context_gpr_p ((ctx), (regno)))
- #define CONTEXT_PC(ctx) CONTEXT_GPR ((ctx), -2)
- static int ctx_version = 0;
- static void init_ctx (void)
- {
- struct utsname name;
- if (uname (&name) == 0){
- if (name.release[1] == '.' && name.release[0] <= '5'){
- ctx_version = 1;
- }else{
- ctx_version = 2;
- }
- }else{
- fatal_error ("cannot determine SIGCONTEXT format");
- }
- }
-
- #ifdef DARWIN_VERSION_6
- #include <sys/ucontext.h>
- static unsigned long *context_gpr_p (void *ctx, int regno)
- {
- unsigned long *regs;
- if (ctx_version == 0) init_ctx ();
- if (ctx_version == 1){
- /* old-style context (10.0 and 10.1) */
- regs = (unsigned long *)(((struct sigcontext *)ctx)->sc_regs);
- }else{
- Assert (ctx_version == 2);
- /* new-style context (10.2) */
- regs = (unsigned long *)&(((struct ucontext *)ctx)->uc_mcontext->ss);
- }
- return &(regs[2 + regno]);
- }
- #else
- #define SA_SIGINFO 0x0040
- struct ucontext {
- int uc_onstack;
- sigset_t uc_sigmask;
- struct sigaltstack uc_stack;
- struct ucontext *uc_link;
- size_t uc_mcsize;
- unsigned long *uc_mcontext;
- };
- static unsigned long *context_gpr_p (void *ctx, int regno)
- {
- unsigned long *regs;
- if (ctx_version == 0) init_ctx ();
- if (ctx_version == 1){
- /* old-style context (10.0 and 10.1) */
- regs = (unsigned long *)(((struct sigcontext *)ctx)->sc_regs);
- }else{
- Assert (ctx_version == 2);
- /* new-style context (10.2) */
- regs = (unsigned long *)((struct ucontext *)ctx)->uc_mcontext + 8;
- }
- return &(regs[2 + regno]);
- }
- #endif
-#endif
-
-#if defined(TARGET_power) && defined(SYS_aix)
-#ifdef _AIXVERSION_430
-#define STRUCT_SIGCONTEXT struct __sigcontext
-#define CONTEXT_GPR(ctx, regno) \
- ((ctx)->__sc_jmpbuf.__jmp_context.__gpr[(regno)])
-#else
-#define STRUCT_SIGCONTEXT struct sigcontext
-#define CONTEXT_GPR(ctx, regno) \
- ((ctx)->sc_jmpbuf.jmp_context.gpr[(regno)])
-#endif
-#endif
-
-volatile int async_signal_mode = 0;
-volatile int pending_signal = 0;
-volatile int force_major_slice = 0;
-value signal_handlers = 0;
-void (*enter_blocking_section_hook)() = NULL;
-void (*leave_blocking_section_hook)() = NULL;
-
-static int rev_convert_signal_number(int signo);
-
-/* Execute a signal handler immediately. */
-
-void execute_signal(int signal_number, int in_signal_handler)
-{
- value res;
-#ifdef POSIX_SIGNALS
- sigset_t sigs;
- /* Block the signal before executing the handler, and record in sigs
- the original signal mask */
- sigemptyset(&sigs);
- sigaddset(&sigs, signal_number);
- sigprocmask(SIG_BLOCK, &sigs, &sigs);
-#endif
- res = callback_exn(Field(signal_handlers, signal_number),
- Val_int(rev_convert_signal_number(signal_number)));
-#ifdef POSIX_SIGNALS
- if (! in_signal_handler) {
- /* Restore the original signal mask */
- sigprocmask(SIG_SETMASK, &sigs, NULL);
- } else if (Is_exception_result(res)) {
- /* Restore the original signal mask and unblock the signal itself */
- sigdelset(&sigs, signal_number);
- sigprocmask(SIG_SETMASK, &sigs, NULL);
- }
-#endif
- if (Is_exception_result(res)) mlraise(Extract_exception(res));
-}
-
-/* This routine is the common entry point for garbage collection
- and signal handling. It can trigger a callback to Caml code.
- With system threads, this callback can cause a context switch.
- Hence [garbage_collection] must not be called from regular C code
- (e.g. the [alloc] function) because the context of the call
- (e.g. [intern_val]) may not allow context switching.
- Only generated assembly code can call [garbage_collection],
- via the caml_call_gc assembly stubs. */
-
-void garbage_collection(void)
-{
- int sig;
-
- if (young_ptr < young_start || force_major_slice) minor_collection();
- /* If a signal arrives between the following two instructions,
- it will be lost. */
- sig = pending_signal;
- pending_signal = 0;
- young_limit = young_start;
- if (sig) execute_signal(sig, 0);
-}
-
-/* Trigger a garbage collection as soon as possible */
-
-void urge_major_slice (void)
-{
- force_major_slice = 1;
- young_limit = young_end;
- /* This is only moderately effective on ports that cache young_limit
- in a register, since modify() is called directly, not through
- caml_c_call, so it may take a while before the register is reloaded
- from young_limit. */
-}
-
-void enter_blocking_section(void)
-{
- int sig;
-
- while (1){
- Assert (!async_signal_mode);
- /* If a signal arrives between the next two instructions,
- it will be lost. */
- sig = pending_signal;
- pending_signal = 0;
- young_limit = young_start;
- if (sig) execute_signal(sig, 0);
- async_signal_mode = 1;
- if (!pending_signal) break;
- async_signal_mode = 0;
- }
- if (enter_blocking_section_hook != NULL) enter_blocking_section_hook();
-}
-
-void leave_blocking_section(void)
-{
- if (leave_blocking_section_hook != NULL) leave_blocking_section_hook();
- Assert(async_signal_mode);
- async_signal_mode = 0;
-}
-
-#ifdef POSIX_SIGNALS
-static void reraise(int sig, int now)
-{
- struct sigaction sa;
- sa.sa_handler = 0;
- sa.sa_flags = 0;
- sigemptyset(&sa.sa_mask);
- sigaction(sig, &sa, 0);
- /* If the signal was sent using kill() (si_code == 0) or will
- not recur then raise it here. Otherwise return. The
- offending instruction will be reexecuted and the signal
- will recur. */
- if (now == 1)
- raise(sig);
- return;
-}
-#endif
-
-#if defined(TARGET_alpha) || defined(TARGET_mips)
-void handle_signal(int sig, int code, struct sigcontext * context)
-#elif defined(TARGET_power) && defined(SYS_aix)
-void handle_signal(int sig, int code, STRUCT_SIGCONTEXT * context)
-#elif defined(TARGET_power) && defined(SYS_elf)
-void handle_signal(int sig, struct sigcontext * context)
-#elif defined(TARGET_power) && defined(SYS_rhapsody)
-void handle_signal(int sig, int code, STRUCT_SIGCONTEXT * context)
-#elif defined(TARGET_power) && defined(SYS_bsd)
-void handle_signal(int sig, int code, struct sigcontext * context)
-#elif defined(TARGET_sparc) && defined(SYS_solaris)
-void handle_signal(int sig, int code, void * context)
-#else
-void handle_signal(int sig)
-#endif
-{
-#if !defined(POSIX_SIGNALS) && !defined(BSD_SIGNALS)
- signal(sig, handle_signal);
-#endif
- if (async_signal_mode) {
- /* We are interrupting a C function blocked on I/O.
- Callback the Caml code immediately. */
- leave_blocking_section();
- execute_signal(sig, 1);
- enter_blocking_section();
- } else {
- /* We can't execute the signal code immediately.
- Instead, we remember the signal and play with the allocation limit
- so that the next allocation will trigger a garbage collection. */
- pending_signal = sig;
- young_limit = young_end;
- /* Some ports cache young_limit in a register.
- Use the signal context to modify that register too, but only if
- we are inside Caml code (not inside C code). */
-#if defined(TARGET_alpha)
- if (In_code_area(context->sc_pc)) {
- /* Cached in register $14 */
- context->sc_regs[14] = (long) young_limit;
- }
-#endif
-#if defined(TARGET_mips)
- if (In_code_area(context->sc_pc)) {
- /* Cached in register $23 */
- context->sc_regs[23] = (int) young_limit;
- }
-#endif
-#if defined(TARGET_power) && defined(SYS_aix)
- if (caml_last_return_address == 0) {
- /* Cached in register 30 */
- CONTEXT_GPR(context, 30) = (ulong_t) young_limit;
- }
-#endif
-#if defined(TARGET_power) && defined(SYS_elf)
- if (caml_last_return_address == 0) {
- /* Cached in register 30 */
- context->regs->gpr[30] = (unsigned long) young_limit;
- }
-#endif
-#if defined(TARGET_power) && defined(SYS_rhapsody)
- if (In_code_area(CONTEXT_PC(context))) {
- /* Cached in register 30 */
- CONTEXT_GPR(context, 30) = (unsigned long) young_limit;
- }
-#endif
-#if defined(TARGET_power) && defined(SYS_bsd)
- if (caml_last_return_address == 0) {
- /* Cached in register 30 */
- context->sc_frame.fixreg[30] = (unsigned long) young_limit;
- }
-#endif
-#if defined(TARGET_sparc) && defined(SYS_solaris)
- { greg_t * gregs = ((ucontext_t *)context)->uc_mcontext.gregs;
- if (In_code_area(gregs[REG_PC])) {
- /* Cached in register l7, which is saved on the stack 7 words
- after the stack pointer. */
- ((long *)(gregs[REG_SP]))[7] = (long) young_limit;
- }
- }
-#endif
- }
-}
-
-#ifndef SIGABRT
-#define SIGABRT -1
-#endif
-#ifndef SIGALRM
-#define SIGALRM -1
-#endif
-#ifndef SIGFPE
-#define SIGFPE -1
-#endif
-#ifndef SIGHUP
-#define SIGHUP -1
-#endif
-#ifndef SIGILL
-#define SIGILL -1
-#endif
-#ifndef SIGINT
-#define SIGINT -1
-#endif
-#ifndef SIGKILL
-#define SIGKILL -1
-#endif
-#ifndef SIGPIPE
-#define SIGPIPE -1
-#endif
-#ifndef SIGQUIT
-#define SIGQUIT -1
-#endif
-#ifndef SIGSEGV
-#define SIGSEGV -1
-#endif
-#ifndef SIGTERM
-#define SIGTERM -1
-#endif
-#ifndef SIGUSR1
-#define SIGUSR1 -1
-#endif
-#ifndef SIGUSR2
-#define SIGUSR2 -1
-#endif
-#ifndef SIGCHLD
-#define SIGCHLD -1
-#endif
-#ifndef SIGCONT
-#define SIGCONT -1
-#endif
-#ifndef SIGSTOP
-#define SIGSTOP -1
-#endif
-#ifndef SIGTSTP
-#define SIGTSTP -1
-#endif
-#ifndef SIGTTIN
-#define SIGTTIN -1
-#endif
-#ifndef SIGTTOU
-#define SIGTTOU -1
-#endif
-#ifndef SIGVTALRM
-#define SIGVTALRM -1
-#endif
-#ifndef SIGPROF
-#define SIGPROF -1
-#endif
-
-static int posix_signals[] = {
- SIGABRT, SIGALRM, SIGFPE, SIGHUP, SIGILL, SIGINT, SIGKILL, SIGPIPE,
- SIGQUIT, SIGSEGV, SIGTERM, SIGUSR1, SIGUSR2, SIGCHLD, SIGCONT,
- SIGSTOP, SIGTSTP, SIGTTIN, SIGTTOU, SIGVTALRM, SIGPROF
-};
-
-int convert_signal_number(int signo)
-{
- if (signo < 0 && signo >= -(sizeof(posix_signals) / sizeof(int)))
- return posix_signals[-signo-1];
- else
- return signo;
-}
-
-static int rev_convert_signal_number(int signo)
-{
- int i;
- for (i = 0; i < sizeof(posix_signals) / sizeof(int); i++)
- if (signo == posix_signals[i]) return -i - 1;
- return signo;
-}
-
-#ifndef NSIG
-#define NSIG 64
-#endif
-
-value install_signal_handler(value signal_number, value action) /* ML */
-{
- CAMLparam2 (signal_number, action);
- int sig;
- void (*act)(int signo), (*oldact)(int signo);
-#ifdef POSIX_SIGNALS
- struct sigaction sigact, oldsigact;
-#endif
- CAMLlocal1 (res);
-
- sig = convert_signal_number(Int_val(signal_number));
- if (sig < 0 || sig >= NSIG)
- invalid_argument("Sys.signal: unavailable signal");
- switch(action) {
- case Val_int(0): /* Signal_default */
- act = SIG_DFL;
- break;
- case Val_int(1): /* Signal_ignore */
- act = SIG_IGN;
- break;
- default: /* Signal_handle */
- act = (void (*)(int)) handle_signal;
- break;
- }
-#ifdef POSIX_SIGNALS
- sigact.sa_handler = act;
- sigemptyset(&sigact.sa_mask);
-#if defined(SYS_solaris) || defined(SYS_rhapsody)
- sigact.sa_flags = SA_SIGINFO;
-#else
- sigact.sa_flags = 0;
-#endif
- if (sigaction(sig, &sigact, &oldsigact) == -1) sys_error(NO_ARG);
- oldact = oldsigact.sa_handler;
-#else
- oldact = signal(sig, act);
- if (oldact == SIG_ERR) sys_error(NO_ARG);
-#endif
- if (oldact == (void (*)(int)) handle_signal) {
- res = alloc_small(1, 0); /* Signal_handle */
- Field(res, 0) = Field(signal_handlers, sig);
- }
- else if (oldact == SIG_IGN)
- res = Val_int(1); /* Signal_ignore */
- else
- res = Val_int(0); /* Signal_default */
- if (Is_block(action)) {
- if (signal_handlers == 0) {
- signal_handlers = alloc(NSIG, 0);
- register_global_root(&signal_handlers);
- }
- modify(&Field(signal_handlers, sig), Field(action, 0));
- }
- CAMLreturn (res);
-}
-
-/* Machine- and OS-dependent handling of bound check trap */
-
-#if defined(TARGET_sparc) && defined(SYS_sunos)
-static void trap_handler(int sig, int code,
- struct sigcontext * context, char * address)
-{
- int * sp;
- /* Unblock SIGILL */
- sigset_t mask;
- sigemptyset(&mask);
- sigaddset(&mask, SIGILL);
- sigprocmask(SIG_UNBLOCK, &mask, NULL);
- if (code != ILL_TRAP_FAULT(5)) {
- fprintf(stderr, "Fatal error: illegal instruction, code 0x%x\n", code);
- exit(100);
- }
- /* Recover young_ptr and caml_exception_pointer from the %l5 and %l6 regs */
- sp = (int *) context->sc_sp;
- caml_exception_pointer = (char *) sp[5];
- young_ptr = (char *) sp[6];
- array_bound_error();
-}
-#endif
-
-#if defined(TARGET_sparc) && defined(SYS_solaris)
-static void trap_handler(int sig, siginfo_t * info, void * context)
-{
- long * sp;
-
- if (info->si_code != ILL_ILLTRP) {
- fprintf(stderr, "Fatal error: illegal instruction, code 0x%x\n",
- info->si_code);
- exit(100);
- }
- /* Recover young_ptr and caml_exception_pointer from the %l5 and %l6 regs */
- sp = (long *) (((ucontext_t *)context)->uc_mcontext.gregs[REG_SP]);
- caml_exception_pointer = (char *) sp[5];
- young_ptr = (char *) sp[6];
- array_bound_error();
-}
-#endif
-
-#if defined(TARGET_sparc) && (defined(SYS_bsd) || defined(SYS_linux))
-static void trap_handler(int sig)
-{
- /* TODO: recover registers from context and call array_bound_error */
- fatal_error("Fatal error: out-of-bound access in array or string\n");
-}
-#endif
-
-#if defined(TARGET_power) && defined(SYS_aix)
-static void trap_handler(int sig, int code, STRUCT_SIGCONTEXT * context)
-{
- /* Unblock SIGTRAP */
- sigset_t mask;
- sigemptyset(&mask);
- sigaddset(&mask, SIGTRAP);
- sigprocmask(SIG_UNBLOCK, &mask, NULL);
- /* Recover young_ptr and caml_exception_pointer from registers 31 and 29 */
- caml_exception_pointer = (char *) CONTEXT_GPR(context, 29);
- young_ptr = (char *) CONTEXT_GPR(context, 31);
- array_bound_error();
-}
-#endif
-
-#if defined(TARGET_power) && defined(SYS_elf)
-static void trap_handler(int sig, struct sigcontext * context)
-{
- /* Recover young_ptr and caml_exception_pointer from registers 31 and 29 */
- caml_exception_pointer = (char *) context->regs->gpr[29];
- young_ptr = (char *) context->regs->gpr[31];
- array_bound_error();
-}
-#endif
-
-#if defined(TARGET_power) && defined(SYS_rhapsody)
-static void trap_handler(int sig, int code, STRUCT_SIGCONTEXT * context)
-{
- /* Unblock SIGTRAP */
- sigset_t mask;
- sigemptyset(&mask);
- sigaddset(&mask, SIGTRAP);
- sigprocmask(SIG_UNBLOCK, &mask, NULL);
- /* Recover young_ptr and caml_exception_pointer from registers 31 and 29 */
- caml_exception_pointer = (char *) CONTEXT_GPR(context, 29);
- young_ptr = (char *) CONTEXT_GPR(context, 31);
- array_bound_error();
-}
-#endif
-
-#if defined(TARGET_power) && defined(SYS_bsd)
-static void trap_handler(int sig, int code, struct sigcontext * context)
-{
- /* Recover young_ptr and caml_exception_pointer from registers 31 and 29 */
- caml_exception_pointer = (char *) context->sc_frame.fixreg[29];
- young_ptr = (char *) context->sc_frame.fixreg[31];
- array_bound_error();
-}
-#endif
-
-
-/* Machine- and OS-dependent handling of stack overflow */
-
-#ifdef HAS_STACK_OVERFLOW_DETECTION
-
-static char * system_stack_top;
-static char sig_alt_stack[SIGSTKSZ];
-
-static int is_stack_overflow(char * fault_addr)
-{
- struct rlimit limit;
- struct sigaction act;
-
- /* Sanity checks:
- - faulting address is word-aligned
- - faulting address is within the stack */
- if (((long) fault_addr & (sizeof(long) - 1)) == 0 &&
- getrlimit(RLIMIT_STACK, &limit) == 0 &&
- fault_addr < system_stack_top &&
- fault_addr >= system_stack_top - limit.rlim_cur - 0x2000) {
- /* OK, caller can turn this into a Stack_overflow exception */
- return 1;
- } else {
- /* Otherwise, deactivate our exception handler. Caller will
- return, causing fatal signal to be generated at point of error. */
- act.sa_handler = SIG_DFL;
- act.sa_flags = 0;
- sigemptyset(&act.sa_mask);
- sigaction(SIGSEGV, &act, NULL);
- return 0;
- }
-}
-
-#if defined(TARGET_i386) && defined(SYS_linux_elf)
-static void segv_handler(int signo, struct sigcontext sc)
-{
- if (is_stack_overflow((char *) sc.cr2))
- raise_stack_overflow();
-}
-#endif
-
-#if defined(TARGET_i386) && !defined(SYS_linux_elf)
-static void segv_handler(int signo, siginfo_t * info, void * arg)
-{
- if (is_stack_overflow((char *) info->si_addr))
- raise_stack_overflow();
-}
-#endif
-
-#endif
-
-/* Initialization of signal stuff */
-
-void init_signals(void)
-{
- /* Bound-check trap handling */
-#if defined(TARGET_sparc) && \
- (defined(SYS_sunos) || defined(SYS_bsd) || defined(SYS_linux))
- {
- struct sigaction act;
- act.sa_handler = (void (*)(int)) trap_handler;
- sigemptyset(&act.sa_mask);
- act.sa_flags = 0;
- sigaction(SIGILL, &act, NULL);
- }
-#endif
-#if defined(TARGET_sparc) && defined(SYS_solaris)
- {
- struct sigaction act;
- act.sa_sigaction = trap_handler;
- sigemptyset(&act.sa_mask);
- act.sa_flags = SA_SIGINFO | SA_NODEFER;
- sigaction(SIGILL, &act, NULL);
- }
-#endif
-#if defined(TARGET_power)
- {
- struct sigaction act;
- act.sa_handler = (void (*)(int)) trap_handler;
- sigemptyset(&act.sa_mask);
-#if defined (SYS_rhapsody)
- act.sa_flags = SA_SIGINFO;
-#elif defined (SYS_aix)
- act.sa_flags = 0;
-#else
- act.sa_flags = SA_NODEFER;
-#endif
- sigaction(SIGTRAP, &act, NULL);
- }
-#endif
- /* Stack overflow handling */
-#ifdef HAS_STACK_OVERFLOW_DETECTION
- {
- struct sigaltstack stk;
- struct sigaction act;
- stk.ss_sp = sig_alt_stack;
- stk.ss_size = SIGSTKSZ;
- stk.ss_flags = 0;
-#if defined(TARGET_i386) && defined(SYS_linux_elf)
- act.sa_handler = (void (*)(int)) segv_handler;
- act.sa_flags = SA_ONSTACK | SA_NODEFER;
-#else
- act.sa_sigaction = segv_handler;
- act.sa_flags = SA_SIGINFO | SA_ONSTACK | SA_NODEFER;
-#endif
- sigemptyset(&act.sa_mask);
- system_stack_top = (char *) &act;
- if (sigaltstack(&stk, NULL) == 0) { sigaction(SIGSEGV, &act, NULL); }
- }
-#endif
-}
diff --git a/asmrun/sparc.S b/asmrun/sparc.S
deleted file mode 100644
index 1ac331d962..0000000000
--- a/asmrun/sparc.S
+++ /dev/null
@@ -1,398 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Asm part of the runtime system for the Sparc processor. */
-/* Must be preprocessed by cpp */
-
-/* SunOS 4 prefixes identifiers with _ */
-
-#if defined(SYS_sunos)
-
- .common _caml_required_size, 4, "bss"
-
-#define Young_limit _young_limit
-#define Young_ptr _young_ptr
-#define Caml_bottom_of_stack _caml_bottom_of_stack
-#define Caml_last_return_address _caml_last_return_address
-#define Caml_gc_regs _caml_gc_regs
-#define Caml_exception_pointer _caml_exception_pointer
-#define Caml_required_size _caml_required_size
-#define Caml_alloc _caml_alloc
-#define Caml_call_gc _caml_call_gc
-#define Garbage_collection _garbage_collection
-#define Caml_c_call _caml_c_call
-#define Caml_start_program _caml_start_program
-#define Caml_program _caml_program
-#define Raise_caml_exception _raise_caml_exception
-#define Callback_exn _callback_exn
-#define Callback2_exn _callback2_exn
-#define Callback3_exn _callback3_exn
-#define Caml_apply2 _caml_apply2
-#define Caml_apply3 _caml_apply3
-#define Mlraise _mlraise
-#define System_frametable _system__frametable
-
-#else
-
- .common caml_required_size, 4, 4
-
-#define Young_limit young_limit
-#define Young_ptr young_ptr
-#define Caml_bottom_of_stack caml_bottom_of_stack
-#define Caml_last_return_address caml_last_return_address
-#define Caml_gc_regs caml_gc_regs
-#define Caml_exception_pointer caml_exception_pointer
-#define Caml_required_size caml_required_size
-#define Caml_alloc caml_alloc
-#define Caml_call_gc caml_call_gc
-#define Garbage_collection garbage_collection
-#define Caml_c_call caml_c_call
-#define Caml_start_program caml_start_program
-#define Caml_program caml_program
-#define Raise_caml_exception raise_caml_exception
-#define Callback_exn callback_exn
-#define Callback2_exn callback2_exn
-#define Callback3_exn callback3_exn
-#define Caml_apply2 caml_apply2
-#define Caml_apply3 caml_apply3
-#define Mlraise mlraise
-#define System_frametable system__frametable
-
-#endif
-
-#ifndef SYS_solaris
-#define INDIRECT_LIMIT
-#endif
-
-#define Exn_ptr %l5
-#define Alloc_ptr %l6
-#define Alloc_limit %l7
-
-#define Load(symb,reg) sethi %hi(symb), %g1; ld [%g1 + %lo(symb)], reg
-#define Store(reg,symb) sethi %hi(symb), %g1; st reg, [%g1 + %lo(symb)]
-#define Address(symb,reg) sethi %hi(symb), reg; or reg, %lo(symb), reg
-
-/* Allocation functions */
-
- .text
- .global Caml_alloc
- .global Caml_call_gc
-
-/* Required size in %g2 */
-Caml_alloc:
-#ifdef INDIRECT_LIMIT
- ld [Alloc_limit], %g1
- sub Alloc_ptr, %g2, Alloc_ptr
- cmp Alloc_ptr, %g1
-#else
- sub Alloc_ptr, %g2, Alloc_ptr
- cmp Alloc_ptr, Alloc_limit
-#endif
- /*blu,pt %icc, Caml_call_gc*/
- blu Caml_call_gc
- nop
- retl
- nop
-
-/* Required size in %g2 */
-Caml_call_gc:
- /* Save %g2 (required size) */
- Store(%g2, Caml_required_size)
- /* Save exception pointer if GC raises */
- Store(Exn_ptr, Caml_exception_pointer)
- /* Save current allocation pointer for debugging purposes */
- Store(Alloc_ptr, Young_ptr)
- /* Record lowest stack address */
- Store(%sp, Caml_bottom_of_stack)
- /* Record last return address */
- Store(%o7, Caml_last_return_address)
- /* Allocate space on stack for caml_context structure and float regs */
- sub %sp, 20*4 + 15*8, %sp
- /* Save int regs on stack and save it into caml_gc_regs */
-L100: add %sp, 96 + 15*8, %g2
- st %o0, [%g2]
- st %o1, [%g2 + 0x4]
- st %o2, [%g2 + 0x8]
- st %o3, [%g2 + 0xc]
- st %o4, [%g2 + 0x10]
- st %o5, [%g2 + 0x14]
- st %i0, [%g2 + 0x18]
- st %i1, [%g2 + 0x1c]
- st %i2, [%g2 + 0x20]
- st %i3, [%g2 + 0x24]
- st %i4, [%g2 + 0x28]
- st %i5, [%g2 + 0x2c]
- st %l0, [%g2 + 0x30]
- st %l1, [%g2 + 0x34]
- st %l2, [%g2 + 0x38]
- st %l3, [%g2 + 0x3c]
- st %l4, [%g2 + 0x40]
- st %g3, [%g2 + 0x44]
- st %g4, [%g2 + 0x48]
- Store(%g2, Caml_gc_regs)
- /* Save the floating-point registers */
- add %sp, 96, %g1
- std %f0, [%g1]
- std %f2, [%g1 + 0x8]
- std %f4, [%g1 + 0x10]
- std %f6, [%g1 + 0x18]
- std %f8, [%g1 + 0x20]
- std %f10, [%g1 + 0x28]
- std %f12, [%g1 + 0x30]
- std %f14, [%g1 + 0x38]
- std %f16, [%g1 + 0x40]
- std %f18, [%g1 + 0x48]
- std %f20, [%g1 + 0x50]
- std %f22, [%g1 + 0x58]
- std %f24, [%g1 + 0x60]
- std %f26, [%g1 + 0x68]
- std %f28, [%g1 + 0x70]
- /* Call the garbage collector */
- call Garbage_collection
- nop
- /* Restore all regs used by the code generator */
- add %sp, 96 + 15*8, %g2
- ld [%g2], %o0
- ld [%g2 + 0x4], %o1
- ld [%g2 + 0x8], %o2
- ld [%g2 + 0xc], %o3
- ld [%g2 + 0x10], %o4
- ld [%g2 + 0x14], %o5
- ld [%g2 + 0x18], %i0
- ld [%g2 + 0x1c], %i1
- ld [%g2 + 0x20], %i2
- ld [%g2 + 0x24], %i3
- ld [%g2 + 0x28], %i4
- ld [%g2 + 0x2c], %i5
- ld [%g2 + 0x30], %l0
- ld [%g2 + 0x34], %l1
- ld [%g2 + 0x38], %l2
- ld [%g2 + 0x3c], %l3
- ld [%g2 + 0x40], %l4
- ld [%g2 + 0x44], %g3
- ld [%g2 + 0x48], %g4
- add %sp, 96, %g1
- ldd [%g1], %f0
- ldd [%g1 + 0x8], %f2
- ldd [%g1 + 0x10], %f4
- ldd [%g1 + 0x18], %f6
- ldd [%g1 + 0x20], %f8
- ldd [%g1 + 0x28], %f10
- ldd [%g1 + 0x30], %f12
- ldd [%g1 + 0x38], %f14
- ldd [%g1 + 0x40], %f16
- ldd [%g1 + 0x48], %f18
- ldd [%g1 + 0x50], %f20
- ldd [%g1 + 0x58], %f22
- ldd [%g1 + 0x60], %f24
- ldd [%g1 + 0x68], %f26
- ldd [%g1 + 0x70], %f28
- /* Reload alloc ptr */
- Load(Young_ptr, Alloc_ptr)
- /* Allocate space for block */
- Load(Caml_required_size, %g2)
-#ifdef INDIRECT_LIMIT
- ld [Alloc_limit], %g1
- sub Alloc_ptr, %g2, Alloc_ptr
- cmp Alloc_ptr, %g1 /* Check that we have enough free space */
-#else
- Load(Young_limit,Alloc_limit)
- sub Alloc_ptr, %g2, Alloc_ptr
- cmp Alloc_ptr, Alloc_limit
-#endif
- blu L100 /* If not, call GC again */
- nop
- /* Return to caller */
- Load(Caml_last_return_address, %o7)
- retl
- add %sp, 20*4 + 15*8, %sp /* in delay slot */
-
-/* Call a C function from Caml */
-
- .global Caml_c_call
-/* Function to call is in %g2 */
-Caml_c_call:
- /* Record lowest stack address and return address */
- Store(%sp, Caml_bottom_of_stack)
- Store(%o7, Caml_last_return_address)
- /* Save the exception handler and alloc pointer */
- Store(Exn_ptr, Caml_exception_pointer)
- sethi %hi(Young_ptr), %g1
- /* Call the C function */
- call %g2
- st Alloc_ptr, [%g1 + %lo(Young_ptr)] /* in delay slot */
- /* Reload return address */
- Load(Caml_last_return_address, %o7)
- /* Reload alloc pointer */
- sethi %hi(Young_ptr), %g1
- /* Return to caller */
- retl
- ld [%g1 + %lo(Young_ptr)], Alloc_ptr /* in delay slot */
-
-/* Start the Caml program */
-
- .global Caml_start_program
-Caml_start_program:
- /* Save all callee-save registers */
- save %sp, -96, %sp
- /* Address of code to call */
- Address(Caml_program, %l2)
-
- /* Code shared with callback* */
-L108:
- /* Set up a callback link on the stack. */
- sub %sp, 16, %sp
- Load(Caml_bottom_of_stack, %l0)
- Load(Caml_last_return_address, %l1)
- Load(Caml_gc_regs, %l3)
- st %l0, [%sp + 96]
- st %l1, [%sp + 100]
- /* Set up a trap frame to catch exceptions escaping the Caml code */
- call L111
- st %l3, [%sp + 104]
- b L110
- nop
-L111: sub %sp, 8, %sp
- Load(Caml_exception_pointer, Exn_ptr)
- st %o7, [%sp + 96]
- st Exn_ptr, [%sp + 100]
- mov %sp, Exn_ptr
- /* Reload allocation pointers */
- Load(Young_ptr, Alloc_ptr)
-#ifdef INDIRECT_LIMIT
- Address(Young_limit, Alloc_limit)
-#else
- Load(Young_limit, Alloc_limit)
-#endif
- /* Call the Caml code */
-L109: call %l2
- nop
- /* Pop trap frame and restore caml_exception_pointer */
- ld [%sp + 100], Exn_ptr
- add %sp, 8, %sp
- Store(Exn_ptr, Caml_exception_pointer)
- /* Pop callback link, restoring the global variables */
-L112: ld [%sp + 96], %l0
- ld [%sp + 100], %l1
- ld [%sp + 104], %l2
- Store(%l0, Caml_bottom_of_stack)
- Store(%l1, Caml_last_return_address)
- Store(%l2, Caml_gc_regs)
- add %sp, 16, %sp
- /* Save allocation pointer */
- Store(Alloc_ptr, Young_ptr)
- /* Reload callee-save registers and return */
- ret
- restore %o0, 0, %o0 /* copy %o0 in this window to caller's %o0 */
-L110:
- /* The trap handler */
- Store(Exn_ptr, Caml_exception_pointer)
- /* Encode exception bucket as an exception result */
- b L112
- or %o0, 2, %o0
-
-/* Raise an exception from C */
-
- .global Raise_caml_exception
-Raise_caml_exception:
- /* Save exception bucket in a register outside the reg windows */
- mov %o0, %g2
- /* Load exception pointer in a register outside the reg windows */
- Load(Caml_exception_pointer, %g3)
- /* Pop some frames until the trap pointer is in the current frame. */
- cmp %g3, %fp
- blt L107 /* if Exn_ptr < %fp, over */
- nop
-L106: restore
- cmp %fp, %g3 /* if %fp <= Exn_ptr, loop */
- ble L106
- nop
-L107:
- /* Reload allocation registers */
- Load(Young_ptr, Alloc_ptr)
-#ifdef INDIRECT_LIMIT
- Address(Young_limit, Alloc_limit)
-#else
- Load(Young_limit, Alloc_limit)
-#endif
- /* Branch to exception handler */
- mov %g3, %sp
- ld [%sp + 96], %g1
- ld [%sp + 100], Exn_ptr
- add %sp, 8, %sp
- jmp %g1 + 8
- /* Restore bucket, in delay slot */
- mov %g2, %o0
-
-/* Callbacks C -> ML */
-
- .global Callback_exn
-Callback_exn:
- /* Save callee-save registers and return address */
- save %sp, -96, %sp
- /* Initial shuffling of arguments */
- mov %i0, %g1
- mov %i1, %i0 /* first arg */
- mov %g1, %i1 /* environment */
- b L108
- ld [%g1], %l2 /* code pointer */
-
- .global Callback2_exn
-Callback2_exn:
- /* Save callee-save registers and return address */
- save %sp, -104, %sp
- /* Initial shuffling of arguments */
- mov %i0, %g1
- mov %i1, %i0 /* first arg */
- mov %i2, %i1 /* second arg */
- mov %g1, %i2 /* environment */
- sethi %hi(Caml_apply2), %l2
- b L108
- or %l2, %lo(Caml_apply2), %l2
-
- .global Callback3_exn
-Callback3_exn:
- /* Save callee-save registers and return address */
- save %sp, -104, %sp
- /* Initial shuffling of arguments */
- mov %i0, %g1
- mov %i1, %i0 /* first arg */
- mov %i2, %i1 /* second arg */
- mov %i3, %i2 /* third arg */
- mov %g1, %i3 /* environment */
- sethi %hi(Caml_apply3), %l2
- b L108
- or %l2, %lo(Caml_apply3), %l2
-
-#ifdef SYS_solaris
- .section ".rodata"
-#else
- .data
-#endif
- .global System_frametable
-System_frametable:
- .word 1 /* one descriptor */
- .word L109 /* return address into callback */
- .half -1 /* negative frame size => use callback link */
- .half 0 /* no roots */
-
-#ifdef SYS_solaris
- .type Caml_alloc, #function
- .type Caml_call_gc, #function
- .type Caml_c_call, #function
- .type Caml_start_program, #function
- .type Raise_caml_exception, #function
- .type System_frametable, #object
-#endif
diff --git a/asmrun/stack.h b/asmrun/stack.h
deleted file mode 100644
index 265b42d26f..0000000000
--- a/asmrun/stack.h
+++ /dev/null
@@ -1,105 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Machine-dependent interface with the asm code */
-
-#ifndef _stack_
-#define _stack_
-
-/* Macros to access the stack frame */
-#ifdef TARGET_alpha
-#define Saved_return_address(sp) *((long *)((sp) - 8))
-#define Already_scanned(sp, retaddr) ((retaddr) & 1L)
-#define Mark_scanned(sp, retaddr) (*((long *)((sp) - 8)) = (retaddr) | 1L)
-#define Mask_already_scanned(retaddr) ((retaddr) & ~1L)
-#define Callback_link(sp) ((struct caml_context *)((sp) + 16))
-#endif
-
-#ifdef TARGET_sparc
-#define Saved_return_address(sp) *((long *)((sp) + 92))
-#define Callback_link(sp) ((struct caml_context *)((sp) + 104))
-#endif
-
-#ifdef TARGET_i386
-#define Saved_return_address(sp) *((long *)((sp) - 4))
-#define Callback_link(sp) ((struct caml_context *)((sp) + 8))
-#endif
-
-#ifdef TARGET_mips
-#define Saved_return_address(sp) *((long *)((sp) - 4))
-#define Callback_link(sp) ((struct caml_context *)((sp) + 16))
-#endif
-
-#ifdef TARGET_hppa
-#define Stack_grows_upwards
-#define Saved_return_address(sp) *((long *)(sp))
-#define Callback_link(sp) ((struct caml_context *)((sp) - 24))
-#endif
-
-#ifdef TARGET_power
-#define Saved_return_address(sp) *((long *)((sp) - 4))
-#define Already_scanned(sp, retaddr) ((retaddr) & 1)
-#define Mark_scanned(sp, retaddr) (*((long *)((sp) - 4)) = (retaddr) | 1)
-#define Mask_already_scanned(retaddr) ((retaddr) & ~1)
-#ifdef SYS_aix
-#define Trap_frame_size 32
-#else
-#define Trap_frame_size 16
-#endif
-#define Callback_link(sp) ((struct caml_context *)((sp) + Trap_frame_size))
-#endif
-
-#ifdef TARGET_m68k
-#define Saved_return_address(sp) *((long *)((sp) - 4))
-#define Callback_link(sp) ((struct caml_context *)((sp) + 8))
-#endif
-
-#ifdef TARGET_arm
-#define Saved_return_address(sp) *((long *)((sp) - 4))
-#define Callback_link(sp) ((struct caml_context *)((sp) + 8))
-#endif
-
-#ifdef TARGET_ia64
-#define Saved_return_address(sp) *((long *)((sp) + 8))
-#define Already_scanned(sp, retaddr) ((retaddr) & 1L)
-#define Mark_scanned(sp, retaddr) (*((long *)((sp) + 8)) = (retaddr) | 1L)
-#define Mask_already_scanned(retaddr) ((retaddr) & ~1L)
-#define Callback_link(sp) ((struct caml_context *)((sp) + 32))
-#endif
-
-#ifdef TARGET_amd64
-#define Saved_return_address(sp) *((long *)((sp) - 8))
-#define Callback_link(sp) ((struct caml_context *)((sp) + 16))
-#endif
-
-/* Structure of Caml callback contexts */
-
-struct caml_context {
- char * bottom_of_stack; /* beginning of Caml stack chunk */
- unsigned long last_retaddr; /* last return address in Caml code */
- value * gc_regs; /* pointer to register block */
-};
-
-/* Declaration of variables used in the asm code */
-extern char * caml_bottom_of_stack;
-extern unsigned long caml_last_return_address;
-extern value * caml_gc_regs;
-extern char * caml_exception_pointer;
-extern value caml_globals[];
-extern long caml_globals_inited;
-extern long * caml_frametable[];
-
-
-#endif /* _stack_ */
diff --git a/asmrun/startup.c b/asmrun/startup.c
deleted file mode 100644
index b3ae46d3c1..0000000000
--- a/asmrun/startup.c
+++ /dev/null
@@ -1,158 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Start-up code */
-
-#include <stdio.h>
-#include <stdlib.h>
-#include "callback.h"
-#include "custom.h"
-#include "fail.h"
-#include "gc.h"
-#include "gc_ctrl.h"
-#include "misc.h"
-#include "mlvalues.h"
-#include "osdeps.h"
-#include "printexc.h"
-#include "sys.h"
-#ifdef HAS_UI
-#include "ui.h"
-#endif
-
-extern int parser_trace;
-header_t atom_table[256];
-char * static_data_start, * static_data_end;
-char * code_area_start, * code_area_end;
-
-/* Initialize the atom table and the static data and code area limits. */
-
-struct segment { char * begin; char * end; };
-
-static void minmax_table(struct segment *table, char **min, char **max)
-{
- int i;
- *min = table[0].begin;
- *max = table[0].end;
- for (i = 1; table[i].begin != 0; i++) {
- if (table[i].begin < *min) *min = table[i].begin;
- if (table[i].end > *max) *max = table[i].end;
- }
-}
-
-static void init_atoms(void)
-{
- int i;
- extern struct segment caml_data_segments[], caml_code_segments[];
-
- for (i = 0; i < 256; i++) atom_table[i] = Make_header(0, i, Caml_white);
- minmax_table(caml_data_segments, &static_data_start, &static_data_end);
- minmax_table(caml_code_segments, &code_area_start, &code_area_end);
-}
-
-/* Configuration parameters and flags */
-
-static unsigned long percent_free_init = Percent_free_def;
-static unsigned long max_percent_free_init = Max_percent_free_def;
-static unsigned long minor_heap_init = Minor_heap_def;
-static unsigned long heap_chunk_init = Heap_chunk_def;
-static unsigned long heap_size_init = Init_heap_def;
-static unsigned long max_stack_init = Max_stack_def;
-
-/* Parse the CAMLRUNPARAM variable */
-/* The option letter for each runtime option is the first letter of the
- last word of the ML name of the option (see [stdlib/gc.mli]).
- Except for l (maximum stack size) and h (initial heap size).
-*/
-/* Note: option l is irrelevant to the native-code runtime. */
-
-/* If you change these functions, see also their copy in byterun/startup.c */
-
-static void scanmult (char *opt, long unsigned int *var)
-{
- char mult = ' ';
- sscanf (opt, "=%lu%c", var, &mult);
- sscanf (opt, "=0x%lx%c", var, &mult);
- if (mult == 'k') *var = *var * 1024;
- if (mult == 'M') *var = *var * (1024 * 1024);
- if (mult == 'G') *var = *var * (1024 * 1024 * 1024);
-}
-
-static void parse_camlrunparam(void)
-{
- char *opt = getenv ("OCAMLRUNPARAM");
-
- if (opt == NULL) opt = getenv ("CAMLRUNPARAM");
-
- if (opt != NULL){
- while (*opt != '\0'){
- switch (*opt++){
- case 's': scanmult (opt, &minor_heap_init); break;
- case 'i': scanmult (opt, &heap_chunk_init); break;
- case 'h': scanmult (opt, &heap_size_init); break;
- case 'l': scanmult (opt, &max_stack_init); break;
- case 'o': scanmult (opt, &percent_free_init); break;
- case 'O': scanmult (opt, &max_percent_free_init); break;
- case 'v': scanmult (opt, &verb_gc); break;
- case 'p': parser_trace = 1; break;
- }
- }
- }
-}
-
-/* These are termination hooks used by the systhreads library */
-struct longjmp_buffer caml_termination_jmpbuf;
-void (*caml_termination_hook)(void *) = NULL;
-
-extern value caml_start_program (void);
-extern void init_ieee_floats (void);
-extern void init_signals (void);
-
-void caml_main(char **argv)
-{
- char * exe_name;
-#ifdef __linux__
- static char proc_self_exe[256];
-#endif
- value res;
-
- init_ieee_floats();
- init_custom_operations();
-#ifdef DEBUG
- verb_gc = 63;
-#endif
- parse_camlrunparam();
- init_gc (minor_heap_init, heap_size_init, heap_chunk_init,
- percent_free_init, max_percent_free_init);
- init_atoms();
- init_signals();
- exe_name = argv[0];
-#ifdef __linux__
- if (executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0)
- exe_name = proc_self_exe;
-#endif
- sys_init(exe_name, argv);
- if (sigsetjmp(caml_termination_jmpbuf.buf, 0)) {
- if (caml_termination_hook != NULL) caml_termination_hook(NULL);
- return;
- }
- res = caml_start_program();
- if (Is_exception_result(res))
- fatal_uncaught_exception(Extract_exception(res));
-}
-
-void caml_startup(char **argv)
-{
- caml_main(argv);
-}
diff --git a/boot/.cvsignore b/boot/.cvsignore
deleted file mode 100644
index bc591db468..0000000000
--- a/boot/.cvsignore
+++ /dev/null
@@ -1,4 +0,0 @@
-Saved
-ocamlrun
-ocamlyacc
-camlheader
diff --git a/boot/ocamlc b/boot/ocamlc
deleted file mode 100755
index 8b739e39d2..0000000000
--- a/boot/ocamlc
+++ /dev/null
Binary files differ
diff --git a/boot/ocamllex b/boot/ocamllex
deleted file mode 100755
index b62a2b463e..0000000000
--- a/boot/ocamllex
+++ /dev/null
Binary files differ
diff --git a/camlp4/CHANGES b/camlp4/CHANGES
deleted file mode 100644
index 0cba993c44..0000000000
--- a/camlp4/CHANGES
+++ /dev/null
@@ -1,851 +0,0 @@
-- [20 nov 03] Illegal escape sequences in strings now issue a warning.
-
-Camlp4 Version 3.07
-___________________
-
-- [29 Sep 03] Camlp4 code now licensed under the LGPL minus clause 6.
-- [09 Sep 03] Added tokens LABEL and OPTLABEL in plexer, and use them in
- both parsers (ocaml and revised). There was, afaik, no other way to fix
- ambiguities (bugs) in parsing labels and type constraints.
-
-Camlp4 Version 3.07 beta1
-________________________
-
-- [July 03] Updated the ocaml/camlp4 CVS tree with the camlp4
- "parallel" CVS tree, which becomes obsolete from now on.
- Added support for recursive modules, private data constructors, and
- new syntaxes for integers (int32, nativeint, ...).
-
-Camlp4 Version 3.06++
------------------------
-
-- [02 Dec 02] In AST predefined quotation, changed antiquotations for
- "rec", "mutable": now all are with coercion "opt": $opt:...$ (instead
- of "rec" and "mut"). Added antiquotation for "private". Cleaned up
- the entries for "methods" and for labelled and optional parameters.
-- [29 Nov 02] Removed all "extract_crc" stuff no more necessary with
- the new interface of Dynlink.
-- [26 Nov 02] Added ability to use "#use" directives in compiled files.
-- [21 Nov 02] Changed Scheme syntax for directives: now, e.g. #load "file"
- is written: # (load "file"). Added directives in "implem", "interf" and
- "use" directive.
-- [20 Nov 02] Added Grammar.glexer returning the lexer used by a
- grammar. Also added a field in Token.glexer type to ask lexers to
- record the locations of the comments.
-- [04 Nov 02] Added option -no_quot with normal syntax (pa_o.cmo):
- don't parse quotations (it allows to use e.g. <:> as a valid token).
-- [31 Oct 02] Added pa_macro.cmo (to replace pa_ifdef.cmo which is
- kept for compatibility, but deprecated). The extended statements
- allow de definitions of macros and conditional compilation like
- in C.
-- [29 Oct 02] Changed pretty printers of the three main syntaxes: if
- the locations of input are not correct, do no more raise End_of_file
- when displaying the inter-phrases (return: the input found up to eof
- if not empty, otherwise the value of the -sep parameter if not empty,
- otherwise the string "\n").
-- [25 Oct 02] Added option -records in pa_sml.cmo: generates normal
- OCaml records instead of objects (the user must be sure that there
- are no names conflicts).
-- [22 Oct 02] Added Plexer.specific_space_dot: when set to "true", the
- next call to Plexer.gmake returns a lexer where the dot preceded by
- spaces (space, tab, newline, etc.) return a different token than when
- not preceded by spaces.
-- [19 Oct 02] Added printer in Scheme syntax: pr_scheme.cmo and the
- extension pr_schemep.cmo which rebuilts parsers.
-- [15 Oct 02] Now, in case of syntax error, the real input file name is
- displayed (can be different from the input file, because of the possibility
- of line directives, typically generated by /lib/cpp).
- Changed interface of Stdpp.line_of_loc: now return also a string: the name
- of the real input file name.
-- [14 Oct 02] Fixed bug in normal syntax (pa_o.cmo): the constructors
- with currification of parameters (C x y) were accepted.
-- [14 Oct 02] Fixed many problems of make under Windows (in particular if
- installations directories contain spaces).
-- [11 Oct 02] In ocaml syntax (pa_o.cmo), fixed 3 bugs (or incompatibilities
- with the ocaml yacc version of the compiler): 1/ "ref new foo" was
- interpreted as "ref;; new foo" instead of "ref (new foo)" 2/ unary
- minuses did not work correctly (nor in quotation of syntax trees), in
- particular "-0.0" 3/ "begin end" was a syntax error, instead of being "()".
-- [Sep-Oct 02] Many changes and improvements in Scheme syntax.
-- [07 Oct 02] Added definition of Pcaml.type_declaration which is
- now visible in the interface, allowing to change the type declarations.
-- [07 Oct 02] Added Pcaml.syntax_name to allow syntax extensions to test
- it and take different decision. In revised syntax, its value is "Revised",
- in normal syntax "OCaml" and in Scheme syntax "Scheme".
-- [03 Oct 02] Added lexing of '\xHH' where HH is hexadecimal number.
-- [01 Oct 02] In normal syntax (camlp4o), fixed problem of lexing
- comment: (* bleble'''*)
-- [23 Sep 02] Fixed bug: input "0x" raised Failure "int_of_string"
- without location (syntaxes pa_o and pa_r).
-- [14 Sep 02] Added functions Grammar.iter_entry and Grammar.fold_entry
- to iterate a grammar entry and transitively all the entries it calls.
-- [12 Sep 02] Added "Pcaml.rename_id", a hook to allow parsers to give
- ability to rename their identifiers. Called in Scheme syntax (pa_scheme.ml)
- when generating its identifiers.
-- [09 Sep 02] Fixed bug under toplevel, the command:
- !Toploop.parse_toplevel_phrase (Lexing.from_buff "1;;");;
- failed "End_of_file".
-- [06 Sep 02] Added "Pcaml.string_of". Combined with Pcaml.pr_expr,
- Pcaml.pr_patt, and so on, allow to pretty print syntax trees in string.
- E.g. in the toplevel:
- # #load "pr_o.cmo";
- # Pcaml.string_of Pcaml.pr_expr <:expr< let x = 3 in x + 2 >>;;
- - : string = "let x = 3 in x + 2"
-
-Camlp4 Version 3.06
---------------------
-
-- [24 Jul 02] Added Scheme syntax: pa_scheme.ml, camlp4sch.cma (toplevel),
- camlp4sch (command).
-
-Camlp4 Version 3.05
------------------------
-
-- [12 Jul 02] Better treatment of comments in option -cip (add comments
- in phrases) for both printers pr_o.cmo (normal syntax) and pr_r.cmo
- (revised syntax); added comments before let binding and class
- structure items; treat comments inside sum and record type definitions;
- the option -tc is now deprecated and equivalent to -cip.
-- [13 Jun 02] Added pa_lefteval.cmo: add let..in expressions to guarantee
- left evaluation of functions parameters, t-uples, and so on (instead of
- the default non-specified-but-in-fact-right-to-left evaluation).
-- [06 Jun 02] Changed revised syntax (pa_r) of variants types definition;
- (Jacques Garrigue's idea):
- old syntax new syntax
- [| ... |] [ = ... ]
- [| < ... |] [ < ... ]
- [| > ... |] [ > ... ]
- This applies also in predefined quotations of syntax tree for types
- <:ctyp< ... >>
-- [05 Jun 02] Added option -ss in pr_o.cmo: print with double semicolons;
- and the option -no_ss is now by default.
-- [30 May 02] Improved SML syntax (pa_sml).
-- [30 May 02] Changed the AST for the "with module" construct (was with
- type "module_type"; changed into type "module_expr").
-- [26 May 02] Added missing abstract module types.
-- [21 Apr 02] Added polymorphic types for polymorphic methods:
- revised syntax (example): ! 'a 'b . type
- ctyp quotation: <:ctyp< ! $list:pl$ . $t$ >>
-- [17 Apr 02] Fixed bug: in normal syntax (pa_o.cmo) made a parse error on
- the "dot" on (in interface file file):
- class c : a * B.c -> object val x : int end
-- [03 Apr 02] Fixed bug: (* "(*" *) resulted in "comment not terminated".
-- [03 Apr 02] Fixed incompatibility with ocaml: ''' and '"' must be
- displayed as '\'' and '\"' in normal syntax printer (pr_o.cmo).
-- [03 Apr 02] When there are several tokens parsed together (locally LL(n)),
- the location error now highlights all tokens, resulting in a more clear
- error message (e.g. "for i let" would display "illegal begin of expr"
- and highlight the 3 tokens, not just "for").
-- [30 Mar 02] Added pa_extfold.cmo extending pa_extend.cmo by grammar
- symbols FOLD0 and FOLD1. Work like LIST0 and LIST1 but have two initial
- parameters: a function of type 'a -> 'b -> 'b doing the fold and an
- initial value of type 'b. Actually, LIST0 now is like
- FOLD0 (fun x y -> x :: y) []
- with an reverse of the resulting list.
-- [20 Mar 02] Fixed problem: when running a toplevel linked with camlp4
- as a script, the camlp4 welcome message was displayed.
-- [14 Mar 02] The configure shell and the program now test the consistency
- of OCaml and Camlp4. Therefore 1/ if trying to compile this version with
- an incompatible OCaml version or 2/ trying to run an installed Camlp4 with
- a incompatible OCaml version: in both cases, camlp4 fails.
-- [14 Mar 02] When make opt.opt is done, the very fast version is made for
- the normal syntax ("compiled" version). The installed camlp4o.opt is that
- version.
-- [05 Mar 02] Changed the conversion to OCaml syntax tree for <:expr< x.val >>
- and <:expr< x.val := e >> which generates now the tree of !x and x := e,
- no more x.contents and x.contents <- e. This change was necessary because
- of a problem if a record has been defined with a field named "contents".
-
-- [16 Feb 02] Changed interface of grammars: the token type is now
- customizable, using a new lexer type Token.glexer, parametrized by
- the token type, and a new functor GMake. This was accompanied by
- some cleanup. Become deprecated: the type Token.lexer (use Token.glexer),
- Grammar.create (use Grammar.gcreate), Unsafe.reinit_gram (use
- Unsafe.gram_reinit), the functor Grammar.Make (use Grammar.GMake).
- Deprecated means that they are kept during some versions and removed
- afterwards.
-- [06 Feb 02] Added missing infix "%" in pa_o (normal syntax).
-- [06 Feb 02] Added Grammar.print_entry printing any kind of (obj) entry
- and having the Format.formatter as first parameter (Grammar.Entry.print
- and its equivalent in functorial interface call it).
-- [05 Feb 02] Added a flag Plexer.no_quotations. When set to True, the
- quotations are no more lexed in all lexers built by Plexer.make ()
-- [05 Feb 02] Changed the printing of options so that the option -help
- aligns correctly their documentation. One can use now Pcaml.add_option
- without having to calculate that.
-- [05 Feb 02] pr_r.cmo: now the option -ncip (no comments in phrases) is
- by default, because its behaviour is not 100% sure. An option -cip has
- been added to set it.
-- [03 Feb 02] Added function Stdpp.line_of_loc returning the line and
- columns positions from a character location and a file.
-- [01 Feb 02] Fixed bug in token.ml: the location function provided by
- lexer_func_of_parser, lexer_func_of_ocamllex and make_stream_and_location
- could raise Invalid_argument "Array.make" for big files if the number
- of read tokens overflows the maximum arrays size (Sys.max_array_length).
- The bug is not really fixed: in case of this overflow, the returned
- location is (0, 0) (but the program does not fail).
-- [28 Jan 02] Fixed bug in pa_o when parsing class_types. A horrible hack
- had to be programmed to be able to treat them correctly.
-- [28 Jan 02] Fixed bug in OCaml toplevel when loading camlp4: the directives
- were not applied in the good order.
-- [26 Jan 02] The printer pr_extend.cmo try now also to rebuild GEXTEND
- statements (before it tried only the EXTEND).
-- [23 Jan 02] The empty functional stream "fstream [: :]" is now of type
- 'a Fstream.t thanks to the new implementation of lazies allowing to
- create polymorphic lazy values.
-- [11 Jan 02] Added a test in grammars using Plexer that a keyword is not
- used also as parameter of a LIDENT or a UIDENT.
-- [04 Jan 02] Fixed bug in pa_sml (SML syntax): the function definitions
- with several currified parameters did not work. It works now, but the
- previous code was supposed to treat let ("fun" in SML syntax) definitions
- of infix operators, what does not work any more now.
-- [04 Jan 02] Alain Frisch's contribution:
- Added pa_ocamllex.cma, syntax for ocamllex files. The command:
- camlp4 pa_ocamllex.cmo pr_o.cmo -ocamllex -impl foo.mll > foo.ml
- does the same thing as:
- ocamllex foo.mll
- Allow to compile directly mll files. Without option -ocamllex, allow
- to insert lex rules in a ml file.
-- [29 Dec 01] Added variable "inter_phrases" in Pcaml, of type ref (option
- string) to specify the string to print between phrases in pretty printers.
- The default is None, meaning to copy the inter phrases from the source
- file.
-
-Camlp4 Version 3.04
--------------------
-
-- [07 Dec 01] Added Pcaml.parse_interf and Pcaml.parse_implem, hooks to
- specify the parsers tof use, i.e. now can use other parsing technics
- than the Camlp4 grammar system.
-- [27 Nov 01] Fixed functions Token.eval_char and Token.eval_string which
- returned bad values, resulting lexing of backslash sequences incompatible
- with OCaml (e.g. "\1" returned "\001" (one character) but OCaml returns
- the string of the two characters \ and 1).
-- [15 Nov 01] In revised syntax, in let binding in sequences, the "in"
- can be replaced by a semicolon; the revised syntax printer pr_r.cmo
- now rather prints a semicolon there.
-- [07 Nov 01] Added the ability to use $ as token: was impossible so far,
- because of AST quotation uses it for its antiquotation. The fix is just
- a little (invisible) change in Plexer.
-- [05 Nov 01] Added option -tc (types comment) when using pr_o or pr_r
- try to print comments inside sum and record types like they are in
- the source (not by default, because may work incorrectly).
-- [05 Nov 01] Added option -ca (comment after) when using pr_o or pr_r:
- print ocamldoc comments after the declarations, when they are before.
-- [04 Nov 01] Added locations for variants and labels declarations in AST
- (file MLast.mli).
-- [03 Nov 01] In pretty printers pr_o and pr_r, skip to next begin of line
- when displaying the sources between phrase, to prevent e.g. the displaying
- of the possible last comment of a sum type declaration (the other comment
- being not displayed anyway).
-- [24 Oct 01] Fixed incorrect locations in sequences.
-- [24 Oct 01] Was erroneously compiled by the OCaml boot compiler instead
- of the generated ocamlc. Fixed.
-- [15 Oct 01] Fixed some parsing differences between pa_o and ocamlyacc:
- in parsers, in labels.
-- [12 Oct 01] Added missing bigarray syntax a.{b} (and Cie) in standard
- syntax (pa_o).
-
-Camlp4 Version 3.03
--------------------
-
-- [09 Oct 01] Fixed bug: the token !$ did not work. Fixed and completed
- some syntaxes of labels patterns. Added missing case in exception
- declaration (exception rebinding).
-- [05 Oct 01] Fixed bug in normal syntax: when defining a constructor
- named "True" of "False" (capitalized, i.e. not like the booleans), it
- did not work.
-- [04 Oct 01] Fixed some revised and quotation syntaxes in objects classes
- and types (cleaner). Cleaned up also several parts of the parsers.
-- [02 Oct 01] In revised syntax, the warning for using old syntax for
- sequences is now by default. To remove it, the option -no-warn-seq
- of camlp4r has been added. Option -warn-seq has been removed.
-- [07 Sep 01] Included Camlp4 in OCaml distribution.
-- [06 Sep 01] Added missing pattern construction #t
-- [05 Sep 01] Fixed bug in pa_o: {A.B.c = d} was refused.
-- [26 Aug 01] Fixed bug: in normal and revised syntaxes, refused -1.0
- (minus float) as pattern.
-- [24 Aug 01] Fixed bug: (a : b :> c) and ((a : b) :> c) were parsed
- identically.
-- [20 Aug 01] Fixed configure script for Windows configuration.
-- [10 Aug 01] Fixed bug: <:expr< 'a' >> did not work because of a typing
- problem.
-- [10 Aug 01] Fixed bug in compilation process under Windows: the use of
- the extension .exe was missing in several parts in Makefiles and shell
- scripts.
-- [09 Aug 01] Changed message error in grammar: in the case when the rule
- is: ....; tok1; tok2; .. tokn; ... (n terminal tokens following each other),
- where the grammar is locally LL(n), it displays now:
- tok1 tok2 .. tokn expected
- instead of just
- tok1 expected
- because "tok1" can be correct in the input, and in this case, the message
- underscored the tok1 and said "tok1 expected".
-- [07 Aug 01] When camlp4r.cma is loaded in the toplevel, the results are
- now displayed in revised syntax.
-- [04 Aug 01] Added syntax "declare..end" in quotations class_str_item and
- class_sig_item to be able to generate several items from one only item
- (like in str_item and sig_item).
-
-Camlp4 Version 3.02
--------------------
-
-- [21 Jul 01] Fixed bug: <:expr< { l = x } >> was badly built and resulted
- in a typing error.
-- [13 Jul 01] Fixed bug: did not accept floats in patterns.
-- [11 Jul 01] Added function Pcaml.top_printer to be able to use the
- printers Pcaml.pr_expr, Pcaml.pr_patt, and so on for the #install_printer
- of OCaml toplevel. Ex:
- let f = Pcaml.top_printer Pcaml.pr_expr;;
- #install_printer f;;
- #load "pr_o.cmo";;
-- [24 Jun 01] In grammars, added symbol ANY, returning the current token,
- whichever it is.
-- [24 Jun 01] In grammars, a rule list of the form [ s1 | s2 | .. | sn ]
- is interpreted as [ x = s1 -> x | x = s2 -> x | .. x = sn -> x ]
- instead of [ _ = s1 -> () | _ = s2 -> () .. ]
-- [24 Jun 01] Moved the functions [Plexer.char_of_char_token] and
- [Plexer.string_of_string_token] into module [Token] with names
- [Token.eval_char] and [Token.eval_string].
-- [22 Jun 01] Added warning when using old syntax for sequences, while
- and do (do..return, do..done) in predefined quotation expr.
-- [22 Jun 01] Changed message for unbound quotations (more clear).
-
-Camlp4 Version 3.01.6:
-----------------------
-
-- [22 Jun 01] Changed the module Pretty into Spretty.
-- [21 Jun 01] Camlp4 can now be compiled even if OCaml is not installed:
- in the directory "config", the file "configure_batch" is a possibility
- to configure the compilation (alternative of "configure" of the top
- directory) and has a parameter "-ocaml-top" to specify the OCaml top
- directory (relative to the camlp4/config directory).
-- [21 Jun 01] The interactive "configure" now tests if the native-code
- compilers ocamlc.opt and ocamlopt.opt are accessible and tell the
- Makefile to preferably use them if they are.
-- [16 Jun 01] The syntax tree for strings and characters now represent their
- exact input representation (the node for characters is now of type string,
- no more char). For example, the string "a\098c" remains "a\098c" and is
- *not* converted into (the equivalent) "abc" in the syntax tree. The
- convertion takes place when converting into OCaml tree representation.
- This has the advantage that the pretty print now display them as they
- are in the input file. To convert from input to real representation
- (if needed), two functions have been added: Plexer.string_of_string_token
- and Plexer.char_of_char_token.
-- [10 Jun 01] In revised syntax, added ability to write {foo x = y} as short
- form for {foo = fun x -> y}.
-- [08 Jun 01] Completed missing cases in pa_extfun.cmo for variants.
-- [06 Jun 01] Completed missing cases in abstract syntax tree and in normal
- syntax parser pa_o.ml (about classes).
-- [06 Jun 01] Fixed bug in pa_o.cmo (parser of normal syntax): (~~) did not
- work, and actually all prefix operators between parentheses.
-
-Camlp4 Version 3.01.5:
-----------------------
-
-- [04 Jun 01] Fixed bug: when using "include" in a structure item the rest
- of the structure was lost.
-- [31 May 01] Added ability to user #load and #directory inside ml or mli
- files to specify a cmo file to be loaded (for syntax extension) or the
- directory path (like option -I). Same semantics than in toplevel.
-- [29 May 01] The name of the location variable used in grammars (action
- parts of the rules) and in the predefined quotations for OCaml syntax
- trees is now configurable in Stdpp.loc_name (string reference). Added also
- option -loc to set this variable. Default: loc.
-- [26 May 01] Added functional streams: a library module Fstream and a syntax
- kit: pa_fstream.cmo. Syntax:
- streams: fstream [: ... :]
- parsers: fparser [ [: ... :] -> ... | ... ]
-- [25 May 01] Added function Token.lexer_func_of a little bit more general
- than Token.lexer_func_of_parser.
-
-Camlp4 Version 3.01.4:
-----------------------
-
-- [20 May 01] Fixed bug: pr_rp and pr_op could generate bound variables
- resulting incorrect program:
- (e.g. fun s -> parser [: `_; x :] -> s x was printed:
- fun s -> parser [: `_; s :] -> s s)
-- [19 May 01] Small improvement in pretty.ml resulting a faster print (no
- more stacked HOVboxes which printers pr_r and pr_o usually generate in
- expr, patt, ctyp, etc.)
-- [18 May 01] Added [lexer_func_of_parser] and [lexer_func_of_ocamllex]
- in module [Token] to create lexers functions from char stream parsers
- or from [ocamllex] lexers.
-- [16 May 01] Pretty printing with pr_r.cmo (revised syntax) now keep
- comments inside phrases.
-- [15 May 01] Changed pretty printing system, using now new extensible
- functions of Camlp4.
-- [15 May 01] Added library module Extfun for extensible functions,
- syntax pa_extfun, and a printer pr_extfun.
-- [12 May 01] Fixed bug: missing cases in pr_o and pr_r for in cases of
- "for", "while", and some other expressions, when between parentheses.
-
-Camlp4 Version 3.01.3:
-----------------------
-
-- [04 May 01] Put back the syntax "do ... return ..." in predefined
- quotation "expr", to be able to compile previous programs. Work
- only if the quotation is in position of expression, not in pattern.
-- [04 May 01] Added lisp syntax pa_lisp.cmo (not terminated).
-- [01 May 01] Fixed bug: in toplevel, in case of syntax error in #use,
- the display was incorrect: it displayed the input, instead of the
- file location.
-
-Camlp4 Version 3.01.2:
-----------------------
-
-- [27 Apr 01] Added variable Grammar.error_verbose and option -verbose of
- command camlp4 to display more information in case of parsing error.
-- [27 Apr 01] Fixed bug: the locations in sequences was not what expected
- by OCaml, resulting on bad locations displaying in case of typing error.
-- [27 Apr 01] Fixed bug: in normal syntax, the sequence was parsed
- of left associative instead of right associative, resulting bad pretty
- printing.
-
-Camlp4 Version 3.01.1:
-----------------------
-
-- [19 Apr 01] Added missing new feature "include" (structure item).
-- [17 Apr 01] Changed revised syntax of sequences. Now:
- do { expr1; expr2 ..... ; exprn }
- for patt = expr to/downto expr do { expr1; expr2 ..... ; exprn }
- while expr do { expr1; expr2 ..... ; exprn }
- * If holding a "let ... in", the scope applies up to the end of the sequence.
- * The old syntax "do .... return ..." is still accepted.
- * In expr quotation, it is *not* accepted. To ensure backward
- compatibility, use ifdef NEWSEQ, which answers True from this version.
- * The printer pr_r.cmo by default prints with this new syntax.
- * To print with old syntax, use option -old_seq.
- * To get a warning when using old syntax, use option -warn_seq.
-
-Camlp4 Version 3.01:
---------------------
-
-- [5 Mar 01] In pa_o.ml fixed problem, did not parse:
- class ['a, 'b] cl a b : ['a, 'b] classtype
-- [9 Oct 00] Raise now Stream.Error when parsing with an empty entry (meaning
- that the user probably forgot to initialize it).
-- [21 Jul 00] Fixed (pr_o.cmo) pb of bad printing of
- let (f : unit -> int) = fun () -> 1
-- [10 Jun, 21 Jul 00] Added Pcaml.sync to synchronize after syntax error in
- toplevel.
-- [24 May 00] Changed the "make opt", returning to what was done in the
- previous releases, i.e. just the compilation of the library (6 files).
- The native code compilation of "camlp4o" and "camlp4r" are not absolutely
- necessary and can create problems in some systems because of too long code.
- The drawbacks are more important than the advantages.
-- [19 May 00] Changed option -split_gext (when pa_extend.cmo is loaded) into
- -split_ext: it applies now also for non functorial grammars (extended by
- EXTEND instead of GEXTEND).
-- [12 May 00] Fixed problem in pr_rp.cmo and pr_op.cmo: the pretty printing
- of the construction "match x with parser" did not work (because of the
- type constraint "Stream.t _" added some versions ago).
-
-Camlp4 Version 3.00:
---------------------
-
-- [Apr 19, 00] Added "pa_olabl" for labels with old Olabl syntax.
-- [Apr 18, 00] Make opt now builds camlp4o.opt and camlp4r.opt
-- [Apr 17, 00] Added support for labels and variants.
-- [Mar 28, 00] Improved the grammars: now the rules starting with n
- terminals are locally LL(n), i.e. if any of the terminal fails, it is
- not Error but just Failure. Allows to write the Ocaml syntax case:
- ( operator )
- ( expr )
- with the problem of "( - )" as:
- "("; "-"; ")"
- "("; operator; ")"
- "("; expr; ")"
- after factorization of the "(", the rule "-"; ")" is locally LL(2): it
- works for this reason. In the previous implementation, a hack had to be
- added for this case.
-
- To allow this, the interface of "Token" changed. The field "tparse" is
- now of type "pattern -> option (Stream.t t -> string)" instead of
- "pattern -> Stream.t t -> string". Set it to "None" for standard pattern
- parsing (or if you don't know).
-
-Camlp4 Version 2.04:
---------------------
-
-- [Nov 23, 99] Changed the module name Config into Oconfig, because of
- conflict problem when applications want to link with the module Config of
- Ocaml.
-
-Camlp4 Version 2.03:
---------------------
-
-* pr_depend:
- - [Jun 25, 99] Added missing case in "pr_depend.cmo": pattern A.B.C.
- - [Jun 5, 99] Fixed in "pr_depend.ml" case expression "Foo.Bar" displaying a
- bad dependency with file "bar.ml" if existed. And changed "pa_r.ml"
- (revised syntax parsing) to generate a more logical ast for case
- "var.Mod.lab".
- - [Apr 29, 99] Added missing cases in "pr_o.cmo" and in "pr_depend.cmo".
- - [Mar 11, 99] Added missing cases in "pr_depend.cmo".
- - [Mar 9, 99] Added missing case in pr_depend.ml.
-
-* Other:
- - [Sep 10, 99] Updated from current Ocaml new interfaces.
- - [Jul 9, 99] Added stream type constraint in pa_oop.ml to reflect the same
- change in Ocaml.
- - [Jun 24, 99] Added missing "constraint" construction in types
- - [Jun 15, 99] Added option -I for command "mkcamlp4".
- - [May 14, 99] Added man pages (links) for camlp4o, camlp4r, mkcamlp4, ocpp
- - [May 10, 99] Added shell script "configure_batch" in directory "config".
- - [May 10, 99] Changed LICENSE to BSD.
- - [Apr 29, 99] Added "ifdef" for mli files.
- - [Apr 11, 99] Changed option "-no_cp" into "-sep" in pr_r.cmo and pr_o.cmo.
- - [Apr 11, 99] Fixed (old) bug: too long strings where bad pretty printed.
- - [Mar 24, 99] Added missing stream type constraint for parsers.
- - [Mar 17, 99] Changed template Makefile to use ocamlc.opt and ocamlopt.opt
- by default, instead of ocamlc and ocamlopt.
- - [Mar 9, 99] Added ifndef in pa_ifdef.ml.
- - [Mar 7, 99] Completed and fixed some cases in pr_extend.ml.
-
-Camlp4 Version 2.02:
---------------------
-
-* Parsing:
- - [Feb 27, 99] Fixed 2 bugs, resulting of incorrect Ocaml parsing of the
- program example: "type t = F(B).t"
- - [Jan 30, 99] Fixed bug "pa_op.ml", could not parse "parser | [<>] -> ()".
- - [Jan 16, 99] Added "define" and "undef" in "pa_ifdef.cmo".
- - [Dec 22, 98] Fixed precedence of "!=" in Ocaml syntax
-
-* Printing:
- - [Mar 4, 99] Added pr_depend.cmo for printing file dependencies.
- - [Dec 28, 98] Fixed pretty printing of long strings starting with spaces;
- used to display "\\n<spaces>..." instead of "<spaces>\\n...".
-
-* Camlp4:
- - [Feb 19, 99] Sort command line argument list in reverse order to
- avoid argument names conflicts when adding arguments.
-
-* Olabl:
- - [Feb 26, 99] Started extensions for Olabl: directory "lablp4" and some
- changes in MLast. Olabl programs can be preprocessed by:
- camlp4 pa_labl.cma pr_ldump.cmo
-
-* Internal:
- - Use of pr_depend.cmo instead of ocamldep for dependencies.
-
-Camlp4 Version 2.01:
---------------------
-
-Token interface
-* Big change: the type for tokens and tokens patterns is now (string * string)
- the first string being the constructor name and the second its possible
- parameters. No change in EXTEND statements using Plexer. But lexers
- have:
- - a supplementary parameter "tparse" to specify how to parse token
- from token patterns.
- - fields "using" and "removing" replacing "add_keyword" and
- "remove_keyword".
- See the file README-2.01 for how to update your programs and the interface
- of Token.
-
-Grammar interface
-* The function "keywords" have been replaced by "tokens". The equivalent
- of the old statement:
- Grammar.keywords g
- is now:
- Grammar.tokens g ""
-
-Missing features added
-* Added "lazy" statement (pa_r.cmo, pa_o.cmo, pr_r.cmo, pr_o.cmo)
-* Added print "assert" statement (pr_o.cmo, pr_r.cmo)
-* Added parsing of infix operators like in Ocaml (e.g. |||) in pa_o.cmo
-
-Compilation
-* Added "make scratch"
-* Changed Makefile. No more "make T=../", working bad in some systems.
-* Some changes to make compilation in Windows 95/98 working better (thanks
- to Patricia Peratto).
-
-Classes and objects
-* Added quotations for classes and objects (q_MLast.ml)
-* Added accessible entries in module Pcaml (class_type, class_expr, etc.)
-* Changed classes and objects types in definition (module MLast)
-
-Miscelleneous
-* Some adds in pa_sml.cmo. Thanks to Franklin Chen.
-* Added option "-no_cp" when "pr_o.cmo" or "pr_r.cmo" is loaded: do
- not print comments between phrases.
-* Added option "-split_gext" when "pa_extend.cmo" is loaded: split GEXTEND
- by functions to turn around a PowerPC problem.
-
-Bug fixes
-* Fixed pa_r.cmo, pa_o.cmo to parse, and pr_r.cmo, pr_o.cmo to print "(x:#M.c)"
-* Fixed printing pr_o.cmo of "(a.b <- 1)::1"
-* Extended options with parameters worked only when the parameter was sticked.
- Ex:
- camlp4o pr_o.cmo -l120 foo.ml
- worked, but not:
- camlp4o pr_o.cmo -l 120 foo.ml
-
-Camlp4 Version 2.00:
---------------------
-
-* Designation "righteous" has been renamed "revised".
-* Added class and objects in Ocaml printing (pr_o.cmo), revised parsing
- (pa_r.cmo) and printing (pr_r.cmo).
-* Fixed bug in Ocaml syntax: let _, x = 1, 2;; was refused.
-
-Camlp4 Version 2.00--1:
------------------------
-
-* Added classes and objects in Ocaml syntax (pa_o.cmo)
-* Fixed pr_r.cmo et pr_r.cmo which wrote on stdout, even when option -o
-
-Camlp4 Version 2.00--:
-----------------------
-
-* Adapted for Ocaml 2.00.
-* No objects and classes in this version.
-
-* Added "let module" parsing and printing.
-* Added arrays patterns parsing and printing.
-* Added records with "with" "{... with ...}" parsing and printing
-
-* Added # num "string" in plexer (was missing).
-* Fixed bug in pr_o.cmo: module A = B (C);; was printed module A = B C;;
-* Added "pa_sml.cmo", SML syntax + "lib.sml"
-* Fixed bug in pa_r.ml and pa_o.ml: forgot to clear let_binding
-* Changed Plexer: unknown keywords do not raise error but return Tterm
-* q_MLast.cmo: suppressed <:expr< [$list:el$] >> (cannot work)
-* Added option "-no_ss" (no ;;) when "pr_o.cmo" loaded
-* Many changes and bug fixing in pretty printing pr_o.cmo and pr_r.cmo
-* Command ocpp works now without having to explicitely load
- "/usr/local/lib/ocaml/stdlib.cma" and
- "/usr/local/lib/camlp4/gramlib.cma"
-
-* Fixed problem of pretty print "&" and "or" in normal and righteous syntaxes
-* Added missing statement "include" in signature item in normal and righteous
- syntaxes
-* Changed precedence of ":=" and "<-" in normal syntax (pa_o et pr_o):
- now before "or", like in Ocaml compiler.
-* Same change in righteous syntax, by symmetry.
-
-Camlp4 Version 1.07.2:
-----------------------
-
-Errors and missings in normal and righteous syntaxes.
-
-* Added forgotten syntax (righteous): type constraints in class type fields.
-* Added missing syntax (normal): type foo = bar = {......}
-* Added missing syntax (normal): did not accept separators before ending
- constructions (many of them).
-* Fixed bug: "assert false" is now of type 'a, like in Ocaml.
-* Fixed to match Ocaml feature: "\^" is "\^" in Ocaml, but just "^" in Camlp4.
-* Fixed bug in Windows NT/95: problem in backslash before newlines in strings
-
-Grammars, EXTEND, DELETE_RULE
-
-* Added functorial version for grammars (started in version 1.07.1,
- completed in this version).
-* Added statements GEXTEND and GDELETE_RULE in pa_extend.cmo for functorial
- version.
-* EXTEND statement is added AFTER "top" instead of LEVEL "top" (because
- of problems parsing "a; EXTEND...")
-* Added ability to have expressions (in antiquotation form) of type string in
- EXTEND after keywords "LIDENT", "UIDENT", "IDENT", "ANTIQUOT", "INT" as
- in others constructions inside EXTEND.
-* A grammar rule hidden by another is not deleted but just masked. DELETE_RULE
- will restore the old version.
-* DELETE_RULE now raises Not_found if no rule matched.
-* Fixed bug: DELETE_RULE did not work when deleting a rule which is a prefix of
- another rule.
-* Some functions for "system use" in [Grammar] become "official":
- [Entry.obj], [extend], [delete_rule].
-
-Command line, man page
-
-* Added option -o: output on file instead of standard output, necessary
- to allow compilation in Windows NT/95 (in fact, this option exists since
- 1.07.1 but forgotten in its "changes" list).
-* Command line option -help more complete.
-* Updated man page: camlp4 options are better explained.
-* Fixed bug: "camlp4 [other-options] foo.ml" worked but not
- "camlp4 foo.ml [other-options]".
-* Fixed bug: "camlp4 foo" did not display a understandable error message.
-
-Camlp4's compilation
-
-* Changes in compilation process in order to try to make it work better for
- Windows NT under Cygnus.
-
-Miscellaneous
-
-* Added [Pcaml.add_option] for adding command line options.
-
-Camlp4 Version 1.07.1:
-----------------------
-
-* Added forgotten syntax in pr_o: type x = y = A | B
-* Fixed bug negative floats parsing in pa_o => error while pretty printing
-* Added assert statement and option -noassert.
-* Environment variable CAMLP4LIB to change camlp4 library directory
-* Grammar: empty rules have a correct location instead of (-1, -1)
-* Compilation possible in Windows NT/95
-* String constants no more shared while parsing Ocaml
-* Fixed bug in antiquotations in q_MLast.cmo (bad errors locations)
-* Fixed bug in antiquotations in q_MLast.cmo (EOI not checked)
-* Fixed bug in Plexer: could not create keywords with iso 8859 characters
-
-Camlp4 Version 1.07:
---------------------
-
-* Changed version number + configuration script
-* Added iso 8859 uppercase characters for uidents in plexer.ml
-* Fixed bug factorization IDENT in grammars
-* Fixed bug pr_o.cmo was printing "declare"
-* Fixed bug constructor arity in Ocaml syntax (pa_o.cmo).
-* Changed "lazy" into "slazy".
-* Completed pa_ifdef.cmo.
-
-Camlp4 Version 1.06:
---------------------
-
-* Adapted to Ocaml 1.06.
-* Changed version number to match Ocaml's => 1.06 too.
-* Deleted module Gstream, using Ocaml's Stream.
-* Generate different AST for C(x,y) and C x y (change done in Ocaml's compiler)
-* No more message "Interrupted" in toplevel in case of syntax error.
-* Added flag to suppress warnings while extending grammars.
-* Completed some missing statements and declarations (objects)
-* Modified odyl implementation; works better
-* Added ability to extend command line specification
-* Added "let_binding" as predefined (accessible) entry in Pcaml.
-* Added construction FUNCTION in EXTEND statement to call another function.
-* Added some ISO-8859-1 characters in lexer identifiers.
-* Fixed bug "value x = {val = 1};" (righteous syntax)
-* Fixed bug "open A.B.C" was interpreted as "open B.A.C"
-* Modified behavior of "DELETE_RULE": the complete rule must be provided
-* Completed quotations MLast ("expr", "patt", etc) to accept whole language
-* Renamed "LIKE" into "LEVEL" in grammar EXTEND
-* Added "NEXT" as grammar symbol in grammar EXTEND
-* Added command "mkcamlp4" to make camlp4 executables linked with C code
-* Added "pr_extend.cmo" to reconstitute EXTEND instructions
-
-Camlp4 Version 0.6:
--------------------
-
---- Installing
-
-* To compile camlp4, it is no more necessary to have the sources of the
- Objective Caml compiler available. It can be compiled like any other
- Objective Caml program.
-
---- Options of "camlp4"
-
-* Added option -where: "camlp4 -where" prints the name of the standard
- library directory of Camlp4 and exit. So, the ocaml toplevel and the
- compiler can use the option:
- -I `camlp4 -where`
-
-* Added option -nolib to not search for objects files in the installed
- library directory of Camlp4.
-
---- Interface of grammar library modules
-
-* The function Grammar.keywords returns now a list of pairs. The pair is
- composed of a keyword and the number of times it is used in entries.
-
-* Changed interface of Token and Grammar for lexers, so user lexers have
- to be changed.
-
---- New features in grammars
-
-* New instruction "DELETE_RULE" provided by pa_extend.cmo to delete rules.
- Ex:
- DELETE_RULE Pcaml.expr: "if" END;
- deletes the "if" instruction of the language.
-
-* Added the ability to parse some specific integer in grammars: a possible
- parameter to INT, like the ones for LIDENT and UIDENT.
-
-* In instruction EXTEND, ability to omit "-> action", default is "-> ()"
-
-* Ability to add antiquotation (between $'s) as symbol rule, of type string,
- interpreted as a keyword, in instruction EXTEND.
-
-* Ability to put entries with qualified names (Foo.bar) in instruction EXTEND.
-
---- Quotations
-
-* The module Ast has been renamed MLast. The quotation expander "q_ast.cmo"
- has been renamed "q_MLast.cmo".
-
-* Quotation expanders are now of two kinds:
- - The "classical" type for expanders returning a string. These expanders
- have now a supplementary parameter: a boolean value set to "True"
- when the quotation is in a context of an expression an to "False"
- when the quotation is in a context of a pattern. These expanders,
- returning strings which are parsed afterwards, may work for some
- language syntax and/or language extensions used (e.g. may work for
- Righteous syntax and not for Ocaml syntax).
- - A new type of expander returning directly syntax trees. A pair
- of functions, for expressions and for patterns must be provided.
- These expanders are independant from the language syntax and/or
- extensions used.
-
-* The predefined quotation expanders "ctyp_", "patt_" and "expr_" has
- been deleted; one can use "ctyp", "patt", and "expr" in position of
- pattern or expression.
-
---- Ocaml and Righteous syntaxes
-
-* Fixed bug: "open Foo.Bar" was converted (pr_dump.cmo) into "open Bar.Foo"
-
-* Corrected behavior different from Ocaml's: "^" and "@" were at the same
- level than "=": now, like Ocaml, they have a separated right associative
- level.
-
---- Grammars behavior
-
-* While extending entries: default position is now "extension of the
- first level", instead of "adding a new level at the end".
-
-* Another Change: in each precedence level, terminals are inserted before
- other symbols (non terminals, lists, options, etc), LIDENT "foo" before
- LIDENT (alone) and UIDENT "foo" before UIDENT (alone). New rules not
- factorizable are now inserted before the other rules.
-
-* Changed algorithm of entries parsing: each precedence level is tested
- against the stream *before* its next precedences levels (instead of
- *after*):
- EXTEND e: [[ LIDENT "a" -> "xxx" ] | [ i = LIDENT -> i ]]; END;
- Now, parsing the entry e with the string "a" returns "xxx" instead of "a"
-
-* Less keywords in instruction EXTEND (LEFTA, LIDENT, etc), which can be
- used now as normal identifiers.
-
-* When inserting a new rule, a warning appears if a rule with the
- same production already existed (it is deleted).
-
-* Parse error messages (Gstream.Error) are formatted => spaces trigger
- Format.print_space and newlines trigger Format.force_newline.
-
-
-Camlp4 Version 0.5:
--------------------
-
-* Possible creation of native code library (make opt)
-
-* Ocaml and Righteous Syntax more complete
-
-* Added pa_ru.cmo for compiling sequences of type unit (Righteous)
-
-* Quotations AST
- - No more quotation long_id
- - Antiquotations for identifiers more simple
-
-* Lot of small changes
-
-
-Camlp4 Version 0.4:
--------------------
-
-* First distributed version
diff --git a/camlp4/ICHANGES b/camlp4/ICHANGES
deleted file mode 100644
index 5b17aaf71d..0000000000
--- a/camlp4/ICHANGES
+++ /dev/null
@@ -1,20 +0,0 @@
-Internal, very small, undocumented, or invisible changes
-********************************************************
-
-- [20 nov 03], token.mli: eval_string takes a location as a extra
- argument (needed to issue a warning).
-
-Camlp4s Version 3.06+19
------------------------
-
-- [28 Oct 02] Changed and simplified local entry of pa_o.ml from "cvalue"
- to "cvalue_binding".
-- [18 Oct 02] The standard syntax for antiquotations in object class_types
- and object class_expr are now: <:class_type< $opt:x$ $list:y$ >> and
- <:class_expr< $opt:x$ $list:y$ >>: the syntax without the "opt" is
- accepted but deprecated (a warning is displayed).
-- [15 Oct 02] Changed Plexer which now manages better the line directives
- (applied only on begin of lines, no error if parsing error in the
- directive).
-- [14 Sep 02] Grammar.print_entry does not end any more with
- Format.print_flush. The "flush" is done by Grammar.Entry.print.
diff --git a/camlp4/Makefile b/camlp4/Makefile
deleted file mode 100644
index f80090a0b4..0000000000
--- a/camlp4/Makefile
+++ /dev/null
@@ -1,190 +0,0 @@
-# $Id$
-
-include config/Makefile
-
-DIRS=odyl camlp4 meta etc top ocpp lib man
-FDIRS=odyl camlp4 meta lib
-OPTDIRS= lib odyl camlp4 meta etc compile
-SHELL=/bin/sh
-COLD_FILES=ocaml_src/camlp4/argl.ml ocaml_src/camlp4/ast2pt.ml ocaml_src/camlp4/ast2pt.mli ocaml_src/camlp4/mLast.mli ocaml_src/camlp4/pcaml.ml ocaml_src/camlp4/pcaml.mli ocaml_src/camlp4/quotation.ml ocaml_src/camlp4/quotation.mli ocaml_src/camlp4/reloc.ml ocaml_src/camlp4/reloc.mli ocaml_src/camlp4/spretty.ml ocaml_src/camlp4/spretty.mli ocaml_src/lib/extfun.ml ocaml_src/lib/extfun.mli ocaml_src/lib/fstream.ml ocaml_src/lib/fstream.mli ocaml_src/lib/gramext.ml ocaml_src/lib/gramext.mli ocaml_src/lib/grammar.ml ocaml_src/lib/grammar.mli ocaml_src/lib/plexer.ml ocaml_src/lib/plexer.mli ocaml_src/lib/stdpp.ml ocaml_src/lib/stdpp.mli ocaml_src/lib/token.ml ocaml_src/lib/token.mli ocaml_src/meta/pa_extend.ml ocaml_src/meta/pa_extend_m.ml ocaml_src/meta/pa_macro.ml ocaml_src/meta/pa_r.ml ocaml_src/meta/pa_rp.ml ocaml_src/meta/pr_dump.ml ocaml_src/meta/q_MLast.ml ocaml_src/odyl/odyl_main.ml ocaml_src/odyl/odyl_main.mli ocaml_src/odyl/odyl.ml
-
-all: boot/camlp4$(EXE)
- set -e; for i in $(DIRS); do cd $$i; $(MAKE) all; cd ..; done
-
-opt:
- cd lib; $(MAKE) opt
-
-opt.opt:
- set -e; for i in $(OPTDIRS); do cd $$i; $(MAKE) opt; cd ..; done
-
-boot/camlp4$(EXE): $(COLD_FILES)
- $(MAKE) clean_cold library_cold compile_cold
- $(MAKE) promote_cold
- $(MAKE) clean_cold clean_hot library
-
-clean_hot:
- for i in $(DIRS) compile; do (cd $$i; $(MAKE) clean); done
-
-depend:
- for i in $(DIRS) compile; do (cd $$i; $(MAKE) depend); done
-
-install:
- for i in $(DIRS) compile; do (cd $$i; $(MAKE) install BINDIR="$(BINDIR)" LIBDIR="$(LIBDIR)" MANDIR="$(MANDIR)"); done
-
-uninstall:
- rm -rf "$(LIBDIR)/camlp4"
- cd "$(BINDIR)"; rm -f *camlp4* odyl ocpp
-
-clean::
- $(MAKE) clean_hot clean_cold
- rm -f boot/*.cm[oi] boot/camlp4*
- rm -rf boot/SAVED
-
-scratch: clean
-
-always:
-
-# Normal bootstrap
-
-bootstrap: backup promote clean_hot all compare
-
-backup:
- mkdir boot.new
- make mv_cvs FROM=boot TO=boot.new
- mv boot boot.new/SAVED
- mv boot.new boot
-
-restore:
- mv boot/SAVED boot.new
- make mv_cvs FROM=boot TO=boot.new
- rm -rf boot
- mv boot.new boot
-
-promote:
- for i in $(FDIRS); do (cd $$i; $(MAKE) promote); done
-
-compare:
- @if (for i in $(FDIRS); do \
- if (cd $$i; $(MAKE) compare 2>/dev/null); then :; \
- else exit 1; fi; \
- done); \
- then echo "Fixpoint reached, bootstrap succeeded."; \
- else echo "Fixpoint not reached, try one more bootstrapping cycle."; \
- fi
-
-cleanboot:
- rm -rf boot/SAVED/SAVED
-
-
-# Core and core bootstrap
-
-bootstrap_core: backup promote clean_hot core compare
-
-core: boot/camlp4$(EXE)
- set -e; for i in $(FDIRS); do cd $$i; $(MAKE) all; cd ..; done
-
-clean_core:
- for i in $(FDIRS); do (cd $$i; $(MAKE) clean); done
-
-
-# The very beginning
-
-world:
- $(MAKE) clean_cold library_cold compile_cold
- $(MAKE) promote_cold
- $(MAKE) clean_cold clean_hot library all
-
-library:
- cd lib; $(MAKE) all promote
-
-# Cold start using pure Objective Caml sources
-
-library_cold:
- cd ocaml_src/lib; $(MAKE) all promote OTOP=../$(OTOP)
-
-compile_cold:
- cd ocaml_src; set -e; \
- for i in $(FDIRS); do \
- cd $$i; $(MAKE) all OTOP=../$(OTOP); cd ..; \
- done
-
-promote_cold:
- for i in $(FDIRS); do \
- (cd ocaml_src/$$i; $(MAKE) promote); \
- done
-
-clean_cold:
- for i in $(FDIRS); do \
- (cd ocaml_src/$$i; $(MAKE) clean); \
- done
-
-# Configuring for native win32
-
-configure_nt:
- echo pouet
- echo BINDIR = $(BINDIR)
-
-# Bootstrap the sources
-
-TXTGEN=This file has been generated by program: do not edit!
-
-bootstrap_sources:
- cd etc; make pr_o.cmo
- mkdir ocaml_src.new
- @-for i in $(FDIRS); do \
- (mkdir ocaml_src.new/$$i; cd ocaml_src.new/$$i; \
- sed 's/# $$Id.*\$$/# $(TXTGEN)/' ../../$$i/Makefile | \
- sed 's-include ../config-include ../../config-g' | \
- sed 's-../boot-../../boot-g' > Makefile; \
- sed 's/# $$Id.*\$$/# $(TXTGEN)/' ../../$$i/Makefile.Mac | \
- sed 's-:boot-::boot-g' > Makefile.Mac; \
- cp ../../$$i/.depend . ; \
- cp ../../$$i/Makefile.Mac.depend .); \
- done
- @-for i in $(FDIRS); do \
- (cd $$i; \
- for j in *.ml*; do \
- echo ============================================; \
- echo ocaml_src.new/$$i/$$j; \
- OTOP=../.. ../tools/conv.sh $$j | \
- sed 's/$$Id.*\$$/$(TXTGEN)/' > \
- ../ocaml_src.new/$$i/$$j; \
- done); \
- done
-
-untouch_sources:
- @-cd ocaml_src; \
- for i in $(FDIRS); do \
- for j in $$i/*.ml* $$i/Makefile*; do \
- if cmp -s $$j ../ocaml_src.new/$$j 2>/dev/null; then \
- cp -p $$j ../ocaml_src.new/$$j; \
- fi; \
- done; \
- done
-
-promote_sources:
- make mv_cvs FROM=ocaml_src TO=ocaml_src.new
- for i in $(FDIRS); do \
- make mv_cvs FROM=ocaml_src/$$i TO=ocaml_src.new/$$i; \
- done
- mv ocaml_src/tools ocaml_src.new/.
- mv ocaml_src ocaml_src.new/SAVED
- mv ocaml_src.new ocaml_src
-
-unpromote_sources:
- mv ocaml_src ocaml_src.new
- mv ocaml_src.new/SAVED ocaml_src
- mv ocaml_src.new/tools ocaml_src/.
- for i in $(FDIRS); do \
- make mv_cvs FROM=ocaml_src.new/$$i TO=ocaml_src/$$i; \
- done
- make mv_cvs FROM=ocaml_src.new TO=ocaml_src
-
-clean_sources:
- rm -rf ocaml_src/SAVED/SAVED
-
-# Utility
-
-mv_cvs:
- test ! -d $(FROM)/CVS || mv $(FROM)/CVS $(TO)/.
- test ! -f $(FROM)/.cvsignore || mv $(FROM)/.cvsignore $(TO)/.
diff --git a/camlp4/Makefile.Mac b/camlp4/Makefile.Mac
deleted file mode 100644
index 7b96430a1e..0000000000
--- a/camlp4/Makefile.Mac
+++ /dev/null
@@ -1,204 +0,0 @@
-#######################################################################
-# #
-# Camlp4 #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. Distributed only by permission. #
-# #
-#######################################################################
-
-# $Id$
-
-DIRS = odyl camlp4 meta etc top ocpp lib man
-FDIRS = odyl camlp4 meta lib
-
-all Ä :boot:camlp4
- for i in {DIRS}
- directory {i}
- domake all
- directory ::
- end
-
-:boot:camlp4 Ä
- domake clean_cold library_cold compile_cold
- domake promote_cold
- domake clean_cold clean_hot library
-
-clean_hot Ä
- for i in {DIRS}
- directory {i}
- domake clean
- directory ::
- end
-
-depend Ä
- for i in {DIRS}
- directory {i}
- domake depend
- directory ::
- end
-
-install Ä
- for i in {DIRS}
- directory {i}
- domake install
- directory ::
- end
-
-scratch Ä clean
- delete -i :boot:Å.cm[oi] || set status 0
- delete -i :boot:camlp4Å || set status 0
- delete -y -i :boot:SAVED
-
-clean Ä clean_hot clean_cold
-
-# Normal bootstrap
-
-bootstrap Ä backup promote clean_hot all compare
-
-backup Ä
- newfolder :boot.new
- domake mv_cvs -d FROM=:boot: -d TO=:boot.new:
- move :boot :boot.new:SAVED
- move :boot.new :boot
-
-restore Ä
- move :boot:SAVED :boot.new
- domake mv_cvs -d FROM=:boot: -d TO=:boot.new:
- delete -y -i :boot
- rename :boot.new :boot
-
-promote Ä
- for i in {FDIRS}
- directory {i}
- domake promote
- directory ::
- end
-
-compare Ä
- set failures 0
- set exit 0
- for i in {FDIRS}
- directory {i}
- domake compare ³ dev:null
- evaluate failures += {status}
- directory ::
- end
- if {failures}
- echo "Fixpoint not reached, try one more bootstrapping cycle."
- else
- echo "Fixpoint reached, bootstrap succeeded."
- end
-
-cleanboot Ä
- delete -i -y :boot:SAVED:SAVED
-
-
-# Fast bootstrap
-
-bootstrap_fast Ä backup promote clean_hot fast compare
-
-fast Ä :boot:camlp4
- for i in {FDIRS}
- directory {i}
- domake all
- directory ::
- end
-
-clean_fast Ä
- for i in {FDIRS}
- directory {i}
- domake clean
- directory ::
- end
-
-
-# The very beginning
-
-world Ä
- domake clean_cold library_cold compile_cold
- domake promote_cold
- domake clean_cold clean_hot library all
-
-library Ä
- directory lib
- domake all promote
- directory ::
-
-# Cold start using pure Objective Caml sources
-
-library_cold Ä
- directory :ocaml_src:lib
- domake all promote
- directory :::
-
-compile_cold Ä
- directory ocaml_src
- for i in {FDIRS}
- directory {i}
- domake all
- directory ::
- end
- directory ::
-
-promote_cold Ä
- for i in {FDIRS}
- directory :ocaml_src:{i}
- domake promote
- directory :::
- end
-
-clean_cold Ä
- for i in {FDIRS}
- directory :ocaml_src:{i}
- domake clean
- directory :::
- end
-
-# Bootstrap the sources
-
-#bootstrap_sources Ä
-# cd etc; make pr_o.cmo
-# mkdir ocaml_src.new
-# @-for i in $(FDIRS); do \
-# (mkdir ocaml_src.new/$$i; cd ocaml_src.new/$$i; \
-# sed 's/# $$Id.*\$$/# Id/' ../../$$i/Makefile | \
-# sed 's-include ../config-include ../../config-g' | \
-# sed 's-../boot-../../boot-g' > Makefile; \
-# cp ../../$$i/.depend .) \
-# done
-# @-for i in $(FDIRS); do \
-# for j in $$i/*.ml*; do \
-# echo ============================================; \
-# echo ocaml_src.new/$$j; \
-# ./tools/conv.sh $$j | \
-# sed 's/$$Id.*\$$/Id/' > ocaml_src.new/$$j; \
-# done; \
-# done
-
-#promote_sources:
-# make mv_cvs FROM=ocaml_src TO=ocaml_src.new
-# for i in $(FDIRS); do \
-# make mv_cvs FROM=ocaml_src/$$i TO=ocaml_src.new/$$i; \
-# done
-# mv ocaml_src/tools ocaml_src.new/.
-# mv ocaml_src ocaml_src.new/SAVED
-# mv ocaml_src.new ocaml_src
-
-#unpromote_sources:
-# mv ocaml_src ocaml_src.new
-# mv ocaml_src.new/SAVED ocaml_src
-# mv ocaml_src.new/tools ocaml_src/.
-# for i in $(FDIRS); do \
-# make mv_cvs FROM=ocaml_src.new/$$i TO=ocaml_src/$$i; \
-# done
-# make mv_cvs FROM=ocaml_src.new TO=ocaml_src
-
-#clean_sources:
-# rm -rf ocaml_src/SAVED/SAVED
-
-mv_cvs Ä
- if "`exists "{FROM}CVS"`"; move "{FROM}CVS" "{TO}"; end
- if "`exists "{FROM}.cvsignore"`"; move "{FROM}.cvsignore" "{TO}"; end
diff --git a/camlp4/boot/.cvsignore b/camlp4/boot/.cvsignore
deleted file mode 100644
index 85599a4b58..0000000000
--- a/camlp4/boot/.cvsignore
+++ /dev/null
@@ -1,5 +0,0 @@
-*.cm[oia]
-camlp4
-camlp4o
-camlp4r
-SAVED
diff --git a/camlp4/camlp4/.cvsignore b/camlp4/camlp4/.cvsignore
deleted file mode 100644
index 38b5e0906f..0000000000
--- a/camlp4/camlp4/.cvsignore
+++ /dev/null
@@ -1,6 +0,0 @@
-*.cm[oia]
-camlp4
-*.lib
-crc.ml
-extract_crc
-phony
diff --git a/camlp4/camlp4/.depend b/camlp4/camlp4/.depend
deleted file mode 100644
index bf82065403..0000000000
--- a/camlp4/camlp4/.depend
+++ /dev/null
@@ -1,21 +0,0 @@
-ast2pt.cmi: $(OTOP)/parsing/location.cmi $(OTOP)/parsing/longident.cmi mLast.cmi \
- $(OTOP)/parsing/parsetree.cmi
-pcaml.cmi: mLast.cmi spretty.cmi
-quotation.cmi: mLast.cmi
-reloc.cmi: mLast.cmi
-argl.cmo: ast2pt.cmi mLast.cmi ../odyl/odyl_main.cmi pcaml.cmi
-argl.cmx: ast2pt.cmx mLast.cmi ../odyl/odyl_main.cmx pcaml.cmx
-ast2pt.cmo: $(OTOP)/parsing/asttypes.cmi $(OTOP)/parsing/location.cmi \
- $(OTOP)/parsing/longident.cmi mLast.cmi $(OTOP)/parsing/parsetree.cmi \
- ast2pt.cmi
-ast2pt.cmx: $(OTOP)/parsing/asttypes.cmi $(OTOP)/parsing/location.cmx \
- $(OTOP)/parsing/longident.cmx mLast.cmi $(OTOP)/parsing/parsetree.cmi \
- ast2pt.cmi
-pcaml.cmo: ast2pt.cmi mLast.cmi quotation.cmi reloc.cmi spretty.cmi pcaml.cmi
-pcaml.cmx: ast2pt.cmx mLast.cmi quotation.cmx reloc.cmx spretty.cmx pcaml.cmi
-quotation.cmo: mLast.cmi quotation.cmi
-quotation.cmx: mLast.cmi quotation.cmi
-reloc.cmo: mLast.cmi reloc.cmi
-reloc.cmx: mLast.cmi reloc.cmi
-spretty.cmo: spretty.cmi
-spretty.cmx: spretty.cmi
diff --git a/camlp4/camlp4/Makefile b/camlp4/camlp4/Makefile
deleted file mode 100644
index 31ffc05057..0000000000
--- a/camlp4/camlp4/Makefile
+++ /dev/null
@@ -1,71 +0,0 @@
-# $Id$
-
-include ../config/Makefile
-
-SHELL=/bin/sh
-
-INCLUDES=-I ../odyl -I ../boot -I $(OTOP)/utils -I $(OTOP)/parsing -I $(OTOP)/otherlibs/dynlink
-OCAMLCFLAGS= $(INCLUDES) -warn-error A $(INCLUDES)
-LINKFLAGS=$(INCLUDES)
-INTERFACES=-I $(OLIBDIR) Arg Array ArrayLabels Buffer Callback CamlinternalOO Char Complex Digest Filename Format Gc Genlex Hashtbl Int32 Int64 Lazy Lexing List ListLabels Map Marshal MoreLabels Nativeint Obj Oo Parsing Pervasives Printexc Printf Queue Random Scanf Set Sort Stack StdLabels Stream String StringLabels Sys Weak -I ../boot Extfold Extfun Fstream Gramext Grammar Plexer Stdpp Token -I $(OTOP)/utils Config Warnings -I $(OTOP)/parsing Asttypes Location Longident Parsetree -I . Ast2pt MLast Pcaml Quotation Spretty
-CAMLP4_INTF=$(OTOP)/utils/config.cmi $(OTOP)/utils/warnings.cmi $(OTOP)/parsing/asttypes.cmi $(OTOP)/parsing/location.cmi $(OTOP)/parsing/longident.cmi $(OTOP)/parsing/parsetree.cmi ast2pt.cmi mLast.cmi pcaml.cmi spretty.cmi quotation.cmi
-CAMLP4_OBJS=../boot/stdpp.cmo ../boot/token.cmo ../boot/plexer.cmo ../boot/gramext.cmo ../boot/grammar.cmo ../boot/extfold.cmo ../boot/extfun.cmo ../boot/fstream.cmo $(OTOP)/utils/config.cmo quotation.cmo ast2pt.cmo spretty.cmo reloc.cmo pcaml.cmo argl.cmo
-CAMLP4_XOBJS=../lib/stdpp.cmx ../lib/token.cmx ../lib/plexer.cmx ../lib/gramext.cmx ../lib/grammar.cmx ../lib/extfold.cmx ../lib/extfun.cmx ../lib/fstream.cmx $(OTOP)/utils/config.cmx quotation.cmx ast2pt.cmx spretty.cmx reloc.cmx pcaml.cmx argl.cmx
-OBJS=../odyl/odyl.cma camlp4.cma
-CAMLP4M=
-
-CAMLP4=camlp4$(EXE)
-CAMLP4OPT=phony
-
-all: $(CAMLP4)
-opt: $(OBJS:.cma=.cmxa)
-optp4: $(CAMLP4OPT)
-
-$(CAMLP4): $(OBJS) ../odyl/odyl.cmo
- $(OCAMLC) $(OBJS) $(CAMLP4M) ../odyl/odyl.cmo -linkall -o $(CAMLP4)
-
-$(CAMLP4OPT): $(OBJS:.cma=.cmxa) ../odyl/odyl.cmx
- $(OCAMLOPT) $(OBJS:.cma=.cmxa) $(CAMLP4M) ../odyl/odyl.cmx -linkall -o $(CAMLP4OPT)
-
-$(OTOP)/utils/config.cmx: $(OTOP)/utils/config.ml
- $(OCAMLOPT) -c $(OTOP)/utils/config.ml
-
-camlp4.cma: $(CAMLP4_OBJS)
- $(OCAMLC) $(LINKFLAGS) $(CAMLP4_OBJS) -a -o camlp4.cma
-
-camlp4.cmxa: $(CAMLP4_XOBJS)
- $(OCAMLOPT) $(LINKFLAGS) $(CAMLP4_XOBJS) -a -o camlp4.cmxa
-
-clean::
- rm -f *.cm* *.pp[io] *.$(O) *.$(A) *.bak .*.bak *.out *.opt
- rm -f $(CAMLP4)
-
-depend:
- cp .depend .depend.bak
- > .depend
- @for i in *.mli *.ml; do \
- ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \
- sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \
- done
-
-promote:
- cp $(CAMLP4) ../boot/.
-
-compare:
- @for j in $(CAMLP4); do \
- if cmp $$j ../boot/$$j; then :; else exit 1; fi; \
- done
-
-install:
- -$(MKDIR) "$(BINDIR)"
- -$(MKDIR) "$(LIBDIR)/camlp4"
- cp $(CAMLP4) "$(BINDIR)/."
- cp mLast.mli quotation.mli ast2pt.mli pcaml.mli spretty.mli "$(LIBDIR)/camlp4/."
- cp mLast.cmi quotation.cmi ast2pt.cmi pcaml.cmi spretty.cmi "$(LIBDIR)/camlp4/."
- cp camlp4.cma $(LIBDIR)/camlp4/.
- if [ -f camlp4.cmxa ]; \
- then cp camlp4.cmxa camlp4.$(A) $(LIBDIR)/camlp4/.; \
- else : ; \
- fi
-
-include .depend
diff --git a/camlp4/camlp4/Makefile.Mac b/camlp4/camlp4/Makefile.Mac
deleted file mode 100644
index 63a0e6bed3..0000000000
--- a/camlp4/camlp4/Makefile.Mac
+++ /dev/null
@@ -1,69 +0,0 @@
-#######################################################################
-# #
-# Camlp4 #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. Distributed only by permission. #
-# #
-#######################################################################
-
-# $Id$
-
-INCLUDES = -I ::odyl: -I ::boot: -I "{OTOP}utils:" -I "{OTOP}parsing:" ¶
- -I "{OTOP}otherlibs:dynlink:"
-OCAMLCFLAGS = {INCLUDES}
-LINKFLAGS = {INCLUDES}
-INTERFACES = -I "{OLIBDIR}" Arg Array ArrayLabels Buffer Callback CamlinternalOO Char Complex Digest Filename Format Gc Genlex Hashtbl Int32 Int64 Lazy Lexing List ListLabels Map Marshal MoreLabels Nativeint Obj Oo Parsing Pervasives Printexc Printf Queue Random Scanf Set Sort Stack StdLabels Stream String StringLabels Sys Weak ¶
- -I ::boot: Extfold Extfun Fstream ¶
- Gramext Grammar Plexer ¶
- Stdpp Token -I "{OTOP}utils:" Config Warnings ¶
- -I "{OTOP}parsing:" Asttypes Location Longident Parsetree ¶
- -I : Ast2pt MLast Pcaml Quotation Spretty
-CAMLP4_INTF = "{OTOP}utils:config.cmi" "{OTOP}utils:warnings.cmi" ¶
- "{OTOP}parsing:asttypes.cmi" "{OTOP}parsing:location.cmi" ¶
- "{OTOP}parsing:longident.cmi" "{OTOP}parsing:parsetree.cmi" ¶
- ast2pt.cmo mLast.cmi pcaml.cmi spretty.cmi ¶
- quotation.cmi
-CAMLP4_OBJS = ::boot:stdpp.cmo ::boot:token.cmo ::boot:plexer.cmo ¶
- ::boot:gramext.cmo ::boot:grammar.cmo ::boot:extfold.cmo ::boot:extfun.cmo ¶
- ::boot:fstream.cmo "{OTOP}utils:config.cmo" ¶
- quotation.cmo ast2pt.cmo spretty.cmo reloc.cmo pcaml.cmo ¶
- argl.cmo crc.cmo
-OBJS = ::odyl:odyl.cma camlp4.cma
-XOBJS = camlp4.cmxa
-CAMLP4M =
-
-CAMLP4 = camlp4
-
-all Ä {CAMLP4}
-
-{CAMLP4} Ä {OBJS} ::odyl:odyl.cmo
- {OCAMLC} {OBJS} {CAMLP4M} ::odyl:odyl.cmo -linkall -o {CAMLP4}
-
-camlp4.cma Ä {CAMLP4_OBJS}
- {OCAMLC} {LINKFLAGS} {CAMLP4_OBJS} -a -o camlp4.cma
-
-clean ÄÄ
- delete -i {CAMLP4}
-
-{dependrule}
-
-promote Ä
- duplicate -y {CAMLP4} ::boot:
-
-compare Ä
- for i in {CAMLP4}
- equal -s {i} ::boot:{i} || exit 1
- end
-
-install Ä
- (newfolder "{BINDIR}" || set status 0) ³ dev:null
- duplicate -y {CAMLP4} "{BINDIR}"
- duplicate -y mLast.mli quotation.mli pcaml.mli spretty.mli "{P4LIBDIR}"
- duplicate -y mLast.cmi quotation.cmi ast2pt.cmi pcaml.cmi spretty.cmi ¶
- "{P4LIBDIR}"
- duplicate -y camlp4.cma "{P4LIBDIR}"
-
-{defrules}
diff --git a/camlp4/camlp4/Makefile.Mac.depend b/camlp4/camlp4/Makefile.Mac.depend
deleted file mode 100644
index 3665195f77..0000000000
--- a/camlp4/camlp4/Makefile.Mac.depend
+++ /dev/null
@@ -1,15 +0,0 @@
-pcaml.cmiÄ mLast.cmi spretty.cmi
-quotation.cmiÄ mLast.cmi
-reloc.cmiÄ mLast.cmi
-argl.cmoÄ ast2pt.cmo mLast.cmi pcaml.cmi
-argl.cmxÄ ast2pt.cmx mLast.cmi pcaml.cmx
-ast2pt.cmoÄ mLast.cmi
-ast2pt.cmxÄ mLast.cmi
-pcaml.cmoÄ ast2pt.cmo mLast.cmi quotation.cmi reloc.cmi spretty.cmi pcaml.cmi
-pcaml.cmxÄ ast2pt.cmx mLast.cmi quotation.cmx reloc.cmx spretty.cmx pcaml.cmi
-quotation.cmoÄ mLast.cmi quotation.cmi
-quotation.cmxÄ mLast.cmi quotation.cmi
-reloc.cmoÄ mLast.cmi reloc.cmi
-reloc.cmxÄ mLast.cmi reloc.cmi
-spretty.cmoÄ spretty.cmi
-spretty.cmxÄ spretty.cmi
diff --git a/camlp4/camlp4/argl.ml b/camlp4/camlp4/argl.ml
deleted file mode 100644
index 8880f07fd1..0000000000
--- a/camlp4/camlp4/argl.ml
+++ /dev/null
@@ -1,424 +0,0 @@
-(* camlp4r q_MLast.cmo *)
-(* $Id$ *)
-
-open Printf;
-
-value rec action_arg s sl =
- fun
- [ Arg.Unit f -> if s = "" then do { f (); Some sl } else None
- | Arg.Bool f ->
- if s = "" then
- match sl with
- [ [s :: sl] ->
- try do { f (bool_of_string s); Some sl } with
- [ Invalid_argument "bool_of_string" -> None ]
- | [] -> None ]
- else
- try do { f (bool_of_string s); Some sl } with
- [ Invalid_argument "bool_of_string" -> None ]
- | Arg.Set r -> if s = "" then do { r.val := True; Some sl } else None
- | Arg.Clear r -> if s = "" then do { r.val := False; Some sl } else None
- | Arg.Rest f -> do { List.iter f [s :: sl]; Some [] }
- | Arg.String f ->
- if s = "" then
- match sl with
- [ [s :: sl] -> do { f s; Some sl }
- | [] -> None ]
- else do { f s; Some sl }
- | Arg.Set_string r ->
- if s = "" then
- match sl with
- [ [s :: sl] -> do { r.val := s; Some sl }
- | [] -> None ]
- else do { r.val := s; Some sl }
- | Arg.Int f ->
- if s = "" then
- match sl with
- [ [s :: sl] ->
- try do { f (int_of_string s); Some sl } with
- [ Failure "int_of_string" -> None ]
- | [] -> None ]
- else
- try do { f (int_of_string s); Some sl } with
- [ Failure "int_of_string" -> None ]
- | Arg.Set_int r ->
- if s = "" then
- match sl with
- [ [s :: sl] ->
- try do { r.val := (int_of_string s); Some sl } with
- [ Failure "int_of_string" -> None ]
- | [] -> None ]
- else
- try do { r.val := (int_of_string s); Some sl } with
- [ Failure "int_of_string" -> None ]
- | Arg.Float f ->
- if s = "" then
- match sl with
- [ [s :: sl] -> do { f (float_of_string s); Some sl }
- | [] -> None ]
- else do { f (float_of_string s); Some sl }
- | Arg.Set_float r ->
- if s = "" then
- match sl with
- [ [s :: sl] -> do { r.val := (float_of_string s); Some sl }
- | [] -> None ]
- else do { r.val := (float_of_string s); Some sl }
- | Arg.Tuple specs ->
- let rec action_args s sl =
- fun
- [ [] -> Some sl
- | [spec :: spec_list] ->
- match action_arg s sl spec with
- [ None -> action_args "" [] spec_list
- | Some [s :: sl] -> action_args s sl spec_list
- | Some sl -> action_args "" sl spec_list
- ]
- ] in
- action_args s sl specs
- | Arg.Symbol syms f ->
- match (if s = "" then sl else [s :: sl]) with
- [ [s :: sl] when List.mem s syms -> do { f s; Some sl }
- | _ -> None ]
- ]
-;
-
-value common_start s1 s2 =
- loop 0 where rec loop i =
- if i == String.length s1 || i == String.length s2 then i
- else if s1.[i] == s2.[i] then loop (i + 1)
- else i
-;
-
-value rec parse_arg s sl =
- fun
- [ [(name, action, _) :: spec_list] ->
- let i = common_start s name in
- if i == String.length name then
- try action_arg (String.sub s i (String.length s - i)) sl action with
- [ Arg.Bad _ -> parse_arg s sl spec_list ]
- else parse_arg s sl spec_list
- | [] -> None ]
-;
-
-value rec parse_aux spec_list anon_fun =
- fun
- [ [] -> []
- | [s :: sl] ->
- if String.length s > 1 && s.[0] = '-' then
- match parse_arg s sl spec_list with
- [ Some sl -> parse_aux spec_list anon_fun sl
- | None -> [s :: parse_aux spec_list anon_fun sl] ]
- else do { (anon_fun s : unit); parse_aux spec_list anon_fun sl } ]
-;
-
-value loc_fmt =
- match Sys.os_type with
- [ "MacOS" ->
- format_of_string "File \"%s\"; line %d; characters %d to %d\n### "
- | _ ->
- format_of_string "File \"%s\", line %d, characters %d-%d:\n" ]
-;
-
-value print_location loc =
- if Pcaml.input_file.val <> "-" then
- let (fname, line, bp, ep) = Stdpp.line_of_loc Pcaml.input_file.val loc in
- eprintf loc_fmt Pcaml.input_file.val line bp ep
- else eprintf "At location %d-%d\n" (fst loc) (snd loc)
-;
-
-value print_warning loc s =
- do { print_location loc; eprintf "%s\n" s }
-;
-
-value rec parse_file pa getdir useast =
- let name = Pcaml.input_file.val in
- do {
- Pcaml.warning.val := print_warning;
- let ic = if name = "-" then stdin else open_in_bin name in
- let cs = Stream.of_channel ic in
- let clear () = if name = "-" then () else close_in ic in
- let phr =
- try
- loop () where rec loop () =
- let (pl, stopped_at_directive) = pa cs in
- if stopped_at_directive then
- let pl =
- let rpl = List.rev pl in
- match getdir rpl with
- [ Some x ->
- match x with
- [ (loc, "load", Some <:expr< $str:s$ >>) ->
- do { Odyl_main.loadfile s; pl }
- | (loc, "directory", Some <:expr< $str:s$ >>) ->
- do { Odyl_main.directory s; pl }
- | (loc, "use", Some <:expr< $str:s$ >>) ->
- List.rev_append rpl
- [(useast loc s (use_file pa getdir useast s), loc)]
- | (loc, _, _) ->
- Stdpp.raise_with_loc loc (Stream.Error "bad directive") ]
- | None -> pl ]
- in
- pl @ loop ()
- else pl
- with x ->
- do { clear (); raise x }
- in
- clear ();
- phr
- }
-and use_file pa getdir useast s =
- let clear =
- let v_input_file = Pcaml.input_file.val in
- fun () -> Pcaml.input_file.val := v_input_file
- in
- do {
- Pcaml.input_file.val := s;
- try
- let r = parse_file pa getdir useast in
- do { clear (); r }
- with e ->
- do { clear (); raise e }
- }
-;
-
-value process pa pr getdir useast =
- pr (parse_file pa getdir useast);
-
-
-value gind =
- fun
- [ [(MLast.SgDir loc n dp, _) :: _] -> Some (loc, n, dp)
- | _ -> None ]
-;
-
-value gimd =
- fun
- [ [(MLast.StDir loc n dp, _) :: _] -> Some (loc, n, dp)
- | _ -> None ]
-;
-
-value usesig loc fname ast = MLast.SgUse loc fname ast;
-value usestr loc fname ast = MLast.StUse loc fname ast;
-
-value process_intf () =
- process Pcaml.parse_interf.val Pcaml.print_interf.val gind usesig;
-value process_impl () =
- process Pcaml.parse_implem.val Pcaml.print_implem.val gimd usestr;
-
-type file_kind =
- [ Intf
- | Impl ]
-;
-value file_kind = ref Intf;
-value file_kind_of_name name =
- if Filename.check_suffix name ".mli" then Intf
- else if Filename.check_suffix name ".ml" then Impl
- else raise (Arg.Bad ("don't know what to do with " ^ name))
-;
-
-value print_version () =
- do {
- eprintf "Camlp4 version %s\n" Pcaml.version; flush stderr; exit 0
- }
-;
-
-value align_doc key s =
- let s =
- loop 0 where rec loop i =
- if i = String.length s then ""
- else if s.[i] = ' ' then loop (i + 1)
- else String.sub s i (String.length s - i)
- in
- let (p, s) =
- if String.length s > 0 then
- if s.[0] = '<' then
- loop 0 where rec loop i =
- if i = String.length s then ("", s)
- else if s.[i] <> '>' then loop (i + 1)
- else
- let p = String.sub s 0 (i + 1) in
- loop (i + 1) where rec loop i =
- if i >= String.length s then (p, "")
- else if s.[i] = ' ' then loop (i + 1)
- else (p, String.sub s i (String.length s - i))
- else ("", s)
- else ("", "")
- in
- let tab =
- String.make (max 1 (13 - String.length key - String.length p)) ' '
- in
- p ^ tab ^ s
-;
-
-value make_symlist l =
- match l with
- [ [] -> "<none>"
- | [h::t] -> (List.fold_left (fun x y -> x ^ "|" ^ y) ("{" ^ h) t) ^ "}" ]
-;
-
-value print_usage_list l =
- List.iter
- (fun (key, spec, doc) ->
- match spec with
- [ Arg.Symbol symbs _ ->
- let s = make_symlist symbs in
- let synt = key ^ " " ^ s in
- eprintf " %s %s\n" synt (align_doc synt doc)
- | _ -> eprintf " %s %s\n" key (align_doc key doc) ] )
- l
-;
-
-value make_symlist l =
- match l with
- [ [] -> "<none>"
- | [h :: t] -> (List.fold_left (fun x y -> x ^ "|" ^ y) ("{" ^ h) t) ^ "}" ]
-;
-
-value print_usage_list l =
- List.iter
- (fun (key, spec, doc) ->
- match spec with
- [ Arg.Symbol symbs _ ->
- let s = make_symlist symbs in
- let synt = key ^ " " ^ s in
- eprintf " %s %s\n" synt (align_doc synt doc)
- | _ -> eprintf " %s %s\n" key (align_doc key doc) ] )
- l
-;
-
-value usage ini_sl ext_sl =
- do {
- eprintf "\
-Usage: camlp4 [load-options] [--] [other-options]
-Load options:
- -I directory Add directory in search patch for object files.
- -where Print camlp4 library directory and exit.
- -nolib No automatic search for object files in library directory.
- <object-file> Load this file in Camlp4 core.
-Other options:
- <file> Parse this file.\n";
- print_usage_list ini_sl;
- loop (ini_sl @ ext_sl) where rec loop =
- fun
- [ [(y, _, _) :: _] when y = "-help" -> ()
- | [_ :: sl] -> loop sl
- | [] -> eprintf " -help Display this list of options.\n" ];
- if ext_sl <> [] then do {
- eprintf "Options added by loaded object files:\n";
- print_usage_list ext_sl;
- }
- else ();
- }
-;
-
-value warn_noassert () =
- do {
- eprintf "\
-camlp4 warning: option -noassert is obsolete
-You should give the -noassert option to the ocaml compiler instead.
-";
- }
-;
-
-value initial_spec_list =
- [("-intf",
- Arg.String
- (fun x -> do { file_kind.val := Intf; Pcaml.input_file.val := x }),
- "<file> Parse <file> as an interface, whatever its extension.");
- ("-impl",
- Arg.String
- (fun x -> do { file_kind.val := Impl; Pcaml.input_file.val := x }),
- "<file> Parse <file> as an implementation, whatever its extension.");
- ("-unsafe", Arg.Set Ast2pt.fast,
- "Generate unsafe accesses to array and strings.");
- ("-noassert", Arg.Unit warn_noassert,
- "Obsolete, do not use this option.");
- ("-verbose", Arg.Set Grammar.error_verbose,
- "More verbose in parsing errors.");
- ("-loc", Arg.String (fun x -> Stdpp.loc_name.val := x),
- "<name> Name of the location variable (default: " ^ Stdpp.loc_name.val ^
- ")");
- ("-QD", Arg.String (fun x -> Pcaml.quotation_dump_file.val := Some x),
- "<file> Dump quotation expander result in case of syntax error.");
- ("-o", Arg.String (fun x -> Pcaml.output_file.val := Some x),
- "<file> Output on <file> instead of standard output.");
- ("-v", Arg.Unit print_version,
- "Print Camlp4 version and exit.")]
-;
-
-value anon_fun x =
- do { Pcaml.input_file.val := x; file_kind.val := file_kind_of_name x }
-;
-
-value parse spec_list anon_fun remaining_args =
- let spec_list =
- Sort.list (fun (k1, _, _) (k2, _, _) -> k1 >= k2) spec_list
- in
- try parse_aux spec_list anon_fun remaining_args with
- [ Arg.Bad s ->
- do {
- eprintf "Error: %s\n" s;
- eprintf "Use option -help for usage\n";
- flush stderr;
- exit 2
- } ]
-;
-
-value remaining_args =
- let rec loop l i =
- if i == Array.length Sys.argv then l else loop [Sys.argv.(i) :: l] (i + 1)
- in
- List.rev (loop [] (Arg.current.val + 1))
-;
-
-value report_error =
- fun
- [ Odyl_main.Error fname msg ->
- do {
- Format.print_string "Error while loading \"";
- Format.print_string fname;
- Format.print_string "\": ";
- Format.print_string msg
- }
- | exc -> Pcaml.report_error exc ]
-;
-
-value go () =
- let ext_spec_list = Pcaml.arg_spec_list () in
- let arg_spec_list = initial_spec_list @ ext_spec_list in
- do {
- match parse arg_spec_list anon_fun remaining_args with
- [ [] -> ()
- | ["-help" :: sl] -> do { usage initial_spec_list ext_spec_list; exit 0 }
- | [s :: sl] ->
- do {
- eprintf "%s: unknown or misused option\n" s;
- eprintf "Use option -help for usage\n";
- exit 2
- } ];
- try
- if Pcaml.input_file.val <> "" then
- match file_kind.val with
- [ Intf -> process_intf ()
- | Impl -> process_impl () ]
- else ()
- with exc ->
- do {
- Format.set_formatter_out_channel stderr;
- Format.open_vbox 0;
- let exc =
- match exc with
- [ Stdpp.Exc_located (bp, ep) exc ->
- do { print_location (bp, ep); exc }
- | _ -> exc ]
- in
- report_error exc;
- Format.close_box ();
- Format.print_newline ();
- exit 2
- }
- }
-;
-
-Odyl_main.name.val := "camlp4";
-Odyl_main.go.val := go;
diff --git a/camlp4/camlp4/ast2pt.ml b/camlp4/camlp4/ast2pt.ml
deleted file mode 100644
index 09b2e037b3..0000000000
--- a/camlp4/camlp4/ast2pt.ml
+++ /dev/null
@@ -1,867 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Stdpp;
-open MLast;
-open Parsetree;
-open Longident;
-open Asttypes;
-
-value fast = ref False;
-value no_constructors_arity = ref False;
-
-value get_tag x =
- if Obj.is_block (Obj.repr x) then Obj.tag (Obj.repr x) else Obj.magic x
-;
-
-value error loc str = raise_with_loc loc (Failure str);
-
-value char_of_char_token loc s =
- try Token.eval_char s with [ Failure _ as exn -> raise_with_loc loc exn ]
-;
-
-value string_of_string_token loc s =
- try Token.eval_string loc s
- with [ Failure _ as exn -> raise_with_loc loc exn ]
-;
-
-value glob_fname = ref "";
-
-value mkloc (bp, ep) =
- let loc_at n = {
- Lexing.pos_fname = glob_fname.val;
- Lexing.pos_lnum = 1; (* ddr met -1 ici ??? *)
- Lexing.pos_bol = 0;
- Lexing.pos_cnum = n
- }
- in
- {Location.loc_start = loc_at bp;
- Location.loc_end = loc_at ep;
- Location.loc_ghost = False} (* ddr met: bp = 0 && ep = 0 *)
-;
-
-value mkghloc (bp, ep) =
- let loc_at n = {
- Lexing.pos_fname = "";
- Lexing.pos_lnum = 1;
- Lexing.pos_bol = 0;
- Lexing.pos_cnum = n
- }
- in
- {Location.loc_start = loc_at bp;
- Location.loc_end = loc_at ep;
- Location.loc_ghost = True}
-;
-
-value mktyp loc d = {ptyp_desc = d; ptyp_loc = mkloc loc};
-value mkpat loc d = {ppat_desc = d; ppat_loc = mkloc loc};
-value mkghpat loc d = {ppat_desc = d; ppat_loc = mkghloc loc};
-value mkexp loc d = {pexp_desc = d; pexp_loc = mkloc loc};
-value mkmty loc d = {pmty_desc = d; pmty_loc = mkloc loc};
-value mksig loc d = {psig_desc = d; psig_loc = mkloc loc};
-value mkmod loc d = {pmod_desc = d; pmod_loc = mkloc loc};
-value mkstr loc d = {pstr_desc = d; pstr_loc = mkloc loc};
-value mkfield loc d = {pfield_desc = d; pfield_loc = mkloc loc};
-value mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc};
-value mkpcl loc d = {pcl_desc = d; pcl_loc = mkloc loc};
-value mkpolytype t =
- match t with
- [ TyPol _ _ _ -> t
- | _ -> TyPol (MLast.loc_of_ctyp t) [] t ]
-;
-
-value lident s = Lident s;
-value ldot l s = Ldot l s;
-
-value conv_con =
- let t = Hashtbl.create 73 in
- do {
- List.iter (fun (s, s') -> Hashtbl.add t s s')
- [("True", "true"); ("False", "false"); (" True", "True");
- (" False", "False")];
- fun s -> try Hashtbl.find t s with [ Not_found -> s ]
- }
-;
-
-value conv_lab =
- let t = Hashtbl.create 73 in
- do {
- List.iter (fun (s, s') -> Hashtbl.add t s s') [("val", "contents")];
- fun s -> try Hashtbl.find t s with [ Not_found -> s ]
- }
-;
-
-value array_function str name =
- ldot (lident str) (if fast.val then "unsafe_" ^ name else name)
-;
-
-value mkrf =
- fun
- [ True -> Recursive
- | False -> Nonrecursive ]
-;
-
-value mkli s =
- loop (fun s -> lident s) where rec loop f =
- fun
- [ [i :: il] -> loop (fun s -> ldot (f i) s) il
- | [] -> f s ]
-;
-
-value long_id_of_string_list loc sl =
- match List.rev sl with
- [ [] -> error loc "bad ast"
- | [s :: sl] -> mkli s (List.rev sl) ]
-;
-
-value rec ctyp_fa al =
- fun
- [ TyApp _ f a -> ctyp_fa [a :: al] f
- | f -> (f, al) ]
-;
-
-value rec ctyp_long_id =
- fun
- [ TyAcc _ m (TyLid _ s) ->
- let (is_cls, li) = ctyp_long_id m in
- (is_cls, ldot li s)
- | TyAcc _ m (TyUid _ s) ->
- let (is_cls, li) = ctyp_long_id m in
- (is_cls, ldot li s)
- | TyApp _ m1 m2 ->
- let (is_cls, li1) = ctyp_long_id m1 in
- let (_, li2) = ctyp_long_id m2 in
- (is_cls, Lapply li1 li2)
- | TyUid _ s -> (False, lident s)
- | TyLid _ s -> (False, lident s)
- | TyCls loc sl -> (True, long_id_of_string_list loc sl)
- | t -> error (loc_of_ctyp t) "incorrect type" ]
-;
-
-value rec ctyp =
- fun
- [ TyAcc loc _ _ as f ->
- let (is_cls, li) = ctyp_long_id f in
- if is_cls then mktyp loc (Ptyp_class li [] [])
- else mktyp loc (Ptyp_constr li [])
- | TyAli loc t1 t2 ->
- let (t, i) =
- match (t1, t2) with
- [ (t, TyQuo _ s) -> (t, s)
- | (TyQuo _ s, t) -> (t, s)
- | _ -> error loc "incorrect alias type" ]
- in
- mktyp loc (Ptyp_alias (ctyp t) i)
- | TyAny loc -> mktyp loc Ptyp_any
- | TyApp loc _ _ as f ->
- let (f, al) = ctyp_fa [] f in
- let (is_cls, li) = ctyp_long_id f in
- if is_cls then mktyp loc (Ptyp_class li (List.map ctyp al) [])
- else mktyp loc (Ptyp_constr li (List.map ctyp al))
- | TyArr loc (TyLab loc1 lab t1) t2 ->
- mktyp loc (Ptyp_arrow lab (ctyp t1) (ctyp t2))
- | TyArr loc (TyOlb loc1 lab t1) t2 ->
- let t1 = TyApp loc1 (TyLid loc1 "option") t1 in
- mktyp loc (Ptyp_arrow ("?" ^ lab) (ctyp t1) (ctyp t2))
- | TyArr loc t1 t2 -> mktyp loc (Ptyp_arrow "" (ctyp t1) (ctyp t2))
- | TyObj loc fl v -> mktyp loc (Ptyp_object (meth_list loc fl v))
- | TyCls loc id ->
- mktyp loc (Ptyp_class (long_id_of_string_list loc id) [] [])
- | TyLab loc _ _ -> error loc "labelled type not allowed here"
- | TyLid loc s -> mktyp loc (Ptyp_constr (lident s) [])
- | TyMan loc _ _ -> error loc "manifest type not allowed here"
- | TyOlb loc lab _ -> error loc "labelled type not allowed here"
- | TyPol loc pl t -> mktyp loc (Ptyp_poly pl (ctyp t))
- | TyQuo loc s -> mktyp loc (Ptyp_var s)
- | TyRec loc _ _ -> error loc "record type not allowed here"
- | TySum loc _ _ -> error loc "sum type not allowed here"
- | TyTup loc tl -> mktyp loc (Ptyp_tuple (List.map ctyp tl))
- | TyUid loc s -> mktyp loc (Ptyp_constr (lident s) [])
- | TyVrn loc catl ool ->
- let catl =
- List.map
- (fun
- [ RfTag c a t -> Rtag c a (List.map ctyp t)
- | RfInh t -> Rinherit (ctyp t) ])
- catl
- in
- let (clos, sl) =
- match ool with
- [ None -> (True, None)
- | Some None -> (False, None)
- | Some (Some sl) -> (True, Some sl) ]
- in
- mktyp loc (Ptyp_variant catl clos sl) ]
-and meth_list loc fl v =
- match fl with
- [ [] -> if v then [mkfield loc Pfield_var] else []
- | [(lab, t) :: fl] ->
- [mkfield loc (Pfield lab (ctyp (mkpolytype t))) :: meth_list loc fl v] ]
-;
-
-value mktype loc tl cl tk tm =
- let (params, variance) = List.split tl in
- {ptype_params = params; ptype_cstrs = cl; ptype_kind = tk;
- ptype_manifest = tm; ptype_loc = mkloc loc; ptype_variance = variance}
-;
-value mkmutable m = if m then Mutable else Immutable;
-value mkprivate m = if m then Private else Public;
-value mktrecord (_, n, m, t) = (n, mkmutable m, ctyp (mkpolytype t));
-value mkvariant (_, c, tl) = (c, List.map ctyp tl);
-value type_decl tl cl =
- fun
- [ TyMan loc t (TyRec _ pflag ltl) ->
- mktype loc tl cl (Ptype_record (List.map mktrecord ltl) (mkprivate pflag))
- (Some (ctyp t))
- | TyMan loc t (TySum _ pflag ctl) ->
- mktype loc tl cl (Ptype_variant (List.map mkvariant ctl) (mkprivate pflag))
- (Some (ctyp t))
- | TyRec loc pflag ltl ->
- mktype loc tl cl (Ptype_record (List.map mktrecord ltl) (mkprivate pflag)) None
- | TySum loc pflag ctl ->
- mktype loc tl cl (Ptype_variant (List.map mkvariant ctl) (mkprivate pflag)) None
- | t ->
- let m =
- match t with
- [ TyQuo _ s -> if List.mem_assoc s tl then Some (ctyp t) else None
- | _ -> Some (ctyp t) ]
- in
- mktype (loc_of_ctyp t) tl cl Ptype_abstract m ]
-;
-
-value mkvalue_desc t p = {pval_type = ctyp t; pval_prim = p};
-
-value option f =
- fun
- [ Some x -> Some (f x)
- | None -> None ]
-;
-
-value expr_of_lab loc lab =
- fun
- [ Some e -> e
- | None -> ExLid loc lab ]
-;
-
-value patt_of_lab loc lab =
- fun
- [ Some p -> p
- | None -> PaLid loc lab ]
-;
-
-value paolab loc lab peoo =
- let lab =
- match (lab, peoo) with
- [ ("", Some (PaLid _ i | PaTyc _ (PaLid _ i) _, _)) -> i
- | ("", _) -> error loc "bad ast"
- | _ -> lab ]
- in
- let (p, eo) =
- match peoo with
- [ Some peo -> peo
- | None -> (PaLid loc lab, None) ]
- in
- (lab, p, eo)
-;
-
-value rec same_type_expr ct ce =
- match (ct, ce) with
- [ (TyLid _ s1, ExLid _ s2) -> s1 = s2
- | (TyUid _ s1, ExUid _ s2) -> s1 = s2
- | (TyAcc _ t1 t2, ExAcc _ e1 e2) ->
- same_type_expr t1 e1 && same_type_expr t2 e2
- | _ -> False ]
-;
-
-value rec common_id loc t e =
- match (t, e) with
- [ (TyLid _ s1, ExLid _ s2) when s1 = s2 -> lident s1
- | (TyUid _ s1, ExUid _ s2) when s1 = s2 -> lident s1
- | (TyAcc _ t1 (TyLid _ s1), ExAcc _ e1 (ExLid _ s2)) when s1 = s2 ->
- ldot (common_id loc t1 e1) s1
- | (TyAcc _ t1 (TyUid _ s1), ExAcc _ e1 (ExUid _ s2)) when s1 = s2 ->
- ldot (common_id loc t1 e1) s1
- | _ -> error loc "this expression should repeat the class id inherited" ]
-;
-
-value rec type_id loc t =
- match t with
- [ TyLid _ s1 -> lident s1
- | TyUid _ s1 -> lident s1
- | TyAcc _ t1 (TyLid _ s1) -> ldot (type_id loc t1) s1
- | TyAcc _ t1 (TyUid _ s1) -> ldot (type_id loc t1) s1
- | _ -> error loc "type identifier expected" ]
-;
-
-value rec module_type_long_id =
- fun
- [ MtAcc _ m (MtUid _ s) -> ldot (module_type_long_id m) s
- | MtAcc _ m (MtLid _ s) -> ldot (module_type_long_id m) s
- | MtApp _ m1 m2 -> Lapply (module_type_long_id m1) (module_type_long_id m2)
- | MtLid _ s -> lident s
- | MtUid _ s -> lident s
- | t -> error (loc_of_module_type t) "bad module type long ident" ]
-;
-
-value rec module_expr_long_id =
- fun
- [ MeAcc _ m (MeUid _ s) -> ldot (module_expr_long_id m) s
- | MeUid _ s -> lident s
- | t -> error (loc_of_module_expr t) "bad module expr long ident" ]
-;
-
-value mkwithc =
- fun
- [ WcTyp loc id tpl ct ->
- let (params, variance) = List.split tpl in
- (long_id_of_string_list loc id,
- Pwith_type
- {ptype_params = params; ptype_cstrs = [];
- ptype_kind = Ptype_abstract; ptype_manifest = Some (ctyp ct);
- ptype_loc = mkloc loc; ptype_variance = variance})
- | WcMod loc id m ->
- (long_id_of_string_list loc id, Pwith_module (module_expr_long_id m)) ]
-;
-
-value rec patt_fa al =
- fun
- [ PaApp _ f a -> patt_fa [a :: al] f
- | f -> (f, al) ]
-;
-
-value rec deep_mkrangepat loc c1 c2 =
- if c1 = c2 then mkghpat loc (Ppat_constant (Const_char c1))
- else
- mkghpat loc
- (Ppat_or (mkghpat loc (Ppat_constant (Const_char c1)))
- (deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2))
-;
-
-value rec mkrangepat loc c1 c2 =
- if c1 > c2 then mkrangepat loc c2 c1
- else if c1 = c2 then mkpat loc (Ppat_constant (Const_char c1))
- else
- mkpat loc
- (Ppat_or (mkghpat loc (Ppat_constant (Const_char c1)))
- (deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2))
-;
-
-value rec patt_long_id il =
- fun
- [ PaAcc _ p (PaUid _ i) -> patt_long_id [i :: il] p
- | p -> (p, il) ]
-;
-
-value rec patt_label_long_id =
- fun
- [ PaAcc _ m (PaLid _ s) -> ldot (patt_label_long_id m) (conv_lab s)
- | PaAcc _ m (PaUid _ s) -> ldot (patt_label_long_id m) s
- | PaUid _ s -> lident s
- | PaLid _ s -> lident (conv_lab s)
- | p -> error (loc_of_patt p) "bad label" ]
-;
-
-value rec patt =
- fun
- [ PaAcc loc p1 p2 ->
- let p =
- match patt_long_id [] p1 with
- [ (PaUid _ i, il) ->
- match p2 with
- [ PaUid _ s ->
- Ppat_construct (mkli (conv_con s) [i :: il]) None
- (not no_constructors_arity.val)
- | _ -> error (loc_of_patt p2) "uppercase identifier expected" ]
- | _ -> error (loc_of_patt p2) "bad pattern" ]
- in
- mkpat loc p
- | PaAli loc p1 p2 ->
- let (p, i) =
- match (p1, p2) with
- [ (p, PaLid _ s) -> (p, s)
- | (PaLid _ s, p) -> (p, s)
- | _ -> error loc "incorrect alias pattern" ]
- in
- mkpat loc (Ppat_alias (patt p) i)
- | PaAnt _ p -> patt p
- | PaAny loc -> mkpat loc Ppat_any
- | PaApp loc _ _ as f ->
- let (f, al) = patt_fa [] f in
- let al = List.map patt al in
- match (patt f).ppat_desc with
- [ Ppat_construct li None _ ->
- if no_constructors_arity.val then
- let a =
- match al with
- [ [a] -> a
- | _ -> mkpat loc (Ppat_tuple al) ]
- in
- mkpat loc (Ppat_construct li (Some a) False)
- else
- let a = mkpat loc (Ppat_tuple al) in
- mkpat loc (Ppat_construct li (Some a) True)
- | Ppat_variant s None ->
- let a =
- match al with
- [ [a] -> a
- | _ -> mkpat loc (Ppat_tuple al) ]
- in
- mkpat loc (Ppat_variant s (Some a))
- | _ ->
- error (loc_of_patt f)
- "this is not a constructor, it cannot be applied in a pattern" ]
- | PaArr loc pl -> mkpat loc (Ppat_array (List.map patt pl))
- | PaChr loc s ->
- mkpat loc (Ppat_constant (Const_char (char_of_char_token loc s)))
- | PaInt loc s -> mkpat loc (Ppat_constant (Const_int (int_of_string s)))
- | PaInt32 loc s -> mkpat loc (Ppat_constant (Const_int32 (Int32.of_string s)))
- | PaInt64 loc s -> mkpat loc (Ppat_constant (Const_int64 (Int64.of_string s)))
- | PaNativeInt loc s -> mkpat loc (Ppat_constant (Const_nativeint (Nativeint.of_string s)))
- | PaFlo loc s -> mkpat loc (Ppat_constant (Const_float s))
- | PaLab loc _ _ -> error loc "labeled pattern not allowed here"
- | PaLid loc s -> mkpat loc (Ppat_var s)
- | PaOlb loc _ _ -> error loc "labeled pattern not allowed here"
- | PaOrp loc p1 p2 -> mkpat loc (Ppat_or (patt p1) (patt p2))
- | PaRng loc p1 p2 ->
- match (p1, p2) with
- [ (PaChr loc1 c1, PaChr loc2 c2) ->
- let c1 = char_of_char_token loc1 c1 in
- let c2 = char_of_char_token loc2 c2 in
- mkrangepat loc c1 c2
- | _ -> error loc "range pattern allowed only for characters" ]
- | PaRec loc lpl -> mkpat loc (Ppat_record (List.map mklabpat lpl))
- | PaStr loc s ->
- mkpat loc (Ppat_constant (Const_string (string_of_string_token loc s)))
- | PaTup loc pl -> mkpat loc (Ppat_tuple (List.map patt pl))
- | PaTyc loc p t -> mkpat loc (Ppat_constraint (patt p) (ctyp t))
- | PaTyp loc sl -> mkpat loc (Ppat_type (long_id_of_string_list loc sl))
- | PaUid loc s ->
- let ca = not no_constructors_arity.val in
- mkpat loc (Ppat_construct (lident (conv_con s)) None ca)
- | PaVrn loc s -> mkpat loc (Ppat_variant s None) ]
-and mklabpat (lab, p) = (patt_label_long_id lab, patt p);
-
-value rec expr_fa al =
- fun
- [ ExApp _ f a -> expr_fa [a :: al] f
- | f -> (f, al) ]
-;
-
-value rec class_expr_fa al =
- fun
- [ CeApp _ ce a -> class_expr_fa [a :: al] ce
- | ce -> (ce, al) ]
-;
-
-value rec sep_expr_acc l =
- fun
- [ ExAcc _ e1 e2 -> sep_expr_acc (sep_expr_acc l e2) e1
- | ExUid ((bp, _) as loc) s as e ->
- match l with
- [ [] -> [(loc, [], e)]
- | [((_, ep), sl, e) :: l] -> [((bp, ep), [s :: sl], e) :: l] ]
- | e -> [(loc_of_expr e, [], e) :: l] ]
-;
-
-(*
-value expr_label_long_id e =
- match sep_expr_acc [] e with
- [ [(_, ml, ExLid _ s)] -> mkli (conv_lab s) ml
- | _ -> error (loc_of_expr e) "invalid label" ]
-;
-*)
-
-value class_info class_expr ci =
- let (params, variance) = List.split (snd ci.ciPrm) in
- {pci_virt = if ci.ciVir then Virtual else Concrete;
- pci_params = (params, mkloc (fst ci.ciPrm)); pci_name = ci.ciNam;
- pci_expr = class_expr ci.ciExp; pci_loc = mkloc ci.ciLoc;
- pci_variance = variance}
-;
-
-value apply_with_var v x f =
- let vx = v.val in
- try
- do {
- v.val := x;
- let r = f ();
- v.val := vx;
- r
- }
- with e -> do { v.val := vx; raise e }
-;
-
-value rec expr =
- fun
- [ ExAcc loc x (ExLid _ "val") ->
- mkexp loc
- (Pexp_apply (mkexp loc (Pexp_ident (Lident "!"))) [("", expr x)])
- | ExAcc loc _ _ as e ->
- let (e, l) =
- match sep_expr_acc [] e with
- [ [(loc, ml, ExUid _ s) :: l] ->
- let ca = not no_constructors_arity.val in
- (mkexp loc (Pexp_construct (mkli s ml) None ca), l)
- | [(loc, ml, ExLid _ s) :: l] ->
- (mkexp loc (Pexp_ident (mkli s ml)), l)
- | [(_, [], e) :: l] -> (expr e, l)
- | _ -> error loc "bad ast" ]
- in
- let (_, e) =
- List.fold_left
- (fun ((bp, _), e1) ((_, ep), ml, e2) ->
- match e2 with
- [ ExLid _ s ->
- let loc = (bp, ep) in
- (loc, mkexp loc (Pexp_field e1 (mkli (conv_lab s) ml)))
- | _ -> error (loc_of_expr e2) "lowercase identifier expected" ])
- (loc, e) l
- in
- e
- | ExAnt _ e -> expr e
- | ExApp loc _ _ as f ->
- let (f, al) = expr_fa [] f in
- let al = List.map label_expr al in
- match (expr f).pexp_desc with
- [ Pexp_construct li None _ ->
- let al = List.map snd al in
- if no_constructors_arity.val then
- let a =
- match al with
- [ [a] -> a
- | _ -> mkexp loc (Pexp_tuple al) ]
- in
- mkexp loc (Pexp_construct li (Some a) False)
- else
- let a = mkexp loc (Pexp_tuple al) in
- mkexp loc (Pexp_construct li (Some a) True)
- | Pexp_variant s None ->
- let al = List.map snd al in
- let a =
- match al with
- [ [a] -> a
- | _ -> mkexp loc (Pexp_tuple al) ]
- in
- mkexp loc (Pexp_variant s (Some a))
- | _ -> mkexp loc (Pexp_apply (expr f) al) ]
- | ExAre loc e1 e2 ->
- mkexp loc
- (Pexp_apply (mkexp loc (Pexp_ident (array_function "Array" "get")))
- [("", expr e1); ("", expr e2)])
- | ExArr loc el -> mkexp loc (Pexp_array (List.map expr el))
- | ExAsf loc -> mkexp loc Pexp_assertfalse
- | ExAss loc e v ->
- let e =
- match e with
- [ ExAcc loc x (ExLid _ "val") ->
- Pexp_apply (mkexp loc (Pexp_ident (Lident ":=")))
- [("", expr x); ("", expr v)]
- | ExAcc loc _ _ ->
- match (expr e).pexp_desc with
- [ Pexp_field e lab -> Pexp_setfield e lab (expr v)
- | _ -> error loc "bad record access" ]
- | ExAre _ e1 e2 ->
- Pexp_apply (mkexp loc (Pexp_ident (array_function "Array" "set")))
- [("", expr e1); ("", expr e2); ("", expr v)]
- | ExLid _ lab -> Pexp_setinstvar lab (expr v)
- | ExSte _ e1 e2 ->
- Pexp_apply
- (mkexp loc (Pexp_ident (array_function "String" "set")))
- [("", expr e1); ("", expr e2); ("", expr v)]
- | _ -> error loc "bad left part of assignment" ]
- in
- mkexp loc e
- | ExAsr loc e -> mkexp loc (Pexp_assert (expr e))
- | ExChr loc s ->
- mkexp loc (Pexp_constant (Const_char (char_of_char_token loc s)))
- | ExCoe loc e t1 t2 ->
- mkexp loc (Pexp_constraint (expr e) (option ctyp t1) (Some (ctyp t2)))
- | ExFlo loc s -> mkexp loc (Pexp_constant (Const_float s))
- | ExFor loc i e1 e2 df el ->
- let e3 = ExSeq loc el in
- let df = if df then Upto else Downto in
- mkexp loc (Pexp_for i (expr e1) (expr e2) df (expr e3))
- | ExFun loc [(PaLab _ lab po, w, e)] ->
- mkexp loc
- (Pexp_function lab None
- [(patt (patt_of_lab loc lab po), when_expr e w)])
- | ExFun loc [(PaOlb _ lab peoo, w, e)] ->
- let (lab, p, eo) = paolab loc lab peoo in
- mkexp loc
- (Pexp_function ("?" ^ lab) (option expr eo) [(patt p, when_expr e w)])
- | ExFun loc pel -> mkexp loc (Pexp_function "" None (List.map mkpwe pel))
- | ExIfe loc e1 e2 e3 ->
- mkexp loc (Pexp_ifthenelse (expr e1) (expr e2) (Some (expr e3)))
- | ExInt loc s -> mkexp loc (Pexp_constant (Const_int (int_of_string s)))
- | ExInt32 loc s -> mkexp loc (Pexp_constant (Const_int32 (Int32.of_string s)))
- | ExInt64 loc s -> mkexp loc (Pexp_constant (Const_int64 (Int64.of_string s)))
- | ExNativeInt loc s -> mkexp loc (Pexp_constant (Const_nativeint (Nativeint.of_string s)))
- | ExLab loc _ _ -> error loc "labeled expression not allowed here"
- | ExLaz loc e -> mkexp loc (Pexp_lazy (expr e))
- | ExLet loc rf pel e ->
- mkexp loc (Pexp_let (mkrf rf) (List.map mkpe pel) (expr e))
- | ExLid loc s -> mkexp loc (Pexp_ident (lident s))
- | ExLmd loc i me e -> mkexp loc (Pexp_letmodule i (module_expr me) (expr e))
- | ExMat loc e pel -> mkexp loc (Pexp_match (expr e) (List.map mkpwe pel))
- | ExNew loc id -> mkexp loc (Pexp_new (long_id_of_string_list loc id))
- | ExOlb loc _ _ -> error loc "labeled expression not allowed here"
- | ExOvr loc iel -> mkexp loc (Pexp_override (List.map mkideexp iel))
- | ExRec loc lel eo ->
- if lel = [] then error loc "empty record"
- else
- let eo =
- match eo with
- [ Some e -> Some (expr e)
- | None -> None ]
- in
- mkexp loc (Pexp_record (List.map mklabexp lel) eo)
- | ExSeq loc el ->
- let rec loop =
- fun
- [ [] -> expr (ExUid loc "()")
- | [e] -> expr e
- | [e :: el] ->
- let loc = (fst (loc_of_expr e), snd loc) in
- mkexp loc (Pexp_sequence (expr e) (loop el)) ]
- in
- loop el
- | ExSnd loc e s -> mkexp loc (Pexp_send (expr e) s)
- | ExSte loc e1 e2 ->
- mkexp loc
- (Pexp_apply (mkexp loc (Pexp_ident (array_function "String" "get")))
- [("", expr e1); ("", expr e2)])
- | ExStr loc s ->
- mkexp loc (Pexp_constant (Const_string (string_of_string_token loc s)))
- | ExTry loc e pel -> mkexp loc (Pexp_try (expr e) (List.map mkpwe pel))
- | ExTup loc el -> mkexp loc (Pexp_tuple (List.map expr el))
- | ExTyc loc e t -> mkexp loc (Pexp_constraint (expr e) (Some (ctyp t)) None)
- | ExUid loc s ->
- let ca = not no_constructors_arity.val in
- mkexp loc (Pexp_construct (lident (conv_con s)) None ca)
- | ExVrn loc s -> mkexp loc (Pexp_variant s None)
- | ExWhi loc e1 el ->
- let e2 = ExSeq loc el in
- mkexp loc (Pexp_while (expr e1) (expr e2)) ]
-and label_expr =
- fun
- [ ExLab loc lab eo -> (lab, expr (expr_of_lab loc lab eo))
- | ExOlb loc lab eo -> ("?" ^ lab, expr (expr_of_lab loc lab eo))
- | e -> ("", expr e) ]
-and mkpe (p, e) = (patt p, expr e)
-and mkpwe (p, w, e) = (patt p, when_expr e w)
-and when_expr e =
- fun
- [ Some w -> mkexp (loc_of_expr e) (Pexp_when (expr w) (expr e))
- | None -> expr e ]
-and mklabexp (lab, e) = (patt_label_long_id lab, expr e)
-and mkideexp (ide, e) = (ide, expr e)
-and mktype_decl ((loc, c), tl, td, cl) =
- let cl =
- List.map
- (fun (t1, t2) ->
- let loc = (fst (loc_of_ctyp t1), snd (loc_of_ctyp t2)) in
- (ctyp t1, ctyp t2, mkloc loc))
- cl
- in
- (c, type_decl tl cl td)
-and module_type =
- fun
- [ MtAcc loc _ _ as f -> mkmty loc (Pmty_ident (module_type_long_id f))
- | MtApp loc _ _ as f -> mkmty loc (Pmty_ident (module_type_long_id f))
- | MtFun loc n nt mt ->
- mkmty loc (Pmty_functor n (module_type nt) (module_type mt))
- | MtLid loc s -> mkmty loc (Pmty_ident (lident s))
- | MtQuo loc _ -> error loc "abstract module type not allowed here"
- | MtSig loc sl ->
- mkmty loc (Pmty_signature (List.fold_right sig_item sl []))
- | MtUid loc s -> mkmty loc (Pmty_ident (lident s))
- | MtWit loc mt wcl ->
- mkmty loc (Pmty_with (module_type mt) (List.map mkwithc wcl)) ]
-and sig_item s l =
- match s with
- [ SgCls loc cd ->
- [mksig loc (Psig_class (List.map (class_info class_type) cd)) :: l]
- | SgClt loc ctd ->
- [mksig loc (Psig_class_type (List.map (class_info class_type) ctd)) ::
- l]
- | SgDcl loc sl -> List.fold_right sig_item sl l
- | SgDir loc _ _ -> l
- | SgExc loc n tl -> [mksig loc (Psig_exception n (List.map ctyp tl)) :: l]
- | SgExt loc n t p -> [mksig loc (Psig_value n (mkvalue_desc t p)) :: l]
- | SgInc loc mt -> [mksig loc (Psig_include (module_type mt)) :: l]
- | SgMod loc n mt -> [mksig loc (Psig_module n (module_type mt)) :: l]
- | SgRecMod loc nmts ->
- [mksig loc (Psig_recmodule (List.map (fun (n,mt) -> (n, module_type mt)) nmts)) :: l]
- | SgMty loc n mt ->
- let si =
- match mt with
- [ MtQuo _ _ -> Pmodtype_abstract
- | _ -> Pmodtype_manifest (module_type mt) ]
- in
- [mksig loc (Psig_modtype n si) :: l]
- | SgOpn loc id ->
- [mksig loc (Psig_open (long_id_of_string_list loc id)) :: l]
- | SgTyp loc tdl -> [mksig loc (Psig_type (List.map mktype_decl tdl)) :: l]
- | SgUse loc fn sl ->
- apply_with_var glob_fname fn
- (fun () -> List.fold_right (fun (si, _) -> sig_item si) sl l)
- | SgVal loc n t -> [mksig loc (Psig_value n (mkvalue_desc t [])) :: l] ]
-and module_expr =
- fun
- [ MeAcc loc _ _ as f -> mkmod loc (Pmod_ident (module_expr_long_id f))
- | MeApp loc me1 me2 ->
- mkmod loc (Pmod_apply (module_expr me1) (module_expr me2))
- | MeFun loc n mt me ->
- mkmod loc (Pmod_functor n (module_type mt) (module_expr me))
- | MeStr loc sl ->
- mkmod loc (Pmod_structure (List.fold_right str_item sl []))
- | MeTyc loc me mt ->
- mkmod loc (Pmod_constraint (module_expr me) (module_type mt))
- | MeUid loc s -> mkmod loc (Pmod_ident (lident s)) ]
-and str_item s l =
- match s with
- [ StCls loc cd ->
- [mkstr loc (Pstr_class (List.map (class_info class_expr) cd)) :: l]
- | StClt loc ctd ->
- [mkstr loc (Pstr_class_type (List.map (class_info class_type) ctd)) ::
- l]
- | StDcl loc sl -> List.fold_right str_item sl l
- | StDir loc _ _ -> l
- | StExc loc n tl sl ->
- let si =
- match (tl, sl) with
- [ (tl, []) -> Pstr_exception n (List.map ctyp tl)
- | ([], sl) -> Pstr_exn_rebind n (long_id_of_string_list loc sl)
- | _ -> error loc "bad exception declaration" ]
- in
- [mkstr loc si :: l]
- | StExp loc e -> [mkstr loc (Pstr_eval (expr e)) :: l]
- | StExt loc n t p -> [mkstr loc (Pstr_primitive n (mkvalue_desc t p)) :: l]
- | StInc loc me -> [mkstr loc (Pstr_include (module_expr me)) :: l]
- | StMod loc n me -> [mkstr loc (Pstr_module n (module_expr me)) :: l]
- | StRecMod loc nmes ->
- [mkstr loc
- (Pstr_recmodule
- (List.map
- (fun (n,mt,me) -> (n, module_type mt, module_expr me))
- nmes)) :: l]
- | StMty loc n mt -> [mkstr loc (Pstr_modtype n (module_type mt)) :: l]
- | StOpn loc id ->
- [mkstr loc (Pstr_open (long_id_of_string_list loc id)) :: l]
- | StTyp loc tdl -> [mkstr loc (Pstr_type (List.map mktype_decl tdl)) :: l]
- | StUse loc fn sl ->
- apply_with_var glob_fname fn
- (fun () -> List.fold_right (fun (si, _) -> str_item si) sl l)
- | StVal loc rf pel ->
- [mkstr loc (Pstr_value (mkrf rf) (List.map mkpe pel)) :: l] ]
-and class_type =
- fun
- [ CtCon loc id tl ->
- mkcty loc
- (Pcty_constr (long_id_of_string_list loc id) (List.map ctyp tl))
- | CtFun loc (TyLab _ lab t) ct ->
- mkcty loc (Pcty_fun lab (ctyp t) (class_type ct))
- | CtFun loc (TyOlb loc1 lab t) ct ->
- let t = TyApp loc1 (TyLid loc1 "option") t in
- mkcty loc (Pcty_fun ("?" ^ lab) (ctyp t) (class_type ct))
- | CtFun loc t ct -> mkcty loc (Pcty_fun "" (ctyp t) (class_type ct))
- | CtSig loc t_o ctfl ->
- let t =
- match t_o with
- [ Some t -> t
- | None -> TyAny loc ]
- in
- let cil = List.fold_right class_sig_item ctfl [] in
- mkcty loc (Pcty_signature (ctyp t, cil)) ]
-and class_sig_item c l =
- match c with
- [ CgCtr loc t1 t2 -> [Pctf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l]
- | CgDcl loc cl -> List.fold_right class_sig_item cl l
- | CgInh loc ct -> [Pctf_inher (class_type ct) :: l]
- | CgMth loc s pf t ->
- [Pctf_meth (s, mkprivate pf, ctyp (mkpolytype t), mkloc loc) :: l]
- | CgVal loc s b t ->
- [Pctf_val (s, mkmutable b, Some (ctyp t), mkloc loc) :: l]
- | CgVir loc s b t ->
- [Pctf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l] ]
-and class_expr =
- fun
- [ CeApp loc _ _ as c ->
- let (ce, el) = class_expr_fa [] c in
- let el = List.map label_expr el in
- mkpcl loc (Pcl_apply (class_expr ce) el)
- | CeCon loc id tl ->
- mkpcl loc
- (Pcl_constr (long_id_of_string_list loc id) (List.map ctyp tl))
- | CeFun loc (PaLab _ lab po) ce ->
- mkpcl loc
- (Pcl_fun lab None (patt (patt_of_lab loc lab po)) (class_expr ce))
- | CeFun loc (PaOlb _ lab peoo) ce ->
- let (lab, p, eo) = paolab loc lab peoo in
- mkpcl loc
- (Pcl_fun ("?" ^ lab) (option expr eo) (patt p) (class_expr ce))
- | CeFun loc p ce -> mkpcl loc (Pcl_fun "" None (patt p) (class_expr ce))
- | CeLet loc rf pel ce ->
- mkpcl loc (Pcl_let (mkrf rf) (List.map mkpe pel) (class_expr ce))
- | CeStr loc po cfl ->
- let p =
- match po with
- [ Some p -> p
- | None -> PaAny loc ]
- in
- let cil = List.fold_right class_str_item cfl [] in
- mkpcl loc (Pcl_structure (patt p, cil))
- | CeTyc loc ce ct ->
- mkpcl loc (Pcl_constraint (class_expr ce) (class_type ct)) ]
-and class_str_item c l =
- match c with
- [ CrCtr loc t1 t2 -> [Pcf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l]
- | CrDcl loc cl -> List.fold_right class_str_item cl l
- | CrInh loc ce pb -> [Pcf_inher (class_expr ce) pb :: l]
- | CrIni loc e -> [Pcf_init (expr e) :: l]
- | CrMth loc s b e t ->
- let t = option (fun t -> ctyp (mkpolytype t)) t in
- let e = mkexp loc (Pexp_poly (expr e) t) in
- [Pcf_meth (s, mkprivate b, e, mkloc loc) :: l]
- | CrVal loc s b e -> [Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l]
- | CrVir loc s b t ->
- [Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l] ]
-;
-
-value interf ast = List.fold_right sig_item ast [];
-value implem ast = List.fold_right str_item ast [];
-
-value directive loc =
- fun
- [ None -> Pdir_none
- | Some (ExStr _ s) -> Pdir_string s
- | Some (ExInt _ i) -> Pdir_int (int_of_string i)
- | Some (ExUid _ "True") -> Pdir_bool True
- | Some (ExUid _ "False") -> Pdir_bool False
- | Some e ->
- let sl =
- loop e where rec loop =
- fun
- [ ExLid _ i | ExUid _ i -> [i]
- | ExAcc _ e (ExLid _ i) | ExAcc _ e (ExUid _ i) -> loop e @ [i]
- | e -> raise_with_loc (loc_of_expr e) (Failure "bad ast") ]
- in
- Pdir_ident (long_id_of_string_list loc sl) ]
-;
-
-value phrase =
- fun
- [ StDir loc d dp -> Ptop_dir d (directive loc dp)
- | si -> Ptop_def (str_item si []) ]
-;
diff --git a/camlp4/camlp4/ast2pt.mli b/camlp4/camlp4/ast2pt.mli
deleted file mode 100644
index 3e7da854f6..0000000000
--- a/camlp4/camlp4/ast2pt.mli
+++ /dev/null
@@ -1,23 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-value fast : ref bool;
-value no_constructors_arity : ref bool;
-value mkloc : (int * int) -> Location.t;
-value long_id_of_string_list : (int * int) -> list string -> Longident.t;
-
-value str_item : MLast.str_item -> Parsetree.structure -> Parsetree.structure;
-value interf : list MLast.sig_item -> Parsetree.signature;
-value implem : list MLast.str_item -> Parsetree.structure;
-value phrase : MLast.str_item -> Parsetree.toplevel_phrase;
diff --git a/camlp4/camlp4/mLast.mli b/camlp4/camlp4/mLast.mli
deleted file mode 100644
index 2d77944318..0000000000
--- a/camlp4/camlp4/mLast.mli
+++ /dev/null
@@ -1,211 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Module [MLast]: abstract syntax tree
-
- This is undocumented because the AST is not supposed to be used
- directly; the good usage is to use the quotations representing
- these values in concrete syntax (see the Camlp4 documentation).
- See also the file q_MLast.ml in Camlp4 sources. *)
-
-type loc = (int * int);
-
-type ctyp =
- [ TyAcc of loc and ctyp and ctyp
- | TyAli of loc and ctyp and ctyp
- | TyAny of loc
- | TyApp of loc and ctyp and ctyp
- | TyArr of loc and ctyp and ctyp
- | TyCls of loc and list string
- | TyLab of loc and string and ctyp
- | TyLid of loc and string
- | TyMan of loc and ctyp and ctyp
- | TyObj of loc and list (string * ctyp) and bool
- | TyOlb of loc and string and ctyp
- | TyPol of loc and list string and ctyp
- | TyQuo of loc and string
- | TyRec of loc and bool and list (loc * string * bool * ctyp)
- | TySum of loc and bool and list (loc * string * list ctyp)
- | TyTup of loc and list ctyp
- | TyUid of loc and string
- | TyVrn of loc and list row_field and option (option (list string)) ]
-and row_field =
- [ RfTag of string and bool and list ctyp
- | RfInh of ctyp ]
-;
-
-type class_infos 'a =
- { ciLoc : loc;
- ciVir : bool;
- ciPrm : (loc * list (string * (bool * bool)));
- ciNam : string;
- ciExp : 'a }
-;
-
-type patt =
- [ PaAcc of loc and patt and patt
- | PaAli of loc and patt and patt
- | PaAnt of loc and patt
- | PaAny of loc
- | PaApp of loc and patt and patt
- | PaArr of loc and list patt
- | PaChr of loc and string
- | PaInt of loc and string
- | PaInt32 of loc and string
- | PaInt64 of loc and string
- | PaNativeInt of loc and string
- | PaFlo of loc and string
- | PaLab of loc and string and option patt
- | PaLid of loc and string
- | PaOlb of loc and string and option (patt * option expr)
- | PaOrp of loc and patt and patt
- | PaRng of loc and patt and patt
- | PaRec of loc and list (patt * patt)
- | PaStr of loc and string
- | PaTup of loc and list patt
- | PaTyc of loc and patt and ctyp
- | PaTyp of loc and list string
- | PaUid of loc and string
- | PaVrn of loc and string ]
-and expr =
- [ ExAcc of loc and expr and expr
- | ExAnt of loc and expr
- | ExApp of loc and expr and expr
- | ExAre of loc and expr and expr
- | ExArr of loc and list expr
- | ExAsf of loc (* assert False *)
- | ExAsr of loc and expr (* assert *)
- | ExAss of loc and expr and expr (* assignment *)
- | ExChr of loc and string
- | ExCoe of loc and expr and option ctyp and ctyp
- | ExFlo of loc and string
- | ExFor of loc and string and expr and expr and bool and list expr
- | ExFun of loc and list (patt * option expr * expr)
- | ExIfe of loc and expr and expr and expr
- | ExInt of loc and string
- | ExInt32 of loc and string
- | ExInt64 of loc and string
- | ExNativeInt of loc and string
- | ExLab of loc and string and option expr
- | ExLaz of loc and expr
- | ExLet of loc and bool and list (patt * expr) and expr
- | ExLid of loc and string
- | ExLmd of loc and string and module_expr and expr
- | ExMat of loc and expr and list (patt * option expr * expr)
- | ExNew of loc and list string
- | ExOlb of loc and string and option expr
- | ExOvr of loc and list (string * expr)
- | ExRec of loc and list (patt * expr) and option expr
- | ExSeq of loc and list expr
- | ExSnd of loc and expr and string
- | ExSte of loc and expr and expr
- | ExStr of loc and string
- | ExTry of loc and expr and list (patt * option expr * expr)
- | ExTup of loc and list expr
- | ExTyc of loc and expr and ctyp
- | ExUid of loc and string
- | ExVrn of loc and string
- | ExWhi of loc and expr and list expr ]
-and module_type =
- [ MtAcc of loc and module_type and module_type
- | MtApp of loc and module_type and module_type
- | MtFun of loc and string and module_type and module_type
- | MtLid of loc and string
- | MtQuo of loc and string
- | MtSig of loc and list sig_item
- | MtUid of loc and string
- | MtWit of loc and module_type and list with_constr ]
-and sig_item =
- [ SgCls of loc and list (class_infos class_type)
- | SgClt of loc and list (class_infos class_type)
- | SgDcl of loc and list sig_item
- | SgDir of loc and string and option expr
- | SgExc of loc and string and list ctyp
- | SgExt of loc and string and ctyp and list string
- | SgInc of loc and module_type
- | SgMod of loc and string and module_type
- | SgRecMod of loc and list (string * module_type)
- | SgMty of loc and string and module_type
- | SgOpn of loc and list string
- | SgTyp of loc and list type_decl
- | SgUse of loc and string and list (sig_item * loc)
- | SgVal of loc and string and ctyp ]
-and with_constr =
- [ WcTyp of loc and list string and list (string * (bool * bool)) and ctyp
- | WcMod of loc and list string and module_expr ]
-and module_expr =
- [ MeAcc of loc and module_expr and module_expr
- | MeApp of loc and module_expr and module_expr
- | MeFun of loc and string and module_type and module_expr
- | MeStr of loc and list str_item
- | MeTyc of loc and module_expr and module_type
- | MeUid of loc and string ]
-and str_item =
- [ StCls of loc and list (class_infos class_expr)
- | StClt of loc and list (class_infos class_type)
- | StDcl of loc and list str_item
- | StDir of loc and string and option expr
- | StExc of loc and string and list ctyp and list string
- | StExp of loc and expr
- | StExt of loc and string and ctyp and list string
- | StInc of loc and module_expr
- | StMod of loc and string and module_expr
- | StRecMod of loc and list (string * module_type * module_expr)
- | StMty of loc and string and module_type
- | StOpn of loc and list string
- | StTyp of loc and list type_decl
- | StUse of loc and string and list (str_item * loc)
- | StVal of loc and bool and list (patt * expr) ]
-and type_decl =
- ((loc * string) * list (string * (bool * bool)) * ctyp * list (ctyp * ctyp))
-and class_type =
- [ CtCon of loc and list string and list ctyp
- | CtFun of loc and ctyp and class_type
- | CtSig of loc and option ctyp and list class_sig_item ]
-and class_sig_item =
- [ CgCtr of loc and ctyp and ctyp
- | CgDcl of loc and list class_sig_item
- | CgInh of loc and class_type
- | CgMth of loc and string and bool and ctyp
- | CgVal of loc and string and bool and ctyp
- | CgVir of loc and string and bool and ctyp ]
-and class_expr =
- [ CeApp of loc and class_expr and expr
- | CeCon of loc and list string and list ctyp
- | CeFun of loc and patt and class_expr
- | CeLet of loc and bool and list (patt * expr) and class_expr
- | CeStr of loc and option patt and list class_str_item
- | CeTyc of loc and class_expr and class_type ]
-and class_str_item =
- [ CrCtr of loc and ctyp and ctyp
- | CrDcl of loc and list class_str_item
- | CrInh of loc and class_expr and option string
- | CrIni of loc and expr
- | CrMth of loc and string and bool and expr and option ctyp
- | CrVal of loc and string and bool and expr
- | CrVir of loc and string and bool and ctyp ]
-;
-
-external loc_of_ctyp : ctyp -> loc = "%field0";
-external loc_of_patt : patt -> loc = "%field0";
-external loc_of_expr : expr -> loc = "%field0";
-external loc_of_module_type : module_type -> loc = "%field0";
-external loc_of_module_expr : module_expr -> loc = "%field0";
-external loc_of_sig_item : sig_item -> loc = "%field0";
-external loc_of_str_item : str_item -> loc = "%field0";
-
-external loc_of_class_type : class_type -> loc = "%field0";
-external loc_of_class_sig_item : class_sig_item -> loc = "%field0";
-external loc_of_class_expr : class_expr -> loc = "%field0";
-external loc_of_class_str_item : class_str_item -> loc = "%field0";
diff --git a/camlp4/camlp4/pcaml.ml b/camlp4/camlp4/pcaml.ml
deleted file mode 100644
index 63c083ceba..0000000000
--- a/camlp4/camlp4/pcaml.ml
+++ /dev/null
@@ -1,457 +0,0 @@
-(* camlp4r pa_extend.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-value version = Sys.ocaml_version;
-
-value syntax_name = ref "";
-
-value gram =
- Grammar.gcreate
- {Token.tok_func _ = failwith "no loaded parsing module";
- Token.tok_using _ = (); Token.tok_removing _ = ();
- Token.tok_match = fun []; Token.tok_text _ = "";
- Token.tok_comm = None}
-;
-
-value interf = Grammar.Entry.create gram "interf";
-value implem = Grammar.Entry.create gram "implem";
-value top_phrase = Grammar.Entry.create gram "top_phrase";
-value use_file = Grammar.Entry.create gram "use_file";
-value sig_item = Grammar.Entry.create gram "sig_item";
-value str_item = Grammar.Entry.create gram "str_item";
-value module_type = Grammar.Entry.create gram "module_type";
-value module_expr = Grammar.Entry.create gram "module_expr";
-value expr = Grammar.Entry.create gram "expr";
-value patt = Grammar.Entry.create gram "patt";
-value ctyp = Grammar.Entry.create gram "type";
-value let_binding = Grammar.Entry.create gram "let_binding";
-value type_declaration = Grammar.Entry.create gram "type_declaration";
-
-value class_sig_item = Grammar.Entry.create gram "class_sig_item";
-value class_str_item = Grammar.Entry.create gram "class_str_item";
-value class_type = Grammar.Entry.create gram "class_type";
-value class_expr = Grammar.Entry.create gram "class_expr";
-
-value parse_interf = ref (Grammar.Entry.parse interf);
-value parse_implem = ref (Grammar.Entry.parse implem);
-
-value rec skip_to_eol cs =
- match Stream.peek cs with
- [ Some '\n' -> ()
- | Some c -> do { Stream.junk cs; skip_to_eol cs }
- | _ -> () ]
-;
-value sync = ref skip_to_eol;
-
-value input_file = ref "";
-value output_file = ref None;
-
-value warning_default_function (bp, ep) txt =
- do { Printf.eprintf "<W> loc %d %d: %s\n" bp ep txt; flush stderr }
-;
-
-value warning = ref warning_default_function;
-
-value apply_with_var v x f =
- let vx = v.val in
- try
- do {
- v.val := x;
- let r = f ();
- v.val := vx;
- r
- }
- with e -> do { v.val := vx; raise e }
-;
-
-List.iter (fun (n, f) -> Quotation.add n f)
- [("id", Quotation.ExStr (fun _ s -> "$0:" ^ s ^ "$"));
- ("string", Quotation.ExStr (fun _ s -> "\"" ^ String.escaped s ^ "\""))];
-
-value quotation_dump_file = ref (None : option string);
-
-type err_ctx =
- [ Finding | Expanding | ParsingResult of (int * int) and string | Locating ]
-;
-exception Qerror of string and err_ctx and exn;
-
-value expand_quotation loc expander shift name str =
- let new_warning =
- let warn = warning.val in
- fun (bp, ep) txt -> warn (shift + bp, shift + ep) txt
- in
- apply_with_var warning new_warning
- (fun () ->
- try expander str with
- [ Stdpp.Exc_located (p1, p2) exc ->
- let exc1 = Qerror name Expanding exc in
- raise (Stdpp.Exc_located (shift + p1, shift + p2) exc1)
- | exc ->
- let exc1 = Qerror name Expanding exc in
- raise (Stdpp.Exc_located loc exc1) ])
-;
-
-value parse_quotation_result entry loc shift name str =
- let cs = Stream.of_string str in
- try Grammar.Entry.parse entry cs with
- [ Stdpp.Exc_located iloc (Qerror _ Locating _ as exc) ->
- raise (Stdpp.Exc_located (shift + fst iloc, shift + snd iloc) exc)
- | Stdpp.Exc_located iloc (Qerror _ Expanding exc) ->
- let ctx = ParsingResult iloc str in
- let exc1 = Qerror name ctx exc in
- raise (Stdpp.Exc_located loc exc1)
- | Stdpp.Exc_located _ (Qerror _ _ _ as exc) ->
- raise (Stdpp.Exc_located loc exc)
- | Stdpp.Exc_located iloc exc ->
- let ctx = ParsingResult iloc str in
- let exc1 = Qerror name ctx exc in
- raise (Stdpp.Exc_located loc exc1) ]
-;
-
-value handle_quotation loc proj in_expr entry reloc (name, str) =
- let shift =
- match name with
- [ "" -> String.length "<<"
- | _ -> String.length "<:" + String.length name + String.length "<" ]
- in
- let shift = fst loc + shift in
- let expander =
- try Quotation.find name with exc ->
- let exc1 = Qerror name Finding exc in
- let loc = (fst loc, shift) in
- raise (Stdpp.Exc_located loc exc1)
- in
- let ast =
- match expander with
- [ Quotation.ExStr f ->
- let new_str = expand_quotation loc (f in_expr) shift name str in
- parse_quotation_result entry loc shift name new_str
- | Quotation.ExAst fe_fp ->
- expand_quotation loc (proj fe_fp) shift name str ]
- in
- reloc (fun _ -> loc) shift ast
-;
-
-value parse_locate entry shift str =
- let cs = Stream.of_string str in
- try Grammar.Entry.parse entry cs with
- [ Stdpp.Exc_located (p1, p2) exc ->
- let ctx = Locating in
- let exc1 = Qerror (Grammar.Entry.name entry) ctx exc in
- raise (Stdpp.Exc_located (shift + p1, shift + p2) exc1) ]
-;
-
-value handle_locate loc entry ast_f (pos, str) =
- let s = str in
- let loc = (pos, pos + String.length s) in
- let x = parse_locate entry (fst loc) s in
- ast_f loc x
-;
-
-value expr_anti loc e = MLast.ExAnt loc e;
-value patt_anti loc p = MLast.PaAnt loc p;
-value expr_eoi = Grammar.Entry.create gram "expression";
-value patt_eoi = Grammar.Entry.create gram "pattern";
-EXTEND
- expr_eoi:
- [ [ x = expr; EOI -> x ] ]
- ;
- patt_eoi:
- [ [ x = patt; EOI -> x ] ]
- ;
-END;
-
-value handle_expr_quotation loc x =
- handle_quotation loc fst True expr_eoi Reloc.expr x
-;
-
-value handle_expr_locate loc x = handle_locate loc expr_eoi expr_anti x;
-
-value handle_patt_quotation loc x =
- handle_quotation loc snd False patt_eoi Reloc.patt x
-;
-
-value handle_patt_locate loc x = handle_locate loc patt_eoi patt_anti x;
-
-value expr_reloc = Reloc.expr;
-value patt_reloc = Reloc.patt;
-
-value rename_id = ref (fun x -> x);
-
-value find_line (bp, ep) str =
- find 0 1 0 where rec find i line col =
- if i == String.length str then (line, 0, col)
- else if i == bp then (line, col, col + ep - bp)
- else if str.[i] == '\n' then find (succ i) (succ line) 0
- else find (succ i) line (succ col)
-;
-
-value loc_fmt =
- match Sys.os_type with
- [ "MacOS" ->
- format_of_string "File \"%s\"; line %d; characters %d to %d\n### "
- | _ ->
- format_of_string "File \"%s\", line %d, characters %d-%d:\n" ]
-;
-
-value report_quotation_error name ctx =
- let name = if name = "" then Quotation.default.val else name in
- do {
- Format.print_flush ();
- Format.open_hovbox 2;
- Printf.eprintf "While %s \"%s\":"
- (match ctx with
- [ Finding -> "finding quotation"
- | Expanding -> "expanding quotation"
- | ParsingResult _ _ -> "parsing result of quotation"
- | Locating -> "parsing" ])
- name;
- match ctx with
- [ ParsingResult (bp, ep) str ->
- match quotation_dump_file.val with
- [ Some dump_file ->
- do {
- Printf.eprintf " dumping result...\n";
- flush stderr;
- try
- let (line, c1, c2) = find_line (bp, ep) str in
- let oc = open_out_bin dump_file in
- do {
- output_string oc str;
- output_string oc "\n";
- flush oc;
- close_out oc;
- Printf.eprintf loc_fmt dump_file line c1 c2;
- flush stderr
- }
- with _ ->
- do {
- Printf.eprintf "Error while dumping result in file \"%s\""
- dump_file;
- Printf.eprintf "; dump aborted.\n";
- flush stderr
- }
- }
- | None ->
- do {
- if input_file.val = "" then
- Printf.eprintf
- "\n(consider setting variable Pcaml.quotation_dump_file)\n"
- else Printf.eprintf " (consider using option -QD)\n";
- flush stderr
- } ]
- | _ -> do { Printf.eprintf "\n"; flush stderr } ]
- }
-;
-
-value print_format str =
- let rec flush ini cnt =
- if cnt > ini then Format.print_string (String.sub str ini (cnt - ini))
- else ()
- in
- let rec loop ini cnt =
- if cnt == String.length str then flush ini cnt
- else
- match str.[cnt] with
- [ '\n' ->
- do {
- flush ini cnt;
- Format.close_box ();
- Format.force_newline ();
- Format.open_box 2;
- loop (cnt + 1) (cnt + 1)
- }
- | ' ' ->
- do {
- flush ini cnt; Format.print_space (); loop (cnt + 1) (cnt + 1)
- }
- | _ -> loop ini (cnt + 1) ]
- in
- do { Format.open_box 2; loop 0 0; Format.close_box () }
-;
-
-value print_file_failed file line char =
- do {
- Format.print_string ", file \"";
- Format.print_string file;
- Format.print_string "\", line ";
- Format.print_int line;
- Format.print_string ", char ";
- Format.print_int char
- }
-;
-
-value print_exn =
- fun
- [ Out_of_memory -> Format.print_string "Out of memory\n"
- | Assert_failure (file, line, char) ->
- do {
- Format.print_string "Assertion failed";
- print_file_failed file line char;
- }
- | Match_failure (file, line, char) ->
- do {
- Format.print_string "Pattern matching failed";
- print_file_failed file line char;
- }
- | Stream.Error str -> print_format ("Parse error: " ^ str)
- | Stream.Failure -> Format.print_string "Parse failure"
- | Token.Error str ->
- do { Format.print_string "Lexing error: "; Format.print_string str }
- | Failure str ->
- do { Format.print_string "Failure: "; Format.print_string str }
- | Invalid_argument str ->
- do { Format.print_string "Invalid argument: "; Format.print_string str }
- | Sys_error msg ->
- do { Format.print_string "I/O error: "; Format.print_string msg }
- | x ->
- do {
- Format.print_string "Uncaught exception: ";
- Format.print_string
- (Obj.magic (Obj.field (Obj.field (Obj.repr x) 0) 0));
- if Obj.size (Obj.repr x) > 1 then do {
- Format.print_string " (";
- for i = 1 to Obj.size (Obj.repr x) - 1 do {
- if i > 1 then Format.print_string ", " else ();
- let arg = Obj.field (Obj.repr x) i in
- if not (Obj.is_block arg) then
- Format.print_int (Obj.magic arg : int)
- else if Obj.tag arg = Obj.tag (Obj.repr "a") then do {
- Format.print_char '"';
- Format.print_string (Obj.magic arg : string);
- Format.print_char '"'
- }
- else Format.print_char '_'
- };
- Format.print_char ')'
- }
- else ()
- } ]
-;
-
-value report_error exn =
- match exn with
- [ Qerror name Finding Not_found ->
- let name = if name = "" then Quotation.default.val else name in
- do {
- Format.print_flush ();
- Format.open_hovbox 2;
- Format.printf "Unbound quotation: \"%s\"" name;
- Format.close_box ()
- }
- | Qerror name ctx exn ->
- do { report_quotation_error name ctx; print_exn exn }
- | e -> print_exn exn ]
-;
-
-value no_constructors_arity = Ast2pt.no_constructors_arity;
-(*value no_assert = ref False;*)
-
-value arg_spec_list_ref = ref [];
-value arg_spec_list () = arg_spec_list_ref.val;
-value add_option name spec descr =
- arg_spec_list_ref.val := arg_spec_list_ref.val @ [(name, spec, descr)]
-;
-
-(* Printers *)
-
-open Spretty;
-
-type printer_t 'a =
- { pr_fun : mutable string -> 'a -> string -> kont -> pretty;
- pr_levels : mutable list (pr_level 'a) }
-and pr_level 'a =
- { pr_label : string;
- pr_box : 'a -> Stream.t pretty -> pretty;
- pr_rules : mutable pr_rule 'a }
-and pr_rule 'a =
- Extfun.t 'a (curr 'a -> next 'a -> string -> kont -> Stream.t pretty)
-and curr 'a = 'a -> string -> kont -> Stream.t pretty
-and next 'a = 'a -> string -> kont -> pretty
-and kont = Stream.t pretty
-;
-
-value pr_str_item = {pr_fun = fun []; pr_levels = []};
-value pr_sig_item = {pr_fun = fun []; pr_levels = []};
-value pr_module_type = {pr_fun = fun []; pr_levels = []};
-value pr_module_expr = {pr_fun = fun []; pr_levels = []};
-value pr_expr = {pr_fun = fun []; pr_levels = []};
-value pr_patt = {pr_fun = fun []; pr_levels = []};
-value pr_ctyp = {pr_fun = fun []; pr_levels = []};
-value pr_class_sig_item = {pr_fun = fun []; pr_levels = []};
-value pr_class_str_item = {pr_fun = fun []; pr_levels = []};
-value pr_class_type = {pr_fun = fun []; pr_levels = []};
-value pr_class_expr = {pr_fun = fun []; pr_levels = []};
-value pr_expr_fun_args = ref Extfun.empty;
-
-value pr_fun name pr lab =
- loop False pr.pr_levels where rec loop app =
- fun
- [ [] -> fun x dg k -> failwith ("unable to print " ^ name)
- | [lev :: levl] ->
- if app || lev.pr_label = lab then
- let next = loop True levl in
- let rec curr x dg k = Extfun.apply lev.pr_rules x curr next dg k in
- fun x dg k -> lev.pr_box x (curr x dg k)
- else loop app levl ]
-;
-
-pr_str_item.pr_fun := pr_fun "str_item" pr_str_item;
-pr_sig_item.pr_fun := pr_fun "sig_item" pr_sig_item;
-pr_module_type.pr_fun := pr_fun "module_type" pr_module_type;
-pr_module_expr.pr_fun := pr_fun "module_expr" pr_module_expr;
-pr_expr.pr_fun := pr_fun "expr" pr_expr;
-pr_patt.pr_fun := pr_fun "patt" pr_patt;
-pr_ctyp.pr_fun := pr_fun "ctyp" pr_ctyp;
-pr_class_sig_item.pr_fun := pr_fun "class_sig_item" pr_class_sig_item;
-pr_class_str_item.pr_fun := pr_fun "class_str_item" pr_class_str_item;
-pr_class_type.pr_fun := pr_fun "class_type" pr_class_type;
-pr_class_expr.pr_fun := pr_fun "class_expr" pr_class_expr;
-
-value rec find_pr_level lab =
- fun
- [ [] -> failwith ("level " ^ lab ^ " not found")
- | [lev :: levl] ->
- if lev.pr_label = lab then lev else find_pr_level lab levl ]
-;
-
-value undef x = ref (fun _ -> failwith x);
-value print_interf = undef "no printer";
-value print_implem = undef "no printer";
-
-value top_printer pr x =
- do {
- Format.force_newline ();
- Spretty.print_pretty Format.print_char Format.print_string
- Format.print_newline "<< " " " 78
- (fun _ _ -> ("", 0, 0, 0)) 0 (pr.pr_fun "top" x "" [: :]);
- Format.print_string " >>";
- }
-;
-
-value buff = Buffer.create 73;
-value buffer_char = Buffer.add_char buff;
-value buffer_string = Buffer.add_string buff;
-value buffer_newline () = Buffer.add_char buff '\n';
-
-value string_of pr x =
- do {
- Buffer.clear buff;
- Spretty.print_pretty buffer_char buffer_string buffer_newline "" "" 78
- (fun _ _ -> ("", 0, 0, 0)) 0 (pr.pr_fun "top" x "" [: :]);
- Buffer.contents buff
- }
-;
-
-value inter_phrases = ref None;
diff --git a/camlp4/camlp4/pcaml.mli b/camlp4/camlp4/pcaml.mli
deleted file mode 100644
index c87ebe39ae..0000000000
--- a/camlp4/camlp4/pcaml.mli
+++ /dev/null
@@ -1,157 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Language grammar, entries and printers.
-
- Hold variables to be set by language syntax extensions. Some of them
- are provided for quotations management. *)
-
-value syntax_name : ref string;
-
-(** {6 Parsers} *)
-
-value parse_interf :
- ref (Stream.t char -> (list (MLast.sig_item * MLast.loc) * bool));
-value parse_implem :
- ref (Stream.t char -> (list (MLast.str_item * MLast.loc) * bool));
- (** Called when parsing an interface (mli file) or an implementation
- (ml file) to build the syntax tree; the returned list contains the
- phrases (signature items or structure items) and their locations;
- the boolean tells that the parser has encountered a directive; in
- this case, since the directive may change the syntax, the parsing
- stops, the directive is evaluated, and this function is called
- again.
- These functions are references, because they can be changed to
- use another technology than the Camlp4 extended grammars. By
- default, they use the grammars entries [implem] and [interf]
- defined below. *)
-
-value gram : Grammar.g;
- (** Grammar variable of the OCaml language *)
-
-value interf : Grammar.Entry.e (list (MLast.sig_item * MLast.loc) * bool);
-value implem : Grammar.Entry.e (list (MLast.str_item * MLast.loc) * bool);
-value top_phrase : Grammar.Entry.e (option MLast.str_item);
-value use_file : Grammar.Entry.e (list MLast.str_item * bool);
-value module_type : Grammar.Entry.e MLast.module_type;
-value module_expr : Grammar.Entry.e MLast.module_expr;
-value sig_item : Grammar.Entry.e MLast.sig_item;
-value str_item : Grammar.Entry.e MLast.str_item;
-value expr : Grammar.Entry.e MLast.expr;
-value patt : Grammar.Entry.e MLast.patt;
-value ctyp : Grammar.Entry.e MLast.ctyp;
-value let_binding : Grammar.Entry.e (MLast.patt * MLast.expr);
-value type_declaration : Grammar.Entry.e MLast.type_decl;
-value class_sig_item : Grammar.Entry.e MLast.class_sig_item;
-value class_str_item : Grammar.Entry.e MLast.class_str_item;
-value class_expr : Grammar.Entry.e MLast.class_expr;
-value class_type : Grammar.Entry.e MLast.class_type;
- (** Some entries of the language, set by [pa_o.cmo] and [pa_r.cmo]. *)
-
-value input_file : ref string;
- (** The file currently being parsed. *)
-value output_file : ref (option string);
- (** The output file, stdout if None (default) *)
-value report_error : exn -> unit;
- (** Prints an error message, using the module [Format]. *)
-value quotation_dump_file : ref (option string);
- (** [quotation_dump_file] optionally tells the compiler to dump the
- result of an expander if this result is syntactically incorrect.
- If [None] (default), this result is not dumped. If [Some fname], the
- result is dumped in the file [fname]. *)
-value version : string;
- (** The current version of Camlp4. *)
-value add_option : string -> Arg.spec -> string -> unit;
- (** Add an option to the command line options. *)
-value no_constructors_arity : ref bool;
- (** [True]: dont generate constructor arity. *)
-(*value no_assert : ref bool;
- (** [True]: dont generate assertion checks. *)
-*)
-
-value sync : ref (Stream.t char -> unit);
-
-value handle_expr_quotation : MLast.loc -> (string * string) -> MLast.expr;
-value handle_expr_locate : MLast.loc -> (int * string) -> MLast.expr;
-
-value handle_patt_quotation : MLast.loc -> (string * string) -> MLast.patt;
-value handle_patt_locate : MLast.loc -> (int * string) -> MLast.patt;
-
-value expr_reloc :
- (MLast.loc -> MLast.loc) -> int -> MLast.expr -> MLast.expr;
-value patt_reloc :
- (MLast.loc -> MLast.loc) -> int -> MLast.patt -> MLast.patt;
-
-(** To possibly rename identifiers; parsers may call this function
- when generating their identifiers; default = identity *)
-value rename_id : ref (string -> string);
-
-(** Allow user to catch exceptions in quotations *)
-type err_ctx =
- [ Finding | Expanding | ParsingResult of (int * int) and string | Locating ]
-;
-exception Qerror of string and err_ctx and exn;
-
-(** {6 Printers} *)
-
-open Spretty;
-
-value print_interf : ref (list (MLast.sig_item * MLast.loc) -> unit);
-value print_implem : ref (list (MLast.str_item * MLast.loc) -> unit);
- (** Some printers, set by [pr_dump.cmo], [pr_o.cmo] and [pr_r.cmo]. *)
-
-type printer_t 'a =
- { pr_fun : mutable string -> 'a -> string -> kont -> pretty;
- pr_levels : mutable list (pr_level 'a) }
-and pr_level 'a =
- { pr_label : string;
- pr_box : 'a -> Stream.t pretty -> pretty;
- pr_rules : mutable pr_rule 'a }
-and pr_rule 'a =
- Extfun.t 'a (curr 'a -> next 'a -> string -> kont -> Stream.t pretty)
-and curr 'a = 'a -> string -> kont -> Stream.t pretty
-and next 'a = 'a -> string -> kont -> pretty
-and kont = Stream.t pretty
-;
-
-value pr_sig_item : printer_t MLast.sig_item;
-value pr_str_item : printer_t MLast.str_item;
-value pr_module_type : printer_t MLast.module_type;
-value pr_module_expr : printer_t MLast.module_expr;
-value pr_expr : printer_t MLast.expr;
-value pr_patt : printer_t MLast.patt;
-value pr_ctyp : printer_t MLast.ctyp;
-value pr_class_sig_item : printer_t MLast.class_sig_item;
-value pr_class_str_item : printer_t MLast.class_str_item;
-value pr_class_type : printer_t MLast.class_type;
-value pr_class_expr : printer_t MLast.class_expr;
-
-value pr_expr_fun_args :
- ref (Extfun.t MLast.expr (list MLast.patt * MLast.expr));
-
-value find_pr_level : string -> list (pr_level 'a) -> pr_level 'a;
-
-value top_printer : printer_t 'a -> 'a -> unit;
-value string_of : printer_t 'a -> 'a -> string;
-
-value inter_phrases : ref (option string);
-
-(**/**)
-
-(* for system use *)
-
-value warning : ref ((int * int) -> string -> unit);
-value expr_eoi : Grammar.Entry.e MLast.expr;
-value patt_eoi : Grammar.Entry.e MLast.patt;
-value arg_spec_list : unit -> list (string * Arg.spec * string);
diff --git a/camlp4/camlp4/quotation.ml b/camlp4/camlp4/quotation.ml
deleted file mode 100644
index 431a75768d..0000000000
--- a/camlp4/camlp4/quotation.ml
+++ /dev/null
@@ -1,33 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-type expander =
- [ ExStr of bool -> string -> string
- | ExAst of (string -> MLast.expr * string -> MLast.patt) ]
-;
-
-value expanders_table = ref [];
-
-value default = ref "";
-value translate = ref (fun x -> x);
-
-value expander_name name =
- match translate.val name with
- [ "" -> default.val
- | name -> name ]
-;
-
-value find name = List.assoc (expander_name name) expanders_table.val;
-
-value add name f = expanders_table.val := [(name, f) :: expanders_table.val];
diff --git a/camlp4/camlp4/quotation.mli b/camlp4/camlp4/quotation.mli
deleted file mode 100644
index 3c0f5f6c4f..0000000000
--- a/camlp4/camlp4/quotation.mli
+++ /dev/null
@@ -1,48 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1998 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Quotation operations. *)
-
-type expander =
- [ ExStr of bool -> string -> string
- | ExAst of (string -> MLast.expr * string -> MLast.patt) ]
-;
-
-(** The type for quotation expanders kind:
-- [ExStr exp] for an expander [exp] returning a string which
- can be parsed to create a syntax tree. Its boolean parameter
- tells whether the quotation is in position of an expression
- (True) or in position of a pattern (False). Quotations expanders
- created with this way may work for some particular language syntax,
- and not for another one (e.g. may work when used with Revised
- syntax and not when used with Ocaml syntax, and conversely).
-- [ExAst (expr_exp, patt_exp)] for expanders returning directly
- syntax trees, therefore not necessiting to be parsed afterwards.
- The function [expr_exp] is called when the quotation is in
- position of an expression, and [patt_exp] when the quotation is
- in position of a pattern. Quotation expanders created with this
- way are independant from the language syntax. *)
-
-value add : string -> expander -> unit;
- (** [add name exp] adds the quotation [name] associated with the
- expander [exp]. *)
-
-value find : string -> expander;
- (** [find name] returns the expander of the given quotation name. *)
-
-value default : ref string;
- (** [default] holds the default quotation name. *)
-
-value translate : ref (string -> string);
- (** function translating quotation names; default = identity *)
diff --git a/camlp4/camlp4/reloc.ml b/camlp4/camlp4/reloc.ml
deleted file mode 100644
index 73f81b9b7b..0000000000
--- a/camlp4/camlp4/reloc.ml
+++ /dev/null
@@ -1,289 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1998 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open MLast;
-
-value option_map f =
- fun
- [ Some x -> Some (f x)
- | None -> None ]
-;
-
-value rec ctyp floc sh =
- self where rec self =
- fun
- [ TyAcc loc x1 x2 -> TyAcc (floc loc) (self x1) (self x2)
- | TyAli loc x1 x2 -> TyAli (floc loc) (self x1) (self x2)
- | TyAny loc -> TyAny (floc loc)
- | TyApp loc x1 x2 -> TyApp (floc loc) (self x1) (self x2)
- | TyArr loc x1 x2 -> TyArr (floc loc) (self x1) (self x2)
- | TyCls loc x1 -> TyCls (floc loc) x1
- | TyLab loc x1 x2 -> TyLab (floc loc) x1 (self x2)
- | TyLid loc x1 -> TyLid (floc loc) x1
- | TyMan loc x1 x2 -> TyMan (floc loc) (self x1) (self x2)
- | TyObj loc x1 x2 ->
- TyObj (floc loc) (List.map (fun (x1, x2) -> (x1, self x2)) x1) x2
- | TyOlb loc x1 x2 -> TyOlb (floc loc) x1 (self x2)
- | TyPol loc x1 x2 -> TyPol (floc loc) x1 (self x2)
- | TyQuo loc x1 -> TyQuo (floc loc) x1
- | TyRec loc pflag x1 ->
- TyRec (floc loc) pflag
- (List.map (fun (loc, x1, x2, x3) -> (floc loc, x1, x2, self x3)) x1)
- | TySum loc pflag x1 ->
- TySum (floc loc) pflag
- (List.map (fun (loc, x1, x2) -> (floc loc, x1, List.map self x2)) x1)
- | TyTup loc x1 -> TyTup (floc loc) (List.map self x1)
- | TyUid loc x1 -> TyUid (floc loc) x1
- | TyVrn loc x1 x2 ->
- TyVrn (floc loc) (List.map (row_field floc sh) x1) x2 ]
-and row_field floc sh =
- fun
- [ RfTag x1 x2 x3 -> RfTag x1 x2 (List.map (ctyp floc sh) x3)
- | RfInh x1 -> RfInh (ctyp floc sh x1) ]
-;
-
-value class_infos a floc sh x =
- {ciLoc = floc x.ciLoc; ciVir = x.ciVir;
- ciPrm =
- let (x1, x2) = x.ciPrm in
- (floc x1, x2);
- ciNam = x.ciNam; ciExp = a floc sh x.ciExp}
-;
-
-value rec patt floc sh =
- self where rec self =
- fun
- [ PaAcc loc x1 x2 -> PaAcc (floc loc) (self x1) (self x2)
- | PaAli loc x1 x2 -> PaAli (floc loc) (self x1) (self x2)
- | PaAnt loc x1 ->
- patt (fun (p1, p2) -> (sh + fst loc + p1, sh + fst loc + p2)) 0 x1
- | PaAny loc -> PaAny (floc loc)
- | PaApp loc x1 x2 -> PaApp (floc loc) (self x1) (self x2)
- | PaArr loc x1 -> PaArr (floc loc) (List.map self x1)
- | PaChr loc x1 -> PaChr (floc loc) x1
- | PaInt loc x1 -> PaInt (floc loc) x1
- | PaInt32 loc x1 -> PaInt32 (floc loc) x1
- | PaInt64 loc x1 -> PaInt64 (floc loc) x1
- | PaNativeInt loc x1 -> PaNativeInt (floc loc) x1
- | PaFlo loc x1 -> PaFlo (floc loc) x1
- | PaLab loc x1 x2 -> PaLab (floc loc) x1 (option_map self x2)
- | PaLid loc x1 -> PaLid (floc loc) x1
- | PaOlb loc x1 x2 ->
- PaOlb (floc loc) x1
- (option_map
- (fun (x1, x2) -> (self x1, option_map (expr floc sh) x2)) x2)
- | PaOrp loc x1 x2 -> PaOrp (floc loc) (self x1) (self x2)
- | PaRng loc x1 x2 -> PaRng (floc loc) (self x1) (self x2)
- | PaRec loc x1 ->
- PaRec (floc loc) (List.map (fun (x1, x2) -> (self x1, self x2)) x1)
- | PaStr loc x1 -> PaStr (floc loc) x1
- | PaTup loc x1 -> PaTup (floc loc) (List.map self x1)
- | PaTyc loc x1 x2 -> PaTyc (floc loc) (self x1) (ctyp floc sh x2)
- | PaTyp loc x1 -> PaTyp (floc loc) x1
- | PaUid loc x1 -> PaUid (floc loc) x1
- | PaVrn loc x1 -> PaVrn (floc loc) x1 ]
-and expr floc sh =
- self where rec self =
- fun
- [ ExAcc loc x1 x2 -> ExAcc (floc loc) (self x1) (self x2)
- | ExAnt loc x1 ->
- expr (fun (p1, p2) -> (sh + fst loc + p1, sh + fst loc + p2)) 0 x1
- | ExApp loc x1 x2 -> ExApp (floc loc) (self x1) (self x2)
- | ExAre loc x1 x2 -> ExAre (floc loc) (self x1) (self x2)
- | ExArr loc x1 -> ExArr (floc loc) (List.map self x1)
- | ExAsf loc -> ExAsf (floc loc)
- | ExAsr loc x1 -> ExAsr (floc loc) (self x1)
- | ExAss loc x1 x2 -> ExAss (floc loc) (self x1) (self x2)
- | ExChr loc x1 -> ExChr (floc loc) x1
- | ExCoe loc x1 x2 x3 ->
- ExCoe (floc loc) (self x1) (option_map (ctyp floc sh) x2)
- (ctyp floc sh x3)
- | ExFlo loc x1 -> ExFlo (floc loc) x1
- | ExFor loc x1 x2 x3 x4 x5 ->
- ExFor (floc loc) x1 (self x2) (self x3) x4 (List.map self x5)
- | ExFun loc x1 ->
- ExFun (floc loc)
- (List.map
- (fun (x1, x2, x3) ->
- (patt floc sh x1, option_map self x2, self x3))
- x1)
- | ExIfe loc x1 x2 x3 -> ExIfe (floc loc) (self x1) (self x2) (self x3)
- | ExInt loc x1 -> ExInt (floc loc) x1
- | ExInt32 loc x1 -> ExInt32 (floc loc) x1
- | ExInt64 loc x1 -> ExInt64 (floc loc) x1
- | ExNativeInt loc x1 -> ExNativeInt (floc loc) x1
- | ExLab loc x1 x2 -> ExLab (floc loc) x1 (option_map self x2)
- | ExLaz loc x1 -> ExLaz (floc loc) (self x1)
- | ExLet loc x1 x2 x3 ->
- ExLet (floc loc) x1
- (List.map (fun (x1, x2) -> (patt floc sh x1, self x2)) x2) (self x3)
- | ExLid loc x1 -> ExLid (floc loc) x1
- | ExLmd loc x1 x2 x3 ->
- ExLmd (floc loc) x1 (module_expr floc sh x2) (self x3)
- | ExMat loc x1 x2 ->
- ExMat (floc loc) (self x1)
- (List.map
- (fun (x1, x2, x3) ->
- (patt floc sh x1, option_map self x2, self x3))
- x2)
- | ExNew loc x1 -> ExNew (floc loc) x1
- | ExOlb loc x1 x2 -> ExOlb (floc loc) x1 (option_map self x2)
- | ExOvr loc x1 ->
- ExOvr (floc loc) (List.map (fun (x1, x2) -> (x1, self x2)) x1)
- | ExRec loc x1 x2 ->
- ExRec (floc loc)
- (List.map (fun (x1, x2) -> (patt floc sh x1, self x2)) x1)
- (option_map self x2)
- | ExSeq loc x1 -> ExSeq (floc loc) (List.map self x1)
- | ExSnd loc x1 x2 -> ExSnd (floc loc) (self x1) x2
- | ExSte loc x1 x2 -> ExSte (floc loc) (self x1) (self x2)
- | ExStr loc x1 -> ExStr (floc loc) x1
- | ExTry loc x1 x2 ->
- ExTry (floc loc) (self x1)
- (List.map
- (fun (x1, x2, x3) ->
- (patt floc sh x1, option_map self x2, self x3))
- x2)
- | ExTup loc x1 -> ExTup (floc loc) (List.map self x1)
- | ExTyc loc x1 x2 -> ExTyc (floc loc) (self x1) (ctyp floc sh x2)
- | ExUid loc x1 -> ExUid (floc loc) x1
- | ExVrn loc x1 -> ExVrn (floc loc) x1
- | ExWhi loc x1 x2 -> ExWhi (floc loc) (self x1) (List.map self x2) ]
-and module_type floc sh =
- self where rec self =
- fun
- [ MtAcc loc x1 x2 -> MtAcc (floc loc) (self x1) (self x2)
- | MtApp loc x1 x2 -> MtApp (floc loc) (self x1) (self x2)
- | MtFun loc x1 x2 x3 -> MtFun (floc loc) x1 (self x2) (self x3)
- | MtLid loc x1 -> MtLid (floc loc) x1
- | MtQuo loc x1 -> MtQuo (floc loc) x1
- | MtSig loc x1 -> MtSig (floc loc) (List.map (sig_item floc sh) x1)
- | MtUid loc x1 -> MtUid (floc loc) x1
- | MtWit loc x1 x2 ->
- MtWit (floc loc) (self x1) (List.map (with_constr floc sh) x2) ]
-and sig_item floc sh =
- self where rec self =
- fun
- [ SgCls loc x1 ->
- SgCls (floc loc) (List.map (class_infos class_type floc sh) x1)
- | SgClt loc x1 ->
- SgClt (floc loc) (List.map (class_infos class_type floc sh) x1)
- | SgDcl loc x1 -> SgDcl (floc loc) (List.map self x1)
- | SgDir loc x1 x2 -> SgDir (floc loc) x1 x2
- | SgExc loc x1 x2 -> SgExc (floc loc) x1 (List.map (ctyp floc sh) x2)
- | SgExt loc x1 x2 x3 -> SgExt (floc loc) x1 (ctyp floc sh x2) x3
- | SgInc loc x1 -> SgInc (floc loc) (module_type floc sh x1)
- | SgMod loc x1 x2 -> SgMod (floc loc) x1 (module_type floc sh x2)
- | SgRecMod loc xxs
- -> SgRecMod (floc loc) (List.map (fun (x1,x2) -> (x1, (module_type floc sh x2))) xxs)
- | SgMty loc x1 x2 -> SgMty (floc loc) x1 (module_type floc sh x2)
- | SgOpn loc x1 -> SgOpn (floc loc) x1
- | SgTyp loc x1 ->
- SgTyp (floc loc)
- (List.map
- (fun ((loc, x1), x2, x3, x4) ->
- ((floc loc, x1), x2, ctyp floc sh x3,
- List.map (fun (x1, x2) -> (ctyp floc sh x1, ctyp floc sh x2))
- x4))
- x1)
- | SgUse loc x1 x2 -> SgUse loc x1 x2
- | SgVal loc x1 x2 -> SgVal (floc loc) x1 (ctyp floc sh x2) ]
-and with_constr floc sh =
- self where rec self =
- fun
- [ WcTyp loc x1 x2 x3 -> WcTyp (floc loc) x1 x2 (ctyp floc sh x3)
- | WcMod loc x1 x2 -> WcMod (floc loc) x1 (module_expr floc sh x2) ]
-and module_expr floc sh =
- self where rec self =
- fun
- [ MeAcc loc x1 x2 -> MeAcc (floc loc) (self x1) (self x2)
- | MeApp loc x1 x2 -> MeApp (floc loc) (self x1) (self x2)
- | MeFun loc x1 x2 x3 ->
- MeFun (floc loc) x1 (module_type floc sh x2) (self x3)
- | MeStr loc x1 -> MeStr (floc loc) (List.map (str_item floc sh) x1)
- | MeTyc loc x1 x2 -> MeTyc (floc loc) (self x1) (module_type floc sh x2)
- | MeUid loc x1 -> MeUid (floc loc) x1 ]
-and str_item floc sh =
- self where rec self =
- fun
- [ StCls loc x1 ->
- StCls (floc loc) (List.map (class_infos class_expr floc sh) x1)
- | StClt loc x1 ->
- StClt (floc loc) (List.map (class_infos class_type floc sh) x1)
- | StDcl loc x1 -> StDcl (floc loc) (List.map self x1)
- | StDir loc x1 x2 -> StDir (floc loc) x1 x2
- | StExc loc x1 x2 x3 -> StExc (floc loc) x1 (List.map (ctyp floc sh) x2) x3
- | StExp loc x1 -> StExp (floc loc) (expr floc sh x1)
- | StExt loc x1 x2 x3 -> StExt (floc loc) x1 (ctyp floc sh x2) x3
- | StInc loc x1 -> StInc (floc loc) (module_expr floc sh x1)
- | StMod loc x1 x2 -> StMod (floc loc) x1 (module_expr floc sh x2)
- | StRecMod loc nmtmes ->
- StRecMod (floc loc) (List.map (fun (n, mt, me) -> (n, module_type floc sh mt, module_expr floc sh me)) nmtmes)
- | StMty loc x1 x2 -> StMty (floc loc) x1 (module_type floc sh x2)
- | StOpn loc x1 -> StOpn (floc loc) x1
- | StTyp loc x1 ->
- StTyp (floc loc)
- (List.map
- (fun ((loc, x1), x2, x3, x4) ->
- ((floc loc, x1), x2, ctyp floc sh x3,
- List.map (fun (x1, x2) -> (ctyp floc sh x1, ctyp floc sh x2))
- x4))
- x1)
- | StUse loc x1 x2 -> StUse loc x1 x2
- | StVal loc x1 x2 ->
- StVal (floc loc) x1
- (List.map (fun (x1, x2) -> (patt floc sh x1, expr floc sh x2)) x2) ]
-and class_type floc sh =
- self where rec self =
- fun
- [ CtCon loc x1 x2 -> CtCon (floc loc) x1 (List.map (ctyp floc sh) x2)
- | CtFun loc x1 x2 -> CtFun (floc loc) (ctyp floc sh x1) (self x2)
- | CtSig loc x1 x2 ->
- CtSig (floc loc) (option_map (ctyp floc sh) x1)
- (List.map (class_sig_item floc sh) x2) ]
-and class_sig_item floc sh =
- self where rec self =
- fun
- [ CgCtr loc x1 x2 -> CgCtr (floc loc) (ctyp floc sh x1) (ctyp floc sh x2)
- | CgDcl loc x1 -> CgDcl (floc loc) (List.map (class_sig_item floc sh) x1)
- | CgInh loc x1 -> CgInh (floc loc) (class_type floc sh x1)
- | CgMth loc x1 x2 x3 -> CgMth (floc loc) x1 x2 (ctyp floc sh x3)
- | CgVal loc x1 x2 x3 -> CgVal (floc loc) x1 x2 (ctyp floc sh x3)
- | CgVir loc x1 x2 x3 -> CgVir (floc loc) x1 x2 (ctyp floc sh x3) ]
-and class_expr floc sh =
- self where rec self =
- fun
- [ CeApp loc x1 x2 -> CeApp (floc loc) (self x1) (expr floc sh x2)
- | CeCon loc x1 x2 -> CeCon (floc loc) x1 (List.map (ctyp floc sh) x2)
- | CeFun loc x1 x2 -> CeFun (floc loc) (patt floc sh x1) (self x2)
- | CeLet loc x1 x2 x3 ->
- CeLet (floc loc) x1
- (List.map (fun (x1, x2) -> (patt floc sh x1, expr floc sh x2)) x2)
- (self x3)
- | CeStr loc x1 x2 ->
- CeStr (floc loc) (option_map (patt floc sh) x1)
- (List.map (class_str_item floc sh) x2)
- | CeTyc loc x1 x2 -> CeTyc (floc loc) (self x1) (class_type floc sh x2) ]
-and class_str_item floc sh =
- self where rec self =
- fun
- [ CrCtr loc x1 x2 -> CrCtr (floc loc) (ctyp floc sh x1) (ctyp floc sh x2)
- | CrDcl loc x1 -> CrDcl (floc loc) (List.map (class_str_item floc sh) x1)
- | CrInh loc x1 x2 -> CrInh (floc loc) (class_expr floc sh x1) x2
- | CrIni loc x1 -> CrIni (floc loc) (expr floc sh x1)
- | CrMth loc x1 x2 x3 x4 ->
- CrMth (floc loc) x1 x2 (expr floc sh x3) (option_map (ctyp floc sh) x4)
- | CrVal loc x1 x2 x3 -> CrVal (floc loc) x1 x2 (expr floc sh x3)
- | CrVir loc x1 x2 x3 -> CrVir (floc loc) x1 x2 (ctyp floc sh x3) ]
-;
diff --git a/camlp4/camlp4/reloc.mli b/camlp4/camlp4/reloc.mli
deleted file mode 100644
index d1a09a4e1f..0000000000
--- a/camlp4/camlp4/reloc.mli
+++ /dev/null
@@ -1,16 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1998 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-value patt : (MLast.loc -> MLast.loc) -> int -> MLast.patt -> MLast.patt;
-value expr : (MLast.loc -> MLast.loc) -> int -> MLast.expr -> MLast.expr;
diff --git a/camlp4/camlp4/spretty.ml b/camlp4/camlp4/spretty.ml
deleted file mode 100644
index 2484cb47be..0000000000
--- a/camlp4/camlp4/spretty.ml
+++ /dev/null
@@ -1,481 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-type glue = [ LO | RO | LR | NO ];
-type pretty =
- [ S of glue and string
- | Hbox of Stream.t pretty
- | HVbox of Stream.t pretty
- | HOVbox of Stream.t pretty
- | HOVCbox of Stream.t pretty
- | Vbox of Stream.t pretty
- | BEbox of Stream.t pretty
- | BEVbox of Stream.t pretty
- | LocInfo of (int * int) and pretty ]
-;
-type prettyL =
- [ SL of int and glue and string
- | HL of list prettyL
- | BL of list prettyL
- | PL of list prettyL
- | QL of list prettyL
- | VL of list prettyL
- | BE of list prettyL
- | BV of list prettyL
- | LI of (string * int * int) and prettyL ]
-;
-type getcomm = int -> int -> (string * int * int * int);
-
-value quiet = ref True;
-value maxl = ref 20;
-value dt = ref 2;
-value tol = ref 1;
-value sp = ref ' ';
-value last_ep = ref 0;
-value getcomm = ref (fun _ _ -> ("", 0, 0, 0));
-value prompt = ref "";
-value print_char_fun = ref (output_char stdout);
-value print_string_fun = ref (output_string stdout);
-value print_newline_fun = ref (fun () -> output_char stdout '\n');
-value lazy_tab = ref (-1);
-
-value flush_tab () =
- if lazy_tab.val >= 0 then do {
- print_newline_fun.val ();
- print_string_fun.val prompt.val;
- for i = 1 to lazy_tab.val do { print_char_fun.val sp.val };
- lazy_tab.val := -1
- }
- else ()
-;
-value print_newline_and_tab tab = lazy_tab.val := tab;
-value print_char c = do { flush_tab (); print_char_fun.val c };
-value print_string s = do { flush_tab (); print_string_fun.val s };
-
-value rec print_spaces nsp =
- for i = 1 to nsp do { print_char sp.val }
-;
-
-value end_with_tab s =
- loop (String.length s - 1) where rec loop i =
- if i >= 0 then
- if s.[i] = ' ' then loop (i - 1)
- else s.[i] = '\n'
- else False
-;
-
-value print_comment tab s nl_bef tab_bef empty_stmt =
- if s = "" then ()
- else do {
- let (tab_aft, i_bef_tab) =
- loop 0 (String.length s - 1) where rec loop tab_aft i =
- if i >= 0 && s.[i] = ' ' then loop (tab_aft + 1) (i - 1)
- else (tab_aft, i)
- ;
- let tab_bef = if nl_bef > 0 then tab_bef else tab in
- let len = if empty_stmt then i_bef_tab else String.length s in
- loop 0 where rec loop i =
- if i = len then ()
- else do {
- print_char_fun.val s.[i];
- let i =
- if s.[i] = '\n' && (i+1 = len || s.[i+1] <> '\n')
- then
- let delta_ind =
- if i = i_bef_tab then tab - tab_aft else tab - tab_bef
- in
- if delta_ind >= 0 then do {
- for i = 1 to delta_ind do { print_char_fun.val ' ' };
- i + 1
- }
- else
- loop delta_ind (i + 1) where rec loop cnt i =
- if cnt = 0 then i
- else if i = len then i
- else if s.[i] = ' ' then loop (cnt + 1) (i + 1)
- else i
- else i + 1
- in
- loop i
- }
- }
-;
-
-value string_np pos np = pos + np;
-
-value trace_ov pos =
- if not quiet.val && pos > maxl.val then do {
- prerr_string "<W> prettych: overflow (length = ";
- prerr_int pos;
- prerr_endline ")"
- }
- else ()
-;
-
-value tolerate tab pos spc = pos + spc <= tab + dt.val + tol.val;
-
-value h_print_string pos spc np x =
- let npos = string_np (pos + spc) np in
- do { print_spaces spc; print_string x; npos }
-;
-
-value n_print_string pos spc np x =
- do { print_spaces spc; print_string x; string_np (pos + spc) np }
-;
-
-value rec hnps ((pos, spc) as ps) =
- fun
- [ SL np RO _ -> (string_np pos np, 1)
- | SL np LO _ -> (string_np (pos + spc) np, 0)
- | SL np NO _ -> (string_np pos np, 0)
- | SL np LR _ -> (string_np (pos + spc) np, 1)
- | HL x -> hnps_list ps x
- | BL x -> hnps_list ps x
- | PL x -> hnps_list ps x
- | QL x -> hnps_list ps x
- | VL [x] -> hnps ps x
- | VL [] -> ps
- | VL x -> (maxl.val + 1, 0)
- | BE x -> hnps_list ps x
- | BV x -> (maxl.val + 1, 0)
- | LI _ x -> hnps ps x ]
-and hnps_list ((pos, _) as ps) pl =
- if pos > maxl.val then (maxl.val + 1, 0)
- else
- match pl with
- [ [p :: pl] -> hnps_list (hnps ps p) pl
- | [] -> ps ]
-;
-
-value rec first =
- fun
- [ SL _ _ s -> Some s
- | HL x -> first_in_list x
- | BL x -> first_in_list x
- | PL x -> first_in_list x
- | QL x -> first_in_list x
- | VL x -> first_in_list x
- | BE x -> first_in_list x
- | BV x -> first_in_list x
- | LI _ x -> first x ]
-and first_in_list =
- fun
- [ [p :: pl] ->
- match first p with
- [ Some p -> Some p
- | None -> first_in_list pl ]
- | [] -> None ]
-;
-
-value first_is_too_big tab p =
- match first p with
- [ Some s -> tab + String.length s >= maxl.val
- | None -> False ]
-;
-
-value too_long tab x p =
- if first_is_too_big tab p then False
- else
- let (pos, spc) = hnps x p in
- pos > maxl.val
-;
-
-value rec has_comment =
- fun
- [ [LI (comm, nl_bef, tab_bef) x :: pl] ->
- comm <> "" || has_comment [x :: pl]
- | [HL x | BL x | PL x | QL x | VL x | BE x | BV x :: pl] ->
- has_comment x || has_comment pl
- | [SL _ _ _ :: pl] -> has_comment pl
- | [] -> False ]
-;
-
-value rec hprint_pretty tab pos spc =
- fun
- [ SL np RO x -> (h_print_string pos 0 np x, 1)
- | SL np LO x -> (h_print_string pos spc np x, 0)
- | SL np NO x -> (h_print_string pos 0 np x, 0)
- | SL np LR x -> (h_print_string pos spc np x, 1)
- | HL x -> hprint_box tab pos spc x
- | BL x -> hprint_box tab pos spc x
- | PL x -> hprint_box tab pos spc x
- | QL x -> hprint_box tab pos spc x
- | VL [x] -> hprint_pretty tab pos spc x
- | VL [] -> (pos, spc)
- | VL x -> hprint_box tab pos spc x
- | BE x -> hprint_box tab pos spc x
- | BV x ->
- (* This should not occur: should be
- invalid_arg "hprint_pretty" instead *)
- hprint_box tab pos spc x
- | LI (comm, nl_bef, tab_bef) x ->
- do {
- if lazy_tab.val >= 0 then do {
- for i = 2 to nl_bef do { print_char_fun.val '\n' };
- flush_tab ()
- }
- else ();
- print_comment tab comm nl_bef tab_bef False;
- hprint_pretty tab pos spc x
- } ]
-and hprint_box tab pos spc =
- fun
- [ [p :: pl] ->
- let (pos, spc) = hprint_pretty tab pos spc p in
- hprint_box tab pos spc pl
- | [] -> (pos, spc) ]
-;
-
-value rec print_pretty tab pos spc =
- fun
- [ SL np RO x -> (n_print_string pos 0 np x, 1)
- | SL np LO x -> (n_print_string pos spc np x, 0)
- | SL np NO x -> (n_print_string pos 0 np x, 0)
- | SL np LR x -> (n_print_string pos spc np x, 1)
- | HL x as p -> print_horiz tab pos spc x
- | BL x as p -> print_horiz_vertic tab pos spc (too_long tab (pos, spc) p) x
- | PL x as p -> print_paragraph tab pos spc (too_long tab (pos, spc) p) x
- | QL x as p -> print_sparagraph tab pos spc (too_long tab (pos, spc) p) x
- | VL x -> print_vertic tab pos spc x
- | BE x as p -> print_begin_end tab pos spc (too_long tab (pos, spc) p) x
- | BV x -> print_beg_end tab pos spc x
- | LI (comm, nl_bef, tab_bef) x ->
- do {
- if lazy_tab.val >= 0 then do {
- for i = 2 to nl_bef do { print_char_fun.val '\n' };
- if comm <> "" && nl_bef = 0 then
- for i = 1 to tab_bef do { print_char_fun.val ' ' }
- else if comm = "" && x = BL [] then lazy_tab.val := -1
- else flush_tab ()
- }
- else ();
- print_comment tab comm nl_bef tab_bef (x = BL []);
- if comm <> "" && nl_bef = 0 then
- if end_with_tab comm then lazy_tab.val := -1 else flush_tab ()
- else ();
- print_pretty tab pos spc x
- } ]
-and print_horiz tab pos spc =
- fun
- [ [p :: pl] ->
- let (npos, nspc) = print_pretty tab pos spc p in
- if match pl with
- [ [] -> True
- | _ -> False ]
- then
- (npos, nspc)
- else print_horiz tab npos nspc pl
- | [] -> (pos, spc) ]
-and print_horiz_vertic tab pos spc ov pl =
- if ov || has_comment pl then print_vertic tab pos spc pl
- else hprint_box tab pos spc pl
-and print_vertic tab pos spc =
- fun
- [ [p :: pl] ->
- let (npos, nspc) = print_pretty tab pos spc p in
- if match pl with
- [ [] -> True
- | _ -> False ]
- then
- (npos, nspc)
- else if tolerate tab npos nspc then do {
- print_spaces nspc; print_vertic_rest (npos + nspc) pl
- }
- else do {
- print_newline_and_tab (tab + dt.val);
- print_vertic_rest (tab + dt.val) pl
- }
- | [] -> (pos, spc) ]
-and print_vertic_rest tab =
- fun
- [ [p :: pl] ->
- let (pos, spc) = print_pretty tab tab 0 p in
- if match pl with
- [ [] -> True
- | _ -> False ]
- then
- (pos, spc)
- else do {
- print_newline_and_tab tab;
- print_vertic_rest tab pl
- }
- | [] -> (tab, 0) ]
-and print_paragraph tab pos spc ov pl =
- if has_comment pl then print_vertic tab pos spc pl
- else if ov then print_parag tab pos spc pl
- else hprint_box tab pos spc pl
-and print_parag tab pos spc =
- fun
- [ [p :: pl] ->
- let (npos, nspc) = print_pretty tab pos spc p in
- if match pl with
- [ [] -> True
- | _ -> False ]
- then
- (npos, nspc)
- else if npos == tab then print_parag_rest tab tab 0 pl
- else if too_long tab (pos, spc) p then do {
- print_newline_and_tab (tab + dt.val);
- print_parag_rest (tab + dt.val) (tab + dt.val) 0 pl
- }
- else if tolerate tab npos nspc then do {
- print_spaces nspc; print_parag_rest (npos + nspc) (npos + nspc) 0 pl
- }
- else print_parag_rest (tab + dt.val) npos nspc pl
- | [] -> (pos, spc) ]
-and print_parag_rest tab pos spc =
- fun
- [ [p :: pl] ->
- let (pos, spc) =
- if pos > tab && too_long tab (pos, spc) p then do {
- print_newline_and_tab tab; (tab, 0)
- }
- else (pos, spc)
- in
- let (npos, nspc) = print_pretty tab pos spc p in
- if match pl with
- [ [] -> True
- | _ -> False ]
- then
- (npos, nspc)
- else
- let (pos, spc) =
- if npos > tab && too_long tab (pos, spc) p then do {
- print_newline_and_tab tab;
- (tab, 0)
- }
- else (npos, nspc)
- in
- print_parag_rest tab pos spc pl
- | [] -> (pos, spc) ]
-and print_sparagraph tab pos spc ov pl =
- if has_comment pl then print_vertic tab pos spc pl
- else if ov then print_sparag tab pos spc pl
- else hprint_box tab pos spc pl
-and print_sparag tab pos spc =
- fun
- [ [p :: pl] ->
- let (npos, nspc) = print_pretty tab pos spc p in
- if match pl with
- [ [] -> True
- | _ -> False ]
- then
- (npos, nspc)
- else if tolerate tab npos nspc then do {
- print_spaces nspc; print_sparag_rest (npos + nspc) (npos + nspc) 0 pl
- }
- else print_sparag_rest (tab + dt.val) npos nspc pl
- | [] -> (pos, spc) ]
-and print_sparag_rest tab pos spc =
- fun
- [ [p :: pl] ->
- let (pos, spc) =
- if pos > tab && too_long tab (pos, spc) p then do {
- print_newline_and_tab tab; (tab, 0)
- }
- else (pos, spc)
- in
- let (npos, nspc) = print_pretty tab pos spc p in
- if match pl with
- [ [] -> True
- | _ -> False ]
- then
- (npos, nspc)
- else print_sparag_rest tab npos nspc pl
- | [] -> (pos, spc) ]
-and print_begin_end tab pos spc ov pl =
- if ov || has_comment pl then print_beg_end tab pos spc pl
- else hprint_box tab pos spc pl
-and print_beg_end tab pos spc =
- fun
- [ [p :: pl] ->
- let (npos, nspc) = print_pretty tab pos spc p in
- if match pl with
- [ [] -> True
- | _ -> False ]
- then
- (npos, nspc)
- else if tolerate tab npos nspc then do {
- let nspc = if npos == tab then nspc + dt.val else nspc in
- print_spaces nspc;
- print_beg_end_rest tab (npos + nspc) pl
- }
- else do {
- print_newline_and_tab (tab + dt.val);
- print_beg_end_rest tab (tab + dt.val) pl
- }
- | [] -> (pos, spc) ]
-and print_beg_end_rest tab pos =
- fun
- [ [p :: pl] ->
- let (pos, spc) = print_pretty (tab + dt.val) pos 0 p in
- if match pl with
- [ [] -> True
- | _ -> False ]
- then
- (pos, spc)
- else do {
- print_newline_and_tab tab;
- print_beg_end_rest tab tab pl
- }
- | [] -> (pos, 0) ]
-;
-
-value string_npos s = String.length s;
-
-value rec conv =
- fun
- [ S g s -> SL (string_npos s) g s
- | Hbox x -> HL (conv_stream x)
- | HVbox x -> BL (conv_stream x)
- | HOVbox x ->
- match conv_stream x with
- [ [(PL _ as x)] -> x
- | x -> PL x ]
- | HOVCbox x -> QL (conv_stream x)
- | Vbox x -> VL (conv_stream x)
- | BEbox x -> BE (conv_stream x)
- | BEVbox x -> BV (conv_stream x)
- | LocInfo (bp, ep) x ->
- let (comm, nl_bef, tab_bef, cnt) =
- let len = bp - last_ep.val in
- if len > 0 then getcomm.val last_ep.val len
- else ("", 0, 0, 0)
- in
- do {
- last_ep.val := last_ep.val + cnt;
- let v = conv x in
- last_ep.val := max ep last_ep.val;
- LI (comm, nl_bef, tab_bef) v
- } ]
-and conv_stream =
- parser
- [ [: `p; s :] -> let x = conv p in [x :: conv_stream s]
- | [: :] -> [] ]
-;
-
-value print_pretty pr_ch pr_str pr_nl pr pr2 m lf bp p =
- do {
- maxl.val := m;
- print_char_fun.val := pr_ch;
- print_string_fun.val := pr_str;
- print_newline_fun.val := pr_nl;
- prompt.val := pr2;
- getcomm.val := lf;
- last_ep.val := bp;
- print_string pr;
- let _ = print_pretty 0 0 0 (conv p) in
- ()
- }
-;
diff --git a/camlp4/camlp4/spretty.mli b/camlp4/camlp4/spretty.mli
deleted file mode 100644
index 6ce1fd8fc0..0000000000
--- a/camlp4/camlp4/spretty.mli
+++ /dev/null
@@ -1,54 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1998 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Hbox: horizontal box
- HVbox: horizontal-vertical box
- HOVbox and HOVCbox: fill maximum of elements horizontally, line by line;
- in HOVbox, if an element has to be displayed vertically (need several
- lines), the next element is displayed next line; in HOVCbox, this next
- element may be displayed same line if it holds.
- Vbox: vertical box
- BEbox: begin-end box: horizontal or 2nd element indented, 3rd element not
- BEVbox: begin-end box always vertical
- LocInfo: call back with location to allow inserting comments *)
-
-(* In case of box displayed vertically, 2nd line and following are indented
- by dt.val spaces, except if first element of the box is empty: to not
- indent, put HVbox [: :] as first element *)
-
-type glue = [ LO | RO | LR | NO ];
-type pretty =
- [ S of glue and string
- | Hbox of Stream.t pretty
- | HVbox of Stream.t pretty
- | HOVbox of Stream.t pretty
- | HOVCbox of Stream.t pretty
- | Vbox of Stream.t pretty
- | BEbox of Stream.t pretty
- | BEVbox of Stream.t pretty
- | LocInfo of (int * int) and pretty ]
-;
-type getcomm = int -> int -> (string * int * int * int);
-
-value print_pretty :
- (char -> unit) -> (string -> unit) -> (unit -> unit) ->
- string -> string -> int -> getcomm -> int -> pretty -> unit;
-value quiet : ref bool;
-
-value dt : ref int;
-
-(*--*)
-
-value tol : ref int;
-value sp : ref char;
diff --git a/camlp4/compile/.cvsignore b/camlp4/compile/.cvsignore
deleted file mode 100644
index 47817ccef6..0000000000
--- a/camlp4/compile/.cvsignore
+++ /dev/null
@@ -1,4 +0,0 @@
-*.fast
-*.fast.opt
-o_fast.ml
-pa_o_fast.ml
diff --git a/camlp4/compile/.depend b/camlp4/compile/.depend
deleted file mode 100644
index 5031b171af..0000000000
--- a/camlp4/compile/.depend
+++ /dev/null
@@ -1,4 +0,0 @@
-compile.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-compile.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-comp_trail.cmo: ../camlp4/pcaml.cmi
-comp_trail.cmx: ../camlp4/pcaml.cmx
diff --git a/camlp4/compile/Makefile b/camlp4/compile/Makefile
deleted file mode 100644
index 277652b1c9..0000000000
--- a/camlp4/compile/Makefile
+++ /dev/null
@@ -1,45 +0,0 @@
-# $Id$
-
-include ../config/Makefile
-
-INCLUDES=-I ../camlp4 -I ../boot
-OCAMLCFLAGS=-warn-error A $(INCLUDES)
-SRC=../etc/pa_o.ml ../etc/pa_op.ml
-D=o
-COMP_OPT=-strict_parsing
-COMP_OPT=-e "Grammar.Entry.obj Pcaml.interf" -e "Grammar.Entry.obj Pcaml.implem" -e "Grammar.Entry.obj Pcaml.top_phrase" -e "Grammar.Entry.obj Pcaml.use_file"
-
-all: out
-
-out: camlp4$D.fast
-opt: camlp4$D.fast.opt
-
-camlp4$D.fast: pa_$D_fast.cmo
- rm -f camlp4$D.fast
- cd ../camlp4; $(MAKE) CAMLP4=../compile/camlp4$D.fast CAMLP4M="../compile/pa_$D_fast.cmo ../meta/pr_dump.cmo"
-
-camlp4$D.fast.opt: pa_$D_fast.cmx
- rm -f camlp4$D.fast.opt
- cd ../camlp4; $(MAKE) optp4 CAMLP4OPT=../compile/camlp4$D.fast.opt CAMLP4M="../compile/pa_$D_fast.cmx ../meta/pr_dump.cmx"
-
-pa_$D_fast.ml: comp_head.ml $D_fast.ml comp_trail.ml
- cat $(SRC) | sed -e "s/Plexer.gmake ()/P.lexer/" -e "/EXTEND/,/END/d" -e "/Grammar.Entry.of_parser/d" -e "/Grammar.Entry.gcreate/d" | cat comp_head.ml - $D_fast.ml comp_trail.ml > pa_$D_fast.ml
-
-$D_fast.ml: compile.cmo $(SRC)
- OTOP=$(OTOP) EXE=$(EXE) ./compile.sh $(COMP_OPT) $(SRC) > $D_fast.ml
-
-install:
- if test -f camlp4o.fast.opt; then cp camlp4o.fast.opt $(BINDIR)/camlp4o.opt$(EXE); fi
-
-clean::
- rm -f *.cm* *.pp[io] *.o *.bak .*.bak *.out *.opt
- rm -f *.fast tmp.* pa_*_fast.ml *_fast.ml
-
-depend:
- cp .depend .depend.bak
- > .depend
- @for i in *.mli *.ml; do \
- ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i >> .depend || : ; \
- done
-
-include .depend
diff --git a/camlp4/compile/comp_head.ml b/camlp4/compile/comp_head.ml
deleted file mode 100644
index 5efa064073..0000000000
--- a/camlp4/compile/comp_head.ml
+++ /dev/null
@@ -1,70 +0,0 @@
-(* camlp4r q_MLast.cmo pa_extend.cmo *)
-(* $Id$ *)
-
-module P =
- struct
- value gloc bp strm = Grammar.loc_of_token_interval bp (Stream.count strm);
- value list0 symb =
- let rec loop al =
- parser
- [ [: a = symb; s :] -> loop [a :: al] s
- | [: :] -> al ]
- in
- parser [: a = loop [] :] -> List.rev a
- ;
- value list0sep symb sep =
- let rec kont al =
- parser
- [ [: v = sep; a = symb; s :] -> kont [a :: al] s
- | [: :] -> al ]
- in
- parser
- [ [: a = symb; s :] -> List.rev (kont [a] s)
- | [: :] -> [] ]
- ;
- value list1 symb =
- let rec loop al =
- parser
- [ [: a = symb; s :] -> loop [a :: al] s
- | [: :] -> al ]
- in
- parser [: a = symb; s :] -> List.rev (loop [a] s)
- ;
- value list1sep symb sep =
- let rec kont al =
- parser
- [ [: v = sep; a = symb; s :] -> kont [a :: al] s
- | [: :] -> al ]
- in
- parser [: a = symb; s :] -> List.rev (kont [a] s)
- ;
- value option f =
- parser
- [ [: x = f :] -> Some x
- | [: :] -> None ]
- ;
- value token (p_con, p_prm) =
- if p_prm = "" then parser [: `(con, prm) when con = p_con :] -> prm
- else parser [: `(con, prm) when con = p_con && prm = p_prm :] -> prm
- ;
- value orzero f f0 =
- parser bp
- [ [: x = f :] -> x
- | [: x = f0 :] ep ->
-(*
-let (loc1, loc2) = Grammar.loc_of_token_interval bp ep in
-let _ = do { Printf.eprintf "recovered or_zero at loc (%d, %d)\n" loc1 loc2; flush stderr } in
-*)
- x ]
- ;
- value error entry prev_symb symb =
- symb ^ " expected" ^
- (if prev_symb = "" then "" else " after " ^ prev_symb) ^
- " (in [" ^ entry ^ "])"
- ;
- value lexer = Plexer.gmake ();
- end
-;
-
-(****************************************)
-
diff --git a/camlp4/compile/comp_trail.ml b/camlp4/compile/comp_trail.ml
deleted file mode 100644
index 75f40abbf4..0000000000
--- a/camlp4/compile/comp_trail.ml
+++ /dev/null
@@ -1,33 +0,0 @@
-(* camlp4r pa_extend.cmo *)
-(****************************************)
-
-value interf_p =
- Grammar.Entry.of_parser Pcaml.gram "interf" interf_0
-;
-
-value implem_p =
- Grammar.Entry.of_parser Pcaml.gram "implem" implem_0
-;
-
-value top_phrase_p =
- Grammar.Entry.of_parser Pcaml.gram "top_phrase" top_phrase_0
-;
-
-value use_file_p =
- Grammar.Entry.of_parser Pcaml.gram "use_file" use_file_0
-;
-
-EXTEND
- interf:
- [ [ x = interf_p -> x ] ]
- ;
- implem:
- [ [ x = implem_p -> x ] ]
- ;
- top_phrase:
- [ [ x = top_phrase_p -> x ] ]
- ;
- use_file:
- [ [ x = use_file_p -> x ] ]
- ;
-END;
diff --git a/camlp4/compile/compile.ml b/camlp4/compile/compile.ml
deleted file mode 100644
index 5fff04b27d..0000000000
--- a/camlp4/compile/compile.ml
+++ /dev/null
@@ -1,571 +0,0 @@
-(* camlp4r *)
-(* $Id$ *)
-
-#load "q_MLast.cmo";
-
-open Gramext;
-
-value strict_parsing = ref False;
-value keywords = ref [];
-
-value loc = (0, 0);
-
-(* Watch the segmentation faults here! the compiled file must have been
- loaded in camlp4 with the option pa_extend.cmo -meta_action. *)
-value magic_act (act : Obj.t) : MLast.expr = Obj.magic act;
-
-(* Names of symbols for error messages; code borrowed to grammar.ml *)
-
-value rec name_of_symbol entry =
- fun
- [ Snterm e -> "[" ^ e.ename ^ "]"
- | Snterml e l -> "[" ^ e.ename ^ " level " ^ l ^ "]"
- | Sself | Snext -> "[" ^ entry.ename ^ "]"
- | Stoken tok -> entry.egram.glexer.Token.tok_text tok
- | _ -> "???" ]
-;
-
-value rec name_of_symbol_failed entry =
- fun
- [ Slist0 s -> name_of_symbol_failed entry s
- | Slist0sep s _ -> name_of_symbol_failed entry s
- | Slist1 s -> name_of_symbol_failed entry s
- | Slist1sep s _ -> name_of_symbol_failed entry s
- | Sopt s -> name_of_symbol_failed entry s
- | Stree t -> name_of_tree_failed entry t
- | s -> name_of_symbol entry s ]
-and name_of_tree_failed entry =
- fun
- [ Node {node = s; brother = bro; son = son} ->
- let txt = name_of_symbol_failed entry s in
- let txt =
- match (s, son) with
- [ (Sopt _, Node _) -> txt ^ " or " ^ name_of_tree_failed entry son
- | _ -> txt ]
- in
- let txt =
- match bro with
- [ DeadEnd | LocAct _ _ -> txt
- | _ -> txt ^ " or " ^ name_of_tree_failed entry bro ]
- in
- txt
- | DeadEnd | LocAct _ _ -> "???" ]
-;
-
-value tree_failed entry prev_symb tree =
- let (s2, s3) =
- let txt = name_of_tree_failed entry tree in
- match prev_symb with
- [ Slist0 s ->
- let txt1 = name_of_symbol_failed entry s in
- ("", txt1 ^ " or " ^ txt)
- | Slist1 s ->
- let txt1 = name_of_symbol_failed entry s in
- ("", txt1 ^ " or " ^ txt)
- | Slist0sep s sep ->
- let txt1 = name_of_symbol_failed entry s in
- ("", txt1 ^ " or " ^ txt)
- | Slist1sep s sep ->
- let txt1 = name_of_symbol_failed entry s in
- ("", txt1 ^ " or " ^ txt)
- | Sopt _ | Stree _ -> ("", txt)
- | _ -> (name_of_symbol entry prev_symb, txt) ]
- in
- <:expr<
- P.error $str:entry.ename$ $str:String.escaped s2$ $str:String.escaped s3$
- >>
-;
-
-(* Compilation *)
-
-value rec find_act =
- fun
- [ DeadEnd -> failwith "find_act"
- | LocAct act _ -> (magic_act act, 0)
- | Node {son = son; brother = bro} ->
- let (act, n) = try find_act son with [ Failure _ -> find_act bro ] in
- (act, n + 1) ]
-;
-
-value level_number e l =
- match e.edesc with
- [ Dlevels elevs ->
- loop 0 elevs where rec loop n =
- fun
- [ [lev :: levs] -> if lev.lname = Some l then n else loop (n + 1) levs
- | [] -> failwith ("level " ^ l ^ " not found in entry " ^ e.ename) ]
- | Dparser _ -> 0 ]
-;
-
-value nth_patt_of_act (e, n) =
- let patt_list =
- loop e where rec loop =
- fun
- [ <:expr< fun (loc : (int * int)) -> $_$ >> -> []
- | <:expr< fun ($p$ : $_$) -> $e$ >> -> [p :: loop e]
- | <:expr< fun $p$ -> $e$ >> -> [p :: loop e]
- | _ -> failwith "nth_patt_of_act" ]
- in
- List.nth patt_list n
-;
-
-value rec last_patt_of_act =
- fun
- [ <:expr< fun ($p$ : $_$) (loc : (int * int)) -> $_$ >> -> p
- | <:expr< fun $_$ -> $e$ >> -> last_patt_of_act e
- | _ -> failwith "last_patt_of_act" ]
-;
-
-value rec final_action =
- fun
- [ <:expr< fun (loc : (int * int)) -> ($e$ : $_$) >> -> e
- | <:expr< fun $_$ -> $e$ >> -> final_action e
- | _ -> failwith "final_action" ]
-;
-
-value parse_standard_symbol e rkont fkont ending_act =
- <:expr<
- match try Some ($e$ strm__) with [ Stream.Failure -> None ] with
- [ Some $nth_patt_of_act ending_act$ -> $rkont$
- | _ -> $fkont$ ]
- >>
-;
-
-value parse_symbol_no_failure e rkont fkont ending_act =
- <:expr<
- let $nth_patt_of_act ending_act$ =
- try $e$ strm__ with [ Stream.Failure -> raise (Stream.Error "") ]
- in
- $rkont$
- >>
-;
-
-value rec contain_loc =
- fun
- [ <:expr< $lid:s$ >> -> s = "loc"
- | <:expr< $uid:_$ >> -> False
- | <:expr< $str:_$ >> -> False
- | <:expr< ($list:el$) >> -> List.exists contain_loc el
- | <:expr< $e1$ $e2$ >> -> contain_loc e1 || contain_loc e2
- | _ -> True ]
-;
-
-value gen_let_loc loc e =
- if contain_loc e then <:expr< let loc = P.gloc bp strm__ in $e$ >> else e
-;
-
-value phony_entry = Grammar.Entry.obj Pcaml.implem;
-
-value rec parse_tree entry nlevn alevn (tree, fst_symb) act_kont kont =
- match tree with
- [ DeadEnd -> kont
- | LocAct act _ ->
- let act = magic_act act in
- act_kont False act
- | Node {node = Sself; son = LocAct act _; brother = bro} ->
- let act = magic_act act in
- let n = entry.ename ^ "_" ^ string_of_int alevn in
- let e =
- if strict_parsing.val || alevn = 0 || fst_symb then <:expr< $lid:n$ >>
- else <:expr< P.orzero $lid:n$ $lid:entry.ename ^ "_0"$ >>
- in
- let p2 =
- match bro with
- [ DeadEnd -> kont
- | _ -> parse_tree entry nlevn alevn (bro, fst_symb) act_kont kont ]
- in
- let p1 = act_kont True act in
- parse_standard_symbol e p1 p2 (act, 0)
- | Node {node = s; son = LocAct act _; brother = bro} ->
- let act = magic_act act in
- let p2 = parse_tree entry nlevn alevn (bro, fst_symb) act_kont kont in
- let p1 = act_kont False act in
- parse_symbol entry nlevn s p1 p2 (act, 0)
- | Node {node = s; son = son; brother = bro} ->
- let p2 = parse_tree entry nlevn alevn (bro, fst_symb) act_kont kont in
- let p1 =
- let err =
- let txt = tree_failed entry s son in
- <:expr< raise (Stream.Error $txt$) >>
- in
- match son with
- [ Node {brother = DeadEnd} ->
- parse_tree entry nlevn alevn (son, False) act_kont err
- | _ ->
- let p1 =
- parse_tree entry nlevn alevn (son, True) act_kont
- <:expr< raise Stream.Failure >>
- in
- <:expr< try $p1$ with [ Stream.Failure -> $err$ ] >> ]
- in
- parse_symbol entry nlevn s p1 p2 (find_act son) ]
-and parse_symbol entry nlevn s rkont fkont ending_act =
- match s with
- [ Slist0 s ->
- let e = <:expr< P.list0 $symbol_parser entry nlevn s$ >> in
- parse_symbol_no_failure e rkont fkont ending_act
- | Slist1 s ->
- let e = <:expr< P.list1 $symbol_parser entry nlevn s$ >> in
- parse_standard_symbol e rkont fkont ending_act
- | Slist0sep s sep ->
- let e =
- <:expr<
- P.list0sep $symbol_parser entry nlevn s$
- $symbol_parser entry nlevn sep$ >>
- in
- parse_symbol_no_failure e rkont fkont ending_act
- | Slist1sep s sep ->
- let e =
- <:expr<
- P.list1sep $symbol_parser entry nlevn s$
- $symbol_parser entry nlevn sep$ >>
- in
- parse_standard_symbol e rkont fkont ending_act
- | Sopt s ->
- let e = <:expr< P.option $symbol_parser entry nlevn s$ >> in
- parse_symbol_no_failure e rkont fkont ending_act
- | Stree tree ->
- let kont = <:expr< raise Stream.Failure >> in
- let act_kont _ act = gen_let_loc loc (final_action act) in
- let e = parse_tree phony_entry 0 0 (tree, True) act_kont kont in
- parse_standard_symbol <:expr< fun strm__ -> $e$ >> rkont fkont ending_act
- | Snterm e ->
- let n =
- match e.edesc with
- [ Dparser _ -> e.ename
- | Dlevels _ -> e.ename ^ "_0" ]
- in
- parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act
- | Snterml e l ->
- let n = e.ename ^ "_" ^ string_of_int (level_number e l) in
- parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act
- | Sself ->
- let n = entry.ename ^ "_0" in
- parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act
- | Snext ->
- let n = entry.ename ^ "_" ^ string_of_int nlevn in
- parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act
- | Stoken tok ->
- let _ =
- do {
- if fst tok = "" && not (List.mem (snd tok) keywords.val) then
- keywords.val := [snd tok :: keywords.val]
- else ()
- }
- in
- let p =
- let patt = nth_patt_of_act ending_act in
- let p_con = String.escaped (fst tok) in
- let p_prm = String.escaped (snd tok) in
- if snd tok = "" then
- if fst tok = "ANY" then <:patt< (_, $patt$) >>
- else <:patt< ($str:p_con$, $patt$) >>
- else
- let p = <:patt< ($str:p_con$, $str:p_prm$) >> in
- match patt with
- [ <:patt< _ >> -> <:patt< ($str:p_con$, $str:p_prm$) >>
- | _ -> <:patt< ($str:p_con$, ($str:p_prm$ as $patt$)) >> ]
- in
- <:expr<
- match Stream.peek strm__ with
- [ Some $p$ -> do { Stream.junk strm__; $rkont$ }
- | _ -> $fkont$ ]
- >>
- | _ ->
- parse_standard_symbol <:expr< not_impl >> rkont fkont ending_act ]
-and symbol_parser entry nlevn =
- fun
- [ Snterm e ->
- let n = e.ename ^ "_0" in
- <:expr< $lid:n$ >>
- | Snterml e l ->
- let n = e.ename ^ "_" ^ string_of_int (level_number e l) in
- <:expr< $lid:n$ >>
- | Snext ->
- let n = entry.ename ^ "_" ^ string_of_int nlevn in
- if strict_parsing.val then <:expr< $lid:n$ >>
- else
- let n0 = entry.ename ^ "_0" in
- <:expr< P.orzero $lid:n$ $lid:n0$ >>
- | Stoken tok ->
- let _ =
- do {
- if fst tok = "" && not (List.mem (snd tok) keywords.val) then
- keywords.val := [snd tok :: keywords.val]
- else ()
- }
- in
- let p_con = String.escaped (fst tok) in
- let p_prm = String.escaped (snd tok) in
- <:expr< P.token ($str:p_con$, $str:p_prm$) >>
- | Stree tree ->
- let kont = <:expr< raise Stream.Failure >> in
- let act_kont _ act = final_action act in
- <:expr<
- fun strm__ ->
- $parse_tree phony_entry 0 0 (tree, True) act_kont kont$
- >>
- | _ ->
- <:expr< aaa >> ]
-;
-
-value rec start_parser_of_levels entry clevn levs =
- let n = entry.ename ^ "_" ^ string_of_int clevn in
- let next = entry.ename ^ "_" ^ string_of_int (clevn + 1) in
- let p = <:patt< $lid:n$ >> in
- match levs with
- [ [] -> [Some (p, <:expr< fun strm__ -> raise Stream.Failure >>)]
- | [lev :: levs] ->
- let pel = start_parser_of_levels entry (succ clevn) levs in
- match lev.lprefix with
- [ DeadEnd ->
- let ncont =
- if not strict_parsing.val && clevn = 0 then
- entry.ename ^ "_gen_cont"
- else entry.ename ^ "_" ^ string_of_int clevn ^ "_cont"
- in
- let curr =
- <:expr< let a = $lid:next$ strm__ in $lid:ncont$ bp a strm__ >>
- in
- let curr = <:expr< let bp = Stream.count strm__ in $curr$ >> in
- let e = <:expr< fun strm__ -> $curr$ >> in
- let pel = if levs = [] then [] else pel in
- [Some (p, e) :: pel]
- | tree ->
- let alevn = clevn in
- let (kont, pel) =
- match levs with
- [ [] -> (<:expr< raise Stream.Failure >>, [])
- | _ ->
- let e =
- match (lev.assoc, lev.lsuffix) with
- [ (NonA, _) | (_, DeadEnd) -> <:expr< $lid:next$ strm__ >>
- | _ ->
- let ncont =
- entry.ename ^ "_" ^ string_of_int clevn ^ "_cont"
- in
- <:expr<
- let a = $lid:next$ strm__ in
- $lid:ncont$ bp a strm__
- >> ]
- in
- (e, pel) ]
- in
- let act_kont end_with_self act =
- if lev.lsuffix = DeadEnd then gen_let_loc loc (final_action act)
- else
- let ncont = entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" in
- gen_let_loc loc
- <:expr< $lid:ncont$ bp $final_action act$ strm__ >>
- in
- let curr =
- parse_tree entry (succ clevn) alevn (tree, True) act_kont kont
- in
- let curr = <:expr< let bp = Stream.count strm__ in $curr$ >> in
- let e = <:expr< fun strm__ -> $curr$ >> in
- [Some (p, e) :: pel] ] ]
-;
-
-value rec continue_parser_of_levels entry clevn levs =
- let n = entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" in
- let p = <:patt< $lid:n$ >> in
- match levs with
- [ [] -> [None]
- | [lev :: levs] ->
- let pel = continue_parser_of_levels entry (succ clevn) levs in
- match lev.lsuffix with
- [ DeadEnd ->
- [None :: pel]
- | tree ->
- let alevn =
- match lev.assoc with
- [ LeftA | NonA -> succ clevn
- | RightA -> clevn ]
- in
- let (kont, pel) =
- match levs with
- [ [] -> (<:expr< a__ >>, [])
- | _ -> (<:expr< a__ >>, pel) ]
- in
- let act_kont end_with_self act =
- let p = last_patt_of_act act in
- match lev.assoc with
- [ RightA | NonA ->
- <:expr<
- let $p$ = a__ in
- $gen_let_loc loc (final_action act)$
- >>
- | LeftA ->
- let ncont =
- entry.ename ^ "_" ^ string_of_int clevn ^ "_cont"
- in
- gen_let_loc loc
- <:expr<
- let $p$ = a__ in
- $lid:ncont$ bp $final_action act$ strm__
- >> ]
- in
- let curr =
- parse_tree entry (succ clevn) alevn (tree, True) act_kont kont
- in
- let e = <:expr< fun bp a__ strm__ -> $curr$ >> in
- [Some (p, e) :: pel] ] ]
-;
-
-value continue_parser_of_levels_again entry levs =
- let n = entry.ename ^ "_gen_cont" in
- let e =
- loop <:expr< a__ >> 0 levs where rec loop var levn =
- fun
- [ [] -> <:expr< if x == a__ then x else $lid:n$ bp x strm__ >>
- | [lev :: levs] ->
- match lev.lsuffix with
- [ DeadEnd -> loop var (levn + 1) levs
- | _ ->
- let n = entry.ename ^ "_" ^ string_of_int levn ^ "_cont" in
- let rest = loop <:expr< x >> (levn + 1) levs in
- <:expr< let x = $lid:n$ bp $var$ strm__ in $rest$ >> ] ]
- in
- (<:patt< $lid:n$ >>, <:expr< fun bp a__ strm__ -> $e$ >>)
-;
-
-value empty_entry ename =
- let p = <:patt< $lid:ename$ >> in
- let e =
- <:expr<
- fun strm__ ->
- raise (Stream.Error $str:"entry [" ^ ename ^ "] is empty"$) >>
- in
- [Some (p, e)]
-;
-
-value start_parser_of_entry entry =
- match entry.edesc with
- [ Dlevels [] -> empty_entry entry.ename
- | Dlevels elev -> start_parser_of_levels entry 0 elev
- | Dparser p -> [] ]
-;
-
-value continue_parser_of_entry entry =
- match entry.edesc with
- [ Dlevels elev -> continue_parser_of_levels entry 0 elev
- | Dparser p -> [] ]
-;
-
-value continue_parser_of_entry_again entry =
- if strict_parsing.val then []
- else
- match entry.edesc with
- [ Dlevels ([_; _ :: _] as levs) ->
- [continue_parser_of_levels_again entry levs]
- | _ -> [] ]
-;
-
-value rec list_alternate l1 l2 =
- match (l1, l2) with
- [ ([x1 :: l1], [x2 :: l2]) -> [x1; x2 :: list_alternate l1 l2]
- | ([], l2) -> l2
- | (l1, []) -> l1 ]
-;
-
-value compile_entry entry =
- let pel1 = start_parser_of_entry entry in
- let pel2 = continue_parser_of_entry entry in
- let pel = list_alternate pel1 pel2 in
- List.fold_right
- (fun pe list ->
- match pe with
- [ Some pe -> [pe :: list]
- | None -> list ])
- pel (continue_parser_of_entry_again entry)
-;
-
-(* get all entries connected together *)
-
-value rec scan_tree list =
- fun
- [ Node {node = n; son = son; brother = bro} ->
- let list = scan_symbol list n in
- let list = scan_tree list son in
- let list = scan_tree list bro in
- list
- | LocAct _ _ | DeadEnd -> list ]
-and scan_symbol list =
- fun
- [ Snterm e -> scan_entry list e
- | Snterml e l -> scan_entry list e
- | Slist0 s -> scan_symbol list s
- | Slist0sep s sep -> scan_symbol (scan_symbol list s) sep
- | Slist1 s -> scan_symbol list s
- | Slist1sep s sep -> scan_symbol (scan_symbol list s) sep
- | Sopt s -> scan_symbol list s
- | Stree t -> scan_tree list t
- | Smeta _ _ _ | Sself | Snext | Stoken _ -> list ]
-and scan_level list lev =
- let list = scan_tree list lev.lsuffix in
- let list = scan_tree list lev.lprefix in
- list
-and scan_levels list levs = List.fold_left scan_level list levs
-and scan_entry list entry =
- if List.memq entry list then list
- else
- match entry.edesc with
- [ Dlevels levs -> scan_levels [entry :: list] levs
- | Dparser _ -> list ]
-;
-
-value all_entries_in_graph list entry =
- List.rev (scan_entry list entry)
-;
-
-(* main *)
-
-value entries = ref [];
-
-value rec list_mem_right_assoc x =
- fun
- [ [] -> False
- | [(a, b) :: l] -> x = b || list_mem_right_assoc x l ]
-;
-
-value rec expr_list =
- fun
- [ [] -> <:expr< [] >>
- | [x :: l] -> <:expr< [$str:String.escaped x$ :: $expr_list l$] >> ]
-;
-
-value compile () =
- let _ = do { keywords.val := []; } in
- let list = List.fold_left all_entries_in_graph [] entries.val in
- let list =
- List.filter (fun e -> List.memq e list) entries.val @
- List.filter (fun e -> not (List.memq e entries.val)) list
- in
- let list =
- let set = ref [] in
- List.fold_right
- (fun entry list ->
- if List.mem entry.ename set.val then
- list
- else do { set.val := [entry.ename :: set.val]; [entry :: list] })
- list []
- in
- let pell = List.map compile_entry list in
- let pel = List.flatten pell in
- let si1 = <:str_item< value rec $list:pel$ >> in
- let si2 =
- let list = List.sort compare keywords.val in
- <:str_item<
- List.iter (fun kw -> P.lexer.Token.tok_using ("", kw))
- $expr_list list$
- >>
- in
- let loc = (1, 1) in
- ([(si1, loc); (si2, loc)], False)
-;
-
-Pcaml.parse_implem.val := fun _ -> compile ();
-
-Pcaml.add_option "-strict_parsing" (Arg.Set strict_parsing)
- "Don't generate error recovering by trying continuations or first levels"
-;
diff --git a/camlp4/compile/compile.sh b/camlp4/compile/compile.sh
deleted file mode 100755
index 1e86d6f7eb..0000000000
--- a/camlp4/compile/compile.sh
+++ /dev/null
@@ -1,27 +0,0 @@
-#!/bin/sh -e
-
-ARGS=
-FILES=
-ENTRIES=
-while test "" != "$1"; do
- case $1 in
- -e)
- shift;
- if test "$ENTRIES" != ""; then ENTRIES="$ENTRIES; "; fi
- ENTRIES="$ENTRIES$1";;
- *.ml*) FILES="$FILES $1";;
- *) ARGS="$ARGS $1";;
- esac
- shift
-done
-
-cat $FILES | sed -e 's/Pcaml.parse_i.*$//' > tmp.ml
-echo "Compile.entries.val := [$ENTRIES];" >> tmp.ml
-> tmp.mli
-$OTOP/boot/ocamlrun$EXE $OTOP/boot/ocamlc -I $OTOP/boot -c tmp.mli
-$OTOP/boot/ocamlrun$EXE ../meta/camlp4r$EXE -I ../meta pa_extend.cmo q_MLast.cmo -meta_action tmp.ml -o tmp.ppo
-$OTOP/boot/ocamlrun$EXE $OTOP/boot/ocamlc -I $OTOP/boot -I ../lib -I ../camlp4 -c -impl tmp.ppo
-rm tmp.ppo
-> tmp.null
-$OTOP/boot/ocamlrun$EXE ../camlp4/camlp4$EXE ./compile.cmo ./tmp.cmo ../etc/pr_r.cmo ../etc/pr_rp.cmo $ARGS -sep "\n\n" -impl tmp.null
-rm tmp.*
diff --git a/camlp4/config/.cvsignore b/camlp4/config/.cvsignore
deleted file mode 100644
index f9761cda36..0000000000
--- a/camlp4/config/.cvsignore
+++ /dev/null
@@ -1,2 +0,0 @@
-Makefile.cnf
-Makefile
diff --git a/camlp4/config/Makefile-nt.cnf b/camlp4/config/Makefile-nt.cnf
deleted file mode 100644
index 379f338507..0000000000
--- a/camlp4/config/Makefile-nt.cnf
+++ /dev/null
@@ -1,7 +0,0 @@
-EXE=.exe
-OPT=
-OTOP=../..
-OLIBDIR=$(OTOP)/boot
-BINDIR=C:/ocaml/bin
-LIBDIR=C:/ocaml/lib
-MANDIR=C:/ocaml/man
diff --git a/camlp4/config/Makefile.tpl b/camlp4/config/Makefile.tpl
deleted file mode 100644
index 0602525a62..0000000000
--- a/camlp4/config/Makefile.tpl
+++ /dev/null
@@ -1,28 +0,0 @@
-# $Id$
-
-CAMLP4_COMM=OTOP=$(OTOP) OPT=$(OPT) EXE=$(EXE) ../tools/camlp4_comm.sh
-OCAMLC=@OTOP=$(OTOP) OPT=$(OPT) EXE=$(EXE) ../tools/ocamlc.sh
-OCAMLOPT=@OTOP=$(OTOP) OPT=$(OPT) EXE=$(EXE) ../tools/ocamlopt.sh
-OCAMLCFLAGS=
-MKDIR=mkdir -p
-
-.SUFFIXES: .cmx .cmo .cmi .ml .mli
-
-.mli.cmi:
- @if test `basename $<` != $<; then echo "Bad directory"; exit 1; fi
- @$(CAMLP4_COMM) $< -o $*.ppi
- $(OCAMLC) $(OCAMLCFLAGS) -c -intf $*.ppi
- rm -f $*.ppi
-
-.ml.cmo:
- @if test `basename $<` != $<; then echo "Bad directory"; exit 1; fi
- @$(CAMLP4_COMM) $< -o $*.ppo
- $(OCAMLC) $(OCAMLCFLAGS) -c -impl $*.ppo
- rm -f $*.ppo
-
-.ml.cmx:
- @if test `basename $<` != $<; then echo "Bad directory"; exit 1; fi
- @$(CAMLP4_COMM) $< -o $*.ppo
- $(OCAMLOPT) $(OCAMLCFLAGS) -c -impl $*.ppo
- rm -f $*.ppo
-
diff --git a/camlp4/config/config.mpw b/camlp4/config/config.mpw
deleted file mode 100644
index 08fe278d4c..0000000000
--- a/camlp4/config/config.mpw
+++ /dev/null
@@ -1,50 +0,0 @@
-#######################################################################
-# #
-# Camlp4 #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. Distributed only by permission. #
-# #
-#######################################################################
-
-# $Id$
-
-set -e P4LIBDIR "{LIBDIR}camlp4:"
-set -e MANDIR "{mpw}"
-set -e OTOP "`directory `:"
-set -e OLIBDIR "{OTOP}boot:"
-
-set -e CAMLP4_COMM ::tools:camlp4_comm.mpw
-set -e OCAMLC ::tools:ocamlc.mpw
-
-set -e defrules "¶n¶
-.cmi Ä .mli ¶n¶
- ¶{CAMLP4_COMM¶} ¶{depdir¶}¶{default¶}.mli -o ¶{depdir¶}¶{default¶}.ppi ¶n¶
- ¶{OCAMLC¶} ¶{OCAMLCFLAGS¶} -c -intf ¶{depdir¶}¶{default¶}.ppi ¶n¶
- delete -y -i ¶{depdir¶}¶{default¶}.ppi ¶n¶
-¶n¶
-.cmo Ä .ml ¶n¶
- ¶{CAMLP4_COMM¶} ¶{depdir¶}¶{default¶}.ml -o ¶{depdir¶}¶{default¶}.ppo ¶n¶
- ¶{OCAMLC¶} ¶{OCAMLCFLAGS¶} -c -impl ¶{depdir¶}¶{default¶}.ppo ¶n¶
- delete -y -i ¶{depdir¶}¶{default¶}.ppo ¶n¶
-¶n¶
-.cmi Ä .cmo ¶n¶
- set status 0 ¶n¶
-¶n¶
-clean ÄÄ ¶n¶
- begin ¶n¶
- delete -i Å.cm[ioa] || set status 0 ¶n¶
- delete -i Å.pp[io] || set status 0 ¶n¶
- delete -i Å.bak || set status 0 ¶n¶
- end ³ dev:null ¶n¶
-"
-
-set -e dependrule "¶n¶
-depend Ķn¶
- duplicate -y Makefile.Mac.depend Makefile.Mac.depend.bak || set status 0¶n¶
- for i in Å.mliÇ0,1ȶn¶
- ::tools:apply.mpw pr_depend.cmo -- ¶{INCLUDES¶} ¶{i¶}¶n¶
- end > Makefile.Mac.depend¶n¶
-"
diff --git a/camlp4/config/configure_batch b/camlp4/config/configure_batch
deleted file mode 100755
index 49b3dafca5..0000000000
--- a/camlp4/config/configure_batch
+++ /dev/null
@@ -1,113 +0,0 @@
-#! /bin/sh
-# $Id$
-
-prefix=/usr/local
-bindir=''
-libdir=''
-mandir=''
-ocaml_top=../ocaml_stuff
-
-# Parse command-line arguments
-
-while : ; do
- case "$1" in
- "") break;;
- -prefix|--prefix)
- prefix=$2; shift;;
- -bindir|--bindir)
- bindir=$2; shift;;
- -libdir|--libdir)
- libdir=$2; shift;;
- -mandir|--mandir)
- mandir=$2; shift;;
- -ocaml-top)
- ocaml_top=$2; shift;;
- *) echo "Unknown option \"$1\"." 1>&2; exit 2;;
- esac
- shift
-done
-
-# Sanity checks
-
-case "$prefix" in
- /*) ;;
- *) echo "The -prefix directory must be absolute." 1>&2; exit 2;;
-esac
-case "$bindir" in
- /*) ;;
- "") ;;
- *) echo "The -bindir directory must be absolute." 1>&2; exit 2;;
-esac
-case "$libdir" in
- /*) ;;
- "") ;;
- *) echo "The -libdir directory must be absolute." 1>&2; exit 2;;
-esac
-case "$mandir" in
- /*) ;;
- "") ;;
- *) echo "The -mandir directory must be absolute." 1>&2; exit 2;;
-esac
-
-# Generate the files
-
-rm -f Makefile.cnf
-touch Makefile.cnf
-
-# Check Ocaml
-
-for i in utils parsing otherlibs/dynlink; do
- if test ! -d "$ocaml_top/$i"; then
- echo "Bad value $ocaml_top for option -ocaml-top"
- echo "There is no directory $ocaml_top/$i"
- echo "Configuration script failed"
- exit 1
- fi
-done
-
-echo "EXE=$EXE" >> Makefile.cnf
-echo "O=o" >> Makefile.cnf
-echo "A=a" >> Makefile.cnf
-echo "OPT=" >> Makefile.cnf
-echo "OTOP=$ocaml_top" >> Makefile.cnf
-
-if test "$ocaml_top" = "../ocaml_stuff"; then
- if ocamlc -v >/dev/null 2>&1; then
- :
- else
- echo "You need the command ocamlc accessible in the path!"
- echo "Configuration script failed!"
- exit 1
- fi
- OLIBDIR=`ocamlc -where`
- echo "OLIBDIR=$OLIBDIR" >> Makefile.cnf
-else
- echo "OLIBDIR=\$(OTOP)/boot" >> Makefile.cnf
-fi
-
-# Where to install
-
-echo "PREFIX=$prefix" >> Makefile.cnf
-case "$bindir" in
- "") echo 'BINDIR=$(PREFIX)/bin' >> Makefile.cnf
- bindir="$prefix/bin";;
- *) echo "BINDIR=$bindir" >> Makefile.cnf;;
-esac
-case "$libdir" in
- "") echo 'LIBDIR=$(PREFIX)/lib/camlp4' >> Makefile.cnf
- libdir="$prefix/lib/camlp4";;
- *) echo "LIBDIR=$libdir" >> Makefile.cnf;;
-esac
-case "$mandir" in
- "") echo 'MANDIR=$(PREFIX)/man/man1' >> Makefile.cnf
- mandir="$prefix/man/man1";;
- *) echo "MANDIR=$mandir" >> Makefile.cnf;;
-esac
-
-rm -f Makefile
-cat Makefile.tpl > Makefile
-cat Makefile.cnf >> Makefile
-
-echo "Resulting configuration file (Makefile.cnf):"
-echo
-cat Makefile.cnf
diff --git a/camlp4/etc/.cvsignore b/camlp4/etc/.cvsignore
deleted file mode 100644
index 92c764cac9..0000000000
--- a/camlp4/etc/.cvsignore
+++ /dev/null
@@ -1,6 +0,0 @@
-*.cm[oia]
-camlp4o
-camlp4sch
-camlp4o.opt
-mkcamlp4.sh
-mkcamlp4.mpw
diff --git a/camlp4/etc/.depend b/camlp4/etc/.depend
deleted file mode 100644
index 8191673978..0000000000
--- a/camlp4/etc/.depend
+++ /dev/null
@@ -1,73 +0,0 @@
-parserify.cmi: ../camlp4/mLast.cmi
-pa_extfold.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_extfold.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pa_extfun.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_extfun.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pa_format.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_format.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pa_fstream.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_fstream.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pa_ifdef.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_ifdef.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pa_lefteval.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_lefteval.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pa_lisp.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_lisp.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pa_lispr.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_lispr.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pa_ocamllex.cmo: $(OTOP)/lex/compact.cmi $(OTOP)/lex/cset.cmi \
- $(OTOP)/lex/lexgen.cmi ../camlp4/mLast.cmi ../camlp4/pcaml.cmi \
- $(OTOP)/lex/syntax.cmi
-pa_ocamllex.cmx: $(OTOP)/lex/compact.cmx $(OTOP)/lex/cset.cmx \
- $(OTOP)/lex/lexgen.cmx ../camlp4/mLast.cmi ../camlp4/pcaml.cmx \
- $(OTOP)/lex/syntax.cmx
-pa_olabl.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_olabl.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pa_o.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_o.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pa_oop.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_oop.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pa_op.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_op.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-parserify.cmo: ../camlp4/mLast.cmi parserify.cmi
-parserify.cmx: ../camlp4/mLast.cmi parserify.cmi
-pa_ru.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_ru.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pa_scheme.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_scheme.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pa_schemer.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_schemer.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pa_sml.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_sml.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pr_depend.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pr_depend.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pr_extend.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/spretty.cmi
-pr_extend.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/spretty.cmx
-pr_extfun.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/spretty.cmi
-pr_extfun.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/spretty.cmx
-pr_null.cmo: ../camlp4/pcaml.cmi
-pr_null.cmx: ../camlp4/pcaml.cmx
-pr_o.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/spretty.cmi
-pr_o.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/spretty.cmx
-pr_op_main.cmo: ../camlp4/mLast.cmi parserify.cmi ../camlp4/pcaml.cmi \
- ../camlp4/spretty.cmi
-pr_op_main.cmx: ../camlp4/mLast.cmi parserify.cmx ../camlp4/pcaml.cmx \
- ../camlp4/spretty.cmx
-pr_op.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/spretty.cmi
-pr_op.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/spretty.cmx
-pr_r.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/spretty.cmi
-pr_r.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/spretty.cmx
-pr_rp_main.cmo: ../camlp4/mLast.cmi parserify.cmi ../camlp4/pcaml.cmi \
- ../camlp4/spretty.cmi
-pr_rp_main.cmx: ../camlp4/mLast.cmi parserify.cmx ../camlp4/pcaml.cmx \
- ../camlp4/spretty.cmx
-pr_rp.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/spretty.cmi
-pr_rp.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/spretty.cmx
-pr_scheme.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pr_scheme.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pr_schp_main.cmo: ../camlp4/mLast.cmi parserify.cmi ../camlp4/pcaml.cmi \
- pr_scheme.cmo
-pr_schp_main.cmx: ../camlp4/mLast.cmi parserify.cmx ../camlp4/pcaml.cmx \
- pr_scheme.cmx
-q_phony.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/quotation.cmi
-q_phony.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/quotation.cmx
diff --git a/camlp4/etc/Makefile b/camlp4/etc/Makefile
deleted file mode 100644
index 070fa00b47..0000000000
--- a/camlp4/etc/Makefile
+++ /dev/null
@@ -1,107 +0,0 @@
-# $Id$
-
-include ../config/Makefile
-
-INCLUDES=-I ../camlp4 -I ../boot -I $(OTOP)/lex
-OCAMLCFLAGS=-warn-error A $(INCLUDES)
-OBJS=q_phony.cmo pa_o.cmo pa_op.cmo pa_oop.cmo pa_ru.cmo pa_format.cmo pa_olabl.cmo pa_sml.cmo pa_lisp.cmo pa_scheme.cmo pa_extfold.cmo pa_extfun.cmo pa_fstream.cmo pa_lefteval.cmo pa_ifdef.cmo pr_r.cmo pr_rp.cmo pr_o.cmo pr_op.cmo pr_scheme.cmo pr_schemep.cmo pr_extend.cmo pr_extfun.cmo pr_null.cmo pr_depend.cmo
-OBJSX=$(OBJS:.cmo=.cmx)
-INTF=pa_o.cmi
-CAMLP4OM=pa_o.cmo pa_op.cmo ../meta/pr_dump.cmo
-CAMLP4OMX=$(CAMLP4OM:.cmo=.cmx)
-CAMLP4SCHM=pa_scheme.cmo ../meta/pr_dump.cmo
-SHELL=/bin/sh
-COUT=$(OBJS) camlp4o$(EXE) camlp4sch$(EXE)
-COPT=$(OBJSX) camlp4o.opt
-
-all: $(COUT) mkcamlp4.sh
-opt: $(COPT)
-
-pr_rp.cmo: parserify.cmo pr_rp_main.cmo
- $(OCAMLC) parserify.cmo pr_rp_main.cmo -a -o $@
-
-pr_op.cmo: parserify.cmo pr_op_main.cmo
- $(OCAMLC) parserify.cmo pr_op_main.cmo -a -o $@
-
-pr_schemep.cmo: parserify.cmo pr_schp_main.cmo
- $(OCAMLC) parserify.cmo pr_schp_main.cmo -a -o $@
-
-pr_rp.cmx: parserify.cmx pr_rp_main.cmx
- $(OCAMLOPT) parserify.cmx pr_rp_main.cmx -a -o $@
-
-pr_op.cmx: parserify.cmx pr_op_main.cmx
- $(OCAMLOPT) parserify.cmx pr_op_main.cmx -a -o $@
-
-pr_schemep.cmx: parserify.cmx pr_schp_main.cmx
- $(OCAMLOPT) parserify.cmx pr_schp_main.cmx -a -o $@
-
-camlp4o$(EXE): ../camlp4/camlp4$(EXE) $(CAMLP4OM)
- rm -f camlp4o$(EXE)
- cd ../camlp4; $(MAKE) CAMLP4=../etc/camlp4o$(EXE) CAMLP4M="-I ../etc $(CAMLP4OM)"
-
-camlp4sch$(EXE): ../camlp4/camlp4$(EXE) $(CAMLP4SCHM)
- rm -f camlp4sch$(EXE)
- cd ../camlp4; $(MAKE) CAMLP4=../etc/camlp4sch$(EXE) CAMLP4M="-I ../etc $(CAMLP4SCHM)"
-
-camlp4o.opt: $(CAMLP4OMX)
- rm -f camlp4o.opt
- cd ../camlp4; $(MAKE) optp4 CAMLP4OPT=../etc/camlp4o.opt CAMLP4M="-I ../etc $(CAMLP4OMX)"
-
-mkcamlp4.sh: mkcamlp4.sh.tpl
- sed -e "s!LIBDIR!$(LIBDIR)!g" mkcamlp4.sh.tpl > mkcamlp4.sh
-
-pa_ocamllex.cma: pa_ocamllex.cmo
- $(OCAMLC) -I $(OTOP)/lex cset.cmo syntax.cmo table.cmo lexgen.cmo compact.cmo pa_ocamllex.cmo -a -o pa_ocamllex.cma
-
-bootstrap_scheme:
- @$(MAKE) bootstrap_l L=scheme | grep -v directory
-compare_scheme:
- @$(MAKE) compare_l L=scheme | grep -v directory
-bootstrap_lisp:
- @$(MAKE) bootstrap_l L=lisp | grep -v directory
-compare_lisp:
- @$(MAKE) compare_l L=lisp | grep -v directory
-
-bootstrap_l:
- ../boot/camlp4 ./pa_$Lr.cmo ./q_phony.cmo -I ../boot pa_extend.cmo ./pr_r.cmo ./pr_extend.cmo ./pr_rp.cmo pa_$L.ml > tmp
- mv pa_$Lr.ml pa_$Lr.ml.old
- sed -e 's/^;; \(.*\)$$/(* \1 *)/' -e 's/^; \(.*\)$$/(* \1 *)/' -e 's|./pa_$Lr.cmo|pa_r.cmo pa_rp.cmo|' -e 's/$$Id.*\$$/File generated by pretty print; do not edit!/' tmp > pa_$Lr.ml
- rm -f tmp
-
-compare_l:
- ../boot/camlp4 ./pa_$Lr.cmo ./q_phony.cmo -I ../boot pa_extend.cmo ./pr_r.cmo ./pr_extend.cmo ./pr_rp.cmo pa_$L.ml | sed -e 's/^;; \(.*\)$$/(* \1 *)/' -e 's/^; \(.*\)$$/(* \1 *)/' -e 's|./pa_$Lr.cmo|pa_r.cmo pa_rp.cmo|' -e 's/$$Id.*\$$/File generated by pretty print; do not edit!/' | diff -c pa_$Lr.ml -
-
-clean::
- rm -f *.cm* *.pp[io] *.o *.bak .*.bak *.out *.opt
- rm -f mkcamlp4.sh camlp4o$(EXE) camlp4sch$(EXE)
-
-depend:
- cp .depend .depend.bak
- > .depend
- @for i in *.mli *.ml; do \
- ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \
- sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \
- done
-
-get_promote:
-
-install:
- -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)"
- cp $(OBJS) "$(LIBDIR)/camlp4/."
- cp $(INTF) "$(LIBDIR)/camlp4/."
- cp lib.sml "$(LIBDIR)/camlp4/."
- cp camlp4o$(EXE) camlp4sch$(EXE) "$(BINDIR)/."
- if test -f camlp4o.opt; then cp camlp4o.opt "$(BINDIR)/camlp4o.opt$(EXE)"; cp $(OBJSX) $(OBJSX:.cmx=.o) "$(LIBDIR)/camlp4/."; fi
- cp mkcamlp4.sh "$(BINDIR)/mkcamlp4"
- chmod a+x "$(BINDIR)/mkcamlp4"
-
-pa_lisp.cmo: pa_lispr.cmo
-pa_scheme.cmo: pa_schemer.cmo
-pa_ocamllex.cmo: pa_o.cmo
-pr_extend.cmo: pa_extfun.cmo
-pr_o.cmo: pa_extfun.cmo
-pr_op.cmo: pa_extfun.cmo
-pr_r.cmo: pa_extfun.cmo
-pr_rp.cmo: pa_extfun.cmo
-
-include .depend
diff --git a/camlp4/etc/Makefile.Mac b/camlp4/etc/Makefile.Mac
deleted file mode 100644
index 27c793fe39..0000000000
--- a/camlp4/etc/Makefile.Mac
+++ /dev/null
@@ -1,71 +0,0 @@
-#######################################################################
-# #
-# Camlp4 #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. Distributed only by permission. #
-# #
-#######################################################################
-
-# $Id$
-
-INCLUDES = -I ::camlp4: -I ::boot:
-OCAMLCFLAGS = {INCLUDES}
-OBJS = q_phony.cmo pa_o.cmo pa_op.cmo pa_oop.cmo pa_ru.cmo pa_format.cmo ¶
- pa_olabl.cmo pa_sml.cmo pa_lisp.cmo pa_extfold.cmo pa_extfun.cmo pa_fstream.cmo spa_lefteval.cmo ¶
- pr_r.cmo pr_rp.cmo pr_o.cmo pr_op.cmo pr_extend.cmo ¶
- pr_extfun.cmo pr_null.cmo pr_depend.cmo
-INTF = pa_o.cmi
-CAMLP4OM = pa_o.cmo pa_op.cmo ::meta:pr_dump.cmo
-OUT = {OBJS} camlp4o
-
-all Ä {OUT} mkcamlp4.mpw
-
-camlp4o Ä ::camlp4:camlp4 {CAMLP4OM}
- delete -i camlp4o
- directory ::camlp4:
- domake -d CAMLP4=::etc:camlp4o -d CAMLP4M="-I ::etc: {CAMLP4OM}"
- directory ::etc:
-
-mkcamlp4.mpw Ä mkcamlp4.mpw.tpl
- streamedit -e "1,$ replace -c ° /OLIBDIR/ ¶"`quote "{OLIBDIR}"`¶"" ¶
- -e "1,$ replace -c ° /LIBDIR/ ¶"`quote "{P4LIBDIR}"`¶"" ¶
- mkcamlp4.mpw.tpl > mkcamlp4.mpw
-
-bootstrap_lisp Ä $OutOfDate
- ::boot:camlp4 :pa_lispr.cmo -I ::boot: pa_extend.cmo q_MLast.cmo ¶
- :pr_r.cmo :pr_extend.cmo :pr_rp.cmo -phony_quot pa_lisp.ml ¶
- | streamedit -e '1,$ replace /¥;; (Å)¨0°/ "(* " ¨0 " *)"' ¶
- -e "1,$ replace /'./pa_lispr.cmo'/ 'pa_r.cmo pa_rp.cmo'" >tmp
- rename -y pa_lispr.ml pa_lispr.ml.old
- rename -y tmp pa_lispr.ml
-
-compare_lisp Ä $OutOfDate
- set status 0
-
-clean ÄÄ
- delete -i mkcamlp4.mpw camlp4o
-
-{dependrule}
-
-get_promote Ä $OutOfDate
-
-install Ä
- (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null
- (newfolder "{BINDIR}" || set status 0) ³ dev:null
- duplicate -y {OBJS} "{P4LIBDIR}"
- duplicate -y {INTF} "{P4LIBDIR}"
- duplicate -y lib.sml "{P4LIBDIR}"
- duplicate -y camlp4o "{BINDIR}"
- duplicate -y mkcamlp4.mpw "{BINDIR}mkcamlp4"
-
-{defrules}
-
-pa_lisp.cmoÄ pa_lispr.cmo
-pr_extend.cmoÄ pa_extfun.cmo
-pr_o.cmoÄ pa_extfun.cmo
-pr_op.cmoÄ pa_extfun.cmo
-pr_r.cmoÄ pa_extfun.cmo
-pr_rp.cmoÄ pa_extfun.cmo
diff --git a/camlp4/etc/Makefile.Mac.depend b/camlp4/etc/Makefile.Mac.depend
deleted file mode 100644
index c8007dcb7f..0000000000
--- a/camlp4/etc/Makefile.Mac.depend
+++ /dev/null
@@ -1,40 +0,0 @@
-pa_extfun.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi
-pa_extfun.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx
-pa_format.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi
-pa_format.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx
-pa_fstream.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi
-pa_fstream.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx
-pa_lisp.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi
-pa_lisp.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx
-pa_lispr.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi
-pa_lispr.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx
-pa_olabl.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi
-pa_olabl.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx
-pa_o.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi
-pa_o.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx
-pa_oop.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi
-pa_oop.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx
-pa_op.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi
-pa_op.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx
-pa_ru.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi
-pa_ru.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx
-pa_sml.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi
-pa_sml.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx
-pr_depend.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi
-pr_depend.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx
-pr_extend.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:spretty.cmi
-pr_extend.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:spretty.cmx
-pr_extfun.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:spretty.cmi
-pr_extfun.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:spretty.cmx
-pr_null.cmoÄ ::camlp4:pcaml.cmi
-pr_null.cmxÄ ::camlp4:pcaml.cmx
-pr_o.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:spretty.cmi
-pr_o.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:spretty.cmx
-pr_op.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:spretty.cmi
-pr_op.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:spretty.cmx
-pr_r.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:spretty.cmi
-pr_r.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:spretty.cmx
-pr_rp.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:spretty.cmi
-pr_rp.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:spretty.cmx
-q_phony.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:quotation.cmi
-q_phony.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:quotation.cmx
diff --git a/camlp4/etc/lib.sml b/camlp4/etc/lib.sml
deleted file mode 100644
index a9d05fe04b..0000000000
--- a/camlp4/etc/lib.sml
+++ /dev/null
@@ -1,384 +0,0 @@
-(* $Id$ *)
-
-datatype 'a option = SOME of 'a | NONE
-exception Fail of string
-exception Domain
-exception Subscript
-type 'a vector = 'a array
-
-structure OCaml =
- struct
- structure List = List
- structure String = String
- end
-
-structure Time =
- struct
- datatype time = TIME of { sec : int, usec : int }
- fun toString _ = failwith "not implemented Time.toString"
- fun now _ = failwith "not implemented Time.now"
- end
-
-datatype cpu_timer =
- CPUT of { gc : Time.time, sys : Time.time, usr : Time.time }
-
-datatype real_timer =
- RealT of Time.time
-
-structure Char =
- struct
- val ord = Char.code
- end
-
-structure General =
- struct
- datatype order = LESS | EQUAL | GREATER
- end
-type order = General.order == LESS | EQUAL | GREATER
-
-structure OS =
- struct
- exception SysErr
- structure Path =
- struct
- fun dir s =
- let val r = Filename.dirname s in
- if r = "." then "" else r
- end
- val file = Filename.basename
- fun ext s =
- let fun loop i =
- if i < 0 then NONE
- else if String.get s i = #"." then
- let val len = String.length s - i - 1 in
- if len = 0 then NONE else SOME (String.sub s (i + 1) len)
- end
- else loop (i - 1)
- in
- loop (String.length s - 1)
- end
- fun splitDirFile s =
- {dir = Filename.dirname s,
- file = Filename.basename s}
- fun joinDirFile x =
- let val {dir,file} = x in Filename.concat dir file end
- end
- structure FileSys =
- struct
- datatype access_mode = A_READ | A_WRITE | A_EXEC
- val chDir = Sys.chdir
- fun isDir s =
- (Unix.stat s) ocaml_record_access Unix.st_kind = Unix.S_DIR
- handle Unix.Unix_error _ => raise SysErr
- fun access (s, accs) =
- let val st = Unix.stat s
- val prm = st ocaml_record_access Unix.st_perm
- val prm =
- if st ocaml_record_access Unix.st_uid = Unix.getuid () then
- lsr prm 6
- else if st ocaml_record_access Unix.st_uid = Unix.getgid ()
- then
- lsr prm 3
- else prm
- val rf =
- if List.mem A_READ accs then land prm 4 <> 0 else true
- val wf =
- if List.mem A_WRITE accs then land prm 2 <> 0 else true
- val xf =
- if List.mem A_EXEC accs then land prm 1 <> 0 else true
- in
- rf andalso wf andalso xf
- end
- handle Unix.Unix_error (_, f, _) =>
- if f = "stat" then false else raise SysErr
- end
- structure Process =
- struct
- fun system s = (flush stdout; flush stderr; Sys.command s)
- fun getEnv s = SOME (Sys.getenv s) handle Not_found => NONE
- val success = 0
- end
- end
-
-exception SysErr = OS.SysErr
-
-structure IO =
- struct
- exception Io of {cause:exn, function:string, name:string}
- end
-
-structure TextIO =
- struct
- type instream = in_channel * char option option ref
- type outstream = out_channel
- type elem = char
- type vector = string
- fun openIn fname =
- (open_in fname, ref NONE) handle exn =>
- raise IO.Io {cause = exn, function = "openIn", name = fname}
- val openOut = open_out
- fun closeIn (ic, ahc) = (ahc := SOME NONE; close_in ic)
- val closeOut = close_out
- val stdIn = (stdin, ref NONE)
- fun endOfStream (ic, _) = pos_in ic = in_channel_length ic
- fun inputLine (ic, ahc) =
- case !ahc of
- NONE =>
- (input_line ic ^ "\n" handle End_of_file => (ahc := SOME NONE; ""))
- | SOME NONE => ""
- | SOME (SOME c) =>
- (ahc := NONE;
- if c = #"\n" then "\n"
- else
- String.make 1 c ^ input_line ic ^ "\n" handle
- End_of_file => (ahc := SOME NONE; ""))
- fun input1 (ic, ahc) =
- case !ahc of
- NONE =>
- (SOME (input_char ic) handle End_of_file => (ahc := SOME NONE; NONE))
- | SOME NONE => NONE
- | SOME x => (ahc := NONE; x)
- fun inputN (ins, n) =
- let fun loop n =
- if n <= 0 then ""
- else
- case input1 ins of
- SOME c => String.make 1 c ^ loop (n - 1)
- | NONE => ""
- in
- loop n
- end
- fun output (oc, v) = output_string oc v
- fun inputAll ic = failwith "not implemented TextIO.inputAll"
- fun lookahead (ic, ahc) =
- case !ahc of
- NONE => let val r = SOME (input_char ic) in ahc := SOME r; r end
- | SOME x => x
- fun print s = (print_string s; flush stdout)
- end
-
-structure Timer =
- struct
- fun startRealTimer () = failwith "not implemented Timer.startRealTimer"
- fun startCPUTimer () = failwith "not implemented Timer.startCPUTimer"
- fun checkRealTimer _ = failwith "not implemented Timer.checkRealTimer"
- fun checkCPUTimer _ = failwith "not implemented Timer.checkCPUTimer"
- end
-
-structure Date =
- struct
- datatype month =
- Jan | Feb | Mar | Apr | May | Jun | Jul | Sep | Oct | Nov | Dec
- datatype wday = Sun | Mon | Tue | Wed | Thu | Fri | Sat
- datatype date =
- DATE of
- {day : int, hour : int, isDst : bool option, minute : int,
- month : month, offset : int option, second : int, wday : wday,
- yday : int, year : int}
- fun fmt _ _ = failwith "not implemented Date.fmt"
- fun fromTimeLocal _ = failwith "not implemented Date.fromTimeLocal"
- end
-
-structure Posix =
- struct
- structure ProcEnv =
- struct
- fun getenv s = SOME (Sys.getenv s) handle Not_found => NONE
- end
- end
-
-structure SMLofNJ =
- struct
- fun exportML s = failwith ("not implemented exportML " ^ s)
- end
-
-fun null x = x = []
-fun explode s =
- let fun loop i =
- if i = String.length s then []
- else String.get s i :: loop (i + 1)
- in
- loop 0
- end
-
-val app = List.iter
-fun implode [] = ""
- | implode (c :: l) = String.make 1 c ^ implode l
-
-fun ooo f g x = f (g x)
-
-structure Array =
- struct
- fun array (len, v) = Array.create len v
- fun sub _ = failwith "not implemented Array.sub"
- fun update _ = failwith "not implemented Array.update"
- (* for make the profiler work *)
- val set = Array.set
- val get = Array.get
- end
-
-structure Vector =
- struct
- fun tabulate _ = failwith "not implemented Vector.tabulate"
- fun sub _ = failwith "not implemented Vector.sub"
- end
-
-structure Bool =
- struct
- val toString = string_of_bool
- end
-
-structure String =
- struct
- val size = String.length
- fun substring (s, beg, len) =
- String.sub s beg len handle Invalid_argument _ => raise Subscript
- val concat = String.concat ""
- fun sub (s, i) = String.get s i
- val str = String.make 1
- fun compare (s1, s2) =
- if s1 < s2 then LESS
- else if s1 > s2 then GREATER
- else EQUAL
- fun isPrefix s1 s2 =
- let fun loop i1 i2 =
- if i1 >= String.length s1 then true
- else if i2 >= String.length s2 then false
- else if String.get s1 i1 = String.get s2 i2 then loop (i1 + 1) (i2 + 1)
- else false
- in
- loop 0 0
- end
- fun tokens p s =
- let fun loop tok i =
- if i >= String.length s then
- if tok = "" then [] else [tok]
- else if p (String.get s i) then
- if tok <> "" then tok :: loop "" (i + 1)
- else loop "" (i + 1)
- else loop (tok ^ String.make 1 (String.get s i)) (i + 1)
- in
- loop "" 0
- end
- fun extract _ = failwith "not implemented String.extract"
- end
-
-structure Substring =
- struct
- type substring = string * int * int
- fun string (s : substring) = String.substring s
- fun all s : substring = (s, 0, String.size s)
- fun splitl f ((s, beg, len) : substring) : substring * substring =
- let fun loop di =
- if di = len then ((s, beg, len), (s, 0, 0))
- else if f (String.sub (s, beg + di)) then loop (di + 1)
- else ((s, beg, di), (s, beg + di, len - di))
- in
- loop 0
- end
- fun getc (s, i, len) =
- if len > 0 andalso i < String.size s then
- SOME (String.sub (s, i), (s, i+1, len-1))
- else NONE
- fun slice _ = failwith "not implemented: Substring.slice"
- fun isEmpty (s, beg, len) = len = 0
- fun concat sl = String.concat (List.map string sl)
- end
-type substring = Substring.substring
-
-structure StringCvt =
- struct
- datatype radix = BIN | OCT | DEC | HEX
- type ('a, 'b) reader = 'b -> ('a * 'b) option
- end
-
-structure ListPair =
- struct
- fun zip (a1::l1, a2::l2) = (a1, a2) :: zip (l1, l2)
- | zip _ = []
- val unzip = List.split
- fun all f (x1 :: l1, x2 :: l2) = f (x1, x2) andalso all f (l1, l2)
- | all _ _ = true
- fun map f (a1::l1, a2::l2) =
- let val r = f (a1, a2) in r :: map f (l1, l2) end
- | map _ _ = []
- end
-
-structure ListMergeSort =
- struct
- fun uniqueSort cmp l =
- List.sort
- (fn x => fn y =>
- case cmp (x, y) of
- LESS => ~1
- | EQUAL => 0
- | GREATER => 1)
- l
- end
-
-structure List =
- struct
- exception Empty
- fun hd [] = raise Empty
- | hd (x :: l) = x
- fun tl [] = raise Empty
- | tl (x :: l) = l
- fun foldr f a l =
- let fun loop a [] = a
- | loop a (x :: l) = loop (f (x, a)) l
- in
- loop a (List.rev l)
- end
- fun foldl f a l = List.fold_left (fn a => fn x => f (x, a)) a l
- val concat = List.flatten
- val exists = List.exists
- val filter = List.filter
- val length = List.length
- val map = List.map
- val rev = List.rev
- val all = List.for_all
- fun find f [] = NONE
- | find f (x :: l) = if f x then SOME x else find f l
- fun last s =
- case List.rev s of
- [] => raise Empty
- | x :: _ => x
- fun take _ = failwith "not implemented: List.take"
- fun partition _ = failwith "not implemented: List.partition"
- fun mapPartial f [] = []
- | mapPartial f (x :: l) =
- case f x of
- NONE => mapPartial f l
- | SOME y => y :: mapPartial f l
- fun op @ l1 l2 = List.rev_append (List.rev l1) l2
- end
-
-structure Int =
- struct
- type int1 = int
- type int = int1
- val toString = string_of_int
- fun fromString s = SOME (int_of_string s) handle Failure _ => NONE
- fun min (x, y) = if x < y then x else y
- fun max (x, y) = if x > y then x else y
- fun scan radix getc src = failwith "not impl: Int.scan"
- end
-
-val foldr = List.foldr
-val exists = List.exists
-val size = String.size
-val substring = String.substring
-val concat = String.concat
-val length = List.length
-val op @ = List.op @
-val hd = List.hd
-val tl = List.tl
-val map = List.map
-val rev = List.rev
-val use_hook = ref (fn (s : string) => failwith "no defined directive use")
-fun use s = !use_hook s
-fun isSome (SOME _) = true
- | isSome NONE = false
-fun valOf (SOME x) = x
- | valOf NONE = failwith "valOf"
-val print = TextIO.print
diff --git a/camlp4/etc/mkcamlp4.mpw.tpl b/camlp4/etc/mkcamlp4.mpw.tpl
deleted file mode 100644
index 6b174bf6a9..0000000000
--- a/camlp4/etc/mkcamlp4.mpw.tpl
+++ /dev/null
@@ -1,33 +0,0 @@
-#######################################################################
-# #
-# Camlp4 #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. Distributed only by permission. #
-# #
-#######################################################################
-
-# $Id$
-
-set OLIB OLIBDIR
-set LIB LIBDIR
-
-set INTERFACES ""
-set OPTS ""
-set INCL "-I :"
-
-loop
- exit if "{1}" == ""
- if "{1}" == "-I"
- set INCL "{INCL} -I `quote "{2}"`"
- shift
- else if "{1}" =~ /([Â:])¨0([Â:]*)¨1.cmi/
- set first `echo {¨0} | translate a-z A-Z`
- set INTERFACES "{INTERFACES} {first}{¨1}"
- else
- set OPTS "{OPTS} `quote "{1}"`"
- end
- shift
-end
diff --git a/camlp4/etc/mkcamlp4.sh.tpl b/camlp4/etc/mkcamlp4.sh.tpl
deleted file mode 100755
index 50c3ea61a7..0000000000
--- a/camlp4/etc/mkcamlp4.sh.tpl
+++ /dev/null
@@ -1,33 +0,0 @@
-#!/bin/sh
-# $Id$
-
-OLIB="`ocamlc -where`"
-LIB="LIBDIR/camlp4"
-
-INTERFACES=
-OPTS=
-INCL="-I ."
-while test "" != "$1"; do
- case "$1" in
- -I) INCL="$INCL -I $2"; shift;;
- *)
- j=`basename "$1" .cmi`
- if test "$j.cmi" = "$1"; then
- first="`expr "$j" : '\(.\)' | tr 'a-z' 'A-Z'`"
- rest="`expr "$j" : '.\(.*\)'`"
- INTERFACES="$INTERFACES $first$rest"
- else
- OPTS="$OPTS $1"
- fi;;
- esac
- shift
-done
-
-CRC=crc_$$
-set -e
-trap 'rm -f $CRC.ml $CRC.cmi $CRC.cmo' 0 2
-$OLIB/extract_crc -I $OLIB $INCL $INTERFACES > $CRC.ml
-echo "let _ = Dynlink.add_available_units crc_unit_list" >> $CRC.ml
-ocamlc -I $LIB odyl.cma camlp4.cma $CRC.ml $INCL $OPTS odyl.cmo -linkall
-rm -f $CRC.ml $CRC.cmi $CRC.cmo
-
diff --git a/camlp4/etc/pa_extfold.ml b/camlp4/etc/pa_extfold.ml
deleted file mode 100644
index 0c272c4d0c..0000000000
--- a/camlp4/etc/pa_extfold.ml
+++ /dev/null
@@ -1,42 +0,0 @@
-(* camlp4r pa_extend.cmo q_MLast.cmo *)
-(* $Id$ *)
-
-open Pcaml;
-open Pa_extend;
-
-value sfold loc n foldfun f e s =
- let styp = STquo loc (new_type_var ()) in
- let e = <:expr< Extfold.$lid:foldfun$ $f$ $e$ >> in
- let t = STapp loc (STapp loc (STtyp <:ctyp< Extfold.t _ >>) s.styp) styp in
- {used = s.used; text = TXmeta loc n [s.text] e t; styp = styp}
-;
-
-value sfoldsep loc n foldfun f e s sep =
- let styp = STquo loc (new_type_var ()) in
- let e = <:expr< Extfold.$lid:foldfun$ $f$ $e$ >> in
- let t =
- STapp loc (STapp loc (STtyp <:ctyp< Extfold.tsep _ >>) s.styp) styp
- in
- {used = s.used @ sep.used; text = TXmeta loc n [s.text; sep.text] e t;
- styp = styp}
-;
-
-EXTEND
- GLOBAL: symbol;
- symbol: LEVEL "top"
- [ [ UIDENT "FOLD0"; f = simple_expr; e = simple_expr; s = SELF ->
- sfold loc "FOLD0" "sfold0" f e s
- | UIDENT "FOLD1"; f = simple_expr; e = simple_expr; s = SELF ->
- sfold loc "FOLD1" "sfold1" f e s
- | UIDENT "FOLD0"; f = simple_expr; e = simple_expr; s = SELF;
- UIDENT "SEP"; sep = symbol ->
- sfoldsep loc "FOLD0 SEP" "sfold0sep" f e s sep
- | UIDENT "FOLD1"; f = simple_expr; e = simple_expr; s = SELF;
- UIDENT "SEP"; sep = symbol ->
- sfoldsep loc "FOLD1 SEP" "sfold1sep" f e s sep ] ]
- ;
- simple_expr:
- [ [ i = LIDENT -> <:expr< $lid:i$ >>
- | "("; e = expr; ")" -> e ] ]
- ;
-END;
diff --git a/camlp4/etc/pa_extfun.ml b/camlp4/etc/pa_extfun.ml
deleted file mode 100644
index 5cab09a2bb..0000000000
--- a/camlp4/etc/pa_extfun.ml
+++ /dev/null
@@ -1,123 +0,0 @@
-(* camlp4r q_MLast.cmo pa_extend.cmo *)
-(* $Id$ *)
-
-open Pcaml;
-
-value not_impl name x =
- let desc =
- if Obj.is_block (Obj.repr x) then
- "tag = " ^ string_of_int (Obj.tag (Obj.repr x))
- else "int_val = " ^ string_of_int (Obj.magic x)
- in
- do {
- print_newline (); failwith ("pa_extfun: not impl " ^ name ^ " " ^ desc)
- }
-;
-
-value rec mexpr p =
- let loc = MLast.loc_of_patt p in
- match p with
- [ <:patt< $p1$ $p2$ >> ->
- loop <:expr< [$mexpr p2$] >> p1 where rec loop el =
- fun
- [ <:patt< $p1$ $p2$ >> -> loop <:expr< [$mexpr p2$ :: $el$] >> p1
- | p -> <:expr< Extfun.Eapp [$mexpr p$ :: $el$] >> ]
- | <:patt< $p1$ . $p2$ >> ->
- loop <:expr< [$mexpr p2$] >> p1 where rec loop el =
- fun
- [ <:patt< $p1$ . $p2$ >> -> loop <:expr< [$mexpr p2$ :: $el$] >> p1
- | p -> <:expr< Extfun.Eacc [$mexpr p$ :: $el$] >> ]
- | <:patt< ($list:pl$) >> -> <:expr< Extfun.Etup $mexpr_list loc pl$ >>
- | <:patt< $uid:id$ >> -> <:expr< Extfun.Econ $str:id$ >>
- | <:patt< ` $id$ >> -> <:expr< Extfun.Econ $str:id$ >>
- | <:patt< $int:s$ >> -> <:expr< Extfun.Eint $str:s$ >>
- | <:patt< $str:s$ >> -> <:expr< Extfun.Estr $str:s$ >>
- | <:patt< ($p1$ as $_$) >> -> mexpr p1
- | <:patt< $lid:_$ >> -> <:expr< Extfun.Evar () >>
- | <:patt< _ >> -> <:expr< Extfun.Evar () >>
- | <:patt< $p1$ | $p2$ >> ->
- Stdpp.raise_with_loc loc (Failure "or patterns not allowed in extfun")
- | p -> not_impl "mexpr" p ]
-and mexpr_list loc =
- fun
- [ [] -> <:expr< [] >>
- | [e :: el] -> <:expr< [$mexpr e$ :: $mexpr_list loc el$] >> ]
-;
-
-value rec catch_any =
- fun
- [ <:patt< $uid:id$ >> -> False
- | <:patt< ` $_$ >> -> False
- | <:patt< $lid:_$ >> -> True
- | <:patt< _ >> -> True
- | <:patt< ($list:pl$) >> -> List.for_all catch_any pl
- | <:patt< $p1$ $p2$ >> -> False
- | <:patt< $p1$ | $p2$ >> -> False
- | <:patt< $int:_$ >> -> False
- | <:patt< $str:_$ >> -> False
- | <:patt< ($p1$ as $_$) >> -> catch_any p1
- | p -> not_impl "catch_any" p ]
-;
-
-value conv (p, wo, e) =
- let tst = mexpr p in
- let loc = (fst (MLast.loc_of_patt p), snd (MLast.loc_of_expr e)) in
- let e =
- if wo = None && catch_any p then <:expr< fun $p$ -> Some $e$ >>
- else <:expr< fun [ $p$ $when:wo$ -> Some $e$ | _ -> None ] >>
- in
- let has_when =
- match wo with
- [ Some _ -> <:expr< True >>
- | None -> <:expr< False >> ]
- in
- <:expr< ($tst$, $has_when$, $e$) >>
-;
-
-value rec conv_list tl =
- fun
- [ [pe :: pel] ->
- let loc = MLast.loc_of_expr tl in
- <:expr< [$conv pe$ :: $conv_list tl pel$] >>
- | [] -> tl ]
-;
-
-value rec split_or =
- fun
- [ [(<:patt< $p1$ | $p2$ >>, wo, e) :: pel] ->
- split_or [(p1, wo, e); (p2, wo, e) :: pel]
- | [(<:patt< ($p1$ | $p2$ as $p$) >>, wo, e) :: pel] ->
- let p1 =
- let loc = MLast.loc_of_patt p1 in
- <:patt< ($p1$ as $p$) >>
- in
- let p2 =
- let loc = MLast.loc_of_patt p2 in
- <:patt< ($p2$ as $p$) >>
- in
- split_or [(p1, wo, e); (p2, wo, e) :: pel]
- | [pe :: pel] -> [pe :: split_or pel]
- | [] -> [] ]
-;
-
-EXTEND
- GLOBAL: expr;
- expr: LEVEL "top"
- [ [ "extfun"; e = SELF; "with"; "["; list = match_case_list; "]" ->
- <:expr< Extfun.extend $e$ $list$ >> ] ]
- ;
- match_case_list:
- [ [ pel = LIST0 match_case SEP "|" ->
- conv_list <:expr< [] >> (split_or pel) ] ]
- ;
- match_case:
- [ [ p = patt; aso = OPT [ "as"; p = patt -> p ];
- w = OPT [ "when"; e = expr -> e ]; "->"; e = expr ->
- let p =
- match aso with
- [ Some p2 -> <:patt< ($p$ as $p2$) >>
- | _ -> p ]
- in
- (p, w, e) ] ]
- ;
-END;
diff --git a/camlp4/etc/pa_format.ml b/camlp4/etc/pa_format.ml
deleted file mode 100644
index 3c8deea472..0000000000
--- a/camlp4/etc/pa_format.ml
+++ /dev/null
@@ -1,39 +0,0 @@
-(* camlp4r pa_extend.cmo q_MLast.cmo *)
-(* $Id$ *)
-
-open Pcaml;
-
-EXTEND
- GLOBAL: expr;
- expr: LEVEL "top"
- [ [ n = box_type; d = SELF; "begin";
- el = LIST0 [ e = box_expr; ";" -> e ]; "end" ->
- let el = [<:expr< Format.$lid:"open_" ^ n$ $d$ >> :: el] in
- let el = el @ [<:expr< Format.close_box () >>] in
- <:expr< do { $list:el$ } >>
- | "hbox"; "begin"; el = LIST0 [ e = box_expr; ";" -> e ]; "end" ->
- let el = [<:expr< Format.open_hbox () >> :: el] in
- let el = el @ [<:expr< Format.close_box () >>] in
- <:expr< do { $list:el$ } >>
- | "nobox"; "begin"; el = LIST0 [ e = box_expr; ";" -> e ]; "end" ->
- match el with
- [ [e] -> e
- | _ -> <:expr< do { $list:el$ } >> ] ] ]
- ;
- box_type:
- [ [ n = "hovbox" -> n
- | n = "hvbox" -> n
- | n = "vbox" -> n
- | n = "box" -> n ] ]
- ;
- box_expr:
- [ [ s = STRING -> <:expr< Format.print_string $str:s$ >>
- | UIDENT "STRING"; e = expr -> <:expr< Format.print_string $e$ >>
- | UIDENT "INT"; e = expr -> <:expr< Format.print_int $e$ >>
- | "/-" -> <:expr< Format.print_space () >>
- | "//" -> <:expr< Format.print_cut () >>
- | "!/" -> <:expr< Format.force_newline () >>
- | "?/" -> <:expr< Format.print_if_newline () >>
- | e = expr -> e ] ]
- ;
-END;
diff --git a/camlp4/etc/pa_fstream.ml b/camlp4/etc/pa_fstream.ml
deleted file mode 100644
index 9a2faebc80..0000000000
--- a/camlp4/etc/pa_fstream.ml
+++ /dev/null
@@ -1,163 +0,0 @@
-(* camlp4r pa_extend.cmo q_MLast.cmo *)
-(* $Id$ *)
-
-open Pcaml;
-
-type spat_comp =
- [ SpTrm of MLast.loc and MLast.patt and option MLast.expr
- | SpNtr of MLast.loc and MLast.patt and MLast.expr
- | SpStr of MLast.loc and MLast.patt ]
-;
-type sexp_comp =
- [ SeTrm of MLast.loc and MLast.expr
- | SeNtr of MLast.loc and MLast.expr ]
-;
-
-(* parsers *)
-
-value strm_n = "strm__";
-value next_fun loc = <:expr< Fstream.next >>;
-
-value rec pattern_eq_expression p e =
- match (p, e) with
- [ (<:patt< $lid:a$ >>, <:expr< $lid:b$ >>) -> a = b
- | (<:patt< $uid:a$ >>, <:expr< $uid:b$ >>) -> a = b
- | (<:patt< $p1$ $p2$ >>, <:expr< $e1$ $e2$ >>) ->
- pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2
- | (<:patt< ($list:pl$) >>, <:expr< ($list:el$) >>) ->
- loop pl el where rec loop pl el =
- match (pl, el) with
- [ ([p :: pl], [e :: el]) ->
- pattern_eq_expression p e && loop pl el
- | ([], []) -> True
- | _ -> False ]
- | _ -> False ]
-;
-
-value stream_pattern_component skont =
- fun
- [ SpTrm loc p wo ->
- let p = <:patt< Some ($p$, $lid:strm_n$) >> in
- if wo = None && pattern_eq_expression p skont then
- <:expr< $next_fun loc$ $lid:strm_n$ >>
- else
- <:expr< match $next_fun loc$ $lid:strm_n$ with
- [ $p$ $when:wo$ -> $skont$
- | _ -> None ] >>
- | SpNtr loc p e ->
- let p = <:patt< Some ($p$, $lid:strm_n$) >> in
- if pattern_eq_expression p skont then <:expr< $e$ $lid:strm_n$ >>
- else
- <:expr< match $e$ $lid:strm_n$ with
- [ $p$ -> $skont$
- | _ -> None ] >>
- | SpStr loc p ->
- <:expr< let $p$ = $lid:strm_n$ in $skont$ >> ]
-;
-
-value rec stream_pattern loc epo e =
- fun
- [ [] ->
- let e =
- match epo with
- [ Some ep -> <:expr< let $ep$ = Fstream.count $lid:strm_n$ in $e$ >>
- | None -> e ]
- in
- <:expr< Some ($e$, $lid:strm_n$) >>
- | [spc :: spcl] ->
- let skont = stream_pattern loc epo e spcl in
- stream_pattern_component skont spc ]
-;
-
-value rec parser_cases loc =
- fun
- [ [] -> <:expr< None >>
- | [(spcl, epo, e) :: spel] ->
- match parser_cases loc spel with
- [ <:expr< None >> -> stream_pattern loc epo e spcl
- | pc ->
- <:expr< match $stream_pattern loc epo e spcl$ with
- [ Some _ as x -> x
- | None -> $pc$ ] >> ] ]
-;
-
-value cparser_match loc me bpo pc =
- let pc = parser_cases loc pc in
- let e =
- match bpo with
- [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>
- | None -> pc ]
- in
- <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >>
-;
-
-value cparser loc bpo pc =
- let e = parser_cases loc pc in
- let e =
- match bpo with
- [ Some bp -> <:expr< let $bp$ = Fstream.count $lid:strm_n$ in $e$ >>
- | None -> e ]
- in
- let p = <:patt< ($lid:strm_n$ : Fstream.t _) >> in <:expr< fun $p$ -> $e$ >>
-;
-
-(* streams *)
-
-value slazy loc x = <:expr< fun () -> $x$ >>;
-
-value rec cstream loc =
- fun
- [ [] -> <:expr< Fstream.nil >>
- | [SeTrm loc e :: sel] ->
- let e2 = cstream loc sel in
- let x = <:expr< Fstream.cons $e$ $e2$ >> in
- <:expr< Fstream.flazy $slazy loc x$ >>
- | [SeNtr loc e] ->
- e
- | [SeNtr loc e :: sel] ->
- let e2 = cstream loc sel in
- let x = <:expr< Fstream.app $e$ $e2$ >> in
- <:expr< Fstream.flazy $slazy loc x$ >> ]
-;
-
-EXTEND
- GLOBAL: expr;
- expr: LEVEL "top"
- [ [ "fparser"; po = OPT ipatt; "["; pcl = LIST0 parser_case SEP "|"; "]" ->
- <:expr< $cparser loc po pcl$ >>
- | "fparser"; po = OPT ipatt; pc = parser_case ->
- <:expr< $cparser loc po [pc]$ >>
- | "match"; e = SELF; "with"; "parser"; po = OPT ipatt; "[";
- pcl = LIST0 parser_case SEP "|"; "]" ->
- <:expr< $cparser_match loc e po pcl$ >>
- | "match"; e = SELF; "with"; "parser"; po = OPT ipatt;
- pc = parser_case ->
- <:expr< $cparser_match loc e po [pc]$ >> ] ]
- ;
- parser_case:
- [ [ "[:"; sp = stream_patt; ":]"; po = OPT ipatt; "->"; e = expr ->
- (sp, po, e) ] ]
- ;
- stream_patt:
- [ [ spc = stream_patt_comp -> [spc]
- | spc = stream_patt_comp; ";"; sp = LIST1 stream_patt_comp SEP ";" ->
- [spc :: sp]
- | -> [] ] ]
- ;
- stream_patt_comp:
- [ [ "`"; p = patt; eo = OPT [ "when"; e = expr -> e ] -> SpTrm loc p eo
- | p = patt; "="; e = expr -> SpNtr loc p e
- | p = patt -> SpStr loc p ] ]
- ;
- ipatt:
- [ [ i = LIDENT -> <:patt< $lid:i$ >> ] ]
- ;
- expr: LEVEL "simple"
- [ [ "fstream"; "[:"; se = LIST0 stream_expr_comp SEP ";"; ":]" ->
- <:expr< $cstream loc se$ >> ] ]
- ;
- stream_expr_comp:
- [ [ "`"; e = expr -> SeTrm loc e
- | e = expr -> SeNtr loc e ] ]
- ;
-END;
diff --git a/camlp4/etc/pa_ifdef.ml b/camlp4/etc/pa_ifdef.ml
deleted file mode 100644
index bc80a7d557..0000000000
--- a/camlp4/etc/pa_ifdef.ml
+++ /dev/null
@@ -1,87 +0,0 @@
-(* camlp4r pa_extend.cmo q_MLast.cmo *)
-(* $Id$ *)
-
-(* This module is deprecated since version 3.07; use pa_macro.ml instead *)
-
-type item_or_def 'a =
- [ SdStr of 'a | SdDef of string | SdUnd of string | SdNop ]
-;
-
-value list_remove x l =
- List.fold_right (fun e l -> if e = x then l else [e :: l]) l []
-;
-
-value defined = ref ["OCAML_307"; "OCAML_305"; "CAMLP4_300"; "NEWSEQ"];
-value define x = defined.val := [x :: defined.val];
-value undef x = defined.val := list_remove x defined.val;
-
-EXTEND
- GLOBAL: Pcaml.expr Pcaml.str_item Pcaml.sig_item;
- Pcaml.expr: LEVEL "top"
- [ [ "ifdef"; c = UIDENT; "then"; e1 = Pcaml.expr; "else";
- e2 = Pcaml.expr ->
- if List.mem c defined.val then e1 else e2
- | "ifndef"; c = UIDENT; "then"; e1 = Pcaml.expr; "else";
- e2 = Pcaml.expr ->
- if List.mem c defined.val then e2 else e1 ] ]
- ;
- Pcaml.str_item: FIRST
- [ [ x = def_undef_str ->
- match x with
- [ SdStr si -> si
- | SdDef x -> do { define x; <:str_item< declare end >> }
- | SdUnd x -> do { undef x; <:str_item< declare end >> }
- | SdNop -> <:str_item< declare end >> ] ] ]
- ;
- def_undef_str:
- [ [ "ifdef"; c = UIDENT; "then"; e1 = str_item_def_undef;
- "else"; e2 = str_item_def_undef ->
- if List.mem c defined.val then e1 else e2
- | "ifdef"; c = UIDENT; "then"; e1 = str_item_def_undef ->
- if List.mem c defined.val then e1 else SdNop
- | "ifndef"; c = UIDENT; "then"; e1 = str_item_def_undef;
- "else"; e2 = str_item_def_undef ->
- if List.mem c defined.val then e2 else e1
- | "ifndef"; c = UIDENT; "then"; e1 = str_item_def_undef ->
- if List.mem c defined.val then SdNop else e1
- | "define"; c = UIDENT -> SdDef c
- | "undef"; c = UIDENT -> SdUnd c ] ]
- ;
- str_item_def_undef:
- [ [ d = def_undef_str -> d
- | si = Pcaml.str_item -> SdStr si ] ]
- ;
- Pcaml.sig_item: FIRST
- [ [ x = def_undef_sig ->
- match x with
- [ SdStr si -> si
- | SdDef x -> do { define x; <:sig_item< declare end >> }
- | SdUnd x -> do { undef x; <:sig_item< declare end >> }
- | SdNop -> <:sig_item< declare end >> ] ] ]
- ;
- def_undef_sig:
- [ [ "ifdef"; c = UIDENT; "then"; e1 = sig_item_def_undef;
- "else"; e2 = sig_item_def_undef ->
- if List.mem c defined.val then e1 else e2
- | "ifdef"; c = UIDENT; "then"; e1 = sig_item_def_undef ->
- if List.mem c defined.val then e1 else SdNop
- | "ifndef"; c = UIDENT; "then"; e1 = sig_item_def_undef;
- "else"; e2 = sig_item_def_undef ->
- if List.mem c defined.val then e2 else e1
- | "ifndef"; c = UIDENT; "then"; e1 = sig_item_def_undef ->
- if List.mem c defined.val then SdNop else e1
- | "define"; c = UIDENT -> SdDef c
- | "undef"; c = UIDENT -> SdUnd c ] ]
- ;
- sig_item_def_undef:
- [ [ d = def_undef_sig -> d
- | si = Pcaml.sig_item -> SdStr si ] ]
- ;
-END;
-
-Pcaml.add_option "-D" (Arg.String define)
- "<string> Define for ifdef instruction."
-;
-Pcaml.add_option "-U" (Arg.String undef)
- "<string> Undefine for ifdef instruction."
-;
diff --git a/camlp4/etc/pa_lefteval.ml b/camlp4/etc/pa_lefteval.ml
deleted file mode 100644
index e96e8d34f5..0000000000
--- a/camlp4/etc/pa_lefteval.ml
+++ /dev/null
@@ -1,239 +0,0 @@
-(* camlp4r q_MLast.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-value not_impl name x =
- let desc =
- if Obj.is_block (Obj.repr x) then
- "tag = " ^ string_of_int (Obj.tag (Obj.repr x))
- else "int_val = " ^ string_of_int (Obj.magic x)
- in
- failwith ("pa_lefteval: not impl: " ^ name ^ "; " ^ desc ^ ">")
-;
-
-value rec expr_fa al =
- fun
- [ <:expr< $f$ $a$ >> -> expr_fa [a :: al] f
- | f -> (f, al) ]
-;
-
-(* generating let..in before functions calls which evaluates
- several (more than one) of their arguments *)
-
-value no_side_effects_ht =
- let ht = Hashtbl.create 73 in
- do {
- List.iter (fun s -> Hashtbl.add ht s True)
- ["<"; "="; "@"; "^"; "+"; "-"; "ref"];
- ht
- }
-;
-
-value no_side_effects =
- fun
- [ <:expr< $uid:_$ >> -> True
- | <:expr< $uid:_$ . $uid:_$ >> -> True
- | <:expr< $lid:s$ >> ->
- try Hashtbl.find no_side_effects_ht s with [ Not_found -> False ]
- | _ -> False ]
-;
-
-value rec may_side_effect =
- fun
- [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $str:_$ >> |
- <:expr< $chr:_$ >> | <:expr< $int:_$ >> | <:expr< $flo:_$ >> |
- <:expr< $_$ . $_$ >> | <:expr< fun [ $list:_$ ] >> ->
- False
- | <:expr< ($list:el$) >> -> List.exists may_side_effect el
- | <:expr< $_$ $_$ >> as e ->
- let (f, el) = expr_fa [] e in
- not (no_side_effects f) || List.exists may_side_effect el
- | _ -> True ]
-;
-
-value rec may_be_side_effect_victim =
- fun
- [ <:expr< $lid:_$ . $_$ >> -> True
- | <:expr< $uid:_$ . $e$ >> -> may_be_side_effect_victim e
- | _ -> False ]
-;
-
-value rec may_depend_on_order el =
- loop False False el where rec loop
- side_effect_found side_effect_victim_found =
- fun
- [ [e :: el] ->
- if may_side_effect e then
- if side_effect_found || side_effect_victim_found then True
- else loop True True el
- else if may_be_side_effect_victim e then
- if side_effect_found then True else loop False True el
- else loop side_effect_found side_effect_victim_found el
- | [] -> False ]
-;
-
-value gen_let_in loc expr el =
- let (pel, el) =
- loop 0 (List.rev el) where rec loop n =
- fun
- [ [e :: el] ->
- if may_side_effect e || may_be_side_effect_victim e then
- if n = 0 then
- let (pel, el) = loop 1 el in
- (pel, [expr e :: el])
- else
- let id = "xxx" ^ string_of_int n in
- let (pel, el) = loop (n + 1) el in
- ([(<:patt< $lid:id$ >>, expr e) :: pel],
- [<:expr< $lid:id$ >> :: el])
- else
- let (pel, el) = loop n el in
- (pel, [expr e :: el])
- | [] -> ([], []) ]
- in
- match List.rev el with
- [ [e :: el] -> (pel, e, el)
- | _ -> assert False ]
-;
-
-value left_eval_apply loc expr e1 e2 =
- let (f, el) = expr_fa [] <:expr< $e1$ $e2$ >> in
- if not (may_depend_on_order [f :: el]) then <:expr< $expr e1$ $expr e2$ >>
- else
- let (pel, e, el) = gen_let_in loc expr [f :: el] in
- let e = List.fold_left (fun e e1 -> <:expr< $e$ $e1$ >>) e el in
- List.fold_left (fun e (p1, e1) -> <:expr< let $p1$ = $e1$ in $e$ >>) e pel
-;
-
-value left_eval_tuple loc expr el =
- if not (may_depend_on_order el) then <:expr< ($list:List.map expr el$) >>
- else
- let (pel, e, el) = gen_let_in loc expr el in
- List.fold_left (fun e (p1, e1) -> <:expr< let $p1$ = $e1$ in $e$ >>)
- <:expr< ($list:[e :: el]$) >> pel
-;
-
-value left_eval_record loc expr lel =
- let el = List.map snd lel in
- if not (may_depend_on_order el) then
- let lel = List.map (fun (p, e) -> (p, expr e)) lel in
- <:expr< { $list:lel$ } >>
- else
- let (pel, e, el) = gen_let_in loc expr el in
- let e =
- let lel = List.combine (List.map fst lel) [e :: el] in
- <:expr< { $list:lel$ } >>
- in
- List.fold_left (fun e (p1, e1) -> <:expr< let $p1$ = $e1$ in $e$ >>) e pel
-;
-
-value left_eval_assign loc expr e1 e2 = <:expr< $e1$ := $expr e2$ >>;
-
-(* scanning the input tree, calling "left_eval_*" functions if necessary *)
-
-value map_option f =
- fun
- [ Some x -> Some (f x)
- | None -> None ]
-;
-
-value class_infos f ci =
- {MLast.ciLoc = ci.MLast.ciLoc; MLast.ciVir = ci.MLast.ciVir;
- MLast.ciPrm = ci.MLast.ciPrm; MLast.ciNam = ci.MLast.ciNam;
- MLast.ciExp = f ci.MLast.ciExp}
-;
-
-value rec expr x =
- let loc = MLast.loc_of_expr x in
- match x with
- [ <:expr< fun [ $list:pwel$ ] >> ->
- <:expr< fun [ $list:List.map match_assoc pwel$ ] >>
- | <:expr< match $e$ with [ $list:pwel$ ] >> ->
- <:expr< match $expr e$ with [ $list:List.map match_assoc pwel$ ] >>
- | <:expr< try $e$ with [ $list:pwel$ ] >> ->
- <:expr< try $expr e$ with [ $list:List.map match_assoc pwel$ ] >>
- | <:expr< let $opt:rf$ $list:pel$ in $e$ >> ->
- <:expr< let $opt:rf$ $list:List.map let_binding pel$ in $expr e$ >>
- | <:expr< let module $s$ = $me$ in $e$ >> ->
- <:expr< let module $s$ = $module_expr me$ in $expr e$ >>
- | <:expr< if $e1$ then $e2$ else $e3$ >> ->
- <:expr< if $expr e1$ then $expr e2$ else $expr e3$ >>
- | <:expr< while $e$ do { $list:el$ } >> ->
- <:expr< while $expr e$ do { $list:List.map expr el$ } >>
- | <:expr< do { $list:el$ } >> -> <:expr< do { $list:List.map expr el$ } >>
- | <:expr< $e$ # $s$ >> -> <:expr< $expr e$ # $s$ >>
- | <:expr< ($e$ : $t$) >> -> <:expr< ($expr e$ : $t$) >>
- | <:expr< $e1$ || $e2$ >> -> <:expr< $expr e1$ || $expr e2$ >>
- | <:expr< $e1$ && $e2$ >> -> <:expr< $expr e1$ && $expr e2$ >>
- | <:expr< $e1$ $e2$ >> -> left_eval_apply loc expr e1 e2
- | <:expr< ($list:el$) >> -> left_eval_tuple loc expr el
- | <:expr< { $list:lel$ } >> -> left_eval_record loc expr lel
- | <:expr< $e1$ := $e2$ >> -> left_eval_assign loc expr e1 e2
- | <:expr< $_$ . $_$ >> | <:expr< $uid:_$ >> | <:expr< $lid:_$ >> |
- <:expr< $str:_$ >> | <:expr< $chr:_$ >> | <:expr< $int:_$ >> |
- <:expr< $flo:_$ >> | <:expr< new $list:_$ >> ->
- x
- | x -> not_impl "expr" x ]
-and let_binding (p, e) = (p, expr e)
-and match_assoc (p, eo, e) = (p, map_option expr eo, expr e)
-and module_expr x =
- let loc = MLast.loc_of_module_expr x in
- match x with
- [ <:module_expr< functor ($s$ : $mt$) -> $me$ >> ->
- <:module_expr< functor ($s$ : $mt$) -> $module_expr me$ >>
- | <:module_expr< ($me$ : $mt$) >> ->
- <:module_expr< ($module_expr me$ : $mt$) >>
- | <:module_expr< struct $list:sil$ end >> ->
- <:module_expr< struct $list:List.map str_item sil$ end >>
- | <:module_expr< $_$ . $_$ >> | <:module_expr< $_$ $_$ >> |
- <:module_expr< $uid:_$ >> ->
- x ]
-and str_item x =
- let loc = MLast.loc_of_str_item x in
- match x with
- [ <:str_item< module $s$ = $me$ >> ->
- <:str_item< module $s$ = $module_expr me$ >>
- | <:str_item< value $opt:rf$ $list:pel$ >> ->
- <:str_item< value $opt:rf$ $list:List.map let_binding pel$ >>
- | <:str_item< declare $list:sil$ end >> ->
- <:str_item< declare $list:List.map str_item sil$ end >>
- | <:str_item< class $list:ce$ >> ->
- <:str_item< class $list:List.map (class_infos class_expr) ce$ >>
- | <:str_item< $exp:e$ >> -> <:str_item< $exp:expr e$ >>
- | <:str_item< open $_$ >> | <:str_item< type $list:_$ >> |
- <:str_item< exception $_$ of $list:_$ = $_$ >> |
- <:str_item< module type $_$ = $_$ >> | <:str_item< # $_$ $opt:_$ >> ->
- x
- | x -> not_impl "str_item" x ]
-and class_expr x =
- let loc = MLast.loc_of_class_expr x in
- match x with
- [ <:class_expr< object $opt:p$ $list:csil$ end >> ->
- <:class_expr< object $opt:p$ $list:List.map class_str_item csil$ end >>
- | x -> not_impl "class_expr" x ]
-and class_str_item x =
- let loc = MLast.loc_of_class_str_item x in
- match x with
- [ <:class_str_item< value $opt:mf$ $s$ = $e$ >> ->
- <:class_str_item< value $opt:mf$ $s$ = $expr e$ >>
- | <:class_str_item< method $s$ = $e$ >> ->
- <:class_str_item< method $s$ = $expr e$ >>
- | x -> not_impl "class_str_item" x ]
-;
-
-value parse_implem = Pcaml.parse_implem.val;
-value parse_implem_with_left_eval strm =
- let (r, b) = parse_implem strm in
- (List.map (fun (si, loc) -> (str_item si, loc)) r, b)
-;
-Pcaml.parse_implem.val := parse_implem_with_left_eval;
diff --git a/camlp4/etc/pa_lisp.ml b/camlp4/etc/pa_lisp.ml
deleted file mode 100644
index 653baf1ed6..0000000000
--- a/camlp4/etc/pa_lisp.ml
+++ /dev/null
@@ -1,684 +0,0 @@
-;; camlp4 ./pa_lispr.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo
-;; $Id$
-
-(open Pcaml)
-(open Stdpp)
-
-(type (choice 'a 'b) (sum (Left 'a) (Right 'b)))
-
-;; Buffer
-
-(module Buff
- (struct
- (value buff (ref (String.create 80)))
- (value store (lambda (len x)
- (if (>= len (String.length buff.val))
- (:= buff.val
- (^ buff.val
- (String.create (String.length buff.val)))))
- (:= ([] buff.val len) x)
- (succ len)))
- (value get (lambda len (String.sub buff.val 0 len)))))
-
-;; Lexer
-
-(value rec skip_to_eol
- (parser
- (((` (or '\n' '\r'))) ())
- (((` _) s) (skip_to_eol s))))
-
-(value no_ident (list '(' ')' ' ' '\t' '\n' '\r' ';'))
-
-(value rec ident
- (lambda len
- (parser
- (((` x (not (List.mem x no_ident))) s)
- (ident (Buff.store len x) s))
- (()
- (Buff.get len)))))
-
-(value rec
- string (lambda len
- (parser
- (((` '"')) (Buff.get len))
- (((` '\\') (` c) s)
- (string (Buff.store (Buff.store len '\\') c) s))
- (((` x) s) (string (Buff.store len x) s)))))
-
-(value rec
- number (lambda len
- (parser
- (((` (as (range '0' '9') c)) s)
- (number (Buff.store len c) s))
- (()
- (, "INT" (Buff.get len))))))
-
-(value char_or_quote_id
- (lambda x
- (parser
- (((` ''')) (, "CHAR" (String.make 1 x)))
- ((s)
- (let ((len (Buff.store (Buff.store 0 ''') x)))
- (, "LIDENT" (ident len s)))))))
-
-(value rec char
- (lambda len
- (parser
- (((` ''')) len)
- (((` x) s) (char (Buff.store len x) s)))))
-
-(value quote
- (parser
- (((` '\\') (len (char (Buff.store 0 '\\')))) (, "CHAR" (Buff.get len)))
- (((` x) s) (char_or_quote_id x s))))
-
-(value rec
- lexer
- (lambda kwt
- (parser bp
- (((` (or ' ' '\t' '\n' '\r')) s) (lexer kwt s))
- (((` ';') (a (semi kwt bp))) a)
- (((` '(')) (, (, "" "(") (, bp (+ bp 1))))
- (((` ')')) (, (, "" ")") (, bp (+ bp 1))))
- (((` '"') (s (string 0))) ep (, (, "STRING" s) (, bp ep)))
- (((` ''') (tok quote)) ep (, tok (, bp ep)))
- (((` '<') (tok less)) ep (, tok (, bp ep)))
- (((` (as (range '0' '9') c)) (n (number (Buff.store 0 c)))) ep
- (, n (, bp ep)))
- (((` x) (s (ident (Buff.store 0 x)))) ep
- (let ((con (try (progn (: (Hashtbl.find kwt s) unit) "")
- (Not_found
- (match x
- ((range 'A' 'Z') "UIDENT")
- ((_) "LIDENT"))))))
- (, (, con s) (, bp ep))))
- (() (, (, "EOI" "") (, bp (+ bp 1))))))
- semi
- (lambda (kwt bp)
- (parser
- (((` ';') (_ skip_to_eol) s) (lexer kwt s))
- (() ep (, (, "" ";") (, bp ep)))))
- less
- (parser
- (((` ':') (lab (label 0)) (? (` '<') "'<' expected") (q (quotation 0)))
- (, "QUOT" (^ lab (^ ":" q))))
- (() (, "LIDENT" "<")))
- label
- (lambda len
- (parser
- (((` (as (or (range 'a' 'z') (range 'A' 'Z') '_') c)) s)
- (label (Buff.store len c) s))
- (() (Buff.get len))))
- quotation
- (lambda len
- (parser
- (((` '>') s) (quotation_greater len s))
- (((` x) s) (quotation (Buff.store len x) s))
- (() (failwith "quotation not terminated"))))
- quotation_greater
- (lambda len
- (parser
- (((` '>')) (Buff.get len))
- (((a (quotation (Buff.store len '>')))) a))))
-
-(value lexer_using
- (lambda (kwt (, con prm))
- (match con
- ((or "CHAR" "EOI" "INT" "LIDENT" "QUOT" "STRING" "UIDENT") ())
- (("ANTIQUOT") ())
- (("")
- (try (Hashtbl.find kwt prm)
- (Not_found (Hashtbl.add kwt prm ()))))
- (_ (raise
- (Token.Error
- (^ "the constructor \""
- (^ con "\" is not recognized by Plexer"))))))))
-
-(value lexer_text
- (lambda (, con prm)
- (if (= con "") (^ "'" (^ prm "'"))
- (if (= prm "") con
- (^ con (^ " \"" (^ prm "\"")))))))
-
-(value lexer_gmake
- (lambda ()
- (let ((kwt (Hashtbl.create 89)))
- ({}
- (Token.tok_func (Token.lexer_func_of_parser (lexer kwt)))
- (Token.tok_using (lexer_using kwt))
- (Token.tok_removing (lambda))
- (Token.tok_match Token.default_match)
- (Token.tok_text lexer_text)
- (Token.tok_comm None)))))
-
-;; Building AST
-
-(type sexpr (sum
- (Sexpr MLast.loc (list sexpr))
- (Satom MLast.loc atom string)
- (Squot MLast.loc string string))
- atom (sum (Alid) (Auid) (Aint) (Achar) (Astring)))
-
-(value error_loc
- (lambda (loc err)
- (raise_with_loc loc (Stream.Error (^ err " expected")))))
-(value error
- (lambda (se err)
- (let ((loc (match se
- ((or (Satom loc _ _) (Sexpr loc _) (Squot loc _ _))
- loc))))
- (error_loc loc err))))
-
-(value expr_id
- (lambda (loc s)
- (match ([] s 0)
- ((range 'A' 'Z') <:expr< $uid:s$ >>)
- (_ <:expr< $lid:s$ >>))))
-
-(value patt_id
- (lambda (loc s)
- (match ([] s 0)
- ((range 'A' 'Z') <:patt< $uid:s$ >>)
- (_ <:patt< $lid:s$ >>))))
-
-(value ctyp_id
- (lambda (loc s)
- (match ([] s 0)
- (''' (let ((s (String.sub s 1 (- (String.length s) 1))))
- <:ctyp< '$s$ >>))
- ((range 'A' 'Z') <:ctyp< $uid:s$ >>)
- (_ <:ctyp< $lid:s$ >>))))
-
-(value strm_n "strm__")
-(value peek_fun (lambda loc <:expr< Stream.peek >>))
-(value junk_fun (lambda loc <:expr< Stream.junk >>))
-
-(value rec
- module_expr_se
- (lambda_match
- ((Sexpr loc (list (Satom _ Alid "struct") :: sl))
- (let ((mel (List.map str_item_se sl)))
- <:module_expr< struct $list:mel$ end >>))
- ((Satom loc Auid s)
- <:module_expr< $uid:s$ >>)
- ((se)
- (error se "module expr")))
- str_item_se
- (lambda se
- (match se
- ((or (Satom loc _ _) (Squot loc _ _))
- (let ((e (expr_se se))) <:str_item< $exp:e$ >>))
- ((Sexpr loc (list (Satom _ Alid "module") (Satom _ Auid i) se))
- (let ((mb (module_binding_se se)))
- <:str_item< module $i$ = $mb$ >>))
- ((Sexpr loc (list (Satom _ Alid "open") (Satom _ Auid s)))
- (let ((s (list s)))
- <:str_item< open $s$ >>))
- ((Sexpr loc (list (Satom _ Alid "type") :: sel))
- (let ((tdl (type_declaration_list_se sel)))
- <:str_item< type $list:tdl$ >>))
- ((Sexpr loc (list (Satom _ Alid "value") :: sel))
- (let* (((, r sel)
- (match sel
- ((list (Satom _ Alid "rec") :: sel) (, True sel))
- ((_) (, False sel))))
- (lbs (value_binding_se sel)))
- <:str_item< value $opt:r$ $list:lbs$ >>))
- ((Sexpr loc _)
- (let ((e (expr_se se)))
- <:str_item< $exp:e$ >>))))
- value_binding_se
- (lambda_match
- ((list se1 se2 :: sel)
- (list (, (ipatt_se se1) (expr_se se2)) :: (value_binding_se sel)))
- ((list) (list))
- ((list se :: _) (error se "value_binding")))
- module_binding_se
- (lambda se (module_expr_se se))
- expr_se
- (lambda_match
- ((Satom loc (or Alid Auid) s)
- (expr_ident_se loc s))
- ((Satom loc Aint s)
- <:expr< $int:s$ >>)
- ((Satom loc Achar s)
- (<:expr< $chr:s$ >>))
- ((Satom loc Astring s)
- <:expr< $str:s$ >>)
- ((Sexpr loc (list))
- <:expr< () >>)
- ((Sexpr loc (list (Satom _ Alid "if") se se1))
- (let* ((e (expr_se se))
- (e1 (expr_se se1)))
- <:expr< if $e$ then $e1$ else () >>))
- ((Sexpr loc (list (Satom _ Alid "if") se se1 se2))
- (let* ((e (expr_se se))
- (e1 (expr_se se1))
- (e2 (expr_se se2)))
- <:expr< if $e$ then $e1$ else $e2$ >>))
- ((Sexpr loc (list (Satom loc1 Alid "lambda"))) <:expr< fun [] >>)
- ((Sexpr loc (list (Satom loc1 Alid "lambda") sep :: sel))
- (let ((e (progn_se loc1 sel)))
- (match (ipatt_opt_se sep)
- ((Left p) <:expr< fun $p$ -> $e$ >>)
- ((Right (, se sel))
- (List.fold_right
- (lambda (se e)
- (let ((p (ipatt_se se))) <:expr< fun $p$ -> $e$ >>))
- (list se :: sel) e)))))
- ((Sexpr loc (list (Satom _ Alid "lambda_match") :: sel))
- (let ((pel (List.map (match_case loc) sel)))
- <:expr< fun [ $list:pel$ ] >>))
- ((Sexpr loc (list (Satom _ Alid "let") :: sel))
- (let (((, r sel)
- (match sel
- ((list (Satom _ Alid "rec") :: sel) (, True sel))
- ((_) (, False sel)))))
- (match sel
- ((list (Sexpr _ sel1) :: sel2)
- (let* ((lbs (List.map let_binding_se sel1))
- (e (progn_se loc sel2)))
- <:expr< let $opt:r$ $list:lbs$ in $e$ >>))
- ((list se :: _) (error se "let_binding"))
- ((_) (error_loc loc "let_binding")))))
- ((Sexpr loc (list (Satom _ Alid "let*") :: sel))
- (match sel
- ((list (Sexpr _ sel1) :: sel2)
- (List.fold_right
- (lambda (se ek)
- (let (((, p e) (let_binding_se se)))
- <:expr< let $p$ = $e$ in $ek$ >>))
- sel1 (progn_se loc sel2)))
- ((list se :: _) (error se "let_binding"))
- ((_) (error_loc loc "let_binding"))))
- ((Sexpr loc (list (Satom _ Alid "match") se :: sel))
- (let* ((e (expr_se se))
- (pel (List.map (match_case loc) sel)))
- <:expr< match $e$ with [ $list:pel$ ] >>))
- ((Sexpr loc (list (Satom _ Alid "parser") :: sel))
- (let ((e (match sel
- ((list (as (Satom _ _ _) se) :: sel)
- (let* ((p (patt_se se))
- (pc (parser_cases_se loc sel)))
- <:expr< let $p$ = Stream.count $lid:strm_n$ in $pc$ >>))
- (_ (parser_cases_se loc sel)))))
- <:expr< fun ($lid:strm_n$ : Stream.t _) -> $e$ >>))
- ((Sexpr loc (list (Satom _ Alid "try") se :: sel))
- (let* ((e (expr_se se))
- (pel (List.map (match_case loc) sel)))
- <:expr< try $e$ with [ $list:pel$ ] >>))
- ((Sexpr loc (list (Satom _ Alid "progn") :: sel))
- (let ((el (List.map expr_se sel)))
- <:expr< do { $list:el$ } >>))
- ((Sexpr loc (list (Satom _ Alid "while") se :: sel))
- (let* ((e (expr_se se))
- (el (List.map expr_se sel)))
- <:expr< while $e$ do { $list:el$ } >>))
- ((Sexpr loc (list (Satom _ Alid ":=") se1 se2))
- (let ((e2 (expr_se se2)))
- (match (expr_se se1)
- (<:expr< $uid:"()"$ $e1$ $i$ >> <:expr< $e1$.($i$) := $e2$ >>)
- (e1 <:expr< $e1$ := $e2$ >>))))
- ((Sexpr loc (list (Satom _ Alid "[]") se1 se2))
- (let* ((e1 (expr_se se1)) (e2 (expr_se se2))) <:expr< $e1$.[$e2$] >>))
- ((Sexpr loc (list (Satom _ Alid ",") :: sel))
- (let ((el (List.map expr_se sel))) <:expr< ( $list:el$ ) >>))
- ((Sexpr loc (list (Satom _ Alid "{}") :: sel))
- (let ((lel (List.map (label_expr_se loc) sel))) <:expr< { $list:lel$ } >>))
- ((Sexpr loc (list (Satom _ Alid ":") se1 se2))
- (let* ((e (expr_se se1))
- (t (ctyp_se se2)))
- <:expr< ( $e$ : $t$ ) >>))
- ((Sexpr loc (list (Satom _ Alid "list") :: sel))
- (let rec ((loop
- (lambda_match
- ((list) <:expr< [] >>)
- ((list se1 (Satom _ Alid "::") se2)
- (let* ((e (expr_se se1))
- (el (expr_se se2)))
- <:expr< [$e$ :: $el$] >>))
- ((list se :: sel)
- (let* ((e (expr_se se))
- (el (loop sel)))
- <:expr< [$e$ :: $el$] >>)))))
- (loop sel)))
- ((Sexpr loc (list se :: sel))
- (List.fold_left
- (lambda (e se) (let ((e1 (expr_se se))) <:expr< $e$ $e1$ >>))
- (expr_se se) sel))
- ((Squot loc typ txt)
- (Pcaml.handle_expr_quotation loc (, typ txt))))
- progn_se
- (lambda loc
- (lambda_match
- ((list) <:expr< () >>)
- ((list se) (expr_se se))
- ((sel) (let ((el (List.map expr_se sel))) <:expr< do { $list:el$ } >>))))
- let_binding_se
- (lambda_match
- ((Sexpr loc (list se1 se2)) (, (ipatt_se se1) (expr_se se2)))
- (se (error se "let_binding")))
- match_case
- (lambda loc
- (lambda_match
- ((Sexpr _ (list se1 se2))
- (, (patt_se se1) None (expr_se se2)))
- ((Sexpr _ (list se1 sew se2))
- (, (patt_se se1) (Some (expr_se sew)) (expr_se se2)))
- (se (error se "match_case"))))
- label_expr_se
- (lambda loc
- (lambda_match
- ((Sexpr _ (list se1 se2)) (, (patt_se se1) (expr_se se2)))
- (se (error se ("label_expr")))))
- expr_ident_se
- (lambda (loc s)
- (if (= ([] s 0) '<')
- <:expr< $lid:s$ >>
- (let rec
- ((loop
- (lambda (ibeg i)
- (if (= i (String.length s))
- (if (> i ibeg)
- (expr_id loc (String.sub s ibeg (- i ibeg)))
- (raise_with_loc (, (- (+ (fst loc) i) 1)
- (+ (fst loc) i))
- (Stream.Error "expr expected")))
- (if (= ([] s i) '.')
- (if (> i ibeg)
- (let* ((e1 (expr_id
- loc
- (String.sub s ibeg (- i ibeg))))
- (e2 (loop (+ i 1) (+ i 1))))
- <:expr< $e1$ . $e2$ >>)
- (raise_with_loc (, (- (+ (fst loc) i) 1)
- (+ (+ (fst loc) i) 1))
- (Stream.Error "expr expected")))
- (loop ibeg (+ i 1)))))))
- (loop 0 0))))
- parser_cases_se
- (lambda loc
- (lambda_match
- ((list) <:expr< raise Stream.Failure >>)
- ((list (Sexpr loc (list (Sexpr _ spsel) :: act)) :: sel)
- (let* ((ekont (lambda _ (parser_cases_se loc sel)))
- (act (match act
- ((list se) (expr_se se))
- ((list sep se)
- (let* ((p (patt_se sep))
- (e (expr_se se)))
- <:expr< let $p$ = Stream.count $lid:strm_n$ in $e$ >>))
- (_ (error_loc loc "parser_case")))))
- (stream_pattern_se loc act ekont spsel)))
- ((list se :: _)
- (error se "parser_case"))))
- stream_pattern_se
- (lambda (loc act ekont)
- (lambda_match
- ((list) act)
- ((list se :: sel)
- (let* ((ckont (lambda err <:expr< raise (Stream.Error $err$) >>))
- (skont (stream_pattern_se loc act ckont sel)))
- (stream_pattern_component skont ekont <:expr< "" >> se)))))
- stream_pattern_component
- (lambda (skont ekont err)
- (lambda_match
- ((Sexpr loc (list (Satom _ Alid "`") se :: wol))
- (let* ((wo (match wol
- ((list se) (Some (expr_se se)))
- ((list) None)
- (_ (error_loc loc "stream_pattern_component"))))
- (e (peek_fun loc))
- (p (patt_se se))
- (j (junk_fun loc))
- (k (ekont err)))
- <:expr< match $e$ $lid:strm_n$ with
- [ Some $p$ $when:wo$ -> do { $j$ $lid:strm_n$ ; $skont$ }
- | _ -> $k$ ] >>))
- ((Sexpr loc (list se1 se2))
- (let* ((p (patt_se se1))
- (e (let ((e (expr_se se2)))
- <:expr< try Some ($e$ $lid:strm_n$) with [ Stream.Failure -> None ] >>))
- (k (ekont err)))
- <:expr< match $e$ with [ Some $p$ -> $skont$ | _ -> $k$ ] >>))
- ((Sexpr loc (list (Satom _ Alid "?") se1 se2))
- (stream_pattern_component skont ekont (expr_se se2) se1))
- ((Satom loc Alid s)
- <:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >>)
- (se
- (error se "stream_pattern_component"))))
- patt_se
- (lambda_match
- ((Satom loc Alid "_") <:patt< _ >>)
- ((Satom loc (or Alid Auid) s) (patt_ident_se loc s))
- ((Satom loc Aint s)
- <:patt< $int:s$ >>)
- ((Satom loc Achar s)
- (<:patt< $chr:s$ >>))
- ((Satom loc Astring s)
- <:patt< $str:s$ >>)
- ((Sexpr loc (list (Satom _ Alid "or") se :: sel))
- (List.fold_left
- (lambda (p se) (let ((p1 (patt_se se))) <:patt< $p$ | $p1$ >>))
- (patt_se se) sel))
- ((Sexpr loc (list (Satom _ Alid "range") se1 se2))
- (let* ((p1 (patt_se se1))
- (p2 (patt_se se2)))
- <:patt< $p1$ .. $p2$ >>))
- ((Sexpr loc (list (Satom _ Alid ",") :: sel))
- (let ((pl (List.map patt_se sel))) <:patt< ( $list:pl$ ) >>))
- ((Sexpr loc (list (Satom _ Alid "as") se1 se2))
- (let* ((p1 (patt_se se1))
- (p2 (patt_se se2)))
- <:patt< ($p1$ as $p2$) >>))
- ((Sexpr loc (list (Satom _ Alid "list") :: sel))
- (let rec ((loop
- (lambda_match
- ((list) <:patt< [] >>)
- ((list se1 (Satom _ Alid "::") se2)
- (let* ((p (patt_se se1))
- (pl (patt_se se2)))
- <:patt< [$p$ :: $pl$] >>))
- ((list se :: sel)
- (let* ((p (patt_se se))
- (pl (loop sel)))
- <:patt< [$p$ :: $pl$] >>)))))
- (loop sel)))
- ((Sexpr loc (list se :: sel))
- (List.fold_left
- (lambda (p se) (let ((p1 (patt_se se))) <:patt< $p$ $p1$ >>))
- (patt_se se) sel))
- ((Sexpr loc (list)) <:patt< () >>)
- ((Squot loc typ txt) (Pcaml.handle_patt_quotation loc (, typ txt))))
- patt_ident_se
- (lambda (loc s)
- (let rec
- ((loop
- (lambda (ibeg i)
- (if (= i (String.length s))
- (if (> i ibeg)
- (patt_id loc (String.sub s ibeg (- i ibeg)))
- (raise_with_loc (, (- (+ (fst loc) i) 1)
- (+ (fst loc) i))
- (Stream.Error "patt expected")))
- (if (= ([] s i) '.')
- (if (> i ibeg)
- (let* ((p1 (patt_id
- loc
- (String.sub s ibeg (- i ibeg))))
- (p2 (loop (+ i 1) (+ i 1))))
- <:patt< $p1$ . $p2$ >>)
- (raise_with_loc (, (- (+ (fst loc) i) 1)
- (+ (+ (fst loc) i) 1))
- (Stream.Error "patt expected")))
- (loop ibeg (+ i 1)))))))
- (loop 0 0)))
- ipatt_se
- (lambda se
- (match (ipatt_opt_se se)
- ((Left p) p)
- ((Right (, se _))
- (error se "ipatt"))))
- ipatt_opt_se
- (lambda_match
- ((Satom loc Alid "_") (Left <:patt< _ >>))
- ((Satom loc Alid s) (Left <:patt< $lid:s$ >>))
- ((Sexpr loc (list (Satom _ Alid ",") :: sel))
- (let ((pl (List.map ipatt_se sel))) (Left <:patt< ( $list:pl$ ) >>)))
- ((Sexpr loc (list)) (Left <:patt< () >>))
- ((Sexpr loc (list se :: sel)) (Right (, se sel)))
- (se (error se "ipatt")))
- type_declaration_list_se
- (lambda_match
- ((list se1 se2 :: sel)
- (let (((, n1 loc1 tpl)
- (match se1
- ((Sexpr _ (list (Satom loc Alid n) :: sel))
- (, n loc (List.map type_parameter_se sel)))
- ((Satom loc Alid n)
- (, n loc (list)))
- ((se)
- (error se "type declaration")))))
- (list (, (, loc1 n1) tpl (ctyp_se se2) (list)) ::
- (type_declaration_list_se sel))))
- ((list) (list))
- ((list se :: _) (error se "type_declaration")))
- type_parameter_se
- (lambda_match
- ((Satom _ Alid s) (&& (>= (String.length s) 2) (= ([] s 0) '''))
- (, (String.sub s 1 (- (String.length s) 1)) (, False False)))
- (se
- (error se "type_parameter")))
- ctyp_se
- (lambda_match
- ((Sexpr loc (list (Satom _ Alid "sum") :: sel))
- (let ((cdl (List.map constructor_declaration_se sel)))
- <:ctyp< [ $list:cdl$ ] >>))
- ((Sexpr loc (list se :: sel))
- (List.fold_left
- (lambda (t se) (let ((t2 (ctyp_se se))) <:ctyp< $t$ $t2$ >>))
- (ctyp_se se) sel))
- ((Satom loc (or Alid Auid) s)
- (ctyp_ident_se loc s))
- (se
- (error se "ctyp")))
- ctyp_ident_se
- (lambda (loc s)
- (let rec
- ((loop (lambda (ibeg i)
- (if (= i (String.length s))
- (if (> i ibeg)
- (ctyp_id loc (String.sub s ibeg (- i ibeg)))
- (raise_with_loc (, (- (+ (fst loc) i) 1)
- (+ (fst loc) i))
- (Stream.Error "ctyp expected")))
- (if (= ([] s i) '.')
- (if (> i ibeg)
- (let* ((t1 (ctyp_id
- loc (String.sub s ibeg (- i ibeg))))
- (t2 (loop (+ i 1) (+ i 1))))
- <:ctyp< $t1$ . $t2$ >>)
- (raise_with_loc (, (- (+ (fst loc) i) 1)
- (+ (+ (fst loc) i) 1))
- (Stream.Error "ctyp expected")))
- (loop ibeg (+ i 1)))))))
- (loop 0 0)))
- constructor_declaration_se
- (lambda_match
- ((Sexpr loc (list (Satom _ Auid ci) :: sel))
- (, loc ci (List.map ctyp_se sel)))
- (se
- (error se "constructor_declaration"))))
-
-(value top_phrase_se
- (lambda se
- (match se
- ((or (Satom loc _ _) (Squot loc _ _)) (str_item_se se))
- ((Sexpr loc (list (Satom _ Alid s) :: sl))
- (if (= ([] s 0) '#')
- (let ((n (String.sub s 1 (- (String.length s) 1))))
- (match sl
- ((list (Satom _ Astring s))
- (MLast.StDir loc n (Some <:expr< $str:s$ >>)))
- (_ (match ()))))
- (str_item_se se)))
- ((Sexpr loc _) (str_item_se se)))))
-
-;; Parser
-
-(value phony_quot (ref False))
-(Pcaml.add_option "-phony_quot" (Arg.Set phony_quot) "phony quotations")
-
-(:= Pcaml.no_constructors_arity.val False)
-
-(progn
- (Grammar.Unsafe.gram_reinit gram (lexer_gmake ()))
- (Grammar.Unsafe.clear_entry interf)
- (Grammar.Unsafe.clear_entry implem)
- (Grammar.Unsafe.clear_entry top_phrase)
- (Grammar.Unsafe.clear_entry use_file)
- (Grammar.Unsafe.clear_entry module_type)
- (Grammar.Unsafe.clear_entry module_expr)
- (Grammar.Unsafe.clear_entry sig_item)
- (Grammar.Unsafe.clear_entry str_item)
- (Grammar.Unsafe.clear_entry expr)
- (Grammar.Unsafe.clear_entry patt)
- (Grammar.Unsafe.clear_entry ctyp)
- (Grammar.Unsafe.clear_entry let_binding)
- (Grammar.Unsafe.clear_entry class_type)
- (Grammar.Unsafe.clear_entry class_expr)
- (Grammar.Unsafe.clear_entry class_sig_item)
- (Grammar.Unsafe.clear_entry class_str_item))
-
-(:= Pcaml.parse_interf.val (Grammar.Entry.parse interf))
-(:= Pcaml.parse_implem.val (Grammar.Entry.parse implem))
-
-(value sexpr (Grammar.Entry.create gram "sexpr"))
-(value atom (Grammar.Entry.create gram "atom"))
-
-EXTEND
- implem :
- [ [ st = LIST0 [ s = str_item -> (, s loc) ]; EOI -> (, st False) ] ]
- ;
- top_phrase :
- [ [ se = sexpr -> (Some (top_phrase_se se))
- | EOI -> None ] ]
- ;
- use_file :
- [ [ l = LIST0 sexpr; EOI -> (, (List.map top_phrase_se l) False) ] ]
- ;
- str_item :
- [ [ se = sexpr -> (str_item_se se)
- | e = expr -> <:str_item< $exp:e$ >> ] ]
- ;
- expr :
- [ "top"
- [ se = sexpr -> (expr_se se) ] ]
- ;
- patt :
- [ [ se = sexpr -> (patt_se se) ] ]
- ;
- sexpr :
- [ [ "("; sl = LIST0 sexpr; ")" -> (Sexpr loc sl)
- | a = atom -> (Satom loc Alid a)
- | s = LIDENT -> (Satom loc Alid s)
- | s = UIDENT -> (Satom loc Auid s)
- | s = INT -> (Satom loc Aint s)
- | s = CHAR -> (Satom loc Achar s)
- | s = STRING -> (Satom loc Astring s)
- | s = QUOT ->
- (let* ((i (String.index s ':'))
- (typ (String.sub s 0 i))
- (txt (String.sub s (+ i 1) (- (- (String.length s) i) 1))))
- (if phony_quot.val
- (Satom loc Alid (^ "<:" (^ typ (^ "<" (^ txt ">>")))))
- (Squot loc typ txt))) ] ]
- ;
- atom :
- [ [ "_" -> "_"
- | "," -> ","
- | "=" -> "="
- | ":" -> ":"
- | "." -> "." ] ]
- ;
-END
diff --git a/camlp4/etc/pa_lispr.ml b/camlp4/etc/pa_lispr.ml
deleted file mode 100644
index fb150e2096..0000000000
--- a/camlp4/etc/pa_lispr.ml
+++ /dev/null
@@ -1,665 +0,0 @@
-(* camlp4 pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *)
-(* File generated by pretty print; do not edit! *)
-
-open Pcaml;
-open Stdpp;
-
-type choice 'a 'b =
- [ Left of 'a
- | Right of 'b ]
-;
-
-(* Buffer *)
-
-module Buff =
- struct
- value buff = ref (String.create 80);
- value store len x =
- do {
- if len >= String.length buff.val then
- buff.val := buff.val ^ String.create (String.length buff.val)
- else ();
- buff.val.[len] := x;
- succ len
- }
- ;
- value get len = String.sub buff.val 0 len;
- end
-;
-
-(* Lexer *)
-
-value rec skip_to_eol =
- parser
- [ [: `'\n' | '\r' :] -> ()
- | [: `_; s :] -> skip_to_eol s ]
-;
-
-value no_ident = ['('; ')'; ' '; '\t'; '\n'; '\r'; ';'];
-
-value rec ident len =
- parser
- [ [: `x when not (List.mem x no_ident); s :] -> ident (Buff.store len x) s
- | [: :] -> Buff.get len ]
-;
-
-value rec string len =
- parser
- [ [: `'"' :] -> Buff.get len
- | [: `'\\'; `c; s :] -> string (Buff.store (Buff.store len '\\') c) s
- | [: `x; s :] -> string (Buff.store len x) s ]
-;
-
-value rec number len =
- parser
- [ [: `('0'..'9' as c); s :] -> number (Buff.store len c) s
- | [: :] -> ("INT", Buff.get len) ]
-;
-
-value char_or_quote_id x =
- parser
- [ [: `''' :] -> ("CHAR", String.make 1 x)
- | [: s :] ->
- let len = Buff.store (Buff.store 0 ''') x in
- ("LIDENT", ident len s) ]
-;
-
-value rec char len =
- parser
- [ [: `''' :] -> len
- | [: `x; s :] -> char (Buff.store len x) s ]
-;
-
-value quote =
- parser
- [ [: `'\\'; len = char (Buff.store 0 '\\') :] -> ("CHAR", Buff.get len)
- | [: `x; s :] -> char_or_quote_id x s ]
-;
-
-value rec lexer kwt =
- parser bp
- [ [: `' ' | '\t' | '\n' | '\r'; s :] -> lexer kwt s
- | [: `';'; a = semi kwt bp :] -> a
- | [: `'(' :] -> (("", "("), (bp, bp + 1))
- | [: `')' :] -> (("", ")"), (bp, bp + 1))
- | [: `'"'; s = string 0 :] ep -> (("STRING", s), (bp, ep))
- | [: `'''; tok = quote :] ep -> (tok, (bp, ep))
- | [: `'<'; tok = less :] ep -> (tok, (bp, ep))
- | [: `('0'..'9' as c); n = number (Buff.store 0 c) :] ep -> (n, (bp, ep))
- | [: `x; s = ident (Buff.store 0 x) :] ep ->
- let con =
- try do { (Hashtbl.find kwt s : unit); "" } with
- [ Not_found ->
- match x with
- [ 'A'..'Z' -> "UIDENT"
- | _ -> "LIDENT" ] ]
- in
- ((con, s), (bp, ep))
- | [: :] -> (("EOI", ""), (bp, bp + 1)) ]
-and semi kwt bp =
- parser
- [ [: `';'; _ = skip_to_eol; s :] -> lexer kwt s
- | [: :] ep -> (("", ";"), (bp, ep)) ]
-and less =
- parser
- [ [: `':'; lab = label 0; `'<' ? "'<' expected"; q = quotation 0 :] ->
- ("QUOT", lab ^ ":" ^ q)
- | [: :] -> ("LIDENT", "<") ]
-and label len =
- parser
- [ [: `('a'..'z' | 'A'..'Z' | '_' as c); s :] -> label (Buff.store len c) s
- | [: :] -> Buff.get len ]
-and quotation len =
- parser
- [ [: `'>'; s :] -> quotation_greater len s
- | [: `x; s :] -> quotation (Buff.store len x) s
- | [: :] -> failwith "quotation not terminated" ]
-and quotation_greater len =
- parser
- [ [: `'>' :] -> Buff.get len
- | [: a = quotation (Buff.store len '>') :] -> a ]
-;
-
-value lexer_using kwt (con, prm) =
- match con with
- [ "CHAR" | "EOI" | "INT" | "LIDENT" | "QUOT" | "STRING" | "UIDENT" -> ()
- | "ANTIQUOT" -> ()
- | "" ->
- try Hashtbl.find kwt prm with [ Not_found -> Hashtbl.add kwt prm () ]
- | _ ->
- raise
- (Token.Error
- ("the constructor \"" ^ con ^ "\" is not recognized by Plexer")) ]
-;
-
-value lexer_text (con, prm) =
- if con = "" then "'" ^ prm ^ "'"
- else if prm = "" then con
- else con ^ " \"" ^ prm ^ "\""
-;
-
-value lexer_gmake () =
- let kwt = Hashtbl.create 89 in
- {Token.tok_func = Token.lexer_func_of_parser (lexer kwt);
- Token.tok_using = lexer_using kwt; Token.tok_removing = fun [];
- Token.tok_match = Token.default_match; Token.tok_text = lexer_text;
- Token.tok_comm = None}
-;
-
-(* Building AST *)
-
-type sexpr =
- [ Sexpr of MLast.loc and list sexpr
- | Satom of MLast.loc and atom and string
- | Squot of MLast.loc and string and string ]
-and atom =
- [ Alid
- | Auid
- | Aint
- | Achar
- | Astring ]
-;
-
-value error_loc loc err =
- raise_with_loc loc (Stream.Error (err ^ " expected"))
-;
-value error se err =
- let loc =
- match se with [ Satom loc _ _ | Sexpr loc _ | Squot loc _ _ -> loc ]
- in
- error_loc loc err
-;
-
-value expr_id loc s =
- match s.[0] with
- [ 'A'..'Z' -> <:expr< $uid:s$ >>
- | _ -> <:expr< $lid:s$ >> ]
-;
-
-value patt_id loc s =
- match s.[0] with
- [ 'A'..'Z' -> <:patt< $uid:s$ >>
- | _ -> <:patt< $lid:s$ >> ]
-;
-
-value ctyp_id loc s =
- match s.[0] with
- [ ''' ->
- let s = String.sub s 1 (String.length s - 1) in
- <:ctyp< '$s$ >>
- | 'A'..'Z' -> <:ctyp< $uid:s$ >>
- | _ -> <:ctyp< $lid:s$ >> ]
-;
-
-value strm_n = "strm__";
-value peek_fun loc = <:expr< Stream.peek >>;
-value junk_fun loc = <:expr< Stream.junk >>;
-
-value rec module_expr_se =
- fun
- [ Sexpr loc [Satom _ Alid "struct" :: sl] ->
- let mel = List.map str_item_se sl in
- <:module_expr< struct $list:mel$ end >>
- | Satom loc Auid s -> <:module_expr< $uid:s$ >>
- | se -> error se "module expr" ]
-and str_item_se se =
- match se with
- [ Satom loc _ _ | Squot loc _ _ ->
- let e = expr_se se in
- <:str_item< $exp:e$ >>
- | Sexpr loc [Satom _ Alid "module"; Satom _ Auid i; se] ->
- let mb = module_binding_se se in
- <:str_item< module $i$ = $mb$ >>
- | Sexpr loc [Satom _ Alid "open"; Satom _ Auid s] ->
- let s = [s] in
- <:str_item< open $s$ >>
- | Sexpr loc [Satom _ Alid "type" :: sel] ->
- let tdl = type_declaration_list_se sel in
- <:str_item< type $list:tdl$ >>
- | Sexpr loc [Satom _ Alid "value" :: sel] ->
- let (r, sel) =
- match sel with
- [ [Satom _ Alid "rec" :: sel] -> (True, sel)
- | _ -> (False, sel) ]
- in
- let lbs = value_binding_se sel in
- <:str_item< value $opt:r$ $list:lbs$ >>
- | Sexpr loc _ ->
- let e = expr_se se in
- <:str_item< $exp:e$ >> ]
-and value_binding_se =
- fun
- [ [se1; se2 :: sel] -> [(ipatt_se se1, expr_se se2) :: value_binding_se sel]
- | [] -> []
- | [se :: _] -> error se "value_binding" ]
-and module_binding_se se = module_expr_se se
-and expr_se =
- fun
- [ Satom loc (Alid | Auid) s -> expr_ident_se loc s
- | Satom loc Aint s -> <:expr< $int:s$ >>
- | Satom loc Achar s -> <:expr< $chr:s$ >>
- | Satom loc Astring s -> <:expr< $str:s$ >>
- | Sexpr loc [] -> <:expr< () >>
- | Sexpr loc [Satom _ Alid "if"; se; se1] ->
- let e = expr_se se in
- let e1 = expr_se se1 in
- <:expr< if $e$ then $e1$ else () >>
- | Sexpr loc [Satom _ Alid "if"; se; se1; se2] ->
- let e = expr_se se in
- let e1 = expr_se se1 in
- let e2 = expr_se se2 in
- <:expr< if $e$ then $e1$ else $e2$ >>
- | Sexpr loc [Satom loc1 Alid "lambda"] -> <:expr< fun [] >>
- | Sexpr loc [Satom loc1 Alid "lambda"; sep :: sel] ->
- let e = progn_se loc1 sel in
- match ipatt_opt_se sep with
- [ Left p -> <:expr< fun $p$ -> $e$ >>
- | Right (se, sel) ->
- List.fold_right
- (fun se e ->
- let p = ipatt_se se in
- <:expr< fun $p$ -> $e$ >>)
- [se :: sel] e ]
- | Sexpr loc [Satom _ Alid "lambda_match" :: sel] ->
- let pel = List.map (match_case loc) sel in
- <:expr< fun [ $list:pel$ ] >>
- | Sexpr loc [Satom _ Alid "let" :: sel] ->
- let (r, sel) =
- match sel with
- [ [Satom _ Alid "rec" :: sel] -> (True, sel)
- | _ -> (False, sel) ]
- in
- match sel with
- [ [Sexpr _ sel1 :: sel2] ->
- let lbs = List.map let_binding_se sel1 in
- let e = progn_se loc sel2 in
- <:expr< let $opt:r$ $list:lbs$ in $e$ >>
- | [se :: _] -> error se "let_binding"
- | _ -> error_loc loc "let_binding" ]
- | Sexpr loc [Satom _ Alid "let*" :: sel] ->
- match sel with
- [ [Sexpr _ sel1 :: sel2] ->
- List.fold_right
- (fun se ek ->
- let (p, e) = let_binding_se se in
- <:expr< let $p$ = $e$ in $ek$ >>)
- sel1 (progn_se loc sel2)
- | [se :: _] -> error se "let_binding"
- | _ -> error_loc loc "let_binding" ]
- | Sexpr loc [Satom _ Alid "match"; se :: sel] ->
- let e = expr_se se in
- let pel = List.map (match_case loc) sel in
- <:expr< match $e$ with [ $list:pel$ ] >>
- | Sexpr loc [Satom _ Alid "parser" :: sel] ->
- let e =
- match sel with
- [ [(Satom _ _ _ as se) :: sel] ->
- let p = patt_se se in
- let pc = parser_cases_se loc sel in
- <:expr< let $p$ = Stream.count $lid:strm_n$ in $pc$ >>
- | _ -> parser_cases_se loc sel ]
- in
- <:expr< fun ($lid:strm_n$ : Stream.t _) -> $e$ >>
- | Sexpr loc [Satom _ Alid "try"; se :: sel] ->
- let e = expr_se se in
- let pel = List.map (match_case loc) sel in
- <:expr< try $e$ with [ $list:pel$ ] >>
- | Sexpr loc [Satom _ Alid "progn" :: sel] ->
- let el = List.map expr_se sel in
- <:expr< do { $list:el$ } >>
- | Sexpr loc [Satom _ Alid "while"; se :: sel] ->
- let e = expr_se se in
- let el = List.map expr_se sel in
- <:expr< while $e$ do { $list:el$ } >>
- | Sexpr loc [Satom _ Alid ":="; se1; se2] ->
- let e2 = expr_se se2 in
- match expr_se se1 with
- [ <:expr< $uid:"()"$ $e1$ $i$ >> -> <:expr< $e1$.($i$) := $e2$ >>
- | e1 -> <:expr< $e1$ := $e2$ >> ]
- | Sexpr loc [Satom _ Alid "[]"; se1; se2] ->
- let e1 = expr_se se1 in
- let e2 = expr_se se2 in
- <:expr< $e1$.[$e2$] >>
- | Sexpr loc [Satom _ Alid "," :: sel] ->
- let el = List.map expr_se sel in
- <:expr< ( $list:el$ ) >>
- | Sexpr loc [Satom _ Alid "{}" :: sel] ->
- let lel = List.map (label_expr_se loc) sel in
- <:expr< { $list:lel$ } >>
- | Sexpr loc [Satom _ Alid ":"; se1; se2] ->
- let e = expr_se se1 in
- let t = ctyp_se se2 in
- <:expr< ( $e$ : $t$ ) >>
- | Sexpr loc [Satom _ Alid "list" :: sel] ->
- let rec loop =
- fun
- [ [] -> <:expr< [] >>
- | [se1; Satom _ Alid "::"; se2] ->
- let e = expr_se se1 in
- let el = expr_se se2 in
- <:expr< [$e$ :: $el$] >>
- | [se :: sel] ->
- let e = expr_se se in
- let el = loop sel in
- <:expr< [$e$ :: $el$] >> ]
- in
- loop sel
- | Sexpr loc [se :: sel] ->
- List.fold_left
- (fun e se ->
- let e1 = expr_se se in
- <:expr< $e$ $e1$ >>)
- (expr_se se) sel
- | Squot loc typ txt -> Pcaml.handle_expr_quotation loc (typ, txt) ]
-and progn_se loc =
- fun
- [ [] -> <:expr< () >>
- | [se] -> expr_se se
- | sel ->
- let el = List.map expr_se sel in
- <:expr< do { $list:el$ } >> ]
-and let_binding_se =
- fun
- [ Sexpr loc [se1; se2] -> (ipatt_se se1, expr_se se2)
- | se -> error se "let_binding" ]
-and match_case loc =
- fun
- [ Sexpr _ [se1; se2] -> (patt_se se1, None, expr_se se2)
- | Sexpr _ [se1; sew; se2] -> (patt_se se1, Some (expr_se sew), expr_se se2)
- | se -> error se "match_case" ]
-and label_expr_se loc =
- fun
- [ Sexpr _ [se1; se2] -> (patt_se se1, expr_se se2)
- | se -> error se "label_expr" ]
-and expr_ident_se loc s =
- if s.[0] = '<' then <:expr< $lid:s$ >>
- else
- let rec loop ibeg i =
- if i = String.length s then
- if i > ibeg then expr_id loc (String.sub s ibeg (i - ibeg))
- else
- raise_with_loc (fst loc + i - 1, fst loc + i)
- (Stream.Error "expr expected")
- else if s.[i] = '.' then
- if i > ibeg then
- let e1 = expr_id loc (String.sub s ibeg (i - ibeg)) in
- let e2 = loop (i + 1) (i + 1) in
- <:expr< $e1$ . $e2$ >>
- else
- raise_with_loc (fst loc + i - 1, fst loc + i + 1)
- (Stream.Error "expr expected")
- else loop ibeg (i + 1)
- in
- loop 0 0
-and parser_cases_se loc =
- fun
- [ [] -> <:expr< raise Stream.Failure >>
- | [Sexpr loc [Sexpr _ spsel :: act] :: sel] ->
- let ekont _ = parser_cases_se loc sel in
- let act =
- match act with
- [ [se] -> expr_se se
- | [sep; se] ->
- let p = patt_se sep in
- let e = expr_se se in
- <:expr< let $p$ = Stream.count $lid:strm_n$ in $e$ >>
- | _ -> error_loc loc "parser_case" ]
- in
- stream_pattern_se loc act ekont spsel
- | [se :: _] -> error se "parser_case" ]
-and stream_pattern_se loc act ekont =
- fun
- [ [] -> act
- | [se :: sel] ->
- let ckont err = <:expr< raise (Stream.Error $err$) >> in
- let skont = stream_pattern_se loc act ckont sel in
- stream_pattern_component skont ekont <:expr< "" >> se ]
-and stream_pattern_component skont ekont err =
- fun
- [ Sexpr loc [Satom _ Alid "`"; se :: wol] ->
- let wo =
- match wol with
- [ [se] -> Some (expr_se se)
- | [] -> None
- | _ -> error_loc loc "stream_pattern_component" ]
- in
- let e = peek_fun loc in
- let p = patt_se se in
- let j = junk_fun loc in
- let k = ekont err in
- <:expr< match $e$ $lid:strm_n$ with
- [ Some $p$ $when:wo$ -> do { $j$ $lid:strm_n$ ; $skont$ }
- | _ -> $k$ ] >>
- | Sexpr loc [se1; se2] ->
- let p = patt_se se1 in
- let e =
- let e = expr_se se2 in
- <:expr< try Some ($e$ $lid:strm_n$) with [ Stream.Failure -> None ] >>
- in
- let k = ekont err in
- <:expr< match $e$ with [ Some $p$ -> $skont$ | _ -> $k$ ] >>
- | Sexpr loc [Satom _ Alid "?"; se1; se2] ->
- stream_pattern_component skont ekont (expr_se se2) se1
- | Satom loc Alid s -> <:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >>
- | se -> error se "stream_pattern_component" ]
-and patt_se =
- fun
- [ Satom loc Alid "_" -> <:patt< _ >>
- | Satom loc (Alid | Auid) s -> patt_ident_se loc s
- | Satom loc Aint s -> <:patt< $int:s$ >>
- | Satom loc Achar s -> <:patt< $chr:s$ >>
- | Satom loc Astring s -> <:patt< $str:s$ >>
- | Sexpr loc [Satom _ Alid "or"; se :: sel] ->
- List.fold_left
- (fun p se ->
- let p1 = patt_se se in
- <:patt< $p$ | $p1$ >>)
- (patt_se se) sel
- | Sexpr loc [Satom _ Alid "range"; se1; se2] ->
- let p1 = patt_se se1 in
- let p2 = patt_se se2 in
- <:patt< $p1$ .. $p2$ >>
- | Sexpr loc [Satom _ Alid "," :: sel] ->
- let pl = List.map patt_se sel in
- <:patt< ( $list:pl$ ) >>
- | Sexpr loc [Satom _ Alid "as"; se1; se2] ->
- let p1 = patt_se se1 in
- let p2 = patt_se se2 in
- <:patt< ($p1$ as $p2$) >>
- | Sexpr loc [Satom _ Alid "list" :: sel] ->
- let rec loop =
- fun
- [ [] -> <:patt< [] >>
- | [se1; Satom _ Alid "::"; se2] ->
- let p = patt_se se1 in
- let pl = patt_se se2 in
- <:patt< [$p$ :: $pl$] >>
- | [se :: sel] ->
- let p = patt_se se in
- let pl = loop sel in
- <:patt< [$p$ :: $pl$] >> ]
- in
- loop sel
- | Sexpr loc [se :: sel] ->
- List.fold_left
- (fun p se ->
- let p1 = patt_se se in
- <:patt< $p$ $p1$ >>)
- (patt_se se) sel
- | Sexpr loc [] -> <:patt< () >>
- | Squot loc typ txt -> Pcaml.handle_patt_quotation loc (typ, txt) ]
-and patt_ident_se loc s =
- loop 0 0 where rec loop ibeg i =
- if i = String.length s then
- if i > ibeg then patt_id loc (String.sub s ibeg (i - ibeg))
- else
- raise_with_loc (fst loc + i - 1, fst loc + i)
- (Stream.Error "patt expected")
- else if s.[i] = '.' then
- if i > ibeg then
- let p1 = patt_id loc (String.sub s ibeg (i - ibeg)) in
- let p2 = loop (i + 1) (i + 1) in
- <:patt< $p1$ . $p2$ >>
- else
- raise_with_loc (fst loc + i - 1, fst loc + i + 1)
- (Stream.Error "patt expected")
- else loop ibeg (i + 1)
-and ipatt_se se =
- match ipatt_opt_se se with
- [ Left p -> p
- | Right (se, _) -> error se "ipatt" ]
-and ipatt_opt_se =
- fun
- [ Satom loc Alid "_" -> Left <:patt< _ >>
- | Satom loc Alid s -> Left <:patt< $lid:s$ >>
- | Sexpr loc [Satom _ Alid "," :: sel] ->
- let pl = List.map ipatt_se sel in
- Left <:patt< ( $list:pl$ ) >>
- | Sexpr loc [] -> Left <:patt< () >>
- | Sexpr loc [se :: sel] -> Right (se, sel)
- | se -> error se "ipatt" ]
-and type_declaration_list_se =
- fun
- [ [se1; se2 :: sel] ->
- let (n1, loc1, tpl) =
- match se1 with
- [ Sexpr _ [Satom loc Alid n :: sel] ->
- (n, loc, List.map type_parameter_se sel)
- | Satom loc Alid n -> (n, loc, [])
- | se -> error se "type declaration" ]
- in
- [((loc1, n1), tpl, ctyp_se se2, []) :: type_declaration_list_se sel]
- | [] -> []
- | [se :: _] -> error se "type_declaration" ]
-and type_parameter_se =
- fun
- [ Satom _ Alid s when String.length s >= 2 && s.[0] = ''' ->
- (String.sub s 1 (String.length s - 1), (False, False))
- | se -> error se "type_parameter" ]
-and ctyp_se =
- fun
- [ Sexpr loc [Satom _ Alid "sum" :: sel] ->
- let cdl = List.map constructor_declaration_se sel in
- <:ctyp< [ $list:cdl$ ] >>
- | Sexpr loc [se :: sel] ->
- List.fold_left
- (fun t se ->
- let t2 = ctyp_se se in
- <:ctyp< $t$ $t2$ >>)
- (ctyp_se se) sel
- | Satom loc (Alid | Auid) s -> ctyp_ident_se loc s
- | se -> error se "ctyp" ]
-and ctyp_ident_se loc s =
- loop 0 0 where rec loop ibeg i =
- if i = String.length s then
- if i > ibeg then ctyp_id loc (String.sub s ibeg (i - ibeg))
- else
- raise_with_loc (fst loc + i - 1, fst loc + i)
- (Stream.Error "ctyp expected")
- else if s.[i] = '.' then
- if i > ibeg then
- let t1 = ctyp_id loc (String.sub s ibeg (i - ibeg)) in
- let t2 = loop (i + 1) (i + 1) in
- <:ctyp< $t1$ . $t2$ >>
- else
- raise_with_loc (fst loc + i - 1, fst loc + i + 1)
- (Stream.Error "ctyp expected")
- else loop ibeg (i + 1)
-and constructor_declaration_se =
- fun
- [ Sexpr loc [Satom _ Auid ci :: sel] -> (loc, ci, List.map ctyp_se sel)
- | se -> error se "constructor_declaration" ]
-;
-
-value top_phrase_se se =
- match se with
- [ Satom loc _ _ | Squot loc _ _ -> str_item_se se
- | Sexpr loc [Satom _ Alid s :: sl] ->
- if s.[0] = '#' then
- let n = String.sub s 1 (String.length s - 1) in
- match sl with
- [ [Satom _ Astring s] -> MLast.StDir loc n (Some <:expr< $str:s$ >>)
- | _ -> match () with [] ]
- else str_item_se se
- | Sexpr loc _ -> str_item_se se ]
-;
-
-(* Parser *)
-
-value phony_quot = ref False;
-Pcaml.add_option "-phony_quot" (Arg.Set phony_quot) "phony quotations";
-
-Pcaml.no_constructors_arity.val := False;
-
-do {
- Grammar.Unsafe.gram_reinit gram (lexer_gmake ());
- Grammar.Unsafe.clear_entry interf;
- Grammar.Unsafe.clear_entry implem;
- Grammar.Unsafe.clear_entry top_phrase;
- Grammar.Unsafe.clear_entry use_file;
- Grammar.Unsafe.clear_entry module_type;
- Grammar.Unsafe.clear_entry module_expr;
- Grammar.Unsafe.clear_entry sig_item;
- Grammar.Unsafe.clear_entry str_item;
- Grammar.Unsafe.clear_entry expr;
- Grammar.Unsafe.clear_entry patt;
- Grammar.Unsafe.clear_entry ctyp;
- Grammar.Unsafe.clear_entry let_binding;
- Grammar.Unsafe.clear_entry class_type;
- Grammar.Unsafe.clear_entry class_expr;
- Grammar.Unsafe.clear_entry class_sig_item;
- Grammar.Unsafe.clear_entry class_str_item
-};
-
-Pcaml.parse_interf.val := Grammar.Entry.parse interf;
-Pcaml.parse_implem.val := Grammar.Entry.parse implem;
-
-value sexpr = Grammar.Entry.create gram "sexpr";
-value atom = Grammar.Entry.create gram "atom";
-
-EXTEND
- implem:
- [ [ st = LIST0 [ s = str_item -> (s, loc) ]; EOI -> (st, False) ] ]
- ;
- top_phrase:
- [ [ se = sexpr -> Some (top_phrase_se se)
- | EOI -> None ] ]
- ;
- use_file:
- [ [ l = LIST0 sexpr; EOI -> (List.map top_phrase_se l, False) ] ]
- ;
- str_item:
- [ [ se = sexpr -> str_item_se se
- | e = expr -> <:str_item< $exp:e$ >> ] ]
- ;
- expr:
- [ "top"
- [ se = sexpr -> expr_se se ] ]
- ;
- patt:
- [ [ se = sexpr -> patt_se se ] ]
- ;
- sexpr:
- [ [ "("; sl = LIST0 sexpr; ")" -> Sexpr loc sl
- | a = atom -> Satom loc Alid a
- | s = LIDENT -> Satom loc Alid s
- | s = UIDENT -> Satom loc Auid s
- | s = INT -> Satom loc Aint s
- | s = CHAR -> Satom loc Achar s
- | s = STRING -> Satom loc Astring s
- | s = QUOT ->
- let i = String.index s ':' in
- let typ = String.sub s 0 i in
- let txt = String.sub s (i + 1) (String.length s - i - 1) in
- if phony_quot.val then
- Satom loc Alid ("<:" ^ typ ^ "<" ^ txt ^ ">>")
- else Squot loc typ txt ] ]
- ;
- atom:
- [ [ "_" -> "_"
- | "," -> ","
- | "=" -> "="
- | ":" -> ":"
- | "." -> "." ] ]
- ;
-END;
diff --git a/camlp4/etc/pa_o.ml b/camlp4/etc/pa_o.ml
deleted file mode 100644
index 4f27f5ecc6..0000000000
--- a/camlp4/etc/pa_o.ml
+++ /dev/null
@@ -1,1293 +0,0 @@
-(* camlp4r pa_extend.cmo q_MLast.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Stdpp;
-open Pcaml;
-
-Pcaml.syntax_name.val := "OCaml";
-Pcaml.no_constructors_arity.val := True;
-
-do {
- let odfa = Plexer.dollar_for_antiquotation.val in
- Plexer.dollar_for_antiquotation.val := False;
- Grammar.Unsafe.gram_reinit gram (Plexer.gmake ());
- Plexer.dollar_for_antiquotation.val := odfa;
- Grammar.Unsafe.clear_entry interf;
- Grammar.Unsafe.clear_entry implem;
- Grammar.Unsafe.clear_entry top_phrase;
- Grammar.Unsafe.clear_entry use_file;
- Grammar.Unsafe.clear_entry module_type;
- Grammar.Unsafe.clear_entry module_expr;
- Grammar.Unsafe.clear_entry sig_item;
- Grammar.Unsafe.clear_entry str_item;
- Grammar.Unsafe.clear_entry expr;
- Grammar.Unsafe.clear_entry patt;
- Grammar.Unsafe.clear_entry ctyp;
- Grammar.Unsafe.clear_entry let_binding;
- Grammar.Unsafe.clear_entry type_declaration;
- Grammar.Unsafe.clear_entry class_type;
- Grammar.Unsafe.clear_entry class_expr;
- Grammar.Unsafe.clear_entry class_sig_item;
- Grammar.Unsafe.clear_entry class_str_item
-};
-
-Pcaml.parse_interf.val := Grammar.Entry.parse interf;
-Pcaml.parse_implem.val := Grammar.Entry.parse implem;
-
-value o2b =
- fun
- [ Some _ -> True
- | None -> False ]
-;
-
-value mkumin loc f arg =
- match (f, arg) with
- [ ("-", <:expr< $int:n$ >>) when int_of_string n > 0 ->
- let n = "-" ^ n in
- <:expr< $int:n$ >>
- | ("-", MLast.ExInt32 loc n) when (Int32.of_string n) > 0l ->
- MLast.ExInt32 loc ("-" ^ n)
- | ("-", MLast.ExInt64 loc n) when (Int64.of_string n) > 0L ->
- MLast.ExInt64 loc ("-" ^ n)
- | ("-", MLast.ExNativeInt loc n) when (Nativeint.of_string n) > 0n ->
- MLast.ExNativeInt loc ("-" ^ n)
- | (_, <:expr< $flo:n$ >>) when float_of_string n > 0.0 ->
- let n = "-" ^ n in
- <:expr< $flo:n$ >>
- | _ ->
- let f = "~" ^ f in
- <:expr< $lid:f$ $arg$ >> ]
-;
-
-value mklistexp loc last =
- loop True where rec loop top =
- fun
- [ [] ->
- match last with
- [ Some e -> e
- | None -> <:expr< [] >> ]
- | [e1 :: el] ->
- let loc = if top then loc else (fst (MLast.loc_of_expr e1), snd loc) in
- <:expr< [$e1$ :: $loop False el$] >> ]
-;
-
-value mklistpat loc last =
- loop True where rec loop top =
- fun
- [ [] ->
- match last with
- [ Some p -> p
- | None -> <:patt< [] >> ]
- | [p1 :: pl] ->
- let loc = if top then loc else (fst (MLast.loc_of_patt p1), snd loc) in
- <:patt< [$p1$ :: $loop False pl$] >> ]
-;
-
-value is_operator =
- let ht = Hashtbl.create 73 in
- let ct = Hashtbl.create 73 in
- do {
- List.iter (fun x -> Hashtbl.add ht x True)
- ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"];
- List.iter (fun x -> Hashtbl.add ct x True)
- ['!'; '&'; '*'; '+'; '-'; '/'; ':'; '<'; '='; '>'; '@'; '^'; '|'; '~';
- '?'; '%'; '.'; '$'];
- fun x ->
- try Hashtbl.find ht x with
- [ Not_found -> try Hashtbl.find ct x.[0] with _ -> False ]
- }
-;
-
-value operator_rparen =
- Grammar.Entry.of_parser gram "operator_rparen"
- (fun strm ->
- match Stream.npeek 2 strm with
- [ [("", s); ("", ")")] when is_operator s ->
- do { Stream.junk strm; Stream.junk strm; s }
- | _ -> raise Stream.Failure ])
-;
-
-value lident_colon =
- Grammar.Entry.of_parser gram "lident_colon"
- (fun strm ->
- match Stream.npeek 2 strm with
- [ [("LIDENT", i); ("", ":")] ->
- do { Stream.junk strm; Stream.junk strm; i }
- | _ -> raise Stream.Failure ])
-;
-
-value symbolchar =
- let list =
- ['!'; '$'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; '>'; '?';
- '@'; '^'; '|'; '~']
- in
- let rec loop s i =
- if i == String.length s then True
- else if List.mem s.[i] list then loop s (i + 1)
- else False
- in
- loop
-;
-
-value prefixop =
- let list = ['!'; '?'; '~'] in
- let excl = ["!="; "??"] in
- Grammar.Entry.of_parser gram "prefixop"
- (parser
- [: `("", x)
- when
- not (List.mem x excl) && String.length x >= 2 &&
- List.mem x.[0] list && symbolchar x 1 :] ->
- x)
-;
-
-value infixop0 =
- let list = ['='; '<'; '>'; '|'; '&'; '$'] in
- let excl = ["<-"; "||"; "&&"] in
- Grammar.Entry.of_parser gram "infixop0"
- (parser
- [: `("", x)
- when
- not (List.mem x excl) && String.length x >= 2 &&
- List.mem x.[0] list && symbolchar x 1 :] ->
- x)
-;
-
-value infixop1 =
- let list = ['@'; '^'] in
- Grammar.Entry.of_parser gram "infixop1"
- (parser
- [: `("", x)
- when
- String.length x >= 2 && List.mem x.[0] list &&
- symbolchar x 1 :] ->
- x)
-;
-
-value infixop2 =
- let list = ['+'; '-'] in
- Grammar.Entry.of_parser gram "infixop2"
- (parser
- [: `("", x)
- when
- x <> "->" && String.length x >= 2 && List.mem x.[0] list &&
- symbolchar x 1 :] ->
- x)
-;
-
-value infixop3 =
- let list = ['*'; '/'; '%'] in
- Grammar.Entry.of_parser gram "infixop3"
- (parser
- [: `("", x)
- when
- String.length x >= 2 && List.mem x.[0] list &&
- symbolchar x 1 :] ->
- x)
-;
-
-value infixop4 =
- Grammar.Entry.of_parser gram "infixop4"
- (parser
- [: `("", x)
- when
- String.length x >= 3 && x.[0] == '*' && x.[1] == '*' &&
- symbolchar x 2 :] ->
- x)
-;
-
-value test_constr_decl =
- Grammar.Entry.of_parser gram "test_constr_decl"
- (fun strm ->
- match Stream.npeek 1 strm with
- [ [("UIDENT", _)] ->
- match Stream.npeek 2 strm with
- [ [_; ("", ".")] -> raise Stream.Failure
- | [_; ("", "(")] -> raise Stream.Failure
- | [_ :: _] -> ()
- | _ -> raise Stream.Failure ]
- | [("", "|")] -> ()
- | _ -> raise Stream.Failure ])
-;
-
-value stream_peek_nth n strm =
- loop n (Stream.npeek n strm) where rec loop n =
- fun
- [ [] -> None
- | [x] -> if n == 1 then Some x else None
- | [_ :: l] -> loop (n - 1) l ]
-;
-
-(* horrible hack to be able to parse class_types *)
-
-value test_ctyp_minusgreater =
- Grammar.Entry.of_parser gram "test_ctyp_minusgreater"
- (fun strm ->
- let rec skip_simple_ctyp n =
- match stream_peek_nth n strm with
- [ Some ("", "->") -> n
- | Some ("", "[" | "[<") ->
- skip_simple_ctyp (ignore_upto "]" (n + 1) + 1)
- | Some ("", "(") -> skip_simple_ctyp (ignore_upto ")" (n + 1) + 1)
- | Some
- ("",
- "as" | "'" | ":" | "*" | "." | "#" | "<" | ">" | ".." | ";" |
- "_") ->
- skip_simple_ctyp (n + 1)
- | Some ("QUESTIONIDENT" | "LIDENT" | "UIDENT", _) ->
- skip_simple_ctyp (n + 1)
- | Some _ | None -> raise Stream.Failure ]
- and ignore_upto end_kwd n =
- match stream_peek_nth n strm with
- [ Some ("", prm) when prm = end_kwd -> n
- | Some ("", "[" | "[<") ->
- ignore_upto end_kwd (ignore_upto "]" (n + 1) + 1)
- | Some ("", "(") -> ignore_upto end_kwd (ignore_upto ")" (n + 1) + 1)
- | Some _ -> ignore_upto end_kwd (n + 1)
- | None -> raise Stream.Failure ]
- in
- match Stream.peek strm with
- [ Some (("", "[") | ("LIDENT" | "UIDENT", _)) -> skip_simple_ctyp 1
- | Some ("", "object") -> raise Stream.Failure
- | _ -> 1 ])
-;
-
-value test_label_eq =
- Grammar.Entry.of_parser gram "test_label_eq"
- (test 1 where rec test lev strm =
- match stream_peek_nth lev strm with
- [ Some (("UIDENT", _) | ("LIDENT", _) | ("", ".")) ->
- test (lev + 1) strm
- | Some ("", "=") -> ()
- | _ -> raise Stream.Failure ])
-;
-
-value test_typevar_list_dot =
- Grammar.Entry.of_parser gram "test_typevar_list_dot"
- (let rec test lev strm =
- match stream_peek_nth lev strm with
- [ Some ("", "'") -> test2 (lev + 1) strm
- | Some ("", ".") -> ()
- | _ -> raise Stream.Failure ]
- and test2 lev strm =
- match stream_peek_nth lev strm with
- [ Some ("UIDENT" | "LIDENT", _) -> test (lev + 1) strm
- | _ -> raise Stream.Failure ]
- in
- test 1)
-;
-
-value constr_arity = ref [("Some", 1); ("Match_Failure", 1)];
-
-value rec is_expr_constr_call =
- fun
- [ <:expr< $uid:_$ >> -> True
- | <:expr< $uid:_$.$e$ >> -> is_expr_constr_call e
- | <:expr< $e$ $_$ >> -> is_expr_constr_call e
- | _ -> False ]
-;
-
-value rec constr_expr_arity loc =
- fun
- [ <:expr< $uid:c$ >> ->
- try List.assoc c constr_arity.val with [ Not_found -> 0 ]
- | <:expr< $uid:_$.$e$ >> -> constr_expr_arity loc e
- | <:expr< $e$ $_$ >> ->
- if is_expr_constr_call e then
- Stdpp.raise_with_loc loc (Stream.Error "currified constructor")
- else 1
- | _ -> 1 ]
-;
-
-value rec is_patt_constr_call =
- fun
- [ <:patt< $uid:_$ >> -> True
- | <:patt< $uid:_$.$p$ >> -> is_patt_constr_call p
- | <:patt< $p$ $_$ >> -> is_patt_constr_call p
- | _ -> False ]
-;
-
-value rec constr_patt_arity loc =
- fun
- [ <:patt< $uid:c$ >> ->
- try List.assoc c constr_arity.val with [ Not_found -> 0 ]
- | <:patt< $uid:_$.$p$ >> -> constr_patt_arity loc p
- | <:patt< $p$ $_$ >> ->
- if is_patt_constr_call p then
- Stdpp.raise_with_loc loc (Stream.Error "currified constructor")
- else 1
- | _ -> 1 ]
-;
-
-value get_seq =
- fun
- [ <:expr< do { $list:el$ } >> -> el
- | e -> [e] ]
-;
-
-value choose_tvar tpl =
- let rec find_alpha v =
- let s = String.make 1 v in
- if List.mem_assoc s tpl then
- if v = 'z' then None else find_alpha (Char.chr (Char.code v + 1))
- else Some (String.make 1 v)
- in
- let rec make_n n =
- let v = "a" ^ string_of_int n in
- if List.mem_assoc v tpl then make_n (succ n) else v
- in
- match find_alpha 'a' with
- [ Some x -> x
- | None -> make_n 1 ]
-;
-
-value rec patt_lid =
- fun
- [ <:patt< $p1$ $p2$ >> ->
- match p1 with
- [ <:patt< $lid:i$ >> -> Some (MLast.loc_of_patt p1, i, [p2])
- | _ ->
- match patt_lid p1 with
- [ Some (loc, i, pl) -> Some (loc, i, [p2 :: pl])
- | None -> None ] ]
- | _ -> None ]
-;
-
-value bigarray_get loc arr arg =
- let coords =
- match arg with
- [ <:expr< ($list:el$) >> -> el
- | _ -> [arg] ]
- in
- match coords with
- [ [c1] -> <:expr< Bigarray.Array1.get $arr$ $c1$ >>
- | [c1; c2] -> <:expr< Bigarray.Array2.get $arr$ $c1$ $c2$ >>
- | [c1; c2; c3] -> <:expr< Bigarray.Array3.get $arr$ $c1$ $c2$ $c3$ >>
- | coords -> <:expr< Bigarray.Genarray.get $arr$ [| $list:coords$ |] >> ]
-;
-
-value bigarray_set loc var newval =
- match var with
- [ <:expr< Bigarray.Array1.get $arr$ $c1$ >> ->
- Some <:expr< Bigarray.Array1.set $arr$ $c1$ $newval$ >>
- | <:expr< Bigarray.Array2.get $arr$ $c1$ $c2$ >> ->
- Some <:expr< Bigarray.Array2.set $arr$ $c1$ $c2$ $newval$ >>
- | <:expr< Bigarray.Array3.get $arr$ $c1$ $c2$ $c3$ >> ->
- Some <:expr< Bigarray.Array3.set $arr$ $c1$ $c2$ $c3$ $newval$ >>
- | <:expr< Bigarray.Genarray.get $arr$ [| $list:coords$ |] >> ->
- Some <:expr< Bigarray.Genarray.set $arr$ [| $list:coords$ |] $newval$ >>
- | _ -> None ]
-;
-
-(* ...works bad...
-value rec sync cs =
- match cs with parser
- [ [: `';' :] -> sync_semi cs
- | [: `_ :] -> sync cs ]
-and sync_semi cs =
- match cs with parser
- [ [: `';' :] -> sync_semisemi cs
- | [: :] -> sync cs ]
-and sync_semisemi cs =
- match Stream.peek cs with
- [ Some ('\010' | '\013') -> ()
- | _ -> sync_semi cs ]
-;
-Pcaml.sync.val := sync;
-*)
-
-EXTEND
- GLOBAL: sig_item str_item ctyp patt expr module_type module_expr class_type
- class_expr class_sig_item class_str_item let_binding type_declaration;
- module_expr:
- [ [ "functor"; "("; i = UIDENT; ":"; t = module_type; ")"; "->";
- me = SELF ->
- <:module_expr< functor ( $i$ : $t$ ) -> $me$ >>
- | "struct"; st = LIST0 [ s = str_item; OPT ";;" -> s ]; "end" ->
- <:module_expr< struct $list:st$ end >> ]
- | [ me1 = SELF; me2 = SELF -> <:module_expr< $me1$ $me2$ >> ]
- | [ i = mod_expr_ident -> i
- | "("; me = SELF; ":"; mt = module_type; ")" ->
- <:module_expr< ( $me$ : $mt$ ) >>
- | "("; me = SELF; ")" -> <:module_expr< $me$ >> ] ]
- ;
- mod_expr_ident:
- [ LEFTA
- [ i = SELF; "."; j = SELF -> <:module_expr< $i$ . $j$ >> ]
- | [ i = UIDENT -> <:module_expr< $uid:i$ >> ] ]
- ;
- str_item:
- [ "top"
- [ "exception"; (_, c, tl) = constructor_declaration; b = rebind_exn ->
- <:str_item< exception $c$ of $list:tl$ = $b$ >>
- | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING ->
- <:str_item< external $i$ : $t$ = $list:pd$ >>
- | "external"; "("; i = operator_rparen; ":"; t = ctyp; "=";
- pd = LIST1 STRING ->
- <:str_item< external $i$ : $t$ = $list:pd$ >>
- | "include"; me = module_expr -> <:str_item< include $me$ >>
- | "module"; i = UIDENT; mb = module_binding ->
- <:str_item< module $i$ = $mb$ >>
- | "module"; "rec"; nmtmes = LIST1 module_rec_binding SEP "and" ->
- MLast.StRecMod loc nmtmes
- | "module"; "type"; i = UIDENT; "="; mt = module_type ->
- <:str_item< module type $i$ = $mt$ >>
- | "open"; i = mod_ident -> <:str_item< open $i$ >>
- | "type"; tdl = LIST1 type_declaration SEP "and" ->
- <:str_item< type $list:tdl$ >>
- | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and"; "in";
- x = expr ->
- let e = <:expr< let $opt:o2b r$ $list:l$ in $x$ >> in
- <:str_item< $exp:e$ >>
- | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and" ->
- match l with
- [ [(<:patt< _ >>, e)] -> <:str_item< $exp:e$ >>
- | _ -> <:str_item< value $opt:o2b r$ $list:l$ >> ]
- | "let"; "module"; m = UIDENT; mb = module_binding; "in"; e = expr ->
- <:str_item< let module $m$ = $mb$ in $e$ >>
- | e = expr -> <:str_item< $exp:e$ >> ] ]
- ;
- rebind_exn:
- [ [ "="; sl = mod_ident -> sl
- | -> [] ] ]
- ;
- module_binding:
- [ RIGHTA
- [ "("; m = UIDENT; ":"; mt = module_type; ")"; mb = SELF ->
- <:module_expr< functor ( $m$ : $mt$ ) -> $mb$ >>
- | ":"; mt = module_type; "="; me = module_expr ->
- <:module_expr< ( $me$ : $mt$ ) >>
- | "="; me = module_expr -> <:module_expr< $me$ >> ] ]
- ;
- module_rec_binding:
- [ [ m = UIDENT; ":"; mt = module_type; "="; me = module_expr ->
- (m, mt, me) ] ]
- ;
- (* Module types *)
- module_type:
- [ [ "functor"; "("; i = UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF ->
- <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ]
- | [ mt = SELF; "with"; wcl = LIST1 with_constr SEP "and" ->
- <:module_type< $mt$ with $list:wcl$ >> ]
- | [ "sig"; sg = LIST0 [ s = sig_item; OPT ";;" -> s ]; "end" ->
- <:module_type< sig $list:sg$ end >>
- | i = mod_type_ident -> i
- | "("; mt = SELF; ")" -> <:module_type< $mt$ >> ] ]
- ;
- mod_type_ident:
- [ LEFTA
- [ m1 = SELF; "."; m2 = SELF -> <:module_type< $m1$ . $m2$ >>
- | m1 = SELF; "("; m2 = SELF; ")" -> <:module_type< $m1$ $m2$ >> ]
- | [ m = UIDENT -> <:module_type< $uid:m$ >>
- | m = LIDENT -> <:module_type< $lid:m$ >> ] ]
- ;
- sig_item:
- [ "top"
- [ "exception"; (_, c, tl) = constructor_declaration ->
- <:sig_item< exception $c$ of $list:tl$ >>
- | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING ->
- <:sig_item< external $i$ : $t$ = $list:pd$ >>
- | "external"; "("; i = operator_rparen; ":"; t = ctyp; "=";
- pd = LIST1 STRING ->
- <:sig_item< external $i$ : $t$ = $list:pd$ >>
- | "include"; mt = module_type -> <:sig_item< include $mt$ >>
- | "module"; i = UIDENT; mt = module_declaration ->
- <:sig_item< module $i$ : $mt$ >>
- | "module"; "rec"; mds = LIST1 module_rec_declaration SEP "and" ->
- MLast.SgRecMod loc mds
- | "module"; "type"; i = UIDENT; "="; mt = module_type ->
- <:sig_item< module type $i$ = $mt$ >>
- | "module"; "type"; i = UIDENT ->
- <:sig_item< module type $i$ = 'abstract >>
- | "open"; i = mod_ident -> <:sig_item< open $i$ >>
- | "type"; tdl = LIST1 type_declaration SEP "and" ->
- <:sig_item< type $list:tdl$ >>
- | "val"; i = LIDENT; ":"; t = ctyp -> <:sig_item< value $i$ : $t$ >>
- | "val"; "("; i = operator_rparen; ":"; t = ctyp ->
- <:sig_item< value $i$ : $t$ >> ] ]
- ;
- module_declaration:
- [ RIGHTA
- [ ":"; mt = module_type -> <:module_type< $mt$ >>
- | "("; i = UIDENT; ":"; t = module_type; ")"; mt = SELF ->
- <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] ]
- ;
- module_rec_declaration:
- [ [ m = UIDENT; ":"; mt = module_type -> (m, mt)] ]
- ;
- (* "with" constraints (additional type equations over signature
- components) *)
- with_constr:
- [ [ "type"; tpl = type_parameters; i = mod_ident; "="; t = ctyp ->
- MLast.WcTyp loc i tpl t
- | "module"; i = mod_ident; "="; me = module_expr ->
- MLast.WcMod loc i me ] ]
- ;
- (* Core expressions *)
- expr:
- [ "top" RIGHTA
- [ e1 = SELF; ";"; e2 = SELF ->
- <:expr< do { $list:[e1 :: get_seq e2]$ } >>
- | e1 = SELF; ";" -> e1 ]
- | "expr1"
- [ "let"; o = OPT "rec"; l = LIST1 let_binding SEP "and"; "in";
- x = expr LEVEL "top" ->
- <:expr< let $opt:o2b o$ $list:l$ in $x$ >>
- | "let"; "module"; m = UIDENT; mb = module_binding; "in";
- e = expr LEVEL "top" ->
- <:expr< let module $m$ = $mb$ in $e$ >>
- | "function"; OPT "|"; l = LIST1 match_case SEP "|" ->
- <:expr< fun [ $list:l$ ] >>
- | "fun"; p = patt LEVEL "simple"; e = fun_def ->
- <:expr< fun [$p$ -> $e$] >>
- | "match"; e = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" ->
- <:expr< match $e$ with [ $list:l$ ] >>
- | "try"; e = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" ->
- <:expr< try $e$ with [ $list:l$ ] >>
- | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1";
- "else"; e3 = expr LEVEL "expr1" ->
- <:expr< if $e1$ then $e2$ else $e3$ >>
- | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1" ->
- <:expr< if $e1$ then $e2$ else () >>
- | "for"; i = LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF;
- "do"; e = SELF; "done" ->
- <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:get_seq e$ } >>
- | "while"; e1 = SELF; "do"; e2 = SELF; "done" ->
- <:expr< while $e1$ do { $list:get_seq e2$ } >> ]
- | [ e = SELF; ","; el = LIST1 NEXT SEP "," ->
- <:expr< ( $list:[e :: el]$ ) >> ]
- | ":=" NONA
- [ e1 = SELF; ":="; e2 = expr LEVEL "expr1" ->
- <:expr< $e1$.val := $e2$ >>
- | e1 = SELF; "<-"; e2 = expr LEVEL "expr1" ->
- match bigarray_set loc e1 e2 with
- [ Some e -> e
- | None -> <:expr< $e1$ := $e2$ >> ] ]
- | "||" RIGHTA
- [ e1 = SELF; "or"; e2 = SELF -> <:expr< $lid:"or"$ $e1$ $e2$ >>
- | e1 = SELF; "||"; e2 = SELF -> <:expr< $e1$ || $e2$ >> ]
- | "&&" RIGHTA
- [ e1 = SELF; "&"; e2 = SELF -> <:expr< $lid:"&"$ $e1$ $e2$ >>
- | e1 = SELF; "&&"; e2 = SELF -> <:expr< $e1$ && $e2$ >> ]
- | "<" LEFTA
- [ e1 = SELF; "<"; e2 = SELF -> <:expr< $e1$ < $e2$ >>
- | e1 = SELF; ">"; e2 = SELF -> <:expr< $e1$ > $e2$ >>
- | e1 = SELF; "<="; e2 = SELF -> <:expr< $e1$ <= $e2$ >>
- | e1 = SELF; ">="; e2 = SELF -> <:expr< $e1$ >= $e2$ >>
- | e1 = SELF; "="; e2 = SELF -> <:expr< $e1$ = $e2$ >>
- | e1 = SELF; "<>"; e2 = SELF -> <:expr< $e1$ <> $e2$ >>
- | e1 = SELF; "=="; e2 = SELF -> <:expr< $e1$ == $e2$ >>
- | e1 = SELF; "!="; e2 = SELF -> <:expr< $e1$ != $e2$ >>
- | e1 = SELF; "$"; e2 = SELF -> <:expr< $lid:"\$"$ $e1$ $e2$ >>
- | e1 = SELF; op = infixop0; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
- | "^" RIGHTA
- [ e1 = SELF; "^"; e2 = SELF -> <:expr< $e1$ ^ $e2$ >>
- | e1 = SELF; "@"; e2 = SELF -> <:expr< $e1$ @ $e2$ >>
- | e1 = SELF; op = infixop1; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
- | RIGHTA
- [ e1 = SELF; "::"; e2 = SELF -> <:expr< [$e1$ :: $e2$] >> ]
- | "+" LEFTA
- [ e1 = SELF; "+"; e2 = SELF -> <:expr< $e1$ + $e2$ >>
- | e1 = SELF; "-"; e2 = SELF -> <:expr< $e1$ - $e2$ >>
- | e1 = SELF; op = infixop2; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
- | "*" LEFTA
- [ e1 = SELF; "*"; e2 = SELF -> <:expr< $e1$ * $e2$ >>
- | e1 = SELF; "/"; e2 = SELF -> <:expr< $e1$ / $e2$ >>
- | e1 = SELF; "%"; e2 = SELF -> <:expr< $lid:"%"$ $e1$ $e2$ >>
- | e1 = SELF; "land"; e2 = SELF -> <:expr< $e1$ land $e2$ >>
- | e1 = SELF; "lor"; e2 = SELF -> <:expr< $e1$ lor $e2$ >>
- | e1 = SELF; "lxor"; e2 = SELF -> <:expr< $e1$ lxor $e2$ >>
- | e1 = SELF; "mod"; e2 = SELF -> <:expr< $e1$ mod $e2$ >>
- | e1 = SELF; op = infixop3; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
- | "**" RIGHTA
- [ e1 = SELF; "**"; e2 = SELF -> <:expr< $e1$ ** $e2$ >>
- | e1 = SELF; "asr"; e2 = SELF -> <:expr< $e1$ asr $e2$ >>
- | e1 = SELF; "lsl"; e2 = SELF -> <:expr< $e1$ lsl $e2$ >>
- | e1 = SELF; "lsr"; e2 = SELF -> <:expr< $e1$ lsr $e2$ >>
- | e1 = SELF; op = infixop4; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
- | "unary minus" NONA
- [ "-"; e = SELF -> <:expr< $mkumin loc "-" e$ >>
- | "-."; e = SELF -> <:expr< $mkumin loc "-." e$ >> ]
- | "apply" LEFTA
- [ e1 = SELF; e2 = SELF ->
- match constr_expr_arity loc e1 with
- [ 1 -> <:expr< $e1$ $e2$ >>
- | _ ->
- match e2 with
- [ <:expr< ( $list:el$ ) >> ->
- List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>) e1 el
- | _ -> <:expr< $e1$ $e2$ >> ] ]
- | "assert"; e = SELF ->
- match e with
- [ <:expr< False >> -> <:expr< assert False >>
- | _ -> <:expr< assert ($e$) >> ]
- | "lazy"; e = SELF ->
- <:expr< lazy ($e$) >> ]
- | "." LEFTA
- [ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >>
- | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >>
- | e1 = SELF; "."; "{"; e2 = SELF; "}" -> bigarray_get loc e1 e2
- | e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >> ]
- | "~-" NONA
- [ "!"; e = SELF -> <:expr< $e$ . val>>
- | "~-"; e = SELF -> <:expr< ~- $e$ >>
- | "~-."; e = SELF -> <:expr< ~-. $e$ >>
- | f = prefixop; e = SELF -> <:expr< $lid:f$ $e$ >> ]
- | "simple" LEFTA
- [ s = INT -> <:expr< $int:s$ >>
- | s = INT32 -> MLast.ExInt32 loc s
- | s = INT64 -> MLast.ExInt64 loc s
- | s = NATIVEINT -> MLast.ExNativeInt loc s
- | s = FLOAT -> <:expr< $flo:s$ >>
- | s = STRING -> <:expr< $str:s$ >>
- | c = CHAR -> <:expr< $chr:c$ >>
- | UIDENT "True" -> <:expr< $uid:" True"$ >>
- | UIDENT "False" -> <:expr< $uid:" False"$ >>
- | i = expr_ident -> i
- | s = "false" -> <:expr< False >>
- | s = "true" -> <:expr< True >>
- | "["; "]" -> <:expr< [] >>
- | "["; el = expr1_semi_list; "]" -> <:expr< $mklistexp loc None el$ >>
- | "[|"; "|]" -> <:expr< [| |] >>
- | "[|"; el = expr1_semi_list; "|]" -> <:expr< [| $list:el$ |] >>
- | "{"; test_label_eq; lel = lbl_expr_list; "}" ->
- <:expr< { $list:lel$ } >>
- | "{"; e = expr LEVEL "."; "with"; lel = lbl_expr_list; "}" ->
- <:expr< { ($e$) with $list:lel$ } >>
- | "("; ")" -> <:expr< () >>
- | "("; op = operator_rparen -> <:expr< $lid:op$ >>
- | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >>
- | "("; e = SELF; ")" -> <:expr< $e$ >>
- | "begin"; e = SELF; "end" -> <:expr< $e$ >>
- | "begin"; "end" -> <:expr< () >>
- | x = LOCATE ->
- let x =
- try
- let i = String.index x ':' in
- (int_of_string (String.sub x 0 i),
- String.sub x (i + 1) (String.length x - i - 1))
- with
- [ Not_found | Failure _ -> (0, x) ]
- in
- Pcaml.handle_expr_locate loc x
- | x = QUOTATION ->
- let x =
- try
- let i = String.index x ':' in
- (String.sub x 0 i,
- String.sub x (i + 1) (String.length x - i - 1))
- with
- [ Not_found -> ("", x) ]
- in
- Pcaml.handle_expr_quotation loc x ] ]
- ;
- let_binding:
- [ [ p = patt; e = fun_binding ->
- match patt_lid p with
- [ Some (loc, i, pl) ->
- let e =
- List.fold_left (fun e p -> <:expr< fun $p$ -> $e$ >>) e pl
- in
- (<:patt< $lid:i$ >>, e)
- | None -> (p, e) ] ] ]
- ;
- fun_binding:
- [ RIGHTA
- [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >>
- | "="; e = expr -> <:expr< $e$ >>
- | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> ] ]
- ;
- match_case:
- [ [ x1 = patt; w = OPT [ "when"; e = expr -> e ]; "->"; x2 = expr ->
- (x1, w, x2) ] ]
- ;
- lbl_expr_list:
- [ [ le = lbl_expr; ";"; lel = SELF -> [le :: lel]
- | le = lbl_expr; ";" -> [le]
- | le = lbl_expr -> [le] ] ]
- ;
- lbl_expr:
- [ [ i = patt_label_ident; "="; e = expr LEVEL "expr1" -> (i, e) ] ]
- ;
- expr1_semi_list:
- [ [ e = expr LEVEL "expr1"; ";"; el = SELF -> [e :: el]
- | e = expr LEVEL "expr1"; ";" -> [e]
- | e = expr LEVEL "expr1" -> [e] ] ]
- ;
- fun_def:
- [ RIGHTA
- [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >>
- | "->"; e = expr -> <:expr< $e$ >> ] ]
- ;
- expr_ident:
- [ RIGHTA
- [ i = LIDENT -> <:expr< $lid:i$ >>
- | i = UIDENT -> <:expr< $uid:i$ >>
- | i = UIDENT; "."; j = SELF ->
- let rec loop m =
- fun
- [ <:expr< $x$ . $y$ >> -> loop <:expr< $m$ . $x$ >> y
- | e -> <:expr< $m$ . $e$ >> ]
- in
- loop <:expr< $uid:i$ >> j
- | i = UIDENT; "."; "("; j = operator_rparen ->
- <:expr< $uid:i$ . $lid:j$ >> ] ]
- ;
- (* Patterns *)
- patt:
- [ LEFTA
- [ p1 = SELF; "as"; i = LIDENT -> <:patt< ($p1$ as $lid:i$) >> ]
- | LEFTA
- [ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ]
- | [ p = SELF; ","; pl = LIST1 NEXT SEP "," ->
- <:patt< ( $list:[p :: pl]$) >> ]
- | NONA
- [ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ]
- | RIGHTA
- [ p1 = SELF; "::"; p2 = SELF -> <:patt< [$p1$ :: $p2$] >> ]
- | LEFTA
- [ p1 = SELF; p2 = SELF ->
- match constr_patt_arity loc p1 with
- [ 1 -> <:patt< $p1$ $p2$ >>
- | n ->
- let p2 =
- match p2 with
- [ <:patt< _ >> when n > 1 ->
- let pl =
- loop n where rec loop n =
- if n = 0 then [] else [<:patt< _ >> :: loop (n - 1)]
- in
- <:patt< ( $list:pl$ ) >>
- | _ -> p2 ]
- in
- match p2 with
- [ <:patt< ( $list:pl$ ) >> ->
- List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>) p1 pl
- | _ -> <:patt< $p1$ $p2$ >> ] ] ]
- | LEFTA
- [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ]
- | "simple"
- [ s = LIDENT -> <:patt< $lid:s$ >>
- | s = UIDENT -> <:patt< $uid:s$ >>
- | s = INT -> <:patt< $int:s$ >>
- | s = INT32 -> MLast.PaInt32 loc s
- | s = INT64 -> MLast.PaInt64 loc s
- | s = NATIVEINT -> MLast.PaNativeInt loc s
- | "-"; s = INT -> <:patt< $int:"-" ^ s$ >>
- | "-"; s = INT32 -> MLast.PaInt32 loc ("-" ^ s)
- | "-"; s = INT64 -> MLast.PaInt64 loc ("-" ^ s)
- | "-"; s = NATIVEINT -> MLast.PaNativeInt loc ("-" ^ s)
- | "-"; s = FLOAT -> <:patt< $flo:"-" ^ s$ >>
- | s = FLOAT -> <:patt< $flo:s$ >>
- | s = STRING -> <:patt< $str:s$ >>
- | s = CHAR -> <:patt< $chr:s$ >>
- | UIDENT "True" -> <:patt< $uid:" True"$ >>
- | UIDENT "False" -> <:patt< $uid:" False"$ >>
- | s = "false" -> <:patt< False >>
- | s = "true" -> <:patt< True >>
- | "["; "]" -> <:patt< [] >>
- | "["; pl = patt_semi_list; "]" -> <:patt< $mklistpat loc None pl$ >>
- | "[|"; "|]" -> <:patt< [| |] >>
- | "[|"; pl = patt_semi_list; "|]" -> <:patt< [| $list:pl$ |] >>
- | "{"; lpl = lbl_patt_list; "}" -> <:patt< { $list:lpl$ } >>
- | "("; ")" -> <:patt< () >>
- | "("; op = operator_rparen -> <:patt< $lid:op$ >>
- | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >>
- | "("; p = SELF; ")" -> <:patt< $p$ >>
- | "_" -> <:patt< _ >>
- | x = LOCATE ->
- let x =
- try
- let i = String.index x ':' in
- (int_of_string (String.sub x 0 i),
- String.sub x (i + 1) (String.length x - i - 1))
- with
- [ Not_found | Failure _ -> (0, x) ]
- in
- Pcaml.handle_patt_locate loc x
- | x = QUOTATION ->
- let x =
- try
- let i = String.index x ':' in
- (String.sub x 0 i,
- String.sub x (i + 1) (String.length x - i - 1))
- with
- [ Not_found -> ("", x) ]
- in
- Pcaml.handle_patt_quotation loc x ] ]
- ;
- patt_semi_list:
- [ [ p = patt; ";"; pl = SELF -> [p :: pl]
- | p = patt; ";" -> [p]
- | p = patt -> [p] ] ]
- ;
- lbl_patt_list:
- [ [ le = lbl_patt; ";"; lel = SELF -> [le :: lel]
- | le = lbl_patt; ";" -> [le]
- | le = lbl_patt -> [le] ] ]
- ;
- lbl_patt:
- [ [ i = patt_label_ident; "="; p = patt -> (i, p) ] ]
- ;
- patt_label_ident:
- [ LEFTA
- [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ]
- | RIGHTA
- [ i = UIDENT -> <:patt< $uid:i$ >>
- | i = LIDENT -> <:patt< $lid:i$ >> ] ]
- ;
- (* Type declaration *)
- type_declaration:
- [ [ tpl = type_parameters; n = type_patt; "="; tk = type_kind;
- cl = LIST0 constrain ->
- (n, tpl, tk, cl)
- | tpl = type_parameters; n = type_patt; cl = LIST0 constrain ->
- (n, tpl, <:ctyp< '$choose_tvar tpl$ >>, cl) ] ]
- ;
- type_patt:
- [ [ n = LIDENT -> (loc, n) ] ]
- ;
- constrain:
- [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> (t1, t2) ] ]
- ;
- type_kind:
- [ [ "private"; "{"; ldl = label_declarations; "}" ->
- <:ctyp< private { $list:ldl$ } >>
- | "private"; OPT "|";
- cdl = LIST1 constructor_declaration SEP "|" -> <:ctyp< private [ $list:cdl$ ] >>
- | test_constr_decl; OPT "|";
- cdl = LIST1 constructor_declaration SEP "|" -> <:ctyp< [ $list:cdl$ ] >>
- | t = ctyp -> <:ctyp< $t$ >>
- | t = ctyp; "="; "private"; "{"; ldl = label_declarations; "}" ->
- <:ctyp< $t$ == private { $list:ldl$ } >>
- | t = ctyp; "="; "{"; ldl = label_declarations; "}" ->
- <:ctyp< $t$ == { $list:ldl$ } >>
- | t = ctyp; "="; "private"; OPT "|"; cdl = LIST1 constructor_declaration SEP "|" ->
- <:ctyp< $t$ == private [ $list:cdl$ ] >>
- | t = ctyp; "="; OPT "|"; cdl = LIST1 constructor_declaration SEP "|" ->
- <:ctyp< $t$ == [ $list:cdl$ ] >>
- | "{"; ldl = label_declarations; "}" ->
- <:ctyp< { $list:ldl$ } >> ] ]
- ;
- type_parameters:
- [ [ -> (* empty *) []
- | tp = type_parameter -> [tp]
- | "("; tpl = LIST1 type_parameter SEP ","; ")" -> tpl ] ]
- ;
- type_parameter:
- [ [ "'"; i = ident -> (i, (False, False))
- | "+"; "'"; i = ident -> (i, (True, False))
- | "-"; "'"; i = ident -> (i, (False, True)) ] ]
- ;
- constructor_declaration:
- [ [ ci = UIDENT; "of"; cal = LIST1 ctyp LEVEL "ctyp1" SEP "*" ->
- (loc, ci, cal)
- | ci = UIDENT -> (loc, ci, []) ] ]
- ;
- label_declarations:
- [ [ ld = label_declaration; ";"; ldl = SELF -> [ld :: ldl]
- | ld = label_declaration; ";" -> [ld]
- | ld = label_declaration -> [ld] ] ]
- ;
- label_declaration:
- [ [ i = LIDENT; ":"; t = poly_type -> (loc, i, False, t)
- | "mutable"; i = LIDENT; ":"; t = poly_type -> (loc, i, True, t) ] ]
- ;
- (* Core types *)
- ctyp:
- [ [ t1 = SELF; "as"; "'"; i = ident -> <:ctyp< $t1$ as '$i$ >> ]
- | "arrow" RIGHTA
- [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ]
- | "star"
- [ t = SELF; "*"; tl = LIST1 (ctyp LEVEL "ctyp1") SEP "*" ->
- <:ctyp< ( $list:[t :: tl]$ ) >> ]
- | "ctyp1"
- [ t1 = SELF; t2 = SELF -> <:ctyp< $t2$ $t1$ >> ]
- | "ctyp2"
- [ t1 = SELF; "."; t2 = SELF -> <:ctyp< $t1$ . $t2$ >>
- | t1 = SELF; "("; t2 = SELF; ")" -> <:ctyp< $t1$ $t2$ >> ]
- | "simple"
- [ "'"; i = ident -> <:ctyp< '$i$ >>
- | "_" -> <:ctyp< _ >>
- | i = LIDENT -> <:ctyp< $lid:i$ >>
- | i = UIDENT -> <:ctyp< $uid:i$ >>
- | "("; t = SELF; ","; tl = LIST1 ctyp SEP ","; ")";
- i = ctyp LEVEL "ctyp2" ->
- List.fold_left (fun c a -> <:ctyp< $c$ $a$ >>) i [t :: tl]
- | "("; t = SELF; ")" -> <:ctyp< $t$ >> ] ]
- ;
- (* Identifiers *)
- ident:
- [ [ i = LIDENT -> i
- | i = UIDENT -> i ] ]
- ;
- mod_ident:
- [ RIGHTA
- [ i = UIDENT -> [i]
- | i = LIDENT -> [i]
- | i = UIDENT; "."; j = SELF -> [i :: j] ] ]
- ;
- (* Miscellaneous *)
- direction_flag:
- [ [ "to" -> True
- | "downto" -> False ] ]
- ;
- (* Objects and Classes *)
- str_item:
- [ [ "class"; cd = LIST1 class_declaration SEP "and" ->
- <:str_item< class $list:cd$ >>
- | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" ->
- <:str_item< class type $list:ctd$ >> ] ]
- ;
- sig_item:
- [ [ "class"; cd = LIST1 class_description SEP "and" ->
- <:sig_item< class $list:cd$ >>
- | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" ->
- <:sig_item< class type $list:ctd$ >> ] ]
- ;
- (* Class expressions *)
- class_declaration:
- [ [ vf = OPT "virtual"; ctp = class_type_parameters; i = LIDENT;
- cfb = class_fun_binding ->
- {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
- MLast.ciNam = i; MLast.ciExp = cfb} ] ]
- ;
- class_fun_binding:
- [ [ "="; ce = class_expr -> ce
- | ":"; ct = class_type; "="; ce = class_expr ->
- <:class_expr< ($ce$ : $ct$) >>
- | p = patt LEVEL "simple"; cfb = SELF ->
- <:class_expr< fun $p$ -> $cfb$ >> ] ]
- ;
- class_type_parameters:
- [ [ -> (loc, [])
- | "["; tpl = LIST1 type_parameter SEP ","; "]" -> (loc, tpl) ] ]
- ;
- class_fun_def:
- [ [ p = patt LEVEL "simple"; "->"; ce = class_expr ->
- <:class_expr< fun $p$ -> $ce$ >>
- | p = labeled_patt; "->"; ce = class_expr ->
- <:class_expr< fun $p$ -> $ce$ >>
- | p = patt LEVEL "simple"; cfd = SELF ->
- <:class_expr< fun $p$ -> $cfd$ >>
- | p = labeled_patt; cfd = SELF ->
- <:class_expr< fun $p$ -> $cfd$ >> ] ]
- ;
- class_expr:
- [ "top"
- [ "fun"; cfd = class_fun_def -> cfd
- | "let"; rf = OPT "rec"; lb = LIST1 let_binding SEP "and"; "in";
- ce = SELF ->
- <:class_expr< let $opt:o2b rf$ $list:lb$ in $ce$ >> ]
- | "apply" LEFTA
- [ ce = SELF; e = expr LEVEL "label" ->
- <:class_expr< $ce$ $e$ >> ]
- | "simple"
- [ "["; ct = ctyp; ","; ctcl = LIST1 ctyp SEP ","; "]";
- ci = class_longident ->
- <:class_expr< $list:ci$ [ $list:[ct :: ctcl]$ ] >>
- | "["; ct = ctyp; "]"; ci = class_longident ->
- <:class_expr< $list:ci$ [ $ct$ ] >>
- | ci = class_longident -> <:class_expr< $list:ci$ >>
- | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" ->
- <:class_expr< object $opt:cspo$ $list:cf$ end >>
- | "("; ce = SELF; ":"; ct = class_type; ")" ->
- <:class_expr< ($ce$ : $ct$) >>
- | "("; ce = SELF; ")" -> ce ] ]
- ;
- class_structure:
- [ [ cf = LIST0 class_str_item -> cf ] ]
- ;
- class_self_patt:
- [ [ "("; p = patt; ")" -> p
- | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> ] ]
- ;
- class_str_item:
- [ [ "inherit"; ce = class_expr; pb = OPT [ "as"; i = LIDENT -> i ] ->
- <:class_str_item< inherit $ce$ $opt:pb$ >>
- | "val"; mf = OPT "mutable"; lab = label; e = cvalue_binding ->
- <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >>
- | "method"; "private"; "virtual"; l = label; ":"; t = poly_type ->
- <:class_str_item< method virtual private $l$ : $t$ >>
- | "method"; "virtual"; "private"; l = label; ":"; t = poly_type ->
- <:class_str_item< method virtual private $l$ : $t$ >>
- | "method"; "virtual"; l = label; ":"; t = poly_type ->
- <:class_str_item< method virtual $l$ : $t$ >>
- | "method"; "private"; l = label; ":"; t = poly_type; "="; e = expr ->
- MLast.CrMth loc l True e (Some t)
- | "method"; "private"; l = label; sb = fun_binding ->
- MLast.CrMth loc l True sb None
- | "method"; l = label; ":"; t = poly_type; "="; e = expr ->
- MLast.CrMth loc l False e (Some t)
- | "method"; l = label; sb = fun_binding ->
- MLast.CrMth loc l False sb None
- | "constraint"; t1 = ctyp; "="; t2 = ctyp ->
- <:class_str_item< type $t1$ = $t2$ >>
- | "initializer"; se = expr -> <:class_str_item< initializer $se$ >> ] ]
- ;
- cvalue_binding:
- [ [ "="; e = expr -> e
- | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >>
- | ":"; t = ctyp; ":>"; t2 = ctyp; "="; e = expr ->
- <:expr< ($e$ : $t$ :> $t2$) >>
- | ":>"; t = ctyp; "="; e = expr ->
- <:expr< ($e$ :> $t$) >> ] ]
- ;
- label:
- [ [ i = LIDENT -> i ] ]
- ;
- (* Class types *)
- class_type:
- [ [ test_ctyp_minusgreater; t = ctyp LEVEL "star"; "->"; ct = SELF ->
- <:class_type< [ $t$ ] -> $ct$ >>
- | cs = class_signature -> cs ] ]
- ;
- class_signature:
- [ [ "["; tl = LIST1 ctyp SEP ","; "]"; id = clty_longident ->
- <:class_type< $list:id$ [ $list:tl$ ] >>
- | id = clty_longident -> <:class_type< $list:id$ >>
- | "object"; cst = OPT class_self_type; csf = LIST0 class_sig_item;
- "end" ->
- <:class_type< object $opt:cst$ $list:csf$ end >> ] ]
- ;
- class_self_type:
- [ [ "("; t = ctyp; ")" -> t ] ]
- ;
- class_sig_item:
- [ [ "inherit"; cs = class_signature -> <:class_sig_item< inherit $cs$ >>
- | "val"; mf = OPT "mutable"; l = label; ":"; t = ctyp ->
- <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >>
- | "method"; "private"; "virtual"; l = label; ":"; t = poly_type ->
- <:class_sig_item< method virtual private $l$ : $t$ >>
- | "method"; "virtual"; "private"; l = label; ":"; t = poly_type ->
- <:class_sig_item< method virtual private $l$ : $t$ >>
- | "method"; "virtual"; l = label; ":"; t = poly_type ->
- <:class_sig_item< method virtual $l$ : $t$ >>
- | "method"; "private"; l = label; ":"; t = poly_type ->
- <:class_sig_item< method private $l$ : $t$ >>
- | "method"; l = label; ":"; t = poly_type ->
- <:class_sig_item< method $l$ : $t$ >>
- | "constraint"; t1 = ctyp; "="; t2 = ctyp ->
- <:class_sig_item< type $t1$ = $t2$ >> ] ]
- ;
- class_description:
- [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; ":";
- ct = class_type ->
- {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
- MLast.ciNam = n; MLast.ciExp = ct} ] ]
- ;
- class_type_declaration:
- [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; "=";
- cs = class_signature ->
- {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
- MLast.ciNam = n; MLast.ciExp = cs} ] ]
- ;
- (* Expressions *)
- expr: LEVEL "simple"
- [ LEFTA
- [ "new"; i = class_longident -> <:expr< new $list:i$ >> ] ]
- ;
- expr: LEVEL "."
- [ [ e = SELF; "#"; lab = label -> <:expr< $e$ # $lab$ >> ] ]
- ;
- expr: LEVEL "simple"
- [ [ "("; e = SELF; ":"; t = ctyp; ":>"; t2 = ctyp; ")" ->
- <:expr< ($e$ : $t$ :> $t2$) >>
- | "("; e = SELF; ":>"; t = ctyp; ")" -> <:expr< ($e$ :> $t$) >>
- | "{<"; ">}" -> <:expr< {< >} >>
- | "{<"; fel = field_expr_list; ">}" -> <:expr< {< $list:fel$ >} >> ] ]
- ;
- field_expr_list:
- [ [ l = label; "="; e = expr LEVEL "expr1"; ";"; fel = SELF ->
- [(l, e) :: fel]
- | l = label; "="; e = expr LEVEL "expr1"; ";" -> [(l, e)]
- | l = label; "="; e = expr LEVEL "expr1" -> [(l, e)] ] ]
- ;
- (* Core types *)
- ctyp: LEVEL "simple"
- [ [ "#"; id = class_longident -> <:ctyp< # $list:id$ >>
- | "<"; (ml, v) = meth_list; ">" -> <:ctyp< < $list:ml$ $opt:v$ > >>
- | "<"; ">" -> <:ctyp< < > >> ] ]
- ;
- meth_list:
- [ [ f = field; ";"; (ml, v) = SELF -> ([f :: ml], v)
- | f = field; ";" -> ([f], False)
- | f = field -> ([f], False)
- | ".." -> ([], True) ] ]
- ;
- field:
- [ [ lab = LIDENT; ":"; t = poly_type -> (lab, t) ] ]
- ;
- (* Polymorphic types *)
- typevar:
- [ [ "'"; i = ident -> i ] ]
- ;
- poly_type:
- [ [ test_typevar_list_dot; tpl = LIST1 typevar; "."; t2 = ctyp ->
- <:ctyp< ! $list:tpl$ . $t2$ >>
- | t = ctyp -> t ] ]
- ;
- (* Identifiers *)
- clty_longident:
- [ [ m = UIDENT; "."; l = SELF -> [m :: l]
- | i = LIDENT -> [i] ] ]
- ;
- class_longident:
- [ [ m = UIDENT; "."; l = SELF -> [m :: l]
- | i = LIDENT -> [i] ] ]
- ;
- (* Labels *)
- ctyp: LEVEL "arrow"
- [ RIGHTA
- [ i = lident_colon; t1 = ctyp LEVEL "star"; "->"; t2 = SELF ->
- <:ctyp< ( ~ $i$ : $t1$ ) -> $t2$ >>
- | i = OPTLABEL; t1 = ctyp LEVEL "star"; "->"; t2 = SELF ->
- <:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >>
- | i = QUESTIONIDENT; ":"; t1 = ctyp LEVEL "star"; "->"; t2 = SELF ->
- <:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >>
- | "?"; i=lident_colon;t1 = ctyp LEVEL "star"; "->"; t2 = SELF ->
- <:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >> ] ]
- ;
- ctyp: LEVEL "simple"
- [ [ "["; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" ->
- <:ctyp< [ = $list:rfl$ ] >>
- | "["; ">"; "]" -> <:ctyp< [ > $list:[]$ ] >>
- | "["; ">"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" ->
- <:ctyp< [ > $list:rfl$ ] >>
- | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" ->
- <:ctyp< [ < $list:rfl$ ] >>
- | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; ">";
- ntl = LIST1 name_tag; "]" ->
- <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ]
- ;
- row_field:
- [ [ "`"; i = ident -> MLast.RfTag i True []
- | "`"; i = ident; "of"; ao = OPT "&"; l = LIST1 ctyp SEP "&" ->
- MLast.RfTag i (o2b ao) l
- | t = ctyp -> MLast.RfInh t ] ]
- ;
- name_tag:
- [ [ "`"; i = ident -> i ] ]
- ;
- expr: LEVEL "expr1"
- [ [ "fun"; p = labeled_patt; e = fun_def -> <:expr< fun $p$ -> $e$ >> ] ]
- ;
- expr: AFTER "apply"
- [ "label"
- [ i = LABEL; e = SELF -> <:expr< ~ $i$ : $e$ >>
- | i = TILDEIDENT -> <:expr< ~ $i$ >>
- | "~"; i = LIDENT -> <:expr< ~ $i$ >>
- | i = OPTLABEL; e = SELF -> <:expr< ? $i$ : $e$ >>
- | i = QUESTIONIDENT -> <:expr< ? $i$ >>
- | "?"; i = LIDENT -> <:expr< ? $i$ >> ] ]
- ;
- expr: LEVEL "simple"
- [ [ "`"; s = ident -> <:expr< ` $s$ >> ] ]
- ;
- fun_def:
- [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ]
- ;
- fun_binding:
- [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ]
- ;
- patt: LEVEL "simple"
- [ [ "`"; s = ident -> <:patt< ` $s$ >>
- | "#"; t = mod_ident -> <:patt< # $list:t$ >> ] ]
- ;
- labeled_patt:
- [ [ i = LABEL; p = patt LEVEL "simple" ->
- <:patt< ~ $i$ : $p$ >>
- | i = TILDEIDENT ->
- <:patt< ~ $i$ >>
- | "~"; i=LIDENT -> <:patt< ~ $i$ >>
- | "~"; "("; i = LIDENT; ")" ->
- <:patt< ~ $i$ >>
- | "~"; "("; i = LIDENT; ":"; t = ctyp; ")" ->
- <:patt< ~ $i$ : ($lid:i$ : $t$) >>
- | i = OPTLABEL; j = LIDENT ->
- <:patt< ? $i$ : ($lid:j$) >>
- | i = OPTLABEL; "("; p = patt; "="; e = expr; ")" ->
- <:patt< ? $i$ : ( $p$ = $e$ ) >>
- | i = OPTLABEL; "("; p = patt; ":"; t = ctyp; ")" ->
- <:patt< ? $i$ : ( $p$ : $t$ ) >>
- | i = OPTLABEL; "("; p = patt; ":"; t = ctyp; "=";
- e = expr; ")" ->
- <:patt< ? $i$ : ( $p$ : $t$ = $e$ ) >>
- | i = QUESTIONIDENT -> <:patt< ? $i$ >>
- | "?"; i = LIDENT -> <:patt< ? $i$ >>
- | "?"; "("; i = LIDENT; "="; e = expr; ")" ->
- <:patt< ? ( $lid:i$ = $e$ ) >>
- | "?"; "("; i = LIDENT; ":"; t = ctyp; "="; e = expr; ")" ->
- <:patt< ? ( $lid:i$ : $t$ = $e$ ) >>
- | "?"; "("; i = LIDENT; ")" ->
- <:patt< ? $i$ >>
- | "?"; "("; i = LIDENT; ":"; t = ctyp; ")" ->
- <:patt< ? ( $lid:i$ : $t$ ) >> ] ]
- ;
- class_type:
- [ [ i = lident_colon; t = ctyp LEVEL "star"; "->"; ct = SELF ->
- <:class_type< [ ~ $i$ : $t$ ] -> $ct$ >>
- | i = OPTLABEL; t = ctyp LEVEL "star"; "->"; ct = SELF ->
- <:class_type< [ ? $i$ : $t$ ] -> $ct$ >>
- | i = QUESTIONIDENT; ":"; t = ctyp LEVEL "star"; "->"; ct = SELF ->
- <:class_type< [ ? $i$ : $t$ ] -> $ct$ >>
- | "?"; i = LIDENT; ":"; t = ctyp LEVEL "star"; "->"; ct = SELF ->
- <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> ] ]
- ;
- class_fun_binding:
- [ [ p = labeled_patt; cfb = SELF -> <:class_expr< fun $p$ -> $cfb$ >> ] ]
- ;
-END;
-
-(* Main entry points *)
-
-EXTEND
- GLOBAL: interf implem use_file top_phrase expr patt;
- interf:
- [ [ si = sig_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped)
- | "#"; n = LIDENT; dp = OPT expr; ";;" ->
- ([(<:sig_item< # $n$ $opt:dp$ >>, loc)], True)
- | EOI -> ([], False) ] ]
- ;
- sig_item_semi:
- [ [ si = sig_item; OPT ";;" -> (si, loc) ] ]
- ;
- implem:
- [ [ si = str_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped)
- | "#"; n = LIDENT; dp = OPT expr; ";;" ->
- ([(<:str_item< # $n$ $opt:dp$ >>, loc)], True)
- | EOI -> ([], False) ] ]
- ;
- str_item_semi:
- [ [ si = str_item; OPT ";;" -> (si, loc) ] ]
- ;
- top_phrase:
- [ [ ph = phrase; ";;" -> Some ph
- | EOI -> None ] ]
- ;
- use_file:
- [ [ si = str_item; OPT ";;"; (sil, stopped) = SELF ->
- ([si :: sil], stopped)
- | "#"; n = LIDENT; dp = OPT expr; ";;" ->
- ([<:str_item< # $n$ $opt:dp$ >>], True)
- | EOI -> ([], False) ] ]
- ;
- phrase:
- [ [ sti = str_item -> sti
- | "#"; n = LIDENT; dp = OPT expr -> <:str_item< # $n$ $opt:dp$ >> ] ]
- ;
-END;
-
-Pcaml.add_option "-no_quot" (Arg.Set Plexer.no_quotations)
- "Don't parse quotations, allowing to use, e.g. \"<:>\" as token";
diff --git a/camlp4/etc/pa_ocamllex.ml b/camlp4/etc/pa_ocamllex.ml
deleted file mode 100644
index 76c8c6aea9..0000000000
--- a/camlp4/etc/pa_ocamllex.ml
+++ /dev/null
@@ -1,344 +0,0 @@
-(* camlp4 ./pa_o.cmo q_MLast.cmo pa_extend.cmo pr_dump.cmo *)
-(* $Id$ *)
-(* Alain Frisch's contribution *)
-
-open Syntax
-open Lexgen
-open Compact
-
-(* Adapted from output.ml *)
-(**************************)
-
-(* Output the DFA tables and its entry points *)
-
-(* To output an array of short ints, encoded as a string *)
-
-let output_byte buf b =
- Buffer.add_char buf '\\';
- Buffer.add_char buf (Char.chr(48 + b / 100));
- Buffer.add_char buf (Char.chr(48 + (b / 10) mod 10));
- Buffer.add_char buf (Char.chr(48 + b mod 10))
-
-let loc = (-1,-1)
-
-let output_array v =
- let b = Buffer.create (Array.length v * 3) in
- for i = 0 to Array.length v - 1 do
- output_byte b (v.(i) land 0xFF);
- output_byte b ((v.(i) asr 8) land 0xFF);
- if i land 7 = 7 then Buffer.add_string b "\\\n "
- done;
- let s = Buffer.contents b in
- <:expr< $str:s$ >>
-
-let output_byte_array v =
- let b = Buffer.create (Array.length v * 2) in
- for i = 0 to Array.length v - 1 do
- output_byte b (v.(i) land 0xFF);
- if i land 15 = 15 then Buffer.add_string b "\\\n "
- done;
- let s = Buffer.contents b in
- <:expr< $str:s$ >>
-
-
-
-(* Output the tables *)
-
-let output_tables tbl =
- <:str_item< value lex_tables = {
- Lexing.lex_base = $output_array tbl.tbl_base$;
- Lexing.lex_backtrk = $output_array tbl.tbl_backtrk$;
- Lexing.lex_default = $output_array tbl.tbl_default$;
- Lexing.lex_trans = $output_array tbl.tbl_trans$;
- Lexing.lex_check = $output_array tbl.tbl_check$;
- Lexing.lex_base_code = $output_array tbl.tbl_base_code$;
- Lexing.lex_backtrk_code = $output_array tbl.tbl_backtrk_code$;
- Lexing.lex_default_code = $output_array tbl.tbl_default_code$;
- Lexing.lex_trans_code = $output_array tbl.tbl_trans_code$;
- Lexing.lex_check_code = $output_array tbl.tbl_check_code$;
- Lexing.lex_code = $output_byte_array tbl.tbl_code$
- } >>
-
-(* Output the entries *)
-
-let rec make_alias n = function
- | [] -> []
- | h::t ->
- (h, "__ocaml_lex_arg_" ^ (string_of_int n)) :: (make_alias (succ n) t)
-
-let abstraction =
- List.fold_right (fun (p,a) e -> <:expr< fun ($p$ as $lid:a$) -> $e$ >>)
-
-
-let application =
- List.fold_left (fun f (_,a) -> <:expr< $f$ $lid:a$ >>)
-
-let int i = <:expr< $int:string_of_int i$ >>
-
-let output_memory_actions acts =
- let aux = function
- | Copy (tgt, src) ->
- <:expr< lexbuf.Lexing.lex_mem.($int tgt$) :=
- lexbuf.Lexing.lex_mem.($int src$) >>
- | Set tgt ->
- <:expr< lexbuf.Lexing.lex_mem.($int tgt$) :=
- lexbuf.Lexing.lex_curr_pos >>
- in
- <:expr< do { $list:List.map aux acts$ } >>
-
-let output_base_mem = function
- | Mem i -> <:expr< lexbuf.Lexing.lex_mem.($int i$) >>
- | Start -> <:expr< lexbuf.Lexing.lex_start_pos >>
- | End -> <:expr< lexbuf.Lexing.lex_curr_pos >>
-
-let output_tag_access = function
- | Sum (a,0) -> output_base_mem a
- | Sum (a,i) -> <:expr< $output_base_mem a$ + $int i$ >>
-
-let rec output_env e = function
- | [] -> e
- | (x, Ident_string (o,nstart,nend)) :: rem ->
- <:expr<
- let $lid:x$ =
- Lexing.$lid:if o then "sub_lexeme_opt" else "sub_lexeme"$
- lexbuf $output_tag_access nstart$ $output_tag_access nend$
- in $output_env e rem$
- >>
- | (x, Ident_char (o,nstart)) :: rem ->
- <:expr<
- let $lid:x$ =
- Lexing.$lid: if o then "sub_lexeme_char_opt" else "sub_lexeme_char"$
- lexbuf $output_tag_access nstart$
- in $output_env e rem$
- >>
-
-let output_entry e =
- let init_num, init_moves = e.auto_initial_state in
- let args = make_alias 0 (e.auto_args @ [ <:patt< lexbuf >> ]) in
- let f = "__ocaml_lex_rec_" ^ e.auto_name ^ "_rec" in
- let call_f = application <:expr< $lid:f$ >> args in
- let body_wrapper =
- <:expr<
- do {
- lexbuf.Lexing.lex_mem := Array.create $int e.auto_mem_size$ (-1) ;
- $output_memory_actions init_moves$;
- $call_f$ $int init_num$
- } >> in
- let cases =
- List.map
- (fun (num, env, (loc,e)) ->
- <:patt< $int:string_of_int num$ >>,
- None,
- output_env <:expr< $e$ >> env
- (* Note: the <:expr<...>> above is there to set the location *)
- ) e.auto_actions @
- [ <:patt< __ocaml_lex_n >>,
- None,
- <:expr< do
- { lexbuf.Lexing.refill_buff lexbuf; $call_f$ __ocaml_lex_n }>> ]
- in
- let engine =
- if e.auto_mem_size = 0
- then <:expr< Lexing.engine >>
- else <:expr< Lexing.new_engine >> in
- let body =
- <:expr< fun state ->
- match $engine$ lex_tables state lexbuf with [ $list:cases$ ] >> in
- [
- <:patt< $lid:e.auto_name$ >>, (abstraction args body_wrapper);
- <:patt< $lid:f$ >>, (abstraction args body)
- ]
-
-(* Main output function *)
-
-exception Table_overflow
-
-let output_lexdef tables entry_points =
- Printf.eprintf
- "pa_ocamllex: lexer found; %d states, %d transitions, table size %d bytes\n"
- (Array.length tables.tbl_base)
- (Array.length tables.tbl_trans)
- (2 * (Array.length tables.tbl_base + Array.length tables.tbl_backtrk +
- Array.length tables.tbl_default + Array.length tables.tbl_trans +
- Array.length tables.tbl_check));
- let size_groups =
- (2 * (Array.length tables.tbl_base_code +
- Array.length tables.tbl_backtrk_code +
- Array.length tables.tbl_default_code +
- Array.length tables.tbl_trans_code +
- Array.length tables.tbl_check_code) +
- Array.length tables.tbl_code) in
- if size_groups > 0 then
- Printf.eprintf "pa_ocamllex: %d additional bytes used for bindings\n"
- size_groups ;
- flush stderr;
- if Array.length tables.tbl_trans > 0x8000 then raise Table_overflow;
-
- let entries = List.map output_entry entry_points in
- [output_tables tables; <:str_item< value rec $list:List.flatten entries$ >> ]
-
-
-(* Adapted from parser.mly and main.ml *)
-(***************************************)
-
-(* Auxiliaries for the parser. *)
-
-let char s = Char.code (Token.eval_char s)
-
-let named_regexps =
- (Hashtbl.create 13 : (string, regular_expression) Hashtbl.t)
-
-let regexp_for_string s =
- let rec re_string n =
- if n >= String.length s then Epsilon
- else if succ n = String.length s then
- Characters (Cset.singleton (Char.code s.[n]))
- else
- Sequence
- (Characters(Cset.singleton (Char.code s.[n])),
- re_string (succ n))
- in re_string 0
-
-let char_class c1 c2 = Cset.interval c1 c2
-
-let all_chars = Cset.all_chars
-
-let rec remove_as = function
- | Bind (e,_) -> remove_as e
- | Epsilon|Eof|Characters _ as e -> e
- | Sequence (e1, e2) -> Sequence (remove_as e1, remove_as e2)
- | Alternative (e1, e2) -> Alternative (remove_as e1, remove_as e2)
- | Repetition e -> Repetition (remove_as e)
-
-let () =
- Hashtbl.add named_regexps "eof" (Characters Cset.eof)
-
-(* The parser *)
-
-let let_regexp = Grammar.Entry.create Pcaml.gram "pa_ocamllex let"
-let header = Grammar.Entry.create Pcaml.gram "pa_ocamllex header"
-let lexer_def = Grammar.Entry.create Pcaml.gram "pa_ocaml lexerdef"
-
-EXTEND
- GLOBAL: Pcaml.str_item let_regexp header lexer_def;
-
- let_regexp: [
- [ x = LIDENT; "="; r = regexp ->
- if Hashtbl.mem named_regexps x then
- Printf.eprintf
- "pa_ocamllex (warning): multiple definition of named regexp '%s'\n"
- x;
- Hashtbl.add named_regexps x r;
- ]
- ];
-
- lexer_def: [
- [ def = LIST0 definition SEP "and" ->
- (try
- let (entries, transitions) = make_dfa def in
- let tables = compact_tables transitions in
- let output = output_lexdef tables entries in
- <:str_item< declare $list: output$ end >>
- with
- |Table_overflow ->
- failwith "Transition table overflow in lexer, automaton is too big"
- | Lexgen.Memory_overflow ->
- failwith "Position memory overflow in lexer, too many as variables")
- ]
- ];
-
-
- Pcaml.str_item: [
- [ "pa_ocamllex"; LIDENT "rule"; d = lexer_def -> d
- | "pa_ocamllex"; "let"; let_regexp ->
- <:str_item< declare $list: []$ end >>
- ]
- ];
-
- definition: [
- [ x=LIDENT; pl = LIST0 Pcaml.patt; "=";
- short=[ LIDENT "parse" -> false | LIDENT "shortest" -> true ];
- OPT "|"; l = LIST0 [ r=regexp; a=action -> (r,a) ] SEP "|" ->
- { name=x ; shortest=short ; args=pl ; clauses = l } ]
- ];
-
- action: [
- [ "{"; e = OPT Pcaml.expr; "}" ->
- let e = match e with
- | Some e -> e
- | None -> <:expr< () >>
- in
- (loc,e)
- ]
- ];
-
- header: [
- [ "{"; e = LIST0 [ si = Pcaml.str_item; OPT ";;" -> si ]; "}" ->
- [<:str_item< declare $list:e$ end>>, loc] ]
- | [ -> [] ]
- ];
-
- regexp: [
- [ r = regexp; "as"; i = LIDENT -> Bind (r,i) ]
- | [ r1 = regexp; "|"; r2 = regexp -> Alternative(r1,r2) ]
- | [ r1 = regexp; r2 = regexp -> Sequence(r1,r2) ]
- | [ r = regexp; "*" -> Repetition r
- | r = regexp; "+" -> Sequence(Repetition (remove_as r), r)
- | r = regexp; "?" -> Alternative(Epsilon, r)
- | "("; r = regexp; ")" -> r
- | "_" -> Characters all_chars
- | c = CHAR -> Characters (Cset.singleton (char c))
- | s = STRING -> regexp_for_string (Token.eval_string s)
- | "["; cc = ch_class; "]" -> Characters cc
- | x = LIDENT ->
- try Hashtbl.find named_regexps x
- with Not_found ->
- failwith
- ("pa_ocamllex (error): reference to unbound regexp name `"^x^"'")
- ]
- ];
-
- ch_class: [
- [ "^"; cc = ch_class -> Cset.complement cc]
- | [ c1 = CHAR; "-"; c2 = CHAR -> Cset.interval (char c1) (char c2)
- | c = CHAR -> Cset.singleton (char c)
- | cc1 = ch_class; cc2 = ch_class -> Cset.union cc1 cc2
- ]
- ];
-END
-
-(* We have to be careful about "rule"; in standalone mode,
- it is used as a keyword (otherwise, there is a conflict
- with named regexp); in normal mode, it is used as LIDENT
- (we do not want to reserve such an useful identifier).
-
- Plexer does not like identifiers used as keyword _and_
- as LIDENT ...
-*)
-
-let standalone =
- let already = ref false in
- fun () ->
- if not (!already) then
- begin
- already := true;
- Printf.eprintf "pa_ocamllex: stand-alone mode\n";
-
- DELETE_RULE Pcaml.str_item: "pa_ocamllex"; LIDENT "rule";lexer_def END;
- DELETE_RULE Pcaml.str_item: "pa_ocamllex"; "let"; let_regexp END;
- let ocamllex = Grammar.Entry.create Pcaml.gram "pa_ocamllex" in
- EXTEND GLOBAL: ocamllex let_regexp header lexer_def;
- ocamllex: [
- [ h = header;
- l = [LIST0 ["let"; let_regexp]; "rule"; d = lexer_def -> (d,loc)];
- t = header; EOI -> h @ (l :: t) ,false
- ]
- ];
- END;
- Pcaml.parse_implem := Grammar.Entry.parse ocamllex
- end
-
-let () =
- Pcaml.add_option "-ocamllex" (Arg.Unit standalone)
- "Activate (standalone) ocamllex emulation mode."
-
diff --git a/camlp4/etc/pa_olabl.ml b/camlp4/etc/pa_olabl.ml
deleted file mode 100644
index d43b499dfd..0000000000
--- a/camlp4/etc/pa_olabl.ml
+++ /dev/null
@@ -1,2005 +0,0 @@
-(* camlp4r pa_extend.cmo q_MLast.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-module Plexer =
- struct
- open Stdpp;
- open Token;
- value buff = ref (String.create 80);
- value store len x =
- do {
- if len >= String.length buff.val then
- buff.val := buff.val ^ String.create (String.length buff.val)
- else ();
- buff.val.[len] := x;
- succ len
- }
- ;
- value mstore len s =
- add_rec len 0 where rec add_rec len i =
- if i == String.length s then len
- else add_rec (store len s.[i]) (succ i)
- ;
- value get_buff len = String.sub buff.val 0 len;
- value rec ident len =
- parser
- [ [: `('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
- '\248'..'\255' | '0'..'9' | '_' | ''' as
- c)
- ;
- s :] ->
- ident (store len c) s
- | [: :] -> len ]
- and ident2 len =
- parser
- [ [: `('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
- '%' | '.' | ':' | '<' | '>' | '|' as
- c)
- ;
- s :] ->
- ident2 (store len c) s
- | [: :] -> len ]
- and ident3 len =
- parser
- [ [: `('0'..'9' | 'A'..'Z' | 'a'..'z' | '\192'..'\214' |
- '\216'..'\246' | '\248'..'\255' | '_' | '!' | '%' | '&' | '*' |
- '+' | '-' | '.' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '^' |
- '|' | '~' | ''' | '$' as
- c)
- ;
- s :] ->
- ident3 (store len c) s
- | [: :] -> len ]
- and ident4 len =
- parser
- [ [: `('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
- '%' | '.' | '<' | '>' | '|' as
- c)
- ;
- s :] ->
- ident4 (store len c) s
- | [: :] -> len ]
- and base_number len =
- parser
- [ [: `'o' | 'O'; s :] -> octal_digits (store len 'o') s
- | [: `'x' | 'X'; s :] -> hexa_digits (store len 'x') s
- | [: `'b' | 'B'; s :] -> binary_digits (store len 'b') s
- | [: a = number len :] -> a ]
- and octal_digits len =
- parser
- [ [: `('0'..'7' as d); s :] -> octal_digits (store len d) s
- | [: :] -> ("INT", get_buff len) ]
- and hexa_digits len =
- parser
- [ [: `('0'..'9' | 'a'..'f' | 'A'..'F' as d); s :] ->
- hexa_digits (store len d) s
- | [: :] -> ("INT", get_buff len) ]
- and binary_digits len =
- parser
- [ [: `('0'..'1' as d); s :] -> binary_digits (store len d) s
- | [: :] -> ("INT", get_buff len) ]
- and number len =
- parser
- [ [: `('0'..'9' as c); s :] -> number (store len c) s
- | [: `'.'; s :] -> decimal_part (store len '.') s
- | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s
- | [: :] -> ("INT", get_buff len) ]
- and decimal_part len =
- parser
- [ [: `('0'..'9' as c); s :] -> decimal_part (store len c) s
- | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s
- | [: :] -> ("FLOAT", get_buff len) ]
- and exponent_part len =
- parser
- [ [: `('+' | '-' as c); s :] -> end_exponent_part (store len c) s
- | [: a = end_exponent_part len :] -> a ]
- and end_exponent_part len =
- parser
- [ [: `('0'..'9' as c); s :] -> end_exponent_part (store len c) s
- | [: :] -> ("FLOAT", get_buff len) ]
- ;
- value valch x = Char.code x - Char.code '0';
- value rec backslash s i =
- if i = String.length s then raise Not_found
- else
- match s.[i] with
- [ 'n' -> ('\n', i + 1)
- | 'r' -> ('\r', i + 1)
- | 't' -> ('\t', i + 1)
- | 'b' -> ('\b', i + 1)
- | '\\' -> ('\\', i + 1)
- | '0'..'9' as c -> backslash1 (valch c) s (i + 1)
- | _ -> raise Not_found ]
- and backslash1 cod s i =
- if i = String.length s then (Char.chr cod, i)
- else
- match s.[i] with
- [ '0'..'9' as c -> backslash2 (10 * cod + valch c) s (i + 1)
- | _ -> (Char.chr cod, i) ]
- and backslash2 cod s i =
- if i = String.length s then (Char.chr cod, i)
- else
- match s.[i] with
- [ '0'..'9' as c -> (Char.chr (10 * cod + valch c), i + 1)
- | _ -> (Char.chr cod, i) ]
- ;
- value rec skip_indent s i =
- if i = String.length s then i
- else
- match s.[i] with
- [ ' ' | '\t' -> skip_indent s (i + 1)
- | _ -> i ]
- ;
- value skip_opt_linefeed s i =
- if i = String.length s then i else if s.[i] = '\010' then i + 1 else i
- ;
- value char_of_char_token s =
- if String.length s = 1 then s.[0]
- else if String.length s = 0 then failwith "invalid char token"
- else if s.[0] = '\\' then
- if String.length s = 2 && s.[1] = ''' then '''
- else
- try
- let (c, i) = backslash s 1 in
- if i = String.length s then c else raise Not_found
- with
- [ Not_found -> failwith "invalid char token" ]
- else failwith "invalid char token"
- ;
- value string_of_string_token s =
- loop 0 0 where rec loop len i =
- if i = String.length s then get_buff len
- else
- let (len, i) =
- if s.[i] = '\\' then
- let i = i + 1 in
- if i = String.length s then failwith "invalid string token"
- else if s.[i] = '"' then (store len '"', i + 1)
- else
- match s.[i] with
- [ '\010' -> (len, skip_indent s (i + 1))
- | '\013' -> (len, skip_indent s (skip_opt_linefeed s (i + 1)))
- | c ->
- try
- let (c, i) = backslash s i in
- (store len c, i)
- with
- [ Not_found -> (store (store len '\\') c, i + 1) ] ]
- else (store len s.[i], i + 1)
- in
- loop len i
- ;
- value rec skip_spaces =
- parser
- [ [: `' ' | '\n' | '\r' | '\t' | '\026' | '\012'; s :] -> skip_spaces s
- | [: :] -> () ]
- ;
- value error_on_unknown_keywords = ref False;
- value next_token_fun find_id_kwd find_spe_kwd =
- let err bp ep msg = raise_with_loc (bp, ep) (Token.Error msg) in
- let keyword_or_error (bp, ep) s =
- try ("", find_spe_kwd s) with
- [ Not_found ->
- if error_on_unknown_keywords.val then
- err bp ep ("illegal token: " ^ s)
- else ("", s) ]
- in
- let rec next_token =
- parser bp
- [ [: `('A'..'Z' | 'À'..'Ö' | 'Ø'..'Þ' as c); s :] ->
- let id = get_buff (ident (store 0 c) s) in
- try ("", find_id_kwd id) with [ Not_found -> ("UIDENT", id) ]
- | [: `('a'..'z' | 'ß'..'ö' | 'ø'..'ÿ' | '_' as c); s :] ->
- let id = get_buff (ident (store 0 c) s) in
- let is_label =
- match Stream.peek s with
- [ Some ':' ->
- match Stream.npeek 2 s with
- [ [_; ':' | '=' | '>'] -> False
- | _ -> True ]
- | _ -> False ]
- in
- if is_label then do { Stream.junk s; ("LABEL", id) }
- else try ("", find_id_kwd id) with [ Not_found -> ("LIDENT", id) ]
- | [: `('1'..'9' as c); s :] -> number (store 0 c) s
- | [: `'0'; s :] -> base_number (store 0 '0') s
- | [: `'''; s :] ep ->
- match Stream.npeek 2 s with
- [ [_; '''] | ['\\'; _] -> ("CHAR", char bp 0 s)
- | _ -> keyword_or_error (bp, ep) "'" ]
- | [: `'"'; s :] -> ("STRING", string bp 0 s)
- | [: `'$'; s :] -> locate_or_antiquot bp 0 s
- | [: `('!' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
- '%' as
- c)
- ;
- s :] ->
- let id = get_buff (ident2 (store 0 c) s) in
- keyword_or_error (bp, Stream.count s) id
- | [: `('?' as c); s :] ->
- let id = get_buff (ident4 (store 0 c) s) in
- keyword_or_error (bp, Stream.count s) id
- | [: `'<'; s :] -> less bp s
- | [: `(':' as c1);
- (is_label, len) =
- parser
- [ [: `(']' | ':' | '=' | '>' as c2) :] ->
- (False, store (store 0 c1) c2)
- | [: `('a'..'z' | 'ß'..'ö' | 'ø'..'ÿ' | '_' as c); s :] ->
- (True, ident (store 0 c) s)
- | [: :] -> (False, store 0 c1) ] :] ep ->
- let id = get_buff len in
- if is_label then ("ELABEL", id) else keyword_or_error (bp, ep) id
- | [: `('>' | '|' as c1);
- len =
- parser
- [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2
- | [: a = ident2 (store 0 c1) :] -> a ] :] ep ->
- let id = get_buff len in
- keyword_or_error (bp, ep) id
- | [: `('[' | '{' as c1); s :] ->
- let len =
- match Stream.npeek 2 s with
- [ ['<'; '<' | ':'] -> store 0 c1
- | _ ->
- match s with parser
- [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2
- | [: :] -> store 0 c1 ] ]
- in
- let ep = Stream.count s in
- let id = get_buff len in
- keyword_or_error (bp, ep) id
- | [: `'.'; id = parser [ [: `'.' :] -> ".." | [: :] -> "." ] :] ep ->
- keyword_or_error (bp, ep) id
- | [: `';'; id = parser [ [: `';' :] -> ";;" | [: :] -> ";" ] :] ep ->
- keyword_or_error (bp, ep) id
- | [: `'\\'; s :] -> ("LIDENT", get_buff (ident3 0 s))
- | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c) ]
- and less bp =
- parser
- [ [: `'<'; s :] -> ("QUOTATION", ":" ^ get_buff (quotation bp 0 s))
- | [: `':'; i = parser [: len = ident 0 :] -> get_buff len;
- `'<' ? "character '<' expected"; s :] ->
- ("QUOTATION", i ^ ":" ^ get_buff (quotation bp 0 s))
- | [: s :] ep ->
- let id = get_buff (ident2 (store 0 '<') s) in
- keyword_or_error (bp, ep) id ]
- and string bp len =
- parser
- [ [: `'"' :] -> get_buff len
- | [: `'\\'; `c; s :] -> string bp (store (store len '\\') c) s
- | [: `c; s :] -> string bp (store len c) s
- | [: :] ep -> err bp ep "string not terminated" ]
- and char bp len =
- parser
- [ [: `'''; s :] ->
- if len = 0 then char bp (store len ''') s else get_buff len
- | [: `'\\'; `c; s :] -> char bp (store (store len '\\') c) s
- | [: `c; s :] -> char bp (store len c) s
- | [: :] ep -> err bp ep "char not terminated" ]
- and locate_or_antiquot bp len =
- parser
- [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
- | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bp (store len c) s
- | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s
- | [: `':'; s :] ->
- let k = get_buff len in
- ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s)
- | [: `'\\'; `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: :] ep -> err bp ep "antiquotation not terminated" ]
- and maybe_locate bp len =
- parser
- [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
- | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s
- | [: `':'; s :] ->
- ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 s)
- | [: `'\\'; `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: :] ep -> err bp ep "antiquotation not terminated" ]
- and antiquot bp len =
- parser
- [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
- | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] ->
- antiquot bp (store len c) s
- | [: `':'; s :] ->
- let k = get_buff len in
- ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s)
- | [: `'\\'; `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: :] ep -> err bp ep "antiquotation not terminated" ]
- and locate_or_antiquot_rest bp len =
- parser
- [ [: `'$' :] -> get_buff len
- | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bp (store len c) s
- | [: `c; s :] -> locate_or_antiquot_rest bp (store len c) s
- | [: :] ep -> err bp ep "antiquotation not terminated" ]
- and quotation bp len =
- parser
- [ [: `'>'; s :] -> maybe_end_quotation bp len s
- | [: `'<'; s :] ->
- quotation bp (maybe_nested_quotation bp (store len '<') strm__) s
- | [: `'\\';
- len =
- parser
- [ [: `('>' | '<' | '\\' as c) :] -> store len c
- | [: :] -> store len '\\' ];
- s :] ->
- quotation bp len s
- | [: `c; s :] -> quotation bp (store len c) s
- | [: :] ep -> err bp ep "quotation not terminated" ]
- and maybe_nested_quotation bp len =
- parser
- [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>"
- | [: `':'; len = ident (store len ':');
- a =
- parser
- [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>"
- | [: :] -> len ] :] ->
- a
- | [: :] -> len ]
- and maybe_end_quotation bp len =
- parser
- [ [: `'>' :] -> len
- | [: a = quotation bp (store len '>') :] -> a ]
- in
- let rec next_token_loc =
- parser bp
- [ [: `' ' | '\n' | '\r' | '\t' | '\026' | '\012'; s :] ->
- next_token_loc s
- | [: `'('; s :] -> maybe_comment bp s
- | [: `'#'; _ = spaces_tabs; a = linenum bp :] -> a
- | [: tok = next_token :] ep -> (tok, (bp, ep))
- | [: _ = Stream.empty :] -> (("EOI", ""), (bp, succ bp)) ]
- and maybe_comment bp =
- parser
- [ [: `'*'; s :] -> do { comment bp s; next_token_loc s }
- | [: :] ep ->
- let tok = keyword_or_error (bp, ep) "(" in
- (tok, (bp, ep)) ]
- and comment bp =
- parser
- [ [: `'('; s :] -> maybe_nested_comment bp s
- | [: `'*'; s :] -> maybe_end_comment bp s
- | [: `c; s :] -> comment bp s
- | [: :] ep -> err bp ep "comment not terminated" ]
- and maybe_nested_comment bp =
- parser
- [ [: `'*'; s :] -> do { comment bp s; comment bp s }
- | [: a = comment bp :] -> a ]
- and maybe_end_comment bp =
- parser [ [: `')' :] -> () | [: a = comment bp :] -> a ]
- and linenum bp =
- parser
- [ [: `'0'..'9'; _ = digits; _ = spaces_tabs; `'"'; _ = any_to_nl;
- s :] ->
- next_token_loc s
- | [: :] -> (keyword_or_error (bp, bp + 1) "#", (bp, bp + 1)) ]
- and spaces_tabs =
- parser [ [: `' ' | '\t'; s :] -> spaces_tabs s | [: :] -> () ]
- and digits = parser [ [: `'0'..'9'; s :] -> digits s | [: :] -> () ]
- and any_to_nl =
- parser
- [ [: `'\r' | '\n' :] -> ()
- | [: `_; s :] -> any_to_nl s
- | [: :] -> () ]
- in
- fun cstrm ->
- try next_token_loc cstrm with
- [ Stream.Error str ->
- err (Stream.count cstrm) (Stream.count cstrm + 1) str ]
- ;
- value locerr () = invalid_arg "Lexer: location function";
- value loct_create () = ref (Array.create 1024 None);
- value loct_func loct i =
- match
- if i < 0 || i >= Array.length loct.val then None
- else Array.unsafe_get loct.val i
- with
- [ Some loc -> loc
- | _ -> locerr () ]
- ;
- value loct_add loct i loc =
- do {
- if i >= Array.length loct.val then do {
- let new_tmax = Array.length loct.val * 2 in
- let new_loct = Array.create new_tmax None in
- Array.blit loct.val 0 new_loct 0 (Array.length loct.val);
- loct.val := new_loct
- }
- else ();
- loct.val.(i) := Some loc
- }
- ;
- value func kwd_table =
- let find = Hashtbl.find kwd_table in
- let lex cstrm =
- let next_token_loc = next_token_fun find find in
- let loct = loct_create () in
- let ts =
- Stream.from
- (fun i ->
- let (tok, loc) = next_token_loc cstrm in
- do { loct_add loct i loc; Some tok })
- in
- let locf = loct_func loct in
- (ts, locf)
- in
- lex
- ;
- value rec check_keyword_stream =
- parser [: _ = check; _ = Stream.empty :] -> True
- and check =
- parser
- [ [: `'A'..'Z' | 'a'..'z' | 'À'..'Ö' | 'Ø'..'ö' | 'ø'..'ÿ'; s :] ->
- check_ident s
- | [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
- '%' | '.'
- ;
- s :] ->
- check_ident2 s
- | [: `'<'; s :] ->
- match Stream.npeek 1 s with
- [ [':' | '<'] -> ()
- | _ -> check_ident2 s ]
- | [: `':';
- _ =
- parser
- [ [: `']' | ':' | '=' | '>' :] -> ()
- | [: :] -> () ] :] ep ->
- ()
- | [: `'>' | '|';
- _ =
- parser
- [ [: `']' | '}' :] -> ()
- | [: a = check_ident2 :] -> a ] :] ->
- ()
- | [: `'[' | '{'; s :] ->
- match Stream.npeek 2 s with
- [ ['<'; '<' | ':'] -> ()
- | _ ->
- match s with parser
- [ [: :] ->
- match Stream.peek strm__ with
- [ Some ('|' | '<' | ':') -> Stream.junk strm__
- | _ -> () ] ] ]
- | [: `';'; _ = parser [ [: `';' :] -> () | [: :] -> () ] :] -> ()
- | [: `_ :] -> () ]
- and check_ident =
- parser
- [ [: `'A'..'Z' | 'a'..'z' | 'À'..'Ö' | 'Ø'..'ö' | 'ø'..'ÿ' | '0'..'9' |
- '_' | '''
- ;
- s :] ->
- check_ident s
- | [: :] -> () ]
- and check_ident2 =
- parser
- [ [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
- '%' | '.' | ':' | '<' | '>' | '|'
- ;
- s :] ->
- check_ident2 s
- | [: :] -> () ]
- ;
- value check_keyword s =
- try check_keyword_stream (Stream.of_string s) with _ -> False
- ;
- value using_token kwd_table (p_con, p_prm) =
- match p_con with
- [ "" ->
- try
- let _ = Hashtbl.find kwd_table p_prm in
- ()
- with
- [ Not_found ->
- if check_keyword p_prm then Hashtbl.add kwd_table p_prm p_prm
- else
- raise
- (Token.Error
- ("the token \"" ^ p_prm ^
- "\" does not respect Plexer rules")) ]
- | "LIDENT" | "UIDENT" | "INT" | "FLOAT" | "CHAR" | "STRING" |
- "QUOTATION" | "ANTIQUOT" | "LOCATE" | "LABEL" | "ELABEL" | "EOI" ->
- ()
- | _ ->
- raise
- (Token.Error
- ("the constructor \"" ^ p_con ^
- "\" is not recognized by Llexer")) ]
- ;
- value removing_token kwd_table (p_con, p_prm) =
- if p_con = "" then Hashtbl.remove kwd_table p_prm else ()
- ;
- value text =
- fun
- [ ("", t) -> "'" ^ t ^ "'"
- | ("LIDENT", "") -> "lowercase identifier"
- | ("LIDENT", t) -> "'" ^ t ^ "'"
- | ("UIDENT", "") -> "uppercase identifier"
- | ("UIDENT", t) -> "'" ^ t ^ "'"
- | ("INT", "") -> "integer"
- | ("INT", s) -> "'" ^ s ^ "'"
- | ("FLOAT", "") -> "float"
- | ("STRING", "") -> "string"
- | ("CHAR", "") -> "char"
- | ("QUOTATION", "") -> "quotation"
- | ("ANTIQUOT", k) -> "antiquot \"" ^ k ^ "\""
- | ("LOCATE", "") -> "locate"
- | ("LABEL", "") -> "label"
- | ("ELABEL", "") -> "elabel"
- | ("EOI", "") -> "end of input"
- | (con, "") -> con
- | (con, prm) -> con ^ " \"" ^ prm ^ "\"" ]
- ;
- value eq_before_colon p e =
- loop 0 where rec loop i =
- if i == String.length e then
- failwith "Internal error in Plexer: incorrect ANTIQUOT"
- else if i == String.length p then e.[i] == ':'
- else if p.[i] == e.[i] then loop (i + 1)
- else False
- ;
- value after_colon e =
- try
- let i = String.index e ':' in
- String.sub e (i + 1) (String.length e - i - 1)
- with
- [ Not_found -> "" ]
- ;
- value gmake () =
- let kwd_table = Hashtbl.create 301 in
- {tok_func = func kwd_table; tok_using = using_token kwd_table;
- tok_removing = removing_token kwd_table;
- tok_match = Token.default_match; tok_text = text; tok_comm = None}
- ;
- end
-;
-
-open Stdpp;
-open Pcaml;
-
-Pcaml.no_constructors_arity.val := True;
-
-do {
- Grammar.Unsafe.gram_reinit gram (Plexer.gmake ());
- Grammar.Unsafe.clear_entry interf;
- Grammar.Unsafe.clear_entry implem;
- Grammar.Unsafe.clear_entry top_phrase;
- Grammar.Unsafe.clear_entry use_file;
- Grammar.Unsafe.clear_entry module_type;
- Grammar.Unsafe.clear_entry module_expr;
- Grammar.Unsafe.clear_entry sig_item;
- Grammar.Unsafe.clear_entry str_item;
- Grammar.Unsafe.clear_entry expr;
- Grammar.Unsafe.clear_entry patt;
- Grammar.Unsafe.clear_entry ctyp;
- Grammar.Unsafe.clear_entry let_binding;
- Grammar.Unsafe.clear_entry class_type;
- Grammar.Unsafe.clear_entry class_expr;
- Grammar.Unsafe.clear_entry class_sig_item;
- Grammar.Unsafe.clear_entry class_str_item
-};
-
-Pcaml.parse_interf.val := Grammar.Entry.parse interf;
-Pcaml.parse_implem.val := Grammar.Entry.parse implem;
-
-value o2b =
- fun
- [ Some _ -> True
- | None -> False ]
-;
-
-value mkumin loc f arg =
- match arg with
- [ <:expr< $int:n$ >> when int_of_string n > 0 ->
- let n = "-" ^ n in
- <:expr< $int:n$ >>
- | <:expr< $flo:n$ >> when float_of_string n > 0.0 ->
- let n = "-" ^ n in
- <:expr< $flo:n$ >>
- | _ ->
- let f = "~" ^ f in
- <:expr< $lid:f$ $arg$ >> ]
-;
-
-external loc_of_node : 'a -> (int * int) = "%field0";
-
-value mklistexp loc last =
- loop True where rec loop top =
- fun
- [ [] ->
- match last with
- [ Some e -> e
- | None -> <:expr< [] >> ]
- | [e1 :: el] ->
- let loc = if top then loc else (fst (loc_of_node e1), snd loc) in
- <:expr< [$e1$ :: $loop False el$] >> ]
-;
-
-value mklistpat loc last =
- loop True where rec loop top =
- fun
- [ [] ->
- match last with
- [ Some p -> p
- | None -> <:patt< [] >> ]
- | [p1 :: pl] ->
- let loc = if top then loc else (fst (loc_of_node p1), snd loc) in
- <:patt< [$p1$ :: $loop False pl$] >> ]
-;
-
-value neg s = string_of_int (- int_of_string s);
-
-value is_operator =
- let ht = Hashtbl.create 73 in
- let ct = Hashtbl.create 73 in
- do {
- List.iter (fun x -> Hashtbl.add ht x True)
- ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"];
- List.iter (fun x -> Hashtbl.add ct x True)
- ['!'; '&'; '*'; '+'; '-'; '/'; ':'; '<'; '='; '>'; '@'; '^'; '|'; '~';
- '?'; '%'; '.'];
- fun x ->
- try Hashtbl.find ht x with
- [ Not_found -> try Hashtbl.find ct x.[0] with _ -> False ]
- }
-;
-
-(*
-value p_operator strm =
- match Stream.peek strm with
- [ Some (Token.Tterm "(") ->
- match Stream.npeek 3 strm with
- [ [_; Token.Tterm x; Token.Tterm ")"] when is_operator x ->
- do { Stream.junk strm; Stream.junk strm; Stream.junk strm; x }
- | _ -> raise Stream.Failure ]
- | _ -> raise Stream.Failure ]
-;
-
-value operator = Grammar.Entry.of_parser gram "operator" p_operator;
-*)
-
-value operator =
- Grammar.Entry.of_parser gram "operator"
- (parser [: `("", x) when is_operator x :] -> x)
-;
-
-value symbolchar =
- let list =
- ['!'; '$'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; '>'; '?';
- '@'; '^'; '|'; '~']
- in
- let rec loop s i =
- if i == String.length s then True
- else if List.mem s.[i] list then loop s (i + 1)
- else False
- in
- loop
-;
-
-value prefixop =
- let list = ['!'; '?'; '~'] in
- let excl = ["!="] in
- Grammar.Entry.of_parser gram "prefixop"
- (parser
- [: `("", x)
- when
- not (List.mem x excl) && String.length x >= 2 &&
- List.mem x.[0] list && symbolchar x 1 :] ->
- x)
-;
-
-value infixop0 =
- let list = ['='; '<'; '>'; '|'; '&'; '$'] in
- let excl = ["<-"; "||"; "&&"] in
- Grammar.Entry.of_parser gram "infixop0"
- (parser
- [: `("", x)
- when
- not (List.mem x excl) && String.length x >= 2 &&
- List.mem x.[0] list && symbolchar x 1 :] ->
- x)
-;
-
-value infixop1 =
- let list = ['@'; '^'] in
- Grammar.Entry.of_parser gram "infixop1"
- (parser
- [: `("", x)
- when
- String.length x >= 2 && List.mem x.[0] list &&
- symbolchar x 1 :] ->
- x)
-;
-
-value infixop2 =
- let list = ['+'; '-'] in
- Grammar.Entry.of_parser gram "infixop2"
- (parser
- [: `("", x)
- when
- x <> "->" && String.length x >= 2 && List.mem x.[0] list &&
- symbolchar x 1 :] ->
- x)
-;
-
-value infixop3 =
- let list = ['*'; '/'; '%'] in
- Grammar.Entry.of_parser gram "infixop3"
- (parser
- [: `("", x)
- when
- String.length x >= 2 && List.mem x.[0] list &&
- symbolchar x 1 :] ->
- x)
-;
-
-value infixop4 =
- Grammar.Entry.of_parser gram "infixop4"
- (parser
- [: `("", x)
- when
- String.length x >= 3 && x.[0] == '*' && x.[1] == '*' &&
- symbolchar x 2 :] ->
- x)
-;
-
-value test_constr_decl =
- Grammar.Entry.of_parser gram "test_constr_decl"
- (fun strm ->
- match Stream.npeek 1 strm with
- [ [("UIDENT", _)] ->
- match Stream.npeek 2 strm with
- [ [_; ("", ".")] -> raise Stream.Failure
- | [_; ("", "(")] -> raise Stream.Failure
- | [_ :: _] -> ()
- | _ -> raise Stream.Failure ]
- | [("", "|")] -> ()
- | _ -> raise Stream.Failure ])
-;
-
-value stream_peek_nth n strm =
- loop n (Stream.npeek n strm) where rec loop n =
- fun
- [ [] -> None
- | [x] -> if n == 1 then Some x else None
- | [_ :: l] -> loop (n - 1) l ]
-;
-
-value test_label_eq =
- let rec test lev strm =
- match stream_peek_nth lev strm with
- [ Some (("UIDENT", _) | ("LIDENT", _) | ("", ".")) -> test (lev + 1) strm
- | Some ("", "=") -> ()
- | _ -> raise Stream.Failure ]
- in
- Grammar.Entry.of_parser gram "test_label_eq" (test 1)
-;
-
-value constr_arity = ref [("Some", 1); ("Match_Failure", 1)];
-
-value rec constr_expr_arity =
- fun
- [ <:expr< $uid:c$ >> ->
- try List.assoc c constr_arity.val with [ Not_found -> 0 ]
- | <:expr< $uid:_$.$e$ >> -> constr_expr_arity e
- | _ -> 1 ]
-;
-
-value rec constr_patt_arity =
- fun
- [ <:patt< $uid:c$ >> ->
- try List.assoc c constr_arity.val with [ Not_found -> 0 ]
- | <:patt< $uid:_$.$p$ >> -> constr_patt_arity p
- | _ -> 1 ]
-;
-
-value rec get_seq =
- fun
- [ <:expr< do { $list:el$ } >> -> el
- | e -> [e] ]
-;
-
-value choose_tvar tpl =
- let rec find_alpha v =
- let s = String.make 1 v in
- if List.mem_assoc s tpl then
- if v = 'z' then None else find_alpha (Char.chr (Char.code v + 1))
- else Some (String.make 1 v)
- in
- let rec make_n n =
- let v = "a" ^ string_of_int n in
- if List.mem_assoc v tpl then make_n (succ n) else v
- in
- match find_alpha 'a' with
- [ Some x -> x
- | None -> make_n 1 ]
-;
-
-value rec patt_lid =
- fun
- [ <:patt< $lid:i$ $p$ >> -> Some (i, [p])
- | <:patt< $p1$ $p2$ >> ->
- match patt_lid p1 with
- [ Some (i, pl) -> Some (i, [p2 :: pl])
- | None -> None ]
- | _ -> None ]
-;
-
-value type_parameter = Grammar.Entry.create gram "type_parameter";
-value fun_def = Grammar.Entry.create gram "fun_def";
-value fun_binding = Grammar.Entry.create gram "fun_binding";
-
-EXTEND
- GLOBAL: interf implem top_phrase use_file sig_item str_item ctyp patt expr
- module_type module_expr let_binding type_parameter fun_def fun_binding;
- (* Main entry points *)
- interf:
- [ [ st = LIST0 [ s = sig_item; OPT ";;" -> (s, loc) ]; EOI ->
- (st, False) ] ]
- ;
- implem:
- [ [ st = LIST0 [ s = str_item; OPT ";;" -> (s, loc) ]; EOI ->
- (st, False) ] ]
- ;
- top_phrase:
- [ [ ph = phrase; ";;" -> Some ph
- | EOI -> None ] ]
- ;
- use_file:
- [ [ l = LIST0 [ ph = phrase; OPT ";;" -> ph ]; EOI -> (l, False) ] ]
- ;
- phrase:
- [ [ sti = str_item -> sti
- | "#"; n = LIDENT; dp = dir_param -> MLast.StDir loc n dp ] ]
- ;
- dir_param:
- [ [ -> None
- | e = expr -> Some e ] ]
- ;
- (* Module expressions *)
- module_expr:
- [ [ "functor"; "("; i = UIDENT; ":"; t = module_type; ")"; "->";
- me = SELF ->
- <:module_expr< functor ( $i$ : $t$ ) -> $me$ >>
- | "struct"; st = LIST0 [ s = str_item; OPT ";;" -> s ]; "end" ->
- <:module_expr< struct $list:st$ end >> ]
- | [ me1 = SELF; me2 = SELF -> <:module_expr< $me1$ $me2$ >> ]
- | [ i = mod_expr_ident -> i
- | "("; me = SELF; ":"; mt = module_type; ")" ->
- <:module_expr< ( $me$ : $mt$ ) >>
- | "("; me = SELF; ")" -> <:module_expr< $me$ >> ] ]
- ;
- mod_expr_ident:
- [ LEFTA
- [ m1 = SELF; "."; m2 = SELF -> <:module_expr< $m1$ . $m2$ >> ]
- | [ m = UIDENT -> <:module_expr< $uid:m$ >> ] ]
- ;
- str_item:
- [ "top"
- [ "exception"; (_, c, tl) = constructor_declaration ->
- <:str_item< exception $c$ of $list:tl$ >>
- | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING ->
- <:str_item< external $i$ : $t$ = $list:pd$ >>
- | "external"; i = LABEL; t = ctyp; "="; pd = LIST1 STRING ->
- <:str_item< external $i$ : $t$ = $list:pd$ >>
- | "external"; "("; i = operator; ")"; ":"; t = ctyp; "=";
- pd = LIST1 STRING ->
- <:str_item< external $i$ : $t$ = $list:pd$ >>
- | "module"; i = UIDENT; mb = module_binding ->
- <:str_item< module $i$ = $mb$ >>
- | "module"; "type"; i = UIDENT; "="; mt = module_type ->
- <:str_item< module type $i$ = $mt$ >>
- | "open"; i = mod_ident -> <:str_item< open $i$ >>
- | "type"; tdl = LIST1 type_declaration SEP "and" ->
- <:str_item< type $list:tdl$ >>
- | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and"; "in";
- x = expr ->
- let e = <:expr< let $opt:o2b r$ $list:l$ in $x$ >> in
- <:str_item< $exp:e$ >>
- | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and" ->
- match l with
- [ [(<:patt< _ >>, e)] -> <:str_item< $exp:e$ >>
- | _ -> <:str_item< value $opt:o2b r$ $list:l$ >> ]
- | "let"; "module"; m = UIDENT; mb = module_binding; "in"; e = expr ->
- <:str_item< let module $m$ = $mb$ in $e$ >>
- | e = expr -> <:str_item< $exp:e$ >> ] ]
- ;
- module_binding:
- [ RIGHTA
- [ "("; m = UIDENT; ":"; mt = module_type; ")"; mb = SELF ->
- <:module_expr< functor ( $m$ : $mt$ ) -> $mb$ >>
- | ":"; mt = module_type; "="; me = module_expr ->
- <:module_expr< ( $me$ : $mt$ ) >>
- | "="; me = module_expr -> <:module_expr< $me$ >> ] ]
- ;
- (* Module types *)
- module_type:
- [ [ "functor"; "("; i = UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF ->
- <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ]
- | [ mt = SELF; "with"; wcl = LIST1 with_constr SEP "and" ->
- <:module_type< $mt$ with $list:wcl$ >> ]
- | [ "sig"; sg = LIST0 [ s = sig_item; OPT ";;" -> s ]; "end" ->
- <:module_type< sig $list:sg$ end >>
- | i = mod_type_ident -> i
- | "("; mt = SELF; ")" -> <:module_type< $mt$ >> ] ]
- ;
- mod_type_ident:
- [ LEFTA
- [ m1 = SELF; "."; m2 = SELF -> <:module_type< $m1$ . $m2$ >>
- | m1 = SELF; "("; m2 = SELF; ")" -> <:module_type< $m1$ $m2$ >> ]
- | [ m = UIDENT -> <:module_type< $uid:m$ >>
- | m = LIDENT -> <:module_type< $lid:m$ >> ] ]
- ;
- sig_item:
- [ "top"
- [ "exception"; (_, c, tl) = constructor_declaration ->
- <:sig_item< exception $c$ of $list:tl$ >>
- | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING ->
- <:sig_item< external $i$ : $t$ = $list:pd$ >>
- | "external"; i = LABEL; t = ctyp; "="; pd = LIST1 STRING ->
- <:sig_item< external $i$ : $t$ = $list:pd$ >>
- | "external"; "("; i = operator; ")"; ":"; t = ctyp; "=";
- pd = LIST1 STRING ->
- <:sig_item< external $i$ : $t$ = $list:pd$ >>
- | "include"; mt = module_type -> <:sig_item< include $mt$ >>
- | "module"; i = UIDENT; mt = module_declaration ->
- <:sig_item< module $i$ : $mt$ >>
- | "module"; "type"; i = UIDENT; "="; mt = module_type ->
- <:sig_item< module type $i$ = $mt$ >>
- | "open"; i = mod_ident -> <:sig_item< open $i$ >>
- | "type"; tdl = LIST1 type_declaration SEP "and" ->
- <:sig_item< type $list:tdl$ >>
- | "val"; i = LIDENT; ":"; t = ctyp -> <:sig_item< value $i$ : $t$ >>
- | "val"; i = LABEL; t = ctyp -> <:sig_item< value $i$ : $t$ >>
- | "val"; "("; i = operator; ")"; ":"; t = ctyp ->
- <:sig_item< value $i$ : $t$ >> ] ]
- ;
- module_declaration:
- [ RIGHTA
- [ ":"; mt = module_type -> <:module_type< $mt$ >>
- | "("; i = UIDENT; ":"; t = module_type; ")"; mt = SELF ->
- <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] ]
- ;
- (* "with" constraints (additional type equations over signature
- components) *)
- with_constr:
- [ [ "type"; tp = type_parameters; i = mod_ident; "="; t = ctyp ->
- MLast.WcTyp loc i tp t
- | "module"; i = mod_ident; "="; me = module_expr ->
- MLast.WcMod loc i me ] ]
- ;
- (* Core expressions *)
- expr:
- [ "top" LEFTA
- [ e1 = SELF; ";"; e2 = SELF ->
- <:expr< do { $list:[e1 :: get_seq e2]$ } >>
- | e1 = SELF; ";" -> e1 ]
- | "expr1"
- [ "let"; o = OPT "rec"; l = LIST1 let_binding SEP "and"; "in";
- x = expr LEVEL "top" ->
- <:expr< let $opt:o2b o$ $list:l$ in $x$ >>
- | "let"; "module"; m = UIDENT; mb = module_binding; "in";
- e = expr LEVEL "top" ->
- <:expr< let module $m$ = $mb$ in $e$ >>
- | "function"; OPT "|"; l = LIST1 match_case SEP "|" ->
- <:expr< fun [ $list:l$ ] >>
- | "fun"; p = patt LEVEL "simple"; e = fun_def ->
- <:expr< fun [$p$ -> $e$] >>
- | "match"; x = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" ->
- <:expr< match $x$ with [ $list:l$ ] >>
- | "try"; x = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" ->
- <:expr< try $x$ with [ $list:l$ ] >>
- | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1";
- e3 = [ "else"; e = expr LEVEL "expr1" -> e | -> <:expr< () >> ] ->
- <:expr< if $e1$ then $e2$ else $e3$ >>
- | "for"; i = LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF;
- "do"; e = SELF; "done" ->
- <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:get_seq e$ } >>
- | "while"; e1 = SELF; "do"; e2 = SELF; "done" ->
- <:expr< while $e1$ do { $list:get_seq e2$ } >> ]
- | [ e = SELF; ","; el = LIST1 NEXT SEP "," ->
- <:expr< ( $list:[e :: el]$ ) >> ]
- | ":=" NONA
- [ e1 = SELF; ":="; e2 = expr LEVEL "expr1" ->
- <:expr< $e1$.val := $e2$ >>
- | e1 = SELF; "<-"; e2 = expr LEVEL "expr1" -> <:expr< $e1$ := $e2$ >> ]
- | "||" RIGHTA
- [ e1 = SELF; f = [ op = "or" -> op | op = "||" -> op ]; e2 = SELF ->
- <:expr< $lid:f$ $e1$ $e2$ >> ]
- | "&&" RIGHTA
- [ e1 = SELF; f = [ op = "&" -> op | op = "&&" -> op ]; e2 = SELF ->
- <:expr< $lid:f$ $e1$ $e2$ >> ]
- | "<" LEFTA
- [ e1 = SELF;
- f =
- [ op = "<" -> op
- | op = ">" -> op
- | op = "<=" -> op
- | op = ">=" -> op
- | op = "=" -> op
- | op = "<>" -> op
- | op = "==" -> op
- | op = "!=" -> op
- | op = infixop0 -> op ];
- e2 = SELF ->
- <:expr< $lid:f$ $e1$ $e2$ >> ]
- | "^" RIGHTA
- [ e1 = SELF;
- f = [ op = "^" -> op | op = "@" -> op | op = infixop1 -> op ];
- e2 = SELF ->
- <:expr< $lid:f$ $e1$ $e2$ >> ]
- | RIGHTA
- [ e1 = SELF; "::"; e2 = SELF -> <:expr< [$e1$ :: $e2$] >> ]
- | "+" LEFTA
- [ e1 = SELF;
- f =
- [ op = "+" -> op
- | op = "-" -> op
- | op = "+." -> op
- | op = "-." -> op
- | op = infixop2 -> op ];
- e2 = SELF ->
- <:expr< $lid:f$ $e1$ $e2$ >> ]
- | "*" LEFTA
- [ e1 = SELF;
- f =
- [ op = "*" -> op
- | op = "/" -> op
- | op = "*." -> op
- | op = "/." -> op
- | op = "land" -> op
- | op = "lor" -> op
- | op = "lxor" -> op
- | op = "mod" -> op
- | op = infixop3 -> op ];
- e2 = SELF ->
- <:expr< $lid:f$ $e1$ $e2$ >> ]
- | "**" RIGHTA
- [ e1 = SELF;
- f =
- [ op = "**" -> op
- | op = "asr" -> op
- | op = "lsl" -> op
- | op = "lsr" -> op
- | op = infixop4 -> op ];
- e2 = SELF ->
- <:expr< $lid:f$ $e1$ $e2$ >> ]
- | "unary minus" NONA
- [ f = [ op = "-" -> op | op = "-." -> op ]; e = SELF ->
- <:expr< $mkumin loc f e$ >> ]
- | "apply" LEFTA
- [ e1 = SELF; e2 = SELF ->
- match constr_expr_arity e1 with
- [ 1 -> <:expr< $e1$ $e2$ >>
- | _ ->
- match e2 with
- [ <:expr< ( $list:el$ ) >> ->
- List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>) e1 el
- | _ -> <:expr< $e1$ $e2$ >> ] ]
- | "assert"; e = expr LEVEL "simple" ->
- match e with
- [ <:expr< False >> -> MLast.ExAsf loc
- | _ -> MLast.ExAsr loc e ]
- | "lazy"; e = SELF ->
- <:expr< lazy ($e$) >> ]
- | "simple" LEFTA
- [ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >>
- | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >>
- | e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >>
- | "!"; e = SELF -> <:expr< $e$ . val>>
- | f =
- [ op = "~-" -> op
- | op = "~-." -> op
- | op = "~" -> op
- | op = prefixop -> op ];
- e = SELF ->
- <:expr< $lid:f$ $e$ >>
- | s = INT -> <:expr< $int:s$ >>
- | s = FLOAT -> <:expr< $flo:s$ >>
- | s = STRING -> <:expr< $str:s$ >>
- | c = CHAR -> <:expr< $chr:c$ >>
- | i = expr_ident -> i
- | s = "false" -> <:expr< False >>
- | s = "true" -> <:expr< True >>
- | "["; "]" -> <:expr< [] >>
- | "["; el = expr1_semi_list; "]" -> <:expr< $mklistexp loc None el$ >>
- | "[|"; "|]" -> <:expr< [| |] >>
- | "[|"; el = expr1_semi_list; "|]" -> <:expr< [| $list:el$ |] >>
- | "{"; test_label_eq; lel = lbl_expr_list; "}" ->
- <:expr< { $list:lel$ } >>
- | "{"; e = expr LEVEL "simple"; "with"; lel = lbl_expr_list; "}" ->
- <:expr< { ($e$) with $list:lel$ } >>
- | "("; ")" -> <:expr< () >>
- | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >>
- | "("; e = SELF; ")" -> <:expr< $e$ >>
- | "("; "-"; ")" -> <:expr< $lid:"-"$ >>
- | "("; "-."; ")" -> <:expr< $lid:"-."$ >>
- | "("; op = operator; ")" -> <:expr< $lid:op$ >>
- | "begin"; e = SELF; "end" -> <:expr< $e$ >>
- | x = LOCATE ->
- let x =
- try
- let i = String.index x ':' in
- (int_of_string (String.sub x 0 i),
- String.sub x (i + 1) (String.length x - i - 1))
- with
- [ Not_found | Failure _ -> (0, x) ]
- in
- Pcaml.handle_expr_locate loc x
- | x = QUOTATION ->
- let x =
- try
- let i = String.index x ':' in
- (String.sub x 0 i,
- String.sub x (i + 1) (String.length x - i - 1))
- with
- [ Not_found -> ("", x) ]
- in
- Pcaml.handle_expr_quotation loc x ] ]
- ;
- let_binding:
- [ [ p = patt; e = fun_binding ->
- match patt_lid p with
- [ Some (i, pl) ->
- let e =
- List.fold_left (fun e p -> <:expr< fun $p$ -> $e$ >>) e pl
- in
- (<:patt< $lid:i$ >>, e)
- | None -> (p, e) ] ] ]
- ;
- fun_binding:
- [ RIGHTA
- [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >>
- | "="; e = expr -> <:expr< $e$ >>
- | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> ] ]
- ;
- match_case:
- [ [ x1 = patt; w = OPT [ "when"; e = expr -> e ]; "->"; x2 = expr ->
- (x1, w, x2) ] ]
- ;
- lbl_expr_list:
- [ [ le = lbl_expr; ";"; lel = SELF -> [le :: lel]
- | le = lbl_expr; ";" -> [le]
- | le = lbl_expr -> [le] ] ]
- ;
- lbl_expr:
- [ [ i = patt_label_ident; "="; e = expr LEVEL "expr1" -> (i, e) ] ]
- ;
- expr1_semi_list:
- [ [ e = expr LEVEL "expr1"; ";"; el = SELF -> [e :: el]
- | e = expr LEVEL "expr1"; ";" -> [e]
- | e = expr LEVEL "expr1" -> [e] ] ]
- ;
- fun_def:
- [ RIGHTA
- [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >>
- | "->"; e = expr -> <:expr< $e$ >> ] ]
- ;
- expr_ident:
- [ RIGHTA
- [ i = LIDENT -> <:expr< $lid:i$ >>
- | i = UIDENT -> <:expr< $uid:i$ >>
- | m = UIDENT; "."; i = SELF ->
- let rec loop m =
- fun
- [ <:expr< $x$ . $y$ >> -> loop <:expr< $m$ . $x$ >> y
- | e -> <:expr< $m$ . $e$ >> ]
- in
- loop <:expr< $uid:m$ >> i
- | m = UIDENT; "."; "("; i = operator; ")" ->
- <:expr< $uid:m$ . $lid:i$ >> ] ]
- ;
- (* Patterns *)
- patt:
- [ LEFTA
- [ p1 = SELF; "as"; i = LIDENT -> <:patt< ($p1$ as $lid:i$) >> ]
- | LEFTA
- [ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ]
- | [ p = SELF; ","; pl = LIST1 NEXT SEP "," ->
- <:patt< ( $list:[p :: pl]$) >> ]
- | NONA
- [ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ]
- | RIGHTA
- [ p1 = SELF; "::"; p2 = SELF -> <:patt< [$p1$ :: $p2$] >> ]
- | LEFTA
- [ p1 = SELF; p2 = SELF ->
- match constr_patt_arity p1 with
- [ 1 -> <:patt< $p1$ $p2$ >>
- | n ->
- let p2 =
- match p2 with
- [ <:patt< _ >> when n > 1 ->
- let pl =
- loop n where rec loop n =
- if n = 0 then [] else [<:patt< _ >> :: loop (n - 1)]
- in
- <:patt< ( $list:pl$ ) >>
- | _ -> p2 ]
- in
- match p2 with
- [ <:patt< ( $list:pl$ ) >> ->
- List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>) p1 pl
- | _ -> <:patt< $p1$ $p2$ >> ] ] ]
- | LEFTA
- [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ]
- | "simple"
- [ s = LIDENT -> <:patt< $lid:s$ >>
- | s = UIDENT -> <:patt< $uid:s$ >>
- | s = INT -> <:patt< $int:s$ >>
- | "-"; s = INT -> <:patt< $int:neg s$ >>
- | s = STRING -> <:patt< $str:s$ >>
- | s = CHAR -> <:patt< $chr:s$ >>
- | s = "false" -> <:patt< False >>
- | s = "true" -> <:patt< True >>
- | "["; "]" -> <:patt< [] >>
- | "["; pl = patt_semi_list; "]" -> <:patt< $mklistpat loc None pl$ >>
- | "[|"; "|]" -> <:patt< [| |] >>
- | "[|"; pl = patt_semi_list; "|]" -> <:patt< [| $list:pl$ |] >>
- | "{"; lpl = lbl_patt_list; "}" -> <:patt< { $list:lpl$ } >>
- | "("; ")" -> <:patt< () >>
- | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >>
- | "("; p = SELF; ")" -> <:patt< $p$ >>
- | "("; "-"; ")" -> <:patt< $lid:"-"$ >>
- | "("; op = operator; ")" -> <:patt< $lid:op$ >>
- | "_" -> <:patt< _ >>
- | x = LOCATE ->
- let x =
- try
- let i = String.index x ':' in
- (int_of_string (String.sub x 0 i),
- String.sub x (i + 1) (String.length x - i - 1))
- with
- [ Not_found | Failure _ -> (0, x) ]
- in
- Pcaml.handle_patt_locate loc x
- | x = QUOTATION ->
- let x =
- try
- let i = String.index x ':' in
- (String.sub x 0 i,
- String.sub x (i + 1) (String.length x - i - 1))
- with
- [ Not_found -> ("", x) ]
- in
- Pcaml.handle_patt_quotation loc x ] ]
- ;
- patt_semi_list:
- [ [ p = patt; ";"; pl = SELF -> [p :: pl]
- | p = patt; ";" -> [p]
- | p = patt -> [p] ] ]
- ;
- lbl_patt_list:
- [ [ le = lbl_patt; ";"; lel = SELF -> [le :: lel]
- | le = lbl_patt; ";" -> [le]
- | le = lbl_patt -> [le] ] ]
- ;
- lbl_patt:
- [ [ i = patt_label_ident; "="; p = patt -> (i, p) ] ]
- ;
- patt_label_ident:
- [ RIGHTA
- [ i = UIDENT -> <:patt< $uid:i$ >>
- | i = LIDENT -> <:patt< $lid:i$ >>
- | m = UIDENT; "."; i = SELF -> <:patt< $uid:m$ . $i$ >> ] ]
- ;
- (* Type declaration *)
- type_declaration:
- [ [ tpl = type_parameters; n = type_patt; "="; tk = type_kind;
- cl = LIST0 constrain ->
- (n, tpl, tk, cl)
- | tpl = type_parameters; n = type_patt; cl = LIST0 constrain ->
- (n, tpl, <:ctyp< '$choose_tvar tpl$ >>, cl) ] ]
- ;
- type_patt:
- [ [ n = LIDENT -> (loc, n) ] ]
- ;
- constrain:
- [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> (t1, t2) ] ]
- ;
- type_kind:
- [ [ test_constr_decl; OPT "|";
- cdl = LIST1 constructor_declaration SEP "|" ->
- <:ctyp< [ $list:cdl$ ] >>
- | t = ctyp -> <:ctyp< $t$ >>
- | t = ctyp; "="; "{"; ldl = label_declarations; "}" ->
- <:ctyp< $t$ == { $list:ldl$ } >>
- | t = ctyp; "="; OPT "|"; cdl = LIST1 constructor_declaration SEP "|" ->
- <:ctyp< $t$ == [ $list:cdl$ ] >>
- | "{"; ldl = label_declarations; "}" -> <:ctyp< { $list:ldl$ } >> ] ]
- ;
- type_parameters:
- [ [ -> (* empty *) []
- | tp = type_parameter -> [tp]
- | "("; tpl = LIST1 type_parameter SEP ","; ")" -> tpl ] ]
- ;
- type_parameter:
- [ [ "'"; i = ident -> (i, (False, False)) ] ]
- ;
- constructor_declaration:
- [ [ ci = UIDENT; "of"; cal = LIST1 ctyp LEVEL "ctyp1" SEP "*" ->
- (loc, ci, cal)
- | ci = UIDENT -> (loc, ci, []) ] ]
- ;
- label_declarations:
- [ [ ld = label_declaration; ";"; ldl = SELF -> [ld :: ldl]
- | ld = label_declaration; ";" -> [ld]
- | ld = label_declaration -> [ld] ] ]
- ;
- label_declaration:
- [ [ i = LIDENT; ":"; t = ctyp -> (loc, i, False, t)
- | i = LABEL; t = ctyp -> (loc, i, False, t)
- | "mutable"; i = LIDENT; ":"; t = ctyp -> (loc, i, True, t)
- | "mutable"; i = LABEL; t = ctyp -> (loc, i, True, t) ] ]
- ;
- (* Core types *)
- ctyp:
- [ [ t1 = SELF; "as"; "'"; i = ident -> <:ctyp< $t1$ as '$i$ >> ]
- | "arrow" RIGHTA
- [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ]
- | [ t = SELF; "*"; tl = LIST1 ctyp LEVEL "ctyp1" SEP "*" ->
- <:ctyp< ( $list:[t :: tl]$ ) >> ]
- | "ctyp1"
- [ t1 = SELF; t2 = SELF -> <:ctyp< $t2$ $t1$ >> ]
- | "ctyp2"
- [ t1 = SELF; "."; t2 = SELF -> <:ctyp< $t1$ . $t2$ >>
- | t1 = SELF; "("; t2 = SELF; ")" -> <:ctyp< $t1$ $t2$ >> ]
- | "simple"
- [ "'"; i = ident -> <:ctyp< '$i$ >>
- | "_" -> <:ctyp< _ >>
- | i = LIDENT -> <:ctyp< $lid:i$ >>
- | i = UIDENT -> <:ctyp< $uid:i$ >>
- | "("; t = SELF; ","; tl = LIST1 ctyp SEP ","; ")";
- i = ctyp LEVEL "ctyp2" ->
- List.fold_left (fun c a -> <:ctyp< $c$ $a$ >>) i [t :: tl]
- | "("; t = SELF; ")" -> <:ctyp< $t$ >> ] ]
- ;
- (* Identifiers *)
- ident:
- [ [ i = LIDENT -> i
- | i = UIDENT -> i ] ]
- ;
- mod_ident:
- [ RIGHTA
- [ i = UIDENT -> [i]
- | i = LIDENT -> [i]
- | m = UIDENT; "."; i = SELF -> [m :: i] ] ]
- ;
- (* Miscellaneous *)
- direction_flag:
- [ [ "to" -> True
- | "downto" -> False ] ]
- ;
-END;
-
-(* Objects and Classes *)
-
-value rec class_type_of_ctyp loc t =
- match t with
- [ <:ctyp< $lid:i$ >> -> <:class_type< $list:[i]$ >>
- | <:ctyp< $uid:m$.$t$ >> -> <:class_type< $list:[m :: type_id_list t]$ >>
- | _ -> raise_with_loc loc (Stream.Error "lowercase identifier expected") ]
-and type_id_list =
- fun
- [ <:ctyp< $uid:m$.$t$ >> -> [m :: type_id_list t]
- | <:ctyp< $lid:i$ >> -> [i]
- | t ->
- raise_with_loc (loc_of_node t)
- (Stream.Error "lowercase identifier expected") ]
-;
-
-value class_fun_binding = Grammar.Entry.create gram "class_fun_binding";
-
-EXTEND
- GLOBAL: str_item sig_item expr ctyp class_sig_item class_str_item class_type
- class_expr class_fun_binding;
- str_item:
- [ [ "class"; cd = LIST1 class_declaration SEP "and" ->
- <:str_item< class $list:cd$ >>
- | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" ->
- <:str_item< class type $list:ctd$ >> ] ]
- ;
- sig_item:
- [ [ "class"; cd = LIST1 class_description SEP "and" ->
- <:sig_item< class $list:cd$ >>
- | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" ->
- <:sig_item< class type $list:ctd$ >> ] ]
- ;
- (* Class expressions *)
- class_declaration:
- [ [ vf = OPT "virtual"; ctp = class_type_parameters; i = LIDENT;
- cfb = class_fun_binding ->
- {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
- MLast.ciNam = i; MLast.ciExp = cfb} ] ]
- ;
- class_fun_binding:
- [ [ "="; ce = class_expr -> ce
- | ":"; ct = class_type; "="; ce = class_expr ->
- <:class_expr< ($ce$ : $ct$) >>
- | p = patt LEVEL "simple"; cfb = SELF ->
- <:class_expr< fun $p$ -> $cfb$ >> ] ]
- ;
- class_type_parameters:
- [ [ -> (loc, [])
- | "["; tpl = LIST1 type_parameter SEP ","; "]" -> (loc, tpl) ] ]
- ;
- class_fun_def:
- [ [ p = patt LEVEL "simple"; "->"; ce = class_expr ->
- <:class_expr< fun $p$ -> $ce$ >>
- | p = patt LEVEL "simple"; cfd = SELF ->
- <:class_expr< fun $p$ -> $cfd$ >> ] ]
- ;
- class_expr:
- [ "top"
- [ "fun"; cfd = class_fun_def -> cfd
- | "let"; rf = OPT "rec"; lb = LIST1 let_binding SEP "and"; "in";
- ce = SELF ->
- <:class_expr< let $opt:o2b rf$ $list:lb$ in $ce$ >> ]
- | "apply" NONA
- [ ce = SELF; e = expr LEVEL "label" ->
- <:class_expr< $ce$ $e$ >> ]
- | "simple"
- [ "["; ct = ctyp; ","; ctcl = LIST1 ctyp SEP ","; "]";
- ci = class_longident ->
- <:class_expr< $list:ci$ [ $list:[ct :: ctcl]$ ] >>
- | "["; ct = ctyp; "]"; ci = class_longident ->
- <:class_expr< $list:ci$ [ $ct$ ] >>
- | ci = class_longident -> <:class_expr< $list:ci$ >>
- | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" ->
- <:class_expr< object $opt:cspo$ $list:cf$ end >>
- | "("; ce = SELF; ":"; ct = class_type; ")" ->
- <:class_expr< ($ce$ : $ct$) >>
- | "("; ce = SELF; ")" -> ce ] ]
- ;
- class_structure:
- [ [ cf = LIST0 class_str_item -> cf ] ]
- ;
- class_self_patt:
- [ [ "("; p = patt; ")" -> p
- | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> ] ]
- ;
- class_str_item:
- [ [ "inherit"; ce = class_expr; pb = OPT [ "as"; i = LIDENT -> i ] ->
- <:class_str_item< inherit $ce$ $opt:pb$ >>
- | "val"; (lab, mf, e) = cvalue ->
- <:class_str_item< value $opt:mf$ $lab$ = $e$ >>
- | "method"; "private"; "virtual"; l = label; ":"; t = ctyp ->
- <:class_str_item< method virtual private $l$ : $t$ >>
- | "method"; "virtual"; "private"; l = label; ":"; t = ctyp ->
- <:class_str_item< method virtual private $l$ : $t$ >>
- | "method"; "virtual"; l = label; ":"; t = ctyp ->
- <:class_str_item< method virtual $l$ : $t$ >>
- | "method"; "private"; l = label; fb = fun_binding ->
- <:class_str_item< method private $l$ = $fb$ >>
- | "method"; l = label; fb = fun_binding ->
- <:class_str_item< method $l$ = $fb$ >>
- | "constraint"; t1 = ctyp; "="; t2 = ctyp ->
- <:class_str_item< type $t1$ = $t2$ >>
- | "initializer"; se = expr -> <:class_str_item< initializer $se$ >> ] ]
- ;
- cvalue:
- [ [ mf = OPT "mutable"; l = label; "="; e = expr -> (l, o2b mf, e)
- | mf = OPT "mutable"; l = label; ":"; t = ctyp; "="; e = expr ->
- (l, o2b mf, <:expr< ($e$ : $t$) >>)
- | mf = OPT "mutable"; l = label; ":"; t1 = ctyp; ":>"; t2 = ctyp; "=";
- e = expr ->
- (l, o2b mf, <:expr< ($e$ : $t1$ :> $t2$) >>)
- | mf = OPT "mutable"; l = label; ":>"; t = ctyp; "="; e = expr ->
- (l, o2b mf, <:expr< ($e$ :> $t$) >>) ] ]
- ;
- label:
- [ [ i = LIDENT -> i ] ]
- ;
- (* Class types *)
- class_type:
- [ [ t = ctyp LEVEL "ctyp1" -> class_type_of_ctyp loc t
- | t = ctyp LEVEL "ctyp1"; "->"; ct = SELF ->
- <:class_type< [ $t$ ] -> $ct$ >>
- | t = ctyp LEVEL "ctyp1"; "*"; tl = LIST1 ctyp LEVEL "simple" SEP "*";
- "->"; ct = SELF ->
- <:class_type< [ ($t$ * $list:tl$) ] -> $ct$ >>
- | cs = class_signature -> cs ] ]
- ;
- class_signature:
- [ [ "["; tl = LIST1 ctyp SEP ","; "]"; id = clty_longident ->
- <:class_type< $list:id$ [ $list:tl$ ] >>
- | id = clty_longident -> <:class_type< $list:id$ >>
- | "object"; cst = OPT class_self_type; csf = LIST0 class_sig_item;
- "end" ->
- <:class_type< object $opt:cst$ $list:csf$ end >> ] ]
- ;
- class_self_type:
- [ [ "("; t = ctyp; ")" -> t ] ]
- ;
- class_sig_item:
- [ [ "inherit"; cs = class_signature -> <:class_sig_item< inherit $cs$ >>
- | "val"; mf = OPT "mutable"; l = label; ":"; t = ctyp ->
- <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >>
- | "method"; "private"; "virtual"; l = label; ":"; t = ctyp ->
- <:class_sig_item< method virtual private $l$ : $t$ >>
- | "method"; "virtual"; "private"; l = label; ":"; t = ctyp ->
- <:class_sig_item< method virtual private $l$ : $t$ >>
- | "method"; "virtual"; l = label; ":"; t = ctyp ->
- <:class_sig_item< method virtual $l$ : $t$ >>
- | "method"; "private"; l = label; ":"; t = ctyp ->
- <:class_sig_item< method private $l$ : $t$ >>
- | "method"; l = label; ":"; t = ctyp ->
- <:class_sig_item< method $l$ : $t$ >>
- | "constraint"; t1 = ctyp; "="; t2 = ctyp ->
- <:class_sig_item< type $t1$ = $t2$ >> ] ]
- ;
- class_description:
- [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; ":";
- ct = class_type ->
- {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
- MLast.ciNam = n; MLast.ciExp = ct}
- | vf = OPT "virtual"; ctp = class_type_parameters; n = LABEL;
- ct = class_type ->
- {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
- MLast.ciNam = n; MLast.ciExp = ct} ] ]
- ;
- class_type_declaration:
- [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; "=";
- cs = class_signature ->
- {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
- MLast.ciNam = n; MLast.ciExp = cs} ] ]
- ;
- (* Expressions *)
- expr: LEVEL "apply"
- [ LEFTA
- [ "new"; i = class_longident -> <:expr< new $list:i$ >> ] ]
- ;
- expr: LEVEL "simple"
- [ [ e = SELF; "#"; lab = label -> <:expr< $e$ # $lab$ >> ] ]
- ;
- expr: LEVEL "simple"
- [ [ "("; e = SELF; ":"; t1 = ctyp; ":>"; t2 = ctyp; ")" ->
- <:expr< ($e$ : $t1$ :> $t2$) >>
- | "("; e = SELF; ":>"; t = ctyp; ")" -> <:expr< ($e$ :> $t$) >>
- | "{<"; ">}" -> <:expr< {< >} >>
- | "{<"; fel = field_expr_list; ">}" -> <:expr< {< $list:fel$ >} >> ] ]
- ;
- field_expr_list:
- [ [ l = label; "="; e = expr LEVEL "expr1"; ";"; fel = SELF ->
- [(l, e) :: fel]
- | l = label; "="; e = expr LEVEL "expr1"; ";" -> [(l, e)]
- | l = label; "="; e = expr LEVEL "expr1" -> [(l, e)] ] ]
- ;
- (* Core types *)
- ctyp: LEVEL "simple"
- [ [ "#"; id = class_longident -> <:ctyp< # $list:id$ >>
- | "<"; (ml, v) = meth_list; ">" -> <:ctyp< < $list:ml$ $opt:v$ > >>
- | "<"; ">" -> <:ctyp< < > >> ] ]
- ;
- meth_list:
- [ [ f = field; ";"; (ml, v) = SELF -> ([f :: ml], v)
- | f = field; ";" -> ([f], False)
- | f = field -> ([f], False)
- | ".." -> ([], True) ] ]
- ;
- field:
- [ [ lab = LIDENT; ":"; t = ctyp -> (lab, t)
- | lab = LABEL; t = ctyp -> (lab, t) ] ]
- ;
- (* Identifiers *)
- clty_longident:
- [ [ m = UIDENT; "."; l = SELF -> [m :: l]
- | i = LIDENT -> [i] ] ]
- ;
- class_longident:
- [ [ m = UIDENT; "."; l = SELF -> [m :: l]
- | i = LIDENT -> [i] ] ]
- ;
-END;
-
-(* Labels *)
-
-EXTEND
- GLOBAL: ctyp expr patt fun_def fun_binding class_type class_fun_binding;
- ctyp: AFTER "arrow"
- [ NONA
- [ i = LABEL; t = SELF -> <:ctyp< ~ $i$ : $t$ >>
- | "?"; i = LABEL; t = SELF -> <:ctyp< ? $i$ : $t$ >> ] ]
- ;
- ctyp: LEVEL "simple"
- [ [ "["; OPT "|"; rfl = LIST0 row_field SEP "|"; "]" ->
- <:ctyp< [ = $list:rfl$ ] >>
- | "["; ">"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" ->
- <:ctyp< [ > $list:rfl$ ] >>
- | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" ->
- <:ctyp< [ < $list:rfl$ ] >>
- | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; ">";
- ntl = LIST1 name_tag; "]" ->
- <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ]
- ;
- row_field:
- [ [ "`"; i = ident -> MLast.RfTag i False []
- | "`"; i = ident; "of"; ao = OPT "&"; l = LIST1 ctyp SEP "&" ->
- MLast.RfTag i (o2b ao) l
- | "`"; i = ident; "&"; l = LIST1 ctyp SEP "&" -> MLast.RfTag i True l
- | "`"; i = ident; l = LIST1 ctyp SEP "&" -> MLast.RfTag i False l ] ]
- ;
- name_tag:
- [ [ "`"; i = ident -> i ] ]
- ;
- expr: LEVEL "expr1"
- [ [ "fun"; p = labeled_patt; e = fun_def -> <:expr< fun $p$ -> $e$ >> ] ]
- ;
- expr: AFTER "apply"
- [ "label"
- [ i = LABEL; e = SELF -> <:expr< ~ $i$ : $e$ >>
- | i = ELABEL -> <:expr< ~ $i$ >>
- | "?"; i = LABEL; e = SELF -> <:expr< ? $i$ : $e$ >>
- | "?"; i = ELABEL -> <:expr< ? $i$ >> ] ]
- ;
- expr: LEVEL "simple"
- [ [ "`"; s = ident -> <:expr< ` $s$ >> ] ]
- ;
- fun_def:
- [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ]
- ;
- fun_binding:
- [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ]
- ;
- patt: LEVEL "simple"
- [ [ "`"; s = ident -> <:patt< ` $s$ >> ] ]
- ;
- labeled_patt:
- [ [ i = LABEL; p = patt LEVEL "simple" -> <:patt< ~ $i$ : $p$ >>
- | i = ELABEL -> <:patt< ~ $i$ >>
- | "?"; i = LABEL; j = LIDENT -> <:patt< ? $i$ : ($lid:j$) >>
- | "?"; "("; i = LABEL; j = LIDENT; ")" -> <:patt< ? $i$ : ($lid:j$) >>
- | "?"; "("; i = LABEL; j = LIDENT; "="; e = expr; ")" ->
- <:patt< ? $i$ : ( $lid:j$ = $e$ ) >>
- | "?"; i = ELABEL -> <:patt< ? $i$ : ($lid:i$) >>
- | "?"; "("; i = ELABEL; "="; e = expr; ")" ->
- <:patt< ? $i$ : ( $lid:i$ = $e$ ) >> ] ]
- ;
- class_type:
- [ [ i = LABEL; t = ctyp LEVEL "ctyp1"; "->"; ct = SELF ->
- <:class_type< [ ~ $i$ : $t$ ] -> $ct$ >>
- | "?"; i = LABEL; t = ctyp LEVEL "ctyp1"; "->"; ct = SELF ->
- <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> ] ]
- ;
- class_fun_binding:
- [ [ p = labeled_patt; cfb = SELF -> <:class_expr< fun $p$ -> $cfb$ >> ] ]
- ;
- ident:
- [ [ i = LIDENT -> i
- | i = UIDENT -> i ] ]
- ;
-END;
-
-type spat_comp =
- [ SpTrm of MLast.loc and MLast.patt and option MLast.expr
- | SpNtr of MLast.loc and MLast.patt and MLast.expr
- | SpStr of MLast.loc and MLast.patt ]
-;
-type sexp_comp =
- [ SeTrm of MLast.loc and MLast.expr | SeNtr of MLast.loc and MLast.expr ]
-;
-
-value strm_n = "strm__";
-value peek_fun loc = <:expr< Stream.peek >>;
-value junk_fun loc = <:expr< Stream.junk >>;
-
-(* Parsers. *)
-(* In syntax generated, many cases are optimisations. *)
-
-value rec pattern_eq_expression p e =
- match (p, e) with
- [ (<:patt< $lid:a$ >>, <:expr< $lid:b$ >>) -> a = b
- | (<:patt< $uid:a$ >>, <:expr< $uid:b$ >>) -> a = b
- | (<:patt< $p1$ $p2$ >>, <:expr< $e1$ $e2$ >>) ->
- pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2
- | _ -> False ]
-;
-
-value is_raise e =
- match e with
- [ <:expr< raise $_$ >> -> True
- | _ -> False ]
-;
-
-value is_raise_failure e =
- match e with
- [ <:expr< raise Stream.Failure >> -> True
- | _ -> False ]
-;
-
-value rec handle_failure e =
- match e with
- [ <:expr< try $te$ with [ Stream.Failure -> $e$] >> -> handle_failure e
- | <:expr< match $me$ with [ $list:pel$ ] >> ->
- handle_failure me &&
- List.for_all
- (fun
- [ (_, None, e) -> handle_failure e
- | _ -> False ])
- pel
- | <:expr< let $list:pel$ in $e$ >> ->
- List.for_all (fun (p, e) -> handle_failure e) pel && handle_failure e
- | <:expr< $lid:_$ >> | <:expr< $int:_$ >> | <:expr< $str:_$ >> |
- <:expr< $chr:_$ >> | <:expr< fun [ $list:_$ ] >> | <:expr< $uid:_$ >> ->
- True
- | <:expr< raise $e$ >> ->
- match e with
- [ <:expr< Stream.Failure >> -> False
- | _ -> True ]
- | <:expr< $f$ $x$ >> ->
- is_constr_apply f && handle_failure f && handle_failure x
- | _ -> False ]
-and is_constr_apply =
- fun
- [ <:expr< $uid:_$ >> -> True
- | <:expr< $lid:_$ >> -> False
- | <:expr< $x$ $_$ >> -> is_constr_apply x
- | _ -> False ]
-;
-
-value rec subst v e =
- let loc = MLast.loc_of_expr e in
- match e with
- [ <:expr< $lid:x$ >> ->
- let x = if x = v then strm_n else x in
- <:expr< $lid:x$ >>
- | <:expr< $uid:_$ >> -> e
- | <:expr< $int:_$ >> -> e
- | <:expr< $chr:_$ >> -> e
- | <:expr< $str:_$ >> -> e
- | <:expr< $_$ . $_$ >> -> e
- | <:expr< let $opt:rf$ $list:pel$ in $e$ >> ->
- <:expr< let $opt:rf$ $list:List.map (subst_pe v) pel$ in $subst v e$ >>
- | <:expr< $e1$ $e2$ >> -> <:expr< $subst v e1$ $subst v e2$ >>
- | <:expr< ( $list:el$ ) >> -> <:expr< ( $list:List.map (subst v) el$ ) >>
- | _ -> raise Not_found ]
-and subst_pe v (p, e) =
- match p with
- [ <:patt< $lid:v'$ >> -> if v = v' then (p, e) else (p, subst v e)
- | _ -> raise Not_found ]
-;
-
-value stream_pattern_component skont ckont =
- fun
- [ SpTrm loc p wo ->
- <:expr< match $peek_fun loc$ $lid:strm_n$ with
- [ Some $p$ $when:wo$ ->
- do { $junk_fun loc$ $lid:strm_n$; $skont$ }
- | _ -> $ckont$ ] >>
- | SpNtr loc p e ->
- let e =
- match e with
- [ <:expr< fun [ ($lid:v$ : Stream.t _) -> $e$ ] >> when v = strm_n ->
- e
- | _ -> <:expr< $e$ $lid:strm_n$ >> ]
- in
- if pattern_eq_expression p skont then
- if is_raise_failure ckont then e
- else if handle_failure e then e
- else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >>
- else if is_raise_failure ckont then <:expr< let $p$ = $e$ in $skont$ >>
- else if pattern_eq_expression <:patt< Some $p$ >> skont then
- <:expr< try Some $e$ with [ Stream.Failure -> $ckont$ ] >>
- else if is_raise ckont then
- let tst =
- if handle_failure e then e
- else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >>
- in
- <:expr< let $p$ = $tst$ in $skont$ >>
- else
- <:expr< match try Some $e$ with [ Stream.Failure -> None ] with
- [ Some $p$ -> $skont$
- | _ -> $ckont$ ] >>
- | SpStr loc p ->
- try
- match p with
- [ <:patt< $lid:v$ >> -> subst v skont
- | _ -> raise Not_found ]
- with
- [ Not_found -> <:expr< let $p$ = $lid:strm_n$ in $skont$ >> ] ]
-;
-
-value rec stream_pattern loc epo e ekont =
- fun
- [ [] ->
- match epo with
- [ Some ep -> <:expr< let $ep$ = Stream.count $lid:strm_n$ in $e$ >>
- | _ -> e ]
- | [(spc, err) :: spcl] ->
- let skont =
- let ekont err =
- let str =
- match err with
- [ Some estr -> estr
- | _ -> <:expr< "" >> ]
- in
- <:expr< raise (Stream.Error $str$) >>
- in
- stream_pattern loc epo e ekont spcl
- in
- let ckont = ekont err in
- stream_pattern_component skont ckont spc ]
-;
-
-value stream_patterns_term loc ekont tspel =
- let pel =
- List.map
- (fun (p, w, loc, spcl, epo, e) ->
- let p = <:patt< Some $p$ >> in
- let e =
- let ekont err =
- let str =
- match err with
- [ Some estr -> estr
- | _ -> <:expr< "" >> ]
- in
- <:expr< raise (Stream.Error $str$) >>
- in
- let skont = stream_pattern loc epo e ekont spcl in
- <:expr< do { $junk_fun loc$ $lid:strm_n$; $skont$ } >>
- in
- (p, w, e))
- tspel
- in
- let pel = pel @ [(<:patt< _ >>, None, ekont ())] in
- <:expr< match $peek_fun loc$ $lid:strm_n$ with [ $list:pel$ ] >>
-;
-
-value rec group_terms =
- fun
- [ [([(SpTrm loc p w, None) :: spcl], epo, e) :: spel] ->
- let (tspel, spel) = group_terms spel in
- ([(p, w, loc, spcl, epo, e) :: tspel], spel)
- | spel -> ([], spel) ]
-;
-
-value rec parser_cases loc =
- fun
- [ [] -> <:expr< raise Stream.Failure >>
- | spel ->
- match group_terms spel with
- [ ([], [(spcl, epo, e) :: spel]) ->
- stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl
- | (tspel, spel) ->
- stream_patterns_term loc (fun _ -> parser_cases loc spel) tspel ] ]
-;
-
-value cparser loc bpo pc =
- let e = parser_cases loc pc in
- let e =
- match bpo with
- [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $e$ >>
- | None -> e ]
- in
- let p = <:patt< ($lid:strm_n$ : Stream.t _) >> in
- <:expr< fun $p$ -> $e$ >>
-;
-
-value cparser_match loc me bpo pc =
- let pc = parser_cases loc pc in
- let e =
- match bpo with
- [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>
- | None -> pc ]
- in
- <:expr< let $lid:strm_n$ = $me$ in $e$ >>
-;
-
-(* streams *)
-
-value rec not_computing =
- fun
- [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $int:_$ >> |
- <:expr< $flo:_$ >> | <:expr< $chr:_$ >> | <:expr< $str:_$ >> ->
- True
- | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y
- | _ -> False ]
-and is_cons_apply_not_computing =
- fun
- [ <:expr< $uid:_$ >> -> True
- | <:expr< $lid:_$ >> -> False
- | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y
- | _ -> False ]
-;
-
-value slazy loc e =
- match e with
- [ <:expr< $f$ () >> ->
- match f with
- [ <:expr< $lid:_$ >> -> f
- | _ -> <:expr< fun _ -> $e$ >> ]
- | _ -> <:expr< fun _ -> $e$ >> ]
-;
-
-value rec cstream gloc =
- fun
- [ [] ->
- let loc = gloc in
- <:expr< Stream.sempty >>
- | [SeTrm loc e] ->
- if not_computing e then <:expr< Stream.ising $e$ >>
- else <:expr< Stream.lsing $slazy loc e$ >>
- | [SeTrm loc e :: secl] ->
- if not_computing e then <:expr< Stream.icons $e$ $cstream gloc secl$ >>
- else <:expr< Stream.lcons $slazy loc e$ $cstream gloc secl$ >>
- | [SeNtr loc e] ->
- if not_computing e then e else <:expr< Stream.slazy $slazy loc e$ >>
- | [SeNtr loc e :: secl] ->
- if not_computing e then <:expr< Stream.iapp $e$ $cstream gloc secl$ >>
- else <:expr< Stream.lapp $slazy loc e$ $cstream gloc secl$ >> ]
-;
-
-(* Syntax extensions in Ocaml grammar *)
-
-EXTEND
- GLOBAL: expr;
- expr: LEVEL "expr1"
- [ [ "parser"; po = OPT ipatt; OPT "|"; pcl = LIST1 parser_case SEP "|" ->
- <:expr< $cparser loc po pcl$ >>
- | "match"; e = SELF; "with"; "parser"; po = OPT ipatt; OPT "|";
- pcl = LIST1 parser_case SEP "|" ->
- <:expr< $cparser_match loc e po pcl$ >> ] ]
- ;
- parser_case:
- [ [ "[<"; sp = stream_patt; ">]"; po = OPT ipatt; "->"; e = expr ->
- (sp, po, e) ] ]
- ;
- stream_patt:
- [ [ spc = stream_patt_comp -> [(spc, None)]
- | spc = stream_patt_comp; ";" -> [(spc, None)]
- | spc = stream_patt_comp; ";"; sp = stream_patt_comp_err_list ->
- [(spc, None) :: sp]
- | -> (* empty *) [] ] ]
- ;
- stream_patt_comp_err_list:
- [ [ spc = stream_patt_comp_err -> [spc]
- | spc = stream_patt_comp_err; ";" -> [spc]
- | spc = stream_patt_comp_err; ";"; sp = SELF -> [spc :: sp] ] ]
- ;
- stream_patt_comp:
- [ [ "'"; p = patt; eo = OPT [ "when"; e = expr LEVEL "expr1" -> e ] ->
- SpTrm loc p eo
- | p = patt; "="; e = expr LEVEL "expr1" -> SpNtr loc p e
- | p = patt -> SpStr loc p ] ]
- ;
- stream_patt_comp_err:
- [ [ spc = stream_patt_comp;
- eo = OPT [ "?"; e = expr LEVEL "expr1" -> e ] ->
- (spc, eo) ] ]
- ;
- ipatt:
- [ [ i = LIDENT -> <:patt< $lid:i$ >> ] ]
- ;
- expr: LEVEL "simple"
- [ [ "[<"; ">]" -> <:expr< $cstream loc []$ >>
- | "[<"; sel = stream_expr_comp_list; ">]" ->
- <:expr< $cstream loc sel$ >> ] ]
- ;
- stream_expr_comp_list:
- [ [ se = stream_expr_comp; ";"; sel = SELF -> [se :: sel]
- | se = stream_expr_comp; ";" -> [se]
- | se = stream_expr_comp -> [se] ] ]
- ;
- stream_expr_comp:
- [ [ "'"; e = expr LEVEL "expr1" -> SeTrm loc e
- | e = expr LEVEL "expr1" -> SeNtr loc e ] ]
- ;
-END;
diff --git a/camlp4/etc/pa_oop.ml b/camlp4/etc/pa_oop.ml
deleted file mode 100644
index fd56158346..0000000000
--- a/camlp4/etc/pa_oop.ml
+++ /dev/null
@@ -1,154 +0,0 @@
-(* camlp4r pa_extend.cmo q_MLast.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1998 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Pcaml;
-
-type spat_comp =
- [ SpTrm of MLast.loc and MLast.patt and option MLast.expr
- | SpNtr of MLast.loc and MLast.patt and MLast.expr
- | SpStr of MLast.loc and MLast.patt ]
-;
-type sexp_comp =
- [ SeTrm of MLast.loc and MLast.expr | SeNtr of MLast.loc and MLast.expr ]
-;
-
-value strm_n = "strm__";
-value peek_fun loc = <:expr< Stream.peek >>;
-value junk_fun loc = <:expr< Stream.junk >>;
-
-(* Parsers. *)
-
-value stream_pattern_component skont =
- fun
- [ SpTrm loc p wo ->
- (<:expr< $peek_fun loc$ $lid:strm_n$ >>, p, wo,
- <:expr< do { $junk_fun loc$ $lid:strm_n$; $skont$ } >>)
- | SpNtr loc p e ->
- (<:expr< try Some ($e$ $lid:strm_n$) with
- [ Stream.Failure -> None ] >>,
- p, None, skont)
- | SpStr loc p ->
- (<:expr< Some $lid:strm_n$ >>, p, None, skont) ]
-;
-
-value rec stream_pattern loc epo e ekont =
- fun
- [ [] ->
- match epo with
- [ Some ep -> <:expr< let $ep$ = Stream.count $lid:strm_n$ in $e$ >>
- | _ -> e ]
- | [(spc, err) :: spcl] ->
- let skont =
- let ekont err =
- let str =
- match err with
- [ Some estr -> estr
- | _ -> <:expr< "" >> ]
- in
- <:expr< raise (Stream.Error $str$) >>
- in
- stream_pattern loc epo e ekont spcl
- in
- let (tst, p, wo, e) = stream_pattern_component skont spc in
- let ckont = ekont err in
- <:expr< match $tst$ with
- [ Some $p$ $when:wo$ -> $e$ | _ -> $ckont$ ] >> ]
-;
-
-value rec parser_cases loc =
- fun
- [ [] -> <:expr< raise Stream.Failure >>
- | [(spcl, epo, e) :: spel] ->
- stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl ]
-;
-
-value cparser loc bpo pc =
- let e = parser_cases loc pc in
- let e =
- match bpo with
- [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $e$ >>
- | None -> e ]
- in
- let p = <:patt< ($lid:strm_n$ : Stream.t _) >> in
- <:expr< fun $p$ -> $e$ >>
-;
-
-value cparser_match loc me bpo pc =
- let pc = parser_cases loc pc in
- let e =
- match bpo with
- [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>
- | None -> pc ]
- in
- <:expr< let $lid:strm_n$ = $me$ in $e$ >>
-;
-
-(* streams *)
-
-value slazy loc e = <:expr< fun _ -> $e$ >>;
-
-value rec cstream gloc =
- fun
- [ [] -> let loc = gloc in <:expr< Stream.sempty >>
- | [SeTrm loc e :: secl] ->
- <:expr< Stream.lcons $slazy loc e$ $cstream gloc secl$ >>
- | [SeNtr loc e :: secl] ->
- <:expr< Stream.lapp $slazy loc e$ $cstream gloc secl$ >> ]
-;
-
-(* Syntax extensions in Ocaml grammar *)
-
-EXTEND
- GLOBAL: expr;
- expr: LEVEL "expr1"
- [ [ "parser"; po = OPT ipatt; OPT "|"; pcl = LIST1 parser_case SEP "|" ->
- <:expr< $cparser loc po pcl$ >>
- | "match"; e = expr; "with"; "parser"; po = OPT ipatt; OPT "|";
- pcl = LIST1 parser_case SEP "|" ->
- <:expr< $cparser_match loc e po pcl$ >> ] ]
- ;
- parser_case:
- [ [ "[<"; sp = stream_patt; ">]"; po = OPT ipatt; "->"; e = expr ->
- (sp, po, e) ] ]
- ;
- stream_patt:
- [ [ spc = stream_patt_comp -> [(spc, None)]
- | spc = stream_patt_comp; ";"; sp = LIST1 stream_patt_comp_err SEP ";" ->
- [(spc, None) :: sp]
- | (* empty *) -> [] ] ]
- ;
- stream_patt_comp_err:
- [ [ spc = stream_patt_comp;
- eo = OPT [ "??"; e = expr LEVEL "expr1" -> e ] ->
- (spc, eo) ] ]
- ;
- stream_patt_comp:
- [ [ "'"; p = patt; eo = OPT [ "when"; e = (expr LEVEL "expr1") -> e ] ->
- SpTrm loc p eo
- | p = patt; "="; e = (expr LEVEL "expr1") -> SpNtr loc p e
- | p = patt -> SpStr loc p ] ]
- ;
- ipatt:
- [ [ i = LIDENT -> <:patt< $lid:i$ >> ] ]
- ;
-
- expr: LEVEL "simple"
- [ [ "[<"; se = LIST0 stream_expr_comp SEP ";"; ">]" ->
- <:expr< $cstream loc se$ >> ] ]
- ;
- stream_expr_comp:
- [ [ "'"; e = expr LEVEL "expr1" -> SeTrm loc e
- | e = expr LEVEL "expr1" -> SeNtr loc e ] ]
- ;
-END;
diff --git a/camlp4/etc/pa_op.ml b/camlp4/etc/pa_op.ml
deleted file mode 100644
index 5f2fff0fae..0000000000
--- a/camlp4/etc/pa_op.ml
+++ /dev/null
@@ -1,330 +0,0 @@
-(* camlp4r pa_extend.cmo q_MLast.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1998 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Pcaml;
-
-type spat_comp =
- [ SpTrm of MLast.loc and MLast.patt and option MLast.expr
- | SpNtr of MLast.loc and MLast.patt and MLast.expr
- | SpStr of MLast.loc and MLast.patt ]
-;
-type sexp_comp =
- [ SeTrm of MLast.loc and MLast.expr | SeNtr of MLast.loc and MLast.expr ]
-;
-
-value strm_n = "strm__";
-value peek_fun loc = <:expr< Stream.peek >>;
-value junk_fun loc = <:expr< Stream.junk >>;
-
-(* Parsers. *)
-(* In syntax generated, many cases are optimisations. *)
-
-value rec pattern_eq_expression p e =
- match (p, e) with
- [ (<:patt< $lid:a$ >>, <:expr< $lid:b$ >>) -> a = b
- | (<:patt< $uid:a$ >>, <:expr< $uid:b$ >>) -> a = b
- | (<:patt< $p1$ $p2$ >>, <:expr< $e1$ $e2$ >>) ->
- pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2
- | _ -> False ]
-;
-
-value is_raise e =
- match e with
- [ <:expr< raise $_$ >> -> True
- | _ -> False ]
-;
-
-value is_raise_failure e =
- match e with
- [ <:expr< raise Stream.Failure >> -> True
- | _ -> False ]
-;
-
-value rec handle_failure e =
- match e with
- [ <:expr< try $te$ with [ Stream.Failure -> $e$] >> ->
- handle_failure e
- | <:expr< match $me$ with [ $list:pel$ ] >> ->
- handle_failure me &&
- List.for_all
- (fun
- [ (_, None, e) -> handle_failure e
- | _ -> False ])
- pel
- | <:expr< let $list:pel$ in $e$ >> ->
- List.for_all (fun (p, e) -> handle_failure e) pel && handle_failure e
- | <:expr< $lid:_$ >> | <:expr< $int:_$ >> | <:expr< $str:_$ >> |
- <:expr< $chr:_$ >> | <:expr< fun [ $list:_$ ] >> | <:expr< $uid:_$ >> ->
- True
- | <:expr< raise $e$ >> ->
- match e with
- [ <:expr< Stream.Failure >> -> False
- | _ -> True ]
- | <:expr< $f$ $x$ >> ->
- is_constr_apply f && handle_failure f && handle_failure x
- | _ -> False ]
-and is_constr_apply =
- fun
- [ <:expr< $uid:_$ >> -> True
- | <:expr< $lid:_$ >> -> False
- | <:expr< $x$ $_$ >> -> is_constr_apply x
- | _ -> False ]
-;
-
-value rec subst v e =
- let loc = MLast.loc_of_expr e in
- match e with
- [ <:expr< $lid:x$ >> ->
- let x = if x = v then strm_n else x in
- <:expr< $lid:x$ >>
- | <:expr< $uid:_$ >> -> e
- | <:expr< $int:_$ >> -> e
- | <:expr< $chr:_$ >> -> e
- | <:expr< $str:_$ >> -> e
- | <:expr< $_$ . $_$ >> -> e
- | <:expr< let $opt:rf$ $list:pel$ in $e$ >> ->
- <:expr< let $opt:rf$ $list:List.map (subst_pe v) pel$ in $subst v e$ >>
- | <:expr< $e1$ $e2$ >> -> <:expr< $subst v e1$ $subst v e2$ >>
- | <:expr< ( $list:el$ ) >> -> <:expr< ( $list:List.map (subst v) el$ ) >>
- | _ -> raise Not_found ]
-and subst_pe v (p, e) =
- match p with
- [ <:patt< $lid:v'$ >> -> if v = v' then (p, e) else (p, subst v e)
- | _ -> raise Not_found ]
-;
-
-value stream_pattern_component skont ckont =
- fun
- [ SpTrm loc p wo ->
- <:expr< match $peek_fun loc$ $lid:strm_n$ with
- [ Some $p$ $when:wo$ ->
- do { $junk_fun loc$ $lid:strm_n$; $skont$ }
- | _ -> $ckont$ ] >>
- | SpNtr loc p e ->
- let e =
- match e with
- [ <:expr< fun [ ($lid:v$ : Stream.t _) -> $e$ ] >> when v = strm_n -> e
- | _ -> <:expr< $e$ $lid:strm_n$ >> ]
- in
- if pattern_eq_expression p skont then
- if is_raise_failure ckont then e
- else if handle_failure e then e
- else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >>
- else if is_raise_failure ckont then
- <:expr< let $p$ = $e$ in $skont$ >>
- else if pattern_eq_expression <:patt< Some $p$ >> skont then
- <:expr< try Some $e$ with [ Stream.Failure -> $ckont$ ] >>
- else if is_raise ckont then
- let tst =
- if handle_failure e then e
- else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >>
- in
- <:expr< let $p$ = $tst$ in $skont$ >>
- else
- <:expr< match try Some $e$ with [ Stream.Failure -> None ] with
- [ Some $p$ -> $skont$
- | _ -> $ckont$ ] >>
- | SpStr loc p ->
- try
- match p with
- [ <:patt< $lid:v$ >> -> subst v skont
- | _ -> raise Not_found ]
- with
- [ Not_found -> <:expr< let $p$ = $lid:strm_n$ in $skont$ >> ] ]
-;
-
-value rec stream_pattern loc epo e ekont =
- fun
- [ [] ->
- match epo with
- [ Some ep -> <:expr< let $ep$ = Stream.count $lid:strm_n$ in $e$ >>
- | _ -> e ]
- | [(spc, err) :: spcl] ->
- let skont =
- let ekont err =
- let str =
- match err with
- [ Some estr -> estr
- | _ -> <:expr< "" >> ]
- in
- <:expr< raise (Stream.Error $str$) >>
- in
- stream_pattern loc epo e ekont spcl
- in
- let ckont = ekont err in stream_pattern_component skont ckont spc ]
-;
-
-value stream_patterns_term loc ekont tspel =
- let pel =
- List.map
- (fun (p, w, loc, spcl, epo, e) ->
- let p = <:patt< Some $p$ >> in
- let e =
- let ekont err =
- let str =
- match err with
- [ Some estr -> estr
- | _ -> <:expr< "" >> ]
- in
- <:expr< raise (Stream.Error $str$) >>
- in
- let skont = stream_pattern loc epo e ekont spcl in
- <:expr< do { $junk_fun loc$ $lid:strm_n$; $skont$ } >>
- in
- (p, w, e))
- tspel
- in
- let pel = pel @ [(<:patt< _ >>, None, ekont ())] in
- <:expr< match $peek_fun loc$ $lid:strm_n$ with [ $list:pel$ ] >>
-;
-
-value rec group_terms =
- fun
- [ [([(SpTrm loc p w, None) :: spcl], epo, e) :: spel] ->
- let (tspel, spel) = group_terms spel in
- ([(p, w, loc, spcl, epo, e) :: tspel], spel)
- | spel -> ([], spel) ]
-;
-
-value rec parser_cases loc =
- fun
- [ [] -> <:expr< raise Stream.Failure >>
- | spel ->
- match group_terms spel with
- [ ([], [(spcl, epo, e) :: spel]) ->
- stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl
- | (tspel, spel) ->
- stream_patterns_term loc (fun _ -> parser_cases loc spel) tspel ] ]
-;
-
-value cparser loc bpo pc =
- let e = parser_cases loc pc in
- let e =
- match bpo with
- [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $e$ >>
- | None -> e ]
- in
- let p = <:patt< ($lid:strm_n$ : Stream.t _) >> in
- <:expr< fun $p$ -> $e$ >>
-;
-
-value cparser_match loc me bpo pc =
- let pc = parser_cases loc pc in
- let e =
- match bpo with
- [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>
- | None -> pc ]
- in
- <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >>
-;
-
-(* streams *)
-
-value rec not_computing =
- fun
- [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $int:_$ >> |
- <:expr< $flo:_$ >> | <:expr< $chr:_$ >> | <:expr< $str:_$ >> -> True
- | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y
- | _ -> False ]
-and is_cons_apply_not_computing =
- fun
- [ <:expr< $uid:_$ >> -> True
- | <:expr< $lid:_$ >> -> False
- | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y
- | _ -> False ]
-;
-
-value slazy loc e =
- match e with
- [ <:expr< $f$ () >> ->
- match f with
- [ <:expr< $lid:_$ >> -> f
- | _ -> <:expr< fun _ -> $e$ >> ]
- | _ -> <:expr< fun _ -> $e$ >> ]
-;
-
-value rec cstream gloc =
- fun
- [ [] -> let loc = gloc in <:expr< Stream.sempty >>
- | [SeTrm loc e] ->
- if not_computing e then <:expr< Stream.ising $e$ >>
- else <:expr< Stream.lsing $slazy loc e$ >>
- | [SeTrm loc e :: secl] ->
- if not_computing e then <:expr< Stream.icons $e$ $cstream gloc secl$ >>
- else <:expr< Stream.lcons $slazy loc e$ $cstream gloc secl$ >>
- | [SeNtr loc e] ->
- if not_computing e then e else <:expr< Stream.slazy $slazy loc e$ >>
- | [SeNtr loc e :: secl] ->
- if not_computing e then <:expr< Stream.iapp $e$ $cstream gloc secl$ >>
- else <:expr< Stream.lapp $slazy loc e$ $cstream gloc secl$ >> ]
-;
-
-(* Syntax extensions in Ocaml grammar *)
-
-EXTEND
- GLOBAL: expr;
- expr: LEVEL "expr1"
- [ [ "parser"; po = OPT ipatt; OPT "|"; pcl = LIST1 parser_case SEP "|" ->
- <:expr< $cparser loc po pcl$ >>
- | "match"; e = expr; "with"; "parser"; po = OPT ipatt; OPT "|";
- pcl = LIST1 parser_case SEP "|" ->
- <:expr< $cparser_match loc e po pcl$ >> ] ]
- ;
- parser_case:
- [ [ "[<"; sp = stream_patt; ">]"; po = OPT ipatt; "->"; e = expr ->
- (sp, po, e) ] ]
- ;
- stream_patt:
- [ [ spc = stream_patt_comp -> [(spc, None)]
- | spc = stream_patt_comp; ";" -> [(spc, None)]
- | spc = stream_patt_comp; ";"; sp = stream_patt_comp_err_list ->
- [(spc, None) :: sp]
- | (* empty *) -> [] ] ]
- ;
- stream_patt_comp_err_list:
- [ [ spc = stream_patt_comp_err -> [spc]
- | spc = stream_patt_comp_err; ";" -> [spc]
- | spc = stream_patt_comp_err; ";"; sp = stream_patt_comp_err_list ->
- [spc :: sp] ] ]
- ;
- stream_patt_comp:
- [ [ "'"; p = patt; eo = OPT [ "when"; e = (expr LEVEL "expr1") -> e ] ->
- SpTrm loc p eo
- | p = patt; "="; e = (expr LEVEL "expr1") -> SpNtr loc p e
- | p = patt -> SpStr loc p ] ]
- ;
- stream_patt_comp_err:
- [ [ spc = stream_patt_comp;
- eo = OPT [ "??"; e = expr LEVEL "expr1" -> e ] -> (spc, eo) ] ]
- ;
- ipatt:
- [ [ i = LIDENT -> <:patt< $lid:i$ >>
- | "_" -> <:patt< _ >> ] ]
- ;
-
- expr: LEVEL "simple"
- [ [ "[<"; ">]" -> <:expr< $cstream loc []$ >>
- | "[<"; sel = stream_expr_comp_list; ">]" ->
- <:expr< $cstream loc sel$ >> ] ]
- ;
- stream_expr_comp_list:
- [ [ se = stream_expr_comp; ";"; sel = stream_expr_comp_list -> [se :: sel]
- | se = stream_expr_comp; ";" -> [se]
- | se = stream_expr_comp -> [se] ] ]
- ;
- stream_expr_comp:
- [ [ "'"; e = expr LEVEL "expr1" -> SeTrm loc e
- | e = expr LEVEL "expr1" -> SeNtr loc e ] ]
- ;
-END;
diff --git a/camlp4/etc/pa_ru.ml b/camlp4/etc/pa_ru.ml
deleted file mode 100644
index d3060c88c5..0000000000
--- a/camlp4/etc/pa_ru.ml
+++ /dev/null
@@ -1,46 +0,0 @@
-(* camlp4r pa_extend.cmo q_MLast.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1998 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Pcaml;
-
-value o2b =
- fun
- [ Some _ -> True
- | None -> False ]
-;
-
-EXTEND
- GLOBAL: expr;
- expr: LEVEL "top"
- [ [ "do"; "{"; seq = sequence; "}" ->
- match seq with
- [ [e] -> e
- | _ -> <:expr< do { $list:seq$ } >> ] ] ]
- ;
- sequence:
- [ [ "let"; o = OPT "rec"; l = LIST1 let_binding SEP "and"; [ "in" | ";" ];
- el = SELF ->
- let e =
- match el with
- [ [e] -> e
- | _ -> <:expr< do { $list:el$ } >> ]
- in
- [<:expr< let $opt:o2b o$ $list:l$ in $e$ >>]
- | e = expr; ";"; el = SELF ->
- let e = let loc = MLast.loc_of_expr e in <:expr< ($e$ : unit) >> in
- [e :: el]
- | e = expr; ";" -> [e]
- | e = expr -> [e] ] ]
- ;
-END;
diff --git a/camlp4/etc/pa_scheme.ml b/camlp4/etc/pa_scheme.ml
deleted file mode 100644
index 846a11e465..0000000000
--- a/camlp4/etc/pa_scheme.ml
+++ /dev/null
@@ -1,1002 +0,0 @@
-; camlp4 ./pa_schemer.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo
-; $Id$
-
-(open Pcaml)
-(open Stdpp)
-
-(type (choice 'a 'b) (sum (Left 'a) (Right 'b)))
-
-; Buffer
-
-(module Buff
- (struct
- (define buff (ref (String.create 80)))
- (define (store len x)
- (if (>= len (String.length buff.val))
- (:= buff.val (^ buff.val (String.create (String.length buff.val)))))
- (:= buff.val.[len] x)
- (succ len))
- (define (get len) (String.sub buff.val 0 len))))
-
-; Lexer
-
-(definerec skip_to_eol
- (parser
- (((` (or '\n' '\r'))) ())
- (((` _) s) (skip_to_eol s))))
-
-(define no_ident ['(' ')' '[' ']' '{' '}' ' ' '\t' '\n' '\r' ';'])
-
-(definerec (ident len)
- (parser
- (((` '.')) (values (Buff.get len) True))
- (((` x (not (List.mem x no_ident))) s) (ident (Buff.store len x) s))
- (() (values (Buff.get len) False))))
-
-(define (identifier kwt (values s dot))
- (let ((con
- (try (begin (: (Hashtbl.find kwt s) unit) "")
- (Not_found
- (match s.[0]
- ((range 'A' 'Z') (if dot "UIDENTDOT" "UIDENT"))
- (_ (if dot "LIDENTDOT" "LIDENT")))))))
- (values con s)))
-
-(definerec (string len)
- (parser
- (((` '"')) (Buff.get len))
- (((` '\\') (` c) s) (string (Buff.store (Buff.store len '\\') c) s))
- (((` x) s) (string (Buff.store len x) s))))
-
-(definerec (end_exponent_part_under len)
- (parser
- (((` (as (range '0' '9') c)) s)
- (end_exponent_part_under (Buff.store len c) s))
- (() (values "FLOAT" (Buff.get len)))))
-
-(define (end_exponent_part len)
- (parser
- (((` (as (range '0' '9') c)) s)
- (end_exponent_part_under (Buff.store len c) s))
- (() (raise (Stream.Error "ill-formed floating-point constant")))))
-
-(define (exponent_part len)
- (parser
- (((` (as (or '+' '-') c)) s) (end_exponent_part (Buff.store len c) s))
- (((a (end_exponent_part len))) a)))
-
-(definerec (decimal_part len)
- (parser
- (((` (as (range '0' '9') c)) s) (decimal_part (Buff.store len c) s))
- (((` (or 'e' 'E')) s) (exponent_part (Buff.store len 'E') s))
- (() (values "FLOAT" (Buff.get len)))))
-
-(definerec (number len)
- (parser
- (((` (as (range '0' '9') c)) s) (number (Buff.store len c) s))
- (((` '.') s) (decimal_part (Buff.store len '.') s))
- (((` (or 'e' 'E')) s) (exponent_part (Buff.store len 'E') s))
- (() (values "INT" (Buff.get len)))))
-
-(define binary
- (parser
- (((` (as (range '0' '1') c))) c)))
-
-(define octal
- (parser
- (((` (as (range '0' '7') c))) c)))
-
-(define hexa
- (parser
- (((` (as (or (range '0' '9') (range 'a' 'f') (range 'A' 'F')) c))) c)))
-
-(definerec (digits_under kind len)
- (parser
- (((d kind) s) (digits_under kind (Buff.store len d) s))
- (() (Buff.get len))))
-
-(define (digits kind bp len)
- (parser
- (((d kind) s) (values "INT" (digits_under kind (Buff.store len d) s)))
- ((s) ep
- (raise_with_loc (values bp ep) (Failure "ill-formed integer constant")))))
-
-(define (base_number kwt bp len)
- (parser
- (((` (or 'b' 'B')) s) (digits binary bp (Buff.store len 'b') s))
- (((` (or 'o' 'O')) s) (digits octal bp (Buff.store len 'o') s))
- (((` (or 'x' 'X')) s) (digits hexa bp (Buff.store len 'x') s))
- (((id (ident (Buff.store 0 '#')))) (identifier kwt id))))
-
-(definerec (operator len)
- (parser
- (((` '.')) (Buff.get (Buff.store len '.')))
- (() (Buff.get len))))
-
-(define (char_or_quote_id x)
- (parser
- (((` ''')) (values "CHAR" (String.make 1 x)))
- ((s) ep
- (if (List.mem x no_ident)
- (Stdpp.raise_with_loc (values (- ep 2) (- ep 1))
- (Stream.Error "bad quote"))
- (let* ((len (Buff.store (Buff.store 0 ''') x))
- ((values s dot) (ident len s)))
- (values (if dot "LIDENTDOT" "LIDENT") s))))))
-
-(definerec (char len)
- (parser
- (((` ''')) len)
- (((` x) s) (char (Buff.store len x) s))))
-
-(define quote
- (parser
- (((` '\\') (len (char (Buff.store 0 '\\'))))
- (values "CHAR" (Buff.get len)))
- (((` x) s) (char_or_quote_id x s))))
-
-; The system with LIDENTDOT and UIDENTDOT is not great (it would be
-; better to have a token DOT (actually SPACEDOT and DOT)) but it is
-; the only way (that I have found) to have a good behaviour in the
-; toplevel (not expecting tokens after a phrase). Drawbacks: 1/ to be
-; complete, we should have STRINGDOT, RIGHTPARENDOT, and so on 2/ the
-; parser rule with dot is right associative and we have to reverse
-; the resulting tree (using the function leftify).
-; This is a complicated issue: the behaviour of the OCaml toplevel
-; is strange, anyway. For example, even without Camlp4, The OCaml
-; toplevel accepts that:
-; # let x = 32;; foo bar match let )
-
-(definerec*
- ((lexer kwt)
- (parser
- (((t (lexer0 kwt))
- (_ no_dot)) t)))
- (no_dot
- (parser
- (((` '.')) ep
- (Stdpp.raise_with_loc (values (- ep 1) ep) (Stream.Error "bad dot")))
- (() ())))
- ((lexer0 kwt)
- (parser bp
- (((` (or '\t' '\n' '\r')) s) (lexer0 kwt s))
- (((` ' ') s) (after_space kwt s))
- (((` ';') (_ skip_to_eol) s) (lexer kwt s))
- (((` '(')) (values (values "" "(") (values bp (+ bp 1))))
- (((` ')') s) ep (values (values "" (rparen s)) (values bp ep)))
- (((` '[')) (values (values "" "[") (values bp (+ bp 1))))
- (((` ']')) (values (values "" "]") (values bp (+ bp 1))))
- (((` '{')) (values (values "" "{") (values bp (+ bp 1))))
- (((` '}')) (values (values "" "}") (values bp (+ bp 1))))
- (((` '"') (s (string 0))) ep
- (values (values "STRING" s) (values bp ep)))
- (((` ''') (tok quote)) ep (values tok (values bp ep)))
- (((` '<') (tok (less kwt))) ep (values tok (values bp ep)))
- (((` '-') (tok (minus kwt))) ep (values tok (values bp ep)))
- (((` '~') (tok tilde)) ep (values tok (values bp ep)))
- (((` '?') (tok question)) ep (values tok (values bp ep)))
- (((` '#') (tok (base_number kwt bp (Buff.store 0 '0')))) ep
- (values tok (values bp ep)))
- (((` (as (range '0' '9') c)) (tok (number (Buff.store 0 c)))) ep
- (values tok (values bp ep)))
- (((` (as (or '+' '*' '/') c)) (id (operator (Buff.store 0 c)))) ep
- (values (identifier kwt (values id False)) (values bp ep)))
- (((` x) (id (ident (Buff.store 0 x)))) ep
- (values (identifier kwt id) (values bp ep)))
- (() (values (values "EOI" "") (values bp (+ bp 1))))))
- (rparen
- (parser
- (((` '.')) ").")
- ((_) ")")))
- ((after_space kwt)
- (parser
- (((` '.')) ep (values (values "" ".") (values (- ep 1) ep)))
- (((x (lexer0 kwt))) x)))
- (tilde
- (parser
- (((` (as (range 'a' 'z') c)) ((values s dot) (ident (Buff.store 0 c))))
- (values "TILDEIDENT" s))
- (() (values "LIDENT" "~"))))
- (question
- (parser
- (((` (as (range 'a' 'z') c)) ((values s dot) (ident (Buff.store 0 c))))
- (values "QUESTIONIDENT" s))
- (() (values "LIDENT" "?"))))
- ((minus kwt)
- (parser
- (((` '.')) (identifier kwt (values "-." False)))
- (((` (as (range '0' '9') c))
- (n (number (Buff.store (Buff.store 0 '-') c)))) ep n)
- (((id (ident (Buff.store 0 '-')))) (identifier kwt id))))
- ((less kwt)
- (parser
- (((` ':') (lab (label 0)) (? (` '<') "'<' expected") (q (quotation 0)))
- (values "QUOT" (^ lab ":" q)))
- (((id (ident (Buff.store 0 '<')))) (identifier kwt id))))
- ((label len)
- (parser
- (((` (as (or (range 'a' 'z') (range 'A' 'Z') '_') c)) s)
- (label (Buff.store len c) s))
- (() (Buff.get len))))
- ((quotation len)
- (parser
- (((` '>') s) (quotation_greater len s))
- (((` x) s) (quotation (Buff.store len x) s))
- (() (failwith "quotation not terminated"))))
- ((quotation_greater len)
- (parser
- (((` '>')) (Buff.get len))
- (((a (quotation (Buff.store len '>')))) a))))
-
-(define (lexer_using kwt (values con prm))
- (match con
- ((or "CHAR" "EOI" "INT" "FLOAT" "LIDENT" "LIDENTDOT" "QUESTIONIDENT"
- "QUOT" "STRING" "TILDEIDENT" "UIDENT" "UIDENTDOT")
- ())
- ("ANTIQUOT" ())
- ("" (try (Hashtbl.find kwt prm) (Not_found (Hashtbl.add kwt prm ()))))
- (_
- (raise
- (Token.Error
- (^ "the constructor \"" con "\" is not recognized by Plexer"))))))
-
-(define (lexer_text (values con prm))
- (cond
- ((= con "") (^ "'"prm "'"))
- ((= prm "") con)
- (else (^ con " \"" prm "\""))))
-
-(define (lexer_gmake ())
- (let ((kwt (Hashtbl.create 89)))
- {(Token.tok_func (Token.lexer_func_of_parser (lexer kwt)))
- (Token.tok_using (lexer_using kwt))
- (Token.tok_removing (lambda))
- (Token.tok_match Token.default_match)
- (Token.tok_text lexer_text)
- (Token.tok_comm None)}))
-
-; Building AST
-
-(type sexpr
- (sum
- (Sacc MLast.loc sexpr sexpr)
- (Schar MLast.loc string)
- (Sexpr MLast.loc (list sexpr))
- (Sint MLast.loc string)
- (Sfloat MLast.loc string)
- (Slid MLast.loc string)
- (Slist MLast.loc (list sexpr))
- (Sqid MLast.loc string)
- (Squot MLast.loc string string)
- (Srec MLast.loc (list sexpr))
- (Sstring MLast.loc string)
- (Stid MLast.loc string)
- (Suid MLast.loc string)))
-
-(define loc_of_sexpr
- (lambda_match
- ((or (Sacc loc _ _) (Schar loc _) (Sexpr loc _) (Sint loc _)
- (Sfloat loc _) (Slid loc _) (Slist loc _) (Sqid loc _) (Squot loc _ _)
- (Srec loc _) (Sstring loc _) (Stid loc _) (Suid loc _))
- loc)))
-(define (error_loc loc err)
- (raise_with_loc loc (Stream.Error (^ err " expected"))))
-(define (error se err) (error_loc (loc_of_sexpr se) err))
-
-(define strm_n "strm__")
-(define (peek_fun loc) <:expr< Stream.peek >>)
-(define (junk_fun loc) <:expr< Stream.junk >>)
-
-(define assoc_left_parsed_op_list ["+" "*" "+." "*." "land" "lor" "lxor"])
-(define assoc_right_parsed_op_list ["and" "or" "^" "@"])
-(define and_by_couple_op_list ["=" "<>" "<" ">" "<=" ">=" "==" "!="])
-
-(define (op_apply loc e1 e2)
- (lambda_match
- ("and" <:expr< $e1$ && $e2$ >>)
- ("or" <:expr< $e1$ || $e2$ >>)
- (x <:expr< $lid:x$ $e1$ $e2$ >>)))
-
-(define string_se
- (lambda_match
- ((Sstring loc s) s)
- (se (error se "string"))))
-
-(define mod_ident_se
- (lambda_match
- ((Suid _ s) [(Pcaml.rename_id.val s)])
- ((Slid _ s) [(Pcaml.rename_id.val s)])
- (se (error se "mod_ident"))))
-
-(define (lident_expr loc s)
- (if (&& (> (String.length s) 1) (= s.[0] '`'))
- (let ((s (String.sub s 1 (- (String.length s) 1))))
- <:expr< ` $s$ >>)
- <:expr< $lid:(Pcaml.rename_id.val s)$ >>))
-
-(definerec*
- (module_expr_se
- (lambda_match
- ((Sexpr loc [(Slid _ "functor") (Suid _ s) se1 se2])
- (let* ((s (Pcaml.rename_id.val s))
- (mt (module_type_se se1))
- (me (module_expr_se se2)))
- <:module_expr< functor ($s$ : $mt$) -> $me$ >>))
- ((Sexpr loc [(Slid _ "struct") . sl])
- (let ((mel (List.map str_item_se sl)))
- <:module_expr< struct $list:mel$ end >>))
- ((Sexpr loc [se1 se2])
- (let* ((me1 (module_expr_se se1))
- (me2 (module_expr_se se2)))
- <:module_expr< $me1$ $me2$ >>))
- ((Suid loc s) <:module_expr< $uid:(Pcaml.rename_id.val s)$ >>)
- (se (error se "module expr"))))
- (module_type_se
- (lambda_match
- ((Sexpr loc [(Slid _ "functor") (Suid _ s) se1 se2])
- (let* ((s (Pcaml.rename_id.val s))
- (mt1 (module_type_se se1))
- (mt2 (module_type_se se2)))
- <:module_type< functor ($s$ : $mt1$) -> $mt2$ >>))
- ((Sexpr loc [(Slid _ "sig") . sel])
- (let ((sil (List.map sig_item_se sel)))
- <:module_type< sig $list:sil$ end >>))
- ((Sexpr loc [(Slid _ "with") se (Sexpr _ sel)])
- (let* ((mt (module_type_se se))
- (wcl (List.map with_constr_se sel)))
- <:module_type< $mt$ with $list:wcl$ >>))
- ((Suid loc s) <:module_type< $uid:(Pcaml.rename_id.val s)$ >>)
- (se (error se "module type"))))
- (with_constr_se
- (lambda_match
- ((Sexpr loc [(Slid _ "type") se1 se2])
- (let* ((tn (mod_ident_se se1))
- (te (ctyp_se se2)))
- (MLast.WcTyp loc tn [] te)))
- (se (error se "with constr"))))
- (sig_item_se
- (lambda_match
- ((Sexpr loc [(Slid _ "type") . sel])
- (let ((tdl (type_declaration_list_se sel)))
- <:sig_item< type $list:tdl$ >>))
- ((Sexpr loc [(Slid _ "exception") (Suid _ c) . sel])
- (let* ((c (Pcaml.rename_id.val c))
- (tl (List.map ctyp_se sel)))
- <:sig_item< exception $c$ of $list:tl$ >>))
- ((Sexpr loc [(Slid _ "value") (Slid _ s) se])
- (let* ((s (Pcaml.rename_id.val s))
- (t (ctyp_se se)))
- <:sig_item< value $s$ : $t$ >>))
- ((Sexpr loc [(Slid _ "external") (Slid _ i) se . sel])
- (let* ((i (Pcaml.rename_id.val i))
- (pd (List.map string_se sel))
- (t (ctyp_se se)))
- <:sig_item< external $i$ : $t$ = $list:pd$ >>))
- ((Sexpr loc [(Slid _ "module") (Suid _ s) se])
- (let* ((s (Pcaml.rename_id.val s))
- (mb (module_type_se se)))
- <:sig_item< module $s$ : $mb$ >>))
- ((Sexpr loc [(Slid _ "moduletype") (Suid _ s) se])
- (let* ((s (Pcaml.rename_id.val s))
- (mt (module_type_se se)))
- <:sig_item< module type $s$ = $mt$ >>))
- (se (error se "sig item"))))
- ((str_item_se se)
- (match se
- ((Sexpr loc [(Slid _ "open") se])
- (let ((s (mod_ident_se se))) <:str_item< open $s$ >>))
- ((Sexpr loc [(Slid _ "type") . sel])
- (let ((tdl (type_declaration_list_se sel)))
- <:str_item< type $list:tdl$ >>))
- ((Sexpr loc [(Slid _ "exception") (Suid _ c) . sel])
- (let* ((c (Pcaml.rename_id.val c))
- (tl (List.map ctyp_se sel)))
- <:str_item< exception $c$ of $list:tl$ >>))
- ((Sexpr loc [(Slid _ (as (or "define" "definerec") r)) se . sel])
- (let* ((r (= r "definerec"))
- ((values p e) (fun_binding_se se (begin_se loc sel))))
- <:str_item< value $opt:r$ $p$ = $e$ >>))
- ((Sexpr loc [(Slid _ (as (or "define*" "definerec*") r)) . sel])
- (let* ((r (= r "definerec*"))
- (lbs (List.map let_binding_se sel)))
- <:str_item< value $opt:r$ $list:lbs$ >>))
- ((Sexpr loc [(Slid _ "external") (Slid _ i) se . sel])
- (let* ((i (Pcaml.rename_id.val i))
- (pd (List.map string_se sel))
- (t (ctyp_se se)))
- <:str_item< external $i$ : $t$ = $list:pd$ >>))
- ((Sexpr loc [(Slid _ "module") (Suid _ i) se])
- (let* ((i (Pcaml.rename_id.val i))
- (mb (module_binding_se se)))
- <:str_item< module $i$ = $mb$ >>))
- ((Sexpr loc [(Slid _ "moduletype") (Suid _ s) se])
- (let* ((s (Pcaml.rename_id.val s))
- (mt (module_type_se se)))
- <:str_item< module type $s$ = $mt$ >>))
- (_
- (let* ((loc (loc_of_sexpr se))
- (e (expr_se se)))
- <:str_item< $exp:e$ >>))))
- ((module_binding_se se) (module_expr_se se))
- (expr_se
- (lambda_match
- ((Sacc loc se1 se2)
- (let ((e1 (expr_se se1)))
- (match se2
- ((Slist loc [se2])
- (let ((e2 (expr_se se2))) <:expr< $e1$ .[ $e2$ ] >>))
- ((Sexpr loc [se2])
- (let ((e2 (expr_se se2))) <:expr< $e1$ .( $e2$ ) >>))
- (_ (let ((e2 (expr_se se2))) <:expr< $e1$ . $e2$ >>)))))
- ((Slid loc s) (lident_expr loc s))
- ((Suid loc s) <:expr< $uid:(Pcaml.rename_id.val s)$ >>)
- ((Sint loc s) <:expr< $int:s$ >>)
- ((Sfloat loc s) <:expr< $flo:s$ >>)
- ((Schar loc s) <:expr< $chr:s$ >>)
- ((Sstring loc s) <:expr< $str:s$ >>)
- ((Stid loc s) <:expr< ~ $(Pcaml.rename_id.val s)$ >>)
- ((Sqid loc s) <:expr< ? $(Pcaml.rename_id.val s)$ >>)
- ((Sexpr loc []) <:expr< () >>)
- ((when (Sexpr loc [(Slid _ s) e1 . (as [_ . _] sel)])
- (List.mem s assoc_left_parsed_op_list))
- (letrec
- (((loop e1)
- (lambda_match
- ([] e1)
- ([e2 . el] (loop (op_apply loc e1 e2 s) el)))))
- (loop (expr_se e1) (List.map expr_se sel))))
- ((when (Sexpr loc [(Slid _ s) . (as [_ _ . _] sel)])
- (List.mem s assoc_right_parsed_op_list))
- (letrec
- ((loop
- (lambda_match
- ([]
- (assert False))
- ([e1] e1)
- ([e1 . el] (let ((e2 (loop el))) (op_apply loc e1 e2 s))))))
- (loop (List.map expr_se sel))))
- ((when (Sexpr loc [(Slid _ s) . (as [_ _ . _] sel)])
- (List.mem s and_by_couple_op_list))
- (letrec
- ((loop
- (lambda_match
- ((or [] [_]) (assert False))
- ([e1 e2] <:expr< $lid:s$ $e1$ $e2$ >>)
- ([e1 . (as [e2 _ . _] el)]
- (let* ((a1 (op_apply loc e1 e2 s))
- (a2 (loop el)))
- <:expr< $a1$ && $a2$ >>)))))
- (loop (List.map expr_se sel))))
- ((Sexpr loc [(Stid _ s) se])
- (let ((e (expr_se se))) <:expr< ~ $s$ : $e$ >>))
- ((Sexpr loc [(Slid _ "-") se])
- (let ((e (expr_se se))) <:expr< - $e$ >>))
- ((Sexpr loc [(Slid _ "if") se se1])
- (let* ((e (expr_se se))
- (e1 (expr_se se1)))
- <:expr< if $e$ then $e1$ else () >>))
- ((Sexpr loc [(Slid _ "if") se se1 se2])
- (let* ((e (expr_se se))
- (e1 (expr_se se1))
- (e2 (expr_se se2)))
- <:expr< if $e$ then $e1$ else $e2$ >>))
- ((Sexpr loc [(Slid _ "cond") . sel])
- (letrec
- ((loop
- (lambda_match
- ([(Sexpr loc [(Slid _ "else") . sel])] (begin_se loc sel))
- ([(Sexpr loc [se1 . sel1]) . sel]
- (let* ((e1 (expr_se se1))
- (e2 (begin_se loc sel1))
- (e3 (loop sel)))
- <:expr< if $e1$ then $e2$ else $e3$ >>))
- ([] <:expr< () >>)
- ([se . _] (error se "cond clause")))))
- (loop sel)))
- ((Sexpr loc [(Slid _ "while") se . sel])
- (let* ((e (expr_se se))
- (el (List.map expr_se sel)))
- <:expr< while $e$ do { $list:el$ } >>))
- ((Sexpr loc [(Slid _ "for") (Slid _ i) se1 se2 . sel])
- (let* ((i (Pcaml.rename_id.val i))
- (e1 (expr_se se1))
- (e2 (expr_se se2))
- (el (List.map expr_se sel)))
- <:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >>))
- ((Sexpr loc [(Slid loc1 "lambda")]) <:expr< fun [] >>)
- ((Sexpr loc [(Slid loc1 "lambda") sep . sel])
- (let ((e (begin_se loc1 sel)))
- (match (ipatt_opt_se sep)
- ((Left p) <:expr< fun $p$ -> $e$ >>)
- ((Right (values se sel))
- (List.fold_right
- (lambda (se e)
- (let ((p (ipatt_se se))) <:expr< fun $p$ -> $e$ >>))
- [se . sel] e)))))
- ((Sexpr loc [(Slid _ "lambda_match") . sel])
- (let ((pel (List.map (match_case loc) sel)))
- <:expr< fun [ $list:pel$ ] >>))
- ((Sexpr loc [(Slid _ (as (or "let" "letrec") r)) . sel])
- (match sel
- ([(Sexpr _ sel1) . sel2]
- (let* ((r (= r "letrec"))
- (lbs (List.map let_binding_se sel1))
- (e (begin_se loc sel2)))
- <:expr< let $opt:r$ $list:lbs$ in $e$ >>))
- ([(Slid _ n) (Sexpr _ sl) . sel]
- (let* ((n (Pcaml.rename_id.val n))
- ((values pl el)
- (List.fold_right
- (lambda (se (values pl el))
- (match se
- ((Sexpr _ [se1 se2])
- (values [(patt_se se1) . pl]
- [(expr_se se2) . el]))
- (se (error se "named let"))))
- sl (values [] [])))
- (e1
- (List.fold_right
- (lambda (p e) <:expr< fun $p$ -> $e$ >>)
- pl (begin_se loc sel)))
- (e2
- (List.fold_left
- (lambda (e1 e2) <:expr< $e1$ $e2$ >>)
- <:expr< $lid:n$ >> el)))
- <:expr< let rec $lid:n$ = $e1$ in $e2$ >>))
- ([se . _] (error se "let_binding"))
- (_ (error_loc loc "let_binding"))))
- ((Sexpr loc [(Slid _ "let*") . sel])
- (match sel
- ([(Sexpr _ sel1) . sel2]
- (List.fold_right
- (lambda (se ek)
- (let (((values p e) (let_binding_se se)))
- <:expr< let $p$ = $e$ in $ek$ >>))
- sel1 (begin_se loc sel2)))
- ([se . _] (error se "let_binding"))
- (_ (error_loc loc "let_binding"))))
- ((Sexpr loc [(Slid _ "match") se . sel])
- (let* ((e (expr_se se))
- (pel (List.map (match_case loc) sel)))
- <:expr< match $e$ with [ $list:pel$ ] >>))
- ((Sexpr loc [(Slid _ "parser") . sel])
- (let ((e
- (match sel
- ([(as (Slid _ _) se) . sel]
- (let* ((p (patt_se se))
- (pc (parser_cases_se loc sel)))
- <:expr< let $p$ = Stream.count $lid:strm_n$ in $pc$ >>))
- (_ (parser_cases_se loc sel)))))
- <:expr< fun ($lid:strm_n$ : Stream.t _) -> $e$ >>))
- ((Sexpr loc [(Slid _ "match_with_parser") se . sel])
- (let* ((me (expr_se se))
- ((values bpo sel)
- (match sel
- ([(as (Slid _ _) se) . sel] (values (Some (patt_se se)) sel))
- (_ (values None sel))))
- (pc (parser_cases_se loc sel))
- (e
- (match bpo
- ((Some bp)
- <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>)
- (None pc))))
- (match me
- ((when <:expr< $lid:x$ >> (= x strm_n)) e)
- (_ <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >>))))
- ((Sexpr loc [(Slid _ "try") se . sel])
- (let* ((e (expr_se se))
- (pel (List.map (match_case loc) sel)))
- <:expr< try $e$ with [ $list:pel$ ] >>))
- ((Sexpr loc [(Slid _ "begin") . sel])
- (let ((el (List.map expr_se sel))) <:expr< do { $list:el$ } >>))
- ((Sexpr loc [(Slid _ ":=") se1 se2])
- (let* ((e1 (expr_se se1))
- (e2 (expr_se se2)))
- <:expr< $e1$ := $e2$ >>))
- ((Sexpr loc [(Slid _ "values") . sel])
- (let ((el (List.map expr_se sel))) <:expr< ( $list:el$ ) >>))
- ((Srec loc [(Slid _ "with") se . sel])
- (let* ((e (expr_se se))
- (lel (List.map (label_expr_se loc) sel)))
- <:expr< { ($e$) with $list:lel$ } >>))
- ((Srec loc sel)
- (let ((lel (List.map (label_expr_se loc) sel)))
- <:expr< { $list:lel$ } >>))
- ((Sexpr loc [(Slid _ ":") se1 se2])
- (let* ((e (expr_se se1)) (t (ctyp_se se2))) <:expr< ( $e$ : $t$ ) >>))
- ((Sexpr loc [se]) (let ((e (expr_se se))) <:expr< $e$ () >>))
- ((Sexpr loc [(Slid _ "assert") se])
- (let ((e (expr_se se))) <:expr< assert $e$ >>))
- ((Sexpr loc [(Slid _ "lazy") se])
- (let ((e (expr_se se))) <:expr< lazy $e$ >>))
- ((Sexpr loc [se . sel])
- (List.fold_left
- (lambda (e se) (let ((e1 (expr_se se))) <:expr< $e$ $e1$ >>))
- (expr_se se) sel))
- ((Slist loc sel)
- (letrec ((loop
- (lambda_match
- ([] <:expr< [] >>)
- ([se1 (Slid _ ".") se2]
- (let* ((e (expr_se se1))
- (el (expr_se se2)))
- <:expr< [$e$ :: $el$] >>))
- ([se . sel]
- (let* ((e (expr_se se))
- (el (loop sel)))
- <:expr< [$e$ :: $el$] >>)))))
- (loop sel)))
- ((Squot loc typ txt)
- (Pcaml.handle_expr_quotation loc (values typ txt)))))
- ((begin_se loc)
- (lambda_match
- ([] <:expr< () >>)
- ([se] (expr_se se))
- ((sel)
- (let* ((el (List.map expr_se sel))
- (loc (values (fst (loc_of_sexpr (List.hd sel))) (snd loc))))
- <:expr< do { $list:el$ } >>))))
- (let_binding_se
- (lambda_match
- ((Sexpr loc [se . sel])
- (let ((e (begin_se loc sel)))
- (match (ipatt_opt_se se)
- ((Left p) (values p e))
- ((Right _) (fun_binding_se se e)))))
- (se (error se "let_binding"))))
- ((fun_binding_se se e)
- (match se
- ((Sexpr _ [(Slid _ "values") . _]) (values (ipatt_se se) e))
- ((Sexpr _ [(Slid loc s) . sel])
- (let* ((s (Pcaml.rename_id.val s))
- (e
- (List.fold_right
- (lambda (se e)
- (let* ((loc
- (values (fst (loc_of_sexpr se))
- (snd (MLast.loc_of_expr e))))
- (p (ipatt_se se)))
- <:expr< fun $p$ -> $e$ >>))
- sel e))
- (p <:patt< $lid:s$ >>))
- (values p e)))
- ((_) (values (ipatt_se se) e))))
- ((match_case loc)
- (lambda_match
- ((Sexpr loc [(Sexpr _ [(Slid _ "when") se sew]) . sel])
- (values (patt_se se) (Some (expr_se sew)) (begin_se loc sel)))
- ((Sexpr loc [se . sel])
- (values (patt_se se) None (begin_se loc sel)))
- (se (error se "match_case"))))
- ((label_expr_se loc)
- (lambda_match
- ((Sexpr _ [se1 se2]) (values (patt_se se1) (expr_se se2)))
- (se (error se "label_expr"))))
- ((label_patt_se loc)
- (lambda_match
- ((Sexpr _ [se1 se2]) (values (patt_se se1) (patt_se se2)))
- (se (error se "label_patt"))))
- ((parser_cases_se loc)
- (lambda_match
- ([] <:expr< raise Stream.Failure >>)
- ([(Sexpr loc [(Sexpr _ spsel) . act]) . sel]
- (let* ((ekont (lambda _ (parser_cases_se loc sel)))
- (act (match act
- ([se] (expr_se se))
- ([sep se]
- (let* ((p (patt_se sep))
- (e (expr_se se)))
- <:expr< let $p$ = Stream.count $lid:strm_n$ in $e$ >>))
- (_ (error_loc loc "parser_case")))))
- (stream_pattern_se loc act ekont spsel)))
- ([se . _]
- (error se "parser_case"))))
- ((stream_pattern_se loc act ekont)
- (lambda_match
- ([] act)
- ([se . sel]
- (let* ((ckont (lambda err <:expr< raise (Stream.Error $err$) >>))
- (skont (stream_pattern_se loc act ckont sel)))
- (stream_pattern_component skont ekont <:expr< "" >> se)))))
- ((stream_pattern_component skont ekont err)
- (lambda_match
- ((Sexpr loc [(Slid _ "`") se . wol])
- (let* ((wo (match wol
- ([se] (Some (expr_se se)))
- ([] None)
- (_ (error_loc loc "stream_pattern_component"))))
- (e (peek_fun loc))
- (p (patt_se se))
- (j (junk_fun loc))
- (k (ekont err)))
- <:expr< match $e$ $lid:strm_n$ with
- [ Some $p$ $when:wo$ -> do { $j$ $lid:strm_n$ ; $skont$ }
- | _ -> $k$ ] >>))
- ((Sexpr loc [se1 se2])
- (let* ((p (patt_se se1))
- (e (let ((e (expr_se se2)))
- <:expr< try Some ($e$ $lid:strm_n$) with [ Stream.Failure -> None ] >>))
- (k (ekont err)))
- <:expr< match $e$ with [ Some $p$ -> $skont$ | _ -> $k$ ] >>))
- ((Sexpr loc [(Slid _ "?") se1 se2])
- (stream_pattern_component skont ekont (expr_se se2) se1))
- ((Slid loc s)
- (let ((s (Pcaml.rename_id.val s)))
- <:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >>))
- (se
- (error se "stream_pattern_component"))))
- (patt_se
- (lambda_match
- ((Sacc loc se1 se2)
- (let* ((p1 (patt_se se1)) (p2 (patt_se se2))) <:patt< $p1$ . $p2$ >>))
- ((Slid loc "_") <:patt< _ >>)
- ((Slid loc s) <:patt< $lid:(Pcaml.rename_id.val s)$ >>)
- ((Suid loc s) <:patt< $uid:(Pcaml.rename_id.val s)$ >>)
- ((Sint loc s) <:patt< $int:s$ >>)
- ((Sfloat loc s) <:patt< $flo:s$ >>)
- ((Schar loc s) <:patt< $chr:s$ >>)
- ((Sstring loc s) <:patt< $str:s$ >>)
- ((Stid loc _) (error_loc loc "patt"))
- ((Sqid loc _) (error_loc loc "patt"))
- ((Srec loc sel)
- (let ((lpl (List.map (label_patt_se loc) sel)))
- <:patt< { $list:lpl$ } >>))
- ((Sexpr loc [(Slid _ ":") se1 se2])
- (let* ((p (patt_se se1)) (t (ctyp_se se2))) <:patt< ($p$ : $t$) >>))
- ((Sexpr loc [(Slid _ "or") se . sel])
- (List.fold_left
- (lambda (p se) (let ((p1 (patt_se se))) <:patt< $p$ | $p1$ >>))
- (patt_se se) sel))
- ((Sexpr loc [(Slid _ "range") se1 se2])
- (let* ((p1 (patt_se se1)) (p2 (patt_se se2))) <:patt< $p1$ .. $p2$ >>))
- ((Sexpr loc [(Slid _ "values") . sel])
- (let ((pl (List.map patt_se sel))) <:patt< ( $list:pl$ ) >>))
- ((Sexpr loc [(Slid _ "as") se1 se2])
- (let* ((p1 (patt_se se1))
- (p2 (patt_se se2)))
- <:patt< ($p1$ as $p2$) >>))
- ((Sexpr loc [se . sel])
- (List.fold_left
- (lambda (p se) (let ((p1 (patt_se se))) <:patt< $p$ $p1$ >>))
- (patt_se se) sel))
- ((Sexpr loc []) <:patt< () >>)
- ((Slist loc sel)
- (letrec ((loop
- (lambda_match
- ([] <:patt< [] >>)
- ([se1 (Slid _ ".") se2]
- (let* ((p (patt_se se1))
- (pl (patt_se se2)))
- <:patt< [$p$ :: $pl$] >>))
- ([se . sel]
- (let* ((p (patt_se se))
- (pl (loop sel)))
- <:patt< [$p$ :: $pl$] >>)))))
- (loop sel)))
- ((Squot loc typ txt)
- (Pcaml.handle_patt_quotation loc (values typ txt)))))
- ((ipatt_se se)
- (match (ipatt_opt_se se)
- ((Left p) p)
- ((Right (values se _)) (error se "ipatt"))))
- (ipatt_opt_se
- (lambda_match
- ((Slid loc "_") (Left <:patt< _ >>))
- ((Slid loc s) (Left <:patt< $lid:(Pcaml.rename_id.val s)$ >>))
- ((Stid loc s) (Left <:patt< ~ $(Pcaml.rename_id.val s)$ >>))
- ((Sqid loc s) (Left <:patt< ? $(Pcaml.rename_id.val s)$ >>))
- ((Sexpr loc [(Sqid _ s) se])
- (let* ((s (Pcaml.rename_id.val s))
- (e (expr_se se)))
- (Left <:patt< ? ( $lid:s$ = $e$ ) >>)))
- ((Sexpr loc [(Slid _ ":") se1 se2])
- (let* ((p (ipatt_se se1)) (t (ctyp_se se2)))
- (Left <:patt< ($p$ : $t$) >>)))
- ((Sexpr loc [(Slid _ "values") . sel])
- (let ((pl (List.map ipatt_se sel))) (Left <:patt< ( $list:pl$ ) >>)))
- ((Sexpr loc []) (Left <:patt< () >>))
- ((Sexpr loc [se . sel]) (Right (values se sel)))
- (se (error se "ipatt"))))
- (type_declaration_list_se
- (lambda_match
- ([se1 se2 . sel]
- (let (((values n1 loc1 tpl)
- (match se1
- ((Sexpr _ [(Slid loc n) . sel])
- (values n loc (List.map type_parameter_se sel)))
- ((Slid loc n)
- (values n loc []))
- ((se)
- (error se "type declaration")))))
- [(values (values loc1 (Pcaml.rename_id.val n1)) tpl (ctyp_se se2) []) .
- (type_declaration_list_se sel)]))
- ([] [])
- ([se . _] (error se "type_declaration"))))
- (type_parameter_se
- (lambda_match
- ((when (Slid _ s) (and (>= (String.length s) 2) (= s.[0] ''')))
- (values (String.sub s 1 (- (String.length s) 1)) (values False False)))
- (se
- (error se "type_parameter"))))
- (ctyp_se
- (lambda_match
- ((Sexpr loc [(Slid _ "sum") . sel])
- (let ((cdl (List.map constructor_declaration_se sel)))
- <:ctyp< [ $list:cdl$ ] >>))
- ((Srec loc sel)
- (let ((ldl (List.map label_declaration_se sel)))
- <:ctyp< { $list:ldl$ } >>))
- ((Sexpr loc [(Slid _ "->") . (as [_ _ . _] sel)])
- (letrec
- ((loop
- (lambda_match
- ([] (assert False))
- ([se] (ctyp_se se))
- ([se . sel]
- (let* ((t1 (ctyp_se se))
- (loc (values (fst (loc_of_sexpr se)) (snd loc)))
- (t2 (loop sel)))
- <:ctyp< $t1$ -> $t2$ >>)))))
- (loop sel)))
- ((Sexpr loc [(Slid _ "*") . sel])
- (let ((tl (List.map ctyp_se sel))) <:ctyp< ($list:tl$) >>))
- ((Sexpr loc [se . sel])
- (List.fold_left
- (lambda (t se) (let ((t2 (ctyp_se se))) <:ctyp< $t$ $t2$ >>))
- (ctyp_se se) sel))
- ((Sacc loc se1 se2)
- (let* ((t1 (ctyp_se se1)) (t2 (ctyp_se se2))) <:ctyp< $t1$ . $t2$ >>))
- ((Slid loc "_") <:ctyp< _ >>)
- ((Slid loc s)
- (if (= s.[0] ''')
- (let ((s (String.sub s 1 (- (String.length s) 1))))
- <:ctyp< '$s$ >>)
- <:ctyp< $lid:(Pcaml.rename_id.val s)$ >>))
- ((Suid loc s) <:ctyp< $uid:(Pcaml.rename_id.val s)$ >>)
- (se (error se "ctyp"))))
- (constructor_declaration_se
- (lambda_match
- ((Sexpr loc [(Suid _ ci) . sel])
- (values loc (Pcaml.rename_id.val ci) (List.map ctyp_se sel)))
- (se
- (error se "constructor_declaration"))))
- (label_declaration_se
- (lambda_match
- ((Sexpr loc [(Slid _ lab) (Slid _ "mutable") se])
- (values loc (Pcaml.rename_id.val lab) True (ctyp_se se)))
- ((Sexpr loc [(Slid _ lab) se])
- (values loc (Pcaml.rename_id.val lab) False (ctyp_se se)))
- (se
- (error se "label_declaration")))))
-
-(define directive_se
- (lambda_match
- ((Sexpr _ [(Slid _ s)]) (values s None))
- ((Sexpr _ [(Slid _ s) se]) (let ((e (expr_se se))) (values s (Some e))))
- (se (error se "directive"))))
-
-; Parser
-
-(:= Pcaml.syntax_name.val "Scheme")
-(:= Pcaml.no_constructors_arity.val False)
-
-(begin
- (Grammar.Unsafe.gram_reinit gram (lexer_gmake ()))
- (Grammar.Unsafe.clear_entry interf)
- (Grammar.Unsafe.clear_entry implem)
- (Grammar.Unsafe.clear_entry top_phrase)
- (Grammar.Unsafe.clear_entry use_file)
- (Grammar.Unsafe.clear_entry module_type)
- (Grammar.Unsafe.clear_entry module_expr)
- (Grammar.Unsafe.clear_entry sig_item)
- (Grammar.Unsafe.clear_entry str_item)
- (Grammar.Unsafe.clear_entry expr)
- (Grammar.Unsafe.clear_entry patt)
- (Grammar.Unsafe.clear_entry ctyp)
- (Grammar.Unsafe.clear_entry let_binding)
- (Grammar.Unsafe.clear_entry type_declaration)
- (Grammar.Unsafe.clear_entry class_type)
- (Grammar.Unsafe.clear_entry class_expr)
- (Grammar.Unsafe.clear_entry class_sig_item)
- (Grammar.Unsafe.clear_entry class_str_item))
-
-(:= Pcaml.parse_interf.val (Grammar.Entry.parse interf))
-(:= Pcaml.parse_implem.val (Grammar.Entry.parse implem))
-
-(define sexpr (Grammar.Entry.create gram "sexpr"))
-
-(definerec leftify
- (lambda_match
- ((Sacc loc1 se1 se2)
- (match (leftify se2)
- ((Sacc loc2 se2 se3) (Sacc loc1 (Sacc loc2 se1 se2) se3))
- (se2 (Sacc loc1 se1 se2))))
- (x x)))
-
-EXTEND
- GLOBAL : implem interf top_phrase use_file str_item sig_item expr
- patt sexpr /
- implem :
- [ [ "#" / se = sexpr ->
- (let (((values n dp) (directive_se se)))
- (values [(values <:str_item< # $n$ $opt:dp$ >> loc)] True))
- | si = str_item / x = SELF ->
- (let* (((values sil stopped) x)
- (loc (MLast.loc_of_str_item si)))
- (values [(values si loc) . sil] stopped))
- | EOI -> (values [] False) ] ]
- /
- interf :
- [ [ "#" / se = sexpr ->
- (let (((values n dp) (directive_se se)))
- (values [(values <:sig_item< # $n$ $opt:dp$ >> loc)] True))
- | si = sig_item / x = SELF ->
- (let* (((values sil stopped) x)
- (loc (MLast.loc_of_sig_item si)))
- (values [(values si loc) . sil] stopped))
- | EOI -> (values [] False) ] ]
- /
- top_phrase :
- [ [ "#" / se = sexpr ->
- (let (((values n dp) (directive_se se)))
- (Some <:str_item< # $n$ $opt:dp$ >>))
- | se = sexpr -> (Some (str_item_se se))
- | EOI -> None ] ]
- /
- use_file :
- [ [ "#" / se = sexpr ->
- (let (((values n dp) (directive_se se)))
- (values [<:str_item< # $n$ $opt:dp$ >>] True))
- | si = str_item / x = SELF ->
- (let (((values sil stopped) x)) (values [si . sil] stopped))
- | EOI -> (values [] False) ] ]
- /
- str_item :
- [ [ se = sexpr -> (str_item_se se)
- | e = expr -> <:str_item< $exp:e$ >> ] ]
- /
- sig_item :
- [ [ se = sexpr -> (sig_item_se se) ] ]
- /
- expr :
- [ "top"
- [ se = sexpr -> (expr_se se) ] ]
- /
- patt :
- [ [ se = sexpr -> (patt_se se) ] ]
- /
- sexpr :
- [ [ se1 = sexpr_dot / se2 = sexpr -> (leftify (Sacc loc se1 se2)) ]
- | [ "(" / sl = LIST0 sexpr / ")" -> (Sexpr loc sl)
- | "(" / sl = LIST0 sexpr / ")." / se = sexpr ->
- (leftify (Sacc loc (Sexpr loc sl) se))
- | "[" / sl = LIST0 sexpr / "]" -> (Slist loc sl)
- | "{" / sl = LIST0 sexpr / "}" -> (Srec loc sl)
- | a = pa_extend_keyword -> (Slid loc a)
- | s = LIDENT -> (Slid loc s)
- | s = UIDENT -> (Suid loc s)
- | s = TILDEIDENT -> (Stid loc s)
- | s = QUESTIONIDENT -> (Sqid loc s)
- | s = INT -> (Sint loc s)
- | s = FLOAT -> (Sfloat loc s)
- | s = CHAR -> (Schar loc s)
- | s = STRING -> (Sstring loc s)
- | s = QUOT ->
- (let* ((i (String.index s ':'))
- (typ (String.sub s 0 i))
- (txt (String.sub s (+ i 1) (- (- (String.length s) i) 1))))
- (Squot loc typ txt)) ] ]
- /
- sexpr_dot :
- [ [ s = LIDENTDOT -> (Slid loc s)
- | s = UIDENTDOT -> (Suid loc s) ] ]
- /
- pa_extend_keyword :
- [ [ "_" -> "_"
- | "," -> ","
- | "=" -> "="
- | ":" -> ":"
- | "." -> "."
- | "/" -> "/" ] ]
- /
-END
diff --git a/camlp4/etc/pa_schemer.ml b/camlp4/etc/pa_schemer.ml
deleted file mode 100644
index a7d64ce4a5..0000000000
--- a/camlp4/etc/pa_schemer.ml
+++ /dev/null
@@ -1,1067 +0,0 @@
-(* camlp4 pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *)
-(* File generated by pretty print; do not edit! *)
-
-open Pcaml;
-open Stdpp;
-
-type choice 'a 'b =
- [ Left of 'a
- | Right of 'b ]
-;
-
-(* Buffer *)
-
-module Buff =
- struct
- value buff = ref (String.create 80);
- value store len x =
- do {
- if len >= String.length buff.val then
- buff.val := buff.val ^ String.create (String.length buff.val)
- else ();
- buff.val.[len] := x;
- succ len
- }
- ;
- value get len = String.sub buff.val 0 len;
- end
-;
-
-(* Lexer *)
-
-value rec skip_to_eol =
- parser
- [ [: `'\n' | '\r' :] -> ()
- | [: `_; s :] -> skip_to_eol s ]
-;
-
-value no_ident = ['('; ')'; '['; ']'; '{'; '}'; ' '; '\t'; '\n'; '\r'; ';'];
-
-value rec ident len =
- parser
- [ [: `'.' :] -> (Buff.get len, True)
- | [: `x when not (List.mem x no_ident); s :] -> ident (Buff.store len x) s
- | [: :] -> (Buff.get len, False) ]
-;
-
-value identifier kwt (s, dot) =
- let con =
- try do { (Hashtbl.find kwt s : unit); "" } with
- [ Not_found ->
- match s.[0] with
- [ 'A'..'Z' -> if dot then "UIDENTDOT" else "UIDENT"
- | _ -> if dot then "LIDENTDOT" else "LIDENT" ] ]
- in
- (con, s)
-;
-
-value rec string len =
- parser
- [ [: `'"' :] -> Buff.get len
- | [: `'\\'; `c; s :] -> string (Buff.store (Buff.store len '\\') c) s
- | [: `x; s :] -> string (Buff.store len x) s ]
-;
-
-value rec end_exponent_part_under len =
- parser
- [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (Buff.store len c) s
- | [: :] -> ("FLOAT", Buff.get len) ]
-;
-
-value end_exponent_part len =
- parser
- [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (Buff.store len c) s
- | [: :] -> raise (Stream.Error "ill-formed floating-point constant") ]
-;
-
-value exponent_part len =
- parser
- [ [: `('+' | '-' as c); s :] -> end_exponent_part (Buff.store len c) s
- | [: a = end_exponent_part len :] -> a ]
-;
-
-value rec decimal_part len =
- parser
- [ [: `('0'..'9' as c); s :] -> decimal_part (Buff.store len c) s
- | [: `'e' | 'E'; s :] -> exponent_part (Buff.store len 'E') s
- | [: :] -> ("FLOAT", Buff.get len) ]
-;
-
-value rec number len =
- parser
- [ [: `('0'..'9' as c); s :] -> number (Buff.store len c) s
- | [: `'.'; s :] -> decimal_part (Buff.store len '.') s
- | [: `'e' | 'E'; s :] -> exponent_part (Buff.store len 'E') s
- | [: :] -> ("INT", Buff.get len) ]
-;
-
-value binary = parser [: `('0'..'1' as c) :] -> c;
-
-value octal = parser [: `('0'..'7' as c) :] -> c;
-
-value hexa = parser [: `('0'..'9' | 'a'..'f' | 'A'..'F' as c) :] -> c;
-
-value rec digits_under kind len =
- parser
- [ [: d = kind; s :] -> digits_under kind (Buff.store len d) s
- | [: :] -> Buff.get len ]
-;
-
-value digits kind bp len =
- parser
- [ [: d = kind; s :] -> ("INT", digits_under kind (Buff.store len d) s)
- | [: s :] ep ->
- raise_with_loc (bp, ep) (Failure "ill-formed integer constant") ]
-;
-
-value base_number kwt bp len =
- parser
- [ [: `'b' | 'B'; s :] -> digits binary bp (Buff.store len 'b') s
- | [: `'o' | 'O'; s :] -> digits octal bp (Buff.store len 'o') s
- | [: `'x' | 'X'; s :] -> digits hexa bp (Buff.store len 'x') s
- | [: id = ident (Buff.store 0 '#') :] -> identifier kwt id ]
-;
-
-value rec operator len =
- parser
- [ [: `'.' :] -> Buff.get (Buff.store len '.')
- | [: :] -> Buff.get len ]
-;
-
-value char_or_quote_id x =
- parser
- [ [: `''' :] -> ("CHAR", String.make 1 x)
- | [: s :] ep ->
- if List.mem x no_ident then
- Stdpp.raise_with_loc (ep - 2, ep - 1) (Stream.Error "bad quote")
- else
- let len = Buff.store (Buff.store 0 ''') x in
- let (s, dot) = ident len s in
- (if dot then "LIDENTDOT" else "LIDENT", s) ]
-;
-
-value rec char len =
- parser
- [ [: `''' :] -> len
- | [: `x; s :] -> char (Buff.store len x) s ]
-;
-
-value quote =
- parser
- [ [: `'\\'; len = char (Buff.store 0 '\\') :] -> ("CHAR", Buff.get len)
- | [: `x; s :] -> char_or_quote_id x s ]
-;
-
-(* The system with LIDENTDOT and UIDENTDOT is not great (it would be *)
-(* better to have a token DOT (actually SPACEDOT and DOT)) but it is *)
-(* the only way (that I have found) to have a good behaviour in the *)
-(* toplevel (not expecting tokens after a phrase). Drawbacks: 1/ to be *)
-(* complete, we should have STRINGDOT, RIGHTPARENDOT, and so on 2/ the *)
-(* parser rule with dot is right associative and we have to reverse *)
-(* the resulting tree (using the function leftify). *)
-(* This is a complicated issue: the behaviour of the OCaml toplevel *)
-(* is strange, anyway. For example, even without Camlp4, The OCaml *)
-(* toplevel accepts that: *)
-(* # let x = 32;; foo bar match let ) *)
-
-value rec lexer kwt = parser [: t = lexer0 kwt; _ = no_dot :] -> t
-and no_dot =
- parser
- [ [: `'.' :] ep ->
- Stdpp.raise_with_loc (ep - 1, ep) (Stream.Error "bad dot")
- | [: :] -> () ]
-and lexer0 kwt =
- parser bp
- [ [: `'\t' | '\n' | '\r'; s :] -> lexer0 kwt s
- | [: `' '; s :] -> after_space kwt s
- | [: `';'; _ = skip_to_eol; s :] -> lexer kwt s
- | [: `'(' :] -> (("", "("), (bp, bp + 1))
- | [: `')'; s :] ep -> (("", rparen s), (bp, ep))
- | [: `'[' :] -> (("", "["), (bp, bp + 1))
- | [: `']' :] -> (("", "]"), (bp, bp + 1))
- | [: `'{' :] -> (("", "{"), (bp, bp + 1))
- | [: `'}' :] -> (("", "}"), (bp, bp + 1))
- | [: `'"'; s = string 0 :] ep -> (("STRING", s), (bp, ep))
- | [: `'''; tok = quote :] ep -> (tok, (bp, ep))
- | [: `'<'; tok = less kwt :] ep -> (tok, (bp, ep))
- | [: `'-'; tok = minus kwt :] ep -> (tok, (bp, ep))
- | [: `'~'; tok = tilde :] ep -> (tok, (bp, ep))
- | [: `'?'; tok = question :] ep -> (tok, (bp, ep))
- | [: `'#'; tok = base_number kwt bp (Buff.store 0 '0') :] ep ->
- (tok, (bp, ep))
- | [: `('0'..'9' as c); tok = number (Buff.store 0 c) :] ep ->
- (tok, (bp, ep))
- | [: `('+' | '*' | '/' as c); id = operator (Buff.store 0 c) :] ep ->
- (identifier kwt (id, False), (bp, ep))
- | [: `x; id = ident (Buff.store 0 x) :] ep -> (identifier kwt id, (bp, ep))
- | [: :] -> (("EOI", ""), (bp, bp + 1)) ]
-and rparen =
- parser
- [ [: `'.' :] -> ")."
- | [: ___ :] -> ")" ]
-and after_space kwt =
- parser
- [ [: `'.' :] ep -> (("", "."), (ep - 1, ep))
- | [: x = lexer0 kwt :] -> x ]
-and tilde =
- parser
- [ [: `('a'..'z' as c); (s, dot) = ident (Buff.store 0 c) :] ->
- ("TILDEIDENT", s)
- | [: :] -> ("LIDENT", "~") ]
-and question =
- parser
- [ [: `('a'..'z' as c); (s, dot) = ident (Buff.store 0 c) :] ->
- ("QUESTIONIDENT", s)
- | [: :] -> ("LIDENT", "?") ]
-and minus kwt =
- parser
- [ [: `'.' :] -> identifier kwt ("-.", False)
- | [: `('0'..'9' as c); n = number (Buff.store (Buff.store 0 '-') c) :] ep ->
- n
- | [: id = ident (Buff.store 0 '-') :] -> identifier kwt id ]
-and less kwt =
- parser
- [ [: `':'; lab = label 0; `'<' ? "'<' expected"; q = quotation 0 :] ->
- ("QUOT", lab ^ ":" ^ q)
- | [: id = ident (Buff.store 0 '<') :] -> identifier kwt id ]
-and label len =
- parser
- [ [: `('a'..'z' | 'A'..'Z' | '_' as c); s :] -> label (Buff.store len c) s
- | [: :] -> Buff.get len ]
-and quotation len =
- parser
- [ [: `'>'; s :] -> quotation_greater len s
- | [: `x; s :] -> quotation (Buff.store len x) s
- | [: :] -> failwith "quotation not terminated" ]
-and quotation_greater len =
- parser
- [ [: `'>' :] -> Buff.get len
- | [: a = quotation (Buff.store len '>') :] -> a ]
-;
-
-value lexer_using kwt (con, prm) =
- match con with
- [ "CHAR" | "EOI" | "INT" | "FLOAT" | "LIDENT" | "LIDENTDOT" |
- "QUESTIONIDENT" | "QUOT" | "STRING" | "TILDEIDENT" | "UIDENT" |
- "UIDENTDOT" ->
- ()
- | "ANTIQUOT" -> ()
- | "" ->
- try Hashtbl.find kwt prm with [ Not_found -> Hashtbl.add kwt prm () ]
- | _ ->
- raise
- (Token.Error
- ("the constructor \"" ^ con ^ "\" is not recognized by Plexer")) ]
-;
-
-value lexer_text (con, prm) =
- if con = "" then "'" ^ prm ^ "'"
- else if prm = "" then con
- else con ^ " \"" ^ prm ^ "\""
-;
-
-value lexer_gmake () =
- let kwt = Hashtbl.create 89 in
- {Token.tok_func = Token.lexer_func_of_parser (lexer kwt);
- Token.tok_using = lexer_using kwt; Token.tok_removing = fun [];
- Token.tok_match = Token.default_match; Token.tok_text = lexer_text;
- Token.tok_comm = None}
-;
-
-(* Building AST *)
-
-type sexpr =
- [ Sacc of MLast.loc and sexpr and sexpr
- | Schar of MLast.loc and string
- | Sexpr of MLast.loc and list sexpr
- | Sint of MLast.loc and string
- | Sfloat of MLast.loc and string
- | Slid of MLast.loc and string
- | Slist of MLast.loc and list sexpr
- | Sqid of MLast.loc and string
- | Squot of MLast.loc and string and string
- | Srec of MLast.loc and list sexpr
- | Sstring of MLast.loc and string
- | Stid of MLast.loc and string
- | Suid of MLast.loc and string ]
-;
-
-value loc_of_sexpr =
- fun [
- Sacc loc _ _ | Schar loc _ | Sexpr loc _ | Sint loc _ | Sfloat loc _ |
- Slid loc _ | Slist loc _ | Sqid loc _ | Squot loc _ _ | Srec loc _ |
- Sstring loc _ | Stid loc _ | Suid loc _ ->
- loc ]
-;
-value error_loc loc err =
- raise_with_loc loc (Stream.Error (err ^ " expected"))
-;
-value error se err = error_loc (loc_of_sexpr se) err;
-
-value strm_n = "strm__";
-value peek_fun loc = <:expr< Stream.peek >>;
-value junk_fun loc = <:expr< Stream.junk >>;
-
-value assoc_left_parsed_op_list =
- ["+"; "*"; "+."; "*."; "land"; "lor"; "lxor"]
-;
-value assoc_right_parsed_op_list = ["and"; "or"; "^"; "@"];
-value and_by_couple_op_list = ["="; "<>"; "<"; ">"; "<="; ">="; "=="; "!="];
-
-value op_apply loc e1 e2 =
- fun
- [ "and" -> <:expr< $e1$ && $e2$ >>
- | "or" -> <:expr< $e1$ || $e2$ >>
- | x -> <:expr< $lid:x$ $e1$ $e2$ >> ]
-;
-
-value string_se =
- fun
- [ Sstring loc s -> s
- | se -> error se "string" ]
-;
-
-value mod_ident_se =
- fun
- [ Suid _ s -> [Pcaml.rename_id.val s]
- | Slid _ s -> [Pcaml.rename_id.val s]
- | se -> error se "mod_ident" ]
-;
-
-value lident_expr loc s =
- if String.length s > 1 && s.[0] = '`' then
- let s = String.sub s 1 (String.length s - 1) in
- <:expr< ` $s$ >>
- else <:expr< $lid:(Pcaml.rename_id.val s)$ >>
-;
-
-value rec module_expr_se =
- fun
- [ Sexpr loc [Slid _ "functor"; Suid _ s; se1; se2] ->
- let s = Pcaml.rename_id.val s in
- let mt = module_type_se se1 in
- let me = module_expr_se se2 in
- <:module_expr< functor ($s$ : $mt$) -> $me$ >>
- | Sexpr loc [Slid _ "struct" :: sl] ->
- let mel = List.map str_item_se sl in
- <:module_expr< struct $list:mel$ end >>
- | Sexpr loc [se1; se2] ->
- let me1 = module_expr_se se1 in
- let me2 = module_expr_se se2 in
- <:module_expr< $me1$ $me2$ >>
- | Suid loc s -> <:module_expr< $uid:(Pcaml.rename_id.val s)$ >>
- | se -> error se "module expr" ]
-and module_type_se =
- fun
- [ Sexpr loc [Slid _ "functor"; Suid _ s; se1; se2] ->
- let s = Pcaml.rename_id.val s in
- let mt1 = module_type_se se1 in
- let mt2 = module_type_se se2 in
- <:module_type< functor ($s$ : $mt1$) -> $mt2$ >>
- | Sexpr loc [Slid _ "sig" :: sel] ->
- let sil = List.map sig_item_se sel in
- <:module_type< sig $list:sil$ end >>
- | Sexpr loc [Slid _ "with"; se; Sexpr _ sel] ->
- let mt = module_type_se se in
- let wcl = List.map with_constr_se sel in
- <:module_type< $mt$ with $list:wcl$ >>
- | Suid loc s -> <:module_type< $uid:(Pcaml.rename_id.val s)$ >>
- | se -> error se "module type" ]
-and with_constr_se =
- fun
- [ Sexpr loc [Slid _ "type"; se1; se2] ->
- let tn = mod_ident_se se1 in
- let te = ctyp_se se2 in
- MLast.WcTyp loc tn [] te
- | se -> error se "with constr" ]
-and sig_item_se =
- fun
- [ Sexpr loc [Slid _ "type" :: sel] ->
- let tdl = type_declaration_list_se sel in
- <:sig_item< type $list:tdl$ >>
- | Sexpr loc [Slid _ "exception"; Suid _ c :: sel] ->
- let c = Pcaml.rename_id.val c in
- let tl = List.map ctyp_se sel in
- <:sig_item< exception $c$ of $list:tl$ >>
- | Sexpr loc [Slid _ "value"; Slid _ s; se] ->
- let s = Pcaml.rename_id.val s in
- let t = ctyp_se se in
- <:sig_item< value $s$ : $t$ >>
- | Sexpr loc [Slid _ "external"; Slid _ i; se :: sel] ->
- let i = Pcaml.rename_id.val i in
- let pd = List.map string_se sel in
- let t = ctyp_se se in
- <:sig_item< external $i$ : $t$ = $list:pd$ >>
- | Sexpr loc [Slid _ "module"; Suid _ s; se] ->
- let s = Pcaml.rename_id.val s in
- let mb = module_type_se se in
- <:sig_item< module $s$ : $mb$ >>
- | Sexpr loc [Slid _ "moduletype"; Suid _ s; se] ->
- let s = Pcaml.rename_id.val s in
- let mt = module_type_se se in
- <:sig_item< module type $s$ = $mt$ >>
- | se -> error se "sig item" ]
-and str_item_se se =
- match se with
- [ Sexpr loc [Slid _ "open"; se] ->
- let s = mod_ident_se se in
- <:str_item< open $s$ >>
- | Sexpr loc [Slid _ "type" :: sel] ->
- let tdl = type_declaration_list_se sel in
- <:str_item< type $list:tdl$ >>
- | Sexpr loc [Slid _ "exception"; Suid _ c :: sel] ->
- let c = Pcaml.rename_id.val c in
- let tl = List.map ctyp_se sel in
- <:str_item< exception $c$ of $list:tl$ >>
- | Sexpr loc [Slid _ ("define" | "definerec" as r); se :: sel] ->
- let r = r = "definerec" in
- let (p, e) = fun_binding_se se (begin_se loc sel) in
- <:str_item< value $opt:r$ $p$ = $e$ >>
- | Sexpr loc [Slid _ ("define*" | "definerec*" as r) :: sel] ->
- let r = r = "definerec*" in
- let lbs = List.map let_binding_se sel in
- <:str_item< value $opt:r$ $list:lbs$ >>
- | Sexpr loc [Slid _ "external"; Slid _ i; se :: sel] ->
- let i = Pcaml.rename_id.val i in
- let pd = List.map string_se sel in
- let t = ctyp_se se in
- <:str_item< external $i$ : $t$ = $list:pd$ >>
- | Sexpr loc [Slid _ "module"; Suid _ i; se] ->
- let i = Pcaml.rename_id.val i in
- let mb = module_binding_se se in
- <:str_item< module $i$ = $mb$ >>
- | Sexpr loc [Slid _ "moduletype"; Suid _ s; se] ->
- let s = Pcaml.rename_id.val s in
- let mt = module_type_se se in
- <:str_item< module type $s$ = $mt$ >>
- | _ ->
- let loc = loc_of_sexpr se in
- let e = expr_se se in
- <:str_item< $exp:e$ >> ]
-and module_binding_se se = module_expr_se se
-and expr_se =
- fun
- [ Sacc loc se1 se2 ->
- let e1 = expr_se se1 in
- match se2 with
- [ Slist loc [se2] ->
- let e2 = expr_se se2 in
- <:expr< $e1$ .[ $e2$ ] >>
- | Sexpr loc [se2] ->
- let e2 = expr_se se2 in
- <:expr< $e1$ .( $e2$ ) >>
- | _ ->
- let e2 = expr_se se2 in
- <:expr< $e1$ . $e2$ >> ]
- | Slid loc s -> lident_expr loc s
- | Suid loc s -> <:expr< $uid:(Pcaml.rename_id.val s)$ >>
- | Sint loc s -> <:expr< $int:s$ >>
- | Sfloat loc s -> <:expr< $flo:s$ >>
- | Schar loc s -> <:expr< $chr:s$ >>
- | Sstring loc s -> <:expr< $str:s$ >>
- | Stid loc s -> <:expr< ~ $(Pcaml.rename_id.val s)$ >>
- | Sqid loc s -> <:expr< ? $(Pcaml.rename_id.val s)$ >>
- | Sexpr loc [] -> <:expr< () >>
- | Sexpr loc [Slid _ s; e1 :: ([_ :: _] as sel)]
- when List.mem s assoc_left_parsed_op_list ->
- let rec loop e1 =
- fun
- [ [] -> e1
- | [e2 :: el] -> loop (op_apply loc e1 e2 s) el ]
- in
- loop (expr_se e1) (List.map expr_se sel)
- | Sexpr loc [Slid _ s :: ([_; _ :: _] as sel)]
- when List.mem s assoc_right_parsed_op_list ->
- let rec loop =
- fun
- [ [] -> assert False
- | [e1] -> e1
- | [e1 :: el] ->
- let e2 = loop el in
- op_apply loc e1 e2 s ]
- in
- loop (List.map expr_se sel)
- | Sexpr loc [Slid _ s :: ([_; _ :: _] as sel)]
- when List.mem s and_by_couple_op_list ->
- let rec loop =
- fun
- [ [] | [_] -> assert False
- | [e1; e2] -> <:expr< $lid:s$ $e1$ $e2$ >>
- | [e1 :: ([e2; _ :: _] as el)] ->
- let a1 = op_apply loc e1 e2 s in
- let a2 = loop el in
- <:expr< $a1$ && $a2$ >> ]
- in
- loop (List.map expr_se sel)
- | Sexpr loc [Stid _ s; se] ->
- let e = expr_se se in
- <:expr< ~ $s$ : $e$ >>
- | Sexpr loc [Slid _ "-"; se] ->
- let e = expr_se se in
- <:expr< - $e$ >>
- | Sexpr loc [Slid _ "if"; se; se1] ->
- let e = expr_se se in
- let e1 = expr_se se1 in
- <:expr< if $e$ then $e1$ else () >>
- | Sexpr loc [Slid _ "if"; se; se1; se2] ->
- let e = expr_se se in
- let e1 = expr_se se1 in
- let e2 = expr_se se2 in
- <:expr< if $e$ then $e1$ else $e2$ >>
- | Sexpr loc [Slid _ "cond" :: sel] ->
- let rec loop =
- fun
- [ [Sexpr loc [Slid _ "else" :: sel]] -> begin_se loc sel
- | [Sexpr loc [se1 :: sel1] :: sel] ->
- let e1 = expr_se se1 in
- let e2 = begin_se loc sel1 in
- let e3 = loop sel in
- <:expr< if $e1$ then $e2$ else $e3$ >>
- | [] -> <:expr< () >>
- | [se :: _] -> error se "cond clause" ]
- in
- loop sel
- | Sexpr loc [Slid _ "while"; se :: sel] ->
- let e = expr_se se in
- let el = List.map expr_se sel in
- <:expr< while $e$ do { $list:el$ } >>
- | Sexpr loc [Slid _ "for"; Slid _ i; se1; se2 :: sel] ->
- let i = Pcaml.rename_id.val i in
- let e1 = expr_se se1 in
- let e2 = expr_se se2 in
- let el = List.map expr_se sel in
- <:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >>
- | Sexpr loc [Slid loc1 "lambda"] -> <:expr< fun [] >>
- | Sexpr loc [Slid loc1 "lambda"; sep :: sel] ->
- let e = begin_se loc1 sel in
- match ipatt_opt_se sep with
- [ Left p -> <:expr< fun $p$ -> $e$ >>
- | Right (se, sel) ->
- List.fold_right
- (fun se e ->
- let p = ipatt_se se in
- <:expr< fun $p$ -> $e$ >>)
- [se :: sel] e ]
- | Sexpr loc [Slid _ "lambda_match" :: sel] ->
- let pel = List.map (match_case loc) sel in
- <:expr< fun [ $list:pel$ ] >>
- | Sexpr loc [Slid _ ("let" | "letrec" as r) :: sel] ->
- match sel with
- [ [Sexpr _ sel1 :: sel2] ->
- let r = r = "letrec" in
- let lbs = List.map let_binding_se sel1 in
- let e = begin_se loc sel2 in
- <:expr< let $opt:r$ $list:lbs$ in $e$ >>
- | [Slid _ n; Sexpr _ sl :: sel] ->
- let n = Pcaml.rename_id.val n in
- let (pl, el) =
- List.fold_right
- (fun se (pl, el) ->
- match se with
- [ Sexpr _ [se1; se2] ->
- ([patt_se se1 :: pl], [expr_se se2 :: el])
- | se -> error se "named let" ])
- sl ([], [])
- in
- let e1 =
- List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) pl
- (begin_se loc sel)
- in
- let e2 =
- List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>)
- <:expr< $lid:n$ >> el
- in
- <:expr< let rec $lid:n$ = $e1$ in $e2$ >>
- | [se :: _] -> error se "let_binding"
- | _ -> error_loc loc "let_binding" ]
- | Sexpr loc [Slid _ "let*" :: sel] ->
- match sel with
- [ [Sexpr _ sel1 :: sel2] ->
- List.fold_right
- (fun se ek ->
- let (p, e) = let_binding_se se in
- <:expr< let $p$ = $e$ in $ek$ >>)
- sel1 (begin_se loc sel2)
- | [se :: _] -> error se "let_binding"
- | _ -> error_loc loc "let_binding" ]
- | Sexpr loc [Slid _ "match"; se :: sel] ->
- let e = expr_se se in
- let pel = List.map (match_case loc) sel in
- <:expr< match $e$ with [ $list:pel$ ] >>
- | Sexpr loc [Slid _ "parser" :: sel] ->
- let e =
- match sel with
- [ [(Slid _ _ as se) :: sel] ->
- let p = patt_se se in
- let pc = parser_cases_se loc sel in
- <:expr< let $p$ = Stream.count $lid:strm_n$ in $pc$ >>
- | _ -> parser_cases_se loc sel ]
- in
- <:expr< fun ($lid:strm_n$ : Stream.t _) -> $e$ >>
- | Sexpr loc [Slid _ "match_with_parser"; se :: sel] ->
- let me = expr_se se in
- let (bpo, sel) =
- match sel with
- [ [(Slid _ _ as se) :: sel] -> (Some (patt_se se), sel)
- | _ -> (None, sel) ]
- in
- let pc = parser_cases_se loc sel in
- let e =
- match bpo with
- [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>
- | None -> pc ]
- in
- match me with
- [ <:expr< $lid:x$ >> when x = strm_n -> e
- | _ -> <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >> ]
- | Sexpr loc [Slid _ "try"; se :: sel] ->
- let e = expr_se se in
- let pel = List.map (match_case loc) sel in
- <:expr< try $e$ with [ $list:pel$ ] >>
- | Sexpr loc [Slid _ "begin" :: sel] ->
- let el = List.map expr_se sel in
- <:expr< do { $list:el$ } >>
- | Sexpr loc [Slid _ ":="; se1; se2] ->
- let e1 = expr_se se1 in
- let e2 = expr_se se2 in
- <:expr< $e1$ := $e2$ >>
- | Sexpr loc [Slid _ "values" :: sel] ->
- let el = List.map expr_se sel in
- <:expr< ( $list:el$ ) >>
- | Srec loc [Slid _ "with"; se :: sel] ->
- let e = expr_se se in
- let lel = List.map (label_expr_se loc) sel in
- <:expr< { ($e$) with $list:lel$ } >>
- | Srec loc sel ->
- let lel = List.map (label_expr_se loc) sel in
- <:expr< { $list:lel$ } >>
- | Sexpr loc [Slid _ ":"; se1; se2] ->
- let e = expr_se se1 in
- let t = ctyp_se se2 in
- <:expr< ( $e$ : $t$ ) >>
- | Sexpr loc [se] ->
- let e = expr_se se in
- <:expr< $e$ () >>
- | Sexpr loc [Slid _ "assert"; Suid _ "False" ] ->
- <:expr< assert False >>
- | Sexpr loc [Slid _ "assert"; se] ->
- let e = expr_se se in
- <:expr< assert $e$ >>
- | Sexpr loc [Slid _ "lazy"; se] ->
- let e = expr_se se in
- <:expr< lazy $e$ >>
- | Sexpr loc [se :: sel] ->
- List.fold_left
- (fun e se ->
- let e1 = expr_se se in
- <:expr< $e$ $e1$ >>)
- (expr_se se) sel
- | Slist loc sel ->
- let rec loop =
- fun
- [ [] -> <:expr< [] >>
- | [se1; Slid _ "."; se2] ->
- let e = expr_se se1 in
- let el = expr_se se2 in
- <:expr< [$e$ :: $el$] >>
- | [se :: sel] ->
- let e = expr_se se in
- let el = loop sel in
- <:expr< [$e$ :: $el$] >> ]
- in
- loop sel
- | Squot loc typ txt -> Pcaml.handle_expr_quotation loc (typ, txt) ]
-and begin_se loc =
- fun
- [ [] -> <:expr< () >>
- | [se] -> expr_se se
- | sel ->
- let el = List.map expr_se sel in
- let loc = (fst (loc_of_sexpr (List.hd sel)), snd loc) in
- <:expr< do { $list:el$ } >> ]
-and let_binding_se =
- fun
- [ Sexpr loc [se :: sel] ->
- let e = begin_se loc sel in
- match ipatt_opt_se se with
- [ Left p -> (p, e)
- | Right _ -> fun_binding_se se e ]
- | se -> error se "let_binding" ]
-and fun_binding_se se e =
- match se with
- [ Sexpr _ [Slid _ "values" :: _] -> (ipatt_se se, e)
- | Sexpr _ [Slid loc s :: sel] ->
- let s = Pcaml.rename_id.val s in
- let e =
- List.fold_right
- (fun se e ->
- let loc = (fst (loc_of_sexpr se), snd (MLast.loc_of_expr e)) in
- let p = ipatt_se se in
- <:expr< fun $p$ -> $e$ >>)
- sel e
- in
- let p = <:patt< $lid:s$ >> in
- (p, e)
- | _ -> (ipatt_se se, e) ]
-and match_case loc =
- fun
- [ Sexpr loc [Sexpr _ [Slid _ "when"; se; sew] :: sel] ->
- (patt_se se, Some (expr_se sew), begin_se loc sel)
- | Sexpr loc [se :: sel] -> (patt_se se, None, begin_se loc sel)
- | se -> error se "match_case" ]
-and label_expr_se loc =
- fun
- [ Sexpr _ [se1; se2] -> (patt_se se1, expr_se se2)
- | se -> error se "label_expr" ]
-and label_patt_se loc =
- fun
- [ Sexpr _ [se1; se2] -> (patt_se se1, patt_se se2)
- | se -> error se "label_patt" ]
-and parser_cases_se loc =
- fun
- [ [] -> <:expr< raise Stream.Failure >>
- | [Sexpr loc [Sexpr _ spsel :: act] :: sel] ->
- let ekont _ = parser_cases_se loc sel in
- let act =
- match act with
- [ [se] -> expr_se se
- | [sep; se] ->
- let p = patt_se sep in
- let e = expr_se se in
- <:expr< let $p$ = Stream.count $lid:strm_n$ in $e$ >>
- | _ -> error_loc loc "parser_case" ]
- in
- stream_pattern_se loc act ekont spsel
- | [se :: _] -> error se "parser_case" ]
-and stream_pattern_se loc act ekont =
- fun
- [ [] -> act
- | [se :: sel] ->
- let ckont err = <:expr< raise (Stream.Error $err$) >> in
- let skont = stream_pattern_se loc act ckont sel in
- stream_pattern_component skont ekont <:expr< "" >> se ]
-and stream_pattern_component skont ekont err =
- fun
- [ Sexpr loc [Slid _ "`"; se :: wol] ->
- let wo =
- match wol with
- [ [se] -> Some (expr_se se)
- | [] -> None
- | _ -> error_loc loc "stream_pattern_component" ]
- in
- let e = peek_fun loc in
- let p = patt_se se in
- let j = junk_fun loc in
- let k = ekont err in
- <:expr< match $e$ $lid:strm_n$ with
- [ Some $p$ $when:wo$ -> do { $j$ $lid:strm_n$ ; $skont$ }
- | _ -> $k$ ] >>
- | Sexpr loc [se1; se2] ->
- let p = patt_se se1 in
- let e =
- let e = expr_se se2 in
- <:expr< try Some ($e$ $lid:strm_n$) with [ Stream.Failure -> None ] >>
- in
- let k = ekont err in
- <:expr< match $e$ with [ Some $p$ -> $skont$ | _ -> $k$ ] >>
- | Sexpr loc [Slid _ "?"; se1; se2] ->
- stream_pattern_component skont ekont (expr_se se2) se1
- | Slid loc s ->
- let s = Pcaml.rename_id.val s in
- <:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >>
- | se -> error se "stream_pattern_component" ]
-and patt_se =
- fun
- [ Sacc loc se1 se2 ->
- let p1 = patt_se se1 in
- let p2 = patt_se se2 in
- <:patt< $p1$ . $p2$ >>
- | Slid loc "_" -> <:patt< _ >>
- | Slid loc s -> <:patt< $lid:(Pcaml.rename_id.val s)$ >>
- | Suid loc s -> <:patt< $uid:(Pcaml.rename_id.val s)$ >>
- | Sint loc s -> <:patt< $int:s$ >>
- | Sfloat loc s -> <:patt< $flo:s$ >>
- | Schar loc s -> <:patt< $chr:s$ >>
- | Sstring loc s -> <:patt< $str:s$ >>
- | Stid loc _ -> error_loc loc "patt"
- | Sqid loc _ -> error_loc loc "patt"
- | Srec loc sel ->
- let lpl = List.map (label_patt_se loc) sel in
- <:patt< { $list:lpl$ } >>
- | Sexpr loc [Slid _ ":"; se1; se2] ->
- let p = patt_se se1 in
- let t = ctyp_se se2 in
- <:patt< ($p$ : $t$) >>
- | Sexpr loc [Slid _ "or"; se :: sel] ->
- List.fold_left
- (fun p se ->
- let p1 = patt_se se in
- <:patt< $p$ | $p1$ >>)
- (patt_se se) sel
- | Sexpr loc [Slid _ "range"; se1; se2] ->
- let p1 = patt_se se1 in
- let p2 = patt_se se2 in
- <:patt< $p1$ .. $p2$ >>
- | Sexpr loc [Slid _ "values" :: sel] ->
- let pl = List.map patt_se sel in
- <:patt< ( $list:pl$ ) >>
- | Sexpr loc [Slid _ "as"; se1; se2] ->
- let p1 = patt_se se1 in
- let p2 = patt_se se2 in
- <:patt< ($p1$ as $p2$) >>
- | Sexpr loc [se :: sel] ->
- List.fold_left
- (fun p se ->
- let p1 = patt_se se in
- <:patt< $p$ $p1$ >>)
- (patt_se se) sel
- | Sexpr loc [] -> <:patt< () >>
- | Slist loc sel ->
- let rec loop =
- fun
- [ [] -> <:patt< [] >>
- | [se1; Slid _ "."; se2] ->
- let p = patt_se se1 in
- let pl = patt_se se2 in
- <:patt< [$p$ :: $pl$] >>
- | [se :: sel] ->
- let p = patt_se se in
- let pl = loop sel in
- <:patt< [$p$ :: $pl$] >> ]
- in
- loop sel
- | Squot loc typ txt -> Pcaml.handle_patt_quotation loc (typ, txt) ]
-and ipatt_se se =
- match ipatt_opt_se se with
- [ Left p -> p
- | Right (se, _) -> error se "ipatt" ]
-and ipatt_opt_se =
- fun
- [ Slid loc "_" -> Left <:patt< _ >>
- | Slid loc s -> Left <:patt< $lid:(Pcaml.rename_id.val s)$ >>
- | Stid loc s -> Left <:patt< ~ $(Pcaml.rename_id.val s)$ >>
- | Sqid loc s -> Left <:patt< ? $(Pcaml.rename_id.val s)$ >>
- | Sexpr loc [Sqid _ s; se] ->
- let s = Pcaml.rename_id.val s in
- let e = expr_se se in
- Left <:patt< ? ( $lid:s$ = $e$ ) >>
- | Sexpr loc [Slid _ ":"; se1; se2] ->
- let p = ipatt_se se1 in
- let t = ctyp_se se2 in
- Left <:patt< ($p$ : $t$) >>
- | Sexpr loc [Slid _ "values" :: sel] ->
- let pl = List.map ipatt_se sel in
- Left <:patt< ( $list:pl$ ) >>
- | Sexpr loc [] -> Left <:patt< () >>
- | Sexpr loc [se :: sel] -> Right (se, sel)
- | se -> error se "ipatt" ]
-and type_declaration_list_se =
- fun
- [ [se1; se2 :: sel] ->
- let (n1, loc1, tpl) =
- match se1 with
- [ Sexpr _ [Slid loc n :: sel] ->
- (n, loc, List.map type_parameter_se sel)
- | Slid loc n -> (n, loc, [])
- | se -> error se "type declaration" ]
- in
- [((loc1, Pcaml.rename_id.val n1), tpl, ctyp_se se2, []) ::
- type_declaration_list_se sel]
- | [] -> []
- | [se :: _] -> error se "type_declaration" ]
-and type_parameter_se =
- fun
- [ Slid _ s when String.length s >= 2 && s.[0] = ''' ->
- (String.sub s 1 (String.length s - 1), (False, False))
- | se -> error se "type_parameter" ]
-and ctyp_se =
- fun
- [ Sexpr loc [Slid _ "sum" :: sel] ->
- let cdl = List.map constructor_declaration_se sel in
- <:ctyp< [ $list:cdl$ ] >>
- | Srec loc sel ->
- let ldl = List.map label_declaration_se sel in
- <:ctyp< { $list:ldl$ } >>
- | Sexpr loc [Slid _ "->" :: ([_; _ :: _] as sel)] ->
- let rec loop =
- fun
- [ [] -> assert False
- | [se] -> ctyp_se se
- | [se :: sel] ->
- let t1 = ctyp_se se in
- let loc = (fst (loc_of_sexpr se), snd loc) in
- let t2 = loop sel in
- <:ctyp< $t1$ -> $t2$ >> ]
- in
- loop sel
- | Sexpr loc [Slid _ "*" :: sel] ->
- let tl = List.map ctyp_se sel in
- <:ctyp< ($list:tl$) >>
- | Sexpr loc [se :: sel] ->
- List.fold_left
- (fun t se ->
- let t2 = ctyp_se se in
- <:ctyp< $t$ $t2$ >>)
- (ctyp_se se) sel
- | Sacc loc se1 se2 ->
- let t1 = ctyp_se se1 in
- let t2 = ctyp_se se2 in
- <:ctyp< $t1$ . $t2$ >>
- | Slid loc "_" -> <:ctyp< _ >>
- | Slid loc s ->
- if s.[0] = ''' then
- let s = String.sub s 1 (String.length s - 1) in
- <:ctyp< '$s$ >>
- else <:ctyp< $lid:(Pcaml.rename_id.val s)$ >>
- | Suid loc s -> <:ctyp< $uid:(Pcaml.rename_id.val s)$ >>
- | se -> error se "ctyp" ]
-and constructor_declaration_se =
- fun
- [ Sexpr loc [Suid _ ci :: sel] ->
- (loc, Pcaml.rename_id.val ci, List.map ctyp_se sel)
- | se -> error se "constructor_declaration" ]
-and label_declaration_se =
- fun
- [ Sexpr loc [Slid _ lab; Slid _ "mutable"; se] ->
- (loc, Pcaml.rename_id.val lab, True, ctyp_se se)
- | Sexpr loc [Slid _ lab; se] ->
- (loc, Pcaml.rename_id.val lab, False, ctyp_se se)
- | se -> error se "label_declaration" ]
-;
-
-value directive_se =
- fun
- [ Sexpr _ [Slid _ s] -> (s, None)
- | Sexpr _ [Slid _ s; se] ->
- let e = expr_se se in
- (s, Some e)
- | se -> error se "directive" ]
-;
-
-(* Parser *)
-
-Pcaml.syntax_name.val := "Scheme";
-Pcaml.no_constructors_arity.val := False;
-
-do {
- Grammar.Unsafe.gram_reinit gram (lexer_gmake ());
- Grammar.Unsafe.clear_entry interf;
- Grammar.Unsafe.clear_entry implem;
- Grammar.Unsafe.clear_entry top_phrase;
- Grammar.Unsafe.clear_entry use_file;
- Grammar.Unsafe.clear_entry module_type;
- Grammar.Unsafe.clear_entry module_expr;
- Grammar.Unsafe.clear_entry sig_item;
- Grammar.Unsafe.clear_entry str_item;
- Grammar.Unsafe.clear_entry expr;
- Grammar.Unsafe.clear_entry patt;
- Grammar.Unsafe.clear_entry ctyp;
- Grammar.Unsafe.clear_entry let_binding;
- Grammar.Unsafe.clear_entry type_declaration;
- Grammar.Unsafe.clear_entry class_type;
- Grammar.Unsafe.clear_entry class_expr;
- Grammar.Unsafe.clear_entry class_sig_item;
- Grammar.Unsafe.clear_entry class_str_item
-};
-
-Pcaml.parse_interf.val := Grammar.Entry.parse interf;
-Pcaml.parse_implem.val := Grammar.Entry.parse implem;
-
-value sexpr = Grammar.Entry.create gram "sexpr";
-
-value rec leftify =
- fun
- [ Sacc loc1 se1 se2 ->
- match leftify se2 with
- [ Sacc loc2 se2 se3 -> Sacc loc1 (Sacc loc2 se1 se2) se3
- | se2 -> Sacc loc1 se1 se2 ]
- | x -> x ]
-;
-
-EXTEND
- GLOBAL: implem interf top_phrase use_file str_item sig_item expr patt sexpr;
- implem:
- [ [ "#"; se = sexpr ->
- let (n, dp) = directive_se se in
- ([(<:str_item< # $n$ $opt:dp$ >>, loc)], True)
- | si = str_item; x = SELF ->
- let (sil, stopped) = x in
- let loc = MLast.loc_of_str_item si in
- ([(si, loc) :: sil], stopped)
- | EOI -> ([], False) ] ]
- ;
- interf:
- [ [ "#"; se = sexpr ->
- let (n, dp) = directive_se se in
- ([(<:sig_item< # $n$ $opt:dp$ >>, loc)], True)
- | si = sig_item; x = SELF ->
- let (sil, stopped) = x in
- let loc = MLast.loc_of_sig_item si in
- ([(si, loc) :: sil], stopped)
- | EOI -> ([], False) ] ]
- ;
- top_phrase:
- [ [ "#"; se = sexpr ->
- let (n, dp) = directive_se se in
- Some <:str_item< # $n$ $opt:dp$ >>
- | se = sexpr -> Some (str_item_se se)
- | EOI -> None ] ]
- ;
- use_file:
- [ [ "#"; se = sexpr ->
- let (n, dp) = directive_se se in
- ([<:str_item< # $n$ $opt:dp$ >>], True)
- | si = str_item; x = SELF ->
- let (sil, stopped) = x in
- ([si :: sil], stopped)
- | EOI -> ([], False) ] ]
- ;
- str_item:
- [ [ se = sexpr -> str_item_se se
- | e = expr -> <:str_item< $exp:e$ >> ] ]
- ;
- sig_item:
- [ [ se = sexpr -> sig_item_se se ] ]
- ;
- expr:
- [ "top"
- [ se = sexpr -> expr_se se ] ]
- ;
- patt:
- [ [ se = sexpr -> patt_se se ] ]
- ;
- sexpr:
- [ [ se1 = sexpr_dot; se2 = SELF -> leftify (Sacc loc se1 se2) ]
- | [ "("; sl = LIST0 sexpr; ")" -> Sexpr loc sl
- | "("; sl = LIST0 sexpr; ")."; se = SELF ->
- leftify (Sacc loc (Sexpr loc sl) se)
- | "["; sl = LIST0 sexpr; "]" -> Slist loc sl
- | "{"; sl = LIST0 sexpr; "}" -> Srec loc sl
- | a = pa_extend_keyword -> Slid loc a
- | s = LIDENT -> Slid loc s
- | s = UIDENT -> Suid loc s
- | s = TILDEIDENT -> Stid loc s
- | s = QUESTIONIDENT -> Sqid loc s
- | s = INT -> Sint loc s
- | s = FLOAT -> Sfloat loc s
- | s = CHAR -> Schar loc s
- | s = STRING -> Sstring loc s
- | s = QUOT ->
- let i = String.index s ':' in
- let typ = String.sub s 0 i in
- let txt = String.sub s (i + 1) (String.length s - i - 1) in
- Squot loc typ txt ] ]
- ;
- sexpr_dot:
- [ [ s = LIDENTDOT -> Slid loc s
- | s = UIDENTDOT -> Suid loc s ] ]
- ;
- pa_extend_keyword:
- [ [ "_" -> "_"
- | "," -> ","
- | "=" -> "="
- | ":" -> ":"
- | "." -> "."
- | "/" -> "/" ] ]
- ;
-END;
diff --git a/camlp4/etc/pa_sml.ml b/camlp4/etc/pa_sml.ml
deleted file mode 100644
index ee5db540d1..0000000000
--- a/camlp4/etc/pa_sml.ml
+++ /dev/null
@@ -1,947 +0,0 @@
-(* camlp4r pa_extend.cmo q_MLast.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Stdpp;
-open Pcaml;
-
-value ocaml_records = ref False;
-
-Pcaml.no_constructors_arity.val := True;
-
-value lexer = Plexer.gmake ();
-
-do {
- Grammar.Unsafe.gram_reinit gram lexer;
- Grammar.Unsafe.clear_entry interf;
- Grammar.Unsafe.clear_entry implem;
- Grammar.Unsafe.clear_entry top_phrase;
- Grammar.Unsafe.clear_entry use_file;
- Grammar.Unsafe.clear_entry module_type;
- Grammar.Unsafe.clear_entry module_expr;
- Grammar.Unsafe.clear_entry sig_item;
- Grammar.Unsafe.clear_entry str_item;
- Grammar.Unsafe.clear_entry expr;
- Grammar.Unsafe.clear_entry patt;
- Grammar.Unsafe.clear_entry ctyp;
- Grammar.Unsafe.clear_entry let_binding;
-};
-
-Pcaml.parse_interf.val := Grammar.Entry.parse interf;
-Pcaml.parse_implem.val := Grammar.Entry.parse implem;
-
-value not_impl loc s =
- raise_with_loc loc (Stream.Error ("not implemented feature [" ^ s ^ "]"))
-;
-
-type altern 'a 'b = [ Left of 'a | Right of 'b ];
-
-value get_seq =
- fun
- [ <:expr< do { $list:el$ } >> -> el
- | e -> [e] ]
-;
-
-value choose_tvar tpl =
- let rec find_alpha v =
- let s = String.make 1 v in
- if List.mem_assoc s tpl then
- if v = 'z' then None else find_alpha (Char.chr (Char.code v + 1))
- else Some (String.make 1 v)
- in
- let rec make_n n =
- let v = "a" ^ string_of_int n in
- if List.mem_assoc v tpl then make_n (succ n) else v
- in
- match find_alpha 'a' with
- [ Some x -> x
- | None -> make_n 1 ]
-;
-
-value mklistexp loc last =
- loop True where rec loop top =
- fun
- [ [] ->
- match last with
- [ Some e -> e
- | None -> <:expr< [] >> ]
- | [e1 :: el] ->
- let loc = if top then loc else (fst (MLast.loc_of_expr e1), snd loc) in
- <:expr< [$e1$ :: $loop False el$] >> ]
-;
-
-value mklistpat loc last =
- loop True where rec loop top =
- fun
- [ [] ->
- match last with
- [ Some p -> p
- | None -> <:patt< [] >> ]
- | [p1 :: pl] ->
- let loc = if top then loc else (fst (MLast.loc_of_patt p1), snd loc) in
- <:patt< [$p1$ :: $loop False pl$] >> ]
-;
-
-value expr_of_patt p =
- let loc = MLast.loc_of_patt p in
- match p with
- [ <:patt< $lid:x$ >> -> <:expr< $lid:x$ >>
- | _ -> Stdpp.raise_with_loc loc (Stream.Error "identifier expected") ]
-;
-
-value apply_bind loc e bl =
- let rec loop e =
- fun
- [ [] -> e
- | [<:str_item< value $p1$ = $e1$ >> :: list] ->
- loop_let e [(p1, e1)] list
- | [<:str_item< value rec $p1$ = $e1$ >> :: list] ->
- loop_letrec e [(p1, e1)] list
- | [<:str_item< module $s$ = $me$ >> :: list] ->
- let e = <:expr< let module $s$ = $me$ in $e$ >> in
- loop e list
- | [si :: list] ->
- raise Exit ]
- and loop_let e pel =
- fun
- [ [<:str_item< value $p1$ = $e1$ >> :: list] ->
- loop_let e [(p1, e1) :: pel] list
- | list ->
- let e = <:expr< let $list:pel$ in $e$ >> in
- loop e list ]
- and loop_letrec e pel =
- fun
- [ [<:str_item< value rec $p1$ = $e1$ >> :: list] ->
- loop_letrec e [(p1, e1) :: pel] list
- | list ->
- let e = <:expr< let rec $list:pel$ in $e$ >> in
- loop e list ]
- in
- loop e (List.rev bl)
-;
-
-value make_local loc sl1 sl2 =
- try
- let pl =
- List.map
- (fun
- [ <:str_item< value $opt:_$ $p$ = $_$ >> -> p
- | _ -> raise Exit ])
- sl2
- in
- let e1 =
- match List.map expr_of_patt pl with
- [ [e] -> e
- | el -> <:expr< ($list:el$) >> ]
- in
- let p1 =
- match pl with
- [ [p] -> p
- | pl -> <:patt< ($list:pl$) >> ]
- in
- let e = apply_bind loc e1 sl2 in
- let e = apply_bind loc e sl1 in
- <:str_item< value $p1$ = $e$ >>
- with
- [ Exit ->
- do {
- Printf.eprintf "\
-*** Warning: a 'local' statement will be defined global because of bindings
-which cannot be defined as first class values (modules, exceptions, ...)\n";
- flush stderr;
- <:str_item< declare $list:sl1 @ sl2$ end >>
- } ]
-;
-
-value str_declare loc =
- fun
- [ [d] -> d
- | dl -> <:str_item< declare $list:dl$ end >> ]
-;
-
-value sig_declare loc =
- fun
- [ [d] -> d
- | dl -> <:sig_item< declare $list:dl$ end >> ]
-;
-
-value extract_label_types loc tn tal cdol =
- let (cdl, aux) =
- List.fold_right
- (fun (loc, c, tl, aux_opt) (cdl, aux) ->
- match aux_opt with
- [ Some anon_record_type ->
- let new_tn = tn ^ "_" ^ c in
- let loc = MLast.loc_of_ctyp anon_record_type in
- let aux_def = ((loc, new_tn), [], anon_record_type, []) in
- let tl = [<:ctyp< $lid:new_tn$ >>] in
- ([(loc, c, tl) :: cdl], [aux_def :: aux])
- | None -> ([(loc, c, tl) :: cdl], aux) ])
- cdol ([], [])
- in
- [((loc, tn), tal, <:ctyp< [ $list:cdl$ ] >>, []) :: aux]
-;
-
-value function_of_clause_list loc xl =
- let (fname, fname_loc, nbpat, l) =
- List.fold_left
- (fun (fname, fname_loc, nbpat, l) ((x1, loc), x2, x3, x4) ->
- let (fname, fname_loc, nbpat) =
- if fname = "" then (x1, loc, List.length x2)
- else if x1 <> fname then
- raise_with_loc loc
- (Stream.Error ("'" ^ fname ^ "' expected"))
- else if List.length x2 <> nbpat then
- raise_with_loc loc
- (Stream.Error "bad number of patterns in that clause")
- else (fname, fname_loc, nbpat)
- in
- let x4 =
- match x3 with
- [ Some t -> <:expr< ($x4$ : $t$) >>
- | _ -> x4 ]
- in
- let l = [(x2, x4) :: l] in
- (fname, fname_loc, nbpat, l))
- ("", loc, 0, []) xl
- in
- let l = List.rev l in
- let e =
- match l with
- [ [(pl, e)] ->
- List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) pl e
- | _ ->
- if nbpat = 1 then
- let pwel =
- List.map
- (fun (pl, e) -> (<:patt< $List.hd pl$ >>, None, e)) l
- in
- <:expr< fun [ $list:pwel$ ] >>
- else
- let sl =
- loop 0 where rec loop n =
- if n = nbpat then []
- else ["a" ^ string_of_int (n + 1) :: loop (n + 1)]
- in
- let e =
- let el = List.map (fun s -> <:expr< $lid:s$ >>) sl in
- let pwel =
- List.map
- (fun (pl, e) -> (<:patt< ($list:pl$) >>, None, e)) l
- in
- <:expr< match ($list:el$) with [ $list:pwel$ ] >>
- in
- List.fold_right (fun s e -> <:expr< fun $lid:s$ -> $e$ >>) sl e ]
- in
- (let loc = fname_loc in <:patt< $lid:fname$ >>, e)
-;
-
-value record_expr loc x1 =
- if ocaml_records.val then <:expr< { $list:x1$ } >>
- else
- let list1 =
- List.map
- (fun (l, v) ->
- let id =
- match l with
- [ <:patt< $lid:l$ >> -> l
- | _ -> "" ]
- in
- let loc = MLast.loc_of_expr v in
- <:class_str_item< value $id$ = $v$ >>)
- x1
- in
- let list2 =
- List.map
- (fun (l, v) ->
- let id =
- match l with
- [ <:patt< $lid:l$ >> -> l
- | _ -> "" ]
- in
- let loc = MLast.loc_of_patt l in
- <:class_str_item< method $id$ = $lid:id$ >>)
- x1
- in
- <:expr<
- let module M =
- struct
- class a = object $list:list1 @ list2$ end;
- end
- in
- new M.a
- >>
-;
-
-value record_match_assoc loc lpl e =
- if ocaml_records.val then (<:patt< { $list:lpl$ } >>, e)
- else
- let pl = List.map (fun (_, p) -> p) lpl in
- let e =
- let el =
- List.map
- (fun (l, _) ->
- let s =
- match l with
- [ <:patt< $lid:l$ >> -> l
- | _ -> "" ]
- in
- let loc = MLast.loc_of_patt l in
- <:expr< v # $lid:s$ >>)
- lpl
- in
- let loc = MLast.loc_of_expr e in
- <:expr< let v = $e$ in ($list:el$) >>
- in
- let p = <:patt< ($list:pl$) >> in
- (p, e)
-;
-
-value op =
- Grammar.Entry.of_parser gram "op"
- (parser [: `("", "op"); `(_, x) :] -> x)
-;
-lexer.Token.tok_using ("", "op");
-
-value special x =
- if String.length x >= 2 then
- match x.[0] with
- [ '+' | '<' | '^' -> True
- | _ -> False ]
- else False
-;
-
-value idd =
- let p =
- parser
- [ [: `("LIDENT", x) :] -> x
- | [: `("UIDENT", x) :] -> x
- | [: `("", "op"); `(_, x) :] -> x
- | [: `("", x) when special x :] -> x ]
- in
- Grammar.Entry.of_parser Pcaml.gram "ID" p
-;
-
-value uncap s = String.uncapitalize s;
-
-EXTEND
- GLOBAL: implem interf top_phrase use_file sig_item str_item ctyp patt expr
- module_type module_expr;
-
- implem:
- [ [ x = interdec; EOI -> x ] ]
- ;
- interf:
- [ [ x = LIST1 [ s = sig_item; OPT ";" -> (s, loc) ] -> (x, False) ] ]
- ;
- top_phrase:
- [ [ ph = phrase; ";" -> Some ph
- | EOI -> None ] ]
- ;
- use_file:
- [ [ l = LIST0 phrase; EOI -> (l, False) ] ]
- ;
- phrase:
- [ [ x = str_item -> x
- | x = expr -> <:str_item< $exp:x$ >>
- | "#"; n = LIDENT; dp = dir_param -> MLast.StDir loc n dp ] ]
- ;
- dir_param:
- [ [ -> None
- | e = expr -> Some e ] ]
- ;
- sdecs:
- [ [ x = sdec; l = sdecs -> [x :: l]
- | ";"; l = sdecs -> l
- | -> [] ] ]
- ;
-
- fsigb: [ [ -> not_impl loc "fsigb" ] ];
- fsigconstraint_op: [ [ -> not_impl loc "fsigconstraint_op" ] ];
- fct_exp: [ [ -> not_impl loc "fct_exp" ] ];
- exp_pa: [ [ -> not_impl loc "exp_pa" ] ];
- rvb: [ [ -> not_impl loc "rvb" ] ];
- tyvarseq: [ [ -> not_impl loc "tyvarseq" ] ];
-
- tyvar_pc:
- [ [ "'"; x1 = LIDENT -> [(x1, (False, False))]
- | "'"; x1 = LIDENT; ","; l = tyvar_pc -> [(x1, (False, False)) :: l] ] ]
- ;
- id:
- [ [ x1 = idd -> x1
- | "*" -> "*" ] ]
- ;
- ident:
- [ [ x1 = idd -> x1
- | "*" -> "*"
- | "=" -> "="
- | "<" -> "<"
- | ">" -> ">"
- | "<=" -> "<="
- | ">=" -> ">="
- | "^" -> "^" ] ]
- ;
- op_op:
- [ [ x1 = op -> not_impl loc "op_op 1"
- | -> () ] ]
- ;
- qid:
- [ [ x1 = idd; "."; x2 = qid -> <:module_expr< $uid:x1$ . $x2$ >>
- | x1 = idd -> <:module_expr< $uid:x1$ >>
- | x1 = "*" -> <:module_expr< $uid:x1$ >>
- | x1 = "=" -> <:module_expr< $uid:x1$ >> ] ]
- ;
- eqid:
- [ [ x1 = UIDENT; "."; x2 = eqid -> <:expr< $uid:x1$ . $x2$ >>
- | x1 = UIDENT -> <:expr< $uid:x1$ >>
- | x1 = idd -> <:expr< $lid:x1$ >>
- | x1 = "*" -> <:expr< $lid:x1$ >>
- | x1 = "=" -> <:expr< $lid:x1$ >> ] ]
- ;
- sqid:
- [ [ x1 = idd; "."; x2 = sqid -> [x1 :: x2]
- | x1 = idd -> [x1]
- | x1 = "*" -> [x1]
- | x1 = "=" -> [x1] ] ]
- ;
- tycon:
- [ [ LIDENT "real" -> <:ctyp< float >>
- | x1 = idd; "."; x2 = tycon ->
- let r = <:ctyp< $uid:x1$ . $x2$ >> in
- loop r where rec loop =
- fun
- [ <:ctyp< $a$ . ($b$ . $c$) >> -> <:ctyp< $a$ . $b$ . $loop c$ >>
- | x -> x ]
- | x1 = idd -> <:ctyp< $lid:uncap x1$ >> ] ]
- ;
- selector:
- [ [ x1 = id -> x1
- | x1 = INT -> not_impl loc "selector 1" ] ]
- ;
- tlabel:
- [ [ x1 = selector; ":"; x2 = ctyp -> (loc, x1, False, x2) ] ]
- ;
- tuple_ty:
- [ [ x1 = ctyp LEVEL "ty'"; "*"; x2 = tuple_ty -> [x1 :: x2]
- | x1 = ctyp LEVEL "ty'" -> [x1] ] ]
- ;
- ctyp:
- [ RIGHTA
- [ x1 = ctyp; "->"; x2 = ctyp -> <:ctyp< $x1$ -> $x2$ >> ]
- | [ x1 = ctyp; "*"; x2 = tuple_ty -> <:ctyp< ($list:[x1 :: x2]$) >> ]
- | "ty'"
- [ "'"; x1 = LIDENT -> <:ctyp< '$x1$ >>
- | "'"; "'"; x1 = LIDENT -> <:ctyp< '$x1$ >>
- | "{"; x1 = LIST1 tlabel SEP ","; "}" ->
- if ocaml_records.val then <:ctyp< { $list:x1$ } >>
- else
- let list = List.map (fun (_, l, _, t) -> (l, t)) x1 in
- <:ctyp< < $list:list$ > >>
- | "{"; "}" -> not_impl loc "ty' 3"
- | "("; x1 = ctyp; ","; x2 = LIST1 ctyp SEP ","; ")"; x3 = tycon ->
- List.fold_left (fun t1 t2 -> <:ctyp< $t1$ $t2$ >>) x3 [x1 :: x2]
- | "("; x1 = ctyp; ")" -> x1
- | x1 = ctyp; x2 = tycon -> <:ctyp< $x2$ $x1$ >>
- | x1 = tycon -> x1 ] ]
- ;
- rule:
- [ [ x1 = patt; "=>"; x2 = expr -> (x1, None, x2) ] ]
- ;
- elabel:
- [ [ x1 = selector; "="; x2 = expr -> (<:patt< $lid:x1$ >>, x2) ] ]
- ;
- exp_ps:
- [ [ x1 = expr -> x1
- | x1 = expr; ";"; x2 = exp_ps ->
- <:expr< do { $list:[x1 :: get_seq x2]$ } >> ] ]
- ;
- expr:
- [ [ "if"; x1 = expr; "then"; x2 = expr; "else"; x3 = expr ->
- <:expr< if $x1$ then $x2$ else $x3$ >>
- | "fn"; x1 = LIST1 rule SEP "|" -> <:expr< fun [$list:x1$] >>
- | "case"; x1 = expr; "of"; x2 = LIST1 rule SEP "|" ->
- <:expr< match $x1$ with [$list:x2$] >>
- | "while"; x1 = expr; "do"; x2 = expr ->
- <:expr< while $x1$ do { $x2$ } >>
- | x1 = expr; "handle"; x2 = LIST1 rule SEP "|" ->
- <:expr< try $x1$ with [$list:x2$] >> ]
- | RIGHTA
- [ "raise"; x1 = expr -> <:expr< raise $x1$ >> ]
- | [ e1 = expr; ":="; e2 = expr -> <:expr< $e1$.val := $e2$ >> ]
- | LEFTA
- [ x1 = expr; "orelse"; x2 = expr -> <:expr< $x1$ || $x2$ >> ]
- | LEFTA
- [ x1 = expr; "andalso"; x2 = expr -> <:expr< $x1$ && $x2$ >> ]
- | LEFTA
- [ x1 = expr; ":"; x2 = ctyp -> <:expr< ($x1$ : $x2$) >> ]
- | "4" NONA
- [ x1 = expr; "<"; x2 = expr -> <:expr< $x1$ < $x2$ >>
- | x1 = expr; ">"; x2 = expr -> <:expr< $x1$ > $x2$ >>
- | x1 = expr; "<>"; x2 = expr -> <:expr< $x1$ <> $x2$ >>
- | x1 = expr; "="; x2 = expr -> <:expr< $x1$ = $x2$ >>
- | x1 = expr; ">="; x2 = expr -> <:expr< $x1$ >= $x2$ >>
- | x1 = expr; "<="; x2 = expr -> <:expr< $x1$ <= $x2$ >> ]
- | RIGHTA
- [ x1 = expr; "^"; x2 = expr -> <:expr< $x1$ ^ $x2$ >>
- | x1 = expr; "@"; x2 = expr -> <:expr< $x1$ @ $x2$ >>
- | x1 = expr; "o"; x2 = expr -> <:expr< ooo $x1$ $x2$ >> ]
- | "5" RIGHTA
- [ x1 = expr; "::"; x2 = expr -> <:expr< [$x1$ :: $x2$] >> ]
- | "6" LEFTA
- [ x1 = expr; "+"; x2 = expr -> <:expr< $x1$ + $x2$ >>
- | x1 = expr; "-"; x2 = expr -> <:expr< $x1$ - $x2$ >> ]
- | "7" LEFTA
- [ x1 = expr; "*"; x2 = expr -> <:expr< $x1$ * $x2$ >>
- | x1 = expr; "/"; x2 = expr -> <:expr< $x1$ / $x2$ >>
- | x1 = expr; "div"; x2 = expr -> <:expr< $x1$ / $x2$ >>
- | x1 = expr; "mod"; x2 = expr -> <:expr< $x1$ mod $x2$ >> ]
- | LEFTA
- [ x1 = expr; x2 = expr -> <:expr< $x1$ $x2$ >> ]
- | [ "#"; x1 = STRING -> <:expr< $chr:x1$ >>
- | "#"; x1 = selector; x2 = expr ->
- if ocaml_records.val then <:expr< $x2$ . $lid:x1$ >>
- else <:expr< $x2$ # $lid:x1$ >>
- | x1 = expr; "ocaml_record_access"; x2 = expr -> <:expr< $x1$ . $x2$ >> ]
- | [ "!"; x1 = expr -> <:expr< $x1$ . val >>
- | "~"; x1 = expr -> <:expr< - $x1$ >> ]
- | [ x1 = LIDENT ->
- match x1 with
- [ "true" | "false" -> <:expr< $uid:String.capitalize x1$ >>
- | "nil" -> <:expr< [] >>
- | _ -> <:expr< $lid:x1$ >> ]
- | x1 = UIDENT -> <:expr< $uid:x1$ >>
- | x1 = UIDENT; "."; x2 = eqid -> <:expr< $uid:x1$ . $x2$ >>
- | x1 = INT -> <:expr< $int:x1$ >>
- | x1 = FLOAT -> <:expr< $flo:x1$ >>
- | x1 = STRING -> <:expr< $str:x1$ >>
- | "~"; x1 = INT -> <:expr< $int:"-"^x1$ >>
- | i = op ->
- if i = "::" then <:expr< fun (x, y) -> [x :: y] >>
- else <:expr< fun (x, y) -> $lid:i$ x y >>
- | "let"; x1 = ldecs; "in"; x2 = exp_ps; "end" ->
- List.fold_right
- (fun pel x2 ->
- let loc =
- match pel with
- [ [(p, _) :: _] ->
- (fst (MLast.loc_of_patt p), snd (MLast.loc_of_expr x2))
- | _ -> loc ]
- in
- match pel with
- [ [(_, <:expr< fun [$list:_$] >>) :: _] ->
- <:expr< let rec $list:pel$ in $x2$ >>
- | _ ->
- let pel =
- List.map
- (fun (p, e) ->
- match p with
- [ <:patt< { $list:lpl$ } >> ->
- record_match_assoc (MLast.loc_of_patt p) lpl e
- | _ -> (p, e) ])
- pel
- in
- <:expr< let $list:pel$ in $x2$ >> ])
- x1 x2
- | "{"; x1 = LIST1 elabel SEP ","; "}" -> record_expr loc x1
- | "["; "]" -> <:expr< [] >>
- | "["; x1 = expr; "]" -> <:expr< [$x1$] >>
- | "["; x1 = expr; ","; x2 = LIST1 SELF SEP ","; "]" ->
- mklistexp loc None [x1 :: x2]
- | "("; ")" -> <:expr< () >>
- | "("; x1 = expr; ","; x2 = LIST1 SELF SEP ","; ")" ->
- <:expr< ($list:[x1::x2]$) >>
- | "("; x1 = expr; ";"; x2 = LIST1 SELF SEP ";"; ")" ->
- <:expr< do { $list:[x1::x2]$ } >>
- | "("; x1 = expr; ")" -> x1 ] ]
- ;
- fixity:
- [ [ "infix" -> ("infix", None)
- | "infix"; x1 = INT -> not_impl loc "fixity 2"
- | "infixr" -> not_impl loc "fixity 3"
- | "infixr"; x1 = INT -> ("infixr", Some x1)
- | "nonfix" -> not_impl loc "fixity 5" ] ]
- ;
- patt:
- [ [ x1 = patt; "as"; x2 = patt -> <:patt< ($x1$ as $x2$) >> ]
- | LEFTA
- [ x1 = patt; ":"; x2 = ctyp -> <:patt< ($x1$ : $x2$) >> ]
- | RIGHTA
- [ x1 = patt; "::"; x2 = patt -> <:patt< [$x1$ :: $x2$] >> ]
- | [ x1 = patt; x2 = patt ->
- match x1 with
- [ <:patt< ref >> -> <:patt< {contents = $x2$} >>
- | _ -> <:patt< $x1$ $x2$ >> ] ]
- | "apat"
- [ x1 = patt; "."; x2 = patt -> <:patt< $x1$ . $x2$ >>
- | x1 = INT -> <:patt< $int:x1$ >>
- | x1 = UIDENT -> <:patt< $uid:x1$ >>
- | x1 = STRING -> <:patt< $str:x1$ >>
- | "#"; x1 = STRING -> <:patt< $chr:x1$ >>
- | "~"; x1 = INT -> <:patt< $int:"-"^x1$ >>
- | LIDENT "nil" -> <:patt< [] >>
- | LIDENT "false" -> <:patt< False >>
- | LIDENT "true" -> <:patt< True >>
- | x1 = id -> <:patt< $lid:x1$ >>
- | x1 = op -> <:patt< $lid:x1$ >>
- | "_" -> <:patt< _ >>
- | "["; "]" -> <:patt< [] >>
- | "["; x1 = patt; "]" -> <:patt< [$x1$] >>
- | "["; x1 = patt; ","; x2 = LIST1 SELF SEP ","; "]" ->
- mklistpat loc None [x1 :: x2]
- | "{"; x1 = LIST1 plabel SEP ","; "}" -> <:patt< {$list:x1$} >>
- | "("; ")" -> <:patt< () >>
- | "("; x1 = patt; ","; x2 = LIST1 SELF SEP ","; ")" ->
- <:patt< ($list:[x1::x2]$) >>
- | "("; x1 = patt; ")" -> x1 ] ]
- ;
- plabel:
- [ [ x1 = selector; "="; x2 = patt -> (<:patt< $lid:x1$ >>, x2)
- | x1 = selector -> (<:patt< $lid:x1$ >>, <:patt< $lid:x1$ >>) ] ]
- ;
- vb:
- [ [ "lazy"; x1 = patt; "="; x2 = expr -> not_impl loc "vb 1"
- | x1 = patt; "="; x2 = expr -> (x1, x2) ] ]
- ;
- constrain:
- [ [ -> None
- | ":"; x1 = ctyp -> Some x1 ] ]
- ;
- fb:
- [ [ xl = LIST1 clause SEP "|" -> function_of_clause_list loc xl
- | "lazy"; x1 = LIST1 clause SEP "|" -> not_impl loc "fb 2" ] ]
- ;
- clause:
- [ [ x1 = patt LEVEL "apat"; x2 = LIST1 (patt LEVEL "apat");
- x3 = constrain; "="; x4 = expr ->
- let x1 =
- match x1 with
- [ <:patt< $lid:id$ >> -> (id, MLast.loc_of_patt x1)
- | _ -> not_impl loc "clause 1" ]
- in
- (x1, x2, x3, x4) ] ]
- ;
- tb:
- [ [ x1 = tyvars; x2 = idd; "="; x3 = ctyp ->
- ((loc, uncap x2), x1, x3, [])
- | x1 = tyvars; x2 = idd; "="; x3 = ctyp; "=="; x4 = dbrhs ->
- let x4 = List.map (fun (loc, c, tl, _) -> (loc, c, tl)) x4 in
- ((loc, uncap x2), x1, <:ctyp< $x3$ == [ $list:x4$ ] >>, []) ] ]
- ;
- tyvars:
- [ [ "'"; x1 = LIDENT -> [(x1, (False, False))]
- | "("; x1 = tyvar_pc; ")" -> x1
- | -> [] ] ]
- ;
- db1:
- [ [ x1 = tyvars; x2 = ident; "="; x3 = dbrhs ->
- let x2 = uncap x2 in
- extract_label_types loc x2 x1 x3
- | "lazy"; x1 = tyvars; x2 = ident; "="; x3 = dbrhs ->
- not_impl loc "db 2" ] ]
- ;
- db:
- [ [ x1 = LIST1 db1 SEP "and" ->
- List.fold_right (fun td tdl -> td @ tdl) x1 [] ] ]
- ;
- dbrhs:
- [ [ x1 = LIST1 constr SEP "|" -> x1
- | "datatype"; x1 = tycon -> not_impl loc "dbrhs 2" ] ]
- ;
- constr:
- [ [ x1 = op_op; x2 = ident -> (loc, x2, [], None)
- | x1 = op_op; x2 = ident; "of"; x3 = ctyp ->
- match x3 with
- [ <:ctyp< {$list:_$} >> -> (loc, x2, [], Some x3)
- | _ -> (loc, x2, [x3], None) ] ] ]
- ;
- eb:
- [ [ x1 = op_op; x2 = ident -> (x2, [], [])
- | x1 = op_op; x2 = ident; "of"; x3 = ctyp -> (x2, [x3], [])
- | x1 = op_op; x2 = ident; "="; x3 = sqid -> (x2, [], x3) ] ]
- ;
- ldec1:
- [ [ "val"; x1 = LIST1 vb SEP "and" -> x1
- | "fun"; x1 = LIST1 fb SEP "and" -> x1 ] ]
- ;
- ldecs:
- [ [ -> []
- | x1 = ldec1; x2 = ldecs -> [x1 :: x2]
- | ";"; x1 = ldecs -> x1
- | "local"; x1 = ldecs; "in"; x2 = ldecs; "end"; x3 = ldecs ->
- not_impl loc "ldecs 4" ] ]
- ;
- spec_s:
- [ [ -> []
- | x1 = spec; x2 = spec_s -> [x1 :: x2]
- | ";"; x1 = spec_s -> x1 ] ]
- ;
- spec:
- [ [ "structure"; x1 = LIST1 strspec SEP "and" -> sig_declare loc x1
- | "functor"; x1 = LIST1 fctspec SEP "and" -> sig_declare loc x1
- | "datatype"; x1 = db -> <:sig_item< type $list:x1$ >>
- | "type"; x1 = LIST1 tyspec SEP "and" -> <:sig_item< type $list:x1$ >>
- | "eqtype"; x1 = LIST1 tyspec SEP "and" -> <:sig_item< type $list:x1$ >>
- | "val"; x1 = LIST1 valspec SEP "and" -> sig_declare loc x1
- | "exception"; x1 = LIST1 exnspec SEP "and" -> sig_declare loc x1
- | "sharing"; x1 = LIST1 sharespec SEP "and" -> <:sig_item< declare end >>
- | "include"; x1 = module_type -> <:sig_item< include $x1$ >> ] ]
- ;
- sig_item:
- [ [ x = spec -> x ] ]
- ;
- strspec:
- [ [ x1 = ident; ":"; x2 = module_type; x3 = LIST0 sharing_def ->
- let x2 =
- List.fold_left
- (fun mt sdl ->
- List.fold_right
- (fun spl mt ->
- match spl with
- [ Right ([m1], m2) ->
- let (m1, m2) =
- match m2 with
- [ <:module_expr< $uid:x$ . $_$ >> ->
- if x = x1 then (m2, m1) else (m1, m2)
- | _ -> (m1, m2) ]
- in
- let m1 =
- loop m1 where rec loop =
- fun
- [ <:module_expr< $uid:x$ >> -> x
- | <:module_expr< $uid:x$ . $y$ >> -> loop y
- | _ -> not_impl loc "strspec 2" ]
- in
- <:module_type< $mt$ with module $[m1]$ = $m2$ >>
- | _ -> not_impl loc "strspec 1" ])
- sdl mt)
- x2 x3
- in
- <:sig_item< module $x1$ : $x2$ >> ] ]
- ;
- sharing_def:
- [ [ "sharing"; x3 = LIST1 sharespec SEP "and" -> x3 ] ]
- ;
- fctspec:
- [ [ x1 = ident; x2 = fsig -> <:sig_item< module $x1$ : $x2$ >> ] ]
- ;
- tyspec:
- [ [ x1 = tyvars; x2 = idd ->
- ((loc, uncap x2), x1, <:ctyp< '$choose_tvar x1$ >>, [])
- | x1 = tyvars; x2 = idd; "="; x3 = ctyp ->
- ((loc, uncap x2), x1, x3, []) ] ]
- ;
- valspec:
- [ [ x1 = op_op; x2 = ident; ":"; x3 = ctyp ->
- <:sig_item< value $x2$ : $x3$ >> ] ]
- ;
- exnspec:
- [ [ x1 = ident -> <:sig_item< exception $x1$ >>
- | x1 = ident; "of"; x2 = ctyp ->
- <:sig_item< exception $x1$ of $x2$ >> ] ]
- ;
- sharespec:
- [ [ "type"; x1 = patheqn -> Left x1
- | x1 = patheqn -> Right x1 ] ]
- ;
- patheqn:
- [ [ l = patheqn1 -> l ] ]
- ;
- patheqn1:
- [ [ (l, y) = patheqn1; "="; x = qid -> ([y :: l], x)
- | x = qid -> ([], x) ] ]
- ;
- whspec:
- [ [ "type"; x1 = tyvars; x2 = sqid; "="; x3 = ctyp ->
- MLast.WcTyp loc x2 x1 x3
- | x1 = sqid; "="; x2 = qid -> MLast.WcMod loc x1 x2 ] ]
- ;
- module_type:
- [ [ x1 = ident -> <:module_type< $uid:x1$ >>
- | "sig"; x1 = spec_s; "end" -> <:module_type< sig $list:x1$ end >>
- | x1 = module_type; "where"; x2 = LIST1 whspec SEP "and" ->
- <:module_type< $x1$ with $list:x2$ >> ] ]
- ;
- sigconstraint_op:
- [ [ -> None
- | ":"; x1 = module_type -> Some x1
- | ":>"; x1 = module_type -> not_impl loc "sigconstraint_op 3" ] ]
- ;
- sigb:
- [ [ x1 = ident; "="; x2 = module_type ->
- <:str_item< module type $x1$ = $x2$ >> ] ]
- ;
- fsig:
- [ [ ":"; x1 = ident -> not_impl loc "fsig 1"
- | x1 = fparamList; ":"; x2 = module_type -> not_impl loc "fsig 2" ] ]
- ;
- module_expr:
- [ [ x1 = qid -> x1
- | "struct"; x1 = strdecs; "end" -> <:module_expr< struct $list:x1$ end >>
- | x1 = qid; x2 = arg_fct ->
- match x2 with
- [ Left [] -> x1
- | Left x2 -> <:module_expr< $x1$ (struct $list:x2$ end) >>
- | Right x2 -> <:module_expr< $x1$ $x2$ >> ]
- | "let"; x1 = strdecs; "in"; x2 = module_expr; "end" ->
- not_impl loc "str 4"
- | x1 = module_expr; ":"; x2 = module_type -> not_impl loc "str 5"
- | x1 = module_expr; x2 = ":>"; x3 = module_type ->
- not_impl loc "str 6" ] ]
- ;
- arg_fct:
- [ [ "("; x1 = strdecs; ")"; x2 = arg_fct -> not_impl loc "arg_fct 1"
- | "("; x1 = module_expr; ")"; x2 = arg_fct -> not_impl loc "arg_fct 2"
- | "("; x1 = module_expr; ")" -> Right x1
- | "("; x2 = strdecs; ")" -> Left x2 ] ]
- ;
- strdecs:
- [ [ x1 = str_item LEVEL "strdec"; x2 = strdecs -> [x1 :: x2]
- | ";"; x1 = strdecs -> x1
- | -> [] ] ]
- ;
- str_item:
- [ [ "signature"; x1 = LIST1 sigb SEP "and" -> str_declare loc x1
- | "funsig"; x1 = fsigb -> not_impl loc "sdec 3" ]
- | "strdec"
- [ "structure"; x1 = LIST1 strb SEP "and" -> str_declare loc x1
- | "functor"; x1 = LIST1 fctb SEP "and" -> str_declare loc x1
- | "local"; x1 = sdecs; "in"; x2 = sdecs; "end" ->
- make_local loc x1 x2 ]
- | [ "val"; x1 = LIST1 vb SEP "and" -> <:str_item< value $list:x1$ >>
- | "val"; x1 = tyvarseq; x3 = LIST1 vb SEP "and" ->
- not_impl loc "ldec 2"
- | "val"; "rec"; x1 = rvb -> not_impl loc "ldec 3"
- | "val"; "rec"; x1 = tyvarseq; x2 = rvb -> not_impl loc "ldec 4"
- | "fun"; x1 = LIST1 fb SEP "and" -> <:str_item< value rec $list:x1$ >>
- | "fun"; x1 = tyvarseq; x2 = fb -> not_impl loc "ldec 6"
- | "type"; x1 = LIST1 tb SEP "and" -> <:str_item< type $list:x1$ >>
- | "datatype"; x1 = db -> <:str_item< type $list:x1$ >>
- | "datatype"; x1 = db; "withtype"; x2 = tb ->
- <:str_item< type $list:x1 @ [x2]$ >>
- | "abstype"; x1 = db; "with"; x2 = ldecs; "end" -> not_impl loc "ldec 10"
- | "abstype"; x1 = db; "withtype"; x2 = tb; "with"; x3 = ldecs; "end" ->
- not_impl loc "ldec 11"
- | "exception"; x1 = LIST1 eb SEP "and" ->
- let dl =
- List.map
- (fun (s, tl, eqn) ->
- <:str_item< exception $s$ of $list:tl$ = $eqn$ >>)
- x1
- in
- str_declare loc dl
- | "open"; x1 = LIST1 sqid ->
- let dl = List.map (fun sl -> <:str_item< open $sl$ >>) x1 in
- str_declare loc dl
- | LIDENT "use"; s = STRING ->
- <:str_item< #use $str:s$ >>
- | x1 = fixity; list = LIST1 idd ->
- match x1 with
- [ ("infixr", Some n) ->
- do {
- List.iter
- (fun s ->
- EXTEND
- expr: LEVEL $n$
- [ [ x1 = expr; $s$; x2 = expr ->
- <:expr< $lid:s$ ($x1$, $x2$) >> ] ]
- ;
- END)
- list;
- str_declare loc []
- }
- | ("infix", None) ->
- do {
- List.iter
- (fun s ->
- EXTEND
- expr: LEVEL "4"
- [ [ x1 = expr; $s$; x2 = expr ->
- <:expr< $lid:s$ ($x1$, $x2$) >> ] ]
- ;
- clause:
- [ [ x1 = patt LEVEL "apat"; $s$;
- x2 = patt LEVEL "apat"; "="; x4 = expr ->
- ((s, loc), [<:patt< ($x1$, $x2$) >>],
- None, x4) ] ]
- ;
- END)
- list;
- str_declare loc []
- }
- | _ -> not_impl loc "ldec 14" ]
- | "overload"; x1 = ident; ":"; x2 = ctyp; "as"; x3 = exp_pa ->
- not_impl loc "ldec 15"
- | x = expr -> <:str_item< $exp:x$ >> ] ]
- ;
- sdec:
- [ [ x = str_item -> x ] ]
- ;
- strb:
- [ [ x1 = ident; x2 = sigconstraint_op; "="; x3 = module_expr ->
- let x3 =
- match x2 with
- [ Some x2 -> <:module_expr< ($x3$ : $x2$) >>
- | None -> x3 ]
- in
- <:str_item< module $x1$ = $x3$ >> ] ]
- ;
- fparam:
- [ [ x1 = idd; ":"; x2 = module_type -> [<:sig_item< module $x1$ : $x2$ >>]
- | x1 = spec_s -> x1 ] ]
- ;
- fparamList:
- [ [ "("; x1 = fparam; ")" -> [x1]
- | "("; x1 = fparam; ")"; x2 = fparamList -> [x1 :: x2] ] ]
- ;
- fctb:
- [ [ x1 = ident; x2 = fparamList; x3 = sigconstraint_op; "=";
- x4 = module_expr ->
- let list = List.flatten x2 in
- let x4 =
- if list = [] then x4
- else
- match x4 with
- [ <:module_expr< struct $list:list$ end >> ->
- let si = let loc = (0, 0) in <:str_item< open AAA >> in
- <:module_expr< struct $list:[si :: list]$ end >>
- | _ -> not_impl loc "fctb 1" ]
- in
- let x4 =
- match x3 with
- [ Some x3 -> <:module_expr< ($x4$ : $x3$) >>
- | None -> x4 ]
- in
- let x4 =
- if list = [] then x4
- else
- let mt =
- let loc =
- (fst (MLast.loc_of_sig_item (List.hd list)),
- snd (MLast.loc_of_sig_item (List.hd (List.rev list))))
- in
- <:module_type< sig $list:list$ end >>
- in
- <:module_expr< functor (AAA : $mt$) -> $x4$ >>
- in
- <:str_item< module $x1$ = $x4$ >>
- | x1 = ident; x2 = fsigconstraint_op; "="; x3 = fct_exp ->
- not_impl loc "fctb 2" ] ]
- ;
- interdec:
- [ [ x = LIST1 [ s = str_item; OPT ";" -> (s, loc) ] -> (x, False)
- | x = expr; OPT ";" -> not_impl loc "interdec 2" ] ]
- ;
-END;
-
-Pcaml.add_option "-records" (Arg.Set ocaml_records)
- "Convert record into OCaml records, instead of objects";
diff --git a/camlp4/etc/parserify.ml b/camlp4/etc/parserify.ml
deleted file mode 100644
index c8ce441714..0000000000
--- a/camlp4/etc/parserify.ml
+++ /dev/null
@@ -1,301 +0,0 @@
-(* camlp4r q_MLast.cmo *)
-(* $Id$ *)
-
-value loc = (0, 0);
-
-type spc =
- [ SPCterm of (MLast.patt * option MLast.expr)
- | SPCnterm of MLast.patt and MLast.expr
- | SPCsterm of MLast.patt ]
-;
-
-exception NotImpl;
-
-value rec subst v e =
- match e with
- [ <:expr< $lid:x$ >> -> if x = "strm__" then <:expr< $lid:v$ >> else e
- | <:expr< $uid:_$ >> -> e
- | <:expr< $int:_$ >> -> e
- | <:expr< $chr:_$ >> -> e
- | <:expr< $str:_$ >> -> e
- | <:expr< $e1$ . $lab$ >> -> <:expr< $subst v e1$ . $lab$ >>
- | <:expr< $x$ $y$ >> -> <:expr< $subst v x$ $subst v y$ >>
- | <:expr< let $lid:s1$ = $e1$ in $e2$ >> ->
- if s1 = v then <:expr< let $lid:s1$ = $subst v e1$ in $e2$ >>
- else <:expr< let $lid:s1$ = $subst v e1$ in $subst v e2$ >>
- | <:expr< let _ = $e1$ in $e2$ >> ->
- <:expr< let _ = $subst v e1$ in $subst v e2$ >>
- | <:expr< ($list:el$) >> -> <:expr< ($list:List.map (subst v) el$) >>
- | _ -> raise NotImpl ]
-;
-
-value rec is_free v =
- fun
- [ <:expr< $lid:x$ >> -> x <> v
- | <:expr< $uid:_$ >> -> True
- | <:expr< $int:_$ >> -> True
- | <:expr< $chr:_$ >> -> True
- | <:expr< $str:_$ >> -> True
- | <:expr< $e$ . $_$ >> -> is_free v e
- | <:expr< $x$ $y$ >> -> is_free v x && is_free v y
- | <:expr< let $lid:s1$ = $e1$ in $e2$ >> ->
- is_free v e1 && (s1 = v || is_free v e2)
- | <:expr< let _ = $e1$ in $e2$ >> -> is_free v e1 && is_free v e2
- | <:expr< ($list:el$) >> -> List.for_all (is_free v) el
- | _ -> raise NotImpl ]
-;
-
-value gensym =
- let cnt = ref 0 in
- fun () ->
- do { incr cnt; "pr_rp_symb_" ^ string_of_int cnt.val }
-;
-
-value free_var_in_expr c e =
- let rec loop_alpha v =
- let x = String.make 1 v in
- if is_free x e then Some x
- else if v = 'z' then None
- else loop_alpha (Char.chr (Char.code v + 1))
- in
- let rec loop_count cnt =
- let x = String.make 1 c ^ string_of_int cnt in
- if is_free x e then x else loop_count (succ cnt)
- in
- try
- match loop_alpha c with
- [ Some v -> v
- | None -> loop_count 1 ]
- with
- [ NotImpl -> gensym () ]
-;
-
-value parserify =
- fun
- [ <:expr< $e$ strm__ >> -> e
- | e -> <:expr< fun strm__ -> $e$ >> ]
-;
-
-value is_raise_failure =
- fun
- [ <:expr< raise Stream.Failure >> -> True
- | _ -> False ]
-;
-
-value is_raise_error =
- fun
- [ <:expr< raise (Stream.Error $_$) >> -> True
- | _ -> False ]
-;
-
-value semantic e =
- try
- if is_free "strm__" e then e
- else
- let v = free_var_in_expr 's' e in
- <:expr< let $lid:v$ = strm__ in $subst v e$ >>
- with
- [ NotImpl -> e ]
-;
-
-value rewrite_parser =
- rewrite True where rec rewrite top ge =
- match ge with
- [ <:expr< let $p$ = try $e$ with [ Stream.Failure -> raise $exc$ ] in
- $sp_kont$ >> ->
- let f = parserify e in
- <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some $p$ -> $rewrite False sp_kont$
- | _ -> raise $exc$ ]
- >>
- | <:expr< let $p$ = Stream.count strm__ in $f$ >> ->
- try
- if is_free "strm__" f then ge
- else
- let v = free_var_in_expr 's' f in
- <:expr<
- let $lid:v$ = strm__ in
- let $p$ = Stream.count strm__ in $subst v f$
- >>
- with
- [ NotImpl -> ge ]
- | <:expr< let $p$ = strm__ in $e$ >> ->
- <:expr< let $p$ = strm__ in $rewrite False e$ >>
- | <:expr< let $p$ = $f$ strm__ in $sp_kont$ >> when top ->
- <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some $p$ -> $rewrite False sp_kont$
- | _ -> raise Stream.Failure ]
- >>
- | <:expr< let $p$ = $e$ in $sp_kont$ >> ->
- if match e with
- [ <:expr< match try Some $_$ with [ Stream.Failure -> None ] with
- [ $list:_$ ] >>
- | <:expr< match Stream.peek strm__ with [ $list:_$ ] >>
- | <:expr< try $_$ with [ Stream.Failure -> $_$ ] >>
- | <:expr< let $_$ = Stream.count strm__ in $_$ >> -> True
- | _ -> False ]
- then
- let f = rewrite True <:expr< fun strm__ -> $e$ >> in
- let exc =
- if top then <:expr< Stream.Failure >>
- else <:expr< Stream.Error "" >>
- in
- <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some $p$ -> $rewrite False sp_kont$
- | _ -> raise $exc$ ]
- >>
- else semantic ge
- | <:expr< match try Some $e$ with [ Stream.Failure -> None ] with
- [ Some $p$ -> $sp_kont$
- | _ -> $p_kont$ ] >> ->
- let f = parserify e in
- if not top && is_raise_failure p_kont then semantic ge
- else
- let (p, f, sp_kont, p_kont) =
- if top || is_raise_error p_kont then
- (p, f, rewrite False sp_kont, rewrite top p_kont)
- else
- let f =
- <:expr<
- fun strm__ ->
- match
- try Some ($f$ strm__) with [ Stream.Failure -> None ]
- with
- [ Some $p$ -> $rewrite False sp_kont$
- | _ -> $rewrite top p_kont$ ]
- >>
- in
- (<:patt< a >>, f, <:expr< a >>,
- <:expr< raise (Stream.Error "") >>)
- in
- <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some $p$ -> $sp_kont$
- | _ -> $p_kont$ ]
- >>
- | <:expr< match Stream.peek strm__ with [ $list:pel$ ] >> ->
- let rec iter pel =
- match pel with
- [ [(<:patt< Some $p$ >>, eo,
- <:expr< do { Stream.junk strm__; $sp_kont$ } >>);
- (<:patt< _ >>, None, p_kont) :: _] ->
- <:expr<
- match Stream.peek strm__ with
- [ Some $p$ $when:eo$ ->
- do { Stream.junk strm__; $rewrite False sp_kont$ }
- | _ -> $rewrite top p_kont$ ]
- >>
- | [(<:patt< Some $p$ >>, eo,
- <:expr< do { Stream.junk strm__; $sp_kont$ } >>) :: pel] ->
- let p_kont = iter pel in
- <:expr<
- match Stream.peek strm__ with
- [ Some $p$ $when:eo$ ->
- do { Stream.junk strm__; $rewrite False sp_kont$ }
- | _ -> $p_kont$ ]
- >>
- | _ ->
- <:expr< match Stream.peek strm__ with [ $list:pel$ ] >> ]
- in
- iter pel
- | <:expr< try Some $e$ with [ Stream.Failure -> $p_kont$ ] >> ->
- let f = parserify e in
- let e =
- <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some a -> Some a
- | _ -> $p_kont$ ]
- >>
- in
- rewrite top e
- | <:expr< try $e$ with [ Stream.Failure -> $p_kont$ ] >> ->
- let f = parserify e in
- let e =
- <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some a -> a
- | _ -> $rewrite top p_kont$ ]
- >>
- in
- rewrite top e
- | <:expr< $f$ strm__ >> ->
- if top then
- <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some a -> a
- | _ -> raise Stream.Failure ]
- >>
- else
- let v = free_var_in_expr 's' f in
- <:expr< let $lid:v$ = strm__ in $subst v f$ $lid:v$ >>
- | e -> semantic e ]
-;
-
-value spc_of_parser =
- let rec parser_cases e =
- match e with
- [ <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some $p$ -> $sp_kont$
- | _ -> $p_kont$ ]
- >> ->
- let spc = (SPCnterm p f, None) in
- let (sp, epo, e) = kont sp_kont in
- [([spc :: sp], epo, e) :: parser_cases p_kont]
- | <:expr<
- match Stream.peek strm__ with
- [ Some $p$ $when:wo$ -> do { Stream.junk strm__; $sp_kont$ }
- | _ -> $p_kont$ ]
- >> ->
- let spc = (SPCterm (p, wo), None) in
- let (sp, epo, e) = kont sp_kont in
- [([spc :: sp], epo, e) :: parser_cases p_kont]
- | <:expr< let $p$ = strm__ in $sp_kont$ >> ->
- let spc = (SPCsterm p, None) in
- let (sp, epo, e) = kont sp_kont in
- [([spc :: sp], epo, e)]
- | <:expr< let $p$ = Stream.count strm__ in $e$ >> -> [([], Some p, e)]
- | <:expr< raise Stream.Failure >> -> []
- | _ -> [([], None, e)] ]
- and kont e =
- match e with
- [ <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some $p$ -> $sp_kont$
- | _ -> raise (Stream.Error $err$) ]
- >> ->
- let err =
- match err with
- [ <:expr< "" >> -> None
- | _ -> Some err ]
- in
- let spc = (SPCnterm p f, err) in
- let (sp, epo, e) = kont sp_kont in
- ([spc :: sp], epo, e)
- | <:expr<
- match Stream.peek strm__ with
- [ Some $p$ $when:wo$ -> do { Stream.junk strm__; $sp_kont$ }
- | _ -> raise (Stream.Error $err$) ]
- >> ->
- let err =
- match err with
- [ <:expr< "" >> -> None
- | _ -> Some err ]
- in
- let spc = (SPCterm (p, wo), err) in
- let (sp, epo, e) = kont sp_kont in
- ([spc :: sp], epo, e)
- | <:expr< let $p$ = strm__ in $sp_kont$ >> ->
- let spc = (SPCsterm p, None) in
- let (sp, epo, e) = kont sp_kont in
- ([spc :: sp], epo, e)
- | <:expr< let $p$ = Stream.count strm__ in $e$ >> -> ([], Some p, e)
- | _ -> ([], None, e) ]
- in
- parser_cases
-;
-
-value parser_of_expr e = spc_of_parser (rewrite_parser e);
diff --git a/camlp4/etc/parserify.mli b/camlp4/etc/parserify.mli
deleted file mode 100644
index ece8b8927f..0000000000
--- a/camlp4/etc/parserify.mli
+++ /dev/null
@@ -1,12 +0,0 @@
-(* camlp4r *)
-(* $Id$ *)
-
-type spc =
- [ SPCterm of (MLast.patt * option MLast.expr)
- | SPCnterm of MLast.patt and MLast.expr
- | SPCsterm of MLast.patt ]
-;
-
-value parser_of_expr :
- MLast.expr ->
- list (list (spc * option MLast.expr) * option MLast.patt * MLast.expr);
diff --git a/camlp4/etc/pr_depend.ml b/camlp4/etc/pr_depend.ml
deleted file mode 100644
index 0cf6e4412f..0000000000
--- a/camlp4/etc/pr_depend.ml
+++ /dev/null
@@ -1,327 +0,0 @@
-(* camlp4r *)
-(* $Id$ *)
-
-open MLast;
-
-value not_impl name x =
- let desc =
- if Obj.is_block (Obj.repr x) then
- "tag = " ^ string_of_int (Obj.tag (Obj.repr x))
- else "int_val = " ^ string_of_int (Obj.magic x)
- in
- do {
- Printf.eprintf "pr_depend: not impl: %s; %s\n" name desc; flush stderr;
- }
-;
-
-module StrSet =
- Set.Make (struct type t = string; value compare = compare; end)
-;
-
-value fset = ref StrSet.empty;
-value addmodule s = fset.val := StrSet.add s fset.val;
-
-value list = List.iter;
-
-value option f =
- fun
- [ Some x -> f x
- | None -> () ]
-;
-
-value longident =
- fun
- [ [s; _ :: _] -> addmodule s
- | _ -> () ]
-;
-
-value rec ctyp =
- fun
- [ TyAcc _ t _ -> ctyp_module t
- | TyAli _ t1 t2 -> do { ctyp t1; ctyp t2; }
- | TyApp _ t1 t2 -> do { ctyp t1; ctyp t2; }
- | TyAny _ -> ()
- | TyArr _ t1 t2 -> do { ctyp t1; ctyp t2; }
- | TyCls _ li -> longident li
- | TyLab _ _ t -> ctyp t
- | TyLid _ _ -> ()
- | TyMan _ t1 t2 -> do { ctyp t1; ctyp t2; }
- | TyOlb _ _ t -> ctyp t
- | TyQuo _ _ -> ()
- | TyRec _ _ ldl -> list label_decl ldl
- | TySum _ _ cdl -> list constr_decl cdl
- | TyTup _ tl -> list ctyp tl
- | TyVrn _ sbtll _ -> list variant sbtll
- | x -> not_impl "ctyp" x ]
-and constr_decl (_, _, tl) = list ctyp tl
-and label_decl (_, _, _, t) = ctyp t
-and variant =
- fun
- [ RfTag _ _ tl -> list ctyp tl
- | RfInh t -> ctyp t ]
-and ctyp_module =
- fun
- [ TyAcc _ t _ -> ctyp_module t
- | TyApp _ t1 t2 -> do { ctyp t1; ctyp t2; }
- | TyUid _ m -> addmodule m
- | x -> not_impl "ctyp_module" x ]
-;
-
-value rec patt =
- fun
- [ PaAcc _ p _ -> patt_module p
- | PaAli _ p1 p2 -> do { patt p1; patt p2; }
- | PaAny _ -> ()
- | PaApp _ p1 p2 -> do { patt p1; patt p2; }
- | PaArr _ pl -> list patt pl
- | PaChr _ _ -> ()
- | PaInt _ _ -> ()
- | PaLab _ _ po -> option patt po
- | PaLid _ _ -> ()
- | PaOlb _ _ peoo ->
- option (fun (p, eo) -> do { patt p; option expr eo }) peoo
- | PaOrp _ p1 p2 -> do { patt p1; patt p2; }
- | PaRec _ lpl -> list label_patt lpl
- | PaRng _ p1 p2 -> do { patt p1; patt p2; }
- | PaStr _ _ -> ()
- | PaTup _ pl -> list patt pl
- | PaTyc _ p t -> do { patt p; ctyp t; }
- | PaUid _ _ -> ()
- | PaVrn _ _ -> ()
- | x -> not_impl "patt" x ]
-and patt_module =
- fun
- [ PaUid _ m -> addmodule m
- | PaAcc _ p _ -> patt_module p
- | x -> not_impl "patt_module" x ]
-and label_patt (p1, p2) = do { patt p1; patt p2; }
-and expr =
- fun
- [ ExAcc _ e1 e2 -> do { expr_module e1; expr e2; }
- | ExApp _ e1 e2 -> do { expr e1; expr e2; }
- | ExAre _ e1 e2 -> do { expr e1; expr e2; }
- | ExArr _ el -> list expr el
- | ExAsf _ -> ()
- | ExAsr _ e -> do { expr e; }
- | ExAss _ e1 e2 -> do { expr e1; expr e2; }
- | ExChr _ _ -> ()
- | ExCoe _ e t1 t2 -> do { expr e; option ctyp t1; ctyp t2 }
- | ExFor _ _ e1 e2 _ el -> do { expr e1; expr e2; list expr el; }
- | ExFun _ pwel -> list match_case pwel
- | ExIfe _ e1 e2 e3 -> do { expr e1; expr e2; expr e3; }
- | ExInt _ _ -> ()
- | ExInt32 _ _ -> ()
- | ExInt64 _ _ -> ()
- | ExNativeInt _ _ -> ()
- | ExFlo _ _ -> ()
- | ExLab _ _ eo -> option expr eo
- | ExLaz _ e -> expr e
- | ExLet _ _ pel e -> do { list let_binding pel; expr e; }
- | ExLid _ _ -> ()
- | ExLmd _ _ me e -> do { module_expr me; expr e; }
- | ExMat _ e pwel -> do { expr e; list match_case pwel; }
- | ExNew _ li -> longident li
- | ExOlb _ _ eo -> option expr eo
- | ExRec _ lel w -> do { list label_expr lel; option expr w; }
- | ExSeq _ el -> list expr el
- | ExSnd _ e _ -> expr e
- | ExSte _ e1 e2 -> do { expr e1; expr e2; }
- | ExStr _ _ -> ()
- | ExTry _ e pwel -> do { expr e; list match_case pwel; }
- | ExTup _ el -> list expr el
- | ExTyc _ e t -> do { expr e; ctyp t; }
- | ExUid _ _ -> ()
- | ExVrn _ _ -> ()
- | ExWhi _ e el -> do { expr e; list expr el; }
- | x -> not_impl "expr" x ]
-and expr_module =
- fun
- [ ExUid _ m -> addmodule m
- | e -> expr e ]
-and let_binding (p, e) = do { patt p; expr e }
-and label_expr (p, e) = do { patt p; expr e }
-and match_case (p, w, e) = do { patt p; option expr w; expr e; }
-and module_type =
- fun
- [ MtAcc _ (MtUid _ m) _ -> addmodule m
- | MtFun _ _ mt1 mt2 -> do { module_type mt1; module_type mt2; }
- | MtSig _ sil -> list sig_item sil
- | MtUid _ _ -> ()
- | MtWit _ mt wc -> do { module_type mt; list with_constr wc; }
- | x -> not_impl "module_type" x ]
-and with_constr =
- fun
- [ WcTyp _ _ _ t -> ctyp t
- | x -> not_impl "with_constr" x ]
-and sig_item =
- fun
- [ SgDcl _ sil -> list sig_item sil
- | SgExc _ _ tl -> list ctyp tl
- | SgExt _ _ t _ -> ctyp t
- | SgMod _ _ mt -> module_type mt
- | SgRecMod _ mts -> list (fun (_, mt) -> module_type mt) mts
- | SgMty _ _ mt -> module_type mt
- | SgOpn _ [s :: _] -> addmodule s
- | SgTyp _ tdl -> list type_decl tdl
- | SgVal _ _ t -> ctyp t
- | x -> not_impl "sig_item" x ]
-and module_expr =
- fun
- [ MeAcc _ (MeUid _ m) _ -> addmodule m
- | MeApp _ me1 me2 -> do { module_expr me1; module_expr me2; }
- | MeFun _ _ mt me -> do { module_type mt; module_expr me; }
- | MeStr _ sil -> list str_item sil
- | MeTyc _ me mt -> do { module_expr me; module_type mt; }
- | MeUid _ _ -> ()
- | x -> not_impl "module_expr" x ]
-and str_item =
- fun
- [ StCls _ cil -> list (fun ci -> class_expr ci.ciExp) cil
- | StDcl _ sil -> list str_item sil
- | StDir _ _ _ -> ()
- | StExc _ _ tl _ -> list ctyp tl
- | StExp _ e -> expr e
- | StExt _ _ t _ -> ctyp t
- | StMod _ _ me -> module_expr me
- | StRecMod _ nmtmes -> list (fun (_, mt, me) -> do { module_expr me; module_type mt; }) nmtmes
- | StMty _ _ mt -> module_type mt
- | StOpn _ [s :: _] -> addmodule s
- | StTyp _ tdl -> list type_decl tdl
- | StVal _ _ pel -> list let_binding pel
- | x -> not_impl "str_item" x ]
-and type_decl (_, _, t, _) = ctyp t
-and class_expr =
- fun
- [ CeApp _ ce e -> do { class_expr ce; expr e; }
- | CeCon _ li tl -> do { longident li; list ctyp tl; }
- | CeFun _ p ce -> do { patt p; class_expr ce; }
- | CeLet _ _ pel ce -> do { list let_binding pel; class_expr ce; }
- | CeStr _ po csil -> do { option patt po; list class_str_item csil; }
- | x -> not_impl "class_expr" x ]
-and class_str_item =
- fun
- [ CrInh _ ce _ -> class_expr ce
- | CrIni _ e -> expr e
- | CrMth _ _ _ e None -> expr e
- | CrMth _ _ _ e (Some t) -> do { expr e; ctyp t }
- | CrVal _ _ _ e -> expr e
- | CrVir _ _ _ t -> ctyp t
- | x -> not_impl "class_str_item" x ]
-;
-
-(* Print dependencies *)
-
-value load_path = ref [""];
-
-value find_in_path path name =
- if not (Filename.is_implicit name) then
- if Sys.file_exists name then name else raise Not_found
- else
- let rec try_dir =
- fun
- [ [] -> raise Not_found
- | [dir :: rem] ->
- let fullname = Filename.concat dir name in
- if Sys.file_exists fullname then fullname else try_dir rem ]
- in
- try_dir path
-;
-
-value find_depend modname (byt_deps, opt_deps) =
- let name = String.uncapitalize modname in
- try
- let filename = find_in_path load_path.val (name ^ ".mli") in
- let basename = Filename.chop_suffix filename ".mli" in
- let byt_dep = basename ^ ".cmi" in
- let opt_dep =
- if Sys.file_exists (basename ^ ".ml") then basename ^ ".cmx"
- else basename ^ ".cmi"
- in
- ([byt_dep :: byt_deps], [opt_dep :: opt_deps])
- with
- [ Not_found ->
- try
- let filename = find_in_path load_path.val (name ^ ".ml") in
- let basename = Filename.chop_suffix filename ".ml" in
- ([basename ^ ".cmo" :: byt_deps], [basename ^ ".cmx" :: opt_deps])
- with
- [ Not_found -> (byt_deps, opt_deps) ] ]
-;
-
-value (depends_on, escaped_eol) =
- match Sys.os_type with
- [ "Unix" | "Win32" | "Cygwin" -> (": ", "\\\n ")
- | "MacOS" -> ("\196 ", "\182\n ")
- | _ -> assert False ]
-;
-
-value print_depend target_file deps =
- match deps with
- [ [] -> ()
- | _ ->
- do {
- print_string target_file;
- print_string depends_on;
- let rec print_items pos =
- fun
- [ [] -> print_string "\n"
- | [dep :: rem] ->
- if pos + String.length dep <= 77 then do {
- print_string dep;
- print_string " ";
- print_items (pos + String.length dep + 1) rem
- }
- else do {
- print_string escaped_eol;
- print_string dep;
- print_string " ";
- print_items (String.length dep + 5) rem
- } ]
- in
- print_items (String.length target_file + 2) deps
- } ]
-;
-
-(* Main *)
-
-value depend_sig ast =
- do {
- fset.val := StrSet.empty;
- List.iter (fun (si, _) -> sig_item si) ast;
- let basename = Filename.chop_suffix Pcaml.input_file.val ".mli" in
- let (byt_deps, opt_deps) = StrSet.fold find_depend fset.val ([], []) in
- print_depend (basename ^ ".cmi") byt_deps;
- }
-;
-
-value depend_str ast =
- do {
- fset.val := StrSet.empty;
- List.iter (fun (si, _) -> str_item si) ast;
- let basename =
- if Filename.check_suffix Pcaml.input_file.val ".ml" then
- Filename.chop_suffix Pcaml.input_file.val ".ml"
- else
- try
- let len = String.rindex Pcaml.input_file.val '.' in
- String.sub Pcaml.input_file.val 0 len
- with
- [ Failure _ | Not_found -> Pcaml.input_file.val ]
- in
- let init_deps =
- if Sys.file_exists (basename ^ ".mli") then
- let cmi_name = basename ^ ".cmi" in ([cmi_name], [cmi_name])
- else ([], [])
- in
- let (byt_deps, opt_deps) = StrSet.fold find_depend fset.val init_deps in
- print_depend (basename ^ ".cmo") byt_deps;
- print_depend (basename ^ ".cmx") opt_deps;
- }
-;
-
-Pcaml.print_interf.val := depend_sig;
-Pcaml.print_implem.val := depend_str;
-
-Pcaml.add_option "-I"
- (Arg.String (fun dir -> load_path.val := load_path.val @ [dir]))
- "<dir> Add <dir> to the list of include directories.";
diff --git a/camlp4/etc/pr_extend.ml b/camlp4/etc/pr_extend.ml
deleted file mode 100644
index 43e3794e17..0000000000
--- a/camlp4/etc/pr_extend.ml
+++ /dev/null
@@ -1,514 +0,0 @@
-(* camlp4r q_MLast.cmo ./pa_extfun.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Pcaml;
-open Spretty;
-
-value no_slist = ref False;
-
-value expr e dg k = pr_expr.pr_fun "top" e dg k;
-value patt e dg k = pr_patt.pr_fun "top" e dg k;
-
-(* Utilities *)
-
-value rec list elem el k =
- match el with
- [ [] -> k
- | [x] -> [: `elem x k :]
- | [x :: l] -> [: `elem x [: :]; list elem l k :] ]
-;
-
-value rec listws elem sep el k =
- match el with
- [ [] -> k
- | [x] -> [: `elem x k :]
- | [x :: l] -> [: `elem x [: `sep :]; listws elem sep l k :] ]
-;
-
-value rec listwbws elem b sep el dg k =
- match el with
- [ [] -> [: b; k :]
- | [x] -> [: `elem b x dg k :]
- | [x :: l] ->
- let sdg =
- match sep with
- [ S _ x -> x
- | _ -> "" ]
- in
- [: `elem b x sdg [: :]; listwbws elem [: `sep :] sep l dg k :] ]
-;
-
-(* Extracting *)
-
-value rec get_globals =
- fun
- [ [(<:patt< _ >>, <:expr< ($e$ : $uid:gmod1$.Entry.e '$_$) >>) :: pel] ->
- let (gmod, gl) = get_globals pel in
- if gmod = "" || gmod = gmod1 then (gmod1, [e :: gl])
- else raise Not_found
- | [] -> ("", [])
- | _ -> raise Not_found ]
-;
-
-value rec get_locals =
- fun
- [ [(<:patt< $_$ >>,
- <:expr< (grammar_entry_create $_$ : $_$) >>) :: pel] ->
- get_locals pel
- | [] -> ()
- | _ -> raise Not_found ]
-;
-
-value unposition =
- fun
- [ <:expr< None >> -> None
- | <:expr< Some Gramext.First >> -> Some Gramext.First
- | <:expr< Some Gramext.Last >> -> Some Gramext.Last
- | <:expr< Some (Gramext.Before $str:s$) >> -> Some (Gramext.Before s)
- | <:expr< Some (Gramext.After $str:s$) >> -> Some (Gramext.After s)
- | <:expr< Some (Gramext.Level $str:s$) >> -> Some (Gramext.Level s)
- | _ -> raise Not_found ]
-;
-
-value unlabel =
- fun
- [ <:expr< None >> -> None
- | <:expr< Some $str:s$ >> -> Some s
- | _ -> raise Not_found ]
-;
-
-value unassoc =
- fun
- [ <:expr< None >> -> None
- | <:expr< Some Gramext.NonA >> -> Some Gramext.NonA
- | <:expr< Some Gramext.LeftA >> -> Some Gramext.LeftA
- | <:expr< Some Gramext.RightA >> -> Some Gramext.RightA
- | _ -> raise Not_found ]
-;
-
-value rec unaction =
- fun
- [ <:expr< fun ($lid:locp$ : (int * int)) -> ($a$ : $_$) >>
- when locp = Stdpp.loc_name.val ->
- let ao =
- match a with
- [ <:expr< () >> -> None
- | _ -> Some a ]
- in
- ([], ao)
- | <:expr< fun ($p$ : $_$) -> $e$ >> ->
- let (pl, a) = unaction e in ([p :: pl], a)
- | <:expr< fun _ -> $e$ >> ->
- let (pl, a) = unaction e in
- (let loc = (0, 0) in [<:patt< _ >> :: pl], a)
- | _ -> raise Not_found ]
-;
-
-value untoken =
- fun
- [ <:expr< ($str:x$, $str:y$) >> -> (x, y)
- | _ -> raise Not_found ]
-;
-
-type symbol =
- [ Snterm of MLast.expr
- | Snterml of MLast.expr and string
- | Slist0 of symbol
- | Slist0sep of symbol and symbol
- | Slist1 of symbol
- | Slist1sep of symbol and symbol
- | Sopt of symbol
- | Sself
- | Snext
- | Stoken of Token.pattern
- | Srules of list (list (option MLast.patt * symbol) * option MLast.expr) ]
-;
-
-value rec unsymbol =
- fun
- [ <:expr< Gramext.Snterm ($uid:_$.Entry.obj ($e$ : $_$)) >> -> Snterm e
- | <:expr< Gramext.Snterml ($uid:_$.Entry.obj ($e$ : $_$)) $str:s$ >> ->
- Snterml e s
- | <:expr< Gramext.Snterml ($uid:_$.Entry.obj ($e$ : $_$), $str:s$) >> ->
- Snterml e s
- | <:expr< Gramext.Slist0 $e$ >> -> Slist0 (unsymbol e)
- | <:expr< Gramext.Slist0sep $e1$ $e2$ >> ->
- Slist0sep (unsymbol e1) (unsymbol e2)
- | <:expr< Gramext.Slist0sep ($e1$, $e2$) >> ->
- Slist0sep (unsymbol e1) (unsymbol e2)
- | <:expr< Gramext.Slist1 $e$ >> -> Slist1 (unsymbol e)
- | <:expr< Gramext.Slist1sep $e1$ $e2$ >> ->
- Slist1sep (unsymbol e1) (unsymbol e2)
- | <:expr< Gramext.Slist1sep ($e1$, $e2$) >> ->
- Slist1sep (unsymbol e1) (unsymbol e2)
- | <:expr< Gramext.Sopt $e$ >> -> Sopt (unsymbol e)
- | <:expr< Gramext.Sself >> -> Sself
- | <:expr< Gramext.Snext >> -> Snext
- | <:expr< Gramext.Stoken $e$ >> -> Stoken (untoken e)
- | <:expr< Gramext.srules $e$ >> -> Srules (unrule_list [] e)
- | _ -> raise Not_found ]
-and unpsymbol_list pl e =
- match (pl, e) with
- [ ([], <:expr< [] >>) -> []
- | ([p :: pl], <:expr< [$e$ :: $el$] >>) ->
- let op =
- match p with
- [ <:patt< _ >> -> None
- | _ -> Some p ]
- in
- [(op, unsymbol e) :: unpsymbol_list pl el]
- | _ -> raise Not_found ]
-and unrule =
- fun
- [ <:expr< ($e1$, Gramext.action $e2$) >> ->
- let (pl, a) =
- match unaction e2 with
- [ ([], None) -> let loc = (0, 0) in ([], Some <:expr< () >>)
- | x -> x ]
- in
- let sl = unpsymbol_list (List.rev pl) e1 in
- (sl, a)
- | _ -> raise Not_found ]
-and unrule_list rl =
- fun
- [ <:expr< [$e$ :: $el$] >> -> unrule_list [unrule e :: rl] el
- | <:expr< [] >> -> rl
- | _ -> raise Not_found ]
-;
-
-value unlevel =
- fun
- [ <:expr< ($e1$, $e2$, $e3$) >> ->
- (unlabel e1, unassoc e2, unrule_list [] e3)
- | _ -> raise Not_found ]
-;
-
-value rec unlevel_list =
- fun
- [ <:expr< [$e$ :: $el$] >> -> [unlevel e :: unlevel_list el]
- | <:expr< [] >> -> []
- | _ -> raise Not_found ]
-;
-
-value unentry =
- fun
- [ <:expr< (Grammar.Entry.obj ($e$ : Grammar.Entry.e '$_$), $pos$, $ll$) >> ->
- (e, unposition pos, unlevel_list ll)
- | _ -> raise Not_found ]
-;
-
-value rec unentry_list =
- fun
- [ <:expr< [$e$ :: $el$] >> -> [unentry e :: unentry_list el]
- | <:expr< [] >> -> []
- | _ -> raise Not_found ]
-;
-
-value unextend_body e =
- let ((_, globals), e) =
- match e with
- [ <:expr< let $list:pel$ in $e1$ >> ->
- try (get_globals pel, e1) with
- [ Not_found -> (("", []), e) ]
- | _ -> (("", []), e) ]
- in
- let e =
- match e with
- [ <:expr<
- let grammar_entry_create s =
- Grammar.Entry.create (Grammar.of_entry $_$) s
- in
- $e$ >> ->
- let e =
- match e with
- [ <:expr< let $list:pel$ in $e1$ >> ->
- try let _ = get_locals pel in e1 with
- [ Not_found -> e ]
- | _ -> e ]
- in
- e
- | _ -> e ]
- in
- let el = unentry_list e in
- (globals, el)
-;
-
-value ungextend_body e =
- let e =
- match e with
- [ <:expr<
- let grammar_entry_create = Gram.Entry.create in
- let $list:ll$ in $e$
- >> ->
- let _ = get_locals ll in e
- | _ -> e ]
- in
- match e with
- [ <:expr< do { $list:el$ } >> ->
- List.map
- (fun
- [ <:expr< $uid:_$.extend ($e$ : $uid:_$.Entry.e '$_$) $pos$ $ll$ >> ->
- (e, unposition pos, unlevel_list ll)
- | _ -> raise Not_found ])
- el
- | _ -> raise Not_found ]
-;
-
-(* Printing *)
-
-value ident s k = HVbox [: `S LR s; k :];
-value string s k = HVbox [: `S LR ("\"" ^ s ^ "\""); k :];
-
-value position =
- fun
- [ None -> [: :]
- | Some Gramext.First -> [: `S LR "FIRST" :]
- | Some Gramext.Last -> [: `S LR "LAST" :]
- | Some (Gramext.Before s) -> [: `S LR "BEFORE"; `string s [: :] :]
- | Some (Gramext.After s) -> [: `S LR "AFTER"; `string s [: :] :]
- | Some (Gramext.Level s) -> [: `S LR "LEVEL"; `string s [: :] :] ]
-;
-
-value action expr a dg k =
- expr a dg k
-;
-
-value token (con, prm) k =
- if con = "" then string prm k
- else if prm = "" then HVbox [: `S LR con; k :]
- else HVbox [: `S LR con; `string prm k :]
-;
-
-value simplify_rules rl =
- try
- List.map
- (fun
- [ ([(Some <:patt< $lid:x$ >>, s)], Some <:expr< $lid:y$ >>) ->
- if x = y then ([(None, s)], None) else raise Exit
- | ([], _) as r -> r
- | _ -> raise Exit ])
- rl
- with
- [ Exit -> rl ]
-;
-
-value rec symbol s k =
- match s with
- [ Snterm e -> expr e "" k
- | Snterml e s -> HVbox [: `expr e "" [: :]; `S LR "LEVEL"; `string s k :]
- | Slist0 s -> HVbox [: `S LR "LIST0"; `symbol s k :]
- | Slist0sep s sep ->
- HVbox
- [: `S LR "LIST0"; `symbol s [: :]; `S LR "SEP";
- `symbol sep k :]
- | Slist1 s -> HVbox [: `S LR "LIST1"; `symbol s k :]
- | Slist1sep s sep ->
- HVbox
- [: `S LR "LIST1"; `symbol s [: :]; `S LR "SEP";
- `symbol sep k :]
- | Sopt s -> HVbox [: `S LR "OPT"; `symbol s k :]
- | Sself -> HVbox [: `S LR "SELF"; k :]
- | Snext -> HVbox [: `S LR "NEXT"; k :]
- | Stoken tok -> token tok k
- | Srules
- [([(Some <:patt< a >>, Snterm <:expr< a_list >>)], Some <:expr< a >>);
- ([(Some <:patt< a >>,
- ((Slist0 _ | Slist1 _ | Slist0sep _ _ | Slist1sep _ _) as s))],
- Some <:expr< Qast.List a >>)]
- when not no_slist.val
- ->
- match s with
- [ Slist0 s -> HVbox [: `S LR "SLIST0"; `simple_symbol s k :]
- | Slist1 s -> HVbox [: `S LR "SLIST1"; `simple_symbol s k :]
- | Slist0sep s sep ->
- HVbox
- [: `S LR "SLIST0"; `simple_symbol s [: :]; `S LR "SEP";
- `symbol sep k :]
- | Slist1sep s sep ->
- HVbox
- [: `S LR "SLIST1"; `simple_symbol s [: :]; `S LR "SEP";
- `simple_symbol sep k :]
- | _ -> assert False ]
- | Srules
- [([(Some <:patt< a >>, Snterm <:expr< a_opt >>)], Some <:expr< a >>);
- ([(Some <:patt< a >>, Sopt s)], Some <:expr< Qast.Option a >>)]
- when not no_slist.val
- ->
- let s =
- match s with
- [ Srules
- [([(Some <:patt< x >>, Stoken ("", str))],
- Some <:expr< Qast.Str x >>)] ->
- Stoken ("", str)
- | s -> s ]
- in
- HVbox [: `S LR "SOPT"; `simple_symbol s k :]
- | Srules rl ->
- let rl = simplify_rules rl in
- HVbox [: `HVbox [: :]; rule_list rl k :] ]
-and simple_symbol s k =
- match s with
- [ Snterml _ _ -> HVbox [: `S LO "("; `symbol s [: `S RO ")"; k :] :]
- | s -> symbol s k ]
-and psymbol (p, s) k =
- match p with
- [ None -> symbol s k
- | Some p -> HVbox [: `patt p "" [: `S LR "=" :]; `symbol s k :] ]
-and psymbol_list sl k =
- listws psymbol (S RO ";") sl k
-and rule b (sl, a) dg k =
- match a with
- [ None -> HVbox [: b; `HOVbox [: psymbol_list sl k :] :]
- | Some a ->
- HVbox
- [: b;
- `HOVbox
- [: `HOVbox
- [: `HVbox [: :];
- psymbol_list sl [: `S LR "->" :] :];
- `action expr a dg k :] :] ]
-and rule_list ll k =
- listwbws rule [: `S LR "[" :] (S LR "|") ll ""
- [: `S LR "]"; k :]
-;
-
-value label =
- fun
- [ Some s -> [: `S LR ("\"" ^ s ^ "\"") :]
- | None -> [: :] ]
-;
-
-value assoc =
- fun
- [ Some Gramext.NonA -> [: `S LR "NONA" :]
- | Some Gramext.LeftA -> [: `S LR "LEFTA" :]
- | Some Gramext.RightA -> [: `S LR "RIGHTA" :]
- | None -> [: :] ]
-;
-
-value level b (lab, ass, rl) dg k =
- let s =
- if rl = [] then [: `S LR "[ ]"; k :]
- else [: `Vbox [: `HVbox [: :]; rule_list rl k :] :]
- in
- match (lab, ass) with
- [ (None, None) -> HVbox [: b; s :]
- | _ ->
- Vbox
- [: `HVbox [: b; label lab; assoc ass :];
- `HVbox [: `HVbox [: :]; s :] :] ]
-;
-
-value level_list ll k =
- Vbox
- [: `HVbox [: :];
- listwbws level [: `S LR "[" :] (S LR "|") ll ""
- [: `S LR "]"; k :] :]
-;
-
-value entry (e, pos, ll) k =
- BEbox
- [: `LocInfo (MLast.loc_of_expr e)
- (HVbox [: `expr e "" [: `S RO ":" :]; position pos :]);
- `level_list ll [: :];
- `HVbox [: `S RO ";"; k :] :]
-;
-
-value entry_list el k =
- Vbox [: `HVbox [: :]; list entry el k :]
-;
-
-value extend_body (globals, e) k =
- let s = entry_list e k in
- match globals with
- [ [] -> s
- | sl ->
- HVbox
- [: `HVbox [: :];
- `HOVbox
- [: `S LR "GLOBAL"; `S RO ":";
- list (fun e k -> HVbox [: `expr e "" k :]) sl
- [: `S RO ";" :] :];
- `s :] ]
-;
-
-value extend e dg k =
- match e with
- [ <:expr< Grammar.extend $e$ >> ->
- try
- let ex = unextend_body e in
- BEbox
- [: `S LR "EXTEND"; `extend_body ex [: :];
- `HVbox [: `S LR "END"; k :] :]
- with
- [ Not_found ->
- HVbox
- [: `S LR "Grammar.extend";
- `HOVbox
- [: `S LO "(";
- `expr e "" [: `HVbox [: `S RO ")"; k :] :] :] :] ]
- | _ -> expr e "" k ]
-;
-
-value get_gextend =
- fun
- [ <:expr< let $list:gl$ in $e$ >> ->
- try
- let (gmod, gl) = get_globals gl in
- let el = ungextend_body e in
- Some (gmod, gl, el)
- with
- [ Not_found -> None ]
- | _ -> None ]
-;
-
-value gextend e dg k =
- match get_gextend e with
- [ Some (gmod, gl, el) ->
- BEbox
- [: `HVbox [: `S LR "GEXTEND"; `S LR gmod :];
- `extend_body (gl, el) [: :];
- `HVbox [: `S LR "END"; k :] :]
- | None -> expr e "" k ]
-;
-
-value is_gextend e = get_gextend e <> None;
-
-(* Printer extensions *)
-
-let lev =
- try find_pr_level "expr1" pr_expr.pr_levels with
- [ Failure _ -> find_pr_level "top" pr_expr.pr_levels ]
-in
-lev.pr_rules :=
- extfun lev.pr_rules with
- [ <:expr< let $list:_$ in $_$ >> as e when is_gextend e ->
- fun curr next _ k -> [: `next e "" k :] ];
-
-let lev = find_pr_level "apply" pr_expr.pr_levels in
-lev.pr_rules :=
- extfun lev.pr_rules with
- [ <:expr< Grammar.extend $_$ >> as e ->
- fun curr next _ k -> [: `next e "" k :] ];
-
-let lev = find_pr_level "simple" pr_expr.pr_levels in
-lev.pr_rules :=
- extfun lev.pr_rules with
- [ <:expr< Grammar.extend $_$ >> as e ->
- fun curr next _ k -> [: `extend e "" k :]
- | <:expr< let $list:_$ in $_$ >> as e when is_gextend e ->
- fun curr next _ k -> [: `gextend e "" k :] ];
-
-Pcaml.add_option "-no_slist" (Arg.Set no_slist)
- "Don't reconstruct SLIST and SOPT";
diff --git a/camlp4/etc/pr_extfun.ml b/camlp4/etc/pr_extfun.ml
deleted file mode 100644
index 4d5c036615..0000000000
--- a/camlp4/etc/pr_extfun.ml
+++ /dev/null
@@ -1,92 +0,0 @@
-(* camlp4r q_MLast.cmo ./pa_extfun.cmo *)
-(* $Id$ *)
-
-open Pcaml;
-open Spretty;
-
-value loc = (0, 0);
-
-value expr e dg k = pr_expr.pr_fun "top" e dg k;
-value patt e dg k = pr_patt.pr_fun "top" e dg k;
-
-value rec un_extfun rpel =
- fun
- [ <:expr< [ ($_$, $_$, fun [ $list:pel$ ]) :: $el$ ] >> ->
- let (p, wo, e) =
- match pel with
- [ [(p, wo, <:expr< Some $e$ >>);
- (<:patt< _ >>, None, <:expr< None >>)] ->
- (p, wo, e)
- | [(p, wo, <:expr< Some $e$ >>)] -> (p, wo, e)
- | _ -> raise Not_found ]
- in
- let rpel =
- match rpel with
- [ [(p1, wo1, e1) :: pel] ->
- if wo1 = wo && e1 = e then
- let p =
- match (p1, p) with
- [ (<:patt< ($x1$ as $x2$) >>, <:patt< ($y1$ as $y2$) >>) ->
- if x2 = y2 then <:patt< ($x1$ | $y1$ as $x2$) >>
- else <:patt< $p1$ | $p$ >>
- | _ -> <:patt< $p1$ | $p$ >> ]
- in
- [(p, wo, e) :: pel]
- else [(p, wo, e) :: rpel]
- | [] -> [(p, wo, e)] ]
- in
- un_extfun rpel el
- | <:expr< [] >> -> List.rev rpel
- | _ -> raise Not_found ]
-;
-
-value rec listwbws elem b sep el k =
- match el with
- [ [] -> [: b; k :]
- | [x] -> [: `elem b x k :]
- | [x :: l] -> [: `elem b x [: :]; listwbws elem [: `sep :] sep l k :] ]
-;
-
-value rec match_assoc_list pwel k =
- match pwel with
- [ [pwe] -> match_assoc [: `S LR "[" :] pwe [: `S LR "]"; k :]
- | pel ->
- Vbox
- [: `HVbox [: :];
- listwbws match_assoc [: `S LR "[" :] (S LR "|") pel
- [: `S LR "]"; k :] :] ]
-and match_assoc b (p, w, e) k =
- let s =
- let (p, k) =
- match p with
- [ <:patt< ($p$ as $p2$) >> -> (p, [: `S LR "as"; `patt p2 "" [: :] :])
- | _ -> (p, [: :]) ]
- in
- match w with
- [ Some e1 ->
- [: `HVbox
- [: `HVbox [: :]; `patt p "" k;
- `HVbox [: `S LR "when"; `expr e1 "" [: `S LR "->" :] :] :] :]
- | _ -> [: `patt p "" [: k; `S LR "->" :] :] ]
- in
- HVbox [: b; `HVbox [: `HVbox s; `expr e "" k :] :]
-;
-
-let lev = find_pr_level "top" pr_expr.pr_levels in
-lev.pr_rules :=
- extfun lev.pr_rules with
- [ <:expr< Extfun.extend $e$ $list$ >> as ge ->
- fun curr next dg k ->
- try
- let pel = un_extfun [] list in
- [: `HVbox [: :];
- `BEbox [: `S LR "extfun"; `expr e "" [: :]; `S LR "with" :];
- `match_assoc_list pel k :]
- with
- [ Not_found -> [: `next ge dg k :] ] ];
-
-let lev = find_pr_level "apply" pr_expr.pr_levels in
-lev.pr_rules :=
- extfun lev.pr_rules with
- [ <:expr< Extfun.extend $e$ $list$ >> as ge ->
- fun curr next dg k -> [: `next ge dg k :] ];
diff --git a/camlp4/etc/pr_null.ml b/camlp4/etc/pr_null.ml
deleted file mode 100644
index 40566f24d3..0000000000
--- a/camlp4/etc/pr_null.ml
+++ /dev/null
@@ -1,16 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1998 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-Pcaml.print_interf.val := fun _ -> ();
-Pcaml.print_implem.val := fun _ -> ();
diff --git a/camlp4/etc/pr_o.ml b/camlp4/etc/pr_o.ml
deleted file mode 100644
index d87566726a..0000000000
--- a/camlp4/etc/pr_o.ml
+++ /dev/null
@@ -1,2062 +0,0 @@
-(* camlp4r q_MLast.cmo ./pa_extfun.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Pcaml;
-open Spretty;
-open Stdpp;
-
-value no_ss = ref True;
-
-value not_impl name x =
- let desc =
- if Obj.is_block (Obj.repr x) then
- "tag = " ^ string_of_int (Obj.tag (Obj.repr x))
- else "int_val = " ^ string_of_int (Obj.magic x)
- in
- HVbox [: `S NO ("<pr_o: not impl: " ^ name ^ "; " ^ desc ^ ">") :]
-;
-
-value apply_it l f =
- apply_it_f l where rec apply_it_f =
- fun
- [ [] -> f
- | [a :: l] -> a (apply_it_f l) ]
-;
-
-value rec list elem =
- fun
- [ [] -> fun _ k -> k
- | [x] -> fun dg k -> [: `elem x dg k :]
- | [x :: l] -> fun dg k -> [: `elem x "" [: :]; list elem l dg k :] ]
-;
-
-value rec listws elem sep el dg k =
- match el with
- [ [] -> k
- | [x] -> [: `elem x dg k :]
- | [x :: l] ->
- let sdg =
- match sep with
- [ S _ x -> x
- | _ -> "" ]
- in
- [: `elem x sdg [: `sep :]; listws elem sep l dg k :] ]
-;
-
-value rec listwbws elem b sep el dg k =
- match el with
- [ [] -> [: b; k :]
- | [x] -> [: `elem b x dg k :]
- | [x :: l] ->
- let sdg =
- match sep with
- [ S _ x -> x
- | _ -> "" ]
- in
- [: `elem b x sdg [: :]; listwbws elem [: `sep :] sep l dg k :] ]
-;
-
-value level box elem next e dg k =
- let rec curr e dg k = elem curr next e dg k in
- box (curr e dg k)
-;
-
-value is_infix =
- let infixes = Hashtbl.create 73 in
- do {
- List.iter (fun s -> Hashtbl.add infixes s True)
- ["=="; "!="; "+"; "+."; "-"; "-."; "*"; "*."; "/"; "/."; "**"; "**.";
- "="; "=."; "<>"; "<>."; "<"; "<."; ">"; ">."; "<="; "<=."; ">="; ">=.";
- "^"; "@"; "asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or";
- "&&"; "||"; "~-"; "~-."];
- fun s -> try Hashtbl.find infixes s with [ Not_found -> False ]
- }
-;
-
-value is_keyword =
- let keywords = Hashtbl.create 301 in
- do {
- List.iter (fun s -> Hashtbl.add keywords s True)
- ["!"; "!="; "#"; "$"; "%"; "&"; "&&"; "'"; "("; ")"; "*"; "**"; "+";
- ","; "-"; "-."; "->"; "."; ".."; "/"; ":"; "::"; ":="; ":>"; ";"; ";;";
- "<"; "<-"; "<="; "<>"; "="; "=="; ">"; ">="; ">]"; ">}"; "?"; "??";
- "@"; "["; "[<"; "[|"; "]"; "^"; "_"; "`"; "and"; "as"; "assert"; "asr";
- "begin"; "class"; "constraint"; "do"; "done"; "downto"; "else"; "end";
- "exception"; "external"; "false"; "for"; "fun"; "function"; "functor";
- "if"; "in"; "include"; "inherit"; "initializer"; "land"; "lazy"; "let";
- "lor"; "lsl"; "lsr"; "lxor"; "match"; "method"; "mod"; "module";
- "mutable"; "new"; "object"; "of"; "open"; "or"; "parser"; "private";
- "rec"; "sig"; "struct"; "then"; "to"; "true"; "try"; "type"; "val";
- "virtual"; "when"; "while"; "with"; "{"; "{<"; "|"; "|]"; "||"; "}";
- "~"; "~-"; "~-."];
- fun s -> try Hashtbl.find keywords s with [ Not_found -> False ]
- }
-;
-
-value has_special_chars v =
- match v.[0] with
- [ 'a'..'z' | 'A'..'Z' | '\192'..'\214' | '\216'..'\246' | '\248'..'\255' |
- '_' ->
- False
- | _ ->
- if String.length v >= 2 && v.[0] == '<' &&
- (v.[1] == '<' || v.[1] == ':')
- then
- False
- else True ]
-;
-
-value var_escaped v =
- if v = "" then "$lid:\"\"$"
- else if has_special_chars v || is_infix v then "( " ^ v ^ " )"
- else if is_keyword v then v ^ "__"
- else v
-;
-
-value flag n f = if f then [: `S LR n :] else [: :];
-
-value conv_con =
- fun
- [ "True" -> "true"
- | "False" -> "false"
- | " True" -> "True"
- | " False" -> "False"
- | x -> x ]
-;
-
-value conv_lab =
- fun
- [ "val" -> "contents"
- | x -> var_escaped x ]
-;
-
-(* default global loc *)
-
-value loc = (0, 0);
-
-value id_var s =
- if has_special_chars s || is_infix s then
- HVbox [: `S LR "("; `S LR s; `S LR ")" :]
- else if is_keyword s then HVbox [: `S LR (s ^ "__") :]
- else HVbox [: `S LR s :]
-;
-
-value virtual_flag =
- fun
- [ True -> [: `S LR "virtual" :]
- | _ -> [: :] ]
-;
-
-value rec_flag =
- fun
- [ True -> [: `S LR "rec" :]
- | _ -> [: :] ]
-;
-
-(* extensible printers *)
-
-value sig_item x dg k =
- let k = if no_ss.val then k else [: `S RO ";;"; k :] in
- pr_sig_item.pr_fun "top" x "" k
-;
-value str_item x dg k =
- let k = if no_ss.val then k else [: `S RO ";;"; k :] in
- pr_str_item.pr_fun "top" x "" k
-;
-value module_type e k = pr_module_type.pr_fun "top" e "" k;
-value module_expr e dg k = pr_module_expr.pr_fun "top" e "" k;
-value expr e dg k = pr_expr.pr_fun "top" e dg k;
-value patt e dg k = pr_patt.pr_fun "top" e dg k;
-value expr1 e dg k = pr_expr.pr_fun "expr1" e dg k;
-value simple_expr e dg k = pr_expr.pr_fun "simple" e dg k;
-value patt1 e dg k = pr_patt.pr_fun "patt1" e dg k;
-value simple_patt e dg k = pr_patt.pr_fun "simple" e dg k;
-value ctyp e dg k = pr_ctyp.pr_fun "top" e dg k;
-value simple_ctyp e dg k = pr_ctyp.pr_fun "simple" e dg k;
-value expr_fun_args ge = Extfun.apply pr_expr_fun_args.val ge;
-value class_sig_item x dg k = pr_class_sig_item.pr_fun "top" x "" k;
-value class_str_item x dg k = pr_class_str_item.pr_fun "top" x "" k;
-value class_type x k = pr_class_type.pr_fun "top" x "" k;
-value class_expr x k = pr_class_expr.pr_fun "top" x "" k;
-
-(* type core *)
-
-value mutable_flag =
- fun
- [ True -> [: `S LR "mutable" :]
- | _ -> [: :] ]
-;
-
-value private_flag =
- fun
- [ True -> [: `S LR "private" :]
- | _ -> [: :] ]
-;
-
-value rec labels loc b vl _ k =
- match vl with
- [ [] -> [: b; k :]
- | [v] ->
- [: `label True b v "" k; `LocInfo (snd loc, snd loc) (HVbox [: :]) :]
- | [v :: l] -> [: `label False b v "" [: :]; labels loc [: :] l "" k :] ]
-and label is_last b (loc, f, m, t) _ k =
- let m = flag "mutable" m in
- let k = [: if is_last then [: :] else [: `S RO ";" :]; k :] in
- Hbox
- [: `LocInfo loc
- (HVbox
- [: `HVbox [: b; m; `S LR (conv_lab f); `S LR ":" :];
- `ctyp t "" [: :] :]);
- k :]
-;
-
-value rec ctyp_list tel _ k = listws simple_ctyp (S LR "*") tel "" k;
-
-value rec variants loc b vl dg k =
- match vl with
- [ [] -> [: b; k :]
- | [v] -> [: `variant b v "" k; `LocInfo (snd loc, snd loc) (HVbox [: :]) :]
- | [v :: l] ->
- [: `variant b v "" [: :]; variants loc [: `S LR "|" :] l "" k :] ]
-and variant b (loc, c, tl) _ k =
- match tl with
- [ [] -> HVbox [: `LocInfo loc (HVbox b); `HOVbox [: `S LR c; k :] :]
- | _ ->
- HVbox
- [: `LocInfo loc (HVbox b);
- `HOVbox [: `S LR c; `S LR "of"; ctyp_list tl "" k :] :] ]
-;
-
-value rec row_fields b rfl _ k = listwbws row_field b (S LR "|") rfl "" k
-and row_field b rf _ k =
- match rf with
- [ MLast.RfTag c ao tl ->
- let c = "`" ^ c in
- match tl with
- [ [] -> HVbox [: b; `HOVbox [: `S LR c; k :] :]
- | _ ->
- let ao = if ao then [: `S LR "&" :] else [: :] in
- HVbox
- [: b;
- `HOVbox [: `S LR c; `S LR "of"; ao; ctyp_list tl "" k :] :] ]
- | MLast.RfInh t -> HVbox [: b; `ctyp t "" k :] ]
-;
-
-value rec get_type_args t tl =
- match t with
- [ <:ctyp< $t1$ $t2$ >> -> get_type_args t1 [t2 :: tl]
- | _ -> (t, tl) ]
-;
-
-value module_pref =
- apply_it
- [level (fun x -> HOVbox x)
- (fun curr next t _ k ->
- match t with
- [ <:ctyp< $t1$ $t2$ >> ->
- let (t, tl) = get_type_args t1 [t2] in
- [: curr t "" [: :];
- list
- (fun t _ k ->
- HOVbox [: `S NO "("; curr t "" [: :]; `S RO ")"; k :])
- tl "" k :]
- | <:ctyp< $t1$ . $t2$ >> ->
- [: curr t1 "" [: `S NO "." :]; `next t2 "" k :]
- | _ -> [: `next t "" k :] ])]
- simple_ctyp
-;
-
-value rec class_longident sl dg k =
- match sl with
- [ [i] -> HVbox [: `S LR i; k :]
- | [m :: sl] -> HVbox [: `S LR m; `S NO "."; `class_longident sl dg k :]
- | _ -> HVbox [: `not_impl "class_longident" sl; k :] ]
-;
-
-value rec clty_longident sl dg k =
- match sl with
- [ [i] -> HVbox [: `S LR i; k :]
- | [m :: sl] -> HVbox [: `S LR m; `S NO "."; `clty_longident sl dg k :]
- | _ -> HVbox [: `not_impl "clty_longident" sl; k :] ]
-;
-
-value rec meth_list (ml, v) dg k =
- match (ml, v) with
- [ ([f], False) -> [: `field f dg k :]
- | ([], _) -> [: `S LR ".."; k :]
- | ([f :: ml], v) ->
- [: `field f "" [: `S RO ";" :]; meth_list (ml, v) dg k :] ]
-and field (lab, t) dg k =
- HVbox [: `S LR (var_escaped lab); `S LR ":"; `ctyp t dg k :]
-;
-
-(* patterns *)
-
-value rec get_patt_args a al =
- match a with
- [ <:patt< $a1$ $a2$ >> -> get_patt_args a1 [a2 :: al]
- | _ -> (a, al) ]
-;
-
-value rec is_irrefut_patt =
- fun
- [ <:patt< $lid:_$ >> -> True
- | <:patt< () >> -> True
- | <:patt< _ >> -> True
- | <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y
- | <:patt< { $list:fpl$ } >> ->
- List.for_all (fun (_, p) -> is_irrefut_patt p) fpl
- | <:patt< ($p$ : $_$) >> -> is_irrefut_patt p
- | <:patt< ($list:pl$) >> -> List.for_all is_irrefut_patt pl
- | <:patt< ? $_$ : ($p$) >> -> is_irrefut_patt p
- | <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p
- | <:patt< ~ $_$ >> -> True
- | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p
- | _ -> False ]
-;
-
-(* expressions *)
-
-pr_expr_fun_args.val :=
- extfun Extfun.empty with
- [ <:expr< fun [$p$ -> $e$] >> as ge ->
- if is_irrefut_patt p then
- let (pl, e) = expr_fun_args e in
- ([p :: pl], e)
- else ([], ge)
- | ge -> ([], ge) ];
-
-value raise_match_failure (bp, ep) k =
- let (fname, line, char, _) =
- if Pcaml.input_file.val <> "-" then
- Stdpp.line_of_loc Pcaml.input_file.val (bp, ep)
- else
- ("-", 1, bp, ep)
- in
- HOVbox
- [: `S LR "raise"; `S LO "("; `S LR "Match_failure"; `S LO "(";
- `S LR ("\"" ^ fname ^ "\""); `S RO ",";
- `S LR (string_of_int line); `S RO ","; `S LR (string_of_int char);
- `S RO ")"; `S RO ")"; k :]
-;
-
-value rec bind_list b pel _ k =
- match pel with
- [ [pe] -> let_binding b pe "" k
- | pel ->
- Vbox [: `HVbox [: :]; listwbws let_binding b (S LR "and") pel "" k :] ]
-and let_binding b (p, e) _ k =
- let loc =
- let (bp1, ep1) = MLast.loc_of_patt p in
- let (bp2, ep2) = MLast.loc_of_expr e in
- (min bp1 bp2, max ep1 ep2)
- in
- LocInfo loc (BEbox (let_binding0 b p e k))
-and let_binding0 b p e k =
- let (pl, e) =
- match p with
- [ <:patt< ($_$ : $_$) >> -> ([], e)
- | _ -> expr_fun_args e ]
- in
- let b = [: b; `simple_patt p "" [: :] :] in
- match (p, e) with
- [ (<:patt< $lid:_$ >>, <:expr< ($e$ : $t$) >>) ->
- [: `HVbox
- [: `HVbox b; `HVbox (list simple_patt pl "" [: `S LR ":" :]);
- `ctyp t "" [: `S LR "=" :] :];
- `expr e "" [: :]; k :]
- | _ ->
- [: `HVbox
- [: `HVbox b; `HOVbox (list simple_patt pl "" [: `S LR "=" :]) :];
- `expr e "" [: :]; k :] ]
-and match_assoc_list loc pel dg k =
- match pel with
- [ [] ->
- HVbox
- [: `HVbox [: `S LR "_"; `S LR "->" :]; `raise_match_failure loc k :]
- | _ ->
- BEVbox
- [: `HVbox [: :]; listwbws match_assoc [: :] (S LR "|") pel "" k :] ]
-and match_assoc b (p, w, e) dg k =
- let s =
- match w with
- [ Some e1 ->
- [: `HVbox
- [: `HVbox [: :]; `patt p "" [: :];
- `HVbox [: `S LR "when"; `expr e1 "" [: `S LR "->" :] :] :] :]
- | _ -> [: `patt p "" [: `S LR "->" :] :] ]
- in
- HVbox [: b; `HVbox [: `HVbox s; `expr e dg k :] :]
-;
-
-value rec get_expr_args a al =
- match a with
- [ <:expr< $a1$ $a2$ >> -> get_expr_args a1 [a2 :: al]
- | _ -> (a, al) ]
-;
-
-value label lab = S LR (var_escaped lab);
-
-value field_expr (lab, e) dg k =
- HVbox [: `label lab; `S LR "="; `expr e dg k :]
-;
-
-value type_params sl _ k =
- match sl with
- [ [] -> k
- | [(s, vari)] ->
- let b =
- match vari with
- [ (True, False) -> [: `S LO "+" :]
- | (False, True) -> [: `S LO "-" :]
- | _ -> [: :] ]
- in
- [: b; `S LO "'"; `S LR s; k :]
- | sl ->
- [: `S LO "(";
- listws (fun (s, _) _ k -> HVbox [: `S LO "'"; `S LR s; k :])
- (S RO ",") sl "" [: `S RO ")"; k :] :] ]
-;
-
-value constrain (t1, t2) _ k =
- HVbox [: `S LR "constraint"; `ctyp t1 "" [: `S LR "=" :]; `ctyp t2 "" k :]
-;
-
-value type_list b tdl _ k =
- HVbox
- [: `HVbox [: :];
- listwbws
- (fun b ((_, tn), tp, te, cl) _ k ->
- let tn = var_escaped tn in
- let cstr = list constrain cl "" k in
- match te with
- [ <:ctyp< '$s$ >> when not (List.mem_assoc s tp) ->
- HVbox [: b; type_params tp "" [: :]; `S LR tn; cstr :]
- | <:ctyp< [ $list:[]$ ] >> ->
- HVbox [: b; type_params tp "" [: :]; `S LR tn; cstr :]
- | _ ->
- HVbox
- [: `HVbox
- [: b; type_params tp "" [: :]; `S LR tn; `S LR "=" :];
- `ctyp te "" [: :]; cstr :] ])
- b (S LR "and") tdl "" [: :];
- k :]
-;
-
-value external_def (s, t, pl) _ k =
- let ls =
- list (fun s _ k -> HVbox [: `S LR ("\"" ^ s ^ "\""); k :]) pl "" k
- in
- HVbox
- [: `HVbox [: `S LR "external"; `S LR (var_escaped s); `S LR ":" :];
- `ctyp t "" [: `S LR "="; ls :] :]
-;
-
-value value_description (s, t) _ k =
- HVbox
- [: `HVbox [: `S LR "val"; `S LR (var_escaped s); `S LR ":" :];
- `ctyp t "" k :]
-;
-
-value typevar s _ k = HVbox [: `S LR ("'" ^ s); k :];
-
-value rec mod_ident sl _ k =
- match sl with
- [ [] -> k
- | [s] -> [: `S LR s; k :]
- | [s :: sl] -> [: `S LR s; `S NO "."; mod_ident sl "" k :] ]
-;
-
-value rec module_declaration b mt k =
- match mt with
- [ <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ->
- module_declaration
- [: `HVbox
- [: b;
- `HVbox
- [: `S LO "("; `S LR i; `S LR ":";
- `module_type t [: `S RO ")" :] :] :] :]
- mt k
- | _ ->
- HVbox
- [: `HVbox [: :];
- `HVbox [: `HVbox [: b; `S LR ":" :]; `module_type mt [: :] :];
- k :] ]
-and module_rec_declaration b (n,mt) _ k =
- HVbox
- [: `HVbox
- [: b; `S LR n; `S LR ":"; `module_type mt [: :] :];
- k :]
-and modtype_declaration (s, mt) _ k =
- match mt with
- [ <:module_type< ' $_$ >> ->
- HVbox [: `HVbox [: `S LR "module"; `S LR "type"; `S LR s; k :] :]
- | _ ->
- HVbox
- [: `HVbox [: :];
- `HVbox
- [: `HVbox
- [: `S LR "module"; `S LR "type"; `S LR s; `S LR "=" :];
- `module_type mt [: :] :];
- k :] ]
-and with_constraints b icl _ k =
- HVbox [: `HVbox [: :]; listwbws with_constraint b (S LR "and") icl "" k :]
-and with_constraint b wc _ k =
- match wc with
- [ MLast.WcTyp _ p al e ->
- let params =
- match al with
- [ [] -> [: :]
- | [s] -> [: `S LO "'"; `S LR (fst s) :]
- | sl -> [: `S LO "("; type_params sl "" [: `S RO ")" :] :] ]
- in
- HVbox
- [: `HVbox
- [: `HVbox b; `S LR "type"; params;
- mod_ident p "" [: `S LR "=" :] :];
- `ctyp e "" k :]
- | MLast.WcMod _ sl me ->
- HVbox
- [: b; `S LR "module"; mod_ident sl "" [: `S LR "=" :];
- `module_expr me "" k :] ]
-;
-
-value rec module_binding b me k =
- match me with
- [ <:module_expr< functor ($s$ : $mt$) -> $mb$ >> ->
- module_binding
- [: `HVbox
- [: b;
- `HVbox
- [: `HVbox [: `S LO "("; `S LR s; `S LR ":" :];
- `module_type mt [: `S RO ")" :] :] :] :]
- mb k
- | <:module_expr< ( $me$ : $mt$ ) >> ->
- HVbox
- [: `HVbox [: :];
- `HVbox
- [: `HVbox
- [: `HVbox [: b; `S LR ":" :];
- `module_type mt [: `S LR "=" :] :];
- `module_expr me "" [: :] :];
- k :]
- | _ ->
- HVbox
- [: `HVbox [: :];
- `HVbox [: `HVbox [: b; `S LR "=" :]; `module_expr me "" [: :] :];
- k :] ]
-and module_rec_binding b (n, mt,me) _ k =
- HVbox
- [: `HVbox [: :];
- `HVbox
- [: `HVbox
- [: `HVbox [: b; `S LR n; `S LR ":" :];
- `module_type mt [: `S LR "=" :] :];
- `module_expr me "" [: :] :];
- k :]
-and class_declaration b ci _ k =
- class_fun_binding
- [: b; virtual_flag ci.MLast.ciVir; class_type_parameters ci.MLast.ciPrm;
- `S LR ci.MLast.ciNam :]
- ci.MLast.ciExp k
-and class_fun_binding b ce k =
- match ce with
- [ MLast.CeFun _ p cfb ->
- class_fun_binding [: b; `simple_patt p "" [: :] :] cfb k
- | ce -> HVbox [: `HVbox [: b; `S LR "=" :]; `class_expr ce k :] ]
-and class_type_parameters (loc, tpl) =
- match tpl with
- [ [] -> [: :]
- | tpl ->
- [: `S LO "[";
- listws type_parameter (S RO ",") tpl "" [: `S RO "]" :] :] ]
-and type_parameter tp dg k = HVbox [: `S LO "'"; `S LR (fst tp); k :]
-and class_self_patt_opt csp =
- match csp with
- [ Some p -> HVbox [: `S LO "("; `patt p "" [: `S RO ")" :] :]
- | None -> HVbox [: :] ]
-and cvalue b (lab, mf, e) k =
- HVbox
- [: `HVbox [: b; mutable_flag mf; `label lab; `S LR "=" :]; `expr e "" k :]
-and fun_binding b fb k =
- match fb with
- [ <:expr< fun $p$ -> $e$ >> ->
- fun_binding [: b; `simple_patt p "" [: :] :] e k
- | e -> HVbox [: `HVbox [: b; `S LR "=" :]; `expr e "" k :] ]
-and class_signature cs k =
- match cs with
- [ MLast.CtCon _ id [] -> clty_longident id "" k
- | MLast.CtCon _ id tl ->
- HVbox
- [: `S LO "["; listws ctyp (S RO ",") tl "" [: `S RO "]" :];
- `clty_longident id "" k :]
- | MLast.CtSig _ cst csf ->
- let ep = snd (MLast.loc_of_class_type cs) in
- class_self_type [: `S LR "object" :] cst
- [: `HVbox
- [: `HVbox [: :]; list class_sig_item csf "" [: :];
- `LocInfo (ep, ep) (HVbox [: :]) :];
- `HVbox [: `S LR "end"; k :] :]
- | _ -> HVbox [: `not_impl "class_signature" cs; k :] ]
-and class_self_type b cst k =
- BEbox
- [: `HVbox
- [: b;
- match cst with
- [ None -> [: :]
- | Some t -> [: `S LO "("; `ctyp t "" [: `S RO ")" :] :] ] :];
- k :]
-and class_description b ci _ k =
- HVbox
- [: `HVbox
- [: b; virtual_flag ci.MLast.ciVir;
- class_type_parameters ci.MLast.ciPrm; `S LR ci.MLast.ciNam;
- `S LR ":" :];
- `class_type ci.MLast.ciExp k :]
-and class_type_declaration b ci _ k =
- HVbox
- [: `HVbox
- [: b; virtual_flag ci.MLast.ciVir;
- class_type_parameters ci.MLast.ciPrm; `S LR ci.MLast.ciNam;
- `S LR "=" :];
- `class_signature ci.MLast.ciExp k :]
-;
-
-pr_module_type.pr_levels :=
- [{pr_label = "top"; pr_box mt x = HVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:module_type< functor ( $s$ : $mt1$ ) -> $mt2$ >> ->
- fun curr next dg k ->
- let head =
- HVbox
- [: `S LR "functor"; `S LO "("; `S LR s; `S LR ":";
- `HVbox (curr mt1 "" [: `S RO ")" :]); `S LR "->" :]
- in
- [: `head; curr mt2 "" k :]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = ""; pr_box mt x = HVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:module_type< $mt$ with $list:icl$ >> ->
- fun curr next dg k ->
- [: curr mt "" [: :];
- `with_constraints [: `S LR "with" :] icl "" k :]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = ""; pr_box mt x = HVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:module_type< sig $list:s$ end >> as mt ->
- fun curr next dg k ->
- let ep = snd (MLast.loc_of_module_type mt) in
- [: `BEbox
- [: `S LR "sig";
- `HVbox
- [: `HVbox [: :]; list sig_item s "" [: :];
- `LocInfo (ep, ep) (HVbox [: :]) :];
- `HVbox [: `S LR "end"; k :] :] :]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = ""; pr_box mt x = HVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:module_type< $mt1$ $mt2$ >> ->
- fun curr next dg k ->
- [: curr mt1 "" [: :]; `S LO "(";
- `next mt2 "" [: `S RO ")"; k :] :]
- | <:module_type< $mt1$ . $mt2$ >> ->
- fun curr next dg k ->
- [: curr mt1 "" [: `S NO "." :]; `next mt2 "" k :]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = ""; pr_box mt x = HVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:module_type< $lid:s$ >> -> fun curr next dg k -> [: `S LR s; k :]
- | <:module_type< $uid:s$ >> -> fun curr next dg k -> [: `S LR s; k :]
- | mt ->
- fun curr next dg k ->
- [: `S LO "("; `module_type mt [: `S RO ")"; k :] :] ]}];
-
-pr_module_expr.pr_levels :=
- [{pr_label = "top"; pr_box mt x = HVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:module_expr< struct $list:s$ end >> as me ->
- fun curr next dg k ->
- let ep = snd (MLast.loc_of_module_expr me) in
- [: `HVbox [: :];
- `HVbox
- [: `S LR "struct"; list str_item s "" [: :];
- `LocInfo (ep, ep) (HVbox [: :]) :];
- `HVbox [: `S LR "end"; k :] :]
- | <:module_expr< functor ($s$ : $mt$) -> $me$ >> ->
- fun curr next dg k ->
- let head =
- HVbox
- [: `S LR "functor"; `S LO "("; `S LR s; `S LR ":";
- `module_type mt [: `S RO ")" :]; `S LR "->" :]
- in
- [: `head; curr me "" k :]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = ""; pr_box mt x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:module_expr< $me1$ $me2$ >> ->
- fun curr next dg k ->
- [: curr me1 "" [: :];
- `HVbox
- [: `S LO "("; `module_expr me2 "" [: `S RO ")"; k :] :] :]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = ""; pr_box mt x = HVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:module_expr< $me1$ . $me2$ >> ->
- fun curr next dg k ->
- [: curr me1 "" [: `S NO "." :]; `next me2 "" k :]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = ""; pr_box mt x = HVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:module_expr< $uid:s$ >> -> fun curr next dg k -> [: `S LR s; k :]
- | <:module_expr< ( $me$ : $mt$ ) >> ->
- fun curr next dg k ->
- [: `S LO "("; `module_expr me "" [: `S LR ":" :];
- `module_type mt [: `S RO ")"; k :] :]
- | <:module_expr< struct $list:_$ end >> |
- <:module_expr< functor ($_$ : $_$) -> $_$ >> |
- <:module_expr< $_$ $_$ >> | <:module_expr< $_$ . $_$ >> as me ->
- fun curr next dg k ->
- [: `S LO "("; `module_expr me "" [: `S RO ")"; k :] :] ]}];
-
-pr_sig_item.pr_levels :=
- [{pr_label = "top";
- pr_box s x = LocInfo (MLast.loc_of_sig_item s) (HVbox x);
- pr_rules =
- extfun Extfun.empty with
- [ <:sig_item< type $list:stl$ >> ->
- fun curr next dg k -> [: `type_list [: `S LR "type" :] stl "" k :]
- | <:sig_item< declare $list:s$ end >> ->
- fun curr next dg k ->
- if s = [] then [: `S LR "(* *)" :]
- else [: `HVbox [: :]; list sig_item s "" [: :] :]
- | MLast.SgDir _ _ _ as si ->
- fun curr next dg k -> [: `not_impl "sig_item" si :]
- | <:sig_item< exception $c$ of $list:tl$ >> ->
- fun curr next dg k ->
- [: `variant [: `S LR "exception" :] (loc, c, tl) "" k :]
- | <:sig_item< value $s$ : $t$ >> ->
- fun curr next dg k -> [: `value_description (s, t) "" k :]
- | <:sig_item< external $s$ : $t$ = $list:pl$ >> ->
- fun curr next dg k -> [: `external_def (s, t, pl) "" k :]
- | <:sig_item< include $mt$ >> ->
- fun curr next dg k -> [: `S LR "include"; `module_type mt k :]
- | <:sig_item< module $s$ : $mt$ >> ->
- fun curr next dg k ->
- [: `module_declaration [: `S LR "module"; `S LR s :] mt k :]
- | <:sig_item< module rec $list:nmts$ >> ->
- fun curr next _ k ->
- [: `HVbox [: :];
- listwbws module_rec_declaration [: `S LR "module rec" :] (S LR "and") nmts
- "" k :]
- | <:sig_item< module type $s$ = $mt$ >> ->
- fun curr next dg k -> [: `modtype_declaration (s, mt) "" k :]
- | <:sig_item< open $sl$ >> ->
- fun curr next dg k -> [: `S LR "open"; mod_ident sl "" k :]
- | MLast.SgCls _ cd ->
- fun curr next dg k ->
- [: `HVbox [: :];
- listwbws class_description [: `S LR "class" :] (S LR "and") cd
- "" k :]
- | MLast.SgClt _ cd ->
- fun curr next dg k ->
- [: `HVbox [: :];
- listwbws class_type_declaration
- [: `S LR "class"; `S LR "type" :] (S LR "and") cd ""
- k :]
- | MLast.SgUse _ _ _ ->
- fun curr next dg k -> [: :] ]}];
-
-pr_str_item.pr_levels :=
- [{pr_label = "top";
- pr_box s x = LocInfo (MLast.loc_of_str_item s) (HVbox x);
- pr_rules =
- extfun Extfun.empty with
- [ <:str_item< open $i$ >> ->
- fun curr next dg k -> [: `S LR "open"; mod_ident i "" k :]
- | <:str_item< $exp:e$ >> ->
- fun curr next dg k ->
- if no_ss.val then
- [: `HVbox [: `S LR "let"; `S LR "_"; `S LR "=" :];
- `expr e "" k :]
- else [: `HVbox [: :]; `expr e "" k :]
- | <:str_item< declare $list:s$ end >> ->
- fun curr next dg k ->
- if s = [] then [: `S LR "(* *)" :]
- else [: `HVbox [: :]; list str_item s "" [: :] :]
- | <:str_item< # $s$ $opt:x$ >> ->
- fun curr next dg k ->
- let s =
- "(* #" ^ s ^ " " ^
- (match x with
- [ Some <:expr< $str:s$ >> -> "\"" ^ s ^ "\""
- | _ -> "?" ]) ^
- " *)"
- in
- [: `S LR s :]
- | <:str_item< exception $c$ of $list:tl$ = $b$ >> ->
- fun curr next dg k ->
- match b with
- [ [] -> [: `variant [: `S LR "exception" :] (loc, c, tl) "" k :]
- | _ ->
- [: `variant [: `S LR "exception" :] (loc, c, tl) ""
- [: `S LR "=" :];
- mod_ident b "" k :] ]
- | <:str_item< include $me$ >> ->
- fun curr next dg k -> [: `S LR "include"; `module_expr me "" k :]
- | <:str_item< type $list:tdl$ >> ->
- fun curr next dg k -> [: `type_list [: `S LR "type" :] tdl "" k :]
- | <:str_item< value $opt:rf$ $list:pel$ >> ->
- fun curr next dg k ->
- [: `bind_list
- [: `S LR "let"; if rf then [: `S LR "rec" :] else [: :] :]
- pel "" k :]
- | <:str_item< external $s$ : $t$ = $list:pl$ >> ->
- fun curr next dg k -> [: `external_def (s, t, pl) "" k :]
- | <:str_item< module $s$ = $me$ >> ->
- fun curr next dg k ->
- [: `module_binding [: `S LR "module"; `S LR s :] me k :]
- | <:str_item< module rec $list:nmtmes$ >> ->
- fun curr next _ k ->
- [: `HVbox [: :];
- listwbws module_rec_binding [: `S LR "module rec" :] (S LR "and") nmtmes
- "" k :]
- | <:str_item< module type $s$ = $mt$ >> ->
- fun curr next dg k ->
- [: `HVbox [: :];
- `HVbox
- [: `HVbox
- [: `S LR "module"; `S LR "type"; `S LR s;
- `S LR "=" :];
- `module_type mt [: :] :];
- k :]
- | MLast.StCls _ cd ->
- fun curr next dg k ->
- [: `HVbox [: :];
- listwbws class_declaration [: `S LR "class" :] (S LR "and") cd
- "" k :]
- | MLast.StClt _ cd ->
- fun curr next dg k ->
- [: `HVbox [: :];
- listwbws class_type_declaration
- [: `S LR "class"; `S LR "type" :] (S LR "and") cd ""
- k :]
- | MLast.StUse _ _ _ ->
- fun curr next dg k -> [: :] ]}];
-
-value ocaml_char =
- fun
- [ "'" -> "\\'"
- | "\"" -> "\\\""
- | c -> c ]
-;
-
-pr_expr.pr_levels :=
- [{pr_label = "top"; pr_box e x = LocInfo (MLast.loc_of_expr e) (HOVbox x);
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< do { $list:el$ } >> ->
- fun curr next dg k ->
- [: `HVbox [: `HVbox [: :]; listws next (S RO ";") el dg k :] :]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = "expr1"; pr_box e x = LocInfo (MLast.loc_of_expr e) (HOVbox x);
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< let $opt:r$ $p1$ = $e1$ in $e$ >> ->
- fun curr next dg k ->
- let r = if r then [: `S LR "rec" :] else [: :] in
- if dg <> ";" then
- [: `HVbox
- [: `HVbox [: :];
- `let_binding [: `S LR "let"; r :] (p1, e1) ""
- [: `S LR "in" :];
- `expr e dg k :] :]
- else
- let pel = [(p1, e1)] in
- [: `BEbox
- [: `S LR "begin";
- `HVbox
- [: `HVbox [: :];
- listwbws
- (fun b (p, e) _ k -> let_binding b (p, e) "" k)
- [: `S LR "let"; r :] (S LR "and") pel ""
- [: `S LR "in" :];
- `expr e "" [: :] :];
- `HVbox [: `S LR "end"; k :] :] :]
- | <:expr< let $opt:r$ $list:pel$ in $e$ >> ->
- fun curr next dg k ->
- let r = if r then [: `S LR "rec" :] else [: :] in
- if dg <> ";" then
- [: `Vbox
- [: `HVbox [: :];
- listwbws
- (fun b (p, e) _ k -> let_binding b (p, e) "" k)
- [: `S LR "let"; r :] (S LR "and") pel ""
- [: `S LR "in" :];
- `expr e dg k :] :]
- else
- [: `BEbox
- [: `S LR "begin";
- `HVbox
- [: `HVbox [: :];
- listwbws
- (fun b (p, e) _ k -> let_binding b (p, e) "" k)
- [: `S LR "let"; r :] (S LR "and") pel ""
- [: `S LR "in" :];
- `expr e "" [: :] :];
- `HVbox [: `S LR "end"; k :] :] :]
- | <:expr< let module $m$ = $mb$ in $e$ >> ->
- fun curr next dg k ->
- if dg <> ";" then
- [: `HVbox
- [: `HVbox [: :];
- `module_binding
- [: `S LR "let"; `S LR "module"; `S LR m :] mb [: :];
- `S LR "in"; `expr e dg k :] :]
- else
- [: `BEbox
- [: `module_binding
- [: `S LR "begin let"; `S LR "module"; `S LR m :] mb
- [: :];
- `HVbox
- [: `HVbox [: :]; `S LR "in"; `expr e dg [: :] :];
- `HVbox [: `S LR "end"; k :] :] :]
- | <:expr< fun [ $list:pel$ ] >> as e ->
- fun curr next dg k ->
- let loc = MLast.loc_of_expr e in
- if not (List.mem dg ["|"; ";"]) then
- match pel with
- [ [] ->
- [: `S LR "fun"; `S LR "_"; `S LR "->";
- `raise_match_failure loc k :]
- | [(p, None, e)] ->
- let (pl, e) = expr_fun_args e in
- [: `BEbox
- [: `HOVbox
- [: `S LR "fun";
- list simple_patt [p :: pl] ""
- [: `S LR "->" :] :];
- `expr e "" k :] :]
- | _ ->
- [: `Vbox
- [: `HVbox [: :]; `S LR "function";
- `match_assoc_list loc pel "" k :] :] ]
- else
- match pel with
- [ [] ->
- [: `S LR "(fun"; `S LR "_"; `S LR "->";
- `raise_match_failure loc [: `S RO ")"; k :] :]
- | [(p, None, e)] ->
- if is_irrefut_patt p then
- let (pl, e) = expr_fun_args e in
- [: `S LO "(";
- `BEbox
- [: `HOVbox
- [: `S LR "fun";
- list simple_patt [p :: pl] ""
- [: `S LR "->" :] :];
- `expr e "" [: `S RO ")"; k :] :] :]
- else
- [: `HVbox
- [: `S LR "fun ["; `patt p "" [: `S LR "->" :] :];
- `expr e "" [: `S LR "]"; k :] :]
- | _ ->
- [: `Vbox
- [: `HVbox [: :]; `S LR "begin function";
- `match_assoc_list loc pel "" k;
- `HVbox [: `S LR "end"; k :] :] :] ]
- | <:expr< match $e$ with [ $list:pel$ ] >> as ge ->
- fun curr next dg k ->
- let loc = MLast.loc_of_expr ge in
- if not (List.mem dg ["|"; ";"]) then
- [: `HVbox
- [: `HVbox [: :];
- `BEbox
- [: `S LR "match"; `expr e "" [: :]; `S LR "with" :];
- `match_assoc_list loc pel "" k :] :]
- else
- [: `HVbox
- [: `HVbox [: :];
- `BEbox
- [: `S LR "begin match"; `expr e "" [: :];
- `S LR "with" :];
- `match_assoc_list loc pel "" [: :];
- `HVbox [: `S LR "end"; k :] :] :]
- | <:expr< try $e$ with [ $list:pel$ ] >> as ge ->
- fun curr next dg k ->
- let loc = MLast.loc_of_expr ge in
- if not (List.mem dg ["|"; ";"]) then
- [: `HVbox
- [: `HVbox [: :];
- `BEbox
- [: `S LR "try"; `expr e "" [: :]; `S LR "with" :];
- `match_assoc_list loc pel "" k :] :]
- else
- [: `HVbox
- [: `HVbox [: :];
- `BEbox
- [: `S LR "begin try"; `expr e "" [: :];
- `S LR "with" :];
- `match_assoc_list loc pel "" [: :];
- `HVbox [: `S LR "end"; k :] :] :]
- | <:expr< if $e1$ then $e2$ else $e3$ >> as e ->
- fun curr next dg k ->
- let eel_e =
- elseif e3 where rec elseif e =
- match e with
- [ <:expr< if $e1$ then $e2$ else $e3$ >> ->
- let (eel, e) = elseif e3 in
- ([(e1, e2) :: eel], e)
- | _ -> ([], e) ]
- in
- if not (List.mem dg ["else"]) then
- match eel_e with
- [ ([], <:expr< () >>) ->
- [: `BEbox [: `S LR "if"; `expr e1 "" [: :]; `S LR "then" :];
- `expr1 e2 dg k :]
- | (eel, <:expr< () >>) ->
- let (eel, (e1f, e2f)) =
- let r = List.rev eel in
- (List.rev (List.tl r), List.hd r)
- in
- [: `HVbox
- [: `HVbox [: :];
- `HVbox
- [: `BEbox
- [: `S LR "if"; `expr e1 "" [: :];
- `S LR "then" :];
- `expr1 e2 "else" [: :] :];
- list
- (fun (e1, e2) _ k ->
- HVbox
- [: `BEbox
- [: `HVbox
- [: `S LR "else"; `S LR "if" :];
- `expr e1 "" [: :]; `S LR "then" :];
- `expr1 e2 "else" k :])
- eel "" [: :];
- `HVbox
- [: `BEbox
- [: `HVbox [: `S LR "else"; `S LR "if" :];
- `expr e1f "" [: :]; `S LR "then" :];
- `expr1 e2f dg k :] :] :]
- | (eel, e) ->
- [: `HVbox
- [: `HVbox [: :];
- `HVbox
- [: `BEbox
- [: `S LR "if"; `expr e1 "" [: :];
- `S LR "then" :];
- `expr1 e2 "else" [: :] :];
- list
- (fun (e1, e2) _ k ->
- HVbox
- [: `BEbox
- [: `HVbox
- [: `S LR "else"; `S LR "if" :];
- `expr e1 "" [: :]; `S LR "then" :];
- `expr1 e2 "else" k :])
- eel "" [: :];
- `HVbox [: `S LR "else"; `expr1 e dg k :] :] :] ]
- else
- match eel_e with
- [ (_, <:expr< () >>) -> [: `next e "" k :]
- | (eel, e) ->
- [: `HVbox
- [: `HVbox [: :];
- `HVbox
- [: `BEbox
- [: `S LR "if"; `expr e1 "" [: :];
- `S LR "then" :];
- `expr1 e2 "" [: :] :];
- list
- (fun (e1, e2) _ k ->
- HVbox
- [: `BEbox
- [: `HVbox
- [: `S LR "else"; `S LR "if" :];
- `expr e1 "" [: :]; `S LR "then" :];
- `expr1 e2 "" [: :] :])
- eel "" [: :];
- `HVbox [: `S LR "else"; `expr1 e "" k :] :] :] ]
- | <:expr< for $i$ = $e1$ $to:d$ $e2$ do { $list:el$ } >> ->
- fun curr next dg k ->
- let d = if d then "to" else "downto" in
- [: `BEbox
- [: `HOVbox
- [: `S LR "for"; `S LR i; `S LR "=";
- `expr e1 "" [: `S LR d :];
- `expr e2 "" [: `S LR "do" :] :];
- `HVbox
- [: `HVbox [: :];
- listws expr (S RO ";") el "" [: :] :];
- `HVbox [: `S LR "done"; k :] :] :]
- | <:expr< while $e1$ do { $list:el$ } >> ->
- fun curr next dg k ->
- [: `BEbox
- [: `BEbox
- [: `S LR "while"; `expr e1 "" [: :]; `S LR "do" :];
- `HVbox
- [: `HVbox [: :];
- listws expr (S RO ";") el "" [: :] :];
- `HVbox [: `S LR "done"; k :] :] :]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< ($list:el$) >> ->
- fun curr next dg k ->
- [: `HVbox [: :]; listws next (S RO ",") el "" k :]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< $x$.val := $y$ >> ->
- fun curr next dg k ->
- [: `next x "" [: `S LR ":=" :]; `expr y dg k :]
- | <:expr< $x$ := $y$ >> ->
- fun curr next dg k ->
- [: `next x "" [: `S LR "<-" :]; `expr y dg k :]
- | e -> fun curr next dg k -> [: `next e "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :];
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< $lid:("||" as f)$ $x$ $y$ >> ->
- fun curr next dg k -> [: `next x "" [: `S LR f :]; curr y "" k :]
- | <:expr< $lid:("or" as f)$ $x$ $y$ >> ->
- fun curr next dg k -> [: `next x "" [: `S LR f :]; curr y "" k :]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :];
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< $lid:(("&&") as f)$ $x$ $y$ >> ->
- fun curr next dg k -> [: `next x "" [: `S LR f :]; curr y "" k :]
- | <:expr< $lid:(("&") as f)$ $x$ $y$ >> ->
- fun curr next dg k -> [: `next x "" [: `S LR f :]; curr y "" k :]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< $lid:op$ $x$ $y$ >> as e ->
- fun curr next dg k ->
- match op with
- [ "=" | "<>" | "<" | "<." | "<=" | ">" | ">=" | ">=." | "==" |
- "!=" ->
- [: curr x "" [: `S LR op :]; `next y "" k :]
- | _ -> [: `next e "" k :] ]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< $lid:op$ $x$ $y$ >> as e ->
- fun curr next dg k ->
- match op with
- [ "^" | "@" -> [: `next x "" [: `S LR op :]; curr y "" k :]
- | _ -> [: `next e "" k :] ]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< [$_$ :: $_$] >> as e ->
- fun curr next dg k ->
- let (el, c) =
- make_list e where rec make_list e =
- match e with
- [ <:expr< [$e$ :: $y$] >> ->
- let (el, c) = make_list y in
- ([e :: el], c)
- | <:expr< [] >> -> ([], None)
- | x -> ([], Some e) ]
- in
- match c with
- [ None -> [: `next e "" k :]
- | Some x ->
- [: listws next (S LR "::") el "" [: `S LR "::" :];
- `next x "" k :] ]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< $lid:op$ $x$ $y$ >> as e ->
- fun curr next dg k ->
- match op with
- [ "+" | "+." | "-" | "-." ->
- [: curr x "" [: `S LR op :]; `next y "" k :]
- | _ -> [: `next e "" k :] ]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< $lid:op$ $x$ $y$ >> as e ->
- fun curr next dg k ->
- match op with
- [ "*" | "/" | "*." | "/." | "land" | "lor" | "lxor" | "mod" ->
- [: curr x "" [: `S LR op :]; `next y "" k :]
- | _ -> [: `next e "" k :] ]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< $lid:op$ $x$ $y$ >> as e ->
- fun curr next dg k ->
- match op with
- [ "**" | "asr" | "lsl" | "lsr" ->
- [: `next x "" [: `S LR op :]; curr y "" k :]
- | _ -> [: `next e "" k :] ]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< $lid:"~-"$ $x$ >> ->
- fun curr next dg k -> [: `S LR "-"; curr x "" k :]
- | <:expr< $lid:"~-."$ $x$ >> ->
- fun curr next dg k -> [: `S LR "-."; curr x "" k :]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ ( <:expr< $int:x$ >> | <:expr< $flo:x$ >> )
- -> fun curr next dg k -> [: `S LR x; k :]
- | MLast.ExInt32 _ x -> fun curr next dg k -> [: `S LR (x^"l"); k :]
- | MLast.ExInt64 _ x -> fun curr next dg k -> [: `S LR (x^"L"); k :]
- | MLast.ExNativeInt _ x -> fun curr next dg k -> [: `S LR (x^"n"); k :]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = "apply"; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< [$_$ :: $_$] >> as e ->
- fun curr next dg k -> [: `next e "" k :]
- | <:expr< lazy ($x$) >> ->
- fun curr next dg k -> [: `S LR "lazy"; `next x "" k :]
- | MLast.ExAsf _ ->
-(* | <:expr< assert False >> -> *)
- fun curr next dg k -> [: `S LR "assert"; `S LR "false"; k :]
- | MLast.ExAsr _ e ->
-(* | <:expr< assert ($e$) >> -> *)
- fun curr next dg k -> [: `S LR "assert"; `next e "" k :]
- | <:expr< $lid:n$ $x$ $y$ >> as e ->
- fun curr next dg k ->
- let loc = MLast.loc_of_expr e in
- if is_infix n then [: `next e "" k :]
- else [: curr <:expr< $lid:n$ $x$ >> "" [: :]; `next y "" k :]
- | <:expr< $x$ $y$ >> ->
- fun curr next dg k ->
- match get_expr_args x [y] with
- [ (_, [_]) -> [: curr x "" [: :]; `next y "" k :]
- | ((<:expr< $uid:_$ >> | <:expr< $_$ . $uid:_$ >> as a), al) ->
- [: curr a "" [: :];
- `HOVbox
- [: `S LO "(";
- listws (fun x _ k -> HOVbox [: curr x "" k :])
- (S RO ",") al "" [: `S RO ")"; k :] :] :]
- | _ -> [: curr x "" [: :]; `next y "" k :] ]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = "dot"; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< $x$ . ( $y$ ) >> ->
- fun curr next dg k ->
- [: curr x "" [: :]; `S NO ".("; `expr y "" [: `S RO ")"; k :] :]
- | <:expr< $x$ . [ $y$ ] >> ->
- fun curr next dg k ->
- [: curr x "" [: :]; `S NO ".["; `expr y "" [: `S RO "]"; k :] :]
- | <:expr< $e$. val >> ->
- fun curr next dg k -> [: `S LO "!"; `next e "" k :]
- | <:expr< $e1$ . $e2$ >> ->
- fun curr next dg k ->
- [: curr e1 "" [: :]; `S NO "."; curr e2 "" k :]
- | <:expr< $e$ # $lab$ >> ->
- fun curr next dg k ->
- [: curr e "" [: :]; `S NO "#"; `label lab; k :]
- | e -> fun curr next dg k -> [: `next e "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< [$_$ :: $_$] >> as e ->
- fun curr next dg k ->
- let (el, c) =
- make_list e where rec make_list e =
- match e with
- [ <:expr< [$e$ :: $y$] >> ->
- let (el, c) = make_list y in
- ([e :: el], c)
- | <:expr< [] >> -> ([], None)
- | x -> ([], Some e) ]
- in
- match c with
- [ None ->
- [: `S LO "[";
- listws expr (S RO ";") el "" [: `S RO "]"; k :] :]
- | Some x -> [: `next e "" k :] ]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = "simple";
- pr_box e x = LocInfo (MLast.loc_of_expr e) (HOVbox x);
- pr_rules =
- extfun Extfun.empty with
- [ ( <:expr< $int:x$ >> | <:expr< $flo:x$ >> )
- -> fun curr next dg k ->
- if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :]
- else [: `S LR x; k :]
- | MLast.ExInt32 _ x ->
- fun curr next dg k ->
- let x = x^"l" in
- if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :]
- else [: `S LR x; k :]
- | MLast.ExInt64 _ x ->
- let x = x^"L" in
- fun curr next dg k ->
- if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :]
- else [: `S LR x; k :]
- | MLast.ExNativeInt _ x ->
- let x = x^"n" in
- fun curr next dg k ->
- if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :]
- else [: `S LR x; k :]
- | <:expr< $str:s$ >> ->
- fun curr next dg k -> [: `S LR ("\"" ^ s ^ "\""); k :]
- | <:expr< $chr:c$ >> ->
- fun curr next dg k ->
- let c = ocaml_char c in
- [: `S LR ("'" ^ c ^ "'"); k :]
- | <:expr< $uid:s$ >> ->
- fun curr next dg k -> [: `S LR (conv_con s); k :]
- | <:expr< $lid:s$ >> ->
- fun curr next dg k -> [: `S LR (var_escaped s); k :]
- | <:expr< ` $i$ >> -> fun curr next dg k -> [: `S LR ("`" ^ i); k :]
- | <:expr< ~ $i$ >> ->
- fun curr next dg k -> [: `S LR ("~" ^ i); k :]
- | <:expr< ~ $i$ : $e$ >> ->
- fun curr next dg k -> [: `S LO ("~" ^ i ^ ":"); curr e "" k :]
- | <:expr< ? $i$ >> ->
- fun curr next dg k -> [: `S LR ("?" ^ i); k :]
- | <:expr< ? $i$ : $e$ >> ->
- fun curr next dg k -> [: `S LO ("?" ^ i ^ ":"); curr e "" k :]
- | <:expr< [| $list:el$ |] >> ->
- fun curr next dg k ->
- [: `S LR "[|"; listws expr (S RO ";") el "" [: `S LR "|]"; k :] :]
- | <:expr< { $list:fel$ } >> ->
- fun curr next dg k ->
- [: `S LO "{";
- listws
- (fun (lab, e) dg k ->
- HVbox [: `patt lab "" [: `S LR "=" :]; `expr1 e dg k :])
- (S RO ";") fel "" [: `S RO "}"; k :] :]
- | <:expr< { ($e$) with $list:fel$ } >> ->
- fun curr next dg k ->
- [: `HVbox [: `S LO "{"; curr e "" [: `S LR "with" :] :];
- listws
- (fun (lab, e) dg k ->
- HVbox [: `patt lab "" [: `S LR "=" :]; `expr1 e dg k :])
- (S RO ";") fel "" [: `S RO "}"; k :] :]
- | <:expr< ($e$ : $t$) >> ->
- fun curr next dg k ->
- [: `S LO "("; `expr e "" [: `S LR ":" :];
- `ctyp t "" [: `S RO ")"; k :] :]
- | <:expr< ($e$ : $t1$ :> $t2$) >> ->
- fun curr next dg k ->
- [: `S LO "("; `expr e "" [: `S LR ":" :];
- `ctyp t1 "" [: `S LR ":>" :]; `ctyp t2 "" [: `S RO ")"; k :] :]
- | <:expr< ($e$ :> $t2$) >> ->
- fun curr next dg k ->
- [: `S LO "("; `expr e "" [: `S LR ":>" :];
- `ctyp t2 "" [: `S RO ")"; k :] :]
- | <:expr< new $list:sl$ >> ->
- fun curr next dg k -> [: `S LR "new"; `class_longident sl "" k :]
- | <:expr< {< >} >> -> fun curr next dg k -> [: `S LR "{< >}"; k :]
- | <:expr< {< $list:fel$ >} >> ->
- fun curr next dg k ->
- [: `S LR "{<";
- listws field_expr (S RO ";") fel dg [: `S LR ">}"; k :] :]
- | <:expr< do { $list:el$ } >> ->
- fun curr next dg k ->
- match el with
- [ [e] -> curr e dg k
- | _ ->
- [: `BEbox
- [: `S LR "begin";
- `HVbox
- [: `HVbox [: :];
- listws expr1 (S RO ";") el "" [: :] :];
- `HVbox [: `S LR "end"; k :] :] :] ]
- | <:expr< $_$ $_$ >> | <:expr< $_$ . $_$ >> | <:expr< $_$ . ( $_$ ) >> |
- <:expr< $_$ . [ $_$ ] >> | <:expr< $_$ := $_$ >> |
- <:expr< $_$ # $_$ >> |
- <:expr< fun [ $list:_$ ] >> | <:expr< match $_$ with [ $list:_$ ] >> |
- <:expr< try $_$ with [ $list:_$ ] >> |
- <:expr< if $_$ then $_$ else $_$ >> |
- <:expr< for $_$ = $_$ $to:_$ $_$ do { $list:_$ } >> |
- <:expr< while $_$ do { $list:_$ } >> | <:expr< ($list: _$) >> |
- <:expr< let $opt:_$ $list:_$ in $_$ >> |
- <:expr< let module $_$ = $_$ in $_$ >> as e ->
- fun curr next dg k ->
- [: `S LO "("; `expr e "" [: `HVbox [: `S RO ")"; k :] :] :]
- | e -> fun curr next _ k -> [: `not_impl "expr" e :] ]}];
-
-pr_patt.pr_levels :=
- [{pr_label = "top"; pr_box p x = LocInfo (MLast.loc_of_patt p) (HOVCbox x);
- pr_rules =
- extfun Extfun.empty with
- [ <:patt< ($x$ as $lid:y$) >> ->
- fun curr next dg k ->
- [: curr x "" [: :]; `S LR "as"; `S LR (var_escaped y); k :]
- | <:patt< ($x$ as $y$) >> ->
- fun curr next dg k ->
- [: curr y "" [: :]; `S LR "as"; `next x "" k :]
- | p -> fun curr next dg k -> [: `next p "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :];
- pr_rules =
- extfun Extfun.empty with
- [ <:patt< $x$ | $y$ >> ->
- fun curr next dg k -> [: curr x "" [: `S LR "|" :]; `next y "" k :]
- | p -> fun curr next dg k -> [: `next p "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVCbox [: `HVbox [: :]; x :];
- pr_rules =
- extfun Extfun.empty with
- [ <:patt< ($list:pl$) >> ->
- fun curr next dg k ->
- [: `HVbox [: :]; listws next (S RO ",") pl "" k :]
- | p -> fun curr next dg k -> [: `next p "" k :] ]};
- {pr_label = "patt1"; pr_box _ x = HOVbox [: `HVbox [: :]; x :];
- pr_rules =
- extfun Extfun.empty with
- [ <:patt< $x$ .. $y$ >> ->
- fun curr next dg k -> [: curr x "" [: `S NO ".." :]; `next y "" k :]
- | p -> fun curr next dg k -> [: `next p "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVCbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:patt< [$_$ :: $_$] >> as p ->
- fun curr next dg k ->
- let (pl, c) =
- make_list p where rec make_list p =
- match p with
- [ <:patt< [$p$ :: $y$] >> ->
- let (pl, c) = make_list y in
- ([p :: pl], c)
- | <:patt< [] >> -> ([], None)
- | x -> ([], Some p) ]
- in
- match c with
- [ None ->
- [: `S LO "[";
- listws patt (S RO ";") pl "" [: `S RO "]"; k :] :]
- | Some x ->
- [: `HVbox [: :]; listws next (S LR "::") (pl @ [x]) "" k :] ]
- | p -> fun curr next dg k -> [: `next p "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:patt< [$_$ :: $_$] >> as p ->
- fun curr next dg k -> [: `next p "" k :]
- | <:patt< $x$ $y$ >> ->
- fun curr next dg k ->
- match get_patt_args x [y] with
- [ (_, [_]) -> [: curr x "" [: :]; `next y "" k :]
- | ((<:patt< $uid:_$ >> | <:patt< $_$ . $uid:_$ >> as a), al) ->
- [: curr a "" [: :];
- `HOVbox
- [: `S LO "(";
- listws (fun x _ k -> HOVbox [: curr x "" k :])
- (S RO ",") al "" [: `S RO ")"; k :] :] :]
- | _ -> [: curr x "" [: :]; `next y "" k :] ]
- | p -> fun curr next dg k -> [: `next p "" k :] ]};
- {pr_label = "simple";
- pr_box p x = LocInfo (MLast.loc_of_patt p) (HOVbox x);
- pr_rules =
- extfun Extfun.empty with
- [ <:patt< $x$ . $y$ >> ->
- fun curr next dg k -> [: curr x "" [: :]; `S NO ".";
- `simple_patt y "" k :]
- | <:patt< [| $list:pl$ |] >> ->
- fun curr next dg k ->
- [: `S LR "[|"; listws patt (S RO ";") pl "" [: `S LR "|]"; k :] :]
- | <:patt< { $list:fpl$ } >> ->
- fun curr next dg k ->
- [: `HVbox
- [: `S LO "{";
- listws
- (fun (lab, p) _ k ->
- HVbox
- [: `patt lab "" [: `S LR "=" :]; `patt p "" k :])
- (S RO ";") fpl "" [: `S RO "}"; k :] :] :]
- | <:patt< [$_$ :: $_$] >> as p ->
- fun curr next dg k ->
- let (pl, c) =
- make_list p where rec make_list p =
- match p with
- [ <:patt< [$p$ :: $y$] >> ->
- let (pl, c) = make_list y in
- ([p :: pl], c)
- | <:patt< [] >> -> ([], None)
- | x -> ([], Some p) ]
- in
- match c with
- [ None ->
- [: `S LO "[";
- listws patt (S RO ";") pl "" [: `S RO "]"; k :] :]
- | Some x ->
- [: `S LO "("; `patt p "" [: `HVbox [: `S RO ")"; k :] :] :] ]
- | <:patt< ($p$ : $ct$) >> ->
- fun curr next dg k ->
- [: `S LO "("; `patt p "" [: `S LR ":" :];
- `ctyp ct "" [: `S RO ")"; k :] :]
- | ( <:patt< $int:s$ >> | <:patt< $flo:s$ >> )
- -> fun curr next dg k -> [: `S LR s; k :]
- | MLast.PaInt32 _ s
- -> fun curr next dg k -> [: `S LR (s^"l"); k :]
- | MLast.PaInt64 _ s
- -> fun curr next dg k -> [: `S LR (s^"L"); k :]
- | MLast.PaNativeInt _ s
- -> fun curr next dg k -> [: `S LR (s^"n"); k :]
- | <:patt< $str:s$ >> ->
- fun curr next dg k -> [: `S LR ("\"" ^ s ^ "\""); k :]
- | <:patt< $chr:c$ >> ->
- fun curr next dg k ->
- let c = ocaml_char c in
- [: `S LR ("'" ^ c ^ "'"); k :]
- | <:patt< $lid:i$ >> -> fun curr next dg k -> [: `id_var i; k :]
- | <:patt< $uid:i$ >> ->
- fun curr next dg k -> [: `S LR (conv_con i); k :]
- | <:patt< ` $i$ >> -> fun curr next dg k -> [: `S LR ("`" ^ i); k :]
- | <:patt< # $list:sl$ >> ->
- fun curr next dg k -> [: `S LO "#"; mod_ident sl dg k :]
- | <:patt< ~ $i$ >> ->
- fun curr next dg k -> [: `S LR ("~" ^ i); k :]
- | <:patt< ~ $i$ : $p$ >> ->
- fun curr next dg k ->
- [: `S LO ("~" ^ i ^ ":"); `simple_patt p "" k :]
- | <:patt< ? $i$ >> ->
- fun curr next _ k -> [: `S LR ("?" ^ i); k :]
- | <:patt< ? $i$ : ($p$) >> ->
- fun curr next dg k ->
- if i = "" then [: `S LO "?"; `simple_patt p "" k :]
- else [: `S LO ("?" ^ i ^ ":"); `simple_patt p "" k :]
- | <:patt< ? $i$ : ($p$ = $e$) >> ->
- fun curr next dg k ->
- if i = "" then
- [: `S LO "?"; `S LO "("; `patt p "" [: `S LR "=" :];
- `expr e "" [: `S RO ")"; k :] :]
- else
- [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p "" [: `S LR "=" :];
- `expr e "" [: `S RO ")"; k :] :]
- | <:patt< ? $i$ : ($p$ : $t$ = $e$) >> ->
- fun curr next dg k ->
- if i = "" then
- [: `S LO "?"; `S LO "("; `patt p "" [: `S LR "=" :];
- `expr e "" [: `S RO ")"; k :] :]
- else
- [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p "" [: `S LR "=" :];
- `expr e "" [: `S RO ")"; k :] :]
- | <:patt< _ >> -> fun curr next dg k -> [: `S LR "_"; k :]
- | <:patt< $_$ $_$ >> | <:patt< ($_$ as $_$) >> | <:patt< $_$ | $_$ >> |
- <:patt< ($list:_$) >> | <:patt< $_$ .. $_$ >> as p ->
- fun curr next dg k ->
- [: `S LO "("; `patt p "" [: `HVbox [: `S RO ")"; k :] :] :]
- | p -> fun curr next dg k -> [: `next p "" k :] ]}];
-
-pr_ctyp.pr_levels :=
- [{pr_label = "top"; pr_box t x = LocInfo (MLast.loc_of_ctyp t) (HOVbox x);
- pr_rules =
- extfun Extfun.empty with
- [ <:ctyp< $x$ as $y$ >> ->
- fun curr next dg k -> [: curr x "" [: `S LR "as" :]; `next y "" k :]
- | t -> fun curr next dg k -> [: `next t "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:ctyp< $x$ -> $y$ >> ->
- fun curr next dg k -> [: `next x "" [: `S LR "->" :]; curr y "" k :]
- | t -> fun curr next dg k -> [: `next t "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:ctyp< ? $lab$ : $t$ >> ->
- fun curr next dg k ->
- [: `S LO "?"; `S LR lab; `S RO ":"; `next t "" k :]
- | t -> fun curr next dg k -> [: `next t "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:ctyp< ($list:tl$) >> ->
- fun curr next dg k -> listws next (S LR "*") tl "" k
- | t -> fun curr next dg k -> [: `next t "" k :] ]};
- {pr_label = "simple";
- pr_box t x = LocInfo (MLast.loc_of_ctyp t) (HOVbox x);
- pr_rules =
- extfun Extfun.empty with
- [ <:ctyp< $t1$ == $t2$ >> ->
- fun curr next dg k ->
- [: curr t1 "=" [: `S LR "=" :]; `next t2 "" k :]
- | t -> fun curr next dg k -> [: `next t "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:ctyp< ? $lab$ : $t$ >> ->
- fun curr next dg k ->
- [: `S LO "?"; `S LR lab; `S RO ":"; `next t "" k :]
- | <:ctyp< ~ $lab$ : $t$ >> ->
- fun curr next dg k -> [: `S LO (lab ^ ":"); `next t "" k :]
- | t -> fun curr next dg k -> [: `next t "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:ctyp< $t1$ $t2$ >> ->
- fun curr next dg k ->
- let (t, tl) = get_type_args t1 [t2] in
- match tl with
- [ [<:ctyp< $_$ $_$ >>] -> [: curr t2 "" [: :]; curr t1 "" k :]
- | [_] -> [: `next t2 "" [: :]; curr t1 "" k :]
- | _ ->
- [: `S LO "(";
- listws (fun x _ k -> HOVbox [: curr x "" k :]) (S RO ",")
- tl "" [: `S RO ")" :];
- curr t "" k :] ]
- | t -> fun curr next dg k -> [: `next t "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:ctyp< $t1$ . $t2$ >> ->
- fun curr next dg k ->
- [: `module_pref t1 "" [: `S NO "." :]; `next t2 "" k :]
- | t -> fun curr next dg k -> [: `next t "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:ctyp< '$s$ >> ->
- fun curr next dg k -> [: `S LO "'"; `S LR (var_escaped s); k :]
- | <:ctyp< $lid:s$ >> ->
- fun curr next dg k -> [: `S LR (var_escaped s); k :]
- | <:ctyp< $uid:s$ >> -> fun curr next dg k -> [: `S LR s; k :]
- | <:ctyp< _ >> -> fun curr next dg k -> [: `S LR "_"; k :]
- | <:ctyp< private { $list:ftl$ } >> as t ->
- fun curr next dg k ->
- let loc = MLast.loc_of_ctyp t in
- [: `HVbox
- [: `HVbox [:`S LR "private" :];
- `HVbox [: labels loc [:`S LR "{" :]
- ftl "" [: `S LR "}" :] :];
- k :] :]
- | <:ctyp< { $list:ftl$ } >> as t ->
- fun curr next dg k ->
- let loc = MLast.loc_of_ctyp t in
- [: `HVbox
- [: labels loc [: `S LR "{" :] ftl "" [: `S LR "}" :];
- k :] :]
- | <:ctyp< private [ $list:ctl$ ] >> as t ->
- fun curr next dg k ->
- let loc = MLast.loc_of_ctyp t in
- [: `Vbox
- [: `HVbox [: `S LR "private" :];
- variants loc [: `S LR " " :] ctl "" [: :];
- k :] :]
- | <:ctyp< [ $list:ctl$ ] >> as t ->
- fun curr next dg k ->
- let loc = MLast.loc_of_ctyp t in
- [: `Vbox
- [: `HVbox [: :]; variants loc [: `S LR " " :] ctl "" [: :];
- k :] :]
- | <:ctyp< [ = $list:rfl$ ] >> ->
- fun curr next dg k ->
- [: `HVbox
- [: `HVbox [: :];
- row_fields [: `S LR "[" :] rfl "" [: `S LR "]" :];
- k :] :]
- | <:ctyp< [ > $list:rfl$ ] >> ->
- fun curr next dg k ->
- [: `HVbox
- [: `HVbox [: :];
- row_fields [: `S LR "[>" :] rfl "" [: `S LR "]" :];
- k :] :]
- | <:ctyp< [ < $list:rfl$ > $list:sl$ ] >> ->
- fun curr next dg k ->
- let k1 = [: `S LR "]" :] in
- let k1 =
- match sl with
- [ [] -> k1
- | l ->
- [: `S LR ">";
- list (fun x _ k -> HVbox [: `S LR x; k :]) l "" k1 :] ]
- in
- [: `HVbox
- [: `HVbox [: :]; row_fields [: `S LR "[<" :] rfl "" k1;
- k :] :]
- | MLast.TyCls _ id ->
- fun curr next dg k -> [: `S LO "#"; `class_longident id "" k :]
- | MLast.TyObj _ [] False -> fun curr next dg k -> [: `S LR "<>"; k :]
- | MLast.TyObj _ ml v ->
- fun curr next dg k ->
- [: `S LR "<"; meth_list (ml, v) "" [: `S LR ">"; k :] :]
- | MLast.TyPol _ pl t ->
- fun curr next dg k ->
- if pl = [] then [: `ctyp t "" k :]
- else [: list typevar pl "" [: `S LR "." :]; `ctyp t "" k :]
- | <:ctyp< $_$ -> $_$ >> | <:ctyp< $_$ $_$ >> | <:ctyp< $_$ == $_$ >> |
- <:ctyp< $_$ . $_$ >> | <:ctyp< ($list:_$) >> | <:ctyp< $_$ as $_$ >> |
- <:ctyp< ~ $_$ : $_$ >> | <:ctyp< ? $_$ : $_$ >> as t ->
- fun curr next dg k ->
- [: `S LO "("; `ctyp t "" [: `HVbox [: `S RO ")"; k :] :] :]
- | t -> fun curr next dg k -> [: `next t "" k :] ]}];
-
-pr_class_str_item.pr_levels :=
- [{pr_label = "top";
- pr_box s x = LocInfo (MLast.loc_of_class_str_item s) (HVbox x);
- pr_rules =
- extfun Extfun.empty with
- [ MLast.CrDcl _ s ->
- fun curr next dg k -> [: `HVbox [: :]; list class_str_item s "" k :]
- | MLast.CrInh _ ce pb ->
- fun curr next dg k ->
- [: `S LR "inherit"; `class_expr ce [: :];
- match pb with
- [ Some i -> [: `S LR "as"; `S LR i :]
- | _ -> [: :] ];
- k :]
- | MLast.CrVal _ lab mf e ->
- fun curr next dg k -> [: `cvalue [: `S LR "val" :] (lab, mf, e) k :]
- | MLast.CrVir _ lab pf t ->
- fun curr next dg k ->
- [: `S LR "method"; `S LR "virtual"; private_flag pf; `label lab;
- `S LR ":"; `ctyp t "" k :]
- | MLast.CrMth _ lab pf fb None ->
- fun curr next dg k ->
- [: `fun_binding [: `S LR "method"; private_flag pf; `label lab :]
- fb k :]
- | MLast.CrMth _ lab pf fb (Some t) ->
- fun curr next dg k ->
- [: `HOVbox
- [: `S LR "method"; private_flag pf; `label lab; `S LR ":";
- `ctyp t "" [: `S LR "=" :] :];
- `expr fb "" k :]
- | MLast.CrCtr _ t1 t2 ->
- fun curr next dg k ->
- [: `HVbox [: `S LR "constraint"; `ctyp t1 "" [: `S LR "=" :] :];
- `ctyp t2 "" k :]
- | MLast.CrIni _ se ->
- fun curr next dg k -> [: `S LR "initializer"; `expr se "" k :]
- | csi -> fun curr next dg k -> [: `next csi "" k :] ]}];
-
-pr_class_sig_item.pr_levels :=
- [{pr_label = "top";
- pr_box s x = LocInfo (MLast.loc_of_class_sig_item s) (HVbox x);
- pr_rules =
- extfun Extfun.empty with
- [ MLast.CgCtr _ t1 t2 ->
- fun curr next dg k ->
- [: `S LR "constraint"; `ctyp t1 "" [: `S LR "=" :];
- `ctyp t2 "" k :]
- | MLast.CgDcl _ s ->
- fun curr next dg k ->
- [: `HVbox [: :]; list class_sig_item s "" [: :] :]
- | MLast.CgInh _ ce ->
- fun curr next dg k -> [: `S LR "inherit"; `class_type ce k :]
- | MLast.CgMth _ lab pf t ->
- fun curr next dg k ->
- [: `HVbox
- [: `S LR "method"; private_flag pf; `label lab;
- `S LR ":" :];
- `ctyp t "" k :]
- | MLast.CgVal _ lab mf t ->
- fun curr next dg k ->
- [: `HVbox
- [: `S LR "val"; mutable_flag mf; `label lab; `S LR ":" :];
- `ctyp t "" k :]
- | MLast.CgVir _ lab pf t ->
- fun curr next dg k ->
- [: `HVbox
- [: `S LR "method"; `S LR "virtual"; private_flag pf;
- `label lab; `S LR ":" :];
- `ctyp t "" k :]
- | csi -> fun curr next dg k -> [: `next csi "" k :] ]}];
-
-pr_class_type.pr_levels :=
- [{pr_label = "top"; pr_box s x = HVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ MLast.CtFun _ t ct ->
- fun curr next dg k ->
- [: `ctyp t "" [: `S LR "->" :]; curr ct "" k :]
- | ct -> fun curr next dg k -> [: `class_signature ct k :] ]}];
-
-pr_class_expr.pr_levels :=
- [{pr_label = "top"; pr_box s x = HVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ MLast.CeFun _ p ce ->
- fun curr next dg k ->
- [: `S LR "fun"; `simple_patt p "" [: `S LR "->" :];
- `class_expr ce k :]
- | MLast.CeLet _ rf lb ce ->
- fun curr next dg k ->
- [: `Vbox
- [: `HVbox [: :];
- `bind_list [: `S LR "let"; rec_flag rf :] lb ""
- [: `S LR "in" :];
- `class_expr ce k :] :]
- | x -> fun curr next dg k -> [: `next x "" k :] ]};
- {pr_label = ""; pr_box s x = HVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ MLast.CeApp _ ce e ->
- fun curr next dg k -> [: curr ce "" [: :]; `simple_expr e "" k :]
- | x -> fun curr next dg k -> [: `next x "" k :] ]};
- {pr_label = ""; pr_box s x = HVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ MLast.CeCon _ ci [] ->
- fun curr next dg k -> [: `class_longident ci "" k :]
- | MLast.CeCon _ ci ctcl ->
- fun curr next dg k ->
- [: `S LO "["; listws ctyp (S RO ",") ctcl "" [: `S RO "]" :];
- `class_longident ci "" k :]
- | MLast.CeStr _ csp cf as ce ->
- let ep = snd (MLast.loc_of_class_expr ce) in
- fun curr next dg k ->
- [: `BEbox
- [: `HVbox [: `S LR "object"; `class_self_patt_opt csp :];
- `HVbox
- [: `HVbox [: :]; list class_str_item cf "" [: :];
- `LocInfo (ep, ep) (HVbox [: :]) :];
- `HVbox [: `S LR "end"; k :] :] :]
- | MLast.CeTyc _ ce ct ->
- fun curr next dg k ->
- [: `S LO "("; `class_expr ce [: `S LR ":" :];
- `class_type ct [: `S RO ")"; k :] :]
- | MLast.CeFun _ _ _ as ce ->
- fun curr next dg k ->
- [: `S LO "("; `class_expr ce [: `S RO ")"; k :] :]
- | ce -> fun curr next dg k -> [: `not_impl "class_expr" ce; k :] ]}];
-
-value output_string_eval oc s =
- loop 0 where rec loop i =
- if i == String.length s then ()
- else if i == String.length s - 1 then output_char oc s.[i]
- else
- match (s.[i], s.[i + 1]) with
- [ ('\\', 'n') -> do { output_char oc '\n'; loop (i + 2) }
- | (c, _) -> do { output_char oc c; loop (i + 1) } ]
-;
-
-value maxl = ref 78;
-value sep = Pcaml.inter_phrases;
-value ncip = ref True;
-
-value input_source ic len =
- let buff = Buffer.create 20 in
- try
- let rec loop i =
- if i >= len then Buffer.contents buff
- else do { let c = input_char ic in Buffer.add_char buff c; loop (i + 1) }
- in
- loop 0
- with
- [ End_of_file ->
- let s = Buffer.contents buff in
- if s = "" then
- match sep.val with
- [ Some s -> s
- | None -> "\n" ]
- else s ]
-;
-
-value copy_source ic oc first bp ep =
- match sep.val with
- [ Some str ->
- if first then ()
- else if ep == in_channel_length ic then output_string oc "\n"
- else output_string_eval oc str
- | None ->
- do {
- seek_in ic bp; let s = input_source ic (ep - bp) in output_string oc s
- } ]
-;
-
-value copy_to_end ic oc first bp =
- let ilen = in_channel_length ic in
- if bp < ilen then copy_source ic oc first bp ilen else output_string oc "\n"
-;
-
-module Buff =
- struct
- value buff = ref (String.create 80);
- value store len x =
- do {
- if len >= String.length buff.val then
- buff.val := buff.val ^ String.create (String.length buff.val)
- else ();
- buff.val.[len] := x;
- succ len
- }
- ;
- value mstore len s =
- add_rec len 0 where rec add_rec len i =
- if i == String.length s then len
- else add_rec (store len s.[i]) (succ i)
- ;
- value get len = String.sub buff.val 0 len;
- end
-;
-
-value extract_comment strm =
- let rec find_comm nl_bef tab_bef =
- parser
- [ [: `'('; a = find_star nl_bef tab_bef :] -> a
- | [: `' '; s :] -> find_comm nl_bef (tab_bef + 1) s
- | [: `'\t'; s :] -> find_comm nl_bef (tab_bef + 8) s
- | [: `'\n'; s :] -> find_comm (nl_bef + 1) 0 s
- | [: `_; s :] -> find_comm 0 0 s
- | [: :] -> ("", nl_bef, tab_bef) ]
- and find_star nl_bef tab_bef =
- parser
- [ [: `'*'; a = insert (Buff.mstore 0 "(*") :] -> (a, nl_bef, tab_bef)
- | [: a = find_comm 0 0 :] -> a ]
- and insert len =
- parser
- [ [: `'*'; a = rparen (Buff.store len '*') :] -> a
- | [: `'('; len = find_star2 (Buff.store len '('); s :] -> insert len s
- | [: `'\t'; s :] -> insert (Buff.mstore len (String.make 8 ' ')) s
- | [: `x; s :] -> insert (Buff.store len x) s
- | [: :] -> "" ]
- and rparen len =
- parser
- [ [: `')'; s :] -> while_space (Buff.store len ')') s
- | [: a = insert len :] -> a ]
- and while_space len =
- parser
- [ [: `' '; a = while_space (Buff.store len ' ') :] -> a
- | [: `'\t'; a = while_space (Buff.mstore len (String.make 8 ' ')) :] -> a
- | [: `'\n'; a = while_space (Buff.store len '\n') :] -> a
- | [: `'('; a = find_star_again len :] -> a
- | [: :] -> Buff.get len ]
- and find_star_again len =
- parser
- [ [: `'*'; a = insert (Buff.mstore len "(*") :] -> a
- | [: :] -> Buff.get len ]
- and find_star2 len =
- parser
- [ [: `'*'; a = insert2 (Buff.store len '*') :] -> a
- | [: :] -> len ]
- and insert2 len =
- parser
- [ [: `'*'; a = rparen2 (Buff.store len '*') :] -> a
- | [: `'('; len = find_star2 (Buff.store len '('); s :] -> insert2 len s
- | [: `x; s :] -> insert2 (Buff.store len x) s
- | [: :] -> 0 ]
- and rparen2 len =
- parser
- [ [: `')' :] -> Buff.store len ')'
- | [: a = insert2 len :] -> a ]
- in
- find_comm 0 0 strm
-;
-
-value get_no_comment _ _ = ("", 0, 0, 0);
-
-value get_comment ic beg len =
- do {
- seek_in ic beg;
- let strm =
- Stream.from (fun i -> if i >= len then None else Some (input_char ic))
- in
- let (s, nl_bef, tab_bef) = extract_comment strm in
- (s, nl_bef, tab_bef, Stream.count strm)
- }
-;
-
-value apply_printer printer ast =
- let oc =
- match Pcaml.output_file.val with
- [ Some f -> open_out_bin f
- | None -> stdout ]
- in
- let cleanup () =
- match Pcaml.output_file.val with
- [ Some _ -> close_out oc
- | None -> () ]
- in
- let pr_ch = output_char oc in
- let pr_str = output_string oc in
- let pr_nl () = output_char oc '\n' in
- if Pcaml.input_file.val <> "-" && Pcaml.input_file.val <> "" then do {
- let ic = open_in_bin Pcaml.input_file.val in
- let getcom =
- if not ncip.val && sep.val = None then get_comment ic
- else get_no_comment
- in
- try
- let (first, last_pos) =
- List.fold_left
- (fun (first, last_pos) (si, (bp, ep)) ->
- do {
- copy_source ic oc first last_pos bp;
- flush oc;
- print_pretty pr_ch pr_str pr_nl "" "" maxl.val getcom bp
- (printer si "" [: :]);
- flush oc;
- (False, ep)
- })
- (True, 0) ast
- in
- do { copy_to_end ic oc first last_pos; flush oc }
- with x ->
- do { close_in ic; cleanup (); raise x };
- close_in ic;
- cleanup ()
- }
- else do {
- List.iter
- (fun (si, _) ->
- do {
- print_pretty pr_ch pr_str pr_nl "" "" maxl.val get_no_comment 0
- (printer si "" [: :]);
- match sep.val with
- [ Some str -> output_string_eval oc str
- | None -> output_char oc '\n' ];
- flush oc
- })
- ast;
- cleanup ()
- }
-;
-
-Pcaml.print_interf.val := apply_printer sig_item;
-Pcaml.print_implem.val := apply_printer str_item;
-
-Pcaml.add_option "-l" (Arg.Int (fun x -> maxl.val := x))
- "<length> line length for pretty printing.";
-
-Pcaml.add_option "-ss" (Arg.Clear no_ss) "Print double semicolons.";
-
-Pcaml.add_option "-no_ss" (Arg.Set no_ss)
- "Do not print double semicolons (default).";
-
-Pcaml.add_option "-sep_src" (Arg.Unit (fun () -> sep.val := None))
- "Read source file for text between phrases (default).";
-
-Pcaml.add_option "-sep" (Arg.String (fun x -> sep.val := Some x))
- "<string> Use this string between phrases instead of reading source.";
-
-Pcaml.add_option "-cip" (Arg.Clear ncip) "Add comments in phrases.";
-
-Pcaml.add_option "-ncip" (Arg.Set ncip) "No comments in phrases (default).";
-
-Pcaml.add_option "-tc" (Arg.Clear ncip)
- "Deprecated since version 3.05; equivalent to -cip.";
diff --git a/camlp4/etc/pr_op.ml b/camlp4/etc/pr_op.ml
deleted file mode 100644
index 983a3a3cd7..0000000000
--- a/camlp4/etc/pr_op.ml
+++ /dev/null
@@ -1,503 +0,0 @@
-(* camlp4r q_MLast.cmo ./pa_extfun.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1998 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Pcaml;
-open Spretty;
-
-value loc = (0, 0);
-
-value expr e dg k = pr_expr.pr_fun "top" e dg k;
-value patt e dg k = pr_patt.pr_fun "top" e dg k;
-
-value spatt p dg k =
- match p with
- [ <:patt< $lid:s$ >> ->
- if String.length s >= 2 && s.[1] == ''' then
- HVbox [: `S LR (" " ^ s); k :]
- else patt p dg k
- | _ -> patt p dg k ]
-;
-
-(* Streams *)
-
-value stream e _ k =
- let rec get =
- fun
- [ <:expr< Stream.iapp $x$ $y$ >> -> [(False, x) :: get y]
- | <:expr< Stream.icons $x$ $y$ >> -> [(True, x) :: get y]
- | <:expr< Stream.ising $x$ >> -> [(True, x)]
- | <:expr< Stream.lapp (fun _ -> $x$) $y$ >> -> [(False, x) :: get y]
- | <:expr< Stream.lcons (fun _ -> $x$) $y$ >> -> [(True, x) :: get y]
- | <:expr< Stream.lsing (fun _ -> $x$) >> -> [(True, x)]
- | <:expr< Stream.sempty >> -> []
- | <:expr< Stream.slazy (fun _ -> $x$) >> -> [(False, x)]
- | <:expr< Stream.slazy $x$ >> -> [(False, <:expr< $x$ () >>)]
- | e -> [(False, e)] ]
- in
- let elem e dg k =
- match e with
- [ (True, e) -> [: `HOVbox [: `S LO "'"; `expr e dg k :] :]
- | (False, e) -> [: `expr e dg k :] ]
- in
- let rec glop e k =
- match e with
- [ [] -> k
- | [e] -> [: elem e "" k :]
- | [e :: el] -> [: elem e ";" [: `S RO ";" :]; glop el k :] ]
- in
- HOVbox [: `S LR "[<"; glop (get e) [: `S LR ">]"; k :] :]
-;
-
-(* Parsers *)
-
-type spc =
- [ SPCterm of (MLast.patt * option MLast.expr)
- | SPCnterm of MLast.patt and MLast.expr
- | SPCsterm of MLast.patt ]
-;
-
-exception NotImpl;
-
-value rec subst v e =
- match e with
- [ <:expr< $lid:x$ >> -> if x = "strm__" then <:expr< $lid:v$ >> else e
- | <:expr< $uid:_$ >> -> e
- | <:expr< $int:_$ >> -> e
- | <:expr< $chr:_$ >> -> e
- | <:expr< $str:_$ >> -> e
- | <:expr< $e1$ . $lab$ >> -> <:expr< $subst v e1$ . $lab$ >>
- | <:expr< $x$ $y$ >> -> <:expr< $subst v x$ $subst v y$ >>
- | <:expr< let $lid:s1$ = $e1$ in $e2$ >> ->
- if s1 = v then <:expr< let $lid:s1$ = $subst v e1$ in $e2$ >>
- else <:expr< let $lid:s1$ = $subst v e1$ in $subst v e2$ >>
- | <:expr< let _ = $e1$ in $e2$ >> ->
- <:expr< let _ = $subst v e1$ in $subst v e2$ >>
- | <:expr< ($list:el$) >> -> <:expr< ($list:List.map (subst v) el$) >>
- | _ -> raise NotImpl ]
-;
-
-value rec is_free v =
- fun
- [ <:expr< $lid:x$ >> -> x <> v
- | <:expr< $uid:_$ >> -> True
- | <:expr< $int:_$ >> -> True
- | <:expr< $chr:_$ >> -> True
- | <:expr< $str:_$ >> -> True
- | <:expr< $e$ . $_$ >> -> is_free v e
- | <:expr< $x$ $y$ >> -> is_free v x && is_free v y
- | <:expr< let $lid:s1$ = $e1$ in $e2$ >> ->
- is_free v e1 && (s1 = v || is_free v e2)
- | <:expr< let _ = $e1$ in $e2$ >> -> is_free v e1 && is_free v e2
- | <:expr< ($list:el$) >> -> List.for_all (is_free v) el
- | _ -> raise NotImpl ]
-;
-
-value free_var_in_expr c e =
- let rec loop_alpha v =
- let x = String.make 1 v in
- if is_free x e then Some x
- else if v = 'z' then None
- else loop_alpha (Char.chr (Char.code v + 1))
- in
- let rec loop_count cnt =
- let x = String.make 1 c ^ string_of_int cnt in
- if is_free x e then x else loop_count (succ cnt)
- in
- try
- match loop_alpha c with
- [ Some v -> v
- | None -> loop_count 1 ]
- with
- [ NotImpl -> "\\%a" ]
-;
-
-value parserify =
- fun
- [ <:expr< $e$ strm__ >> -> e
- | e -> <:expr< fun strm__ -> $e$ >> ]
-;
-
-value is_raise_failure =
- fun
- [ <:expr< raise Stream.Failure >> -> True
- | _ -> False ]
-;
-
-value is_raise_error =
- fun
- [ <:expr< raise (Stream.Error $_$) >> -> True
- | _ -> False ]
-;
-
-value semantic e =
- try
- if is_free "strm__" e then e
- else
- let v = free_var_in_expr 's' e in
- <:expr< let $lid:v$ = strm__ in $subst v e$ >>
- with
- [ NotImpl -> e ]
-;
-
-value rewrite_parser =
- rewrite True where rec rewrite top ge =
- match ge with
- [ <:expr< let $p$ = try $e$ with [ Stream.Failure -> raise $exc$ ] in
- $sp_kont$ >> ->
- let f = parserify e in
- <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some $p$ -> $rewrite False sp_kont$
- | _ -> raise $exc$ ]
- >>
- | <:expr< let $p$ = Stream.count strm__ in $f$ >> ->
- try
- if is_free "strm__" f then ge
- else
- let v = free_var_in_expr 's' f in
- <:expr<
- let $lid:v$ = strm__ in
- let $p$ = Stream.count strm__ in $subst v f$
- >>
- with
- [ NotImpl -> ge ]
- | <:expr< let $p$ = strm__ in $e$ >> ->
- <:expr< let $p$ = strm__ in $rewrite False e$ >>
- | <:expr< let $p$ = $f$ strm__ in $sp_kont$ >> when top ->
- <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some $p$ -> $rewrite False sp_kont$
- | _ -> raise Stream.Failure ]
- >>
- | <:expr< let $p$ = $e$ in $sp_kont$ >> ->
- if match e with
- [ <:expr< match try Some $_$ with [ Stream.Failure -> None ] with
- [ $list:_$ ] >>
- | <:expr< match Stream.peek strm__ with [ $list:_$ ] >>
- | <:expr< try $_$ with [ Stream.Failure -> $_$ ] >>
- | <:expr< let $_$ = Stream.count strm__ in $_$ >> -> True
- | _ -> False ]
- then
- let f = rewrite True <:expr< fun strm__ -> $e$ >> in
- let exc =
- if top then <:expr< Stream.Failure >>
- else <:expr< Stream.Error "" >>
- in
- <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some $p$ -> $rewrite False sp_kont$
- | _ -> raise $exc$ ]
- >>
- else semantic ge
- | <:expr< match try Some $e$ with [ Stream.Failure -> None ] with
- [ Some $p$ -> $sp_kont$
- | _ -> $p_kont$ ] >> ->
- let f = parserify e in
- if not top && is_raise_failure p_kont then semantic ge
- else
- let (p, f, sp_kont, p_kont) =
- if top || is_raise_error p_kont then
- (p, f, rewrite False sp_kont, rewrite top p_kont)
- else
- let f =
- <:expr<
- fun strm__ ->
- match
- try Some ($f$ strm__) with [ Stream.Failure -> None ]
- with
- [ Some $p$ -> $rewrite False sp_kont$
- | _ -> $rewrite top p_kont$ ]
- >>
- in
- (<:patt< a >>, f, <:expr< a >>,
- <:expr< raise (Stream.Error "") >>)
- in
- <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some $p$ -> $sp_kont$
- | _ -> $p_kont$ ]
- >>
- | <:expr< match Stream.peek strm__ with [ $list:pel$ ] >> ->
- let rec iter pel =
- match pel with
- [ [(<:patt< Some $p$ >>, eo,
- <:expr< do { Stream.junk strm__; $sp_kont$ } >>);
- (<:patt< _ >>, None, p_kont) :: _] ->
- <:expr<
- match Stream.peek strm__ with
- [ Some $p$ $when:eo$ ->
- do { Stream.junk strm__; $rewrite False sp_kont$ }
- | _ -> $rewrite top p_kont$ ]
- >>
- | [(<:patt< Some $p$ >>, eo,
- <:expr< do { Stream.junk strm__; $sp_kont$ } >>) :: pel] ->
- let p_kont = iter pel in
- <:expr<
- match Stream.peek strm__ with
- [ Some $p$ $when:eo$ ->
- do { Stream.junk strm__; $rewrite False sp_kont$ }
- | _ -> $p_kont$ ]
- >>
- | _ ->
- <:expr< match Stream.peek strm__ with [ $list:pel$ ] >> ]
- in
- iter pel
- | <:expr< try Some $e$ with [ Stream.Failure -> $p_kont$ ] >> ->
- let f = parserify e in
- let e =
- <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some a -> Some a
- | _ -> $p_kont$ ]
- >>
- in
- rewrite top e
- | <:expr< try $e$ with [ Stream.Failure -> $p_kont$ ] >> ->
- let f = parserify e in
- let e =
- <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some a -> a
- | _ -> $rewrite top p_kont$ ]
- >>
- in
- rewrite top e
- | <:expr< $f$ strm__ >> ->
- if top then
- <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some a -> a
- | _ -> raise Stream.Failure ]
- >>
- else
- let v = free_var_in_expr 's' f in
- <:expr< let $lid:v$ = strm__ in $f$ $lid:v$ >>
- | e -> semantic e ]
-;
-
-value parser_of_expr =
- let rec parser_cases e =
- match e with
- [ <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some $p$ -> $sp_kont$
- | _ -> $p_kont$ ]
- >> ->
- let spc = (SPCnterm p f, None) in
- let (sp, epo, e) = kont sp_kont in
- [([spc :: sp], epo, e) :: parser_cases p_kont]
- | <:expr<
- match Stream.peek strm__ with
- [ Some $p$ $when:wo$ -> do { Stream.junk strm__; $sp_kont$ }
- | _ -> $p_kont$ ]
- >> ->
- let spc = (SPCterm (p, wo), None) in
- let (sp, epo, e) = kont sp_kont in
- [([spc :: sp], epo, e) :: parser_cases p_kont]
- | <:expr< let $p$ = strm__ in $sp_kont$ >> ->
- let spc = (SPCsterm p, None) in
- let (sp, epo, e) = kont sp_kont in
- [([spc :: sp], epo, e)]
- | <:expr< let $p$ = Stream.count strm__ in $e$ >> -> [([], Some p, e)]
- | <:expr< raise Stream.Failure >> -> []
- | _ -> [([], None, e)] ]
- and kont e =
- match e with
- [ <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some $p$ -> $sp_kont$
- | _ -> raise (Stream.Error $err$) ]
- >> ->
- let err =
- match err with
- [ <:expr< "" >> -> None
- | _ -> Some err ]
- in
- let spc = (SPCnterm p f, err) in
- let (sp, epo, e) = kont sp_kont in
- ([spc :: sp], epo, e)
- | <:expr<
- match Stream.peek strm__ with
- [ Some $p$ $when:wo$ -> do { Stream.junk strm__; $sp_kont$ }
- | _ -> raise (Stream.Error $err$) ]
- >> ->
- let err =
- match err with
- [ <:expr< "" >> -> None
- | _ -> Some err ]
- in
- let spc = (SPCterm (p, wo), err) in
- let (sp, epo, e) = kont sp_kont in
- ([spc :: sp], epo, e)
- | <:expr< let $p$ = strm__ in $sp_kont$ >> ->
- let spc = (SPCsterm p, None) in
- let (sp, epo, e) = kont sp_kont in
- ([spc :: sp], epo, e)
- | <:expr< let $p$ = Stream.count strm__ in $e$ >> -> ([], Some p, e)
- | _ -> ([], None, e) ]
- in
- parser_cases
-;
-
-value parser_cases b spel dg k =
- let rec parser_cases b spel dg k =
- match spel with
- [ [] -> [: `HVbox [: b; k :] :]
- | [(sp, epo, e)] -> [: `parser_case b sp epo e dg k :]
- | [(sp, epo, e) :: spel] ->
- [: `parser_case b sp epo e "|" [: :];
- parser_cases [: `S LR "|" :] spel dg k :] ]
- and parser_case b sp epo e dg k =
- let epo =
- match epo with
- [ Some p -> [: `patt p "" [: `S LR "->" :] :]
- | _ -> [: `S LR "->" :] ]
- in
- HVbox
- [: b;
- `HOVbox
- [: `HOVbox
- [: `S LR "[<";
- stream_patt [: :] sp [: `S LR ">]"; epo :] :];
- `expr e dg k :] :]
- and stream_patt b sp k =
- match sp with
- [ [] -> [: `HVbox [: b; k :] :]
- | [(spc, None)] -> [: `stream_patt_comp b spc "" k :]
- | [(spc, Some e)] ->
- [: `HVbox
- [: `stream_patt_comp b spc "" [: :];
- `HVbox [: `S LR "??"; `expr e "" k :] :] :]
- | [(spc, None) :: spcl] ->
- [: `stream_patt_comp b spc ";" [: `S RO ";" :];
- stream_patt [: :] spcl k :]
- | [(spc, Some e) :: spcl] ->
- [: `HVbox
- [: `stream_patt_comp b spc "" [: :];
- `HVbox [: `S LR "??"; `expr e ";" [: `S RO ";" :] :] :];
- stream_patt [: :] spcl k :] ]
- and stream_patt_comp b spc dg k =
- match spc with
- [ SPCterm (p, w) ->
- HVbox [: b; `S LO "'"; `spatt p "" (when_opt w k) :]
- | SPCnterm p e ->
- HVbox [: b; `HVbox [: `patt p "" [: `S LR "=" :]; `expr e dg k :] :]
- | SPCsterm p -> HVbox [: b; `patt p "" k :] ]
- and when_opt wo k =
- match wo with
- [ Some e -> [: `S LR "when"; `expr e "" k :]
- | _ -> k ]
- in
- parser_cases b spel dg k
-;
-
-value parser_body e dg k =
- let (bp, e) =
- match e with
- [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e)
- | e -> (None, e) ]
- in
- let e = rewrite_parser e in
- match parser_of_expr e with
- [ [] ->
- let spe = ([], None, <:expr< raise Stream.Failure >>) in
- HVbox
- [: `HVbox
- [: `S LR "parser";
- match bp with
- [ Some p -> [: `patt p "" [: :] :]
- | _ -> [: :] ] :];
- parser_cases [: :] [spe] dg k :]
- | spel ->
- BEVbox
- [: `HVbox
- [: `S LR "parser";
- match bp with
- [ Some p -> [: `patt p "" [: :] :]
- | _ -> [: :] ] :];
- parser_cases [: :] spel dg k :] ]
-;
-
-value pmatch e dg k =
- let (me, e) =
- match e with
- [ <:expr< let (strm__ : Stream.t _) = $me$ in $e$ >> -> (me, e)
- | _ -> failwith "Pr_op.pmatch" ]
- in
- let (bp, e) =
- match e with
- [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e)
- | e -> (None, e) ]
- in
- let e = rewrite_parser e in
- let spel = parser_of_expr e in
- Vbox
- [: `HVbox [: :];
- `HVbox
- [: `S LR "match"; `expr me "" [: `S LR "with" :]; `S LR "parser";
- match bp with
- [ Some p -> [: `patt p "" [: :] :]
- | _ -> [: :] ] :];
- `BEbox [: `HVbox [: :]; parser_cases [: :] spel dg k :] :]
-;
-
-(* Printer extensions *)
-
-pr_expr_fun_args.val :=
- extfun pr_expr_fun_args.val with
- [ <:expr< fun strm__ -> $_$ >> as ge -> ([], ge)
- | <:expr< fun [(strm__ : $_$) -> $_$] >> as ge -> ([], ge) ];
-
-let lev = find_pr_level "expr1" pr_expr.pr_levels in
-lev.pr_rules :=
- extfun lev.pr_rules with
- [ <:expr< let (strm__ : Stream.t _) = $_$ in $_$ >> as e ->
- fun curr next dg k ->
- if not (List.mem dg ["|"; ";"]) then [: `pmatch e dg k :]
- else [: `S LO "("; `pmatch e "" [: `S RO ")"; k :] :]
- | <:expr< fun strm__ -> $x$ >> ->
- fun curr next dg k ->
- if not (List.mem dg ["|"; ";"]) then [: `parser_body x dg k :]
- else [: `S LO "("; `parser_body x "" [: `S RO ")"; k :] :]
- | <:expr< fun [ (strm__ : $_$) -> $x$ ] >> ->
- fun curr next dg k ->
- if not (List.mem dg ["|"; ";"]) then [: `parser_body x dg k :]
- else [: `S LO "("; `parser_body x "" [: `S RO ")"; k :] :] ];
-
-let lev = find_pr_level "apply" pr_expr.pr_levels in
-lev.pr_rules :=
- extfun lev.pr_rules with
- [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> |
- <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> |
- <:expr< Stream.lcons (fun _ -> $_$) $_$ >> |
- <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> |
- <:expr< Stream.slazy $_$ >> as e ->
- fun curr next dg k -> [: `next e "" k :] ];
-
-let lev = find_pr_level "dot" pr_expr.pr_levels in
-lev.pr_rules :=
- extfun lev.pr_rules with
- [ <:expr< Stream.sempty >> as e ->
- fun curr next dg k -> [: `next e "" k :] ];
-
-let lev = find_pr_level "simple" pr_expr.pr_levels in
-lev.pr_rules :=
- extfun lev.pr_rules with
- [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> |
- <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> |
- <:expr< Stream.lcons (fun _ -> $_$) $_$ >> |
- <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> |
- <:expr< Stream.slazy $_$ >> as e ->
- fun curr next dg k ->
- [: `stream e "" k :] ];
diff --git a/camlp4/etc/pr_op_main.ml b/camlp4/etc/pr_op_main.ml
deleted file mode 100644
index d7203e6e38..0000000000
--- a/camlp4/etc/pr_op_main.ml
+++ /dev/null
@@ -1,214 +0,0 @@
-(* camlp4r q_MLast.cmo ./pa_extfun.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1998 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Pcaml;
-open Spretty;
-
-value loc = (0, 0);
-
-value expr e dg k = pr_expr.pr_fun "top" e dg k;
-value patt e dg k = pr_patt.pr_fun "top" e dg k;
-
-value spatt p dg k =
- match p with
- [ <:patt< $lid:s$ >> ->
- if String.length s >= 2 && s.[1] == ''' then
- HVbox [: `S LR (" " ^ s); k :]
- else patt p dg k
- | _ -> patt p dg k ]
-;
-
-(* Streams *)
-
-value stream e _ k =
- let rec get =
- fun
- [ <:expr< Stream.iapp $x$ $y$ >> -> [(False, x) :: get y]
- | <:expr< Stream.icons $x$ $y$ >> -> [(True, x) :: get y]
- | <:expr< Stream.ising $x$ >> -> [(True, x)]
- | <:expr< Stream.lapp (fun _ -> $x$) $y$ >> -> [(False, x) :: get y]
- | <:expr< Stream.lcons (fun _ -> $x$) $y$ >> -> [(True, x) :: get y]
- | <:expr< Stream.lsing (fun _ -> $x$) >> -> [(True, x)]
- | <:expr< Stream.sempty >> -> []
- | <:expr< Stream.slazy (fun _ -> $x$) >> -> [(False, x)]
- | <:expr< Stream.slazy $x$ >> -> [(False, <:expr< $x$ () >>)]
- | e -> [(False, e)] ]
- in
- let elem e dg k =
- match e with
- [ (True, e) -> [: `HOVbox [: `S LO "'"; `expr e dg k :] :]
- | (False, e) -> [: `expr e dg k :] ]
- in
- let rec glop e k =
- match e with
- [ [] -> k
- | [e] -> [: elem e "" k :]
- | [e :: el] -> [: elem e ";" [: `S RO ";" :]; glop el k :] ]
- in
- HOVbox [: `S LR "[<"; glop (get e) [: `S LR ">]"; k :] :]
-;
-
-(* Parsers *)
-
-open Parserify;
-
-value parser_cases b spel dg k =
- let rec parser_cases b spel dg k =
- match spel with
- [ [] -> [: `HVbox [: b; k :] :]
- | [(sp, epo, e)] -> [: `parser_case b sp epo e dg k :]
- | [(sp, epo, e) :: spel] ->
- [: `parser_case b sp epo e "|" [: :];
- parser_cases [: `S LR "|" :] spel dg k :] ]
- and parser_case b sp epo e dg k =
- let epo =
- match epo with
- [ Some p -> [: `patt p "" [: `S LR "->" :] :]
- | _ -> [: `S LR "->" :] ]
- in
- HVbox
- [: b;
- `HOVbox
- [: `HOVbox
- [: `S LR "[<";
- stream_patt [: :] sp [: `S LR ">]"; epo :] :];
- `expr e dg k :] :]
- and stream_patt b sp k =
- match sp with
- [ [] -> [: `HVbox [: b; k :] :]
- | [(spc, None)] -> [: `stream_patt_comp b spc "" k :]
- | [(spc, Some e)] ->
- [: `HVbox
- [: `stream_patt_comp b spc "" [: :];
- `HVbox [: `S LR "??"; `expr e "" k :] :] :]
- | [(spc, None) :: spcl] ->
- [: `stream_patt_comp b spc ";" [: `S RO ";" :];
- stream_patt [: :] spcl k :]
- | [(spc, Some e) :: spcl] ->
- [: `HVbox
- [: `stream_patt_comp b spc "" [: :];
- `HVbox [: `S LR "??"; `expr e ";" [: `S RO ";" :] :] :];
- stream_patt [: :] spcl k :] ]
- and stream_patt_comp b spc dg k =
- match spc with
- [ SPCterm (p, w) ->
- HVbox [: b; `S LO "'"; `spatt p "" (when_opt w k) :]
- | SPCnterm p e ->
- HVbox [: b; `HVbox [: `patt p "" [: `S LR "=" :]; `expr e dg k :] :]
- | SPCsterm p -> HVbox [: b; `patt p "" k :] ]
- and when_opt wo k =
- match wo with
- [ Some e -> [: `S LR "when"; `expr e "" k :]
- | _ -> k ]
- in
- parser_cases b spel dg k
-;
-
-value parser_body e dg k =
- let (bp, e) =
- match e with
- [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e)
- | e -> (None, e) ]
- in
- match parser_of_expr e with
- [ [] ->
- let spe = ([], None, <:expr< raise Stream.Failure >>) in
- HVbox
- [: `HVbox
- [: `S LR "parser";
- match bp with
- [ Some p -> [: `patt p "" [: :] :]
- | _ -> [: :] ] :];
- parser_cases [: :] [spe] dg k :]
- | spel ->
- BEVbox
- [: `HVbox
- [: `S LR "parser";
- match bp with
- [ Some p -> [: `patt p "" [: :] :]
- | _ -> [: :] ] :];
- parser_cases [: :] spel dg k :] ]
-;
-
-value pmatch e dg k =
- let (me, e) =
- match e with
- [ <:expr< let (strm__ : Stream.t _) = $me$ in $e$ >> -> (me, e)
- | _ -> failwith "Pr_op.pmatch" ]
- in
- let (bp, e) =
- match e with
- [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e)
- | e -> (None, e) ]
- in
- let spel = parser_of_expr e in
- Vbox
- [: `HVbox [: :];
- `HVbox
- [: `S LR "match"; `expr me "" [: `S LR "with" :]; `S LR "parser";
- match bp with
- [ Some p -> [: `patt p "" [: :] :]
- | _ -> [: :] ] :];
- `BEbox [: `HVbox [: :]; parser_cases [: :] spel dg k :] :]
-;
-
-(* Printer extensions *)
-
-pr_expr_fun_args.val :=
- extfun pr_expr_fun_args.val with
- [ <:expr< fun strm__ -> $_$ >> as ge -> ([], ge)
- | <:expr< fun [(strm__ : $_$) -> $_$] >> as ge -> ([], ge) ];
-
-let lev = find_pr_level "expr1" pr_expr.pr_levels in
-lev.pr_rules :=
- extfun lev.pr_rules with
- [ <:expr< let (strm__ : Stream.t _) = $_$ in $_$ >> as e ->
- fun curr next dg k ->
- if not (List.mem dg ["|"; ";"]) then [: `pmatch e dg k :]
- else [: `S LO "("; `pmatch e "" [: `S RO ")"; k :] :]
- | <:expr< fun strm__ -> $x$ >> ->
- fun curr next dg k ->
- if not (List.mem dg ["|"; ";"]) then [: `parser_body x dg k :]
- else [: `S LO "("; `parser_body x "" [: `S RO ")"; k :] :]
- | <:expr< fun [ (strm__ : $_$) -> $x$ ] >> ->
- fun curr next dg k ->
- if not (List.mem dg ["|"; ";"]) then [: `parser_body x dg k :]
- else [: `S LO "("; `parser_body x "" [: `S RO ")"; k :] :] ];
-
-let lev = find_pr_level "apply" pr_expr.pr_levels in
-lev.pr_rules :=
- extfun lev.pr_rules with
- [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> |
- <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> |
- <:expr< Stream.lcons (fun _ -> $_$) $_$ >> |
- <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> |
- <:expr< Stream.slazy $_$ >> as e ->
- fun curr next dg k -> [: `next e "" k :] ];
-
-let lev = find_pr_level "dot" pr_expr.pr_levels in
-lev.pr_rules :=
- extfun lev.pr_rules with
- [ <:expr< Stream.sempty >> as e ->
- fun curr next dg k -> [: `next e "" k :] ];
-
-let lev = find_pr_level "simple" pr_expr.pr_levels in
-lev.pr_rules :=
- extfun lev.pr_rules with
- [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> |
- <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> |
- <:expr< Stream.lcons (fun _ -> $_$) $_$ >> |
- <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> |
- <:expr< Stream.slazy $_$ >> as e ->
- fun curr next dg k ->
- [: `stream e "" k :] ];
diff --git a/camlp4/etc/pr_r.ml b/camlp4/etc/pr_r.ml
deleted file mode 100644
index eb14e73762..0000000000
--- a/camlp4/etc/pr_r.ml
+++ /dev/null
@@ -1,1898 +0,0 @@
-(* camlp4r q_MLast.cmo ./pa_extfun.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Pcaml;
-open Spretty;
-
-value not_impl name x =
- let desc =
- if Obj.is_block (Obj.repr x) then
- "tag = " ^ string_of_int (Obj.tag (Obj.repr x))
- else "int_val = " ^ string_of_int (Obj.magic x)
- in
- HVbox [: `S NO ("<pr_r: not impl: " ^ name ^ "; " ^ desc ^ ">") :]
-;
-
-value gen_where = ref True;
-value old_sequences = ref False;
-value expand_declare = ref False;
-
-external is_printable : char -> bool = "is_printable";
-
-value char_escaped =
- fun
- [ '\\' -> "\\\\"
- | '\b' -> "\\b"
- | '\n' -> "\\n"
- | '\r' -> "\\r"
- | '\t' -> "\\t"
- | c ->
- if is_printable c then String.make 1 c
- else do {
- let n = Char.code c in
- let s = String.create 4 in
- String.unsafe_set s 0 '\\';
- String.unsafe_set s 1 (Char.unsafe_chr (48 + n / 100));
- String.unsafe_set s 2 (Char.unsafe_chr (48 + n / 10 mod 10));
- String.unsafe_set s 3 (Char.unsafe_chr (48 + n mod 10));
- s
- } ]
-;
-
-value rec list elem el k =
- match el with
- [ [] -> k
- | [x] -> [: `elem x k :]
- | [x :: l] -> [: `elem x [: :]; list elem l k :] ]
-;
-
-value rec listws elem sep el k =
- match el with
- [ [] -> k
- | [x] -> [: `elem x k :]
- | [x :: l] -> [: `elem x [: `sep :]; listws elem sep l k :] ]
-;
-
-value rec listwbws elem b sep el k =
- match el with
- [ [] -> [: b; k :]
- | [x] -> [: `elem b x k :]
- | [x :: l] -> [: `elem b x [: :]; listwbws elem [: `sep :] sep l k :] ]
-;
-
-value is_infix =
- let infixes = Hashtbl.create 73 in
- do {
- List.iter (fun s -> Hashtbl.add infixes s True)
- ["=="; "!="; "+"; "+."; "-"; "-."; "*"; "*."; "/"; "/."; "**";
- "="; "=."; "<>"; "<>."; "<"; "<."; ">"; ">."; "<="; "<=."; ">="; ">=.";
- "^"; "@"; "asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or";
- "&&"; "||"; "~-"; "~-."];
- fun s -> try Hashtbl.find infixes s with [ Not_found -> False ]
- }
-;
-
-value is_keyword =
- let keywords = Hashtbl.create 301 in
- do {
- List.iter (fun s -> Hashtbl.add keywords s True)
- ["!"; "!="; "#"; "&"; "&&"; "'"; "("; ")"; "*"; "**"; "*."; "+"; "+.";
- ","; "-"; "-."; "->"; "."; ".."; "/"; "/."; ":"; "::"; ":="; ":>";
- ":]"; ";"; "<"; "<="; "<>"; "="; "=="; ">"; ">="; ">}"; "?"; "@"; "[";
- "[:"; "[|"; "]"; "^"; "_"; "`"; "and"; "as"; "asr"; "assert"; "class";
- "constraint"; "declare"; "do"; "done"; "downto"; "else"; "end";
- "exception"; "external"; "for"; "fun"; "functor"; "if"; "in";
- "include"; "inherit"; "initializer"; "land"; "lazy"; "let"; "lor";
- "lsl"; "lsr"; "lxor"; "match"; "method"; "mod"; "module"; "mutable";
- "new"; "object"; "of"; "open"; "parser"; "private"; "rec"; "return";
- "sig"; "struct"; "then"; "to"; "try"; "type"; "value"; "virtual";
- "when"; "where"; "while"; "with"; "{"; "{<"; "|"; "|]"; "||"; "}";
- "~-"; "~-."];
- fun s -> try Hashtbl.find keywords s with [ Not_found -> False ]
- }
-;
-
-value has_special_chars v =
- match v.[0] with
- [ 'a'..'z' | 'A'..'Z' | '\192'..'\214' | '\216'..'\246' | '\248'..'\255' |
- '_' ->
- False
- | _ ->
- if String.length v >= 2 && v.[0] == '<' &&
- (v.[1] == '<' || v.[1] == ':')
- then
- False
- else True ]
-;
-
-value var_escaped v =
- if v = "" then "$lid:\"\"$"
- else if has_special_chars v || is_infix v then "\\" ^ v
- else if is_keyword v then v ^ "__"
- else v
-;
-
-value flag n f = if f then [: `S LR n :] else [: :];
-
-(* default global loc *)
-
-value loc = (0, 0);
-
-(* extensible printers *)
-
-value module_type e k = pr_module_type.pr_fun "top" e "" k;
-value module_expr e k = pr_module_expr.pr_fun "top" e "" k;
-value sig_item x k = pr_sig_item.pr_fun "top" x "" [: `S RO ";"; k :];
-value str_item x k = pr_str_item.pr_fun "top" x "" [: `S RO ";"; k :];
-value expr x k = pr_expr.pr_fun "top" x "" k;
-value patt x k = pr_patt.pr_fun "top" x "" k;
-value ctyp x k = pr_ctyp.pr_fun "top" x "" k;
-value expr_fun_args ge = Extfun.apply pr_expr_fun_args.val ge;
-value simple_expr x k = pr_expr.pr_fun "simple" x "" k;
-value class_sig_item x k =
- pr_class_sig_item.pr_fun "top" x "" [: `S RO ";"; k :]
-;
-value class_str_item x k =
- pr_class_str_item.pr_fun "top" x "" [: `S RO ";"; k :]
-;
-value class_type x k = pr_class_type.pr_fun "top" x "" k;
-value class_expr x k = pr_class_expr.pr_fun "top" x "" k;
-
-
-(* type core *)
-
-value rec labels loc b vl k =
- match vl with
- [ [] -> [: b; k :]
- | [v] ->
- [: `HVbox
- [: `HVbox [: :]; `label True b v [: :];
- `LocInfo (snd loc, snd loc) (HVbox k) :] :]
- | [v :: l] -> [: `label False b v [: :]; labels loc [: :] l k :] ]
-and label is_last b (loc, f, m, t) k =
- let m = flag "mutable" m in
- let k = [: if is_last then [: :] else [: `S RO ";" :]; k :] in
- Hbox
- [: `LocInfo loc
- (HVbox
- [: `HVbox [: b; `S LR f; `S LR ":" :];
- `HVbox [: m; `ctyp t [: :] :] :]);
- k :]
-;
-
-value rec ctyp_list tel k = listws ctyp (S LR "and") tel k;
-
-value rec variants loc b vl k =
- match vl with
- [ [] -> [: b; k :]
- | [v] ->
- [: `HVbox
- [: `HVbox [: :]; `variant b v [: :];
- `LocInfo (snd loc, snd loc) (HVbox k) :] :]
- | [v :: l] -> [: `variant b v [: :]; variants loc [: `S LR "|" :] l k :] ]
-and variant b (loc, c, tl) k =
- match tl with
- [ [] -> HVbox [: `LocInfo loc (HVbox b); `HOVbox [: `S LR c; k :] :]
- | _ ->
- HVbox
- [: `LocInfo loc (HVbox b);
- `HOVbox [: `S LR c; `S LR "of"; ctyp_list tl k :] :] ]
-;
-
-value rec row_fields b rfl k = listwbws row_field b (S LR "|") rfl k
-and row_field b rf k =
- match rf with
- [ MLast.RfTag c ao tl ->
- let c = "`" ^ c in
- match tl with
- [ [] -> HVbox [: b; `HOVbox [: `S LR c; k :] :]
- | _ ->
- let ao = if ao then [: `S LR "&" :] else [: :] in
- HVbox
- [: b; `HOVbox [: `S LR c; `S LR "of"; ao; ctyp_list tl k :] :] ]
- | MLast.RfInh t -> HVbox [: b; `ctyp t k :] ]
-;
-
-(* *)
-
-value rec class_longident sl k =
- match sl with
- [ [i] -> HVbox [: `S LR i; k :]
- | [m :: sl] -> HVbox [: `S LR m; `S NO "."; `class_longident sl k :]
- | _ -> HVbox [: `not_impl "class_longident" sl; k :] ]
-;
-
-value rec clty_longident sl k =
- match sl with
- [ [i] -> HVbox [: `S LR i; k :]
- | [m :: sl] -> HVbox [: `S LR m; `S NO "."; `clty_longident sl k :]
- | _ -> HVbox [: `not_impl "clty_longident" sl; k :] ]
-;
-
-value rec meth_list (ml, v) k =
- match (ml, v) with
- [ ([f], False) -> [: `field f k :]
- | ([], _) -> [: `S LR ".."; k :]
- | ([f :: ml], v) -> [: `field f [: `S RO ";" :]; meth_list (ml, v) k :] ]
-and field (lab, t) k =
- HVbox [: `S LR (var_escaped lab); `S LR ":"; `ctyp t k :]
-;
-
-(* patterns *)
-
-value rec is_irrefut_patt =
- fun
- [ <:patt< $lid:_$ >> -> True
- | <:patt< () >> -> True
- | <:patt< _ >> -> True
- | <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y
- | <:patt< { $list:fpl$ } >> ->
- List.for_all (fun (_, p) -> is_irrefut_patt p) fpl
- | <:patt< ($p$ : $_$) >> -> is_irrefut_patt p
- | <:patt< ($list:pl$) >> -> List.for_all is_irrefut_patt pl
- | <:patt< ? $_$ >> -> True
- | <:patt< ? $_$ : ( $p$ ) >> -> is_irrefut_patt p
- | <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p
- | <:patt< ~ $_$ >> -> True
- | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p
- | _ -> False ]
-;
-
-value rec get_defined_ident =
- fun
- [ <:patt< $_$ . $_$ >> -> []
- | <:patt< _ >> -> []
- | <:patt< $lid:x$ >> -> [x]
- | <:patt< ($p1$ as $p2$) >> -> get_defined_ident p1 @ get_defined_ident p2
- | <:patt< $int:_$ >> -> []
- | (MLast.PaNativeInt _ _ | MLast.PaInt64 _ _ | MLast.PaInt32 _ _) -> []
- | <:patt< $flo:_$ >> -> []
- | <:patt< $str:_$ >> -> []
- | <:patt< $chr:_$ >> -> []
- | <:patt< [| $list:pl$ |] >> -> List.flatten (List.map get_defined_ident pl)
- | <:patt< ($list:pl$) >> -> List.flatten (List.map get_defined_ident pl)
- | <:patt< $uid:_$ >> -> []
- | <:patt< ` $_$ >> -> []
- | <:patt< # $list:_$ >> -> []
- | <:patt< $p1$ $p2$ >> -> get_defined_ident p1 @ get_defined_ident p2
- | <:patt< { $list:lpl$ } >> ->
- List.flatten (List.map (fun (lab, p) -> get_defined_ident p) lpl)
- | <:patt< $p1$ | $p2$ >> -> get_defined_ident p1 @ get_defined_ident p2
- | <:patt< $p1$ .. $p2$ >> -> get_defined_ident p1 @ get_defined_ident p2
- | <:patt< ($p$ : $_$) >> -> get_defined_ident p
- | <:patt< ~ $_$ >> -> []
- | <:patt< ~ $_$ : $p$ >> -> get_defined_ident p
- | <:patt< ? $_$ >> -> []
- | <:patt< ? $_$ : ($p$) >> -> get_defined_ident p
- | <:patt< ? $_$ : ($p$ = $e$) >> -> get_defined_ident p
- | <:patt< $anti:p$ >> -> get_defined_ident p ]
-;
-
-value un_irrefut_patt p =
- match get_defined_ident p with
- [ [] -> (<:patt< _ >>, <:expr< () >>)
- | [i] -> (<:patt< $lid:i$ >>, <:expr< $lid:i$ >>)
- | il ->
- let (upl, uel) =
- List.fold_right
- (fun i (upl, uel) ->
- ([<:patt< $lid:i$ >> :: upl], [<:expr< $lid:i$ >> :: uel]))
- il ([], [])
- in
- (<:patt< ($list:upl$) >>, <:expr< ($list:uel$) >>) ]
-;
-
-(* expressions *)
-
-pr_expr_fun_args.val :=
- extfun Extfun.empty with
- [ <:expr< fun [$p$ -> $e$] >> as ge ->
- if is_irrefut_patt p then
- let (pl, e) = expr_fun_args e in
- ([p :: pl], e)
- else ([], ge)
- | ge -> ([], ge) ];
-
-value rec bind_list b pel k =
- match pel with
- [ [pe] -> let_binding b pe k
- | pel ->
- Vbox [: `HVbox [: :]; listwbws let_binding b (S LR "and") pel k :] ]
-and let_binding b (p, e) k =
- let (p, e) =
- if is_irrefut_patt p then (p, e)
- else
- let (up, ue) = un_irrefut_patt p in
- (up, <:expr< match $e$ with [ $p$ -> $ue$ ] >>)
- in
- let loc =
- let (bp1, ep1) = MLast.loc_of_patt p in
- let (bp2, ep2) = MLast.loc_of_expr e in
- (min bp1 bp2, max ep1 ep2)
- in
- LocInfo loc (BEbox [: let_binding0 [: b; `patt p [: :] :] e [: :]; k :])
-and let_binding0 b e k =
- let (pl, e) = expr_fun_args e in
- match e with
- [ <:expr< let $opt:r$ $lid:f$ = fun [ $list:pel$ ] in $e$ >>
- when
- let rec call_f =
- fun
- [ <:expr< $lid:f'$ >> -> f = f'
- | <:expr< $e$ $_$ >> -> call_f e
- | _ -> False ]
- in
- gen_where.val && call_f e ->
- let (pl1, e1) = expr_fun_args <:expr< fun [ $list:pel$ ] >> in
- [: `HVbox [: `HVbox b; `HOVbox (list patt pl [: `S LR "=" :]) :];
- `HVbox
- [: `HOVbox
- [: `expr e [: :]; `S LR "where"; flag "rec" r; `S LR f;
- `HVbox (list patt pl1 [: `S LR "=" :]) :];
- `expr e1 k :] :]
- | <:expr< ($e$ : $t$) >> ->
- [: `HVbox
- [: `HVbox b; `HOVbox (list patt pl [: `S LR ":" :]);
- `ctyp t [: `S LR "=" :] :];
- `expr e k :]
- | _ ->
- [: `HVbox [: `HVbox b; `HOVbox (list patt pl [: `S LR "=" :]) :];
- `expr e k :] ]
-and match_assoc_list pwel k =
- match pwel with
- [ [pwe] -> match_assoc [: `S LR "[" :] pwe [: `S LR "]"; k :]
- | pel ->
- Vbox
- [: `HVbox [: :];
- listwbws match_assoc [: `S LR "[" :] (S LR "|") pel
- [: `S LR "]"; k :] :] ]
-and match_assoc b (p, w, e) k =
- let s =
- let (p, k) =
- match p with
- [ <:patt< ($p$ as $p2$) >> -> (p, [: `S LR "as"; `patt p2 [: :] :])
- | _ -> (p, [: :]) ]
- in
- match w with
- [ Some e1 ->
- [: `HVbox
- [: `HVbox [: :]; `patt p k;
- `HVbox [: `S LR "when"; `expr e1 [: `S LR "->" :] :] :] :]
- | _ -> [: `patt p [: k; `S LR "->" :] :] ]
- in
- HVbox [: b; `HVbox [: `HVbox s; `expr e k :] :]
-;
-
-value label lab = S LR (var_escaped lab);
-
-value field_expr (lab, e) k = HVbox [: `label lab; `S LR "="; `expr e k :];
-
-value rec sequence_loop =
- fun
- [ [<:expr< let $opt:r$ $list:pel$ in $e$ >>] ->
- let el =
- match e with
- [ <:expr< do { $list:el$ } >> -> el
- | _ -> [e] ]
- in
- let r = flag "rec" r in
- [: listwbws (fun b (p, e) k -> let_binding b (p, e) k)
- [: `S LR "let"; r :] (S LR "and") pel [: `S LR "in" :];
- sequence_loop el :]
- | [(<:expr< let $opt:_$ $list:_$ in $_$ >> as e) :: el] ->
- [: `simple_expr e [: `S RO ";" :]; sequence_loop el :]
- | [e] -> [: `expr e [: :] :]
- | [e :: el] -> [: `expr e [: `S RO ";" :]; sequence_loop el :]
- | [] -> [: :] ]
-;
-
-value sequence b1 b2 b3 el k =
- BEbox
- [: `BEbox [: b1; b2; `HVbox [: b3; `S LR "do {" :] :];
- `HVbox [: `HVbox [: :]; sequence_loop el :];
- `HVbox [: `S LR "}"; k :] :]
-;
-
-value rec let_sequence e =
- match e with
- [ <:expr< do { $list:el$ } >> -> Some el
- | <:expr< let $opt:_$ $list:_$ in $e1$ >> ->
- match let_sequence e1 with
- [ Some _ -> Some [e]
- | None -> None ]
- | _ -> None ]
-;
-
-value ifbox b1 b2 b3 e k =
- if old_sequences.val then HVbox [: `HOVbox [: b1; b2; b3 :]; `expr e k :]
- else
- match let_sequence e with
- [ Some el -> sequence b1 b2 b3 el k
- | None -> HVbox [: `BEbox [: b1; b2; b3 :]; `expr e k :] ]
-;
-
-value rec type_params sl k =
- list
- (fun (s, vari) k ->
- let b =
- match vari with
- [ (True, False) -> [: `S LO "+" :]
- | (False, True) -> [: `S LO "-" :]
- | _ -> [: :] ]
- in
- HVbox [: b; `S LO "'"; `S LR s; k :])
- sl k
-;
-
-value constrain (t1, t2) k =
- HVbox [: `S LR "constraint"; `ctyp t1 [: `S LR "=" :]; `ctyp t2 k :]
-;
-
-value type_list b tdl k =
- HVbox
- [: `HVbox [: :];
- listwbws
- (fun b ((_, tn), tp, te, cl) k ->
- let tn = var_escaped tn in
- HVbox
- [: `HVbox [: b; `S LR tn; type_params tp [: `S LR "=" :] :];
- `ctyp te [: :]; list constrain cl k :])
- b (S LR "and") tdl [: :];
- k :]
-;
-
-value external_def s t pl k =
- let ls = list (fun s k -> HVbox [: `S LR ("\"" ^ s ^ "\""); k :]) pl k in
- HVbox
- [: `HVbox [: `S LR "external"; `S LR (var_escaped s); `S LR ":" :];
- `ctyp t [: `S LR "="; ls :] :]
-;
-
-value value_description s t k =
- HVbox
- [: `HVbox [: `S LR "value"; `S LR (var_escaped s); `S LR ":" :];
- `ctyp t k :]
-;
-
-value typevar s k = HVbox [: `S LR ("'" ^ s); k :];
-
-value rec mod_ident sl k =
- match sl with
- [ [] -> k
- | [s] -> [: `S LR (var_escaped s); k :]
- | [s :: sl] -> [: `S LR s; `S NO "."; mod_ident sl k :] ]
-;
-
-value rec module_declaration b mt k =
- match mt with
- [ <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ->
- module_declaration
- [: `HVbox
- [: b;
- `HVbox
- [: `S LO "("; `S LR i; `S LR ":";
- `module_type t [: `S RO ")" :] :] :] :]
- mt k
- | _ ->
- HVbox
- [: `HVbox [: :];
- `HVbox [: `HVbox [: b; `S LR ":" :]; `module_type mt [: :] :];
- k :] ]
-and module_rec_declaration b (n,mt) k =
- HVbox
- [: `HVbox
- [: b; `S LR n; `S LR ":"; `module_type mt [: :] :];
- k :]
-and modtype_declaration s mt k =
- HVbox
- [: `HVbox [: :];
- `HVbox
- [: `HVbox [: `S LR "module"; `S LR "type"; `S LR s; `S LR "=" :];
- `module_type mt [: :] :];
- k :]
-and with_constraints b icl k =
- HVbox [: `HVbox [: :]; listwbws with_constraint b (S LR "and") icl k :]
-and with_constraint b wc k =
- match wc with
- [ <:with_constr< type $p$ $list:al$ = $e$ >> ->
- let params =
- match al with
- [ [] -> [: :]
- | [s] -> [: `S LO "'"; `S LR (fst s) :]
- | sl -> [: `S LO "("; type_params sl [: `S RO ")" :] :] ]
- in
- HVbox
- [: `HVbox
- [: `HVbox b; `S LR "type"; params;
- mod_ident p [: `S LR "=" :] :];
- `ctyp e k :]
- | <:with_constr< module $sl$ = $me$ >> ->
- HVbox
- [: b; `S LR "module"; mod_ident sl [: `S LR "=" :];
- `module_expr me k :] ]
-and module_binding b me k =
- match me with
- [ <:module_expr< functor ($s$ : $mt$) -> $mb$ >> ->
- module_binding
- [: `HVbox
- [: b;
- `HVbox
- [: `HVbox [: `S LO "("; `S LR s; `S LR ":" :];
- `module_type mt [: `S RO ")" :] :] :] :]
- mb k
- | <:module_expr< ( $me$ : $mt$ ) >> ->
- HVbox
- [: `HVbox [: :];
- `HVbox
- [: `HVbox
- [: `HVbox [: b; `S LR ":" :];
- `module_type mt [: `S LR "=" :] :];
- `module_expr me [: :] :];
- k :]
- | _ ->
- HVbox
- [: `HVbox [: :];
- `HVbox [: `HVbox [: b; `S LR "=" :]; `module_expr me [: :] :];
- k :] ]
-and module_rec_binding b (n, mt,me) k =
- HVbox
- [: `HVbox [: :];
- `HVbox
- [: `HVbox
- [: `HVbox [: b; `S LR n; `S LR ":" :];
- `module_type mt [: `S LR "=" :] :];
- `module_expr me [: :] :];
- k :]
-and class_declaration b ci k =
- class_fun_binding
- [: b; flag "virtual" ci.MLast.ciVir; `S LR ci.MLast.ciNam;
- class_type_parameters ci.MLast.ciPrm :]
- ci.MLast.ciExp k
-and class_fun_binding b ce k =
- match ce with
- [ <:class_expr< fun $p$ -> $cfb$ >> ->
- class_fun_binding [: b; `patt p [: :] :] cfb k
- | ce -> HVbox [: `HVbox [: b; `S LR "=" :]; `class_expr ce k :] ]
-and class_type_parameters (loc, tpl) =
- match tpl with
- [ [] -> [: :]
- | tpl ->
- [: `S LO "["; listws type_parameter (S RO ",") tpl [: `S RO "]" :] :] ]
-and type_parameter tp k = HVbox [: `S LO "'"; `S LR (fst tp); k :]
-and simple_expr e k =
- match e with
- [ <:expr< $lid:_$ >> -> expr e k
- | _ -> HVbox [: `S LO "("; `expr e [: `S RO ")"; k :] :] ]
-and class_self_patt_opt csp =
- match csp with
- [ Some p -> HVbox [: `S LO "("; `patt p [: `S RO ")" :] :]
- | None -> HVbox [: :] ]
-and label lab = S LR (var_escaped lab)
-and cvalue b (lab, mf, e) k =
- HVbox
- [: `HVbox [: b; flag "mutable" mf; `label lab; `S LR "=" :]; `expr e k :]
-and fun_binding b fb k =
- match fb with
- [ <:expr< fun $p$ -> $e$ >> -> fun_binding [: b; `simple_patt p [: :] :] e k
- | e -> HVbox [: `HVbox [: b; `S LR "=" :]; `expr e k :] ]
-and simple_patt p k =
- match p with
- [ <:patt< $lid:_$ >> | <:patt< ~ $_$ : $_$ >> |
- <:patt< ? $_$ : ($_$ $opt:_$) >> -> patt p k
- | _ -> HVbox [: `S LO "("; `patt p [: `S RO ")"; k :] :] ]
-and class_signature cs k =
- match cs with
- [ <:class_type< $list:id$ >> -> clty_longident id k
- | <:class_type< $list:id$ [ $list:tl$ ] >> ->
- HVbox
- [: `clty_longident id [: :]; `S LO "[";
- listws ctyp (S RO ",") tl [: `S RO "]"; k :] :]
- | <:class_type< object $opt:cst$ $list:csf$ end >> ->
- let ep = snd (MLast.loc_of_class_type cs) in
- class_self_type [: `S LR "object" :] cst
- [: `HVbox
- [: `HVbox [: :]; list class_sig_item csf [: :];
- `LocInfo (ep, ep) (HVbox [: :]) :];
- `HVbox [: `S LR "end"; k :] :]
- | _ -> HVbox [: `not_impl "class_signature" cs; k :] ]
-and class_self_type b cst k =
- BEbox
- [: `HVbox
- [: b;
- match cst with
- [ None -> [: :]
- | Some t -> [: `S LO "("; `ctyp t [: `S RO ")" :] :] ] :];
- k :]
-and class_description b ci k =
- HVbox
- [: `HVbox
- [: b; flag "virtual" ci.MLast.ciVir; `S LR ci.MLast.ciNam;
- class_type_parameters ci.MLast.ciPrm; `S LR ":" :];
- `class_type ci.MLast.ciExp k :]
-and class_type_declaration b ci k =
- HVbox
- [: `HVbox
- [: b; flag "virtual" ci.MLast.ciVir; `S LR ci.MLast.ciNam;
- class_type_parameters ci.MLast.ciPrm; `S LR "=" :];
- `class_signature ci.MLast.ciExp k :]
-;
-
-pr_module_type.pr_levels :=
- [{pr_label = "top"; pr_box s x = HVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:module_type< functor ( $s$ : $mt1$ ) -> $mt2$ >> ->
- fun curr next _ k ->
- let head =
- HVbox
- [: `S LR "functor"; `S LO "("; `S LR s; `S LR ":";
- `module_type mt1 [: `S RO ")" :]; `S LR "->" :]
- in
- [: `head; `module_type mt2 k :]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = ""; pr_box s x = HVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:module_type< $mt$ with $list:icl$ >> ->
- fun curr next _ k ->
- [: curr mt "" [: :]; `with_constraints [: `S LR "with" :] icl k :]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = ""; pr_box s x = HVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:module_type< sig $list:s$ end >> as mt ->
- fun curr next _ k ->
- let ep = snd (MLast.loc_of_module_type mt) in
- [: `BEbox
- [: `S LR "sig";
- `HVbox
- [: `HVbox [: :]; list sig_item s [: :];
- `LocInfo (ep, ep) (HVbox [: :]) :];
- `HVbox [: `S LR "end"; k :] :] :]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = ""; pr_box s x = HVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:module_type< $mt1$ $mt2$ >> ->
- fun curr next _ k -> [: curr mt1 "" [: :]; `next mt2 "" k :]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = ""; pr_box s x = HVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:module_type< $mt1$ . $mt2$ >> ->
- fun curr next _ k ->
- [: curr mt1 "" [: `S NO "." :]; `next mt2 "" k :]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = ""; pr_box s x = HVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:module_type< $lid:s$ >> -> fun curr next _ k -> [: `S LR s; k :]
- | <:module_type< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :]
- | <:module_type< ' $s$ >> ->
- fun curr next _ k -> [: `S LR ("'" ^ s); k :]
- | mt ->
- fun curr next _ k ->
- [: `S LO "("; `module_type mt [: `S RO ")"; k :] :] ]}];
-
-pr_module_expr.pr_levels :=
- [{pr_label = "top"; pr_box s x = HVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:module_expr< struct $list:s$ end >> as me ->
- fun curr next _ k ->
- let ep = snd (MLast.loc_of_module_expr me) in
- [: `HVbox [: :];
- `HVbox
- [: `S LR "struct"; list str_item s [: :];
- `LocInfo (ep, ep) (HVbox [: :]) :];
- `HVbox [: `S LR "end"; k :] :]
- | <:module_expr< functor ($s$ : $mt$) -> $me$ >> ->
- fun curr next _ k ->
- let head =
- HVbox
- [: `S LR "functor"; `S LO "("; `S LR s; `S LR ":";
- `module_type mt [: `S RO ")" :]; `S LR "->" :]
- in
- [: `head; curr me "" k :]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = ""; pr_box s x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:module_expr< $me1$ $me2$ >> ->
- fun curr next _ k -> [: curr me1 "" [: :]; `next me2 "" k :]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = ""; pr_box s x = HVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:module_expr< $me1$ . $me2$ >> ->
- fun curr next _ k ->
- [: curr me1 "" [: `S NO "." :]; `next me2 "" k :]
- | e -> fun curr next dg k -> [: `next e dg k :] ]};
- {pr_label = ""; pr_box s x = HVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:module_expr< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :]
- | <:module_expr< ( $me$ : $mt$ ) >> ->
- fun curr next _ k ->
- [: `S LO "("; `module_expr me [: `S LR ":" :];
- `module_type mt [: `S RO ")"; k :] :]
- | <:module_expr< struct $list:_$ end >> |
- <:module_expr< functor ($_$ : $_$) -> $_$ >> |
- <:module_expr< $_$ $_$ >> | <:module_expr< $_$ . $_$ >> as me ->
- fun curr next _ k ->
- [: `S LO "("; `module_expr me [: `S RO ")"; k :] :] ]}];
-
-pr_sig_item.pr_levels :=
- [{pr_label = "top";
- pr_box s x = LocInfo (MLast.loc_of_sig_item s) (HVbox x);
- pr_rules =
- extfun Extfun.empty with
- [ <:sig_item< type $list:stl$ >> ->
- fun curr next _ k -> [: `type_list [: `S LR "type" :] stl k :]
- | <:sig_item< declare $list:s$ end >> ->
- fun curr next _ k ->
- if expand_declare.val then
- if s = [] then [: `S LR "(* *)" :]
- else [: `HVbox [: :]; list sig_item s [: :] :]
- else
- [: `BEbox
- [: `S LR "declare";
- `HVbox [: `HVbox [: :]; list sig_item s [: :] :];
- `HVbox [: `S LR "end"; k :] :] :]
- | <:sig_item< # $_$ $opt:_$ >> as si ->
- fun curr next _ k -> [: `not_impl "sig_item1" si :]
- | <:sig_item< exception $c$ of $list:tl$ >> ->
- fun curr next _ k ->
- [: `variant [: `S LR "exception" :] (loc, c, tl) k :]
- | <:sig_item< value $s$ : $t$ >> ->
- fun curr next _ k -> [: `value_description s t k :]
- | <:sig_item< include $mt$ >> ->
- fun curr next _ k -> [: `S LR "include"; `module_type mt k :]
- | <:sig_item< external $s$ : $t$ = $list:pl$ >> ->
- fun curr next _ k -> [: `external_def s t pl k :]
- | <:sig_item< module $s$ : $mt$ >> ->
- fun curr next _ k ->
- [: `module_declaration [: `S LR "module"; `S LR s :] mt k :]
- | <:sig_item< module rec $list:nmts$ >> ->
- fun curr next _ k ->
- [: `HVbox [: :];
- listwbws module_rec_declaration [: `S LR "module rec" :] (S LR "and") nmts
- k :]
- | <:sig_item< module type $s$ = $mt$ >> ->
- fun curr next _ k -> [: `modtype_declaration s mt k :]
- | <:sig_item< open $sl$ >> ->
- fun curr next _ k -> [: `S LR "open"; mod_ident sl k :]
- | <:sig_item< class $list:cd$ >> ->
- fun curr next _ k ->
- [: `HVbox [: :];
- listwbws class_description [: `S LR "class" :] (S LR "and") cd
- k :]
- | <:sig_item< class type $list:cd$ >> ->
- fun curr next _ k ->
- [: `HVbox [: :];
- listwbws class_type_declaration
- [: `S LR "class"; `S LR "type" :] (S LR "and") cd k :]
- | MLast.SgUse _ _ _ ->
- fun curr next _ k -> [: :] ]}];
-
-pr_str_item.pr_levels :=
- [{pr_label = "top";
- pr_box s x = LocInfo (MLast.loc_of_str_item s) (HVbox x);
- pr_rules =
- extfun Extfun.empty with
- [ <:str_item< open $i$ >> ->
- fun curr next _ k -> [: `S LR "open"; mod_ident i k :]
- | <:str_item< $exp:e$ >> ->
- fun curr next _ k -> [: `HVbox [: :]; `expr e k :]
- | <:str_item< declare $list:s$ end >> ->
- fun curr next _ k ->
- if expand_declare.val then
- if s = [] then [: `S LR "(* *)" :]
- else [: `HVbox [: :]; list str_item s [: :] :]
- else
- [: `BEbox
- [: `S LR "declare";
- `HVbox [: `HVbox [: :]; list str_item s [: :] :];
- `HVbox [: `S LR "end"; k :] :] :]
- | <:str_item< # $s$ $opt:x$ >> ->
- fun curr next _ k ->
- let s =
- "(* #" ^ s ^ " " ^
- (match x with
- [ Some <:expr< $str:s$ >> -> "\"" ^ s ^ "\""
- | _ -> "?" ]) ^
- " *)"
- in
- [: `S LR s :]
- | <:str_item< exception $c$ of $list:tl$ = $b$ >> ->
- fun curr next _ k ->
- match b with
- [ [] -> [: `variant [: `S LR "exception" :] (loc, c, tl) k :]
- | _ ->
- [: `variant [: `S LR "exception" :] (loc, c, tl)
- [: `S LR "=" :];
- mod_ident b k :] ]
- | <:str_item< include $me$ >> ->
- fun curr next _ k -> [: `S LR "include"; `module_expr me k :]
- | <:str_item< type $list:tdl$ >> ->
- fun curr next _ k -> [: `type_list [: `S LR "type" :] tdl k :]
- | <:str_item< value $opt:rf$ $list:pel$ >> ->
- fun curr next _ k ->
- [: `bind_list [: `S LR "value"; flag "rec" rf :] pel k :]
- | <:str_item< external $s$ : $t$ = $list:pl$ >> ->
- fun curr next _ k -> [: `external_def s t pl k :]
- | <:str_item< module $s$ = $me$ >> ->
- fun curr next _ k ->
- [: `module_binding [: `S LR "module"; `S LR s :] me k :]
- | <:str_item< module rec $list:nmtmes$ >> ->
- fun curr next _ k ->
- [: `HVbox [: :];
- listwbws module_rec_binding [: `S LR "module rec" :] (S LR "and") nmtmes
- k :]
- | <:str_item< module type $s$ = $mt$ >> ->
- fun curr next _ k ->
- [: `HVbox [: :];
- `HVbox
- [: `HVbox
- [: `S LR "module"; `S LR "type"; `S LR s;
- `S LR "=" :];
- `module_type mt [: :] :];
- k :]
- | <:str_item< class $list:cd$ >> ->
- fun curr next _ k ->
- [: `HVbox [: :];
- listwbws class_declaration [: `S LR "class" :] (S LR "and") cd
- k :]
- | <:str_item< class type $list:cd$ >> ->
- fun curr next _ k ->
- [: `HVbox [: :];
- listwbws class_type_declaration
- [: `S LR "class"; `S LR "type" :] (S LR "and") cd k :]
- | MLast.StUse _ _ _ ->
- fun curr next _ k -> [: :] ]}];
-
-(*
-EXTEND_PRINTER
- pr_expr:
- [ "top" (fun e x -> LocInfo (MLast.loc_of_expr e) (HOVbox x))
- [ <:expr< let $rec:r$ $p1$ = $e1$ in $e$ >> ->
- let r = flag "rec" r in
- [: `Vbox
- [: `HVbox [: :];
- `let_binding [: `S LR "let"; r :] (p1, e1)
- [: `S LR "in" :];
- `expr e k :] :]
- | <:expr< let $rec:r$ $list:pel$ in $e$ >> ->
- let r = flag "rec" r in
- [: `Vbox
- [: `HVbox [: :];
- listwbws (fun b (p, e) k -> let_binding b (p, e) k)
- [: `S LR "let"; r :] (S LR "and") pel [: `S LR "in" :];
- `expr e k :] :] ] ]
- ;
-END;
-*)
-
-pr_expr.pr_levels :=
- [{pr_label = "top"; pr_box e x = LocInfo (MLast.loc_of_expr e) (HOVbox x);
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< let $opt:r$ $p1$ = $e1$ in $e$ >> ->
- fun curr next _ k ->
- let r = flag "rec" r in
- [: `Vbox
- [: `HVbox [: :];
- `let_binding [: `S LR "let"; r :] (p1, e1)
- [: `S LR "in" :];
- `expr e k :] :]
- | <:expr< let $opt:r$ $list:pel$ in $e$ >> ->
- fun curr next _ k ->
- let r = flag "rec" r in
- [: `Vbox
- [: `HVbox [: :];
- listwbws (fun b (p, e) k -> let_binding b (p, e) k)
- [: `S LR "let"; r :] (S LR "and") pel [: `S LR "in" :];
- `expr e k :] :]
- | <:expr< let module $m$ = $mb$ in $e$ >> ->
- fun curr next _ k ->
- [: `HVbox
- [: `HVbox [: :];
- `module_binding
- [: `S LR "let"; `S LR "module"; `S LR m :] mb
- [: `S LR "in" :];
- `expr e k :] :]
- | <:expr< fun [ $list:pel$ ] >> ->
- fun curr next _ k ->
- match pel with
- [ [] -> [: `S LR "fun"; `S LR "[]"; k :]
- | [(p, None, e)] ->
- if is_irrefut_patt p then
- let (pl, e) = expr_fun_args e in
- [: `BEbox
- [: `HOVbox
- [: `S LR "fun";
- list patt [p :: pl] [: `S LR "->" :] :];
- `expr e k :] :]
- else
- [: `HVbox [: `S LR "fun ["; `patt p [: `S LR "->" :] :];
- `expr e [: `S LR "]"; k :] :]
- | _ ->
- [: `Vbox
- [: `HVbox [: :]; `S LR "fun";
- listwbws match_assoc [: `S LR "[" :] (S LR "|") pel
- [: `S LR "]"; k :] :] :] ]
- | <:expr< match $e$ with $p1$ -> $e1$ >> when is_irrefut_patt p1 ->
- fun curr next _ k ->
- [: `BEbox
- [: `S LR "match"; `expr e [: :];
- `HVbox [: `S LR "with"; `patt p1 [: `S LR "->" :] :] :];
- `expr e1 k :]
- | <:expr< match $e$ with [ ] >> ->
- fun curr next _ k ->
- [: `HVbox [: :];
- `BEbox
- [: `S LR "match"; `expr e [: :]; `S LR "with"; `S LR "[]";
- k :] :]
- | <:expr< match $e$ with [ $list:pel$ ] >> ->
- fun curr next _ k ->
- [: `HVbox [: :];
- `BEbox [: `S LR "match"; `expr e [: :]; `S LR "with" :];
- `match_assoc_list pel k :]
- | <:expr< try $e$ with [ ] >> ->
- fun curr next _ k ->
- [: `HVbox [: :];
- `BEbox
- [: `S LR "try"; `expr e [: :]; `S LR "with"; `S LR "[]";
- k :] :]
- | <:expr< try $e$ with $p1$ -> $e1$ >> when is_irrefut_patt p1 ->
- fun curr next _ k ->
- [: `BEbox
- [: `S LR "try"; `expr e [: :];
- `HVbox [: `S LR "with"; `patt p1 [: `S LR "->" :] :] :];
- `expr e1 k :]
- | <:expr< try $e$ with [ $list:pel$ ] >> ->
- fun curr next _ k ->
- [: `HVbox [: :];
- `BEbox [: `S LR "try"; `expr e [: :]; `S LR "with" :];
- `match_assoc_list pel k :]
- | <:expr< if $e1$ then $e2$ else $e3$ >> ->
- fun curr next _ k ->
- let (eel, e) =
- elseif e3 where rec elseif e =
- match e with
- [ <:expr< if $e1$ then $e2$ else $e3$ >> ->
- let (eel, e) = elseif e3 in
- ([(e1, e2) :: eel], e)
- | _ -> ([], e) ]
- in
- [: `HVbox
- [: `HVbox [: :];
- `ifbox [: `S LR "if" :] [: `expr e1 [: :] :]
- [: `S LR "then" :] e2 [: :];
- list
- (fun (e1, e2) k ->
- ifbox [: `HVbox [: `S LR "else"; `S LR "if" :] :]
- [: `expr e1 [: :] :] [: `S LR "then" :] e2 k)
- eel [: :];
- `ifbox [: `S LR "else" :] [: :] [: :] e k :] :]
- | <:expr< do { $list:el$ } >> when old_sequences.val ->
- fun curr next _ k ->
- let (el, e) =
- match List.rev el with
- [ [e :: el] -> (List.rev el, e)
- | [] -> ([], <:expr< () >>) ]
- in
- [: `HOVCbox
- [: `HVbox [: :];
- `BEbox
- [: `S LR "do";
- `HVbox
- [: `HVbox [: :];
- list (fun e k -> expr e [: `S RO ";"; k :])
- el [: :] :];
- `S LR "return" :];
- `expr e k :] :]
- | <:expr< do { $list:el$ } >> ->
- fun curr next _ k -> [: `sequence [: :] [: :] [: :] el k :]
- | <:expr< for $i$ = $e1$ $to:d$ $e2$ do { $list:el$ } >>
- when old_sequences.val ->
- fun curr next _ k ->
- let d = if d then "to" else "downto" in
- [: `BEbox
- [: `HOVbox
- [: `S LR "for"; `S LR i; `S LR "=";
- `expr e1 [: `S LR d :];
- `expr e2 [: `S LR "do" :] :];
- `HVbox
- [: `HVbox [: :];
- list (fun e k -> expr e [: `S RO ";"; k :]) el
- [: :] :];
- `HVbox [: `S LR "done"; k :] :] :]
- | <:expr< for $i$ = $e1$ $to:d$ $e2$ do { $list:el$ } >> ->
- fun curr next _ k ->
- let d = if d then "to" else "downto" in
- [: `sequence
- [: `HOVbox
- [: `S LR "for"; `S LR i; `S LR "=";
- `expr e1 [: `S LR d :]; `expr e2 [: :] :] :]
- [: :] [: :] el k :]
- | <:expr< while $e1$ do { $list:el$ } >> when old_sequences.val ->
- fun curr next _ k ->
- [: `BEbox
- [: `BEbox [: `S LR "while"; `expr e1 [: :]; `S LR "do" :];
- `HVbox
- [: `HVbox [: :];
- list (fun e k -> expr e [: `S RO ";"; k :]) el
- [: :] :];
- `HVbox [: `S LR "done"; k :] :] :]
- | <:expr< while $e1$ do { $list:el$ } >> ->
- fun curr next _ k ->
- [: `sequence [: `S LR "while"; `expr e1 [: :] :] [: :] [: :] el
- k :]
- | e -> fun curr next _ k -> [: `next e "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< $x$ := $y$ >> ->
- fun curr next _ k -> [: `next x "" [: `S LR ":=" :]; `expr y k :]
- | e -> fun curr next _ k -> [: `next e "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :];
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< $lid:"||"$ $x$ $y$ >> ->
- fun curr next _ k -> [: `next x "" [: `S LR "||" :]; curr y "" k :]
- | <:expr< $lid:"or"$ $x$ $y$ >> ->
- fun curr next _ k -> [: `next x "" [: `S LR "||" :]; curr y "" k :]
- | e -> fun curr next _ k -> [: `next e "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :];
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< $lid:"&&"$ $x$ $y$ >> ->
- fun curr next _ k -> [: `next x "" [: `S LR "&&" :]; curr y "" k :]
- | <:expr< $lid:"&"$ $x$ $y$ >> ->
- fun curr next _ k -> [: `next x "" [: `S LR "&&" :]; curr y "" k :]
- | e -> fun curr next _ k -> [: `next e "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< $lid:op$ $x$ $y$ >> as e ->
- fun curr next _ k ->
- match op with
- [ "<" | ">" | "<=" | ">=" | ">=." | "=" | "<>" | "==" | "!=" ->
- [: curr x "" [: `S LR op :]; `next y "" k :]
- | _ -> [: `next e "" k :] ]
- | e -> fun curr next _ k -> [: `next e "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< $lid:op$ $x$ $y$ >> as e ->
- fun curr next _ k ->
- match op with
- [ "^" | "@" -> [: `next x "" [: `S LR op :]; curr y "" k :]
- | _ -> [: `next e "" k :] ]
- | e -> fun curr next _ k -> [: `next e "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< $lid:op$ $x$ $y$ >> as e ->
- fun curr next _ k ->
- match op with
- [ "+" | "+." | "-" | "-." ->
- [: curr x "" [: `S LR op :]; `next y "" k :]
- | _ -> [: `next e "" k :] ]
- | e -> fun curr next _ k -> [: `next e "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< $lid:op$ $x$ $y$ >> as e ->
- fun curr next _ k ->
- match op with
- [ "*" | "/" | "*." | "/." | "land" | "lor" | "lxor" | "mod" ->
- [: curr x "" [: `S LR op :]; `next y "" k :]
- | _ -> [: `next e "" k :] ]
- | e -> fun curr next _ k -> [: `next e "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< $lid:op$ $x$ $y$ >> as e ->
- fun curr next _ k ->
- match op with
- [ "**" | "asr" | "lsl" | "lsr" ->
- [: `next x "" [: `S LR op :]; curr y "" k :]
- | _ -> [: `next e "" k :] ]
- | e -> fun curr next _ k -> [: `next e "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< $lid:"~-"$ $x$ >> ->
- fun curr next _ k -> [: `S LR "-"; curr x "" k :]
- | <:expr< $lid:"~-."$ $x$ >> ->
- fun curr next _ k -> [: `S LR "-."; curr x "" k :]
- | e -> fun curr next _ k -> [: `next e "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< $int:x$ >> -> fun curr next _ k -> [: `S LR x; k :]
- | MLast.ExInt32 _ x -> fun curr next _ k -> [: `S LR (x^"l"); k :]
- | MLast.ExInt64 _ x -> fun curr next _ k -> [: `S LR (x^"L"); k :]
- | MLast.ExNativeInt _ x -> fun curr next _ k -> [: `S LR (x^"n"); k :]
- | e -> fun curr next _ k -> [: `next e "" k :] ]};
- {pr_label = "apply"; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< [$_$ :: $_$] >> as e ->
- fun curr next _ k -> [: `next e "" k :]
- | <:expr< lazy ($x$) >> ->
- fun curr next _ k -> [: `S LR "lazy"; `next x "" k :]
- | <:expr< assert False >> ->
- fun curr next _ k -> [: `S LR "assert"; `S LR "False"; k :]
- | <:expr< assert ($e$) >> ->
- fun curr next _ k -> [: `S LR "assert"; `next e "" k :]
- | <:expr< $lid:n$ $x$ $y$ >> as e ->
- fun curr next _ k ->
- if is_infix n then [: `next e "" k :]
- else [: curr <:expr< $lid:n$ $x$ >> "" [: :]; `next y "" k :]
- | <:expr< $x$ $y$ >> ->
- fun curr next _ k -> [: curr x "" [: :]; `next y "" k :]
- | <:expr< new $list:sl$ >> ->
- fun curr next _ k -> [: `S LR "new"; `class_longident sl k :]
- | e -> fun curr next _ k -> [: `next e "" k :] ]};
- {pr_label = "dot"; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< $x$ . ( $y$ ) >> ->
- fun curr next _ k ->
- [: curr x "" [: :]; `S NO ".("; `expr y [: `S RO ")"; k :] :]
- | <:expr< $x$ . [ $y$ ] >> ->
- fun curr next _ k ->
- [: curr x "" [: :]; `S NO ".["; `expr y [: `S RO "]"; k :] :]
- | <:expr< $e1$ . $e2$ >> ->
- fun curr next _ k -> [: curr e1 "" [: :]; `S NO "."; curr e2 "" k :]
- | <:expr< $e$ # $lab$ >> ->
- fun curr next _ k -> [: curr e "" [: :]; `S NO "#"; `label lab; k :]
- | e -> fun curr next _ k -> [: `next e "" k :] ]};
- {pr_label = "simple";
- pr_box e x = LocInfo (MLast.loc_of_expr e) (HOVbox x);
- pr_rules =
- extfun Extfun.empty with
- [ ( <:expr< $int:x$ >> | <:expr< $flo:x$ >> ) ->
- fun curr next _ k ->
- if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :]
- else [: `S LR x; k :]
- | MLast. ExInt32 _ x ->
- fun curr next _ k ->
- let x = x^"l" in
- if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :]
- else [: `S LR x; k :]
- | MLast.ExInt64 _ x ->
- fun curr next _ k ->
- let x = x^"L" in
- if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :]
- else [: `S LR x; k :]
- | MLast.ExNativeInt _ x ->
- fun curr next _ k ->
- let x = x^"n" in
- if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :]
- else [: `S LR x; k :]
- | <:expr< $str:s$ >> ->
- fun curr next _ k -> [: `S LR ("\"" ^ s ^ "\""); k :]
- | <:expr< $chr:c$ >> ->
- fun curr next _ k -> [: `S LR ("'" ^ c ^ "'"); k :]
- | <:expr< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :]
- | <:expr< $lid:s$ >> ->
- fun curr next _ k -> [: `S LR (var_escaped s); k :]
- | <:expr< ` $i$ >> -> fun curr next _ k -> [: `S LR ("`" ^ i); k :]
- | <:expr< ~ $i$ >> ->
- fun curr next _ k -> [: `S LR ("~" ^ i); k :]
- | <:expr< ~ $i$ : $e$ >> ->
- fun curr next _ k -> [: `S LO ("~" ^ i ^ ":"); curr e "" k :]
- | <:expr< ? $i$ >> ->
- fun curr next _ k -> [: `S LR ("?" ^ i); k :]
- | <:expr< ? $i$ : $e$ >> ->
- fun curr next _ k -> [: `S LO ("?" ^ i ^ ":"); curr e "" k :]
- | <:expr< [$_$ :: $_$] >> as e ->
- fun curr next _ k ->
- let (el, c) =
- make_list e where rec make_list e =
- match e with
- [ <:expr< [$e$ :: $y$] >> ->
- let (el, c) = make_list y in
- ([e :: el], c)
- | <:expr< [] >> -> ([], None)
- | x -> ([], Some e) ]
- in
- match c with
- [ None ->
- [: `S LO "["; listws expr (S RO ";") el [: `S RO "]"; k :] :]
- | Some x ->
- [: `S LO "["; listws expr (S RO ";") el [: `S LR "::" :];
- `expr x [: `S RO "]"; k :] :] ]
- | <:expr< [| $list:el$ |] >> ->
- fun curr next _ k ->
- [: `S LR "[|"; listws expr (S RO ";") el [: `S LR "|]"; k :] :]
- | <:expr< { $list:fel$ } >> ->
- fun curr next _ k ->
- [: `S LO "{";
- listws
- (fun (lab, e) k ->
- HVbox [: let_binding0 [: `patt lab [: :] :] e k :])
- (S RO ";") fel [: `S RO "}"; k :] :]
- | <:expr< { ($e$) with $list:fel$ } >> ->
- fun curr next _ k ->
- [: `HVbox
- [: `S LO "{"; `S LO "(";
- `expr e [: `S RO ")"; `S LR "with" :] :];
- listws
- (fun (lab, e) k ->
- HVbox [: `patt lab [: `S LR "=" :]; `expr e k :])
- (S RO ";") fel [: `S RO "}"; k :] :]
- | <:expr< ($e$ : $t$) >> ->
- fun curr next _ k ->
- [: `S LO "("; `expr e [: `S LR ":" :];
- `ctyp t [: `S RO ")"; k :] :]
- | <:expr< ($e$ : $t1$ :> $t2$) >> ->
- fun curr next _ k ->
- [: `S LO "("; `expr e [: `S LR ":" :]; `ctyp t1 [: `S LR ":>" :];
- `ctyp t2 [: `S RO ")"; k :] :]
- | <:expr< ($e$ :> $t2$) >> ->
- fun curr next _ k ->
- [: `S LO "("; `expr e [: `S LR ":>" :];
- `ctyp t2 [: `S RO ")"; k :] :]
- | <:expr< {< >} >> -> fun curr next _ k -> [: `S LR "{< >}"; k :]
- | <:expr< {< $list:fel$ >} >> ->
- fun curr next _ k ->
- [: `S LR "{<";
- listws field_expr (S RO ";") fel [: `S LR ">}"; k :] :]
- | <:expr< ($list:el$) >> ->
- fun curr next _ k ->
- [: `S LO "("; listws expr (S RO ",") el [: `S RO ")"; k :] :]
- | <:expr< $_$ $_$ >> | <:expr< $_$ . $_$ >> | <:expr< $_$ . ( $_$ ) >> |
- <:expr< $_$ . [ $_$ ] >> | <:expr< $_$ := $_$ >> |
- <:expr< $_$ # $_$ >> |
- <:expr< fun [ $list:_$ ] >> | <:expr< match $_$ with [ $list:_$ ] >> |
- <:expr< try $_$ with [ $list:_$ ] >> |
- <:expr< if $_$ then $_$ else $_$ >> | <:expr< do { $list:_$ } >> |
- <:expr< for $_$ = $_$ $to:_$ $_$ do { $list:_$ } >> |
- <:expr< while $_$ do { $list:_$ } >> |
- <:expr< let $opt:_$ $list:_$ in $_$ >> |
- <:expr< let module $_$ = $_$ in $_$ >> |
- <:expr< new $list:_$ >> as e ->
- fun curr next _ k ->
- [: `S LO "("; `expr e [: `HVbox [: `S RO ")"; k :] :] :]
- | e -> fun curr next _ k -> [: `not_impl "expr" e :] ]}];
-
-pr_patt.pr_levels :=
- [{pr_label = "top";
- pr_box p x = LocInfo (MLast.loc_of_patt p) (HOVbox [: `HVbox [: :]; x :]);
- pr_rules =
- extfun Extfun.empty with
- [ <:patt< $x$ | $y$ >> ->
- fun curr next _ k -> [: curr x "" [: `S LR "|" :]; `next y "" k :]
- | p -> fun curr next _ k -> [: `next p "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :];
- pr_rules =
- extfun Extfun.empty with
- [ <:patt< $x$ .. $y$ >> ->
- fun curr next _ k -> [: curr x "" [: `S NO ".." :]; `next y "" k :]
- | p -> fun curr next _ k -> [: `next p "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:patt< [$_$ :: $_$] >> as p ->
- fun curr next _ k -> [: `next p "" k :]
- | <:patt< $x$ $y$ >> ->
- fun curr next _ k -> [: curr x "" [: :]; `next y "" k :]
- | p -> fun curr next _ k -> [: `next p "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:patt< $x$ . $y$ >> ->
- fun curr next _ k -> [: curr x "" [: `S NO "." :]; `next y "" k :]
- | p -> fun curr next _ k -> [: `next p "" k :] ]};
- {pr_label = "simple";
- pr_box p x = LocInfo (MLast.loc_of_patt p) (HOVbox x);
- pr_rules =
- extfun Extfun.empty with
- [ <:patt< [$_$ :: $_$] >> as p ->
- fun curr next _ k ->
- let (pl, c) =
- make_list p where rec make_list p =
- match p with
- [ <:patt< [$p$ :: $y$] >> ->
- let (pl, c) = make_list y in
- ([p :: pl], c)
- | <:patt< [] >> -> ([], None)
- | x -> ([], Some p) ]
- in
- [: `HOVCbox
- [: `S LO "[";
- let rec glop pl k =
- match pl with
- [ [] -> failwith "simple_patt"
- | [p] ->
- match c with
- [ None -> [: `patt p k :]
- | Some x ->
- [: `patt p [: `S LR "::" :]; `patt x k :] ]
- | [p :: pl] ->
- [: `patt p [: `S RO ";" :]; glop pl k :] ]
- in
- glop pl [: `S RO "]"; k :] :] :]
- | <:patt< [| $list:pl$ |] >> ->
- fun curr next _ k ->
- [: `S LR "[|"; listws patt (S RO ";") pl [: `S LR "|]"; k :] :]
- | <:patt< { $list:fpl$ } >> ->
- fun curr next _ k ->
- [: `HVbox
- [: `S LO "{";
- listws
- (fun (lab, p) k ->
- HVbox [: `patt lab [: `S LR "=" :]; `patt p k :])
- (S RO ";") fpl [: `S RO "}"; k :] :] :]
- | <:patt< ($list:[p::pl]$) >> ->
- fun curr next _ k ->
- [: `HOVCbox
- [: `S LO "(";
- listws patt (S RO ",") [p :: pl] [: `S RO ")"; k :] :] :]
- | <:patt< ($p$ : $ct$) >> ->
- fun curr next _ k ->
- [: `S LO "("; `patt p [: `S LR ":" :];
- `ctyp ct [: `S RO ")"; k :] :]
- | <:patt< ($x$ as $y$) >> ->
- fun curr next _ k ->
- [: `S LO "("; `patt x [: `S LR "as" :];
- `patt y [: `S RO ")"; k :] :]
- | ( <:patt< $int:s$ >> | <:patt< $flo:s$ >> ) ->
- fun curr next _ k -> [: `S LR s; k :]
- | MLast.PaInt32 _ s -> fun curr next _ k -> [: `S LR (s^"l"); k :]
- | MLast.PaInt64 _ s -> fun curr next _ k -> [: `S LR (s^"L"); k :]
- | MLast.PaNativeInt _ s -> fun curr next _ k -> [: `S LR (s^"n"); k :]
- | <:patt< $str:s$ >> ->
- fun curr next _ k -> [: `S LR ("\"" ^ s ^ "\""); k :]
- | <:patt< $chr:c$ >> ->
- fun curr next _ k -> [: `S LR ("'" ^ c ^ "'"); k :]
- | <:patt< $lid:s$ >> ->
- fun curr next _ k -> [: `S LR (var_escaped s); k :]
- | <:patt< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :]
- | <:patt< ` $i$ >> -> fun curr next _ k -> [: `S LR ("`" ^ i); k :]
- | <:patt< # $list:sl$ >> ->
- fun curr next _ k -> [: `S LO "#"; mod_ident sl k :]
- | <:patt< ~ $i$ >> ->
- fun curr next _ k -> [: `S LR ("~" ^ i); k :]
- | <:patt< ~ $i$ : $p$ >> ->
- fun curr next _ k -> [: `S LO ("~" ^ i ^ ":"); curr p "" k :]
- | <:patt< ? $i$ >> ->
- fun curr next _ k -> [: `S LR ("?" ^ i); k :]
- | <:patt< ? $i$ : ($p$ : $t$) >> ->
- fun curr next _ k ->
- [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p [: `S LR ":" :];
- `ctyp t [: `S RO ")"; k :] :]
- | <:patt< ? $i$ : ($p$) >> ->
- fun curr next _ k ->
- if i = "" then [: `S LO "?"; curr p "" k :]
- else
- [: `S LO ("?" ^ i ^ ":"); `S LO "(";
- `patt p [: `S RO ")"; k :] :]
- | <:patt< ? $i$ : ($p$ : $t$ = $e$) >> ->
- fun curr next _ k ->
- if i = "" then
- [: `S LO "?"; `S LO "("; `patt p [: `S LR ":" :];
- `ctyp t [: `S LR "=" :]; `expr e [: `S RO ")"; k :] :]
- else
- [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p [: `S LR ":" :];
- `ctyp t [: `S LR "=" :]; `expr e [: `S RO ")"; k :] :]
- | <:patt< ? $i$ : ($p$ = $e$) >> ->
- fun curr next _ k ->
- if i = "" then
- [: `S LO "?"; `S LO "("; `patt p [: `S LR "=" :];
- `expr e [: `S RO ")"; k :] :]
- else
- [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p [: `S LR "=" :];
- `expr e [: `S RO ")"; k :] :]
- | <:patt< _ >> -> fun curr next _ k -> [: `S LR "_"; k :]
- | <:patt< $_$ $_$ >> | <:patt< $_$ .. $_$ >> |
- <:patt< $_$ | $_$ >> as p ->
- fun curr next _ k ->
- [: `S LO "("; `patt p [: `HVbox [: `S RO ")"; k :] :] :]
- | p -> fun curr next _ k -> [: `next p "" k :] ]}];
-
-pr_ctyp.pr_levels :=
- [{pr_label = "top"; pr_box t x = LocInfo (MLast.loc_of_ctyp t) (HOVbox x);
- pr_rules =
- extfun Extfun.empty with
- [ <:ctyp< $t1$ == $t2$ >> ->
- fun curr next _ k ->
- [: curr t1 "" [: `S LR "==" :]; `next t2 "" k :]
- | t -> fun curr next _ k -> [: `next t "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:ctyp< $x$ as $y$ >> ->
- fun curr next _ k -> [: curr x "" [: `S LR "as" :]; `next y "" k :]
- | t -> fun curr next _ k -> [: `next t "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:ctyp< ! $list:pl$ . $t$ >> ->
- fun curr next dg k ->
- if pl = [] then [: `ctyp t k :]
- else
- [: `HVbox [: `S LR "!"; list typevar pl [: `S LR "." :] :];
- `ctyp t k :]
- | t -> fun curr next _ k -> [: `next t "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:ctyp< $x$ -> $y$ >> ->
- fun curr next _ k -> [: `next x "" [: `S LR "->" :]; curr y "" k :]
- | t -> fun curr next _ k -> [: `next t "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:ctyp< $t1$ $t2$ >> ->
- fun curr next _ k -> [: curr t1 "" [: :]; `next t2 "" k :]
- | t -> fun curr next _ k -> [: `next t "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:ctyp< ? $lab$ : $t$ >> ->
- fun curr next _ k ->
- [: `S LO "?"; `S LR lab; `S RO ":"; `next t "" k :]
- | <:ctyp< ~ $lab$ : $t$ >> ->
- fun curr next _ k -> [: `S LO ("~" ^ lab ^ ":"); `next t "" k :]
- | t -> fun curr next _ k -> [: `next t "" k :] ]};
- {pr_label = ""; pr_box _ x = HOVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ <:ctyp< $t1$ . $t2$ >> ->
- fun curr next _ k ->
- [: curr t1 "" [: :]; `S NO "."; `next t2 "" k :]
- | t -> fun curr next _ k -> [: `next t "" k :] ]};
- {pr_label = "simple";
- pr_box t x = LocInfo (MLast.loc_of_ctyp t) (HOVbox x);
- pr_rules =
- extfun Extfun.empty with
- [ <:ctyp< ($list:tl$) >> ->
- fun curr next _ k ->
- [: `S LO "("; listws ctyp (S LR "*") tl [: `S RO ")"; k :] :]
- | <:ctyp< '$s$ >> ->
- fun curr next _ k -> [: `S LO "'"; `S LR (var_escaped s); k :]
- | <:ctyp< $lid:s$ >> ->
- fun curr next _ k -> [: `S LR (var_escaped s); k :]
- | <:ctyp< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :]
- | <:ctyp< _ >> -> fun curr next _ k -> [: `S LR "_"; k :]
- | <:ctyp< private { $list: ftl$ } >> as t ->
- fun curr next _ k ->
- let loc = MLast.loc_of_ctyp t in
- [: `HVbox
- [: `HVbox [:`S LR "private" :];
- `HVbox [: labels loc [:`S LR "{" :]
- ftl [: `S LR "}" :] :];
- k :] :]
- | <:ctyp< { $list: ftl$ } >> as t ->
- fun curr next _ k ->
- let loc = MLast.loc_of_ctyp t in
- [: `HVbox
- [: labels loc [: `S LR "{" :] ftl [: `S LR "}" :]; k :] :]
- | <:ctyp< [ $list:ctl$ ] >> as t ->
- fun curr next _ k ->
- let loc = MLast.loc_of_ctyp t in
- [: `Vbox
- [: `HVbox [: :];
- variants loc [: `S LR "[" :] ctl [: `S LR "]" :]; k :] :]
- | <:ctyp< private [ $list:ctl$ ] >> as t ->
- fun curr next _ k ->
- let loc = MLast.loc_of_ctyp t in
- [: `Vbox
- [: `HVbox [: `S LR "private" :];
- variants loc [: `S LR "[" :] ctl [: `S LR "]" :]; k :] :]
- | <:ctyp< [ = $list:rfl$ ] >> ->
- fun curr next _ k ->
- [: `HVbox
- [: `HVbox [: :];
- row_fields [: `S LR "[ =" :] rfl [: `S LR "]" :]; k :] :]
- | <:ctyp< [ > $list:rfl$ ] >> ->
- fun curr next _ k ->
- [: `HVbox
- [: `HVbox [: :];
- row_fields [: `S LR "[ >" :] rfl [: `S LR "]" :]; k :] :]
- | <:ctyp< [ < $list:rfl$ > $list:sl$ ] >> ->
- fun curr next _ k ->
- let k1 = [: `S LR "]" :] in
- let k1 =
- match sl with
- [ [] -> k1
- | l ->
- [: `S LR ">";
- list (fun x k -> HVbox [: `S LR x; k :]) l k1 :] ]
- in
- [: `HVbox
- [: `HVbox [: :]; row_fields [: `S LR "[ <" :] rfl k1;
- k :] :]
- | <:ctyp< # $list:id$ >> ->
- fun curr next _ k -> [: `S LO "#"; `class_longident id k :]
- | <:ctyp< < > >> -> fun curr next _ k -> [: `S LR "<>"; k :]
- | <:ctyp< < $list:ml$ $opt:v$ > >> ->
- fun curr next _ k ->
- [: `S LR "<"; meth_list (ml, v) [: `S LR ">"; k :] :]
- | <:ctyp< $_$ -> $_$ >> | <:ctyp< $_$ $_$ >> | <:ctyp< $_$ == $_$ >> |
- <:ctyp< $_$ . $_$ >> | <:ctyp< $_$ as $_$ >> |
- <:ctyp< ? $_$ : $_$ >> | <:ctyp< ~ $_$ : $_$ >> |
- <:ctyp< ! $list:_$ . $_$ >> as t ->
- fun curr next _ k ->
- [: `S LO "("; `ctyp t [: `HVbox [: `S RO ")"; k :] :] :]
- | t -> fun curr next _ k -> [: `next t "" k :] ]}];
-
-pr_class_sig_item.pr_levels :=
- [{pr_label = "top";
- pr_box s x = LocInfo (MLast.loc_of_class_sig_item s) (HVbox x);
- pr_rules =
- extfun Extfun.empty with
- [ <:class_sig_item< type $t1$ = $t2$ >> ->
- fun curr next _ k ->
- [: `S LR "type"; `ctyp t1 [: `S LR "=" :]; `ctyp t2 k :]
- | <:class_sig_item< declare $list:s$ end >> ->
- fun curr next _ k -> [: `HVbox [: :]; list class_sig_item s k :]
- | <:class_sig_item< inherit $ce$ >> ->
- fun curr next _ k -> [: `S LR "inherit"; `class_type ce k :]
- | <:class_sig_item< method $lab$ : $t$ >> ->
- fun curr next _ k ->
- [: `HVbox
- [: `S LR "method"; `label lab; `S LR ":" :];
- `ctyp t k :]
- | <:class_sig_item< method private $lab$ : $t$ >> ->
- fun curr next _ k ->
- [: `HVbox
- [: `S LR "method"; `S LR "private"; `label lab;
- `S LR ":" :];
- `ctyp t k :]
- | <:class_sig_item< value $opt:mf$ $lab$ : $t$ >> ->
- fun curr next _ k ->
- [: `HVbox
- [: `S LR "value"; flag "mutable" mf; `label lab;
- `S LR ":" :];
- `ctyp t k :]
- | <:class_sig_item< method virtual $lab$ : $t$ >> ->
- fun curr next _ k ->
- [: `HVbox
- [: `S LR "method"; `S LR "virtual"; `label lab;
- `S LR ":" :];
- `ctyp t k :]
- | <:class_sig_item< method virtual private $lab$ : $t$ >> ->
- fun curr next _ k ->
- [: `HVbox
- [: `S LR "method"; `S LR "virtual"; `S LR "private";
- `label lab; `S LR ":" :];
- `ctyp t k :]
- | csi -> fun curr next dg k -> [: `next csi "" k :] ]}];
-
-pr_class_str_item.pr_levels :=
- [{pr_label = "top";
- pr_box s x = LocInfo (MLast.loc_of_class_str_item s) (HVbox x);
- pr_rules =
- extfun Extfun.empty with
- [ MLast.CrDcl _ s ->
- fun curr next _ k -> [: `HVbox [: :]; list class_str_item s [: :] :]
- | MLast.CrInh _ ce pb ->
- fun curr next _ k ->
- [: `S LR "inherit"; `class_expr ce [: :];
- match pb with
- [ Some i -> [: `S LR "as"; `S LR i :]
- | _ -> [: :] ];
- k :]
- | MLast.CrVal _ lab mf e ->
- fun curr next _ k ->
- [: `cvalue [: `S LR "value" :] (lab, mf, e) k :]
- | MLast.CrVir _ lab pf t ->
- fun curr next _ k ->
- [: `S LR "method"; `S LR "virtual"; flag "private" pf; `label lab;
- `S LR ":"; `ctyp t k :]
- | MLast.CrMth _ lab pf fb None ->
- fun curr next _ k ->
- [: `fun_binding
- [: `S LR "method"; flag "private" pf; `label lab :] fb k :]
- | MLast.CrMth _ lab pf fb (Some t) ->
- fun curr next dg k ->
- [: `HOVbox
- [: `S LR "method"; flag "private" pf; `label lab; `S LR ":";
- `ctyp t [: `S LR "=" :] :];
- `expr fb k :]
- | MLast.CrCtr _ t1 t2 ->
- fun curr next _ k ->
- [: `HVbox [: `S LR "type"; `ctyp t1 [: `S LR "=" :] :];
- `ctyp t2 k :]
- | MLast.CrIni _ se ->
- fun curr next _ k -> [: `S LR "initializer"; `expr se k :]
- | csi -> fun curr next dg k -> [: `next csi "" k :] ]}];
-
-pr_class_type.pr_levels :=
- [{pr_label = "top"; pr_box s x = HVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ MLast.CtFun _ t ct ->
- fun curr next _ k ->
- [: `S LR "["; `ctyp t [: `S LR "]"; `S LR "->" :];
- `class_type ct k :]
- | ct -> fun curr next _ k -> [: `class_signature ct k :] ]}];
-
-pr_class_expr.pr_levels :=
- [{pr_label = "top"; pr_box s x = HVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ MLast.CeFun _ p ce ->
- fun curr next _ k ->
- [: `S LR "fun"; `simple_patt p [: `S LR "->" :];
- `class_expr ce k :]
- | MLast.CeLet _ rf lb ce ->
- fun curr next _ k ->
- [: `Vbox
- [: `HVbox [: :];
- `bind_list [: `S LR "let"; flag "rec" rf :] lb
- [: `S LR "in" :];
- `class_expr ce k :] :]
- | x -> fun curr next dg k -> [: `next x "" k :] ]};
- {pr_label = ""; pr_box s x = HVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ MLast.CeApp _ ce e ->
- fun curr next _ k -> [: curr ce "" [: :]; `simple_expr e k :]
- | x -> fun curr next dg k -> [: `next x "" k :] ]};
- {pr_label = ""; pr_box s x = HVbox x;
- pr_rules =
- extfun Extfun.empty with
- [ MLast.CeCon _ ci [] ->
- fun curr next _ k -> [: `class_longident ci k :]
- | MLast.CeCon _ ci ctcl ->
- fun curr next _ k ->
- [: `class_longident ci [: :]; `S LO "[";
- listws ctyp (S RO ",") ctcl [: `S RO "]"; k :] :]
- | MLast.CeStr _ csp cf as ce ->
- fun curr next _ k ->
- let ep = snd (MLast.loc_of_class_expr ce) in
- [: `BEbox
- [: `HVbox [: `S LR "object"; `class_self_patt_opt csp :];
- `HVbox
- [: `HVbox [: :]; list class_str_item cf [: :];
- `LocInfo (ep, ep) (HVbox [: :]) :];
- `HVbox [: `S LR "end"; k :] :] :]
- | MLast.CeTyc _ ce ct ->
- fun curr next _ k ->
- [: `S LO "("; `class_expr ce [: `S LR ":" :];
- `class_type ct [: `S RO ")"; k :] :]
- | MLast.CeFun _ _ _ as ce ->
- fun curr next _ k ->
- [: `S LO "("; `class_expr ce [: `S RO ")"; k :] :]
- | ce -> fun curr next _ k -> [: `not_impl "class_expr" ce; k :] ]}];
-
-value output_string_eval oc s =
- loop 0 where rec loop i =
- if i == String.length s then ()
- else if i == String.length s - 1 then output_char oc s.[i]
- else
- match (s.[i], s.[i + 1]) with
- [ ('\\', 'n') -> do { output_char oc '\n'; loop (i + 2) }
- | (c, _) -> do { output_char oc c; loop (i + 1) } ]
-;
-
-value maxl = ref 78;
-value sep = Pcaml.inter_phrases;
-value ncip = ref True;
-
-value input_source ic len =
- let buff = Buffer.create 20 in
- try
- let rec loop i =
- if i >= len then Buffer.contents buff
- else do { let c = input_char ic in Buffer.add_char buff c; loop (i + 1) }
- in
- loop 0
- with
- [ End_of_file ->
- let s = Buffer.contents buff in
- if s = "" then
- match sep.val with
- [ Some s -> s
- | None -> "\n" ]
- else s ]
-;
-
-value copy_source ic oc first bp ep =
- match sep.val with
- [ Some str ->
- if first then ()
- else if ep == in_channel_length ic then output_string oc "\n"
- else output_string_eval oc str
- | None ->
- do {
- seek_in ic bp;
- let s = input_source ic (ep - bp) in
- output_string oc s
- } ]
-;
-
-value copy_to_end ic oc first bp =
- let ilen = in_channel_length ic in
- if bp < ilen then copy_source ic oc first bp ilen else output_string oc "\n"
-;
-
-module Buff =
- struct
- value buff = ref (String.create 80);
- value store len x =
- do {
- if len >= String.length buff.val then
- buff.val := buff.val ^ String.create (String.length buff.val)
- else ();
- buff.val.[len] := x;
- succ len
- }
- ;
- value mstore len s =
- add_rec len 0 where rec add_rec len i =
- if i == String.length s then len
- else add_rec (store len s.[i]) (succ i)
- ;
- value get len = String.sub buff.val 0 len;
- end
-;
-
-value extract_comment strm =
- let rec find_comm nl_bef tab_bef =
- parser
- [ [: `'('; a = find_star nl_bef tab_bef :] -> a
- | [: `' '; s :] -> find_comm nl_bef (tab_bef + 1) s
- | [: `'\t'; s :] -> find_comm nl_bef (tab_bef + 8) s
- | [: `'\n'; s :] -> find_comm (nl_bef + 1) 0 s
- | [: `_; s :] -> find_comm 0 0 s
- | [: :] -> ("", nl_bef, tab_bef) ]
- and find_star nl_bef tab_bef =
- parser
- [ [: `'*'; a = insert (Buff.mstore 0 "(*") :] -> (a, nl_bef, tab_bef)
- | [: a = find_comm 0 0 :] -> a ]
- and insert len =
- parser
- [ [: `'*'; a = rparen (Buff.store len '*') :] -> a
- | [: `'('; len = find_star2 (Buff.store len '('); s :] -> insert len s
- | [: `'\t'; s :] -> insert (Buff.mstore len (String.make 8 ' ')) s
- | [: `x; s :] -> insert (Buff.store len x) s
- | [: :] -> "" ]
- and rparen len =
- parser
- [ [: `')'; s :] -> while_space (Buff.store len ')') s
- | [: a = insert len :] -> a ]
- and while_space len =
- parser
- [ [: `' '; a = while_space (Buff.store len ' ') :] -> a
- | [: `'\t'; a = while_space (Buff.mstore len (String.make 8 ' ')) :] -> a
- | [: `'\n'; a = while_space (Buff.store len '\n') :] -> a
- | [: `'('; a = find_star_again len :] -> a
- | [: :] -> Buff.get len ]
- and find_star_again len =
- parser
- [ [: `'*'; a = insert (Buff.mstore len "(*") :] -> a
- | [: :] -> Buff.get len ]
- and find_star2 len =
- parser
- [ [: `'*'; a = insert2 (Buff.store len '*') :] -> a
- | [: :] -> len ]
- and insert2 len =
- parser
- [ [: `'*'; a = rparen2 (Buff.store len '*') :] -> a
- | [: `'('; len = find_star2 (Buff.store len '('); s :] -> insert2 len s
- | [: `x; s :] -> insert2 (Buff.store len x) s
- | [: :] -> 0 ]
- and rparen2 len =
- parser
- [ [: `')' :] -> Buff.store len ')'
- | [: a = insert2 len :] -> a ]
- in
- find_comm 0 0 strm
-;
-
-value get_no_comment _ _ = ("", 0, 0, 0);
-
-value get_comment ic beg len =
- do {
- seek_in ic beg;
- let strm =
- Stream.from (fun i -> if i >= len then None else Some (input_char ic))
- in
- let (s, nl_bef, tab_bef) = extract_comment strm in
- (s, nl_bef, tab_bef, Stream.count strm)
- }
-;
-
-value apply_printer printer ast =
- let oc =
- match Pcaml.output_file.val with
- [ Some f -> open_out_bin f
- | None -> stdout ]
- in
- let cleanup () =
- match Pcaml.output_file.val with
- [ Some _ -> close_out oc
- | None -> () ]
- in
- let pr_ch = output_char oc in
- let pr_str = output_string oc in
- let pr_nl () = output_char oc '\n' in
- if Pcaml.input_file.val <> "-" && Pcaml.input_file.val <> "" then do {
- let ic = open_in_bin Pcaml.input_file.val in
- let getcom =
- if not ncip.val && sep.val = None then get_comment ic
- else get_no_comment
- in
- try
- let (first, last_pos) =
- List.fold_left
- (fun (first, last_pos) (si, (bp, ep)) ->
- do {
- copy_source ic oc first last_pos bp;
- flush oc;
- print_pretty pr_ch pr_str pr_nl "" "" maxl.val getcom bp
- (printer si [: :]);
- flush oc;
- (False, ep)
- })
- (True, 0) ast
- in
- do { copy_to_end ic oc first last_pos; flush oc }
- with x ->
- do { close_in ic; cleanup (); raise x };
- close_in ic;
- cleanup ()
- }
- else do {
- List.iter
- (fun (si, _) ->
- do {
- print_pretty pr_ch pr_str pr_nl "" "" maxl.val get_no_comment 0
- (printer si [: :]);
- match sep.val with
- [ Some str -> output_string_eval oc str
- | None -> output_char oc '\n' ];
- flush oc
- })
- ast;
- cleanup ()
- }
-;
-
-Pcaml.print_interf.val := apply_printer sig_item;
-Pcaml.print_implem.val := apply_printer str_item;
-
-Pcaml.add_option "-l" (Arg.Int (fun x -> maxl.val := x))
- "<length> Maximum line length for pretty printing.";
-
-Pcaml.add_option "-sep_src" (Arg.Unit (fun () -> sep.val := None))
- "Read source file for text between phrases (default).";
-
-Pcaml.add_option "-sep" (Arg.String (fun x -> sep.val := Some x))
- "<string> Use this string between phrases instead of reading source.";
-
-Pcaml.add_option "-no_where" (Arg.Clear gen_where)
- "Dont generate \"where\" statements";
-
-Pcaml.add_option "-cip" (Arg.Clear ncip) "Add comments in phrases.";
-
-Pcaml.add_option "-ncip" (Arg.Set ncip) "No comments in phrases (default).";
-
-Pcaml.add_option "-old_seq" (Arg.Set old_sequences)
- "Pretty print with old syntax for sequences.";
-
-Pcaml.add_option "-exp_dcl" (Arg.Set expand_declare)
- "Expand the \"declare\" items.";
-
-Pcaml.add_option "-tc" (Arg.Clear ncip)
- "Deprecated since version 3.05; equivalent to -cip.";
diff --git a/camlp4/etc/pr_rp.ml b/camlp4/etc/pr_rp.ml
deleted file mode 100644
index 3487165e9f..0000000000
--- a/camlp4/etc/pr_rp.ml
+++ /dev/null
@@ -1,504 +0,0 @@
-(* camlp4r q_MLast.cmo ./pa_extfun.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1998 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Pcaml;
-open Spretty;
-
-value loc = (0, 0);
-
-value expr e dg k = pr_expr.pr_fun "top" e dg k;
-value patt e dg k = pr_patt.pr_fun "top" e dg k;
-
-(* Streams *)
-
-value stream e dg k =
- let rec get =
- fun
- [ <:expr< Stream.iapp $x$ $y$ >> -> [(False, x) :: get y]
- | <:expr< Stream.icons $x$ $y$ >> -> [(True, x) :: get y]
- | <:expr< Stream.ising $x$ >> -> [(True, x)]
- | <:expr< Stream.lapp (fun _ -> $x$) $y$ >> -> [(False, x) :: get y]
- | <:expr< Stream.lcons (fun _ -> $x$) $y$ >> -> [(True, x) :: get y]
- | <:expr< Stream.lsing (fun _ -> $x$) >> -> [(True, x)]
- | <:expr< Stream.sempty >> -> []
- | <:expr< Stream.slazy (fun _ -> $x$) >> -> [(False, x)]
- | <:expr< Stream.slazy $x$ >> -> [(False, <:expr< $x$ () >>)]
- | e -> [(False, e)] ]
- in
- let elem e k =
- match e with
- [ (True, e) -> [: `HOVbox [: `S LO "`"; `expr e "" k :] :]
- | (False, e) -> [: `expr e "" k :] ]
- in
- let rec glop e k =
- match e with
- [ [] -> k
- | [e] -> [: elem e k :]
- | [e :: el] -> [: elem e [: `S RO ";" :]; glop el k :] ]
- in
- HOVbox [: `S LR "[:"; glop (get e) [: `S LR ":]"; k :] :]
-;
-
-(* Parsers *)
-
-type spc =
- [ SPCterm of (MLast.patt * option MLast.expr)
- | SPCnterm of MLast.patt and MLast.expr
- | SPCsterm of MLast.patt ]
-;
-
-exception NotImpl;
-
-value rec subst v e =
- match e with
- [ <:expr< $lid:x$ >> -> if x = "strm__" then <:expr< $lid:v$ >> else e
- | <:expr< $uid:_$ >> -> e
- | <:expr< $int:_$ >> -> e
- | <:expr< $chr:_$ >> -> e
- | <:expr< $str:_$ >> -> e
- | <:expr< $e1$ . $lab$ >> -> <:expr< $subst v e1$ . $lab$ >>
- | <:expr< $x$ $y$ >> -> <:expr< $subst v x$ $subst v y$ >>
- | <:expr< let $lid:s1$ = $e1$ in $e2$ >> ->
- if s1 = v then <:expr< let $lid:s1$ = $subst v e1$ in $e2$ >>
- else <:expr< let $lid:s1$ = $subst v e1$ in $subst v e2$ >>
- | <:expr< let _ = $e1$ in $e2$ >> ->
- <:expr< let _ = $subst v e1$ in $subst v e2$ >>
- | <:expr< ($list:el$) >> -> <:expr< ($list:List.map (subst v) el$) >>
- | _ -> raise NotImpl ]
-;
-
-value rec is_free v =
- fun
- [ <:expr< $lid:x$ >> -> x <> v
- | <:expr< $uid:_$ >> -> True
- | <:expr< $int:_$ >> -> True
- | <:expr< $chr:_$ >> -> True
- | <:expr< $str:_$ >> -> True
- | <:expr< $e$ . $_$ >> -> is_free v e
- | <:expr< $x$ $y$ >> -> is_free v x && is_free v y
- | <:expr< let $lid:s1$ = $e1$ in $e2$ >> ->
- is_free v e1 && (s1 = v || is_free v e2)
- | <:expr< let _ = $e1$ in $e2$ >> -> is_free v e1 && is_free v e2
- | <:expr< ($list:el$) >> -> List.for_all (is_free v) el
- | _ -> raise NotImpl ]
-;
-
-value gensym =
- let cnt = ref 0 in
- fun () ->
- do { incr cnt; "pr_rp_symb_" ^ string_of_int cnt.val }
-;
-
-value free_var_in_expr c e =
- let rec loop_alpha v =
- let x = String.make 1 v in
- if is_free x e then Some x
- else if v = 'z' then None
- else loop_alpha (Char.chr (Char.code v + 1))
- in
- let rec loop_count cnt =
- let x = String.make 1 c ^ string_of_int cnt in
- if is_free x e then x else loop_count (succ cnt)
- in
- try
- match loop_alpha c with
- [ Some v -> v
- | None -> loop_count 1 ]
- with
- [ NotImpl -> gensym () ]
-;
-
-value parserify =
- fun
- [ <:expr< $e$ strm__ >> -> e
- | e -> <:expr< fun strm__ -> $e$ >> ]
-;
-
-value is_raise_failure =
- fun
- [ <:expr< raise Stream.Failure >> -> True
- | _ -> False ]
-;
-
-value is_raise_error =
- fun
- [ <:expr< raise (Stream.Error $_$) >> -> True
- | _ -> False ]
-;
-
-value semantic e =
- try
- if is_free "strm__" e then e
- else
- let v = free_var_in_expr 's' e in
- <:expr< let $lid:v$ = strm__ in $subst v e$ >>
- with
- [ NotImpl -> e ]
-;
-
-value rewrite_parser =
- rewrite True where rec rewrite top ge =
- match ge with
- [ <:expr< let $p$ = try $e$ with [ Stream.Failure -> raise $exc$ ] in
- $sp_kont$ >> ->
- let f = parserify e in
- <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some $p$ -> $rewrite False sp_kont$
- | _ -> raise $exc$ ]
- >>
- | <:expr< let $p$ = Stream.count strm__ in $f$ >> ->
- try
- if is_free "strm__" f then ge
- else
- let v = free_var_in_expr 's' f in
- <:expr<
- let $lid:v$ = strm__ in
- let $p$ = Stream.count strm__ in $subst v f$
- >>
- with
- [ NotImpl -> ge ]
- | <:expr< let $p$ = strm__ in $e$ >> ->
- <:expr< let $p$ = strm__ in $rewrite False e$ >>
- | <:expr< let $p$ = $f$ strm__ in $sp_kont$ >> when top ->
- <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some $p$ -> $rewrite False sp_kont$
- | _ -> raise Stream.Failure ]
- >>
- | <:expr< let $p$ = $e$ in $sp_kont$ >> ->
- if match e with
- [ <:expr< match try Some $_$ with [ Stream.Failure -> None ] with
- [ $list:_$ ] >>
- | <:expr< match Stream.peek strm__ with [ $list:_$ ] >>
- | <:expr< try $_$ with [ Stream.Failure -> $_$ ] >>
- | <:expr< let $_$ = Stream.count strm__ in $_$ >> -> True
- | _ -> False ]
- then
- let f = rewrite True <:expr< fun strm__ -> $e$ >> in
- let exc =
- if top then <:expr< Stream.Failure >>
- else <:expr< Stream.Error "" >>
- in
- <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some $p$ -> $rewrite False sp_kont$
- | _ -> raise $exc$ ]
- >>
- else semantic ge
- | <:expr< match try Some $e$ with [ Stream.Failure -> None ] with
- [ Some $p$ -> $sp_kont$
- | _ -> $p_kont$ ] >> ->
- let f = parserify e in
- if not top && is_raise_failure p_kont then semantic ge
- else
- let (p, f, sp_kont, p_kont) =
- if top || is_raise_error p_kont then
- (p, f, rewrite False sp_kont, rewrite top p_kont)
- else
- let f =
- <:expr<
- fun strm__ ->
- match
- try Some ($f$ strm__) with [ Stream.Failure -> None ]
- with
- [ Some $p$ -> $rewrite False sp_kont$
- | _ -> $rewrite top p_kont$ ]
- >>
- in
- (<:patt< a >>, f, <:expr< a >>,
- <:expr< raise (Stream.Error "") >>)
- in
- <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some $p$ -> $sp_kont$
- | _ -> $p_kont$ ]
- >>
- | <:expr< match Stream.peek strm__ with [ $list:pel$ ] >> ->
- let rec iter pel =
- match pel with
- [ [(<:patt< Some $p$ >>, eo,
- <:expr< do { Stream.junk strm__; $sp_kont$ } >>);
- (<:patt< _ >>, None, p_kont) :: _] ->
- <:expr<
- match Stream.peek strm__ with
- [ Some $p$ $when:eo$ ->
- do { Stream.junk strm__; $rewrite False sp_kont$ }
- | _ -> $rewrite top p_kont$ ]
- >>
- | [(<:patt< Some $p$ >>, eo,
- <:expr< do { Stream.junk strm__; $sp_kont$ } >>) :: pel] ->
- let p_kont = iter pel in
- <:expr<
- match Stream.peek strm__ with
- [ Some $p$ $when:eo$ ->
- do { Stream.junk strm__; $rewrite False sp_kont$ }
- | _ -> $p_kont$ ]
- >>
- | _ ->
- <:expr< match Stream.peek strm__ with [ $list:pel$ ] >> ]
- in
- iter pel
- | <:expr< try Some $e$ with [ Stream.Failure -> $p_kont$ ] >> ->
- let f = parserify e in
- let e =
- <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some a -> Some a
- | _ -> $p_kont$ ]
- >>
- in
- rewrite top e
- | <:expr< try $e$ with [ Stream.Failure -> $p_kont$ ] >> ->
- let f = parserify e in
- let e =
- <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some a -> a
- | _ -> $rewrite top p_kont$ ]
- >>
- in
- rewrite top e
- | <:expr< $f$ strm__ >> ->
- if top then
- <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some a -> a
- | _ -> raise Stream.Failure ]
- >>
- else
- let v = free_var_in_expr 's' f in
- <:expr< let $lid:v$ = strm__ in $f$ $lid:v$ >>
- | e -> semantic e ]
-;
-
-value parser_of_expr =
- let rec parser_cases e =
- match e with
- [ <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some $p$ -> $sp_kont$
- | _ -> $p_kont$ ]
- >> ->
- let spc = (SPCnterm p f, None) in
- let (sp, epo, e) = kont sp_kont in
- [([spc :: sp], epo, e) :: parser_cases p_kont]
- | <:expr<
- match Stream.peek strm__ with
- [ Some $p$ $when:wo$ -> do { Stream.junk strm__; $sp_kont$ }
- | _ -> $p_kont$ ]
- >> ->
- let spc = (SPCterm (p, wo), None) in
- let (sp, epo, e) = kont sp_kont in
- [([spc :: sp], epo, e) :: parser_cases p_kont]
- | <:expr< let $p$ = strm__ in $sp_kont$ >> ->
- let spc = (SPCsterm p, None) in
- let (sp, epo, e) = kont sp_kont in
- [([spc :: sp], epo, e)]
- | <:expr< let $p$ = Stream.count strm__ in $e$ >> -> [([], Some p, e)]
- | <:expr< raise Stream.Failure >> -> []
- | _ -> [([], None, e)] ]
- and kont e =
- match e with
- [ <:expr<
- match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
- [ Some $p$ -> $sp_kont$
- | _ -> raise (Stream.Error $err$) ]
- >> ->
- let err =
- match err with
- [ <:expr< "" >> -> None
- | _ -> Some err ]
- in
- let spc = (SPCnterm p f, err) in
- let (sp, epo, e) = kont sp_kont in
- ([spc :: sp], epo, e)
- | <:expr<
- match Stream.peek strm__ with
- [ Some $p$ $when:wo$ -> do { Stream.junk strm__; $sp_kont$ }
- | _ -> raise (Stream.Error $err$) ]
- >> ->
- let err =
- match err with
- [ <:expr< "" >> -> None
- | _ -> Some err ]
- in
- let spc = (SPCterm (p, wo), err) in
- let (sp, epo, e) = kont sp_kont in
- ([spc :: sp], epo, e)
- | <:expr< let $p$ = strm__ in $sp_kont$ >> ->
- let spc = (SPCsterm p, None) in
- let (sp, epo, e) = kont sp_kont in
- ([spc :: sp], epo, e)
- | <:expr< let $p$ = Stream.count strm__ in $e$ >> -> ([], Some p, e)
- | _ -> ([], None, e) ]
- in
- parser_cases
-;
-
-value parser_cases b spel k =
- let rec parser_cases b spel k =
- match spel with
- [ [] -> [: `HVbox [: b; k :] :]
- | [(sp, epo, e)] -> [: `parser_case b sp epo e k :]
- | [(sp, epo, e) :: spel] ->
- [: `parser_case b sp epo e [: :];
- parser_cases [: `S LR "|" :] spel k :] ]
- and parser_case b sp epo e k =
- let epo =
- match epo with
- [ Some p -> [: `patt p "" [: `S LR "->" :] :]
- | _ -> [: `S LR "->" :] ]
- in
- HVbox
- [: b;
- `HOVbox
- [: `HOVbox
- [: `S LR "[:";
- stream_patt [: :] sp [: `S LR ":]"; epo :] :];
- `expr e "" k :] :]
- and stream_patt b sp k =
- match sp with
- [ [] -> [: `HVbox [: b; k :] :]
- | [(spc, None)] -> [: `stream_patt_comp b spc k :]
- | [(spc, Some e)] ->
- [: `HVbox
- [: `stream_patt_comp b spc [: :];
- `HVbox [: `S LR "?"; `expr e "" k :] :] :]
- | [(spc, None) :: spcl] ->
- [: `stream_patt_comp b spc [: `S RO ";" :];
- stream_patt [: :] spcl k :]
- | [(spc, Some e) :: spcl] ->
- [: `HVbox
- [: `stream_patt_comp b spc [: :];
- `HVbox [: `S LR "?"; `expr e "" [: `S RO ";" :] :] :];
- stream_patt [: :] spcl k :] ]
- and stream_patt_comp b spc k =
- match spc with
- [ SPCterm (p, w) ->
- HVbox [: b; `S LO "`"; `patt p "" [: :]; `HVbox [: when_opt w k :] :]
- | SPCnterm p e ->
- HVbox [: b; `HVbox [: `patt p "" [: `S LR "=" :]; `expr e "" k :] :]
- | SPCsterm p -> HVbox [: b; `patt p "" k :] ]
- and when_opt wo k =
- match wo with
- [ Some e -> [: `S LR "when"; `expr e "" k :]
- | _ -> k ]
- in
- parser_cases b spel k
-;
-
-value parser_body e dg k =
- let (bp, e) =
- match e with
- [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e)
- | e -> (None, e) ]
- in
- let e = rewrite_parser e in
- match parser_of_expr e with
- [ [] ->
- HVbox
- [: `HVbox
- [: `S LR "parser";
- match bp with
- [ Some p -> [: `patt p "" [: :] :]
- | _ -> [: :] ] :];
- `HVbox [: `S LR "[]"; k :] :]
- | [spe] ->
- HVbox
- [: `HVbox
- [: `S LR "parser";
- match bp with
- [ Some p -> [: `patt p "" [: :] :]
- | _ -> [: :] ] :];
- parser_cases [: :] [spe] k :]
- | spel ->
- Vbox
- [: `HVbox [: :];
- `HVbox
- [: `S LR "parser";
- match bp with
- [ Some p -> [: `patt p "" [: :] :]
- | _ -> [: :] ] :];
- parser_cases [: `S LR "[" :] spel [: `S LR "]"; k :] :] ]
-;
-
-value pmatch e dg k =
- let (me, e) =
- match e with
- [ <:expr< let (strm__ : Stream.t _) = $me$ in $e$ >> -> (me, e)
- | <:expr< match $_$ strm__ with [ $list:_$ ] >> -> (<:expr< strm__ >>, e)
- | _ -> failwith "Pr_rp.pmatch" ]
- in
- let (bp, e) =
- match e with
- [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e)
- | e -> (None, e) ]
- in
- let e = rewrite_parser e in
- let spel = parser_of_expr e in
- Vbox
- [: `HVbox [: :];
- `HVbox
- [: `S LR "match"; `expr me "" [: `S LR "with" :]; `S LR "parser";
- match bp with
- [ Some p -> [: `patt p "" [: :] :]
- | _ -> [: :] ] :];
- parser_cases [: `S LR "[" :] spel [: `S LR "]"; k :] :]
-;
-
-(* Printer extensions *)
-
-pr_expr_fun_args.val :=
- extfun pr_expr_fun_args.val with
- [ <:expr< fun strm__ -> $_$ >> as ge -> ([], ge)
- | <:expr< fun [(strm__ : $_$) -> $_$] >> as ge -> ([], ge) ];
-
-let lev = find_pr_level "top" pr_expr.pr_levels in
-lev.pr_rules :=
- extfun lev.pr_rules with
- [ <:expr< let (strm__ : Stream.t _) = $_$ in $_$ >> as e ->
- fun curr next _ k -> [: `pmatch e "" k :]
- | <:expr< match $_$ strm__ with [ $list:_$ ] >> as e ->
- fun curr next _ k -> [: `pmatch e "" k :]
- | <:expr< fun strm__ -> $x$ >> ->
- fun curr next _ k -> [: `parser_body x "" k :]
- | <:expr< fun (strm__ : $_$) -> $x$ >> ->
- fun curr next _ k -> [: `parser_body x "" k :] ];
-
-let lev = find_pr_level "apply" pr_expr.pr_levels in
-lev.pr_rules :=
- extfun lev.pr_rules with
- [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> |
- <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> |
- <:expr< Stream.lcons (fun _ -> $_$) $_$ >> |
- <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> |
- <:expr< Stream.slazy $_$ >> as e ->
- fun curr next _ k -> [: `next e "" k :] ];
-
-let lev = find_pr_level "dot" pr_expr.pr_levels in
-lev.pr_rules :=
- extfun lev.pr_rules with
- [ <:expr< Stream.sempty >> as e ->
- fun curr next _ k -> [: `next e "" k :] ];
-
-let lev = find_pr_level "simple" pr_expr.pr_levels in
-lev.pr_rules :=
- extfun lev.pr_rules with
- [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> |
- <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> |
- <:expr< Stream.lcons (fun _ -> $_$) $_$ >> |
- <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> |
- <:expr< Stream.slazy $_$ >> as e ->
- fun curr next _ k -> [: `stream e "" k :] ];
diff --git a/camlp4/etc/pr_rp_main.ml b/camlp4/etc/pr_rp_main.ml
deleted file mode 100644
index 11ad11af77..0000000000
--- a/camlp4/etc/pr_rp_main.ml
+++ /dev/null
@@ -1,206 +0,0 @@
-(* camlp4r q_MLast.cmo ./pa_extfun.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1998 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Pcaml;
-open Spretty;
-
-value loc = (0, 0);
-
-value expr e dg k = pr_expr.pr_fun "top" e dg k;
-value patt e dg k = pr_patt.pr_fun "top" e dg k;
-
-(* Streams *)
-
-value stream e dg k =
- let rec get =
- fun
- [ <:expr< Stream.iapp $x$ $y$ >> -> [(False, x) :: get y]
- | <:expr< Stream.icons $x$ $y$ >> -> [(True, x) :: get y]
- | <:expr< Stream.ising $x$ >> -> [(True, x)]
- | <:expr< Stream.lapp (fun _ -> $x$) $y$ >> -> [(False, x) :: get y]
- | <:expr< Stream.lcons (fun _ -> $x$) $y$ >> -> [(True, x) :: get y]
- | <:expr< Stream.lsing (fun _ -> $x$) >> -> [(True, x)]
- | <:expr< Stream.sempty >> -> []
- | <:expr< Stream.slazy (fun _ -> $x$) >> -> [(False, x)]
- | <:expr< Stream.slazy $x$ >> -> [(False, <:expr< $x$ () >>)]
- | e -> [(False, e)] ]
- in
- let elem e k =
- match e with
- [ (True, e) -> [: `HOVbox [: `S LO "`"; `expr e "" k :] :]
- | (False, e) -> [: `expr e "" k :] ]
- in
- let rec glop e k =
- match e with
- [ [] -> k
- | [e] -> [: elem e k :]
- | [e :: el] -> [: elem e [: `S RO ";" :]; glop el k :] ]
- in
- HOVbox [: `S LR "[:"; glop (get e) [: `S LR ":]"; k :] :]
-;
-
-(* Parsers *)
-
-open Parserify;
-
-value parser_cases b spel k =
- let rec parser_cases b spel k =
- match spel with
- [ [] -> [: `HVbox [: b; k :] :]
- | [(sp, epo, e)] -> [: `parser_case b sp epo e k :]
- | [(sp, epo, e) :: spel] ->
- [: `parser_case b sp epo e [: :];
- parser_cases [: `S LR "|" :] spel k :] ]
- and parser_case b sp epo e k =
- let epo =
- match epo with
- [ Some p -> [: `patt p "" [: `S LR "->" :] :]
- | _ -> [: `S LR "->" :] ]
- in
- HVbox
- [: b;
- `HOVbox
- [: `HOVbox
- [: `S LR "[:";
- stream_patt [: :] sp [: `S LR ":]"; epo :] :];
- `expr e "" k :] :]
- and stream_patt b sp k =
- match sp with
- [ [] -> [: `HVbox [: b; k :] :]
- | [(spc, None)] -> [: `stream_patt_comp b spc k :]
- | [(spc, Some e)] ->
- [: `HVbox
- [: `stream_patt_comp b spc [: :];
- `HVbox [: `S LR "?"; `expr e "" k :] :] :]
- | [(spc, None) :: spcl] ->
- [: `stream_patt_comp b spc [: `S RO ";" :];
- stream_patt [: :] spcl k :]
- | [(spc, Some e) :: spcl] ->
- [: `HVbox
- [: `stream_patt_comp b spc [: :];
- `HVbox [: `S LR "?"; `expr e "" [: `S RO ";" :] :] :];
- stream_patt [: :] spcl k :] ]
- and stream_patt_comp b spc k =
- match spc with
- [ SPCterm (p, w) ->
- HVbox [: b; `S LO "`"; `patt p "" [: :]; `HVbox [: when_opt w k :] :]
- | SPCnterm p e ->
- HVbox [: b; `HVbox [: `patt p "" [: `S LR "=" :]; `expr e "" k :] :]
- | SPCsterm p -> HVbox [: b; `patt p "" k :] ]
- and when_opt wo k =
- match wo with
- [ Some e -> [: `S LR "when"; `expr e "" k :]
- | _ -> k ]
- in
- parser_cases b spel k
-;
-
-value parser_body e dg k =
- let (bp, e) =
- match e with
- [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e)
- | e -> (None, e) ]
- in
- match parser_of_expr e with
- [ [] ->
- HVbox
- [: `HVbox
- [: `S LR "parser";
- match bp with
- [ Some p -> [: `patt p "" [: :] :]
- | _ -> [: :] ] :];
- `HVbox [: `S LR "[]"; k :] :]
- | [spe] ->
- HVbox
- [: `HVbox
- [: `S LR "parser";
- match bp with
- [ Some p -> [: `patt p "" [: :] :]
- | _ -> [: :] ] :];
- parser_cases [: :] [spe] k :]
- | spel ->
- Vbox
- [: `HVbox [: :];
- `HVbox
- [: `S LR "parser";
- match bp with
- [ Some p -> [: `patt p "" [: :] :]
- | _ -> [: :] ] :];
- parser_cases [: `S LR "[" :] spel [: `S LR "]"; k :] :] ]
-;
-
-value pmatch e dg k =
- let (me, e) =
- match e with
- [ <:expr< let (strm__ : Stream.t _) = $me$ in $e$ >> -> (me, e)
- | _ -> failwith "Pr_rp.pmatch" ]
- in
- let (bp, e) =
- match e with
- [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e)
- | e -> (None, e) ]
- in
- let spel = parser_of_expr e in
- Vbox
- [: `HVbox [: :];
- `HVbox
- [: `S LR "match"; `expr me "" [: `S LR "with" :]; `S LR "parser";
- match bp with
- [ Some p -> [: `patt p "" [: :] :]
- | _ -> [: :] ] :];
- parser_cases [: `S LR "[" :] spel [: `S LR "]"; k :] :]
-;
-
-(* Printer extensions *)
-
-pr_expr_fun_args.val :=
- extfun pr_expr_fun_args.val with
- [ <:expr< fun strm__ -> $_$ >> as ge -> ([], ge)
- | <:expr< fun [(strm__ : $_$) -> $_$] >> as ge -> ([], ge) ];
-
-let lev = find_pr_level "top" pr_expr.pr_levels in
-lev.pr_rules :=
- extfun lev.pr_rules with
- [ <:expr< let (strm__ : Stream.t _) = $_$ in $_$ >> as e ->
- fun curr next _ k -> [: `pmatch e "" k :]
- | <:expr< fun strm__ -> $x$ >> ->
- fun curr next _ k -> [: `parser_body x "" k :]
- | <:expr< fun (strm__ : $_$) -> $x$ >> ->
- fun curr next _ k -> [: `parser_body x "" k :] ];
-
-let lev = find_pr_level "apply" pr_expr.pr_levels in
-lev.pr_rules :=
- extfun lev.pr_rules with
- [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> |
- <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> |
- <:expr< Stream.lcons (fun _ -> $_$) $_$ >> |
- <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> |
- <:expr< Stream.slazy $_$ >> as e ->
- fun curr next _ k -> [: `next e "" k :] ];
-
-let lev = find_pr_level "dot" pr_expr.pr_levels in
-lev.pr_rules :=
- extfun lev.pr_rules with
- [ <:expr< Stream.sempty >> as e ->
- fun curr next _ k -> [: `next e "" k :] ];
-
-let lev = find_pr_level "simple" pr_expr.pr_levels in
-lev.pr_rules :=
- extfun lev.pr_rules with
- [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> |
- <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> |
- <:expr< Stream.lcons (fun _ -> $_$) $_$ >> |
- <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> |
- <:expr< Stream.slazy $_$ >> as e ->
- fun curr next _ k -> [: `stream e "" k :] ];
diff --git a/camlp4/etc/pr_scheme.ml b/camlp4/etc/pr_scheme.ml
deleted file mode 100644
index a7c2309488..0000000000
--- a/camlp4/etc/pr_scheme.ml
+++ /dev/null
@@ -1,813 +0,0 @@
-(* camlp4r q_MLast.cmo ./pa_extfun.cmo *)
-(* $Id$ *)
-
-open Pcaml;
-open Format;
-
-type printer_t 'a =
- { pr_fun : mutable string -> next 'a;
- pr_levels : mutable list (pr_level 'a) }
-and pr_level 'a =
- { pr_label : string;
- pr_box : formatter -> (formatter -> unit) -> 'a -> unit;
- pr_rules : mutable pr_rule 'a }
-and pr_rule 'a =
- Extfun.t 'a (formatter -> curr 'a -> next 'a -> string -> kont -> unit)
-and curr 'a = formatter -> ('a * string * kont) -> unit
-and next 'a = formatter -> ('a * string * kont) -> unit
-and kont = formatter -> unit;
-
-value not_impl name x ppf k =
- let desc =
- if Obj.is_block (Obj.repr x) then
- "tag = " ^ string_of_int (Obj.tag (Obj.repr x))
- else "int_val = " ^ string_of_int (Obj.magic x)
- in
- fprintf ppf "<pr_scheme: not impl: %s; %s>%t" name desc k
-;
-
-value pr_fun name pr lab =
- loop False pr.pr_levels where rec loop app =
- fun
- [ [] -> fun ppf (x, dg, k) -> failwith ("unable to print " ^ name)
- | [lev :: levl] ->
- if app || lev.pr_label = lab then
- let next = loop True levl in
- let rec curr ppf (x, dg, k) =
- Extfun.apply lev.pr_rules x ppf curr next dg k
- in
- fun ppf ((x, _, _) as n) -> lev.pr_box ppf (fun ppf -> curr ppf n) x
- else loop app levl ]
-;
-
-value rec find_pr_level lab =
- fun
- [ [] -> failwith ("level " ^ lab ^ " not found")
- | [lev :: levl] ->
- if lev.pr_label = lab then lev else find_pr_level lab levl ]
-;
-
-value pr_constr_decl = {pr_fun = fun []; pr_levels = []};
-value constr_decl ppf (x, k) = pr_constr_decl.pr_fun "top" ppf (x, "", k);
-pr_constr_decl.pr_fun := pr_fun "constr_decl" pr_constr_decl;
-
-value pr_ctyp = {pr_fun = fun []; pr_levels = []};
-pr_ctyp.pr_fun := pr_fun "ctyp" pr_ctyp;
-value ctyp ppf (x, k) = pr_ctyp.pr_fun "top" ppf (x, "", k);
-
-value pr_expr = {pr_fun = fun []; pr_levels = []};
-pr_expr.pr_fun := pr_fun "expr" pr_expr;
-value expr ppf (x, k) = pr_expr.pr_fun "top" ppf (x, "", k);
-
-value pr_label_decl = {pr_fun = fun []; pr_levels = []};
-value label_decl ppf (x, k) = pr_label_decl.pr_fun "top" ppf (x, "", k);
-pr_label_decl.pr_fun := pr_fun "label_decl" pr_label_decl;
-
-value pr_let_binding = {pr_fun = fun []; pr_levels = []};
-pr_let_binding.pr_fun := pr_fun "let_binding" pr_let_binding;
-value let_binding ppf (x, k) = pr_let_binding.pr_fun "top" ppf (x, "", k);
-
-value pr_match_assoc = {pr_fun = fun []; pr_levels = []};
-pr_match_assoc.pr_fun := pr_fun "match_assoc" pr_match_assoc;
-value match_assoc ppf (x, k) = pr_match_assoc.pr_fun "top" ppf (x, "", k);
-
-value pr_mod_ident = {pr_fun = fun []; pr_levels = []};
-pr_mod_ident.pr_fun := pr_fun "mod_ident" pr_mod_ident;
-value mod_ident ppf (x, k) = pr_mod_ident.pr_fun "top" ppf (x, "", k);
-
-value pr_module_binding = {pr_fun = fun []; pr_levels = []};
-pr_module_binding.pr_fun := pr_fun "module_binding" pr_module_binding;
-value module_binding ppf (x, k) =
- pr_module_binding.pr_fun "top" ppf (x, "", k);
-
-value pr_module_expr = {pr_fun = fun []; pr_levels = []};
-pr_module_expr.pr_fun := pr_fun "module_expr" pr_module_expr;
-value module_expr ppf (x, k) = pr_module_expr.pr_fun "top" ppf (x, "", k);
-
-value pr_module_type = {pr_fun = fun []; pr_levels = []};
-pr_module_type.pr_fun := pr_fun "module_type" pr_module_type;
-value module_type ppf (x, k) = pr_module_type.pr_fun "top" ppf (x, "", k);
-
-value pr_patt = {pr_fun = fun []; pr_levels = []};
-pr_patt.pr_fun := pr_fun "patt" pr_patt;
-value patt ppf (x, k) = pr_patt.pr_fun "top" ppf (x, "", k);
-
-value pr_sig_item = {pr_fun = fun []; pr_levels = []};
-pr_sig_item.pr_fun := pr_fun "sig_item" pr_sig_item;
-value sig_item ppf (x, k) = pr_sig_item.pr_fun "top" ppf (x, "", k);
-
-value pr_str_item = {pr_fun = fun []; pr_levels = []};
-pr_str_item.pr_fun := pr_fun "str_item" pr_str_item;
-value str_item ppf (x, k) = pr_str_item.pr_fun "top" ppf (x, "", k);
-
-value pr_type_decl = {pr_fun = fun []; pr_levels = []};
-value type_decl ppf (x, k) = pr_type_decl.pr_fun "top" ppf (x, "", k);
-pr_type_decl.pr_fun := pr_fun "type_decl" pr_type_decl;
-
-value pr_type_params = {pr_fun = fun []; pr_levels = []};
-value type_params ppf (x, k) = pr_type_params.pr_fun "top" ppf (x, "", k);
-pr_type_params.pr_fun := pr_fun "type_params" pr_type_params;
-
-value pr_with_constr = {pr_fun = fun []; pr_levels = []};
-value with_constr ppf (x, k) = pr_with_constr.pr_fun "top" ppf (x, "", k);
-pr_with_constr.pr_fun := pr_fun "with_constr" pr_with_constr;
-
-(* general functions *)
-
-value nok ppf = ();
-value ks s k ppf = fprintf ppf "%s%t" s k;
-
-value rec list f ppf (l, k) =
- match l with
- [ [] -> k ppf
- | [x] -> f ppf (x, k)
- | [x :: l] -> fprintf ppf "%a@ %a" f (x, nok) (list f) (l, k) ]
-;
-
-value rec listwb b f ppf (l, k) =
- match l with
- [ [] -> k ppf
- | [x] -> f ppf ((b, x), k)
- | [x :: l] -> fprintf ppf "%a@ %a" f ((b, x), nok) (listwb "" f) (l, k) ]
-;
-
-(* specific functions *)
-
-value rec is_irrefut_patt =
- fun
- [ <:patt< $lid:_$ >> -> True
- | <:patt< () >> -> True
- | <:patt< _ >> -> True
- | <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y
- | <:patt< { $list:fpl$ } >> ->
- List.for_all (fun (_, p) -> is_irrefut_patt p) fpl
- | <:patt< ($p$ : $_$) >> -> is_irrefut_patt p
- | <:patt< ($list:pl$) >> -> List.for_all is_irrefut_patt pl
- | <:patt< ? $_$ : ( $p$ ) >> -> is_irrefut_patt p
- | <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p
- | <:patt< ~ $_$ >> -> True
- | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p
- | _ -> False ]
-;
-
-value expr_fun_args ge = Extfun.apply pr_expr_fun_args.val ge;
-
-pr_expr_fun_args.val :=
- extfun Extfun.empty with
- [ <:expr< fun [$p$ -> $e$] >> as ge ->
- if is_irrefut_patt p then
- let (pl, e) = expr_fun_args e in
- ([p :: pl], e)
- else ([], ge)
- | ge -> ([], ge) ];
-
-value sequence ppf (e, k) =
- match e with
- [ <:expr< do { $list:el$ } >> ->
- fprintf ppf "@[<hv>%a@]" (list expr) (el, k)
- | _ -> expr ppf (e, k) ]
-;
-
-value string ppf (s, k) = fprintf ppf "\"%s\"%t" s k;
-
-value int_repr s =
- if String.length s > 2 && s.[0] = '0' then
- match s.[1] with
- [ 'b' | 'o' | 'x' | 'B' | 'O' | 'X' ->
- "#" ^ String.sub s 1 (String.length s - 1)
- | _ -> s ]
- else s
-;
-
-value assoc_left_parsed_op_list = ["+"; "*"; "land"; "lor"; "lxor"];
-value assoc_right_parsed_op_list = ["and"; "or"; "^"; "@"];
-value and_by_couple_op_list = ["="; "<>"; "<"; ">"; "<="; ">="; "=="; "!="];
-
-(* extensible pretty print functions *)
-
-pr_constr_decl.pr_levels :=
- [{pr_label = "top";
- pr_box ppf f x = fprintf ppf "@[%t@]" f;
- pr_rules =
- extfun Extfun.empty with
- [ (loc, c, []) as x ->
- fun ppf curr next dg k -> fprintf ppf "(@[<hv>%s%t@]" c (ks ")" k)
- | (loc, c, tl) ->
- fun ppf curr next dg k ->
- fprintf ppf "(@[<hv>%s@ %a@]" c (list ctyp) (tl, ks ")" k) ]}];
-
-pr_ctyp.pr_levels :=
- [{pr_label = "top";
- pr_box ppf f x = fprintf ppf "@[%t@]" f;
- pr_rules =
- extfun Extfun.empty with
- [ <:ctyp< [ $list:cdl$ ] >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(@[<hv>sum@ %a@]" (list constr_decl) (cdl, ks ")" k)
- | <:ctyp< { $list:cdl$ } >> ->
- fun ppf curr next dg k ->
- fprintf ppf "{@[<hv>%a@]" (list label_decl) (cdl, ks "}" k)
- | <:ctyp< ( $list:tl$ ) >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(@[* @[<hv>%a@]@]" (list ctyp) (tl, ks ")" k)
- | <:ctyp< $t1$ -> $t2$ >> ->
- fun ppf curr next dg k ->
- let tl =
- loop t2 where rec loop =
- fun
- [ <:ctyp< $t1$ -> $t2$ >> -> [t1 :: loop t2]
- | t -> [t] ]
- in
- fprintf ppf "(@[-> @[<hv>%a@]@]" (list ctyp)
- ([t1 :: tl], ks ")" k)
- | <:ctyp< $t1$ $t2$ >> ->
- fun ppf curr next dg k ->
- let (t, tl) =
- loop [t2] t1 where rec loop tl =
- fun
- [ <:ctyp< $t1$ $t2$ >> -> loop [t2 :: tl] t1
- | t1 -> (t1, tl) ]
- in
- fprintf ppf "(@[%a@ %a@]" ctyp (t, nok) (list ctyp) (tl, ks ")" k)
- | <:ctyp< $t1$ . $t2$ >> ->
- fun ppf curr next dg k ->
- fprintf ppf "%a.%a" ctyp (t1, nok) ctyp (t2, k)
- | <:ctyp< $lid:s$ >> | <:ctyp< $uid:s$ >> ->
- fun ppf curr next dg k -> fprintf ppf "%s%t" s k
- | <:ctyp< ' $s$ >> ->
- fun ppf curr next dg k -> fprintf ppf "'%s%t" s k
- | <:ctyp< _ >> ->
- fun ppf curr next dg k -> fprintf ppf "_%t" k
- | x ->
- fun ppf curr next dg k -> not_impl "ctyp" x ppf k ]}];
-
-pr_expr.pr_levels :=
- [{pr_label = "top";
- pr_box ppf f x = fprintf ppf "@[%t@]" f;
- pr_rules =
- extfun Extfun.empty with
- [ <:expr< fun [] >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(lambda%t" (ks ")" k)
- | <:expr< fun $lid:s$ -> $e$ >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(lambda@ %s@;<1 1>%a" s expr (e, ks ")" k)
- | <:expr< fun [ $list:pwel$ ] >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(@[<hv>lambda_match@ %a@]" (list match_assoc)
- (pwel, ks ")" k)
- | <:expr< match $e$ with [ $list:pwel$ ] >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(@[<hv>@[<b 2>match@ %a@]@ %a@]" expr (e, nok)
- (list match_assoc) (pwel, ks ")" k)
- | <:expr< try $e$ with [ $list:pwel$ ] >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(@[<hv>@[<b 2>try@ %a@]@ %a@]" expr (e, nok)
- (list match_assoc) (pwel, ks ")" k)
- | <:expr< let $p1$ = $e1$ in $e2$ >> ->
- fun ppf curr next dg k ->
- let (pel, e) =
- loop [(p1, e1)] e2 where rec loop pel =
- fun
- [ <:expr< let $p1$ = $e1$ in $e2$ >> ->
- loop [(p1, e1) :: pel] e2
- | e -> (List.rev pel, e) ]
- in
- let b =
- match pel with
- [ [_] -> "let"
- | _ -> "let*" ]
- in
- fprintf ppf "(@[@[%s (@[<v>%a@]@]@;<1 2>%a@]" b
- (listwb "" let_binding) (pel, ks ")" nok)
- sequence (e, ks ")" k)
- | <:expr< let $opt:rf$ $list:pel$ in $e$ >> ->
- fun ppf curr next dg k ->
- let b = if rf then "letrec" else "let" in
- fprintf ppf "(@[<hv>%s@ (@[<hv>%a@]@ %a@]" b
- (listwb "" let_binding) (pel, ks ")" nok) expr (e, ks ")" k)
- | <:expr< if $e1$ then $e2$ else () >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(if @[%a@;<1 0>%a@]" expr (e1, nok)
- expr (e2, ks ")" k)
- | <:expr< if $e1$ then $e2$ else $e3$ >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(if @[%a@ %a@ %a@]" expr (e1, nok)
- expr (e2, nok) expr (e3, ks ")" k)
- | <:expr< do { $list:el$ } >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(begin@;<1 1>@[<hv>%a@]" (list expr) (el, ks ")" k)
- | <:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(@[for %s@ %a@ %a %a@]" i expr (e1, nok)
- expr (e2, nok) (list expr) (el, ks ")" k)
- | <:expr< ($e$ : $t$) >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(:@ %a@ %a" expr (e, nok) ctyp (t, ks ")" k)
- | <:expr< ($list:el$) >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(values @[%a@]" (list expr) (el, ks ")" k)
- | <:expr< { $list:fel$ } >> ->
- fun ppf curr next dg k ->
- let record_binding ppf ((p, e), k) =
- fprintf ppf "(@[%a@ %a@]" patt (p, nok) expr (e, ks ")" k)
- in
- fprintf ppf "{@[<hv>%a@]" (list record_binding) (fel, ks "}" k)
- | <:expr< { ($e$) with $list:fel$ } >> ->
- fun ppf curr next dg k ->
- let record_binding ppf ((p, e), k) =
- fprintf ppf "(@[%a@ %a@]" patt (p, nok) expr (e, ks ")" k)
- in
- fprintf ppf "{@[@[with@ %a@]@ @[%a@]@]" expr (e, nok)
- (list record_binding) (fel, ks "}" k)
- | <:expr< $e1$ := $e2$ >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(:=@;<1 1>%a@;<1 1>%a" expr (e1, nok)
- expr (e2, ks ")" k)
- | <:expr< [$_$ :: $_$] >> as e ->
- fun ppf curr next dg k ->
- let (el, c) =
- make_list e where rec make_list e =
- match e with
- [ <:expr< [$e$ :: $y$] >> ->
- let (el, c) = make_list y in
- ([e :: el], c)
- | <:expr< [] >> -> ([], None)
- | x -> ([], Some e) ]
- in
- match c with
- [ None ->
- fprintf ppf "[%a" (list expr) (el, ks "]" k)
- | Some x ->
- fprintf ppf "[%a@ %a" (list expr) (el, ks " ." nok)
- expr (x, ks "]" k) ]
- | <:expr< lazy ($x$) >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(@[lazy@ %a@]" expr (x, ks ")" k)
- | <:expr< $lid:s$ $e1$ $e2$ >>
- when List.mem s assoc_right_parsed_op_list ->
- fun ppf curr next dg k ->
- let el =
- loop [e1] e2 where rec loop el =
- fun
- [ <:expr< $lid:s1$ $e1$ $e2$ >> when s1 = s ->
- loop [e1 :: el] e2
- | e -> List.rev [e :: el] ]
- in
- fprintf ppf "(@[%s %a@]" s (list expr) (el, ks ")" k)
- | <:expr< $e1$ $e2$ >> ->
- fun ppf curr next dg k ->
- let (f, el) =
- loop [e2] e1 where rec loop el =
- fun
- [ <:expr< $e1$ $e2$ >> -> loop [e2 :: el] e1
- | e1 -> (e1, el) ]
- in
- fprintf ppf "(@[%a@ %a@]" expr (f, nok) (list expr) (el, ks ")" k)
- | <:expr< ~ $s$ : ($e$) >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(~%s@ %a" s expr (e, ks ")" k)
- | <:expr< $e1$ .[ $e2$ ] >> ->
- fun ppf curr next dg k ->
- fprintf ppf "%a.[%a" expr (e1, nok) expr (e2, ks "]" k)
- | <:expr< $e1$ .( $e2$ ) >> ->
- fun ppf curr next dg k ->
- fprintf ppf "%a.(%a" expr (e1, nok) expr (e2, ks ")" k)
- | <:expr< $e1$ . $e2$ >> ->
- fun ppf curr next dg k ->
- fprintf ppf "%a.%a" expr (e1, nok) expr (e2, k)
- | <:expr< $int:s$ >> ->
- fun ppf curr next dg k -> fprintf ppf "%s%t" (int_repr s) k
- | <:expr< $lid:s$ >> | <:expr< $uid:s$ >> ->
- fun ppf curr next dg k -> fprintf ppf "%s%t" s k
- | <:expr< ` $s$ >> ->
- fun ppf curr next dg k -> fprintf ppf "`%s%t" s k
- | <:expr< $str:s$ >> ->
- fun ppf curr next dg k -> fprintf ppf "\"%s\"%t" s k
- | <:expr< $chr:s$ >> ->
- fun ppf curr next dg k -> fprintf ppf "'%s'%t" s k
- | x ->
- fun ppf curr next dg k -> not_impl "expr" x ppf k ]}];
-
-pr_label_decl.pr_levels :=
- [{pr_label = "top";
- pr_box ppf f x = fprintf ppf "@[%t@]" f;
- pr_rules =
- extfun Extfun.empty with
- [ (loc, f, m, t) ->
- fun ppf curr next dg k ->
- fprintf ppf "(@[<hv>%s%t@ %a@]" f
- (fun ppf -> if m then fprintf ppf "@ mutable" else ())
- ctyp (t, ks ")" k) ]}];
-
-pr_let_binding.pr_levels :=
- [{pr_label = "top";
- pr_box ppf f x = fprintf ppf "@[%t@]" f;
- pr_rules =
- extfun Extfun.empty with
- [ (b, (p, e)) ->
- fun ppf curr next dg k ->
- let (pl, e) = expr_fun_args e in
- match pl with
- [ [] ->
- fprintf ppf "(@[<b 1>%s%s%a@ %a@]" b
- (if b = "" then "" else " ") patt (p, nok)
- sequence (e, ks ")" k)
- | _ ->
- fprintf ppf "(@[<b 1>%s%s(%a)@ %a@]" b
- (if b = "" then "" else " ") (list patt) ([p :: pl], nok)
- sequence (e, ks ")" k) ] ]}];
-
-pr_match_assoc.pr_levels :=
- [{pr_label = "top";
- pr_box ppf f x = fprintf ppf "@[%t@]" f;
- pr_rules =
- extfun Extfun.empty with
- [ (p, we, e) ->
- fun ppf curr next dg k ->
- fprintf ppf "(@[%t@ %a@]"
- (fun ppf ->
- match we with
- [ Some e ->
- fprintf ppf "(when@ %a@ %a" patt (p, nok)
- expr (e, ks ")" nok)
- | None -> patt ppf (p, nok) ])
- sequence (e, ks ")" k) ]}];
-
-pr_mod_ident.pr_levels :=
- [{pr_label = "top";
- pr_box ppf f x = fprintf ppf "@[%t@]" f;
- pr_rules =
- extfun Extfun.empty with
- [ [s] ->
- fun ppf curr next dg k ->
- fprintf ppf "%s%t" s k
- | [s :: sl] ->
- fun ppf curr next dg k ->
- fprintf ppf "%s.%a" s curr (sl, "", k)
- | x ->
- fun ppf curr next dg k -> not_impl "mod_ident" x ppf k ]}];
-
-pr_module_binding.pr_levels :=
- [{pr_label = "top";
- pr_box ppf f x = fprintf ppf "@[%t@]" f;
- pr_rules =
- extfun Extfun.empty with
- [ (b, s, me) ->
- fun ppf curr next dg k ->
- fprintf ppf "%s@ %s@ %a" b s module_expr (me, k) ]}];
-
-pr_module_expr.pr_levels :=
- [{pr_label = "top";
- pr_box ppf f x = fprintf ppf "@[%t@]" f;
- pr_rules =
- extfun Extfun.empty with
- [ <:module_expr< functor ($i$ : $mt$) -> $me$ >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(@[@[@[functor@ %s@]@ %a@]@ %a@]"
- i module_type (mt, nok) module_expr (me, ks ")" k)
- | <:module_expr< struct $list:sil$ end >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(@[struct@ @[<hv>%a@]@]" (list str_item)
- (sil, ks ")" k)
- | <:module_expr< $me1$ $me2$ >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(@[%a@ %a@]" module_expr (me1, nok)
- module_expr (me2, ks ")" k)
- | <:module_expr< $uid:s$ >> ->
- fun ppf curr next dg k -> fprintf ppf "%s%t" s k
- | x ->
- fun ppf curr next dg k -> not_impl "module_expr" x ppf k ]}];
-
-pr_module_type.pr_levels :=
- [{pr_label = "top";
- pr_box ppf f x = fprintf ppf "@[%t@]" f;
- pr_rules =
- extfun Extfun.empty with
- [ <:module_type< functor ($i$ : $mt1$) -> $mt2$ >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(@[@[@[functor@ %s@]@ %a@]@ %a@]"
- i module_type (mt1, nok) module_type (mt2, ks ")" k)
- | <:module_type< sig $list:sil$ end >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(@[sig@ @[<hv>%a@]@]" (list sig_item) (sil, ks ")" k)
- | <:module_type< $mt$ with $list:wcl$ >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(@[with@;<1 2>@[%a@ (%a@]@]" module_type (mt, nok)
- (list with_constr) (wcl, ks "))" k)
- | <:module_type< $uid:s$ >> ->
- fun ppf curr next dg k -> fprintf ppf "%s%t" s k
- | x ->
- fun ppf curr next dg k -> not_impl "module_type" x ppf k ]}];
-
-pr_patt.pr_levels :=
- [{pr_label = "top";
- pr_box ppf f x = fprintf ppf "@[%t@]" f;
- pr_rules =
- extfun Extfun.empty with
- [ <:patt< $p1$ | $p2$ >> ->
- fun ppf curr next dg k ->
- let (f, pl) =
- loop [p2] p1 where rec loop pl =
- fun
- [ <:patt< $p1$ | $p2$ >> -> loop [p2 :: pl] p1
- | p1 -> (p1, pl) ]
- in
- fprintf ppf "(@[or@ %a@ %a@]" patt (f, nok) (list patt)
- (pl, ks ")" k)
- | <:patt< ($p1$ as $p2$) >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(@[as@ %a@ %a@]" patt (p1, nok) patt (p2, ks ")" k)
- | <:patt< $p1$ .. $p2$ >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(@[range@ %a@ %a@]" patt (p1, nok) patt (p2, ks ")" k)
- | <:patt< [$_$ :: $_$] >> as p ->
- fun ppf curr next dg k ->
- let (pl, c) =
- make_list p where rec make_list p =
- match p with
- [ <:patt< [$p$ :: $y$] >> ->
- let (pl, c) = make_list y in
- ([p :: pl], c)
- | <:patt< [] >> -> ([], None)
- | x -> ([], Some p) ]
- in
- match c with
- [ None ->
- fprintf ppf "[%a" (list patt) (pl, ks "]" k)
- | Some x ->
- fprintf ppf "[%a@ %a" (list patt) (pl, ks " ." nok)
- patt (x, ks "]" k) ]
- | <:patt< $p1$ $p2$ >> ->
- fun ppf curr next dg k ->
- let pl =
- loop [p2] p1 where rec loop pl =
- fun
- [ <:patt< $p1$ $p2$ >> -> loop [p2 :: pl] p1
- | p1 -> [p1 :: pl] ]
- in
- fprintf ppf "(@[%a@]" (list patt) (pl, ks ")" k)
- | <:patt< ($p$ : $t$) >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(:@ %a@ %a" patt (p, nok) ctyp (t, ks ")" k)
- | <:patt< ($list:pl$) >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(values @[%a@]" (list patt) (pl, ks ")" k)
- | <:patt< { $list:fpl$ } >> ->
- fun ppf curr next dg k ->
- let record_binding ppf ((p1, p2), k) =
- fprintf ppf "(@[%a@ %a@]" patt (p1, nok) patt (p2, ks ")" k)
- in
- fprintf ppf "(@[<hv>{}@ %a@]" (list record_binding) (fpl, ks ")" k)
- | <:patt< ? $x$ >> ->
- fun ppf curr next dg k -> fprintf ppf "?%s%t" x k
- | <:patt< ? ($lid:x$ = $e$) >> ->
- fun ppf curr next dg k -> fprintf ppf "(?%s@ %a" x expr (e, ks ")" k)
- | <:patt< $p1$ . $p2$ >> ->
- fun ppf curr next dg k ->
- fprintf ppf "%a.%a" patt (p1, nok) patt (p2, k)
- | <:patt< $lid:s$ >> | <:patt< $uid:s$ >> ->
- fun ppf curr next dg k -> fprintf ppf "%s%t" s k
- | <:patt< $str:s$ >> ->
- fun ppf curr next dg k -> fprintf ppf "\"%s\"%t" s k
- | <:patt< $chr:s$ >> ->
- fun ppf curr next dg k -> fprintf ppf "'%s'%t" s k
- | <:patt< $int:s$ >> ->
- fun ppf curr next dg k -> fprintf ppf "%s%t" (int_repr s) k
- | <:patt< $flo:s$ >> ->
- fun ppf curr next dg k -> fprintf ppf "%s%t" s k
- | <:patt< _ >> ->
- fun ppf curr next dg k -> fprintf ppf "_%t" k
- | x ->
- fun ppf curr next dg k -> not_impl "patt" x ppf k ]}];
-
-pr_sig_item.pr_levels :=
- [{pr_label = "top";
- pr_box ppf f x = fprintf ppf "@[%t@]" f;
- pr_rules =
- extfun Extfun.empty with
- [ <:sig_item< type $list:tdl$ >> ->
- fun ppf curr next dg k ->
- match tdl with
- [ [td] -> fprintf ppf "(%a" type_decl (("type", td), ks ")" k)
- | tdl ->
- fprintf ppf "(@[<hv>type@ %a@]" (listwb "" type_decl)
- (tdl, ks ")" k) ]
- | <:sig_item< exception $c$ of $list:tl$ >> ->
- fun ppf curr next dg k ->
- match tl with
- [ [] -> fprintf ppf "(@[exception@ %s%t@]" c (ks ")" k)
- | tl ->
- fprintf ppf "(@[@[exception@ %s@]@ %a@]" c
- (list ctyp) (tl, ks ")" k) ]
- | <:sig_item< value $i$ : $t$ >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(@[@[value %s@]@ %a@]" i ctyp (t, ks ")" k)
- | <:sig_item< external $i$ : $t$ = $list:pd$ >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(@[@[external@ %s@]@ %a@ %a@]" i ctyp (t, nok)
- (list string) (pd, ks ")" k)
- | <:sig_item< module $s$ : $mt$ >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(@[@[module@ %s@]@ %a@]" s
- module_type (mt, ks ")" k)
- | <:sig_item< module type $s$ = $mt$ >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(@[@[moduletype@ %s@]@ %a@]" s
- module_type (mt, ks ")" k)
- | <:sig_item< declare $list:s$ end >> ->
- fun ppf curr next dg k ->
- if s = [] then fprintf ppf "; ..."
- else fprintf ppf "%a" (list sig_item) (s, k)
- | MLast.SgUse _ _ _ ->
- fun ppf curr next dg k -> ()
- | x ->
- fun ppf curr next dg k -> not_impl "sig_item" x ppf k ]}];
-
-pr_str_item.pr_levels :=
- [{pr_label = "top";
- pr_box ppf f x = fprintf ppf "@[%t@]" f;
- pr_rules =
- extfun Extfun.empty with
- [ <:str_item< open $i$ >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(open@ %a" mod_ident (i, ks ")" k)
- | <:str_item< type $list:tdl$ >> ->
- fun ppf curr next dg k ->
- match tdl with
- [ [td] -> fprintf ppf "(%a" type_decl (("type", td), ks ")" k)
- | tdl ->
- fprintf ppf "(@[<hv>type@ %a@]" (listwb "" type_decl)
- (tdl, ks ")" k) ]
- | <:str_item< exception $c$ of $list:tl$ >> ->
- fun ppf curr next dg k ->
- match tl with
- [ [] -> fprintf ppf "(@[exception@ %s%t@]" c (ks ")" k)
- | tl ->
- fprintf ppf "(@[@[exception@ %s@]@ %a@]" c
- (list ctyp) (tl, ks ")" k) ]
- | <:str_item< value $opt:rf$ $list:pel$ >> ->
- fun ppf curr next dg k ->
- let b = if rf then "definerec" else "define" in
- match pel with
- [ [(p, e)] ->
- fprintf ppf "%a" let_binding ((b, (p, e)), k)
- | pel ->
- fprintf ppf "(@[<hv 1>%s*@ %a@]" b (listwb "" let_binding)
- (pel, ks ")" k) ]
- | <:str_item< module $s$ = $me$ >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(%a" module_binding (("module", s, me), ks ")" k)
- | <:str_item< module type $s$ = $mt$ >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(@[@[moduletype@ %s@]@ %a@]" s
- module_type (mt, ks ")" k)
- | <:str_item< external $i$ : $t$ = $list:pd$ >> ->
- fun ppf curr next dg k ->
- fprintf ppf "(@[external@ %s@ %a@ %a@]" i ctyp (t, nok)
- (list string) (pd, ks ")" k)
- | <:str_item< $exp:e$ >> ->
- fun ppf curr next dg k ->
- fprintf ppf "%a" expr (e, k)
- | <:str_item< # $s$ $opt:x$ >> ->
- fun ppf curr next dg k ->
- match x with
- [ Some e -> fprintf ppf "; # (%s %a" s expr (e, ks ")" k)
- | None -> fprintf ppf "; # (%s%t" s (ks ")" k) ]
- | <:str_item< declare $list:s$ end >> ->
- fun ppf curr next dg k ->
- if s = [] then fprintf ppf "; ..."
- else fprintf ppf "%a" (list str_item) (s, k)
- | MLast.StUse _ _ _ ->
- fun ppf curr next dg k -> ()
- | x ->
- fun ppf curr next dg k -> not_impl "str_item" x ppf k ]}];
-
-pr_type_decl.pr_levels :=
- [{pr_label = "top";
- pr_box ppf f x = fprintf ppf "@[%t@]" f;
- pr_rules =
- extfun Extfun.empty with
- [ (b, ((_, tn), tp, te, cl)) ->
- fun ppf curr next dg k ->
- fprintf ppf "%t%t@;<1 1>%a"
- (fun ppf ->
- if b <> "" then fprintf ppf "%s@ " b
- else ())
- (fun ppf ->
- match tp with
- [ [] -> fprintf ppf "%s" tn
- | tp -> fprintf ppf "(%s%a)" tn type_params (tp, nok) ])
- ctyp (te, k) ]}];
-
-pr_type_params.pr_levels :=
- [{pr_label = "top";
- pr_box ppf f x = fprintf ppf "@[%t@]" f;
- pr_rules =
- extfun Extfun.empty with
- [ [(s, vari) :: tpl] ->
- fun ppf curr next dg k ->
- fprintf ppf "@ '%s%a" s type_params (tpl, k)
- | [] ->
- fun ppf curr next dg k -> () ]}];
-
-pr_with_constr.pr_levels :=
- [{pr_label = "top";
- pr_box ppf f x = fprintf ppf "@[%t@]" f;
- pr_rules =
- extfun Extfun.empty with
- [ MLast.WcTyp _ m tp te ->
- fun ppf curr next dg k ->
- fprintf ppf "(type@ %t@;<1 1>%a"
- (fun ppf ->
- match tp with
- [ [] -> fprintf ppf "%a" mod_ident (m, nok)
- | tp ->
- fprintf ppf "(%a@ %a)" mod_ident (m, nok)
- type_params (tp, nok) ])
- ctyp (te, ks ")" k)
- | x ->
- fun ppf curr next dg k -> not_impl "with_constr" x ppf k ]}];
-
-(* main *)
-
-value output_string_eval ppf s =
- loop 0 where rec loop i =
- if i == String.length s then ()
- else if i == String.length s - 1 then pp_print_char ppf s.[i]
- else
- match (s.[i], s.[i + 1]) with
- [ ('\\', 'n') -> do { pp_print_char ppf '\n'; loop (i + 2) }
- | (c, _) -> do { pp_print_char ppf c; loop (i + 1) } ]
-;
-
-value sep = Pcaml.inter_phrases;
-
-value input_source ic len =
- let buff = Buffer.create 20 in
- try
- let rec loop i =
- if i >= len then Buffer.contents buff
- else do { let c = input_char ic in Buffer.add_char buff c; loop (i + 1) }
- in
- loop 0
- with
- [ End_of_file ->
- let s = Buffer.contents buff in
- if s = "" then
- match sep.val with
- [ Some s -> s
- | None -> "\n" ]
- else s ]
-;
-
-value copy_source ppf (ic, first, bp, ep) =
- match sep.val with
- [ Some str ->
- if first then ()
- else if ep == in_channel_length ic then pp_print_string ppf "\n"
- else output_string_eval ppf str
- | None ->
- do {
- seek_in ic bp;
- let s = input_source ic (ep - bp) in pp_print_string ppf s
- } ]
-;
-
-value copy_to_end ppf (ic, first, bp) =
- let ilen = in_channel_length ic in
- if bp < ilen then copy_source ppf (ic, first, bp, ilen)
- else pp_print_string ppf "\n"
-;
-
-value apply_printer printer ast =
- let ppf = std_formatter in
- if Pcaml.input_file.val <> "-" && Pcaml.input_file.val <> "" then do {
- let ic = open_in_bin Pcaml.input_file.val in
- try
- let (first, last_pos) =
- List.fold_left
- (fun (first, last_pos) (si, (bp, ep)) ->
- do {
- fprintf ppf "@[%a@]@?" copy_source (ic, first, last_pos, bp);
- fprintf ppf "@[%a@]@?" printer (si, nok);
- (False, ep)
- })
- (True, 0) ast
- in
- fprintf ppf "@[%a@]@?" copy_to_end (ic, first, last_pos)
- with x ->
- do { fprintf ppf "@."; close_in ic; raise x };
- close_in ic;
- }
- else failwith "not implemented"
-;
-
-Pcaml.print_interf.val := apply_printer sig_item;
-Pcaml.print_implem.val := apply_printer str_item;
-
-Pcaml.add_option "-l" (Arg.Int (fun x -> set_margin x))
- "<length> Maximum line length for pretty printing.";
-
-Pcaml.add_option "-sep" (Arg.String (fun x -> sep.val := Some x))
- "<string> Use this string between phrases instead of reading source.";
diff --git a/camlp4/etc/pr_schp_main.ml b/camlp4/etc/pr_schp_main.ml
deleted file mode 100644
index c535111499..0000000000
--- a/camlp4/etc/pr_schp_main.ml
+++ /dev/null
@@ -1,119 +0,0 @@
-(* camlp4r q_MLast.cmo ./pa_extfun.cmo *)
-(* $Id$ *)
-
-open Format;
-open Pcaml;
-open Parserify;
-
-value nok = Pr_scheme.nok;
-value ks = Pr_scheme.ks;
-value patt = Pr_scheme.patt;
-value expr = Pr_scheme.expr;
-value find_pr_level = Pr_scheme.find_pr_level;
-value pr_expr = Pr_scheme.pr_expr;
-type printer_t 'a = Pr_scheme.printer_t 'a ==
- { pr_fun : mutable string -> Pr_scheme.next 'a;
- pr_levels : mutable list (pr_level 'a) }
-and pr_level 'a = Pr_scheme.pr_level 'a ==
- { pr_label : string;
- pr_box : formatter -> (formatter -> unit) -> 'a -> unit;
- pr_rules : mutable Pr_scheme.pr_rule 'a }
-;
-
-(* extensions for rebuilding syntax of parsers *)
-
-value parser_cases ppf (spel, k) =
- let rec parser_cases ppf (spel, k) =
- match spel with
- [ [] -> fprintf ppf "[: `HVbox [: b; k :] :]"
- | [(sp, epo, e)] -> parser_case ppf (sp, epo, e, k)
- | [(sp, epo, e) :: spel] ->
- fprintf ppf "%a@ %a" parser_case (sp, epo, e, nok)
- parser_cases (spel, k) ]
- and parser_case ppf (sp, epo, e, k) =
- fprintf ppf "(@[@[(%a)%t@]@ %a@]" stream_patt (sp, nok)
- (fun ppf ->
- match epo with
- [ Some p -> fprintf ppf "@ %a" patt (p, nok)
- | None -> () ])
- expr (e, ks ")" k)
- and stream_patt ppf (sp, k) =
- match sp with
- [ [] -> k ppf
- | [(spc, None)] -> fprintf ppf "%a" stream_patt_comp (spc, k)
- | [(spc, Some e)] ->
- fprintf ppf "(@[? %a@ %a@]" stream_patt_comp (spc, nok)
- expr (e, ks ")" k)
- | [(spc, None) :: spcl] ->
- fprintf ppf "%a@ %a" stream_patt_comp (spc, nok) stream_patt (spcl, k)
- | [(spc, Some e) :: spcl] ->
- fprintf ppf "(@[? %a@ %a@]@ %a" stream_patt_comp (spc, nok)
- expr (e, ks ")" nok) stream_patt (spcl, k) ]
- and stream_patt_comp ppf (spc, k) =
- match spc with
- [ SPCterm (p, w) ->
- match w with
- [ Some e ->
- fprintf ppf "(` %a@ %a" patt (p, nok) expr (e, ks ")" k)
- | None -> fprintf ppf "(` %a" patt (p, ks ")" k) ]
- | SPCnterm p e ->
- fprintf ppf "(@[%a %a@]" patt (p, nok) expr (e, ks ")" k)
- | SPCsterm p -> fprintf ppf "%a" patt (p, k) ]
- in
- parser_cases ppf (spel, k)
-;
-
-value parser_body ppf (e, k) =
- let (bp, e) =
- match e with
- [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e)
- | e -> (None, e) ]
- in
- match parser_of_expr e with
- [ [] ->
- fprintf ppf "(parser%t%t"
- (fun ppf ->
- match bp with
- [ Some p -> fprintf ppf "@ %a" patt (p, nok)
- | _ -> ()])
- (ks ")" k)
- | spel ->
- fprintf ppf "(@[<v>@[parser%t@]@ @[<v 0>%a@]@]"
- (fun ppf ->
- match bp with
- [ Some p -> fprintf ppf "@ %a" patt (p, nok)
- | _ -> ()])
- parser_cases (spel, ks ")" k) ]
-;
-
-value pmatch ppf (e, k) =
- let (me, e) =
- match e with
- [ <:expr< let (strm__ : Stream.t _) = $me$ in $e$ >> -> (me, e)
- | _ -> failwith "Pr_schp_main.pmatch" ]
- in
- let (bp, e) =
- match e with
- [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e)
- | e -> (None, e) ]
- in
- let spel = parser_of_expr e in
- fprintf ppf "(@[@[match_with_parser@ %a@]%t@ @[<v 0>%a@]@]" expr (me, nok)
- (fun ppf ->
- match bp with
- [ Some p -> fprintf ppf "@ %a" patt (p, nok)
- | _ -> () ])
- parser_cases (spel, ks ")" k)
-;
-
-pr_expr_fun_args.val :=
- extfun pr_expr_fun_args.val with
- [ <:expr< fun [(strm__ : $_$) -> $_$] >> as ge -> ([], ge) ];
-
-let lev = find_pr_level "top" pr_expr.pr_levels in
-lev.pr_rules :=
- extfun lev.pr_rules with
- [ <:expr< fun (strm__ : $_$) -> $x$ >> ->
- fun ppf curr next dg k -> fprintf ppf "%a" parser_body (x, k)
- | <:expr< let (strm__ : Stream.t _) = $_$ in $_$ >> as e ->
- fun ppf curr next dg k -> fprintf ppf "%a" pmatch (e, k) ];
diff --git a/camlp4/etc/q_phony.ml b/camlp4/etc/q_phony.ml
deleted file mode 100644
index 841e2bec90..0000000000
--- a/camlp4/etc/q_phony.ml
+++ /dev/null
@@ -1,49 +0,0 @@
-(* camlp4r pa_extend.cmo q_MLast.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Pcaml;
-
-value t = ref "";
-
-Quotation.add ""
- (Quotation.ExAst
- (fun s ->
- let t =
- if t.val = "" then "<<" ^ s ^ ">>"
- else "<:" ^ t.val ^ "<" ^ s ^ ">>"
- in
- let loc = (0, 0) in
- <:expr< $uid:t$ >>,
- fun s ->
- let t =
- if t.val = "" then "<<" ^ s ^ ">>"
- else "<:" ^ t.val ^ "<" ^ s ^ ">>"
- in
- let loc = (0, 0) in
- <:patt< $uid:t$ >>))
-;
-
-Quotation.default.val := "";
-Quotation.translate.val := fun s -> do { t.val := s; "" };
-
-if Pcaml.syntax_name.val <> "Scheme" then
- EXTEND
- expr: LEVEL "top"
- [ [ "IFDEF"; c = UIDENT; "THEN"; e1 = expr; "ELSE"; e2 = expr; "END" ->
- <:expr< if DEF $uid:c$ then $e1$ else $e2$ >>
- | "IFNDEF"; c = UIDENT; "THEN"; e1 = expr; "ELSE"; e2 = expr; "END" ->
- <:expr< if NDEF $uid:c$ then $e1$ else $e2$ >> ] ]
- ;
- END
-else ();
diff --git a/camlp4/lib/.cvsignore b/camlp4/lib/.cvsignore
deleted file mode 100644
index c77a681dd6..0000000000
--- a/camlp4/lib/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-*.cm[oiax]
-*.cmxa
-*.lib
diff --git a/camlp4/lib/.depend b/camlp4/lib/.depend
deleted file mode 100644
index 0d5adc691f..0000000000
--- a/camlp4/lib/.depend
+++ /dev/null
@@ -1,20 +0,0 @@
-extfold.cmi: gramext.cmi
-gramext.cmi: token.cmi
-grammar.cmi: gramext.cmi token.cmi
-plexer.cmi: token.cmi
-extfold.cmo: gramext.cmi grammar.cmi extfold.cmi
-extfold.cmx: gramext.cmx grammar.cmx extfold.cmi
-extfun.cmo: extfun.cmi
-extfun.cmx: extfun.cmi
-fstream.cmo: fstream.cmi
-fstream.cmx: fstream.cmi
-gramext.cmo: token.cmi gramext.cmi
-gramext.cmx: token.cmx gramext.cmi
-grammar.cmo: gramext.cmi stdpp.cmi token.cmi grammar.cmi
-grammar.cmx: gramext.cmx stdpp.cmx token.cmx grammar.cmi
-plexer.cmo: stdpp.cmi token.cmi plexer.cmi
-plexer.cmx: stdpp.cmx token.cmx plexer.cmi
-stdpp.cmo: stdpp.cmi
-stdpp.cmx: stdpp.cmi
-token.cmo: token.cmi
-token.cmx: token.cmi
diff --git a/camlp4/lib/Makefile b/camlp4/lib/Makefile
deleted file mode 100644
index ece72d1519..0000000000
--- a/camlp4/lib/Makefile
+++ /dev/null
@@ -1,48 +0,0 @@
-# $Id$
-
-include ../config/Makefile
-
-INCLUDES=
-OCAMLCFLAGS=-warn-error A $(INCLUDES)
-OBJS=stdpp.cmo token.cmo plexer.cmo gramext.cmo grammar.cmo extfold.cmo extfun.cmo fstream.cmo
-SHELL=/bin/sh
-TARGET=gramlib.cma
-
-all: $(TARGET)
-opt: $(TARGET:.cma=.cmxa)
-
-$(TARGET): $(OBJS)
- $(OCAMLC) $(OBJS) -a -o $(TARGET)
-
-$(TARGET:.cma=.cmxa): $(OBJS:.cmo=.cmx)
- $(OCAMLOPT) $(OBJS:.cmo=.cmx) -a -o $(TARGET:.cma=.cmxa)
-
-clean::
- rm -f *.cm[ioax] *.cmxa *.pp[io] *.$(O) *.$(A) *.bak .*.bak $(TARGET)
-
-depend:
- cp .depend .depend.bak
- > .depend
- @for i in *.mli *.ml; do \
- ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i >> .depend; \
- done
-
-promote:
- cp $(OBJS) $(OBJS:.cmo=.cmi) ../boot/.
-
-compare:
- @for j in $(OBJS) $(OBJS:.cmo=.cmi); do \
- if cmp $$j ../boot/$$j; then :; else exit 1; fi; \
- done
-
-install:
- -$(MKDIR) "$(LIBDIR)/camlp4"
- cp $(TARGET) *.mli "$(LIBDIR)/camlp4/."
- cp *.cmi "$(LIBDIR)/camlp4/."
- if test -f $(TARGET:.cma=.cmxa); then $(MAKE) installopt LIBDIR="$(LIBDIR)"; fi
-
-installopt:
- cp $(TARGET:.cma=.cmxa) *.cmx "$(LIBDIR)/camlp4/."
- tar cf - $(TARGET:.cma=.$(A)) | (cd "$(LIBDIR)/camlp4/."; tar xf -)
-
-include .depend
diff --git a/camlp4/lib/Makefile.Mac b/camlp4/lib/Makefile.Mac
deleted file mode 100644
index 90034c5c74..0000000000
--- a/camlp4/lib/Makefile.Mac
+++ /dev/null
@@ -1,46 +0,0 @@
-#######################################################################
-# #
-# Camlp4 #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. Distributed only by permission. #
-# #
-#######################################################################
-
-# $Id$
-
-INCLUDES =
-OCAMLCFLAGS = {INCLUDES}
-OBJS = stdpp.cmo token.cmo plexer.cmo gramext.cmo grammar.cmo extfun.cmo fstream.cmo
-INTF = stdpp.cmi token.cmi plexer.cmi gramext.cmi grammar.cmi extfun.cmi fstream.cmi
-TARGETS = gramlib.cma
-
-all Ä {TARGETS}
-
-{TARGETS} Ä {OBJS}
- {OCAMLC} {OBJS} -a -o {TARGETS}
-
-steal Ä
-
-compare_stolen Ä
-
-clean ÄÄ
- delete -i {TARGETS}
-
-{dependrule}
-
-promote Ä
- duplicate -y {OBJS} {INTF} ::boot:
-
-compare Ä
- for i in {OBJS} {INTF}
- equal -s ::boot:{i} || exit 1
- end
-
-install Ä
- (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null
- duplicate -y {TARGETS} Å.mli Å.cmi "{P4LIBDIR}"
-
-{defrules}
diff --git a/camlp4/lib/Makefile.Mac.depend b/camlp4/lib/Makefile.Mac.depend
deleted file mode 100644
index 8d12e3e08a..0000000000
--- a/camlp4/lib/Makefile.Mac.depend
+++ /dev/null
@@ -1,13 +0,0 @@
-gramext.cmoÄ token.cmi gramext.cmi
-gramext.cmxÄ token.cmx gramext.cmi
-gramext.cmiÄ token.cmi
-grammar.cmoÄ gramext.cmi stdpp.cmi token.cmi grammar.cmi
-grammar.cmxÄ gramext.cmx stdpp.cmx token.cmx grammar.cmi
-grammar.cmiÄ gramext.cmi token.cmi
-plexer.cmoÄ stdpp.cmi token.cmi plexer.cmi
-plexer.cmxÄ stdpp.cmx token.cmx plexer.cmi
-plexer.cmiÄ token.cmi
-stdpp.cmoÄ stdpp.cmi
-stdpp.cmxÄ stdpp.cmi
-token.cmoÄ token.cmi
-token.cmxÄ token.cmi
diff --git a/camlp4/lib/extfold.ml b/camlp4/lib/extfold.ml
deleted file mode 100644
index b612d15248..0000000000
--- a/camlp4/lib/extfold.ml
+++ /dev/null
@@ -1,91 +0,0 @@
-(* camlp4r *)
-(* $Id$ *)
-
-type t 'te 'a 'b =
- Gramext.g_entry 'te -> list (Gramext.g_symbol 'te) ->
- (Stream.t 'te -> 'a) -> Stream.t 'te -> 'b
-;
-
-type tsep 'te 'a 'b =
- Gramext.g_entry 'te -> list (Gramext.g_symbol 'te) ->
- (Stream.t 'te -> 'a) -> (Stream.t 'te -> unit) -> Stream.t 'te -> 'b
-;
-
-value gen_fold0 final f e entry symbl psymb =
- let rec fold accu =
- parser
- [ [: a = psymb; s :] -> fold (f a accu) s
- | [: :] -> accu ]
- in
- parser [: a = fold e :] -> final a
-;
-
-value gen_fold1 final f e entry symbl psymb =
- let rec fold accu =
- parser
- [ [: a = psymb; s :] -> fold (f a accu) s
- | [: :] -> accu ]
- in
- parser [: a = psymb; a = fold (f a e) :] -> final a
-;
-
-value gen_fold0sep final f e entry symbl psymb psep =
- let failed =
- fun
- [ [symb; sep] -> Grammar.symb_failed_txt entry sep symb
- | _ -> "failed" ]
- in
- let rec kont accu =
- parser
- [ [: v = psep; a = psymb ? failed symbl; s :] -> kont (f a accu) s
- | [: :] -> accu ]
- in
- parser
- [ [: a = psymb; s :] -> final (kont (f a e) s)
- | [: :] -> e ]
-;
-
-value gen_fold1sep final f e entry symbl psymb psep =
- let failed =
- fun
- [ [symb; sep] -> Grammar.symb_failed_txt entry sep symb
- | _ -> "failed" ]
- in
- let parse_top =
- fun
- [ [symb; _] -> Grammar.parse_top_symb entry symb
- | _ -> raise Stream.Failure ]
- in
- let rec kont accu =
- parser
- [ [: v = psep;
- a =
- parser
- [ [: a = psymb :] -> a
- | [: a = parse_top symbl :] -> Obj.magic a
- | [: :] -> raise (Stream.Error (failed symbl)) ];
- s :] ->
- kont (f a accu) s
- | [: :] -> accu ]
- in
- parser [: a = psymb; s :] -> final (kont (f a e) s)
-;
-
-value sfold0 f e = gen_fold0 (fun x -> x) f e;
-value sfold1 f e = gen_fold1 (fun x -> x) f e;
-value sfold0sep f e = gen_fold0sep (fun x -> x) f e;
-value sfold1sep f e = gen_fold1sep (fun x -> x) f e;
-
-value cons x y = [x :: y];
-value nil = [];
-
-value slist0 entry = gen_fold0 List.rev cons nil entry;
-value slist1 entry = gen_fold1 List.rev cons nil entry;
-value slist0sep entry = gen_fold0sep List.rev cons nil entry;
-value slist1sep entry = gen_fold1sep List.rev cons nil entry;
-
-value sopt entry symbl psymb =
- parser
- [ [: a = psymb :] -> Some a
- | [: :] -> None ]
-;
diff --git a/camlp4/lib/extfold.mli b/camlp4/lib/extfold.mli
deleted file mode 100644
index 639631e27d..0000000000
--- a/camlp4/lib/extfold.mli
+++ /dev/null
@@ -1,24 +0,0 @@
-(* camlp4r *)
-(* $Id$ *)
-
-type t 'te 'a 'b =
- Gramext.g_entry 'te -> list (Gramext.g_symbol 'te) ->
- (Stream.t 'te -> 'a) -> Stream.t 'te -> 'b
-;
-
-type tsep 'te 'a 'b =
- Gramext.g_entry 'te -> list (Gramext.g_symbol 'te) ->
- (Stream.t 'te -> 'a) -> (Stream.t 'te -> unit) -> Stream.t 'te -> 'b
-;
-
-value sfold0 : ('a -> 'b -> 'b) -> 'b -> t _ 'a 'b;
-value sfold1 : ('a -> 'b -> 'b) -> 'b -> t _ 'a 'b;
-value sfold0sep : ('a -> 'b -> 'b) -> 'b -> tsep _ 'a 'b;
-value sfold1sep : ('a -> 'b -> 'b) -> 'b -> tsep _ 'a 'b;
-
-value slist0 : t _ 'a (list 'a);
-value slist1 : t _ 'a (list 'a);
-value slist0sep : tsep _ 'a (list 'a);
-value slist1sep : tsep _ 'a (list 'a);
-
-value sopt : t _ 'a (option 'a);
diff --git a/camlp4/lib/extfun.ml b/camlp4/lib/extfun.ml
deleted file mode 100644
index 866ea221c1..0000000000
--- a/camlp4/lib/extfun.ml
+++ /dev/null
@@ -1,109 +0,0 @@
-(* camlp4r *)
-(* $Id$ *)
-(* Copyright 2001 INRIA *)
-
-(* Extensible Functions *)
-
-type t 'a 'b = list (matching 'a 'b)
-and matching 'a 'b = { patt : patt; has_when : bool; expr : expr 'a 'b }
-and patt =
- [ Eapp of list patt
- | Eacc of list patt
- | Econ of string
- | Estr of string
- | Eint of string
- | Etup of list patt
- | Evar of unit ]
-and expr 'a 'b = 'a -> option 'b
-;
-
-exception Failure;
-
-value empty = [];
-
-(*** Apply ***)
-
-value rec apply_matchings a =
- fun
- [ [m :: ml] ->
- match m.expr a with
- [ None -> apply_matchings a ml
- | x -> x ]
- | [] -> None ]
-;
-
-value apply ef a =
- match apply_matchings a ef with
- [ Some x -> x
- | None -> raise Failure ]
-;
-
-(*** Trace ***)
-
-value rec list_iter_sep f s =
- fun
- [ [] -> ()
- | [x] -> f x
- | [x :: l] -> do { f x; s (); list_iter_sep f s l } ]
-;
-
-value rec print_patt =
- fun
- [ Eapp pl -> list_iter_sep print_patt2 (fun () -> print_string " ") pl
- | p -> print_patt2 p ]
-and print_patt2 =
- fun
- [ Eacc pl -> list_iter_sep print_patt1 (fun () -> print_string ".") pl
- | p -> print_patt1 p ]
-and print_patt1 =
- fun
- [ Econ s -> print_string s
- | Estr s -> do { print_string "\""; print_string s; print_string "\"" }
- | Eint s -> print_string s
- | Evar () -> print_string "_"
- | Etup pl ->
- do {
- print_string "(";
- list_iter_sep print_patt (fun () -> print_string ", ") pl;
- print_string ")"
- }
- | Eapp _ | Eacc _ as p ->
- do { print_string "("; print_patt p; print_string ")" } ]
-;
-
-value print ef =
- List.iter
- (fun m ->
- do {
- print_patt m.patt;
- if m.has_when then print_string " when ..." else ();
- print_newline ()
- })
- ef
-;
-
-(*** Extension ***)
-
-value insert_matching matchings (patt, has_when, expr) =
- let m1 = {patt = patt; has_when = has_when; expr = expr} in
- let rec loop =
- fun
- [ [m :: ml] as gml ->
- if m1.has_when && not m.has_when then [m1 :: gml]
- else if not m1.has_when && m.has_when then [m :: loop ml]
- else
- let c = compare m1.patt m.patt in
- if c < 0 then [m1 :: gml]
- else if c > 0 then [m :: loop ml]
- else if m.has_when then [m1 :: gml]
- else [m1 :: ml]
- | [] -> [m1] ]
- in
- loop matchings
-;
-
-(* available extension function *)
-
-value extend ef matchings_def =
- List.fold_left insert_matching ef matchings_def
-;
diff --git a/camlp4/lib/extfun.mli b/camlp4/lib/extfun.mli
deleted file mode 100644
index 01b3cbd76b..0000000000
--- a/camlp4/lib/extfun.mli
+++ /dev/null
@@ -1,36 +0,0 @@
-(* camlp4r *)
-(* $Id$ *)
-
-(** Extensible functions.
-
- This module implements pattern matching extensible functions.
- To extend, use syntax [pa_extfun.cmo]:
-
- [extfun e with [ pattern_matching ]] *)
-
-type t 'a 'b = 'x;
- (** The type of the extensible functions of type ['a -> 'b] *)
-value empty : t 'a 'b;
- (** Empty extensible function *)
-value apply : t 'a 'b -> 'a -> 'b;
- (** Apply an extensible function *)
-exception Failure;
- (** Match failure while applying an extensible function *)
-value print : t 'a 'b -> unit;
- (** Print patterns in the order they are recorded *)
-
-(**/**)
-
-type matching 'a 'b = { patt : patt; has_when : bool; expr : expr 'a 'b }
-and patt =
- [ Eapp of list patt
- | Eacc of list patt
- | Econ of string
- | Estr of string
- | Eint of string
- | Etup of list patt
- | Evar of unit ]
-and expr 'a 'b = 'a -> option 'b
-;
-
-value extend : t 'a 'b -> list (patt * bool * expr 'a 'b) -> t 'a 'b;
diff --git a/camlp4/lib/fstream.ml b/camlp4/lib/fstream.ml
deleted file mode 100644
index 14ab3a3d1c..0000000000
--- a/camlp4/lib/fstream.ml
+++ /dev/null
@@ -1,77 +0,0 @@
-(* camlp4r *)
-(* $Id$ *)
-(* Copyright 2001 INRIA *)
-
-type t 'a = { count : int; data : Lazy.t (data 'a) }
-and data 'a =
- [ Nil
- | Cons of 'a and t 'a
- | App of t 'a and t 'a ]
-;
-
-value from f =
- loop 0 where rec loop i =
- {count = 0;
- data =
- lazy
- (match f i with
- [ Some x -> Cons x (loop (i + 1))
- | None -> Nil ])}
-;
-
-value rec next s =
- let count = s.count + 1 in
- match Lazy.force s.data with
- [ Nil -> None
- | Cons a s -> Some (a, {count = count; data = s.data})
- | App s1 s2 ->
- match next s1 with
- [ Some (a, s1) -> Some (a, {count = count; data = lazy (App s1 s2)})
- | None ->
- match next s2 with
- [ Some (a, s2) -> Some (a, {count = count; data = s2.data})
- | None -> None ] ] ]
-;
-
-value empty s =
- match next s with
- [ Some _ -> None
- | None -> Some ((), s) ]
-;
-
-value nil = {count = 0; data = lazy Nil};
-value cons a s = Cons a s;
-value app s1 s2 = App s1 s2;
-value flazy f = {count = 0; data = Lazy.lazy_from_fun f};
-
-value of_list l =
- List.fold_right (fun x s -> flazy (fun () -> cons x s)) l nil
-;
-
-value of_string s =
- from (fun c -> if c < String.length s then Some s.[c] else None)
-;
-
-value of_channel ic =
- from (fun _ -> try Some (input_char ic) with [ End_of_file -> None ])
-;
-
-value iter f =
- do_rec where rec do_rec strm =
- match next strm with
- [ Some (a, strm) ->
- let _ = f a in
- do_rec strm
- | None -> () ]
-;
-
-value count s = s.count;
-
-value count_unfrozen s =
- loop 0 s where rec loop cnt s =
- if Lazy.lazy_is_val s.data then
- match Lazy.force s.data with
- [ Cons _ s -> loop (cnt + 1) s
- | _ -> cnt ]
- else cnt
-;
diff --git a/camlp4/lib/fstream.mli b/camlp4/lib/fstream.mli
deleted file mode 100644
index 12926d99ff..0000000000
--- a/camlp4/lib/fstream.mli
+++ /dev/null
@@ -1,60 +0,0 @@
-(* camlp4r *)
-(* $Id$ *)
-
-(* Module [Fstream]: functional streams *)
-
-(* This module implement functional streams.
- To be used with syntax [pa_fstream.cmo]. The syntax is:
-- stream: [fstream [: ... :]]
-- parser: [parser [ [: ... :] -> ... | ... ]]
-
- Functional parsers are of type: [Fstream.t 'a -> option ('a * Fstream.t 'a)]
-
- They have limited backtrack, i.e if a rule fails, the next rule is tested
- with the initial stream; limited because when in case of a rule with two
- consecutive symbols [a] and [b], if [b] fails, the rule fails: there is
- no try with the next rule of [a].
-*)
-
-type t 'a = 'x;
- (* The type of 'a functional streams *)
-value from : (int -> option 'a) -> t 'a;
- (* [Fstream.from f] returns a stream built from the function [f].
- To create a new stream element, the function [f] is called with
- the current stream count. The user function [f] must return either
- [Some <value>] for a value or [None] to specify the end of the
- stream. *)
-
-value of_list : list 'a -> t 'a;
- (* Return the stream holding the elements of the list in the same
- order. *)
-value of_string : string -> t char;
- (* Return the stream of the characters of the string parameter. *)
-value of_channel : in_channel -> t char;
- (* Return the stream of the characters read from the input channel. *)
-
-value iter : ('a -> unit) -> t 'a -> unit;
- (* [Fstream.iter f s] scans the whole stream s, applying function [f]
- in turn to each stream element encountered. *)
-
-value next : t 'a -> option ('a * t 'a);
- (* Return [Some (a, s)] where [a] is the first element of the stream
- and [s] the remaining stream, or [None] if the stream is empty. *)
-value empty : t 'a -> option (unit * t 'a);
- (* Return [Some ((), s)] if the stream is empty where [s] is itself,
- else [None] *)
-value count : t 'a -> int;
- (* Return the current count of the stream elements, i.e. the number
- of the stream elements discarded. *)
-value count_unfrozen : t 'a -> int;
- (* Return the number of unfrozen elements in the beginning of the
- stream; useful to determine the position of a parsing error (longuest
- path). *)
-
-(*--*)
-
-value nil : t 'a;
-type data 'a = 'x;
-value cons : 'a -> t 'a -> data 'a;
-value app : t 'a -> t 'a -> data 'a;
-value flazy : (unit -> data 'a) -> t 'a;
diff --git a/camlp4/lib/gramext.ml b/camlp4/lib/gramext.ml
deleted file mode 100644
index 980f0918d8..0000000000
--- a/camlp4/lib/gramext.ml
+++ /dev/null
@@ -1,565 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Printf;
-
-type grammar 'te =
- { gtokens : Hashtbl.t Token.pattern (ref int);
- glexer : mutable Token.glexer 'te }
-;
-
-type g_entry 'te =
- { egram : grammar 'te;
- ename : string;
- estart : mutable int -> Stream.t 'te -> Obj.t;
- econtinue : mutable int -> int -> Obj.t -> Stream.t 'te -> Obj.t;
- edesc : mutable g_desc 'te }
-and g_desc 'te =
- [ Dlevels of list (g_level 'te)
- | Dparser of Stream.t 'te -> Obj.t ]
-and g_level 'te =
- { assoc : g_assoc;
- lname : option string;
- lsuffix : g_tree 'te;
- lprefix : g_tree 'te }
-and g_assoc =
- [ NonA
- | RightA
- | LeftA ]
-and g_symbol 'te =
- [ Smeta of string and list (g_symbol 'te) and Obj.t
- | Snterm of g_entry 'te
- | Snterml of g_entry 'te and string
- | Slist0 of g_symbol 'te
- | Slist0sep of g_symbol 'te and g_symbol 'te
- | Slist1 of g_symbol 'te
- | Slist1sep of g_symbol 'te and g_symbol 'te
- | Sopt of g_symbol 'te
- | Sself
- | Snext
- | Stoken of Token.pattern
- | Stree of g_tree 'te ]
-and g_action = Obj.t
-and g_tree 'te =
- [ Node of g_node 'te
- | LocAct of g_action and list g_action
- | DeadEnd ]
-and g_node 'te =
- { node : g_symbol 'te; son : g_tree 'te; brother : g_tree 'te }
-;
-
-type position =
- [ First
- | Last
- | Before of string
- | After of string
- | Level of string ]
-;
-
-value warning_verbose = ref True;
-
-value rec derive_eps =
- fun
- [ Slist0 _ -> True
- | Slist0sep _ _ -> True
- | Sopt _ -> True
- | Stree t -> tree_derive_eps t
- | Smeta _ _ _ | Slist1 _ | Slist1sep _ _ | Snterm _ | Snterml _ _ | Snext |
- Sself | Stoken _ ->
- False ]
-and tree_derive_eps =
- fun
- [ LocAct _ _ -> True
- | Node {node = s; brother = bro; son = son} ->
- derive_eps s && tree_derive_eps son || tree_derive_eps bro
- | DeadEnd -> False ]
-;
-
-value rec eq_symbol s1 s2 =
- match (s1, s2) with
- [ (Snterm e1, Snterm e2) -> e1 == e2
- | (Snterml e1 l1, Snterml e2 l2) -> e1 == e2 && l1 = l2
- | (Slist0 s1, Slist0 s2) -> eq_symbol s1 s2
- | (Slist0sep s1 sep1, Slist0sep s2 sep2) ->
- eq_symbol s1 s2 && eq_symbol sep1 sep2
- | (Slist1 s1, Slist1 s2) -> eq_symbol s1 s2
- | (Slist1sep s1 sep1, Slist1sep s2 sep2) ->
- eq_symbol s1 s2 && eq_symbol sep1 sep2
- | (Sopt s1, Sopt s2) -> eq_symbol s1 s2
- | (Stree _, Stree _) -> False
- | _ -> s1 = s2 ]
-;
-
-value is_before s1 s2 =
- match (s1, s2) with
- [ (Stoken ("ANY", _), _) -> False
- | (_, Stoken ("ANY", _)) -> True
- | (Stoken (_, s), Stoken (_, "")) when s <> "" -> True
- | (Stoken _, Stoken _) -> False
- | (Stoken _, _) -> True
- | _ -> False ]
-;
-
-value insert_tree entry_name gsymbols action tree =
- let rec insert symbols tree =
- match symbols with
- [ [s :: sl] -> insert_in_tree s sl tree
- | [] ->
- match tree with
- [ Node {node = s; son = son; brother = bro} ->
- Node {node = s; son = son; brother = insert [] bro}
- | LocAct old_action action_list ->
- do {
- if warning_verbose.val then do {
- eprintf "<W> Grammar extension: ";
- if entry_name <> "" then eprintf "in [%s], " entry_name
- else ();
- eprintf "some rule has been masked\n";
- flush stderr
- }
- else ();
- LocAct action [old_action :: action_list]
- }
- | DeadEnd -> LocAct action [] ] ]
- and insert_in_tree s sl tree =
- match try_insert s sl tree with
- [ Some t -> t
- | None -> Node {node = s; son = insert sl DeadEnd; brother = tree} ]
- and try_insert s sl tree =
- match tree with
- [ Node {node = s1; son = son; brother = bro} ->
- if eq_symbol s s1 then
- let t = Node {node = s1; son = insert sl son; brother = bro} in
- Some t
- else if is_before s1 s || derive_eps s && not (derive_eps s1) then
- let bro =
- match try_insert s sl bro with
- [ Some bro -> bro
- | None ->
- Node {node = s; son = insert sl DeadEnd; brother = bro} ]
- in
- let t = Node {node = s1; son = son; brother = bro} in
- Some t
- else
- match try_insert s sl bro with
- [ Some bro ->
- let t = Node {node = s1; son = son; brother = bro} in
- Some t
- | None -> None ]
- | LocAct _ _ | DeadEnd -> None ]
- and insert_new =
- fun
- [ [s :: sl] -> Node {node = s; son = insert_new sl; brother = DeadEnd}
- | [] -> LocAct action [] ]
- in
- insert gsymbols tree
-;
-
-value srules rl =
- let t =
- List.fold_left
- (fun tree (symbols, action) -> insert_tree "" symbols action tree)
- DeadEnd rl
- in
- Stree t
-;
-
-external action : 'a -> g_action = "%identity";
-
-value is_level_labelled n lev =
- match lev.lname with
- [ Some n1 -> n = n1
- | None -> False ]
-;
-
-value insert_level entry_name e1 symbols action slev =
- match e1 with
- [ True ->
- {assoc = slev.assoc; lname = slev.lname;
- lsuffix = insert_tree entry_name symbols action slev.lsuffix;
- lprefix = slev.lprefix}
- | False ->
- {assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix;
- lprefix = insert_tree entry_name symbols action slev.lprefix} ]
-;
-
-value empty_lev lname assoc =
- let assoc =
- match assoc with
- [ Some a -> a
- | None -> LeftA ]
- in
- {assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd}
-;
-
-value change_lev lev n lname assoc =
- let a =
- match assoc with
- [ None -> lev.assoc
- | Some a ->
- do {
- if a <> lev.assoc && warning_verbose.val then do {
- eprintf "<W> Changing associativity of level \"%s\"\n" n;
- flush stderr
- }
- else ();
- a
- } ]
- in
- do {
- match lname with
- [ Some n ->
- if lname <> lev.lname && warning_verbose.val then do {
- eprintf "<W> Level label \"%s\" ignored\n" n; flush stderr
- }
- else ()
- | None -> () ];
- {assoc = a; lname = lev.lname; lsuffix = lev.lsuffix;
- lprefix = lev.lprefix}
- }
-;
-
-value get_level entry position levs =
- match position with
- [ Some First -> ([], empty_lev, levs)
- | Some Last -> (levs, empty_lev, [])
- | Some (Level n) ->
- let rec get =
- fun
- [ [] ->
- do {
- eprintf "No level labelled \"%s\" in entry \"%s\"\n" n
- entry.ename;
- flush stderr;
- failwith "Grammar.extend"
- }
- | [lev :: levs] ->
- if is_level_labelled n lev then ([], change_lev lev n, levs)
- else
- let (levs1, rlev, levs2) = get levs in
- ([lev :: levs1], rlev, levs2) ]
- in
- get levs
- | Some (Before n) ->
- let rec get =
- fun
- [ [] ->
- do {
- eprintf "No level labelled \"%s\" in entry \"%s\"\n" n
- entry.ename;
- flush stderr;
- failwith "Grammar.extend"
- }
- | [lev :: levs] ->
- if is_level_labelled n lev then ([], empty_lev, [lev :: levs])
- else
- let (levs1, rlev, levs2) = get levs in
- ([lev :: levs1], rlev, levs2) ]
- in
- get levs
- | Some (After n) ->
- let rec get =
- fun
- [ [] ->
- do {
- eprintf "No level labelled \"%s\" in entry \"%s\"\n" n
- entry.ename;
- flush stderr;
- failwith "Grammar.extend"
- }
- | [lev :: levs] ->
- if is_level_labelled n lev then ([lev], empty_lev, levs)
- else
- let (levs1, rlev, levs2) = get levs in
- ([lev :: levs1], rlev, levs2) ]
- in
- get levs
- | None ->
- match levs with
- [ [lev :: levs] -> ([], change_lev lev "<top>", levs)
- | [] -> ([], empty_lev, []) ] ]
-;
-
-value rec check_gram entry =
- fun
- [ Snterm e ->
- if e.egram != entry.egram then do {
- eprintf "\
-Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n"
- entry.ename e.ename;
- flush stderr;
- failwith "Grammar.extend error"
- }
- else ()
- | Snterml e _ ->
- if e.egram != entry.egram then do {
- eprintf "\
-Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n"
- entry.ename e.ename;
- flush stderr;
- failwith "Grammar.extend error"
- }
- else ()
- | Smeta _ sl _ -> List.iter (check_gram entry) sl
- | Slist0sep s t -> do { check_gram entry t; check_gram entry s }
- | Slist1sep s t -> do { check_gram entry t; check_gram entry s }
- | Slist0 s -> check_gram entry s
- | Slist1 s -> check_gram entry s
- | Sopt s -> check_gram entry s
- | Stree t -> tree_check_gram entry t
- | Snext | Sself | Stoken _ -> () ]
-and tree_check_gram entry =
- fun
- [ Node {node = n; brother = bro; son = son} ->
- do {
- check_gram entry n;
- tree_check_gram entry bro;
- tree_check_gram entry son
- }
- | LocAct _ _ | DeadEnd -> () ]
-;
-
-value change_to_self entry =
- fun
- [ Snterm e when e == entry -> Sself
- | x -> x ]
-;
-
-value get_initial entry =
- fun
- [ [Sself :: symbols] -> (True, symbols)
- | symbols -> (False, symbols) ]
-;
-
-value insert_tokens gram symbols =
- let rec insert =
- fun
- [ Smeta _ sl _ -> List.iter insert sl
- | Slist0 s -> insert s
- | Slist1 s -> insert s
- | Slist0sep s t -> do { insert s; insert t }
- | Slist1sep s t -> do { insert s; insert t }
- | Sopt s -> insert s
- | Stree t -> tinsert t
- | Stoken ("ANY", _) -> ()
- | Stoken tok ->
- do {
- gram.glexer.Token.tok_using tok;
- let r =
- try Hashtbl.find gram.gtokens tok with
- [ Not_found ->
- let r = ref 0 in
- do { Hashtbl.add gram.gtokens tok r; r } ]
- in
- incr r
- }
- | Snterm _ | Snterml _ _ | Snext | Sself -> () ]
- and tinsert =
- fun
- [ Node {node = s; brother = bro; son = son} ->
- do { insert s; tinsert bro; tinsert son }
- | LocAct _ _ | DeadEnd -> () ]
- in
- List.iter insert symbols
-;
-
-value levels_of_rules entry position rules =
- let elev =
- match entry.edesc with
- [ Dlevels elev -> elev
- | Dparser _ ->
- do {
- eprintf "Error: entry not extensible: \"%s\"\n" entry.ename;
- flush stderr;
- failwith "Grammar.extend"
- } ]
- in
- if rules = [] then elev
- else
- let (levs1, make_lev, levs2) = get_level entry position elev in
- let (levs, _) =
- List.fold_left
- (fun (levs, make_lev) (lname, assoc, level) ->
- let lev = make_lev lname assoc in
- let lev =
- List.fold_left
- (fun lev (symbols, action) ->
- let symbols = List.map (change_to_self entry) symbols in
- do {
- List.iter (check_gram entry) symbols;
- let (e1, symbols) = get_initial entry symbols in
- insert_tokens entry.egram symbols;
- insert_level entry.ename e1 symbols action lev
- })
- lev level
- in
- ([lev :: levs], empty_lev))
- ([], make_lev) rules
- in
- levs1 @ List.rev levs @ levs2
-;
-
-value logically_eq_symbols entry =
- let rec eq_symbols s1 s2 =
- match (s1, s2) with
- [ (Snterm e1, Snterm e2) -> e1.ename = e2.ename
- | (Snterm e1, Sself) -> e1.ename = entry.ename
- | (Sself, Snterm e2) -> entry.ename = e2.ename
- | (Snterml e1 l1, Snterml e2 l2) -> e1.ename = e2.ename && l1 = l2
- | (Slist0 s1, Slist0 s2) -> eq_symbols s1 s2
- | (Slist0sep s1 sep1, Slist0sep s2 sep2) ->
- eq_symbols s1 s2 && eq_symbols sep1 sep2
- | (Slist1 s1, Slist1 s2) -> eq_symbols s1 s2
- | (Slist1sep s1 sep1, Slist1sep s2 sep2) ->
- eq_symbols s1 s2 && eq_symbols sep1 sep2
- | (Sopt s1, Sopt s2) -> eq_symbols s1 s2
- | (Stree t1, Stree t2) -> eq_trees t1 t2
- | _ -> s1 = s2 ]
- and eq_trees t1 t2 =
- match (t1, t2) with
- [ (Node n1, Node n2) ->
- eq_symbols n1.node n2.node && eq_trees n1.son n2.son &&
- eq_trees n1.brother n2.brother
- | (LocAct _ _ | DeadEnd, LocAct _ _ | DeadEnd) -> True
- | _ -> False ]
- in
- eq_symbols
-;
-
-(* [delete_rule_in_tree] returns
- [Some (dsl, t)] if success
- [dsl] =
- Some (list of deleted nodes) if branch deleted
- None if action replaced by previous version of action
- [t] = remaining tree
- [None] if failure *)
-
-value delete_rule_in_tree entry =
- let rec delete_in_tree symbols tree =
- match (symbols, tree) with
- [ ([s :: sl], Node n) ->
- if logically_eq_symbols entry s n.node then delete_son sl n
- else
- match delete_in_tree symbols n.brother with
- [ Some (dsl, t) ->
- Some (dsl, Node {node = n.node; son = n.son; brother = t})
- | None -> None ]
- | ([s :: sl], _) -> None
- | ([], Node n) ->
- match delete_in_tree [] n.brother with
- [ Some (dsl, t) ->
- Some (dsl, Node {node = n.node; son = n.son; brother = t})
- | None -> None ]
- | ([], DeadEnd) -> None
- | ([], LocAct _ []) -> Some (Some [], DeadEnd)
- | ([], LocAct _ [action :: list]) -> Some (None, LocAct action list) ]
- and delete_son sl n =
- match delete_in_tree sl n.son with
- [ Some (Some dsl, DeadEnd) -> Some (Some [n.node :: dsl], n.brother)
- | Some (Some dsl, t) ->
- let t = Node {node = n.node; son = t; brother = n.brother} in
- Some (Some [n.node :: dsl], t)
- | Some (None, t) ->
- let t = Node {node = n.node; son = t; brother = n.brother} in
- Some (None, t)
- | None -> None ]
- in
- delete_in_tree
-;
-
-value rec decr_keyw_use gram =
- fun
- [ Stoken tok ->
- let r = Hashtbl.find gram.gtokens tok in
- do {
- decr r;
- if r.val == 0 then do {
- Hashtbl.remove gram.gtokens tok; gram.glexer.Token.tok_removing tok
- }
- else ()
- }
- | Smeta _ sl _ -> List.iter (decr_keyw_use gram) sl
- | Slist0 s -> decr_keyw_use gram s
- | Slist1 s -> decr_keyw_use gram s
- | Slist0sep s1 s2 -> do { decr_keyw_use gram s1; decr_keyw_use gram s2 }
- | Slist1sep s1 s2 -> do { decr_keyw_use gram s1; decr_keyw_use gram s2 }
- | Sopt s -> decr_keyw_use gram s
- | Stree t -> decr_keyw_use_in_tree gram t
- | Sself | Snext | Snterm _ | Snterml _ _ -> () ]
-and decr_keyw_use_in_tree gram =
- fun
- [ DeadEnd | LocAct _ _ -> ()
- | Node n ->
- do {
- decr_keyw_use gram n.node;
- decr_keyw_use_in_tree gram n.son;
- decr_keyw_use_in_tree gram n.brother
- } ]
-;
-
-value rec delete_rule_in_suffix entry symbols =
- fun
- [ [lev :: levs] ->
- match delete_rule_in_tree entry symbols lev.lsuffix with
- [ Some (dsl, t) ->
- do {
- match dsl with
- [ Some dsl -> List.iter (decr_keyw_use entry.egram) dsl
- | None -> () ];
- match t with
- [ DeadEnd when lev.lprefix == DeadEnd -> levs
- | _ ->
- let lev =
- {assoc = lev.assoc; lname = lev.lname; lsuffix = t;
- lprefix = lev.lprefix}
- in
- [lev :: levs] ]
- }
- | None ->
- let levs = delete_rule_in_suffix entry symbols levs in
- [lev :: levs] ]
- | [] -> raise Not_found ]
-;
-
-value rec delete_rule_in_prefix entry symbols =
- fun
- [ [lev :: levs] ->
- match delete_rule_in_tree entry symbols lev.lprefix with
- [ Some (dsl, t) ->
- do {
- match dsl with
- [ Some dsl -> List.iter (decr_keyw_use entry.egram) dsl
- | None -> () ];
- match t with
- [ DeadEnd when lev.lsuffix == DeadEnd -> levs
- | _ ->
- let lev =
- {assoc = lev.assoc; lname = lev.lname;
- lsuffix = lev.lsuffix; lprefix = t}
- in
- [lev :: levs] ]
- }
- | None ->
- let levs = delete_rule_in_prefix entry symbols levs in
- [lev :: levs] ]
- | [] -> raise Not_found ]
-;
-
-value rec delete_rule_in_level_list entry symbols levs =
- match symbols with
- [ [Sself :: symbols] -> delete_rule_in_suffix entry symbols levs
- | [Snterm e :: symbols] when e == entry ->
- delete_rule_in_suffix entry symbols levs
- | _ -> delete_rule_in_prefix entry symbols levs ]
-;
diff --git a/camlp4/lib/gramext.mli b/camlp4/lib/gramext.mli
deleted file mode 100644
index bd0fed514b..0000000000
--- a/camlp4/lib/gramext.mli
+++ /dev/null
@@ -1,81 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-type grammar 'te =
- { gtokens : Hashtbl.t Token.pattern (ref int);
- glexer : mutable Token.glexer 'te }
-;
-
-type g_entry 'te =
- { egram : grammar 'te;
- ename : string;
- estart : mutable int -> Stream.t 'te -> Obj.t;
- econtinue : mutable int -> int -> Obj.t -> Stream.t 'te -> Obj.t;
- edesc : mutable g_desc 'te }
-and g_desc 'te =
- [ Dlevels of list (g_level 'te)
- | Dparser of Stream.t 'te -> Obj.t ]
-and g_level 'te =
- { assoc : g_assoc;
- lname : option string;
- lsuffix : g_tree 'te;
- lprefix : g_tree 'te }
-and g_assoc =
- [ NonA
- | RightA
- | LeftA ]
-and g_symbol 'te =
- [ Smeta of string and list (g_symbol 'te) and Obj.t
- | Snterm of g_entry 'te
- | Snterml of g_entry 'te and string
- | Slist0 of g_symbol 'te
- | Slist0sep of g_symbol 'te and g_symbol 'te
- | Slist1 of g_symbol 'te
- | Slist1sep of g_symbol 'te and g_symbol 'te
- | Sopt of g_symbol 'te
- | Sself
- | Snext
- | Stoken of Token.pattern
- | Stree of g_tree 'te ]
-and g_action = Obj.t
-and g_tree 'te =
- [ Node of g_node 'te
- | LocAct of g_action and list g_action
- | DeadEnd ]
-and g_node 'te =
- { node : g_symbol 'te; son : g_tree 'te; brother : g_tree 'te }
-;
-
-type position =
- [ First
- | Last
- | Before of string
- | After of string
- | Level of string ]
-;
-
-value levels_of_rules :
- g_entry 'te -> option position ->
- list
- (option string * option g_assoc *
- list (list (g_symbol 'te) * g_action)) ->
- list (g_level 'te);
-value srules : list (list (g_symbol 'te) * g_action) -> g_symbol 'te;
-external action : 'a -> g_action = "%identity";
-
-value delete_rule_in_level_list :
- g_entry 'te -> list (g_symbol 'te) -> list (g_level 'te) ->
- list (g_level 'te);
-
-value warning_verbose : ref bool;
diff --git a/camlp4/lib/grammar.ml b/camlp4/lib/grammar.ml
deleted file mode 100644
index b8c22d5073..0000000000
--- a/camlp4/lib/grammar.ml
+++ /dev/null
@@ -1,1064 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Stdpp;
-open Gramext;
-open Format;
-
-value rec flatten_tree =
- fun
- [ DeadEnd -> []
- | LocAct _ _ -> [[]]
- | Node {node = n; brother = b; son = s} ->
- List.map (fun l -> [n :: l]) (flatten_tree s) @ flatten_tree b ]
-;
-
-value print_str ppf s = fprintf ppf "\"%s\"" (String.escaped s);
-
-value rec print_symbol ppf =
- fun
- [ Smeta n sl _ -> print_meta ppf n sl
- | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s
- | Slist0sep s t ->
- fprintf ppf "LIST0 %a SEP %a" print_symbol1 s print_symbol1 t
- | Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s
- | Slist1sep s t ->
- fprintf ppf "LIST1 %a SEP %a" print_symbol1 s print_symbol1 t
- | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s
- | Stoken (con, prm) when con <> "" && prm <> "" ->
- fprintf ppf "%s@ %a" con print_str prm
- | Snterml e l -> fprintf ppf "%s@ LEVEL@ %a" e.ename print_str l
- | Snterm _ | Snext | Sself | Stoken _ | Stree _ as s ->
- print_symbol1 ppf s ]
-and print_meta ppf n sl =
- loop 0 sl where rec loop i =
- fun
- [ [] -> ()
- | [s :: sl] ->
- let j =
- try String.index_from n i ' ' with [ Not_found -> String.length n ]
- in
- do {
- fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s;
- if sl = [] then ()
- else do { fprintf ppf " "; loop (min (j + 1) (String.length n)) sl }
- } ]
-and print_symbol1 ppf =
- fun
- [ Snterm e -> pp_print_string ppf e.ename
- | Sself -> pp_print_string ppf "SELF"
- | Snext -> pp_print_string ppf "NEXT"
- | Stoken ("", s) -> print_str ppf s
- | Stoken (con, "") -> pp_print_string ppf con
- | Stree t -> print_level ppf pp_print_space (flatten_tree t)
- | Smeta _ _ _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ |
- Slist1sep _ _ | Sopt _ | Stoken _ as s ->
- fprintf ppf "(%a)" print_symbol s ]
-and print_rule ppf symbols =
- do {
- fprintf ppf "@[<hov 0>";
- let _ =
- List.fold_left
- (fun sep symbol ->
- do {
- fprintf ppf "%t%a" sep print_symbol symbol;
- fun ppf -> fprintf ppf ";@ "
- })
- (fun ppf -> ()) symbols
- in
- fprintf ppf "@]"
- }
-and print_level ppf pp_print_space rules =
- do {
- fprintf ppf "@[<hov 0>[ ";
- let _ =
- List.fold_left
- (fun sep rule ->
- do {
- fprintf ppf "%t%a" sep print_rule rule;
- fun ppf -> fprintf ppf "%a| " pp_print_space ()
- })
- (fun ppf -> ()) rules
- in
- fprintf ppf " ]@]"
- }
-;
-
-value print_levels ppf elev =
- let _ =
- List.fold_left
- (fun sep lev ->
- let rules =
- List.map (fun t -> [Sself :: t]) (flatten_tree lev.lsuffix) @
- flatten_tree lev.lprefix
- in
- do {
- fprintf ppf "%t@[<hov 2>" sep;
- match lev.lname with
- [ Some n -> fprintf ppf "%a@;<1 2>" print_str n
- | None -> () ];
- match lev.assoc with
- [ LeftA -> fprintf ppf "LEFTA"
- | RightA -> fprintf ppf "RIGHTA"
- | NonA -> fprintf ppf "NONA" ];
- fprintf ppf "@]@;<1 2>";
- print_level ppf pp_force_newline rules;
- fun ppf -> fprintf ppf "@,| "
- })
- (fun ppf -> ()) elev
- in
- ()
-;
-
-value print_entry ppf e =
- do {
- fprintf ppf "@[<v 0>[ ";
- match e.edesc with
- [ Dlevels elev -> print_levels ppf elev
- | Dparser _ -> fprintf ppf "<parser>" ];
- fprintf ppf " ]@]"
- }
-;
-
-value iter_entry f e =
- let treated = ref [] in
- let rec do_entry e =
- if List.memq e treated.val then ()
- else do {
- treated.val := [e :: treated.val];
- f e;
- match e.edesc with
- [ Dlevels ll -> List.iter do_level ll
- | Dparser _ -> () ]
- }
- and do_level lev = do { do_tree lev.lsuffix; do_tree lev.lprefix }
- and do_tree =
- fun
- [ Node n -> do_node n
- | LocAct _ _ | DeadEnd -> () ]
- and do_node n = do { do_symbol n.node; do_tree n.son; do_tree n.brother }
- and do_symbol =
- fun
- [ Smeta _ sl _ -> List.iter do_symbol sl
- | Snterm e | Snterml e _ -> do_entry e
- | Slist0 s | Slist1 s | Sopt s -> do_symbol s
- | Slist0sep s1 s2 | Slist1sep s1 s2 -> do { do_symbol s1; do_symbol s2 }
- | Stree t -> do_tree t
- | Sself | Snext | Stoken _ -> () ]
- in
- do_entry e
-;
-
-value fold_entry f e init =
- let treated = ref [] in
- let rec do_entry accu e =
- if List.memq e treated.val then accu
- else do {
- treated.val := [e :: treated.val];
- let accu = f e accu in
- match e.edesc with
- [ Dlevels ll -> List.fold_left do_level accu ll
- | Dparser _ -> accu ]
- }
- and do_level accu lev =
- let accu = do_tree accu lev.lsuffix in
- do_tree accu lev.lprefix
- and do_tree accu =
- fun
- [ Node n -> do_node accu n
- | LocAct _ _ | DeadEnd -> accu ]
- and do_node accu n =
- let accu = do_symbol accu n.node in
- let accu = do_tree accu n.son in
- do_tree accu n.brother
- and do_symbol accu =
- fun
- [ Smeta _ sl _ -> List.fold_left do_symbol accu sl
- | Snterm e | Snterml e _ -> do_entry accu e
- | Slist0 s | Slist1 s | Sopt s -> do_symbol accu s
- | Slist0sep s1 s2 | Slist1sep s1 s2 ->
- let accu = do_symbol accu s1 in
- do_symbol accu s2
- | Stree t -> do_tree accu t
- | Sself | Snext | Stoken _ -> accu ]
- in
- do_entry init e
-;
-
-type g = Gramext.grammar Token.t;
-
-external grammar_obj : g -> grammar Token.t = "%identity";
-
-value floc = ref (fun _ -> failwith "internal error when computing location");
-value loc_of_token_interval bp ep =
- if bp == ep then
- if bp == 0 then (0, 1)
- else
- let a = snd (floc.val (bp - 1)) in
- (a, a + 1)
- else
- let (bp1, bp2) = floc.val bp in
- let (ep1, ep2) = floc.val (pred ep) in
- (if bp1 < ep1 then bp1 else ep1, if bp2 > ep2 then bp2 else ep2)
-;
-
-value rec name_of_symbol entry =
- fun
- [ Snterm e -> "[" ^ e.ename ^ "]"
- | Snterml e l -> "[" ^ e.ename ^ " level " ^ l ^ "]"
- | Sself | Snext -> "[" ^ entry.ename ^ "]"
- | Stoken tok -> entry.egram.glexer.Token.tok_text tok
- | _ -> "???" ]
-;
-
-value rec get_token_list entry tokl last_tok tree =
- match tree with
- [ Node {node = (Stoken tok as s); son = son; brother = DeadEnd} ->
- get_token_list entry [last_tok :: tokl] tok son
- | _ ->
- if tokl = [] then None
- else Some (List.rev [last_tok :: tokl], last_tok, tree) ]
-;
-
-value rec name_of_symbol_failed entry =
- fun
- [ Slist0 s -> name_of_symbol_failed entry s
- | Slist0sep s _ -> name_of_symbol_failed entry s
- | Slist1 s -> name_of_symbol_failed entry s
- | Slist1sep s _ -> name_of_symbol_failed entry s
- | Sopt s -> name_of_symbol_failed entry s
- | Stree t -> name_of_tree_failed entry t
- | s -> name_of_symbol entry s ]
-and name_of_tree_failed entry =
- fun
- [ Node {node = s; brother = bro; son = son} ->
- let tokl =
- match s with
- [ Stoken tok -> get_token_list entry [] tok son
- | _ -> None ]
- in
- match tokl with
- [ None ->
- let txt = name_of_symbol_failed entry s in
- let txt =
- match (s, son) with
- [ (Sopt _, Node _) -> txt ^ " or " ^ name_of_tree_failed entry son
- | _ -> txt ]
- in
- let txt =
- match bro with
- [ DeadEnd | LocAct _ _ -> txt
- | Node _ -> txt ^ " or " ^ name_of_tree_failed entry bro ]
- in
- txt
- | Some (tokl, last_tok, son) ->
- List.fold_left
- (fun s tok ->
- (if s = "" then "" else s ^ " ") ^
- entry.egram.glexer.Token.tok_text tok)
- "" tokl ]
- | DeadEnd | LocAct _ _ -> "???" ]
-;
-
-value search_tree_in_entry prev_symb tree =
- fun
- [ Dlevels levels ->
- let rec search_levels =
- fun
- [ [] -> tree
- | [level :: levels] ->
- match search_level level with
- [ Some tree -> tree
- | None -> search_levels levels ] ]
- and search_level level =
- match search_tree level.lsuffix with
- [ Some t -> Some (Node {node = Sself; son = t; brother = DeadEnd})
- | None -> search_tree level.lprefix ]
- and search_tree t =
- if tree <> DeadEnd && t == tree then Some t
- else
- match t with
- [ Node n ->
- match search_symbol n.node with
- [ Some symb ->
- Some (Node {node = symb; son = n.son; brother = DeadEnd})
- | None ->
- match search_tree n.son with
- [ Some t ->
- Some (Node {node = n.node; son = t; brother = DeadEnd})
- | None -> search_tree n.brother ] ]
- | LocAct _ _ | DeadEnd -> None ]
- and search_symbol symb =
- match symb with
- [ Snterm _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ |
- Slist1sep _ _ | Sopt _ | Stoken _ | Stree _
- when symb == prev_symb ->
- Some symb
- | Slist0 symb ->
- match search_symbol symb with
- [ Some symb -> Some (Slist0 symb)
- | None -> None ]
- | Slist0sep symb sep ->
- match search_symbol symb with
- [ Some symb -> Some (Slist0sep symb sep)
- | None ->
- match search_symbol sep with
- [ Some sep -> Some (Slist0sep symb sep)
- | None -> None ] ]
- | Slist1 symb ->
- match search_symbol symb with
- [ Some symb -> Some (Slist1 symb)
- | None -> None ]
- | Slist1sep symb sep ->
- match search_symbol symb with
- [ Some symb -> Some (Slist1sep symb sep)
- | None ->
- match search_symbol sep with
- [ Some sep -> Some (Slist1sep symb sep)
- | None -> None ] ]
- | Sopt symb ->
- match search_symbol symb with
- [ Some symb -> Some (Sopt symb)
- | None -> None ]
- | Stree t ->
- match search_tree t with
- [ Some t -> Some (Stree t)
- | None -> None ]
- | _ -> None ]
- in
- search_levels levels
- | Dparser _ -> tree ]
-;
-
-value error_verbose = ref False;
-
-value tree_failed entry prev_symb_result prev_symb tree =
- let txt = name_of_tree_failed entry tree in
- let txt =
- match prev_symb with
- [ Slist0 s ->
- let txt1 = name_of_symbol_failed entry s in
- txt1 ^ " or " ^ txt ^ " expected"
- | Slist1 s ->
- let txt1 = name_of_symbol_failed entry s in
- txt1 ^ " or " ^ txt ^ " expected"
- | Slist0sep s sep ->
- match Obj.magic prev_symb_result with
- [ [] ->
- let txt1 = name_of_symbol_failed entry s in
- txt1 ^ " or " ^ txt ^ " expected"
- | _ ->
- let txt1 = name_of_symbol_failed entry sep in
- txt1 ^ " or " ^ txt ^ " expected" ]
- | Slist1sep s sep ->
- match Obj.magic prev_symb_result with
- [ [] ->
- let txt1 = name_of_symbol_failed entry s in
- txt1 ^ " or " ^ txt ^ " expected"
- | _ ->
- let txt1 = name_of_symbol_failed entry sep in
- txt1 ^ " or " ^ txt ^ " expected" ]
- | Sopt _ | Stree _ -> txt ^ " expected"
- | _ -> txt ^ " expected after " ^ name_of_symbol entry prev_symb ]
- in
- do {
- if error_verbose.val then do {
- let tree = search_tree_in_entry prev_symb tree entry.edesc in
- let ppf = err_formatter in
- fprintf ppf "@[<v 0>@,";
- fprintf ppf "----------------------------------@,";
- fprintf ppf "Parse error in entry [%s], rule:@;<0 2>" entry.ename;
- fprintf ppf "@[";
- print_level ppf pp_force_newline (flatten_tree tree);
- fprintf ppf "@]@,";
- fprintf ppf "----------------------------------@,";
- fprintf ppf "@]@."
- }
- else ();
- txt ^ " (in [" ^ entry.ename ^ "])"
- }
-;
-
-value symb_failed entry prev_symb_result prev_symb symb =
- let tree = Node {node = symb; brother = DeadEnd; son = DeadEnd} in
- tree_failed entry prev_symb_result prev_symb tree
-;
-
-external app : Obj.t -> 'a = "%identity";
-
-value is_level_labelled n lev =
- match lev.lname with
- [ Some n1 -> n = n1
- | None -> False ]
-;
-
-value level_number entry lab =
- let rec lookup levn =
- fun
- [ [] -> failwith ("unknown level " ^ lab)
- | [lev :: levs] ->
- if is_level_labelled lab lev then levn else lookup (succ levn) levs ]
- in
- match entry.edesc with
- [ Dlevels elev -> lookup 0 elev
- | Dparser _ -> raise Not_found ]
-;
-
-value rec top_symb entry =
- fun
- [ Sself | Snext -> Snterm entry
- | Snterml e _ -> Snterm e
- | Slist1sep s sep -> Slist1sep (top_symb entry s) sep
- | _ -> raise Stream.Failure ]
-;
-
-value entry_of_symb entry =
- fun
- [ Sself | Snext -> entry
- | Snterm e -> e
- | Snterml e _ -> e
- | _ -> raise Stream.Failure ]
-;
-
-value top_tree entry =
- fun
- [ Node {node = s; brother = bro; son = son} ->
- Node {node = top_symb entry s; brother = bro; son = son}
- | LocAct _ _ | DeadEnd -> raise Stream.Failure ]
-;
-
-value skip_if_empty bp p strm =
- if Stream.count strm == bp then Gramext.action (fun a -> p strm)
- else raise Stream.Failure
-;
-
-value continue entry bp a s son p1 =
- parser
- [: a = (entry_of_symb entry s).econtinue 0 bp a;
- act = p1 ? tree_failed entry a s son :] ->
- Gramext.action (fun _ -> app act a)
-;
-
-value do_recover parser_of_tree entry nlevn alevn bp a s son =
- parser
- [ [: a = parser_of_tree entry nlevn alevn (top_tree entry son) :] -> a
- | [: a = skip_if_empty bp (parser []) :] -> a
- | [: a =
- continue entry bp a s son
- (parser_of_tree entry nlevn alevn son) :] ->
- a ]
-;
-
-value strict_parsing = ref False;
-
-value recover parser_of_tree entry nlevn alevn bp a s son strm =
- if strict_parsing.val then raise (Stream.Error (tree_failed entry a s son))
- else do_recover parser_of_tree entry nlevn alevn bp a s son strm
-;
-
-value token_count = ref 0;
-
-value peek_nth n strm =
- let list = Stream.npeek n strm in
- do {
- token_count.val := Stream.count strm + n;
- let rec loop list n =
- match (list, n) with
- [ ([x :: _], 1) -> Some x
- | ([_ :: l], n) -> loop l (n - 1)
- | ([], _) -> None ]
- in
- loop list n
- }
-;
-
-value rec parser_of_tree entry nlevn alevn =
- fun
- [ DeadEnd -> parser []
- | LocAct act _ -> parser [: :] -> act
- | Node {node = Sself; son = LocAct act _; brother = DeadEnd} ->
- parser [: a = entry.estart alevn :] -> app act a
- | Node {node = Sself; son = LocAct act _; brother = bro} ->
- let p2 = parser_of_tree entry nlevn alevn bro in
- parser
- [ [: a = entry.estart alevn :] -> app act a
- | [: a = p2 :] -> a ]
- | Node {node = s; son = son; brother = DeadEnd} ->
- let tokl =
- match s with
- [ Stoken tok -> get_token_list entry [] tok son
- | _ -> None ]
- in
- match tokl with
- [ None ->
- let ps = parser_of_symbol entry nlevn s in
- let p1 = parser_of_tree entry nlevn alevn son in
- let p1 = parser_cont p1 entry nlevn alevn s son in
- parser bp [: a = ps; act = p1 bp a :] -> app act a
- | Some (tokl, last_tok, son) ->
- let p1 = parser_of_tree entry nlevn alevn son in
- let p1 = parser_cont p1 entry nlevn alevn (Stoken last_tok) son in
- parser_of_token_list entry.egram p1 tokl ]
- | Node {node = s; son = son; brother = bro} ->
- let tokl =
- match s with
- [ Stoken tok -> get_token_list entry [] tok son
- | _ -> None ]
- in
- match tokl with
- [ None ->
- let ps = parser_of_symbol entry nlevn s in
- let p1 = parser_of_tree entry nlevn alevn son in
- let p1 = parser_cont p1 entry nlevn alevn s son in
- let p2 = parser_of_tree entry nlevn alevn bro in
- parser bp
- [ [: a = ps; act = p1 bp a :] -> app act a
- | [: a = p2 :] -> a ]
- | Some (tokl, last_tok, son) ->
- let p1 = parser_of_tree entry nlevn alevn son in
- let p1 = parser_cont p1 entry nlevn alevn (Stoken last_tok) son in
- let p1 = parser_of_token_list entry.egram p1 tokl in
- let p2 = parser_of_tree entry nlevn alevn bro in
- parser
- [ [: a = p1 :] -> a
- | [: a = p2 :] -> a ] ] ]
-and parser_cont p1 entry nlevn alevn s son bp a =
- parser
- [ [: a = p1 :] -> a
- | [: a = recover parser_of_tree entry nlevn alevn bp a s son :] -> a
- | [: :] -> raise (Stream.Error (tree_failed entry a s son)) ]
-and parser_of_token_list gram p1 tokl =
- loop 1 tokl where rec loop n =
- fun
- [ [tok :: tokl] ->
- let tematch = gram.glexer.Token.tok_match tok in
- match tokl with
- [ [] ->
- let ps strm =
- match peek_nth n strm with
- [ Some tok ->
- let r = tematch tok in
- do { for i = 1 to n do { Stream.junk strm }; Obj.repr r }
- | None -> raise Stream.Failure ]
- in
- parser bp [: a = ps; act = p1 bp a :] -> app act a
- | _ ->
- let ps strm =
- match peek_nth n strm with
- [ Some tok -> tematch tok
- | None -> raise Stream.Failure ]
- in
- let p1 = loop (n + 1) tokl in
- parser
- [: a = ps; s :] ->
- let act = p1 s in
- app act a ]
- | [] -> invalid_arg "parser_of_token_list" ]
-and parser_of_symbol entry nlevn =
- fun
- [ Smeta _ symbl act ->
- let act = Obj.magic act entry symbl in
- Obj.magic
- (List.fold_left
- (fun act symb -> Obj.magic act (parser_of_symbol entry nlevn symb))
- act symbl)
- | Slist0 s ->
- let ps = parser_of_symbol entry nlevn s in
- let rec loop al =
- parser
- [ [: a = ps; s :] -> loop [a :: al] s
- | [: :] -> al ]
- in
- parser [: a = loop [] :] -> Obj.repr (List.rev a)
- | Slist0sep symb sep ->
- let ps = parser_of_symbol entry nlevn symb in
- let pt = parser_of_symbol entry nlevn sep in
- let rec kont al =
- parser
- [ [: v = pt; a = ps ? symb_failed entry v sep symb; s :] ->
- kont [a :: al] s
- | [: :] -> al ]
- in
- parser
- [ [: a = ps; s :] -> Obj.repr (List.rev (kont [a] s))
- | [: :] -> Obj.repr [] ]
- | Slist1 s ->
- let ps = parser_of_symbol entry nlevn s in
- let rec loop al =
- parser
- [ [: a = ps; s :] -> loop [a :: al] s
- | [: :] -> al ]
- in
- parser [: a = ps; s :] -> Obj.repr (List.rev (loop [a] s))
- | Slist1sep symb sep ->
- let ps = parser_of_symbol entry nlevn symb in
- let pt = parser_of_symbol entry nlevn sep in
- let rec kont al =
- parser
- [ [: v = pt;
- a =
- parser
- [ [: a = ps :] -> a
- | [: a = parse_top_symb entry symb :] -> a
- | [: :] ->
- raise (Stream.Error (symb_failed entry v sep symb)) ];
- s :] ->
- kont [a :: al] s
- | [: :] -> al ]
- in
- parser [: a = ps; s :] -> Obj.repr (List.rev (kont [a] s))
- | Sopt s ->
- let ps = parser_of_symbol entry nlevn s in
- parser
- [ [: a = ps :] -> Obj.repr (Some a)
- | [: :] -> Obj.repr None ]
- | Stree t ->
- let pt = parser_of_tree entry 1 0 t in
- parser bp
- [: a = pt :] ep ->
- let loc = loc_of_token_interval bp ep in
- app a loc
- | Snterm e -> parser [: a = e.estart 0 :] -> a
- | Snterml e l -> parser [: a = e.estart (level_number e l) :] -> a
- | Sself -> parser [: a = entry.estart 0 :] -> a
- | Snext -> parser [: a = entry.estart nlevn :] -> a
- | Stoken tok ->
- let f = entry.egram.glexer.Token.tok_match tok in
- fun strm ->
- match Stream.peek strm with
- [ Some tok ->
- let r = f tok in
- do { Stream.junk strm; Obj.repr r }
- | None -> raise Stream.Failure ] ]
-and parse_top_symb entry symb =
- parser_of_symbol entry 0 (top_symb entry symb)
-;
-
-value symb_failed_txt e s1 s2 = symb_failed e 0 s1 s2;
-
-value rec continue_parser_of_levels entry clevn =
- fun
- [ [] -> fun levn bp a -> parser []
- | [lev :: levs] ->
- let p1 = continue_parser_of_levels entry (succ clevn) levs in
- match lev.lsuffix with
- [ DeadEnd -> p1
- | tree ->
- let alevn =
- match lev.assoc with
- [ LeftA | NonA -> succ clevn
- | RightA -> clevn ]
- in
- let p2 = parser_of_tree entry (succ clevn) alevn tree in
- fun levn bp a strm ->
- if levn > clevn then p1 levn bp a strm
- else
- match strm with parser
- [ [: a = p1 levn bp a :] -> a
- | [: act = p2 :] ep ->
- let a = app act a (loc_of_token_interval bp ep) in
- entry.econtinue levn bp a strm ] ] ]
-;
-
-value rec start_parser_of_levels entry clevn =
- fun
- [ [] -> fun levn -> parser []
- | [lev :: levs] ->
- let p1 = start_parser_of_levels entry (succ clevn) levs in
- match lev.lprefix with
- [ DeadEnd -> p1
- | tree ->
- let alevn =
- match lev.assoc with
- [ LeftA | NonA -> succ clevn
- | RightA -> clevn ]
- in
- let p2 = parser_of_tree entry (succ clevn) alevn tree in
- match levs with
- [ [] ->
- fun levn strm ->
- match strm with parser bp
- [ [: act = p2 :] ep ->
- let a = app act (loc_of_token_interval bp ep) in
- entry.econtinue levn bp a strm ]
- | _ ->
- fun levn strm ->
- if levn > clevn then p1 levn strm
- else
- match strm with parser bp
- [ [: act = p2 :] ep ->
- let a = app act (loc_of_token_interval bp ep) in
- entry.econtinue levn bp a strm
- | [: a = p1 levn :] -> a ] ] ] ]
-;
-
-value continue_parser_of_entry entry =
- match entry.edesc with
- [ Dlevels elev ->
- let p = continue_parser_of_levels entry 0 elev in
- fun levn bp a ->
- parser
- [ [: a = p levn bp a :] -> a
- | [: :] -> a ]
- | Dparser p -> fun levn bp a -> parser [] ]
-;
-
-value empty_entry ename levn strm =
- raise (Stream.Error ("entry [" ^ ename ^ "] is empty"))
-;
-
-value start_parser_of_entry entry =
- match entry.edesc with
- [ Dlevels [] -> empty_entry entry.ename
- | Dlevels elev -> start_parser_of_levels entry 0 elev
- | Dparser p -> fun levn strm -> p strm ]
-;
-
-value parse_parsable entry efun (cs, (ts, fun_loc)) =
- let restore =
- let old_floc = floc.val in
- let old_tc = token_count.val in
- fun () -> do { floc.val := old_floc; token_count.val := old_tc }
- in
- let get_loc () =
- try
- let cnt = Stream.count ts in
- let loc = fun_loc cnt in
- if token_count.val - 1 <= cnt then loc
- else (fst loc, snd (fun_loc (token_count.val - 1)))
- with _ ->
- (Stream.count cs, Stream.count cs + 1)
- in
- do {
- floc.val := fun_loc;
- token_count.val := 0;
- try
- let r = efun ts in
- do { restore (); r }
- with
- [ Stream.Failure ->
- let loc = get_loc () in
- do {
- restore ();
- raise_with_loc loc
- (Stream.Error ("illegal begin of " ^ entry.ename))
- }
- | Stream.Error _ as exc ->
- let loc = get_loc () in
- do { restore (); raise_with_loc loc exc }
- | exc ->
- let loc = (Stream.count cs, Stream.count cs + 1) in
- do { restore (); raise_with_loc loc exc } ]
- }
-;
-
-value wrap_parse entry efun cs =
- let parsable = (cs, entry.egram.glexer.Token.tok_func cs) in
- parse_parsable entry efun parsable
-;
-
-value create_toktab () = Hashtbl.create 301;
-value gcreate glexer = {gtokens = create_toktab (); glexer = glexer};
-
-value tematch tparse tok =
- match tparse tok with
- [ Some p -> fun x -> p [: `x :]
- | None -> Token.default_match tok ]
-;
-value glexer_of_lexer lexer =
- {Token.tok_func = lexer.Token.func; Token.tok_using = lexer.Token.using;
- Token.tok_removing = lexer.Token.removing;
- Token.tok_match = tematch lexer.Token.tparse;
- Token.tok_text = lexer.Token.text; Token.tok_comm = None}
-;
-value create lexer = gcreate (glexer_of_lexer lexer);
-
-(* Extend syntax *)
-
-value extend_entry entry position rules =
- try
- let elev = Gramext.levels_of_rules entry position rules in
- do {
- entry.edesc := Dlevels elev;
- entry.estart :=
- fun lev strm ->
- let f = start_parser_of_entry entry in
- do { entry.estart := f; f lev strm };
- entry.econtinue :=
- fun lev bp a strm ->
- let f = continue_parser_of_entry entry in
- do { entry.econtinue := f; f lev bp a strm }
- }
- with
- [ Token.Error s ->
- do {
- Printf.eprintf "Lexer initialization error:\n- %s\n" s;
- flush stderr;
- failwith "Grammar.extend"
- } ]
-;
-
-value extend entry_rules_list =
- let gram = ref None in
- List.iter
- (fun (entry, position, rules) ->
- do {
- match gram.val with
- [ Some g ->
- if g != entry.egram then do {
- Printf.eprintf "Error: entries with different grammars\n";
- flush stderr;
- failwith "Grammar.extend"
- }
- else ()
- | None -> gram.val := Some entry.egram ];
- extend_entry entry position rules
- })
- entry_rules_list
-;
-
-(* Deleting a rule *)
-
-value delete_rule entry sl =
- match entry.edesc with
- [ Dlevels levs ->
- let levs = Gramext.delete_rule_in_level_list entry sl levs in
- do {
- entry.edesc := Dlevels levs;
- entry.estart :=
- fun lev strm ->
- let f = start_parser_of_entry entry in
- do { entry.estart := f; f lev strm };
- entry.econtinue :=
- fun lev bp a strm ->
- let f = continue_parser_of_entry entry in
- do { entry.econtinue := f; f lev bp a strm }
- }
- | Dparser _ -> () ]
-;
-
-(* Unsafe *)
-
-value clear_entry e =
- do {
- e.estart := fun _ -> parser [];
- e.econtinue := fun _ _ _ -> parser [];
- match e.edesc with
- [ Dlevels _ -> e.edesc := Dlevels []
- | Dparser _ -> () ]
- }
-;
-
-value gram_reinit g glexer =
- do { Hashtbl.clear g.gtokens; g.glexer := glexer }
-;
-
-value reinit_gram g lexer = gram_reinit g (glexer_of_lexer lexer);
-
-module Unsafe =
- struct
- value gram_reinit = gram_reinit;
- value clear_entry = clear_entry;
- value reinit_gram = reinit_gram;
- end
-;
-
-value find_entry e s =
- let rec find_levels =
- fun
- [ [] -> None
- | [lev :: levs] ->
- match find_tree lev.lsuffix with
- [ None ->
- match find_tree lev.lprefix with
- [ None -> find_levels levs
- | x -> x ]
- | x -> x ] ]
- and find_symbol =
- fun
- [ Snterm e -> if e.ename = s then Some e else None
- | Snterml e _ -> if e.ename = s then Some e else None
- | Smeta _ sl _ -> find_symbol_list sl
- | Slist0 s -> find_symbol s
- | Slist0sep s _ -> find_symbol s
- | Slist1 s -> find_symbol s
- | Slist1sep s _ -> find_symbol s
- | Sopt s -> find_symbol s
- | Stree t -> find_tree t
- | Sself | Snext | Stoken _ -> None ]
- and find_symbol_list =
- fun
- [ [s :: sl] ->
- match find_symbol s with
- [ None -> find_symbol_list sl
- | x -> x ]
- | [] -> None ]
- and find_tree =
- fun
- [ Node {node = s; brother = bro; son = son} ->
- match find_symbol s with
- [ None ->
- match find_tree bro with
- [ None -> find_tree son
- | x -> x ]
- | x -> x ]
- | LocAct _ _ | DeadEnd -> None ]
- in
- match e.edesc with
- [ Dlevels levs ->
- match find_levels levs with
- [ Some e -> e
- | None -> raise Not_found ]
- | Dparser _ -> raise Not_found ]
-;
-
-value of_entry e = e.egram;
-
-module Entry =
- struct
- type te = Token.t;
- type e 'a = g_entry te;
- value create g n =
- {egram = g; ename = n; estart = empty_entry n;
- econtinue _ _ _ = parser []; edesc = Dlevels []}
- ;
- value parse (entry : e 'a) cs : 'a =
- Obj.magic (wrap_parse entry (entry.estart 0) cs)
- ;
- value parse_token (entry : e 'a) ts : 'a = Obj.magic (entry.estart 0 ts);
- value name e = e.ename;
- value of_parser g n (p : Stream.t te -> 'a) : e 'a =
- {egram = g; ename = n; estart _ = Obj.magic p;
- econtinue _ _ _ = parser []; edesc = Dparser (Obj.magic p)}
- ;
- external obj : e 'a -> Gramext.g_entry te = "%identity";
- value print e = printf "%a@." print_entry (obj e);
- value find e s = find_entry (obj e) s;
- end
-;
-
-value tokens g con =
- let list = ref [] in
- do {
- Hashtbl.iter
- (fun (p_con, p_prm) c ->
- if p_con = con then list.val := [(p_prm, c.val) :: list.val] else ())
- g.gtokens;
- list.val
- }
-;
-
-value glexer g = g.glexer;
-
-value warning_verbose = Gramext.warning_verbose;
-
-(* Functorial interface *)
-
-module type GLexerType = sig type te = 'x; value lexer : Token.glexer te; end;
-
-module type S =
- sig
- type te = 'x;
- type parsable = 'x;
- value parsable : Stream.t char -> parsable;
- value tokens : string -> list (string * int);
- value glexer : Token.glexer te;
- module Entry :
- sig
- type e 'a = 'x;
- value create : string -> e 'a;
- value parse : e 'a -> parsable -> 'a;
- value parse_token : e 'a -> Stream.t te -> 'a;
- value name : e 'a -> string;
- value of_parser : string -> (Stream.t te -> 'a) -> e 'a;
- value print : e 'a -> unit;
- external obj : e 'a -> Gramext.g_entry te = "%identity";
- end
- ;
- module Unsafe :
- sig
- value gram_reinit : Token.glexer te -> unit;
- value clear_entry : Entry.e 'a -> unit;
- value reinit_gram : Token.lexer -> unit;
- end
- ;
- value extend :
- Entry.e 'a -> option Gramext.position ->
- list
- (option string * option Gramext.g_assoc *
- list (list (Gramext.g_symbol te) * Gramext.g_action)) ->
- unit;
- value delete_rule : Entry.e 'a -> list (Gramext.g_symbol te) -> unit;
- end
-;
-
-module type ReinitType = sig value reinit_gram : g -> Token.lexer -> unit; end
-;
-
-module GGMake (R : ReinitType) (L : GLexerType) =
- struct
- type te = L.te;
- type parsable = (Stream.t char * (Stream.t te * Token.location_function));
- value gram = gcreate L.lexer;
- value parsable cs = (cs, L.lexer.Token.tok_func cs);
- value tokens = tokens gram;
- value glexer = glexer gram;
- module Entry =
- struct
- type e 'a = g_entry te;
- value create n =
- {egram = gram; ename = n; estart = empty_entry n;
- econtinue _ _ _ = parser []; edesc = Dlevels []}
- ;
- external obj : e 'a -> Gramext.g_entry te = "%identity";
- value parse (e : e 'a) p : 'a =
- Obj.magic (parse_parsable e (e.estart 0) p)
- ;
- value parse_token (e : e 'a) ts : 'a = Obj.magic (e.estart 0 ts);
- value name e = e.ename;
- value of_parser n (p : Stream.t te -> 'a) : e 'a =
- {egram = gram; ename = n; estart _ = Obj.magic p;
- econtinue _ _ _ = parser []; edesc = Dparser (Obj.magic p)}
- ;
- value print e = printf "%a@." print_entry (obj e);
- end
- ;
- module Unsafe =
- struct
- value gram_reinit = gram_reinit gram;
- value clear_entry = Unsafe.clear_entry;
- value reinit_gram = R.reinit_gram (Obj.magic gram);
- end
- ;
- value extend = extend_entry;
- value delete_rule e r = delete_rule (Entry.obj e) r;
- end
-;
-
-module GMake (L : GLexerType) =
- GGMake
- (struct
- value reinit_gram _ _ =
- failwith "call of deprecated reinit_gram in grammar built by GMake"
- ;
- end)
- L
-;
-
-module type LexerType = sig value lexer : Token.lexer; end;
-
-module Make (L : LexerType) =
- GGMake (struct value reinit_gram = reinit_gram; end)
- (struct type te = Token.t; value lexer = glexer_of_lexer L.lexer; end)
-;
diff --git a/camlp4/lib/grammar.mli b/camlp4/lib/grammar.mli
deleted file mode 100644
index fe8345fb36..0000000000
--- a/camlp4/lib/grammar.mli
+++ /dev/null
@@ -1,209 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Extensible grammars.
-
- This module implements the Camlp4 extensible grammars system.
- Grammars entries can be extended using the [EXTEND] statement,
- added by loading the Camlp4 [pa_extend.cmo] file. *)
-
-type g = 'x;
- (** The type for grammars, holding entries. *)
-value gcreate : Token.glexer Token.t -> g;
- (** Create a new grammar, without keywords, using the lexer given
- as parameter. *)
-value tokens : g -> string -> list (string * int);
- (** Given a grammar and a token pattern constructor, returns the list of
- the corresponding values currently used in all entries of this grammar.
- The integer is the number of times this pattern value is used.
-
- Examples:
-- If the associated lexer uses ("", xxx) to represent a keyword
- (what is represented by then simple string xxx in an [EXTEND]
- statement rule), the call [Grammar.token g ""] returns the keywords
- list.
-- The call [Grammar.token g "IDENT"] returns the list of all usages
- of the pattern "IDENT" in the [EXTEND] statements. *)
-value glexer : g -> Token.glexer Token.t;
- (** Return the lexer used by the grammar *)
-
-module Entry :
- sig
- type e 'a = 'x;
- value create : g -> string -> e 'a;
- value parse : e 'a -> Stream.t char -> 'a;
- value parse_token : e 'a -> Stream.t Token.t -> 'a;
- value name : e 'a -> string;
- value of_parser : g -> string -> (Stream.t Token.t -> 'a) -> e 'a;
- value print : e 'a -> unit;
- value find : e 'a -> string -> e Obj.t;
- external obj : e 'a -> Gramext.g_entry Token.t = "%identity";
- end
-;
- (** Module to handle entries.
-- [Entry.e] is the type for entries returning values of type ['a].
-- [Entry.create g n] creates a new entry named [n] in the grammar [g].
-- [Entry.parse e] returns the stream parser of the entry [e].
-- [Entry.parse_token e] returns the token parser of the entry [e].
-- [Entry.name e] returns the name of the entry [e].
-- [Entry.of_parser g n p] makes an entry from a token stream parser.
-- [Entry.print e] displays the entry [e] using [Format].
-- [Entry.find e s] finds the entry named [s] in [e]'s rules.
-- [Entry.obj e] converts an entry into a [Gramext.g_entry] allowing
-- to see what it holds ([Gramext] is visible, but not documented). *)
-
-value of_entry : Entry.e 'a -> g;
- (** Return the grammar associated with an entry. *)
-
-(** {6 Clearing grammars and entries} *)
-
-module Unsafe :
- sig
- value gram_reinit : g -> Token.glexer Token.t -> unit;
- value clear_entry : Entry.e 'a -> unit;
- (**/**)
- (* deprecated since version 3.05; use rather function [gram_reinit] *)
- value reinit_gram : g -> Token.lexer -> unit;
- end
-;
- (** Module for clearing grammars and entries. To be manipulated with
- care, because: 1) reinitializing a grammar destroys all tokens
- and there may have problems with the associated lexer if it has
- a notion of keywords; 2) clearing an entry does not destroy the
- tokens used only by itself.
-- [Unsafe.reinit_gram g lex] removes the tokens of the grammar
-- and sets [lex] as a new lexer for [g]. Warning: the lexer
-- itself is not reinitialized.
-- [Unsafe.clear_entry e] removes all rules of the entry [e]. *)
-
-(** {6 Functorial interface} *)
-
- (** Alternative for grammars use. Grammars are no more Ocaml values:
- there is no type for them. Modules generated preserve the
- rule "an entry cannot call an entry of another grammar" by
- normal OCaml typing. *)
-
-module type GLexerType =
- sig
- type te = 'x;
- value lexer : Token.glexer te;
- end;
- (** The input signature for the functor [Grammar.GMake]: [te] is the
- type of the tokens. *)
-
-module type S =
- sig
- type te = 'x;
- type parsable = 'x;
- value parsable : Stream.t char -> parsable;
- value tokens : string -> list (string * int);
- value glexer : Token.glexer te;
- module Entry :
- sig
- type e 'a = 'y;
- value create : string -> e 'a;
- value parse : e 'a -> parsable -> 'a;
- value parse_token : e 'a -> Stream.t te -> 'a;
- value name : e 'a -> string;
- value of_parser : string -> (Stream.t te -> 'a) -> e 'a;
- value print : e 'a -> unit;
- external obj : e 'a -> Gramext.g_entry te = "%identity";
- end
- ;
- module Unsafe :
- sig
- value gram_reinit : Token.glexer te -> unit;
- value clear_entry : Entry.e 'a -> unit;
- (**/**)
- (* deprecated since version 3.05; use rather [gram_reinit] *)
- (* warning: [reinit_gram] fails if used with GMake *)
- value reinit_gram : Token.lexer -> unit;
- end
- ;
- value extend :
- Entry.e 'a -> option Gramext.position ->
- list
- (option string * option Gramext.g_assoc *
- list (list (Gramext.g_symbol te) * Gramext.g_action)) ->
- unit;
- value delete_rule : Entry.e 'a -> list (Gramext.g_symbol te) -> unit;
- end
-;
- (** Signature type of the functor [Grammar.GMake]. The types and
- functions are almost the same than in generic interface, but:
-- Grammars are not values. Functions holding a grammar as parameter
- do not have this parameter yet.
-- The type [parsable] is used in function [parse] instead of
- the char stream, avoiding the possible loss of tokens.
-- The type of tokens (expressions and patterns) can be any
- type (instead of (string * string)); the module parameter
- must specify a way to show them as (string * string) *)
-
-module GMake (L : GLexerType) : S with type te = L.te;
-
-(** {6 Miscellaneous} *)
-
-value error_verbose : ref bool;
- (** Flag for displaying more information in case of parsing error;
- default = [False] *)
-
-value warning_verbose : ref bool;
- (** Flag for displaying warnings while extension; default = [True] *)
-
-value strict_parsing : ref bool;
- (** Flag to apply strict parsing, without trying to recover errors;
- default = [False] *)
-
-value print_entry : Format.formatter -> Gramext.g_entry 'te -> unit;
- (** General printer for all kinds of entries (obj entries) *)
-
-value iter_entry :
- (Gramext.g_entry 'te -> unit) -> Gramext.g_entry 'te -> unit;
- (** [Grammar.iter_entry f e] applies [f] to the entry [e] and
- transitively all entries called by [e]. The order in which
- the entries are passed to [f] is the order they appear in
- each entry. Each entry is passed only once. *)
-
-value fold_entry :
- (Gramext.g_entry 'te -> 'a -> 'a) -> Gramext.g_entry 'te -> 'a -> 'a;
- (** [Grammar.fold_entry f e init] computes [(f eN .. (f e2 (f e1 init)))],
- where [e1 .. eN] are [e] and transitively all entries called by [e].
- The order in which the entries are passed to [f] is the order they
- appear in each entry. Each entry is passed only once. *)
-
-(**/**)
-
-(*** deprecated since version 3.05; use rather the functor GMake *)
-module type LexerType = sig value lexer : Token.lexer; end;
-module Make (L : LexerType) : S with type te = Token.t;
-(*** deprecated since version 3.05; use rather the function gcreate *)
-value create : Token.lexer -> g;
-
-(*** For system use *)
-
-value loc_of_token_interval : int -> int -> (int * int);
-value extend :
- list
- (Gramext.g_entry 'te * option Gramext.position *
- list
- (option string * option Gramext.g_assoc *
- list (list (Gramext.g_symbol 'te) * Gramext.g_action))) ->
- unit;
-value delete_rule : Entry.e 'a -> list (Gramext.g_symbol Token.t) -> unit;
-
-value parse_top_symb :
- Gramext.g_entry 'te -> Gramext.g_symbol 'te -> Stream.t 'te -> Obj.t;
-value symb_failed_txt :
- Gramext.g_entry 'te -> Gramext.g_symbol 'te -> Gramext.g_symbol 'te ->
- string;
diff --git a/camlp4/lib/plexer.ml b/camlp4/lib/plexer.ml
deleted file mode 100644
index 329380b267..0000000000
--- a/camlp4/lib/plexer.ml
+++ /dev/null
@@ -1,1006 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Stdpp;
-open Token;
-
-value no_quotations = ref False;
-
-(* The string buffering machinery *)
-
-value buff = ref (String.create 80);
-value store len x =
- do {
- if len >= String.length buff.val then
- buff.val := buff.val ^ String.create (String.length buff.val)
- else ();
- buff.val.[len] := x;
- succ len
- }
-;
-value mstore len s =
- add_rec len 0 where rec add_rec len i =
- if i == String.length s then len else add_rec (store len s.[i]) (succ i)
-;
-value get_buff len = String.sub buff.val 0 len;
-
-(* The lexer *)
-
-value stream_peek_nth n strm =
- loop n (Stream.npeek n strm) where rec loop n =
- fun
- [ [] -> None
- | [x] -> if n == 1 then Some x else None
- | [_ :: l] -> loop (n - 1) l ]
-;
-
-value rec ident len =
- parser
- [ [: `('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
- '\248'..'\255' | '0'..'9' | '_' | ''' as
- c)
- ;
- s :] ->
- ident (store len c) s
- | [: :] -> len ]
-and ident2 len =
- parser
- [ [: `('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
- '%' | '.' | ':' | '<' | '>' | '|' | '$' as
- c)
- ;
- s :] ->
- ident2 (store len c) s
- | [: :] -> len ]
-and ident3 len =
- parser
- [ [: `('0'..'9' | 'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
- '\248'..'\255' | '_' | '!' | '%' | '&' | '*' | '+' | '-' | '.' |
- '/' | ':' | '<' | '=' | '>' | '?' | '@' | '^' | '|' | '~' | ''' |
- '$' as
- c)
- ;
- s :] ->
- ident3 (store len c) s
- | [: :] -> len ]
-and base_number len =
- parser
- [ [: `'o' | 'O'; s :] -> digits octal (store len 'o') s
- | [: `'x' | 'X'; s :] -> digits hexa (store len 'x') s
- | [: `'b' | 'B'; s :] -> digits binary (store len 'b') s
- | [: a = number len :] -> a ]
-and digits kind len =
- parser
- [ [: d = kind; s :] -> digits_under kind (store len d) s
- | [: :] -> raise (Stream.Error "ill-formed integer constant") ]
-and digits_under kind len =
- parser
- [ [: d = kind; s :] -> digits_under kind (store len d) s
- | [: `'_'; s :] -> digits_under kind len s
- | [: :] -> ("INT", get_buff len) ]
-and octal = parser [ [: `('0'..'7' as d) :] -> d ]
-and hexa = parser [ [: `('0'..'9' | 'a'..'f' | 'A'..'F' as d) :] -> d ]
-and binary = parser [ [: `('0'..'1' as d) :] -> d ]
-and number len =
- parser
- [ [: `('0'..'9' as c); s :] -> number (store len c) s
- | [: `'_'; s :] -> number len s
- | [: `'.'; s :] -> decimal_part (store len '.') s
- | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s
- | [: `'l' :] -> ("INT32", get_buff len)
- | [: `'L' :] -> ("INT64", get_buff len)
- | [: `'n' :] -> ("NATIVEINT", get_buff len)
- | [: :] -> ("INT", get_buff len) ]
-and decimal_part len =
- parser
- [ [: `('0'..'9' as c); s :] -> decimal_part (store len c) s
- | [: `'_'; s :] -> decimal_part len s
- | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s
- | [: :] -> ("FLOAT", get_buff len) ]
-and exponent_part len =
- parser
- [ [: `('+' | '-' as c); s :] -> end_exponent_part (store len c) s
- | [: a = end_exponent_part len :] -> a ]
-and end_exponent_part len =
- parser
- [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (store len c) s
- | [: :] -> raise (Stream.Error "ill-formed floating-point constant") ]
-and end_exponent_part_under len =
- parser
- [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (store len c) s
- | [: `'_'; s :] -> end_exponent_part_under len s
- | [: :] -> ("FLOAT", get_buff len) ]
-;
-
-value error_on_unknown_keywords = ref False;
-value err loc msg = raise_with_loc loc (Token.Error msg);
-
-(*
-value next_token_fun dfa find_kwd =
- let keyword_or_error loc s =
- try (("", find_kwd s), loc) with
- [ Not_found ->
- if error_on_unknown_keywords.val then err loc ("illegal token: " ^ s)
- else (("", s), loc) ]
- in
- let rec next_token =
- parser bp
- [ [: `' ' | '\010' | '\013' | '\t' | '\026' | '\012'; s :] ->
- next_token s
- | [: `'('; s :] -> left_paren bp s
- | [: `'#'; s :] -> do { spaces_tabs s; linenum bp s }
- | [: `('A'..'Z' | '\192'..'\214' | '\216'..'\222' as c); s :] ->
- let id = get_buff (ident (store 0 c) s) in
- let loc = (bp, Stream.count s) in
- (try ("", find_kwd id) with [ Not_found -> ("UIDENT", id) ], loc)
- | [: `('a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' as c); s :] ->
- let id = get_buff (ident (store 0 c) s) in
- let loc = (bp, Stream.count s) in
- (try ("", find_kwd id) with [ Not_found -> ("LIDENT", id) ], loc)
- | [: `('1'..'9' as c); s :] ->
- let tok = number (store 0 c) s in
- let loc = (bp, Stream.count s) in
- (tok, loc)
- | [: `'0'; s :] ->
- let tok = base_number (store 0 '0') s in
- let loc = (bp, Stream.count s) in
- (tok, loc)
- | [: `'''; s :] ->
- match Stream.npeek 3 s with
- [ [_; '''; _] | ['\\'; _; _] | ['\x0D'; '\x0A'; '''] ->
- let tok = ("CHAR", get_buff (char bp 0 s)) in
- let loc = (bp, Stream.count s) in
- (tok, loc)
- | _ -> keyword_or_error (bp, Stream.count s) "'" ]
- | [: `'"'; s :] ->
- let tok = ("STRING", get_buff (string bp 0 s)) in
- let loc = (bp, Stream.count s) in
- (tok, loc)
- | [: `'$'; s :] ->
- let tok = dollar bp 0 s in
- let loc = (bp, Stream.count s) in
- (tok, loc)
- | [: `('!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c);
- s :] ->
- let id = get_buff (ident2 (store 0 c) s) in
- keyword_or_error (bp, Stream.count s) id
- | [: `('~' as c);
- a =
- parser
- [ [: `('a'..'z' as c); len = ident (store 0 c) :] ep ->
- (("TILDEIDENT", get_buff len), (bp, ep))
- | [: s :] ->
- let id = get_buff (ident2 (store 0 c) s) in
- keyword_or_error (bp, Stream.count s) id ] :] ->
- a
- | [: `('?' as c);
- a =
- parser
- [ [: `('a'..'z' as c); len = ident (store 0 c) :] ep ->
- (("QUESTIONIDENT", get_buff len), (bp, ep))
- | [: s :] ->
- let id = get_buff (ident2 (store 0 c) s) in
- keyword_or_error (bp, Stream.count s) id ] :] ->
- a
- | [: `'<'; s :] -> less bp s
- | [: `(':' as c1);
- len =
- parser
- [ [: `(']' | ':' | '=' | '>' as c2) :] -> store (store 0 c1) c2
- | [: :] -> store 0 c1 ] :] ep ->
- let id = get_buff len in
- keyword_or_error (bp, ep) id
- | [: `('>' | '|' as c1);
- len =
- parser
- [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2
- | [: a = ident2 (store 0 c1) :] -> a ] :] ep ->
- let id = get_buff len in
- keyword_or_error (bp, ep) id
- | [: `('[' | '{' as c1); s :] ->
- let len =
- match Stream.npeek 2 s with
- [ ['<'; '<' | ':'] -> store 0 c1
- | _ ->
- match s with parser
- [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2
- | [: :] -> store 0 c1 ] ]
- in
- let ep = Stream.count s in
- let id = get_buff len in
- keyword_or_error (bp, ep) id
- | [: `'.';
- id =
- parser
- [ [: `'.' :] -> ".."
- | [: :] -> if ssd && after_space then " ." else "." ] :] ep ->
- keyword_or_error (bp, ep) id
- | [: `';';
- id =
- parser
- [ [: `';' :] -> ";;"
- | [: :] -> ";" ] :] ep ->
- keyword_or_error (bp, ep) id
- | [: `'\\'; s :] ep -> (("LIDENT", get_buff (ident3 0 s)), (bp, ep))
- | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c)
- | [: _ = Stream.empty :] -> (("EOI", ""), (bp, succ bp)) ]
- and less bp strm =
- if no_quotations.val then
- match strm with parser
- [ [: len = ident2 (store 0 '<') :] ep ->
- let id = get_buff len in
- keyword_or_error (bp, ep) id ]
- else
- match strm with parser
- [ [: `'<'; len = quotation bp 0 :] ep ->
- (("QUOTATION", ":" ^ get_buff len), (bp, ep))
- | [: `':'; i = parser [: len = ident 0 :] -> get_buff len;
- `'<' ? "character '<' expected"; len = quotation bp 0 :] ep ->
- (("QUOTATION", i ^ ":" ^ get_buff len), (bp, ep))
- | [: len = ident2 (store 0 '<') :] ep ->
- let id = get_buff len in
- keyword_or_error (bp, ep) id ]
- and string bp len =
- parser
- [ [: `'"' :] -> len
- | [: `'\\'; `c; s :] -> string bp (store (store len '\\') c) s
- | [: `c; s :] -> string bp (store len c) s
- | [: :] ep -> err (bp, ep) "string not terminated" ]
- and char bp len =
- parser
- [ [: `'''; s :] -> if len = 0 then char bp (store len ''') s else len
- | [: `'\\'; `c; s :] -> char bp (store (store len '\\') c) s
- | [: `c; s :] -> char bp (store len c) s
- | [: :] ep -> err (bp, ep) "char not terminated" ]
- and dollar bp len =
- parser
- [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
- | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bp (store len c) s
- | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s
- | [: `':'; s :] ->
- let k = get_buff len in
- ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s)
- | [: `'\\'; `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: s :] ->
- if dfa then
- match s with parser
- [ [: `c :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
- else ("", get_buff (ident2 (store 0 '$') s)) ]
- and maybe_locate bp len =
- parser
- [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
- | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s
- | [: `':'; s :] ->
- ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 s)
- | [: `'\\'; `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
- and antiquot bp len =
- parser
- [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
- | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] ->
- antiquot bp (store len c) s
- | [: `':'; s :] ->
- let k = get_buff len in
- ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s)
- | [: `'\\'; `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
- and locate_or_antiquot_rest bp len =
- parser
- [ [: `'$' :] -> get_buff len
- | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bp (store len c) s
- | [: `c; s :] -> locate_or_antiquot_rest bp (store len c) s
- | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
- and quotation bp len =
- parser
- [ [: `'>'; s :] -> maybe_end_quotation bp len s
- | [: `'<'; s :] ->
- quotation bp (maybe_nested_quotation bp (store len '<') s) s
- | [: `'\\';
- len =
- parser
- [ [: `('>' | '<' | '\\' as c) :] -> store len c
- | [: :] -> store len '\\' ];
- s :] ->
- quotation bp len s
- | [: `c; s :] -> quotation bp (store len c) s
- | [: :] ep -> err (bp, ep) "quotation not terminated" ]
- and maybe_nested_quotation bp len =
- parser
- [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>"
- | [: `':'; len = ident (store len ':');
- a =
- parser
- [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>"
- | [: :] -> len ] :] ->
- a
- | [: :] -> len ]
- and maybe_end_quotation bp len =
- parser
- [ [: `'>' :] -> len
- | [: a = quotation bp (store len '>') :] -> a ]
- and left_paren bp =
- parser
- [ [: `'*'; _ = comment bp; a = next_token True :] -> a
- | [: :] ep -> keyword_or_error (bp, ep) "(" ]
- and comment bp =
- parser
- [ [: `'('; s :] -> left_paren_in_comment bp s
- | [: `'*'; s :] -> star_in_comment bp s
- | [: `'"'; _ = string bp 0; s :] -> comment bp s
- | [: `'''; s :] -> quote_in_comment bp s
- | [: `c; s :] -> comment bp s
- | [: :] ep -> err (bp, ep) "comment not terminated" ]
- and quote_in_comment bp =
- parser
- [ [: `'''; s :] -> comment bp s
- | [: `'\013'; s :] -> quote_cr_in_comment bp s
- | [: `'\\'; s :] -> quote_antislash_in_comment bp s
- | [: `'('; s :] -> quote_left_paren_in_comment bp s
- | [: `'*'; s :] -> quote_star_in_comment bp s
- | [: `'"'; s :] -> quote_doublequote_in_comment bp s
- | [: `_; s :] -> quote_any_in_comment bp s
- | [: s :] -> comment bp s ]
- and quote_any_in_comment bp =
- parser
- [ [: `'''; s :] -> comment bp s
- | [: s :] -> comment bp s ]
- and quote_cr_in_comment bp =
- parser
- [ [: `'\010'; s :] -> quote_any_in_comment bp s
- | [: s :] -> quote_any_in_comment bp s ]
- and quote_left_paren_in_comment bp =
- parser
- [ [: `'''; s :] -> comment bp s
- | [: s :] -> left_paren_in_comment bp s ]
- and quote_star_in_comment bp =
- parser
- [ [: `'''; s :] -> comment bp s
- | [: s :] -> star_in_comment bp s ]
- and quote_doublequote_in_comment bp =
- parser
- [ [: `'''; s :] -> comment bp s
- | [: _ = string bp 0; s :] -> comment bp s ]
- and quote_antislash_in_comment bp =
- parser
- [ [: `'''; s :] -> quote_antislash_quote_in_comment bp s
- | [: `('\\' | '"' | 'n' | 't' | 'b' | 'r'); s :] ->
- quote_any_in_comment bp s
- | [: `('0'..'9'); s :] -> quote_antislash_digit_in_comment bp s
- | [: `'x'; s :] -> quote_antislash_x_in_comment bp s
- | [: s :] -> comment bp s ]
- and quote_antislash_quote_in_comment bp =
- parser
- [ [: `'''; s :] -> comment bp s
- | [: s :] -> quote_in_comment bp s ]
- and quote_antislash_digit_in_comment bp =
- parser
- [ [: `('0'..'9'); s :] -> quote_antislash_digit2_in_comment bp s
- | [: s :] -> comment bp s ]
- and quote_antislash_digit2_in_comment bp =
- parser
- [ [: `('0'..'9'); s :] -> quote_any_in_comment bp s
- | [: s :] -> comment bp s ]
- and quote_antislash_x_in_comment bp =
- parser
- [ [: _ = hexa; s :] -> quote_antislash_x_digit_in_comment bp s
- | [: s :] -> comment bp s ]
- and quote_antislash_x_digit_in_comment bp =
- parser
- [ [: _ = hexa; s :] -> quote_any_in_comment bp s
- | [: s :] -> comment bp s ]
- and left_paren_in_comment bp =
- parser
- [ [: `'*'; s :] -> do { comment bp s; comment bp s }
- | [: a = comment bp :] -> a ]
- and star_in_comment bp =
- parser
- [ [: `')' :] -> ()
- | [: a = comment bp :] -> a ]
- and linedir n s =
- match stream_peek_nth n s with
- [ Some (' ' | '\t') -> linedir (n + 1) s
- | Some ('0'..'9') -> linedir_digits (n + 1) s
- | _ -> False ]
- and linedir_digits n s =
- match stream_peek_nth n s with
- [ Some ('0'..'9') -> linedir_digits (n + 1) s
- | _ -> linedir_quote n s ]
- and linedir_quote n s =
- match stream_peek_nth n s with
- [ Some (' ' | '\t') -> linedir_quote (n + 1) s
- | Some '"' -> True
- | _ -> False ]
- and any_to_nl =
- parser
- [ [: `'\013' | '\010' :] ep -> bolpos.val := ep
- | [: `_; s :] -> any_to_nl s
- | [: :] -> () ]
- in
- fun cstrm ->
- try
- let glex = glexr.val in
- let comm_bp = Stream.count cstrm in
- let r = next_token False cstrm in
- do {
- match glex.tok_comm with
- [ Some list ->
- if fst (snd r) > comm_bp then
- let comm_loc = (comm_bp, fst (snd r)) in
- glex.tok_comm := Some [comm_loc :: list]
- else ()
- | None -> () ];
- r
- }
- with
- [ Stream.Error str ->
- err (Stream.count cstrm, Stream.count cstrm + 1) str ]
-;
-*)
-
-value next_token_fun dfa ssd find_kwd bolpos glexr =
- let keyword_or_error loc s =
- try (("", find_kwd s), loc) with
- [ Not_found ->
- if error_on_unknown_keywords.val then err loc ("illegal token: " ^ s)
- else (("", s), loc) ] in
- let error_if_keyword ( ((_,id), loc) as a) =
- try do {
- ignore(find_kwd id);
- err loc ("illegal use of a keyword as a label: " ^ id) }
- with [ Not_found -> a ]
- in
- let rec next_token after_space =
- parser bp
- [ [: `'\010' | '\013'; s :] ep ->
- do { bolpos.val := ep; next_token True s }
- | [: `' ' | '\t' | '\026' | '\012'; s :] -> next_token True s
- | [: `'#' when bp = bolpos.val; s :] ->
- if linedir 1 s then do { any_to_nl s; next_token True s }
- else keyword_or_error (bp, bp + 1) "#"
- | [: `'('; s :] -> left_paren bp s
- | [: `('A'..'Z' | '\192'..'\214' | '\216'..'\222' as c); s :] ->
- let id = get_buff (ident (store 0 c) s) in
- let loc = (bp, Stream.count s) in
- (try ("", find_kwd id) with [ Not_found -> ("UIDENT", id) ], loc)
- | [: `('a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' as c); s :] ->
- let id = get_buff (ident (store 0 c) s) in
- let loc = (bp, Stream.count s) in
- (try ("", find_kwd id) with [ Not_found -> ("LIDENT", id) ], loc)
- | [: `('1'..'9' as c); s :] ->
- let tok = number (store 0 c) s in
- let loc = (bp, Stream.count s) in
- (tok, loc)
- | [: `'0'; s :] ->
- let tok = base_number (store 0 '0') s in
- let loc = (bp, Stream.count s) in
- (tok, loc)
- | [: `'''; s :] ->
- match Stream.npeek 2 s with
- [ [_; '''] | ['\\'; _] ->
- let tok = ("CHAR", get_buff (char bp 0 s)) in
- let loc = (bp, Stream.count s) in
- (tok, loc)
- | _ -> keyword_or_error (bp, Stream.count s) "'" ]
- | [: `'"'; s :] ->
- let tok = ("STRING", get_buff (string bp 0 s)) in
- let loc = (bp, Stream.count s) in
- (tok, loc)
- | [: `'$'; s :] ->
- let tok = dollar bp 0 s in
- let loc = (bp, Stream.count s) in
- (tok, loc)
- | [: `('!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c);
- s :] ->
- let id = get_buff (ident2 (store 0 c) s) in
- keyword_or_error (bp, Stream.count s) id
- | [: `('~' as c);
- a =
- parser
- [ [: `('a'..'z' as c); len = ident (store 0 c); s :] ep ->
- let id = get_buff len in
- match s with parser
- [ [: `':' :] eb -> error_if_keyword (("LABEL", id), (bp,ep))
- | [: :] -> error_if_keyword (("TILDEIDENT", id), (bp, ep)) ]
- | [: s :] ->
- let id = get_buff (ident2 (store 0 c) s) in
- keyword_or_error (bp, Stream.count s) id ] :] ->
- a
-
- | [: `('?' as c);
- a =
- parser
- [ [: `('a'..'z' as c); len = ident (store 0 c); s :] ep ->
- let id = get_buff len in
- match s with parser
- [ [: `':' :] eb -> error_if_keyword (("OPTLABEL", id), (bp,ep))
- | [: :] -> error_if_keyword (("QUESTIONIDENT", id), (bp, ep)) ]
- | [: s :] ->
- let id = get_buff (ident2 (store 0 c) s) in
- keyword_or_error (bp, Stream.count s) id ] :] ->
- a
- | [: `'<'; s :] -> less bp s
- | [: `(':' as c1);
- len =
- parser
- [ [: `(']' | ':' | '=' | '>' as c2) :] -> store (store 0 c1) c2
- | [: :] -> store 0 c1 ] :] ep ->
- let id = get_buff len in
- keyword_or_error (bp, ep) id
- | [: `('>' | '|' as c1);
- len =
- parser
- [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2
- | [: a = ident2 (store 0 c1) :] -> a ] :] ep ->
- let id = get_buff len in
- keyword_or_error (bp, ep) id
- | [: `('[' | '{' as c1); s :] ->
- let len =
- match Stream.npeek 2 s with
- [ ['<'; '<' | ':'] -> store 0 c1
- | _ ->
- match s with parser
- [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2
- | [: :] -> store 0 c1 ] ]
- in
- let ep = Stream.count s in
- let id = get_buff len in
- keyword_or_error (bp, ep) id
- | [: `'.';
- id =
- parser
- [ [: `'.' :] -> ".."
- | [: :] -> if ssd && after_space then " ." else "." ] :] ep ->
- keyword_or_error (bp, ep) id
- | [: `';';
- id =
- parser
- [ [: `';' :] -> ";;"
- | [: :] -> ";" ] :] ep ->
- keyword_or_error (bp, ep) id
- | [: `'\\'; s :] ep -> (("LIDENT", get_buff (ident3 0 s)), (bp, ep))
- | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c)
- | [: _ = Stream.empty :] -> (("EOI", ""), (bp, succ bp)) ]
- and less bp strm =
- if no_quotations.val then
- match strm with parser
- [ [: len = ident2 (store 0 '<') :] ep ->
- let id = get_buff len in
- keyword_or_error (bp, ep) id ]
- else
- match strm with parser
- [ [: `'<'; len = quotation bp 0 :] ep ->
- (("QUOTATION", ":" ^ get_buff len), (bp, ep))
- | [: `':'; i = parser [: len = ident 0 :] -> get_buff len;
- `'<' ? "character '<' expected"; len = quotation bp 0 :] ep ->
- (("QUOTATION", i ^ ":" ^ get_buff len), (bp, ep))
- | [: len = ident2 (store 0 '<') :] ep ->
- let id = get_buff len in
- keyword_or_error (bp, ep) id ]
- and string bp len =
- parser
- [ [: `'"' :] -> len
- | [: `'\\'; `c; s :] ep -> string bp (store (store len '\\') c) s
- | [: `c; s :] -> string bp (store len c) s
- | [: :] ep -> err (bp, ep) "string not terminated" ]
- and char bp len =
- parser
- [ [: `'''; s :] -> if len = 0 then char bp (store len ''') s else len
- | [: `'\\'; `c; s :] -> char bp (store (store len '\\') c) s
- | [: `c; s :] -> char bp (store len c) s
- | [: :] ep -> err (bp, ep) "char not terminated" ]
- and dollar bp len =
- parser
- [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
- | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bp (store len c) s
- | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s
- | [: `':'; s :] ->
- let k = get_buff len in
- ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s)
- | [: `'\\'; `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: s :] ->
- if dfa then
- match s with parser
- [ [: `c :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
- else ("", get_buff (ident2 (store 0 '$') s)) ]
- and maybe_locate bp len =
- parser
- [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
- | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s
- | [: `':'; s :] ->
- ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 s)
- | [: `'\\'; `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
- and antiquot bp len =
- parser
- [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
- | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] ->
- antiquot bp (store len c) s
- | [: `':'; s :] ->
- let k = get_buff len in
- ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s)
- | [: `'\\'; `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
- and locate_or_antiquot_rest bp len =
- parser
- [ [: `'$' :] -> get_buff len
- | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bp (store len c) s
- | [: `c; s :] -> locate_or_antiquot_rest bp (store len c) s
- | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
- and quotation bp len =
- parser
- [ [: `'>'; s :] -> maybe_end_quotation bp len s
- | [: `'<'; s :] ->
- quotation bp (maybe_nested_quotation bp (store len '<') s) s
- | [: `'\\';
- len =
- parser
- [ [: `('>' | '<' | '\\' as c) :] -> store len c
- | [: :] -> store len '\\' ];
- s :] ->
- quotation bp len s
- | [: `c; s :] -> quotation bp (store len c) s
- | [: :] ep -> err (bp, ep) "quotation not terminated" ]
- and maybe_nested_quotation bp len =
- parser
- [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>"
- | [: `':'; len = ident (store len ':');
- a =
- parser
- [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>"
- | [: :] -> len ] :] ->
- a
- | [: :] -> len ]
- and maybe_end_quotation bp len =
- parser
- [ [: `'>' :] -> len
- | [: a = quotation bp (store len '>') :] -> a ]
- and left_paren bp =
- parser
- [ [: `'*'; _ = comment bp; a = next_token True :] -> a
- | [: :] ep -> keyword_or_error (bp, ep) "(" ]
- and comment bp =
- parser
- [ [: `'('; s :] -> left_paren_in_comment bp s
- | [: `'*'; s :] -> star_in_comment bp s
- | [: `'"'; _ = string bp 0; s :] -> comment bp s
- | [: `'''; s :] -> quote_in_comment bp s
- | [: `c; s :] -> comment bp s
- | [: :] ep -> err (bp, ep) "comment not terminated" ]
- and quote_in_comment bp =
- parser
- [ [: `'''; s :] -> comment bp s
- | [: `'\\'; s :] -> quote_antislash_in_comment bp 0 s
- | [: s :] ->
- do {
- match Stream.npeek 2 s with
- [ [_; '''] -> do { Stream.junk s; Stream.junk s }
- | _ -> () ];
- comment bp s
- } ]
- and quote_any_in_comment bp =
- parser
- [ [: `'''; s :] -> comment bp s
- | [: a = comment bp :] -> a ]
- and quote_antislash_in_comment bp len =
- parser
- [ [: `'''; s :] -> comment bp s
- | [: `'\\' | '"' | 'n' | 't' | 'b' | 'r'; s :] ->
- quote_any_in_comment bp s
- | [: `'0'..'9'; s :] -> quote_antislash_digit_in_comment bp s
- | [: a = comment bp :] -> a ]
- and quote_antislash_digit_in_comment bp =
- parser
- [ [: `'0'..'9'; s :] -> quote_antislash_digit2_in_comment bp s
- | [: a = comment bp :] -> a ]
- and quote_antislash_digit2_in_comment bp =
- parser
- [ [: `'0'..'9'; s :] -> quote_any_in_comment bp s
- | [: a = comment bp :] -> a ]
- and left_paren_in_comment bp =
- parser
- [ [: `'*'; s :] -> do { comment bp s; comment bp s }
- | [: a = comment bp :] -> a ]
- and star_in_comment bp =
- parser
- [ [: `')' :] -> ()
- | [: a = comment bp :] -> a ]
- and linedir n s =
- match stream_peek_nth n s with
- [ Some (' ' | '\t') -> linedir (n + 1) s
- | Some ('0'..'9') -> linedir_digits (n + 1) s
- | _ -> False ]
- and linedir_digits n s =
- match stream_peek_nth n s with
- [ Some ('0'..'9') -> linedir_digits (n + 1) s
- | _ -> linedir_quote n s ]
- and linedir_quote n s =
- match stream_peek_nth n s with
- [ Some (' ' | '\t') -> linedir_quote (n + 1) s
- | Some '"' -> True
- | _ -> False ]
- and any_to_nl =
- parser
- [ [: `'\013' | '\010' :] ep -> bolpos.val := ep
- | [: `_; s :] -> any_to_nl s
- | [: :] -> () ]
- in
- fun cstrm ->
- try
- let glex = glexr.val in
- let comm_bp = Stream.count cstrm in
- let r = next_token False cstrm in
- do {
- match glex.tok_comm with
- [ Some list ->
- if fst (snd r) > comm_bp then
- let comm_loc = (comm_bp, fst (snd r)) in
- glex.tok_comm := Some [comm_loc :: list]
- else ()
- | None -> () ];
- r
- }
- with
- [ Stream.Error str ->
- err (Stream.count cstrm, Stream.count cstrm + 1) str ]
-;
-
-
-value dollar_for_antiquotation = ref True;
-value specific_space_dot = ref False;
-
-value func kwd_table glexr =
- let bolpos = ref 0 in
- let find = Hashtbl.find kwd_table in
- let dfa = dollar_for_antiquotation.val in
- let ssd = specific_space_dot.val in
- Token.lexer_func_of_parser (next_token_fun dfa ssd find bolpos glexr)
-;
-
-value rec check_keyword_stream =
- parser [: _ = check; _ = Stream.empty :] -> True
-and check =
- parser
- [ [: `'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | '\248'..'\255'
- ;
- s :] ->
- check_ident s
- | [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
- '%' | '.'
- ;
- s :] ->
- check_ident2 s
- | [: `'<'; s :] ->
- match Stream.npeek 1 s with
- [ [':' | '<'] -> ()
- | _ -> check_ident2 s ]
- | [: `':';
- _ =
- parser
- [ [: `']' | ':' | '=' | '>' :] -> ()
- | [: :] -> () ] :] ep ->
- ()
- | [: `'>' | '|';
- _ =
- parser
- [ [: `']' | '}' :] -> ()
- | [: a = check_ident2 :] -> a ] :] ->
- ()
- | [: `'[' | '{'; s :] ->
- match Stream.npeek 2 s with
- [ ['<'; '<' | ':'] -> ()
- | _ ->
- match s with parser
- [ [: `'|' | '<' | ':' :] -> ()
- | [: :] -> () ] ]
- | [: `';';
- _ =
- parser
- [ [: `';' :] -> ()
- | [: :] -> () ] :] ->
- ()
- | [: `_ :] -> () ]
-and check_ident =
- parser
- [ [: `'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
- '\248'..'\255' | '0'..'9' | '_' | '''
- ;
- s :] ->
- check_ident s
- | [: :] -> () ]
-and check_ident2 =
- parser
- [ [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
- '%' | '.' | ':' | '<' | '>' | '|'
- ;
- s :] ->
- check_ident2 s
- | [: :] -> () ]
-;
-
-value check_keyword s =
- try check_keyword_stream (Stream.of_string s) with _ -> False
-;
-
-value error_no_respect_rules p_con p_prm =
- raise
- (Token.Error
- ("the token " ^
- (if p_con = "" then "\"" ^ p_prm ^ "\""
- else if p_prm = "" then p_con
- else p_con ^ " \"" ^ p_prm ^ "\"") ^
- " does not respect Plexer rules"))
-;
-
-value error_ident_and_keyword p_con p_prm =
- raise
- (Token.Error
- ("the token \"" ^ p_prm ^ "\" is used as " ^ p_con ^
- " and as keyword"))
-;
-
-value using_token kwd_table ident_table (p_con, p_prm) =
- match p_con with
- [ "" ->
- if not (Hashtbl.mem kwd_table p_prm) then
- if check_keyword p_prm then
- if Hashtbl.mem ident_table p_prm then
- error_ident_and_keyword (Hashtbl.find ident_table p_prm) p_prm
- else Hashtbl.add kwd_table p_prm p_prm
- else error_no_respect_rules p_con p_prm
- else ()
- | "LIDENT" ->
- if p_prm = "" then ()
- else
- match p_prm.[0] with
- [ 'A'..'Z' -> error_no_respect_rules p_con p_prm
- | _ ->
- if Hashtbl.mem kwd_table p_prm then
- error_ident_and_keyword p_con p_prm
- else Hashtbl.add ident_table p_prm p_con ]
- | "UIDENT" ->
- if p_prm = "" then ()
- else
- match p_prm.[0] with
- [ 'a'..'z' -> error_no_respect_rules p_con p_prm
- | _ ->
- if Hashtbl.mem kwd_table p_prm then
- error_ident_and_keyword p_con p_prm
- else Hashtbl.add ident_table p_prm p_con ]
- | "INT" | "INT32" | "INT64" | "NATIVEINT"
- | "FLOAT" | "CHAR" | "STRING"
- | "TILDEIDENT" | "QUESTIONIDENT" | "LABEL" | "OPTLABEL"
- | "QUOTATION" | "ANTIQUOT" | "LOCATE" | "EOI" ->
- ()
- | _ ->
- raise
- (Token.Error
- ("the constructor \"" ^ p_con ^
- "\" is not recognized by Plexer")) ]
-;
-
-value removing_token kwd_table ident_table (p_con, p_prm) =
- match p_con with
- [ "" -> Hashtbl.remove kwd_table p_prm
- | "LIDENT" | "UIDENT" ->
- if p_prm <> "" then Hashtbl.remove ident_table p_prm else ()
- | _ -> () ]
-;
-
-value text =
- fun
- [ ("", t) -> "'" ^ t ^ "'"
- | ("LIDENT", "") -> "lowercase identifier"
- | ("LIDENT", t) -> "'" ^ t ^ "'"
- | ("UIDENT", "") -> "uppercase identifier"
- | ("UIDENT", t) -> "'" ^ t ^ "'"
- | ("INT", "") -> "integer"
- | ("INT32", "") -> "32 bits integer"
- | ("INT64", "") -> "64 bits integer"
- | ("NATIVEINT", "") -> "native integer"
- | (("INT" | "INT32" | "NATIVEINT"), s) -> "'" ^ s ^ "'"
- | ("FLOAT", "") -> "float"
- | ("STRING", "") -> "string"
- | ("CHAR", "") -> "char"
- | ("QUOTATION", "") -> "quotation"
- | ("ANTIQUOT", k) -> "antiquot \"" ^ k ^ "\""
- | ("LOCATE", "") -> "locate"
- | ("EOI", "") -> "end of input"
- | (con, "") -> con
- | (con, prm) -> con ^ " \"" ^ prm ^ "\"" ]
-;
-
-value eq_before_colon p e =
- loop 0 where rec loop i =
- if i == String.length e then
- failwith "Internal error in Plexer: incorrect ANTIQUOT"
- else if i == String.length p then e.[i] == ':'
- else if p.[i] == e.[i] then loop (i + 1)
- else False
-;
-
-value after_colon e =
- try
- let i = String.index e ':' in
- String.sub e (i + 1) (String.length e - i - 1)
- with
- [ Not_found -> "" ]
-;
-
-value tok_match =
- fun
- [ ("ANTIQUOT", p_prm) ->
- fun
- [ ("ANTIQUOT", prm) when eq_before_colon p_prm prm -> after_colon prm
- | _ -> raise Stream.Failure ]
- | tok -> Token.default_match tok ]
-;
-
-value gmake () =
- let kwd_table = Hashtbl.create 301 in
- let id_table = Hashtbl.create 301 in
- let glexr =
- ref
- {tok_func = fun []; tok_using = fun []; tok_removing = fun [];
- tok_match = fun []; tok_text = fun []; tok_comm = None}
- in
- let glex =
- {tok_func = func kwd_table glexr;
- tok_using = using_token kwd_table id_table;
- tok_removing = removing_token kwd_table id_table; tok_match = tok_match;
- tok_text = text; tok_comm = None}
- in
- do { glexr.val := glex; glex }
-;
-
-value tparse =
- fun
- [ ("ANTIQUOT", p_prm) ->
- let p =
- parser
- [: `("ANTIQUOT", prm) when eq_before_colon p_prm prm :] ->
- after_colon prm
- in
- Some p
- | _ -> None ]
-;
-
-value make () =
- let kwd_table = Hashtbl.create 301 in
- let id_table = Hashtbl.create 301 in
- let glexr =
- ref
- {tok_func = fun []; tok_using = fun []; tok_removing = fun [];
- tok_match = fun []; tok_text = fun []; tok_comm = None}
- in
- {func = func kwd_table glexr; using = using_token kwd_table id_table;
- removing = removing_token kwd_table id_table; tparse = tparse; text = text}
-;
diff --git a/camlp4/lib/plexer.mli b/camlp4/lib/plexer.mli
deleted file mode 100644
index 32d8fe6b8e..0000000000
--- a/camlp4/lib/plexer.mli
+++ /dev/null
@@ -1,72 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** A lexical analyzer. *)
-
-value gmake : unit -> Token.glexer Token.t;
- (** Some lexer provided. See the module [Token]. The tokens returned
- follow the Objective Caml and the Revised syntax lexing rules.
-
- The meaning of the tokens are:
-- * [("", s)] is the keyword [s].
-- * [("LIDENT", s)] is the ident [s] starting with a lowercase letter.
-- * [("UIDENT", s)] is the ident [s] starting with an uppercase letter.
-- * [("INT", s)] (resp. ["INT32"], ["INT64"] and ["NATIVEINT"])
- is an integer constant whose string source is [s].
-- * [("FLOAT", s)] is a float constant whose string source is [s].
-- * [("STRING", s)] is the string constant [s].
-- * [("CHAR", s)] is the character constant [s].
-- * [("QUOTATION", "t:s")] is a quotation [t] holding the string [s].
-- * [("ANTIQUOT", "t:s")] is an antiquotation [t] holding the string [s].
-- * [("LOCATE", "i:s")] is a location directive at pos [i] holding [s].
-- * [("EOI", "")] is the end of input.
-
- The associated token patterns in the EXTEND statement hold the
- same names than the first string (constructor name) of the tokens
- expressions above.
-
- Warning: the string associated with the constructor [STRING] is
- the string found in the source without any interpretation. In
- particular, the backslashes are not interpreted. For example, if
- the input is ["\n"] the string is *not* a string with one
- element containing the character "return", but a string of two
- elements: the backslash and the character ["n"]. To interpret
- a string use the function [Token.eval_string]. Same thing for
- the constructor [CHAR]: to get the character, don't get the
- first character of the string, but use the function
- [Token.eval_char].
-
- The lexer do not use global (mutable) variables: instantiations
- of [Plexer.gmake ()] do not perturb each other. *)
-
-value dollar_for_antiquotation : ref bool;
- (** When True (default), the next call to [Plexer.make ()] returns a
- lexer where the dollar sign is used for antiquotations. If False,
- the dollar sign can be used as token. *)
-
-value specific_space_dot : ref bool;
- (** When False (default), the next call to [Plexer.make ()] returns a
- lexer where the dots can be preceded by spaces. If True, dots
- preceded by spaces return the keyword " ." (space dot), otherwise
- return the keyword "." (dot). *)
-
-value no_quotations : ref bool;
- (** When True, all lexers built by [Plexer.make ()] do not lex the
- quotation syntax any more. Default is False (quotations are
- lexed). *)
-
-(**/**)
-
-(* deprecated since version 3.05; use rather function gmake *)
-value make : unit -> Token.lexer;
diff --git a/camlp4/lib/stdpp.ml b/camlp4/lib/stdpp.ml
deleted file mode 100644
index a89cb15d8e..0000000000
--- a/camlp4/lib/stdpp.ml
+++ /dev/null
@@ -1,79 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-exception Exc_located of (int * int) and exn;
-
-value raise_with_loc loc exc =
- match exc with
- [ Exc_located _ _ -> raise exc
- | _ -> raise (Exc_located loc exc) ]
-;
-
-value line_of_loc fname (bp, ep) =
- try
- let ic = open_in_bin fname in
- let strm = Stream.of_channel ic in
- let rec loop fname lin =
- let rec not_a_line_dir col =
- parser cnt
- [: `c; s :] ->
- if cnt < bp then
- if c = '\n' then loop fname (lin + 1)
- else not_a_line_dir (col + 1) s
- else
- let col = col - (cnt - bp) in
- (fname, lin, col, col + ep - bp)
- in
- let rec a_line_dir str n col =
- parser
- [ [: `'\n' :] -> loop str n
- | [: `_; s :] -> a_line_dir str n (col + 1) s ]
- in
- let rec spaces col =
- parser
- [ [: `' '; s :] -> spaces (col + 1) s
- | [: :] -> col ]
- in
- let rec check_string str n col =
- parser
- [ [: `'"'; col = spaces (col + 1); s :] -> a_line_dir str n col s
- | [: `c when c <> '\n'; s :] ->
- check_string (str ^ String.make 1 c) n (col + 1) s
- | [: a = not_a_line_dir col :] -> a ]
- in
- let check_quote n col =
- parser
- [ [: `'"'; s :] -> check_string "" n (col + 1) s
- | [: a = not_a_line_dir col :] -> a ]
- in
- let rec check_num n col =
- parser
- [ [: `('0'..'9' as c); s :] ->
- check_num (10 * n + Char.code c - Char.code '0') (col + 1) s
- | [: col = spaces col; s :] -> check_quote n col s ]
- in
- let begin_line =
- parser
- [ [: `'#'; col = spaces 1; s :] -> check_num 0 col s
- | [: a = not_a_line_dir 0 :] -> a ]
- in
- begin_line strm
- in
- let r = try loop fname 1 with [ Stream.Failure -> (fname, 1, bp, ep) ] in
- do { close_in ic; r }
- with
- [ Sys_error _ -> (fname, 1, bp, ep) ]
-;
-
-value loc_name = ref "loc";
diff --git a/camlp4/lib/stdpp.mli b/camlp4/lib/stdpp.mli
deleted file mode 100644
index 069e56bee3..0000000000
--- a/camlp4/lib/stdpp.mli
+++ /dev/null
@@ -1,37 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Standard definitions. *)
-
-exception Exc_located of (int * int) and exn;
- (** [Exc_located loc e] is an encapsulation of the exception [e] with
- the input location [loc]. To be used in quotation expanders
- and in grammars to specify some input location for an error.
- Do not raise this exception directly: rather use the following
- function [raise_with_loc]. *)
-
-value raise_with_loc : (int * int) -> exn -> 'a;
- (** [raise_with_loc loc e], if [e] is already the exception [Exc_located],
- re-raise it, else raise the exception [Exc_located loc e]. *)
-
-value line_of_loc : string -> (int * int) -> (string * int * int * int);
- (** [line_of_loc fname loc] reads the file [fname] up to the
- location [loc] and returns the real input file, the line number
- and the characters location in the line; the real input file
- can be different from [fname] because of possibility of line
- directives typically generated by /lib/cpp. *)
-
-value loc_name : ref string;
- (** Name of the location variable used in grammars and in the predefined
- quotations for OCaml syntax trees. Default: [loc] *)
diff --git a/camlp4/lib/token.ml b/camlp4/lib/token.ml
deleted file mode 100644
index e26798af9c..0000000000
--- a/camlp4/lib/token.ml
+++ /dev/null
@@ -1,229 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-type t = (string * string);
-type pattern = (string * string);
-
-exception Error of string;
-
-type location = (int * int);
-type location_function = int -> (int * int);
-type lexer_func 'te = Stream.t char -> (Stream.t 'te * location_function);
-
-type glexer 'te =
- { tok_func : lexer_func 'te;
- tok_using : pattern -> unit;
- tok_removing : pattern -> unit;
- tok_match : pattern -> 'te -> string;
- tok_text : pattern -> string;
- tok_comm : mutable option (list location) }
-;
-type lexer =
- { func : lexer_func t;
- using : pattern -> unit;
- removing : pattern -> unit;
- tparse : pattern -> option (Stream.t t -> string);
- text : pattern -> string }
-;
-
-value lexer_text (con, prm) =
- if con = "" then "'" ^ prm ^ "'"
- else if prm = "" then con
- else con ^ " '" ^ prm ^ "'"
-;
-
-value locerr () = invalid_arg "Lexer: location function";
-value loct_create () = (ref (Array.create 1024 None), ref False);
-value loct_func (loct, ov) i =
- match
- if i < 0 || i >= Array.length loct.val then
- if ov.val then Some (0, 0) else None
- else Array.unsafe_get loct.val i
- with
- [ Some loc -> loc
- | _ -> locerr () ]
-;
-value loct_add (loct, ov) i loc =
- if i >= Array.length loct.val then
- let new_tmax = Array.length loct.val * 2 in
- if new_tmax < Sys.max_array_length then do {
- let new_loct = Array.create new_tmax None in
- Array.blit loct.val 0 new_loct 0 (Array.length loct.val);
- loct.val := new_loct;
- loct.val.(i) := Some loc
- }
- else ov.val := True
- else loct.val.(i) := Some loc
-;
-
-value make_stream_and_location next_token_loc =
- let loct = loct_create () in
- let ts =
- Stream.from
- (fun i ->
- let (tok, loc) = next_token_loc () in
- do { loct_add loct i loc; Some tok })
- in
- (ts, loct_func loct)
-;
-
-value lexer_func_of_parser next_token_loc cs =
- make_stream_and_location (fun () -> next_token_loc cs)
-;
-
-value lexer_func_of_ocamllex lexfun cs =
- let lb =
- Lexing.from_function
- (fun s n ->
- try do { s.[0] := Stream.next cs; 1 } with [ Stream.Failure -> 0 ])
- in
- let next_token_loc _ =
- let tok = lexfun lb in
- let loc = (Lexing.lexeme_start lb, Lexing.lexeme_end lb) in
- (tok, loc)
- in
- make_stream_and_location next_token_loc
-;
-
-(* Char and string tokens to real chars and string *)
-
-value buff = ref (String.create 80);
-value store len x =
- do {
- if len >= String.length buff.val then
- buff.val := buff.val ^ String.create (String.length buff.val)
- else ();
- buff.val.[len] := x;
- succ len
- }
-;
-value mstore len s =
- add_rec len 0 where rec add_rec len i =
- if i == String.length s then len else add_rec (store len s.[i]) (succ i)
-;
-value get_buff len = String.sub buff.val 0 len;
-
-value valch x = Char.code x - Char.code '0';
-value valch_a x = Char.code x - Char.code 'a' + 10;
-value valch_A x = Char.code x - Char.code 'A' + 10;
-
-value rec backslash s i =
- if i = String.length s then raise Not_found
- else
- match s.[i] with
- [ 'n' -> ('\n', i + 1)
- | 'r' -> ('\r', i + 1)
- | 't' -> ('\t', i + 1)
- | 'b' -> ('\b', i + 1)
- | '\\' -> ('\\', i + 1)
- | '"' -> ('"', i + 1)
- | ''' -> (''', i + 1)
- | '0'..'9' as c -> backslash1 (valch c) s (i + 1)
- | 'x' -> backslash1h s (i + 1)
- | _ -> raise Not_found ]
-and backslash1 cod s i =
- if i = String.length s then raise Not_found
- else
- match s.[i] with
- [ '0'..'9' as c -> backslash2 (10 * cod + valch c) s (i + 1)
- | _ -> raise Not_found ]
-and backslash2 cod s i =
- if i = String.length s then raise Not_found
- else
- match s.[i] with
- [ '0'..'9' as c -> (Char.chr (10 * cod + valch c), i + 1)
- | _ -> raise Not_found ]
-and backslash1h s i =
- if i = String.length s then raise Not_found
- else
- match s.[i] with
- [ '0'..'9' as c -> backslash2h (valch c) s (i + 1)
- | 'a'..'f' as c -> backslash2h (valch_a c) s (i + 1)
- | 'A'..'F' as c -> backslash2h (valch_A c) s (i + 1)
- | _ -> raise Not_found ]
-and backslash2h cod s i =
- if i = String.length s then ('\\', i - 2)
- else
- match s.[i] with
- [ '0'..'9' as c -> (Char.chr (16 * cod + valch c), i + 1)
- | 'a'..'f' as c -> (Char.chr (16 * cod + valch_a c), i + 1)
- | 'A'..'F' as c -> (Char.chr (16 * cod + valch_A c), i + 1)
- | _ -> raise Not_found ]
-;
-
-value rec skip_indent s i =
- if i = String.length s then i
- else
- match s.[i] with
- [ ' ' | '\t' -> skip_indent s (i + 1)
- | _ -> i ]
-;
-
-value skip_opt_linefeed s i =
- if i = String.length s then i else if s.[i] = '\010' then i + 1 else i
-;
-
-value eval_char s =
- if String.length s = 1 then s.[0]
- else if String.length s = 0 then failwith "invalid char token"
- else if s.[0] = '\\' then
- if String.length s = 2 && s.[1] = ''' then '''
- else
- try
- let (c, i) = backslash s 1 in
- if i = String.length s then c else raise Not_found
- with
- [ Not_found -> failwith "invalid char token" ]
- else failwith "invalid char token"
-;
-
-value eval_string (bp, ep) s =
- loop 0 0 where rec loop len i =
- if i = String.length s then get_buff len
- else
- let (len, i) =
- if s.[i] = '\\' then
- let i = i + 1 in
- if i = String.length s then failwith "invalid string token"
- else if s.[i] = '"' then (store len '"', i + 1)
- else
- match s.[i] with
- [ '\010' -> (len, skip_indent s (i + 1))
- | '\013' -> (len, skip_indent s (skip_opt_linefeed s (i + 1)))
- | c ->
- try
- let (c, i) = backslash s i in
- (store len c, i)
- with
- [ Not_found -> do {
- Printf.eprintf
- "Warning: char %d, Invalid backslash escape in string\n%!"
- (bp+i+1);
- (store (store len '\\') c, i + 1) } ] ]
- else (store len s.[i], i + 1)
- in
- loop len i
-;
-
-value default_match =
- fun
- [ ("ANY", "") -> fun (con, prm) -> prm
- | ("ANY", v) ->
- fun (con, prm) -> if v = prm then v else raise Stream.Failure
- | (p_con, "") ->
- fun (con, prm) -> if con = p_con then prm else raise Stream.Failure
- | (p_con, p_prm) ->
- fun (con, prm) ->
- if con = p_con && prm = p_prm then prm else raise Stream.Failure ]
-;
diff --git a/camlp4/lib/token.mli b/camlp4/lib/token.mli
deleted file mode 100644
index fbd1aefd30..0000000000
--- a/camlp4/lib/token.mli
+++ /dev/null
@@ -1,133 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Lexers for Camlp4 grammars.
-
- This module defines the Camlp4 lexer type to be used in extensible
- grammars (see module [Grammar]). It also provides some useful functions
- to create lexers (this module should be renamed [Glexer] one day). *)
-
-type pattern = (string * string);
- (** Token patterns come from the EXTEND statement.
-- The first string is the constructor name (must start with
- an uppercase character). When it is empty, the second string
- is supposed to be a keyword.
-- The second string is the constructor parameter. Empty if it
- has no parameter.
-- The way tokens patterns are interpreted to parse tokens is
- done by the lexer, function [tok_match] below. *)
-
-exception Error of string;
- (** An lexing error exception to be used by lexers. *)
-
-(** {6 Lexer type} *)
-
-type location = (int * int);
-type location_function = int -> location;
- (** The type for a function associating a number of a token in a stream
- (starting from 0) to its source location. *)
-type lexer_func 'te = Stream.t char -> (Stream.t 'te * location_function);
- (** The type for a lexer function. The character stream is the input
- stream to be lexed. The result is a pair of a token stream and
- a location function for this tokens stream. *)
-
-type glexer 'te =
- { tok_func : lexer_func 'te;
- tok_using : pattern -> unit;
- tok_removing : pattern -> unit;
- tok_match : pattern -> 'te -> string;
- tok_text : pattern -> string;
- tok_comm : mutable option (list location) }
-;
- (** The type for a lexer used by Camlp4 grammars.
-- The field [tok_func] is the main lexer function. See [lexer_func]
- type above. This function may be created from a [char stream parser]
- or for an [ocamllex] function using the functions below.
-- The field [tok_using] is a function telling the lexer that the grammar
- uses this token (pattern). The lexer can check that its constructor
- is correct, and interpret some kind of tokens as keywords (to record
- them in its tables). Called by [EXTEND] statements.
-- The field [tok_removing] is a function telling the lexer that the
- grammar does not uses the given token (pattern) any more. If the
- lexer has a notion of "keywords", it can release it from its tables.
- Called by [DELETE_RULE] statements.
-- The field [tok_match] is a function taking a pattern and returning
- a function matching a token against the pattern. Warning: for
- efficency, write it as a function returning functions according
- to the values of the pattern, not a function with two parameters.
-- The field [tok_text] returns the name of some token pattern,
- used in error messages.
-- The field [tok_comm] if not None asks the lexer to record the
- locations of the comments. *)
-
-value lexer_text : pattern -> string;
- (** A simple [tok_text] function for lexers *)
-
-value default_match : pattern -> (string * string) -> string;
- (** A simple [tok_match] function for lexers, appling to token type
- [(string * string)] *)
-
-(** {6 Lexers from char stream parsers or ocamllex function}
-
- The functions below create lexer functions either from a [char stream]
- parser or for an [ocamllex] function. With the returned function [f],
- the simplest [Token.lexer] can be written:
- {[
- { Token.tok_func = f;
- Token.tok_using = (fun _ -> ());
- Token.tok_removing = (fun _ -> ());
- Token.tok_match = Token.default_match;
- Token.tok_text = Token.lexer_text }
- ]}
- Note that a better [tok_using] function should check the used tokens
- and raise [Token.Error] for incorrect ones. The other functions
- [tok_removing], [tok_match] and [tok_text] may have other implementations
- as well. *)
-
-value lexer_func_of_parser :
- (Stream.t char -> ('te * location)) -> lexer_func 'te;
- (** A lexer function from a lexer written as a char stream parser
- returning the next token and its location. *)
-value lexer_func_of_ocamllex : (Lexing.lexbuf -> 'te) -> lexer_func 'te;
- (** A lexer function from a lexer created by [ocamllex] *)
-
-value make_stream_and_location :
- (unit -> ('te * location)) -> (Stream.t 'te * location_function);
- (** General function *)
-
-(** {6 Useful functions} *)
-
-value eval_char : string -> char;
- (** Convert a char token, where the escape sequences (backslashes)
- remain to be interpreted; raise [Failure] if an
- incorrect backslash sequence is found; [Token.eval_char (Char.escaped c)]
- returns [c] *)
-
-value eval_string : location -> string -> string;
- (** Convert a string token, where the escape sequences (backslashes)
- remain to be interpreted; issue a warning if an incorrect
- backslash sequence is found;
- [Token.eval_string loc (String.escaped s)] returns [s] *)
-
-(**/**)
-
-(* deprecated since version 3.05; use rather type glexer *)
-type t = (string * string);
-type lexer =
- { func : lexer_func t;
- using : pattern -> unit;
- removing : pattern -> unit;
- tparse : pattern -> option (Stream.t t -> string);
- text : pattern -> string }
-;
diff --git a/camlp4/man/.cvsignore b/camlp4/man/.cvsignore
deleted file mode 100644
index 2dc933cb1d..0000000000
--- a/camlp4/man/.cvsignore
+++ /dev/null
@@ -1,2 +0,0 @@
-camlp4.1
-camlp4.help
diff --git a/camlp4/man/Makefile b/camlp4/man/Makefile
deleted file mode 100644
index a7aa303478..0000000000
--- a/camlp4/man/Makefile
+++ /dev/null
@@ -1,28 +0,0 @@
-# $Id$
-
-include ../config/Makefile
-
-TARGET=camlp4.1
-ALIASES=camlp4o.1 camlp4r.1 mkcamlp4.1 ocpp.1 camlp4o.opt.1 camlp4r.opt.1
-
-all: $(TARGET)
-
-clean::
- rm -f $(TARGET)
-
-depend:
-
-get_promote:
-
-install:
- if test -n '$(MANDIR)'; then \
- $(MKDIR) $(MANDIR)/man1 ; \
- cp $(TARGET) $(MANDIR)/man1/. ; \
- for i in $(ALIASES); do \
- rm -f $(MANDIR)/man1/$$i; \
- echo '.so man1/$(TARGET)' > $(MANDIR)/man1/$$i; \
- done; \
- fi
-
-camlp4.1: camlp4.1.tpl
- sed -e "s'LIBDIR'$(LIBDIR)'g" camlp4.1.tpl > camlp4.1
diff --git a/camlp4/man/Makefile.Mac b/camlp4/man/Makefile.Mac
deleted file mode 100644
index df95e66fb5..0000000000
--- a/camlp4/man/Makefile.Mac
+++ /dev/null
@@ -1,31 +0,0 @@
-#######################################################################
-# #
-# Camlp4 #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. Distributed only by permission. #
-# #
-#######################################################################
-
-# $Id$
-
-TARGETS = camlp4.help
-
-all Ä {TARGETS}
-
-clean ÄÄ
- delete -i {TARGETS}
-
-depend Ä $OutOfDate
-
-get_promote Ä $OutOfDate
-
-install Ä
- (newfolder "{MANDIR}" || set status 0) ³ dev:null
- duplicate -y {TARGETS} "{MANDIR}"
-
-camlp4.help Ä camlp4.help.tpl
- streamedit -e "1,$ replace -c ° /LIBDIR/ '{P4LIBDIR}'" camlp4.help.tpl ¶
- > camlp4.help
diff --git a/camlp4/man/camlp4.1.tpl b/camlp4/man/camlp4.1.tpl
deleted file mode 100644
index b40b5f9f0b..0000000000
--- a/camlp4/man/camlp4.1.tpl
+++ /dev/null
@@ -1,302 +0,0 @@
-.TH CAMLP4 1 "" "INRIA"
-.SH NAME
-camlp4 - Pre-Precessor-Pretty-Printer for OCaml
-.br
-mkcamlp4 - Create custom camlp4
-.br
-ocpp - Universal preprocessor
-
-.SH SYNOPSIS
-.B camlp4
-[
-load-options
-] [--] [
-other-options
-]
-.br
-.B camlp4o
-[
-load-options
-] [--] [
-other-options
-]
-.br
-.B camlp4r
-[
-load-options
-] [--] [
-other-options
-]
-.br
-.B camlp4sch
-[
-load-options
-] [--] [
-other-options
-]
-.br
-.B camlp4o.cma
-.br
-.B camlp4r.cma
-.br
-.B camlp4sch.cma
-.br
-.B mkcamlp4
-.br
-.B ocpp
-[
-load-options
-]
-file
-.LP
-.br
-.B camlp4o.opt
-[--] [
-other-options
-]
-.br
-.B camlp4r.opt
-[--] [
-other-options
-]
-
-.SH DESCRIPTION
-.B camlp4
-is a Pre-Processor-Pretty-Printer for OCaml, parsing a source
-file and printing some result on standard output.
-.LP
-.B camlp4o,
-.B camlp4r
-and
-.B camlp4sch
-are versions of
-.B camlp4
-with some files already loaded (see further).
-.LP
-.B camlp4o.cma,
-.B camlp4r.cma
-and
-.B camlp4sch.cma
-are files to be loaded in ocaml toplevel to use the camlp4 machinery
-.LP
-.B mkcamlp4
-creates camlp4 executables with almost the same options than ocamlmktop.
-See further.
-.LP
-.B ocpp
-is an universal preprocessor, treating any kind of source file,
-generating the same text with the possible quotations expanded.
-.LP
-.B camlp4o.opt
-and
-.B camlp4r.opt
-are versions of camlp4o and camlp4r compiled by the native-code compiler
-ocamlopt. They are faster but not extensible. And they are not available
-in all installations of camlp4.
-
-.SH LOAD OPTIONS
-
-The load options select parsing and printing actions recorded in OCaml
-object files (ending with .cmo or .cma). Several usage of these options
-are authorized. They must precede the other options.
-
-.LP
-An optionnal
-.B \-\-
-may end the load options.
-
-.TP
-.BI \-I\ directory
-Add
-.I directory
-in the search path for files loaded. Unless the option \-nolib is used,
-the camlp4 library directory is appended to the path. Warning: there is
-no automatic search in the current directory: add "\-I ." for this.
-.TP
-.B \-where
-Print camlp4 library directory name and exit.
-.TP
-.B \-nolib
-No automatic search for objects files in camlp4 library directory.
-.TP
-.BI object-file
-The file is loaded in camlp4 core.
-
-.SH OTHER OPTIONS
-
-.LP
-The others options are:
-
-.TP
-.I file
-Treat
-.I file
-as an interface file if it ends with .mli and as an implementation file
-if it ends with .ml.
-
-.TP
-.BI \-intf\ file
-Treat
-.I file
-as an interface file, whatever its extension.
-.TP
-.BI \-impl\ file
-Treat
-.I file
-as an implementation file, whatever its extension.
-.TP
-.B \-unsafe
-Generate unsafe accesses to arrays and strings.
-.TP
-.B \-noassert
-Do not compile assertion checks.
-.TP
-.B \-verbose
-More verbose in parsing errors.
-.TP
-.BI \-QD\ file
-Dump in
-.I file
-in case of syntax error in the result of a quotation expansion.
-.TP
-.BI \-o\ out-file
-Print the result on out-file instead of standard output. File is opened
-with open_out_bin (see OCaml library Pervasives).
-.TP
-.B \-v
-Print the version number and exit.
-.TP
-.B \-help
-Print the available options and exit. This print includes the options
-possibly added by the loaded object files.
-
-.LP
-The others options can be extended by loaded object files. The provided
-files add the following options:
-
-.TP
-.BI \-l\ line-length
-Added by pr_o.cmo and pr_r.cmo: set the line length (default 78).
-.TP
-.BI \-sep\ string
-Added by pr_o.cmo and pr_r.cmo: print this string between phrases instead
-of comments.
-.TP
-.BI \-no_ss
-Added by pr_o.cmo: do not print double semicolons
-.TP
-.BI \-D\ ident
-Added by pa_macro.cmo: define the ident.
-.TP
-.BI \-U\ ident
-Added by pa_macro.cmo: undefine the ident.
-
-.SH "PROVIDED FILES"
-These files are installed in the directory LIBDIR/camlp4.
-
-.LP
-Parsing files:
-.nf
-.ta 1c
- pa_o.cmo: syntax of OCaml
- pa_op.cmo: streams and parsers
- pa_oop.cmo: streams and parsers (without code optimization)
- pa_r.cmo: revised syntax
- pa_rp.cmo: streams and parsers
- pa_scheme.cmo: scheme syntax
- pa_extend.cmo: syntax extension for grammars
- pa_extfold.cmo: extension of pa_extend with FOLD0 and FOLD1
- pa_extfun.cmo: syntax extension for extensible functions
- pa_fstream.cmo: syntax extension for functional streams
- pa_macro.cmo: add macros (ifdef, define) like in C
- pa_lefteval.cmo: left-to-right evaluation of parameters
- pa_olabl.cmo: old syntax for labels
-.fi
-.LP
-Printing files:
-.nf
-.ta 1c
- pr_o.cmo: syntax of OCaml
- pr_op.cmo: try to rebuild streams and parsers syntax
- pr_r.cmo: revised syntax
- pr_rp.cmo: try to rebuild streams and parsers syntax
- pr_scheme.cmo: scheme syntax
- pr_schemep.cmo: try to rebuild streams and parsers syntax
- pr_extend.cmo: try to rebuild EXTEND statements
- pr_extfun.cmo: try to rebuild extfun statements
- pr_dump.cmo: syntax tree
- pr_depend.cmo: file dependencies
- pr_null.cmo: no output
-.fi
-.LP
-Quotation expanders:
-.nf
-.ta 1c
- q_MLast.cmo: syntax tree nodes
- q_phony.cmo: keeping quotations for pretty printing
-.fi
-.LP
-The command
-.B camlp4o
-is a shortcut for:
-.nf
-.ta 1c
- camlp4 pa_o.cmo pa_op.cmo pr_dump.cmo
-.fi
-.LP
-The command
-.B camlp4r
-is a shortcut for:
-.nf
-.ta 1c
- camlp4 pa_r.cmo pa_rp.cmo pr_dump.cmo
-.fi
-.LP
-The command
-.B camlp4sch
-is a shortcut for:
-.nf
-.ta 1c
- camlp4 pa_scheme.cmo pr_dump.cmo
-.fi
-.LP
-.LP
-The file
-.B camlp4o.cma
-can be loaded in the toplevel to start camlp4 with OCaml syntax.
-.LP
-The file
-.B camlp4r.cma
-can be loaded in the toplevel to start camlp4 with revised syntax.
-.LP
-The file
-.B camlp4sch.cma
-can be loaded in the toplevel to start camlp4 with Scheme syntax.
-
-.SH "MKCAMLP4"
-
-.B mkcamlp4
-creates camlp4 executables with almost the same options than ocamlmktop.
-The only difference is that the interfaces to be visible must be explicitly
-added in the command line as ".cmi" files. For example, how to add the
-the OCaml module "str":
-.nf
-.ta 1c 2c
- mkcamlp4 -custom str.cmi str.cma -cclib -lstr \\
- -o camlp4str
-.fi
-
-.SH "FILES"
-Camlp4 library directory in the present installation:
-.br
-LIBDIR/camlp4
-
-.SH "SEE ALSO"
-Camlp4 - tutorial
-.br
-Camlp4 - reference manual
-.br
-ocamlc(1), ocaml(1).
-
-.SH AUTHOR
-Daniel de Rauglaudre, INRIA Rocquencourt.
diff --git a/camlp4/man/camlp4.help.tpl b/camlp4/man/camlp4.help.tpl
deleted file mode 100644
index 8b13789179..0000000000
--- a/camlp4/man/camlp4.help.tpl
+++ /dev/null
@@ -1 +0,0 @@
-
diff --git a/camlp4/meta/.cvsignore b/camlp4/meta/.cvsignore
deleted file mode 100644
index 460c5a60df..0000000000
--- a/camlp4/meta/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-*.cm[oia]
-camlp4r
-camlp4r.opt
diff --git a/camlp4/meta/.depend b/camlp4/meta/.depend
deleted file mode 100644
index 737ea5ec6b..0000000000
--- a/camlp4/meta/.depend
+++ /dev/null
@@ -1,16 +0,0 @@
-pa_extend.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_extend.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pa_extend_m.cmo: pa_extend.cmo
-pa_extend_m.cmx: pa_extend.cmx
-pa_ifdef.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_ifdef.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pa_macro.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_macro.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pa_r.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_r.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pa_rp.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_rp.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pr_dump.cmo: ../camlp4/ast2pt.cmi $(OTOP)/utils/config.cmi ../camlp4/pcaml.cmi
-pr_dump.cmx: ../camlp4/ast2pt.cmx $(OTOP)/utils/config.cmx ../camlp4/pcaml.cmx
-q_MLast.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/quotation.cmi
-q_MLast.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/quotation.cmx
diff --git a/camlp4/meta/Makefile b/camlp4/meta/Makefile
deleted file mode 100644
index ba1481bed7..0000000000
--- a/camlp4/meta/Makefile
+++ /dev/null
@@ -1,59 +0,0 @@
-# $Id$
-
-include ../config/Makefile
-
-INCLUDES=-I ../camlp4 -I ../boot -I $(OTOP)/utils
-OCAMLCFLAGS=-warn-error A $(INCLUDES)
-OBJS=q_MLast.cmo pa_r.cmo pa_rp.cmo pa_extend.cmo pa_extend_m.cmo pa_macro.cmo pr_dump.cmo
-OBJSX=$(OBJS:.cmo=.cmx)
-CAMLP4RM=pa_r.cmo pa_rp.cmo pr_dump.cmo
-CAMLP4RMX=$(CAMLP4RM:.cmo=.cmx)
-SHELL=/bin/sh
-COUT=$(OBJS) camlp4r$(EXE)
-COPT=$(OBJSX) camlp4r.opt
-
-all: $(COUT)
-opt: $(COPT)
-
-camlp4r$(EXE): ../camlp4/camlp4$(EXE) $(CAMLP4RM)
- rm -f camlp4r$(EXE)
- cd ../camlp4; $(MAKE) OTOP=$(OTOP) CAMLP4=../meta/camlp4r$(EXE) CAMLP4M="-I ../meta $(CAMLP4RM)"
-
-camlp4r.opt: $(CAMLP4RMX)
- rm -f camlp4r.opt
- cd ../camlp4; $(MAKE) optp4 OTOP=$(OTOP) CAMLP4OPT=../meta/camlp4r.opt CAMLP4M="-I ../meta $(CAMLP4RMX)"
-
-clean::
- rm -f *.cm* *.pp[io] *.o *.bak .*.bak $(COUT) $(COPT)
-
-depend:
- cp .depend .depend.bak
- > .depend
- @for i in *.mli *.ml; do \
- ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \
- sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \
- done
-
-promote:
- cp $(COUT) pa_extend.cmi ../boot/.
-
-compare:
- @for j in $(COUT); do \
- if cmp $$j ../boot/$$j; then :; else exit 1; fi; \
- done
-
-install:
- -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)"
- cp $(OBJS) "$(LIBDIR)/camlp4/."
- cp pa_macro.cmi pa_extend.cmi "$(LIBDIR)/camlp4/."
- cp camlp4r$(EXE) "$(BINDIR)/."
- if test -f camlp4r.opt; then \
- cp camlp4r.opt "$(BINDIR)/camlp4r.opt$(EXE)" ;\
- for target in $(OBJSX) $(OBJSX:.cmx=.$(O)) ; do \
- if test -f $$target; then \
- cp $$target "$(LIBDIR)/camlp4/."; \
- fi; \
- done; \
- fi
-
-include .depend
diff --git a/camlp4/meta/Makefile.Mac b/camlp4/meta/Makefile.Mac
deleted file mode 100644
index 9451d5222c..0000000000
--- a/camlp4/meta/Makefile.Mac
+++ /dev/null
@@ -1,50 +0,0 @@
-#######################################################################
-# #
-# Camlp4 #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. Distributed only by permission. #
-# #
-#######################################################################
-
-# $Id$
-
-INCLUDES = -I ::camlp4: -I ::boot: -I "{OTOP}utils:"
-OCAMLCFLAGS = {INCLUDES}
-OBJS = q_MLast.cmo pa_r.cmo pa_rp.cmo pa_extend.cmo pa_extend_m.cmo ¶
- pa_ifdef.cmo pr_dump.cmo
-CAMLP4RM = pa_r.cmo pa_rp.cmo pr_dump.cmo
-OUT = {OBJS} camlp4r
-
-all Ä {OUT}
-
-camlp4r Ä ::camlp4:camlp4 {CAMLP4RM}
- delete -i camlp4r
- directory ::camlp4:
- domake -d CAMLP4=::meta:camlp4r -d CAMLP4M="-I ::meta {CAMLP4RM}"
- directory ::meta:
-
-clean ÄÄ
- delete -i {OUT}
-
-{dependrule}
-
-promote Ä
- duplicate -y {OUT} pa_extend.cmi ::boot:
-
-compare Ä
- for i in {OUT}
- equal -s {i} ::boot:{i} || exit 1
- end
-
-install Ä
- (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null
- (newfolder "{BINDIR}" || set status 0) ³ dev:null
- duplicate -y {OBJS} "{P4LIBDIR}"
- duplicate -y camlp4r "{BINDIR}"
-
-{defrules}
-
-pr_dump.cmo Ä ::camlp4:ast2pt.cmo "{OTOP}utils:config.cmi" ::camlp4:pcaml.cmi
diff --git a/camlp4/meta/Makefile.Mac.depend b/camlp4/meta/Makefile.Mac.depend
deleted file mode 100644
index 29675238e9..0000000000
--- a/camlp4/meta/Makefile.Mac.depend
+++ /dev/null
@@ -1,12 +0,0 @@
-pa_extend.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi
-pa_extend.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx
-pa_extend_m.cmoÄ ::camlp4:mLast.cmi pa_extend.cmo
-pa_extend_m.cmxÄ ::camlp4:mLast.cmi pa_extend.cmx
-pa_macro.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi
-pa_macro.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx
-pa_r.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi
-pa_r.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx
-pa_rp.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi
-pa_rp.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx
-q_MLast.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:quotation.cmi
-q_MLast.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:quotation.cmx
diff --git a/camlp4/meta/mk_q_MLast.sh b/camlp4/meta/mk_q_MLast.sh
deleted file mode 100755
index c678f350ad..0000000000
--- a/camlp4/meta/mk_q_MLast.sh
+++ /dev/null
@@ -1,12 +0,0 @@
-#!/bin/sh
-# $Id$
-
-IFILE=pa_r.ml
-OFILE=q_MLast.ml
-(
-sed -e '/^EXTEND$/,$d' $OFILE
-echo EXTEND
-../../boot/ocamlrun ./camlp4r -I . -I ../etc q_MLast.cmo pa_extend.cmo pr_r.cmo pr_extend.cmo -cip -quotify $IFILE | sed -e '1,/^EXTEND$/d' -e '/^END;$/,$d'
-echo ' (* Antiquotations for local entries *)'
-sed -e '1,/Antiquotations for local entries/d' $OFILE
-)
diff --git a/camlp4/meta/pa_extend.ml b/camlp4/meta/pa_extend.ml
deleted file mode 100644
index e8fed87b62..0000000000
--- a/camlp4/meta/pa_extend.ml
+++ /dev/null
@@ -1,916 +0,0 @@
-(* camlp4r pa_extend.cmo q_MLast.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Stdpp;
-
-value split_ext = ref False;
-
-Pcaml.add_option "-split_ext" (Arg.Set split_ext)
- "Split EXTEND by functions to turn around a PowerPC problem.";
-
-Pcaml.add_option "-split_gext" (Arg.Set split_ext)
- "Old name for the option -split_ext.";
-
-type loc = (int * int);
-
-type name 'e = { expr : 'e; tvar : string; loc : (int * int) };
-
-type styp =
- [ STlid of loc and string
- | STapp of loc and styp and styp
- | STquo of loc and string
- | STself of loc and string
- | STtyp of MLast.ctyp ]
-;
-
-type text 'e =
- [ TXmeta of loc and string and list (text 'e) and 'e and styp
- | TXlist of loc and bool and text 'e and option (text 'e)
- | TXnext of loc
- | TXnterm of loc and name 'e and option string
- | TXopt of loc and text 'e
- | TXrules of loc and list (list (text 'e) * 'e)
- | TXself of loc
- | TXtok of loc and string and 'e ]
-;
-
-type entry 'e 'p =
- { name : name 'e; pos : option 'e; levels : list (level 'e 'p) }
-and level 'e 'p =
- { label : option string; assoc : option 'e; rules : list (rule 'e 'p) }
-and rule 'e 'p = { prod : list (psymbol 'e 'p); action : option 'e }
-and psymbol 'e 'p = { pattern : option 'p; symbol : symbol 'e 'p }
-and symbol 'e 'p = { used : list string; text : text 'e; styp : styp }
-;
-
-type used = [ Unused | UsedScanned | UsedNotScanned ];
-
-value mark_used modif ht n =
- try
- let rll = Hashtbl.find_all ht n in
- List.iter
- (fun (r, _) ->
- if r.val == Unused then do {
- r.val := UsedNotScanned; modif.val := True;
- }
- else ())
- rll
- with
- [ Not_found -> () ]
-;
-
-value rec mark_symbol modif ht symb =
- List.iter (fun e -> mark_used modif ht e) symb.used
-;
-
-value check_use nl el =
- let ht = Hashtbl.create 301 in
- let modif = ref False in
- do {
- List.iter
- (fun e ->
- let u =
- match e.name.expr with
- [ <:expr< $lid:_$ >> -> Unused
- | _ -> UsedNotScanned ]
- in
- Hashtbl.add ht e.name.tvar (ref u, e))
- el;
- List.iter
- (fun n ->
- try
- let rll = Hashtbl.find_all ht n.tvar in
- List.iter (fun (r, _) -> r.val := UsedNotScanned) rll
- with _ ->
- ())
- nl;
- modif.val := True;
- while modif.val do {
- modif.val := False;
- Hashtbl.iter
- (fun s (r, e) ->
- if r.val = UsedNotScanned then do {
- r.val := UsedScanned;
- List.iter
- (fun level ->
- let rules = level.rules in
- List.iter
- (fun rule ->
- List.iter (fun ps -> mark_symbol modif ht ps.symbol)
- rule.prod)
- rules)
- e.levels
- }
- else ())
- ht
- };
- Hashtbl.iter
- (fun s (r, e) ->
- if r.val = Unused then
- Pcaml.warning.val e.name.loc ("Unused local entry \"" ^ s ^ "\"")
- else ())
- ht;
- }
-;
-
-value locate n = let loc = n.loc in <:expr< $n.expr$ >>;
-
-value new_type_var =
- let i = ref 0 in fun () -> do { incr i; "e__" ^ string_of_int i.val }
-;
-
-value used_of_rule_list rl =
- List.fold_left
- (fun nl r -> List.fold_left (fun nl s -> s.symbol.used @ nl) nl r.prod) []
- rl
-;
-
-value retype_rule_list_without_patterns loc rl =
- try
- List.map
- (fun
- [ {prod = [{pattern = None; symbol = s}]; action = None} ->
- {prod = [{pattern = Some <:patt< x >>; symbol = s}];
- action = Some <:expr< x >>}
- | {prod = []; action = Some _} as r -> r
- | _ -> raise Exit ])
- rl
- with
- [ Exit -> rl ]
-;
-
-value quotify = ref False;
-value meta_action = ref False;
-
-module MetaAction =
- struct
- value not_impl f x =
- let desc =
- if Obj.is_block (Obj.repr x) then
- "tag = " ^ string_of_int (Obj.tag (Obj.repr x))
- else "int_val = " ^ string_of_int (Obj.magic x)
- in
- failwith (f ^ ", not impl: " ^ desc)
- ;
- value loc = (0, 0);
- value rec mlist mf =
- fun
- [ [] -> <:expr< [] >>
- | [x :: l] -> <:expr< [ $mf x$ :: $mlist mf l$ ] >> ]
- ;
- value moption mf =
- fun
- [ None -> <:expr< None >>
- | Some x -> <:expr< Some $mf x$ >> ]
- ;
- value mbool =
- fun
- [ False -> <:expr< False >>
- | True -> <:expr< True >> ]
- ;
- value mloc = <:expr< (0, 0) >>;
- value rec mexpr =
- fun
- [ MLast.ExAcc loc e1 e2 ->
- <:expr< MLast.ExAcc $mloc$ $mexpr e1$ $mexpr e2$ >>
- | MLast.ExApp loc e1 e2 ->
- <:expr< MLast.ExApp $mloc$ $mexpr e1$ $mexpr e2$ >>
- | MLast.ExChr loc s -> <:expr< MLast.ExChr $mloc$ $str:s$ >>
- | MLast.ExFun loc pwel -> <:expr< MLast.ExFun $mloc$ $mlist mpwe pwel$ >>
- | MLast.ExIfe loc e1 e2 e3 ->
- <:expr< MLast.ExIfe $mloc$ $mexpr e1$ $mexpr e2$ $mexpr e3$ >>
- | MLast.ExInt loc s -> <:expr< MLast.ExInt $mloc$ $str:s$ >>
- | MLast.ExFlo loc s -> <:expr< MLast.ExFlo $mloc$ $str:s$ >>
- | MLast.ExLet loc rf pel e ->
- <:expr< MLast.ExLet $mloc$ $mbool rf$ $mlist mpe pel$ $mexpr e$ >>
- | MLast.ExLid loc s -> <:expr< MLast.ExLid $mloc$ $str:s$ >>
- | MLast.ExMat loc e pwel ->
- <:expr< MLast.ExMat $mloc$ $mexpr e$ $mlist mpwe pwel$ >>
- | MLast.ExRec loc pel eo ->
- <:expr< MLast.ExRec $mloc$ $mlist mpe pel$ $moption mexpr eo$ >>
- | MLast.ExSeq loc el -> <:expr< MLast.ExSeq $mloc$ $mlist mexpr el$ >>
- | MLast.ExSte loc e1 e2 ->
- <:expr< MLast.ExSte $mloc$ $mexpr e1$ $mexpr e2$ >>
- | MLast.ExStr loc s ->
- <:expr< MLast.ExStr $mloc$ $str:String.escaped s$ >>
- | MLast.ExTry loc e pwel ->
- <:expr< MLast.ExTry $mloc$ $mexpr e$ $mlist mpwe pwel$ >>
- | MLast.ExTup loc el -> <:expr< MLast.ExTup $mloc$ $mlist mexpr el$ >>
- | MLast.ExTyc loc e t ->
- <:expr< MLast.ExTyc $mloc$ $mexpr e$ $mctyp t$ >>
- | MLast.ExUid loc s -> <:expr< MLast.ExUid $mloc$ $str:s$ >>
- | x -> not_impl "mexpr" x ]
- and mpatt =
- fun
- [ MLast.PaAcc loc p1 p2 ->
- <:expr< MLast.PaAcc $mloc$ $mpatt p1$ $mpatt p2$ >>
- | MLast.PaAny loc -> <:expr< MLast.PaAny $mloc$ >>
- | MLast.PaApp loc p1 p2 ->
- <:expr< MLast.PaApp $mloc$ $mpatt p1$ $mpatt p2$ >>
- | MLast.PaInt loc s -> <:expr< MLast.PaInt $mloc$ $str:s$ >>
- | MLast.PaLid loc s -> <:expr< MLast.PaLid $mloc$ $str:s$ >>
- | MLast.PaOrp loc p1 p2 ->
- <:expr< MLast.PaOrp $mloc$ $mpatt p1$ $mpatt p2$ >>
- | MLast.PaStr loc s ->
- <:expr< MLast.PaStr $mloc$ $str:String.escaped s$ >>
- | MLast.PaTup loc pl -> <:expr< MLast.PaTup $mloc$ $mlist mpatt pl$ >>
- | MLast.PaTyc loc p t ->
- <:expr< MLast.PaTyc $mloc$ $mpatt p$ $mctyp t$ >>
- | MLast.PaUid loc s -> <:expr< MLast.PaUid $mloc$ $str:s$ >>
- | x -> not_impl "mpatt" x ]
- and mctyp =
- fun
- [ MLast.TyAcc loc t1 t2 ->
- <:expr< MLast.TyAcc $mloc$ $mctyp t1$ $mctyp t2$ >>
- | MLast.TyApp loc t1 t2 ->
- <:expr< MLast.TyApp $mloc$ $mctyp t1$ $mctyp t2$ >>
- | MLast.TyLid loc s -> <:expr< MLast.TyLid $mloc$ $str:s$ >>
- | MLast.TyQuo loc s -> <:expr< MLast.TyQuo $mloc$ $str:s$ >>
- | MLast.TyTup loc tl -> <:expr< MLast.TyTup $mloc$ $mlist mctyp tl$ >>
- | MLast.TyUid loc s -> <:expr< MLast.TyUid $mloc$ $str:s$ >>
- | x -> not_impl "mctyp" x ]
- and mpe (p, e) = <:expr< ($mpatt p$, $mexpr e$) >>
- and mpwe (p, w, e) = <:expr< ($mpatt p$, $moption mexpr w$, $mexpr e$) >>
- ;
- end
-;
-
-value mklistexp loc =
- loop True where rec loop top =
- fun
- [ [] -> <:expr< [] >>
- | [e1 :: el] ->
- let loc =
- if top then loc else (fst (MLast.loc_of_expr e1), snd loc)
- in
- <:expr< [$e1$ :: $loop False el$] >> ]
-;
-
-value mklistpat loc =
- loop True where rec loop top =
- fun
- [ [] -> <:patt< [] >>
- | [p1 :: pl] ->
- let loc =
- if top then loc else (fst (MLast.loc_of_patt p1), snd loc)
- in
- <:patt< [$p1$ :: $loop False pl$] >> ]
-;
-
-value rec expr_fa al =
- fun
- [ <:expr< $f$ $a$ >> -> expr_fa [a :: al] f
- | f -> (f, al) ]
-;
-
-value rec quot_expr e =
- let loc = MLast.loc_of_expr e in
- match e with
- [ <:expr< None >> -> <:expr< Qast.Option None >>
- | <:expr< Some $e$ >> -> <:expr< Qast.Option (Some $quot_expr e$) >>
- | <:expr< False >> -> <:expr< Qast.Bool False >>
- | <:expr< True >> -> <:expr< Qast.Bool True >>
- | <:expr< () >> -> e
- | <:expr< Qast.List $_$ >> -> e
- | <:expr< Qast.Option $_$ >> -> e
- | <:expr< Qast.Str $_$ >> -> e
- | <:expr< [] >> -> <:expr< Qast.List [] >>
- | <:expr< [$e$] >> -> <:expr< Qast.List [$quot_expr e$] >>
- | <:expr< [$e1$ :: $e2$] >> ->
- <:expr< Qast.Cons $quot_expr e1$ $quot_expr e2$ >>
- | <:expr< $_$ $_$ >> ->
- let (f, al) = expr_fa [] e in
- match f with
- [ <:expr< $uid:c$ >> ->
- let al = List.map quot_expr al in
- <:expr< Qast.Node $str:c$ $mklistexp loc al$ >>
- | <:expr< MLast.$uid:c$ >> ->
- let al = List.map quot_expr al in
- <:expr< Qast.Node $str:c$ $mklistexp loc al$ >>
- | <:expr< $uid:m$.$uid:c$ >> ->
- let al = List.map quot_expr al in
- <:expr< Qast.Node $str:m ^ "." ^ c$ $mklistexp loc al$ >>
- | <:expr< $lid:f$ >> ->
- let al = List.map quot_expr al in
- List.fold_left (fun f e -> <:expr< $f$ $e$ >>)
- <:expr< $lid:f$ >> al
- | _ -> e ]
- | <:expr< {$list:pel$} >> ->
- try
- let lel =
- List.map
- (fun (p, e) ->
- let lab =
- match p with
- [ <:patt< $lid:c$ >> -> <:expr< $str:c$ >>
- | <:patt< $_$.$lid:c$ >> -> <:expr< $str:c$ >>
- | _ -> raise Not_found ]
- in
- <:expr< ($lab$, $quot_expr e$) >>)
- pel
- in
- <:expr< Qast.Record $mklistexp loc lel$>>
- with
- [ Not_found -> e ]
- | <:expr< $lid:s$ >> ->
- if s = Stdpp.loc_name.val then <:expr< Qast.Loc >> else e
- | <:expr< MLast.$uid:s$ >> -> <:expr< Qast.Node $str:s$ [] >>
- | <:expr< $uid:m$.$uid:s$ >> -> <:expr< Qast.Node $str:m ^ "." ^ s$ [] >>
- | <:expr< $uid:s$ >> -> <:expr< Qast.Node $str:s$ [] >>
- | <:expr< $str:s$ >> -> <:expr< Qast.Str $str:s$ >>
- | <:expr< ($list:el$) >> ->
- let el = List.map quot_expr el in
- <:expr< Qast.Tuple $mklistexp loc el$ >>
- | <:expr< let $opt:r$ $list:pel$ in $e$ >> ->
- let pel = List.map (fun (p, e) -> (p, quot_expr e)) pel in
- <:expr< let $opt:r$ $list:pel$ in $quot_expr e$ >>
- | _ -> e ]
-;
-
-value symgen = "xx";
-
-value pname_of_ptuple pl =
- List.fold_left
- (fun pname p ->
- match p with
- [ <:patt< $lid:s$ >> -> pname ^ s
- | _ -> pname ])
- "" pl
-;
-
-value quotify_action psl act =
- let e = quot_expr act in
- List.fold_left
- (fun e ps ->
- match ps.pattern with
- [ Some <:patt< ($list:pl$) >> ->
- let loc = (0, 0) in
- let pname = pname_of_ptuple pl in
- let (pl1, el1) =
- let (l, _) =
- List.fold_left
- (fun (l, cnt) _ ->
- ([symgen ^ string_of_int cnt :: l], cnt + 1))
- ([], 1) pl
- in
- let l = List.rev l in
- (List.map (fun s -> <:patt< $lid:s$ >>) l,
- List.map (fun s -> <:expr< $lid:s$ >>) l)
- in
- <:expr<
- let ($list:pl$) =
- match $lid:pname$ with
- [ Qast.Tuple $mklistpat loc pl1$ -> ($list:el1$)
- | _ -> match () with [] ]
- in $e$ >>
- | _ -> e ])
- e psl
-;
-
-value rec make_ctyp styp tvar =
- match styp with
- [ STlid loc s -> <:ctyp< $lid:s$ >>
- | STapp loc t1 t2 -> <:ctyp< $make_ctyp t1 tvar$ $make_ctyp t2 tvar$ >>
- | STquo loc s -> <:ctyp< '$s$ >>
- | STself loc x ->
- if tvar = "" then
- Stdpp.raise_with_loc loc
- (Stream.Error ("'" ^ x ^ "' illegal in anonymous entry level"))
- else <:ctyp< '$tvar$ >>
- | STtyp t -> t ]
-;
-
-value rec make_expr gmod tvar =
- fun
- [ TXmeta loc n tl e t ->
- let el =
- List.fold_right
- (fun t el -> <:expr< [$make_expr gmod "" t$ :: $el$] >>)
- tl <:expr< [] >>
- in
- <:expr<
- Gramext.Smeta $str:n$ $el$ (Obj.repr ($e$ : $make_ctyp t tvar$)) >>
- | TXlist loc min t ts ->
- let txt = make_expr gmod "" t in
- match (min, ts) with
- [ (False, None) -> <:expr< Gramext.Slist0 $txt$ >>
- | (True, None) -> <:expr< Gramext.Slist1 $txt$ >>
- | (False, Some s) ->
- let x = make_expr gmod tvar s in
- <:expr< Gramext.Slist0sep $txt$ $x$ >>
- | (True, Some s) ->
- let x = make_expr gmod tvar s in
- <:expr< Gramext.Slist1sep $txt$ $x$ >> ]
- | TXnext loc -> <:expr< Gramext.Snext >>
- | TXnterm loc n lev ->
- match lev with
- [ Some lab ->
- <:expr<
- Gramext.Snterml
- ($uid:gmod$.Entry.obj ($n.expr$ : $uid:gmod$.Entry.e '$n.tvar$))
- $str:lab$ >>
- | None ->
- if n.tvar = tvar then <:expr< Gramext.Sself >>
- else
- <:expr<
- Gramext.Snterm
- ($uid:gmod$.Entry.obj
- ($n.expr$ : $uid:gmod$.Entry.e '$n.tvar$)) >> ]
- | TXopt loc t -> <:expr< Gramext.Sopt $make_expr gmod "" t$ >>
- | TXrules loc rl ->
- <:expr< Gramext.srules $make_expr_rules loc gmod rl ""$ >>
- | TXself loc -> <:expr< Gramext.Sself >>
- | TXtok loc s e -> <:expr< Gramext.Stoken ($str:s$, $e$) >> ]
-and make_expr_rules loc gmod rl tvar =
- List.fold_left
- (fun txt (sl, ac) ->
- let sl =
- List.fold_right
- (fun t txt ->
- let x = make_expr gmod tvar t in
- <:expr< [$x$ :: $txt$] >>)
- sl <:expr< [] >>
- in
- <:expr< [($sl$, $ac$) :: $txt$] >>)
- <:expr< [] >> rl
-;
-
-value text_of_action loc psl rtvar act tvar =
- let locid = <:patt< $lid:Stdpp.loc_name.val$ >> in
- let act =
- match act with
- [ Some act -> if quotify.val then quotify_action psl act else act
- | None -> <:expr< () >> ]
- in
- let e = <:expr< fun [ ($locid$ : (int * int)) -> ($act$ : '$rtvar$) ] >> in
- let txt =
- List.fold_left
- (fun txt ps ->
- match ps.pattern with
- [ None -> <:expr< fun _ -> $txt$ >>
- | Some p ->
- let t = make_ctyp ps.symbol.styp tvar in
- let p =
- match p with
- [ <:patt< ($list:pl$) >> when quotify.val ->
- <:patt< $lid:pname_of_ptuple pl$ >>
- | _ -> p ]
- in
- <:expr< fun ($p$ : $t$) -> $txt$ >> ])
- e psl
- in
- let txt =
- if meta_action.val then
- <:expr< Obj.magic $MetaAction.mexpr txt$ >>
- else txt
- in
- <:expr< Gramext.action $txt$ >>
-;
-
-value srules loc t rl tvar =
- List.map
- (fun r ->
- let sl = List.map (fun ps -> ps.symbol.text) r.prod in
- let ac = text_of_action loc r.prod t r.action tvar in
- (sl, ac))
- rl
-;
-
-value expr_of_delete_rule loc gmod n sl =
- let sl =
- List.fold_right
- (fun s e -> <:expr< [$make_expr gmod "" s.text$ :: $e$] >>) sl
- <:expr< [] >>
- in
- (<:expr< $n.expr$ >>, sl)
-;
-
-value rec ident_of_expr =
- fun
- [ <:expr< $lid:s$ >> -> s
- | <:expr< $uid:s$ >> -> s
- | <:expr< $e1$ . $e2$ >> -> ident_of_expr e1 ^ "__" ^ ident_of_expr e2
- | _ -> failwith "internal error in pa_extend" ]
-;
-
-value mk_name loc e = {expr = e; tvar = ident_of_expr e; loc = loc};
-
-value slist loc min sep symb =
- let t =
- match sep with
- [ Some s -> Some s.text
- | None -> None ]
- in
- TXlist loc min symb.text t
-;
-
-value sstoken loc s =
- let n = mk_name loc <:expr< $lid:"a_" ^ s$ >> in
- TXnterm loc n None
-;
-
-value mk_psymbol p s t =
- let symb = {used = []; text = s; styp = t} in
- {pattern = Some p; symbol = symb}
-;
-
-value sslist loc min sep s =
- let rl =
- let r1 =
- let prod =
- let n = mk_name loc <:expr< a_list >> in
- [mk_psymbol <:patt< a >> (TXnterm loc n None) (STquo loc "a_list")]
- in
- let act = <:expr< a >> in
- {prod = prod; action = Some act}
- in
- let r2 =
- let prod =
- [mk_psymbol <:patt< a >> (slist loc min sep s)
- (STapp loc (STlid loc "list") s.styp)]
- in
- let act = <:expr< Qast.List a >> in
- {prod = prod; action = Some act}
- in
- [r1; r2]
- in
- let used =
- match sep with
- [ Some symb -> symb.used @ s.used
- | None -> s.used ]
- in
- let used = ["a_list" :: used] in
- let text = TXrules loc (srules loc "a_list" rl "") in
- let styp = STquo loc "a_list" in
- {used = used; text = text; styp = styp}
-;
-
-value ssopt loc s =
- let rl =
- let r1 =
- let prod =
- let n = mk_name loc <:expr< a_opt >> in
- [mk_psymbol <:patt< a >> (TXnterm loc n None) (STquo loc "a_opt")]
- in
- let act = <:expr< a >> in
- {prod = prod; action = Some act}
- in
- let r2 =
- let s =
- match s.text with
- [ TXtok loc "" <:expr< $str:_$ >> ->
- let rl =
- [{prod = [{pattern = Some <:patt< x >>; symbol = s}];
- action = Some <:expr< Qast.Str x >>}]
- in
- let t = new_type_var () in
- {used = []; text = TXrules loc (srules loc t rl "");
- styp = STquo loc t}
- | _ -> s ]
- in
- let prod =
- [mk_psymbol <:patt< a >> (TXopt loc s.text)
- (STapp loc (STlid loc "option") s.styp)]
- in
- let act = <:expr< Qast.Option a >> in
- {prod = prod; action = Some act}
- in
- [r1; r2]
- in
- let used = ["a_opt" :: s.used] in
- let text = TXrules loc (srules loc "a_opt" rl "") in
- let styp = STquo loc "a_opt" in
- {used = used; text = text; styp = styp}
-;
-
-value text_of_entry loc gmod e =
- let ent =
- let x = e.name in
- let loc = e.name.loc in
- <:expr< ($x.expr$ : $uid:gmod$.Entry.e '$x.tvar$) >>
- in
- let pos =
- match e.pos with
- [ Some pos -> <:expr< Some $pos$ >>
- | None -> <:expr< None >> ]
- in
- let txt =
- List.fold_right
- (fun level txt ->
- let lab =
- match level.label with
- [ Some lab -> <:expr< Some $str:lab$ >>
- | None -> <:expr< None >> ]
- in
- let ass =
- match level.assoc with
- [ Some ass -> <:expr< Some $ass$ >>
- | None -> <:expr< None >> ]
- in
- let txt =
- let rl = srules loc e.name.tvar level.rules e.name.tvar in
- let e = make_expr_rules loc gmod rl e.name.tvar in
- <:expr< [($lab$, $ass$, $e$) :: $txt$] >>
- in
- txt)
- e.levels <:expr< [] >>
- in
- (ent, pos, txt)
-;
-
-value let_in_of_extend loc gmod functor_version gl el args =
- match gl with
- [ Some ([n1 :: _] as nl) ->
- do {
- check_use nl el;
- let ll =
- let same_tvar e n = e.name.tvar = n.tvar in
- List.fold_right
- (fun e ll ->
- match e.name.expr with
- [ <:expr< $lid:_$ >> ->
- if List.exists (same_tvar e) nl then ll
- else if List.exists (same_tvar e) ll then ll
- else [e.name :: ll]
- | _ -> ll ])
- el []
- in
- let globals =
- List.map
- (fun {expr = e; tvar = x; loc = loc} ->
- (<:patt< _ >>, <:expr< ($e$ : $uid:gmod$.Entry.e '$x$) >>))
- nl
- in
- let locals =
- List.map
- (fun {expr = e; tvar = x; loc = loc} ->
- let i =
- match e with
- [ <:expr< $lid:i$ >> -> i
- | _ -> failwith "internal error in pa_extend" ]
- in
- (<:patt< $lid:i$ >>, <:expr<
- (grammar_entry_create $str:i$ : $uid:gmod$.Entry.e '$x$) >>))
- ll
- in
- let e =
- if ll = [] then args
- else if functor_version then
- <:expr<
- let grammar_entry_create = $uid:gmod$.Entry.create in
- let $list:locals$ in $args$ >>
- else
- <:expr<
- let grammar_entry_create s =
- $uid:gmod$.Entry.create ($uid:gmod$.of_entry $locate n1$) s
- in
- let $list:locals$ in $args$ >>
- in
- <:expr< let $list:globals$ in $e$ >>
- }
- | _ -> args ]
-;
-
-value text_of_extend loc gmod gl el f =
- if split_ext.val then
- let args =
- List.map
- (fun e ->
- let (ent, pos, txt) = text_of_entry e.name.loc gmod e in
- let ent = <:expr< $uid:gmod$.Entry.obj $ent$ >> in
- let e = <:expr< ($ent$, $pos$, $txt$) >> in
- <:expr< let aux () = $f$ [$e$] in aux () >>)
- el
- in
- let args = <:expr< do { $list:args$ } >> in
- let_in_of_extend loc gmod False gl el args
- else
- let args =
- List.fold_right
- (fun e el ->
- let (ent, pos, txt) = text_of_entry e.name.loc gmod e in
- let ent = <:expr< $uid:gmod$.Entry.obj $ent$ >> in
- let e = <:expr< ($ent$, $pos$, $txt$) >> in
- <:expr< [$e$ :: $el$] >>)
- el <:expr< [] >>
- in
- let args = let_in_of_extend loc gmod False gl el args in
- <:expr< $f$ $args$ >>
-;
-
-value text_of_functorial_extend loc gmod gl el =
- let args =
- let el =
- List.map
- (fun e ->
- let (ent, pos, txt) = text_of_entry e.name.loc gmod e in
- let e = <:expr< $uid:gmod$.extend $ent$ $pos$ $txt$ >> in
- if split_ext.val then <:expr< let aux () = $e$ in aux () >> else e)
- el
- in
- <:expr< do { $list:el$ } >>
- in
- let_in_of_extend loc gmod True gl el args
-;
-
-open Pcaml;
-value symbol = Grammar.Entry.create gram "symbol";
-value semi_sep =
- if syntax_name.val = "Scheme" then
- Grammar.Entry.of_parser gram "'/'" (parser [: `("", "/") :] -> ())
- else
- Grammar.Entry.of_parser gram "';'" (parser [: `("", ";") :] -> ())
-;
-
-EXTEND
- GLOBAL: expr symbol;
- expr: AFTER "top"
- [ [ "EXTEND"; e = extend_body; "END" -> e
- | "GEXTEND"; e = gextend_body; "END" -> e
- | "DELETE_RULE"; e = delete_rule_body; "END" -> e
- | "GDELETE_RULE"; e = gdelete_rule_body; "END" -> e ] ]
- ;
- extend_body:
- [ [ f = efunction; sl = OPT global;
- el = LIST1 [ e = entry; semi_sep -> e ] ->
- text_of_extend loc "Grammar" sl el f ] ]
- ;
- gextend_body:
- [ [ g = UIDENT; sl = OPT global; el = LIST1 [ e = entry; semi_sep -> e ] ->
- text_of_functorial_extend loc g sl el ] ]
- ;
- delete_rule_body:
- [ [ n = name; ":"; sl = LIST1 symbol SEP semi_sep ->
- let (e, b) = expr_of_delete_rule loc "Grammar" n sl in
- <:expr< Grammar.delete_rule $e$ $b$ >> ] ]
- ;
- gdelete_rule_body:
- [ [ g = UIDENT; n = name; ":"; sl = LIST1 symbol SEP semi_sep ->
- let (e, b) = expr_of_delete_rule loc g n sl in
- <:expr< $uid:g$.delete_rule $e$ $b$ >> ] ]
- ;
- efunction:
- [ [ UIDENT "FUNCTION"; ":"; f = qualid; semi_sep -> f
- | -> <:expr< Grammar.extend >> ] ]
- ;
- global:
- [ [ UIDENT "GLOBAL"; ":"; sl = LIST1 name; semi_sep -> sl ] ]
- ;
- entry:
- [ [ n = name; ":"; pos = OPT position; ll = level_list ->
- {name = n; pos = pos; levels = ll} ] ]
- ;
- position:
- [ [ UIDENT "FIRST" -> <:expr< Gramext.First >>
- | UIDENT "LAST" -> <:expr< Gramext.Last >>
- | UIDENT "BEFORE"; n = string -> <:expr< Gramext.Before $n$ >>
- | UIDENT "AFTER"; n = string -> <:expr< Gramext.After $n$ >>
- | UIDENT "LEVEL"; n = string -> <:expr< Gramext.Level $n$ >> ] ]
- ;
- level_list:
- [ [ "["; ll = LIST0 level SEP "|"; "]" -> ll ] ]
- ;
- level:
- [ [ lab = OPT STRING; ass = OPT assoc; rules = rule_list ->
- {label = lab; assoc = ass; rules = rules} ] ]
- ;
- assoc:
- [ [ UIDENT "LEFTA" -> <:expr< Gramext.LeftA >>
- | UIDENT "RIGHTA" -> <:expr< Gramext.RightA >>
- | UIDENT "NONA" -> <:expr< Gramext.NonA >> ] ]
- ;
- rule_list:
- [ [ "["; "]" -> []
- | "["; rules = LIST1 rule SEP "|"; "]" ->
- retype_rule_list_without_patterns loc rules ] ]
- ;
- rule:
- [ [ psl = LIST0 psymbol SEP semi_sep; "->"; act = expr ->
- {prod = psl; action = Some act}
- | psl = LIST0 psymbol SEP semi_sep ->
- {prod = psl; action = None} ] ]
- ;
- psymbol:
- [ [ p = LIDENT; "="; s = symbol ->
- {pattern = Some <:patt< $lid:p$ >>; symbol = s}
- | i = LIDENT; lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] ->
- let name = mk_name loc <:expr< $lid:i$ >> in
- let text = TXnterm loc name lev in
- let styp = STquo loc i in
- let symb = {used = [i]; text = text; styp = styp} in
- {pattern = None; symbol = symb}
- | p = pattern; "="; s = symbol -> {pattern = Some p; symbol = s}
- | s = symbol -> {pattern = None; symbol = s} ] ]
- ;
- symbol:
- [ "top" NONA
- [ UIDENT "LIST0"; s = SELF;
- sep = OPT [ UIDENT "SEP"; t = symbol -> t ] ->
- if quotify.val then sslist loc False sep s
- else
- let used =
- match sep with
- [ Some symb -> symb.used @ s.used
- | None -> s.used ]
- in
- let styp = STapp loc (STlid loc "list") s.styp in
- let text = slist loc False sep s in
- {used = used; text = text; styp = styp}
- | UIDENT "LIST1"; s = SELF;
- sep = OPT [ UIDENT "SEP"; t = symbol -> t ] ->
- if quotify.val then sslist loc True sep s
- else
- let used =
- match sep with
- [ Some symb -> symb.used @ s.used
- | None -> s.used ]
- in
- let styp = STapp loc (STlid loc "list") s.styp in
- let text = slist loc True sep s in
- {used = used; text = text; styp = styp}
- | UIDENT "OPT"; s = SELF ->
- if quotify.val then ssopt loc s
- else
- let styp = STapp loc (STlid loc "option") s.styp in
- let text = TXopt loc s.text in
- {used = s.used; text = text; styp = styp} ]
- | [ UIDENT "SELF" ->
- {used = []; text = TXself loc; styp = STself loc "SELF"}
- | UIDENT "NEXT" ->
- {used = []; text = TXnext loc; styp = STself loc "NEXT"}
- | "["; rl = LIST0 rule SEP "|"; "]" ->
- let rl = retype_rule_list_without_patterns loc rl in
- let t = new_type_var () in
- {used = used_of_rule_list rl;
- text = TXrules loc (srules loc t rl "");
- styp = STquo loc t}
- | x = UIDENT ->
- let text =
- if quotify.val then sstoken loc x
- else TXtok loc x <:expr< "" >>
- in
- {used = []; text = text; styp = STlid loc "string"}
- | x = UIDENT; e = string ->
- let text = TXtok loc x e in
- {used = []; text = text; styp = STlid loc "string"}
- | e = string ->
- let text = TXtok loc "" e in
- {used = []; text = text; styp = STlid loc "string"}
- | i = UIDENT; "."; e = qualid;
- lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] ->
- let n = mk_name loc <:expr< $uid:i$ . $e$ >> in
- {used = [n.tvar]; text = TXnterm loc n lev;
- styp = STquo loc n.tvar}
- | n = name; lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] ->
- {used = [n.tvar]; text = TXnterm loc n lev;
- styp = STquo loc n.tvar}
- | "("; s_t = SELF; ")" -> s_t ] ]
- ;
- pattern:
- [ [ i = LIDENT -> <:patt< $lid:i$ >>
- | "_" -> <:patt< _ >>
- | "("; p = SELF; ")" -> <:patt< $p$ >>
- | "("; p = SELF; ","; pl = patterns_comma; ")" ->
- <:patt< ( $list:[p :: pl]$ ) >> ] ]
- ;
- patterns_comma:
- [ [ pl = SELF; ","; p = pattern -> pl @ [p] ]
- | [ p = pattern -> [p] ] ]
- ;
- name:
- [ [ e = qualid -> mk_name loc e ] ]
- ;
- qualid:
- [ [ e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >> ]
- | [ i = UIDENT -> <:expr< $uid:i$ >>
- | i = LIDENT -> <:expr< $lid:i$ >> ] ]
- ;
- string:
- [ [ s = STRING -> <:expr< $str:s$ >>
- | i = ANTIQUOT ->
- let shift = fst loc + String.length "$" in
- let e =
- try Grammar.Entry.parse Pcaml.expr_eoi (Stream.of_string i) with
- [ Exc_located (bp, ep) exc ->
- raise_with_loc (shift + bp, shift + ep) exc ]
- in
- Pcaml.expr_reloc (fun (bp, ep) -> (shift + bp, shift + ep)) 0 e ] ]
- ;
-END;
-
-Pcaml.add_option "-quotify" (Arg.Set quotify)
- "Generate code for quotations";
-
-Pcaml.add_option "-meta_action" (Arg.Set meta_action)
- "Undocumented";
diff --git a/camlp4/meta/pa_extend_m.ml b/camlp4/meta/pa_extend_m.ml
deleted file mode 100644
index 7e000dd7b4..0000000000
--- a/camlp4/meta/pa_extend_m.ml
+++ /dev/null
@@ -1,26 +0,0 @@
-(* camlp4r pa_extend.cmo q_MLast.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Pa_extend;
-
-EXTEND
- symbol: LEVEL "top"
- [ NONA
- [ min = [ UIDENT "SLIST0" -> False | UIDENT "SLIST1" -> True ];
- s = SELF; sep = OPT [ UIDENT "SEP"; t = symbol -> t ] ->
- sslist loc min sep s
- | UIDENT "SOPT"; s = SELF ->
- ssopt loc s ] ]
- ;
-END;
diff --git a/camlp4/meta/pa_ifdef.ml b/camlp4/meta/pa_ifdef.ml
deleted file mode 100644
index 59d448ef1b..0000000000
--- a/camlp4/meta/pa_ifdef.ml
+++ /dev/null
@@ -1,85 +0,0 @@
-(* camlp4r pa_extend.cmo q_MLast.cmo *)
-(* $Id$ *)
-
-type item_or_def 'a =
- [ SdStr of 'a | SdDef of string | SdUnd of string | SdNop ]
-;
-
-value list_remove x l =
- List.fold_right (fun e l -> if e = x then l else [e :: l]) l []
-;
-
-value defined = ref ["OCAML_305"; "CAMLP4_300"; "NEWSEQ"];
-value define x = defined.val := [x :: defined.val];
-value undef x = defined.val := list_remove x defined.val;
-
-EXTEND
- GLOBAL: Pcaml.expr Pcaml.str_item Pcaml.sig_item;
- Pcaml.expr: LEVEL "top"
- [ [ "ifdef"; c = UIDENT; "then"; e1 = Pcaml.expr; "else";
- e2 = Pcaml.expr ->
- if List.mem c defined.val then e1 else e2
- | "ifndef"; c = UIDENT; "then"; e1 = Pcaml.expr; "else";
- e2 = Pcaml.expr ->
- if List.mem c defined.val then e2 else e1 ] ]
- ;
- Pcaml.str_item: FIRST
- [ [ x = def_undef_str ->
- match x with
- [ SdStr si -> si
- | SdDef x -> do { define x; <:str_item< declare end >> }
- | SdUnd x -> do { undef x; <:str_item< declare end >> }
- | SdNop -> <:str_item< declare end >> ] ] ]
- ;
- def_undef_str:
- [ [ "ifdef"; c = UIDENT; "then"; e1 = str_item_def_undef;
- "else"; e2 = str_item_def_undef ->
- if List.mem c defined.val then e1 else e2
- | "ifdef"; c = UIDENT; "then"; e1 = str_item_def_undef ->
- if List.mem c defined.val then e1 else SdNop
- | "ifndef"; c = UIDENT; "then"; e1 = str_item_def_undef;
- "else"; e2 = str_item_def_undef ->
- if List.mem c defined.val then e2 else e1
- | "ifndef"; c = UIDENT; "then"; e1 = str_item_def_undef ->
- if List.mem c defined.val then SdNop else e1
- | "define"; c = UIDENT -> SdDef c
- | "undef"; c = UIDENT -> SdUnd c ] ]
- ;
- str_item_def_undef:
- [ [ d = def_undef_str -> d
- | si = Pcaml.str_item -> SdStr si ] ]
- ;
- Pcaml.sig_item: FIRST
- [ [ x = def_undef_sig ->
- match x with
- [ SdStr si -> si
- | SdDef x -> do { define x; <:sig_item< declare end >> }
- | SdUnd x -> do { undef x; <:sig_item< declare end >> }
- | SdNop -> <:sig_item< declare end >> ] ] ]
- ;
- def_undef_sig:
- [ [ "ifdef"; c = UIDENT; "then"; e1 = sig_item_def_undef;
- "else"; e2 = sig_item_def_undef ->
- if List.mem c defined.val then e1 else e2
- | "ifdef"; c = UIDENT; "then"; e1 = sig_item_def_undef ->
- if List.mem c defined.val then e1 else SdNop
- | "ifndef"; c = UIDENT; "then"; e1 = sig_item_def_undef;
- "else"; e2 = sig_item_def_undef ->
- if List.mem c defined.val then e2 else e1
- | "ifndef"; c = UIDENT; "then"; e1 = sig_item_def_undef ->
- if List.mem c defined.val then SdNop else e1
- | "define"; c = UIDENT -> SdDef c
- | "undef"; c = UIDENT -> SdUnd c ] ]
- ;
- sig_item_def_undef:
- [ [ d = def_undef_sig -> d
- | si = Pcaml.sig_item -> SdStr si ] ]
- ;
-END;
-
-Pcaml.add_option "-D" (Arg.String define)
- "<string> Define for ifdef instruction."
-;
-Pcaml.add_option "-U" (Arg.String undef)
- "<string> Undefine for ifdef instruction."
-;
diff --git a/camlp4/meta/pa_macro.ml b/camlp4/meta/pa_macro.ml
deleted file mode 100644
index 406a3bd622..0000000000
--- a/camlp4/meta/pa_macro.ml
+++ /dev/null
@@ -1,251 +0,0 @@
-(* camlp4r *)
-(* $Id$ *)
-
-(*
-Added statements:
-
- At toplevel (structure item):
-
- DEFINE <uident>
- DEFINE <uident> = <expression>
- DEFINE <uident> (<parameters>) = <expression>
- IFDEF <uident> THEN <structure_items> END
- IFDEF <uident> THEN <structure_items> ELSE <structure_items> END
- IFNDEF <uident> THEN <structure_items> END
- IFNDEF <uident> THEN <structure_items> ELSE <structure_items> END
-
- In expressions:
-
- IFDEF <uident> THEN <expression> ELSE <expression> END
- IFNDEF <uident> THEN <expression> ELSE <expression> END
- __FILE__
- __LOCATION__
-
- In patterns:
-
- IFDEF <uident> THEN <pattern> ELSE <pattern> END
- IFNDEF <uident> THEN <pattern> ELSE <pattern> END
-
- As Camlp4 options:
-
- -D<uident>
- -U<uident>
-
- After having used a DEFINE <uident> followed by "= <expression>", you
- can use it in expressions *and* in patterns. If the expression defining
- the macro cannot be used as a pattern, there is an error message if
- it is used in a pattern.
-
- The expression __FILE__ returns the current compiled file name.
- The expression __LOCATION__ returns the current location of itself.
-
-*)
-
-#load "pa_extend.cmo";
-#load "q_MLast.cmo";
-
-open Pcaml;
-
-type item_or_def 'a =
- [ SdStr of 'a
- | SdDef of string and option (list string * MLast.expr)
- | SdUnd of string
- | SdNop ]
-;
-
-value rec list_remove x =
- fun
- [ [(y, _) :: l] when y = x -> l
- | [d :: l] -> [d :: list_remove x l]
- | [] -> [] ]
-;
-
-value defined = ref [];
-
-value is_defined i = List.mem_assoc i defined.val;
-
-value loc = (0, 0);
-
-value subst mloc env =
- loop where rec loop =
- fun
- [ <:expr< let $opt:rf$ $list:pel$ in $e$ >> ->
- let pel = List.map (fun (p, e) -> (p, loop e)) pel in
- <:expr< let $opt:rf$ $list:pel$ in $loop e$ >>
- | <:expr< if $e1$ then $e2$ else $e3$ >> ->
- <:expr< if $loop e1$ then $loop e2$ else $loop e3$ >>
- | <:expr< $e1$ $e2$ >> -> <:expr< $loop e1$ $loop e2$ >>
- | <:expr< $lid:x$ >> | <:expr< $uid:x$ >> as e ->
- try <:expr< $anti:List.assoc x env$ >> with
- [ Not_found -> e ]
- | <:expr< ($list:x$) >> -> <:expr< ($list:List.map loop x$) >>
- | <:expr< { $list:pel$ } >> ->
- let pel = List.map (fun (p, e) -> (p, loop e)) pel in
- <:expr< { $list:pel$ } >>
- | e -> e ]
-;
-
-value substp mloc env =
- loop where rec loop =
- fun
- [ <:expr< $e1$ $e2$ >> -> <:patt< $loop e1$ $loop e2$ >>
- | <:expr< $lid:x$ >> ->
- try <:patt< $anti:List.assoc x env$ >> with
- [ Not_found -> <:patt< $lid:x$ >> ]
- | <:expr< $uid:x$ >> ->
- try <:patt< $anti:List.assoc x env$ >> with
- [ Not_found -> <:patt< $uid:x$ >> ]
- | <:expr< $int:x$ >> -> <:patt< $int:x$ >>
- | <:expr< ($list:x$) >> -> <:patt< ($list:List.map loop x$) >>
- | <:expr< { $list:pel$ } >> ->
- let ppl = List.map (fun (p, e) -> (p, loop e)) pel in
- <:patt< { $list:ppl$ } >>
- | x ->
- Stdpp.raise_with_loc mloc
- (Failure
- "this macro cannot be used in a pattern (see its definition)") ]
-;
-
-value incorrect_number loc l1 l2 =
- Stdpp.raise_with_loc loc
- (Failure
- (Printf.sprintf "expected %d parameters; found %d"
- (List.length l2) (List.length l1)))
-;
-
-value define eo x =
- do {
- match eo with
- [ Some ([], e) ->
- EXTEND
- expr: LEVEL "simple"
- [ [ UIDENT $x$ -> Pcaml.expr_reloc (fun _ -> loc) 0 e ] ]
- ;
- patt: LEVEL "simple"
- [ [ UIDENT $x$ ->
- let p = substp loc [] e in
- Pcaml.patt_reloc (fun _ -> loc) 0 p ] ]
- ;
- END
- | Some (sl, e) ->
- EXTEND
- expr: LEVEL "apply"
- [ [ UIDENT $x$; param = SELF ->
- let el =
- match param with
- [ <:expr< ($list:el$) >> -> el
- | e -> [e] ]
- in
- if List.length el = List.length sl then
- let env = List.combine sl el in
- let e = subst loc env e in
- Pcaml.expr_reloc (fun _ -> loc) 0 e
- else
- incorrect_number loc el sl ] ]
- ;
- patt: LEVEL "simple"
- [ [ UIDENT $x$; param = SELF ->
- let pl =
- match param with
- [ <:patt< ($list:pl$) >> -> pl
- | p -> [p] ]
- in
- if List.length pl = List.length sl then
- let env = List.combine sl pl in
- let p = substp loc env e in
- Pcaml.patt_reloc (fun _ -> loc) 0 p
- else
- incorrect_number loc pl sl ] ]
- ;
- END
- | None -> () ];
- defined.val := [(x, eo) :: defined.val];
- }
-;
-
-value undef x =
- try
- do {
- let eo = List.assoc x defined.val in
- match eo with
- [ Some ([], _) ->
- do {
- DELETE_RULE expr: UIDENT $x$ END;
- DELETE_RULE patt: UIDENT $x$ END;
- }
- | Some (_, _) ->
- do {
- DELETE_RULE expr: UIDENT $x$; SELF END;
- DELETE_RULE patt: UIDENT $x$; SELF END;
- }
- | None -> () ];
- defined.val := list_remove x defined.val;
- }
- with
- [ Not_found -> () ]
-;
-
-EXTEND
- GLOBAL: expr patt str_item sig_item;
- str_item: FIRST
- [ [ x = macro_def ->
- match x with
- [ SdStr [si] -> si
- | SdStr sil -> <:str_item< declare $list:sil$ end >>
- | SdDef x eo -> do { define eo x; <:str_item< declare end >> }
- | SdUnd x -> do { undef x; <:str_item< declare end >> }
- | SdNop -> <:str_item< declare end >> ] ] ]
- ;
- macro_def:
- [ [ "DEFINE"; i = uident; def = opt_macro_value -> SdDef i def
- | "UNDEF"; i = uident -> SdUnd i
- | "IFDEF"; i = uident; "THEN"; d = str_item_or_macro; "END" ->
- if is_defined i then d else SdNop
- | "IFDEF"; i = uident; "THEN"; d1 = str_item_or_macro; "ELSE";
- d2 = str_item_or_macro; "END" ->
- if is_defined i then d1 else d2
- | "IFNDEF"; i = uident; "THEN"; d = str_item_or_macro; "END" ->
- if is_defined i then SdNop else d
- | "IFNDEF"; i = uident; "THEN"; d1 = str_item_or_macro; "ELSE";
- d2 = str_item_or_macro; "END" ->
- if is_defined i then d2 else d1 ] ]
- ;
- str_item_or_macro:
- [ [ d = macro_def -> d
- | si = LIST1 str_item -> SdStr si ] ]
- ;
- opt_macro_value:
- [ [ "("; pl = LIST1 LIDENT SEP ","; ")"; "="; e = expr -> Some (pl, e)
- | "="; e = expr -> Some ([], e)
- | -> None ] ]
- ;
- expr: LEVEL "top"
- [ [ "IFDEF"; i = uident; "THEN"; e1 = expr; "ELSE"; e2 = expr; "END" ->
- if is_defined i then e1 else e2
- | "IFNDEF"; i = uident; "THEN"; e1 = expr; "ELSE"; e2 = expr; "END" ->
- if is_defined i then e2 else e1 ] ]
- ;
- expr: LEVEL "simple"
- [ [ LIDENT "__FILE__" -> <:expr< $str:Pcaml.input_file.val$ >>
- | LIDENT "__LOCATION__" ->
- let bp = string_of_int (fst loc) in
- let ep = string_of_int (snd loc) in
- <:expr< ($int:bp$, $int:ep$) >> ] ]
- ;
- patt:
- [ [ "IFDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; "END" ->
- if is_defined i then p1 else p2
- | "IFNDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; "END" ->
- if is_defined i then p2 else p1 ] ]
- ;
- uident:
- [ [ i = UIDENT -> i ] ]
- ;
-END;
-
-Pcaml.add_option "-D" (Arg.String (define None))
- "<string> Define for IFDEF instruction."
-;
-Pcaml.add_option "-U" (Arg.String undef)
- "<string> Undefine for IFDEF instruction."
-;
diff --git a/camlp4/meta/pa_r.ml b/camlp4/meta/pa_r.ml
deleted file mode 100644
index dd6b499ac5..0000000000
--- a/camlp4/meta/pa_r.ml
+++ /dev/null
@@ -1,943 +0,0 @@
-(* camlp4r pa_extend.cmo q_MLast.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Stdpp;
-open Pcaml;
-
-Pcaml.no_constructors_arity.val := False;
-
-value help_sequences () =
- do {
- Printf.eprintf "\
-New syntax:
- do {e1; e2; ... ; en}
- while e do {e1; e2; ... ; en}
- for v = v1 to/downto v2 do {e1; e2; ... ; en}
-Old (discouraged) syntax:
- do e1; e2; ... ; en-1; return en
- while e do e1; e2; ... ; en; done
- for v = v1 to/downto v2 do e1; e2; ... ; en; done
-To avoid compilation warning use the new syntax.
-";
- flush stderr;
- exit 1
- }
-;
-Pcaml.add_option "-help_seq" (Arg.Unit help_sequences)
- "Print explanations about new sequences and exit.";
-
-do {
- let odfa = Plexer.dollar_for_antiquotation.val in
- Plexer.dollar_for_antiquotation.val := False;
- Grammar.Unsafe.gram_reinit gram (Plexer.gmake ());
- Plexer.dollar_for_antiquotation.val := odfa;
- Grammar.Unsafe.clear_entry interf;
- Grammar.Unsafe.clear_entry implem;
- Grammar.Unsafe.clear_entry top_phrase;
- Grammar.Unsafe.clear_entry use_file;
- Grammar.Unsafe.clear_entry module_type;
- Grammar.Unsafe.clear_entry module_expr;
- Grammar.Unsafe.clear_entry sig_item;
- Grammar.Unsafe.clear_entry str_item;
- Grammar.Unsafe.clear_entry expr;
- Grammar.Unsafe.clear_entry patt;
- Grammar.Unsafe.clear_entry ctyp;
- Grammar.Unsafe.clear_entry let_binding;
- Grammar.Unsafe.clear_entry type_declaration;
- Grammar.Unsafe.clear_entry class_type;
- Grammar.Unsafe.clear_entry class_expr;
- Grammar.Unsafe.clear_entry class_sig_item;
- Grammar.Unsafe.clear_entry class_str_item
-};
-
-Pcaml.parse_interf.val := Grammar.Entry.parse interf;
-Pcaml.parse_implem.val := Grammar.Entry.parse implem;
-
-value o2b =
- fun
- [ Some _ -> True
- | None -> False ]
-;
-
-value mksequence loc =
- fun
- [ [e] -> e
- | el -> <:expr< do { $list:el$ } >> ]
-;
-
-value mkmatchcase loc p aso w e =
- let p =
- match aso with
- [ Some p2 -> <:patt< ($p$ as $p2$) >>
- | _ -> p ]
- in
- (p, w, e)
-;
-
-value neg_string n =
- let len = String.length n in
- if len > 0 && n.[0] = '-' then String.sub n 1 (len - 1)
- else "-" ^ n
-;
-
-value mkumin loc f arg =
- match arg with
- [ <:expr< $int:n$ >> -> <:expr< $int:neg_string n$ >>
- | MLast.ExInt32 loc n -> MLast.ExInt32 loc (neg_string n)
- | MLast.ExInt64 loc n -> MLast.ExInt64 loc (neg_string n)
- | MLast.ExNativeInt loc n -> MLast.ExNativeInt loc (neg_string n)
- | <:expr< $flo:n$ >> -> <:expr< $flo:neg_string n$ >>
- | _ ->
- let f = "~" ^ f in
- <:expr< $lid:f$ $arg$ >> ]
-;
-
-value mklistexp loc last =
- loop True where rec loop top =
- fun
- [ [] ->
- match last with
- [ Some e -> e
- | None -> <:expr< [] >> ]
- | [e1 :: el] ->
- let loc =
- if top then loc else (fst (MLast.loc_of_expr e1), snd loc)
- in
- <:expr< [$e1$ :: $loop False el$] >> ]
-;
-
-value mklistpat loc last =
- loop True where rec loop top =
- fun
- [ [] ->
- match last with
- [ Some p -> p
- | None -> <:patt< [] >> ]
- | [p1 :: pl] ->
- let loc =
- if top then loc else (fst (MLast.loc_of_patt p1), snd loc)
- in
- <:patt< [$p1$ :: $loop False pl$] >> ]
-;
-
-value mkexprident loc i j =
- let rec loop m =
- fun
- [ <:expr< $x$ . $y$ >> -> loop <:expr< $m$ . $x$ >> y
- | e -> <:expr< $m$ . $e$ >> ]
- in
- loop <:expr< $uid:i$ >> j
-;
-
-value mkassert loc e =
- match e with
- [ <:expr< False >> -> MLast.ExAsf loc
- | _ -> MLast.ExAsr loc e ]
-;
-
-value append_elem el e = el @ [e];
-
-(* ...suppose to flush the input in case of syntax error to avoid multiple
- errors in case of cut-and-paste in the xterm, but work bad: for example
- the input "for x = 1;" waits for another line before displaying the
- error...
-value rec sync cs =
- match cs with parser
- [ [: `';' :] -> sync_semi cs
- | [: `_ :] -> sync cs ]
-and sync_semi cs =
- match Stream.peek cs with
- [ Some ('\010' | '\013') -> ()
- | _ -> sync cs ]
-;
-Pcaml.sync.val := sync;
-*)
-
-value ipatt = Grammar.Entry.create gram "ipatt";
-value with_constr = Grammar.Entry.create gram "with_constr";
-value row_field = Grammar.Entry.create gram "row_field";
-
-value not_yet_warned_variant = ref True;
-value warn_variant loc =
- if not_yet_warned_variant.val then do {
- not_yet_warned_variant.val := False;
- Pcaml.warning.val loc
- (Printf.sprintf
- "use of syntax of variants types deprecated since version 3.05");
- }
- else ()
-;
-
-value not_yet_warned = ref True;
-value warn_sequence loc =
- if not_yet_warned.val then do {
- not_yet_warned.val := False;
- Pcaml.warning.val loc
- ("use of syntax of sequences deprecated since version 3.01.1");
- }
- else ()
-;
-Pcaml.add_option "-no_warn_seq" (Arg.Clear not_yet_warned)
- "No warning when using old syntax for sequences.";
-
-EXTEND
- GLOBAL: sig_item str_item ctyp patt expr module_type module_expr class_type
- class_expr class_sig_item class_str_item let_binding type_declaration
- ipatt with_constr row_field;
- module_expr:
- [ [ "functor"; "("; i = UIDENT; ":"; t = module_type; ")"; "->";
- me = SELF ->
- <:module_expr< functor ( $i$ : $t$ ) -> $me$ >>
- | "struct"; st = LIST0 [ s = str_item; ";" -> s ]; "end" ->
- <:module_expr< struct $list:st$ end >> ]
- | [ me1 = SELF; me2 = SELF -> <:module_expr< $me1$ $me2$ >> ]
- | [ me1 = SELF; "."; me2 = SELF -> <:module_expr< $me1$ . $me2$ >> ]
- | "simple"
- [ i = UIDENT -> <:module_expr< $uid:i$ >>
- | "("; me = SELF; ":"; mt = module_type; ")" ->
- <:module_expr< ( $me$ : $mt$ ) >>
- | "("; me = SELF; ")" -> <:module_expr< $me$ >> ] ]
- ;
- str_item:
- [ "top"
- [ "declare"; st = LIST0 [ s = str_item; ";" -> s ]; "end" ->
- <:str_item< declare $list:st$ end >>
- | "exception"; (_, c, tl) = constructor_declaration; b = rebind_exn ->
- <:str_item< exception $c$ of $list:tl$ = $b$ >>
- | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING ->
- <:str_item< external $i$ : $t$ = $list:pd$ >>
- | "include"; me = module_expr -> <:str_item< include $me$ >>
- | "module"; i = UIDENT; mb = module_binding ->
- <:str_item< module $i$ = $mb$ >>
- | "module"; "rec"; nmtmes = LIST1 module_rec_binding SEP "and" ->
- MLast.StRecMod loc nmtmes
- | "module"; "type"; i = UIDENT; "="; mt = module_type ->
- <:str_item< module type $i$ = $mt$ >>
- | "open"; i = mod_ident -> <:str_item< open $i$ >>
- | "type"; tdl = LIST1 type_declaration SEP "and" ->
- <:str_item< type $list:tdl$ >>
- | "value"; r = OPT "rec"; l = LIST1 let_binding SEP "and" ->
- <:str_item< value $opt:o2b r$ $list:l$ >>
- | e = expr -> <:str_item< $exp:e$ >> ] ]
- ;
- rebind_exn:
- [ [ "="; sl = mod_ident -> sl
- | -> [] ] ]
- ;
- module_binding:
- [ RIGHTA
- [ "("; m = UIDENT; ":"; mt = module_type; ")"; mb = SELF ->
- <:module_expr< functor ( $m$ : $mt$ ) -> $mb$ >>
- | ":"; mt = module_type; "="; me = module_expr ->
- <:module_expr< ( $me$ : $mt$ ) >>
- | "="; me = module_expr -> <:module_expr< $me$ >> ] ]
- ;
- module_rec_binding:
- [ [ m = UIDENT; ":"; mt = module_type; "="; me = module_expr ->
- (m, mt, me) ] ]
- ;
- module_type:
- [ [ "functor"; "("; i = UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF ->
- <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ]
- | [ mt = SELF; "with"; wcl = LIST1 with_constr SEP "and" ->
- <:module_type< $mt$ with $list:wcl$ >> ]
- | [ "sig"; sg = LIST0 [ s = sig_item; ";" -> s ]; "end" ->
- <:module_type< sig $list:sg$ end >> ]
- | [ m1 = SELF; m2 = SELF -> <:module_type< $m1$ $m2$ >> ]
- | [ m1 = SELF; "."; m2 = SELF -> <:module_type< $m1$ . $m2$ >> ]
- | "simple"
- [ i = UIDENT -> <:module_type< $uid:i$ >>
- | i = LIDENT -> <:module_type< $lid:i$ >>
- | "'"; i = ident -> <:module_type< ' $i$ >>
- | "("; mt = SELF; ")" -> <:module_type< $mt$ >> ] ]
- ;
- sig_item:
- [ "top"
- [ "declare"; st = LIST0 [ s = sig_item; ";" -> s ]; "end" ->
- <:sig_item< declare $list:st$ end >>
- | "exception"; (_, c, tl) = constructor_declaration ->
- <:sig_item< exception $c$ of $list:tl$ >>
- | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING ->
- <:sig_item< external $i$ : $t$ = $list:pd$ >>
- | "include"; mt = module_type -> <:sig_item< include $mt$ >>
- | "module"; i = UIDENT; mt = module_declaration ->
- <:sig_item< module $i$ : $mt$ >>
- | "module"; "rec"; mds = LIST1 module_rec_declaration SEP "and" ->
- MLast.SgRecMod loc mds
- | "module"; "type"; i = UIDENT; "="; mt = module_type ->
- <:sig_item< module type $i$ = $mt$ >>
- | "open"; i = mod_ident -> <:sig_item< open $i$ >>
- | "type"; tdl = LIST1 type_declaration SEP "and" ->
- <:sig_item< type $list:tdl$ >>
- | "value"; i = LIDENT; ":"; t = ctyp ->
- <:sig_item< value $i$ : $t$ >> ] ]
- ;
- module_declaration:
- [ RIGHTA
- [ ":"; mt = module_type -> <:module_type< $mt$ >>
- | "("; i = UIDENT; ":"; t = module_type; ")"; mt = SELF ->
- <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] ]
- ;
- module_rec_declaration:
- [ [ m = UIDENT; ":"; mt = module_type -> (m, mt)] ]
- ;
- with_constr:
- [ [ "type"; i = mod_ident; tpl = LIST0 type_parameter; "="; t = ctyp ->
- <:with_constr< type $i$ $list:tpl$ = $t$ >>
- | "module"; i = mod_ident; "="; me = module_expr ->
- <:with_constr< module $i$ = $me$ >> ] ]
- ;
- expr:
- [ "top" RIGHTA
- [ "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and"; "in";
- x = SELF ->
- <:expr< let $opt:o2b r$ $list:l$ in $x$ >>
- | "let"; "module"; m = UIDENT; mb = module_binding; "in"; e = SELF ->
- <:expr< let module $m$ = $mb$ in $e$ >>
- | "fun"; "["; l = LIST0 match_case SEP "|"; "]" ->
- <:expr< fun [ $list:l$ ] >>
- | "fun"; p = ipatt; e = fun_def -> <:expr< fun $p$ -> $e$ >>
- | "match"; e = SELF; "with"; "["; l = LIST0 match_case SEP "|"; "]" ->
- <:expr< match $e$ with [ $list:l$ ] >>
- | "match"; e = SELF; "with"; p1 = ipatt; "->"; e1 = SELF ->
- <:expr< match $e$ with $p1$ -> $e1$ >>
- | "try"; e = SELF; "with"; "["; l = LIST0 match_case SEP "|"; "]" ->
- <:expr< try $e$ with [ $list:l$ ] >>
- | "try"; e = SELF; "with"; p1 = ipatt; "->"; e1 = SELF ->
- <:expr< try $e$ with $p1$ -> $e1$ >>
- | "if"; e1 = SELF; "then"; e2 = SELF; "else"; e3 = SELF ->
- <:expr< if $e1$ then $e2$ else $e3$ >>
- | "do"; "{"; seq = sequence; "}" -> mksequence loc seq
- | "for"; i = LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF;
- "do"; "{"; seq = sequence; "}" ->
- <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:seq$ } >>
- | "while"; e = SELF; "do"; "{"; seq = sequence; "}" ->
- <:expr< while $e$ do { $list:seq$ } >> ]
- | "where"
- [ e = SELF; "where"; rf = OPT "rec"; lb = let_binding ->
- <:expr< let $opt:o2b rf$ $list:[lb]$ in $e$ >> ]
- | ":=" NONA
- [ e1 = SELF; ":="; e2 = SELF; dummy -> <:expr< $e1$ := $e2$ >> ]
- | "||" RIGHTA
- [ e1 = SELF; "||"; e2 = SELF -> <:expr< $e1$ || $e2$ >> ]
- | "&&" RIGHTA
- [ e1 = SELF; "&&"; e2 = SELF -> <:expr< $e1$ && $e2$ >> ]
- | "<" LEFTA
- [ e1 = SELF; "<"; e2 = SELF -> <:expr< $e1$ < $e2$ >>
- | e1 = SELF; ">"; e2 = SELF -> <:expr< $e1$ > $e2$ >>
- | e1 = SELF; "<="; e2 = SELF -> <:expr< $e1$ <= $e2$ >>
- | e1 = SELF; ">="; e2 = SELF -> <:expr< $e1$ >= $e2$ >>
- | e1 = SELF; "="; e2 = SELF -> <:expr< $e1$ = $e2$ >>
- | e1 = SELF; "<>"; e2 = SELF -> <:expr< $e1$ <> $e2$ >>
- | e1 = SELF; "=="; e2 = SELF -> <:expr< $e1$ == $e2$ >>
- | e1 = SELF; "!="; e2 = SELF -> <:expr< $e1$ != $e2$ >> ]
- | "^" RIGHTA
- [ e1 = SELF; "^"; e2 = SELF -> <:expr< $e1$ ^ $e2$ >>
- | e1 = SELF; "@"; e2 = SELF -> <:expr< $e1$ @ $e2$ >> ]
- | "+" LEFTA
- [ e1 = SELF; "+"; e2 = SELF -> <:expr< $e1$ + $e2$ >>
- | e1 = SELF; "-"; e2 = SELF -> <:expr< $e1$ - $e2$ >>
- | e1 = SELF; "+."; e2 = SELF -> <:expr< $e1$ +. $e2$ >>
- | e1 = SELF; "-."; e2 = SELF -> <:expr< $e1$ -. $e2$ >> ]
- | "*" LEFTA
- [ e1 = SELF; "*"; e2 = SELF -> <:expr< $e1$ * $e2$ >>
- | e1 = SELF; "/"; e2 = SELF -> <:expr< $e1$ / $e2$ >>
- | e1 = SELF; "*."; e2 = SELF -> <:expr< $e1$ *. $e2$ >>
- | e1 = SELF; "/."; e2 = SELF -> <:expr< $e1$ /. $e2$ >>
- | e1 = SELF; "land"; e2 = SELF -> <:expr< $e1$ land $e2$ >>
- | e1 = SELF; "lor"; e2 = SELF -> <:expr< $e1$ lor $e2$ >>
- | e1 = SELF; "lxor"; e2 = SELF -> <:expr< $e1$ lxor $e2$ >>
- | e1 = SELF; "mod"; e2 = SELF -> <:expr< $e1$ mod $e2$ >> ]
- | "**" RIGHTA
- [ e1 = SELF; "**"; e2 = SELF -> <:expr< $e1$ ** $e2$ >>
- | e1 = SELF; "asr"; e2 = SELF -> <:expr< $e1$ asr $e2$ >>
- | e1 = SELF; "lsl"; e2 = SELF -> <:expr< $e1$ lsl $e2$ >>
- | e1 = SELF; "lsr"; e2 = SELF -> <:expr< $e1$ lsr $e2$ >> ]
- | "unary minus" NONA
- [ "-"; e = SELF -> mkumin loc "-" e
- | "-."; e = SELF -> mkumin loc "-." e ]
- | "apply" LEFTA
- [ e1 = SELF; e2 = SELF -> <:expr< $e1$ $e2$ >>
- | "assert"; e = SELF -> mkassert loc e
- | "lazy"; e = SELF -> <:expr< lazy ($e$) >> ]
- | "." LEFTA
- [ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >>
- | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >>
- | e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >> ]
- | "~-" NONA
- [ "~-"; e = SELF -> <:expr< ~- $e$ >>
- | "~-."; e = SELF -> <:expr< ~-. $e$ >> ]
- | "simple"
- [ s = INT -> <:expr< $int:s$ >>
- | s = INT32 -> MLast.ExInt32 loc s
- | s = INT64 -> MLast.ExInt64 loc s
- | s = NATIVEINT -> MLast.ExNativeInt loc s
- | s = FLOAT -> <:expr< $flo:s$ >>
- | s = STRING -> <:expr< $str:s$ >>
- | s = CHAR -> <:expr< $chr:s$ >>
- | i = expr_ident -> i
- | "["; "]" -> <:expr< [] >>
- | "["; el = LIST1 expr SEP ";"; last = cons_expr_opt; "]" ->
- mklistexp loc last el
- | "[|"; el = LIST0 expr SEP ";"; "|]" -> <:expr< [| $list:el$ |] >>
- | "{"; lel = LIST1 label_expr SEP ";"; "}" -> <:expr< { $list:lel$ } >>
- | "{"; "("; e = SELF; ")"; "with"; lel = LIST1 label_expr SEP ";";
- "}" ->
- <:expr< { ($e$) with $list:lel$ } >>
- | "("; ")" -> <:expr< () >>
- | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >>
- | "("; e = SELF; ","; el = LIST1 expr SEP ","; ")" ->
- <:expr< ( $list:[e::el]$) >>
- | "("; e = SELF; ")" -> <:expr< $e$ >> ] ]
- ;
- cons_expr_opt:
- [ [ "::"; e = expr -> Some e
- | -> None ] ]
- ;
- dummy:
- [ [ -> () ] ]
- ;
- sequence:
- [ [ "let"; rf = OPT "rec"; l = LIST1 let_binding SEP "and"; [ "in" | ";" ];
- el = SELF ->
- [<:expr< let $opt:o2b rf$ $list:l$ in $mksequence loc el$ >>]
- | e = expr; ";"; el = SELF -> [e :: el]
- | e = expr; ";" -> [e]
- | e = expr -> [e] ] ]
- ;
- let_binding:
- [ [ p = ipatt; e = fun_binding -> (p, e) ] ]
- ;
- fun_binding:
- [ RIGHTA
- [ p = ipatt; e = SELF -> <:expr< fun $p$ -> $e$ >>
- | "="; e = expr -> <:expr< $e$ >>
- | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> ] ]
- ;
- match_case:
- [ [ p = patt; aso = as_patt_opt; w = when_expr_opt; "->"; e = expr ->
- mkmatchcase loc p aso w e ] ]
- ;
- as_patt_opt:
- [ [ "as"; p = patt -> Some p
- | -> None ] ]
- ;
- when_expr_opt:
- [ [ "when"; e = expr -> Some e
- | -> None ] ]
- ;
- label_expr:
- [ [ i = patt_label_ident; e = fun_binding -> (i, e) ] ]
- ;
- expr_ident:
- [ RIGHTA
- [ i = LIDENT -> <:expr< $lid:i$ >>
- | i = UIDENT -> <:expr< $uid:i$ >>
- | i = UIDENT; "."; j = SELF -> mkexprident loc i j ] ]
- ;
- fun_def:
- [ RIGHTA
- [ p = ipatt; e = SELF -> <:expr< fun $p$ -> $e$ >>
- | "->"; e = expr -> e ] ]
- ;
- patt:
- [ LEFTA
- [ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ]
- | NONA
- [ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ]
- | LEFTA
- [ p1 = SELF; p2 = SELF -> <:patt< $p1$ $p2$ >> ]
- | LEFTA
- [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ]
- | "simple"
- [ s = LIDENT -> <:patt< $lid:s$ >>
- | s = UIDENT -> <:patt< $uid:s$ >>
- | s = INT -> <:patt< $int:s$ >>
- | s = INT32 -> MLast.PaInt32 loc s
- | s = INT64 -> MLast.PaInt64 loc s
- | s = NATIVEINT -> MLast.PaNativeInt loc s
- | s = FLOAT -> <:patt< $flo:s$ >>
- | s = STRING -> <:patt< $str:s$ >>
- | s = CHAR -> <:patt< $chr:s$ >>
- | "-"; s = INT -> MLast.PaInt loc (neg_string s)
- | "-"; s = INT32 -> MLast.PaInt32 loc (neg_string s)
- | "-"; s = INT64 -> MLast.PaInt64 loc (neg_string s)
- | "-"; s = NATIVEINT -> MLast.PaNativeInt loc (neg_string s)
- | "-"; s = FLOAT -> <:patt< $flo:neg_string s$ >>
- | "["; "]" -> <:patt< [] >>
- | "["; pl = LIST1 patt SEP ";"; last = cons_patt_opt; "]" ->
- mklistpat loc last pl
- | "[|"; pl = LIST0 patt SEP ";"; "|]" -> <:patt< [| $list:pl$ |] >>
- | "{"; lpl = LIST1 label_patt SEP ";"; "}" -> <:patt< { $list:lpl$ } >>
- | "("; ")" -> <:patt< () >>
- | "("; p = SELF; ")" -> <:patt< $p$ >>
- | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >>
- | "("; p = SELF; "as"; p2 = SELF; ")" -> <:patt< ($p$ as $p2$) >>
- | "("; p = SELF; ","; pl = LIST1 patt SEP ","; ")" ->
- <:patt< ( $list:[p::pl]$) >>
- | "_" -> <:patt< _ >> ] ]
- ;
- cons_patt_opt:
- [ [ "::"; p = patt -> Some p
- | -> None ] ]
- ;
- label_patt:
- [ [ i = patt_label_ident; "="; p = patt -> (i, p) ] ]
- ;
- patt_label_ident:
- [ LEFTA
- [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ]
- | "simple" RIGHTA
- [ i = UIDENT -> <:patt< $uid:i$ >>
- | i = LIDENT -> <:patt< $lid:i$ >> ] ]
- ;
- ipatt:
- [ [ "{"; lpl = LIST1 label_ipatt SEP ";"; "}" -> <:patt< { $list:lpl$ } >>
- | "("; ")" -> <:patt< () >>
- | "("; p = SELF; ")" -> <:patt< $p$ >>
- | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >>
- | "("; p = SELF; "as"; p2 = SELF; ")" -> <:patt< ($p$ as $p2$) >>
- | "("; p = SELF; ","; pl = LIST1 ipatt SEP ","; ")" ->
- <:patt< ( $list:[p::pl]$) >>
- | s = LIDENT -> <:patt< $lid:s$ >>
- | "_" -> <:patt< _ >> ] ]
- ;
- label_ipatt:
- [ [ i = patt_label_ident; "="; p = ipatt -> (i, p) ] ]
- ;
- type_declaration:
- [ [ n = type_patt; tpl = LIST0 type_parameter; "="; tk = ctyp;
- cl = LIST0 constrain ->
- (n, tpl, tk, cl) ] ]
- ;
- type_patt:
- [ [ n = LIDENT -> (loc, n) ] ]
- ;
- constrain:
- [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> (t1, t2) ] ]
- ;
- type_parameter:
- [ [ "'"; i = ident -> (i, (False, False))
- | "+"; "'"; i = ident -> (i, (True, False))
- | "-"; "'"; i = ident -> (i, (False, True)) ] ]
- ;
- ctyp:
- [ LEFTA
- [ t1 = SELF; "=="; t2 = SELF -> <:ctyp< $t1$ == $t2$ >> ]
- | LEFTA
- [ t1 = SELF; "as"; t2 = SELF -> <:ctyp< $t1$ as $t2$ >> ]
- | LEFTA
- [ "!"; pl = LIST1 typevar; "."; t = ctyp ->
- <:ctyp< ! $list:pl$ . $t$ >> ]
- | "arrow" RIGHTA
- [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ]
- | "label" NONA
- [ i = TILDEIDENT; ":"; t = SELF -> <:ctyp< ~ $i$ : $t$ >>
- | i = LABEL; t = SELF -> <:ctyp< ~ $i$ : $t$ >>
- | i = QUESTIONIDENT; ":"; t = SELF -> <:ctyp< ? $i$ : $t$ >>
- | i = OPTLABEL; t = SELF -> <:ctyp< ? $i$ : $t$ >> ]
- | LEFTA
- [ t1 = SELF; t2 = SELF -> <:ctyp< $t1$ $t2$ >> ]
- | LEFTA
- [ t1 = SELF; "."; t2 = SELF -> <:ctyp< $t1$ . $t2$ >> ]
- | "simple"
- [ "'"; i = ident -> <:ctyp< '$i$ >>
- | "_" -> <:ctyp< _ >>
- | i = LIDENT -> <:ctyp< $lid:i$ >>
- | i = UIDENT -> <:ctyp< $uid:i$ >>
- | "("; t = SELF; "*"; tl = LIST1 ctyp SEP "*"; ")" ->
- <:ctyp< ( $list:[t::tl]$ ) >>
- | "("; t = SELF; ")" -> <:ctyp< $t$ >>
- | "private"; "["; cdl = LIST0 constructor_declaration SEP "|"; "]" ->
- <:ctyp< private [ $list:cdl$ ] >>
- | "private"; "{"; ldl = LIST1 label_declaration SEP ";"; "}" ->
- <:ctyp< private { $list:ldl$ } >>
- | "["; cdl = LIST0 constructor_declaration SEP "|"; "]" ->
- <:ctyp< [ $list:cdl$ ] >>
- | "{"; ldl = LIST1 label_declaration SEP ";"; "}" ->
- <:ctyp< { $list:ldl$ } >> ] ]
- ;
- constructor_declaration:
- [ [ ci = UIDENT; "of"; cal = LIST1 ctyp SEP "and" -> (loc, ci, cal)
- | ci = UIDENT -> (loc, ci, []) ] ]
- ;
- label_declaration:
- [ [ i = LIDENT; ":"; mf = OPT "mutable"; t = ctyp ->
- (loc, i, o2b mf, t) ] ]
- ;
- ident:
- [ [ i = LIDENT -> i
- | i = UIDENT -> i ] ]
- ;
- mod_ident:
- [ RIGHTA
- [ i = UIDENT -> [i]
- | i = LIDENT -> [i]
- | i = UIDENT; "."; j = SELF -> [i :: j] ] ]
- ;
- (* Objects and Classes *)
- str_item:
- [ [ "class"; cd = LIST1 class_declaration SEP "and" ->
- <:str_item< class $list:cd$ >>
- | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" ->
- <:str_item< class type $list:ctd$ >> ] ]
- ;
- sig_item:
- [ [ "class"; cd = LIST1 class_description SEP "and" ->
- <:sig_item< class $list:cd$ >>
- | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" ->
- <:sig_item< class type $list:ctd$ >> ] ]
- ;
- class_declaration:
- [ [ vf = OPT "virtual"; i = LIDENT; ctp = class_type_parameters;
- cfb = class_fun_binding ->
- {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
- MLast.ciNam = i; MLast.ciExp = cfb} ] ]
- ;
- class_fun_binding:
- [ [ "="; ce = class_expr -> ce
- | ":"; ct = class_type; "="; ce = class_expr ->
- <:class_expr< ($ce$ : $ct$) >>
- | p = ipatt; cfb = SELF -> <:class_expr< fun $p$ -> $cfb$ >> ] ]
- ;
- class_type_parameters:
- [ [ -> (loc, [])
- | "["; tpl = LIST1 type_parameter SEP ","; "]" -> (loc, tpl) ] ]
- ;
- class_fun_def:
- [ [ p = ipatt; ce = SELF -> <:class_expr< fun $p$ -> $ce$ >>
- | "->"; ce = class_expr -> ce ] ]
- ;
- class_expr:
- [ "top"
- [ "fun"; p = ipatt; ce = class_fun_def ->
- <:class_expr< fun $p$ -> $ce$ >>
- | "let"; rf = OPT "rec"; lb = LIST1 let_binding SEP "and"; "in";
- ce = SELF ->
- <:class_expr< let $opt:o2b rf$ $list:lb$ in $ce$ >> ]
- | "apply" NONA
- [ ce = SELF; e = expr LEVEL "label" ->
- <:class_expr< $ce$ $e$ >> ]
- | "simple"
- [ ci = class_longident; "["; ctcl = LIST0 ctyp SEP ","; "]" ->
- <:class_expr< $list:ci$ [ $list:ctcl$ ] >>
- | ci = class_longident -> <:class_expr< $list:ci$ >>
- | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" ->
- <:class_expr< object $opt:cspo$ $list:cf$ end >>
- | "("; ce = SELF; ":"; ct = class_type; ")" ->
- <:class_expr< ($ce$ : $ct$) >>
- | "("; ce = SELF; ")" -> ce ] ]
- ;
- class_structure:
- [ [ cf = LIST0 [ cf = class_str_item; ";" -> cf ] -> cf ] ]
- ;
- class_self_patt:
- [ [ "("; p = patt; ")" -> p
- | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> ] ]
- ;
- class_str_item:
- [ [ "declare"; st = LIST0 [ s= class_str_item; ";" -> s ]; "end" ->
- <:class_str_item< declare $list:st$ end >>
- | "inherit"; ce = class_expr; pb = OPT as_lident ->
- <:class_str_item< inherit $ce$ $opt:pb$ >>
- | "value"; mf = OPT "mutable"; lab = label; e = cvalue_binding ->
- <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >>
- | "method"; "virtual"; pf = OPT "private"; l = label; ":"; t = ctyp ->
- <:class_str_item< method virtual $opt:o2b pf$ $l$ : $t$ >>
- | "method"; pf = OPT "private"; l = label; topt = OPT polyt;
- e = fun_binding ->
- <:class_str_item< method $opt:o2b pf$ $l$ $opt:topt$ = $e$ >>
- | "type"; t1 = ctyp; "="; t2 = ctyp ->
- <:class_str_item< type $t1$ = $t2$ >>
- | "initializer"; se = expr -> <:class_str_item< initializer $se$ >> ] ]
- ;
- as_lident:
- [ [ "as"; i = LIDENT -> i ] ]
- ;
- polyt:
- [ [ ":"; t = ctyp -> t ] ]
- ;
- cvalue_binding:
- [ [ "="; e = expr -> e
- | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >>
- | ":"; t = ctyp; ":>"; t2 = ctyp; "="; e = expr ->
- <:expr< ($e$ : $t$ :> $t2$) >>
- | ":>"; t = ctyp; "="; e = expr -> <:expr< ($e$ :> $t$) >> ] ]
- ;
- label:
- [ [ i = LIDENT -> i ] ]
- ;
- class_type:
- [ [ "["; t = ctyp; "]"; "->"; ct = SELF ->
- <:class_type< [ $t$ ] -> $ct$ >>
- | id = clty_longident; "["; tl = LIST1 ctyp SEP ","; "]" ->
- <:class_type< $list:id$ [ $list:tl$ ] >>
- | id = clty_longident -> <:class_type< $list:id$ >>
- | "object"; cst = OPT class_self_type;
- csf = LIST0 [ csf = class_sig_item; ";" -> csf ]; "end" ->
- <:class_type< object $opt:cst$ $list:csf$ end >> ] ]
- ;
- class_self_type:
- [ [ "("; t = ctyp; ")" -> t ] ]
- ;
- class_sig_item:
- [ [ "declare"; st = LIST0 [ s = class_sig_item; ";" -> s ]; "end" ->
- <:class_sig_item< declare $list:st$ end >>
- | "inherit"; cs = class_type -> <:class_sig_item< inherit $cs$ >>
- | "value"; mf = OPT "mutable"; l = label; ":"; t = ctyp ->
- <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >>
- | "method"; "virtual"; pf = OPT "private"; l = label; ":"; t = ctyp ->
- <:class_sig_item< method virtual $opt:o2b pf$ $l$ : $t$ >>
- | "method"; pf = OPT "private"; l = label; ":"; t = ctyp ->
- <:class_sig_item< method $opt:o2b pf$ $l$ : $t$ >>
- | "type"; t1 = ctyp; "="; t2 = ctyp ->
- <:class_sig_item< type $t1$ = $t2$ >> ] ]
- ;
- class_description:
- [ [ vf = OPT "virtual"; n = LIDENT; ctp = class_type_parameters; ":";
- ct = class_type ->
- {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
- MLast.ciNam = n; MLast.ciExp = ct} ] ]
- ;
- class_type_declaration:
- [ [ vf = OPT "virtual"; n = LIDENT; ctp = class_type_parameters; "=";
- cs = class_type ->
- {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
- MLast.ciNam = n; MLast.ciExp = cs} ] ]
- ;
- expr: LEVEL "apply"
- [ LEFTA
- [ "new"; i = class_longident -> <:expr< new $list:i$ >> ] ]
- ;
- expr: LEVEL "."
- [ [ e = SELF; "#"; lab = label -> <:expr< $e$ # $lab$ >> ] ]
- ;
- expr: LEVEL "simple"
- [ [ "("; e = SELF; ":"; t = ctyp; ":>"; t2 = ctyp; ")" ->
- <:expr< ($e$ : $t$ :> $t2$ ) >>
- | "("; e = SELF; ":>"; t = ctyp; ")" -> <:expr< ($e$ :> $t$) >>
- | "{<"; fel = LIST0 field_expr SEP ";"; ">}" ->
- <:expr< {< $list:fel$ >} >> ] ]
- ;
- field_expr:
- [ [ l = label; "="; e = expr -> (l, e) ] ]
- ;
- ctyp: LEVEL "simple"
- [ [ "#"; id = class_longident -> <:ctyp< # $list:id$ >>
- | "<"; ml = LIST0 field SEP ";"; v = OPT ".."; ">" ->
- <:ctyp< < $list:ml$ $opt:o2b v$ > >> ] ]
- ;
- field:
- [ [ lab = LIDENT; ":"; t = ctyp -> (lab, t) ] ]
- ;
- typevar:
- [ [ "'"; i = ident -> i ] ]
- ;
- clty_longident:
- [ [ m = UIDENT; "."; l = SELF -> [m :: l]
- | i = LIDENT -> [i] ] ]
- ;
- class_longident:
- [ [ m = UIDENT; "."; l = SELF -> [m :: l]
- | i = LIDENT -> [i] ] ]
- ;
- ctyp: LEVEL "simple"
- [ [ "["; "="; rfl = row_field_list; "]" ->
- <:ctyp< [ = $list:rfl$ ] >>
- | "["; ">"; rfl = row_field_list; "]" ->
- <:ctyp< [ > $list:rfl$ ] >>
- | "["; "<"; rfl = row_field_list; "]" ->
- <:ctyp< [ < $list:rfl$ ] >>
- | "["; "<"; rfl = row_field_list; ">"; ntl = LIST1 name_tag; "]" ->
- <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ]
- ;
- row_field_list:
- [ [ rfl = LIST0 row_field SEP "|" -> rfl ] ]
- ;
- row_field:
- [ [ "`"; i = ident -> <:row_field< ` $i$ >>
- | "`"; i = ident; "of"; ao = OPT "&"; l = LIST1 ctyp SEP "&" ->
- <:row_field< ` $i$ of $opt:o2b ao$ $list:l$ >>
- | t = ctyp -> <:row_field< $t$ >> ] ]
- ;
- name_tag:
- [ [ "`"; i = ident -> i ] ]
- ;
- patt: LEVEL "simple"
- [ [ "`"; s = ident -> <:patt< ` $s$ >>
- | "#"; sl = mod_ident -> <:patt< # $list:sl$ >>
- | i = TILDEIDENT; ":"; p = SELF -> <:patt< ~ $i$ : $p$ >>
- | i = LABEL; p = SELF -> <:patt< ~ $i$ : $p$ >>
- | i = TILDEIDENT -> <:patt< ~ $i$ >>
- | i = QUESTIONIDENT; ":"; "("; p = patt_tcon; eo = OPT eq_expr; ")" ->
- <:patt< ? $i$ : ($p$ $opt:eo$) >>
- | i = OPTLABEL; "("; p = patt_tcon; eo = OPT eq_expr; ")" ->
- <:patt< ? $i$ : ($p$ $opt:eo$) >>
- | i = QUESTIONIDENT ->
- <:patt< ? $i$ >>
- | "?"; "("; p = patt_tcon; eo = OPT eq_expr; ")" ->
- <:patt< ? ($p$ $opt:eo$) >> ] ]
- ;
- patt_tcon:
- [ [ p = patt; ":"; t = ctyp -> <:patt< ($p$ : $t$) >>
- | p = patt -> p ] ]
- ;
- ipatt:
- [ [ i = TILDEIDENT; ":"; p = SELF -> <:patt< ~ $i$ : $p$ >>
- | i = LABEL; p = SELF -> <:patt< ~ $i$ : $p$ >>
- | i = TILDEIDENT -> <:patt< ~ $i$ >>
- | i = QUESTIONIDENT; ":"; "("; p = ipatt_tcon; eo = OPT eq_expr; ")" ->
- <:patt< ? $i$ : ($p$ $opt:eo$) >>
- | i = OPTLABEL; "("; p = ipatt_tcon; eo = OPT eq_expr; ")" ->
- <:patt< ? $i$ : ($p$ $opt:eo$) >>
- | i = QUESTIONIDENT ->
- <:patt< ? $i$ >>
- | "?"; "("; p = ipatt_tcon; eo = OPT eq_expr; ")" ->
- <:patt< ? ($p$ $opt:eo$) >> ] ]
- ;
- ipatt_tcon:
- [ [ p = ipatt; ":"; t = ctyp -> <:patt< ($p$ : $t$) >>
- | p = ipatt -> p ] ]
- ;
- eq_expr:
- [ [ "="; e = expr -> e ] ]
- ;
- expr: AFTER "apply"
- [ "label" NONA
- [ i = TILDEIDENT; ":"; e = SELF -> <:expr< ~ $i$ : $e$ >>
- | i = LABEL; e = SELF -> <:expr< ~ $i$ : $e$ >>
- | i = TILDEIDENT -> <:expr< ~ $i$ >>
- | i = QUESTIONIDENT; ":"; e = SELF -> <:expr< ? $i$ : $e$ >>
- | i = OPTLABEL; e = SELF -> <:expr< ? $i$ : $e$ >>
- | i = QUESTIONIDENT -> <:expr< ? $i$ >> ] ]
- ;
- expr: LEVEL "simple"
- [ [ "`"; s = ident -> <:expr< ` $s$ >> ] ]
- ;
- direction_flag:
- [ [ "to" -> True
- | "downto" -> False ] ]
- ;
- (* Compatibility old syntax of variant types definitions *)
- ctyp: LEVEL "simple"
- [ [ "[|"; warning_variant; rfl = row_field_list; "|]" ->
- <:ctyp< [ = $list:rfl$ ] >>
- | "[|"; warning_variant; ">"; rfl = row_field_list; "|]" ->
- <:ctyp< [ > $list:rfl$ ] >>
- | "[|"; warning_variant; "<"; rfl = row_field_list; "|]" ->
- <:ctyp< [ < $list:rfl$ ] >>
- | "[|"; warning_variant; "<"; rfl = row_field_list; ">";
- ntl = LIST1 name_tag; "|]" ->
- <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ]
- ;
- warning_variant:
- [ [ -> warn_variant loc ] ]
- ;
- (* Compatibility old syntax of sequences *)
- expr: LEVEL "top"
- [ [ "do"; seq = LIST0 [ e = expr; ";" -> e ]; "return"; warning_sequence;
- e = SELF ->
- <:expr< do { $list:append_elem seq e$ } >>
- | "for"; i = LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF;
- "do"; seq = LIST0 [ e = expr; ";" -> e ]; warning_sequence; "done" ->
- <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:seq$ } >>
- | "while"; e = SELF; "do"; seq = LIST0 [ e = expr; ";" -> e ];
- warning_sequence; "done" ->
- <:expr< while $e$ do { $list:seq$ } >> ] ]
- ;
- warning_sequence:
- [ [ -> warn_sequence loc ] ]
- ;
-END;
-
-EXTEND
- GLOBAL: interf implem use_file top_phrase expr patt;
- interf:
- [ [ "#"; n = LIDENT; dp = OPT expr; ";" ->
- ([(<:sig_item< # $n$ $opt:dp$ >>, loc)], True)
- | si = sig_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped)
- | EOI -> ([], False) ] ]
- ;
- sig_item_semi:
- [ [ si = sig_item; ";" -> (si, loc) ] ]
- ;
- implem:
- [ [ "#"; n = LIDENT; dp = OPT expr; ";" ->
- ([(<:str_item< # $n$ $opt:dp$ >>, loc)], True)
- | si = str_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped)
- | EOI -> ([], False) ] ]
- ;
- str_item_semi:
- [ [ si = str_item; ";" -> (si, loc) ] ]
- ;
- top_phrase:
- [ [ ph = phrase -> Some ph
- | EOI -> None ] ]
- ;
- use_file:
- [ [ "#"; n = LIDENT; dp = OPT expr; ";" ->
- ([<:str_item< # $n$ $opt:dp$ >>], True)
- | si = str_item; ";"; (sil, stopped) = SELF -> ([si :: sil], stopped)
- | EOI -> ([], False) ] ]
- ;
- phrase:
- [ [ "#"; n = LIDENT; dp = OPT expr; ";" ->
- <:str_item< # $n$ $opt:dp$ >>
- | sti = str_item; ";" -> sti ] ]
- ;
- expr: LEVEL "simple"
- [ [ x = LOCATE ->
- let x =
- try
- let i = String.index x ':' in
- (int_of_string (String.sub x 0 i),
- String.sub x (i + 1) (String.length x - i - 1))
- with
- [ Not_found | Failure _ -> (0, x) ]
- in
- Pcaml.handle_expr_locate loc x
- | x = QUOTATION ->
- let x =
- try
- let i = String.index x ':' in
- (String.sub x 0 i,
- String.sub x (i + 1) (String.length x - i - 1))
- with
- [ Not_found -> ("", x) ]
- in
- Pcaml.handle_expr_quotation loc x ] ]
- ;
- patt: LEVEL "simple"
- [ [ x = LOCATE ->
- let x =
- try
- let i = String.index x ':' in
- (int_of_string (String.sub x 0 i),
- String.sub x (i + 1) (String.length x - i - 1))
- with
- [ Not_found | Failure _ -> (0, x) ]
- in
- Pcaml.handle_patt_locate loc x
- | x = QUOTATION ->
- let x =
- try
- let i = String.index x ':' in
- (String.sub x 0 i,
- String.sub x (i + 1) (String.length x - i - 1))
- with
- [ Not_found -> ("", x) ]
- in
- Pcaml.handle_patt_quotation loc x ] ]
- ;
-END;
diff --git a/camlp4/meta/pa_rp.ml b/camlp4/meta/pa_rp.ml
deleted file mode 100644
index cb3566cd3e..0000000000
--- a/camlp4/meta/pa_rp.ml
+++ /dev/null
@@ -1,318 +0,0 @@
-(* camlp4r pa_extend.cmo q_MLast.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1998 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Pcaml;
-
-type spat_comp =
- [ SpTrm of MLast.loc and MLast.patt and option MLast.expr
- | SpNtr of MLast.loc and MLast.patt and MLast.expr
- | SpStr of MLast.loc and MLast.patt ]
-;
-type sexp_comp =
- [ SeTrm of MLast.loc and MLast.expr | SeNtr of MLast.loc and MLast.expr ]
-;
-
-value strm_n = "strm__";
-value peek_fun loc = <:expr< Stream.peek >>;
-value junk_fun loc = <:expr< Stream.junk >>;
-
-(* Parsers. *)
-(* In syntax generated, many cases are optimisations. *)
-
-value rec pattern_eq_expression p e =
- match (p, e) with
- [ (<:patt< $lid:a$ >>, <:expr< $lid:b$ >>) -> a = b
- | (<:patt< $uid:a$ >>, <:expr< $uid:b$ >>) -> a = b
- | (<:patt< $p1$ $p2$ >>, <:expr< $e1$ $e2$ >>) ->
- pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2
- | _ -> False ]
-;
-
-value is_raise e =
- match e with
- [ <:expr< raise $_$ >> -> True
- | _ -> False ]
-;
-
-value is_raise_failure e =
- match e with
- [ <:expr< raise Stream.Failure >> -> True
- | _ -> False ]
-;
-
-value rec handle_failure e =
- match e with
- [ <:expr< try $te$ with [ Stream.Failure -> $e$] >> -> handle_failure e
- | <:expr< match $me$ with [ $list:pel$ ] >> ->
- handle_failure me &&
- List.for_all
- (fun
- [ (_, None, e) -> handle_failure e
- | _ -> False ])
- pel
- | <:expr< let $list:pel$ in $e$ >> ->
- List.for_all (fun (p, e) -> handle_failure e) pel && handle_failure e
- | <:expr< $lid:_$ >> | <:expr< $int:_$ >> | <:expr< $str:_$ >> |
- <:expr< $chr:_$ >> | <:expr< fun [ $list:_$ ] >> | <:expr< $uid:_$ >> ->
- True
- | <:expr< raise $e$ >> ->
- match e with
- [ <:expr< Stream.Failure >> -> False
- | _ -> True ]
- | <:expr< $f$ $x$ >> ->
- is_constr_apply f && handle_failure f && handle_failure x
- | _ -> False ]
-and is_constr_apply =
- fun
- [ <:expr< $uid:_$ >> -> True
- | <:expr< $lid:_$ >> -> False
- | <:expr< $x$ $_$ >> -> is_constr_apply x
- | _ -> False ]
-;
-
-value rec subst v e =
- let loc = MLast.loc_of_expr e in
- match e with
- [ <:expr< $lid:x$ >> ->
- let x = if x = v then strm_n else x in <:expr< $lid:x$ >>
- | <:expr< $uid:_$ >> -> e
- | <:expr< $int:_$ >> -> e
- | <:expr< $chr:_$ >> -> e
- | <:expr< $str:_$ >> -> e
- | <:expr< $_$.$_$ >> -> e
- | <:expr< let $opt:rf$ $list:pel$ in $e$ >> ->
- <:expr< let $opt:rf$ $list:List.map (subst_pe v) pel$ in $subst v e$ >>
- | <:expr< $e1$ $e2$ >> -> <:expr< $subst v e1$ $subst v e2$ >>
- | <:expr< ( $list:el$ ) >> -> <:expr< ( $list:List.map (subst v) el$ ) >>
- | _ -> raise Not_found ]
-and subst_pe v (p, e) =
- match p with
- [ <:patt< $lid:v'$ >> when v <> v' -> (p, subst v e)
- | _ -> raise Not_found ]
-;
-
-value stream_pattern_component skont ckont =
- fun
- [ SpTrm loc p wo ->
- <:expr< match $peek_fun loc$ $lid:strm_n$ with
- [ Some $p$ $when:wo$ ->
- do { $junk_fun loc$ $lid:strm_n$; $skont$ }
- | _ -> $ckont$ ] >>
- | SpNtr loc p e ->
- let e =
- match e with
- [ <:expr< fun [ ($lid:v$ : Stream.t _) -> $e$ ] >> when v = strm_n -> e
- | _ -> <:expr< $e$ $lid:strm_n$ >> ]
- in
- if pattern_eq_expression p skont then
- if is_raise_failure ckont then e
- else if handle_failure e then e
- else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >>
- else if is_raise_failure ckont then <:expr< let $p$ = $e$ in $skont$ >>
- else if pattern_eq_expression <:patt< Some $p$ >> skont then
- <:expr< try Some $e$ with [ Stream.Failure -> $ckont$ ] >>
- else if is_raise ckont then
- let tst =
- if handle_failure e then e
- else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >>
- in
- <:expr< let $p$ = $tst$ in $skont$ >>
- else
- <:expr< match try Some $e$ with [ Stream.Failure -> None ] with
- [ Some $p$ -> $skont$
- | _ -> $ckont$ ] >>
- | SpStr loc p ->
- try
- match p with
- [ <:patt< $lid:v$ >> -> subst v skont
- | _ -> raise Not_found ]
- with
- [ Not_found -> <:expr< let $p$ = $lid:strm_n$ in $skont$ >> ] ]
-;
-
-value rec stream_pattern loc epo e ekont =
- fun
- [ [] ->
- match epo with
- [ Some ep -> <:expr< let $ep$ = Stream.count $lid:strm_n$ in $e$ >>
- | _ -> e ]
- | [(spc, err) :: spcl] ->
- let skont =
- let ekont err =
- let str =
- match err with
- [ Some estr -> estr
- | _ -> <:expr< "" >> ]
- in
- <:expr< raise (Stream.Error $str$) >>
- in
- stream_pattern loc epo e ekont spcl
- in
- let ckont = ekont err in stream_pattern_component skont ckont spc ]
-;
-
-value stream_patterns_term loc ekont tspel =
- let pel =
- List.map
- (fun (p, w, loc, spcl, epo, e) ->
- let p = <:patt< Some $p$ >> in
- let e =
- let ekont err =
- let str =
- match err with
- [ Some estr -> estr
- | _ -> <:expr< "" >> ]
- in
- <:expr< raise (Stream.Error $str$) >>
- in
- let skont = stream_pattern loc epo e ekont spcl in
- <:expr< do { $junk_fun loc$ $lid:strm_n$; $skont$ } >>
- in
- (p, w, e))
- tspel
- in
- let pel = pel @ [(<:patt< _ >>, None, ekont ())] in
- <:expr< match $peek_fun loc$ $lid:strm_n$ with [ $list:pel$ ] >>
-;
-
-value rec group_terms =
- fun
- [ [([(SpTrm loc p w, None) :: spcl], epo, e) :: spel] ->
- let (tspel, spel) = group_terms spel in
- ([(p, w, loc, spcl, epo, e) :: tspel], spel)
- | spel -> ([], spel) ]
-;
-
-value rec parser_cases loc =
- fun
- [ [] -> <:expr< raise Stream.Failure >>
- | spel ->
- match group_terms spel with
- [ ([], [(spcl, epo, e) :: spel]) ->
- stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl
- | (tspel, spel) ->
- stream_patterns_term loc (fun _ -> parser_cases loc spel) tspel ] ]
-;
-
-value cparser loc bpo pc =
- let e = parser_cases loc pc in
- let e =
- match bpo with
- [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $e$ >>
- | None -> e ]
- in
- let p = <:patt< ($lid:strm_n$ : Stream.t _) >> in <:expr< fun $p$ -> $e$ >>
-;
-
-value cparser_match loc me bpo pc =
- let pc = parser_cases loc pc in
- let e =
- match bpo with
- [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>
- | None -> pc ]
- in
- match me with
- [ <:expr< $lid:x$ >> when x = strm_n -> e
- | _ -> <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >> ]
-;
-
-(* streams *)
-
-value rec not_computing =
- fun
- [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $int:_$ >> |
- <:expr< $flo:_$ >> | <:expr< $chr:_$ >> | <:expr< $str:_$ >> ->
- True
- | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y
- | _ -> False ]
-and is_cons_apply_not_computing =
- fun
- [ <:expr< $uid:_$ >> -> True
- | <:expr< $lid:_$ >> -> False
- | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y
- | _ -> False ]
-;
-
-value slazy loc e =
- match e with
- [ <:expr< $f$ () >> ->
- match f with
- [ <:expr< $lid:_$ >> -> f
- | _ -> <:expr< fun _ -> $e$ >> ]
- | _ -> <:expr< fun _ -> $e$ >> ]
-;
-
-value rec cstream gloc =
- fun
- [ [] -> let loc = gloc in <:expr< Stream.sempty >>
- | [SeTrm loc e] ->
- if not_computing e then <:expr< Stream.ising $e$ >>
- else <:expr< Stream.lsing $slazy loc e$ >>
- | [SeTrm loc e :: secl] ->
- if not_computing e then <:expr< Stream.icons $e$ $cstream gloc secl$ >>
- else <:expr< Stream.lcons $slazy loc e$ $cstream gloc secl$ >>
- | [SeNtr loc e] ->
- if not_computing e then e else <:expr< Stream.slazy $slazy loc e$ >>
- | [SeNtr loc e :: secl] ->
- if not_computing e then <:expr< Stream.iapp $e$ $cstream gloc secl$ >>
- else <:expr< Stream.lapp $slazy loc e$ $cstream gloc secl$ >> ]
-;
-
-(* Syntax extensions in Revised Syntax grammar *)
-
-EXTEND
- GLOBAL: expr;
- expr: LEVEL "top"
- [ [ "parser"; po = OPT ipatt; "["; pcl = LIST0 parser_case SEP "|"; "]" ->
- <:expr< $cparser loc po pcl$ >>
- | "parser"; po = OPT ipatt; pc = parser_case ->
- <:expr< $cparser loc po [pc]$ >>
- | "match"; e = SELF; "with"; "parser"; po = OPT ipatt; "[";
- pcl = LIST0 parser_case SEP "|"; "]" ->
- <:expr< $cparser_match loc e po pcl$ >>
- | "match"; e = SELF; "with"; "parser"; po = OPT ipatt;
- pc = parser_case ->
- <:expr< $cparser_match loc e po [pc]$ >> ] ]
- ;
- parser_case:
- [ [ "[:"; sp = stream_patt; ":]"; po = OPT ipatt; "->"; e = expr ->
- (sp, po, e) ] ]
- ;
- stream_patt:
- [ [ spc = stream_patt_comp -> [(spc, None)]
- | spc = stream_patt_comp; ";";
- sp = LIST1 stream_patt_comp_err SEP ";" ->
- [(spc, None) :: sp]
- | -> [] ] ]
- ;
- stream_patt_comp_err:
- [ [ spc = stream_patt_comp; eo = OPT [ "?"; e = expr -> e ] ->
- (spc, eo) ] ]
- ;
- stream_patt_comp:
- [ [ "`"; p = patt; eo = OPT [ "when"; e = expr -> e ] -> SpTrm loc p eo
- | p = patt; "="; e = expr -> SpNtr loc p e
- | p = patt -> SpStr loc p ] ]
- ;
- ipatt:
- [ [ i = LIDENT -> <:patt< $lid:i$ >> ] ]
- ;
- expr: LEVEL "simple"
- [ [ "[:"; se = LIST0 stream_expr_comp SEP ";"; ":]" ->
- <:expr< $cstream loc se$ >> ] ]
- ;
- stream_expr_comp:
- [ [ "`"; e = expr -> SeTrm loc e | e = expr -> SeNtr loc e ] ]
- ;
-END;
diff --git a/camlp4/meta/pr_dump.ml b/camlp4/meta/pr_dump.ml
deleted file mode 100644
index 2558c5fa93..0000000000
--- a/camlp4/meta/pr_dump.ml
+++ /dev/null
@@ -1,52 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-value open_out_file () =
- match Pcaml.output_file.val with
- [ Some f -> open_out_bin f
- | None -> do { set_binary_mode_out stdout True; stdout } ]
-;
-
-value interf ast =
- let pt = Ast2pt.interf (List.map fst ast) in
- let oc = open_out_file () in
- let fname = Pcaml.input_file.val in
- do {
- output_string oc Config.ast_intf_magic_number;
- output_value oc (if fname = "-" then "" else fname);
- output_value oc pt;
- flush oc;
- match Pcaml.output_file.val with
- [ Some _ -> close_out oc
- | None -> () ]
- }
-;
-
-value implem ast =
- let pt = Ast2pt.implem (List.map fst ast) in
- let oc = open_out_file () in
- let fname = Pcaml.input_file.val in
- do {
- output_string oc Config.ast_impl_magic_number;
- output_value oc (if fname = "-" then "" else fname);
- output_value oc pt;
- flush oc;
- match Pcaml.output_file.val with
- [ Some _ -> close_out oc
- | None -> () ]
- }
-;
-
-Pcaml.print_interf.val := interf;
-Pcaml.print_implem.val := implem;
diff --git a/camlp4/meta/q_MLast.ml b/camlp4/meta/q_MLast.ml
deleted file mode 100644
index c10ad7980c..0000000000
--- a/camlp4/meta/q_MLast.ml
+++ /dev/null
@@ -1,1501 +0,0 @@
-(* camlp4r pa_extend.cmo pa_extend_m.cmo q_MLast.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-value gram = Grammar.gcreate (Plexer.gmake ());
-
-module Qast =
- struct
- type t =
- [ Node of string and list t
- | List of list t
- | Tuple of list t
- | Option of option t
- | Int of string
- | Str of string
- | Bool of bool
- | Cons of t and t
- | Apply of string and list t
- | Record of list (string * t)
- | Loc
- | Antiquot of MLast.loc and string ]
- ;
- value loc = (0, 0);
- value rec to_expr =
- fun
- [ Node n al ->
- List.fold_left (fun e a -> <:expr< $e$ $to_expr a$ >>)
- <:expr< MLast.$uid:n$ >> al
- | List al ->
- List.fold_right (fun a e -> <:expr< [$to_expr a$ :: $e$] >>) al
- <:expr< [] >>
- | Tuple al -> <:expr< ($list:List.map to_expr al$) >>
- | Option None -> <:expr< None >>
- | Option (Some a) -> <:expr< Some $to_expr a$ >>
- | Int s -> <:expr< $int:s$ >>
- | Str s -> <:expr< $str:s$ >>
- | Bool True -> <:expr< True >>
- | Bool False -> <:expr< False >>
- | Cons a1 a2 -> <:expr< [$to_expr a1$ :: $to_expr a2$] >>
- | Apply f al ->
- List.fold_left (fun e a -> <:expr< $e$ $to_expr a$ >>)
- <:expr< $lid:f$ >> al
- | Record lal -> <:expr< {$list:List.map to_expr_label lal$} >>
- | Loc -> <:expr< $lid:Stdpp.loc_name.val$ >>
- | Antiquot loc s ->
- let e =
- try Grammar.Entry.parse Pcaml.expr_eoi (Stream.of_string s) with
- [ Stdpp.Exc_located (bp, ep) exc ->
- raise (Stdpp.Exc_located (fst loc + bp, fst loc + ep) exc) ]
- in
- <:expr< $anti:e$ >> ]
- and to_expr_label (l, a) = (<:patt< MLast.$lid:l$ >>, to_expr a);
- value rec to_patt =
- fun
- [ Node n al ->
- List.fold_left (fun e a -> <:patt< $e$ $to_patt a$ >>)
- <:patt< MLast.$uid:n$ >> al
- | List al ->
- List.fold_right (fun a p -> <:patt< [$to_patt a$ :: $p$] >>) al
- <:patt< [] >>
- | Tuple al -> <:patt< ($list:List.map to_patt al$) >>
- | Option None -> <:patt< None >>
- | Option (Some a) -> <:patt< Some $to_patt a$ >>
- | Int s -> <:patt< $int:s$ >>
- | Str s -> <:patt< $str:s$ >>
- | Bool True -> <:patt< True >>
- | Bool False -> <:patt< False >>
- | Cons a1 a2 -> <:patt< [$to_patt a1$ :: $to_patt a2$] >>
- | Apply _ _ -> failwith "bad pattern"
- | Record lal -> <:patt< {$list:List.map to_patt_label lal$} >>
- | Loc -> <:patt< _ >>
- | Antiquot loc s ->
- let p =
- try Grammar.Entry.parse Pcaml.patt_eoi (Stream.of_string s) with
- [ Stdpp.Exc_located (bp, ep) exc ->
- raise (Stdpp.Exc_located (fst loc + bp, fst loc + ep) exc) ]
- in
- <:patt< $anti:p$ >> ]
- and to_patt_label (l, a) = (<:patt< MLast.$lid:l$ >>, to_patt a);
- end
-;
-
-value antiquot k (bp, ep) x =
- let shift =
- if k = "" then String.length "$"
- else String.length "$" + String.length k + String.length ":"
- in
- Qast.Antiquot (shift + bp, shift + ep) x
-;
-
-value sig_item = Grammar.Entry.create gram "signature item";
-value str_item = Grammar.Entry.create gram "structure item";
-value ctyp = Grammar.Entry.create gram "type";
-value patt = Grammar.Entry.create gram "pattern";
-value expr = Grammar.Entry.create gram "expression";
-
-value module_type = Grammar.Entry.create gram "module type";
-value module_expr = Grammar.Entry.create gram "module expression";
-
-value class_type = Grammar.Entry.create gram "class type";
-value class_expr = Grammar.Entry.create gram "class expr";
-value class_sig_item = Grammar.Entry.create gram "class signature item";
-value class_str_item = Grammar.Entry.create gram "class structure item";
-
-value ipatt = Grammar.Entry.create gram "ipatt";
-value let_binding = Grammar.Entry.create gram "let_binding";
-value type_declaration = Grammar.Entry.create gram "type_declaration";
-value with_constr = Grammar.Entry.create gram "with_constr";
-value row_field = Grammar.Entry.create gram "row_field";
-
-value a_list = Grammar.Entry.create gram "a_list";
-value a_opt = Grammar.Entry.create gram "a_opt";
-value a_UIDENT = Grammar.Entry.create gram "a_UIDENT";
-value a_LIDENT = Grammar.Entry.create gram "a_LIDENT";
-value a_INT = Grammar.Entry.create gram "a_INT";
-value a_FLOAT = Grammar.Entry.create gram "a_FLOAT";
-value a_STRING = Grammar.Entry.create gram "a_STRING";
-value a_CHAR = Grammar.Entry.create gram "a_CHAR";
-value a_TILDEIDENT = Grammar.Entry.create gram "a_TILDEIDENT";
-value a_LABEL = Grammar.Entry.create gram "a_LABEL";
-value a_QUESTIONIDENT = Grammar.Entry.create gram "a_QUESTIONIDENT";
-value a_OPTLABEL = Grammar.Entry.create gram "a_OPTLABEL";
-
-value o2b =
- fun
- [ Qast.Option (Some _) -> Qast.Bool True
- | Qast.Option None -> Qast.Bool False
- | x -> x ]
-;
-
-value mksequence _ =
- fun
- [ Qast.List [e] -> e
- | el -> Qast.Node "ExSeq" [Qast.Loc; el] ]
-;
-
-value mkmatchcase _ p aso w e =
- let p =
- match aso with
- [ Qast.Option (Some p2) -> Qast.Node "PaAli" [Qast.Loc; p; p2]
- | Qast.Option None -> p
- | _ -> Qast.Node "PaAli" [Qast.Loc; p; aso] ]
- in
- Qast.Tuple [p; w; e]
-;
-
-value neg_string n =
- let len = String.length n in
- if len > 0 && n.[0] = '-' then String.sub n 1 (len - 1)
- else "-" ^ n
-;
-
-value mkumin _ f arg =
- match arg with
- [ Qast.Node "ExInt" [Qast.Loc; Qast.Str n] when int_of_string n > 0 ->
- let n = neg_string n in
- Qast.Node "ExInt" [Qast.Loc; Qast.Str n]
- | Qast.Node "ExFlo" [Qast.Loc; Qast.Str n] when float_of_string n > 0.0 ->
- let n = neg_string n in
- Qast.Node "ExFlo" [Qast.Loc; Qast.Str n]
- | _ ->
- match f with
- [ Qast.Str f ->
- let f = "~" ^ f in
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str f]; arg]
- | _ -> assert False ] ]
-;
-
-value mkuminpat _ f is_int s =
- let s =
- match s with
- [ Qast.Str s -> Qast.Str (neg_string s)
- | s -> failwith "bad unary minus" ]
- in
- match is_int with
- [ Qast.Bool True -> Qast.Node "PaInt" [Qast.Loc; s]
- | Qast.Bool False -> Qast.Node "PaFlo" [Qast.Loc; s]
- | _ -> assert False ]
-;
-
-value mklistexp _ last =
- loop True where rec loop top =
- fun
- [ Qast.List [] ->
- match last with
- [ Qast.Option (Some e) -> e
- | Qast.Option None -> Qast.Node "ExUid" [Qast.Loc; Qast.Str "[]"]
- | a -> a ]
- | Qast.List [e1 :: el] ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExUid" [Qast.Loc; Qast.Str "::"]; e1];
- loop False (Qast.List el)]
- | a -> a ]
-;
-
-value mklistpat _ last =
- loop True where rec loop top =
- fun
- [ Qast.List [] ->
- match last with
- [ Qast.Option (Some p) -> p
- | Qast.Option None -> Qast.Node "PaUid" [Qast.Loc; Qast.Str "[]"]
- | a -> a ]
- | Qast.List [p1 :: pl] ->
- Qast.Node "PaApp"
- [Qast.Loc;
- Qast.Node "PaApp"
- [Qast.Loc; Qast.Node "PaUid" [Qast.Loc; Qast.Str "::"]; p1];
- loop False (Qast.List pl)]
- | a -> a ]
-;
-
-value mkexprident loc i j =
- loop (Qast.Node "ExUid" [Qast.Loc; i]) j where rec loop m =
- fun
- [ Qast.Node "ExAcc" [_; x; y] ->
- loop (Qast.Node "ExAcc" [Qast.Loc; m; x]) y
- | e -> Qast.Node "ExAcc" [Qast.Loc; m; e] ]
-;
-
-value mkassert _ e =
- match e with
- [ Qast.Node "ExUid" [_; Qast.Str "False"] -> Qast.Node "ExAsf" [Qast.Loc]
- | _ -> Qast.Node "ExAsr" [Qast.Loc; e] ]
-;
-
-value append_elem el e = Qast.Apply "@" [el; Qast.List [e]];
-
-value not_yet_warned_antiq = ref True;
-value warn_antiq loc vers =
- if not_yet_warned_antiq.val then do {
- not_yet_warned_antiq.val := False;
- Pcaml.warning.val loc
- (Printf.sprintf
- "use of antiquotation syntax deprecated since version %s" vers);
- }
- else ()
-;
-
-value not_yet_warned_variant = ref True;
-value warn_variant _ =
- if not_yet_warned_variant.val then do {
- not_yet_warned_variant.val := False;
- Pcaml.warning.val (0, 1)
- (Printf.sprintf
- "use of syntax of variants types deprecated since version 3.05");
- }
- else ()
-;
-
-value not_yet_warned_seq = ref True;
-value warn_sequence _ =
- if not_yet_warned_seq.val then do {
- not_yet_warned_seq.val := False;
- Pcaml.warning.val (0, 1)
- (Printf.sprintf
- "use of syntax of sequences deprecated since version 3.01.1");
- }
- else ()
-;
-
-EXTEND
- GLOBAL: sig_item str_item ctyp patt expr module_type module_expr class_type
- class_expr class_sig_item class_str_item let_binding type_declaration
- ipatt with_constr row_field;
- module_expr:
- [ [ "functor"; "("; i = a_UIDENT; ":"; t = module_type; ")"; "->";
- me = SELF ->
- Qast.Node "MeFun" [Qast.Loc; i; t; me]
- | "struct"; st = SLIST0 [ s = str_item; ";" -> s ]; "end" ->
- Qast.Node "MeStr" [Qast.Loc; st] ]
- | [ me1 = SELF; me2 = SELF -> Qast.Node "MeApp" [Qast.Loc; me1; me2] ]
- | [ me1 = SELF; "."; me2 = SELF ->
- Qast.Node "MeAcc" [Qast.Loc; me1; me2] ]
- | "simple"
- [ i = a_UIDENT -> Qast.Node "MeUid" [Qast.Loc; i]
- | "("; me = SELF; ":"; mt = module_type; ")" ->
- Qast.Node "MeTyc" [Qast.Loc; me; mt]
- | "("; me = SELF; ")" -> me ] ]
- ;
- str_item:
- [ "top"
- [ "declare"; st = SLIST0 [ s = str_item; ";" -> s ]; "end" ->
- Qast.Node "StDcl" [Qast.Loc; st]
- | "exception"; ctl = constructor_declaration; b = rebind_exn ->
- let (_, c, tl) =
- match ctl with
- [ Qast.Tuple [xx1; xx2; xx3] -> (xx1, xx2, xx3)
- | _ -> match () with [] ]
- in
- Qast.Node "StExc" [Qast.Loc; c; tl; b]
- | "external"; i = a_LIDENT; ":"; t = ctyp; "="; pd = SLIST1 a_STRING ->
- Qast.Node "StExt" [Qast.Loc; i; t; pd]
- | "include"; me = module_expr -> Qast.Node "StInc" [Qast.Loc; me]
- | "module"; i = a_UIDENT; mb = module_binding ->
- Qast.Node "StMod" [Qast.Loc; i; mb]
- | "module"; "rec"; nmtmes = SLIST1 module_rec_binding SEP "and" ->
- Qast.Node "StRecMod" [Qast.Loc; nmtmes]
- | "module"; "type"; i = a_UIDENT; "="; mt = module_type ->
- Qast.Node "StMty" [Qast.Loc; i; mt]
- | "open"; i = mod_ident -> Qast.Node "StOpn" [Qast.Loc; i]
- | "type"; tdl = SLIST1 type_declaration SEP "and" ->
- Qast.Node "StTyp" [Qast.Loc; tdl]
- | "value"; r = SOPT "rec"; l = SLIST1 let_binding SEP "and" ->
- Qast.Node "StVal" [Qast.Loc; o2b r; l]
- | e = expr -> Qast.Node "StExp" [Qast.Loc; e] ] ]
- ;
- rebind_exn:
- [ [ "="; sl = mod_ident -> sl
- | -> Qast.List [] ] ]
- ;
- module_binding:
- [ RIGHTA
- [ "("; m = a_UIDENT; ":"; mt = module_type; ")"; mb = SELF ->
- Qast.Node "MeFun" [Qast.Loc; m; mt; mb]
- | ":"; mt = module_type; "="; me = module_expr ->
- Qast.Node "MeTyc" [Qast.Loc; me; mt]
- | "="; me = module_expr -> me ] ]
- ;
- module_rec_binding:
- [ [ m = a_UIDENT; ":"; mt = module_type; "="; me = module_expr ->
- Qast.Tuple [m; me; mt] ] ]
- ;
- module_type:
- [ [ "functor"; "("; i = a_UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF ->
- Qast.Node "MtFun" [Qast.Loc; i; t; mt] ]
- | [ mt = SELF; "with"; wcl = SLIST1 with_constr SEP "and" ->
- Qast.Node "MtWit" [Qast.Loc; mt; wcl] ]
- | [ "sig"; sg = SLIST0 [ s = sig_item; ";" -> s ]; "end" ->
- Qast.Node "MtSig" [Qast.Loc; sg] ]
- | [ m1 = SELF; m2 = SELF -> Qast.Node "MtApp" [Qast.Loc; m1; m2] ]
- | [ m1 = SELF; "."; m2 = SELF -> Qast.Node "MtAcc" [Qast.Loc; m1; m2] ]
- | "simple"
- [ i = a_UIDENT -> Qast.Node "MtUid" [Qast.Loc; i]
- | i = a_LIDENT -> Qast.Node "MtLid" [Qast.Loc; i]
- | "'"; i = ident -> Qast.Node "MtQuo" [Qast.Loc; i]
- | "("; mt = SELF; ")" -> mt ] ]
- ;
- sig_item:
- [ "top"
- [ "declare"; st = SLIST0 [ s = sig_item; ";" -> s ]; "end" ->
- Qast.Node "SgDcl" [Qast.Loc; st]
- | "exception"; ctl = constructor_declaration ->
- let (_, c, tl) =
- match ctl with
- [ Qast.Tuple [xx1; xx2; xx3] -> (xx1, xx2, xx3)
- | _ -> match () with [] ]
- in
- Qast.Node "SgExc" [Qast.Loc; c; tl]
- | "external"; i = a_LIDENT; ":"; t = ctyp; "="; pd = SLIST1 a_STRING ->
- Qast.Node "SgExt" [Qast.Loc; i; t; pd]
- | "include"; mt = module_type -> Qast.Node "SgInc" [Qast.Loc; mt]
- | "module"; i = a_UIDENT; mt = module_declaration ->
- Qast.Node "SgMod" [Qast.Loc; i; mt]
- | "module"; "type"; i = a_UIDENT; "="; mt = module_type ->
- Qast.Node "SgMty" [Qast.Loc; i; mt]
- | "module"; "rec"; mds = SLIST1 module_rec_declaration SEP "and" ->
- Qast.Node "SgRecMod" [Qast.Loc; mds]
- | "open"; i = mod_ident -> Qast.Node "SgOpn" [Qast.Loc; i]
- | "type"; tdl = SLIST1 type_declaration SEP "and" ->
- Qast.Node "SgTyp" [Qast.Loc; tdl]
- | "value"; i = a_LIDENT; ":"; t = ctyp ->
- Qast.Node "SgVal" [Qast.Loc; i; t] ] ]
- ;
- module_declaration:
- [ RIGHTA
- [ ":"; mt = module_type -> mt
- | "("; i = a_UIDENT; ":"; t = module_type; ")"; mt = SELF ->
- Qast.Node "MtFun" [Qast.Loc; i; t; mt] ] ]
- ;
- module_rec_declaration:
- [ [ m = a_UIDENT; ":"; mt = module_type -> Qast.Tuple [m; mt] ] ]
- ;
- with_constr:
- [ [ "type"; i = mod_ident; tpl = SLIST0 type_parameter; "="; t = ctyp ->
- Qast.Node "WcTyp" [Qast.Loc; i; tpl; t]
- | "module"; i = mod_ident; "="; me = module_expr ->
- Qast.Node "WcMod" [Qast.Loc; i; me] ] ]
- ;
- expr:
- [ "top" RIGHTA
- [ "let"; r = SOPT "rec"; l = SLIST1 let_binding SEP "and"; "in";
- x = SELF ->
- Qast.Node "ExLet" [Qast.Loc; o2b r; l; x]
- | "let"; "module"; m = a_UIDENT; mb = module_binding; "in"; e = SELF ->
- Qast.Node "ExLmd" [Qast.Loc; m; mb; e]
- | "fun"; "["; l = SLIST0 match_case SEP "|"; "]" ->
- Qast.Node "ExFun" [Qast.Loc; l]
- | "fun"; p = ipatt; e = fun_def ->
- Qast.Node "ExFun"
- [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]
- | "match"; e = SELF; "with"; "["; l = SLIST0 match_case SEP "|"; "]" ->
- Qast.Node "ExMat" [Qast.Loc; e; l]
- | "match"; e = SELF; "with"; p1 = ipatt; "->"; e1 = SELF ->
- Qast.Node "ExMat"
- [Qast.Loc; e; Qast.List [Qast.Tuple [p1; Qast.Option None; e1]]]
- | "try"; e = SELF; "with"; "["; l = SLIST0 match_case SEP "|"; "]" ->
- Qast.Node "ExTry" [Qast.Loc; e; l]
- | "try"; e = SELF; "with"; p1 = ipatt; "->"; e1 = SELF ->
- Qast.Node "ExTry"
- [Qast.Loc; e; Qast.List [Qast.Tuple [p1; Qast.Option None; e1]]]
- | "if"; e1 = SELF; "then"; e2 = SELF; "else"; e3 = SELF ->
- Qast.Node "ExIfe" [Qast.Loc; e1; e2; e3]
- | "do"; "{"; seq = sequence; "}" -> mksequence Qast.Loc seq
- | "for"; i = a_LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF;
- "do"; "{"; seq = sequence; "}" ->
- Qast.Node "ExFor" [Qast.Loc; i; e1; e2; df; seq]
- | "while"; e = SELF; "do"; "{"; seq = sequence; "}" ->
- Qast.Node "ExWhi" [Qast.Loc; e; seq] ]
- | "where"
- [ e = SELF; "where"; rf = SOPT "rec"; lb = let_binding ->
- Qast.Node "ExLet" [Qast.Loc; o2b rf; Qast.List [lb]; e] ]
- | ":=" NONA
- [ e1 = SELF; ":="; e2 = SELF; dummy ->
- Qast.Node "ExAss" [Qast.Loc; e1; e2] ]
- | "||" RIGHTA
- [ e1 = SELF; "||"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "||"]; e1];
- e2] ]
- | "&&" RIGHTA
- [ e1 = SELF; "&&"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "&&"]; e1];
- e2] ]
- | "<" LEFTA
- [ e1 = SELF; "<"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "<"]; e1];
- e2]
- | e1 = SELF; ">"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str ">"]; e1];
- e2]
- | e1 = SELF; "<="; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "<="]; e1];
- e2]
- | e1 = SELF; ">="; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str ">="]; e1];
- e2]
- | e1 = SELF; "="; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "="]; e1];
- e2]
- | e1 = SELF; "<>"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "<>"]; e1];
- e2]
- | e1 = SELF; "=="; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "=="]; e1];
- e2]
- | e1 = SELF; "!="; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "!="]; e1];
- e2] ]
- | "^" RIGHTA
- [ e1 = SELF; "^"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "^"]; e1];
- e2]
- | e1 = SELF; "@"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "@"]; e1];
- e2] ]
- | "+" LEFTA
- [ e1 = SELF; "+"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "+"]; e1];
- e2]
- | e1 = SELF; "-"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "-"]; e1];
- e2]
- | e1 = SELF; "+."; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "+."]; e1];
- e2]
- | e1 = SELF; "-."; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "-."]; e1];
- e2] ]
- | "*" LEFTA
- [ e1 = SELF; "*"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "*"]; e1];
- e2]
- | e1 = SELF; "/"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "/"]; e1];
- e2]
- | e1 = SELF; "*."; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "*."]; e1];
- e2]
- | e1 = SELF; "/."; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "/."]; e1];
- e2]
- | e1 = SELF; "land"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "land"]; e1];
- e2]
- | e1 = SELF; "lor"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "lor"]; e1];
- e2]
- | e1 = SELF; "lxor"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "lxor"]; e1];
- e2]
- | e1 = SELF; "mod"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "mod"]; e1];
- e2] ]
- | "**" RIGHTA
- [ e1 = SELF; "**"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "**"]; e1];
- e2]
- | e1 = SELF; "asr"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "asr"]; e1];
- e2]
- | e1 = SELF; "lsl"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "lsl"]; e1];
- e2]
- | e1 = SELF; "lsr"; e2 = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc;
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "lsr"]; e1];
- e2] ]
- | "unary minus" NONA
- [ "-"; e = SELF -> mkumin Qast.Loc (Qast.Str "-") e
- | "-."; e = SELF -> mkumin Qast.Loc (Qast.Str "-.") e ]
- | "apply" LEFTA
- [ e1 = SELF; e2 = SELF -> Qast.Node "ExApp" [Qast.Loc; e1; e2]
- | "assert"; e = SELF -> mkassert Qast.Loc e
- | "lazy"; e = SELF -> Qast.Node "ExLaz" [Qast.Loc; e] ]
- | "." LEFTA
- [ e1 = SELF; "."; "("; e2 = SELF; ")" ->
- Qast.Node "ExAre" [Qast.Loc; e1; e2]
- | e1 = SELF; "."; "["; e2 = SELF; "]" ->
- Qast.Node "ExSte" [Qast.Loc; e1; e2]
- | e1 = SELF; "."; e2 = SELF -> Qast.Node "ExAcc" [Qast.Loc; e1; e2] ]
- | "~-" NONA
- [ "~-"; e = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "~-"]; e]
- | "~-."; e = SELF ->
- Qast.Node "ExApp"
- [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "~-."]; e] ]
- | "simple"
- [ s = a_INT -> Qast.Node "ExInt" [Qast.Loc; s]
- | s = a_FLOAT -> Qast.Node "ExFlo" [Qast.Loc; s]
- | s = a_STRING -> Qast.Node "ExStr" [Qast.Loc; s]
- | s = a_CHAR -> Qast.Node "ExChr" [Qast.Loc; s]
- | i = expr_ident -> i
- | "["; "]" -> Qast.Node "ExUid" [Qast.Loc; Qast.Str "[]"]
- | "["; el = SLIST1 expr SEP ";"; last = cons_expr_opt; "]" ->
- mklistexp Qast.Loc last el
- | "[|"; el = SLIST0 expr SEP ";"; "|]" ->
- Qast.Node "ExArr" [Qast.Loc; el]
- | "{"; lel = SLIST1 label_expr SEP ";"; "}" ->
- Qast.Node "ExRec" [Qast.Loc; lel; Qast.Option None]
- | "{"; "("; e = SELF; ")"; "with"; lel = SLIST1 label_expr SEP ";";
- "}" ->
- Qast.Node "ExRec" [Qast.Loc; lel; Qast.Option (Some e)]
- | "("; ")" -> Qast.Node "ExUid" [Qast.Loc; Qast.Str "()"]
- | "("; e = SELF; ":"; t = ctyp; ")" ->
- Qast.Node "ExTyc" [Qast.Loc; e; t]
- | "("; e = SELF; ","; el = SLIST1 expr SEP ","; ")" ->
- Qast.Node "ExTup" [Qast.Loc; Qast.Cons e el]
- | "("; e = SELF; ")" -> e ] ]
- ;
- cons_expr_opt:
- [ [ "::"; e = expr -> Qast.Option (Some e)
- | -> Qast.Option None ] ]
- ;
- dummy:
- [ [ -> () ] ]
- ;
- sequence:
- [ [ "let"; rf = SOPT "rec"; l = SLIST1 let_binding SEP "and";
- [ "in" | ";" ]; el = SELF ->
- Qast.List
- [Qast.Node "ExLet" [Qast.Loc; o2b rf; l; mksequence Qast.Loc el]]
- | e = expr; ";"; el = SELF -> Qast.Cons e el
- | e = expr; ";" -> Qast.List [e]
- | e = expr -> Qast.List [e] ] ]
- ;
- let_binding:
- [ [ p = ipatt; e = fun_binding -> Qast.Tuple [p; e] ] ]
- ;
- fun_binding:
- [ RIGHTA
- [ p = ipatt; e = SELF ->
- Qast.Node "ExFun"
- [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]
- | "="; e = expr -> e
- | ":"; t = ctyp; "="; e = expr -> Qast.Node "ExTyc" [Qast.Loc; e; t] ] ]
- ;
- match_case:
- [ [ p = patt; aso = as_patt_opt; w = when_expr_opt; "->"; e = expr ->
- mkmatchcase Qast.Loc p aso w e ] ]
- ;
- as_patt_opt:
- [ [ "as"; p = patt -> Qast.Option (Some p)
- | -> Qast.Option None ] ]
- ;
- when_expr_opt:
- [ [ "when"; e = expr -> Qast.Option (Some e)
- | -> Qast.Option None ] ]
- ;
- label_expr:
- [ [ i = patt_label_ident; e = fun_binding -> Qast.Tuple [i; e] ] ]
- ;
- expr_ident:
- [ RIGHTA
- [ i = a_LIDENT -> Qast.Node "ExLid" [Qast.Loc; i]
- | i = a_UIDENT -> Qast.Node "ExUid" [Qast.Loc; i]
- | i = a_UIDENT; "."; j = SELF -> mkexprident Qast.Loc i j ] ]
- ;
- fun_def:
- [ RIGHTA
- [ p = ipatt; e = SELF ->
- Qast.Node "ExFun"
- [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]
- | "->"; e = expr -> e ] ]
- ;
- patt:
- [ LEFTA
- [ p1 = SELF; "|"; p2 = SELF -> Qast.Node "PaOrp" [Qast.Loc; p1; p2] ]
- | NONA
- [ p1 = SELF; ".."; p2 = SELF -> Qast.Node "PaRng" [Qast.Loc; p1; p2] ]
- | LEFTA
- [ p1 = SELF; p2 = SELF -> Qast.Node "PaApp" [Qast.Loc; p1; p2] ]
- | LEFTA
- [ p1 = SELF; "."; p2 = SELF -> Qast.Node "PaAcc" [Qast.Loc; p1; p2] ]
- | "simple"
- [ s = a_LIDENT -> Qast.Node "PaLid" [Qast.Loc; s]
- | s = a_UIDENT -> Qast.Node "PaUid" [Qast.Loc; s]
- | s = a_INT -> Qast.Node "PaInt" [Qast.Loc; s]
- | s = a_FLOAT -> Qast.Node "PaFlo" [Qast.Loc; s]
- | s = a_STRING -> Qast.Node "PaStr" [Qast.Loc; s]
- | s = a_CHAR -> Qast.Node "PaChr" [Qast.Loc; s]
- | "-"; s = a_INT -> mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool True) s
- | "-"; s = a_FLOAT ->
- mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool False) s
- | "["; "]" -> Qast.Node "PaUid" [Qast.Loc; Qast.Str "[]"]
- | "["; pl = SLIST1 patt SEP ";"; last = cons_patt_opt; "]" ->
- mklistpat Qast.Loc last pl
- | "[|"; pl = SLIST0 patt SEP ";"; "|]" ->
- Qast.Node "PaArr" [Qast.Loc; pl]
- | "{"; lpl = SLIST1 label_patt SEP ";"; "}" ->
- Qast.Node "PaRec" [Qast.Loc; lpl]
- | "("; ")" -> Qast.Node "PaUid" [Qast.Loc; Qast.Str "()"]
- | "("; p = SELF; ")" -> p
- | "("; p = SELF; ":"; t = ctyp; ")" ->
- Qast.Node "PaTyc" [Qast.Loc; p; t]
- | "("; p = SELF; "as"; p2 = SELF; ")" ->
- Qast.Node "PaAli" [Qast.Loc; p; p2]
- | "("; p = SELF; ","; pl = SLIST1 patt SEP ","; ")" ->
- Qast.Node "PaTup" [Qast.Loc; Qast.Cons p pl]
- | "_" -> Qast.Node "PaAny" [Qast.Loc] ] ]
- ;
- cons_patt_opt:
- [ [ "::"; p = patt -> Qast.Option (Some p)
- | -> Qast.Option None ] ]
- ;
- label_patt:
- [ [ i = patt_label_ident; "="; p = patt -> Qast.Tuple [i; p] ] ]
- ;
- patt_label_ident:
- [ LEFTA
- [ p1 = SELF; "."; p2 = SELF -> Qast.Node "PaAcc" [Qast.Loc; p1; p2] ]
- | "simple" RIGHTA
- [ i = a_UIDENT -> Qast.Node "PaUid" [Qast.Loc; i]
- | i = a_LIDENT -> Qast.Node "PaLid" [Qast.Loc; i] ] ]
- ;
- ipatt:
- [ [ "{"; lpl = SLIST1 label_ipatt SEP ";"; "}" ->
- Qast.Node "PaRec" [Qast.Loc; lpl]
- | "("; ")" -> Qast.Node "PaUid" [Qast.Loc; Qast.Str "()"]
- | "("; p = SELF; ")" -> p
- | "("; p = SELF; ":"; t = ctyp; ")" ->
- Qast.Node "PaTyc" [Qast.Loc; p; t]
- | "("; p = SELF; "as"; p2 = SELF; ")" ->
- Qast.Node "PaAli" [Qast.Loc; p; p2]
- | "("; p = SELF; ","; pl = SLIST1 ipatt SEP ","; ")" ->
- Qast.Node "PaTup" [Qast.Loc; Qast.Cons p pl]
- | s = a_LIDENT -> Qast.Node "PaLid" [Qast.Loc; s]
- | "_" -> Qast.Node "PaAny" [Qast.Loc] ] ]
- ;
- label_ipatt:
- [ [ i = patt_label_ident; "="; p = ipatt -> Qast.Tuple [i; p] ] ]
- ;
- type_declaration:
- [ [ n = type_patt; tpl = SLIST0 type_parameter; "="; tk = ctyp;
- cl = SLIST0 constrain ->
- Qast.Tuple [n; tpl; tk; cl] ] ]
- ;
- type_patt:
- [ [ n = a_LIDENT -> Qast.Tuple [Qast.Loc; n] ] ]
- ;
- constrain:
- [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> Qast.Tuple [t1; t2] ] ]
- ;
- type_parameter:
- [ [ "'"; i = ident ->
- Qast.Tuple [i; Qast.Tuple [Qast.Bool False; Qast.Bool False]]
- | "+"; "'"; i = ident ->
- Qast.Tuple [i; Qast.Tuple [Qast.Bool True; Qast.Bool False]]
- | "-"; "'"; i = ident ->
- Qast.Tuple [i; Qast.Tuple [Qast.Bool False; Qast.Bool True]] ] ]
- ;
- ctyp:
- [ LEFTA
- [ t1 = SELF; "=="; t2 = SELF -> Qast.Node "TyMan" [Qast.Loc; t1; t2] ]
- | LEFTA
- [ t1 = SELF; "as"; t2 = SELF -> Qast.Node "TyAli" [Qast.Loc; t1; t2] ]
- | LEFTA
- [ "!"; pl = SLIST1 typevar; "."; t = SELF ->
- Qast.Node "TyPol" [Qast.Loc; pl; t] ]
- | "arrow" RIGHTA
- [ t1 = SELF; "->"; t2 = SELF -> Qast.Node "TyArr" [Qast.Loc; t1; t2] ]
- | "label" NONA
- [ i = a_TILDEIDENT; ":"; t = SELF -> Qast.Node "TyLab" [Qast.Loc; i; t]
- | i = a_LABEL; t = SELF -> Qast.Node "TyLab" [Qast.Loc; i; t]
- | i = a_QUESTIONIDENT; ":"; t = SELF ->
- Qast.Node "TyOlb" [Qast.Loc; i; t]
- | i = a_OPTLABEL; t = SELF ->
- Qast.Node "TyOlb" [Qast.Loc; i; t] ]
- | LEFTA
- [ t1 = SELF; t2 = SELF -> Qast.Node "TyApp" [Qast.Loc; t1; t2] ]
- | LEFTA
- [ t1 = SELF; "."; t2 = SELF -> Qast.Node "TyAcc" [Qast.Loc; t1; t2] ]
- | "simple"
- [ "'"; i = ident -> Qast.Node "TyQuo" [Qast.Loc; i]
- | "_" -> Qast.Node "TyAny" [Qast.Loc]
- | i = a_LIDENT -> Qast.Node "TyLid" [Qast.Loc; i]
- | i = a_UIDENT -> Qast.Node "TyUid" [Qast.Loc; i]
- | "("; t = SELF; "*"; tl = SLIST1 ctyp SEP "*"; ")" ->
- Qast.Node "TyTup" [Qast.Loc; Qast.Cons t tl]
- | "("; t = SELF; ")" -> t
- | "private"; "["; cdl = SLIST0 constructor_declaration SEP "|"; "]" ->
- Qast.Node "TySum" [Qast.Loc; Qast.Bool True; cdl]
- | "private"; "{"; ldl = SLIST1 label_declaration SEP ";"; "}" ->
- Qast.Node "TyRec" [Qast.Loc; Qast.Bool True; ldl]
- | "["; cdl = SLIST0 constructor_declaration SEP "|"; "]" ->
- Qast.Node "TySum" [Qast.Loc; Qast.Bool False; cdl]
- | "{"; ldl = SLIST1 label_declaration SEP ";"; "}" ->
- Qast.Node "TyRec" [Qast.Loc; Qast.Bool False; ldl] ] ]
- ;
- constructor_declaration:
- [ [ ci = a_UIDENT; "of"; cal = SLIST1 ctyp SEP "and" ->
- Qast.Tuple [Qast.Loc; ci; cal]
- | ci = a_UIDENT -> Qast.Tuple [Qast.Loc; ci; Qast.List []] ] ]
- ;
- label_declaration:
- [ [ i = a_LIDENT; ":"; mf = SOPT "mutable"; t = ctyp ->
- Qast.Tuple [Qast.Loc; i; o2b mf; t] ] ]
- ;
- ident:
- [ [ i = a_LIDENT -> i
- | i = a_UIDENT -> i ] ]
- ;
- mod_ident:
- [ RIGHTA
- [ i = a_UIDENT -> Qast.List [i]
- | i = a_LIDENT -> Qast.List [i]
- | i = a_UIDENT; "."; j = SELF -> Qast.Cons i j ] ]
- ;
- (* Objects and Classes *)
- str_item:
- [ [ "class"; cd = SLIST1 class_declaration SEP "and" ->
- Qast.Node "StCls" [Qast.Loc; cd]
- | "class"; "type"; ctd = SLIST1 class_type_declaration SEP "and" ->
- Qast.Node "StClt" [Qast.Loc; ctd] ] ]
- ;
- sig_item:
- [ [ "class"; cd = SLIST1 class_description SEP "and" ->
- Qast.Node "SgCls" [Qast.Loc; cd]
- | "class"; "type"; ctd = SLIST1 class_type_declaration SEP "and" ->
- Qast.Node "SgClt" [Qast.Loc; ctd] ] ]
- ;
- class_declaration:
- [ [ vf = SOPT "virtual"; i = a_LIDENT; ctp = class_type_parameters;
- cfb = class_fun_binding ->
- Qast.Record
- [("ciLoc", Qast.Loc); ("ciVir", o2b vf); ("ciPrm", ctp);
- ("ciNam", i); ("ciExp", cfb)] ] ]
- ;
- class_fun_binding:
- [ [ "="; ce = class_expr -> ce
- | ":"; ct = class_type; "="; ce = class_expr ->
- Qast.Node "CeTyc" [Qast.Loc; ce; ct]
- | p = ipatt; cfb = SELF -> Qast.Node "CeFun" [Qast.Loc; p; cfb] ] ]
- ;
- class_type_parameters:
- [ [ -> Qast.Tuple [Qast.Loc; Qast.List []]
- | "["; tpl = SLIST1 type_parameter SEP ","; "]" ->
- Qast.Tuple [Qast.Loc; tpl] ] ]
- ;
- class_fun_def:
- [ [ p = ipatt; ce = SELF -> Qast.Node "CeFun" [Qast.Loc; p; ce]
- | "->"; ce = class_expr -> ce ] ]
- ;
- class_expr:
- [ "top"
- [ "fun"; p = ipatt; ce = class_fun_def ->
- Qast.Node "CeFun" [Qast.Loc; p; ce]
- | "let"; rf = SOPT "rec"; lb = SLIST1 let_binding SEP "and"; "in";
- ce = SELF ->
- Qast.Node "CeLet" [Qast.Loc; o2b rf; lb; ce] ]
- | "apply" NONA
- [ ce = SELF; e = expr LEVEL "label" ->
- Qast.Node "CeApp" [Qast.Loc; ce; e] ]
- | "simple"
- [ ci = class_longident; "["; ctcl = SLIST0 ctyp SEP ","; "]" ->
- Qast.Node "CeCon" [Qast.Loc; ci; ctcl]
- | ci = class_longident -> Qast.Node "CeCon" [Qast.Loc; ci; Qast.List []]
- | "object"; cspo = SOPT class_self_patt; cf = class_structure; "end" ->
- Qast.Node "CeStr" [Qast.Loc; cspo; cf]
- | "("; ce = SELF; ":"; ct = class_type; ")" ->
- Qast.Node "CeTyc" [Qast.Loc; ce; ct]
- | "("; ce = SELF; ")" -> ce ] ]
- ;
- class_structure:
- [ [ cf = SLIST0 [ cf = class_str_item; ";" -> cf ] -> cf ] ]
- ;
- class_self_patt:
- [ [ "("; p = patt; ")" -> p
- | "("; p = patt; ":"; t = ctyp; ")" ->
- Qast.Node "PaTyc" [Qast.Loc; p; t] ] ]
- ;
- class_str_item:
- [ [ "declare"; st = SLIST0 [ s = class_str_item; ";" -> s ]; "end" ->
- Qast.Node "CrDcl" [Qast.Loc; st]
- | "inherit"; ce = class_expr; pb = SOPT as_lident ->
- Qast.Node "CrInh" [Qast.Loc; ce; pb]
- | "value"; mf = SOPT "mutable"; lab = label; e = cvalue_binding ->
- Qast.Node "CrVal" [Qast.Loc; lab; o2b mf; e]
- | "method"; "virtual"; pf = SOPT "private"; l = label; ":"; t = ctyp ->
- Qast.Node "CrVir" [Qast.Loc; l; o2b pf; t]
- | "method"; pf = SOPT "private"; l = label; topt = SOPT polyt;
- e = fun_binding ->
- Qast.Node "CrMth" [Qast.Loc; l; o2b pf; e; topt]
- | "type"; t1 = ctyp; "="; t2 = ctyp ->
- Qast.Node "CrCtr" [Qast.Loc; t1; t2]
- | "initializer"; se = expr -> Qast.Node "CrIni" [Qast.Loc; se] ] ]
- ;
- as_lident:
- [ [ "as"; i = a_LIDENT -> i ] ]
- ;
- polyt:
- [ [ ":"; t = ctyp -> t ] ]
- ;
- cvalue_binding:
- [ [ "="; e = expr -> e
- | ":"; t = ctyp; "="; e = expr -> Qast.Node "ExTyc" [Qast.Loc; e; t]
- | ":"; t = ctyp; ":>"; t2 = ctyp; "="; e = expr ->
- Qast.Node "ExCoe" [Qast.Loc; e; Qast.Option (Some t); t2]
- | ":>"; t = ctyp; "="; e = expr ->
- Qast.Node "ExCoe" [Qast.Loc; e; Qast.Option None; t] ] ]
- ;
- label:
- [ [ i = a_LIDENT -> i ] ]
- ;
- class_type:
- [ [ "["; t = ctyp; "]"; "->"; ct = SELF ->
- Qast.Node "CtFun" [Qast.Loc; t; ct]
- | id = clty_longident; "["; tl = SLIST1 ctyp SEP ","; "]" ->
- Qast.Node "CtCon" [Qast.Loc; id; tl]
- | id = clty_longident -> Qast.Node "CtCon" [Qast.Loc; id; Qast.List []]
- | "object"; cst = SOPT class_self_type;
- csf = SLIST0 [ csf = class_sig_item; ";" -> csf ]; "end" ->
- Qast.Node "CtSig" [Qast.Loc; cst; csf] ] ]
- ;
- class_self_type:
- [ [ "("; t = ctyp; ")" -> t ] ]
- ;
- class_sig_item:
- [ [ "declare"; st = SLIST0 [ s = class_sig_item; ";" -> s ]; "end" ->
- Qast.Node "CgDcl" [Qast.Loc; st]
- | "inherit"; cs = class_type -> Qast.Node "CgInh" [Qast.Loc; cs]
- | "value"; mf = SOPT "mutable"; l = label; ":"; t = ctyp ->
- Qast.Node "CgVal" [Qast.Loc; l; o2b mf; t]
- | "method"; "virtual"; pf = SOPT "private"; l = label; ":"; t = ctyp ->
- Qast.Node "CgVir" [Qast.Loc; l; o2b pf; t]
- | "method"; pf = SOPT "private"; l = label; ":"; t = ctyp ->
- Qast.Node "CgMth" [Qast.Loc; l; o2b pf; t]
- | "type"; t1 = ctyp; "="; t2 = ctyp ->
- Qast.Node "CgCtr" [Qast.Loc; t1; t2] ] ]
- ;
- class_description:
- [ [ vf = SOPT "virtual"; n = a_LIDENT; ctp = class_type_parameters; ":";
- ct = class_type ->
- Qast.Record
- [("ciLoc", Qast.Loc); ("ciVir", o2b vf); ("ciPrm", ctp);
- ("ciNam", n); ("ciExp", ct)] ] ]
- ;
- class_type_declaration:
- [ [ vf = SOPT "virtual"; n = a_LIDENT; ctp = class_type_parameters; "=";
- cs = class_type ->
- Qast.Record
- [("ciLoc", Qast.Loc); ("ciVir", o2b vf); ("ciPrm", ctp);
- ("ciNam", n); ("ciExp", cs)] ] ]
- ;
- expr: LEVEL "apply"
- [ LEFTA
- [ "new"; i = class_longident -> Qast.Node "ExNew" [Qast.Loc; i] ] ]
- ;
- expr: LEVEL "."
- [ [ e = SELF; "#"; lab = label -> Qast.Node "ExSnd" [Qast.Loc; e; lab] ] ]
- ;
- expr: LEVEL "simple"
- [ [ "("; e = SELF; ":"; t = ctyp; ":>"; t2 = ctyp; ")" ->
- Qast.Node "ExCoe" [Qast.Loc; e; Qast.Option (Some t); t2]
- | "("; e = SELF; ":>"; t = ctyp; ")" ->
- Qast.Node "ExCoe" [Qast.Loc; e; Qast.Option None; t]
- | "{<"; fel = SLIST0 field_expr SEP ";"; ">}" ->
- Qast.Node "ExOvr" [Qast.Loc; fel] ] ]
- ;
- field_expr:
- [ [ l = label; "="; e = expr -> Qast.Tuple [l; e] ] ]
- ;
- ctyp: LEVEL "simple"
- [ [ "#"; id = class_longident -> Qast.Node "TyCls" [Qast.Loc; id]
- | "<"; ml = SLIST0 field SEP ";"; v = SOPT ".."; ">" ->
- Qast.Node "TyObj" [Qast.Loc; ml; o2b v] ] ]
- ;
- field:
- [ [ lab = a_LIDENT; ":"; t = ctyp -> Qast.Tuple [lab; t] ] ]
- ;
- typevar:
- [ [ "'"; i = ident -> i ] ]
- ;
- clty_longident:
- [ [ m = a_UIDENT; "."; l = SELF -> Qast.Cons m l
- | i = a_LIDENT -> Qast.List [i] ] ]
- ;
- class_longident:
- [ [ m = a_UIDENT; "."; l = SELF -> Qast.Cons m l
- | i = a_LIDENT -> Qast.List [i] ] ]
- ;
- ctyp: LEVEL "simple"
- [ [ "["; "="; rfl = row_field_list; "]" ->
- Qast.Node "TyVrn" [Qast.Loc; rfl; Qast.Option None]
- | "["; ">"; rfl = row_field_list; "]" ->
- Qast.Node "TyVrn"
- [Qast.Loc; rfl; Qast.Option (Some (Qast.Option None))]
- | "["; "<"; rfl = row_field_list; "]" ->
- Qast.Node "TyVrn"
- [Qast.Loc; rfl;
- Qast.Option (Some (Qast.Option (Some (Qast.List []))))]
- | "["; "<"; rfl = row_field_list; ">"; ntl = SLIST1 name_tag; "]" ->
- Qast.Node "TyVrn"
- [Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))] ] ]
- ;
- row_field_list:
- [ [ rfl = SLIST0 row_field SEP "|" -> rfl ] ]
- ;
- row_field:
- [ [ "`"; i = ident -> Qast.Node "RfTag" [i; Qast.Bool True; Qast.List []]
- | "`"; i = ident; "of"; ao = SOPT "&"; l = SLIST1 ctyp SEP "&" ->
- Qast.Node "RfTag" [i; o2b ao; l]
- | t = ctyp -> Qast.Node "RfInh" [t] ] ]
- ;
- name_tag:
- [ [ "`"; i = ident -> i ] ]
- ;
- patt: LEVEL "simple"
- [ [ "`"; s = ident -> Qast.Node "PaVrn" [Qast.Loc; s]
- | "#"; sl = mod_ident -> Qast.Node "PaTyp" [Qast.Loc; sl]
- | i = a_TILDEIDENT; ":"; p = SELF ->
- Qast.Node "PaLab" [Qast.Loc; i; Qast.Option (Some p)]
- | i = a_LABEL; p = SELF ->
- Qast.Node "PaLab" [Qast.Loc; i; Qast.Option (Some p)]
- | i = a_TILDEIDENT -> Qast.Node "PaLab" [Qast.Loc; i; Qast.Option None]
- | i = a_QUESTIONIDENT; ":"; "("; p = patt_tcon; eo = SOPT eq_expr;
- ")" ->
- Qast.Node "PaOlb"
- [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]
- | i = a_OPTLABEL; "("; p = patt_tcon; eo = SOPT eq_expr; ")" ->
- Qast.Node "PaOlb"
- [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]
- | i = a_QUESTIONIDENT ->
- Qast.Node "PaOlb" [Qast.Loc; i; Qast.Option None]
- | "?"; "("; p = patt_tcon; eo = SOPT eq_expr; ")" ->
- Qast.Node "PaOlb"
- [Qast.Loc; Qast.Str "";
- Qast.Option (Some (Qast.Tuple [p; eo]))] ] ]
- ;
- patt_tcon:
- [ [ p = patt; ":"; t = ctyp -> Qast.Node "PaTyc" [Qast.Loc; p; t]
- | p = patt -> p ] ]
- ;
- ipatt:
- [ [ i = a_TILDEIDENT; ":"; p = SELF ->
- Qast.Node "PaLab" [Qast.Loc; i; Qast.Option (Some p)]
- | i = a_LABEL; p = SELF ->
- Qast.Node "PaLab" [Qast.Loc; i; Qast.Option (Some p)]
- | i = a_TILDEIDENT -> Qast.Node "PaLab" [Qast.Loc; i; Qast.Option None]
- | i = a_QUESTIONIDENT; ":"; "("; p = ipatt_tcon; eo = SOPT eq_expr;
- ")" ->
- Qast.Node "PaOlb"
- [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]
- | i = a_OPTLABEL; "("; p = ipatt_tcon; eo = SOPT eq_expr; ")" ->
- Qast.Node "PaOlb"
- [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]
- | i = a_QUESTIONIDENT ->
- Qast.Node "PaOlb" [Qast.Loc; i; Qast.Option None]
- | "?"; "("; p = ipatt_tcon; eo = SOPT eq_expr; ")" ->
- Qast.Node "PaOlb"
- [Qast.Loc; Qast.Str "";
- Qast.Option (Some (Qast.Tuple [p; eo]))] ] ]
- ;
- ipatt_tcon:
- [ [ p = ipatt; ":"; t = ctyp -> Qast.Node "PaTyc" [Qast.Loc; p; t]
- | p = ipatt -> p ] ]
- ;
- eq_expr:
- [ [ "="; e = expr -> e ] ]
- ;
- expr: AFTER "apply"
- [ "label" NONA
- [ i = a_TILDEIDENT; ":"; e = SELF ->
- Qast.Node "ExLab" [Qast.Loc; i; Qast.Option (Some e)]
- | i = a_LABEL; e = SELF ->
- Qast.Node "ExLab" [Qast.Loc; i; Qast.Option (Some e)]
- | i = a_TILDEIDENT -> Qast.Node "ExLab" [Qast.Loc; i; Qast.Option None]
- | i = a_QUESTIONIDENT; ":"; e = SELF ->
- Qast.Node "ExOlb" [Qast.Loc; i; Qast.Option (Some e)]
- | i = a_OPTLABEL; e = SELF ->
- Qast.Node "ExOlb" [Qast.Loc; i; Qast.Option (Some e)]
- | i = a_QUESTIONIDENT ->
- Qast.Node "ExOlb" [Qast.Loc; i; Qast.Option None] ] ]
- ;
- expr: LEVEL "simple"
- [ [ "`"; s = ident -> Qast.Node "ExVrn" [Qast.Loc; s] ] ]
- ;
- direction_flag:
- [ [ "to" -> Qast.Bool True
- | "downto" -> Qast.Bool False ] ]
- ;
- (* Compatibility old syntax of variant types definitions *)
- ctyp: LEVEL "simple"
- [ [ "[|"; warning_variant; rfl = row_field_list; "|]" ->
- Qast.Node "TyVrn" [Qast.Loc; rfl; Qast.Option None]
- | "[|"; warning_variant; ">"; rfl = row_field_list; "|]" ->
- Qast.Node "TyVrn"
- [Qast.Loc; rfl; Qast.Option (Some (Qast.Option None))]
- | "[|"; warning_variant; "<"; rfl = row_field_list; "|]" ->
- Qast.Node "TyVrn"
- [Qast.Loc; rfl;
- Qast.Option (Some (Qast.Option (Some (Qast.List []))))]
- | "[|"; warning_variant; "<"; rfl = row_field_list; ">";
- ntl = SLIST1 name_tag; "|]" ->
- Qast.Node "TyVrn"
- [Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))] ] ]
- ;
- warning_variant:
- [ [ -> warn_variant Qast.Loc ] ]
- ;
- (* Compatibility old syntax of sequences *)
- expr: LEVEL "top"
- [ [ "do"; seq = SLIST0 [ e = expr; ";" -> e ]; "return"; warning_sequence;
- e = SELF ->
- Qast.Node "ExSeq" [Qast.Loc; append_elem seq e]
- | "for"; i = a_LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF;
- "do"; seq = SLIST0 [ e = expr; ";" -> e ]; warning_sequence; "done" ->
- Qast.Node "ExFor" [Qast.Loc; i; e1; e2; df; seq]
- | "while"; e = SELF; "do"; seq = SLIST0 [ e = expr; ";" -> e ];
- warning_sequence; "done" ->
- Qast.Node "ExWhi" [Qast.Loc; e; seq] ] ]
- ;
- warning_sequence:
- [ [ -> warn_sequence Qast.Loc ] ]
- ;
- (* Antiquotations for local entries *)
- sequence:
- [ [ a = ANTIQUOT "list" -> antiquot "list" loc a ] ]
- ;
- expr_ident:
- [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
- ;
- patt_label_ident: LEVEL "simple"
- [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
- ;
- when_expr_opt:
- [ [ a = ANTIQUOT "when" -> antiquot "when" loc a ] ]
- ;
- mod_ident:
- [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
- ;
- clty_longident:
- [ [ a = a_list -> a ] ]
- ;
- class_longident:
- [ [ a = a_list -> a ] ]
- ;
- direction_flag:
- [ [ a = ANTIQUOT "to" -> antiquot "to" loc a ] ]
- ;
- (* deprecated since version 3.05; code for compatibility *)
- class_expr: LEVEL "simple"
- [ [ "object"; x = ANTIQUOT; cf = class_structure; "end" ->
- let _ = warn_antiq loc "3.05" in
- Qast.Node "CeStr" [Qast.Loc; antiquot "" loc x; cf]
- | "object"; x = ANTIQUOT; ";";
- csl = SLIST0 [ cf = class_str_item; ";" -> cf ] ; "end" ->
- let _ = warn_antiq loc "3.05" in
- Qast.Node "CeStr"
- [Qast.Loc; Qast.Option None;
- Qast.Cons (antiquot "" loc x) csl] ] ]
- ;
- class_type:
- [ [ "object"; x = ANTIQUOT;
- csf = SLIST0 [ csf = class_sig_item; ";" -> csf ]; "end" ->
- let _ = warn_antiq loc "3.05" in
- Qast.Node "CtSig" [Qast.Loc; antiquot "" loc x; csf]
- | "object"; x = ANTIQUOT; ";";
- csf = SLIST0 [ csf = class_sig_item; ";" -> csf ]; "end" ->
- let _ = warn_antiq loc "3.05" in
- Qast.Node "CtSig"
- [Qast.Loc; Qast.Option None;
- Qast.Cons (antiquot "" loc x) csf] ] ]
- ;
- (* deprecated since version 3.06+18; code for compatibility *)
- expr: LEVEL "top"
- [ [ "let"; r = ANTIQUOT "rec"; l = SLIST1 let_binding SEP "and"; "in";
- x = SELF ->
- let _ = warn_antiq loc "3.06+18" in
- Qast.Node "ExLet" [Qast.Loc; antiquot "rec" loc r; l; x] ] ]
- ;
- str_item: LEVEL "top"
- [ [ "value"; r = ANTIQUOT "rec"; l = SLIST1 let_binding SEP "and" ->
- let _ = warn_antiq loc "3.06+18" in
- Qast.Node "StVal" [Qast.Loc; antiquot "rec" loc r; l] ] ]
- ;
- class_expr: LEVEL "top"
- [ [ "let"; r = ANTIQUOT "rec"; lb = SLIST1 let_binding SEP "and"; "in";
- ce = SELF ->
- let _ = warn_antiq loc "3.06+18" in
- Qast.Node "CeLet" [Qast.Loc; antiquot "rec" loc r; lb; ce] ] ]
- ;
- class_str_item:
- [ [ "inherit"; ce = class_expr; pb = ANTIQUOT "as" ->
- let _ = warn_antiq loc "3.06+18" in
- Qast.Node "CrInh" [Qast.Loc; ce; antiquot "as" loc pb]
- | "value"; mf = ANTIQUOT "mut"; lab = label; e = cvalue_binding ->
- let _ = warn_antiq loc "3.06+18" in
- Qast.Node "CrVal" [Qast.Loc; lab; antiquot "mut" loc mf; e] ] ]
- ;
- class_sig_item:
- [ [ "value"; mf = ANTIQUOT "mut"; l = label; ":"; t = ctyp ->
- let _ = warn_antiq loc "3.06+18" in
- Qast.Node "CgVal" [Qast.Loc; l; antiquot "mut" loc mf; t] ] ]
- ;
-END;
-
-EXTEND
- GLOBAL: str_item sig_item;
- str_item:
- [ [ "#"; n = a_LIDENT; dp = dir_param ->
- Qast.Node "StDir" [Qast.Loc; n; dp] ] ]
- ;
- sig_item:
- [ [ "#"; n = a_LIDENT; dp = dir_param ->
- Qast.Node "SgDir" [Qast.Loc; n; dp] ] ]
- ;
- dir_param:
- [ [ a = ANTIQUOT "opt" -> antiquot "opt" loc a
- | e = expr -> Qast.Option (Some e)
- | -> Qast.Option None ] ]
- ;
-END;
-
-(* Antiquotations *)
-
-EXTEND
- module_expr: LEVEL "simple"
- [ [ a = ANTIQUOT "mexp" -> antiquot "mexp" loc a
- | a = ANTIQUOT -> antiquot "" loc a ] ]
- ;
- str_item: LEVEL "top"
- [ [ a = ANTIQUOT "stri" -> antiquot "stri" loc a
- | a = ANTIQUOT -> antiquot "" loc a ] ]
- ;
- module_type: LEVEL "simple"
- [ [ a = ANTIQUOT "mtyp" -> antiquot "mtyp" loc a
- | a = ANTIQUOT -> antiquot "" loc a ] ]
- ;
- sig_item: LEVEL "top"
- [ [ a = ANTIQUOT "sigi" -> antiquot "sigi" loc a
- | a = ANTIQUOT -> antiquot "" loc a ] ]
- ;
- expr: LEVEL "simple"
- [ [ a = ANTIQUOT "exp" -> antiquot "exp" loc a
- | a = ANTIQUOT -> antiquot "" loc a
- | a = ANTIQUOT "anti" ->
- Qast.Node "ExAnt" [Qast.Loc; antiquot "anti" loc a]
- | "("; el = a_list; ")" -> Qast.Node "ExTup" [Qast.Loc; el] ] ]
- ;
- patt: LEVEL "simple"
- [ [ a = ANTIQUOT "pat" -> antiquot "pat" loc a
- | a = ANTIQUOT -> antiquot "" loc a
- | a = ANTIQUOT "anti" ->
- Qast.Node "PaAnt" [Qast.Loc; antiquot "anti" loc a]
- | "("; pl = a_list; ")" -> Qast.Node "PaTup" [Qast.Loc; pl] ] ]
- ;
- ipatt:
- [ [ a = ANTIQUOT "pat" -> antiquot "pat" loc a
- | a = ANTIQUOT -> antiquot "" loc a
- | a = ANTIQUOT "anti" ->
- Qast.Node "PaAnt" [Qast.Loc; antiquot "anti" loc a]
- | "("; pl = a_list; ")" -> Qast.Node "PaTup" [Qast.Loc; pl] ] ]
- ;
- ctyp: LEVEL "simple"
- [ [ a = ANTIQUOT "typ" -> antiquot "typ" loc a
- | a = ANTIQUOT -> antiquot "" loc a
- | "("; tl = a_list; ")" -> Qast.Node "TyTup" [Qast.Loc; tl] ] ]
- ;
- class_expr: LEVEL "simple"
- [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
- ;
- class_str_item:
- [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
- ;
- class_sig_item:
- [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
- ;
- class_type:
- [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
- ;
- expr: LEVEL "simple"
- [ [ "{<"; fel = a_list; ">}" -> Qast.Node "ExOvr" [Qast.Loc; fel] ] ]
- ;
- patt: LEVEL "simple"
- [ [ "#"; a = a_list -> Qast.Node "PaTyp" [Qast.Loc; a] ] ]
- ;
- a_list:
- [ [ a = ANTIQUOT "list" -> antiquot "list" loc a ] ]
- ;
- a_opt:
- [ [ a = ANTIQUOT "opt" -> antiquot "opt" loc a ] ]
- ;
- a_UIDENT:
- [ [ a = ANTIQUOT "uid" -> antiquot "uid" loc a
- | a = ANTIQUOT -> antiquot "" loc a
- | i = UIDENT -> Qast.Str i ] ]
- ;
- a_LIDENT:
- [ [ a = ANTIQUOT "lid" -> antiquot "lid" loc a
- | a = ANTIQUOT -> antiquot "" loc a
- | i = LIDENT -> Qast.Str i ] ]
- ;
- a_INT:
- [ [ a = ANTIQUOT "int" -> antiquot "int" loc a
- | a = ANTIQUOT -> antiquot "" loc a
- | s = INT -> Qast.Str s ] ]
- ;
- a_FLOAT:
- [ [ a = ANTIQUOT "flo" -> antiquot "flo" loc a
- | a = ANTIQUOT -> antiquot "" loc a
- | s = FLOAT -> Qast.Str s ] ]
- ;
- a_STRING:
- [ [ a = ANTIQUOT "str" -> antiquot "str" loc a
- | a = ANTIQUOT -> antiquot "" loc a
- | s = STRING -> Qast.Str s ] ]
- ;
- a_CHAR:
- [ [ a = ANTIQUOT "chr" -> antiquot "chr" loc a
- | a = ANTIQUOT -> antiquot "" loc a
- | s = CHAR -> Qast.Str s ] ]
- ;
- a_TILDEIDENT:
- [ [ "~"; a = ANTIQUOT -> antiquot "" loc a
- | s = TILDEIDENT -> Qast.Str s ] ]
- ;
- a_LABEL:
- [ [ s = LABEL -> Qast.Str s ] ]
- ;
- a_QUESTIONIDENT:
- [ [ "?"; a = ANTIQUOT -> antiquot "" loc a
- | s = QUESTIONIDENT -> Qast.Str s ] ]
- ;
- a_OPTLABEL:
- [ [ s = OPTLABEL -> Qast.Str s ] ]
- ;
-END;
-
-value apply_entry e =
- let f s = Grammar.Entry.parse e (Stream.of_string s) in
- let expr s = Qast.to_expr (f s) in
- let patt s = Qast.to_patt (f s) in
- Quotation.ExAst (expr, patt)
-;
-
-let sig_item_eoi = Grammar.Entry.create gram "signature item" in
-do {
- EXTEND
- sig_item_eoi:
- [ [ x = sig_item; EOI -> x ] ]
- ;
- END;
- Quotation.add "sig_item" (apply_entry sig_item_eoi)
-};
-
-let str_item_eoi = Grammar.Entry.create gram "structure item" in
-do {
- EXTEND
- str_item_eoi:
- [ [ x = str_item; EOI -> x ] ]
- ;
- END;
- Quotation.add "str_item" (apply_entry str_item_eoi)
-};
-
-let ctyp_eoi = Grammar.Entry.create gram "type" in
-do {
- EXTEND
- ctyp_eoi:
- [ [ x = ctyp; EOI -> x ] ]
- ;
- END;
- Quotation.add "ctyp" (apply_entry ctyp_eoi)
-};
-
-let patt_eoi = Grammar.Entry.create gram "pattern" in
-do {
- EXTEND
- patt_eoi:
- [ [ x = patt; EOI -> x ] ]
- ;
- END;
- Quotation.add "patt" (apply_entry patt_eoi)
-};
-
-let expr_eoi = Grammar.Entry.create gram "expression" in
-do {
- EXTEND
- expr_eoi:
- [ [ x = expr; EOI -> x ] ]
- ;
- END;
- Quotation.add "expr" (apply_entry expr_eoi)
-};
-
-let module_type_eoi = Grammar.Entry.create gram "module type" in
-do {
- EXTEND
- module_type_eoi:
- [ [ x = module_type; EOI -> x ] ]
- ;
- END;
- Quotation.add "module_type" (apply_entry module_type_eoi)
-};
-
-let module_expr_eoi = Grammar.Entry.create gram "module expression" in
-do {
- EXTEND
- module_expr_eoi:
- [ [ x = module_expr; EOI -> x ] ]
- ;
- END;
- Quotation.add "module_expr" (apply_entry module_expr_eoi)
-};
-
-let class_type_eoi = Grammar.Entry.create gram "class_type" in
-do {
- EXTEND
- class_type_eoi:
- [ [ x = class_type; EOI -> x ] ]
- ;
- END;
- Quotation.add "class_type" (apply_entry class_type_eoi)
-};
-
-let class_expr_eoi = Grammar.Entry.create gram "class_expr" in
-do {
- EXTEND
- class_expr_eoi:
- [ [ x = class_expr; EOI -> x ] ]
- ;
- END;
- Quotation.add "class_expr" (apply_entry class_expr_eoi)
-};
-
-let class_sig_item_eoi = Grammar.Entry.create gram "class_sig_item" in
-do {
- EXTEND
- class_sig_item_eoi:
- [ [ x = class_sig_item; EOI -> x ] ]
- ;
- END;
- Quotation.add "class_sig_item" (apply_entry class_sig_item_eoi)
-};
-
-let class_str_item_eoi = Grammar.Entry.create gram "class_str_item" in
-do {
- EXTEND
- class_str_item_eoi:
- [ [ x = class_str_item; EOI -> x ] ]
- ;
- END;
- Quotation.add "class_str_item" (apply_entry class_str_item_eoi)
-};
-
-let with_constr_eoi = Grammar.Entry.create gram "with constr" in
-do {
- EXTEND
- with_constr_eoi:
- [ [ x = with_constr; EOI -> x ] ]
- ;
- END;
- Quotation.add "with_constr" (apply_entry with_constr_eoi)
-};
-
-let row_field_eoi = Grammar.Entry.create gram "row_field" in
-do {
- EXTEND
- row_field_eoi:
- [ [ x = row_field; EOI -> x ] ]
- ;
- END;
- Quotation.add "row_field" (apply_entry row_field_eoi)
-};
diff --git a/camlp4/ocaml_src/.cvsignore b/camlp4/ocaml_src/.cvsignore
deleted file mode 100644
index 2551b02453..0000000000
--- a/camlp4/ocaml_src/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-SAVED
diff --git a/camlp4/ocaml_src/camlp4/.cvsignore b/camlp4/ocaml_src/camlp4/.cvsignore
deleted file mode 100644
index eb4bb86b20..0000000000
--- a/camlp4/ocaml_src/camlp4/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-camlp4
-crc.ml
-extract_crc
diff --git a/camlp4/ocaml_src/camlp4/.depend b/camlp4/ocaml_src/camlp4/.depend
deleted file mode 100644
index bf82065403..0000000000
--- a/camlp4/ocaml_src/camlp4/.depend
+++ /dev/null
@@ -1,21 +0,0 @@
-ast2pt.cmi: $(OTOP)/parsing/location.cmi $(OTOP)/parsing/longident.cmi mLast.cmi \
- $(OTOP)/parsing/parsetree.cmi
-pcaml.cmi: mLast.cmi spretty.cmi
-quotation.cmi: mLast.cmi
-reloc.cmi: mLast.cmi
-argl.cmo: ast2pt.cmi mLast.cmi ../odyl/odyl_main.cmi pcaml.cmi
-argl.cmx: ast2pt.cmx mLast.cmi ../odyl/odyl_main.cmx pcaml.cmx
-ast2pt.cmo: $(OTOP)/parsing/asttypes.cmi $(OTOP)/parsing/location.cmi \
- $(OTOP)/parsing/longident.cmi mLast.cmi $(OTOP)/parsing/parsetree.cmi \
- ast2pt.cmi
-ast2pt.cmx: $(OTOP)/parsing/asttypes.cmi $(OTOP)/parsing/location.cmx \
- $(OTOP)/parsing/longident.cmx mLast.cmi $(OTOP)/parsing/parsetree.cmi \
- ast2pt.cmi
-pcaml.cmo: ast2pt.cmi mLast.cmi quotation.cmi reloc.cmi spretty.cmi pcaml.cmi
-pcaml.cmx: ast2pt.cmx mLast.cmi quotation.cmx reloc.cmx spretty.cmx pcaml.cmi
-quotation.cmo: mLast.cmi quotation.cmi
-quotation.cmx: mLast.cmi quotation.cmi
-reloc.cmo: mLast.cmi reloc.cmi
-reloc.cmx: mLast.cmi reloc.cmi
-spretty.cmo: spretty.cmi
-spretty.cmx: spretty.cmi
diff --git a/camlp4/ocaml_src/camlp4/Makefile b/camlp4/ocaml_src/camlp4/Makefile
deleted file mode 100644
index 0e5d05762d..0000000000
--- a/camlp4/ocaml_src/camlp4/Makefile
+++ /dev/null
@@ -1,71 +0,0 @@
-# This file has been generated by program: do not edit!
-
-include ../../config/Makefile
-
-SHELL=/bin/sh
-
-INCLUDES=-I ../odyl -I ../../boot -I $(OTOP)/utils -I $(OTOP)/parsing -I $(OTOP)/otherlibs/dynlink
-OCAMLCFLAGS= $(INCLUDES) -warn-error A $(INCLUDES)
-LINKFLAGS=$(INCLUDES)
-INTERFACES=-I $(OLIBDIR) Arg Array ArrayLabels Buffer Callback CamlinternalOO Char Complex Digest Filename Format Gc Genlex Hashtbl Int32 Int64 Lazy Lexing List ListLabels Map Marshal MoreLabels Nativeint Obj Oo Parsing Pervasives Printexc Printf Queue Random Scanf Set Sort Stack StdLabels Stream String StringLabels Sys Weak -I ../../boot Extfold Extfun Fstream Gramext Grammar Plexer Stdpp Token -I $(OTOP)/utils Config Warnings -I $(OTOP)/parsing Asttypes Location Longident Parsetree -I . Ast2pt MLast Pcaml Quotation Spretty
-CAMLP4_INTF=$(OTOP)/utils/config.cmi $(OTOP)/utils/warnings.cmi $(OTOP)/parsing/asttypes.cmi $(OTOP)/parsing/location.cmi $(OTOP)/parsing/longident.cmi $(OTOP)/parsing/parsetree.cmi ast2pt.cmi mLast.cmi pcaml.cmi spretty.cmi quotation.cmi
-CAMLP4_OBJS=../../boot/stdpp.cmo ../../boot/token.cmo ../../boot/plexer.cmo ../../boot/gramext.cmo ../../boot/grammar.cmo ../../boot/extfold.cmo ../../boot/extfun.cmo ../../boot/fstream.cmo $(OTOP)/utils/config.cmo quotation.cmo ast2pt.cmo spretty.cmo reloc.cmo pcaml.cmo argl.cmo
-CAMLP4_XOBJS=../lib/stdpp.cmx ../lib/token.cmx ../lib/plexer.cmx ../lib/gramext.cmx ../lib/grammar.cmx ../lib/extfold.cmx ../lib/extfun.cmx ../lib/fstream.cmx $(OTOP)/utils/config.cmx quotation.cmx ast2pt.cmx spretty.cmx reloc.cmx pcaml.cmx argl.cmx
-OBJS=../odyl/odyl.cma camlp4.cma
-CAMLP4M=
-
-CAMLP4=camlp4$(EXE)
-CAMLP4OPT=phony
-
-all: $(CAMLP4)
-opt: $(OBJS:.cma=.cmxa)
-optp4: $(CAMLP4OPT)
-
-$(CAMLP4): $(OBJS) ../odyl/odyl.cmo
- $(OCAMLC) $(OBJS) $(CAMLP4M) ../odyl/odyl.cmo -linkall -o $(CAMLP4)
-
-$(CAMLP4OPT): $(OBJS:.cma=.cmxa) ../odyl/odyl.cmx
- $(OCAMLOPT) $(OBJS:.cma=.cmxa) $(CAMLP4M) ../odyl/odyl.cmx -linkall -o $(CAMLP4OPT)
-
-$(OTOP)/utils/config.cmx: $(OTOP)/utils/config.ml
- $(OCAMLOPT) -c $(OTOP)/utils/config.ml
-
-camlp4.cma: $(CAMLP4_OBJS)
- $(OCAMLC) $(LINKFLAGS) $(CAMLP4_OBJS) -a -o camlp4.cma
-
-camlp4.cmxa: $(CAMLP4_XOBJS)
- $(OCAMLOPT) $(LINKFLAGS) $(CAMLP4_XOBJS) -a -o camlp4.cmxa
-
-clean::
- rm -f *.cm* *.pp[io] *.$(O) *.$(A) *.bak .*.bak *.out *.opt
- rm -f $(CAMLP4)
-
-depend:
- cp .depend .depend.bak
- > .depend
- @for i in *.mli *.ml; do \
- ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \
- sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \
- done
-
-promote:
- cp $(CAMLP4) ../../boot/.
-
-compare:
- @for j in $(CAMLP4); do \
- if cmp $$j ../../boot/$$j; then :; else exit 1; fi; \
- done
-
-install:
- -$(MKDIR) "$(BINDIR)"
- -$(MKDIR) "$(LIBDIR)/camlp4"
- cp $(CAMLP4) "$(BINDIR)/."
- cp mLast.mli quotation.mli ast2pt.mli pcaml.mli spretty.mli "$(LIBDIR)/camlp4/."
- cp mLast.cmi quotation.cmi ast2pt.cmi pcaml.cmi spretty.cmi "$(LIBDIR)/camlp4/."
- cp camlp4.cma $(LIBDIR)/camlp4/.
- if [ -f camlp4.cmxa ]; \
- then cp camlp4.cmxa camlp4.$(A) $(LIBDIR)/camlp4/.; \
- else : ; \
- fi
-
-include .depend
diff --git a/camlp4/ocaml_src/camlp4/Makefile.Mac b/camlp4/ocaml_src/camlp4/Makefile.Mac
deleted file mode 100644
index b7561d8cb5..0000000000
--- a/camlp4/ocaml_src/camlp4/Makefile.Mac
+++ /dev/null
@@ -1,69 +0,0 @@
-#######################################################################
-# #
-# Camlp4 #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. Distributed only by permission. #
-# #
-#######################################################################
-
-# This file has been generated by program: do not edit!
-
-INCLUDES = -I ::odyl: -I :::boot: -I "{OTOP}utils:" -I "{OTOP}parsing:" ¶
- -I "{OTOP}otherlibs:dynlink:"
-OCAMLCFLAGS = {INCLUDES}
-LINKFLAGS = {INCLUDES}
-INTERFACES = -I "{OLIBDIR}" Arg Array ArrayLabels Buffer Callback CamlinternalOO Char Complex Digest Filename Format Gc Genlex Hashtbl Int32 Int64 Lazy Lexing List ListLabels Map Marshal MoreLabels Nativeint Obj Oo Parsing Pervasives Printexc Printf Queue Random Scanf Set Sort Stack StdLabels Stream String StringLabels Sys Weak ¶
- -I :::boot: Extfold Extfun Fstream ¶
- Gramext Grammar Plexer ¶
- Stdpp Token -I "{OTOP}utils:" Config Warnings ¶
- -I "{OTOP}parsing:" Asttypes Location Longident Parsetree ¶
- -I : Ast2pt MLast Pcaml Quotation Spretty
-CAMLP4_INTF = "{OTOP}utils:config.cmi" "{OTOP}utils:warnings.cmi" ¶
- "{OTOP}parsing:asttypes.cmi" "{OTOP}parsing:location.cmi" ¶
- "{OTOP}parsing:longident.cmi" "{OTOP}parsing:parsetree.cmi" ¶
- ast2pt.cmo mLast.cmi pcaml.cmi spretty.cmi ¶
- quotation.cmi
-CAMLP4_OBJS = :::boot:stdpp.cmo :::boot:token.cmo :::boot:plexer.cmo ¶
- :::boot:gramext.cmo :::boot:grammar.cmo :::boot:extfold.cmo :::boot:extfun.cmo ¶
- :::boot:fstream.cmo "{OTOP}utils:config.cmo" ¶
- quotation.cmo ast2pt.cmo spretty.cmo reloc.cmo pcaml.cmo ¶
- argl.cmo crc.cmo
-OBJS = ::odyl:odyl.cma camlp4.cma
-XOBJS = camlp4.cmxa
-CAMLP4M =
-
-CAMLP4 = camlp4
-
-all Ä {CAMLP4}
-
-{CAMLP4} Ä {OBJS} ::odyl:odyl.cmo
- {OCAMLC} {OBJS} {CAMLP4M} ::odyl:odyl.cmo -linkall -o {CAMLP4}
-
-camlp4.cma Ä {CAMLP4_OBJS}
- {OCAMLC} {LINKFLAGS} {CAMLP4_OBJS} -a -o camlp4.cma
-
-clean ÄÄ
- delete -i {CAMLP4}
-
-{dependrule}
-
-promote Ä
- duplicate -y {CAMLP4} :::boot:
-
-compare Ä
- for i in {CAMLP4}
- equal -s {i} :::boot:{i} || exit 1
- end
-
-install Ä
- (newfolder "{BINDIR}" || set status 0) ³ dev:null
- duplicate -y {CAMLP4} "{BINDIR}"
- duplicate -y mLast.mli quotation.mli pcaml.mli spretty.mli "{P4LIBDIR}"
- duplicate -y mLast.cmi quotation.cmi ast2pt.cmi pcaml.cmi spretty.cmi ¶
- "{P4LIBDIR}"
- duplicate -y camlp4.cma "{P4LIBDIR}"
-
-{defrules}
diff --git a/camlp4/ocaml_src/camlp4/Makefile.Mac.depend b/camlp4/ocaml_src/camlp4/Makefile.Mac.depend
deleted file mode 100644
index 3665195f77..0000000000
--- a/camlp4/ocaml_src/camlp4/Makefile.Mac.depend
+++ /dev/null
@@ -1,15 +0,0 @@
-pcaml.cmiÄ mLast.cmi spretty.cmi
-quotation.cmiÄ mLast.cmi
-reloc.cmiÄ mLast.cmi
-argl.cmoÄ ast2pt.cmo mLast.cmi pcaml.cmi
-argl.cmxÄ ast2pt.cmx mLast.cmi pcaml.cmx
-ast2pt.cmoÄ mLast.cmi
-ast2pt.cmxÄ mLast.cmi
-pcaml.cmoÄ ast2pt.cmo mLast.cmi quotation.cmi reloc.cmi spretty.cmi pcaml.cmi
-pcaml.cmxÄ ast2pt.cmx mLast.cmi quotation.cmx reloc.cmx spretty.cmx pcaml.cmi
-quotation.cmoÄ mLast.cmi quotation.cmi
-quotation.cmxÄ mLast.cmi quotation.cmi
-reloc.cmoÄ mLast.cmi reloc.cmi
-reloc.cmxÄ mLast.cmi reloc.cmi
-spretty.cmoÄ spretty.cmi
-spretty.cmxÄ spretty.cmi
diff --git a/camlp4/ocaml_src/camlp4/argl.ml b/camlp4/ocaml_src/camlp4/argl.ml
deleted file mode 100644
index 0f6ac98ced..0000000000
--- a/camlp4/ocaml_src/camlp4/argl.ml
+++ /dev/null
@@ -1,406 +0,0 @@
-(* camlp4r q_MLast.cmo *)
-(* This file has been generated by program: do not edit! *)
-
-open Printf;;
-
-let rec action_arg s sl =
- function
- Arg.Unit f -> if s = "" then begin f (); Some sl end else None
- | Arg.Bool f ->
- if s = "" then
- match sl with
- s :: sl ->
- begin try f (bool_of_string s); Some sl with
- Invalid_argument "bool_of_string" -> None
- end
- | [] -> None
- else
- begin try f (bool_of_string s); Some sl with
- Invalid_argument "bool_of_string" -> None
- end
- | Arg.Set r -> if s = "" then begin r := true; Some sl end else None
- | Arg.Clear r -> if s = "" then begin r := false; Some sl end else None
- | Arg.Rest f -> List.iter f (s :: sl); Some []
- | Arg.String f ->
- if s = "" then
- match sl with
- s :: sl -> f s; Some sl
- | [] -> None
- else begin f s; Some sl end
- | Arg.Set_string r ->
- if s = "" then
- match sl with
- s :: sl -> r := s; Some sl
- | [] -> None
- else begin r := s; Some sl end
- | Arg.Int f ->
- if s = "" then
- match sl with
- s :: sl ->
- begin try f (int_of_string s); Some sl with
- Failure "int_of_string" -> None
- end
- | [] -> None
- else
- begin try f (int_of_string s); Some sl with
- Failure "int_of_string" -> None
- end
- | Arg.Set_int r ->
- if s = "" then
- match sl with
- s :: sl ->
- begin try r := int_of_string s; Some sl with
- Failure "int_of_string" -> None
- end
- | [] -> None
- else
- begin try r := int_of_string s; Some sl with
- Failure "int_of_string" -> None
- end
- | Arg.Float f ->
- if s = "" then
- match sl with
- s :: sl -> f (float_of_string s); Some sl
- | [] -> None
- else begin f (float_of_string s); Some sl end
- | Arg.Set_float r ->
- if s = "" then
- match sl with
- s :: sl -> r := float_of_string s; Some sl
- | [] -> None
- else begin r := float_of_string s; Some sl end
- | Arg.Tuple specs ->
- let rec action_args s sl =
- function
- [] -> Some sl
- | spec :: spec_list ->
- match action_arg s sl spec with
- None -> action_args "" [] spec_list
- | Some (s :: sl) -> action_args s sl spec_list
- | Some sl -> action_args "" sl spec_list
- in
- action_args s sl specs
- | Arg.Symbol (syms, f) ->
- match if s = "" then sl else s :: sl with
- s :: sl when List.mem s syms -> f s; Some sl
- | _ -> None
-;;
-
-let common_start s1 s2 =
- let rec loop i =
- if i == String.length s1 || i == String.length s2 then i
- else if s1.[i] == s2.[i] then loop (i + 1)
- else i
- in
- loop 0
-;;
-
-let rec parse_arg s sl =
- function
- (name, action, _) :: spec_list ->
- let i = common_start s name in
- if i == String.length name then
- try action_arg (String.sub s i (String.length s - i)) sl action with
- Arg.Bad _ -> parse_arg s sl spec_list
- else parse_arg s sl spec_list
- | [] -> None
-;;
-
-let rec parse_aux spec_list anon_fun =
- function
- [] -> []
- | s :: sl ->
- if String.length s > 1 && s.[0] = '-' then
- match parse_arg s sl spec_list with
- Some sl -> parse_aux spec_list anon_fun sl
- | None -> s :: parse_aux spec_list anon_fun sl
- else begin (anon_fun s : unit); parse_aux spec_list anon_fun sl end
-;;
-
-let loc_fmt =
- match Sys.os_type with
- "MacOS" ->
- format_of_string "File \"%s\"; line %d; characters %d to %d\n### "
- | _ -> format_of_string "File \"%s\", line %d, characters %d-%d:\n"
-;;
-
-let print_location loc =
- if !(Pcaml.input_file) <> "-" then
- let (fname, line, bp, ep) = Stdpp.line_of_loc !(Pcaml.input_file) loc in
- eprintf loc_fmt !(Pcaml.input_file) line bp ep
- else eprintf "At location %d-%d\n" (fst loc) (snd loc)
-;;
-
-let print_warning loc s = print_location loc; eprintf "%s\n" s;;
-
-let rec parse_file pa getdir useast =
- let name = !(Pcaml.input_file) in
- Pcaml.warning := print_warning;
- let ic = if name = "-" then stdin else open_in_bin name in
- let cs = Stream.of_channel ic in
- let clear () = if name = "-" then () else close_in ic in
- let phr =
- try
- let rec loop () =
- let (pl, stopped_at_directive) = pa cs in
- if stopped_at_directive then
- let pl =
- let rpl = List.rev pl in
- match getdir rpl with
- Some x ->
- begin match x with
- loc, "load", Some (MLast.ExStr (_, s)) ->
- Odyl_main.loadfile s; pl
- | loc, "directory", Some (MLast.ExStr (_, s)) ->
- Odyl_main.directory s; pl
- | loc, "use", Some (MLast.ExStr (_, s)) ->
- List.rev_append rpl
- [useast loc s (use_file pa getdir useast s), loc]
- | loc, _, _ ->
- Stdpp.raise_with_loc loc (Stream.Error "bad directive")
- end
- | None -> pl
- in
- pl @ loop ()
- else pl
- in
- loop ()
- with
- x -> clear (); raise x
- in
- clear (); phr
-and use_file pa getdir useast s =
- let clear =
- let v_input_file = !(Pcaml.input_file) in
- fun () -> Pcaml.input_file := v_input_file
- in
- Pcaml.input_file := s;
- try let r = parse_file pa getdir useast in clear (); r with
- e -> clear (); raise e
-;;
-
-let process pa pr getdir useast = pr (parse_file pa getdir useast);;
-
-
-let gind =
- function
- (MLast.SgDir (loc, n, dp), _) :: _ -> Some (loc, n, dp)
- | _ -> None
-;;
-
-let gimd =
- function
- (MLast.StDir (loc, n, dp), _) :: _ -> Some (loc, n, dp)
- | _ -> None
-;;
-
-let usesig loc fname ast = MLast.SgUse (loc, fname, ast);;
-let usestr loc fname ast = MLast.StUse (loc, fname, ast);;
-
-let process_intf () =
- process !(Pcaml.parse_interf) !(Pcaml.print_interf) gind usesig
-;;
-let process_impl () =
- process !(Pcaml.parse_implem) !(Pcaml.print_implem) gimd usestr
-;;
-
-type file_kind =
- Intf
- | Impl
-;;
-let file_kind = ref Intf;;
-let file_kind_of_name name =
- if Filename.check_suffix name ".mli" then Intf
- else if Filename.check_suffix name ".ml" then Impl
- else raise (Arg.Bad ("don't know what to do with " ^ name))
-;;
-
-let print_version () =
- eprintf "Camlp4 version %s\n" Pcaml.version; flush stderr; exit 0
-;;
-
-let align_doc key s =
- let s =
- let rec loop i =
- if i = String.length s then ""
- else if s.[i] = ' ' then loop (i + 1)
- else String.sub s i (String.length s - i)
- in
- loop 0
- in
- let (p, s) =
- if String.length s > 0 then
- if s.[0] = '<' then
- let rec loop i =
- if i = String.length s then "", s
- else if s.[i] <> '>' then loop (i + 1)
- else
- let p = String.sub s 0 (i + 1) in
- let rec loop i =
- if i >= String.length s then p, ""
- else if s.[i] = ' ' then loop (i + 1)
- else p, String.sub s i (String.length s - i)
- in
- loop (i + 1)
- in
- loop 0
- else "", s
- else "", ""
- in
- let tab =
- String.make (max 1 (13 - String.length key - String.length p)) ' '
- in
- p ^ tab ^ s
-;;
-
-let make_symlist l =
- match l with
- [] -> "<none>"
- | h :: t -> List.fold_left (fun x y -> x ^ "|" ^ y) ("{" ^ h) t ^ "}"
-;;
-
-let print_usage_list l =
- List.iter
- (fun (key, spec, doc) ->
- match spec with
- Arg.Symbol (symbs, _) ->
- let s = make_symlist symbs in
- let synt = key ^ " " ^ s in
- eprintf " %s %s\n" synt (align_doc synt doc)
- | _ -> eprintf " %s %s\n" key (align_doc key doc))
- l
-;;
-
-let make_symlist l =
- match l with
- [] -> "<none>"
- | h :: t -> List.fold_left (fun x y -> x ^ "|" ^ y) ("{" ^ h) t ^ "}"
-;;
-
-let print_usage_list l =
- List.iter
- (fun (key, spec, doc) ->
- match spec with
- Arg.Symbol (symbs, _) ->
- let s = make_symlist symbs in
- let synt = key ^ " " ^ s in
- eprintf " %s %s\n" synt (align_doc synt doc)
- | _ -> eprintf " %s %s\n" key (align_doc key doc))
- l
-;;
-
-let usage ini_sl ext_sl =
- eprintf "\
-Usage: camlp4 [load-options] [--] [other-options]
-Load options:
- -I directory Add directory in search patch for object files.
- -where Print camlp4 library directory and exit.
- -nolib No automatic search for object files in library directory.
- <object-file> Load this file in Camlp4 core.
-Other options:
- <file> Parse this file.\n";
- print_usage_list ini_sl;
- begin
- let rec loop =
- function
- (y, _, _) :: _ when y = "-help" -> ()
- | _ :: sl -> loop sl
- | [] -> eprintf " -help Display this list of options.\n"
- in
- loop (ini_sl @ ext_sl)
- end;
- if ext_sl <> [] then
- begin
- eprintf "Options added by loaded object files:\n";
- print_usage_list ext_sl
- end
-;;
-
-let warn_noassert () =
- eprintf "\
-camlp4 warning: option -noassert is obsolete
-You should give the -noassert option to the ocaml compiler instead.
-"
-;;
-
-let initial_spec_list =
- ["-intf", Arg.String (fun x -> file_kind := Intf; Pcaml.input_file := x),
- "<file> Parse <file> as an interface, whatever its extension.";
- "-impl", Arg.String (fun x -> file_kind := Impl; Pcaml.input_file := x),
- "<file> Parse <file> as an implementation, whatever its extension.";
- "-unsafe", Arg.Set Ast2pt.fast,
- "Generate unsafe accesses to array and strings.";
- "-noassert", Arg.Unit warn_noassert, "Obsolete, do not use this option.";
- "-verbose", Arg.Set Grammar.error_verbose,
- "More verbose in parsing errors.";
- "-loc", Arg.String (fun x -> Stdpp.loc_name := x),
- "<name> Name of the location variable (default: " ^ !(Stdpp.loc_name) ^
- ")";
- "-QD", Arg.String (fun x -> Pcaml.quotation_dump_file := Some x),
- "<file> Dump quotation expander result in case of syntax error.";
- "-o", Arg.String (fun x -> Pcaml.output_file := Some x),
- "<file> Output on <file> instead of standard output.";
- "-v", Arg.Unit print_version, "Print Camlp4 version and exit."]
-;;
-
-let anon_fun x = Pcaml.input_file := x; file_kind := file_kind_of_name x;;
-
-let parse spec_list anon_fun remaining_args =
- let spec_list =
- Sort.list (fun (k1, _, _) (k2, _, _) -> k1 >= k2) spec_list
- in
- try parse_aux spec_list anon_fun remaining_args with
- Arg.Bad s ->
- eprintf "Error: %s\n" s;
- eprintf "Use option -help for usage\n";
- flush stderr;
- exit 2
-;;
-
-let remaining_args =
- let rec loop l i =
- if i == Array.length Sys.argv then l else loop (Sys.argv.(i) :: l) (i + 1)
- in
- List.rev (loop [] (!(Arg.current) + 1))
-;;
-
-let report_error =
- function
- Odyl_main.Error (fname, msg) ->
- Format.print_string "Error while loading \"";
- Format.print_string fname;
- Format.print_string "\": ";
- Format.print_string msg
- | exc -> Pcaml.report_error exc
-;;
-
-let go () =
- let ext_spec_list = Pcaml.arg_spec_list () in
- let arg_spec_list = initial_spec_list @ ext_spec_list in
- begin match parse arg_spec_list anon_fun remaining_args with
- [] -> ()
- | "-help" :: sl -> usage initial_spec_list ext_spec_list; exit 0
- | s :: sl ->
- eprintf "%s: unknown or misused option\n" s;
- eprintf "Use option -help for usage\n";
- exit 2
- end;
- try
- if !(Pcaml.input_file) <> "" then
- match !file_kind with
- Intf -> process_intf ()
- | Impl -> process_impl ()
- with
- exc ->
- Format.set_formatter_out_channel stderr;
- Format.open_vbox 0;
- let exc =
- match exc with
- Stdpp.Exc_located ((bp, ep), exc) -> print_location (bp, ep); exc
- | _ -> exc
- in
- report_error exc; Format.close_box (); Format.print_newline (); exit 2
-;;
-
-Odyl_main.name := "camlp4";;
-Odyl_main.go := go;;
diff --git a/camlp4/ocaml_src/camlp4/ast2pt.ml b/camlp4/ocaml_src/camlp4/ast2pt.ml
deleted file mode 100644
index b243109b73..0000000000
--- a/camlp4/ocaml_src/camlp4/ast2pt.ml
+++ /dev/null
@@ -1,880 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-open Stdpp;;
-open MLast;;
-open Parsetree;;
-open Longident;;
-open Asttypes;;
-
-let fast = ref false;;
-let no_constructors_arity = ref false;;
-
-let get_tag x =
- if Obj.is_block (Obj.repr x) then Obj.tag (Obj.repr x) else Obj.magic x
-;;
-
-let error loc str = raise_with_loc loc (Failure str);;
-
-let char_of_char_token loc s =
- try Token.eval_char s with
- Failure _ as exn -> raise_with_loc loc exn
-;;
-
-let string_of_string_token loc s =
- try Token.eval_string loc s with
- Failure _ as exn -> raise_with_loc loc exn
-;;
-
-let glob_fname = ref "";;
-
-let mkloc (bp, ep) =
- let loc_at n =
- {Lexing.pos_fname = !glob_fname; Lexing.pos_lnum = 1; Lexing.pos_bol = 0;
- Lexing.pos_cnum = n}
- in
- {Location.loc_start = loc_at bp; Location.loc_end = loc_at ep;
- Location.loc_ghost = false}
-;;
-
-let mkghloc (bp, ep) =
- let loc_at n =
- {Lexing.pos_fname = ""; Lexing.pos_lnum = 1; Lexing.pos_bol = 0;
- Lexing.pos_cnum = n}
- in
- {Location.loc_start = loc_at bp; Location.loc_end = loc_at ep;
- Location.loc_ghost = true}
-;;
-
-let mktyp loc d = {ptyp_desc = d; ptyp_loc = mkloc loc};;
-let mkpat loc d = {ppat_desc = d; ppat_loc = mkloc loc};;
-let mkghpat loc d = {ppat_desc = d; ppat_loc = mkghloc loc};;
-let mkexp loc d = {pexp_desc = d; pexp_loc = mkloc loc};;
-let mkmty loc d = {pmty_desc = d; pmty_loc = mkloc loc};;
-let mksig loc d = {psig_desc = d; psig_loc = mkloc loc};;
-let mkmod loc d = {pmod_desc = d; pmod_loc = mkloc loc};;
-let mkstr loc d = {pstr_desc = d; pstr_loc = mkloc loc};;
-let mkfield loc d = {pfield_desc = d; pfield_loc = mkloc loc};;
-let mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc};;
-let mkpcl loc d = {pcl_desc = d; pcl_loc = mkloc loc};;
-let mkpolytype t =
- match t with
- TyPol (_, _, _) -> t
- | _ -> TyPol (MLast.loc_of_ctyp t, [], t)
-;;
-
-let lident s = Lident s;;
-let ldot l s = Ldot (l, s);;
-
-let conv_con =
- let t = Hashtbl.create 73 in
- List.iter (fun (s, s') -> Hashtbl.add t s s')
- ["True", "true"; "False", "false"; " True", "True"; " False", "False"];
- fun s ->
- try Hashtbl.find t s with
- Not_found -> s
-;;
-
-let conv_lab =
- let t = Hashtbl.create 73 in
- List.iter (fun (s, s') -> Hashtbl.add t s s') ["val", "contents"];
- fun s ->
- try Hashtbl.find t s with
- Not_found -> s
-;;
-
-let array_function str name =
- ldot (lident str) (if !fast then "unsafe_" ^ name else name)
-;;
-
-let mkrf =
- function
- true -> Recursive
- | false -> Nonrecursive
-;;
-
-let mkli s =
- let rec loop f =
- function
- i :: il -> loop (fun s -> ldot (f i) s) il
- | [] -> f s
- in
- loop (fun s -> lident s)
-;;
-
-let long_id_of_string_list loc sl =
- match List.rev sl with
- [] -> error loc "bad ast"
- | s :: sl -> mkli s (List.rev sl)
-;;
-
-let rec ctyp_fa al =
- function
- TyApp (_, f, a) -> ctyp_fa (a :: al) f
- | f -> f, al
-;;
-
-let rec ctyp_long_id =
- function
- TyAcc (_, m, TyLid (_, s)) ->
- let (is_cls, li) = ctyp_long_id m in is_cls, ldot li s
- | TyAcc (_, m, TyUid (_, s)) ->
- let (is_cls, li) = ctyp_long_id m in is_cls, ldot li s
- | TyApp (_, m1, m2) ->
- let (is_cls, li1) = ctyp_long_id m1 in
- let (_, li2) = ctyp_long_id m2 in is_cls, Lapply (li1, li2)
- | TyUid (_, s) -> false, lident s
- | TyLid (_, s) -> false, lident s
- | TyCls (loc, sl) -> true, long_id_of_string_list loc sl
- | t -> error (loc_of_ctyp t) "incorrect type"
-;;
-
-let rec ctyp =
- function
- TyAcc (loc, _, _) as f ->
- let (is_cls, li) = ctyp_long_id f in
- if is_cls then mktyp loc (Ptyp_class (li, [], []))
- else mktyp loc (Ptyp_constr (li, []))
- | TyAli (loc, t1, t2) ->
- let (t, i) =
- match t1, t2 with
- t, TyQuo (_, s) -> t, s
- | TyQuo (_, s), t -> t, s
- | _ -> error loc "incorrect alias type"
- in
- mktyp loc (Ptyp_alias (ctyp t, i))
- | TyAny loc -> mktyp loc Ptyp_any
- | TyApp (loc, _, _) as f ->
- let (f, al) = ctyp_fa [] f in
- let (is_cls, li) = ctyp_long_id f in
- if is_cls then mktyp loc (Ptyp_class (li, List.map ctyp al, []))
- else mktyp loc (Ptyp_constr (li, List.map ctyp al))
- | TyArr (loc, TyLab (loc1, lab, t1), t2) ->
- mktyp loc (Ptyp_arrow (lab, ctyp t1, ctyp t2))
- | TyArr (loc, TyOlb (loc1, lab, t1), t2) ->
- let t1 = TyApp (loc1, TyLid (loc1, "option"), t1) in
- mktyp loc (Ptyp_arrow (("?" ^ lab), ctyp t1, ctyp t2))
- | TyArr (loc, t1, t2) -> mktyp loc (Ptyp_arrow ("", ctyp t1, ctyp t2))
- | TyObj (loc, fl, v) -> mktyp loc (Ptyp_object (meth_list loc fl v))
- | TyCls (loc, id) ->
- mktyp loc (Ptyp_class (long_id_of_string_list loc id, [], []))
- | TyLab (loc, _, _) -> error loc "labelled type not allowed here"
- | TyLid (loc, s) -> mktyp loc (Ptyp_constr (lident s, []))
- | TyMan (loc, _, _) -> error loc "manifest type not allowed here"
- | TyOlb (loc, lab, _) -> error loc "labelled type not allowed here"
- | TyPol (loc, pl, t) -> mktyp loc (Ptyp_poly (pl, ctyp t))
- | TyQuo (loc, s) -> mktyp loc (Ptyp_var s)
- | TyRec (loc, _, _) -> error loc "record type not allowed here"
- | TySum (loc, _, _) -> error loc "sum type not allowed here"
- | TyTup (loc, tl) -> mktyp loc (Ptyp_tuple (List.map ctyp tl))
- | TyUid (loc, s) -> mktyp loc (Ptyp_constr (lident s, []))
- | TyVrn (loc, catl, ool) ->
- let catl =
- List.map
- (function
- RfTag (c, a, t) -> Rtag (c, a, List.map ctyp t)
- | RfInh t -> Rinherit (ctyp t))
- catl
- in
- let (clos, sl) =
- match ool with
- None -> true, None
- | Some None -> false, None
- | Some (Some sl) -> true, Some sl
- in
- mktyp loc (Ptyp_variant (catl, clos, sl))
-and meth_list loc fl v =
- match fl with
- [] -> if v then [mkfield loc Pfield_var] else []
- | (lab, t) :: fl ->
- mkfield loc (Pfield (lab, ctyp (mkpolytype t))) :: meth_list loc fl v
-;;
-
-let mktype loc tl cl tk tm =
- let (params, variance) = List.split tl in
- {ptype_params = params; ptype_cstrs = cl; ptype_kind = tk;
- ptype_manifest = tm; ptype_loc = mkloc loc; ptype_variance = variance}
-;;
-let mkmutable m = if m then Mutable else Immutable;;
-let mkprivate m = if m then Private else Public;;
-let mktrecord (_, n, m, t) = n, mkmutable m, ctyp (mkpolytype t);;
-let mkvariant (_, c, tl) = c, List.map ctyp tl;;
-let type_decl tl cl =
- function
- TyMan (loc, t, TyRec (_, pflag, ltl)) ->
- mktype loc tl cl
- (Ptype_record (List.map mktrecord ltl, mkprivate pflag))
- (Some (ctyp t))
- | TyMan (loc, t, TySum (_, pflag, ctl)) ->
- mktype loc tl cl
- (Ptype_variant (List.map mkvariant ctl, mkprivate pflag))
- (Some (ctyp t))
- | TyRec (loc, pflag, ltl) ->
- mktype loc tl cl
- (Ptype_record (List.map mktrecord ltl, mkprivate pflag)) None
- | TySum (loc, pflag, ctl) ->
- mktype loc tl cl
- (Ptype_variant (List.map mkvariant ctl, mkprivate pflag)) None
- | t ->
- let m =
- match t with
- TyQuo (_, s) -> if List.mem_assoc s tl then Some (ctyp t) else None
- | _ -> Some (ctyp t)
- in
- mktype (loc_of_ctyp t) tl cl Ptype_abstract m
-;;
-
-let mkvalue_desc t p = {pval_type = ctyp t; pval_prim = p};;
-
-let option f =
- function
- Some x -> Some (f x)
- | None -> None
-;;
-
-let expr_of_lab loc lab =
- function
- Some e -> e
- | None -> ExLid (loc, lab)
-;;
-
-let patt_of_lab loc lab =
- function
- Some p -> p
- | None -> PaLid (loc, lab)
-;;
-
-let paolab loc lab peoo =
- let lab =
- match lab, peoo with
- "", Some ((PaLid (_, i) | PaTyc (_, PaLid (_, i), _)), _) -> i
- | "", _ -> error loc "bad ast"
- | _ -> lab
- in
- let (p, eo) =
- match peoo with
- Some peo -> peo
- | None -> PaLid (loc, lab), None
- in
- lab, p, eo
-;;
-
-let rec same_type_expr ct ce =
- match ct, ce with
- TyLid (_, s1), ExLid (_, s2) -> s1 = s2
- | TyUid (_, s1), ExUid (_, s2) -> s1 = s2
- | TyAcc (_, t1, t2), ExAcc (_, e1, e2) ->
- same_type_expr t1 e1 && same_type_expr t2 e2
- | _ -> false
-;;
-
-let rec common_id loc t e =
- match t, e with
- TyLid (_, s1), ExLid (_, s2) when s1 = s2 -> lident s1
- | TyUid (_, s1), ExUid (_, s2) when s1 = s2 -> lident s1
- | TyAcc (_, t1, TyLid (_, s1)), ExAcc (_, e1, ExLid (_, s2)) when s1 = s2 ->
- ldot (common_id loc t1 e1) s1
- | TyAcc (_, t1, TyUid (_, s1)), ExAcc (_, e1, ExUid (_, s2)) when s1 = s2 ->
- ldot (common_id loc t1 e1) s1
- | _ -> error loc "this expression should repeat the class id inherited"
-;;
-
-let rec type_id loc t =
- match t with
- TyLid (_, s1) -> lident s1
- | TyUid (_, s1) -> lident s1
- | TyAcc (_, t1, TyLid (_, s1)) -> ldot (type_id loc t1) s1
- | TyAcc (_, t1, TyUid (_, s1)) -> ldot (type_id loc t1) s1
- | _ -> error loc "type identifier expected"
-;;
-
-let rec module_type_long_id =
- function
- MtAcc (_, m, MtUid (_, s)) -> ldot (module_type_long_id m) s
- | MtAcc (_, m, MtLid (_, s)) -> ldot (module_type_long_id m) s
- | MtApp (_, m1, m2) ->
- Lapply (module_type_long_id m1, module_type_long_id m2)
- | MtLid (_, s) -> lident s
- | MtUid (_, s) -> lident s
- | t -> error (loc_of_module_type t) "bad module type long ident"
-;;
-
-let rec module_expr_long_id =
- function
- MeAcc (_, m, MeUid (_, s)) -> ldot (module_expr_long_id m) s
- | MeUid (_, s) -> lident s
- | t -> error (loc_of_module_expr t) "bad module expr long ident"
-;;
-
-let mkwithc =
- function
- WcTyp (loc, id, tpl, ct) ->
- let (params, variance) = List.split tpl in
- long_id_of_string_list loc id,
- Pwith_type
- {ptype_params = params; ptype_cstrs = []; ptype_kind = Ptype_abstract;
- ptype_manifest = Some (ctyp ct); ptype_loc = mkloc loc;
- ptype_variance = variance}
- | WcMod (loc, id, m) ->
- long_id_of_string_list loc id, Pwith_module (module_expr_long_id m)
-;;
-
-let rec patt_fa al =
- function
- PaApp (_, f, a) -> patt_fa (a :: al) f
- | f -> f, al
-;;
-
-let rec deep_mkrangepat loc c1 c2 =
- if c1 = c2 then mkghpat loc (Ppat_constant (Const_char c1))
- else
- mkghpat loc
- (Ppat_or
- (mkghpat loc (Ppat_constant (Const_char c1)),
- deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2))
-;;
-
-let rec mkrangepat loc c1 c2 =
- if c1 > c2 then mkrangepat loc c2 c1
- else if c1 = c2 then mkpat loc (Ppat_constant (Const_char c1))
- else
- mkpat loc
- (Ppat_or
- (mkghpat loc (Ppat_constant (Const_char c1)),
- deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2))
-;;
-
-let rec patt_long_id il =
- function
- PaAcc (_, p, PaUid (_, i)) -> patt_long_id (i :: il) p
- | p -> p, il
-;;
-
-let rec patt_label_long_id =
- function
- PaAcc (_, m, PaLid (_, s)) -> ldot (patt_label_long_id m) (conv_lab s)
- | PaAcc (_, m, PaUid (_, s)) -> ldot (patt_label_long_id m) s
- | PaUid (_, s) -> lident s
- | PaLid (_, s) -> lident (conv_lab s)
- | p -> error (loc_of_patt p) "bad label"
-;;
-
-let rec patt =
- function
- PaAcc (loc, p1, p2) ->
- let p =
- match patt_long_id [] p1 with
- PaUid (_, i), il ->
- begin match p2 with
- PaUid (_, s) ->
- Ppat_construct
- (mkli (conv_con s) (i :: il), None,
- not !no_constructors_arity)
- | _ -> error (loc_of_patt p2) "uppercase identifier expected"
- end
- | _ -> error (loc_of_patt p2) "bad pattern"
- in
- mkpat loc p
- | PaAli (loc, p1, p2) ->
- let (p, i) =
- match p1, p2 with
- p, PaLid (_, s) -> p, s
- | PaLid (_, s), p -> p, s
- | _ -> error loc "incorrect alias pattern"
- in
- mkpat loc (Ppat_alias (patt p, i))
- | PaAnt (_, p) -> patt p
- | PaAny loc -> mkpat loc Ppat_any
- | PaApp (loc, _, _) as f ->
- let (f, al) = patt_fa [] f in
- let al = List.map patt al in
- begin match (patt f).ppat_desc with
- Ppat_construct (li, None, _) ->
- if !no_constructors_arity then
- let a =
- match al with
- [a] -> a
- | _ -> mkpat loc (Ppat_tuple al)
- in
- mkpat loc (Ppat_construct (li, Some a, false))
- else
- let a = mkpat loc (Ppat_tuple al) in
- mkpat loc (Ppat_construct (li, Some a, true))
- | Ppat_variant (s, None) ->
- let a =
- match al with
- [a] -> a
- | _ -> mkpat loc (Ppat_tuple al)
- in
- mkpat loc (Ppat_variant (s, Some a))
- | _ ->
- error (loc_of_patt f)
- "this is not a constructor, it cannot be applied in a pattern"
- end
- | PaArr (loc, pl) -> mkpat loc (Ppat_array (List.map patt pl))
- | PaChr (loc, s) ->
- mkpat loc (Ppat_constant (Const_char (char_of_char_token loc s)))
- | PaInt (loc, s) -> mkpat loc (Ppat_constant (Const_int (int_of_string s)))
- | PaInt32 (loc, s) ->
- mkpat loc (Ppat_constant (Const_int32 (Int32.of_string s)))
- | PaInt64 (loc, s) ->
- mkpat loc (Ppat_constant (Const_int64 (Int64.of_string s)))
- | PaNativeInt (loc, s) ->
- mkpat loc (Ppat_constant (Const_nativeint (Nativeint.of_string s)))
- | PaFlo (loc, s) -> mkpat loc (Ppat_constant (Const_float s))
- | PaLab (loc, _, _) -> error loc "labeled pattern not allowed here"
- | PaLid (loc, s) -> mkpat loc (Ppat_var s)
- | PaOlb (loc, _, _) -> error loc "labeled pattern not allowed here"
- | PaOrp (loc, p1, p2) -> mkpat loc (Ppat_or (patt p1, patt p2))
- | PaRng (loc, p1, p2) ->
- begin match p1, p2 with
- PaChr (loc1, c1), PaChr (loc2, c2) ->
- let c1 = char_of_char_token loc1 c1 in
- let c2 = char_of_char_token loc2 c2 in mkrangepat loc c1 c2
- | _ -> error loc "range pattern allowed only for characters"
- end
- | PaRec (loc, lpl) -> mkpat loc (Ppat_record (List.map mklabpat lpl))
- | PaStr (loc, s) ->
- mkpat loc (Ppat_constant (Const_string (string_of_string_token loc s)))
- | PaTup (loc, pl) -> mkpat loc (Ppat_tuple (List.map patt pl))
- | PaTyc (loc, p, t) -> mkpat loc (Ppat_constraint (patt p, ctyp t))
- | PaTyp (loc, sl) -> mkpat loc (Ppat_type (long_id_of_string_list loc sl))
- | PaUid (loc, s) ->
- let ca = not !no_constructors_arity in
- mkpat loc (Ppat_construct (lident (conv_con s), None, ca))
- | PaVrn (loc, s) -> mkpat loc (Ppat_variant (s, None))
-and mklabpat (lab, p) = patt_label_long_id lab, patt p;;
-
-let rec expr_fa al =
- function
- ExApp (_, f, a) -> expr_fa (a :: al) f
- | f -> f, al
-;;
-
-let rec class_expr_fa al =
- function
- CeApp (_, ce, a) -> class_expr_fa (a :: al) ce
- | ce -> ce, al
-;;
-
-let rec sep_expr_acc l =
- function
- ExAcc (_, e1, e2) -> sep_expr_acc (sep_expr_acc l e2) e1
- | ExUid ((bp, _ as loc), s) as e ->
- begin match l with
- [] -> [loc, [], e]
- | ((_, ep), sl, e) :: l -> ((bp, ep), s :: sl, e) :: l
- end
- | e -> (loc_of_expr e, [], e) :: l
-;;
-
-(*
-value expr_label_long_id e =
- match sep_expr_acc [] e with
- [ [(_, ml, ExLid _ s)] -> mkli (conv_lab s) ml
- | _ -> error (loc_of_expr e) "invalid label" ]
-;
-*)
-
-let class_info class_expr ci =
- let (params, variance) = List.split (snd ci.ciPrm) in
- {pci_virt = if ci.ciVir then Virtual else Concrete;
- pci_params = params, mkloc (fst ci.ciPrm); pci_name = ci.ciNam;
- pci_expr = class_expr ci.ciExp; pci_loc = mkloc ci.ciLoc;
- pci_variance = variance}
-;;
-
-let apply_with_var v x f =
- let vx = !v in
- try v := x; let r = f () in v := vx; r with
- e -> v := vx; raise e
-;;
-
-let rec expr =
- function
- ExAcc (loc, x, ExLid (_, "val")) ->
- mkexp loc
- (Pexp_apply (mkexp loc (Pexp_ident (Lident "!")), ["", expr x]))
- | ExAcc (loc, _, _) as e ->
- let (e, l) =
- match sep_expr_acc [] e with
- (loc, ml, ExUid (_, s)) :: l ->
- let ca = not !no_constructors_arity in
- mkexp loc (Pexp_construct (mkli s ml, None, ca)), l
- | (loc, ml, ExLid (_, s)) :: l ->
- mkexp loc (Pexp_ident (mkli s ml)), l
- | (_, [], e) :: l -> expr e, l
- | _ -> error loc "bad ast"
- in
- let (_, e) =
- List.fold_left
- (fun ((bp, _), e1) ((_, ep), ml, e2) ->
- match e2 with
- ExLid (_, s) ->
- let loc = bp, ep in
- loc, mkexp loc (Pexp_field (e1, mkli (conv_lab s) ml))
- | _ -> error (loc_of_expr e2) "lowercase identifier expected")
- (loc, e) l
- in
- e
- | ExAnt (_, e) -> expr e
- | ExApp (loc, _, _) as f ->
- let (f, al) = expr_fa [] f in
- let al = List.map label_expr al in
- begin match (expr f).pexp_desc with
- Pexp_construct (li, None, _) ->
- let al = List.map snd al in
- if !no_constructors_arity then
- let a =
- match al with
- [a] -> a
- | _ -> mkexp loc (Pexp_tuple al)
- in
- mkexp loc (Pexp_construct (li, Some a, false))
- else
- let a = mkexp loc (Pexp_tuple al) in
- mkexp loc (Pexp_construct (li, Some a, true))
- | Pexp_variant (s, None) ->
- let al = List.map snd al in
- let a =
- match al with
- [a] -> a
- | _ -> mkexp loc (Pexp_tuple al)
- in
- mkexp loc (Pexp_variant (s, Some a))
- | _ -> mkexp loc (Pexp_apply (expr f, al))
- end
- | ExAre (loc, e1, e2) ->
- mkexp loc
- (Pexp_apply
- (mkexp loc (Pexp_ident (array_function "Array" "get")),
- ["", expr e1; "", expr e2]))
- | ExArr (loc, el) -> mkexp loc (Pexp_array (List.map expr el))
- | ExAsf loc -> mkexp loc Pexp_assertfalse
- | ExAss (loc, e, v) ->
- let e =
- match e with
- ExAcc (loc, x, ExLid (_, "val")) ->
- Pexp_apply
- (mkexp loc (Pexp_ident (Lident ":=")), ["", expr x; "", expr v])
- | ExAcc (loc, _, _) ->
- begin match (expr e).pexp_desc with
- Pexp_field (e, lab) -> Pexp_setfield (e, lab, expr v)
- | _ -> error loc "bad record access"
- end
- | ExAre (_, e1, e2) ->
- Pexp_apply
- (mkexp loc (Pexp_ident (array_function "Array" "set")),
- ["", expr e1; "", expr e2; "", expr v])
- | ExLid (_, lab) -> Pexp_setinstvar (lab, expr v)
- | ExSte (_, e1, e2) ->
- Pexp_apply
- (mkexp loc (Pexp_ident (array_function "String" "set")),
- ["", expr e1; "", expr e2; "", expr v])
- | _ -> error loc "bad left part of assignment"
- in
- mkexp loc e
- | ExAsr (loc, e) -> mkexp loc (Pexp_assert (expr e))
- | ExChr (loc, s) ->
- mkexp loc (Pexp_constant (Const_char (char_of_char_token loc s)))
- | ExCoe (loc, e, t1, t2) ->
- mkexp loc (Pexp_constraint (expr e, option ctyp t1, Some (ctyp t2)))
- | ExFlo (loc, s) -> mkexp loc (Pexp_constant (Const_float s))
- | ExFor (loc, i, e1, e2, df, el) ->
- let e3 = ExSeq (loc, el) in
- let df = if df then Upto else Downto in
- mkexp loc (Pexp_for (i, expr e1, expr e2, df, expr e3))
- | ExFun (loc, [PaLab (_, lab, po), w, e]) ->
- mkexp loc
- (Pexp_function
- (lab, None, [patt (patt_of_lab loc lab po), when_expr e w]))
- | ExFun (loc, [PaOlb (_, lab, peoo), w, e]) ->
- let (lab, p, eo) = paolab loc lab peoo in
- mkexp loc
- (Pexp_function (("?" ^ lab), option expr eo, [patt p, when_expr e w]))
- | ExFun (loc, pel) ->
- mkexp loc (Pexp_function ("", None, List.map mkpwe pel))
- | ExIfe (loc, e1, e2, e3) ->
- mkexp loc (Pexp_ifthenelse (expr e1, expr e2, Some (expr e3)))
- | ExInt (loc, s) -> mkexp loc (Pexp_constant (Const_int (int_of_string s)))
- | ExInt32 (loc, s) ->
- mkexp loc (Pexp_constant (Const_int32 (Int32.of_string s)))
- | ExInt64 (loc, s) ->
- mkexp loc (Pexp_constant (Const_int64 (Int64.of_string s)))
- | ExNativeInt (loc, s) ->
- mkexp loc (Pexp_constant (Const_nativeint (Nativeint.of_string s)))
- | ExLab (loc, _, _) -> error loc "labeled expression not allowed here"
- | ExLaz (loc, e) -> mkexp loc (Pexp_lazy (expr e))
- | ExLet (loc, rf, pel, e) ->
- mkexp loc (Pexp_let (mkrf rf, List.map mkpe pel, expr e))
- | ExLid (loc, s) -> mkexp loc (Pexp_ident (lident s))
- | ExLmd (loc, i, me, e) ->
- mkexp loc (Pexp_letmodule (i, module_expr me, expr e))
- | ExMat (loc, e, pel) -> mkexp loc (Pexp_match (expr e, List.map mkpwe pel))
- | ExNew (loc, id) -> mkexp loc (Pexp_new (long_id_of_string_list loc id))
- | ExOlb (loc, _, _) -> error loc "labeled expression not allowed here"
- | ExOvr (loc, iel) -> mkexp loc (Pexp_override (List.map mkideexp iel))
- | ExRec (loc, lel, eo) ->
- if lel = [] then error loc "empty record"
- else
- let eo =
- match eo with
- Some e -> Some (expr e)
- | None -> None
- in
- mkexp loc (Pexp_record (List.map mklabexp lel, eo))
- | ExSeq (loc, el) ->
- let rec loop =
- function
- [] -> expr (ExUid (loc, "()"))
- | [e] -> expr e
- | e :: el ->
- let loc = fst (loc_of_expr e), snd loc in
- mkexp loc (Pexp_sequence (expr e, loop el))
- in
- loop el
- | ExSnd (loc, e, s) -> mkexp loc (Pexp_send (expr e, s))
- | ExSte (loc, e1, e2) ->
- mkexp loc
- (Pexp_apply
- (mkexp loc (Pexp_ident (array_function "String" "get")),
- ["", expr e1; "", expr e2]))
- | ExStr (loc, s) ->
- mkexp loc (Pexp_constant (Const_string (string_of_string_token loc s)))
- | ExTry (loc, e, pel) -> mkexp loc (Pexp_try (expr e, List.map mkpwe pel))
- | ExTup (loc, el) -> mkexp loc (Pexp_tuple (List.map expr el))
- | ExTyc (loc, e, t) ->
- mkexp loc (Pexp_constraint (expr e, Some (ctyp t), None))
- | ExUid (loc, s) ->
- let ca = not !no_constructors_arity in
- mkexp loc (Pexp_construct (lident (conv_con s), None, ca))
- | ExVrn (loc, s) -> mkexp loc (Pexp_variant (s, None))
- | ExWhi (loc, e1, el) ->
- let e2 = ExSeq (loc, el) in mkexp loc (Pexp_while (expr e1, expr e2))
-and label_expr =
- function
- ExLab (loc, lab, eo) -> lab, expr (expr_of_lab loc lab eo)
- | ExOlb (loc, lab, eo) -> "?" ^ lab, expr (expr_of_lab loc lab eo)
- | e -> "", expr e
-and mkpe (p, e) = patt p, expr e
-and mkpwe (p, w, e) = patt p, when_expr e w
-and when_expr e =
- function
- Some w -> mkexp (loc_of_expr e) (Pexp_when (expr w, expr e))
- | None -> expr e
-and mklabexp (lab, e) = patt_label_long_id lab, expr e
-and mkideexp (ide, e) = ide, expr e
-and mktype_decl ((loc, c), tl, td, cl) =
- let cl =
- List.map
- (fun (t1, t2) ->
- let loc = fst (loc_of_ctyp t1), snd (loc_of_ctyp t2) in
- ctyp t1, ctyp t2, mkloc loc)
- cl
- in
- c, type_decl tl cl td
-and module_type =
- function
- MtAcc (loc, _, _) as f -> mkmty loc (Pmty_ident (module_type_long_id f))
- | MtApp (loc, _, _) as f -> mkmty loc (Pmty_ident (module_type_long_id f))
- | MtFun (loc, n, nt, mt) ->
- mkmty loc (Pmty_functor (n, module_type nt, module_type mt))
- | MtLid (loc, s) -> mkmty loc (Pmty_ident (lident s))
- | MtQuo (loc, _) -> error loc "abstract module type not allowed here"
- | MtSig (loc, sl) ->
- mkmty loc (Pmty_signature (List.fold_right sig_item sl []))
- | MtUid (loc, s) -> mkmty loc (Pmty_ident (lident s))
- | MtWit (loc, mt, wcl) ->
- mkmty loc (Pmty_with (module_type mt, List.map mkwithc wcl))
-and sig_item s l =
- match s with
- SgCls (loc, cd) ->
- mksig loc (Psig_class (List.map (class_info class_type) cd)) :: l
- | SgClt (loc, ctd) ->
- mksig loc (Psig_class_type (List.map (class_info class_type) ctd)) :: l
- | SgDcl (loc, sl) -> List.fold_right sig_item sl l
- | SgDir (loc, _, _) -> l
- | SgExc (loc, n, tl) ->
- mksig loc (Psig_exception (n, List.map ctyp tl)) :: l
- | SgExt (loc, n, t, p) -> mksig loc (Psig_value (n, mkvalue_desc t p)) :: l
- | SgInc (loc, mt) -> mksig loc (Psig_include (module_type mt)) :: l
- | SgMod (loc, n, mt) -> mksig loc (Psig_module (n, module_type mt)) :: l
- | SgRecMod (loc, nmts) ->
- mksig loc
- (Psig_recmodule (List.map (fun (n, mt) -> n, module_type mt) nmts)) ::
- l
- | SgMty (loc, n, mt) ->
- let si =
- match mt with
- MtQuo (_, _) -> Pmodtype_abstract
- | _ -> Pmodtype_manifest (module_type mt)
- in
- mksig loc (Psig_modtype (n, si)) :: l
- | SgOpn (loc, id) ->
- mksig loc (Psig_open (long_id_of_string_list loc id)) :: l
- | SgTyp (loc, tdl) -> mksig loc (Psig_type (List.map mktype_decl tdl)) :: l
- | SgUse (loc, fn, sl) ->
- apply_with_var glob_fname fn
- (fun () -> List.fold_right (fun (si, _) -> sig_item si) sl l)
- | SgVal (loc, n, t) -> mksig loc (Psig_value (n, mkvalue_desc t [])) :: l
-and module_expr =
- function
- MeAcc (loc, _, _) as f -> mkmod loc (Pmod_ident (module_expr_long_id f))
- | MeApp (loc, me1, me2) ->
- mkmod loc (Pmod_apply (module_expr me1, module_expr me2))
- | MeFun (loc, n, mt, me) ->
- mkmod loc (Pmod_functor (n, module_type mt, module_expr me))
- | MeStr (loc, sl) ->
- mkmod loc (Pmod_structure (List.fold_right str_item sl []))
- | MeTyc (loc, me, mt) ->
- mkmod loc (Pmod_constraint (module_expr me, module_type mt))
- | MeUid (loc, s) -> mkmod loc (Pmod_ident (lident s))
-and str_item s l =
- match s with
- StCls (loc, cd) ->
- mkstr loc (Pstr_class (List.map (class_info class_expr) cd)) :: l
- | StClt (loc, ctd) ->
- mkstr loc (Pstr_class_type (List.map (class_info class_type) ctd)) :: l
- | StDcl (loc, sl) -> List.fold_right str_item sl l
- | StDir (loc, _, _) -> l
- | StExc (loc, n, tl, sl) ->
- let si =
- match tl, sl with
- tl, [] -> Pstr_exception (n, List.map ctyp tl)
- | [], sl -> Pstr_exn_rebind (n, long_id_of_string_list loc sl)
- | _ -> error loc "bad exception declaration"
- in
- mkstr loc si :: l
- | StExp (loc, e) -> mkstr loc (Pstr_eval (expr e)) :: l
- | StExt (loc, n, t, p) ->
- mkstr loc (Pstr_primitive (n, mkvalue_desc t p)) :: l
- | StInc (loc, me) -> mkstr loc (Pstr_include (module_expr me)) :: l
- | StMod (loc, n, me) -> mkstr loc (Pstr_module (n, module_expr me)) :: l
- | StRecMod (loc, nmes) ->
- mkstr loc
- (Pstr_recmodule
- (List.map (fun (n, mt, me) -> n, module_type mt, module_expr me)
- nmes)) ::
- l
- | StMty (loc, n, mt) -> mkstr loc (Pstr_modtype (n, module_type mt)) :: l
- | StOpn (loc, id) ->
- mkstr loc (Pstr_open (long_id_of_string_list loc id)) :: l
- | StTyp (loc, tdl) -> mkstr loc (Pstr_type (List.map mktype_decl tdl)) :: l
- | StUse (loc, fn, sl) ->
- apply_with_var glob_fname fn
- (fun () -> List.fold_right (fun (si, _) -> str_item si) sl l)
- | StVal (loc, rf, pel) ->
- mkstr loc (Pstr_value (mkrf rf, List.map mkpe pel)) :: l
-and class_type =
- function
- CtCon (loc, id, tl) ->
- mkcty loc
- (Pcty_constr (long_id_of_string_list loc id, List.map ctyp tl))
- | CtFun (loc, TyLab (_, lab, t), ct) ->
- mkcty loc (Pcty_fun (lab, ctyp t, class_type ct))
- | CtFun (loc, TyOlb (loc1, lab, t), ct) ->
- let t = TyApp (loc1, TyLid (loc1, "option"), t) in
- mkcty loc (Pcty_fun (("?" ^ lab), ctyp t, class_type ct))
- | CtFun (loc, t, ct) -> mkcty loc (Pcty_fun ("", ctyp t, class_type ct))
- | CtSig (loc, t_o, ctfl) ->
- let t =
- match t_o with
- Some t -> t
- | None -> TyAny loc
- in
- let cil = List.fold_right class_sig_item ctfl [] in
- mkcty loc (Pcty_signature (ctyp t, cil))
-and class_sig_item c l =
- match c with
- CgCtr (loc, t1, t2) -> Pctf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l
- | CgDcl (loc, cl) -> List.fold_right class_sig_item cl l
- | CgInh (loc, ct) -> Pctf_inher (class_type ct) :: l
- | CgMth (loc, s, pf, t) ->
- Pctf_meth (s, mkprivate pf, ctyp (mkpolytype t), mkloc loc) :: l
- | CgVal (loc, s, b, t) ->
- Pctf_val (s, mkmutable b, Some (ctyp t), mkloc loc) :: l
- | CgVir (loc, s, b, t) ->
- Pctf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l
-and class_expr =
- function
- CeApp (loc, _, _) as c ->
- let (ce, el) = class_expr_fa [] c in
- let el = List.map label_expr el in
- mkpcl loc (Pcl_apply (class_expr ce, el))
- | CeCon (loc, id, tl) ->
- mkpcl loc (Pcl_constr (long_id_of_string_list loc id, List.map ctyp tl))
- | CeFun (loc, PaLab (_, lab, po), ce) ->
- mkpcl loc
- (Pcl_fun (lab, None, patt (patt_of_lab loc lab po), class_expr ce))
- | CeFun (loc, PaOlb (_, lab, peoo), ce) ->
- let (lab, p, eo) = paolab loc lab peoo in
- mkpcl loc (Pcl_fun (("?" ^ lab), option expr eo, patt p, class_expr ce))
- | CeFun (loc, p, ce) ->
- mkpcl loc (Pcl_fun ("", None, patt p, class_expr ce))
- | CeLet (loc, rf, pel, ce) ->
- mkpcl loc (Pcl_let (mkrf rf, List.map mkpe pel, class_expr ce))
- | CeStr (loc, po, cfl) ->
- let p =
- match po with
- Some p -> p
- | None -> PaAny loc
- in
- let cil = List.fold_right class_str_item cfl [] in
- mkpcl loc (Pcl_structure (patt p, cil))
- | CeTyc (loc, ce, ct) ->
- mkpcl loc (Pcl_constraint (class_expr ce, class_type ct))
-and class_str_item c l =
- match c with
- CrCtr (loc, t1, t2) -> Pcf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l
- | CrDcl (loc, cl) -> List.fold_right class_str_item cl l
- | CrInh (loc, ce, pb) -> Pcf_inher (class_expr ce, pb) :: l
- | CrIni (loc, e) -> Pcf_init (expr e) :: l
- | CrMth (loc, s, b, e, t) ->
- let t = option (fun t -> ctyp (mkpolytype t)) t in
- let e = mkexp loc (Pexp_poly (expr e, t)) in
- Pcf_meth (s, mkprivate b, e, mkloc loc) :: l
- | CrVal (loc, s, b, e) -> Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l
- | CrVir (loc, s, b, t) ->
- Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l
-;;
-
-let interf ast = List.fold_right sig_item ast [];;
-let implem ast = List.fold_right str_item ast [];;
-
-let directive loc =
- function
- None -> Pdir_none
- | Some (ExStr (_, s)) -> Pdir_string s
- | Some (ExInt (_, i)) -> Pdir_int (int_of_string i)
- | Some (ExUid (_, "True")) -> Pdir_bool true
- | Some (ExUid (_, "False")) -> Pdir_bool false
- | Some e ->
- let sl =
- let rec loop =
- function
- ExLid (_, i) | ExUid (_, i) -> [i]
- | ExAcc (_, e, ExLid (_, i)) | ExAcc (_, e, ExUid (_, i)) ->
- loop e @ [i]
- | e -> raise_with_loc (loc_of_expr e) (Failure "bad ast")
- in
- loop e
- in
- Pdir_ident (long_id_of_string_list loc sl)
-;;
-
-let phrase =
- function
- StDir (loc, d, dp) -> Ptop_dir (d, directive loc dp)
- | si -> Ptop_def (str_item si [])
-;;
diff --git a/camlp4/ocaml_src/camlp4/ast2pt.mli b/camlp4/ocaml_src/camlp4/ast2pt.mli
deleted file mode 100644
index d64fb6e370..0000000000
--- a/camlp4/ocaml_src/camlp4/ast2pt.mli
+++ /dev/null
@@ -1,23 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-val fast : bool ref;;
-val no_constructors_arity : bool ref;;
-val mkloc : int * int -> Location.t;;
-val long_id_of_string_list : int * int -> string list -> Longident.t;;
-
-val str_item : MLast.str_item -> Parsetree.structure -> Parsetree.structure;;
-val interf : MLast.sig_item list -> Parsetree.signature;;
-val implem : MLast.str_item list -> Parsetree.structure;;
-val phrase : MLast.str_item -> Parsetree.toplevel_phrase;;
diff --git a/camlp4/ocaml_src/camlp4/mLast.mli b/camlp4/ocaml_src/camlp4/mLast.mli
deleted file mode 100644
index 54a66b9c65..0000000000
--- a/camlp4/ocaml_src/camlp4/mLast.mli
+++ /dev/null
@@ -1,211 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-(* Module [MLast]: abstract syntax tree
-
- This is undocumented because the AST is not supposed to be used
- directly; the good usage is to use the quotations representing
- these values in concrete syntax (see the Camlp4 documentation).
- See also the file q_MLast.ml in Camlp4 sources. *)
-
-type loc = int * int;;
-
-type ctyp =
- TyAcc of loc * ctyp * ctyp
- | TyAli of loc * ctyp * ctyp
- | TyAny of loc
- | TyApp of loc * ctyp * ctyp
- | TyArr of loc * ctyp * ctyp
- | TyCls of loc * string list
- | TyLab of loc * string * ctyp
- | TyLid of loc * string
- | TyMan of loc * ctyp * ctyp
- | TyObj of loc * (string * ctyp) list * bool
- | TyOlb of loc * string * ctyp
- | TyPol of loc * string list * ctyp
- | TyQuo of loc * string
- | TyRec of loc * bool * (loc * string * bool * ctyp) list
- | TySum of loc * bool * (loc * string * ctyp list) list
- | TyTup of loc * ctyp list
- | TyUid of loc * string
- | TyVrn of loc * row_field list * string list option option
-and row_field =
- RfTag of string * bool * ctyp list
- | RfInh of ctyp
-;;
-
-type 'a class_infos =
- { ciLoc : loc;
- ciVir : bool;
- ciPrm : loc * (string * (bool * bool)) list;
- ciNam : string;
- ciExp : 'a }
-;;
-
-type patt =
- PaAcc of loc * patt * patt
- | PaAli of loc * patt * patt
- | PaAnt of loc * patt
- | PaAny of loc
- | PaApp of loc * patt * patt
- | PaArr of loc * patt list
- | PaChr of loc * string
- | PaInt of loc * string
- | PaInt32 of loc * string
- | PaInt64 of loc * string
- | PaNativeInt of loc * string
- | PaFlo of loc * string
- | PaLab of loc * string * patt option
- | PaLid of loc * string
- | PaOlb of loc * string * (patt * expr option) option
- | PaOrp of loc * patt * patt
- | PaRng of loc * patt * patt
- | PaRec of loc * (patt * patt) list
- | PaStr of loc * string
- | PaTup of loc * patt list
- | PaTyc of loc * patt * ctyp
- | PaTyp of loc * string list
- | PaUid of loc * string
- | PaVrn of loc * string
-and expr =
- ExAcc of loc * expr * expr
- | ExAnt of loc * expr
- | ExApp of loc * expr * expr
- | ExAre of loc * expr * expr
- | ExArr of loc * expr list
- | ExAsf of loc
- | ExAsr of loc * expr
- | ExAss of loc * expr * expr
- | ExChr of loc * string
- | ExCoe of loc * expr * ctyp option * ctyp
- | ExFlo of loc * string
- | ExFor of loc * string * expr * expr * bool * expr list
- | ExFun of loc * (patt * expr option * expr) list
- | ExIfe of loc * expr * expr * expr
- | ExInt of loc * string
- | ExInt32 of loc * string
- | ExInt64 of loc * string
- | ExNativeInt of loc * string
- | ExLab of loc * string * expr option
- | ExLaz of loc * expr
- | ExLet of loc * bool * (patt * expr) list * expr
- | ExLid of loc * string
- | ExLmd of loc * string * module_expr * expr
- | ExMat of loc * expr * (patt * expr option * expr) list
- | ExNew of loc * string list
- | ExOlb of loc * string * expr option
- | ExOvr of loc * (string * expr) list
- | ExRec of loc * (patt * expr) list * expr option
- | ExSeq of loc * expr list
- | ExSnd of loc * expr * string
- | ExSte of loc * expr * expr
- | ExStr of loc * string
- | ExTry of loc * expr * (patt * expr option * expr) list
- | ExTup of loc * expr list
- | ExTyc of loc * expr * ctyp
- | ExUid of loc * string
- | ExVrn of loc * string
- | ExWhi of loc * expr * expr list
-and module_type =
- MtAcc of loc * module_type * module_type
- | MtApp of loc * module_type * module_type
- | MtFun of loc * string * module_type * module_type
- | MtLid of loc * string
- | MtQuo of loc * string
- | MtSig of loc * sig_item list
- | MtUid of loc * string
- | MtWit of loc * module_type * with_constr list
-and sig_item =
- SgCls of loc * class_type class_infos list
- | SgClt of loc * class_type class_infos list
- | SgDcl of loc * sig_item list
- | SgDir of loc * string * expr option
- | SgExc of loc * string * ctyp list
- | SgExt of loc * string * ctyp * string list
- | SgInc of loc * module_type
- | SgMod of loc * string * module_type
- | SgRecMod of loc * (string * module_type) list
- | SgMty of loc * string * module_type
- | SgOpn of loc * string list
- | SgTyp of loc * type_decl list
- | SgUse of loc * string * (sig_item * loc) list
- | SgVal of loc * string * ctyp
-and with_constr =
- WcTyp of loc * string list * (string * (bool * bool)) list * ctyp
- | WcMod of loc * string list * module_expr
-and module_expr =
- MeAcc of loc * module_expr * module_expr
- | MeApp of loc * module_expr * module_expr
- | MeFun of loc * string * module_type * module_expr
- | MeStr of loc * str_item list
- | MeTyc of loc * module_expr * module_type
- | MeUid of loc * string
-and str_item =
- StCls of loc * class_expr class_infos list
- | StClt of loc * class_type class_infos list
- | StDcl of loc * str_item list
- | StDir of loc * string * expr option
- | StExc of loc * string * ctyp list * string list
- | StExp of loc * expr
- | StExt of loc * string * ctyp * string list
- | StInc of loc * module_expr
- | StMod of loc * string * module_expr
- | StRecMod of loc * (string * module_type * module_expr) list
- | StMty of loc * string * module_type
- | StOpn of loc * string list
- | StTyp of loc * type_decl list
- | StUse of loc * string * (str_item * loc) list
- | StVal of loc * bool * (patt * expr) list
-and type_decl =
- (loc * string) * (string * (bool * bool)) list * ctyp * (ctyp * ctyp) list
-and class_type =
- CtCon of loc * string list * ctyp list
- | CtFun of loc * ctyp * class_type
- | CtSig of loc * ctyp option * class_sig_item list
-and class_sig_item =
- CgCtr of loc * ctyp * ctyp
- | CgDcl of loc * class_sig_item list
- | CgInh of loc * class_type
- | CgMth of loc * string * bool * ctyp
- | CgVal of loc * string * bool * ctyp
- | CgVir of loc * string * bool * ctyp
-and class_expr =
- CeApp of loc * class_expr * expr
- | CeCon of loc * string list * ctyp list
- | CeFun of loc * patt * class_expr
- | CeLet of loc * bool * (patt * expr) list * class_expr
- | CeStr of loc * patt option * class_str_item list
- | CeTyc of loc * class_expr * class_type
-and class_str_item =
- CrCtr of loc * ctyp * ctyp
- | CrDcl of loc * class_str_item list
- | CrInh of loc * class_expr * string option
- | CrIni of loc * expr
- | CrMth of loc * string * bool * expr * ctyp option
- | CrVal of loc * string * bool * expr
- | CrVir of loc * string * bool * ctyp
-;;
-
-external loc_of_ctyp : ctyp -> loc = "%field0";;
-external loc_of_patt : patt -> loc = "%field0";;
-external loc_of_expr : expr -> loc = "%field0";;
-external loc_of_module_type : module_type -> loc = "%field0";;
-external loc_of_module_expr : module_expr -> loc = "%field0";;
-external loc_of_sig_item : sig_item -> loc = "%field0";;
-external loc_of_str_item : str_item -> loc = "%field0";;
-
-external loc_of_class_type : class_type -> loc = "%field0";;
-external loc_of_class_sig_item : class_sig_item -> loc = "%field0";;
-external loc_of_class_expr : class_expr -> loc = "%field0";;
-external loc_of_class_str_item : class_str_item -> loc = "%field0";;
diff --git a/camlp4/ocaml_src/camlp4/pcaml.ml b/camlp4/ocaml_src/camlp4/pcaml.ml
deleted file mode 100644
index 7258fa070e..0000000000
--- a/camlp4/ocaml_src/camlp4/pcaml.ml
+++ /dev/null
@@ -1,464 +0,0 @@
-(* camlp4r pa_extend.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-let version = Sys.ocaml_version;;
-
-let syntax_name = ref "";;
-
-let gram =
- Grammar.gcreate
- {Token.tok_func = (fun _ -> failwith "no loaded parsing module");
- Token.tok_using = (fun _ -> ()); Token.tok_removing = (fun _ -> ());
- Token.tok_match = (fun _ -> raise (Match_failure ("pcaml.ml", 23, 23)));
- Token.tok_text = (fun _ -> ""); Token.tok_comm = None}
-;;
-
-let interf = Grammar.Entry.create gram "interf";;
-let implem = Grammar.Entry.create gram "implem";;
-let top_phrase = Grammar.Entry.create gram "top_phrase";;
-let use_file = Grammar.Entry.create gram "use_file";;
-let sig_item = Grammar.Entry.create gram "sig_item";;
-let str_item = Grammar.Entry.create gram "str_item";;
-let module_type = Grammar.Entry.create gram "module_type";;
-let module_expr = Grammar.Entry.create gram "module_expr";;
-let expr = Grammar.Entry.create gram "expr";;
-let patt = Grammar.Entry.create gram "patt";;
-let ctyp = Grammar.Entry.create gram "type";;
-let let_binding = Grammar.Entry.create gram "let_binding";;
-let type_declaration = Grammar.Entry.create gram "type_declaration";;
-
-let class_sig_item = Grammar.Entry.create gram "class_sig_item";;
-let class_str_item = Grammar.Entry.create gram "class_str_item";;
-let class_type = Grammar.Entry.create gram "class_type";;
-let class_expr = Grammar.Entry.create gram "class_expr";;
-
-let parse_interf = ref (Grammar.Entry.parse interf);;
-let parse_implem = ref (Grammar.Entry.parse implem);;
-
-let rec skip_to_eol cs =
- match Stream.peek cs with
- Some '\n' -> ()
- | Some c -> Stream.junk cs; skip_to_eol cs
- | _ -> ()
-;;
-let sync = ref skip_to_eol;;
-
-let input_file = ref "";;
-let output_file = ref None;;
-
-let warning_default_function (bp, ep) txt =
- Printf.eprintf "<W> loc %d %d: %s\n" bp ep txt; flush stderr
-;;
-
-let warning = ref warning_default_function;;
-
-let apply_with_var v x f =
- let vx = !v in
- try v := x; let r = f () in v := vx; r with
- e -> v := vx; raise e
-;;
-
-List.iter (fun (n, f) -> Quotation.add n f)
- ["id", Quotation.ExStr (fun _ s -> "$0:" ^ s ^ "$");
- "string", Quotation.ExStr (fun _ s -> "\"" ^ String.escaped s ^ "\"")];;
-
-let quotation_dump_file = ref (None : string option);;
-
-type err_ctx =
- Finding
- | Expanding
- | ParsingResult of (int * int) * string
- | Locating
-;;
-exception Qerror of string * err_ctx * exn;;
-
-let expand_quotation loc expander shift name str =
- let new_warning =
- let warn = !warning in
- fun (bp, ep) txt -> warn (shift + bp, shift + ep) txt
- in
- apply_with_var warning new_warning
- (fun () ->
- try expander str with
- Stdpp.Exc_located ((p1, p2), exc) ->
- let exc1 = Qerror (name, Expanding, exc) in
- raise (Stdpp.Exc_located ((shift + p1, shift + p2), exc1))
- | exc ->
- let exc1 = Qerror (name, Expanding, exc) in
- raise (Stdpp.Exc_located (loc, exc1)))
-;;
-
-let parse_quotation_result entry loc shift name str =
- let cs = Stream.of_string str in
- try Grammar.Entry.parse entry cs with
- Stdpp.Exc_located (iloc, (Qerror (_, Locating, _) as exc)) ->
- raise (Stdpp.Exc_located ((shift + fst iloc, shift + snd iloc), exc))
- | Stdpp.Exc_located (iloc, Qerror (_, Expanding, exc)) ->
- let ctx = ParsingResult (iloc, str) in
- let exc1 = Qerror (name, ctx, exc) in
- raise (Stdpp.Exc_located (loc, exc1))
- | Stdpp.Exc_located (_, (Qerror (_, _, _) as exc)) ->
- raise (Stdpp.Exc_located (loc, exc))
- | Stdpp.Exc_located (iloc, exc) ->
- let ctx = ParsingResult (iloc, str) in
- let exc1 = Qerror (name, ctx, exc) in
- raise (Stdpp.Exc_located (loc, exc1))
-;;
-
-let handle_quotation loc proj in_expr entry reloc (name, str) =
- let shift =
- match name with
- "" -> String.length "<<"
- | _ -> String.length "<:" + String.length name + String.length "<"
- in
- let shift = fst loc + shift in
- let expander =
- try Quotation.find name with
- exc ->
- let exc1 = Qerror (name, Finding, exc) in
- let loc = fst loc, shift in raise (Stdpp.Exc_located (loc, exc1))
- in
- let ast =
- match expander with
- Quotation.ExStr f ->
- let new_str = expand_quotation loc (f in_expr) shift name str in
- parse_quotation_result entry loc shift name new_str
- | Quotation.ExAst fe_fp ->
- expand_quotation loc (proj fe_fp) shift name str
- in
- reloc (fun _ -> loc) shift ast
-;;
-
-let parse_locate entry shift str =
- let cs = Stream.of_string str in
- try Grammar.Entry.parse entry cs with
- Stdpp.Exc_located ((p1, p2), exc) ->
- let ctx = Locating in
- let exc1 = Qerror (Grammar.Entry.name entry, ctx, exc) in
- raise (Stdpp.Exc_located ((shift + p1, shift + p2), exc1))
-;;
-
-let handle_locate loc entry ast_f (pos, str) =
- let s = str in
- let loc = pos, pos + String.length s in
- let x = parse_locate entry (fst loc) s in ast_f loc x
-;;
-
-let expr_anti loc e = MLast.ExAnt (loc, e);;
-let patt_anti loc p = MLast.PaAnt (loc, p);;
-let expr_eoi = Grammar.Entry.create gram "expression";;
-let patt_eoi = Grammar.Entry.create gram "pattern";;
-Grammar.extend
- [Grammar.Entry.obj (expr_eoi : 'expr_eoi Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e));
- Gramext.Stoken ("EOI", "")],
- Gramext.action
- (fun _ (x : 'expr) (loc : int * int) -> (x : 'expr_eoi))]];
- Grammar.Entry.obj (patt_eoi : 'patt_eoi Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e));
- Gramext.Stoken ("EOI", "")],
- Gramext.action
- (fun _ (x : 'patt) (loc : int * int) -> (x : 'patt_eoi))]]];;
-
-let handle_expr_quotation loc x =
- handle_quotation loc fst true expr_eoi Reloc.expr x
-;;
-
-let handle_expr_locate loc x = handle_locate loc expr_eoi expr_anti x;;
-
-let handle_patt_quotation loc x =
- handle_quotation loc snd false patt_eoi Reloc.patt x
-;;
-
-let handle_patt_locate loc x = handle_locate loc patt_eoi patt_anti x;;
-
-let expr_reloc = Reloc.expr;;
-let patt_reloc = Reloc.patt;;
-
-let rename_id = ref (fun x -> x);;
-
-let find_line (bp, ep) str =
- let rec find i line col =
- if i == String.length str then line, 0, col
- else if i == bp then line, col, col + ep - bp
- else if str.[i] == '\n' then find (succ i) (succ line) 0
- else find (succ i) line (succ col)
- in
- find 0 1 0
-;;
-
-let loc_fmt =
- match Sys.os_type with
- "MacOS" ->
- format_of_string "File \"%s\"; line %d; characters %d to %d\n### "
- | _ -> format_of_string "File \"%s\", line %d, characters %d-%d:\n"
-;;
-
-let report_quotation_error name ctx =
- let name = if name = "" then !(Quotation.default) else name in
- Format.print_flush ();
- Format.open_hovbox 2;
- Printf.eprintf "While %s \"%s\":"
- (match ctx with
- Finding -> "finding quotation"
- | Expanding -> "expanding quotation"
- | ParsingResult (_, _) -> "parsing result of quotation"
- | Locating -> "parsing")
- name;
- match ctx with
- ParsingResult ((bp, ep), str) ->
- begin match !quotation_dump_file with
- Some dump_file ->
- Printf.eprintf " dumping result...\n";
- flush stderr;
- begin try
- let (line, c1, c2) = find_line (bp, ep) str in
- let oc = open_out_bin dump_file in
- output_string oc str;
- output_string oc "\n";
- flush oc;
- close_out oc;
- Printf.eprintf loc_fmt dump_file line c1 c2;
- flush stderr
- with
- _ ->
- Printf.eprintf "Error while dumping result in file \"%s\""
- dump_file;
- Printf.eprintf "; dump aborted.\n";
- flush stderr
- end
- | None ->
- if !input_file = "" then
- Printf.eprintf
- "\n(consider setting variable Pcaml.quotation_dump_file)\n"
- else Printf.eprintf " (consider using option -QD)\n";
- flush stderr
- end
- | _ -> Printf.eprintf "\n"; flush stderr
-;;
-
-let print_format str =
- let rec flush ini cnt =
- if cnt > ini then Format.print_string (String.sub str ini (cnt - ini))
- in
- let rec loop ini cnt =
- if cnt == String.length str then flush ini cnt
- else
- match str.[cnt] with
- '\n' ->
- flush ini cnt;
- Format.close_box ();
- Format.force_newline ();
- Format.open_box 2;
- loop (cnt + 1) (cnt + 1)
- | ' ' -> flush ini cnt; Format.print_space (); loop (cnt + 1) (cnt + 1)
- | _ -> loop ini (cnt + 1)
- in
- Format.open_box 2; loop 0 0; Format.close_box ()
-;;
-
-let print_file_failed file line char =
- Format.print_string ", file \"";
- Format.print_string file;
- Format.print_string "\", line ";
- Format.print_int line;
- Format.print_string ", char ";
- Format.print_int char
-;;
-
-let print_exn =
- function
- Out_of_memory -> Format.print_string "Out of memory\n"
- | Assert_failure (file, line, char) ->
- Format.print_string "Assertion failed"; print_file_failed file line char
- | Match_failure (file, line, char) ->
- Format.print_string "Pattern matching failed";
- print_file_failed file line char
- | Stream.Error str -> print_format ("Parse error: " ^ str)
- | Stream.Failure -> Format.print_string "Parse failure"
- | Token.Error str ->
- Format.print_string "Lexing error: "; Format.print_string str
- | Failure str -> Format.print_string "Failure: "; Format.print_string str
- | Invalid_argument str ->
- Format.print_string "Invalid argument: "; Format.print_string str
- | Sys_error msg ->
- Format.print_string "I/O error: "; Format.print_string msg
- | x ->
- Format.print_string "Uncaught exception: ";
- Format.print_string
- (Obj.magic (Obj.field (Obj.field (Obj.repr x) 0) 0));
- if Obj.size (Obj.repr x) > 1 then
- begin
- Format.print_string " (";
- for i = 1 to Obj.size (Obj.repr x) - 1 do
- if i > 1 then Format.print_string ", ";
- let arg = Obj.field (Obj.repr x) i in
- if not (Obj.is_block arg) then
- Format.print_int (Obj.magic arg : int)
- else if Obj.tag arg = Obj.tag (Obj.repr "a") then
- begin
- Format.print_char '\"';
- Format.print_string (Obj.magic arg : string);
- Format.print_char '\"'
- end
- else Format.print_char '_'
- done;
- Format.print_char ')'
- end
-;;
-
-let report_error exn =
- match exn with
- Qerror (name, Finding, Not_found) ->
- let name = if name = "" then !(Quotation.default) else name in
- Format.print_flush ();
- Format.open_hovbox 2;
- Format.printf "Unbound quotation: \"%s\"" name;
- Format.close_box ()
- | Qerror (name, ctx, exn) -> report_quotation_error name ctx; print_exn exn
- | e -> print_exn exn
-;;
-
-let no_constructors_arity = Ast2pt.no_constructors_arity;;
-(*value no_assert = ref False;*)
-
-let arg_spec_list_ref = ref [];;
-let arg_spec_list () = !arg_spec_list_ref;;
-let add_option name spec descr =
- arg_spec_list_ref := !arg_spec_list_ref @ [name, spec, descr]
-;;
-
-(* Printers *)
-
-open Spretty;;
-
-type 'a printer_t =
- { mutable pr_fun : string -> 'a -> string -> kont -> pretty;
- mutable pr_levels : 'a pr_level list }
-and 'a pr_level =
- { pr_label : string;
- pr_box : 'a -> pretty Stream.t -> pretty;
- mutable pr_rules : 'a pr_rule }
-and 'a pr_rule =
- ('a, ('a curr -> 'a next -> string -> kont -> pretty Stream.t)) Extfun.t
-and 'a curr = 'a -> string -> kont -> pretty Stream.t
-and 'a next = 'a -> string -> kont -> pretty
-and kont = pretty Stream.t
-;;
-
-let pr_str_item =
- {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 385, 30)));
- pr_levels = []}
-;;
-let pr_sig_item =
- {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 386, 30)));
- pr_levels = []}
-;;
-let pr_module_type =
- {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 387, 33)));
- pr_levels = []}
-;;
-let pr_module_expr =
- {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 388, 33)));
- pr_levels = []}
-;;
-let pr_expr =
- {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 389, 26)));
- pr_levels = []}
-;;
-let pr_patt =
- {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 390, 26)));
- pr_levels = []}
-;;
-let pr_ctyp =
- {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 391, 26)));
- pr_levels = []}
-;;
-let pr_class_sig_item =
- {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 392, 36)));
- pr_levels = []}
-;;
-let pr_class_str_item =
- {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 393, 36)));
- pr_levels = []}
-;;
-let pr_class_type =
- {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 394, 32)));
- pr_levels = []}
-;;
-let pr_class_expr =
- {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 395, 32)));
- pr_levels = []}
-;;
-let pr_expr_fun_args = ref Extfun.empty;;
-
-let pr_fun name pr lab =
- let rec loop app =
- function
- [] -> (fun x dg k -> failwith ("unable to print " ^ name))
- | lev :: levl ->
- if app || lev.pr_label = lab then
- let next = loop true levl in
- let rec curr x dg k = Extfun.apply lev.pr_rules x curr next dg k in
- fun x dg k -> lev.pr_box x (curr x dg k)
- else loop app levl
- in
- loop false pr.pr_levels
-;;
-
-pr_str_item.pr_fun <- pr_fun "str_item" pr_str_item;;
-pr_sig_item.pr_fun <- pr_fun "sig_item" pr_sig_item;;
-pr_module_type.pr_fun <- pr_fun "module_type" pr_module_type;;
-pr_module_expr.pr_fun <- pr_fun "module_expr" pr_module_expr;;
-pr_expr.pr_fun <- pr_fun "expr" pr_expr;;
-pr_patt.pr_fun <- pr_fun "patt" pr_patt;;
-pr_ctyp.pr_fun <- pr_fun "ctyp" pr_ctyp;;
-pr_class_sig_item.pr_fun <- pr_fun "class_sig_item" pr_class_sig_item;;
-pr_class_str_item.pr_fun <- pr_fun "class_str_item" pr_class_str_item;;
-pr_class_type.pr_fun <- pr_fun "class_type" pr_class_type;;
-pr_class_expr.pr_fun <- pr_fun "class_expr" pr_class_expr;;
-
-let rec find_pr_level lab =
- function
- [] -> failwith ("level " ^ lab ^ " not found")
- | lev :: levl -> if lev.pr_label = lab then lev else find_pr_level lab levl
-;;
-
-let undef x = ref (fun _ -> failwith x);;
-let print_interf = undef "no printer";;
-let print_implem = undef "no printer";;
-
-let top_printer pr x =
- Format.force_newline ();
- Spretty.print_pretty Format.print_char Format.print_string
- Format.print_newline "<< " " " 78 (fun _ _ -> "", 0, 0, 0) 0
- (pr.pr_fun "top" x "" Stream.sempty);
- Format.print_string " >>"
-;;
-
-let buff = Buffer.create 73;;
-let buffer_char = Buffer.add_char buff;;
-let buffer_string = Buffer.add_string buff;;
-let buffer_newline () = Buffer.add_char buff '\n';;
-
-let string_of pr x =
- Buffer.clear buff;
- Spretty.print_pretty buffer_char buffer_string buffer_newline "" "" 78
- (fun _ _ -> "", 0, 0, 0) 0 (pr.pr_fun "top" x "" Stream.sempty);
- Buffer.contents buff
-;;
-
-let inter_phrases = ref None;;
diff --git a/camlp4/ocaml_src/camlp4/pcaml.mli b/camlp4/ocaml_src/camlp4/pcaml.mli
deleted file mode 100644
index 8f8eacaf24..0000000000
--- a/camlp4/ocaml_src/camlp4/pcaml.mli
+++ /dev/null
@@ -1,158 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-(** Language grammar, entries and printers.
-
- Hold variables to be set by language syntax extensions. Some of them
- are provided for quotations management. *)
-
-val syntax_name : string ref;;
-
-(** {6 Parsers} *)
-
-val parse_interf :
- (char Stream.t -> (MLast.sig_item * MLast.loc) list * bool) ref;;
-val parse_implem :
- (char Stream.t -> (MLast.str_item * MLast.loc) list * bool) ref;;
- (** Called when parsing an interface (mli file) or an implementation
- (ml file) to build the syntax tree; the returned list contains the
- phrases (signature items or structure items) and their locations;
- the boolean tells that the parser has encountered a directive; in
- this case, since the directive may change the syntax, the parsing
- stops, the directive is evaluated, and this function is called
- again.
- These functions are references, because they can be changed to
- use another technology than the Camlp4 extended grammars. By
- default, they use the grammars entries [implem] and [interf]
- defined below. *)
-
-val gram : Grammar.g;;
- (** Grammar variable of the OCaml language *)
-
-val interf : ((MLast.sig_item * MLast.loc) list * bool) Grammar.Entry.e;;
-val implem : ((MLast.str_item * MLast.loc) list * bool) Grammar.Entry.e;;
-val top_phrase : MLast.str_item option Grammar.Entry.e;;
-val use_file : (MLast.str_item list * bool) Grammar.Entry.e;;
-val module_type : MLast.module_type Grammar.Entry.e;;
-val module_expr : MLast.module_expr Grammar.Entry.e;;
-val sig_item : MLast.sig_item Grammar.Entry.e;;
-val str_item : MLast.str_item Grammar.Entry.e;;
-val expr : MLast.expr Grammar.Entry.e;;
-val patt : MLast.patt Grammar.Entry.e;;
-val ctyp : MLast.ctyp Grammar.Entry.e;;
-val let_binding : (MLast.patt * MLast.expr) Grammar.Entry.e;;
-val type_declaration : MLast.type_decl Grammar.Entry.e;;
-val class_sig_item : MLast.class_sig_item Grammar.Entry.e;;
-val class_str_item : MLast.class_str_item Grammar.Entry.e;;
-val class_expr : MLast.class_expr Grammar.Entry.e;;
-val class_type : MLast.class_type Grammar.Entry.e;;
- (** Some entries of the language, set by [pa_o.cmo] and [pa_r.cmo]. *)
-
-val input_file : string ref;;
- (** The file currently being parsed. *)
-val output_file : string option ref;;
- (** The output file, stdout if None (default) *)
-val report_error : exn -> unit;;
- (** Prints an error message, using the module [Format]. *)
-val quotation_dump_file : string option ref;;
- (** [quotation_dump_file] optionally tells the compiler to dump the
- result of an expander if this result is syntactically incorrect.
- If [None] (default), this result is not dumped. If [Some fname], the
- result is dumped in the file [fname]. *)
-val version : string;;
- (** The current version of Camlp4. *)
-val add_option : string -> Arg.spec -> string -> unit;;
- (** Add an option to the command line options. *)
-val no_constructors_arity : bool ref;;
- (** [True]: dont generate constructor arity. *)
-(*value no_assert : ref bool;
- (** [True]: dont generate assertion checks. *)
-*)
-
-val sync : (char Stream.t -> unit) ref;;
-
-val handle_expr_quotation : MLast.loc -> string * string -> MLast.expr;;
-val handle_expr_locate : MLast.loc -> int * string -> MLast.expr;;
-
-val handle_patt_quotation : MLast.loc -> string * string -> MLast.patt;;
-val handle_patt_locate : MLast.loc -> int * string -> MLast.patt;;
-
-val expr_reloc : (MLast.loc -> MLast.loc) -> int -> MLast.expr -> MLast.expr;;
-val patt_reloc : (MLast.loc -> MLast.loc) -> int -> MLast.patt -> MLast.patt;;
-
-(** To possibly rename identifiers; parsers may call this function
- when generating their identifiers; default = identity *)
-val rename_id : (string -> string) ref;;
-
-(** Allow user to catch exceptions in quotations *)
-type err_ctx =
- Finding
- | Expanding
- | ParsingResult of (int * int) * string
- | Locating
-;;
-exception Qerror of string * err_ctx * exn;;
-
-(** {6 Printers} *)
-
-open Spretty;;
-
-val print_interf : ((MLast.sig_item * MLast.loc) list -> unit) ref;;
-val print_implem : ((MLast.str_item * MLast.loc) list -> unit) ref;;
- (** Some printers, set by [pr_dump.cmo], [pr_o.cmo] and [pr_r.cmo]. *)
-
-type 'a printer_t =
- { mutable pr_fun : string -> 'a -> string -> kont -> pretty;
- mutable pr_levels : 'a pr_level list }
-and 'a pr_level =
- { pr_label : string;
- pr_box : 'a -> pretty Stream.t -> pretty;
- mutable pr_rules : 'a pr_rule }
-and 'a pr_rule =
- ('a, ('a curr -> 'a next -> string -> kont -> pretty Stream.t)) Extfun.t
-and 'a curr = 'a -> string -> kont -> pretty Stream.t
-and 'a next = 'a -> string -> kont -> pretty
-and kont = pretty Stream.t
-;;
-
-val pr_sig_item : MLast.sig_item printer_t;;
-val pr_str_item : MLast.str_item printer_t;;
-val pr_module_type : MLast.module_type printer_t;;
-val pr_module_expr : MLast.module_expr printer_t;;
-val pr_expr : MLast.expr printer_t;;
-val pr_patt : MLast.patt printer_t;;
-val pr_ctyp : MLast.ctyp printer_t;;
-val pr_class_sig_item : MLast.class_sig_item printer_t;;
-val pr_class_str_item : MLast.class_str_item printer_t;;
-val pr_class_type : MLast.class_type printer_t;;
-val pr_class_expr : MLast.class_expr printer_t;;
-
-val pr_expr_fun_args :
- (MLast.expr, (MLast.patt list * MLast.expr)) Extfun.t ref;;
-
-val find_pr_level : string -> 'a pr_level list -> 'a pr_level;;
-
-val top_printer : 'a printer_t -> 'a -> unit;;
-val string_of : 'a printer_t -> 'a -> string;;
-
-val inter_phrases : string option ref;;
-
-(**/**)
-
-(* for system use *)
-
-val warning : (int * int -> string -> unit) ref;;
-val expr_eoi : MLast.expr Grammar.Entry.e;;
-val patt_eoi : MLast.patt Grammar.Entry.e;;
-val arg_spec_list : unit -> (string * Arg.spec * string) list;;
diff --git a/camlp4/ocaml_src/camlp4/quotation.ml b/camlp4/ocaml_src/camlp4/quotation.ml
deleted file mode 100644
index 07057c968b..0000000000
--- a/camlp4/ocaml_src/camlp4/quotation.ml
+++ /dev/null
@@ -1,33 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-type expander =
- ExStr of (bool -> string -> string)
- | ExAst of ((string -> MLast.expr) * (string -> MLast.patt))
-;;
-
-let expanders_table = ref [];;
-
-let default = ref "";;
-let translate = ref (fun x -> x);;
-
-let expander_name name =
- match !translate name with
- "" -> !default
- | name -> name
-;;
-
-let find name = List.assoc (expander_name name) !expanders_table;;
-
-let add name f = expanders_table := (name, f) :: !expanders_table;;
diff --git a/camlp4/ocaml_src/camlp4/quotation.mli b/camlp4/ocaml_src/camlp4/quotation.mli
deleted file mode 100644
index aba963d705..0000000000
--- a/camlp4/ocaml_src/camlp4/quotation.mli
+++ /dev/null
@@ -1,48 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1998 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-(** Quotation operations. *)
-
-type expander =
- ExStr of (bool -> string -> string)
- | ExAst of ((string -> MLast.expr) * (string -> MLast.patt))
-;;
-
-(** The type for quotation expanders kind:
-- [ExStr exp] for an expander [exp] returning a string which
- can be parsed to create a syntax tree. Its boolean parameter
- tells whether the quotation is in position of an expression
- (True) or in position of a pattern (False). Quotations expanders
- created with this way may work for some particular language syntax,
- and not for another one (e.g. may work when used with Revised
- syntax and not when used with Ocaml syntax, and conversely).
-- [ExAst (expr_exp, patt_exp)] for expanders returning directly
- syntax trees, therefore not necessiting to be parsed afterwards.
- The function [expr_exp] is called when the quotation is in
- position of an expression, and [patt_exp] when the quotation is
- in position of a pattern. Quotation expanders created with this
- way are independant from the language syntax. *)
-
-val add : string -> expander -> unit;;
- (** [add name exp] adds the quotation [name] associated with the
- expander [exp]. *)
-
-val find : string -> expander;;
- (** [find name] returns the expander of the given quotation name. *)
-
-val default : string ref;;
- (** [default] holds the default quotation name. *)
-
-val translate : (string -> string) ref;;
- (** function translating quotation names; default = identity *)
diff --git a/camlp4/ocaml_src/camlp4/reloc.ml b/camlp4/ocaml_src/camlp4/reloc.ml
deleted file mode 100644
index 980d6ce786..0000000000
--- a/camlp4/ocaml_src/camlp4/reloc.ml
+++ /dev/null
@@ -1,337 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1998 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-open MLast;;
-
-let option_map f =
- function
- Some x -> Some (f x)
- | None -> None
-;;
-
-let rec ctyp floc sh =
- let rec self =
- function
- TyAcc (loc, x1, x2) -> TyAcc (floc loc, self x1, self x2)
- | TyAli (loc, x1, x2) -> TyAli (floc loc, self x1, self x2)
- | TyAny loc -> TyAny (floc loc)
- | TyApp (loc, x1, x2) -> TyApp (floc loc, self x1, self x2)
- | TyArr (loc, x1, x2) -> TyArr (floc loc, self x1, self x2)
- | TyCls (loc, x1) -> TyCls (floc loc, x1)
- | TyLab (loc, x1, x2) -> TyLab (floc loc, x1, self x2)
- | TyLid (loc, x1) -> TyLid (floc loc, x1)
- | TyMan (loc, x1, x2) -> TyMan (floc loc, self x1, self x2)
- | TyObj (loc, x1, x2) ->
- TyObj (floc loc, List.map (fun (x1, x2) -> x1, self x2) x1, x2)
- | TyOlb (loc, x1, x2) -> TyOlb (floc loc, x1, self x2)
- | TyPol (loc, x1, x2) -> TyPol (floc loc, x1, self x2)
- | TyQuo (loc, x1) -> TyQuo (floc loc, x1)
- | TyRec (loc, pflag, x1) ->
- TyRec
- (floc loc, pflag,
- List.map (fun (loc, x1, x2, x3) -> floc loc, x1, x2, self x3) x1)
- | TySum (loc, pflag, x1) ->
- TySum
- (floc loc, pflag,
- List.map (fun (loc, x1, x2) -> floc loc, x1, List.map self x2) x1)
- | TyTup (loc, x1) -> TyTup (floc loc, List.map self x1)
- | TyUid (loc, x1) -> TyUid (floc loc, x1)
- | TyVrn (loc, x1, x2) ->
- TyVrn (floc loc, List.map (row_field floc sh) x1, x2)
- in
- self
-and row_field floc sh =
- function
- RfTag (x1, x2, x3) -> RfTag (x1, x2, List.map (ctyp floc sh) x3)
- | RfInh x1 -> RfInh (ctyp floc sh x1)
-;;
-
-let class_infos a floc sh x =
- {ciLoc = floc x.ciLoc; ciVir = x.ciVir;
- ciPrm = begin let (x1, x2) = x.ciPrm in floc x1, x2 end; ciNam = x.ciNam;
- ciExp = a floc sh x.ciExp}
-;;
-
-let rec patt floc sh =
- let rec self =
- function
- PaAcc (loc, x1, x2) -> PaAcc (floc loc, self x1, self x2)
- | PaAli (loc, x1, x2) -> PaAli (floc loc, self x1, self x2)
- | PaAnt (loc, x1) ->
- patt (fun (p1, p2) -> sh + fst loc + p1, sh + fst loc + p2) 0 x1
- | PaAny loc -> PaAny (floc loc)
- | PaApp (loc, x1, x2) -> PaApp (floc loc, self x1, self x2)
- | PaArr (loc, x1) -> PaArr (floc loc, List.map self x1)
- | PaChr (loc, x1) -> PaChr (floc loc, x1)
- | PaInt (loc, x1) -> PaInt (floc loc, x1)
- | PaInt32 (loc, x1) -> PaInt32 (floc loc, x1)
- | PaInt64 (loc, x1) -> PaInt64 (floc loc, x1)
- | PaNativeInt (loc, x1) -> PaNativeInt (floc loc, x1)
- | PaFlo (loc, x1) -> PaFlo (floc loc, x1)
- | PaLab (loc, x1, x2) -> PaLab (floc loc, x1, option_map self x2)
- | PaLid (loc, x1) -> PaLid (floc loc, x1)
- | PaOlb (loc, x1, x2) ->
- PaOlb
- (floc loc, x1,
- option_map (fun (x1, x2) -> self x1, option_map (expr floc sh) x2)
- x2)
- | PaOrp (loc, x1, x2) -> PaOrp (floc loc, self x1, self x2)
- | PaRng (loc, x1, x2) -> PaRng (floc loc, self x1, self x2)
- | PaRec (loc, x1) ->
- PaRec (floc loc, List.map (fun (x1, x2) -> self x1, self x2) x1)
- | PaStr (loc, x1) -> PaStr (floc loc, x1)
- | PaTup (loc, x1) -> PaTup (floc loc, List.map self x1)
- | PaTyc (loc, x1, x2) -> PaTyc (floc loc, self x1, ctyp floc sh x2)
- | PaTyp (loc, x1) -> PaTyp (floc loc, x1)
- | PaUid (loc, x1) -> PaUid (floc loc, x1)
- | PaVrn (loc, x1) -> PaVrn (floc loc, x1)
- in
- self
-and expr floc sh =
- let rec self =
- function
- ExAcc (loc, x1, x2) -> ExAcc (floc loc, self x1, self x2)
- | ExAnt (loc, x1) ->
- expr (fun (p1, p2) -> sh + fst loc + p1, sh + fst loc + p2) 0 x1
- | ExApp (loc, x1, x2) -> ExApp (floc loc, self x1, self x2)
- | ExAre (loc, x1, x2) -> ExAre (floc loc, self x1, self x2)
- | ExArr (loc, x1) -> ExArr (floc loc, List.map self x1)
- | ExAsf loc -> ExAsf (floc loc)
- | ExAsr (loc, x1) -> ExAsr (floc loc, self x1)
- | ExAss (loc, x1, x2) -> ExAss (floc loc, self x1, self x2)
- | ExChr (loc, x1) -> ExChr (floc loc, x1)
- | ExCoe (loc, x1, x2, x3) ->
- ExCoe
- (floc loc, self x1, option_map (ctyp floc sh) x2, ctyp floc sh x3)
- | ExFlo (loc, x1) -> ExFlo (floc loc, x1)
- | ExFor (loc, x1, x2, x3, x4, x5) ->
- ExFor (floc loc, x1, self x2, self x3, x4, List.map self x5)
- | ExFun (loc, x1) ->
- ExFun
- (floc loc,
- List.map
- (fun (x1, x2, x3) ->
- patt floc sh x1, option_map self x2, self x3)
- x1)
- | ExIfe (loc, x1, x2, x3) -> ExIfe (floc loc, self x1, self x2, self x3)
- | ExInt (loc, x1) -> ExInt (floc loc, x1)
- | ExInt32 (loc, x1) -> ExInt32 (floc loc, x1)
- | ExInt64 (loc, x1) -> ExInt64 (floc loc, x1)
- | ExNativeInt (loc, x1) -> ExNativeInt (floc loc, x1)
- | ExLab (loc, x1, x2) -> ExLab (floc loc, x1, option_map self x2)
- | ExLaz (loc, x1) -> ExLaz (floc loc, self x1)
- | ExLet (loc, x1, x2, x3) ->
- ExLet
- (floc loc, x1,
- List.map (fun (x1, x2) -> patt floc sh x1, self x2) x2, self x3)
- | ExLid (loc, x1) -> ExLid (floc loc, x1)
- | ExLmd (loc, x1, x2, x3) ->
- ExLmd (floc loc, x1, module_expr floc sh x2, self x3)
- | ExMat (loc, x1, x2) ->
- ExMat
- (floc loc, self x1,
- List.map
- (fun (x1, x2, x3) ->
- patt floc sh x1, option_map self x2, self x3)
- x2)
- | ExNew (loc, x1) -> ExNew (floc loc, x1)
- | ExOlb (loc, x1, x2) -> ExOlb (floc loc, x1, option_map self x2)
- | ExOvr (loc, x1) ->
- ExOvr (floc loc, List.map (fun (x1, x2) -> x1, self x2) x1)
- | ExRec (loc, x1, x2) ->
- ExRec
- (floc loc, List.map (fun (x1, x2) -> patt floc sh x1, self x2) x1,
- option_map self x2)
- | ExSeq (loc, x1) -> ExSeq (floc loc, List.map self x1)
- | ExSnd (loc, x1, x2) -> ExSnd (floc loc, self x1, x2)
- | ExSte (loc, x1, x2) -> ExSte (floc loc, self x1, self x2)
- | ExStr (loc, x1) -> ExStr (floc loc, x1)
- | ExTry (loc, x1, x2) ->
- ExTry
- (floc loc, self x1,
- List.map
- (fun (x1, x2, x3) ->
- patt floc sh x1, option_map self x2, self x3)
- x2)
- | ExTup (loc, x1) -> ExTup (floc loc, List.map self x1)
- | ExTyc (loc, x1, x2) -> ExTyc (floc loc, self x1, ctyp floc sh x2)
- | ExUid (loc, x1) -> ExUid (floc loc, x1)
- | ExVrn (loc, x1) -> ExVrn (floc loc, x1)
- | ExWhi (loc, x1, x2) -> ExWhi (floc loc, self x1, List.map self x2)
- in
- self
-and module_type floc sh =
- let rec self =
- function
- MtAcc (loc, x1, x2) -> MtAcc (floc loc, self x1, self x2)
- | MtApp (loc, x1, x2) -> MtApp (floc loc, self x1, self x2)
- | MtFun (loc, x1, x2, x3) -> MtFun (floc loc, x1, self x2, self x3)
- | MtLid (loc, x1) -> MtLid (floc loc, x1)
- | MtQuo (loc, x1) -> MtQuo (floc loc, x1)
- | MtSig (loc, x1) -> MtSig (floc loc, List.map (sig_item floc sh) x1)
- | MtUid (loc, x1) -> MtUid (floc loc, x1)
- | MtWit (loc, x1, x2) ->
- MtWit (floc loc, self x1, List.map (with_constr floc sh) x2)
- in
- self
-and sig_item floc sh =
- let rec self =
- function
- SgCls (loc, x1) ->
- SgCls (floc loc, List.map (class_infos class_type floc sh) x1)
- | SgClt (loc, x1) ->
- SgClt (floc loc, List.map (class_infos class_type floc sh) x1)
- | SgDcl (loc, x1) -> SgDcl (floc loc, List.map self x1)
- | SgDir (loc, x1, x2) -> SgDir (floc loc, x1, x2)
- | SgExc (loc, x1, x2) -> SgExc (floc loc, x1, List.map (ctyp floc sh) x2)
- | SgExt (loc, x1, x2, x3) -> SgExt (floc loc, x1, ctyp floc sh x2, x3)
- | SgInc (loc, x1) -> SgInc (floc loc, module_type floc sh x1)
- | SgMod (loc, x1, x2) -> SgMod (floc loc, x1, module_type floc sh x2)
- | SgRecMod (loc, xxs) ->
- SgRecMod
- (floc loc,
- List.map (fun (x1, x2) -> x1, module_type floc sh x2) xxs)
- | SgMty (loc, x1, x2) -> SgMty (floc loc, x1, module_type floc sh x2)
- | SgOpn (loc, x1) -> SgOpn (floc loc, x1)
- | SgTyp (loc, x1) ->
- SgTyp
- (floc loc,
- List.map
- (fun ((loc, x1), x2, x3, x4) ->
- (floc loc, x1), x2, ctyp floc sh x3,
- List.map (fun (x1, x2) -> ctyp floc sh x1, ctyp floc sh x2)
- x4)
- x1)
- | SgUse (loc, x1, x2) -> SgUse (loc, x1, x2)
- | SgVal (loc, x1, x2) -> SgVal (floc loc, x1, ctyp floc sh x2)
- in
- self
-and with_constr floc sh =
- let rec self =
- function
- WcTyp (loc, x1, x2, x3) -> WcTyp (floc loc, x1, x2, ctyp floc sh x3)
- | WcMod (loc, x1, x2) -> WcMod (floc loc, x1, module_expr floc sh x2)
- in
- self
-and module_expr floc sh =
- let rec self =
- function
- MeAcc (loc, x1, x2) -> MeAcc (floc loc, self x1, self x2)
- | MeApp (loc, x1, x2) -> MeApp (floc loc, self x1, self x2)
- | MeFun (loc, x1, x2, x3) ->
- MeFun (floc loc, x1, module_type floc sh x2, self x3)
- | MeStr (loc, x1) -> MeStr (floc loc, List.map (str_item floc sh) x1)
- | MeTyc (loc, x1, x2) -> MeTyc (floc loc, self x1, module_type floc sh x2)
- | MeUid (loc, x1) -> MeUid (floc loc, x1)
- in
- self
-and str_item floc sh =
- let rec self =
- function
- StCls (loc, x1) ->
- StCls (floc loc, List.map (class_infos class_expr floc sh) x1)
- | StClt (loc, x1) ->
- StClt (floc loc, List.map (class_infos class_type floc sh) x1)
- | StDcl (loc, x1) -> StDcl (floc loc, List.map self x1)
- | StDir (loc, x1, x2) -> StDir (floc loc, x1, x2)
- | StExc (loc, x1, x2, x3) ->
- StExc (floc loc, x1, List.map (ctyp floc sh) x2, x3)
- | StExp (loc, x1) -> StExp (floc loc, expr floc sh x1)
- | StExt (loc, x1, x2, x3) -> StExt (floc loc, x1, ctyp floc sh x2, x3)
- | StInc (loc, x1) -> StInc (floc loc, module_expr floc sh x1)
- | StMod (loc, x1, x2) -> StMod (floc loc, x1, module_expr floc sh x2)
- | StRecMod (loc, nmtmes) ->
- StRecMod
- (floc loc,
- List.map
- (fun (n, mt, me) ->
- n, module_type floc sh mt, module_expr floc sh me)
- nmtmes)
- | StMty (loc, x1, x2) -> StMty (floc loc, x1, module_type floc sh x2)
- | StOpn (loc, x1) -> StOpn (floc loc, x1)
- | StTyp (loc, x1) ->
- StTyp
- (floc loc,
- List.map
- (fun ((loc, x1), x2, x3, x4) ->
- (floc loc, x1), x2, ctyp floc sh x3,
- List.map (fun (x1, x2) -> ctyp floc sh x1, ctyp floc sh x2)
- x4)
- x1)
- | StUse (loc, x1, x2) -> StUse (loc, x1, x2)
- | StVal (loc, x1, x2) ->
- StVal
- (floc loc, x1,
- List.map (fun (x1, x2) -> patt floc sh x1, expr floc sh x2) x2)
- in
- self
-and class_type floc sh =
- let rec self =
- function
- CtCon (loc, x1, x2) -> CtCon (floc loc, x1, List.map (ctyp floc sh) x2)
- | CtFun (loc, x1, x2) -> CtFun (floc loc, ctyp floc sh x1, self x2)
- | CtSig (loc, x1, x2) ->
- CtSig
- (floc loc, option_map (ctyp floc sh) x1,
- List.map (class_sig_item floc sh) x2)
- in
- self
-and class_sig_item floc sh =
- let rec self =
- function
- CgCtr (loc, x1, x2) ->
- CgCtr (floc loc, ctyp floc sh x1, ctyp floc sh x2)
- | CgDcl (loc, x1) ->
- CgDcl (floc loc, List.map (class_sig_item floc sh) x1)
- | CgInh (loc, x1) -> CgInh (floc loc, class_type floc sh x1)
- | CgMth (loc, x1, x2, x3) -> CgMth (floc loc, x1, x2, ctyp floc sh x3)
- | CgVal (loc, x1, x2, x3) -> CgVal (floc loc, x1, x2, ctyp floc sh x3)
- | CgVir (loc, x1, x2, x3) -> CgVir (floc loc, x1, x2, ctyp floc sh x3)
- in
- self
-and class_expr floc sh =
- let rec self =
- function
- CeApp (loc, x1, x2) -> CeApp (floc loc, self x1, expr floc sh x2)
- | CeCon (loc, x1, x2) -> CeCon (floc loc, x1, List.map (ctyp floc sh) x2)
- | CeFun (loc, x1, x2) -> CeFun (floc loc, patt floc sh x1, self x2)
- | CeLet (loc, x1, x2, x3) ->
- CeLet
- (floc loc, x1,
- List.map (fun (x1, x2) -> patt floc sh x1, expr floc sh x2) x2,
- self x3)
- | CeStr (loc, x1, x2) ->
- CeStr
- (floc loc, option_map (patt floc sh) x1,
- List.map (class_str_item floc sh) x2)
- | CeTyc (loc, x1, x2) -> CeTyc (floc loc, self x1, class_type floc sh x2)
- in
- self
-and class_str_item floc sh =
- let rec self =
- function
- CrCtr (loc, x1, x2) ->
- CrCtr (floc loc, ctyp floc sh x1, ctyp floc sh x2)
- | CrDcl (loc, x1) ->
- CrDcl (floc loc, List.map (class_str_item floc sh) x1)
- | CrInh (loc, x1, x2) -> CrInh (floc loc, class_expr floc sh x1, x2)
- | CrIni (loc, x1) -> CrIni (floc loc, expr floc sh x1)
- | CrMth (loc, x1, x2, x3, x4) ->
- CrMth
- (floc loc, x1, x2, expr floc sh x3, option_map (ctyp floc sh) x4)
- | CrVal (loc, x1, x2, x3) -> CrVal (floc loc, x1, x2, expr floc sh x3)
- | CrVir (loc, x1, x2, x3) -> CrVir (floc loc, x1, x2, ctyp floc sh x3)
- in
- self
-;;
diff --git a/camlp4/ocaml_src/camlp4/reloc.mli b/camlp4/ocaml_src/camlp4/reloc.mli
deleted file mode 100644
index 21018b52af..0000000000
--- a/camlp4/ocaml_src/camlp4/reloc.mli
+++ /dev/null
@@ -1,16 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1998 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-val patt : (MLast.loc -> MLast.loc) -> int -> MLast.patt -> MLast.patt;;
-val expr : (MLast.loc -> MLast.loc) -> int -> MLast.expr -> MLast.expr;;
diff --git a/camlp4/ocaml_src/camlp4/spretty.ml b/camlp4/ocaml_src/camlp4/spretty.ml
deleted file mode 100644
index ada592b604..0000000000
--- a/camlp4/ocaml_src/camlp4/spretty.ml
+++ /dev/null
@@ -1,465 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-type glue =
- LO
- | RO
- | LR
- | NO
-;;
-type pretty =
- S of glue * string
- | Hbox of pretty Stream.t
- | HVbox of pretty Stream.t
- | HOVbox of pretty Stream.t
- | HOVCbox of pretty Stream.t
- | Vbox of pretty Stream.t
- | BEbox of pretty Stream.t
- | BEVbox of pretty Stream.t
- | LocInfo of (int * int) * pretty
-;;
-type prettyL =
- SL of int * glue * string
- | HL of prettyL list
- | BL of prettyL list
- | PL of prettyL list
- | QL of prettyL list
- | VL of prettyL list
- | BE of prettyL list
- | BV of prettyL list
- | LI of (string * int * int) * prettyL
-;;
-type getcomm = int -> int -> string * int * int * int;;
-
-let quiet = ref true;;
-let maxl = ref 20;;
-let dt = ref 2;;
-let tol = ref 1;;
-let sp = ref ' ';;
-let last_ep = ref 0;;
-let getcomm = ref (fun _ _ -> "", 0, 0, 0);;
-let prompt = ref "";;
-let print_char_fun = ref (output_char stdout);;
-let print_string_fun = ref (output_string stdout);;
-let print_newline_fun = ref (fun () -> output_char stdout '\n');;
-let lazy_tab = ref (-1);;
-
-let flush_tab () =
- if !lazy_tab >= 0 then
- begin
- !print_newline_fun ();
- !print_string_fun !prompt;
- for i = 1 to !lazy_tab do !print_char_fun !sp done;
- lazy_tab := -1
- end
-;;
-let print_newline_and_tab tab = lazy_tab := tab;;
-let print_char c = flush_tab (); !print_char_fun c;;
-let print_string s = flush_tab (); !print_string_fun s;;
-
-let rec print_spaces nsp = for i = 1 to nsp do print_char !sp done;;
-
-let end_with_tab s =
- let rec loop i =
- if i >= 0 then if s.[i] = ' ' then loop (i - 1) else s.[i] = '\n'
- else false
- in
- loop (String.length s - 1)
-;;
-
-let print_comment tab s nl_bef tab_bef empty_stmt =
- if s = "" then ()
- else
- let (tab_aft, i_bef_tab) =
- let rec loop tab_aft i =
- if i >= 0 && s.[i] = ' ' then loop (tab_aft + 1) (i - 1)
- else tab_aft, i
- in
- loop 0 (String.length s - 1)
- in
- let tab_bef = if nl_bef > 0 then tab_bef else tab in
- let len = if empty_stmt then i_bef_tab else String.length s in
- let rec loop i =
- if i = len then ()
- else
- begin
- !print_char_fun s.[i];
- let i =
- if s.[i] = '\n' && (i + 1 = len || s.[i + 1] <> '\n') then
- let delta_ind =
- if i = i_bef_tab then tab - tab_aft else tab - tab_bef
- in
- if delta_ind >= 0 then
- begin
- for i = 1 to delta_ind do !print_char_fun ' ' done; i + 1
- end
- else
- let rec loop cnt i =
- if cnt = 0 then i
- else if i = len then i
- else if s.[i] = ' ' then loop (cnt + 1) (i + 1)
- else i
- in
- loop delta_ind (i + 1)
- else i + 1
- in
- loop i
- end
- in
- loop 0
-;;
-
-let string_np pos np = pos + np;;
-
-let trace_ov pos =
- if not !quiet && pos > !maxl then
- begin
- prerr_string "<W> prettych: overflow (length = ";
- prerr_int pos;
- prerr_endline ")"
- end
-;;
-
-let tolerate tab pos spc = pos + spc <= tab + !dt + !tol;;
-
-let h_print_string pos spc np x =
- let npos = string_np (pos + spc) np in
- print_spaces spc; print_string x; npos
-;;
-
-let n_print_string pos spc np x =
- print_spaces spc; print_string x; string_np (pos + spc) np
-;;
-
-let rec hnps (pos, spc as ps) =
- function
- SL (np, RO, _) -> string_np pos np, 1
- | SL (np, LO, _) -> string_np (pos + spc) np, 0
- | SL (np, NO, _) -> string_np pos np, 0
- | SL (np, LR, _) -> string_np (pos + spc) np, 1
- | HL x -> hnps_list ps x
- | BL x -> hnps_list ps x
- | PL x -> hnps_list ps x
- | QL x -> hnps_list ps x
- | VL [x] -> hnps ps x
- | VL [] -> ps
- | VL x -> !maxl + 1, 0
- | BE x -> hnps_list ps x
- | BV x -> !maxl + 1, 0
- | LI (_, x) -> hnps ps x
-and hnps_list (pos, _ as ps) pl =
- if pos > !maxl then !maxl + 1, 0
- else
- match pl with
- p :: pl -> hnps_list (hnps ps p) pl
- | [] -> ps
-;;
-
-let rec first =
- function
- SL (_, _, s) -> Some s
- | HL x -> first_in_list x
- | BL x -> first_in_list x
- | PL x -> first_in_list x
- | QL x -> first_in_list x
- | VL x -> first_in_list x
- | BE x -> first_in_list x
- | BV x -> first_in_list x
- | LI (_, x) -> first x
-and first_in_list =
- function
- p :: pl ->
- begin match first p with
- Some p -> Some p
- | None -> first_in_list pl
- end
- | [] -> None
-;;
-
-let first_is_too_big tab p =
- match first p with
- Some s -> tab + String.length s >= !maxl
- | None -> false
-;;
-
-let too_long tab x p =
- if first_is_too_big tab p then false
- else let (pos, spc) = hnps x p in pos > !maxl
-;;
-
-let rec has_comment =
- function
- LI ((comm, nl_bef, tab_bef), x) :: pl ->
- comm <> "" || has_comment (x :: pl)
- | (HL x | BL x | PL x | QL x | VL x | BE x | BV x) :: pl ->
- has_comment x || has_comment pl
- | SL (_, _, _) :: pl -> has_comment pl
- | [] -> false
-;;
-
-let rec hprint_pretty tab pos spc =
- function
- SL (np, RO, x) -> h_print_string pos 0 np x, 1
- | SL (np, LO, x) -> h_print_string pos spc np x, 0
- | SL (np, NO, x) -> h_print_string pos 0 np x, 0
- | SL (np, LR, x) -> h_print_string pos spc np x, 1
- | HL x -> hprint_box tab pos spc x
- | BL x -> hprint_box tab pos spc x
- | PL x -> hprint_box tab pos spc x
- | QL x -> hprint_box tab pos spc x
- | VL [x] -> hprint_pretty tab pos spc x
- | VL [] -> pos, spc
- | VL x -> hprint_box tab pos spc x
- | BE x -> hprint_box tab pos spc x
- | BV x -> hprint_box tab pos spc x
- | LI ((comm, nl_bef, tab_bef), x) ->
- if !lazy_tab >= 0 then
- begin
- for i = 2 to nl_bef do !print_char_fun '\n' done; flush_tab ()
- end;
- print_comment tab comm nl_bef tab_bef false;
- hprint_pretty tab pos spc x
-and hprint_box tab pos spc =
- function
- p :: pl ->
- let (pos, spc) = hprint_pretty tab pos spc p in
- hprint_box tab pos spc pl
- | [] -> pos, spc
-;;
-
-let rec print_pretty tab pos spc =
- function
- SL (np, RO, x) -> n_print_string pos 0 np x, 1
- | SL (np, LO, x) -> n_print_string pos spc np x, 0
- | SL (np, NO, x) -> n_print_string pos 0 np x, 0
- | SL (np, LR, x) -> n_print_string pos spc np x, 1
- | HL x as p -> print_horiz tab pos spc x
- | BL x as p -> print_horiz_vertic tab pos spc (too_long tab (pos, spc) p) x
- | PL x as p -> print_paragraph tab pos spc (too_long tab (pos, spc) p) x
- | QL x as p -> print_sparagraph tab pos spc (too_long tab (pos, spc) p) x
- | VL x -> print_vertic tab pos spc x
- | BE x as p -> print_begin_end tab pos spc (too_long tab (pos, spc) p) x
- | BV x -> print_beg_end tab pos spc x
- | LI ((comm, nl_bef, tab_bef), x) ->
- if !lazy_tab >= 0 then
- begin
- for i = 2 to nl_bef do !print_char_fun '\n' done;
- if comm <> "" && nl_bef = 0 then
- for i = 1 to tab_bef do !print_char_fun ' ' done
- else if comm = "" && x = BL [] then lazy_tab := -1
- else flush_tab ()
- end;
- print_comment tab comm nl_bef tab_bef (x = BL []);
- if comm <> "" && nl_bef = 0 then
- if end_with_tab comm then lazy_tab := -1 else flush_tab ();
- print_pretty tab pos spc x
-and print_horiz tab pos spc =
- function
- p :: pl ->
- let (npos, nspc) = print_pretty tab pos spc p in
- if match pl with
- [] -> true
- | _ -> false
- then
- npos, nspc
- else print_horiz tab npos nspc pl
- | [] -> pos, spc
-and print_horiz_vertic tab pos spc ov pl =
- if ov || has_comment pl then print_vertic tab pos spc pl
- else hprint_box tab pos spc pl
-and print_vertic tab pos spc =
- function
- p :: pl ->
- let (npos, nspc) = print_pretty tab pos spc p in
- if match pl with
- [] -> true
- | _ -> false
- then
- npos, nspc
- else if tolerate tab npos nspc then
- begin print_spaces nspc; print_vertic_rest (npos + nspc) pl end
- else
- begin
- print_newline_and_tab (tab + !dt); print_vertic_rest (tab + !dt) pl
- end
- | [] -> pos, spc
-and print_vertic_rest tab =
- function
- p :: pl ->
- let (pos, spc) = print_pretty tab tab 0 p in
- if match pl with
- [] -> true
- | _ -> false
- then
- pos, spc
- else begin print_newline_and_tab tab; print_vertic_rest tab pl end
- | [] -> tab, 0
-and print_paragraph tab pos spc ov pl =
- if has_comment pl then print_vertic tab pos spc pl
- else if ov then print_parag tab pos spc pl
- else hprint_box tab pos spc pl
-and print_parag tab pos spc =
- function
- p :: pl ->
- let (npos, nspc) = print_pretty tab pos spc p in
- if match pl with
- [] -> true
- | _ -> false
- then
- npos, nspc
- else if npos == tab then print_parag_rest tab tab 0 pl
- else if too_long tab (pos, spc) p then
- begin
- print_newline_and_tab (tab + !dt);
- print_parag_rest (tab + !dt) (tab + !dt) 0 pl
- end
- else if tolerate tab npos nspc then
- begin
- print_spaces nspc; print_parag_rest (npos + nspc) (npos + nspc) 0 pl
- end
- else print_parag_rest (tab + !dt) npos nspc pl
- | [] -> pos, spc
-and print_parag_rest tab pos spc =
- function
- p :: pl ->
- let (pos, spc) =
- if pos > tab && too_long tab (pos, spc) p then
- begin print_newline_and_tab tab; tab, 0 end
- else pos, spc
- in
- let (npos, nspc) = print_pretty tab pos spc p in
- if match pl with
- [] -> true
- | _ -> false
- then
- npos, nspc
- else
- let (pos, spc) =
- if npos > tab && too_long tab (pos, spc) p then
- begin print_newline_and_tab tab; tab, 0 end
- else npos, nspc
- in
- print_parag_rest tab pos spc pl
- | [] -> pos, spc
-and print_sparagraph tab pos spc ov pl =
- if has_comment pl then print_vertic tab pos spc pl
- else if ov then print_sparag tab pos spc pl
- else hprint_box tab pos spc pl
-and print_sparag tab pos spc =
- function
- p :: pl ->
- let (npos, nspc) = print_pretty tab pos spc p in
- if match pl with
- [] -> true
- | _ -> false
- then
- npos, nspc
- else if tolerate tab npos nspc then
- begin
- print_spaces nspc;
- print_sparag_rest (npos + nspc) (npos + nspc) 0 pl
- end
- else print_sparag_rest (tab + !dt) npos nspc pl
- | [] -> pos, spc
-and print_sparag_rest tab pos spc =
- function
- p :: pl ->
- let (pos, spc) =
- if pos > tab && too_long tab (pos, spc) p then
- begin print_newline_and_tab tab; tab, 0 end
- else pos, spc
- in
- let (npos, nspc) = print_pretty tab pos spc p in
- if match pl with
- [] -> true
- | _ -> false
- then
- npos, nspc
- else print_sparag_rest tab npos nspc pl
- | [] -> pos, spc
-and print_begin_end tab pos spc ov pl =
- if ov || has_comment pl then print_beg_end tab pos spc pl
- else hprint_box tab pos spc pl
-and print_beg_end tab pos spc =
- function
- p :: pl ->
- let (npos, nspc) = print_pretty tab pos spc p in
- if match pl with
- [] -> true
- | _ -> false
- then
- npos, nspc
- else if tolerate tab npos nspc then
- let nspc = if npos == tab then nspc + !dt else nspc in
- print_spaces nspc; print_beg_end_rest tab (npos + nspc) pl
- else
- begin
- print_newline_and_tab (tab + !dt);
- print_beg_end_rest tab (tab + !dt) pl
- end
- | [] -> pos, spc
-and print_beg_end_rest tab pos =
- function
- p :: pl ->
- let (pos, spc) = print_pretty (tab + !dt) pos 0 p in
- if match pl with
- [] -> true
- | _ -> false
- then
- pos, spc
- else begin print_newline_and_tab tab; print_beg_end_rest tab tab pl end
- | [] -> pos, 0
-;;
-
-let string_npos s = String.length s;;
-
-let rec conv =
- function
- S (g, s) -> SL (string_npos s, g, s)
- | Hbox x -> HL (conv_stream x)
- | HVbox x -> BL (conv_stream x)
- | HOVbox x ->
- begin match conv_stream x with
- [PL _ as x] -> x
- | x -> PL x
- end
- | HOVCbox x -> QL (conv_stream x)
- | Vbox x -> VL (conv_stream x)
- | BEbox x -> BE (conv_stream x)
- | BEVbox x -> BV (conv_stream x)
- | LocInfo ((bp, ep), x) ->
- let (comm, nl_bef, tab_bef, cnt) =
- let len = bp - !last_ep in
- if len > 0 then !getcomm !last_ep len else "", 0, 0, 0
- in
- last_ep := !last_ep + cnt;
- let v = conv x in
- last_ep := max ep !last_ep; LI ((comm, nl_bef, tab_bef), v)
-and conv_stream (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some p -> Stream.junk strm__; let x = conv p in x :: conv_stream strm__
- | _ -> []
-;;
-
-let print_pretty pr_ch pr_str pr_nl pr pr2 m lf bp p =
- maxl := m;
- print_char_fun := pr_ch;
- print_string_fun := pr_str;
- print_newline_fun := pr_nl;
- prompt := pr2;
- getcomm := lf;
- last_ep := bp;
- print_string pr;
- let _ = print_pretty 0 0 0 (conv p) in ()
-;;
diff --git a/camlp4/ocaml_src/camlp4/spretty.mli b/camlp4/ocaml_src/camlp4/spretty.mli
deleted file mode 100644
index 5c62d3f6cd..0000000000
--- a/camlp4/ocaml_src/camlp4/spretty.mli
+++ /dev/null
@@ -1,59 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1998 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-(* Hbox: horizontal box
- HVbox: horizontal-vertical box
- HOVbox and HOVCbox: fill maximum of elements horizontally, line by line;
- in HOVbox, if an element has to be displayed vertically (need several
- lines), the next element is displayed next line; in HOVCbox, this next
- element may be displayed same line if it holds.
- Vbox: vertical box
- BEbox: begin-end box: horizontal or 2nd element indented, 3rd element not
- BEVbox: begin-end box always vertical
- LocInfo: call back with location to allow inserting comments *)
-
-(* In case of box displayed vertically, 2nd line and following are indented
- by dt.val spaces, except if first element of the box is empty: to not
- indent, put HVbox [: :] as first element *)
-
-type glue =
- LO
- | RO
- | LR
- | NO
-;;
-type pretty =
- S of glue * string
- | Hbox of pretty Stream.t
- | HVbox of pretty Stream.t
- | HOVbox of pretty Stream.t
- | HOVCbox of pretty Stream.t
- | Vbox of pretty Stream.t
- | BEbox of pretty Stream.t
- | BEVbox of pretty Stream.t
- | LocInfo of (int * int) * pretty
-;;
-type getcomm = int -> int -> string * int * int * int;;
-
-val print_pretty :
- (char -> unit) -> (string -> unit) -> (unit -> unit) -> string -> string ->
- int -> getcomm -> int -> pretty -> unit;;
-val quiet : bool ref;;
-
-val dt : int ref;;
-
-(*--*)
-
-val tol : int ref;;
-val sp : char ref;;
diff --git a/camlp4/ocaml_src/lib/.depend b/camlp4/ocaml_src/lib/.depend
deleted file mode 100644
index 0d5adc691f..0000000000
--- a/camlp4/ocaml_src/lib/.depend
+++ /dev/null
@@ -1,20 +0,0 @@
-extfold.cmi: gramext.cmi
-gramext.cmi: token.cmi
-grammar.cmi: gramext.cmi token.cmi
-plexer.cmi: token.cmi
-extfold.cmo: gramext.cmi grammar.cmi extfold.cmi
-extfold.cmx: gramext.cmx grammar.cmx extfold.cmi
-extfun.cmo: extfun.cmi
-extfun.cmx: extfun.cmi
-fstream.cmo: fstream.cmi
-fstream.cmx: fstream.cmi
-gramext.cmo: token.cmi gramext.cmi
-gramext.cmx: token.cmx gramext.cmi
-grammar.cmo: gramext.cmi stdpp.cmi token.cmi grammar.cmi
-grammar.cmx: gramext.cmx stdpp.cmx token.cmx grammar.cmi
-plexer.cmo: stdpp.cmi token.cmi plexer.cmi
-plexer.cmx: stdpp.cmx token.cmx plexer.cmi
-stdpp.cmo: stdpp.cmi
-stdpp.cmx: stdpp.cmi
-token.cmo: token.cmi
-token.cmx: token.cmi
diff --git a/camlp4/ocaml_src/lib/Makefile b/camlp4/ocaml_src/lib/Makefile
deleted file mode 100644
index e19e52052b..0000000000
--- a/camlp4/ocaml_src/lib/Makefile
+++ /dev/null
@@ -1,48 +0,0 @@
-# This file has been generated by program: do not edit!
-
-include ../../config/Makefile
-
-INCLUDES=
-OCAMLCFLAGS=-warn-error A $(INCLUDES)
-OBJS=stdpp.cmo token.cmo plexer.cmo gramext.cmo grammar.cmo extfold.cmo extfun.cmo fstream.cmo
-SHELL=/bin/sh
-TARGET=gramlib.cma
-
-all: $(TARGET)
-opt: $(TARGET:.cma=.cmxa)
-
-$(TARGET): $(OBJS)
- $(OCAMLC) $(OBJS) -a -o $(TARGET)
-
-$(TARGET:.cma=.cmxa): $(OBJS:.cmo=.cmx)
- $(OCAMLOPT) $(OBJS:.cmo=.cmx) -a -o $(TARGET:.cma=.cmxa)
-
-clean::
- rm -f *.cm[ioax] *.cmxa *.pp[io] *.$(O) *.$(A) *.bak .*.bak $(TARGET)
-
-depend:
- cp .depend .depend.bak
- > .depend
- @for i in *.mli *.ml; do \
- ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i >> .depend; \
- done
-
-promote:
- cp $(OBJS) $(OBJS:.cmo=.cmi) ../../boot/.
-
-compare:
- @for j in $(OBJS) $(OBJS:.cmo=.cmi); do \
- if cmp $$j ../../boot/$$j; then :; else exit 1; fi; \
- done
-
-install:
- -$(MKDIR) "$(LIBDIR)/camlp4"
- cp $(TARGET) *.mli "$(LIBDIR)/camlp4/."
- cp *.cmi "$(LIBDIR)/camlp4/."
- if test -f $(TARGET:.cma=.cmxa); then $(MAKE) installopt LIBDIR="$(LIBDIR)"; fi
-
-installopt:
- cp $(TARGET:.cma=.cmxa) *.cmx "$(LIBDIR)/camlp4/."
- tar cf - $(TARGET:.cma=.$(A)) | (cd "$(LIBDIR)/camlp4/."; tar xf -)
-
-include .depend
diff --git a/camlp4/ocaml_src/lib/Makefile.Mac b/camlp4/ocaml_src/lib/Makefile.Mac
deleted file mode 100644
index 2fc15c630d..0000000000
--- a/camlp4/ocaml_src/lib/Makefile.Mac
+++ /dev/null
@@ -1,46 +0,0 @@
-#######################################################################
-# #
-# Camlp4 #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. Distributed only by permission. #
-# #
-#######################################################################
-
-# This file has been generated by program: do not edit!
-
-INCLUDES =
-OCAMLCFLAGS = {INCLUDES}
-OBJS = stdpp.cmo token.cmo plexer.cmo gramext.cmo grammar.cmo extfun.cmo fstream.cmo
-INTF = stdpp.cmi token.cmi plexer.cmi gramext.cmi grammar.cmi extfun.cmi fstream.cmi
-TARGETS = gramlib.cma
-
-all Ä {TARGETS}
-
-{TARGETS} Ä {OBJS}
- {OCAMLC} {OBJS} -a -o {TARGETS}
-
-steal Ä
-
-compare_stolen Ä
-
-clean ÄÄ
- delete -i {TARGETS}
-
-{dependrule}
-
-promote Ä
- duplicate -y {OBJS} {INTF} :::boot:
-
-compare Ä
- for i in {OBJS} {INTF}
- equal -s :::boot:{i} || exit 1
- end
-
-install Ä
- (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null
- duplicate -y {TARGETS} Å.mli Å.cmi "{P4LIBDIR}"
-
-{defrules}
diff --git a/camlp4/ocaml_src/lib/Makefile.Mac.depend b/camlp4/ocaml_src/lib/Makefile.Mac.depend
deleted file mode 100644
index 8d12e3e08a..0000000000
--- a/camlp4/ocaml_src/lib/Makefile.Mac.depend
+++ /dev/null
@@ -1,13 +0,0 @@
-gramext.cmoÄ token.cmi gramext.cmi
-gramext.cmxÄ token.cmx gramext.cmi
-gramext.cmiÄ token.cmi
-grammar.cmoÄ gramext.cmi stdpp.cmi token.cmi grammar.cmi
-grammar.cmxÄ gramext.cmx stdpp.cmx token.cmx grammar.cmi
-grammar.cmiÄ gramext.cmi token.cmi
-plexer.cmoÄ stdpp.cmi token.cmi plexer.cmi
-plexer.cmxÄ stdpp.cmx token.cmx plexer.cmi
-plexer.cmiÄ token.cmi
-stdpp.cmoÄ stdpp.cmi
-stdpp.cmxÄ stdpp.cmi
-token.cmoÄ token.cmi
-token.cmxÄ token.cmi
diff --git a/camlp4/ocaml_src/lib/extfold.ml b/camlp4/ocaml_src/lib/extfold.ml
deleted file mode 100644
index 0411497f02..0000000000
--- a/camlp4/ocaml_src/lib/extfold.ml
+++ /dev/null
@@ -1,124 +0,0 @@
-(* camlp4r *)
-(* This file has been generated by program: do not edit! *)
-
-type ('te, 'a, 'b) t =
- 'te Gramext.g_entry -> 'te Gramext.g_symbol list -> ('te Stream.t -> 'a) ->
- 'te Stream.t -> 'b
-;;
-
-type ('te, 'a, 'b) tsep =
- 'te Gramext.g_entry -> 'te Gramext.g_symbol list -> ('te Stream.t -> 'a) ->
- ('te Stream.t -> unit) -> 'te Stream.t -> 'b
-;;
-
-let gen_fold0 final f e entry symbl psymb =
- let rec fold accu (strm__ : _ Stream.t) =
- match
- try Some (psymb strm__) with
- Stream.Failure -> None
- with
- Some a -> fold (f a accu) strm__
- | _ -> accu
- in
- fun (strm__ : _ Stream.t) -> let a = fold e strm__ in final a
-;;
-
-let gen_fold1 final f e entry symbl psymb =
- let rec fold accu (strm__ : _ Stream.t) =
- match
- try Some (psymb strm__) with
- Stream.Failure -> None
- with
- Some a -> fold (f a accu) strm__
- | _ -> accu
- in
- fun (strm__ : _ Stream.t) ->
- let a = psymb strm__ in
- let a =
- try fold (f a e) strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- final a
-;;
-
-let gen_fold0sep final f e entry symbl psymb psep =
- let failed =
- function
- [symb; sep] -> Grammar.symb_failed_txt entry sep symb
- | _ -> "failed"
- in
- let rec kont accu (strm__ : _ Stream.t) =
- match
- try Some (psep strm__) with
- Stream.Failure -> None
- with
- Some v ->
- let a =
- try psymb strm__ with
- Stream.Failure -> raise (Stream.Error (failed symbl))
- in
- kont (f a accu) strm__
- | _ -> accu
- in
- fun (strm__ : _ Stream.t) ->
- match
- try Some (psymb strm__) with
- Stream.Failure -> None
- with
- Some a -> final (kont (f a e) strm__)
- | _ -> e
-;;
-
-let gen_fold1sep final f e entry symbl psymb psep =
- let failed =
- function
- [symb; sep] -> Grammar.symb_failed_txt entry sep symb
- | _ -> "failed"
- in
- let parse_top =
- function
- [symb; _] -> Grammar.parse_top_symb entry symb
- | _ -> raise Stream.Failure
- in
- let rec kont accu (strm__ : _ Stream.t) =
- match
- try Some (psep strm__) with
- Stream.Failure -> None
- with
- Some v ->
- let a =
- try
- try psymb strm__ with
- Stream.Failure ->
- let a =
- try parse_top symbl strm__ with
- Stream.Failure -> raise (Stream.Error (failed symbl))
- in
- Obj.magic a
- with
- Stream.Failure -> raise (Stream.Error "")
- in
- kont (f a accu) strm__
- | _ -> accu
- in
- fun (strm__ : _ Stream.t) ->
- let a = psymb strm__ in final (kont (f a e) strm__)
-;;
-
-let sfold0 f e = gen_fold0 (fun x -> x) f e;;
-let sfold1 f e = gen_fold1 (fun x -> x) f e;;
-let sfold0sep f e = gen_fold0sep (fun x -> x) f e;;
-let sfold1sep f e = gen_fold1sep (fun x -> x) f e;;
-
-let cons x y = x :: y;;
-let nil = [];;
-
-let slist0 entry = gen_fold0 List.rev cons nil entry;;
-let slist1 entry = gen_fold1 List.rev cons nil entry;;
-let slist0sep entry = gen_fold0sep List.rev cons nil entry;;
-let slist1sep entry = gen_fold1sep List.rev cons nil entry;;
-
-let sopt entry symbl psymb (strm__ : _ Stream.t) =
- try Some (psymb strm__) with
- Stream.Failure -> None
-;;
diff --git a/camlp4/ocaml_src/lib/extfold.mli b/camlp4/ocaml_src/lib/extfold.mli
deleted file mode 100644
index cb2824fb1d..0000000000
--- a/camlp4/ocaml_src/lib/extfold.mli
+++ /dev/null
@@ -1,24 +0,0 @@
-(* camlp4r *)
-(* This file has been generated by program: do not edit! *)
-
-type ('te, 'a, 'b) t =
- 'te Gramext.g_entry -> 'te Gramext.g_symbol list -> ('te Stream.t -> 'a) ->
- 'te Stream.t -> 'b
-;;
-
-type ('te, 'a, 'b) tsep =
- 'te Gramext.g_entry -> 'te Gramext.g_symbol list -> ('te Stream.t -> 'a) ->
- ('te Stream.t -> unit) -> 'te Stream.t -> 'b
-;;
-
-val sfold0 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) t;;
-val sfold1 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) t;;
-val sfold0sep : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) tsep;;
-val sfold1sep : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) tsep;;
-
-val slist0 : (_, 'a, 'a list) t;;
-val slist1 : (_, 'a, 'a list) t;;
-val slist0sep : (_, 'a, 'a list) tsep;;
-val slist1sep : (_, 'a, 'a list) tsep;;
-
-val sopt : (_, 'a, 'a option) t;;
diff --git a/camlp4/ocaml_src/lib/extfun.ml b/camlp4/ocaml_src/lib/extfun.ml
deleted file mode 100644
index f8a6b26ac5..0000000000
--- a/camlp4/ocaml_src/lib/extfun.ml
+++ /dev/null
@@ -1,105 +0,0 @@
-(* camlp4r *)
-(* This file has been generated by program: do not edit! *)
-(* Copyright 2001 INRIA *)
-
-(* Extensible Functions *)
-
-type ('a, 'b) t = ('a, 'b) matching list
-and ('a, 'b) matching = { patt : patt; has_when : bool; expr : ('a, 'b) expr }
-and patt =
- Eapp of patt list
- | Eacc of patt list
- | Econ of string
- | Estr of string
- | Eint of string
- | Etup of patt list
- | Evar of unit
-and ('a, 'b) expr = 'a -> 'b option
-;;
-
-exception Failure;;
-
-let empty = [];;
-
-(*** Apply ***)
-
-let rec apply_matchings a =
- function
- m :: ml ->
- begin match m.expr a with
- None -> apply_matchings a ml
- | x -> x
- end
- | [] -> None
-;;
-
-let apply ef a =
- match apply_matchings a ef with
- Some x -> x
- | None -> raise Failure
-;;
-
-(*** Trace ***)
-
-let rec list_iter_sep f s =
- function
- [] -> ()
- | [x] -> f x
- | x :: l -> f x; s (); list_iter_sep f s l
-;;
-
-let rec print_patt =
- function
- Eapp pl -> list_iter_sep print_patt2 (fun () -> print_string " ") pl
- | p -> print_patt2 p
-and print_patt2 =
- function
- Eacc pl -> list_iter_sep print_patt1 (fun () -> print_string ".") pl
- | p -> print_patt1 p
-and print_patt1 =
- function
- Econ s -> print_string s
- | Estr s -> print_string "\""; print_string s; print_string "\""
- | Eint s -> print_string s
- | Evar () -> print_string "_"
- | Etup pl ->
- print_string "(";
- list_iter_sep print_patt (fun () -> print_string ", ") pl;
- print_string ")"
- | Eapp _ | Eacc _ as p -> print_string "("; print_patt p; print_string ")"
-;;
-
-let print ef =
- List.iter
- (fun m ->
- print_patt m.patt;
- if m.has_when then print_string " when ...";
- print_newline ())
- ef
-;;
-
-(*** Extension ***)
-
-let insert_matching matchings (patt, has_when, expr) =
- let m1 = {patt = patt; has_when = has_when; expr = expr} in
- let rec loop =
- function
- m :: ml as gml ->
- if m1.has_when && not m.has_when then m1 :: gml
- else if not m1.has_when && m.has_when then m :: loop ml
- else
- let c = compare m1.patt m.patt in
- if c < 0 then m1 :: gml
- else if c > 0 then m :: loop ml
- else if m.has_when then m1 :: gml
- else m1 :: ml
- | [] -> [m1]
- in
- loop matchings
-;;
-
-(* available extension function *)
-
-let extend ef matchings_def =
- List.fold_left insert_matching ef matchings_def
-;;
diff --git a/camlp4/ocaml_src/lib/extfun.mli b/camlp4/ocaml_src/lib/extfun.mli
deleted file mode 100644
index 2d42fe2e84..0000000000
--- a/camlp4/ocaml_src/lib/extfun.mli
+++ /dev/null
@@ -1,37 +0,0 @@
-(* camlp4r *)
-(* This file has been generated by program: do not edit! *)
-
-(** Extensible functions.
-
- This module implements pattern matching extensible functions.
- To extend, use syntax [pa_extfun.cmo]:
-
- [extfun e with [ pattern_matching ]] *)
-
-type ('a, 'b) t;;
- (** The type of the extensible functions of type ['a -> 'b] *)
-val empty : ('a, 'b) t;;
- (** Empty extensible function *)
-val apply : ('a, 'b) t -> 'a -> 'b;;
- (** Apply an extensible function *)
-exception Failure;;
- (** Match failure while applying an extensible function *)
-val print : ('a, 'b) t -> unit;;
- (** Print patterns in the order they are recorded *)
-
-(**/**)
-
-type ('a, 'b) matching =
- { patt : patt; has_when : bool; expr : ('a, 'b) expr }
-and patt =
- Eapp of patt list
- | Eacc of patt list
- | Econ of string
- | Estr of string
- | Eint of string
- | Etup of patt list
- | Evar of unit
-and ('a, 'b) expr = 'a -> 'b option
-;;
-
-val extend : ('a, 'b) t -> (patt * bool * ('a, 'b) expr) list -> ('a, 'b) t;;
diff --git a/camlp4/ocaml_src/lib/fstream.ml b/camlp4/ocaml_src/lib/fstream.ml
deleted file mode 100644
index 9ffdb71041..0000000000
--- a/camlp4/ocaml_src/lib/fstream.ml
+++ /dev/null
@@ -1,84 +0,0 @@
-(* camlp4r *)
-(* This file has been generated by program: do not edit! *)
-(* Copyright 2001 INRIA *)
-
-type 'a t = { count : int; data : 'a data Lazy.t }
-and 'a data =
- Nil
- | Cons of 'a * 'a t
- | App of 'a t * 'a t
-;;
-
-let from f =
- let rec loop i =
- {count = 0;
- data =
- lazy
- (match f i with
- Some x -> Cons (x, loop (i + 1))
- | None -> Nil)}
- in
- loop 0
-;;
-
-let rec next s =
- let count = s.count + 1 in
- match Lazy.force s.data with
- Nil -> None
- | Cons (a, s) -> Some (a, {count = count; data = s.data})
- | App (s1, s2) ->
- match next s1 with
- Some (a, s1) -> Some (a, {count = count; data = lazy (App (s1, s2))})
- | None ->
- match next s2 with
- Some (a, s2) -> Some (a, {count = count; data = s2.data})
- | None -> None
-;;
-
-let empty s =
- match next s with
- Some _ -> None
- | None -> Some ((), s)
-;;
-
-let nil = {count = 0; data = lazy Nil};;
-let cons a s = Cons (a, s);;
-let app s1 s2 = App (s1, s2);;
-let flazy f = {count = 0; data = Lazy.lazy_from_fun f};;
-
-let of_list l =
- List.fold_right (fun x s -> flazy (fun () -> cons x s)) l nil
-;;
-
-let of_string s =
- from (fun c -> if c < String.length s then Some s.[c] else None)
-;;
-
-let of_channel ic =
- from
- (fun _ ->
- try Some (input_char ic) with
- End_of_file -> None)
-;;
-
-let iter f =
- let rec do_rec strm =
- match next strm with
- Some (a, strm) -> let _ = f a in do_rec strm
- | None -> ()
- in
- do_rec
-;;
-
-let count s = s.count;;
-
-let count_unfrozen s =
- let rec loop cnt s =
- if Lazy.lazy_is_val s.data then
- match Lazy.force s.data with
- Cons (_, s) -> loop (cnt + 1) s
- | _ -> cnt
- else cnt
- in
- loop 0 s
-;;
diff --git a/camlp4/ocaml_src/lib/fstream.mli b/camlp4/ocaml_src/lib/fstream.mli
deleted file mode 100644
index d0e8f8b49c..0000000000
--- a/camlp4/ocaml_src/lib/fstream.mli
+++ /dev/null
@@ -1,60 +0,0 @@
-(* camlp4r *)
-(* This file has been generated by program: do not edit! *)
-
-(* Module [Fstream]: functional streams *)
-
-(* This module implement functional streams.
- To be used with syntax [pa_fstream.cmo]. The syntax is:
-- stream: [fstream [: ... :]]
-- parser: [parser [ [: ... :] -> ... | ... ]]
-
- Functional parsers are of type: [Fstream.t 'a -> option ('a * Fstream.t 'a)]
-
- They have limited backtrack, i.e if a rule fails, the next rule is tested
- with the initial stream; limited because when in case of a rule with two
- consecutive symbols [a] and [b], if [b] fails, the rule fails: there is
- no try with the next rule of [a].
-*)
-
-type 'a t;;
- (* The type of 'a functional streams *)
-val from : (int -> 'a option) -> 'a t;;
- (* [Fstream.from f] returns a stream built from the function [f].
- To create a new stream element, the function [f] is called with
- the current stream count. The user function [f] must return either
- [Some <value>] for a value or [None] to specify the end of the
- stream. *)
-
-val of_list : 'a list -> 'a t;;
- (* Return the stream holding the elements of the list in the same
- order. *)
-val of_string : string -> char t;;
- (* Return the stream of the characters of the string parameter. *)
-val of_channel : in_channel -> char t;;
- (* Return the stream of the characters read from the input channel. *)
-
-val iter : ('a -> unit) -> 'a t -> unit;;
- (* [Fstream.iter f s] scans the whole stream s, applying function [f]
- in turn to each stream element encountered. *)
-
-val next : 'a t -> ('a * 'a t) option;;
- (* Return [Some (a, s)] where [a] is the first element of the stream
- and [s] the remaining stream, or [None] if the stream is empty. *)
-val empty : 'a t -> (unit * 'a t) option;;
- (* Return [Some ((), s)] if the stream is empty where [s] is itself,
- else [None] *)
-val count : 'a t -> int;;
- (* Return the current count of the stream elements, i.e. the number
- of the stream elements discarded. *)
-val count_unfrozen : 'a t -> int;;
- (* Return the number of unfrozen elements in the beginning of the
- stream; useful to determine the position of a parsing error (longuest
- path). *)
-
-(*--*)
-
-val nil : 'a t;;
-type 'a data;;
-val cons : 'a -> 'a t -> 'a data;;
-val app : 'a t -> 'a t -> 'a data;;
-val flazy : (unit -> 'a data) -> 'a t;;
diff --git a/camlp4/ocaml_src/lib/gramext.ml b/camlp4/ocaml_src/lib/gramext.ml
deleted file mode 100644
index 41fdd76c19..0000000000
--- a/camlp4/ocaml_src/lib/gramext.ml
+++ /dev/null
@@ -1,531 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-open Printf;;
-
-type 'te grammar =
- { gtokens : (Token.pattern, int ref) Hashtbl.t;
- mutable glexer : 'te Token.glexer }
-;;
-
-type 'te g_entry =
- { egram : 'te grammar;
- ename : string;
- mutable estart : int -> 'te Stream.t -> Obj.t;
- mutable econtinue : int -> int -> Obj.t -> 'te Stream.t -> Obj.t;
- mutable edesc : 'te g_desc }
-and 'te g_desc =
- Dlevels of 'te g_level list
- | Dparser of ('te Stream.t -> Obj.t)
-and 'te g_level =
- { assoc : g_assoc;
- lname : string option;
- lsuffix : 'te g_tree;
- lprefix : 'te g_tree }
-and g_assoc =
- NonA
- | RightA
- | LeftA
-and 'te g_symbol =
- Smeta of string * 'te g_symbol list * Obj.t
- | Snterm of 'te g_entry
- | Snterml of 'te g_entry * string
- | Slist0 of 'te g_symbol
- | Slist0sep of 'te g_symbol * 'te g_symbol
- | Slist1 of 'te g_symbol
- | Slist1sep of 'te g_symbol * 'te g_symbol
- | Sopt of 'te g_symbol
- | Sself
- | Snext
- | Stoken of Token.pattern
- | Stree of 'te g_tree
-and g_action = Obj.t
-and 'te g_tree =
- Node of 'te g_node
- | LocAct of g_action * g_action list
- | DeadEnd
-and 'te g_node =
- { node : 'te g_symbol; son : 'te g_tree; brother : 'te g_tree }
-;;
-
-type position =
- First
- | Last
- | Before of string
- | After of string
- | Level of string
-;;
-
-let warning_verbose = ref true;;
-
-let rec derive_eps =
- function
- Slist0 _ -> true
- | Slist0sep (_, _) -> true
- | Sopt _ -> true
- | Stree t -> tree_derive_eps t
- | Smeta (_, _, _) | Slist1 _ | Slist1sep (_, _) | Snterm _ |
- Snterml (_, _) | Snext | Sself | Stoken _ ->
- false
-and tree_derive_eps =
- function
- LocAct (_, _) -> true
- | Node {node = s; brother = bro; son = son} ->
- derive_eps s && tree_derive_eps son || tree_derive_eps bro
- | DeadEnd -> false
-;;
-
-let rec eq_symbol s1 s2 =
- match s1, s2 with
- Snterm e1, Snterm e2 -> e1 == e2
- | Snterml (e1, l1), Snterml (e2, l2) -> e1 == e2 && l1 = l2
- | Slist0 s1, Slist0 s2 -> eq_symbol s1 s2
- | Slist0sep (s1, sep1), Slist0sep (s2, sep2) ->
- eq_symbol s1 s2 && eq_symbol sep1 sep2
- | Slist1 s1, Slist1 s2 -> eq_symbol s1 s2
- | Slist1sep (s1, sep1), Slist1sep (s2, sep2) ->
- eq_symbol s1 s2 && eq_symbol sep1 sep2
- | Sopt s1, Sopt s2 -> eq_symbol s1 s2
- | Stree _, Stree _ -> false
- | _ -> s1 = s2
-;;
-
-let is_before s1 s2 =
- match s1, s2 with
- Stoken ("ANY", _), _ -> false
- | _, Stoken ("ANY", _) -> true
- | Stoken (_, s), Stoken (_, "") when s <> "" -> true
- | Stoken _, Stoken _ -> false
- | Stoken _, _ -> true
- | _ -> false
-;;
-
-let insert_tree entry_name gsymbols action tree =
- let rec insert symbols tree =
- match symbols with
- s :: sl -> insert_in_tree s sl tree
- | [] ->
- match tree with
- Node {node = s; son = son; brother = bro} ->
- Node {node = s; son = son; brother = insert [] bro}
- | LocAct (old_action, action_list) ->
- if !warning_verbose then
- begin
- eprintf "<W> Grammar extension: ";
- if entry_name <> "" then eprintf "in [%s], " entry_name;
- eprintf "some rule has been masked\n";
- flush stderr
- end;
- LocAct (action, (old_action :: action_list))
- | DeadEnd -> LocAct (action, [])
- and insert_in_tree s sl tree =
- match try_insert s sl tree with
- Some t -> t
- | None -> Node {node = s; son = insert sl DeadEnd; brother = tree}
- and try_insert s sl tree =
- match tree with
- Node {node = s1; son = son; brother = bro} ->
- if eq_symbol s s1 then
- let t = Node {node = s1; son = insert sl son; brother = bro} in
- Some t
- else if is_before s1 s || derive_eps s && not (derive_eps s1) then
- let bro =
- match try_insert s sl bro with
- Some bro -> bro
- | None -> Node {node = s; son = insert sl DeadEnd; brother = bro}
- in
- let t = Node {node = s1; son = son; brother = bro} in Some t
- else
- begin match try_insert s sl bro with
- Some bro ->
- let t = Node {node = s1; son = son; brother = bro} in Some t
- | None -> None
- end
- | LocAct (_, _) | DeadEnd -> None
- and insert_new =
- function
- s :: sl -> Node {node = s; son = insert_new sl; brother = DeadEnd}
- | [] -> LocAct (action, [])
- in
- insert gsymbols tree
-;;
-
-let srules rl =
- let t =
- List.fold_left
- (fun tree (symbols, action) -> insert_tree "" symbols action tree)
- DeadEnd rl
- in
- Stree t
-;;
-
-external action : 'a -> g_action = "%identity";;
-
-let is_level_labelled n lev =
- match lev.lname with
- Some n1 -> n = n1
- | None -> false
-;;
-
-let insert_level entry_name e1 symbols action slev =
- match e1 with
- true ->
- {assoc = slev.assoc; lname = slev.lname;
- lsuffix = insert_tree entry_name symbols action slev.lsuffix;
- lprefix = slev.lprefix}
- | false ->
- {assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix;
- lprefix = insert_tree entry_name symbols action slev.lprefix}
-;;
-
-let empty_lev lname assoc =
- let assoc =
- match assoc with
- Some a -> a
- | None -> LeftA
- in
- {assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd}
-;;
-
-let change_lev lev n lname assoc =
- let a =
- match assoc with
- None -> lev.assoc
- | Some a ->
- if a <> lev.assoc && !warning_verbose then
- begin
- eprintf "<W> Changing associativity of level \"%s\"\n" n;
- flush stderr
- end;
- a
- in
- begin match lname with
- Some n ->
- if lname <> lev.lname && !warning_verbose then
- begin eprintf "<W> Level label \"%s\" ignored\n" n; flush stderr end
- | None -> ()
- end;
- {assoc = a; lname = lev.lname; lsuffix = lev.lsuffix; lprefix = lev.lprefix}
-;;
-
-let get_level entry position levs =
- match position with
- Some First -> [], empty_lev, levs
- | Some Last -> levs, empty_lev, []
- | Some (Level n) ->
- let rec get =
- function
- [] ->
- eprintf "No level labelled \"%s\" in entry \"%s\"\n" n
- entry.ename;
- flush stderr;
- failwith "Grammar.extend"
- | lev :: levs ->
- if is_level_labelled n lev then [], change_lev lev n, levs
- else
- let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2
- in
- get levs
- | Some (Before n) ->
- let rec get =
- function
- [] ->
- eprintf "No level labelled \"%s\" in entry \"%s\"\n" n
- entry.ename;
- flush stderr;
- failwith "Grammar.extend"
- | lev :: levs ->
- if is_level_labelled n lev then [], empty_lev, lev :: levs
- else
- let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2
- in
- get levs
- | Some (After n) ->
- let rec get =
- function
- [] ->
- eprintf "No level labelled \"%s\" in entry \"%s\"\n" n
- entry.ename;
- flush stderr;
- failwith "Grammar.extend"
- | lev :: levs ->
- if is_level_labelled n lev then [lev], empty_lev, levs
- else
- let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2
- in
- get levs
- | None ->
- match levs with
- lev :: levs -> [], change_lev lev "<top>", levs
- | [] -> [], empty_lev, []
-;;
-
-let rec check_gram entry =
- function
- Snterm e ->
- if e.egram != entry.egram then
- begin
- eprintf "\
-Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n"
- entry.ename e.ename;
- flush stderr;
- failwith "Grammar.extend error"
- end
- | Snterml (e, _) ->
- if e.egram != entry.egram then
- begin
- eprintf "\
-Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n"
- entry.ename e.ename;
- flush stderr;
- failwith "Grammar.extend error"
- end
- | Smeta (_, sl, _) -> List.iter (check_gram entry) sl
- | Slist0sep (s, t) -> check_gram entry t; check_gram entry s
- | Slist1sep (s, t) -> check_gram entry t; check_gram entry s
- | Slist0 s -> check_gram entry s
- | Slist1 s -> check_gram entry s
- | Sopt s -> check_gram entry s
- | Stree t -> tree_check_gram entry t
- | Snext | Sself | Stoken _ -> ()
-and tree_check_gram entry =
- function
- Node {node = n; brother = bro; son = son} ->
- check_gram entry n; tree_check_gram entry bro; tree_check_gram entry son
- | LocAct (_, _) | DeadEnd -> ()
-;;
-
-let change_to_self entry =
- function
- Snterm e when e == entry -> Sself
- | x -> x
-;;
-
-let get_initial entry =
- function
- Sself :: symbols -> true, symbols
- | symbols -> false, symbols
-;;
-
-let insert_tokens gram symbols =
- let rec insert =
- function
- Smeta (_, sl, _) -> List.iter insert sl
- | Slist0 s -> insert s
- | Slist1 s -> insert s
- | Slist0sep (s, t) -> insert s; insert t
- | Slist1sep (s, t) -> insert s; insert t
- | Sopt s -> insert s
- | Stree t -> tinsert t
- | Stoken ("ANY", _) -> ()
- | Stoken tok ->
- gram.glexer.Token.tok_using tok;
- let r =
- try Hashtbl.find gram.gtokens tok with
- Not_found -> let r = ref 0 in Hashtbl.add gram.gtokens tok r; r
- in
- incr r
- | Snterm _ | Snterml (_, _) | Snext | Sself -> ()
- and tinsert =
- function
- Node {node = s; brother = bro; son = son} ->
- insert s; tinsert bro; tinsert son
- | LocAct (_, _) | DeadEnd -> ()
- in
- List.iter insert symbols
-;;
-
-let levels_of_rules entry position rules =
- let elev =
- match entry.edesc with
- Dlevels elev -> elev
- | Dparser _ ->
- eprintf "Error: entry not extensible: \"%s\"\n" entry.ename;
- flush stderr;
- failwith "Grammar.extend"
- in
- if rules = [] then elev
- else
- let (levs1, make_lev, levs2) = get_level entry position elev in
- let (levs, _) =
- List.fold_left
- (fun (levs, make_lev) (lname, assoc, level) ->
- let lev = make_lev lname assoc in
- let lev =
- List.fold_left
- (fun lev (symbols, action) ->
- let symbols = List.map (change_to_self entry) symbols in
- List.iter (check_gram entry) symbols;
- let (e1, symbols) = get_initial entry symbols in
- insert_tokens entry.egram symbols;
- insert_level entry.ename e1 symbols action lev)
- lev level
- in
- lev :: levs, empty_lev)
- ([], make_lev) rules
- in
- levs1 @ List.rev levs @ levs2
-;;
-
-let logically_eq_symbols entry =
- let rec eq_symbols s1 s2 =
- match s1, s2 with
- Snterm e1, Snterm e2 -> e1.ename = e2.ename
- | Snterm e1, Sself -> e1.ename = entry.ename
- | Sself, Snterm e2 -> entry.ename = e2.ename
- | Snterml (e1, l1), Snterml (e2, l2) -> e1.ename = e2.ename && l1 = l2
- | Slist0 s1, Slist0 s2 -> eq_symbols s1 s2
- | Slist0sep (s1, sep1), Slist0sep (s2, sep2) ->
- eq_symbols s1 s2 && eq_symbols sep1 sep2
- | Slist1 s1, Slist1 s2 -> eq_symbols s1 s2
- | Slist1sep (s1, sep1), Slist1sep (s2, sep2) ->
- eq_symbols s1 s2 && eq_symbols sep1 sep2
- | Sopt s1, Sopt s2 -> eq_symbols s1 s2
- | Stree t1, Stree t2 -> eq_trees t1 t2
- | _ -> s1 = s2
- and eq_trees t1 t2 =
- match t1, t2 with
- Node n1, Node n2 ->
- eq_symbols n1.node n2.node && eq_trees n1.son n2.son &&
- eq_trees n1.brother n2.brother
- | (LocAct (_, _) | DeadEnd), (LocAct (_, _) | DeadEnd) -> true
- | _ -> false
- in
- eq_symbols
-;;
-
-(* [delete_rule_in_tree] returns
- [Some (dsl, t)] if success
- [dsl] =
- Some (list of deleted nodes) if branch deleted
- None if action replaced by previous version of action
- [t] = remaining tree
- [None] if failure *)
-
-let delete_rule_in_tree entry =
- let rec delete_in_tree symbols tree =
- match symbols, tree with
- s :: sl, Node n ->
- if logically_eq_symbols entry s n.node then delete_son sl n
- else
- begin match delete_in_tree symbols n.brother with
- Some (dsl, t) ->
- Some (dsl, Node {node = n.node; son = n.son; brother = t})
- | None -> None
- end
- | s :: sl, _ -> None
- | [], Node n ->
- begin match delete_in_tree [] n.brother with
- Some (dsl, t) ->
- Some (dsl, Node {node = n.node; son = n.son; brother = t})
- | None -> None
- end
- | [], DeadEnd -> None
- | [], LocAct (_, []) -> Some (Some [], DeadEnd)
- | [], LocAct (_, (action :: list)) -> Some (None, LocAct (action, list))
- and delete_son sl n =
- match delete_in_tree sl n.son with
- Some (Some dsl, DeadEnd) -> Some (Some (n.node :: dsl), n.brother)
- | Some (Some dsl, t) ->
- let t = Node {node = n.node; son = t; brother = n.brother} in
- Some (Some (n.node :: dsl), t)
- | Some (None, t) ->
- let t = Node {node = n.node; son = t; brother = n.brother} in
- Some (None, t)
- | None -> None
- in
- delete_in_tree
-;;
-
-let rec decr_keyw_use gram =
- function
- Stoken tok ->
- let r = Hashtbl.find gram.gtokens tok in
- decr r;
- if !r == 0 then
- begin
- Hashtbl.remove gram.gtokens tok; gram.glexer.Token.tok_removing tok
- end
- | Smeta (_, sl, _) -> List.iter (decr_keyw_use gram) sl
- | Slist0 s -> decr_keyw_use gram s
- | Slist1 s -> decr_keyw_use gram s
- | Slist0sep (s1, s2) -> decr_keyw_use gram s1; decr_keyw_use gram s2
- | Slist1sep (s1, s2) -> decr_keyw_use gram s1; decr_keyw_use gram s2
- | Sopt s -> decr_keyw_use gram s
- | Stree t -> decr_keyw_use_in_tree gram t
- | Sself | Snext | Snterm _ | Snterml (_, _) -> ()
-and decr_keyw_use_in_tree gram =
- function
- DeadEnd | LocAct (_, _) -> ()
- | Node n ->
- decr_keyw_use gram n.node;
- decr_keyw_use_in_tree gram n.son;
- decr_keyw_use_in_tree gram n.brother
-;;
-
-let rec delete_rule_in_suffix entry symbols =
- function
- lev :: levs ->
- begin match delete_rule_in_tree entry symbols lev.lsuffix with
- Some (dsl, t) ->
- begin match dsl with
- Some dsl -> List.iter (decr_keyw_use entry.egram) dsl
- | None -> ()
- end;
- begin match t with
- DeadEnd when lev.lprefix == DeadEnd -> levs
- | _ ->
- let lev =
- {assoc = lev.assoc; lname = lev.lname; lsuffix = t;
- lprefix = lev.lprefix}
- in
- lev :: levs
- end
- | None ->
- let levs = delete_rule_in_suffix entry symbols levs in lev :: levs
- end
- | [] -> raise Not_found
-;;
-
-let rec delete_rule_in_prefix entry symbols =
- function
- lev :: levs ->
- begin match delete_rule_in_tree entry symbols lev.lprefix with
- Some (dsl, t) ->
- begin match dsl with
- Some dsl -> List.iter (decr_keyw_use entry.egram) dsl
- | None -> ()
- end;
- begin match t with
- DeadEnd when lev.lsuffix == DeadEnd -> levs
- | _ ->
- let lev =
- {assoc = lev.assoc; lname = lev.lname; lsuffix = lev.lsuffix;
- lprefix = t}
- in
- lev :: levs
- end
- | None ->
- let levs = delete_rule_in_prefix entry symbols levs in lev :: levs
- end
- | [] -> raise Not_found
-;;
-
-let rec delete_rule_in_level_list entry symbols levs =
- match symbols with
- Sself :: symbols -> delete_rule_in_suffix entry symbols levs
- | Snterm e :: symbols when e == entry ->
- delete_rule_in_suffix entry symbols levs
- | _ -> delete_rule_in_prefix entry symbols levs
-;;
diff --git a/camlp4/ocaml_src/lib/gramext.mli b/camlp4/ocaml_src/lib/gramext.mli
deleted file mode 100644
index bd275ae8ee..0000000000
--- a/camlp4/ocaml_src/lib/gramext.mli
+++ /dev/null
@@ -1,79 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-type 'te grammar =
- { gtokens : (Token.pattern, int ref) Hashtbl.t;
- mutable glexer : 'te Token.glexer }
-;;
-
-type 'te g_entry =
- { egram : 'te grammar;
- ename : string;
- mutable estart : int -> 'te Stream.t -> Obj.t;
- mutable econtinue : int -> int -> Obj.t -> 'te Stream.t -> Obj.t;
- mutable edesc : 'te g_desc }
-and 'te g_desc =
- Dlevels of 'te g_level list
- | Dparser of ('te Stream.t -> Obj.t)
-and 'te g_level =
- { assoc : g_assoc;
- lname : string option;
- lsuffix : 'te g_tree;
- lprefix : 'te g_tree }
-and g_assoc =
- NonA
- | RightA
- | LeftA
-and 'te g_symbol =
- Smeta of string * 'te g_symbol list * Obj.t
- | Snterm of 'te g_entry
- | Snterml of 'te g_entry * string
- | Slist0 of 'te g_symbol
- | Slist0sep of 'te g_symbol * 'te g_symbol
- | Slist1 of 'te g_symbol
- | Slist1sep of 'te g_symbol * 'te g_symbol
- | Sopt of 'te g_symbol
- | Sself
- | Snext
- | Stoken of Token.pattern
- | Stree of 'te g_tree
-and g_action = Obj.t
-and 'te g_tree =
- Node of 'te g_node
- | LocAct of g_action * g_action list
- | DeadEnd
-and 'te g_node =
- { node : 'te g_symbol; son : 'te g_tree; brother : 'te g_tree }
-;;
-
-type position =
- First
- | Last
- | Before of string
- | After of string
- | Level of string
-;;
-
-val levels_of_rules :
- 'te g_entry -> position option ->
- (string option * g_assoc option * ('te g_symbol list * g_action) list)
- list ->
- 'te g_level list;;
-val srules : ('te g_symbol list * g_action) list -> 'te g_symbol;;
-external action : 'a -> g_action = "%identity";;
-
-val delete_rule_in_level_list :
- 'te g_entry -> 'te g_symbol list -> 'te g_level list -> 'te g_level list;;
-
-val warning_verbose : bool ref;;
diff --git a/camlp4/ocaml_src/lib/grammar.ml b/camlp4/ocaml_src/lib/grammar.ml
deleted file mode 100644
index 196a6b954a..0000000000
--- a/camlp4/ocaml_src/lib/grammar.ml
+++ /dev/null
@@ -1,1119 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-open Stdpp;;
-open Gramext;;
-open Format;;
-
-let rec flatten_tree =
- function
- DeadEnd -> []
- | LocAct (_, _) -> [[]]
- | Node {node = n; brother = b; son = s} ->
- List.map (fun l -> n :: l) (flatten_tree s) @ flatten_tree b
-;;
-
-let print_str ppf s = fprintf ppf "\"%s\"" (String.escaped s);;
-
-let rec print_symbol ppf =
- function
- Smeta (n, sl, _) -> print_meta ppf n sl
- | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s
- | Slist0sep (s, t) ->
- fprintf ppf "LIST0 %a SEP %a" print_symbol1 s print_symbol1 t
- | Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s
- | Slist1sep (s, t) ->
- fprintf ppf "LIST1 %a SEP %a" print_symbol1 s print_symbol1 t
- | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s
- | Stoken (con, prm) when con <> "" && prm <> "" ->
- fprintf ppf "%s@ %a" con print_str prm
- | Snterml (e, l) -> fprintf ppf "%s@ LEVEL@ %a" e.ename print_str l
- | Snterm _ | Snext | Sself | Stoken _ | Stree _ as s -> print_symbol1 ppf s
-and print_meta ppf n sl =
- let rec loop i =
- function
- [] -> ()
- | s :: sl ->
- let j =
- try String.index_from n i ' ' with
- Not_found -> String.length n
- in
- fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s;
- if sl = [] then ()
- else
- begin fprintf ppf " "; loop (min (j + 1) (String.length n)) sl end
- in
- loop 0 sl
-and print_symbol1 ppf =
- function
- Snterm e -> pp_print_string ppf e.ename
- | Sself -> pp_print_string ppf "SELF"
- | Snext -> pp_print_string ppf "NEXT"
- | Stoken ("", s) -> print_str ppf s
- | Stoken (con, "") -> pp_print_string ppf con
- | Stree t -> print_level ppf pp_print_space (flatten_tree t)
- | Smeta (_, _, _) | Snterml (_, _) | Slist0 _ | Slist0sep (_, _) |
- Slist1 _ | Slist1sep (_, _) | Sopt _ | Stoken _ as s ->
- fprintf ppf "(%a)" print_symbol s
-and print_rule ppf symbols =
- fprintf ppf "@[<hov 0>";
- let _ =
- List.fold_left
- (fun sep symbol ->
- fprintf ppf "%t%a" sep print_symbol symbol;
- fun ppf -> fprintf ppf ";@ ")
- (fun ppf -> ()) symbols
- in
- fprintf ppf "@]"
-and print_level ppf pp_print_space rules =
- fprintf ppf "@[<hov 0>[ ";
- let _ =
- List.fold_left
- (fun sep rule ->
- fprintf ppf "%t%a" sep print_rule rule;
- fun ppf -> fprintf ppf "%a| " pp_print_space ())
- (fun ppf -> ()) rules
- in
- fprintf ppf " ]@]"
-;;
-
-let print_levels ppf elev =
- let _ =
- List.fold_left
- (fun sep lev ->
- let rules =
- List.map (fun t -> Sself :: t) (flatten_tree lev.lsuffix) @
- flatten_tree lev.lprefix
- in
- fprintf ppf "%t@[<hov 2>" sep;
- begin match lev.lname with
- Some n -> fprintf ppf "%a@;<1 2>" print_str n
- | None -> ()
- end;
- begin match lev.assoc with
- LeftA -> fprintf ppf "LEFTA"
- | RightA -> fprintf ppf "RIGHTA"
- | NonA -> fprintf ppf "NONA"
- end;
- fprintf ppf "@]@;<1 2>";
- print_level ppf pp_force_newline rules;
- fun ppf -> fprintf ppf "@,| ")
- (fun ppf -> ()) elev
- in
- ()
-;;
-
-let print_entry ppf e =
- fprintf ppf "@[<v 0>[ ";
- begin match e.edesc with
- Dlevels elev -> print_levels ppf elev
- | Dparser _ -> fprintf ppf "<parser>"
- end;
- fprintf ppf " ]@]"
-;;
-
-let iter_entry f e =
- let treated = ref [] in
- let rec do_entry e =
- if List.memq e !treated then ()
- else
- begin
- treated := e :: !treated;
- f e;
- match e.edesc with
- Dlevels ll -> List.iter do_level ll
- | Dparser _ -> ()
- end
- and do_level lev = do_tree lev.lsuffix; do_tree lev.lprefix
- and do_tree =
- function
- Node n -> do_node n
- | LocAct (_, _) | DeadEnd -> ()
- and do_node n = do_symbol n.node; do_tree n.son; do_tree n.brother
- and do_symbol =
- function
- Smeta (_, sl, _) -> List.iter do_symbol sl
- | Snterm e | Snterml (e, _) -> do_entry e
- | Slist0 s | Slist1 s | Sopt s -> do_symbol s
- | Slist0sep (s1, s2) | Slist1sep (s1, s2) -> do_symbol s1; do_symbol s2
- | Stree t -> do_tree t
- | Sself | Snext | Stoken _ -> ()
- in
- do_entry e
-;;
-
-let fold_entry f e init =
- let treated = ref [] in
- let rec do_entry accu e =
- if List.memq e !treated then accu
- else
- begin
- treated := e :: !treated;
- let accu = f e accu in
- match e.edesc with
- Dlevels ll -> List.fold_left do_level accu ll
- | Dparser _ -> accu
- end
- and do_level accu lev =
- let accu = do_tree accu lev.lsuffix in do_tree accu lev.lprefix
- and do_tree accu =
- function
- Node n -> do_node accu n
- | LocAct (_, _) | DeadEnd -> accu
- and do_node accu n =
- let accu = do_symbol accu n.node in
- let accu = do_tree accu n.son in do_tree accu n.brother
- and do_symbol accu =
- function
- Smeta (_, sl, _) -> List.fold_left do_symbol accu sl
- | Snterm e | Snterml (e, _) -> do_entry accu e
- | Slist0 s | Slist1 s | Sopt s -> do_symbol accu s
- | Slist0sep (s1, s2) | Slist1sep (s1, s2) ->
- let accu = do_symbol accu s1 in do_symbol accu s2
- | Stree t -> do_tree accu t
- | Sself | Snext | Stoken _ -> accu
- in
- do_entry init e
-;;
-
-type g = Token.t Gramext.grammar;;
-
-external grammar_obj : g -> Token.t grammar = "%identity";;
-
-let floc = ref (fun _ -> failwith "internal error when computing location");;
-let loc_of_token_interval bp ep =
- if bp == ep then
- if bp == 0 then 0, 1 else let a = snd (!floc (bp - 1)) in a, a + 1
- else
- let (bp1, bp2) = !floc bp in
- let (ep1, ep2) = !floc (pred ep) in
- (if bp1 < ep1 then bp1 else ep1), (if bp2 > ep2 then bp2 else ep2)
-;;
-
-let rec name_of_symbol entry =
- function
- Snterm e -> "[" ^ e.ename ^ "]"
- | Snterml (e, l) -> "[" ^ e.ename ^ " level " ^ l ^ "]"
- | Sself | Snext -> "[" ^ entry.ename ^ "]"
- | Stoken tok -> entry.egram.glexer.Token.tok_text tok
- | _ -> "???"
-;;
-
-let rec get_token_list entry tokl last_tok tree =
- match tree with
- Node {node = Stoken tok as s; son = son; brother = DeadEnd} ->
- get_token_list entry (last_tok :: tokl) tok son
- | _ ->
- if tokl = [] then None
- else Some (List.rev (last_tok :: tokl), last_tok, tree)
-;;
-
-let rec name_of_symbol_failed entry =
- function
- Slist0 s -> name_of_symbol_failed entry s
- | Slist0sep (s, _) -> name_of_symbol_failed entry s
- | Slist1 s -> name_of_symbol_failed entry s
- | Slist1sep (s, _) -> name_of_symbol_failed entry s
- | Sopt s -> name_of_symbol_failed entry s
- | Stree t -> name_of_tree_failed entry t
- | s -> name_of_symbol entry s
-and name_of_tree_failed entry =
- function
- Node {node = s; brother = bro; son = son} ->
- let tokl =
- match s with
- Stoken tok -> get_token_list entry [] tok son
- | _ -> None
- in
- begin match tokl with
- None ->
- let txt = name_of_symbol_failed entry s in
- let txt =
- match s, son with
- Sopt _, Node _ -> txt ^ " or " ^ name_of_tree_failed entry son
- | _ -> txt
- in
- let txt =
- match bro with
- DeadEnd | LocAct (_, _) -> txt
- | Node _ -> txt ^ " or " ^ name_of_tree_failed entry bro
- in
- txt
- | Some (tokl, last_tok, son) ->
- List.fold_left
- (fun s tok ->
- (if s = "" then "" else s ^ " ") ^
- entry.egram.glexer.Token.tok_text tok)
- "" tokl
- end
- | DeadEnd | LocAct (_, _) -> "???"
-;;
-
-let search_tree_in_entry prev_symb tree =
- function
- Dlevels levels ->
- let rec search_levels =
- function
- [] -> tree
- | level :: levels ->
- match search_level level with
- Some tree -> tree
- | None -> search_levels levels
- and search_level level =
- match search_tree level.lsuffix with
- Some t -> Some (Node {node = Sself; son = t; brother = DeadEnd})
- | None -> search_tree level.lprefix
- and search_tree t =
- if tree <> DeadEnd && t == tree then Some t
- else
- match t with
- Node n ->
- begin match search_symbol n.node with
- Some symb ->
- Some (Node {node = symb; son = n.son; brother = DeadEnd})
- | None ->
- match search_tree n.son with
- Some t ->
- Some (Node {node = n.node; son = t; brother = DeadEnd})
- | None -> search_tree n.brother
- end
- | LocAct (_, _) | DeadEnd -> None
- and search_symbol symb =
- match symb with
- Snterm _ | Snterml (_, _) | Slist0 _ | Slist0sep (_, _) | Slist1 _ |
- Slist1sep (_, _) | Sopt _ | Stoken _ | Stree _
- when symb == prev_symb ->
- Some symb
- | Slist0 symb ->
- begin match search_symbol symb with
- Some symb -> Some (Slist0 symb)
- | None -> None
- end
- | Slist0sep (symb, sep) ->
- begin match search_symbol symb with
- Some symb -> Some (Slist0sep (symb, sep))
- | None ->
- match search_symbol sep with
- Some sep -> Some (Slist0sep (symb, sep))
- | None -> None
- end
- | Slist1 symb ->
- begin match search_symbol symb with
- Some symb -> Some (Slist1 symb)
- | None -> None
- end
- | Slist1sep (symb, sep) ->
- begin match search_symbol symb with
- Some symb -> Some (Slist1sep (symb, sep))
- | None ->
- match search_symbol sep with
- Some sep -> Some (Slist1sep (symb, sep))
- | None -> None
- end
- | Sopt symb ->
- begin match search_symbol symb with
- Some symb -> Some (Sopt symb)
- | None -> None
- end
- | Stree t ->
- begin match search_tree t with
- Some t -> Some (Stree t)
- | None -> None
- end
- | _ -> None
- in
- search_levels levels
- | Dparser _ -> tree
-;;
-
-let error_verbose = ref false;;
-
-let tree_failed entry prev_symb_result prev_symb tree =
- let txt = name_of_tree_failed entry tree in
- let txt =
- match prev_symb with
- Slist0 s ->
- let txt1 = name_of_symbol_failed entry s in
- txt1 ^ " or " ^ txt ^ " expected"
- | Slist1 s ->
- let txt1 = name_of_symbol_failed entry s in
- txt1 ^ " or " ^ txt ^ " expected"
- | Slist0sep (s, sep) ->
- begin match Obj.magic prev_symb_result with
- [] ->
- let txt1 = name_of_symbol_failed entry s in
- txt1 ^ " or " ^ txt ^ " expected"
- | _ ->
- let txt1 = name_of_symbol_failed entry sep in
- txt1 ^ " or " ^ txt ^ " expected"
- end
- | Slist1sep (s, sep) ->
- begin match Obj.magic prev_symb_result with
- [] ->
- let txt1 = name_of_symbol_failed entry s in
- txt1 ^ " or " ^ txt ^ " expected"
- | _ ->
- let txt1 = name_of_symbol_failed entry sep in
- txt1 ^ " or " ^ txt ^ " expected"
- end
- | Sopt _ | Stree _ -> txt ^ " expected"
- | _ -> txt ^ " expected after " ^ name_of_symbol entry prev_symb
- in
- if !error_verbose then
- begin
- let tree = search_tree_in_entry prev_symb tree entry.edesc in
- let ppf = err_formatter in
- fprintf ppf "@[<v 0>@,";
- fprintf ppf "----------------------------------@,";
- fprintf ppf "Parse error in entry [%s], rule:@;<0 2>" entry.ename;
- fprintf ppf "@[";
- print_level ppf pp_force_newline (flatten_tree tree);
- fprintf ppf "@]@,";
- fprintf ppf "----------------------------------@,";
- fprintf ppf "@]@."
- end;
- txt ^ " (in [" ^ entry.ename ^ "])"
-;;
-
-let symb_failed entry prev_symb_result prev_symb symb =
- let tree = Node {node = symb; brother = DeadEnd; son = DeadEnd} in
- tree_failed entry prev_symb_result prev_symb tree
-;;
-
-external app : Obj.t -> 'a = "%identity";;
-
-let is_level_labelled n lev =
- match lev.lname with
- Some n1 -> n = n1
- | None -> false
-;;
-
-let level_number entry lab =
- let rec lookup levn =
- function
- [] -> failwith ("unknown level " ^ lab)
- | lev :: levs ->
- if is_level_labelled lab lev then levn else lookup (succ levn) levs
- in
- match entry.edesc with
- Dlevels elev -> lookup 0 elev
- | Dparser _ -> raise Not_found
-;;
-
-let rec top_symb entry =
- function
- Sself | Snext -> Snterm entry
- | Snterml (e, _) -> Snterm e
- | Slist1sep (s, sep) -> Slist1sep (top_symb entry s, sep)
- | _ -> raise Stream.Failure
-;;
-
-let entry_of_symb entry =
- function
- Sself | Snext -> entry
- | Snterm e -> e
- | Snterml (e, _) -> e
- | _ -> raise Stream.Failure
-;;
-
-let top_tree entry =
- function
- Node {node = s; brother = bro; son = son} ->
- Node {node = top_symb entry s; brother = bro; son = son}
- | LocAct (_, _) | DeadEnd -> raise Stream.Failure
-;;
-
-let skip_if_empty bp p strm =
- if Stream.count strm == bp then Gramext.action (fun a -> p strm)
- else raise Stream.Failure
-;;
-
-let continue entry bp a s son p1 (strm__ : _ Stream.t) =
- let a = (entry_of_symb entry s).econtinue 0 bp a strm__ in
- let act =
- try p1 strm__ with
- Stream.Failure -> raise (Stream.Error (tree_failed entry a s son))
- in
- Gramext.action (fun _ -> app act a)
-;;
-
-let do_recover
- parser_of_tree entry nlevn alevn bp a s son (strm__ : _ Stream.t) =
- try parser_of_tree entry nlevn alevn (top_tree entry son) strm__ with
- Stream.Failure ->
- try
- skip_if_empty bp (fun (strm__ : _ Stream.t) -> raise Stream.Failure)
- strm__
- with
- Stream.Failure ->
- continue entry bp a s son (parser_of_tree entry nlevn alevn son)
- strm__
-;;
-
-let strict_parsing = ref false;;
-
-let recover parser_of_tree entry nlevn alevn bp a s son strm =
- if !strict_parsing then raise (Stream.Error (tree_failed entry a s son))
- else do_recover parser_of_tree entry nlevn alevn bp a s son strm
-;;
-
-let token_count = ref 0;;
-
-let peek_nth n strm =
- let list = Stream.npeek n strm in
- token_count := Stream.count strm + n;
- let rec loop list n =
- match list, n with
- x :: _, 1 -> Some x
- | _ :: l, n -> loop l (n - 1)
- | [], _ -> None
- in
- loop list n
-;;
-
-let rec parser_of_tree entry nlevn alevn =
- function
- DeadEnd -> (fun (strm__ : _ Stream.t) -> raise Stream.Failure)
- | LocAct (act, _) -> (fun (strm__ : _ Stream.t) -> act)
- | Node {node = Sself; son = LocAct (act, _); brother = DeadEnd} ->
- (fun (strm__ : _ Stream.t) ->
- let a = entry.estart alevn strm__ in app act a)
- | Node {node = Sself; son = LocAct (act, _); brother = bro} ->
- let p2 = parser_of_tree entry nlevn alevn bro in
- (fun (strm__ : _ Stream.t) ->
- match
- try Some (entry.estart alevn strm__) with
- Stream.Failure -> None
- with
- Some a -> app act a
- | _ -> p2 strm__)
- | Node {node = s; son = son; brother = DeadEnd} ->
- let tokl =
- match s with
- Stoken tok -> get_token_list entry [] tok son
- | _ -> None
- in
- begin match tokl with
- None ->
- let ps = parser_of_symbol entry nlevn s in
- let p1 = parser_of_tree entry nlevn alevn son in
- let p1 = parser_cont p1 entry nlevn alevn s son in
- (fun (strm__ : _ Stream.t) ->
- let bp = Stream.count strm__ in
- let a = ps strm__ in
- let act =
- try p1 bp a strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- app act a)
- | Some (tokl, last_tok, son) ->
- let p1 = parser_of_tree entry nlevn alevn son in
- let p1 = parser_cont p1 entry nlevn alevn (Stoken last_tok) son in
- parser_of_token_list entry.egram p1 tokl
- end
- | Node {node = s; son = son; brother = bro} ->
- let tokl =
- match s with
- Stoken tok -> get_token_list entry [] tok son
- | _ -> None
- in
- match tokl with
- None ->
- let ps = parser_of_symbol entry nlevn s in
- let p1 = parser_of_tree entry nlevn alevn son in
- let p1 = parser_cont p1 entry nlevn alevn s son in
- let p2 = parser_of_tree entry nlevn alevn bro in
- (fun (strm__ : _ Stream.t) ->
- let bp = Stream.count strm__ in
- match
- try Some (ps strm__) with
- Stream.Failure -> None
- with
- Some a ->
- let act =
- try p1 bp a strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- app act a
- | _ -> p2 strm__)
- | Some (tokl, last_tok, son) ->
- let p1 = parser_of_tree entry nlevn alevn son in
- let p1 = parser_cont p1 entry nlevn alevn (Stoken last_tok) son in
- let p1 = parser_of_token_list entry.egram p1 tokl in
- let p2 = parser_of_tree entry nlevn alevn bro in
- fun (strm__ : _ Stream.t) ->
- try p1 strm__ with
- Stream.Failure -> p2 strm__
-and parser_cont p1 entry nlevn alevn s son bp a (strm__ : _ Stream.t) =
- try p1 strm__ with
- Stream.Failure ->
- try recover parser_of_tree entry nlevn alevn bp a s son strm__ with
- Stream.Failure -> raise (Stream.Error (tree_failed entry a s son))
-and parser_of_token_list gram p1 tokl =
- let rec loop n =
- function
- tok :: tokl ->
- let tematch = gram.glexer.Token.tok_match tok in
- begin match tokl with
- [] ->
- let ps strm =
- match peek_nth n strm with
- Some tok ->
- let r = tematch tok in
- for i = 1 to n do Stream.junk strm done; Obj.repr r
- | None -> raise Stream.Failure
- in
- (fun (strm__ : _ Stream.t) ->
- let bp = Stream.count strm__ in
- let a = ps strm__ in
- let act =
- try p1 bp a strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- app act a)
- | _ ->
- let ps strm =
- match peek_nth n strm with
- Some tok -> tematch tok
- | None -> raise Stream.Failure
- in
- let p1 = loop (n + 1) tokl in
- fun (strm__ : _ Stream.t) ->
- let a = ps strm__ in let act = p1 strm__ in app act a
- end
- | [] -> invalid_arg "parser_of_token_list"
- in
- loop 1 tokl
-and parser_of_symbol entry nlevn =
- function
- Smeta (_, symbl, act) ->
- let act = Obj.magic act entry symbl in
- Obj.magic
- (List.fold_left
- (fun act symb -> Obj.magic act (parser_of_symbol entry nlevn symb))
- act symbl)
- | Slist0 s ->
- let ps = parser_of_symbol entry nlevn s in
- let rec loop al (strm__ : _ Stream.t) =
- match
- try Some (ps strm__) with
- Stream.Failure -> None
- with
- Some a -> loop (a :: al) strm__
- | _ -> al
- in
- (fun (strm__ : _ Stream.t) ->
- let a = loop [] strm__ in Obj.repr (List.rev a))
- | Slist0sep (symb, sep) ->
- let ps = parser_of_symbol entry nlevn symb in
- let pt = parser_of_symbol entry nlevn sep in
- let rec kont al (strm__ : _ Stream.t) =
- match
- try Some (pt strm__) with
- Stream.Failure -> None
- with
- Some v ->
- let a =
- try ps strm__ with
- Stream.Failure ->
- raise (Stream.Error (symb_failed entry v sep symb))
- in
- kont (a :: al) strm__
- | _ -> al
- in
- (fun (strm__ : _ Stream.t) ->
- match
- try Some (ps strm__) with
- Stream.Failure -> None
- with
- Some a -> Obj.repr (List.rev (kont [a] strm__))
- | _ -> Obj.repr [])
- | Slist1 s ->
- let ps = parser_of_symbol entry nlevn s in
- let rec loop al (strm__ : _ Stream.t) =
- match
- try Some (ps strm__) with
- Stream.Failure -> None
- with
- Some a -> loop (a :: al) strm__
- | _ -> al
- in
- (fun (strm__ : _ Stream.t) ->
- let a = ps strm__ in Obj.repr (List.rev (loop [a] strm__)))
- | Slist1sep (symb, sep) ->
- let ps = parser_of_symbol entry nlevn symb in
- let pt = parser_of_symbol entry nlevn sep in
- let rec kont al (strm__ : _ Stream.t) =
- match
- try Some (pt strm__) with
- Stream.Failure -> None
- with
- Some v ->
- let a =
- try ps strm__ with
- Stream.Failure ->
- try parse_top_symb entry symb strm__ with
- Stream.Failure ->
- raise (Stream.Error (symb_failed entry v sep symb))
- in
- kont (a :: al) strm__
- | _ -> al
- in
- (fun (strm__ : _ Stream.t) ->
- let a = ps strm__ in Obj.repr (List.rev (kont [a] strm__)))
- | Sopt s ->
- let ps = parser_of_symbol entry nlevn s in
- (fun (strm__ : _ Stream.t) ->
- match
- try Some (ps strm__) with
- Stream.Failure -> None
- with
- Some a -> Obj.repr (Some a)
- | _ -> Obj.repr None)
- | Stree t ->
- let pt = parser_of_tree entry 1 0 t in
- (fun (strm__ : _ Stream.t) ->
- let bp = Stream.count strm__ in
- let a = pt strm__ in
- let ep = Stream.count strm__ in
- let loc = loc_of_token_interval bp ep in app a loc)
- | Snterm e -> (fun (strm__ : _ Stream.t) -> e.estart 0 strm__)
- | Snterml (e, l) ->
- (fun (strm__ : _ Stream.t) -> e.estart (level_number e l) strm__)
- | Sself -> (fun (strm__ : _ Stream.t) -> entry.estart 0 strm__)
- | Snext -> (fun (strm__ : _ Stream.t) -> entry.estart nlevn strm__)
- | Stoken tok ->
- let f = entry.egram.glexer.Token.tok_match tok in
- fun strm ->
- match Stream.peek strm with
- Some tok -> let r = f tok in Stream.junk strm; Obj.repr r
- | None -> raise Stream.Failure
-and parse_top_symb entry symb =
- parser_of_symbol entry 0 (top_symb entry symb)
-;;
-
-let symb_failed_txt e s1 s2 = symb_failed e 0 s1 s2;;
-
-let rec continue_parser_of_levels entry clevn =
- function
- [] -> (fun levn bp a (strm__ : _ Stream.t) -> raise Stream.Failure)
- | lev :: levs ->
- let p1 = continue_parser_of_levels entry (succ clevn) levs in
- match lev.lsuffix with
- DeadEnd -> p1
- | tree ->
- let alevn =
- match lev.assoc with
- LeftA | NonA -> succ clevn
- | RightA -> clevn
- in
- let p2 = parser_of_tree entry (succ clevn) alevn tree in
- fun levn bp a strm ->
- if levn > clevn then p1 levn bp a strm
- else
- let (strm__ : _ Stream.t) = strm in
- try p1 levn bp a strm__ with
- Stream.Failure ->
- let act = p2 strm__ in
- let ep = Stream.count strm__ in
- let a = app act a (loc_of_token_interval bp ep) in
- entry.econtinue levn bp a strm
-;;
-
-let rec start_parser_of_levels entry clevn =
- function
- [] -> (fun levn (strm__ : _ Stream.t) -> raise Stream.Failure)
- | lev :: levs ->
- let p1 = start_parser_of_levels entry (succ clevn) levs in
- match lev.lprefix with
- DeadEnd -> p1
- | tree ->
- let alevn =
- match lev.assoc with
- LeftA | NonA -> succ clevn
- | RightA -> clevn
- in
- let p2 = parser_of_tree entry (succ clevn) alevn tree in
- match levs with
- [] ->
- (fun levn strm ->
- let (strm__ : _ Stream.t) = strm in
- let bp = Stream.count strm__ in
- let act = p2 strm__ in
- let ep = Stream.count strm__ in
- let a = app act (loc_of_token_interval bp ep) in
- entry.econtinue levn bp a strm)
- | _ ->
- fun levn strm ->
- if levn > clevn then p1 levn strm
- else
- let (strm__ : _ Stream.t) = strm in
- let bp = Stream.count strm__ in
- match
- try Some (p2 strm__) with
- Stream.Failure -> None
- with
- Some act ->
- let ep = Stream.count strm__ in
- let a = app act (loc_of_token_interval bp ep) in
- entry.econtinue levn bp a strm
- | _ -> p1 levn strm__
-;;
-
-let continue_parser_of_entry entry =
- match entry.edesc with
- Dlevels elev ->
- let p = continue_parser_of_levels entry 0 elev in
- (fun levn bp a (strm__ : _ Stream.t) ->
- try p levn bp a strm__ with
- Stream.Failure -> a)
- | Dparser p -> fun levn bp a (strm__ : _ Stream.t) -> raise Stream.Failure
-;;
-
-let empty_entry ename levn strm =
- raise (Stream.Error ("entry [" ^ ename ^ "] is empty"))
-;;
-
-let start_parser_of_entry entry =
- match entry.edesc with
- Dlevels [] -> empty_entry entry.ename
- | Dlevels elev -> start_parser_of_levels entry 0 elev
- | Dparser p -> fun levn strm -> p strm
-;;
-
-let parse_parsable entry efun (cs, (ts, fun_loc)) =
- let restore =
- let old_floc = !floc in
- let old_tc = !token_count in
- fun () -> floc := old_floc; token_count := old_tc
- in
- let get_loc () =
- try
- let cnt = Stream.count ts in
- let loc = fun_loc cnt in
- if !token_count - 1 <= cnt then loc
- else fst loc, snd (fun_loc (!token_count - 1))
- with
- _ -> Stream.count cs, Stream.count cs + 1
- in
- floc := fun_loc;
- token_count := 0;
- try let r = efun ts in restore (); r with
- Stream.Failure ->
- let loc = get_loc () in
- restore ();
- raise_with_loc loc (Stream.Error ("illegal begin of " ^ entry.ename))
- | Stream.Error _ as exc ->
- let loc = get_loc () in restore (); raise_with_loc loc exc
- | exc ->
- let loc = Stream.count cs, Stream.count cs + 1 in
- restore (); raise_with_loc loc exc
-;;
-
-let wrap_parse entry efun cs =
- let parsable = cs, entry.egram.glexer.Token.tok_func cs in
- parse_parsable entry efun parsable
-;;
-
-let create_toktab () = Hashtbl.create 301;;
-let gcreate glexer = {gtokens = create_toktab (); glexer = glexer};;
-
-let tematch tparse tok =
- match tparse tok with
- Some p -> (fun x -> p (Stream.ising x))
- | None -> Token.default_match tok
-;;
-let glexer_of_lexer lexer =
- {Token.tok_func = lexer.Token.func; Token.tok_using = lexer.Token.using;
- Token.tok_removing = lexer.Token.removing;
- Token.tok_match = tematch lexer.Token.tparse;
- Token.tok_text = lexer.Token.text; Token.tok_comm = None}
-;;
-let create lexer = gcreate (glexer_of_lexer lexer);;
-
-(* Extend syntax *)
-
-let extend_entry entry position rules =
- try
- let elev = Gramext.levels_of_rules entry position rules in
- entry.edesc <- Dlevels elev;
- entry.estart <-
- (fun lev strm ->
- let f = start_parser_of_entry entry in
- entry.estart <- f; f lev strm);
- entry.econtinue <-
- fun lev bp a strm ->
- let f = continue_parser_of_entry entry in
- entry.econtinue <- f; f lev bp a strm
- with
- Token.Error s ->
- Printf.eprintf "Lexer initialization error:\n- %s\n" s;
- flush stderr;
- failwith "Grammar.extend"
-;;
-
-let extend entry_rules_list =
- let gram = ref None in
- List.iter
- (fun (entry, position, rules) ->
- begin match !gram with
- Some g ->
- if g != entry.egram then
- begin
- Printf.eprintf "Error: entries with different grammars\n";
- flush stderr;
- failwith "Grammar.extend"
- end
- | None -> gram := Some entry.egram
- end;
- extend_entry entry position rules)
- entry_rules_list
-;;
-
-(* Deleting a rule *)
-
-let delete_rule entry sl =
- match entry.edesc with
- Dlevels levs ->
- let levs = Gramext.delete_rule_in_level_list entry sl levs in
- entry.edesc <- Dlevels levs;
- entry.estart <-
- (fun lev strm ->
- let f = start_parser_of_entry entry in
- entry.estart <- f; f lev strm);
- entry.econtinue <-
- (fun lev bp a strm ->
- let f = continue_parser_of_entry entry in
- entry.econtinue <- f; f lev bp a strm)
- | Dparser _ -> ()
-;;
-
-(* Unsafe *)
-
-let clear_entry e =
- e.estart <- (fun _ (strm__ : _ Stream.t) -> raise Stream.Failure);
- e.econtinue <- (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure);
- match e.edesc with
- Dlevels _ -> e.edesc <- Dlevels []
- | Dparser _ -> ()
-;;
-
-let gram_reinit g glexer = Hashtbl.clear g.gtokens; g.glexer <- glexer;;
-
-let reinit_gram g lexer = gram_reinit g (glexer_of_lexer lexer);;
-
-module Unsafe =
- struct
- let gram_reinit = gram_reinit;;
- let clear_entry = clear_entry;;
- let reinit_gram = reinit_gram;;
- end
-;;
-
-let find_entry e s =
- let rec find_levels =
- function
- [] -> None
- | lev :: levs ->
- match find_tree lev.lsuffix with
- None ->
- begin match find_tree lev.lprefix with
- None -> find_levels levs
- | x -> x
- end
- | x -> x
- and find_symbol =
- function
- Snterm e -> if e.ename = s then Some e else None
- | Snterml (e, _) -> if e.ename = s then Some e else None
- | Smeta (_, sl, _) -> find_symbol_list sl
- | Slist0 s -> find_symbol s
- | Slist0sep (s, _) -> find_symbol s
- | Slist1 s -> find_symbol s
- | Slist1sep (s, _) -> find_symbol s
- | Sopt s -> find_symbol s
- | Stree t -> find_tree t
- | Sself | Snext | Stoken _ -> None
- and find_symbol_list =
- function
- s :: sl ->
- begin match find_symbol s with
- None -> find_symbol_list sl
- | x -> x
- end
- | [] -> None
- and find_tree =
- function
- Node {node = s; brother = bro; son = son} ->
- begin match find_symbol s with
- None ->
- begin match find_tree bro with
- None -> find_tree son
- | x -> x
- end
- | x -> x
- end
- | LocAct (_, _) | DeadEnd -> None
- in
- match e.edesc with
- Dlevels levs ->
- begin match find_levels levs with
- Some e -> e
- | None -> raise Not_found
- end
- | Dparser _ -> raise Not_found
-;;
-
-let of_entry e = e.egram;;
-
-module Entry =
- struct
- type te = Token.t;;
- type 'a e = te g_entry;;
- let create g n =
- {egram = g; ename = n; estart = empty_entry n;
- econtinue = (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure);
- edesc = Dlevels []}
- ;;
- let parse (entry : 'a e) cs : 'a =
- Obj.magic (wrap_parse entry (entry.estart 0) cs)
- ;;
- let parse_token (entry : 'a e) ts : 'a = Obj.magic (entry.estart 0 ts);;
- let name e = e.ename;;
- let of_parser g n (p : te Stream.t -> 'a) : 'a e =
- {egram = g; ename = n; estart = (fun _ -> Obj.magic p);
- econtinue = (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure);
- edesc = Dparser (Obj.magic p)}
- ;;
- external obj : 'a e -> te Gramext.g_entry = "%identity";;
- let print e = printf "%a@." print_entry (obj e);;
- let find e s = find_entry (obj e) s;;
- end
-;;
-
-let tokens g con =
- let list = ref [] in
- Hashtbl.iter
- (fun (p_con, p_prm) c -> if p_con = con then list := (p_prm, !c) :: !list)
- g.gtokens;
- !list
-;;
-
-let glexer g = g.glexer;;
-
-let warning_verbose = Gramext.warning_verbose;;
-
-(* Functorial interface *)
-
-module type GLexerType = sig type te;; val lexer : te Token.glexer;; end;;
-
-module type S =
- sig
- type te;;
- type parsable;;
- val parsable : char Stream.t -> parsable;;
- val tokens : string -> (string * int) list;;
- val glexer : te Token.glexer;;
- module Entry :
- sig
- type 'a e;;
- val create : string -> 'a e;;
- val parse : 'a e -> parsable -> 'a;;
- val parse_token : 'a e -> te Stream.t -> 'a;;
- val name : 'a e -> string;;
- val of_parser : string -> (te Stream.t -> 'a) -> 'a e;;
- val print : 'a e -> unit;;
- external obj : 'a e -> te Gramext.g_entry = "%identity";;
- end
- ;;
- module Unsafe :
- sig
- val gram_reinit : te Token.glexer -> unit;;
- val clear_entry : 'a Entry.e -> unit;;
- val reinit_gram : Token.lexer -> unit;;
- end
- ;;
- val extend :
- 'a Entry.e -> Gramext.position option ->
- (string option * Gramext.g_assoc option *
- (te Gramext.g_symbol list * Gramext.g_action) list)
- list ->
- unit;;
- val delete_rule : 'a Entry.e -> te Gramext.g_symbol list -> unit;;
- end
-;;
-
-module type ReinitType = sig val reinit_gram : g -> Token.lexer -> unit;; end
-;;
-
-module GGMake (R : ReinitType) (L : GLexerType) =
- struct
- type te = L.te;;
- type parsable = char Stream.t * (te Stream.t * Token.location_function);;
- let gram = gcreate L.lexer;;
- let parsable cs = cs, L.lexer.Token.tok_func cs;;
- let tokens = tokens gram;;
- let glexer = glexer gram;;
- module Entry =
- struct
- type 'a e = te g_entry;;
- let create n =
- {egram = gram; ename = n; estart = empty_entry n;
- econtinue =
- (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure);
- edesc = Dlevels []}
- ;;
- external obj : 'a e -> te Gramext.g_entry = "%identity";;
- let parse (e : 'a e) p : 'a =
- Obj.magic (parse_parsable e (e.estart 0) p)
- ;;
- let parse_token (e : 'a e) ts : 'a = Obj.magic (e.estart 0 ts);;
- let name e = e.ename;;
- let of_parser n (p : te Stream.t -> 'a) : 'a e =
- {egram = gram; ename = n; estart = (fun _ -> Obj.magic p);
- econtinue =
- (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure);
- edesc = Dparser (Obj.magic p)}
- ;;
- let print e = printf "%a@." print_entry (obj e);;
- end
- ;;
- module Unsafe =
- struct
- let gram_reinit = gram_reinit gram;;
- let clear_entry = Unsafe.clear_entry;;
- let reinit_gram = R.reinit_gram (Obj.magic gram);;
- end
- ;;
- let extend = extend_entry;;
- let delete_rule e r = delete_rule (Entry.obj e) r;;
- end
-;;
-
-module GMake (L : GLexerType) =
- GGMake
- (struct
- let reinit_gram _ _ =
- failwith "call of deprecated reinit_gram in grammar built by GMake"
- ;;
- end)
- (L)
-;;
-
-module type LexerType = sig val lexer : Token.lexer;; end;;
-
-module Make (L : LexerType) =
- GGMake (struct let reinit_gram = reinit_gram;; end)
- (struct type te = Token.t;; let lexer = glexer_of_lexer L.lexer;; end)
-;;
diff --git a/camlp4/ocaml_src/lib/grammar.mli b/camlp4/ocaml_src/lib/grammar.mli
deleted file mode 100644
index d38b449f95..0000000000
--- a/camlp4/ocaml_src/lib/grammar.mli
+++ /dev/null
@@ -1,200 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-(** Extensible grammars.
-
- This module implements the Camlp4 extensible grammars system.
- Grammars entries can be extended using the [EXTEND] statement,
- added by loading the Camlp4 [pa_extend.cmo] file. *)
-
-type g;;
- (** The type for grammars, holding entries. *)
-val gcreate : Token.t Token.glexer -> g;;
- (** Create a new grammar, without keywords, using the lexer given
- as parameter. *)
-val tokens : g -> string -> (string * int) list;;
- (** Given a grammar and a token pattern constructor, returns the list of
- the corresponding values currently used in all entries of this grammar.
- The integer is the number of times this pattern value is used.
-
- Examples:
-- If the associated lexer uses ("", xxx) to represent a keyword
- (what is represented by then simple string xxx in an [EXTEND]
- statement rule), the call [Grammar.token g ""] returns the keywords
- list.
-- The call [Grammar.token g "IDENT"] returns the list of all usages
- of the pattern "IDENT" in the [EXTEND] statements. *)
-val glexer : g -> Token.t Token.glexer;;
- (** Return the lexer used by the grammar *)
-
-module Entry :
- sig
- type 'a e;;
- val create : g -> string -> 'a e;;
- val parse : 'a e -> char Stream.t -> 'a;;
- val parse_token : 'a e -> Token.t Stream.t -> 'a;;
- val name : 'a e -> string;;
- val of_parser : g -> string -> (Token.t Stream.t -> 'a) -> 'a e;;
- val print : 'a e -> unit;;
- val find : 'a e -> string -> Obj.t e;;
- external obj : 'a e -> Token.t Gramext.g_entry = "%identity";;
- end
-;;
- (** Module to handle entries.
-- [Entry.e] is the type for entries returning values of type ['a].
-- [Entry.create g n] creates a new entry named [n] in the grammar [g].
-- [Entry.parse e] returns the stream parser of the entry [e].
-- [Entry.parse_token e] returns the token parser of the entry [e].
-- [Entry.name e] returns the name of the entry [e].
-- [Entry.of_parser g n p] makes an entry from a token stream parser.
-- [Entry.print e] displays the entry [e] using [Format].
-- [Entry.find e s] finds the entry named [s] in [e]'s rules.
-- [Entry.obj e] converts an entry into a [Gramext.g_entry] allowing
-- to see what it holds ([Gramext] is visible, but not documented). *)
-
-val of_entry : 'a Entry.e -> g;;
- (** Return the grammar associated with an entry. *)
-
-(** {6 Clearing grammars and entries} *)
-
-module Unsafe :
- sig
- val gram_reinit : g -> Token.t Token.glexer -> unit;;
- val clear_entry : 'a Entry.e -> unit;;
- val reinit_gram : g -> Token.lexer -> unit;;
- end
-;;
- (** Module for clearing grammars and entries. To be manipulated with
- care, because: 1) reinitializing a grammar destroys all tokens
- and there may have problems with the associated lexer if it has
- a notion of keywords; 2) clearing an entry does not destroy the
- tokens used only by itself.
-- [Unsafe.reinit_gram g lex] removes the tokens of the grammar
-- and sets [lex] as a new lexer for [g]. Warning: the lexer
-- itself is not reinitialized.
-- [Unsafe.clear_entry e] removes all rules of the entry [e]. *)
-
-(** {6 Functorial interface} *)
-
- (** Alternative for grammars use. Grammars are no more Ocaml values:
- there is no type for them. Modules generated preserve the
- rule "an entry cannot call an entry of another grammar" by
- normal OCaml typing. *)
-
-module type GLexerType = sig type te;; val lexer : te Token.glexer;; end;;
- (** The input signature for the functor [Grammar.GMake]: [te] is the
- type of the tokens. *)
-
-module type S =
- sig
- type te;;
- type parsable;;
- val parsable : char Stream.t -> parsable;;
- val tokens : string -> (string * int) list;;
- val glexer : te Token.glexer;;
- module Entry :
- sig
- type 'a e;;
- val create : string -> 'a e;;
- val parse : 'a e -> parsable -> 'a;;
- val parse_token : 'a e -> te Stream.t -> 'a;;
- val name : 'a e -> string;;
- val of_parser : string -> (te Stream.t -> 'a) -> 'a e;;
- val print : 'a e -> unit;;
- external obj : 'a e -> te Gramext.g_entry = "%identity";;
- end
- ;;
- module Unsafe :
- sig
- val gram_reinit : te Token.glexer -> unit;;
- val clear_entry : 'a Entry.e -> unit;;
- val reinit_gram : Token.lexer -> unit;;
- end
- ;;
- val extend :
- 'a Entry.e -> Gramext.position option ->
- (string option * Gramext.g_assoc option *
- (te Gramext.g_symbol list * Gramext.g_action) list)
- list ->
- unit;;
- val delete_rule : 'a Entry.e -> te Gramext.g_symbol list -> unit;;
- end
-;;
- (** Signature type of the functor [Grammar.GMake]. The types and
- functions are almost the same than in generic interface, but:
-- Grammars are not values. Functions holding a grammar as parameter
- do not have this parameter yet.
-- The type [parsable] is used in function [parse] instead of
- the char stream, avoiding the possible loss of tokens.
-- The type of tokens (expressions and patterns) can be any
- type (instead of (string * string)); the module parameter
- must specify a way to show them as (string * string) *)
-
-module GMake (L : GLexerType) : S with type te = L.te;;
-
-(** {6 Miscellaneous} *)
-
-val error_verbose : bool ref;;
- (** Flag for displaying more information in case of parsing error;
- default = [False] *)
-
-val warning_verbose : bool ref;;
- (** Flag for displaying warnings while extension; default = [True] *)
-
-val strict_parsing : bool ref;;
- (** Flag to apply strict parsing, without trying to recover errors;
- default = [False] *)
-
-val print_entry : Format.formatter -> 'te Gramext.g_entry -> unit;;
- (** General printer for all kinds of entries (obj entries) *)
-
-val iter_entry :
- ('te Gramext.g_entry -> unit) -> 'te Gramext.g_entry -> unit;;
- (** [Grammar.iter_entry f e] applies [f] to the entry [e] and
- transitively all entries called by [e]. The order in which
- the entries are passed to [f] is the order they appear in
- each entry. Each entry is passed only once. *)
-
-val fold_entry :
- ('te Gramext.g_entry -> 'a -> 'a) -> 'te Gramext.g_entry -> 'a -> 'a;;
- (** [Grammar.fold_entry f e init] computes [(f eN .. (f e2 (f e1 init)))],
- where [e1 .. eN] are [e] and transitively all entries called by [e].
- The order in which the entries are passed to [f] is the order they
- appear in each entry. Each entry is passed only once. *)
-
-(**/**)
-
-(*** deprecated since version 3.05; use rather the functor GMake *)
-module type LexerType = sig val lexer : Token.lexer;; end;;
-module Make (L : LexerType) : S with type te = Token.t;;
-(*** deprecated since version 3.05; use rather the function gcreate *)
-val create : Token.lexer -> g;;
-
-(*** For system use *)
-
-val loc_of_token_interval : int -> int -> int * int;;
-val extend :
- ('te Gramext.g_entry * Gramext.position option *
- (string option * Gramext.g_assoc option *
- ('te Gramext.g_symbol list * Gramext.g_action) list)
- list)
- list ->
- unit;;
-val delete_rule : 'a Entry.e -> Token.t Gramext.g_symbol list -> unit;;
-
-val parse_top_symb :
- 'te Gramext.g_entry -> 'te Gramext.g_symbol -> 'te Stream.t -> Obj.t;;
-val symb_failed_txt :
- 'te Gramext.g_entry -> 'te Gramext.g_symbol -> 'te Gramext.g_symbol ->
- string;;
diff --git a/camlp4/ocaml_src/lib/plexer.ml b/camlp4/ocaml_src/lib/plexer.ml
deleted file mode 100644
index 4b5dcca151..0000000000
--- a/camlp4/ocaml_src/lib/plexer.ml
+++ /dev/null
@@ -1,1258 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-open Stdpp;;
-open Token;;
-
-let no_quotations = ref false;;
-
-(* The string buffering machinery *)
-
-let buff = ref (String.create 80);;
-let store len x =
- if len >= String.length !buff then
- buff := !buff ^ String.create (String.length !buff);
- !buff.[len] <- x;
- succ len
-;;
-let mstore len s =
- let rec add_rec len i =
- if i == String.length s then len else add_rec (store len s.[i]) (succ i)
- in
- add_rec len 0
-;;
-let get_buff len = String.sub !buff 0 len;;
-
-(* The lexer *)
-
-let stream_peek_nth n strm =
- let rec loop n =
- function
- [] -> None
- | [x] -> if n == 1 then Some x else None
- | _ :: l -> loop (n - 1) l
- in
- loop n (Stream.npeek n strm)
-;;
-
-let rec ident len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some
- ('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
- '\248'..'\255' | '0'..'9' | '_' | '\'' as c) ->
- Stream.junk strm__; ident (store len c) strm__
- | _ -> len
-and ident2 len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some
- ('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' |
- '.' | ':' | '<' | '>' | '|' | '$' as c) ->
- Stream.junk strm__; ident2 (store len c) strm__
- | _ -> len
-and ident3 len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some
- ('0'..'9' | 'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
- '\248'..'\255' | '_' | '!' | '%' | '&' | '*' | '+' | '-' | '.' | '/' |
- ':' | '<' | '=' | '>' | '?' | '@' | '^' | '|' | '~' | '\'' | '$' as c
- ) ->
- Stream.junk strm__; ident3 (store len c) strm__
- | _ -> len
-and base_number len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ('o' | 'O') ->
- Stream.junk strm__; digits octal (store len 'o') strm__
- | Some ('x' | 'X') -> Stream.junk strm__; digits hexa (store len 'x') strm__
- | Some ('b' | 'B') ->
- Stream.junk strm__; digits binary (store len 'b') strm__
- | _ -> number len strm__
-and digits kind len (strm__ : _ Stream.t) =
- let d =
- try kind strm__ with
- Stream.Failure -> raise (Stream.Error "ill-formed integer constant")
- in
- digits_under kind (store len d) strm__
-and digits_under kind len (strm__ : _ Stream.t) =
- match
- try Some (kind strm__) with
- Stream.Failure -> None
- with
- Some d -> digits_under kind (store len d) strm__
- | _ ->
- match Stream.peek strm__ with
- Some '_' -> Stream.junk strm__; digits_under kind len strm__
- | _ -> "INT", get_buff len
-and octal (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ('0'..'7' as d) -> Stream.junk strm__; d
- | _ -> raise Stream.Failure
-and hexa (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ('0'..'9' | 'a'..'f' | 'A'..'F' as d) -> Stream.junk strm__; d
- | _ -> raise Stream.Failure
-and binary (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ('0'..'1' as d) -> Stream.junk strm__; d
- | _ -> raise Stream.Failure
-and number len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ('0'..'9' as c) -> Stream.junk strm__; number (store len c) strm__
- | Some '_' -> Stream.junk strm__; number len strm__
- | Some '.' -> Stream.junk strm__; decimal_part (store len '.') strm__
- | Some ('e' | 'E') ->
- Stream.junk strm__; exponent_part (store len 'E') strm__
- | Some 'l' -> Stream.junk strm__; "INT32", get_buff len
- | Some 'L' -> Stream.junk strm__; "INT64", get_buff len
- | Some 'n' -> Stream.junk strm__; "NATIVEINT", get_buff len
- | _ -> "INT", get_buff len
-and decimal_part len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ('0'..'9' as c) ->
- Stream.junk strm__; decimal_part (store len c) strm__
- | Some '_' -> Stream.junk strm__; decimal_part len strm__
- | Some ('e' | 'E') ->
- Stream.junk strm__; exponent_part (store len 'E') strm__
- | _ -> "FLOAT", get_buff len
-and exponent_part len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ('+' | '-' as c) ->
- Stream.junk strm__; end_exponent_part (store len c) strm__
- | _ -> end_exponent_part len strm__
-and end_exponent_part len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ('0'..'9' as c) ->
- Stream.junk strm__; end_exponent_part_under (store len c) strm__
- | _ -> raise (Stream.Error "ill-formed floating-point constant")
-and end_exponent_part_under len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ('0'..'9' as c) ->
- Stream.junk strm__; end_exponent_part_under (store len c) strm__
- | Some '_' -> Stream.junk strm__; end_exponent_part_under len strm__
- | _ -> "FLOAT", get_buff len
-;;
-
-let error_on_unknown_keywords = ref false;;
-let err loc msg = raise_with_loc loc (Token.Error msg);;
-
-(*
-value next_token_fun dfa find_kwd =
- let keyword_or_error loc s =
- try (("", find_kwd s), loc) with
- [ Not_found ->
- if error_on_unknown_keywords.val then err loc ("illegal token: " ^ s)
- else (("", s), loc) ]
- in
- let rec next_token =
- parser bp
- [ [: `' ' | '\010' | '\013' | '\t' | '\026' | '\012'; s :] ->
- next_token s
- | [: `'('; s :] -> left_paren bp s
- | [: `'#'; s :] -> do { spaces_tabs s; linenum bp s }
- | [: `('A'..'Z' | '\192'..'\214' | '\216'..'\222' as c); s :] ->
- let id = get_buff (ident (store 0 c) s) in
- let loc = (bp, Stream.count s) in
- (try ("", find_kwd id) with [ Not_found -> ("UIDENT", id) ], loc)
- | [: `('a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' as c); s :] ->
- let id = get_buff (ident (store 0 c) s) in
- let loc = (bp, Stream.count s) in
- (try ("", find_kwd id) with [ Not_found -> ("LIDENT", id) ], loc)
- | [: `('1'..'9' as c); s :] ->
- let tok = number (store 0 c) s in
- let loc = (bp, Stream.count s) in
- (tok, loc)
- | [: `'0'; s :] ->
- let tok = base_number (store 0 '0') s in
- let loc = (bp, Stream.count s) in
- (tok, loc)
- | [: `'''; s :] ->
- match Stream.npeek 3 s with
- [ [_; '''; _] | ['\\'; _; _] | ['\x0D'; '\x0A'; '''] ->
- let tok = ("CHAR", get_buff (char bp 0 s)) in
- let loc = (bp, Stream.count s) in
- (tok, loc)
- | _ -> keyword_or_error (bp, Stream.count s) "'" ]
- | [: `'"'; s :] ->
- let tok = ("STRING", get_buff (string bp 0 s)) in
- let loc = (bp, Stream.count s) in
- (tok, loc)
- | [: `'$'; s :] ->
- let tok = dollar bp 0 s in
- let loc = (bp, Stream.count s) in
- (tok, loc)
- | [: `('!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c);
- s :] ->
- let id = get_buff (ident2 (store 0 c) s) in
- keyword_or_error (bp, Stream.count s) id
- | [: `('~' as c);
- a =
- parser
- [ [: `('a'..'z' as c); len = ident (store 0 c) :] ep ->
- (("TILDEIDENT", get_buff len), (bp, ep))
- | [: s :] ->
- let id = get_buff (ident2 (store 0 c) s) in
- keyword_or_error (bp, Stream.count s) id ] :] ->
- a
- | [: `('?' as c);
- a =
- parser
- [ [: `('a'..'z' as c); len = ident (store 0 c) :] ep ->
- (("QUESTIONIDENT", get_buff len), (bp, ep))
- | [: s :] ->
- let id = get_buff (ident2 (store 0 c) s) in
- keyword_or_error (bp, Stream.count s) id ] :] ->
- a
- | [: `'<'; s :] -> less bp s
- | [: `(':' as c1);
- len =
- parser
- [ [: `(']' | ':' | '=' | '>' as c2) :] -> store (store 0 c1) c2
- | [: :] -> store 0 c1 ] :] ep ->
- let id = get_buff len in
- keyword_or_error (bp, ep) id
- | [: `('>' | '|' as c1);
- len =
- parser
- [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2
- | [: a = ident2 (store 0 c1) :] -> a ] :] ep ->
- let id = get_buff len in
- keyword_or_error (bp, ep) id
- | [: `('[' | '{' as c1); s :] ->
- let len =
- match Stream.npeek 2 s with
- [ ['<'; '<' | ':'] -> store 0 c1
- | _ ->
- match s with parser
- [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2
- | [: :] -> store 0 c1 ] ]
- in
- let ep = Stream.count s in
- let id = get_buff len in
- keyword_or_error (bp, ep) id
- | [: `'.';
- id =
- parser
- [ [: `'.' :] -> ".."
- | [: :] -> if ssd && after_space then " ." else "." ] :] ep ->
- keyword_or_error (bp, ep) id
- | [: `';';
- id =
- parser
- [ [: `';' :] -> ";;"
- | [: :] -> ";" ] :] ep ->
- keyword_or_error (bp, ep) id
- | [: `'\\'; s :] ep -> (("LIDENT", get_buff (ident3 0 s)), (bp, ep))
- | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c)
- | [: _ = Stream.empty :] -> (("EOI", ""), (bp, succ bp)) ]
- and less bp strm =
- if no_quotations.val then
- match strm with parser
- [ [: len = ident2 (store 0 '<') :] ep ->
- let id = get_buff len in
- keyword_or_error (bp, ep) id ]
- else
- match strm with parser
- [ [: `'<'; len = quotation bp 0 :] ep ->
- (("QUOTATION", ":" ^ get_buff len), (bp, ep))
- | [: `':'; i = parser [: len = ident 0 :] -> get_buff len;
- `'<' ? "character '<' expected"; len = quotation bp 0 :] ep ->
- (("QUOTATION", i ^ ":" ^ get_buff len), (bp, ep))
- | [: len = ident2 (store 0 '<') :] ep ->
- let id = get_buff len in
- keyword_or_error (bp, ep) id ]
- and string bp len =
- parser
- [ [: `'"' :] -> len
- | [: `'\\'; `c; s :] -> string bp (store (store len '\\') c) s
- | [: `c; s :] -> string bp (store len c) s
- | [: :] ep -> err (bp, ep) "string not terminated" ]
- and char bp len =
- parser
- [ [: `'''; s :] -> if len = 0 then char bp (store len ''') s else len
- | [: `'\\'; `c; s :] -> char bp (store (store len '\\') c) s
- | [: `c; s :] -> char bp (store len c) s
- | [: :] ep -> err (bp, ep) "char not terminated" ]
- and dollar bp len =
- parser
- [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
- | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bp (store len c) s
- | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s
- | [: `':'; s :] ->
- let k = get_buff len in
- ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s)
- | [: `'\\'; `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: s :] ->
- if dfa then
- match s with parser
- [ [: `c :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
- else ("", get_buff (ident2 (store 0 '$') s)) ]
- and maybe_locate bp len =
- parser
- [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
- | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s
- | [: `':'; s :] ->
- ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 s)
- | [: `'\\'; `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
- and antiquot bp len =
- parser
- [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
- | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] ->
- antiquot bp (store len c) s
- | [: `':'; s :] ->
- let k = get_buff len in
- ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s)
- | [: `'\\'; `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
- and locate_or_antiquot_rest bp len =
- parser
- [ [: `'$' :] -> get_buff len
- | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bp (store len c) s
- | [: `c; s :] -> locate_or_antiquot_rest bp (store len c) s
- | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
- and quotation bp len =
- parser
- [ [: `'>'; s :] -> maybe_end_quotation bp len s
- | [: `'<'; s :] ->
- quotation bp (maybe_nested_quotation bp (store len '<') s) s
- | [: `'\\';
- len =
- parser
- [ [: `('>' | '<' | '\\' as c) :] -> store len c
- | [: :] -> store len '\\' ];
- s :] ->
- quotation bp len s
- | [: `c; s :] -> quotation bp (store len c) s
- | [: :] ep -> err (bp, ep) "quotation not terminated" ]
- and maybe_nested_quotation bp len =
- parser
- [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>"
- | [: `':'; len = ident (store len ':');
- a =
- parser
- [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>"
- | [: :] -> len ] :] ->
- a
- | [: :] -> len ]
- and maybe_end_quotation bp len =
- parser
- [ [: `'>' :] -> len
- | [: a = quotation bp (store len '>') :] -> a ]
- and left_paren bp =
- parser
- [ [: `'*'; _ = comment bp; a = next_token True :] -> a
- | [: :] ep -> keyword_or_error (bp, ep) "(" ]
- and comment bp =
- parser
- [ [: `'('; s :] -> left_paren_in_comment bp s
- | [: `'*'; s :] -> star_in_comment bp s
- | [: `'"'; _ = string bp 0; s :] -> comment bp s
- | [: `'''; s :] -> quote_in_comment bp s
- | [: `c; s :] -> comment bp s
- | [: :] ep -> err (bp, ep) "comment not terminated" ]
- and quote_in_comment bp =
- parser
- [ [: `'''; s :] -> comment bp s
- | [: `'\013'; s :] -> quote_cr_in_comment bp s
- | [: `'\\'; s :] -> quote_antislash_in_comment bp s
- | [: `'('; s :] -> quote_left_paren_in_comment bp s
- | [: `'*'; s :] -> quote_star_in_comment bp s
- | [: `'"'; s :] -> quote_doublequote_in_comment bp s
- | [: `_; s :] -> quote_any_in_comment bp s
- | [: s :] -> comment bp s ]
- and quote_any_in_comment bp =
- parser
- [ [: `'''; s :] -> comment bp s
- | [: s :] -> comment bp s ]
- and quote_cr_in_comment bp =
- parser
- [ [: `'\010'; s :] -> quote_any_in_comment bp s
- | [: s :] -> quote_any_in_comment bp s ]
- and quote_left_paren_in_comment bp =
- parser
- [ [: `'''; s :] -> comment bp s
- | [: s :] -> left_paren_in_comment bp s ]
- and quote_star_in_comment bp =
- parser
- [ [: `'''; s :] -> comment bp s
- | [: s :] -> star_in_comment bp s ]
- and quote_doublequote_in_comment bp =
- parser
- [ [: `'''; s :] -> comment bp s
- | [: _ = string bp 0; s :] -> comment bp s ]
- and quote_antislash_in_comment bp =
- parser
- [ [: `'''; s :] -> quote_antislash_quote_in_comment bp s
- | [: `('\\' | '"' | 'n' | 't' | 'b' | 'r'); s :] ->
- quote_any_in_comment bp s
- | [: `('0'..'9'); s :] -> quote_antislash_digit_in_comment bp s
- | [: `'x'; s :] -> quote_antislash_x_in_comment bp s
- | [: s :] -> comment bp s ]
- and quote_antislash_quote_in_comment bp =
- parser
- [ [: `'''; s :] -> comment bp s
- | [: s :] -> quote_in_comment bp s ]
- and quote_antislash_digit_in_comment bp =
- parser
- [ [: `('0'..'9'); s :] -> quote_antislash_digit2_in_comment bp s
- | [: s :] -> comment bp s ]
- and quote_antislash_digit2_in_comment bp =
- parser
- [ [: `('0'..'9'); s :] -> quote_any_in_comment bp s
- | [: s :] -> comment bp s ]
- and quote_antislash_x_in_comment bp =
- parser
- [ [: _ = hexa; s :] -> quote_antislash_x_digit_in_comment bp s
- | [: s :] -> comment bp s ]
- and quote_antislash_x_digit_in_comment bp =
- parser
- [ [: _ = hexa; s :] -> quote_any_in_comment bp s
- | [: s :] -> comment bp s ]
- and left_paren_in_comment bp =
- parser
- [ [: `'*'; s :] -> do { comment bp s; comment bp s }
- | [: a = comment bp :] -> a ]
- and star_in_comment bp =
- parser
- [ [: `')' :] -> ()
- | [: a = comment bp :] -> a ]
- and linedir n s =
- match stream_peek_nth n s with
- [ Some (' ' | '\t') -> linedir (n + 1) s
- | Some ('0'..'9') -> linedir_digits (n + 1) s
- | _ -> False ]
- and linedir_digits n s =
- match stream_peek_nth n s with
- [ Some ('0'..'9') -> linedir_digits (n + 1) s
- | _ -> linedir_quote n s ]
- and linedir_quote n s =
- match stream_peek_nth n s with
- [ Some (' ' | '\t') -> linedir_quote (n + 1) s
- | Some '"' -> True
- | _ -> False ]
- and any_to_nl =
- parser
- [ [: `'\013' | '\010' :] ep -> bolpos.val := ep
- | [: `_; s :] -> any_to_nl s
- | [: :] -> () ]
- in
- fun cstrm ->
- try
- let glex = glexr.val in
- let comm_bp = Stream.count cstrm in
- let r = next_token False cstrm in
- do {
- match glex.tok_comm with
- [ Some list ->
- if fst (snd r) > comm_bp then
- let comm_loc = (comm_bp, fst (snd r)) in
- glex.tok_comm := Some [comm_loc :: list]
- else ()
- | None -> () ];
- r
- }
- with
- [ Stream.Error str ->
- err (Stream.count cstrm, Stream.count cstrm + 1) str ]
-;
-*)
-
-let next_token_fun dfa ssd find_kwd bolpos glexr =
- let keyword_or_error loc s =
- try ("", find_kwd s), loc with
- Not_found ->
- if !error_on_unknown_keywords then err loc ("illegal token: " ^ s)
- else ("", s), loc
- in
- let error_if_keyword ((_, id), loc as a) =
- try
- ignore (find_kwd id);
- err loc ("illegal use of a keyword as a label: " ^ id)
- with
- Not_found -> a
- in
- let rec next_token after_space (strm__ : _ Stream.t) =
- let bp = Stream.count strm__ in
- match Stream.peek strm__ with
- Some ('\010' | '\013') ->
- Stream.junk strm__;
- let s = strm__ in
- let ep = Stream.count strm__ in bolpos := ep; next_token true s
- | Some (' ' | '\t' | '\026' | '\012') ->
- Stream.junk strm__; next_token true strm__
- | Some '#' when bp = !bolpos ->
- Stream.junk strm__;
- let s = strm__ in
- if linedir 1 s then begin any_to_nl s; next_token true s end
- else keyword_or_error (bp, bp + 1) "#"
- | Some '(' -> Stream.junk strm__; left_paren bp strm__
- | Some ('A'..'Z' | '\192'..'\214' | '\216'..'\222' as c) ->
- Stream.junk strm__;
- let s = strm__ in
- let id = get_buff (ident (store 0 c) s) in
- let loc = bp, Stream.count s in
- (try "", find_kwd id with
- Not_found -> "UIDENT", id),
- loc
- | Some ('a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' as c) ->
- Stream.junk strm__;
- let s = strm__ in
- let id = get_buff (ident (store 0 c) s) in
- let loc = bp, Stream.count s in
- (try "", find_kwd id with
- Not_found -> "LIDENT", id),
- loc
- | Some ('1'..'9' as c) ->
- Stream.junk strm__;
- let tok = number (store 0 c) strm__ in
- let loc = bp, Stream.count strm__ in tok, loc
- | Some '0' ->
- Stream.junk strm__;
- let tok = base_number (store 0 '0') strm__ in
- let loc = bp, Stream.count strm__ in tok, loc
- | Some '\'' ->
- Stream.junk strm__;
- let s = strm__ in
- begin match Stream.npeek 2 s with
- [_; '\''] | ['\\'; _] ->
- let tok = "CHAR", get_buff (char bp 0 s) in
- let loc = bp, Stream.count s in tok, loc
- | _ -> keyword_or_error (bp, Stream.count s) "'"
- end
- | Some '\"' ->
- Stream.junk strm__;
- let tok = "STRING", get_buff (string bp 0 strm__) in
- let loc = bp, Stream.count strm__ in tok, loc
- | Some '$' ->
- Stream.junk strm__;
- let tok = dollar bp 0 strm__ in
- let loc = bp, Stream.count strm__ in tok, loc
- | Some ('!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c) ->
- Stream.junk strm__;
- let id = get_buff (ident2 (store 0 c) strm__) in
- keyword_or_error (bp, Stream.count strm__) id
- | Some ('~' as c) ->
- Stream.junk strm__;
- begin try
- match Stream.peek strm__ with
- Some ('a'..'z' as c) ->
- Stream.junk strm__;
- let len =
- try ident (store 0 c) strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- let s = strm__ in
- let ep = Stream.count strm__ in
- let id = get_buff len in
- let (strm__ : _ Stream.t) = s in
- begin match Stream.peek strm__ with
- Some ':' ->
- Stream.junk strm__;
- let eb = Stream.count strm__ in
- error_if_keyword (("LABEL", id), (bp, ep))
- | _ -> error_if_keyword (("TILDEIDENT", id), (bp, ep))
- end
- | _ ->
- let id = get_buff (ident2 (store 0 c) strm__) in
- keyword_or_error (bp, Stream.count strm__) id
- with
- Stream.Failure -> raise (Stream.Error "")
- end
- | Some ('?' as c) ->
- Stream.junk strm__;
- begin try
- match Stream.peek strm__ with
- Some ('a'..'z' as c) ->
- Stream.junk strm__;
- let len =
- try ident (store 0 c) strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- let s = strm__ in
- let ep = Stream.count strm__ in
- let id = get_buff len in
- let (strm__ : _ Stream.t) = s in
- begin match Stream.peek strm__ with
- Some ':' ->
- Stream.junk strm__;
- let eb = Stream.count strm__ in
- error_if_keyword (("OPTLABEL", id), (bp, ep))
- | _ -> error_if_keyword (("QUESTIONIDENT", id), (bp, ep))
- end
- | _ ->
- let id = get_buff (ident2 (store 0 c) strm__) in
- keyword_or_error (bp, Stream.count strm__) id
- with
- Stream.Failure -> raise (Stream.Error "")
- end
- | Some '<' -> Stream.junk strm__; less bp strm__
- | Some (':' as c1) ->
- Stream.junk strm__;
- let len =
- try
- match Stream.peek strm__ with
- Some (']' | ':' | '=' | '>' as c2) ->
- Stream.junk strm__; store (store 0 c1) c2
- | _ -> store 0 c1
- with
- Stream.Failure -> raise (Stream.Error "")
- in
- let ep = Stream.count strm__ in
- let id = get_buff len in keyword_or_error (bp, ep) id
- | Some ('>' | '|' as c1) ->
- Stream.junk strm__;
- let len =
- try
- match Stream.peek strm__ with
- Some (']' | '}' as c2) ->
- Stream.junk strm__; store (store 0 c1) c2
- | _ -> ident2 (store 0 c1) strm__
- with
- Stream.Failure -> raise (Stream.Error "")
- in
- let ep = Stream.count strm__ in
- let id = get_buff len in keyword_or_error (bp, ep) id
- | Some ('[' | '{' as c1) ->
- Stream.junk strm__;
- let s = strm__ in
- let len =
- match Stream.npeek 2 s with
- ['<'; '<' | ':'] -> store 0 c1
- | _ ->
- let (strm__ : _ Stream.t) = s in
- match Stream.peek strm__ with
- Some ('|' | '<' | ':' as c2) ->
- Stream.junk strm__; store (store 0 c1) c2
- | _ -> store 0 c1
- in
- let ep = Stream.count s in
- let id = get_buff len in keyword_or_error (bp, ep) id
- | Some '.' ->
- Stream.junk strm__;
- let id =
- try
- match Stream.peek strm__ with
- Some '.' -> Stream.junk strm__; ".."
- | _ -> if ssd && after_space then " ." else "."
- with
- Stream.Failure -> raise (Stream.Error "")
- in
- let ep = Stream.count strm__ in keyword_or_error (bp, ep) id
- | Some ';' ->
- Stream.junk strm__;
- let id =
- try
- match Stream.peek strm__ with
- Some ';' -> Stream.junk strm__; ";;"
- | _ -> ";"
- with
- Stream.Failure -> raise (Stream.Error "")
- in
- let ep = Stream.count strm__ in keyword_or_error (bp, ep) id
- | Some '\\' ->
- Stream.junk strm__;
- let ep = Stream.count strm__ in
- ("LIDENT", get_buff (ident3 0 strm__)), (bp, ep)
- | Some c ->
- Stream.junk strm__;
- let ep = Stream.count strm__ in
- keyword_or_error (bp, ep) (String.make 1 c)
- | _ -> let _ = Stream.empty strm__ in ("EOI", ""), (bp, succ bp)
- and less bp strm =
- if !no_quotations then
- let (strm__ : _ Stream.t) = strm in
- let len = ident2 (store 0 '<') strm__ in
- let ep = Stream.count strm__ in
- let id = get_buff len in keyword_or_error (bp, ep) id
- else
- let (strm__ : _ Stream.t) = strm in
- match Stream.peek strm__ with
- Some '<' ->
- Stream.junk strm__;
- let len =
- try quotation bp 0 strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- let ep = Stream.count strm__ in
- ("QUOTATION", ":" ^ get_buff len), (bp, ep)
- | Some ':' ->
- Stream.junk strm__;
- let i =
- try let len = ident 0 strm__ in get_buff len with
- Stream.Failure -> raise (Stream.Error "")
- in
- begin match Stream.peek strm__ with
- Some '<' ->
- Stream.junk strm__;
- let len =
- try quotation bp 0 strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- let ep = Stream.count strm__ in
- ("QUOTATION", i ^ ":" ^ get_buff len), (bp, ep)
- | _ -> raise (Stream.Error "character '<' expected")
- end
- | _ ->
- let len = ident2 (store 0 '<') strm__ in
- let ep = Stream.count strm__ in
- let id = get_buff len in keyword_or_error (bp, ep) id
- and string bp len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '\"' -> Stream.junk strm__; len
- | Some '\\' ->
- Stream.junk strm__;
- begin match Stream.peek strm__ with
- Some c ->
- Stream.junk strm__;
- let ep = Stream.count strm__ in
- string bp (store (store len '\\') c) strm__
- | _ -> raise (Stream.Error "")
- end
- | Some c -> Stream.junk strm__; string bp (store len c) strm__
- | _ ->
- let ep = Stream.count strm__ in err (bp, ep) "string not terminated"
- and char bp len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '\'' ->
- Stream.junk strm__;
- let s = strm__ in if len = 0 then char bp (store len '\'') s else len
- | Some '\\' ->
- Stream.junk strm__;
- begin match Stream.peek strm__ with
- Some c ->
- Stream.junk strm__; char bp (store (store len '\\') c) strm__
- | _ -> raise (Stream.Error "")
- end
- | Some c -> Stream.junk strm__; char bp (store len c) strm__
- | _ -> let ep = Stream.count strm__ in err (bp, ep) "char not terminated"
- and dollar bp len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '$' -> Stream.junk strm__; "ANTIQUOT", ":" ^ get_buff len
- | Some ('a'..'z' | 'A'..'Z' as c) ->
- Stream.junk strm__; antiquot bp (store len c) strm__
- | Some ('0'..'9' as c) ->
- Stream.junk strm__; maybe_locate bp (store len c) strm__
- | Some ':' ->
- Stream.junk strm__;
- let k = get_buff len in
- "ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 strm__
- | Some '\\' ->
- Stream.junk strm__;
- begin match Stream.peek strm__ with
- Some c ->
- Stream.junk strm__;
- "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) strm__
- | _ -> raise (Stream.Error "")
- end
- | _ ->
- let s = strm__ in
- if dfa then
- let (strm__ : _ Stream.t) = s in
- match Stream.peek strm__ with
- Some c ->
- Stream.junk strm__;
- "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s
- | _ ->
- let ep = Stream.count strm__ in
- err (bp, ep) "antiquotation not terminated"
- else "", get_buff (ident2 (store 0 '$') s)
- and maybe_locate bp len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '$' -> Stream.junk strm__; "ANTIQUOT", ":" ^ get_buff len
- | Some ('0'..'9' as c) ->
- Stream.junk strm__; maybe_locate bp (store len c) strm__
- | Some ':' ->
- Stream.junk strm__;
- "LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 strm__
- | Some '\\' ->
- Stream.junk strm__;
- begin match Stream.peek strm__ with
- Some c ->
- Stream.junk strm__;
- "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) strm__
- | _ -> raise (Stream.Error "")
- end
- | Some c ->
- Stream.junk strm__;
- "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) strm__
- | _ ->
- let ep = Stream.count strm__ in
- err (bp, ep) "antiquotation not terminated"
- and antiquot bp len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '$' -> Stream.junk strm__; "ANTIQUOT", ":" ^ get_buff len
- | Some ('a'..'z' | 'A'..'Z' | '0'..'9' as c) ->
- Stream.junk strm__; antiquot bp (store len c) strm__
- | Some ':' ->
- Stream.junk strm__;
- let k = get_buff len in
- "ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 strm__
- | Some '\\' ->
- Stream.junk strm__;
- begin match Stream.peek strm__ with
- Some c ->
- Stream.junk strm__;
- "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) strm__
- | _ -> raise (Stream.Error "")
- end
- | Some c ->
- Stream.junk strm__;
- "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) strm__
- | _ ->
- let ep = Stream.count strm__ in
- err (bp, ep) "antiquotation not terminated"
- and locate_or_antiquot_rest bp len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '$' -> Stream.junk strm__; get_buff len
- | Some '\\' ->
- Stream.junk strm__;
- begin match Stream.peek strm__ with
- Some c ->
- Stream.junk strm__;
- locate_or_antiquot_rest bp (store len c) strm__
- | _ -> raise (Stream.Error "")
- end
- | Some c ->
- Stream.junk strm__; locate_or_antiquot_rest bp (store len c) strm__
- | _ ->
- let ep = Stream.count strm__ in
- err (bp, ep) "antiquotation not terminated"
- and quotation bp len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '>' -> Stream.junk strm__; maybe_end_quotation bp len strm__
- | Some '<' ->
- Stream.junk strm__;
- quotation bp (maybe_nested_quotation bp (store len '<') strm__) strm__
- | Some '\\' ->
- Stream.junk strm__;
- let len =
- try
- match Stream.peek strm__ with
- Some ('>' | '<' | '\\' as c) -> Stream.junk strm__; store len c
- | _ -> store len '\\'
- with
- Stream.Failure -> raise (Stream.Error "")
- in
- quotation bp len strm__
- | Some c -> Stream.junk strm__; quotation bp (store len c) strm__
- | _ ->
- let ep = Stream.count strm__ in
- err (bp, ep) "quotation not terminated"
- and maybe_nested_quotation bp len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '<' ->
- Stream.junk strm__; mstore (quotation bp (store len '<') strm__) ">>"
- | Some ':' ->
- Stream.junk strm__;
- let len =
- try ident (store len ':') strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- begin try
- match Stream.peek strm__ with
- Some '<' ->
- Stream.junk strm__;
- mstore (quotation bp (store len '<') strm__) ">>"
- | _ -> len
- with
- Stream.Failure -> raise (Stream.Error "")
- end
- | _ -> len
- and maybe_end_quotation bp len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '>' -> Stream.junk strm__; len
- | _ -> quotation bp (store len '>') strm__
- and left_paren bp (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '*' ->
- Stream.junk strm__;
- let _ =
- try comment bp strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- begin try next_token true strm__ with
- Stream.Failure -> raise (Stream.Error "")
- end
- | _ -> let ep = Stream.count strm__ in keyword_or_error (bp, ep) "("
- and comment bp (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '(' -> Stream.junk strm__; left_paren_in_comment bp strm__
- | Some '*' -> Stream.junk strm__; star_in_comment bp strm__
- | Some '\"' ->
- Stream.junk strm__;
- let _ =
- try string bp 0 strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- comment bp strm__
- | Some '\'' -> Stream.junk strm__; quote_in_comment bp strm__
- | Some c -> Stream.junk strm__; comment bp strm__
- | _ ->
- let ep = Stream.count strm__ in err (bp, ep) "comment not terminated"
- and quote_in_comment bp (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '\'' -> Stream.junk strm__; comment bp strm__
- | Some '\\' -> Stream.junk strm__; quote_antislash_in_comment bp 0 strm__
- | _ ->
- let s = strm__ in
- begin match Stream.npeek 2 s with
- [_; '\''] -> Stream.junk s; Stream.junk s
- | _ -> ()
- end;
- comment bp s
- and quote_any_in_comment bp (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '\'' -> Stream.junk strm__; comment bp strm__
- | _ -> comment bp strm__
- and quote_antislash_in_comment bp len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '\'' -> Stream.junk strm__; comment bp strm__
- | Some ('\\' | '\"' | 'n' | 't' | 'b' | 'r') ->
- Stream.junk strm__; quote_any_in_comment bp strm__
- | Some ('0'..'9') ->
- Stream.junk strm__; quote_antislash_digit_in_comment bp strm__
- | _ -> comment bp strm__
- and quote_antislash_digit_in_comment bp (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ('0'..'9') ->
- Stream.junk strm__; quote_antislash_digit2_in_comment bp strm__
- | _ -> comment bp strm__
- and quote_antislash_digit2_in_comment bp (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ('0'..'9') -> Stream.junk strm__; quote_any_in_comment bp strm__
- | _ -> comment bp strm__
- and left_paren_in_comment bp (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '*' ->
- Stream.junk strm__; let s = strm__ in comment bp s; comment bp s
- | _ -> comment bp strm__
- and star_in_comment bp (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ')' -> Stream.junk strm__; ()
- | _ -> comment bp strm__
- and linedir n s =
- match stream_peek_nth n s with
- Some (' ' | '\t') -> linedir (n + 1) s
- | Some ('0'..'9') -> linedir_digits (n + 1) s
- | _ -> false
- and linedir_digits n s =
- match stream_peek_nth n s with
- Some ('0'..'9') -> linedir_digits (n + 1) s
- | _ -> linedir_quote n s
- and linedir_quote n s =
- match stream_peek_nth n s with
- Some (' ' | '\t') -> linedir_quote (n + 1) s
- | Some '\"' -> true
- | _ -> false
- and any_to_nl (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ('\013' | '\010') ->
- Stream.junk strm__; let ep = Stream.count strm__ in bolpos := ep
- | Some _ -> Stream.junk strm__; any_to_nl strm__
- | _ -> ()
- in
- fun cstrm ->
- try
- let glex = !glexr in
- let comm_bp = Stream.count cstrm in
- let r = next_token false cstrm in
- begin match glex.tok_comm with
- Some list ->
- if fst (snd r) > comm_bp then
- let comm_loc = comm_bp, fst (snd r) in
- glex.tok_comm <- Some (comm_loc :: list)
- | None -> ()
- end;
- r
- with
- Stream.Error str -> err (Stream.count cstrm, Stream.count cstrm + 1) str
-;;
-
-
-let dollar_for_antiquotation = ref true;;
-let specific_space_dot = ref false;;
-
-let func kwd_table glexr =
- let bolpos = ref 0 in
- let find = Hashtbl.find kwd_table in
- let dfa = !dollar_for_antiquotation in
- let ssd = !specific_space_dot in
- Token.lexer_func_of_parser (next_token_fun dfa ssd find bolpos glexr)
-;;
-
-let rec check_keyword_stream (strm__ : _ Stream.t) =
- let _ = check strm__ in
- let _ =
- try Stream.empty strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- true
-and check (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some
- ('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
- '\248'..'\255') ->
- Stream.junk strm__; check_ident strm__
- | Some
- ('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' |
- '.') ->
- Stream.junk strm__; check_ident2 strm__
- | Some '<' ->
- Stream.junk strm__;
- let s = strm__ in
- begin match Stream.npeek 1 s with
- [':' | '<'] -> ()
- | _ -> check_ident2 s
- end
- | Some ':' ->
- Stream.junk strm__;
- let _ =
- try
- match Stream.peek strm__ with
- Some (']' | ':' | '=' | '>') -> Stream.junk strm__; ()
- | _ -> ()
- with
- Stream.Failure -> raise (Stream.Error "")
- in
- let ep = Stream.count strm__ in ()
- | Some ('>' | '|') ->
- Stream.junk strm__;
- let _ =
- try
- match Stream.peek strm__ with
- Some (']' | '}') -> Stream.junk strm__; ()
- | _ -> check_ident2 strm__
- with
- Stream.Failure -> raise (Stream.Error "")
- in
- ()
- | Some ('[' | '{') ->
- Stream.junk strm__;
- let s = strm__ in
- begin match Stream.npeek 2 s with
- ['<'; '<' | ':'] -> ()
- | _ ->
- let (strm__ : _ Stream.t) = s in
- match Stream.peek strm__ with
- Some ('|' | '<' | ':') -> Stream.junk strm__; ()
- | _ -> ()
- end
- | Some ';' ->
- Stream.junk strm__;
- let _ =
- try
- match Stream.peek strm__ with
- Some ';' -> Stream.junk strm__; ()
- | _ -> ()
- with
- Stream.Failure -> raise (Stream.Error "")
- in
- ()
- | Some _ -> Stream.junk strm__; ()
- | _ -> raise Stream.Failure
-and check_ident (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some
- ('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
- '\248'..'\255' | '0'..'9' | '_' | '\'') ->
- Stream.junk strm__; check_ident strm__
- | _ -> ()
-and check_ident2 (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some
- ('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' |
- '.' | ':' | '<' | '>' | '|') ->
- Stream.junk strm__; check_ident2 strm__
- | _ -> ()
-;;
-
-let check_keyword s =
- try check_keyword_stream (Stream.of_string s) with
- _ -> false
-;;
-
-let error_no_respect_rules p_con p_prm =
- raise
- (Token.Error
- ("the token " ^
- (if p_con = "" then "\"" ^ p_prm ^ "\""
- else if p_prm = "" then p_con
- else p_con ^ " \"" ^ p_prm ^ "\"") ^
- " does not respect Plexer rules"))
-;;
-
-let error_ident_and_keyword p_con p_prm =
- raise
- (Token.Error
- ("the token \"" ^ p_prm ^ "\" is used as " ^ p_con ^
- " and as keyword"))
-;;
-
-let using_token kwd_table ident_table (p_con, p_prm) =
- match p_con with
- "" ->
- if not (Hashtbl.mem kwd_table p_prm) then
- if check_keyword p_prm then
- if Hashtbl.mem ident_table p_prm then
- error_ident_and_keyword (Hashtbl.find ident_table p_prm) p_prm
- else Hashtbl.add kwd_table p_prm p_prm
- else error_no_respect_rules p_con p_prm
- | "LIDENT" ->
- if p_prm = "" then ()
- else
- begin match p_prm.[0] with
- 'A'..'Z' -> error_no_respect_rules p_con p_prm
- | _ ->
- if Hashtbl.mem kwd_table p_prm then
- error_ident_and_keyword p_con p_prm
- else Hashtbl.add ident_table p_prm p_con
- end
- | "UIDENT" ->
- if p_prm = "" then ()
- else
- begin match p_prm.[0] with
- 'a'..'z' -> error_no_respect_rules p_con p_prm
- | _ ->
- if Hashtbl.mem kwd_table p_prm then
- error_ident_and_keyword p_con p_prm
- else Hashtbl.add ident_table p_prm p_con
- end
- | "INT" | "INT32" | "INT64" | "NATIVEINT" | "FLOAT" | "CHAR" | "STRING" |
- "TILDEIDENT" | "QUESTIONIDENT" | "LABEL" | "OPTLABEL" | "QUOTATION" |
- "ANTIQUOT" | "LOCATE" | "EOI" ->
- ()
- | _ ->
- raise
- (Token.Error
- ("the constructor \"" ^ p_con ^ "\" is not recognized by Plexer"))
-;;
-
-let removing_token kwd_table ident_table (p_con, p_prm) =
- match p_con with
- "" -> Hashtbl.remove kwd_table p_prm
- | "LIDENT" | "UIDENT" ->
- if p_prm <> "" then Hashtbl.remove ident_table p_prm
- | _ -> ()
-;;
-
-let text =
- function
- "", t -> "'" ^ t ^ "'"
- | "LIDENT", "" -> "lowercase identifier"
- | "LIDENT", t -> "'" ^ t ^ "'"
- | "UIDENT", "" -> "uppercase identifier"
- | "UIDENT", t -> "'" ^ t ^ "'"
- | "INT", "" -> "integer"
- | "INT32", "" -> "32 bits integer"
- | "INT64", "" -> "64 bits integer"
- | "NATIVEINT", "" -> "native integer"
- | ("INT" | "INT32" | "NATIVEINT"), s -> "'" ^ s ^ "'"
- | "FLOAT", "" -> "float"
- | "STRING", "" -> "string"
- | "CHAR", "" -> "char"
- | "QUOTATION", "" -> "quotation"
- | "ANTIQUOT", k -> "antiquot \"" ^ k ^ "\""
- | "LOCATE", "" -> "locate"
- | "EOI", "" -> "end of input"
- | con, "" -> con
- | con, prm -> con ^ " \"" ^ prm ^ "\""
-;;
-
-let eq_before_colon p e =
- let rec loop i =
- if i == String.length e then
- failwith "Internal error in Plexer: incorrect ANTIQUOT"
- else if i == String.length p then e.[i] == ':'
- else if p.[i] == e.[i] then loop (i + 1)
- else false
- in
- loop 0
-;;
-
-let after_colon e =
- try
- let i = String.index e ':' in
- String.sub e (i + 1) (String.length e - i - 1)
- with
- Not_found -> ""
-;;
-
-let tok_match =
- function
- "ANTIQUOT", p_prm ->
- begin function
- "ANTIQUOT", prm when eq_before_colon p_prm prm -> after_colon prm
- | _ -> raise Stream.Failure
- end
- | tok -> Token.default_match tok
-;;
-
-let gmake () =
- let kwd_table = Hashtbl.create 301 in
- let id_table = Hashtbl.create 301 in
- let glexr =
- ref
- {tok_func = (fun _ -> raise (Match_failure ("plexer.ml", 972, 17)));
- tok_using = (fun _ -> raise (Match_failure ("plexer.ml", 972, 37)));
- tok_removing = (fun _ -> raise (Match_failure ("plexer.ml", 972, 60)));
- tok_match = (fun _ -> raise (Match_failure ("plexer.ml", 973, 18)));
- tok_text = (fun _ -> raise (Match_failure ("plexer.ml", 973, 37)));
- tok_comm = None}
- in
- let glex =
- {tok_func = func kwd_table glexr;
- tok_using = using_token kwd_table id_table;
- tok_removing = removing_token kwd_table id_table; tok_match = tok_match;
- tok_text = text; tok_comm = None}
- in
- glexr := glex; glex
-;;
-
-let tparse =
- function
- "ANTIQUOT", p_prm ->
- let p (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ("ANTIQUOT", prm) when eq_before_colon p_prm prm ->
- Stream.junk strm__; after_colon prm
- | _ -> raise Stream.Failure
- in
- Some p
- | _ -> None
-;;
-
-let make () =
- let kwd_table = Hashtbl.create 301 in
- let id_table = Hashtbl.create 301 in
- let glexr =
- ref
- {tok_func = (fun _ -> raise (Match_failure ("plexer.ml", 1001, 17)));
- tok_using = (fun _ -> raise (Match_failure ("plexer.ml", 1001, 37)));
- tok_removing =
- (fun _ -> raise (Match_failure ("plexer.ml", 1001, 60)));
- tok_match = (fun _ -> raise (Match_failure ("plexer.ml", 1002, 18)));
- tok_text = (fun _ -> raise (Match_failure ("plexer.ml", 1002, 37)));
- tok_comm = None}
- in
- {func = func kwd_table glexr; using = using_token kwd_table id_table;
- removing = removing_token kwd_table id_table; tparse = tparse; text = text}
-;;
diff --git a/camlp4/ocaml_src/lib/plexer.mli b/camlp4/ocaml_src/lib/plexer.mli
deleted file mode 100644
index 601c175331..0000000000
--- a/camlp4/ocaml_src/lib/plexer.mli
+++ /dev/null
@@ -1,72 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-(** A lexical analyzer. *)
-
-val gmake : unit -> Token.t Token.glexer;;
- (** Some lexer provided. See the module [Token]. The tokens returned
- follow the Objective Caml and the Revised syntax lexing rules.
-
- The meaning of the tokens are:
-- * [("", s)] is the keyword [s].
-- * [("LIDENT", s)] is the ident [s] starting with a lowercase letter.
-- * [("UIDENT", s)] is the ident [s] starting with an uppercase letter.
-- * [("INT", s)] (resp. ["INT32"], ["INT64"] and ["NATIVEINT"])
- is an integer constant whose string source is [s].
-- * [("FLOAT", s)] is a float constant whose string source is [s].
-- * [("STRING", s)] is the string constant [s].
-- * [("CHAR", s)] is the character constant [s].
-- * [("QUOTATION", "t:s")] is a quotation [t] holding the string [s].
-- * [("ANTIQUOT", "t:s")] is an antiquotation [t] holding the string [s].
-- * [("LOCATE", "i:s")] is a location directive at pos [i] holding [s].
-- * [("EOI", "")] is the end of input.
-
- The associated token patterns in the EXTEND statement hold the
- same names than the first string (constructor name) of the tokens
- expressions above.
-
- Warning: the string associated with the constructor [STRING] is
- the string found in the source without any interpretation. In
- particular, the backslashes are not interpreted. For example, if
- the input is ["\n"] the string is *not* a string with one
- element containing the character "return", but a string of two
- elements: the backslash and the character ["n"]. To interpret
- a string use the function [Token.eval_string]. Same thing for
- the constructor [CHAR]: to get the character, don't get the
- first character of the string, but use the function
- [Token.eval_char].
-
- The lexer do not use global (mutable) variables: instantiations
- of [Plexer.gmake ()] do not perturb each other. *)
-
-val dollar_for_antiquotation : bool ref;;
- (** When True (default), the next call to [Plexer.make ()] returns a
- lexer where the dollar sign is used for antiquotations. If False,
- the dollar sign can be used as token. *)
-
-val specific_space_dot : bool ref;;
- (** When False (default), the next call to [Plexer.make ()] returns a
- lexer where the dots can be preceded by spaces. If True, dots
- preceded by spaces return the keyword " ." (space dot), otherwise
- return the keyword "." (dot). *)
-
-val no_quotations : bool ref;;
- (** When True, all lexers built by [Plexer.make ()] do not lex the
- quotation syntax any more. Default is False (quotations are
- lexed). *)
-
-(**/**)
-
-(* deprecated since version 3.05; use rather function gmake *)
-val make : unit -> Token.lexer;;
diff --git a/camlp4/ocaml_src/lib/stdpp.ml b/camlp4/ocaml_src/lib/stdpp.ml
deleted file mode 100644
index d91ee78c07..0000000000
--- a/camlp4/ocaml_src/lib/stdpp.ml
+++ /dev/null
@@ -1,99 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-exception Exc_located of (int * int) * exn;;
-
-let raise_with_loc loc exc =
- match exc with
- Exc_located (_, _) -> raise exc
- | _ -> raise (Exc_located (loc, exc))
-;;
-
-let line_of_loc fname (bp, ep) =
- try
- let ic = open_in_bin fname in
- let strm = Stream.of_channel ic in
- let rec loop fname lin =
- let rec not_a_line_dir col (strm__ : _ Stream.t) =
- let cnt = Stream.count strm__ in
- match Stream.peek strm__ with
- Some c ->
- Stream.junk strm__;
- let s = strm__ in
- if cnt < bp then
- if c = '\n' then loop fname (lin + 1)
- else not_a_line_dir (col + 1) s
- else let col = col - (cnt - bp) in fname, lin, col, col + ep - bp
- | _ -> raise Stream.Failure
- in
- let rec a_line_dir str n col (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '\n' -> Stream.junk strm__; loop str n
- | Some _ -> Stream.junk strm__; a_line_dir str n (col + 1) strm__
- | _ -> raise Stream.Failure
- in
- let rec spaces col (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ' ' -> Stream.junk strm__; spaces (col + 1) strm__
- | _ -> col
- in
- let rec check_string str n col (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '\"' ->
- Stream.junk strm__;
- let col =
- try spaces (col + 1) strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- a_line_dir str n col strm__
- | Some c when c <> '\n' ->
- Stream.junk strm__;
- check_string (str ^ String.make 1 c) n (col + 1) strm__
- | _ -> not_a_line_dir col strm__
- in
- let check_quote n col (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '\"' -> Stream.junk strm__; check_string "" n (col + 1) strm__
- | _ -> not_a_line_dir col strm__
- in
- let rec check_num n col (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ('0'..'9' as c) ->
- Stream.junk strm__;
- check_num (10 * n + Char.code c - Char.code '0') (col + 1) strm__
- | _ -> let col = spaces col strm__ in check_quote n col strm__
- in
- let begin_line (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '#' ->
- Stream.junk strm__;
- let col =
- try spaces 1 strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- check_num 0 col strm__
- | _ -> not_a_line_dir 0 strm__
- in
- begin_line strm
- in
- let r =
- try loop fname 1 with
- Stream.Failure -> fname, 1, bp, ep
- in
- close_in ic; r
- with
- Sys_error _ -> fname, 1, bp, ep
-;;
-
-let loc_name = ref "loc";;
diff --git a/camlp4/ocaml_src/lib/stdpp.mli b/camlp4/ocaml_src/lib/stdpp.mli
deleted file mode 100644
index 68c0cb6ada..0000000000
--- a/camlp4/ocaml_src/lib/stdpp.mli
+++ /dev/null
@@ -1,37 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-(** Standard definitions. *)
-
-exception Exc_located of (int * int) * exn;;
- (** [Exc_located loc e] is an encapsulation of the exception [e] with
- the input location [loc]. To be used in quotation expanders
- and in grammars to specify some input location for an error.
- Do not raise this exception directly: rather use the following
- function [raise_with_loc]. *)
-
-val raise_with_loc : int * int -> exn -> 'a;;
- (** [raise_with_loc loc e], if [e] is already the exception [Exc_located],
- re-raise it, else raise the exception [Exc_located loc e]. *)
-
-val line_of_loc : string -> int * int -> string * int * int * int;;
- (** [line_of_loc fname loc] reads the file [fname] up to the
- location [loc] and returns the real input file, the line number
- and the characters location in the line; the real input file
- can be different from [fname] because of possibility of line
- directives typically generated by /lib/cpp. *)
-
-val loc_name : string ref;;
- (** Name of the location variable used in grammars and in the predefined
- quotations for OCaml syntax trees. Default: [loc] *)
diff --git a/camlp4/ocaml_src/lib/token.ml b/camlp4/ocaml_src/lib/token.ml
deleted file mode 100644
index bc8faeac3e..0000000000
--- a/camlp4/ocaml_src/lib/token.ml
+++ /dev/null
@@ -1,223 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-type t = string * string;;
-type pattern = string * string;;
-
-exception Error of string;;
-
-type location = int * int;;
-type location_function = int -> int * int;;
-type 'te lexer_func = char Stream.t -> 'te Stream.t * location_function;;
-
-type 'te glexer =
- { tok_func : 'te lexer_func;
- tok_using : pattern -> unit;
- tok_removing : pattern -> unit;
- tok_match : pattern -> 'te -> string;
- tok_text : pattern -> string;
- mutable tok_comm : location list option }
-;;
-type lexer =
- { func : t lexer_func;
- using : pattern -> unit;
- removing : pattern -> unit;
- tparse : pattern -> (t Stream.t -> string) option;
- text : pattern -> string }
-;;
-
-let lexer_text (con, prm) =
- if con = "" then "'" ^ prm ^ "'"
- else if prm = "" then con
- else con ^ " '" ^ prm ^ "'"
-;;
-
-let locerr () = invalid_arg "Lexer: location function";;
-let loct_create () = ref (Array.create 1024 None), ref false;;
-let loct_func (loct, ov) i =
- match
- if i < 0 || i >= Array.length !loct then if !ov then Some (0, 0) else None
- else Array.unsafe_get !loct i
- with
- Some loc -> loc
- | _ -> locerr ()
-;;
-let loct_add (loct, ov) i loc =
- if i >= Array.length !loct then
- let new_tmax = Array.length !loct * 2 in
- if new_tmax < Sys.max_array_length then
- let new_loct = Array.create new_tmax None in
- Array.blit !loct 0 new_loct 0 (Array.length !loct);
- loct := new_loct;
- !loct.(i) <- Some loc
- else ov := true
- else !loct.(i) <- Some loc
-;;
-
-let make_stream_and_location next_token_loc =
- let loct = loct_create () in
- let ts =
- Stream.from
- (fun i ->
- let (tok, loc) = next_token_loc () in loct_add loct i loc; Some tok)
- in
- ts, loct_func loct
-;;
-
-let lexer_func_of_parser next_token_loc cs =
- make_stream_and_location (fun () -> next_token_loc cs)
-;;
-
-let lexer_func_of_ocamllex lexfun cs =
- let lb =
- Lexing.from_function
- (fun s n ->
- try s.[0] <- Stream.next cs; 1 with
- Stream.Failure -> 0)
- in
- let next_token_loc _ =
- let tok = lexfun lb in
- let loc = Lexing.lexeme_start lb, Lexing.lexeme_end lb in tok, loc
- in
- make_stream_and_location next_token_loc
-;;
-
-(* Char and string tokens to real chars and string *)
-
-let buff = ref (String.create 80);;
-let store len x =
- if len >= String.length !buff then
- buff := !buff ^ String.create (String.length !buff);
- !buff.[len] <- x;
- succ len
-;;
-let mstore len s =
- let rec add_rec len i =
- if i == String.length s then len else add_rec (store len s.[i]) (succ i)
- in
- add_rec len 0
-;;
-let get_buff len = String.sub !buff 0 len;;
-
-let valch x = Char.code x - Char.code '0';;
-let valch_a x = Char.code x - Char.code 'a' + 10;;
-let valch_A x = Char.code x - Char.code 'A' + 10;;
-
-let rec backslash s i =
- if i = String.length s then raise Not_found
- else
- match s.[i] with
- 'n' -> '\n', i + 1
- | 'r' -> '\r', i + 1
- | 't' -> '\t', i + 1
- | 'b' -> '\b', i + 1
- | '\\' -> '\\', i + 1
- | '\"' -> '\"', i + 1
- | '\'' -> '\'', i + 1
- | '0'..'9' as c -> backslash1 (valch c) s (i + 1)
- | 'x' -> backslash1h s (i + 1)
- | _ -> raise Not_found
-and backslash1 cod s i =
- if i = String.length s then raise Not_found
- else
- match s.[i] with
- '0'..'9' as c -> backslash2 (10 * cod + valch c) s (i + 1)
- | _ -> raise Not_found
-and backslash2 cod s i =
- if i = String.length s then raise Not_found
- else
- match s.[i] with
- '0'..'9' as c -> Char.chr (10 * cod + valch c), i + 1
- | _ -> raise Not_found
-and backslash1h s i =
- if i = String.length s then raise Not_found
- else
- match s.[i] with
- '0'..'9' as c -> backslash2h (valch c) s (i + 1)
- | 'a'..'f' as c -> backslash2h (valch_a c) s (i + 1)
- | 'A'..'F' as c -> backslash2h (valch_A c) s (i + 1)
- | _ -> raise Not_found
-and backslash2h cod s i =
- if i = String.length s then '\\', i - 2
- else
- match s.[i] with
- '0'..'9' as c -> Char.chr (16 * cod + valch c), i + 1
- | 'a'..'f' as c -> Char.chr (16 * cod + valch_a c), i + 1
- | 'A'..'F' as c -> Char.chr (16 * cod + valch_A c), i + 1
- | _ -> raise Not_found
-;;
-
-let rec skip_indent s i =
- if i = String.length s then i
- else
- match s.[i] with
- ' ' | '\t' -> skip_indent s (i + 1)
- | _ -> i
-;;
-
-let skip_opt_linefeed s i =
- if i = String.length s then i else if s.[i] = '\010' then i + 1 else i
-;;
-
-let eval_char s =
- if String.length s = 1 then s.[0]
- else if String.length s = 0 then failwith "invalid char token"
- else if s.[0] = '\\' then
- if String.length s = 2 && s.[1] = '\'' then '\''
- else
- try
- let (c, i) = backslash s 1 in
- if i = String.length s then c else raise Not_found
- with
- Not_found -> failwith "invalid char token"
- else failwith "invalid char token"
-;;
-
-let eval_string (bp, ep) s =
- let rec loop len i =
- if i = String.length s then get_buff len
- else
- let (len, i) =
- if s.[i] = '\\' then
- let i = i + 1 in
- if i = String.length s then failwith "invalid string token"
- else if s.[i] = '\"' then store len '\"', i + 1
- else
- match s.[i] with
- '\010' -> len, skip_indent s (i + 1)
- | '\013' -> len, skip_indent s (skip_opt_linefeed s (i + 1))
- | c ->
- try let (c, i) = backslash s i in store len c, i with
- Not_found ->
- Printf.eprintf "Warning: char %d, Invalid backslash escape in string\n%!"
- (bp + i + 1);
- store (store len '\\') c, i + 1
- else store len s.[i], i + 1
- in
- loop len i
- in
- loop 0 0
-;;
-
-let default_match =
- function
- "ANY", "" -> (fun (con, prm) -> prm)
- | "ANY", v ->
- (fun (con, prm) -> if v = prm then v else raise Stream.Failure)
- | p_con, "" ->
- (fun (con, prm) -> if con = p_con then prm else raise Stream.Failure)
- | p_con, p_prm ->
- fun (con, prm) ->
- if con = p_con && prm = p_prm then prm else raise Stream.Failure
-;;
diff --git a/camlp4/ocaml_src/lib/token.mli b/camlp4/ocaml_src/lib/token.mli
deleted file mode 100644
index 9ddb41069b..0000000000
--- a/camlp4/ocaml_src/lib/token.mli
+++ /dev/null
@@ -1,133 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-(** Lexers for Camlp4 grammars.
-
- This module defines the Camlp4 lexer type to be used in extensible
- grammars (see module [Grammar]). It also provides some useful functions
- to create lexers (this module should be renamed [Glexer] one day). *)
-
-type pattern = string * string;;
- (** Token patterns come from the EXTEND statement.
-- The first string is the constructor name (must start with
- an uppercase character). When it is empty, the second string
- is supposed to be a keyword.
-- The second string is the constructor parameter. Empty if it
- has no parameter.
-- The way tokens patterns are interpreted to parse tokens is
- done by the lexer, function [tok_match] below. *)
-
-exception Error of string;;
- (** An lexing error exception to be used by lexers. *)
-
-(** {6 Lexer type} *)
-
-type location = int * int;;
-type location_function = int -> location;;
- (** The type for a function associating a number of a token in a stream
- (starting from 0) to its source location. *)
-type 'te lexer_func = char Stream.t -> 'te Stream.t * location_function;;
- (** The type for a lexer function. The character stream is the input
- stream to be lexed. The result is a pair of a token stream and
- a location function for this tokens stream. *)
-
-type 'te glexer =
- { tok_func : 'te lexer_func;
- tok_using : pattern -> unit;
- tok_removing : pattern -> unit;
- tok_match : pattern -> 'te -> string;
- tok_text : pattern -> string;
- mutable tok_comm : location list option }
-;;
- (** The type for a lexer used by Camlp4 grammars.
-- The field [tok_func] is the main lexer function. See [lexer_func]
- type above. This function may be created from a [char stream parser]
- or for an [ocamllex] function using the functions below.
-- The field [tok_using] is a function telling the lexer that the grammar
- uses this token (pattern). The lexer can check that its constructor
- is correct, and interpret some kind of tokens as keywords (to record
- them in its tables). Called by [EXTEND] statements.
-- The field [tok_removing] is a function telling the lexer that the
- grammar does not uses the given token (pattern) any more. If the
- lexer has a notion of "keywords", it can release it from its tables.
- Called by [DELETE_RULE] statements.
-- The field [tok_match] is a function taking a pattern and returning
- a function matching a token against the pattern. Warning: for
- efficency, write it as a function returning functions according
- to the values of the pattern, not a function with two parameters.
-- The field [tok_text] returns the name of some token pattern,
- used in error messages.
-- The field [tok_comm] if not None asks the lexer to record the
- locations of the comments. *)
-
-val lexer_text : pattern -> string;;
- (** A simple [tok_text] function for lexers *)
-
-val default_match : pattern -> string * string -> string;;
- (** A simple [tok_match] function for lexers, appling to token type
- [(string * string)] *)
-
-(** {6 Lexers from char stream parsers or ocamllex function}
-
- The functions below create lexer functions either from a [char stream]
- parser or for an [ocamllex] function. With the returned function [f],
- the simplest [Token.lexer] can be written:
- {[
- { Token.tok_func = f;
- Token.tok_using = (fun _ -> ());
- Token.tok_removing = (fun _ -> ());
- Token.tok_match = Token.default_match;
- Token.tok_text = Token.lexer_text }
- ]}
- Note that a better [tok_using] function should check the used tokens
- and raise [Token.Error] for incorrect ones. The other functions
- [tok_removing], [tok_match] and [tok_text] may have other implementations
- as well. *)
-
-val lexer_func_of_parser :
- (char Stream.t -> 'te * location) -> 'te lexer_func;;
- (** A lexer function from a lexer written as a char stream parser
- returning the next token and its location. *)
-val lexer_func_of_ocamllex : (Lexing.lexbuf -> 'te) -> 'te lexer_func;;
- (** A lexer function from a lexer created by [ocamllex] *)
-
-val make_stream_and_location :
- (unit -> 'te * location) -> 'te Stream.t * location_function;;
- (** General function *)
-
-(** {6 Useful functions} *)
-
-val eval_char : string -> char;;
- (** Convert a char token, where the escape sequences (backslashes)
- remain to be interpreted; raise [Failure] if an
- incorrect backslash sequence is found; [Token.eval_char (Char.escaped c)]
- returns [c] *)
-
-val eval_string : location -> string -> string;;
- (** Convert a string token, where the escape sequences (backslashes)
- remain to be interpreted; issue a warning if an incorrect
- backslash sequence is found;
- [Token.eval_string loc (String.escaped s)] returns [s] *)
-
-(**/**)
-
-(* deprecated since version 3.05; use rather type glexer *)
-type t = string * string;;
-type lexer =
- { func : t lexer_func;
- using : pattern -> unit;
- removing : pattern -> unit;
- tparse : pattern -> (t Stream.t -> string) option;
- text : pattern -> string }
-;;
diff --git a/camlp4/ocaml_src/meta/.cvsignore b/camlp4/ocaml_src/meta/.cvsignore
deleted file mode 100644
index 45db17209f..0000000000
--- a/camlp4/ocaml_src/meta/.cvsignore
+++ /dev/null
@@ -1,2 +0,0 @@
-camlp4o.out
-camlp4r.out
diff --git a/camlp4/ocaml_src/meta/.depend b/camlp4/ocaml_src/meta/.depend
deleted file mode 100644
index 737ea5ec6b..0000000000
--- a/camlp4/ocaml_src/meta/.depend
+++ /dev/null
@@ -1,16 +0,0 @@
-pa_extend.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_extend.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pa_extend_m.cmo: pa_extend.cmo
-pa_extend_m.cmx: pa_extend.cmx
-pa_ifdef.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_ifdef.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pa_macro.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_macro.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pa_r.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_r.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pa_rp.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
-pa_rp.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
-pr_dump.cmo: ../camlp4/ast2pt.cmi $(OTOP)/utils/config.cmi ../camlp4/pcaml.cmi
-pr_dump.cmx: ../camlp4/ast2pt.cmx $(OTOP)/utils/config.cmx ../camlp4/pcaml.cmx
-q_MLast.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/quotation.cmi
-q_MLast.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/quotation.cmx
diff --git a/camlp4/ocaml_src/meta/Makefile b/camlp4/ocaml_src/meta/Makefile
deleted file mode 100644
index 3b01659358..0000000000
--- a/camlp4/ocaml_src/meta/Makefile
+++ /dev/null
@@ -1,59 +0,0 @@
-# This file has been generated by program: do not edit!
-
-include ../../config/Makefile
-
-INCLUDES=-I ../camlp4 -I ../../boot -I $(OTOP)/utils
-OCAMLCFLAGS=-warn-error A $(INCLUDES)
-OBJS=q_MLast.cmo pa_r.cmo pa_rp.cmo pa_extend.cmo pa_extend_m.cmo pa_macro.cmo pr_dump.cmo
-OBJSX=$(OBJS:.cmo=.cmx)
-CAMLP4RM=pa_r.cmo pa_rp.cmo pr_dump.cmo
-CAMLP4RMX=$(CAMLP4RM:.cmo=.cmx)
-SHELL=/bin/sh
-COUT=$(OBJS) camlp4r$(EXE)
-COPT=$(OBJSX) camlp4r.opt
-
-all: $(COUT)
-opt: $(COPT)
-
-camlp4r$(EXE): ../camlp4/camlp4$(EXE) $(CAMLP4RM)
- rm -f camlp4r$(EXE)
- cd ../camlp4; $(MAKE) OTOP=$(OTOP) CAMLP4=../meta/camlp4r$(EXE) CAMLP4M="-I ../meta $(CAMLP4RM)"
-
-camlp4r.opt: $(CAMLP4RMX)
- rm -f camlp4r.opt
- cd ../camlp4; $(MAKE) optp4 OTOP=$(OTOP) CAMLP4OPT=../meta/camlp4r.opt CAMLP4M="-I ../meta $(CAMLP4RMX)"
-
-clean::
- rm -f *.cm* *.pp[io] *.o *.bak .*.bak $(COUT) $(COPT)
-
-depend:
- cp .depend .depend.bak
- > .depend
- @for i in *.mli *.ml; do \
- ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \
- sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \
- done
-
-promote:
- cp $(COUT) pa_extend.cmi ../../boot/.
-
-compare:
- @for j in $(COUT); do \
- if cmp $$j ../../boot/$$j; then :; else exit 1; fi; \
- done
-
-install:
- -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)"
- cp $(OBJS) "$(LIBDIR)/camlp4/."
- cp pa_macro.cmi pa_extend.cmi "$(LIBDIR)/camlp4/."
- cp camlp4r$(EXE) "$(BINDIR)/."
- if test -f camlp4r.opt; then \
- cp camlp4r.opt "$(BINDIR)/camlp4r.opt$(EXE)" ;\
- for target in $(OBJSX) $(OBJSX:.cmx=.$(O)) ; do \
- if test -f $$target; then \
- cp $$target "$(LIBDIR)/camlp4/."; \
- fi; \
- done; \
- fi
-
-include .depend
diff --git a/camlp4/ocaml_src/meta/Makefile.Mac b/camlp4/ocaml_src/meta/Makefile.Mac
deleted file mode 100644
index b62b945c12..0000000000
--- a/camlp4/ocaml_src/meta/Makefile.Mac
+++ /dev/null
@@ -1,50 +0,0 @@
-#######################################################################
-# #
-# Camlp4 #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. Distributed only by permission. #
-# #
-#######################################################################
-
-# This file has been generated by program: do not edit!
-
-INCLUDES = -I ::camlp4: -I :::boot: -I "{OTOP}utils:"
-OCAMLCFLAGS = {INCLUDES}
-OBJS = q_MLast.cmo pa_r.cmo pa_rp.cmo pa_extend.cmo pa_extend_m.cmo ¶
- pa_ifdef.cmo pr_dump.cmo
-CAMLP4RM = pa_r.cmo pa_rp.cmo pr_dump.cmo
-OUT = {OBJS} camlp4r
-
-all Ä {OUT}
-
-camlp4r Ä ::camlp4:camlp4 {CAMLP4RM}
- delete -i camlp4r
- directory ::camlp4:
- domake -d CAMLP4=::meta:camlp4r -d CAMLP4M="-I ::meta {CAMLP4RM}"
- directory ::meta:
-
-clean ÄÄ
- delete -i {OUT}
-
-{dependrule}
-
-promote Ä
- duplicate -y {OUT} pa_extend.cmi :::boot:
-
-compare Ä
- for i in {OUT}
- equal -s {i} :::boot:{i} || exit 1
- end
-
-install Ä
- (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null
- (newfolder "{BINDIR}" || set status 0) ³ dev:null
- duplicate -y {OBJS} "{P4LIBDIR}"
- duplicate -y camlp4r "{BINDIR}"
-
-{defrules}
-
-pr_dump.cmo Ä ::camlp4:ast2pt.cmo "{OTOP}utils:config.cmi" ::camlp4:pcaml.cmi
diff --git a/camlp4/ocaml_src/meta/Makefile.Mac.depend b/camlp4/ocaml_src/meta/Makefile.Mac.depend
deleted file mode 100644
index 29675238e9..0000000000
--- a/camlp4/ocaml_src/meta/Makefile.Mac.depend
+++ /dev/null
@@ -1,12 +0,0 @@
-pa_extend.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi
-pa_extend.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx
-pa_extend_m.cmoÄ ::camlp4:mLast.cmi pa_extend.cmo
-pa_extend_m.cmxÄ ::camlp4:mLast.cmi pa_extend.cmx
-pa_macro.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi
-pa_macro.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx
-pa_r.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi
-pa_r.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx
-pa_rp.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi
-pa_rp.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx
-q_MLast.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:quotation.cmi
-q_MLast.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:quotation.cmx
diff --git a/camlp4/ocaml_src/meta/pa_extend.ml b/camlp4/ocaml_src/meta/pa_extend.ml
deleted file mode 100644
index d68baf8d59..0000000000
--- a/camlp4/ocaml_src/meta/pa_extend.ml
+++ /dev/null
@@ -1,2027 +0,0 @@
-(* camlp4r pa_extend.cmo q_MLast.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-open Stdpp;;
-
-let split_ext = ref false;;
-
-Pcaml.add_option "-split_ext" (Arg.Set split_ext)
- "Split EXTEND by functions to turn around a PowerPC problem.";;
-
-Pcaml.add_option "-split_gext" (Arg.Set split_ext)
- "Old name for the option -split_ext.";;
-
-type loc = int * int;;
-
-type 'e name = { expr : 'e; tvar : string; loc : int * int };;
-
-type styp =
- STlid of loc * string
- | STapp of loc * styp * styp
- | STquo of loc * string
- | STself of loc * string
- | STtyp of MLast.ctyp
-;;
-
-type 'e text =
- TXmeta of loc * string * 'e text list * 'e * styp
- | TXlist of loc * bool * 'e text * 'e text option
- | TXnext of loc
- | TXnterm of loc * 'e name * string option
- | TXopt of loc * 'e text
- | TXrules of loc * ('e text list * 'e) list
- | TXself of loc
- | TXtok of loc * string * 'e
-;;
-
-type ('e, 'p) entry =
- { name : 'e name; pos : 'e option; levels : ('e, 'p) level list }
-and ('e, 'p) level =
- { label : string option; assoc : 'e option; rules : ('e, 'p) rule list }
-and ('e, 'p) rule = { prod : ('e, 'p) psymbol list; action : 'e option }
-and ('e, 'p) psymbol = { pattern : 'p option; symbol : ('e, 'p) symbol }
-and ('e, 'p) symbol = { used : string list; text : 'e text; styp : styp }
-;;
-
-type used =
- Unused
- | UsedScanned
- | UsedNotScanned
-;;
-
-let mark_used modif ht n =
- try
- let rll = Hashtbl.find_all ht n in
- List.iter
- (fun (r, _) ->
- if !r == Unused then begin r := UsedNotScanned; modif := true end)
- rll
- with
- Not_found -> ()
-;;
-
-let rec mark_symbol modif ht symb =
- List.iter (fun e -> mark_used modif ht e) symb.used
-;;
-
-let check_use nl el =
- let ht = Hashtbl.create 301 in
- let modif = ref false in
- List.iter
- (fun e ->
- let u =
- match e.name.expr with
- MLast.ExLid (_, _) -> Unused
- | _ -> UsedNotScanned
- in
- Hashtbl.add ht e.name.tvar (ref u, e))
- el;
- List.iter
- (fun n ->
- try
- let rll = Hashtbl.find_all ht n.tvar in
- List.iter (fun (r, _) -> r := UsedNotScanned) rll
- with
- _ -> ())
- nl;
- modif := true;
- while !modif do
- modif := false;
- Hashtbl.iter
- (fun s (r, e) ->
- if !r = UsedNotScanned then
- begin
- r := UsedScanned;
- List.iter
- (fun level ->
- let rules = level.rules in
- List.iter
- (fun rule ->
- List.iter (fun ps -> mark_symbol modif ht ps.symbol)
- rule.prod)
- rules)
- e.levels
- end)
- ht
- done;
- Hashtbl.iter
- (fun s (r, e) ->
- if !r = Unused then
- !(Pcaml.warning) e.name.loc ("Unused local entry \"" ^ s ^ "\""))
- ht
-;;
-
-let locate n = let loc = n.loc in n.expr;;
-
-let new_type_var =
- let i = ref 0 in fun () -> incr i; "e__" ^ string_of_int !i
-;;
-
-let used_of_rule_list rl =
- List.fold_left
- (fun nl r -> List.fold_left (fun nl s -> s.symbol.used @ nl) nl r.prod) []
- rl
-;;
-
-let retype_rule_list_without_patterns loc rl =
- try
- List.map
- (function
- {prod = [{pattern = None; symbol = s}]; action = None} ->
- {prod = [{pattern = Some (MLast.PaLid (loc, "x")); symbol = s}];
- action = Some (MLast.ExLid (loc, "x"))}
- | {prod = []; action = Some _} as r -> r
- | _ -> raise Exit)
- rl
- with
- Exit -> rl
-;;
-
-let quotify = ref false;;
-let meta_action = ref false;;
-
-module MetaAction =
- struct
- let not_impl f x =
- let desc =
- if Obj.is_block (Obj.repr x) then
- "tag = " ^ string_of_int (Obj.tag (Obj.repr x))
- else "int_val = " ^ string_of_int (Obj.magic x)
- in
- failwith (f ^ ", not impl: " ^ desc)
- ;;
- let loc = 0, 0;;
- let rec mlist mf =
- function
- [] -> MLast.ExUid (loc, "[]")
- | x :: l ->
- MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), mf x),
- mlist mf l)
- ;;
- let moption mf =
- function
- None -> MLast.ExUid (loc, "None")
- | Some x -> MLast.ExApp (loc, MLast.ExUid (loc, "Some"), mf x)
- ;;
- let mbool =
- function
- false -> MLast.ExUid (loc, "False")
- | true -> MLast.ExUid (loc, "True")
- ;;
- let mloc =
- MLast.ExTup (loc, [MLast.ExInt (loc, "0"); MLast.ExInt (loc, "0")])
- ;;
- let rec mexpr =
- function
- MLast.ExAcc (loc, e1, e2) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExAcc")),
- mloc),
- mexpr e1),
- mexpr e2)
- | MLast.ExApp (loc, e1, e2) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExApp")),
- mloc),
- mexpr e1),
- mexpr e2)
- | MLast.ExChr (loc, s) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExChr")),
- mloc),
- MLast.ExStr (loc, s))
- | MLast.ExFun (loc, pwel) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExFun")),
- mloc),
- mlist mpwe pwel)
- | MLast.ExIfe (loc, e1, e2, e3) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExIfe")),
- mloc),
- mexpr e1),
- mexpr e2),
- mexpr e3)
- | MLast.ExInt (loc, s) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExInt")),
- mloc),
- MLast.ExStr (loc, s))
- | MLast.ExFlo (loc, s) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExFlo")),
- mloc),
- MLast.ExStr (loc, s))
- | MLast.ExLet (loc, rf, pel, e) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExLet")),
- mloc),
- mbool rf),
- mlist mpe pel),
- mexpr e)
- | MLast.ExLid (loc, s) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExLid")),
- mloc),
- MLast.ExStr (loc, s))
- | MLast.ExMat (loc, e, pwel) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExMat")),
- mloc),
- mexpr e),
- mlist mpwe pwel)
- | MLast.ExRec (loc, pel, eo) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExRec")),
- mloc),
- mlist mpe pel),
- moption mexpr eo)
- | MLast.ExSeq (loc, el) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExSeq")),
- mloc),
- mlist mexpr el)
- | MLast.ExSte (loc, e1, e2) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExSte")),
- mloc),
- mexpr e1),
- mexpr e2)
- | MLast.ExStr (loc, s) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExStr")),
- mloc),
- MLast.ExStr (loc, String.escaped s))
- | MLast.ExTry (loc, e, pwel) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExTry")),
- mloc),
- mexpr e),
- mlist mpwe pwel)
- | MLast.ExTup (loc, el) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExTup")),
- mloc),
- mlist mexpr el)
- | MLast.ExTyc (loc, e, t) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExTyc")),
- mloc),
- mexpr e),
- mctyp t)
- | MLast.ExUid (loc, s) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExUid")),
- mloc),
- MLast.ExStr (loc, s))
- | x -> not_impl "mexpr" x
- and mpatt =
- function
- MLast.PaAcc (loc, p1, p2) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "PaAcc")),
- mloc),
- mpatt p1),
- mpatt p2)
- | MLast.PaAny loc ->
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"), MLast.ExUid (loc, "PaAny")),
- mloc)
- | MLast.PaApp (loc, p1, p2) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "PaApp")),
- mloc),
- mpatt p1),
- mpatt p2)
- | MLast.PaInt (loc, s) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "PaInt")),
- mloc),
- MLast.ExStr (loc, s))
- | MLast.PaLid (loc, s) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "PaLid")),
- mloc),
- MLast.ExStr (loc, s))
- | MLast.PaOrp (loc, p1, p2) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "PaOrp")),
- mloc),
- mpatt p1),
- mpatt p2)
- | MLast.PaStr (loc, s) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "PaStr")),
- mloc),
- MLast.ExStr (loc, String.escaped s))
- | MLast.PaTup (loc, pl) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "PaTup")),
- mloc),
- mlist mpatt pl)
- | MLast.PaTyc (loc, p, t) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "PaTyc")),
- mloc),
- mpatt p),
- mctyp t)
- | MLast.PaUid (loc, s) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "PaUid")),
- mloc),
- MLast.ExStr (loc, s))
- | x -> not_impl "mpatt" x
- and mctyp =
- function
- MLast.TyAcc (loc, t1, t2) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "TyAcc")),
- mloc),
- mctyp t1),
- mctyp t2)
- | MLast.TyApp (loc, t1, t2) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "TyApp")),
- mloc),
- mctyp t1),
- mctyp t2)
- | MLast.TyLid (loc, s) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "TyLid")),
- mloc),
- MLast.ExStr (loc, s))
- | MLast.TyQuo (loc, s) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "TyQuo")),
- mloc),
- MLast.ExStr (loc, s))
- | MLast.TyTup (loc, tl) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "TyTup")),
- mloc),
- mlist mctyp tl)
- | MLast.TyUid (loc, s) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "TyUid")),
- mloc),
- MLast.ExStr (loc, s))
- | x -> not_impl "mctyp" x
- and mpe (p, e) = MLast.ExTup (loc, [mpatt p; mexpr e])
- and mpwe (p, w, e) =
- MLast.ExTup (loc, [mpatt p; moption mexpr w; mexpr e])
- ;;
- end
-;;
-
-let mklistexp loc =
- let rec loop top =
- function
- [] -> MLast.ExUid (loc, "[]")
- | e1 :: el ->
- let loc = if top then loc else fst (MLast.loc_of_expr e1), snd loc in
- MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), e1), loop false el)
- in
- loop true
-;;
-
-let mklistpat loc =
- let rec loop top =
- function
- [] -> MLast.PaUid (loc, "[]")
- | p1 :: pl ->
- let loc = if top then loc else fst (MLast.loc_of_patt p1), snd loc in
- MLast.PaApp
- (loc, MLast.PaApp (loc, MLast.PaUid (loc, "::"), p1), loop false pl)
- in
- loop true
-;;
-
-let rec expr_fa al =
- function
- MLast.ExApp (_, f, a) -> expr_fa (a :: al) f
- | f -> f, al
-;;
-
-let rec quot_expr e =
- let loc = MLast.loc_of_expr e in
- match e with
- MLast.ExUid (_, "None") ->
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Option")),
- MLast.ExUid (loc, "None"))
- | MLast.ExApp (_, MLast.ExUid (_, "Some"), e) ->
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Option")),
- MLast.ExApp (loc, MLast.ExUid (loc, "Some"), quot_expr e))
- | MLast.ExUid (_, "False") ->
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Bool")),
- MLast.ExUid (loc, "False"))
- | MLast.ExUid (_, "True") ->
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Bool")),
- MLast.ExUid (loc, "True"))
- | MLast.ExUid (_, "()") -> e
- | MLast.ExApp
- (_, MLast.ExAcc (_, MLast.ExUid (_, "Qast"), MLast.ExUid (_, "List")),
- _) ->
- e
- | MLast.ExApp
- (_, MLast.ExAcc (_, MLast.ExUid (_, "Qast"), MLast.ExUid (_, "Option")),
- _) ->
- e
- | MLast.ExApp
- (_, MLast.ExAcc (_, MLast.ExUid (_, "Qast"), MLast.ExUid (_, "Str")),
- _) ->
- e
- | MLast.ExUid (_, "[]") ->
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "List")),
- MLast.ExUid (loc, "[]"))
- | MLast.ExApp
- (_, MLast.ExApp (_, MLast.ExUid (_, "::"), e), MLast.ExUid (_, "[]")) ->
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "List")),
- MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), quot_expr e),
- MLast.ExUid (loc, "[]")))
- | MLast.ExApp (_, MLast.ExApp (_, MLast.ExUid (_, "::"), e1), e2) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Cons")),
- quot_expr e1),
- quot_expr e2)
- | MLast.ExApp (_, _, _) ->
- let (f, al) = expr_fa [] e in
- begin match f with
- MLast.ExUid (_, c) ->
- let al = List.map quot_expr al in
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")),
- MLast.ExStr (loc, c)),
- mklistexp loc al)
- | MLast.ExAcc (_, MLast.ExUid (_, "MLast"), MLast.ExUid (_, c)) ->
- let al = List.map quot_expr al in
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")),
- MLast.ExStr (loc, c)),
- mklistexp loc al)
- | MLast.ExAcc (_, MLast.ExUid (_, m), MLast.ExUid (_, c)) ->
- let al = List.map quot_expr al in
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")),
- MLast.ExStr (loc, (m ^ "." ^ c))),
- mklistexp loc al)
- | MLast.ExLid (_, f) ->
- let al = List.map quot_expr al in
- List.fold_left (fun f e -> MLast.ExApp (loc, f, e))
- (MLast.ExLid (loc, f)) al
- | _ -> e
- end
- | MLast.ExRec (_, pel, None) ->
- begin try
- let lel =
- List.map
- (fun (p, e) ->
- let lab =
- match p with
- MLast.PaLid (_, c) -> MLast.ExStr (loc, c)
- | MLast.PaAcc (_, _, MLast.PaLid (_, c)) ->
- MLast.ExStr (loc, c)
- | _ -> raise Not_found
- in
- MLast.ExTup (loc, [lab; quot_expr e]))
- pel
- in
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Record")),
- mklistexp loc lel)
- with
- Not_found -> e
- end
- | MLast.ExLid (_, s) ->
- if s = !(Stdpp.loc_name) then
- MLast.ExAcc (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Loc"))
- else e
- | MLast.ExAcc (_, MLast.ExUid (_, "MLast"), MLast.ExUid (_, s)) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")),
- MLast.ExStr (loc, s)),
- MLast.ExUid (loc, "[]"))
- | MLast.ExAcc (_, MLast.ExUid (_, m), MLast.ExUid (_, s)) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")),
- MLast.ExStr (loc, (m ^ "." ^ s))),
- MLast.ExUid (loc, "[]"))
- | MLast.ExUid (_, s) ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")),
- MLast.ExStr (loc, s)),
- MLast.ExUid (loc, "[]"))
- | MLast.ExStr (_, s) ->
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Str")),
- MLast.ExStr (loc, s))
- | MLast.ExTup (_, el) ->
- let el = List.map quot_expr el in
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Tuple")),
- mklistexp loc el)
- | MLast.ExLet (_, r, pel, e) ->
- let pel = List.map (fun (p, e) -> p, quot_expr e) pel in
- MLast.ExLet (loc, r, pel, quot_expr e)
- | _ -> e
-;;
-
-let symgen = "xx";;
-
-let pname_of_ptuple pl =
- List.fold_left
- (fun pname p ->
- match p with
- MLast.PaLid (_, s) -> pname ^ s
- | _ -> pname)
- "" pl
-;;
-
-let quotify_action psl act =
- let e = quot_expr act in
- List.fold_left
- (fun e ps ->
- match ps.pattern with
- Some (MLast.PaTup (_, pl)) ->
- let loc = 0, 0 in
- let pname = pname_of_ptuple pl in
- let (pl1, el1) =
- let (l, _) =
- List.fold_left
- (fun (l, cnt) _ ->
- (symgen ^ string_of_int cnt) :: l, cnt + 1)
- ([], 1) pl
- in
- let l = List.rev l in
- List.map (fun s -> MLast.PaLid (loc, s)) l,
- List.map (fun s -> MLast.ExLid (loc, s)) l
- in
- MLast.ExLet
- (loc, false,
- [MLast.PaTup (loc, pl),
- MLast.ExMat
- (loc, MLast.ExLid (loc, pname),
- [MLast.PaApp
- (loc,
- MLast.PaAcc
- (loc, MLast.PaUid (loc, "Qast"),
- MLast.PaUid (loc, "Tuple")),
- mklistpat loc pl1),
- None, MLast.ExTup (loc, el1);
- MLast.PaAny loc, None,
- MLast.ExMat (loc, MLast.ExUid (loc, "()"), [])])],
- e)
- | _ -> e)
- e psl
-;;
-
-let rec make_ctyp styp tvar =
- match styp with
- STlid (loc, s) -> MLast.TyLid (loc, s)
- | STapp (loc, t1, t2) ->
- MLast.TyApp (loc, make_ctyp t1 tvar, make_ctyp t2 tvar)
- | STquo (loc, s) -> MLast.TyQuo (loc, s)
- | STself (loc, x) ->
- if tvar = "" then
- Stdpp.raise_with_loc loc
- (Stream.Error ("'" ^ x ^ "' illegal in anonymous entry level"))
- else MLast.TyQuo (loc, tvar)
- | STtyp t -> t
-;;
-
-let rec make_expr gmod tvar =
- function
- TXmeta (loc, n, tl, e, t) ->
- let el =
- List.fold_right
- (fun t el ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc, MLast.ExUid (loc, "::"), make_expr gmod "" t),
- el))
- tl (MLast.ExUid (loc, "[]"))
- in
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"),
- MLast.ExUid (loc, "Smeta")),
- MLast.ExStr (loc, n)),
- el),
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Obj"), MLast.ExLid (loc, "repr")),
- MLast.ExTyc (loc, e, make_ctyp t tvar)))
- | TXlist (loc, min, t, ts) ->
- let txt = make_expr gmod "" t in
- begin match min, ts with
- false, None ->
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"),
- MLast.ExUid (loc, "Slist0")),
- txt)
- | true, None ->
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"),
- MLast.ExUid (loc, "Slist1")),
- txt)
- | false, Some s ->
- let x = make_expr gmod tvar s in
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"),
- MLast.ExUid (loc, "Slist0sep")),
- txt),
- x)
- | true, Some s ->
- let x = make_expr gmod tvar s in
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"),
- MLast.ExUid (loc, "Slist1sep")),
- txt),
- x)
- end
- | TXnext loc ->
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Snext"))
- | TXnterm (loc, n, lev) ->
- begin match lev with
- Some lab ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"),
- MLast.ExUid (loc, "Snterml")),
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, gmod),
- MLast.ExUid (loc, "Entry")),
- MLast.ExLid (loc, "obj")),
- MLast.ExTyc
- (loc, n.expr,
- MLast.TyApp
- (loc,
- MLast.TyAcc
- (loc,
- MLast.TyAcc
- (loc, MLast.TyUid (loc, gmod),
- MLast.TyUid (loc, "Entry")),
- MLast.TyLid (loc, "e")),
- MLast.TyQuo (loc, n.tvar))))),
- MLast.ExStr (loc, lab))
- | None ->
- if n.tvar = tvar then
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Sself"))
- else
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"),
- MLast.ExUid (loc, "Snterm")),
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, gmod),
- MLast.ExUid (loc, "Entry")),
- MLast.ExLid (loc, "obj")),
- MLast.ExTyc
- (loc, n.expr,
- MLast.TyApp
- (loc,
- MLast.TyAcc
- (loc,
- MLast.TyAcc
- (loc, MLast.TyUid (loc, gmod),
- MLast.TyUid (loc, "Entry")),
- MLast.TyLid (loc, "e")),
- MLast.TyQuo (loc, n.tvar)))))
- end
- | TXopt (loc, t) ->
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Sopt")),
- make_expr gmod "" t)
- | TXrules (loc, rl) ->
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"), MLast.ExLid (loc, "srules")),
- make_expr_rules loc gmod rl "")
- | TXself loc ->
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Sself"))
- | TXtok (loc, s, e) ->
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Stoken")),
- MLast.ExTup (loc, [MLast.ExStr (loc, s); e]))
-and make_expr_rules loc gmod rl tvar =
- List.fold_left
- (fun txt (sl, ac) ->
- let sl =
- List.fold_right
- (fun t txt ->
- let x = make_expr gmod tvar t in
- MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), x), txt))
- sl (MLast.ExUid (loc, "[]"))
- in
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc, MLast.ExUid (loc, "::"), MLast.ExTup (loc, [sl; ac])),
- txt))
- (MLast.ExUid (loc, "[]")) rl
-;;
-
-let text_of_action loc psl rtvar act tvar =
- let locid = MLast.PaLid (loc, !(Stdpp.loc_name)) in
- let act =
- match act with
- Some act -> if !quotify then quotify_action psl act else act
- | None -> MLast.ExUid (loc, "()")
- in
- let e =
- MLast.ExFun
- (loc,
- [MLast.PaTyc
- (loc, locid,
- MLast.TyTup
- (loc, [MLast.TyLid (loc, "int"); MLast.TyLid (loc, "int")])),
- None, MLast.ExTyc (loc, act, MLast.TyQuo (loc, rtvar))])
- in
- let txt =
- List.fold_left
- (fun txt ps ->
- match ps.pattern with
- None -> MLast.ExFun (loc, [MLast.PaAny loc, None, txt])
- | Some p ->
- let t = make_ctyp ps.symbol.styp tvar in
- let p =
- match p with
- MLast.PaTup (_, pl) when !quotify ->
- MLast.PaLid (loc, pname_of_ptuple pl)
- | _ -> p
- in
- MLast.ExFun (loc, [MLast.PaTyc (loc, p, t), None, txt]))
- e psl
- in
- let txt =
- if !meta_action then
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Obj"), MLast.ExLid (loc, "magic")),
- MetaAction.mexpr txt)
- else txt
- in
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"), MLast.ExLid (loc, "action")),
- txt)
-;;
-
-let srules loc t rl tvar =
- List.map
- (fun r ->
- let sl = List.map (fun ps -> ps.symbol.text) r.prod in
- let ac = text_of_action loc r.prod t r.action tvar in sl, ac)
- rl
-;;
-
-let expr_of_delete_rule loc gmod n sl =
- let sl =
- List.fold_right
- (fun s e ->
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc, MLast.ExUid (loc, "::"), make_expr gmod "" s.text),
- e))
- sl (MLast.ExUid (loc, "[]"))
- in
- n.expr, sl
-;;
-
-let rec ident_of_expr =
- function
- MLast.ExLid (_, s) -> s
- | MLast.ExUid (_, s) -> s
- | MLast.ExAcc (_, e1, e2) -> ident_of_expr e1 ^ "__" ^ ident_of_expr e2
- | _ -> failwith "internal error in pa_extend"
-;;
-
-let mk_name loc e = {expr = e; tvar = ident_of_expr e; loc = loc};;
-
-let slist loc min sep symb =
- let t =
- match sep with
- Some s -> Some s.text
- | None -> None
- in
- TXlist (loc, min, symb.text, t)
-;;
-
-let sstoken loc s =
- let n = mk_name loc (MLast.ExLid (loc, ("a_" ^ s))) in
- TXnterm (loc, n, None)
-;;
-
-let mk_psymbol p s t =
- let symb = {used = []; text = s; styp = t} in
- {pattern = Some p; symbol = symb}
-;;
-
-let sslist loc min sep s =
- let rl =
- let r1 =
- let prod =
- let n = mk_name loc (MLast.ExLid (loc, "a_list")) in
- [mk_psymbol (MLast.PaLid (loc, "a")) (TXnterm (loc, n, None))
- (STquo (loc, "a_list"))]
- in
- let act = MLast.ExLid (loc, "a") in {prod = prod; action = Some act}
- in
- let r2 =
- let prod =
- [mk_psymbol (MLast.PaLid (loc, "a")) (slist loc min sep s)
- (STapp (loc, STlid (loc, "list"), s.styp))]
- in
- let act =
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "List")),
- MLast.ExLid (loc, "a"))
- in
- {prod = prod; action = Some act}
- in
- [r1; r2]
- in
- let used =
- match sep with
- Some symb -> symb.used @ s.used
- | None -> s.used
- in
- let used = "a_list" :: used in
- let text = TXrules (loc, srules loc "a_list" rl "") in
- let styp = STquo (loc, "a_list") in {used = used; text = text; styp = styp}
-;;
-
-let ssopt loc s =
- let rl =
- let r1 =
- let prod =
- let n = mk_name loc (MLast.ExLid (loc, "a_opt")) in
- [mk_psymbol (MLast.PaLid (loc, "a")) (TXnterm (loc, n, None))
- (STquo (loc, "a_opt"))]
- in
- let act = MLast.ExLid (loc, "a") in {prod = prod; action = Some act}
- in
- let r2 =
- let s =
- match s.text with
- TXtok (loc, "", MLast.ExStr (_, _)) ->
- let rl =
- [{prod =
- [{pattern = Some (MLast.PaLid (loc, "x")); symbol = s}];
- action =
- Some
- (MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"),
- MLast.ExUid (loc, "Str")),
- MLast.ExLid (loc, "x")))}]
- in
- let t = new_type_var () in
- {used = []; text = TXrules (loc, srules loc t rl "");
- styp = STquo (loc, t)}
- | _ -> s
- in
- let prod =
- [mk_psymbol (MLast.PaLid (loc, "a")) (TXopt (loc, s.text))
- (STapp (loc, STlid (loc, "option"), s.styp))]
- in
- let act =
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Option")),
- MLast.ExLid (loc, "a"))
- in
- {prod = prod; action = Some act}
- in
- [r1; r2]
- in
- let used = "a_opt" :: s.used in
- let text = TXrules (loc, srules loc "a_opt" rl "") in
- let styp = STquo (loc, "a_opt") in {used = used; text = text; styp = styp}
-;;
-
-let text_of_entry loc gmod e =
- let ent =
- let x = e.name in
- let loc = e.name.loc in
- MLast.ExTyc
- (loc, x.expr,
- MLast.TyApp
- (loc,
- MLast.TyAcc
- (loc,
- MLast.TyAcc
- (loc, MLast.TyUid (loc, gmod), MLast.TyUid (loc, "Entry")),
- MLast.TyLid (loc, "e")),
- MLast.TyQuo (loc, x.tvar)))
- in
- let pos =
- match e.pos with
- Some pos -> MLast.ExApp (loc, MLast.ExUid (loc, "Some"), pos)
- | None -> MLast.ExUid (loc, "None")
- in
- let txt =
- List.fold_right
- (fun level txt ->
- let lab =
- match level.label with
- Some lab ->
- MLast.ExApp
- (loc, MLast.ExUid (loc, "Some"), MLast.ExStr (loc, lab))
- | None -> MLast.ExUid (loc, "None")
- in
- let ass =
- match level.assoc with
- Some ass -> MLast.ExApp (loc, MLast.ExUid (loc, "Some"), ass)
- | None -> MLast.ExUid (loc, "None")
- in
- let txt =
- let rl = srules loc e.name.tvar level.rules e.name.tvar in
- let e = make_expr_rules loc gmod rl e.name.tvar in
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc, MLast.ExUid (loc, "::"),
- MLast.ExTup (loc, [lab; ass; e])),
- txt)
- in
- txt)
- e.levels (MLast.ExUid (loc, "[]"))
- in
- ent, pos, txt
-;;
-
-let let_in_of_extend loc gmod functor_version gl el args =
- match gl with
- Some (n1 :: _ as nl) ->
- check_use nl el;
- let ll =
- let same_tvar e n = e.name.tvar = n.tvar in
- List.fold_right
- (fun e ll ->
- match e.name.expr with
- MLast.ExLid (_, _) ->
- if List.exists (same_tvar e) nl then ll
- else if List.exists (same_tvar e) ll then ll
- else e.name :: ll
- | _ -> ll)
- el []
- in
- let globals =
- List.map
- (fun {expr = e; tvar = x; loc = loc} ->
- MLast.PaAny loc,
- MLast.ExTyc
- (loc, e,
- MLast.TyApp
- (loc,
- MLast.TyAcc
- (loc,
- MLast.TyAcc
- (loc, MLast.TyUid (loc, gmod),
- MLast.TyUid (loc, "Entry")),
- MLast.TyLid (loc, "e")),
- MLast.TyQuo (loc, x))))
- nl
- in
- let locals =
- List.map
- (fun {expr = e; tvar = x; loc = loc} ->
- let i =
- match e with
- MLast.ExLid (_, i) -> i
- | _ -> failwith "internal error in pa_extend"
- in
- MLast.PaLid (loc, i),
- MLast.ExTyc
- (loc,
- MLast.ExApp
- (loc, MLast.ExLid (loc, "grammar_entry_create"),
- MLast.ExStr (loc, i)),
- MLast.TyApp
- (loc,
- MLast.TyAcc
- (loc,
- MLast.TyAcc
- (loc, MLast.TyUid (loc, gmod),
- MLast.TyUid (loc, "Entry")),
- MLast.TyLid (loc, "e")),
- MLast.TyQuo (loc, x))))
- ll
- in
- let e =
- if ll = [] then args
- else if functor_version then
- MLast.ExLet
- (loc, false,
- [MLast.PaLid (loc, "grammar_entry_create"),
- MLast.ExAcc
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, gmod), MLast.ExUid (loc, "Entry")),
- MLast.ExLid (loc, "create"))],
- MLast.ExLet (loc, false, locals, args))
- else
- MLast.ExLet
- (loc, false,
- [MLast.PaLid (loc, "grammar_entry_create"),
- MLast.ExFun
- (loc,
- [MLast.PaLid (loc, "s"), None,
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, gmod),
- MLast.ExUid (loc, "Entry")),
- MLast.ExLid (loc, "create")),
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, gmod),
- MLast.ExLid (loc, "of_entry")),
- locate n1)),
- MLast.ExLid (loc, "s"))])],
- MLast.ExLet (loc, false, locals, args))
- in
- MLast.ExLet (loc, false, globals, e)
- | _ -> args
-;;
-
-let text_of_extend loc gmod gl el f =
- if !split_ext then
- let args =
- List.map
- (fun e ->
- let (ent, pos, txt) = text_of_entry e.name.loc gmod e in
- let ent =
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, gmod),
- MLast.ExUid (loc, "Entry")),
- MLast.ExLid (loc, "obj")),
- ent)
- in
- let e = MLast.ExTup (loc, [ent; pos; txt]) in
- MLast.ExLet
- (loc, false,
- [MLast.PaLid (loc, "aux"),
- MLast.ExFun
- (loc,
- [MLast.PaUid (loc, "()"), None,
- MLast.ExApp
- (loc, f,
- MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), e),
- MLast.ExUid (loc, "[]")))])],
- MLast.ExApp
- (loc, MLast.ExLid (loc, "aux"), MLast.ExUid (loc, "()"))))
- el
- in
- let args = MLast.ExSeq (loc, args) in
- let_in_of_extend loc gmod false gl el args
- else
- let args =
- List.fold_right
- (fun e el ->
- let (ent, pos, txt) = text_of_entry e.name.loc gmod e in
- let ent =
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, gmod),
- MLast.ExUid (loc, "Entry")),
- MLast.ExLid (loc, "obj")),
- ent)
- in
- let e = MLast.ExTup (loc, [ent; pos; txt]) in
- MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), e), el))
- el (MLast.ExUid (loc, "[]"))
- in
- let args = let_in_of_extend loc gmod false gl el args in
- MLast.ExApp (loc, f, args)
-;;
-
-let text_of_functorial_extend loc gmod gl el =
- let args =
- let el =
- List.map
- (fun e ->
- let (ent, pos, txt) = text_of_entry e.name.loc gmod e in
- let e =
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, gmod),
- MLast.ExLid (loc, "extend")),
- ent),
- pos),
- txt)
- in
- if !split_ext then
- MLast.ExLet
- (loc, false,
- [MLast.PaLid (loc, "aux"),
- MLast.ExFun (loc, [MLast.PaUid (loc, "()"), None, e])],
- MLast.ExApp
- (loc, MLast.ExLid (loc, "aux"), MLast.ExUid (loc, "()")))
- else e)
- el
- in
- MLast.ExSeq (loc, el)
- in
- let_in_of_extend loc gmod true gl el args
-;;
-
-open Pcaml;;
-let symbol = Grammar.Entry.create gram "symbol";;
-let semi_sep =
- if !syntax_name = "Scheme" then
- Grammar.Entry.of_parser gram "'/'"
- (fun (strm__ : _ Stream.t) ->
- match Stream.peek strm__ with
- Some ("", "/") -> Stream.junk strm__; ()
- | _ -> raise Stream.Failure)
- else
- Grammar.Entry.of_parser gram "';'"
- (fun (strm__ : _ Stream.t) ->
- match Stream.peek strm__ with
- Some ("", ";") -> Stream.junk strm__; ()
- | _ -> raise Stream.Failure)
-;;
-
-Grammar.extend
- (let _ = (expr : 'expr Grammar.Entry.e)
- and _ = (symbol : 'symbol Grammar.Entry.e) in
- let grammar_entry_create s =
- Grammar.Entry.create (Grammar.of_entry expr) s
- in
- let extend_body : 'extend_body Grammar.Entry.e =
- grammar_entry_create "extend_body"
- and gextend_body : 'gextend_body Grammar.Entry.e =
- grammar_entry_create "gextend_body"
- and delete_rule_body : 'delete_rule_body Grammar.Entry.e =
- grammar_entry_create "delete_rule_body"
- and gdelete_rule_body : 'gdelete_rule_body Grammar.Entry.e =
- grammar_entry_create "gdelete_rule_body"
- and efunction : 'efunction Grammar.Entry.e =
- grammar_entry_create "efunction"
- and global : 'global Grammar.Entry.e = grammar_entry_create "global"
- and entry : 'entry Grammar.Entry.e = grammar_entry_create "entry"
- and position : 'position Grammar.Entry.e = grammar_entry_create "position"
- and level_list : 'level_list Grammar.Entry.e =
- grammar_entry_create "level_list"
- and level : 'level Grammar.Entry.e = grammar_entry_create "level"
- and assoc : 'assoc Grammar.Entry.e = grammar_entry_create "assoc"
- and rule_list : 'rule_list Grammar.Entry.e =
- grammar_entry_create "rule_list"
- and rule : 'rule Grammar.Entry.e = grammar_entry_create "rule"
- and psymbol : 'psymbol Grammar.Entry.e = grammar_entry_create "psymbol"
- and pattern : 'pattern Grammar.Entry.e = grammar_entry_create "pattern"
- and patterns_comma : 'patterns_comma Grammar.Entry.e =
- grammar_entry_create "patterns_comma"
- and name : 'name Grammar.Entry.e = grammar_entry_create "name"
- and qualid : 'qualid Grammar.Entry.e = grammar_entry_create "qualid"
- and string : 'string Grammar.Entry.e = grammar_entry_create "string" in
- [Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
- Some (Gramext.After "top"),
- [None, None,
- [[Gramext.Stoken ("", "GDELETE_RULE");
- Gramext.Snterm
- (Grammar.Entry.obj
- (gdelete_rule_body : 'gdelete_rule_body Grammar.Entry.e));
- Gramext.Stoken ("", "END")],
- Gramext.action
- (fun _ (e : 'gdelete_rule_body) _ (loc : int * int) -> (e : 'expr));
- [Gramext.Stoken ("", "DELETE_RULE");
- Gramext.Snterm
- (Grammar.Entry.obj
- (delete_rule_body : 'delete_rule_body Grammar.Entry.e));
- Gramext.Stoken ("", "END")],
- Gramext.action
- (fun _ (e : 'delete_rule_body) _ (loc : int * int) -> (e : 'expr));
- [Gramext.Stoken ("", "GEXTEND");
- Gramext.Snterm
- (Grammar.Entry.obj (gextend_body : 'gextend_body Grammar.Entry.e));
- Gramext.Stoken ("", "END")],
- Gramext.action
- (fun _ (e : 'gextend_body) _ (loc : int * int) -> (e : 'expr));
- [Gramext.Stoken ("", "EXTEND");
- Gramext.Snterm
- (Grammar.Entry.obj (extend_body : 'extend_body Grammar.Entry.e));
- Gramext.Stoken ("", "END")],
- Gramext.action
- (fun _ (e : 'extend_body) _ (loc : int * int) -> (e : 'expr))]];
- Grammar.Entry.obj (extend_body : 'extend_body Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (efunction : 'efunction Grammar.Entry.e));
- Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj (global : 'global Grammar.Entry.e)));
- Gramext.Slist1
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj (entry : 'entry Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))],
- Gramext.action
- (fun _ (e : 'entry) (loc : int * int) -> (e : 'e__1))])],
- Gramext.action
- (fun (el : 'e__1 list) (sl : 'global option) (f : 'efunction)
- (loc : int * int) ->
- (text_of_extend loc "Grammar" sl el f : 'extend_body))]];
- Grammar.Entry.obj (gextend_body : 'gextend_body Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("UIDENT", "");
- Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj (global : 'global Grammar.Entry.e)));
- Gramext.Slist1
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj (entry : 'entry Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))],
- Gramext.action
- (fun _ (e : 'entry) (loc : int * int) -> (e : 'e__2))])],
- Gramext.action
- (fun (el : 'e__2 list) (sl : 'global option) (g : string)
- (loc : int * int) ->
- (text_of_functorial_extend loc g sl el : 'gextend_body))]];
- Grammar.Entry.obj (delete_rule_body : 'delete_rule_body Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e)),
- Gramext.Snterm
- (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e)))],
- Gramext.action
- (fun (sl : 'symbol list) _ (n : 'name) (loc : int * int) ->
- (let (e, b) = expr_of_delete_rule loc "Grammar" n sl in
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Grammar"),
- MLast.ExLid (loc, "delete_rule")),
- e),
- b) :
- 'delete_rule_body))]];
- Grammar.Entry.obj
- (gdelete_rule_body : 'gdelete_rule_body Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("UIDENT", "");
- Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e)),
- Gramext.Snterm
- (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e)))],
- Gramext.action
- (fun (sl : 'symbol list) _ (n : 'name) (g : string)
- (loc : int * int) ->
- (let (e, b) = expr_of_delete_rule loc g n sl in
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, g),
- MLast.ExLid (loc, "delete_rule")),
- e),
- b) :
- 'gdelete_rule_body))]];
- Grammar.Entry.obj (efunction : 'efunction Grammar.Entry.e), None,
- [None, None,
- [[],
- Gramext.action
- (fun (loc : int * int) ->
- (MLast.ExAcc
- (loc, MLast.ExUid (loc, "Grammar"),
- MLast.ExLid (loc, "extend")) :
- 'efunction));
- [Gramext.Stoken ("UIDENT", "FUNCTION"); Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (qualid : 'qualid Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))],
- Gramext.action
- (fun _ (f : 'qualid) _ _ (loc : int * int) -> (f : 'efunction))]];
- Grammar.Entry.obj (global : 'global Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("UIDENT", "GLOBAL"); Gramext.Stoken ("", ":");
- Gramext.Slist1
- (Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e)));
- Gramext.Snterm
- (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))],
- Gramext.action
- (fun _ (sl : 'name list) _ _ (loc : int * int) -> (sl : 'global))]];
- Grammar.Entry.obj (entry : 'entry Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj (position : 'position Grammar.Entry.e)));
- Gramext.Snterm
- (Grammar.Entry.obj (level_list : 'level_list Grammar.Entry.e))],
- Gramext.action
- (fun (ll : 'level_list) (pos : 'position option) _ (n : 'name)
- (loc : int * int) ->
- ({name = n; pos = pos; levels = ll} : 'entry))]];
- Grammar.Entry.obj (position : 'position Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("UIDENT", "LEVEL");
- Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))],
- Gramext.action
- (fun (n : 'string) _ (loc : int * int) ->
- (MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"),
- MLast.ExUid (loc, "Level")),
- n) :
- 'position));
- [Gramext.Stoken ("UIDENT", "AFTER");
- Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))],
- Gramext.action
- (fun (n : 'string) _ (loc : int * int) ->
- (MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"),
- MLast.ExUid (loc, "After")),
- n) :
- 'position));
- [Gramext.Stoken ("UIDENT", "BEFORE");
- Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))],
- Gramext.action
- (fun (n : 'string) _ (loc : int * int) ->
- (MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"),
- MLast.ExUid (loc, "Before")),
- n) :
- 'position));
- [Gramext.Stoken ("UIDENT", "LAST")],
- Gramext.action
- (fun _ (loc : int * int) ->
- (MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Last")) :
- 'position));
- [Gramext.Stoken ("UIDENT", "FIRST")],
- Gramext.action
- (fun _ (loc : int * int) ->
- (MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"),
- MLast.ExUid (loc, "First")) :
- 'position))]];
- Grammar.Entry.obj (level_list : 'level_list Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "[");
- Gramext.Slist0sep
- (Gramext.Snterm (Grammar.Entry.obj (level : 'level Grammar.Entry.e)),
- Gramext.Stoken ("", "|"));
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (ll : 'level list) _ (loc : int * int) ->
- (ll : 'level_list))]];
- Grammar.Entry.obj (level : 'level Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Sopt (Gramext.Stoken ("STRING", ""));
- Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj (assoc : 'assoc Grammar.Entry.e)));
- Gramext.Snterm
- (Grammar.Entry.obj (rule_list : 'rule_list Grammar.Entry.e))],
- Gramext.action
- (fun (rules : 'rule_list) (ass : 'assoc option) (lab : string option)
- (loc : int * int) ->
- ({label = lab; assoc = ass; rules = rules} : 'level))]];
- Grammar.Entry.obj (assoc : 'assoc Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("UIDENT", "NONA")],
- Gramext.action
- (fun _ (loc : int * int) ->
- (MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "NonA")) :
- 'assoc));
- [Gramext.Stoken ("UIDENT", "RIGHTA")],
- Gramext.action
- (fun _ (loc : int * int) ->
- (MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"),
- MLast.ExUid (loc, "RightA")) :
- 'assoc));
- [Gramext.Stoken ("UIDENT", "LEFTA")],
- Gramext.action
- (fun _ (loc : int * int) ->
- (MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"),
- MLast.ExUid (loc, "LeftA")) :
- 'assoc))]];
- Grammar.Entry.obj (rule_list : 'rule_list Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "[");
- Gramext.Slist1sep
- (Gramext.Snterm (Grammar.Entry.obj (rule : 'rule Grammar.Entry.e)),
- Gramext.Stoken ("", "|"));
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (rules : 'rule list) _ (loc : int * int) ->
- (retype_rule_list_without_patterns loc rules : 'rule_list));
- [Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")],
- Gramext.action (fun _ _ (loc : int * int) -> ([] : 'rule_list))]];
- Grammar.Entry.obj (rule : 'rule Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Slist0sep
- (Gramext.Snterm
- (Grammar.Entry.obj (psymbol : 'psymbol Grammar.Entry.e)),
- Gramext.Snterm
- (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e)))],
- Gramext.action
- (fun (psl : 'psymbol list) (loc : int * int) ->
- ({prod = psl; action = None} : 'rule));
- [Gramext.Slist0sep
- (Gramext.Snterm
- (Grammar.Entry.obj (psymbol : 'psymbol Grammar.Entry.e)),
- Gramext.Snterm
- (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e)));
- Gramext.Stoken ("", "->");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (act : 'expr) _ (psl : 'psymbol list) (loc : int * int) ->
- ({prod = psl; action = Some act} : 'rule))]];
- Grammar.Entry.obj (psymbol : 'psymbol Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))],
- Gramext.action
- (fun (s : 'symbol) (loc : int * int) ->
- ({pattern = None; symbol = s} : 'psymbol));
- [Gramext.Snterm
- (Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))],
- Gramext.action
- (fun (s : 'symbol) _ (p : 'pattern) (loc : int * int) ->
- ({pattern = Some p; symbol = s} : 'psymbol));
- [Gramext.Stoken ("LIDENT", "");
- Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("UIDENT", "LEVEL");
- Gramext.Stoken ("STRING", "")],
- Gramext.action
- (fun (s : string) _ (loc : int * int) -> (s : 'e__3))])],
- Gramext.action
- (fun (lev : 'e__3 option) (i : string) (loc : int * int) ->
- (let name = mk_name loc (MLast.ExLid (loc, i)) in
- let text = TXnterm (loc, name, lev) in
- let styp = STquo (loc, i) in
- let symb = {used = [i]; text = text; styp = styp} in
- {pattern = None; symbol = symb} :
- 'psymbol));
- [Gramext.Stoken ("LIDENT", ""); Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))],
- Gramext.action
- (fun (s : 'symbol) _ (p : string) (loc : int * int) ->
- ({pattern = Some (MLast.PaLid (loc, p)); symbol = s} :
- 'psymbol))]];
- Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e), None,
- [Some "top", Some Gramext.NonA,
- [[Gramext.Stoken ("UIDENT", "OPT"); Gramext.Sself],
- Gramext.action
- (fun (s : 'symbol) _ (loc : int * int) ->
- (if !quotify then ssopt loc s
- else
- let styp = STapp (loc, STlid (loc, "option"), s.styp) in
- let text = TXopt (loc, s.text) in
- {used = s.used; text = text; styp = styp} :
- 'symbol));
- [Gramext.Stoken ("UIDENT", "LIST1"); Gramext.Sself;
- Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("UIDENT", "SEP");
- Gramext.Snterm
- (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'symbol) _ (loc : int * int) -> (t : 'e__5))])],
- Gramext.action
- (fun (sep : 'e__5 option) (s : 'symbol) _ (loc : int * int) ->
- (if !quotify then sslist loc true sep s
- else
- let used =
- match sep with
- Some symb -> symb.used @ s.used
- | None -> s.used
- in
- let styp = STapp (loc, STlid (loc, "list"), s.styp) in
- let text = slist loc true sep s in
- {used = used; text = text; styp = styp} :
- 'symbol));
- [Gramext.Stoken ("UIDENT", "LIST0"); Gramext.Sself;
- Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("UIDENT", "SEP");
- Gramext.Snterm
- (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'symbol) _ (loc : int * int) -> (t : 'e__4))])],
- Gramext.action
- (fun (sep : 'e__4 option) (s : 'symbol) _ (loc : int * int) ->
- (if !quotify then sslist loc false sep s
- else
- let used =
- match sep with
- Some symb -> symb.used @ s.used
- | None -> s.used
- in
- let styp = STapp (loc, STlid (loc, "list"), s.styp) in
- let text = slist loc false sep s in
- {used = used; text = text; styp = styp} :
- 'symbol))];
- None, None,
- [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (s_t : 'symbol) _ (loc : int * int) -> (s_t : 'symbol));
- [Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e));
- Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("UIDENT", "LEVEL");
- Gramext.Stoken ("STRING", "")],
- Gramext.action
- (fun (s : string) _ (loc : int * int) -> (s : 'e__7))])],
- Gramext.action
- (fun (lev : 'e__7 option) (n : 'name) (loc : int * int) ->
- ({used = [n.tvar]; text = TXnterm (loc, n, lev);
- styp = STquo (loc, n.tvar)} :
- 'symbol));
- [Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ".");
- Gramext.Snterm (Grammar.Entry.obj (qualid : 'qualid Grammar.Entry.e));
- Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("UIDENT", "LEVEL");
- Gramext.Stoken ("STRING", "")],
- Gramext.action
- (fun (s : string) _ (loc : int * int) -> (s : 'e__6))])],
- Gramext.action
- (fun (lev : 'e__6 option) (e : 'qualid) _ (i : string)
- (loc : int * int) ->
- (let n =
- mk_name loc (MLast.ExAcc (loc, MLast.ExUid (loc, i), e))
- in
- {used = [n.tvar]; text = TXnterm (loc, n, lev);
- styp = STquo (loc, n.tvar)} :
- 'symbol));
- [Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'string) (loc : int * int) ->
- (let text = TXtok (loc, "", e) in
- {used = []; text = text; styp = STlid (loc, "string")} :
- 'symbol));
- [Gramext.Stoken ("UIDENT", "");
- Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'string) (x : string) (loc : int * int) ->
- (let text = TXtok (loc, x, e) in
- {used = []; text = text; styp = STlid (loc, "string")} :
- 'symbol));
- [Gramext.Stoken ("UIDENT", "")],
- Gramext.action
- (fun (x : string) (loc : int * int) ->
- (let text =
- if !quotify then sstoken loc x
- else TXtok (loc, x, MLast.ExStr (loc, ""))
- in
- {used = []; text = text; styp = STlid (loc, "string")} :
- 'symbol));
- [Gramext.Stoken ("", "[");
- Gramext.Slist0sep
- (Gramext.Snterm (Grammar.Entry.obj (rule : 'rule Grammar.Entry.e)),
- Gramext.Stoken ("", "|"));
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (rl : 'rule list) _ (loc : int * int) ->
- (let rl = retype_rule_list_without_patterns loc rl in
- let t = new_type_var () in
- {used = used_of_rule_list rl;
- text = TXrules (loc, srules loc t rl "");
- styp = STquo (loc, t)} :
- 'symbol));
- [Gramext.Stoken ("UIDENT", "NEXT")],
- Gramext.action
- (fun _ (loc : int * int) ->
- ({used = []; text = TXnext loc; styp = STself (loc, "NEXT")} :
- 'symbol));
- [Gramext.Stoken ("UIDENT", "SELF")],
- Gramext.action
- (fun _ (loc : int * int) ->
- ({used = []; text = TXself loc; styp = STself (loc, "SELF")} :
- 'symbol))]];
- Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ",");
- Gramext.Snterm
- (Grammar.Entry.obj
- (patterns_comma : 'patterns_comma Grammar.Entry.e));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (pl : 'patterns_comma) _ (p : 'pattern) _ (loc : int * int) ->
- (MLast.PaTup (loc, (p :: pl)) : 'pattern));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (p : 'pattern) _ (loc : int * int) -> (p : 'pattern));
- [Gramext.Stoken ("", "_")],
- Gramext.action
- (fun _ (loc : int * int) -> (MLast.PaAny loc : 'pattern));
- [Gramext.Stoken ("LIDENT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) ->
- (MLast.PaLid (loc, i) : 'pattern))]];
- Grammar.Entry.obj (patterns_comma : 'patterns_comma Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Sself; Gramext.Stoken ("", ",");
- Gramext.Snterm
- (Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e))],
- Gramext.action
- (fun (p : 'pattern) _ (pl : 'patterns_comma) (loc : int * int) ->
- (pl @ [p] : 'patterns_comma))];
- None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e))],
- Gramext.action
- (fun (p : 'pattern) (loc : int * int) -> ([p] : 'patterns_comma))]];
- Grammar.Entry.obj (name : 'name Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (qualid : 'qualid Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'qualid) (loc : int * int) -> (mk_name loc e : 'name))]];
- Grammar.Entry.obj (qualid : 'qualid Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'qualid) _ (e1 : 'qualid) (loc : int * int) ->
- (MLast.ExAcc (loc, e1, e2) : 'qualid))];
- None, None,
- [[Gramext.Stoken ("LIDENT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) ->
- (MLast.ExLid (loc, i) : 'qualid));
- [Gramext.Stoken ("UIDENT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) ->
- (MLast.ExUid (loc, i) : 'qualid))]];
- Grammar.Entry.obj (string : 'string Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("ANTIQUOT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) ->
- (let shift = fst loc + String.length "$" in
- let e =
- try Grammar.Entry.parse Pcaml.expr_eoi (Stream.of_string i) with
- Exc_located ((bp, ep), exc) ->
- raise_with_loc (shift + bp, shift + ep) exc
- in
- Pcaml.expr_reloc (fun (bp, ep) -> shift + bp, shift + ep) 0 e :
- 'string));
- [Gramext.Stoken ("STRING", "")],
- Gramext.action
- (fun (s : string) (loc : int * int) ->
- (MLast.ExStr (loc, s) : 'string))]]]);;
-
-Pcaml.add_option "-quotify" (Arg.Set quotify) "Generate code for quotations";;
-
-Pcaml.add_option "-meta_action" (Arg.Set meta_action) "Undocumented";;
diff --git a/camlp4/ocaml_src/meta/pa_extend_m.ml b/camlp4/ocaml_src/meta/pa_extend_m.ml
deleted file mode 100644
index 11fd07f58a..0000000000
--- a/camlp4/ocaml_src/meta/pa_extend_m.ml
+++ /dev/null
@@ -1,40 +0,0 @@
-(* camlp4r pa_extend.cmo q_MLast.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-open Pa_extend;;
-
-Grammar.extend
- [Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e),
- Some (Gramext.Level "top"),
- [None, Some Gramext.NonA,
- [[Gramext.Stoken ("UIDENT", "SOPT"); Gramext.Sself],
- Gramext.action
- (fun (s : 'symbol) _ (loc : int * int) -> (ssopt loc s : 'symbol));
- [Gramext.srules
- [[Gramext.Stoken ("UIDENT", "SLIST1")],
- Gramext.action (fun _ (loc : int * int) -> (true : 'e__1));
- [Gramext.Stoken ("UIDENT", "SLIST0")],
- Gramext.action (fun _ (loc : int * int) -> (false : 'e__1))];
- Gramext.Sself;
- Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("UIDENT", "SEP");
- Gramext.Snterm
- (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'symbol) _ (loc : int * int) -> (t : 'e__2))])],
- Gramext.action
- (fun (sep : 'e__2 option) (s : 'symbol) (min : 'e__1)
- (loc : int * int) ->
- (sslist loc min sep s : 'symbol))]]];;
diff --git a/camlp4/ocaml_src/meta/pa_ifdef.ml b/camlp4/ocaml_src/meta/pa_ifdef.ml
deleted file mode 100644
index 6384d6be1f..0000000000
--- a/camlp4/ocaml_src/meta/pa_ifdef.ml
+++ /dev/null
@@ -1,216 +0,0 @@
-(* camlp4r pa_extend.cmo q_MLast.cmo *)
-(* This file has been generated by program: do not edit! *)
-
-type 'a item_or_def =
- SdStr of 'a
- | SdDef of string
- | SdUnd of string
- | SdNop
-;;
-
-let list_remove x l =
- List.fold_right (fun e l -> if e = x then l else e :: l) l []
-;;
-
-let defined = ref ["OCAML_305"; "CAMLP4_300"; "NEWSEQ"];;
-let define x = defined := x :: !defined;;
-let undef x = defined := list_remove x !defined;;
-
-Grammar.extend
- (let _ = (Pcaml.expr : 'Pcaml__expr Grammar.Entry.e)
- and _ = (Pcaml.str_item : 'Pcaml__str_item Grammar.Entry.e)
- and _ = (Pcaml.sig_item : 'Pcaml__sig_item Grammar.Entry.e) in
- let grammar_entry_create s =
- Grammar.Entry.create (Grammar.of_entry Pcaml.expr) s
- in
- let def_undef_str : 'def_undef_str Grammar.Entry.e =
- grammar_entry_create "def_undef_str"
- and str_item_def_undef : 'str_item_def_undef Grammar.Entry.e =
- grammar_entry_create "str_item_def_undef"
- and def_undef_sig : 'def_undef_sig Grammar.Entry.e =
- grammar_entry_create "def_undef_sig"
- and sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e =
- grammar_entry_create "sig_item_def_undef"
- in
- [Grammar.Entry.obj (Pcaml.expr : 'Pcaml__expr Grammar.Entry.e),
- Some (Gramext.Level "top"),
- [None, None,
- [[Gramext.Stoken ("", "ifndef"); Gramext.Stoken ("UIDENT", "");
- Gramext.Stoken ("", "then"); Gramext.Sself;
- Gramext.Stoken ("", "else"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'Pcaml__expr) _ (e1 : 'Pcaml__expr) _ (c : string) _
- (loc : int * int) ->
- (if List.mem c !defined then e2 else e1 : 'Pcaml__expr));
- [Gramext.Stoken ("", "ifdef"); Gramext.Stoken ("UIDENT", "");
- Gramext.Stoken ("", "then"); Gramext.Sself;
- Gramext.Stoken ("", "else"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'Pcaml__expr) _ (e1 : 'Pcaml__expr) _ (c : string) _
- (loc : int * int) ->
- (if List.mem c !defined then e1 else e2 : 'Pcaml__expr))]];
- Grammar.Entry.obj (Pcaml.str_item : 'Pcaml__str_item Grammar.Entry.e),
- Some Gramext.First,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (def_undef_str : 'def_undef_str Grammar.Entry.e))],
- Gramext.action
- (fun (x : 'def_undef_str) (loc : int * int) ->
- (match x with
- SdStr si -> si
- | SdDef x -> define x; MLast.StDcl (loc, [])
- | SdUnd x -> undef x; MLast.StDcl (loc, [])
- | SdNop -> MLast.StDcl (loc, []) :
- 'Pcaml__str_item))]];
- Grammar.Entry.obj (def_undef_str : 'def_undef_str Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "undef"); Gramext.Stoken ("UIDENT", "")],
- Gramext.action
- (fun (c : string) _ (loc : int * int) -> (SdUnd c : 'def_undef_str));
- [Gramext.Stoken ("", "define"); Gramext.Stoken ("UIDENT", "")],
- Gramext.action
- (fun (c : string) _ (loc : int * int) -> (SdDef c : 'def_undef_str));
- [Gramext.Stoken ("", "ifndef"); Gramext.Stoken ("UIDENT", "");
- Gramext.Stoken ("", "then");
- Gramext.Snterm
- (Grammar.Entry.obj
- (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e))],
- Gramext.action
- (fun (e1 : 'str_item_def_undef) _ (c : string) _ (loc : int * int) ->
- (if List.mem c !defined then SdNop else e1 : 'def_undef_str));
- [Gramext.Stoken ("", "ifndef"); Gramext.Stoken ("UIDENT", "");
- Gramext.Stoken ("", "then");
- Gramext.Snterm
- (Grammar.Entry.obj
- (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e));
- Gramext.Stoken ("", "else");
- Gramext.Snterm
- (Grammar.Entry.obj
- (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e))],
- Gramext.action
- (fun (e2 : 'str_item_def_undef) _ (e1 : 'str_item_def_undef) _
- (c : string) _ (loc : int * int) ->
- (if List.mem c !defined then e2 else e1 : 'def_undef_str));
- [Gramext.Stoken ("", "ifdef"); Gramext.Stoken ("UIDENT", "");
- Gramext.Stoken ("", "then");
- Gramext.Snterm
- (Grammar.Entry.obj
- (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e))],
- Gramext.action
- (fun (e1 : 'str_item_def_undef) _ (c : string) _ (loc : int * int) ->
- (if List.mem c !defined then e1 else SdNop : 'def_undef_str));
- [Gramext.Stoken ("", "ifdef"); Gramext.Stoken ("UIDENT", "");
- Gramext.Stoken ("", "then");
- Gramext.Snterm
- (Grammar.Entry.obj
- (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e));
- Gramext.Stoken ("", "else");
- Gramext.Snterm
- (Grammar.Entry.obj
- (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e))],
- Gramext.action
- (fun (e2 : 'str_item_def_undef) _ (e1 : 'str_item_def_undef) _
- (c : string) _ (loc : int * int) ->
- (if List.mem c !defined then e1 else e2 : 'def_undef_str))]];
- Grammar.Entry.obj
- (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (Pcaml.str_item : 'Pcaml__str_item Grammar.Entry.e))],
- Gramext.action
- (fun (si : 'Pcaml__str_item) (loc : int * int) ->
- (SdStr si : 'str_item_def_undef));
- [Gramext.Snterm
- (Grammar.Entry.obj
- (def_undef_str : 'def_undef_str Grammar.Entry.e))],
- Gramext.action
- (fun (d : 'def_undef_str) (loc : int * int) ->
- (d : 'str_item_def_undef))]];
- Grammar.Entry.obj (Pcaml.sig_item : 'Pcaml__sig_item Grammar.Entry.e),
- Some Gramext.First,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (def_undef_sig : 'def_undef_sig Grammar.Entry.e))],
- Gramext.action
- (fun (x : 'def_undef_sig) (loc : int * int) ->
- (match x with
- SdStr si -> si
- | SdDef x -> define x; MLast.SgDcl (loc, [])
- | SdUnd x -> undef x; MLast.SgDcl (loc, [])
- | SdNop -> MLast.SgDcl (loc, []) :
- 'Pcaml__sig_item))]];
- Grammar.Entry.obj (def_undef_sig : 'def_undef_sig Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "undef"); Gramext.Stoken ("UIDENT", "")],
- Gramext.action
- (fun (c : string) _ (loc : int * int) -> (SdUnd c : 'def_undef_sig));
- [Gramext.Stoken ("", "define"); Gramext.Stoken ("UIDENT", "")],
- Gramext.action
- (fun (c : string) _ (loc : int * int) -> (SdDef c : 'def_undef_sig));
- [Gramext.Stoken ("", "ifndef"); Gramext.Stoken ("UIDENT", "");
- Gramext.Stoken ("", "then");
- Gramext.Snterm
- (Grammar.Entry.obj
- (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e))],
- Gramext.action
- (fun (e1 : 'sig_item_def_undef) _ (c : string) _ (loc : int * int) ->
- (if List.mem c !defined then SdNop else e1 : 'def_undef_sig));
- [Gramext.Stoken ("", "ifndef"); Gramext.Stoken ("UIDENT", "");
- Gramext.Stoken ("", "then");
- Gramext.Snterm
- (Grammar.Entry.obj
- (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e));
- Gramext.Stoken ("", "else");
- Gramext.Snterm
- (Grammar.Entry.obj
- (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e))],
- Gramext.action
- (fun (e2 : 'sig_item_def_undef) _ (e1 : 'sig_item_def_undef) _
- (c : string) _ (loc : int * int) ->
- (if List.mem c !defined then e2 else e1 : 'def_undef_sig));
- [Gramext.Stoken ("", "ifdef"); Gramext.Stoken ("UIDENT", "");
- Gramext.Stoken ("", "then");
- Gramext.Snterm
- (Grammar.Entry.obj
- (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e))],
- Gramext.action
- (fun (e1 : 'sig_item_def_undef) _ (c : string) _ (loc : int * int) ->
- (if List.mem c !defined then e1 else SdNop : 'def_undef_sig));
- [Gramext.Stoken ("", "ifdef"); Gramext.Stoken ("UIDENT", "");
- Gramext.Stoken ("", "then");
- Gramext.Snterm
- (Grammar.Entry.obj
- (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e));
- Gramext.Stoken ("", "else");
- Gramext.Snterm
- (Grammar.Entry.obj
- (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e))],
- Gramext.action
- (fun (e2 : 'sig_item_def_undef) _ (e1 : 'sig_item_def_undef) _
- (c : string) _ (loc : int * int) ->
- (if List.mem c !defined then e1 else e2 : 'def_undef_sig))]];
- Grammar.Entry.obj
- (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (Pcaml.sig_item : 'Pcaml__sig_item Grammar.Entry.e))],
- Gramext.action
- (fun (si : 'Pcaml__sig_item) (loc : int * int) ->
- (SdStr si : 'sig_item_def_undef));
- [Gramext.Snterm
- (Grammar.Entry.obj
- (def_undef_sig : 'def_undef_sig Grammar.Entry.e))],
- Gramext.action
- (fun (d : 'def_undef_sig) (loc : int * int) ->
- (d : 'sig_item_def_undef))]]]);;
-
-Pcaml.add_option "-D" (Arg.String define)
- "<string> Define for ifdef instruction.";;
-Pcaml.add_option "-U" (Arg.String undef)
- "<string> Undefine for ifdef instruction.";;
diff --git a/camlp4/ocaml_src/meta/pa_macro.ml b/camlp4/ocaml_src/meta/pa_macro.ml
deleted file mode 100644
index 599608f9fa..0000000000
--- a/camlp4/ocaml_src/meta/pa_macro.ml
+++ /dev/null
@@ -1,392 +0,0 @@
-(* camlp4r *)
-(* This file has been generated by program: do not edit! *)
-
-(*
-Added statements:
-
- At toplevel (structure item):
-
- DEFINE <uident>
- DEFINE <uident> = <expression>
- DEFINE <uident> (<parameters>) = <expression>
- IFDEF <uident> THEN <structure_items> END
- IFDEF <uident> THEN <structure_items> ELSE <structure_items> END
- IFNDEF <uident> THEN <structure_items> END
- IFNDEF <uident> THEN <structure_items> ELSE <structure_items> END
-
- In expressions:
-
- IFDEF <uident> THEN <expression> ELSE <expression> END
- IFNDEF <uident> THEN <expression> ELSE <expression> END
- __FILE__
- __LOCATION__
-
- In patterns:
-
- IFDEF <uident> THEN <pattern> ELSE <pattern> END
- IFNDEF <uident> THEN <pattern> ELSE <pattern> END
-
- As Camlp4 options:
-
- -D<uident>
- -U<uident>
-
- After having used a DEFINE <uident> followed by "= <expression>", you
- can use it in expressions *and* in patterns. If the expression defining
- the macro cannot be used as a pattern, there is an error message if
- it is used in a pattern.
-
- The expression __FILE__ returns the current compiled file name.
- The expression __LOCATION__ returns the current location of itself.
-
-*)
-
-(* #load "pa_extend.cmo" *)
-(* #load "q_MLast.cmo" *)
-
-open Pcaml;;
-
-type 'a item_or_def =
- SdStr of 'a
- | SdDef of string * (string list * MLast.expr) option
- | SdUnd of string
- | SdNop
-;;
-
-let rec list_remove x =
- function
- (y, _) :: l when y = x -> l
- | d :: l -> d :: list_remove x l
- | [] -> []
-;;
-
-let defined = ref [];;
-
-let is_defined i = List.mem_assoc i !defined;;
-
-let loc = 0, 0;;
-
-let subst mloc env =
- let rec loop =
- function
- MLast.ExLet (_, rf, pel, e) ->
- let pel = List.map (fun (p, e) -> p, loop e) pel in
- MLast.ExLet (loc, rf, pel, loop e)
- | MLast.ExIfe (_, e1, e2, e3) ->
- MLast.ExIfe (loc, loop e1, loop e2, loop e3)
- | MLast.ExApp (_, e1, e2) -> MLast.ExApp (loc, loop e1, loop e2)
- | MLast.ExLid (_, x) | MLast.ExUid (_, x) as e ->
- begin try MLast.ExAnt (loc, List.assoc x env) with
- Not_found -> e
- end
- | MLast.ExTup (_, x) -> MLast.ExTup (loc, List.map loop x)
- | MLast.ExRec (_, pel, None) ->
- let pel = List.map (fun (p, e) -> p, loop e) pel in
- MLast.ExRec (loc, pel, None)
- | e -> e
- in
- loop
-;;
-
-let substp mloc env =
- let rec loop =
- function
- MLast.ExApp (_, e1, e2) -> MLast.PaApp (loc, loop e1, loop e2)
- | MLast.ExLid (_, x) ->
- begin try MLast.PaAnt (loc, List.assoc x env) with
- Not_found -> MLast.PaLid (loc, x)
- end
- | MLast.ExUid (_, x) ->
- begin try MLast.PaAnt (loc, List.assoc x env) with
- Not_found -> MLast.PaUid (loc, x)
- end
- | MLast.ExInt (_, x) -> MLast.PaInt (loc, x)
- | MLast.ExTup (_, x) -> MLast.PaTup (loc, List.map loop x)
- | MLast.ExRec (_, pel, None) ->
- let ppl = List.map (fun (p, e) -> p, loop e) pel in
- MLast.PaRec (loc, ppl)
- | x ->
- Stdpp.raise_with_loc mloc
- (Failure
- "this macro cannot be used in a pattern (see its definition)")
- in
- loop
-;;
-
-let incorrect_number loc l1 l2 =
- Stdpp.raise_with_loc loc
- (Failure
- (Printf.sprintf "expected %d parameters; found %d" (List.length l2)
- (List.length l1)))
-;;
-
-let define eo x =
- begin match eo with
- Some ([], e) ->
- Grammar.extend
- [Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("UIDENT", x)],
- Gramext.action
- (fun _ (loc : int * int) ->
- (Pcaml.expr_reloc (fun _ -> loc) 0 e : 'expr))]];
- Grammar.Entry.obj (patt : 'patt Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("UIDENT", x)],
- Gramext.action
- (fun _ (loc : int * int) ->
- (let p = substp loc [] e in
- Pcaml.patt_reloc (fun _ -> loc) 0 p :
- 'patt))]]]
- | Some (sl, e) ->
- Grammar.extend
- [Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
- Some (Gramext.Level "apply"),
- [None, None,
- [[Gramext.Stoken ("UIDENT", x); Gramext.Sself],
- Gramext.action
- (fun (param : 'expr) _ (loc : int * int) ->
- (let el =
- match param with
- MLast.ExTup (_, el) -> el
- | e -> [e]
- in
- if List.length el = List.length sl then
- let env = List.combine sl el in
- let e = subst loc env e in
- Pcaml.expr_reloc (fun _ -> loc) 0 e
- else incorrect_number loc el sl :
- 'expr))]];
- Grammar.Entry.obj (patt : 'patt Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("UIDENT", x); Gramext.Sself],
- Gramext.action
- (fun (param : 'patt) _ (loc : int * int) ->
- (let pl =
- match param with
- MLast.PaTup (_, pl) -> pl
- | p -> [p]
- in
- if List.length pl = List.length sl then
- let env = List.combine sl pl in
- let p = substp loc env e in
- Pcaml.patt_reloc (fun _ -> loc) 0 p
- else incorrect_number loc pl sl :
- 'patt))]]]
- | None -> ()
- end;
- defined := (x, eo) :: !defined
-;;
-
-let undef x =
- try
- let eo = List.assoc x !defined in
- begin match eo with
- Some ([], _) ->
- Grammar.delete_rule expr [Gramext.Stoken ("UIDENT", x)];
- Grammar.delete_rule patt [Gramext.Stoken ("UIDENT", x)]
- | Some (_, _) ->
- Grammar.delete_rule expr
- [Gramext.Stoken ("UIDENT", x); Gramext.Sself];
- Grammar.delete_rule patt [Gramext.Stoken ("UIDENT", x); Gramext.Sself]
- | None -> ()
- end;
- defined := list_remove x !defined
- with
- Not_found -> ()
-;;
-
-Grammar.extend
- (let _ = (expr : 'expr Grammar.Entry.e)
- and _ = (patt : 'patt Grammar.Entry.e)
- and _ = (str_item : 'str_item Grammar.Entry.e)
- and _ = (sig_item : 'sig_item Grammar.Entry.e) in
- let grammar_entry_create s =
- Grammar.Entry.create (Grammar.of_entry expr) s
- in
- let macro_def : 'macro_def Grammar.Entry.e =
- grammar_entry_create "macro_def"
- and str_item_or_macro : 'str_item_or_macro Grammar.Entry.e =
- grammar_entry_create "str_item_or_macro"
- and opt_macro_value : 'opt_macro_value Grammar.Entry.e =
- grammar_entry_create "opt_macro_value"
- and uident : 'uident Grammar.Entry.e = grammar_entry_create "uident" in
- [Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e),
- Some Gramext.First,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (macro_def : 'macro_def Grammar.Entry.e))],
- Gramext.action
- (fun (x : 'macro_def) (loc : int * int) ->
- (match x with
- SdStr [si] -> si
- | SdStr sil -> MLast.StDcl (loc, sil)
- | SdDef (x, eo) -> define eo x; MLast.StDcl (loc, [])
- | SdUnd x -> undef x; MLast.StDcl (loc, [])
- | SdNop -> MLast.StDcl (loc, []) :
- 'str_item))]];
- Grammar.Entry.obj (macro_def : 'macro_def Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "IFNDEF");
- Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e));
- Gramext.Stoken ("", "THEN");
- Gramext.Snterm
- (Grammar.Entry.obj
- (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e));
- Gramext.Stoken ("", "ELSE");
- Gramext.Snterm
- (Grammar.Entry.obj
- (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e));
- Gramext.Stoken ("", "END")],
- Gramext.action
- (fun _ (d2 : 'str_item_or_macro) _ (d1 : 'str_item_or_macro) _
- (i : 'uident) _ (loc : int * int) ->
- (if is_defined i then d2 else d1 : 'macro_def));
- [Gramext.Stoken ("", "IFNDEF");
- Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e));
- Gramext.Stoken ("", "THEN");
- Gramext.Snterm
- (Grammar.Entry.obj
- (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e));
- Gramext.Stoken ("", "END")],
- Gramext.action
- (fun _ (d : 'str_item_or_macro) _ (i : 'uident) _ (loc : int * int) ->
- (if is_defined i then SdNop else d : 'macro_def));
- [Gramext.Stoken ("", "IFDEF");
- Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e));
- Gramext.Stoken ("", "THEN");
- Gramext.Snterm
- (Grammar.Entry.obj
- (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e));
- Gramext.Stoken ("", "ELSE");
- Gramext.Snterm
- (Grammar.Entry.obj
- (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e));
- Gramext.Stoken ("", "END")],
- Gramext.action
- (fun _ (d2 : 'str_item_or_macro) _ (d1 : 'str_item_or_macro) _
- (i : 'uident) _ (loc : int * int) ->
- (if is_defined i then d1 else d2 : 'macro_def));
- [Gramext.Stoken ("", "IFDEF");
- Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e));
- Gramext.Stoken ("", "THEN");
- Gramext.Snterm
- (Grammar.Entry.obj
- (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e));
- Gramext.Stoken ("", "END")],
- Gramext.action
- (fun _ (d : 'str_item_or_macro) _ (i : 'uident) _ (loc : int * int) ->
- (if is_defined i then d else SdNop : 'macro_def));
- [Gramext.Stoken ("", "UNDEF");
- Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'uident) _ (loc : int * int) -> (SdUnd i : 'macro_def));
- [Gramext.Stoken ("", "DEFINE");
- Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj
- (opt_macro_value : 'opt_macro_value Grammar.Entry.e))],
- Gramext.action
- (fun (def : 'opt_macro_value) (i : 'uident) _ (loc : int * int) ->
- (SdDef (i, def) : 'macro_def))]];
- Grammar.Entry.obj
- (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Slist1
- (Gramext.Snterm
- (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)))],
- Gramext.action
- (fun (si : 'str_item list) (loc : int * int) ->
- (SdStr si : 'str_item_or_macro));
- [Gramext.Snterm
- (Grammar.Entry.obj (macro_def : 'macro_def Grammar.Entry.e))],
- Gramext.action
- (fun (d : 'macro_def) (loc : int * int) ->
- (d : 'str_item_or_macro))]];
- Grammar.Entry.obj (opt_macro_value : 'opt_macro_value Grammar.Entry.e),
- None,
- [None, None,
- [[], Gramext.action (fun (loc : int * int) -> (None : 'opt_macro_value));
- [Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (loc : int * int) ->
- (Some ([], e) : 'opt_macro_value));
- [Gramext.Stoken ("", "(");
- Gramext.Slist1sep
- (Gramext.Stoken ("LIDENT", ""), Gramext.Stoken ("", ","));
- Gramext.Stoken ("", ")"); Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ _ (pl : string list) _ (loc : int * int) ->
- (Some (pl, e) : 'opt_macro_value))]];
- Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
- Some (Gramext.Level "top"),
- [None, None,
- [[Gramext.Stoken ("", "IFNDEF");
- Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e));
- Gramext.Stoken ("", "THEN"); Gramext.Sself;
- Gramext.Stoken ("", "ELSE"); Gramext.Sself;
- Gramext.Stoken ("", "END")],
- Gramext.action
- (fun _ (e2 : 'expr) _ (e1 : 'expr) _ (i : 'uident) _
- (loc : int * int) ->
- (if is_defined i then e2 else e1 : 'expr));
- [Gramext.Stoken ("", "IFDEF");
- Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e));
- Gramext.Stoken ("", "THEN"); Gramext.Sself;
- Gramext.Stoken ("", "ELSE"); Gramext.Sself;
- Gramext.Stoken ("", "END")],
- Gramext.action
- (fun _ (e2 : 'expr) _ (e1 : 'expr) _ (i : 'uident) _
- (loc : int * int) ->
- (if is_defined i then e1 else e2 : 'expr))]];
- Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("LIDENT", "__LOCATION__")],
- Gramext.action
- (fun _ (loc : int * int) ->
- (let bp = string_of_int (fst loc) in
- let ep = string_of_int (snd loc) in
- MLast.ExTup
- (loc, [MLast.ExInt (loc, bp); MLast.ExInt (loc, ep)]) :
- 'expr));
- [Gramext.Stoken ("LIDENT", "__FILE__")],
- Gramext.action
- (fun _ (loc : int * int) ->
- (MLast.ExStr (loc, !(Pcaml.input_file)) : 'expr))]];
- Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "IFNDEF");
- Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e));
- Gramext.Stoken ("", "THEN"); Gramext.Sself;
- Gramext.Stoken ("", "ELSE"); Gramext.Sself;
- Gramext.Stoken ("", "END")],
- Gramext.action
- (fun _ (p2 : 'patt) _ (p1 : 'patt) _ (i : 'uident) _
- (loc : int * int) ->
- (if is_defined i then p2 else p1 : 'patt));
- [Gramext.Stoken ("", "IFDEF");
- Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e));
- Gramext.Stoken ("", "THEN"); Gramext.Sself;
- Gramext.Stoken ("", "ELSE"); Gramext.Sself;
- Gramext.Stoken ("", "END")],
- Gramext.action
- (fun _ (p2 : 'patt) _ (p1 : 'patt) _ (i : 'uident) _
- (loc : int * int) ->
- (if is_defined i then p1 else p2 : 'patt))]];
- Grammar.Entry.obj (uident : 'uident Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("UIDENT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) -> (i : 'uident))]]]);;
-
-Pcaml.add_option "-D" (Arg.String (define None))
- "<string> Define for IFDEF instruction.";;
-Pcaml.add_option "-U" (Arg.String undef)
- "<string> Undefine for IFDEF instruction.";;
diff --git a/camlp4/ocaml_src/meta/pa_r.ml b/camlp4/ocaml_src/meta/pa_r.ml
deleted file mode 100644
index 013adfa8d6..0000000000
--- a/camlp4/ocaml_src/meta/pa_r.ml
+++ /dev/null
@@ -1,2814 +0,0 @@
-(* camlp4r pa_extend.cmo q_MLast.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-open Stdpp;;
-open Pcaml;;
-
-Pcaml.no_constructors_arity := false;;
-
-let help_sequences () =
- Printf.eprintf "\
-New syntax:
- do {e1; e2; ... ; en}
- while e do {e1; e2; ... ; en}
- for v = v1 to/downto v2 do {e1; e2; ... ; en}
-Old (discouraged) syntax:
- do e1; e2; ... ; en-1; return en
- while e do e1; e2; ... ; en; done
- for v = v1 to/downto v2 do e1; e2; ... ; en; done
-To avoid compilation warning use the new syntax.
-";
- flush stderr;
- exit 1
-;;
-Pcaml.add_option "-help_seq" (Arg.Unit help_sequences)
- "Print explanations about new sequences and exit.";;
-
-let odfa = !(Plexer.dollar_for_antiquotation) in
-Plexer.dollar_for_antiquotation := false;
-Grammar.Unsafe.gram_reinit gram (Plexer.gmake ());
-Plexer.dollar_for_antiquotation := odfa;
-Grammar.Unsafe.clear_entry interf;
-Grammar.Unsafe.clear_entry implem;
-Grammar.Unsafe.clear_entry top_phrase;
-Grammar.Unsafe.clear_entry use_file;
-Grammar.Unsafe.clear_entry module_type;
-Grammar.Unsafe.clear_entry module_expr;
-Grammar.Unsafe.clear_entry sig_item;
-Grammar.Unsafe.clear_entry str_item;
-Grammar.Unsafe.clear_entry expr;
-Grammar.Unsafe.clear_entry patt;
-Grammar.Unsafe.clear_entry ctyp;
-Grammar.Unsafe.clear_entry let_binding;
-Grammar.Unsafe.clear_entry type_declaration;
-Grammar.Unsafe.clear_entry class_type;
-Grammar.Unsafe.clear_entry class_expr;
-Grammar.Unsafe.clear_entry class_sig_item;
-Grammar.Unsafe.clear_entry class_str_item;;
-
-Pcaml.parse_interf := Grammar.Entry.parse interf;;
-Pcaml.parse_implem := Grammar.Entry.parse implem;;
-
-let o2b =
- function
- Some _ -> true
- | None -> false
-;;
-
-let mksequence loc =
- function
- [e] -> e
- | el -> MLast.ExSeq (loc, el)
-;;
-
-let mkmatchcase loc p aso w e =
- let p =
- match aso with
- Some p2 -> MLast.PaAli (loc, p, p2)
- | _ -> p
- in
- p, w, e
-;;
-
-let neg_string n =
- let len = String.length n in
- if len > 0 && n.[0] = '-' then String.sub n 1 (len - 1) else "-" ^ n
-;;
-
-let mkumin loc f arg =
- match arg with
- MLast.ExInt (_, n) -> MLast.ExInt (loc, neg_string n)
- | MLast.ExInt32 (loc, n) -> MLast.ExInt32 (loc, neg_string n)
- | MLast.ExInt64 (loc, n) -> MLast.ExInt64 (loc, neg_string n)
- | MLast.ExNativeInt (loc, n) -> MLast.ExNativeInt (loc, neg_string n)
- | MLast.ExFlo (_, n) -> MLast.ExFlo (loc, neg_string n)
- | _ -> let f = "~" ^ f in MLast.ExApp (loc, MLast.ExLid (loc, f), arg)
-;;
-
-let mklistexp loc last =
- let rec loop top =
- function
- [] ->
- begin match last with
- Some e -> e
- | None -> MLast.ExUid (loc, "[]")
- end
- | e1 :: el ->
- let loc = if top then loc else fst (MLast.loc_of_expr e1), snd loc in
- MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), e1), loop false el)
- in
- loop true
-;;
-
-let mklistpat loc last =
- let rec loop top =
- function
- [] ->
- begin match last with
- Some p -> p
- | None -> MLast.PaUid (loc, "[]")
- end
- | p1 :: pl ->
- let loc = if top then loc else fst (MLast.loc_of_patt p1), snd loc in
- MLast.PaApp
- (loc, MLast.PaApp (loc, MLast.PaUid (loc, "::"), p1), loop false pl)
- in
- loop true
-;;
-
-let mkexprident loc i j =
- let rec loop m =
- function
- MLast.ExAcc (_, x, y) -> loop (MLast.ExAcc (loc, m, x)) y
- | e -> MLast.ExAcc (loc, m, e)
- in
- loop (MLast.ExUid (loc, i)) j
-;;
-
-let mkassert loc e =
- match e with
- MLast.ExUid (_, "False") -> MLast.ExAsf loc
- | _ -> MLast.ExAsr (loc, e)
-;;
-
-let append_elem el e = el @ [e];;
-
-(* ...suppose to flush the input in case of syntax error to avoid multiple
- errors in case of cut-and-paste in the xterm, but work bad: for example
- the input "for x = 1;" waits for another line before displaying the
- error...
-value rec sync cs =
- match cs with parser
- [ [: `';' :] -> sync_semi cs
- | [: `_ :] -> sync cs ]
-and sync_semi cs =
- match Stream.peek cs with
- [ Some ('\010' | '\013') -> ()
- | _ -> sync cs ]
-;
-Pcaml.sync.val := sync;
-*)
-
-let ipatt = Grammar.Entry.create gram "ipatt";;
-let with_constr = Grammar.Entry.create gram "with_constr";;
-let row_field = Grammar.Entry.create gram "row_field";;
-
-let not_yet_warned_variant = ref true;;
-let warn_variant loc =
- if !not_yet_warned_variant then
- begin
- not_yet_warned_variant := false;
- !(Pcaml.warning) loc
- (Printf.sprintf
- "use of syntax of variants types deprecated since version 3.05")
- end
-;;
-
-let not_yet_warned = ref true;;
-let warn_sequence loc =
- if !not_yet_warned then
- begin
- not_yet_warned := false;
- !(Pcaml.warning) loc
- "use of syntax of sequences deprecated since version 3.01.1"
- end
-;;
-Pcaml.add_option "-no_warn_seq" (Arg.Clear not_yet_warned)
- "No warning when using old syntax for sequences.";;
-
-Grammar.extend
- (let _ = (sig_item : 'sig_item Grammar.Entry.e)
- and _ = (str_item : 'str_item Grammar.Entry.e)
- and _ = (ctyp : 'ctyp Grammar.Entry.e)
- and _ = (patt : 'patt Grammar.Entry.e)
- and _ = (expr : 'expr Grammar.Entry.e)
- and _ = (module_type : 'module_type Grammar.Entry.e)
- and _ = (module_expr : 'module_expr Grammar.Entry.e)
- and _ = (class_type : 'class_type Grammar.Entry.e)
- and _ = (class_expr : 'class_expr Grammar.Entry.e)
- and _ = (class_sig_item : 'class_sig_item Grammar.Entry.e)
- and _ = (class_str_item : 'class_str_item Grammar.Entry.e)
- and _ = (let_binding : 'let_binding Grammar.Entry.e)
- and _ = (type_declaration : 'type_declaration Grammar.Entry.e)
- and _ = (ipatt : 'ipatt Grammar.Entry.e)
- and _ = (with_constr : 'with_constr Grammar.Entry.e)
- and _ = (row_field : 'row_field Grammar.Entry.e) in
- let grammar_entry_create s =
- Grammar.Entry.create (Grammar.of_entry sig_item) s
- in
- let rebind_exn : 'rebind_exn Grammar.Entry.e =
- grammar_entry_create "rebind_exn"
- and module_binding : 'module_binding Grammar.Entry.e =
- grammar_entry_create "module_binding"
- and module_rec_binding : 'module_rec_binding Grammar.Entry.e =
- grammar_entry_create "module_rec_binding"
- and module_declaration : 'module_declaration Grammar.Entry.e =
- grammar_entry_create "module_declaration"
- and module_rec_declaration : 'module_rec_declaration Grammar.Entry.e =
- grammar_entry_create "module_rec_declaration"
- and cons_expr_opt : 'cons_expr_opt Grammar.Entry.e =
- grammar_entry_create "cons_expr_opt"
- and dummy : 'dummy Grammar.Entry.e = grammar_entry_create "dummy"
- and sequence : 'sequence Grammar.Entry.e = grammar_entry_create "sequence"
- and fun_binding : 'fun_binding Grammar.Entry.e =
- grammar_entry_create "fun_binding"
- and match_case : 'match_case Grammar.Entry.e =
- grammar_entry_create "match_case"
- and as_patt_opt : 'as_patt_opt Grammar.Entry.e =
- grammar_entry_create "as_patt_opt"
- and when_expr_opt : 'when_expr_opt Grammar.Entry.e =
- grammar_entry_create "when_expr_opt"
- and label_expr : 'label_expr Grammar.Entry.e =
- grammar_entry_create "label_expr"
- and expr_ident : 'expr_ident Grammar.Entry.e =
- grammar_entry_create "expr_ident"
- and fun_def : 'fun_def Grammar.Entry.e = grammar_entry_create "fun_def"
- and cons_patt_opt : 'cons_patt_opt Grammar.Entry.e =
- grammar_entry_create "cons_patt_opt"
- and label_patt : 'label_patt Grammar.Entry.e =
- grammar_entry_create "label_patt"
- and patt_label_ident : 'patt_label_ident Grammar.Entry.e =
- grammar_entry_create "patt_label_ident"
- and label_ipatt : 'label_ipatt Grammar.Entry.e =
- grammar_entry_create "label_ipatt"
- and type_patt : 'type_patt Grammar.Entry.e =
- grammar_entry_create "type_patt"
- and constrain : 'constrain Grammar.Entry.e =
- grammar_entry_create "constrain"
- and type_parameter : 'type_parameter Grammar.Entry.e =
- grammar_entry_create "type_parameter"
- and constructor_declaration : 'constructor_declaration Grammar.Entry.e =
- grammar_entry_create "constructor_declaration"
- and label_declaration : 'label_declaration Grammar.Entry.e =
- grammar_entry_create "label_declaration"
- and ident : 'ident Grammar.Entry.e = grammar_entry_create "ident"
- and mod_ident : 'mod_ident Grammar.Entry.e =
- grammar_entry_create "mod_ident"
- and class_declaration : 'class_declaration Grammar.Entry.e =
- grammar_entry_create "class_declaration"
- and class_fun_binding : 'class_fun_binding Grammar.Entry.e =
- grammar_entry_create "class_fun_binding"
- and class_type_parameters : 'class_type_parameters Grammar.Entry.e =
- grammar_entry_create "class_type_parameters"
- and class_fun_def : 'class_fun_def Grammar.Entry.e =
- grammar_entry_create "class_fun_def"
- and class_structure : 'class_structure Grammar.Entry.e =
- grammar_entry_create "class_structure"
- and class_self_patt : 'class_self_patt Grammar.Entry.e =
- grammar_entry_create "class_self_patt"
- and as_lident : 'as_lident Grammar.Entry.e =
- grammar_entry_create "as_lident"
- and polyt : 'polyt Grammar.Entry.e = grammar_entry_create "polyt"
- and cvalue_binding : 'cvalue_binding Grammar.Entry.e =
- grammar_entry_create "cvalue_binding"
- and label : 'label Grammar.Entry.e = grammar_entry_create "label"
- and class_self_type : 'class_self_type Grammar.Entry.e =
- grammar_entry_create "class_self_type"
- and class_description : 'class_description Grammar.Entry.e =
- grammar_entry_create "class_description"
- and class_type_declaration : 'class_type_declaration Grammar.Entry.e =
- grammar_entry_create "class_type_declaration"
- and field_expr : 'field_expr Grammar.Entry.e =
- grammar_entry_create "field_expr"
- and field : 'field Grammar.Entry.e = grammar_entry_create "field"
- and typevar : 'typevar Grammar.Entry.e = grammar_entry_create "typevar"
- and clty_longident : 'clty_longident Grammar.Entry.e =
- grammar_entry_create "clty_longident"
- and class_longident : 'class_longident Grammar.Entry.e =
- grammar_entry_create "class_longident"
- and row_field_list : 'row_field_list Grammar.Entry.e =
- grammar_entry_create "row_field_list"
- and name_tag : 'name_tag Grammar.Entry.e = grammar_entry_create "name_tag"
- and patt_tcon : 'patt_tcon Grammar.Entry.e =
- grammar_entry_create "patt_tcon"
- and ipatt_tcon : 'ipatt_tcon Grammar.Entry.e =
- grammar_entry_create "ipatt_tcon"
- and eq_expr : 'eq_expr Grammar.Entry.e = grammar_entry_create "eq_expr"
- and direction_flag : 'direction_flag Grammar.Entry.e =
- grammar_entry_create "direction_flag"
- and warning_variant : 'warning_variant Grammar.Entry.e =
- grammar_entry_create "warning_variant"
- and warning_sequence : 'warning_sequence Grammar.Entry.e =
- grammar_entry_create "warning_sequence"
- in
- [Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "struct");
- Gramext.Slist0
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (s : 'str_item) (loc : int * int) -> (s : 'e__1))]);
- Gramext.Stoken ("", "end")],
- Gramext.action
- (fun _ (st : 'e__1 list) _ (loc : int * int) ->
- (MLast.MeStr (loc, st) : 'module_expr));
- [Gramext.Stoken ("", "functor"); Gramext.Stoken ("", "(");
- Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ":");
- Gramext.Snterm
- (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e));
- Gramext.Stoken ("", ")"); Gramext.Stoken ("", "->"); Gramext.Sself],
- Gramext.action
- (fun (me : 'module_expr) _ _ (t : 'module_type) _ (i : string) _ _
- (loc : int * int) ->
- (MLast.MeFun (loc, i, t, me) : 'module_expr))];
- None, None,
- [[Gramext.Sself; Gramext.Sself],
- Gramext.action
- (fun (me2 : 'module_expr) (me1 : 'module_expr) (loc : int * int) ->
- (MLast.MeApp (loc, me1, me2) : 'module_expr))];
- None, None,
- [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
- Gramext.action
- (fun (me2 : 'module_expr) _ (me1 : 'module_expr) (loc : int * int) ->
- (MLast.MeAcc (loc, me1, me2) : 'module_expr))];
- Some "simple", None,
- [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (me : 'module_expr) _ (loc : int * int) ->
- (me : 'module_expr));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":");
- Gramext.Snterm
- (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (mt : 'module_type) _ (me : 'module_expr) _
- (loc : int * int) ->
- (MLast.MeTyc (loc, me, mt) : 'module_expr));
- [Gramext.Stoken ("UIDENT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) ->
- (MLast.MeUid (loc, i) : 'module_expr))]];
- Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), None,
- [Some "top", None,
- [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) (loc : int * int) ->
- (MLast.StExp (loc, e) : 'str_item));
- [Gramext.Stoken ("", "value");
- Gramext.Sopt (Gramext.Stoken ("", "rec"));
- Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (l : 'let_binding list) (r : string option) _
- (loc : int * int) ->
- (MLast.StVal (loc, o2b r, l) : 'str_item));
- [Gramext.Stoken ("", "type");
- Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (type_declaration : 'type_declaration Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (tdl : 'type_declaration list) _ (loc : int * int) ->
- (MLast.StTyp (loc, tdl) : 'str_item));
- [Gramext.Stoken ("", "open");
- Gramext.Snterm
- (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'mod_ident) _ (loc : int * int) ->
- (MLast.StOpn (loc, i) : 'str_item));
- [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "type");
- Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "=");
- Gramext.Snterm
- (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))],
- Gramext.action
- (fun (mt : 'module_type) _ (i : string) _ _ (loc : int * int) ->
- (MLast.StMty (loc, i, mt) : 'str_item));
- [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "rec");
- Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (module_rec_binding : 'module_rec_binding Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (nmtmes : 'module_rec_binding list) _ _ (loc : int * int) ->
- (MLast.StRecMod (loc, nmtmes) : 'str_item));
- [Gramext.Stoken ("", "module"); Gramext.Stoken ("UIDENT", "");
- Gramext.Snterm
- (Grammar.Entry.obj
- (module_binding : 'module_binding Grammar.Entry.e))],
- Gramext.action
- (fun (mb : 'module_binding) (i : string) _ (loc : int * int) ->
- (MLast.StMod (loc, i, mb) : 'str_item));
- [Gramext.Stoken ("", "include");
- Gramext.Snterm
- (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))],
- Gramext.action
- (fun (me : 'module_expr) _ (loc : int * int) ->
- (MLast.StInc (loc, me) : 'str_item));
- [Gramext.Stoken ("", "external"); Gramext.Stoken ("LIDENT", "");
- Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Slist1 (Gramext.Stoken ("STRING", ""))],
- Gramext.action
- (fun (pd : string list) _ (t : 'ctyp) _ (i : string) _
- (loc : int * int) ->
- (MLast.StExt (loc, i, t, pd) : 'str_item));
- [Gramext.Stoken ("", "exception");
- Gramext.Snterm
- (Grammar.Entry.obj
- (constructor_declaration :
- 'constructor_declaration Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj (rebind_exn : 'rebind_exn Grammar.Entry.e))],
- Gramext.action
- (fun (b : 'rebind_exn) (_, c, tl : 'constructor_declaration) _
- (loc : int * int) ->
- (MLast.StExc (loc, c, tl, b) : 'str_item));
- [Gramext.Stoken ("", "declare");
- Gramext.Slist0
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (s : 'str_item) (loc : int * int) -> (s : 'e__2))]);
- Gramext.Stoken ("", "end")],
- Gramext.action
- (fun _ (st : 'e__2 list) _ (loc : int * int) ->
- (MLast.StDcl (loc, st) : 'str_item))]];
- Grammar.Entry.obj (rebind_exn : 'rebind_exn Grammar.Entry.e), None,
- [None, None,
- [[], Gramext.action (fun (loc : int * int) -> ([] : 'rebind_exn));
- [Gramext.Stoken ("", "=");
- Gramext.Snterm
- (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))],
- Gramext.action
- (fun (sl : 'mod_ident) _ (loc : int * int) -> (sl : 'rebind_exn))]];
- Grammar.Entry.obj (module_binding : 'module_binding Grammar.Entry.e),
- None,
- [None, Some Gramext.RightA,
- [[Gramext.Stoken ("", "=");
- Gramext.Snterm
- (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))],
- Gramext.action
- (fun (me : 'module_expr) _ (loc : int * int) ->
- (me : 'module_binding));
- [Gramext.Stoken ("", ":");
- Gramext.Snterm
- (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm
- (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))],
- Gramext.action
- (fun (me : 'module_expr) _ (mt : 'module_type) _ (loc : int * int) ->
- (MLast.MeTyc (loc, me, mt) : 'module_binding));
- [Gramext.Stoken ("", "("); Gramext.Stoken ("UIDENT", "");
- Gramext.Stoken ("", ":");
- Gramext.Snterm
- (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e));
- Gramext.Stoken ("", ")"); Gramext.Sself],
- Gramext.action
- (fun (mb : 'module_binding) _ (mt : 'module_type) _ (m : string) _
- (loc : int * int) ->
- (MLast.MeFun (loc, m, mt, mb) : 'module_binding))]];
- Grammar.Entry.obj
- (module_rec_binding : 'module_rec_binding Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ":");
- Gramext.Snterm
- (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm
- (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))],
- Gramext.action
- (fun (me : 'module_expr) _ (mt : 'module_type) _ (m : string)
- (loc : int * int) ->
- (m, mt, me : 'module_rec_binding))]];
- Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "functor"); Gramext.Stoken ("", "(");
- Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ":"); Gramext.Sself;
- Gramext.Stoken ("", ")"); Gramext.Stoken ("", "->"); Gramext.Sself],
- Gramext.action
- (fun (mt : 'module_type) _ _ (t : 'module_type) _ (i : string) _ _
- (loc : int * int) ->
- (MLast.MtFun (loc, i, t, mt) : 'module_type))];
- None, None,
- [[Gramext.Sself; Gramext.Stoken ("", "with");
- Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj (with_constr : 'with_constr Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (wcl : 'with_constr list) _ (mt : 'module_type)
- (loc : int * int) ->
- (MLast.MtWit (loc, mt, wcl) : 'module_type))];
- None, None,
- [[Gramext.Stoken ("", "sig");
- Gramext.Slist0
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (s : 'sig_item) (loc : int * int) -> (s : 'e__3))]);
- Gramext.Stoken ("", "end")],
- Gramext.action
- (fun _ (sg : 'e__3 list) _ (loc : int * int) ->
- (MLast.MtSig (loc, sg) : 'module_type))];
- None, None,
- [[Gramext.Sself; Gramext.Sself],
- Gramext.action
- (fun (m2 : 'module_type) (m1 : 'module_type) (loc : int * int) ->
- (MLast.MtApp (loc, m1, m2) : 'module_type))];
- None, None,
- [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
- Gramext.action
- (fun (m2 : 'module_type) _ (m1 : 'module_type) (loc : int * int) ->
- (MLast.MtAcc (loc, m1, m2) : 'module_type))];
- Some "simple", None,
- [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (mt : 'module_type) _ (loc : int * int) ->
- (mt : 'module_type));
- [Gramext.Stoken ("", "'");
- Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'ident) _ (loc : int * int) ->
- (MLast.MtQuo (loc, i) : 'module_type));
- [Gramext.Stoken ("LIDENT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) ->
- (MLast.MtLid (loc, i) : 'module_type));
- [Gramext.Stoken ("UIDENT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) ->
- (MLast.MtUid (loc, i) : 'module_type))]];
- Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None,
- [Some "top", None,
- [[Gramext.Stoken ("", "value"); Gramext.Stoken ("LIDENT", "");
- Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'ctyp) _ (i : string) _ (loc : int * int) ->
- (MLast.SgVal (loc, i, t) : 'sig_item));
- [Gramext.Stoken ("", "type");
- Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (type_declaration : 'type_declaration Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (tdl : 'type_declaration list) _ (loc : int * int) ->
- (MLast.SgTyp (loc, tdl) : 'sig_item));
- [Gramext.Stoken ("", "open");
- Gramext.Snterm
- (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'mod_ident) _ (loc : int * int) ->
- (MLast.SgOpn (loc, i) : 'sig_item));
- [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "type");
- Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "=");
- Gramext.Snterm
- (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))],
- Gramext.action
- (fun (mt : 'module_type) _ (i : string) _ _ (loc : int * int) ->
- (MLast.SgMty (loc, i, mt) : 'sig_item));
- [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "rec");
- Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (module_rec_declaration :
- 'module_rec_declaration Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (mds : 'module_rec_declaration list) _ _ (loc : int * int) ->
- (MLast.SgRecMod (loc, mds) : 'sig_item));
- [Gramext.Stoken ("", "module"); Gramext.Stoken ("UIDENT", "");
- Gramext.Snterm
- (Grammar.Entry.obj
- (module_declaration : 'module_declaration Grammar.Entry.e))],
- Gramext.action
- (fun (mt : 'module_declaration) (i : string) _ (loc : int * int) ->
- (MLast.SgMod (loc, i, mt) : 'sig_item));
- [Gramext.Stoken ("", "include");
- Gramext.Snterm
- (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))],
- Gramext.action
- (fun (mt : 'module_type) _ (loc : int * int) ->
- (MLast.SgInc (loc, mt) : 'sig_item));
- [Gramext.Stoken ("", "external"); Gramext.Stoken ("LIDENT", "");
- Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Slist1 (Gramext.Stoken ("STRING", ""))],
- Gramext.action
- (fun (pd : string list) _ (t : 'ctyp) _ (i : string) _
- (loc : int * int) ->
- (MLast.SgExt (loc, i, t, pd) : 'sig_item));
- [Gramext.Stoken ("", "exception");
- Gramext.Snterm
- (Grammar.Entry.obj
- (constructor_declaration :
- 'constructor_declaration Grammar.Entry.e))],
- Gramext.action
- (fun (_, c, tl : 'constructor_declaration) _ (loc : int * int) ->
- (MLast.SgExc (loc, c, tl) : 'sig_item));
- [Gramext.Stoken ("", "declare");
- Gramext.Slist0
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (s : 'sig_item) (loc : int * int) -> (s : 'e__4))]);
- Gramext.Stoken ("", "end")],
- Gramext.action
- (fun _ (st : 'e__4 list) _ (loc : int * int) ->
- (MLast.SgDcl (loc, st) : 'sig_item))]];
- Grammar.Entry.obj
- (module_declaration : 'module_declaration Grammar.Entry.e),
- None,
- [None, Some Gramext.RightA,
- [[Gramext.Stoken ("", "("); Gramext.Stoken ("UIDENT", "");
- Gramext.Stoken ("", ":");
- Gramext.Snterm
- (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e));
- Gramext.Stoken ("", ")"); Gramext.Sself],
- Gramext.action
- (fun (mt : 'module_declaration) _ (t : 'module_type) _ (i : string) _
- (loc : int * int) ->
- (MLast.MtFun (loc, i, t, mt) : 'module_declaration));
- [Gramext.Stoken ("", ":");
- Gramext.Snterm
- (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))],
- Gramext.action
- (fun (mt : 'module_type) _ (loc : int * int) ->
- (mt : 'module_declaration))]];
- Grammar.Entry.obj
- (module_rec_declaration : 'module_rec_declaration Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ":");
- Gramext.Snterm
- (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))],
- Gramext.action
- (fun (mt : 'module_type) _ (m : string) (loc : int * int) ->
- (m, mt : 'module_rec_declaration))]];
- Grammar.Entry.obj (with_constr : 'with_constr Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "module");
- Gramext.Snterm
- (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm
- (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))],
- Gramext.action
- (fun (me : 'module_expr) _ (i : 'mod_ident) _ (loc : int * int) ->
- (MLast.WcMod (loc, i, me) : 'with_constr));
- [Gramext.Stoken ("", "type");
- Gramext.Snterm
- (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e));
- Gramext.Slist0
- (Gramext.Snterm
- (Grammar.Entry.obj
- (type_parameter : 'type_parameter Grammar.Entry.e)));
- Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'ctyp) _ (tpl : 'type_parameter list) (i : 'mod_ident) _
- (loc : int * int) ->
- (MLast.WcTyp (loc, i, tpl, t) : 'with_constr))]];
- Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), None,
- [Some "top", Some Gramext.RightA,
- [[Gramext.Stoken ("", "while"); Gramext.Sself; Gramext.Stoken ("", "do");
- Gramext.Stoken ("", "{");
- Gramext.Snterm
- (Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e));
- Gramext.Stoken ("", "}")],
- Gramext.action
- (fun _ (seq : 'sequence) _ _ (e : 'expr) _ (loc : int * int) ->
- (MLast.ExWhi (loc, e, seq) : 'expr));
- [Gramext.Stoken ("", "for"); Gramext.Stoken ("LIDENT", "");
- Gramext.Stoken ("", "="); Gramext.Sself;
- Gramext.Snterm
- (Grammar.Entry.obj
- (direction_flag : 'direction_flag Grammar.Entry.e));
- Gramext.Sself; Gramext.Stoken ("", "do"); Gramext.Stoken ("", "{");
- Gramext.Snterm
- (Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e));
- Gramext.Stoken ("", "}")],
- Gramext.action
- (fun _ (seq : 'sequence) _ _ (e2 : 'expr) (df : 'direction_flag)
- (e1 : 'expr) _ (i : string) _ (loc : int * int) ->
- (MLast.ExFor (loc, i, e1, e2, df, seq) : 'expr));
- [Gramext.Stoken ("", "do"); Gramext.Stoken ("", "{");
- Gramext.Snterm
- (Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e));
- Gramext.Stoken ("", "}")],
- Gramext.action
- (fun _ (seq : 'sequence) _ _ (loc : int * int) ->
- (mksequence loc seq : 'expr));
- [Gramext.Stoken ("", "if"); Gramext.Sself; Gramext.Stoken ("", "then");
- Gramext.Sself; Gramext.Stoken ("", "else"); Gramext.Sself],
- Gramext.action
- (fun (e3 : 'expr) _ (e2 : 'expr) _ (e1 : 'expr) _ (loc : int * int) ->
- (MLast.ExIfe (loc, e1, e2, e3) : 'expr));
- [Gramext.Stoken ("", "try"); Gramext.Sself; Gramext.Stoken ("", "with");
- Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
- Gramext.Stoken ("", "->"); Gramext.Sself],
- Gramext.action
- (fun (e1 : 'expr) _ (p1 : 'ipatt) _ (e : 'expr) _ (loc : int * int) ->
- (MLast.ExTry (loc, e, [p1, None, e1]) : 'expr));
- [Gramext.Stoken ("", "try"); Gramext.Sself; Gramext.Stoken ("", "with");
- Gramext.Stoken ("", "[");
- Gramext.Slist0sep
- (Gramext.Snterm
- (Grammar.Entry.obj (match_case : 'match_case Grammar.Entry.e)),
- Gramext.Stoken ("", "|"));
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (l : 'match_case list) _ _ (e : 'expr) _ (loc : int * int) ->
- (MLast.ExTry (loc, e, l) : 'expr));
- [Gramext.Stoken ("", "match"); Gramext.Sself;
- Gramext.Stoken ("", "with");
- Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
- Gramext.Stoken ("", "->"); Gramext.Sself],
- Gramext.action
- (fun (e1 : 'expr) _ (p1 : 'ipatt) _ (e : 'expr) _ (loc : int * int) ->
- (MLast.ExMat (loc, e, [p1, None, e1]) : 'expr));
- [Gramext.Stoken ("", "match"); Gramext.Sself;
- Gramext.Stoken ("", "with"); Gramext.Stoken ("", "[");
- Gramext.Slist0sep
- (Gramext.Snterm
- (Grammar.Entry.obj (match_case : 'match_case Grammar.Entry.e)),
- Gramext.Stoken ("", "|"));
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (l : 'match_case list) _ _ (e : 'expr) _ (loc : int * int) ->
- (MLast.ExMat (loc, e, l) : 'expr));
- [Gramext.Stoken ("", "fun");
- Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj (fun_def : 'fun_def Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'fun_def) (p : 'ipatt) _ (loc : int * int) ->
- (MLast.ExFun (loc, [p, None, e]) : 'expr));
- [Gramext.Stoken ("", "fun"); Gramext.Stoken ("", "[");
- Gramext.Slist0sep
- (Gramext.Snterm
- (Grammar.Entry.obj (match_case : 'match_case Grammar.Entry.e)),
- Gramext.Stoken ("", "|"));
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (l : 'match_case list) _ _ (loc : int * int) ->
- (MLast.ExFun (loc, l) : 'expr));
- [Gramext.Stoken ("", "let"); Gramext.Stoken ("", "module");
- Gramext.Stoken ("UIDENT", "");
- Gramext.Snterm
- (Grammar.Entry.obj
- (module_binding : 'module_binding Grammar.Entry.e));
- Gramext.Stoken ("", "in"); Gramext.Sself],
- Gramext.action
- (fun (e : 'expr) _ (mb : 'module_binding) (m : string) _ _
- (loc : int * int) ->
- (MLast.ExLmd (loc, m, mb, e) : 'expr));
- [Gramext.Stoken ("", "let"); Gramext.Sopt (Gramext.Stoken ("", "rec"));
- Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e)),
- Gramext.Stoken ("", "and"));
- Gramext.Stoken ("", "in"); Gramext.Sself],
- Gramext.action
- (fun (x : 'expr) _ (l : 'let_binding list) (r : string option) _
- (loc : int * int) ->
- (MLast.ExLet (loc, o2b r, l, x) : 'expr))];
- Some "where", None,
- [[Gramext.Sself; Gramext.Stoken ("", "where");
- Gramext.Sopt (Gramext.Stoken ("", "rec"));
- Gramext.Snterm
- (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e))],
- Gramext.action
- (fun (lb : 'let_binding) (rf : string option) _ (e : 'expr)
- (loc : int * int) ->
- (MLast.ExLet (loc, o2b rf, [lb], e) : 'expr))];
- Some ":=", Some Gramext.NonA,
- [[Gramext.Sself; Gramext.Stoken ("", ":="); Gramext.Sself;
- Gramext.Snterm (Grammar.Entry.obj (dummy : 'dummy Grammar.Entry.e))],
- Gramext.action
- (fun _ (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExAss (loc, e1, e2) : 'expr))];
- Some "||", Some Gramext.RightA,
- [[Gramext.Sself; Gramext.Stoken ("", "||"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "||"), e1), e2) :
- 'expr))];
- Some "&&", Some Gramext.RightA,
- [[Gramext.Sself; Gramext.Stoken ("", "&&"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "&&"), e1), e2) :
- 'expr))];
- Some "<", Some Gramext.LeftA,
- [[Gramext.Sself; Gramext.Stoken ("", "!="); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "!="), e1), e2) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "=="); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "=="), e1), e2) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "<>"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "<>"), e1), e2) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "="); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "="), e1), e2) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", ">="); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, ">="), e1), e2) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "<="); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "<="), e1), e2) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", ">"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, ">"), e1), e2) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "<"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "<"), e1), e2) :
- 'expr))];
- Some "^", Some Gramext.RightA,
- [[Gramext.Sself; Gramext.Stoken ("", "@"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "@"), e1), e2) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "^"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "^"), e1), e2) :
- 'expr))];
- Some "+", Some Gramext.LeftA,
- [[Gramext.Sself; Gramext.Stoken ("", "-."); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "-."), e1), e2) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "+."); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "+."), e1), e2) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "-"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "-"), e1), e2) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "+"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "+"), e1), e2) :
- 'expr))];
- Some "*", Some Gramext.LeftA,
- [[Gramext.Sself; Gramext.Stoken ("", "mod"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "mod"), e1), e2) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "lxor"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "lxor"), e1), e2) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "lor"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "lor"), e1), e2) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "land"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "land"), e1), e2) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "/."); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "/."), e1), e2) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "*."); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "*."), e1), e2) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "/"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "/"), e1), e2) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "*"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "*"), e1), e2) :
- 'expr))];
- Some "**", Some Gramext.RightA,
- [[Gramext.Sself; Gramext.Stoken ("", "lsr"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "lsr"), e1), e2) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "lsl"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "lsl"), e1), e2) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "asr"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "asr"), e1), e2) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "**"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "**"), e1), e2) :
- 'expr))];
- Some "unary minus", Some Gramext.NonA,
- [[Gramext.Stoken ("", "-."); Gramext.Sself],
- Gramext.action
- (fun (e : 'expr) _ (loc : int * int) -> (mkumin loc "-." e : 'expr));
- [Gramext.Stoken ("", "-"); Gramext.Sself],
- Gramext.action
- (fun (e : 'expr) _ (loc : int * int) -> (mkumin loc "-" e : 'expr))];
- Some "apply", Some Gramext.LeftA,
- [[Gramext.Stoken ("", "lazy"); Gramext.Sself],
- Gramext.action
- (fun (e : 'expr) _ (loc : int * int) ->
- (MLast.ExLaz (loc, e) : 'expr));
- [Gramext.Stoken ("", "assert"); Gramext.Sself],
- Gramext.action
- (fun (e : 'expr) _ (loc : int * int) -> (mkassert loc e : 'expr));
- [Gramext.Sself; Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) (e1 : 'expr) (loc : int * int) ->
- (MLast.ExApp (loc, e1, e2) : 'expr))];
- Some ".", Some Gramext.LeftA,
- [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExAcc (loc, e1, e2) : 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Stoken ("", "[");
- Gramext.Sself; Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (e2 : 'expr) _ _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExSte (loc, e1, e2) : 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Stoken ("", "(");
- Gramext.Sself; Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (e2 : 'expr) _ _ (e1 : 'expr) (loc : int * int) ->
- (MLast.ExAre (loc, e1, e2) : 'expr))];
- Some "~-", Some Gramext.NonA,
- [[Gramext.Stoken ("", "~-."); Gramext.Sself],
- Gramext.action
- (fun (e : 'expr) _ (loc : int * int) ->
- (MLast.ExApp (loc, MLast.ExLid (loc, "~-."), e) : 'expr));
- [Gramext.Stoken ("", "~-"); Gramext.Sself],
- Gramext.action
- (fun (e : 'expr) _ (loc : int * int) ->
- (MLast.ExApp (loc, MLast.ExLid (loc, "~-"), e) : 'expr))];
- Some "simple", None,
- [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
- Gramext.action (fun _ (e : 'expr) _ (loc : int * int) -> (e : 'expr));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ",");
- Gramext.Slist1sep
- (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)),
- Gramext.Stoken ("", ","));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (el : 'expr list) _ (e : 'expr) _ (loc : int * int) ->
- (MLast.ExTup (loc, (e :: el)) : 'expr));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (t : 'ctyp) _ (e : 'expr) _ (loc : int * int) ->
- (MLast.ExTyc (loc, e, t) : 'expr));
- [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ _ (loc : int * int) -> (MLast.ExUid (loc, "()") : 'expr));
- [Gramext.Stoken ("", "{"); Gramext.Stoken ("", "("); Gramext.Sself;
- Gramext.Stoken ("", ")"); Gramext.Stoken ("", "with");
- Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj (label_expr : 'label_expr Grammar.Entry.e)),
- Gramext.Stoken ("", ";"));
- Gramext.Stoken ("", "}")],
- Gramext.action
- (fun _ (lel : 'label_expr list) _ _ (e : 'expr) _ _
- (loc : int * int) ->
- (MLast.ExRec (loc, lel, Some e) : 'expr));
- [Gramext.Stoken ("", "{");
- Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj (label_expr : 'label_expr Grammar.Entry.e)),
- Gramext.Stoken ("", ";"));
- Gramext.Stoken ("", "}")],
- Gramext.action
- (fun _ (lel : 'label_expr list) _ (loc : int * int) ->
- (MLast.ExRec (loc, lel, None) : 'expr));
- [Gramext.Stoken ("", "[|");
- Gramext.Slist0sep
- (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)),
- Gramext.Stoken ("", ";"));
- Gramext.Stoken ("", "|]")],
- Gramext.action
- (fun _ (el : 'expr list) _ (loc : int * int) ->
- (MLast.ExArr (loc, el) : 'expr));
- [Gramext.Stoken ("", "[");
- Gramext.Slist1sep
- (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)),
- Gramext.Stoken ("", ";"));
- Gramext.Snterm
- (Grammar.Entry.obj (cons_expr_opt : 'cons_expr_opt Grammar.Entry.e));
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (last : 'cons_expr_opt) (el : 'expr list) _
- (loc : int * int) ->
- (mklistexp loc last el : 'expr));
- [Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ _ (loc : int * int) -> (MLast.ExUid (loc, "[]") : 'expr));
- [Gramext.Snterm
- (Grammar.Entry.obj (expr_ident : 'expr_ident Grammar.Entry.e))],
- Gramext.action (fun (i : 'expr_ident) (loc : int * int) -> (i : 'expr));
- [Gramext.Stoken ("CHAR", "")],
- Gramext.action
- (fun (s : string) (loc : int * int) ->
- (MLast.ExChr (loc, s) : 'expr));
- [Gramext.Stoken ("STRING", "")],
- Gramext.action
- (fun (s : string) (loc : int * int) ->
- (MLast.ExStr (loc, s) : 'expr));
- [Gramext.Stoken ("FLOAT", "")],
- Gramext.action
- (fun (s : string) (loc : int * int) ->
- (MLast.ExFlo (loc, s) : 'expr));
- [Gramext.Stoken ("NATIVEINT", "")],
- Gramext.action
- (fun (s : string) (loc : int * int) ->
- (MLast.ExNativeInt (loc, s) : 'expr));
- [Gramext.Stoken ("INT64", "")],
- Gramext.action
- (fun (s : string) (loc : int * int) ->
- (MLast.ExInt64 (loc, s) : 'expr));
- [Gramext.Stoken ("INT32", "")],
- Gramext.action
- (fun (s : string) (loc : int * int) ->
- (MLast.ExInt32 (loc, s) : 'expr));
- [Gramext.Stoken ("INT", "")],
- Gramext.action
- (fun (s : string) (loc : int * int) ->
- (MLast.ExInt (loc, s) : 'expr))]];
- Grammar.Entry.obj (cons_expr_opt : 'cons_expr_opt Grammar.Entry.e), None,
- [None, None,
- [[], Gramext.action (fun (loc : int * int) -> (None : 'cons_expr_opt));
- [Gramext.Stoken ("", "::");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (loc : int * int) -> (Some e : 'cons_expr_opt))]];
- Grammar.Entry.obj (dummy : 'dummy Grammar.Entry.e), None,
- [None, None,
- [[], Gramext.action (fun (loc : int * int) -> (() : 'dummy))]];
- Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action (fun (e : 'expr) (loc : int * int) -> ([e] : 'sequence));
- [Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (e : 'expr) (loc : int * int) -> ([e] : 'sequence));
- [Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e));
- Gramext.Stoken ("", ";"); Gramext.Sself],
- Gramext.action
- (fun (el : 'sequence) _ (e : 'expr) (loc : int * int) ->
- (e :: el : 'sequence));
- [Gramext.Stoken ("", "let"); Gramext.Sopt (Gramext.Stoken ("", "rec"));
- Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e)),
- Gramext.Stoken ("", "and"));
- Gramext.srules
- [[Gramext.Stoken ("", ";")],
- Gramext.action (fun (x : string) (loc : int * int) -> (x : 'e__5));
- [Gramext.Stoken ("", "in")],
- Gramext.action (fun (x : string) (loc : int * int) -> (x : 'e__5))];
- Gramext.Sself],
- Gramext.action
- (fun (el : 'sequence) _ (l : 'let_binding list) (rf : string option) _
- (loc : int * int) ->
- ([MLast.ExLet (loc, o2b rf, l, mksequence loc el)] : 'sequence))]];
- Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'fun_binding) (p : 'ipatt) (loc : int * int) ->
- (p, e : 'let_binding))]];
- Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e), None,
- [None, Some Gramext.RightA,
- [[Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) ->
- (MLast.ExTyc (loc, e, t) : 'fun_binding));
- [Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (loc : int * int) -> (e : 'fun_binding));
- [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
- Gramext.Sself],
- Gramext.action
- (fun (e : 'fun_binding) (p : 'ipatt) (loc : int * int) ->
- (MLast.ExFun (loc, [p, None, e]) : 'fun_binding))]];
- Grammar.Entry.obj (match_case : 'match_case Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj (as_patt_opt : 'as_patt_opt Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj (when_expr_opt : 'when_expr_opt Grammar.Entry.e));
- Gramext.Stoken ("", "->");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (w : 'when_expr_opt) (aso : 'as_patt_opt)
- (p : 'patt) (loc : int * int) ->
- (mkmatchcase loc p aso w e : 'match_case))]];
- Grammar.Entry.obj (as_patt_opt : 'as_patt_opt Grammar.Entry.e), None,
- [None, None,
- [[], Gramext.action (fun (loc : int * int) -> (None : 'as_patt_opt));
- [Gramext.Stoken ("", "as");
- Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))],
- Gramext.action
- (fun (p : 'patt) _ (loc : int * int) -> (Some p : 'as_patt_opt))]];
- Grammar.Entry.obj (when_expr_opt : 'when_expr_opt Grammar.Entry.e), None,
- [None, None,
- [[], Gramext.action (fun (loc : int * int) -> (None : 'when_expr_opt));
- [Gramext.Stoken ("", "when");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (loc : int * int) -> (Some e : 'when_expr_opt))]];
- Grammar.Entry.obj (label_expr : 'label_expr Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (patt_label_ident : 'patt_label_ident Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'fun_binding) (i : 'patt_label_ident) (loc : int * int) ->
- (i, e : 'label_expr))]];
- Grammar.Entry.obj (expr_ident : 'expr_ident Grammar.Entry.e), None,
- [None, Some Gramext.RightA,
- [[Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ".");
- Gramext.Sself],
- Gramext.action
- (fun (j : 'expr_ident) _ (i : string) (loc : int * int) ->
- (mkexprident loc i j : 'expr_ident));
- [Gramext.Stoken ("UIDENT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) ->
- (MLast.ExUid (loc, i) : 'expr_ident));
- [Gramext.Stoken ("LIDENT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) ->
- (MLast.ExLid (loc, i) : 'expr_ident))]];
- Grammar.Entry.obj (fun_def : 'fun_def Grammar.Entry.e), None,
- [None, Some Gramext.RightA,
- [[Gramext.Stoken ("", "->");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action (fun (e : 'expr) _ (loc : int * int) -> (e : 'fun_def));
- [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
- Gramext.Sself],
- Gramext.action
- (fun (e : 'fun_def) (p : 'ipatt) (loc : int * int) ->
- (MLast.ExFun (loc, [p, None, e]) : 'fun_def))]];
- Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), None,
- [None, Some Gramext.LeftA,
- [[Gramext.Sself; Gramext.Stoken ("", "|"); Gramext.Sself],
- Gramext.action
- (fun (p2 : 'patt) _ (p1 : 'patt) (loc : int * int) ->
- (MLast.PaOrp (loc, p1, p2) : 'patt))];
- None, Some Gramext.NonA,
- [[Gramext.Sself; Gramext.Stoken ("", ".."); Gramext.Sself],
- Gramext.action
- (fun (p2 : 'patt) _ (p1 : 'patt) (loc : int * int) ->
- (MLast.PaRng (loc, p1, p2) : 'patt))];
- None, Some Gramext.LeftA,
- [[Gramext.Sself; Gramext.Sself],
- Gramext.action
- (fun (p2 : 'patt) (p1 : 'patt) (loc : int * int) ->
- (MLast.PaApp (loc, p1, p2) : 'patt))];
- None, Some Gramext.LeftA,
- [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
- Gramext.action
- (fun (p2 : 'patt) _ (p1 : 'patt) (loc : int * int) ->
- (MLast.PaAcc (loc, p1, p2) : 'patt))];
- Some "simple", None,
- [[Gramext.Stoken ("", "_")],
- Gramext.action (fun _ (loc : int * int) -> (MLast.PaAny loc : 'patt));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ",");
- Gramext.Slist1sep
- (Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)),
- Gramext.Stoken ("", ","));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (pl : 'patt list) _ (p : 'patt) _ (loc : int * int) ->
- (MLast.PaTup (loc, (p :: pl)) : 'patt));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "as");
- Gramext.Sself; Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (p2 : 'patt) _ (p : 'patt) _ (loc : int * int) ->
- (MLast.PaAli (loc, p, p2) : 'patt));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (t : 'ctyp) _ (p : 'patt) _ (loc : int * int) ->
- (MLast.PaTyc (loc, p, t) : 'patt));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
- Gramext.action (fun _ (p : 'patt) _ (loc : int * int) -> (p : 'patt));
- [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ _ (loc : int * int) -> (MLast.PaUid (loc, "()") : 'patt));
- [Gramext.Stoken ("", "{");
- Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj (label_patt : 'label_patt Grammar.Entry.e)),
- Gramext.Stoken ("", ";"));
- Gramext.Stoken ("", "}")],
- Gramext.action
- (fun _ (lpl : 'label_patt list) _ (loc : int * int) ->
- (MLast.PaRec (loc, lpl) : 'patt));
- [Gramext.Stoken ("", "[|");
- Gramext.Slist0sep
- (Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)),
- Gramext.Stoken ("", ";"));
- Gramext.Stoken ("", "|]")],
- Gramext.action
- (fun _ (pl : 'patt list) _ (loc : int * int) ->
- (MLast.PaArr (loc, pl) : 'patt));
- [Gramext.Stoken ("", "[");
- Gramext.Slist1sep
- (Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)),
- Gramext.Stoken ("", ";"));
- Gramext.Snterm
- (Grammar.Entry.obj (cons_patt_opt : 'cons_patt_opt Grammar.Entry.e));
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (last : 'cons_patt_opt) (pl : 'patt list) _
- (loc : int * int) ->
- (mklistpat loc last pl : 'patt));
- [Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ _ (loc : int * int) -> (MLast.PaUid (loc, "[]") : 'patt));
- [Gramext.Stoken ("", "-"); Gramext.Stoken ("FLOAT", "")],
- Gramext.action
- (fun (s : string) _ (loc : int * int) ->
- (MLast.PaFlo (loc, neg_string s) : 'patt));
- [Gramext.Stoken ("", "-"); Gramext.Stoken ("NATIVEINT", "")],
- Gramext.action
- (fun (s : string) _ (loc : int * int) ->
- (MLast.PaNativeInt (loc, neg_string s) : 'patt));
- [Gramext.Stoken ("", "-"); Gramext.Stoken ("INT64", "")],
- Gramext.action
- (fun (s : string) _ (loc : int * int) ->
- (MLast.PaInt64 (loc, neg_string s) : 'patt));
- [Gramext.Stoken ("", "-"); Gramext.Stoken ("INT32", "")],
- Gramext.action
- (fun (s : string) _ (loc : int * int) ->
- (MLast.PaInt32 (loc, neg_string s) : 'patt));
- [Gramext.Stoken ("", "-"); Gramext.Stoken ("INT", "")],
- Gramext.action
- (fun (s : string) _ (loc : int * int) ->
- (MLast.PaInt (loc, neg_string s) : 'patt));
- [Gramext.Stoken ("CHAR", "")],
- Gramext.action
- (fun (s : string) (loc : int * int) ->
- (MLast.PaChr (loc, s) : 'patt));
- [Gramext.Stoken ("STRING", "")],
- Gramext.action
- (fun (s : string) (loc : int * int) ->
- (MLast.PaStr (loc, s) : 'patt));
- [Gramext.Stoken ("FLOAT", "")],
- Gramext.action
- (fun (s : string) (loc : int * int) ->
- (MLast.PaFlo (loc, s) : 'patt));
- [Gramext.Stoken ("NATIVEINT", "")],
- Gramext.action
- (fun (s : string) (loc : int * int) ->
- (MLast.PaNativeInt (loc, s) : 'patt));
- [Gramext.Stoken ("INT64", "")],
- Gramext.action
- (fun (s : string) (loc : int * int) ->
- (MLast.PaInt64 (loc, s) : 'patt));
- [Gramext.Stoken ("INT32", "")],
- Gramext.action
- (fun (s : string) (loc : int * int) ->
- (MLast.PaInt32 (loc, s) : 'patt));
- [Gramext.Stoken ("INT", "")],
- Gramext.action
- (fun (s : string) (loc : int * int) ->
- (MLast.PaInt (loc, s) : 'patt));
- [Gramext.Stoken ("UIDENT", "")],
- Gramext.action
- (fun (s : string) (loc : int * int) ->
- (MLast.PaUid (loc, s) : 'patt));
- [Gramext.Stoken ("LIDENT", "")],
- Gramext.action
- (fun (s : string) (loc : int * int) ->
- (MLast.PaLid (loc, s) : 'patt))]];
- Grammar.Entry.obj (cons_patt_opt : 'cons_patt_opt Grammar.Entry.e), None,
- [None, None,
- [[], Gramext.action (fun (loc : int * int) -> (None : 'cons_patt_opt));
- [Gramext.Stoken ("", "::");
- Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))],
- Gramext.action
- (fun (p : 'patt) _ (loc : int * int) -> (Some p : 'cons_patt_opt))]];
- Grammar.Entry.obj (label_patt : 'label_patt Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (patt_label_ident : 'patt_label_ident Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))],
- Gramext.action
- (fun (p : 'patt) _ (i : 'patt_label_ident) (loc : int * int) ->
- (i, p : 'label_patt))]];
- Grammar.Entry.obj (patt_label_ident : 'patt_label_ident Grammar.Entry.e),
- None,
- [None, Some Gramext.LeftA,
- [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
- Gramext.action
- (fun (p2 : 'patt_label_ident) _ (p1 : 'patt_label_ident)
- (loc : int * int) ->
- (MLast.PaAcc (loc, p1, p2) : 'patt_label_ident))];
- Some "simple", Some Gramext.RightA,
- [[Gramext.Stoken ("LIDENT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) ->
- (MLast.PaLid (loc, i) : 'patt_label_ident));
- [Gramext.Stoken ("UIDENT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) ->
- (MLast.PaUid (loc, i) : 'patt_label_ident))]];
- Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "_")],
- Gramext.action (fun _ (loc : int * int) -> (MLast.PaAny loc : 'ipatt));
- [Gramext.Stoken ("LIDENT", "")],
- Gramext.action
- (fun (s : string) (loc : int * int) ->
- (MLast.PaLid (loc, s) : 'ipatt));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ",");
- Gramext.Slist1sep
- (Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)),
- Gramext.Stoken ("", ","));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (pl : 'ipatt list) _ (p : 'ipatt) _ (loc : int * int) ->
- (MLast.PaTup (loc, (p :: pl)) : 'ipatt));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "as");
- Gramext.Sself; Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (p2 : 'ipatt) _ (p : 'ipatt) _ (loc : int * int) ->
- (MLast.PaAli (loc, p, p2) : 'ipatt));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (t : 'ctyp) _ (p : 'ipatt) _ (loc : int * int) ->
- (MLast.PaTyc (loc, p, t) : 'ipatt));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
- Gramext.action (fun _ (p : 'ipatt) _ (loc : int * int) -> (p : 'ipatt));
- [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ _ (loc : int * int) -> (MLast.PaUid (loc, "()") : 'ipatt));
- [Gramext.Stoken ("", "{");
- Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj (label_ipatt : 'label_ipatt Grammar.Entry.e)),
- Gramext.Stoken ("", ";"));
- Gramext.Stoken ("", "}")],
- Gramext.action
- (fun _ (lpl : 'label_ipatt list) _ (loc : int * int) ->
- (MLast.PaRec (loc, lpl) : 'ipatt))]];
- Grammar.Entry.obj (label_ipatt : 'label_ipatt Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (patt_label_ident : 'patt_label_ident Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))],
- Gramext.action
- (fun (p : 'ipatt) _ (i : 'patt_label_ident) (loc : int * int) ->
- (i, p : 'label_ipatt))]];
- Grammar.Entry.obj (type_declaration : 'type_declaration Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (type_patt : 'type_patt Grammar.Entry.e));
- Gramext.Slist0
- (Gramext.Snterm
- (Grammar.Entry.obj
- (type_parameter : 'type_parameter Grammar.Entry.e)));
- Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Slist0
- (Gramext.Snterm
- (Grammar.Entry.obj (constrain : 'constrain Grammar.Entry.e)))],
- Gramext.action
- (fun (cl : 'constrain list) (tk : 'ctyp) _
- (tpl : 'type_parameter list) (n : 'type_patt) (loc : int * int) ->
- (n, tpl, tk, cl : 'type_declaration))]];
- Grammar.Entry.obj (type_patt : 'type_patt Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("LIDENT", "")],
- Gramext.action
- (fun (n : string) (loc : int * int) -> (loc, n : 'type_patt))]];
- Grammar.Entry.obj (constrain : 'constrain Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "constraint");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (loc : int * int) ->
- (t1, t2 : 'constrain))]];
- Grammar.Entry.obj (type_parameter : 'type_parameter Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("", "-"); Gramext.Stoken ("", "'");
- Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'ident) _ _ (loc : int * int) ->
- (i, (false, true) : 'type_parameter));
- [Gramext.Stoken ("", "+"); Gramext.Stoken ("", "'");
- Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'ident) _ _ (loc : int * int) ->
- (i, (true, false) : 'type_parameter));
- [Gramext.Stoken ("", "'");
- Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'ident) _ (loc : int * int) ->
- (i, (false, false) : 'type_parameter))]];
- Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), None,
- [None, Some Gramext.LeftA,
- [[Gramext.Sself; Gramext.Stoken ("", "=="); Gramext.Sself],
- Gramext.action
- (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (loc : int * int) ->
- (MLast.TyMan (loc, t1, t2) : 'ctyp))];
- None, Some Gramext.LeftA,
- [[Gramext.Sself; Gramext.Stoken ("", "as"); Gramext.Sself],
- Gramext.action
- (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (loc : int * int) ->
- (MLast.TyAli (loc, t1, t2) : 'ctyp))];
- None, Some Gramext.LeftA,
- [[Gramext.Stoken ("", "!");
- Gramext.Slist1
- (Gramext.Snterm
- (Grammar.Entry.obj (typevar : 'typevar Grammar.Entry.e)));
- Gramext.Stoken ("", "."); Gramext.Sself],
- Gramext.action
- (fun (t : 'ctyp) _ (pl : 'typevar list) _ (loc : int * int) ->
- (MLast.TyPol (loc, pl, t) : 'ctyp))];
- Some "arrow", Some Gramext.RightA,
- [[Gramext.Sself; Gramext.Stoken ("", "->"); Gramext.Sself],
- Gramext.action
- (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (loc : int * int) ->
- (MLast.TyArr (loc, t1, t2) : 'ctyp))];
- Some "label", Some Gramext.NonA,
- [[Gramext.Stoken ("OPTLABEL", ""); Gramext.Sself],
- Gramext.action
- (fun (t : 'ctyp) (i : string) (loc : int * int) ->
- (MLast.TyOlb (loc, i, t) : 'ctyp));
- [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":");
- Gramext.Sself],
- Gramext.action
- (fun (t : 'ctyp) _ (i : string) (loc : int * int) ->
- (MLast.TyOlb (loc, i, t) : 'ctyp));
- [Gramext.Stoken ("LABEL", ""); Gramext.Sself],
- Gramext.action
- (fun (t : 'ctyp) (i : string) (loc : int * int) ->
- (MLast.TyLab (loc, i, t) : 'ctyp));
- [Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":");
- Gramext.Sself],
- Gramext.action
- (fun (t : 'ctyp) _ (i : string) (loc : int * int) ->
- (MLast.TyLab (loc, i, t) : 'ctyp))];
- None, Some Gramext.LeftA,
- [[Gramext.Sself; Gramext.Sself],
- Gramext.action
- (fun (t2 : 'ctyp) (t1 : 'ctyp) (loc : int * int) ->
- (MLast.TyApp (loc, t1, t2) : 'ctyp))];
- None, Some Gramext.LeftA,
- [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
- Gramext.action
- (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (loc : int * int) ->
- (MLast.TyAcc (loc, t1, t2) : 'ctyp))];
- Some "simple", None,
- [[Gramext.Stoken ("", "{");
- Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (label_declaration : 'label_declaration Grammar.Entry.e)),
- Gramext.Stoken ("", ";"));
- Gramext.Stoken ("", "}")],
- Gramext.action
- (fun _ (ldl : 'label_declaration list) _ (loc : int * int) ->
- (MLast.TyRec (loc, false, ldl) : 'ctyp));
- [Gramext.Stoken ("", "[");
- Gramext.Slist0sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (constructor_declaration :
- 'constructor_declaration Grammar.Entry.e)),
- Gramext.Stoken ("", "|"));
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (cdl : 'constructor_declaration list) _ (loc : int * int) ->
- (MLast.TySum (loc, false, cdl) : 'ctyp));
- [Gramext.Stoken ("", "private"); Gramext.Stoken ("", "{");
- Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (label_declaration : 'label_declaration Grammar.Entry.e)),
- Gramext.Stoken ("", ";"));
- Gramext.Stoken ("", "}")],
- Gramext.action
- (fun _ (ldl : 'label_declaration list) _ _ (loc : int * int) ->
- (MLast.TyRec (loc, true, ldl) : 'ctyp));
- [Gramext.Stoken ("", "private"); Gramext.Stoken ("", "[");
- Gramext.Slist0sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (constructor_declaration :
- 'constructor_declaration Grammar.Entry.e)),
- Gramext.Stoken ("", "|"));
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (cdl : 'constructor_declaration list) _ _ (loc : int * int) ->
- (MLast.TySum (loc, true, cdl) : 'ctyp));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
- Gramext.action (fun _ (t : 'ctyp) _ (loc : int * int) -> (t : 'ctyp));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "*");
- Gramext.Slist1sep
- (Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)),
- Gramext.Stoken ("", "*"));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (tl : 'ctyp list) _ (t : 'ctyp) _ (loc : int * int) ->
- (MLast.TyTup (loc, (t :: tl)) : 'ctyp));
- [Gramext.Stoken ("UIDENT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) ->
- (MLast.TyUid (loc, i) : 'ctyp));
- [Gramext.Stoken ("LIDENT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) ->
- (MLast.TyLid (loc, i) : 'ctyp));
- [Gramext.Stoken ("", "_")],
- Gramext.action (fun _ (loc : int * int) -> (MLast.TyAny loc : 'ctyp));
- [Gramext.Stoken ("", "'");
- Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'ident) _ (loc : int * int) ->
- (MLast.TyQuo (loc, i) : 'ctyp))]];
- Grammar.Entry.obj
- (constructor_declaration : 'constructor_declaration Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("UIDENT", "")],
- Gramext.action
- (fun (ci : string) (loc : int * int) ->
- (loc, ci, [] : 'constructor_declaration));
- [Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "of");
- Gramext.Slist1sep
- (Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (cal : 'ctyp list) _ (ci : string) (loc : int * int) ->
- (loc, ci, cal : 'constructor_declaration))]];
- Grammar.Entry.obj
- (label_declaration : 'label_declaration Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("LIDENT", ""); Gramext.Stoken ("", ":");
- Gramext.Sopt (Gramext.Stoken ("", "mutable"));
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'ctyp) (mf : string option) _ (i : string)
- (loc : int * int) ->
- (loc, i, o2b mf, t : 'label_declaration))]];
- Grammar.Entry.obj (ident : 'ident Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("UIDENT", "")],
- Gramext.action (fun (i : string) (loc : int * int) -> (i : 'ident));
- [Gramext.Stoken ("LIDENT", "")],
- Gramext.action (fun (i : string) (loc : int * int) -> (i : 'ident))]];
- Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e), None,
- [None, Some Gramext.RightA,
- [[Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ".");
- Gramext.Sself],
- Gramext.action
- (fun (j : 'mod_ident) _ (i : string) (loc : int * int) ->
- (i :: j : 'mod_ident));
- [Gramext.Stoken ("LIDENT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) -> ([i] : 'mod_ident));
- [Gramext.Stoken ("UIDENT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) -> ([i] : 'mod_ident))]];
- Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "class"); Gramext.Stoken ("", "type");
- Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (class_type_declaration :
- 'class_type_declaration Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (ctd : 'class_type_declaration list) _ _ (loc : int * int) ->
- (MLast.StClt (loc, ctd) : 'str_item));
- [Gramext.Stoken ("", "class");
- Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (class_declaration : 'class_declaration Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (cd : 'class_declaration list) _ (loc : int * int) ->
- (MLast.StCls (loc, cd) : 'str_item))]];
- Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "class"); Gramext.Stoken ("", "type");
- Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (class_type_declaration :
- 'class_type_declaration Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (ctd : 'class_type_declaration list) _ _ (loc : int * int) ->
- (MLast.SgClt (loc, ctd) : 'sig_item));
- [Gramext.Stoken ("", "class");
- Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (class_description : 'class_description Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (cd : 'class_description list) _ (loc : int * int) ->
- (MLast.SgCls (loc, cd) : 'sig_item))]];
- Grammar.Entry.obj
- (class_declaration : 'class_declaration Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Sopt (Gramext.Stoken ("", "virtual"));
- Gramext.Stoken ("LIDENT", "");
- Gramext.Snterm
- (Grammar.Entry.obj
- (class_type_parameters : 'class_type_parameters Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj
- (class_fun_binding : 'class_fun_binding Grammar.Entry.e))],
- Gramext.action
- (fun (cfb : 'class_fun_binding) (ctp : 'class_type_parameters)
- (i : string) (vf : string option) (loc : int * int) ->
- ({MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
- MLast.ciNam = i; MLast.ciExp = cfb} :
- 'class_declaration))]];
- Grammar.Entry.obj
- (class_fun_binding : 'class_fun_binding Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
- Gramext.Sself],
- Gramext.action
- (fun (cfb : 'class_fun_binding) (p : 'ipatt) (loc : int * int) ->
- (MLast.CeFun (loc, p, cfb) : 'class_fun_binding));
- [Gramext.Stoken ("", ":");
- Gramext.Snterm
- (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm
- (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))],
- Gramext.action
- (fun (ce : 'class_expr) _ (ct : 'class_type) _ (loc : int * int) ->
- (MLast.CeTyc (loc, ce, ct) : 'class_fun_binding));
- [Gramext.Stoken ("", "=");
- Gramext.Snterm
- (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))],
- Gramext.action
- (fun (ce : 'class_expr) _ (loc : int * int) ->
- (ce : 'class_fun_binding))]];
- Grammar.Entry.obj
- (class_type_parameters : 'class_type_parameters Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("", "[");
- Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (type_parameter : 'type_parameter Grammar.Entry.e)),
- Gramext.Stoken ("", ","));
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (tpl : 'type_parameter list) _ (loc : int * int) ->
- (loc, tpl : 'class_type_parameters));
- [],
- Gramext.action
- (fun (loc : int * int) -> (loc, [] : 'class_type_parameters))]];
- Grammar.Entry.obj (class_fun_def : 'class_fun_def Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "->");
- Gramext.Snterm
- (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))],
- Gramext.action
- (fun (ce : 'class_expr) _ (loc : int * int) -> (ce : 'class_fun_def));
- [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
- Gramext.Sself],
- Gramext.action
- (fun (ce : 'class_fun_def) (p : 'ipatt) (loc : int * int) ->
- (MLast.CeFun (loc, p, ce) : 'class_fun_def))]];
- Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e), None,
- [Some "top", None,
- [[Gramext.Stoken ("", "let"); Gramext.Sopt (Gramext.Stoken ("", "rec"));
- Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e)),
- Gramext.Stoken ("", "and"));
- Gramext.Stoken ("", "in"); Gramext.Sself],
- Gramext.action
- (fun (ce : 'class_expr) _ (lb : 'let_binding list)
- (rf : string option) _ (loc : int * int) ->
- (MLast.CeLet (loc, o2b rf, lb, ce) : 'class_expr));
- [Gramext.Stoken ("", "fun");
- Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj
- (class_fun_def : 'class_fun_def Grammar.Entry.e))],
- Gramext.action
- (fun (ce : 'class_fun_def) (p : 'ipatt) _ (loc : int * int) ->
- (MLast.CeFun (loc, p, ce) : 'class_expr))];
- Some "apply", Some Gramext.NonA,
- [[Gramext.Sself;
- Gramext.Snterml
- (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), "label")],
- Gramext.action
- (fun (e : 'expr) (ce : 'class_expr) (loc : int * int) ->
- (MLast.CeApp (loc, ce, e) : 'class_expr))];
- Some "simple", None,
- [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (ce : 'class_expr) _ (loc : int * int) -> (ce : 'class_expr));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":");
- Gramext.Snterm
- (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (ct : 'class_type) _ (ce : 'class_expr) _ (loc : int * int) ->
- (MLast.CeTyc (loc, ce, ct) : 'class_expr));
- [Gramext.Stoken ("", "object");
- Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj
- (class_self_patt : 'class_self_patt Grammar.Entry.e)));
- Gramext.Snterm
- (Grammar.Entry.obj
- (class_structure : 'class_structure Grammar.Entry.e));
- Gramext.Stoken ("", "end")],
- Gramext.action
- (fun _ (cf : 'class_structure) (cspo : 'class_self_patt option) _
- (loc : int * int) ->
- (MLast.CeStr (loc, cspo, cf) : 'class_expr));
- [Gramext.Snterm
- (Grammar.Entry.obj
- (class_longident : 'class_longident Grammar.Entry.e))],
- Gramext.action
- (fun (ci : 'class_longident) (loc : int * int) ->
- (MLast.CeCon (loc, ci, []) : 'class_expr));
- [Gramext.Snterm
- (Grammar.Entry.obj
- (class_longident : 'class_longident Grammar.Entry.e));
- Gramext.Stoken ("", "[");
- Gramext.Slist0sep
- (Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)),
- Gramext.Stoken ("", ","));
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (ctcl : 'ctyp list) _ (ci : 'class_longident)
- (loc : int * int) ->
- (MLast.CeCon (loc, ci, ctcl) : 'class_expr))]];
- Grammar.Entry.obj (class_structure : 'class_structure Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Slist0
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (class_str_item : 'class_str_item Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (cf : 'class_str_item) (loc : int * int) ->
- (cf : 'e__6))])],
- Gramext.action
- (fun (cf : 'e__6 list) (loc : int * int) ->
- (cf : 'class_structure))]];
- Grammar.Entry.obj (class_self_patt : 'class_self_patt Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("", "(");
- Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (t : 'ctyp) _ (p : 'patt) _ (loc : int * int) ->
- (MLast.PaTyc (loc, p, t) : 'class_self_patt));
- [Gramext.Stoken ("", "(");
- Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (p : 'patt) _ (loc : int * int) -> (p : 'class_self_patt))]];
- Grammar.Entry.obj (class_str_item : 'class_str_item Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("", "initializer");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (se : 'expr) _ (loc : int * int) ->
- (MLast.CrIni (loc, se) : 'class_str_item));
- [Gramext.Stoken ("", "type");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (loc : int * int) ->
- (MLast.CrCtr (loc, t1, t2) : 'class_str_item));
- [Gramext.Stoken ("", "method");
- Gramext.Sopt (Gramext.Stoken ("", "private"));
- Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
- Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj (polyt : 'polyt Grammar.Entry.e)));
- Gramext.Snterm
- (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'fun_binding) (topt : 'polyt option) (l : 'label)
- (pf : string option) _ (loc : int * int) ->
- (MLast.CrMth (loc, l, o2b pf, e, topt) : 'class_str_item));
- [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual");
- Gramext.Sopt (Gramext.Stoken ("", "private"));
- Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ _
- (loc : int * int) ->
- (MLast.CrVir (loc, l, o2b pf, t) : 'class_str_item));
- [Gramext.Stoken ("", "value");
- Gramext.Sopt (Gramext.Stoken ("", "mutable"));
- Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj
- (cvalue_binding : 'cvalue_binding Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'cvalue_binding) (lab : 'label) (mf : string option) _
- (loc : int * int) ->
- (MLast.CrVal (loc, lab, o2b mf, e) : 'class_str_item));
- [Gramext.Stoken ("", "inherit");
- Gramext.Snterm
- (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e));
- Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj (as_lident : 'as_lident Grammar.Entry.e)))],
- Gramext.action
- (fun (pb : 'as_lident option) (ce : 'class_expr) _
- (loc : int * int) ->
- (MLast.CrInh (loc, ce, pb) : 'class_str_item));
- [Gramext.Stoken ("", "declare");
- Gramext.Slist0
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (class_str_item : 'class_str_item Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (s : 'class_str_item) (loc : int * int) ->
- (s : 'e__7))]);
- Gramext.Stoken ("", "end")],
- Gramext.action
- (fun _ (st : 'e__7 list) _ (loc : int * int) ->
- (MLast.CrDcl (loc, st) : 'class_str_item))]];
- Grammar.Entry.obj (as_lident : 'as_lident Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "as"); Gramext.Stoken ("LIDENT", "")],
- Gramext.action
- (fun (i : string) _ (loc : int * int) -> (i : 'as_lident))]];
- Grammar.Entry.obj (polyt : 'polyt Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action (fun (t : 'ctyp) _ (loc : int * int) -> (t : 'polyt))]];
- Grammar.Entry.obj (cvalue_binding : 'cvalue_binding Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("", ":>");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) ->
- (MLast.ExCoe (loc, e, None, t) : 'cvalue_binding));
- [Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", ":>");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (t2 : 'ctyp) _ (t : 'ctyp) _ (loc : int * int) ->
- (MLast.ExCoe (loc, e, Some t, t2) : 'cvalue_binding));
- [Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) ->
- (MLast.ExTyc (loc, e, t) : 'cvalue_binding));
- [Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (loc : int * int) -> (e : 'cvalue_binding))]];
- Grammar.Entry.obj (label : 'label Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("LIDENT", "")],
- Gramext.action (fun (i : string) (loc : int * int) -> (i : 'label))]];
- Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "object");
- Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj
- (class_self_type : 'class_self_type Grammar.Entry.e)));
- Gramext.Slist0
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (class_sig_item : 'class_sig_item Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (csf : 'class_sig_item) (loc : int * int) ->
- (csf : 'e__8))]);
- Gramext.Stoken ("", "end")],
- Gramext.action
- (fun _ (csf : 'e__8 list) (cst : 'class_self_type option) _
- (loc : int * int) ->
- (MLast.CtSig (loc, cst, csf) : 'class_type));
- [Gramext.Snterm
- (Grammar.Entry.obj
- (clty_longident : 'clty_longident Grammar.Entry.e))],
- Gramext.action
- (fun (id : 'clty_longident) (loc : int * int) ->
- (MLast.CtCon (loc, id, []) : 'class_type));
- [Gramext.Snterm
- (Grammar.Entry.obj
- (clty_longident : 'clty_longident Grammar.Entry.e));
- Gramext.Stoken ("", "[");
- Gramext.Slist1sep
- (Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)),
- Gramext.Stoken ("", ","));
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (tl : 'ctyp list) _ (id : 'clty_longident) (loc : int * int) ->
- (MLast.CtCon (loc, id, tl) : 'class_type));
- [Gramext.Stoken ("", "[");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", "]"); Gramext.Stoken ("", "->"); Gramext.Sself],
- Gramext.action
- (fun (ct : 'class_type) _ _ (t : 'ctyp) _ (loc : int * int) ->
- (MLast.CtFun (loc, t, ct) : 'class_type))]];
- Grammar.Entry.obj (class_self_type : 'class_self_type Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("", "(");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (t : 'ctyp) _ (loc : int * int) -> (t : 'class_self_type))]];
- Grammar.Entry.obj (class_sig_item : 'class_sig_item Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("", "type");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (loc : int * int) ->
- (MLast.CgCtr (loc, t1, t2) : 'class_sig_item));
- [Gramext.Stoken ("", "method");
- Gramext.Sopt (Gramext.Stoken ("", "private"));
- Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'ctyp) _ (l : 'label) (pf : string option) _
- (loc : int * int) ->
- (MLast.CgMth (loc, l, o2b pf, t) : 'class_sig_item));
- [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual");
- Gramext.Sopt (Gramext.Stoken ("", "private"));
- Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ _
- (loc : int * int) ->
- (MLast.CgVir (loc, l, o2b pf, t) : 'class_sig_item));
- [Gramext.Stoken ("", "value");
- Gramext.Sopt (Gramext.Stoken ("", "mutable"));
- Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'ctyp) _ (l : 'label) (mf : string option) _
- (loc : int * int) ->
- (MLast.CgVal (loc, l, o2b mf, t) : 'class_sig_item));
- [Gramext.Stoken ("", "inherit");
- Gramext.Snterm
- (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))],
- Gramext.action
- (fun (cs : 'class_type) _ (loc : int * int) ->
- (MLast.CgInh (loc, cs) : 'class_sig_item));
- [Gramext.Stoken ("", "declare");
- Gramext.Slist0
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (class_sig_item : 'class_sig_item Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (s : 'class_sig_item) (loc : int * int) ->
- (s : 'e__9))]);
- Gramext.Stoken ("", "end")],
- Gramext.action
- (fun _ (st : 'e__9 list) _ (loc : int * int) ->
- (MLast.CgDcl (loc, st) : 'class_sig_item))]];
- Grammar.Entry.obj
- (class_description : 'class_description Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Sopt (Gramext.Stoken ("", "virtual"));
- Gramext.Stoken ("LIDENT", "");
- Gramext.Snterm
- (Grammar.Entry.obj
- (class_type_parameters : 'class_type_parameters Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm
- (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))],
- Gramext.action
- (fun (ct : 'class_type) _ (ctp : 'class_type_parameters) (n : string)
- (vf : string option) (loc : int * int) ->
- ({MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
- MLast.ciNam = n; MLast.ciExp = ct} :
- 'class_description))]];
- Grammar.Entry.obj
- (class_type_declaration : 'class_type_declaration Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Sopt (Gramext.Stoken ("", "virtual"));
- Gramext.Stoken ("LIDENT", "");
- Gramext.Snterm
- (Grammar.Entry.obj
- (class_type_parameters : 'class_type_parameters Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm
- (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))],
- Gramext.action
- (fun (cs : 'class_type) _ (ctp : 'class_type_parameters) (n : string)
- (vf : string option) (loc : int * int) ->
- ({MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
- MLast.ciNam = n; MLast.ciExp = cs} :
- 'class_type_declaration))]];
- Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
- Some (Gramext.Level "apply"),
- [None, Some Gramext.LeftA,
- [[Gramext.Stoken ("", "new");
- Gramext.Snterm
- (Grammar.Entry.obj
- (class_longident : 'class_longident Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'class_longident) _ (loc : int * int) ->
- (MLast.ExNew (loc, i) : 'expr))]];
- Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
- Some (Gramext.Level "."),
- [None, None,
- [[Gramext.Sself; Gramext.Stoken ("", "#");
- Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e))],
- Gramext.action
- (fun (lab : 'label) _ (e : 'expr) (loc : int * int) ->
- (MLast.ExSnd (loc, e, lab) : 'expr))]];
- Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("", "{<");
- Gramext.Slist0sep
- (Gramext.Snterm
- (Grammar.Entry.obj (field_expr : 'field_expr Grammar.Entry.e)),
- Gramext.Stoken ("", ";"));
- Gramext.Stoken ("", ">}")],
- Gramext.action
- (fun _ (fel : 'field_expr list) _ (loc : int * int) ->
- (MLast.ExOvr (loc, fel) : 'expr));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":>");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (t : 'ctyp) _ (e : 'expr) _ (loc : int * int) ->
- (MLast.ExCoe (loc, e, None, t) : 'expr));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", ":>");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (t2 : 'ctyp) _ (t : 'ctyp) _ (e : 'expr) _ (loc : int * int) ->
- (MLast.ExCoe (loc, e, Some t, t2) : 'expr))]];
- Grammar.Entry.obj (field_expr : 'field_expr Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (l : 'label) (loc : int * int) ->
- (l, e : 'field_expr))]];
- Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("", "<");
- Gramext.Slist0sep
- (Gramext.Snterm (Grammar.Entry.obj (field : 'field Grammar.Entry.e)),
- Gramext.Stoken ("", ";"));
- Gramext.Sopt (Gramext.Stoken ("", "..")); Gramext.Stoken ("", ">")],
- Gramext.action
- (fun _ (v : string option) (ml : 'field list) _ (loc : int * int) ->
- (MLast.TyObj (loc, ml, o2b v) : 'ctyp));
- [Gramext.Stoken ("", "#");
- Gramext.Snterm
- (Grammar.Entry.obj
- (class_longident : 'class_longident Grammar.Entry.e))],
- Gramext.action
- (fun (id : 'class_longident) _ (loc : int * int) ->
- (MLast.TyCls (loc, id) : 'ctyp))]];
- Grammar.Entry.obj (field : 'field Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("LIDENT", ""); Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'ctyp) _ (lab : string) (loc : int * int) ->
- (lab, t : 'field))]];
- Grammar.Entry.obj (typevar : 'typevar Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "'");
- Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'ident) _ (loc : int * int) -> (i : 'typevar))]];
- Grammar.Entry.obj (clty_longident : 'clty_longident Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("LIDENT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) -> ([i] : 'clty_longident));
- [Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ".");
- Gramext.Sself],
- Gramext.action
- (fun (l : 'clty_longident) _ (m : string) (loc : int * int) ->
- (m :: l : 'clty_longident))]];
- Grammar.Entry.obj (class_longident : 'class_longident Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("LIDENT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) -> ([i] : 'class_longident));
- [Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ".");
- Gramext.Sself],
- Gramext.action
- (fun (l : 'class_longident) _ (m : string) (loc : int * int) ->
- (m :: l : 'class_longident))]];
- Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("", "["); Gramext.Stoken ("", "<");
- Gramext.Snterm
- (Grammar.Entry.obj
- (row_field_list : 'row_field_list Grammar.Entry.e));
- Gramext.Stoken ("", ">");
- Gramext.Slist1
- (Gramext.Snterm
- (Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e)));
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (ntl : 'name_tag list) _ (rfl : 'row_field_list) _ _
- (loc : int * int) ->
- (MLast.TyVrn (loc, rfl, Some (Some ntl)) : 'ctyp));
- [Gramext.Stoken ("", "["); Gramext.Stoken ("", "<");
- Gramext.Snterm
- (Grammar.Entry.obj
- (row_field_list : 'row_field_list Grammar.Entry.e));
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) ->
- (MLast.TyVrn (loc, rfl, Some (Some [])) : 'ctyp));
- [Gramext.Stoken ("", "["); Gramext.Stoken ("", ">");
- Gramext.Snterm
- (Grammar.Entry.obj
- (row_field_list : 'row_field_list Grammar.Entry.e));
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) ->
- (MLast.TyVrn (loc, rfl, Some None) : 'ctyp));
- [Gramext.Stoken ("", "["); Gramext.Stoken ("", "=");
- Gramext.Snterm
- (Grammar.Entry.obj
- (row_field_list : 'row_field_list Grammar.Entry.e));
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) ->
- (MLast.TyVrn (loc, rfl, None) : 'ctyp))]];
- Grammar.Entry.obj (row_field_list : 'row_field_list Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Slist0sep
- (Gramext.Snterm
- (Grammar.Entry.obj (row_field : 'row_field Grammar.Entry.e)),
- Gramext.Stoken ("", "|"))],
- Gramext.action
- (fun (rfl : 'row_field list) (loc : int * int) ->
- (rfl : 'row_field_list))]];
- Grammar.Entry.obj (row_field : 'row_field Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'ctyp) (loc : int * int) -> (MLast.RfInh t : 'row_field));
- [Gramext.Stoken ("", "`");
- Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e));
- Gramext.Stoken ("", "of"); Gramext.Sopt (Gramext.Stoken ("", "&"));
- Gramext.Slist1sep
- (Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)),
- Gramext.Stoken ("", "&"))],
- Gramext.action
- (fun (l : 'ctyp list) (ao : string option) _ (i : 'ident) _
- (loc : int * int) ->
- (MLast.RfTag (i, o2b ao, l) : 'row_field));
- [Gramext.Stoken ("", "`");
- Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'ident) _ (loc : int * int) ->
- (MLast.RfTag (i, true, []) : 'row_field))]];
- Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "`");
- Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'ident) _ (loc : int * int) -> (i : 'name_tag))]];
- Grammar.Entry.obj (patt : 'patt Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("", "?"); Gramext.Stoken ("", "(");
- Gramext.Snterm
- (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e));
- Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (eo : 'eq_expr option) (p : 'patt_tcon) _ _
- (loc : int * int) ->
- (MLast.PaOlb (loc, "", Some (p, eo)) : 'patt));
- [Gramext.Stoken ("QUESTIONIDENT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) ->
- (MLast.PaOlb (loc, i, None) : 'patt));
- [Gramext.Stoken ("OPTLABEL", ""); Gramext.Stoken ("", "(");
- Gramext.Snterm
- (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e));
- Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (eo : 'eq_expr option) (p : 'patt_tcon) _ (i : string)
- (loc : int * int) ->
- (MLast.PaOlb (loc, i, Some (p, eo)) : 'patt));
- [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":");
- Gramext.Stoken ("", "(");
- Gramext.Snterm
- (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e));
- Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (eo : 'eq_expr option) (p : 'patt_tcon) _ _ (i : string)
- (loc : int * int) ->
- (MLast.PaOlb (loc, i, Some (p, eo)) : 'patt));
- [Gramext.Stoken ("TILDEIDENT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) ->
- (MLast.PaLab (loc, i, None) : 'patt));
- [Gramext.Stoken ("LABEL", ""); Gramext.Sself],
- Gramext.action
- (fun (p : 'patt) (i : string) (loc : int * int) ->
- (MLast.PaLab (loc, i, Some p) : 'patt));
- [Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":");
- Gramext.Sself],
- Gramext.action
- (fun (p : 'patt) _ (i : string) (loc : int * int) ->
- (MLast.PaLab (loc, i, Some p) : 'patt));
- [Gramext.Stoken ("", "#");
- Gramext.Snterm
- (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))],
- Gramext.action
- (fun (sl : 'mod_ident) _ (loc : int * int) ->
- (MLast.PaTyp (loc, sl) : 'patt));
- [Gramext.Stoken ("", "`");
- Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
- Gramext.action
- (fun (s : 'ident) _ (loc : int * int) ->
- (MLast.PaVrn (loc, s) : 'patt))]];
- Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))],
- Gramext.action (fun (p : 'patt) (loc : int * int) -> (p : 'patt_tcon));
- [Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'ctyp) _ (p : 'patt) (loc : int * int) ->
- (MLast.PaTyc (loc, p, t) : 'patt_tcon))]];
- Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "?"); Gramext.Stoken ("", "(");
- Gramext.Snterm
- (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e));
- Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (eo : 'eq_expr option) (p : 'ipatt_tcon) _ _
- (loc : int * int) ->
- (MLast.PaOlb (loc, "", Some (p, eo)) : 'ipatt));
- [Gramext.Stoken ("QUESTIONIDENT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) ->
- (MLast.PaOlb (loc, i, None) : 'ipatt));
- [Gramext.Stoken ("OPTLABEL", ""); Gramext.Stoken ("", "(");
- Gramext.Snterm
- (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e));
- Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (eo : 'eq_expr option) (p : 'ipatt_tcon) _ (i : string)
- (loc : int * int) ->
- (MLast.PaOlb (loc, i, Some (p, eo)) : 'ipatt));
- [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":");
- Gramext.Stoken ("", "(");
- Gramext.Snterm
- (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e));
- Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (eo : 'eq_expr option) (p : 'ipatt_tcon) _ _ (i : string)
- (loc : int * int) ->
- (MLast.PaOlb (loc, i, Some (p, eo)) : 'ipatt));
- [Gramext.Stoken ("TILDEIDENT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) ->
- (MLast.PaLab (loc, i, None) : 'ipatt));
- [Gramext.Stoken ("LABEL", ""); Gramext.Sself],
- Gramext.action
- (fun (p : 'ipatt) (i : string) (loc : int * int) ->
- (MLast.PaLab (loc, i, Some p) : 'ipatt));
- [Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":");
- Gramext.Sself],
- Gramext.action
- (fun (p : 'ipatt) _ (i : string) (loc : int * int) ->
- (MLast.PaLab (loc, i, Some p) : 'ipatt))]];
- Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))],
- Gramext.action
- (fun (p : 'ipatt) (loc : int * int) -> (p : 'ipatt_tcon));
- [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'ctyp) _ (p : 'ipatt) (loc : int * int) ->
- (MLast.PaTyc (loc, p, t) : 'ipatt_tcon))]];
- Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (loc : int * int) -> (e : 'eq_expr))]];
- Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
- Some (Gramext.After "apply"),
- [Some "label", Some Gramext.NonA,
- [[Gramext.Stoken ("QUESTIONIDENT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) ->
- (MLast.ExOlb (loc, i, None) : 'expr));
- [Gramext.Stoken ("OPTLABEL", ""); Gramext.Sself],
- Gramext.action
- (fun (e : 'expr) (i : string) (loc : int * int) ->
- (MLast.ExOlb (loc, i, Some e) : 'expr));
- [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":");
- Gramext.Sself],
- Gramext.action
- (fun (e : 'expr) _ (i : string) (loc : int * int) ->
- (MLast.ExOlb (loc, i, Some e) : 'expr));
- [Gramext.Stoken ("TILDEIDENT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) ->
- (MLast.ExLab (loc, i, None) : 'expr));
- [Gramext.Stoken ("LABEL", ""); Gramext.Sself],
- Gramext.action
- (fun (e : 'expr) (i : string) (loc : int * int) ->
- (MLast.ExLab (loc, i, Some e) : 'expr));
- [Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":");
- Gramext.Sself],
- Gramext.action
- (fun (e : 'expr) _ (i : string) (loc : int * int) ->
- (MLast.ExLab (loc, i, Some e) : 'expr))]];
- Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("", "`");
- Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
- Gramext.action
- (fun (s : 'ident) _ (loc : int * int) ->
- (MLast.ExVrn (loc, s) : 'expr))]];
- Grammar.Entry.obj (direction_flag : 'direction_flag Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("", "downto")],
- Gramext.action (fun _ (loc : int * int) -> (false : 'direction_flag));
- [Gramext.Stoken ("", "to")],
- Gramext.action (fun _ (loc : int * int) -> (true : 'direction_flag))]];
- Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("", "[|");
- Gramext.Snterm
- (Grammar.Entry.obj
- (warning_variant : 'warning_variant Grammar.Entry.e));
- Gramext.Stoken ("", "<");
- Gramext.Snterm
- (Grammar.Entry.obj
- (row_field_list : 'row_field_list Grammar.Entry.e));
- Gramext.Stoken ("", ">");
- Gramext.Slist1
- (Gramext.Snterm
- (Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e)));
- Gramext.Stoken ("", "|]")],
- Gramext.action
- (fun _ (ntl : 'name_tag list) _ (rfl : 'row_field_list) _ _ _
- (loc : int * int) ->
- (MLast.TyVrn (loc, rfl, Some (Some ntl)) : 'ctyp));
- [Gramext.Stoken ("", "[|");
- Gramext.Snterm
- (Grammar.Entry.obj
- (warning_variant : 'warning_variant Grammar.Entry.e));
- Gramext.Stoken ("", "<");
- Gramext.Snterm
- (Grammar.Entry.obj
- (row_field_list : 'row_field_list Grammar.Entry.e));
- Gramext.Stoken ("", "|]")],
- Gramext.action
- (fun _ (rfl : 'row_field_list) _ _ _ (loc : int * int) ->
- (MLast.TyVrn (loc, rfl, Some (Some [])) : 'ctyp));
- [Gramext.Stoken ("", "[|");
- Gramext.Snterm
- (Grammar.Entry.obj
- (warning_variant : 'warning_variant Grammar.Entry.e));
- Gramext.Stoken ("", ">");
- Gramext.Snterm
- (Grammar.Entry.obj
- (row_field_list : 'row_field_list Grammar.Entry.e));
- Gramext.Stoken ("", "|]")],
- Gramext.action
- (fun _ (rfl : 'row_field_list) _ _ _ (loc : int * int) ->
- (MLast.TyVrn (loc, rfl, Some None) : 'ctyp));
- [Gramext.Stoken ("", "[|");
- Gramext.Snterm
- (Grammar.Entry.obj
- (warning_variant : 'warning_variant Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj
- (row_field_list : 'row_field_list Grammar.Entry.e));
- Gramext.Stoken ("", "|]")],
- Gramext.action
- (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) ->
- (MLast.TyVrn (loc, rfl, None) : 'ctyp))]];
- Grammar.Entry.obj (warning_variant : 'warning_variant Grammar.Entry.e),
- None,
- [None, None,
- [[],
- Gramext.action
- (fun (loc : int * int) -> (warn_variant loc : 'warning_variant))]];
- Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
- Some (Gramext.Level "top"),
- [None, None,
- [[Gramext.Stoken ("", "while"); Gramext.Sself; Gramext.Stoken ("", "do");
- Gramext.Slist0
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__12))]);
- Gramext.Snterm
- (Grammar.Entry.obj
- (warning_sequence : 'warning_sequence Grammar.Entry.e));
- Gramext.Stoken ("", "done")],
- Gramext.action
- (fun _ _ (seq : 'e__12 list) _ (e : 'expr) _ (loc : int * int) ->
- (MLast.ExWhi (loc, e, seq) : 'expr));
- [Gramext.Stoken ("", "for"); Gramext.Stoken ("LIDENT", "");
- Gramext.Stoken ("", "="); Gramext.Sself;
- Gramext.Snterm
- (Grammar.Entry.obj
- (direction_flag : 'direction_flag Grammar.Entry.e));
- Gramext.Sself; Gramext.Stoken ("", "do");
- Gramext.Slist0
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__11))]);
- Gramext.Snterm
- (Grammar.Entry.obj
- (warning_sequence : 'warning_sequence Grammar.Entry.e));
- Gramext.Stoken ("", "done")],
- Gramext.action
- (fun _ _ (seq : 'e__11 list) _ (e2 : 'expr) (df : 'direction_flag)
- (e1 : 'expr) _ (i : string) _ (loc : int * int) ->
- (MLast.ExFor (loc, i, e1, e2, df, seq) : 'expr));
- [Gramext.Stoken ("", "do");
- Gramext.Slist0
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__10))]);
- Gramext.Stoken ("", "return");
- Gramext.Snterm
- (Grammar.Entry.obj
- (warning_sequence : 'warning_sequence Grammar.Entry.e));
- Gramext.Sself],
- Gramext.action
- (fun (e : 'expr) _ _ (seq : 'e__10 list) _ (loc : int * int) ->
- (MLast.ExSeq (loc, append_elem seq e) : 'expr))]];
- Grammar.Entry.obj (warning_sequence : 'warning_sequence Grammar.Entry.e),
- None,
- [None, None,
- [[],
- Gramext.action
- (fun (loc : int * int) ->
- (warn_sequence loc : 'warning_sequence))]]]);;
-
-Grammar.extend
- (let _ = (interf : 'interf Grammar.Entry.e)
- and _ = (implem : 'implem Grammar.Entry.e)
- and _ = (use_file : 'use_file Grammar.Entry.e)
- and _ = (top_phrase : 'top_phrase Grammar.Entry.e)
- and _ = (expr : 'expr Grammar.Entry.e)
- and _ = (patt : 'patt Grammar.Entry.e) in
- let grammar_entry_create s =
- Grammar.Entry.create (Grammar.of_entry interf) s
- in
- let sig_item_semi : 'sig_item_semi Grammar.Entry.e =
- grammar_entry_create "sig_item_semi"
- and str_item_semi : 'str_item_semi Grammar.Entry.e =
- grammar_entry_create "str_item_semi"
- and phrase : 'phrase Grammar.Entry.e = grammar_entry_create "phrase" in
- [Grammar.Entry.obj (interf : 'interf Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("EOI", "")],
- Gramext.action (fun _ (loc : int * int) -> ([], false : 'interf));
- [Gramext.Snterm
- (Grammar.Entry.obj (sig_item_semi : 'sig_item_semi Grammar.Entry.e));
- Gramext.Sself],
- Gramext.action
- (fun (sil, stopped : 'interf) (si : 'sig_item_semi)
- (loc : int * int) ->
- (si :: sil, stopped : 'interf));
- [Gramext.Stoken ("", "#"); Gramext.Stoken ("LIDENT", "");
- Gramext.Sopt
- (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (dp : 'expr option) (n : string) _ (loc : int * int) ->
- ([MLast.SgDir (loc, n, dp), loc], true : 'interf))]];
- Grammar.Entry.obj (sig_item_semi : 'sig_item_semi Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (si : 'sig_item) (loc : int * int) ->
- (si, loc : 'sig_item_semi))]];
- Grammar.Entry.obj (implem : 'implem Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("EOI", "")],
- Gramext.action (fun _ (loc : int * int) -> ([], false : 'implem));
- [Gramext.Snterm
- (Grammar.Entry.obj (str_item_semi : 'str_item_semi Grammar.Entry.e));
- Gramext.Sself],
- Gramext.action
- (fun (sil, stopped : 'implem) (si : 'str_item_semi)
- (loc : int * int) ->
- (si :: sil, stopped : 'implem));
- [Gramext.Stoken ("", "#"); Gramext.Stoken ("LIDENT", "");
- Gramext.Sopt
- (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (dp : 'expr option) (n : string) _ (loc : int * int) ->
- ([MLast.StDir (loc, n, dp), loc], true : 'implem))]];
- Grammar.Entry.obj (str_item_semi : 'str_item_semi Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (si : 'str_item) (loc : int * int) ->
- (si, loc : 'str_item_semi))]];
- Grammar.Entry.obj (top_phrase : 'top_phrase Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("EOI", "")],
- Gramext.action (fun _ (loc : int * int) -> (None : 'top_phrase));
- [Gramext.Snterm (Grammar.Entry.obj (phrase : 'phrase Grammar.Entry.e))],
- Gramext.action
- (fun (ph : 'phrase) (loc : int * int) -> (Some ph : 'top_phrase))]];
- Grammar.Entry.obj (use_file : 'use_file Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("EOI", "")],
- Gramext.action (fun _ (loc : int * int) -> ([], false : 'use_file));
- [Gramext.Snterm
- (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e));
- Gramext.Stoken ("", ";"); Gramext.Sself],
- Gramext.action
- (fun (sil, stopped : 'use_file) _ (si : 'str_item)
- (loc : int * int) ->
- (si :: sil, stopped : 'use_file));
- [Gramext.Stoken ("", "#"); Gramext.Stoken ("LIDENT", "");
- Gramext.Sopt
- (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (dp : 'expr option) (n : string) _ (loc : int * int) ->
- ([MLast.StDir (loc, n, dp)], true : 'use_file))]];
- Grammar.Entry.obj (phrase : 'phrase Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (sti : 'str_item) (loc : int * int) -> (sti : 'phrase));
- [Gramext.Stoken ("", "#"); Gramext.Stoken ("LIDENT", "");
- Gramext.Sopt
- (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (dp : 'expr option) (n : string) _ (loc : int * int) ->
- (MLast.StDir (loc, n, dp) : 'phrase))]];
- Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("QUOTATION", "")],
- Gramext.action
- (fun (x : string) (loc : int * int) ->
- (let x =
- try
- let i = String.index x ':' in
- String.sub x 0 i,
- String.sub x (i + 1) (String.length x - i - 1)
- with
- Not_found -> "", x
- in
- Pcaml.handle_expr_quotation loc x :
- 'expr));
- [Gramext.Stoken ("LOCATE", "")],
- Gramext.action
- (fun (x : string) (loc : int * int) ->
- (let x =
- try
- let i = String.index x ':' in
- int_of_string (String.sub x 0 i),
- String.sub x (i + 1) (String.length x - i - 1)
- with
- Not_found | Failure _ -> 0, x
- in
- Pcaml.handle_expr_locate loc x :
- 'expr))]];
- Grammar.Entry.obj (patt : 'patt Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("QUOTATION", "")],
- Gramext.action
- (fun (x : string) (loc : int * int) ->
- (let x =
- try
- let i = String.index x ':' in
- String.sub x 0 i,
- String.sub x (i + 1) (String.length x - i - 1)
- with
- Not_found -> "", x
- in
- Pcaml.handle_patt_quotation loc x :
- 'patt));
- [Gramext.Stoken ("LOCATE", "")],
- Gramext.action
- (fun (x : string) (loc : int * int) ->
- (let x =
- try
- let i = String.index x ':' in
- int_of_string (String.sub x 0 i),
- String.sub x (i + 1) (String.length x - i - 1)
- with
- Not_found | Failure _ -> 0, x
- in
- Pcaml.handle_patt_locate loc x :
- 'patt))]]]);;
diff --git a/camlp4/ocaml_src/meta/pa_rp.ml b/camlp4/ocaml_src/meta/pa_rp.ml
deleted file mode 100644
index ad743e8708..0000000000
--- a/camlp4/ocaml_src/meta/pa_rp.ml
+++ /dev/null
@@ -1,641 +0,0 @@
-(* camlp4r pa_extend.cmo q_MLast.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1998 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-open Pcaml;;
-
-type spat_comp =
- SpTrm of MLast.loc * MLast.patt * MLast.expr option
- | SpNtr of MLast.loc * MLast.patt * MLast.expr
- | SpStr of MLast.loc * MLast.patt
-;;
-type sexp_comp =
- SeTrm of MLast.loc * MLast.expr
- | SeNtr of MLast.loc * MLast.expr
-;;
-
-let strm_n = "strm__";;
-let peek_fun loc =
- MLast.ExAcc (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "peek"))
-;;
-let junk_fun loc =
- MLast.ExAcc (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "junk"))
-;;
-
-(* Parsers. *)
-(* In syntax generated, many cases are optimisations. *)
-
-let rec pattern_eq_expression p e =
- match p, e with
- MLast.PaLid (_, a), MLast.ExLid (_, b) -> a = b
- | MLast.PaUid (_, a), MLast.ExUid (_, b) -> a = b
- | MLast.PaApp (_, p1, p2), MLast.ExApp (_, e1, e2) ->
- pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2
- | _ -> false
-;;
-
-let is_raise e =
- match e with
- MLast.ExApp (_, MLast.ExLid (_, "raise"), _) -> true
- | _ -> false
-;;
-
-let is_raise_failure e =
- match e with
- MLast.ExApp
- (_, MLast.ExLid (_, "raise"),
- MLast.ExAcc
- (_, MLast.ExUid (_, "Stream"), MLast.ExUid (_, "Failure"))) ->
- true
- | _ -> false
-;;
-
-let rec handle_failure e =
- match e with
- MLast.ExTry
- (_, te,
- [MLast.PaAcc
- (_, MLast.PaUid (_, "Stream"), MLast.PaUid (_, "Failure")), None,
- e]) ->
- handle_failure e
- | MLast.ExMat (_, me, pel) ->
- handle_failure me &&
- List.for_all
- (function
- _, None, e -> handle_failure e
- | _ -> false)
- pel
- | MLast.ExLet (_, false, pel, e) ->
- List.for_all (fun (p, e) -> handle_failure e) pel && handle_failure e
- | MLast.ExLid (_, _) | MLast.ExInt (_, _) | MLast.ExStr (_, _) |
- MLast.ExChr (_, _) | MLast.ExFun (_, _) | MLast.ExUid (_, _) ->
- true
- | MLast.ExApp (_, MLast.ExLid (_, "raise"), e) ->
- begin match e with
- MLast.ExAcc
- (_, MLast.ExUid (_, "Stream"), MLast.ExUid (_, "Failure")) ->
- false
- | _ -> true
- end
- | MLast.ExApp (_, f, x) ->
- is_constr_apply f && handle_failure f && handle_failure x
- | _ -> false
-and is_constr_apply =
- function
- MLast.ExUid (_, _) -> true
- | MLast.ExLid (_, _) -> false
- | MLast.ExApp (_, x, _) -> is_constr_apply x
- | _ -> false
-;;
-
-let rec subst v e =
- let loc = MLast.loc_of_expr e in
- match e with
- MLast.ExLid (_, x) ->
- let x = if x = v then strm_n else x in MLast.ExLid (loc, x)
- | MLast.ExUid (_, _) -> e
- | MLast.ExInt (_, _) -> e
- | MLast.ExChr (_, _) -> e
- | MLast.ExStr (_, _) -> e
- | MLast.ExAcc (_, _, _) -> e
- | MLast.ExLet (_, rf, pel, e) ->
- MLast.ExLet (loc, rf, List.map (subst_pe v) pel, subst v e)
- | MLast.ExApp (_, e1, e2) -> MLast.ExApp (loc, subst v e1, subst v e2)
- | MLast.ExTup (_, el) -> MLast.ExTup (loc, List.map (subst v) el)
- | _ -> raise Not_found
-and subst_pe v (p, e) =
- match p with
- MLast.PaLid (_, v') when v <> v' -> p, subst v e
- | _ -> raise Not_found
-;;
-
-let stream_pattern_component skont ckont =
- function
- SpTrm (loc, p, wo) ->
- MLast.ExMat
- (loc, MLast.ExApp (loc, peek_fun loc, MLast.ExLid (loc, strm_n)),
- [MLast.PaApp (loc, MLast.PaUid (loc, "Some"), p), wo,
- MLast.ExSeq
- (loc,
- [MLast.ExApp (loc, junk_fun loc, MLast.ExLid (loc, strm_n));
- skont]);
- MLast.PaAny loc, None, ckont])
- | SpNtr (loc, p, e) ->
- let e =
- match e with
- MLast.ExFun
- (_,
- [MLast.PaTyc
- (_, MLast.PaLid (_, v),
- MLast.TyApp
- (_,
- MLast.TyAcc
- (_, MLast.TyUid (_, "Stream"), MLast.TyLid (_, "t")),
- MLast.TyAny _)), None, e])
- when v = strm_n ->
- e
- | _ -> MLast.ExApp (loc, e, MLast.ExLid (loc, strm_n))
- in
- if pattern_eq_expression p skont then
- if is_raise_failure ckont then e
- else if handle_failure e then e
- else
- MLast.ExTry
- (loc, e,
- [MLast.PaAcc
- (loc, MLast.PaUid (loc, "Stream"),
- MLast.PaUid (loc, "Failure")),
- None, ckont])
- else if is_raise_failure ckont then
- MLast.ExLet (loc, false, [p, e], skont)
- else if
- pattern_eq_expression
- (MLast.PaApp (loc, MLast.PaUid (loc, "Some"), p)) skont
- then
- MLast.ExTry
- (loc, MLast.ExApp (loc, MLast.ExUid (loc, "Some"), e),
- [MLast.PaAcc
- (loc, MLast.PaUid (loc, "Stream"),
- MLast.PaUid (loc, "Failure")),
- None, ckont])
- else if is_raise ckont then
- let tst =
- if handle_failure e then e
- else
- MLast.ExTry
- (loc, e,
- [MLast.PaAcc
- (loc, MLast.PaUid (loc, "Stream"),
- MLast.PaUid (loc, "Failure")),
- None, ckont])
- in
- MLast.ExLet (loc, false, [p, tst], skont)
- else
- MLast.ExMat
- (loc,
- MLast.ExTry
- (loc, MLast.ExApp (loc, MLast.ExUid (loc, "Some"), e),
- [MLast.PaAcc
- (loc, MLast.PaUid (loc, "Stream"),
- MLast.PaUid (loc, "Failure")),
- None, MLast.ExUid (loc, "None")]),
- [MLast.PaApp (loc, MLast.PaUid (loc, "Some"), p), None, skont;
- MLast.PaAny loc, None, ckont])
- | SpStr (loc, p) ->
- try
- match p with
- MLast.PaLid (_, v) -> subst v skont
- | _ -> raise Not_found
- with
- Not_found ->
- MLast.ExLet (loc, false, [p, MLast.ExLid (loc, strm_n)], skont)
-;;
-
-let rec stream_pattern loc epo e ekont =
- function
- [] ->
- begin match epo with
- Some ep ->
- MLast.ExLet
- (loc, false,
- [ep,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"),
- MLast.ExLid (loc, "count")),
- MLast.ExLid (loc, strm_n))],
- e)
- | _ -> e
- end
- | (spc, err) :: spcl ->
- let skont =
- let ekont err =
- let str =
- match err with
- Some estr -> estr
- | _ -> MLast.ExStr (loc, "")
- in
- MLast.ExApp
- (loc, MLast.ExLid (loc, "raise"),
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"),
- MLast.ExUid (loc, "Error")),
- str))
- in
- stream_pattern loc epo e ekont spcl
- in
- let ckont = ekont err in stream_pattern_component skont ckont spc
-;;
-
-let stream_patterns_term loc ekont tspel =
- let pel =
- List.map
- (fun (p, w, loc, spcl, epo, e) ->
- let p = MLast.PaApp (loc, MLast.PaUid (loc, "Some"), p) in
- let e =
- let ekont err =
- let str =
- match err with
- Some estr -> estr
- | _ -> MLast.ExStr (loc, "")
- in
- MLast.ExApp
- (loc, MLast.ExLid (loc, "raise"),
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"),
- MLast.ExUid (loc, "Error")),
- str))
- in
- let skont = stream_pattern loc epo e ekont spcl in
- MLast.ExSeq
- (loc,
- [MLast.ExApp (loc, junk_fun loc, MLast.ExLid (loc, strm_n));
- skont])
- in
- p, w, e)
- tspel
- in
- let pel = pel @ [MLast.PaAny loc, None, ekont ()] in
- MLast.ExMat
- (loc, MLast.ExApp (loc, peek_fun loc, MLast.ExLid (loc, strm_n)), pel)
-;;
-
-let rec group_terms =
- function
- ((SpTrm (loc, p, w), None) :: spcl, epo, e) :: spel ->
- let (tspel, spel) = group_terms spel in
- (p, w, loc, spcl, epo, e) :: tspel, spel
- | spel -> [], spel
-;;
-
-let rec parser_cases loc =
- function
- [] ->
- MLast.ExApp
- (loc, MLast.ExLid (loc, "raise"),
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"), MLast.ExUid (loc, "Failure")))
- | spel ->
- match group_terms spel with
- [], (spcl, epo, e) :: spel ->
- stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl
- | tspel, spel ->
- stream_patterns_term loc (fun _ -> parser_cases loc spel) tspel
-;;
-
-let cparser loc bpo pc =
- let e = parser_cases loc pc in
- let e =
- match bpo with
- Some bp ->
- MLast.ExLet
- (loc, false,
- [bp,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"),
- MLast.ExLid (loc, "count")),
- MLast.ExLid (loc, strm_n))],
- e)
- | None -> e
- in
- let p =
- MLast.PaTyc
- (loc, MLast.PaLid (loc, strm_n),
- MLast.TyApp
- (loc,
- MLast.TyAcc
- (loc, MLast.TyUid (loc, "Stream"), MLast.TyLid (loc, "t")),
- MLast.TyAny loc))
- in
- MLast.ExFun (loc, [p, None, e])
-;;
-
-let cparser_match loc me bpo pc =
- let pc = parser_cases loc pc in
- let e =
- match bpo with
- Some bp ->
- MLast.ExLet
- (loc, false,
- [bp,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"),
- MLast.ExLid (loc, "count")),
- MLast.ExLid (loc, strm_n))],
- pc)
- | None -> pc
- in
- match me with
- MLast.ExLid (_, x) when x = strm_n -> e
- | _ ->
- MLast.ExLet
- (loc, false,
- [MLast.PaTyc
- (loc, MLast.PaLid (loc, strm_n),
- MLast.TyApp
- (loc,
- MLast.TyAcc
- (loc, MLast.TyUid (loc, "Stream"), MLast.TyLid (loc, "t")),
- MLast.TyAny loc)),
- me],
- e)
-;;
-
-(* streams *)
-
-let rec not_computing =
- function
- MLast.ExLid (_, _) | MLast.ExUid (_, _) | MLast.ExInt (_, _) |
- MLast.ExFlo (_, _) | MLast.ExChr (_, _) | MLast.ExStr (_, _) ->
- true
- | MLast.ExApp (_, x, y) -> is_cons_apply_not_computing x && not_computing y
- | _ -> false
-and is_cons_apply_not_computing =
- function
- MLast.ExUid (_, _) -> true
- | MLast.ExLid (_, _) -> false
- | MLast.ExApp (_, x, y) -> is_cons_apply_not_computing x && not_computing y
- | _ -> false
-;;
-
-let slazy loc e =
- match e with
- MLast.ExApp (_, f, MLast.ExUid (_, "()")) ->
- begin match f with
- MLast.ExLid (_, _) -> f
- | _ -> MLast.ExFun (loc, [MLast.PaAny loc, None, e])
- end
- | _ -> MLast.ExFun (loc, [MLast.PaAny loc, None, e])
-;;
-
-let rec cstream gloc =
- function
- [] ->
- let loc = gloc in
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "sempty"))
- | [SeTrm (loc, e)] ->
- if not_computing e then
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "ising")),
- e)
- else
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "lsing")),
- slazy loc e)
- | SeTrm (loc, e) :: secl ->
- if not_computing e then
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"),
- MLast.ExLid (loc, "icons")),
- e),
- cstream gloc secl)
- else
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"),
- MLast.ExLid (loc, "lcons")),
- slazy loc e),
- cstream gloc secl)
- | [SeNtr (loc, e)] ->
- if not_computing e then e
- else
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "slazy")),
- slazy loc e)
- | SeNtr (loc, e) :: secl ->
- if not_computing e then
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "iapp")),
- e),
- cstream gloc secl)
- else
- MLast.ExApp
- (loc,
- MLast.ExApp
- (loc,
- MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "lapp")),
- slazy loc e),
- cstream gloc secl)
-;;
-
-(* Syntax extensions in Revised Syntax grammar *)
-
-Grammar.extend
- (let _ = (expr : 'expr Grammar.Entry.e) in
- let grammar_entry_create s =
- Grammar.Entry.create (Grammar.of_entry expr) s
- in
- let parser_case : 'parser_case Grammar.Entry.e =
- grammar_entry_create "parser_case"
- and stream_patt : 'stream_patt Grammar.Entry.e =
- grammar_entry_create "stream_patt"
- and stream_patt_comp_err : 'stream_patt_comp_err Grammar.Entry.e =
- grammar_entry_create "stream_patt_comp_err"
- and stream_patt_comp : 'stream_patt_comp Grammar.Entry.e =
- grammar_entry_create "stream_patt_comp"
- and ipatt : 'ipatt Grammar.Entry.e = grammar_entry_create "ipatt"
- and stream_expr_comp : 'stream_expr_comp Grammar.Entry.e =
- grammar_entry_create "stream_expr_comp"
- in
- [Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
- Some (Gramext.Level "top"),
- [None, None,
- [[Gramext.Stoken ("", "match"); Gramext.Sself;
- Gramext.Stoken ("", "with"); Gramext.Stoken ("", "parser");
- Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)));
- Gramext.Snterm
- (Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e))],
- Gramext.action
- (fun (pc : 'parser_case) (po : 'ipatt option) _ _ (e : 'expr) _
- (loc : int * int) ->
- (cparser_match loc e po [pc] : 'expr));
- [Gramext.Stoken ("", "match"); Gramext.Sself;
- Gramext.Stoken ("", "with"); Gramext.Stoken ("", "parser");
- Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)));
- Gramext.Stoken ("", "[");
- Gramext.Slist0sep
- (Gramext.Snterm
- (Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e)),
- Gramext.Stoken ("", "|"));
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (pcl : 'parser_case list) _ (po : 'ipatt option) _ _
- (e : 'expr) _ (loc : int * int) ->
- (cparser_match loc e po pcl : 'expr));
- [Gramext.Stoken ("", "parser");
- Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)));
- Gramext.Snterm
- (Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e))],
- Gramext.action
- (fun (pc : 'parser_case) (po : 'ipatt option) _ (loc : int * int) ->
- (cparser loc po [pc] : 'expr));
- [Gramext.Stoken ("", "parser");
- Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)));
- Gramext.Stoken ("", "[");
- Gramext.Slist0sep
- (Gramext.Snterm
- (Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e)),
- Gramext.Stoken ("", "|"));
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (pcl : 'parser_case list) _ (po : 'ipatt option) _
- (loc : int * int) ->
- (cparser loc po pcl : 'expr))]];
- Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "[:");
- Gramext.Snterm
- (Grammar.Entry.obj (stream_patt : 'stream_patt Grammar.Entry.e));
- Gramext.Stoken ("", ":]");
- Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)));
- Gramext.Stoken ("", "->");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (po : 'ipatt option) _ (sp : 'stream_patt) _
- (loc : int * int) ->
- (sp, po, e : 'parser_case))]];
- Grammar.Entry.obj (stream_patt : 'stream_patt Grammar.Entry.e), None,
- [None, None,
- [[], Gramext.action (fun (loc : int * int) -> ([] : 'stream_patt));
- [Gramext.Snterm
- (Grammar.Entry.obj
- (stream_patt_comp : 'stream_patt_comp Grammar.Entry.e));
- Gramext.Stoken ("", ";");
- Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (stream_patt_comp_err :
- 'stream_patt_comp_err Grammar.Entry.e)),
- Gramext.Stoken ("", ";"))],
- Gramext.action
- (fun (sp : 'stream_patt_comp_err list) _ (spc : 'stream_patt_comp)
- (loc : int * int) ->
- ((spc, None) :: sp : 'stream_patt));
- [Gramext.Snterm
- (Grammar.Entry.obj
- (stream_patt_comp : 'stream_patt_comp Grammar.Entry.e))],
- Gramext.action
- (fun (spc : 'stream_patt_comp) (loc : int * int) ->
- ([spc, None] : 'stream_patt))]];
- Grammar.Entry.obj
- (stream_patt_comp_err : 'stream_patt_comp_err Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (stream_patt_comp : 'stream_patt_comp Grammar.Entry.e));
- Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("", "?");
- Gramext.Snterm
- (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (loc : int * int) -> (e : 'e__1))])],
- Gramext.action
- (fun (eo : 'e__1 option) (spc : 'stream_patt_comp)
- (loc : int * int) ->
- (spc, eo : 'stream_patt_comp_err))]];
- Grammar.Entry.obj (stream_patt_comp : 'stream_patt_comp Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))],
- Gramext.action
- (fun (p : 'patt) (loc : int * int) ->
- (SpStr (loc, p) : 'stream_patt_comp));
- [Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (p : 'patt) (loc : int * int) ->
- (SpNtr (loc, p, e) : 'stream_patt_comp));
- [Gramext.Stoken ("", "`");
- Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e));
- Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("", "when");
- Gramext.Snterm
- (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (loc : int * int) -> (e : 'e__2))])],
- Gramext.action
- (fun (eo : 'e__2 option) (p : 'patt) _ (loc : int * int) ->
- (SpTrm (loc, p, eo) : 'stream_patt_comp))]];
- Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("LIDENT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) ->
- (MLast.PaLid (loc, i) : 'ipatt))]];
- Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("", "[:");
- Gramext.Slist0sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (stream_expr_comp : 'stream_expr_comp Grammar.Entry.e)),
- Gramext.Stoken ("", ";"));
- Gramext.Stoken ("", ":]")],
- Gramext.action
- (fun _ (se : 'stream_expr_comp list) _ (loc : int * int) ->
- (cstream loc se : 'expr))]];
- Grammar.Entry.obj (stream_expr_comp : 'stream_expr_comp Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) (loc : int * int) ->
- (SeNtr (loc, e) : 'stream_expr_comp));
- [Gramext.Stoken ("", "`");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (loc : int * int) ->
- (SeTrm (loc, e) : 'stream_expr_comp))]]]);;
diff --git a/camlp4/ocaml_src/meta/pr_dump.ml b/camlp4/ocaml_src/meta/pr_dump.ml
deleted file mode 100644
index db42285310..0000000000
--- a/camlp4/ocaml_src/meta/pr_dump.ml
+++ /dev/null
@@ -1,48 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-let open_out_file () =
- match !(Pcaml.output_file) with
- Some f -> open_out_bin f
- | None -> set_binary_mode_out stdout true; stdout
-;;
-
-let interf ast =
- let pt = Ast2pt.interf (List.map fst ast) in
- let oc = open_out_file () in
- let fname = !(Pcaml.input_file) in
- output_string oc Config.ast_intf_magic_number;
- output_value oc (if fname = "-" then "" else fname);
- output_value oc pt;
- flush oc;
- match !(Pcaml.output_file) with
- Some _ -> close_out oc
- | None -> ()
-;;
-
-let implem ast =
- let pt = Ast2pt.implem (List.map fst ast) in
- let oc = open_out_file () in
- let fname = !(Pcaml.input_file) in
- output_string oc Config.ast_impl_magic_number;
- output_value oc (if fname = "-" then "" else fname);
- output_value oc pt;
- flush oc;
- match !(Pcaml.output_file) with
- Some _ -> close_out oc
- | None -> ()
-;;
-
-Pcaml.print_interf := interf;;
-Pcaml.print_implem := implem;;
diff --git a/camlp4/ocaml_src/meta/q_MLast.ml b/camlp4/ocaml_src/meta/q_MLast.ml
deleted file mode 100644
index 70540af642..0000000000
--- a/camlp4/ocaml_src/meta/q_MLast.ml
+++ /dev/null
@@ -1,4700 +0,0 @@
-(* camlp4r pa_extend.cmo pa_extend_m.cmo q_MLast.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-let gram = Grammar.gcreate (Plexer.gmake ());;
-
-module Qast =
- struct
- type t =
- Node of string * t list
- | List of t list
- | Tuple of t list
- | Option of t option
- | Int of string
- | Str of string
- | Bool of bool
- | Cons of t * t
- | Apply of string * t list
- | Record of (string * t) list
- | Loc
- | Antiquot of MLast.loc * string
- ;;
- let loc = 0, 0;;
- let rec to_expr =
- function
- Node (n, al) ->
- List.fold_left (fun e a -> MLast.ExApp (loc, e, to_expr a))
- (MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"), MLast.ExUid (loc, n)))
- al
- | List al ->
- List.fold_right
- (fun a e ->
- MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), to_expr a),
- e))
- al (MLast.ExUid (loc, "[]"))
- | Tuple al -> MLast.ExTup (loc, List.map to_expr al)
- | Option None -> MLast.ExUid (loc, "None")
- | Option (Some a) ->
- MLast.ExApp (loc, MLast.ExUid (loc, "Some"), to_expr a)
- | Int s -> MLast.ExInt (loc, s)
- | Str s -> MLast.ExStr (loc, s)
- | Bool true -> MLast.ExUid (loc, "True")
- | Bool false -> MLast.ExUid (loc, "False")
- | Cons (a1, a2) ->
- MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), to_expr a1),
- to_expr a2)
- | Apply (f, al) ->
- List.fold_left (fun e a -> MLast.ExApp (loc, e, to_expr a))
- (MLast.ExLid (loc, f)) al
- | Record lal -> MLast.ExRec (loc, List.map to_expr_label lal, None)
- | Loc -> MLast.ExLid (loc, !(Stdpp.loc_name))
- | Antiquot (loc, s) ->
- let e =
- try Grammar.Entry.parse Pcaml.expr_eoi (Stream.of_string s) with
- Stdpp.Exc_located ((bp, ep), exc) ->
- raise (Stdpp.Exc_located ((fst loc + bp, fst loc + ep), exc))
- in
- MLast.ExAnt (loc, e)
- and to_expr_label (l, a) =
- MLast.PaAcc (loc, MLast.PaUid (loc, "MLast"), MLast.PaLid (loc, l)),
- to_expr a
- ;;
- let rec to_patt =
- function
- Node (n, al) ->
- List.fold_left (fun e a -> MLast.PaApp (loc, e, to_patt a))
- (MLast.PaAcc
- (loc, MLast.PaUid (loc, "MLast"), MLast.PaUid (loc, n)))
- al
- | List al ->
- List.fold_right
- (fun a p ->
- MLast.PaApp
- (loc, MLast.PaApp (loc, MLast.PaUid (loc, "::"), to_patt a),
- p))
- al (MLast.PaUid (loc, "[]"))
- | Tuple al -> MLast.PaTup (loc, List.map to_patt al)
- | Option None -> MLast.PaUid (loc, "None")
- | Option (Some a) ->
- MLast.PaApp (loc, MLast.PaUid (loc, "Some"), to_patt a)
- | Int s -> MLast.PaInt (loc, s)
- | Str s -> MLast.PaStr (loc, s)
- | Bool true -> MLast.PaUid (loc, "True")
- | Bool false -> MLast.PaUid (loc, "False")
- | Cons (a1, a2) ->
- MLast.PaApp
- (loc, MLast.PaApp (loc, MLast.PaUid (loc, "::"), to_patt a1),
- to_patt a2)
- | Apply (_, _) -> failwith "bad pattern"
- | Record lal -> MLast.PaRec (loc, List.map to_patt_label lal)
- | Loc -> MLast.PaAny loc
- | Antiquot (loc, s) ->
- let p =
- try Grammar.Entry.parse Pcaml.patt_eoi (Stream.of_string s) with
- Stdpp.Exc_located ((bp, ep), exc) ->
- raise (Stdpp.Exc_located ((fst loc + bp, fst loc + ep), exc))
- in
- MLast.PaAnt (loc, p)
- and to_patt_label (l, a) =
- MLast.PaAcc (loc, MLast.PaUid (loc, "MLast"), MLast.PaLid (loc, l)),
- to_patt a
- ;;
- end
-;;
-
-let antiquot k (bp, ep) x =
- let shift =
- if k = "" then String.length "$"
- else String.length "$" + String.length k + String.length ":"
- in
- Qast.Antiquot ((shift + bp, shift + ep), x)
-;;
-
-let sig_item = Grammar.Entry.create gram "signature item";;
-let str_item = Grammar.Entry.create gram "structure item";;
-let ctyp = Grammar.Entry.create gram "type";;
-let patt = Grammar.Entry.create gram "pattern";;
-let expr = Grammar.Entry.create gram "expression";;
-
-let module_type = Grammar.Entry.create gram "module type";;
-let module_expr = Grammar.Entry.create gram "module expression";;
-
-let class_type = Grammar.Entry.create gram "class type";;
-let class_expr = Grammar.Entry.create gram "class expr";;
-let class_sig_item = Grammar.Entry.create gram "class signature item";;
-let class_str_item = Grammar.Entry.create gram "class structure item";;
-
-let ipatt = Grammar.Entry.create gram "ipatt";;
-let let_binding = Grammar.Entry.create gram "let_binding";;
-let type_declaration = Grammar.Entry.create gram "type_declaration";;
-let with_constr = Grammar.Entry.create gram "with_constr";;
-let row_field = Grammar.Entry.create gram "row_field";;
-
-let a_list = Grammar.Entry.create gram "a_list";;
-let a_opt = Grammar.Entry.create gram "a_opt";;
-let a_UIDENT = Grammar.Entry.create gram "a_UIDENT";;
-let a_LIDENT = Grammar.Entry.create gram "a_LIDENT";;
-let a_INT = Grammar.Entry.create gram "a_INT";;
-let a_FLOAT = Grammar.Entry.create gram "a_FLOAT";;
-let a_STRING = Grammar.Entry.create gram "a_STRING";;
-let a_CHAR = Grammar.Entry.create gram "a_CHAR";;
-let a_TILDEIDENT = Grammar.Entry.create gram "a_TILDEIDENT";;
-let a_LABEL = Grammar.Entry.create gram "a_LABEL";;
-let a_QUESTIONIDENT = Grammar.Entry.create gram "a_QUESTIONIDENT";;
-let a_OPTLABEL = Grammar.Entry.create gram "a_OPTLABEL";;
-
-let o2b =
- function
- Qast.Option (Some _) -> Qast.Bool true
- | Qast.Option None -> Qast.Bool false
- | x -> x
-;;
-
-let mksequence _ =
- function
- Qast.List [e] -> e
- | el -> Qast.Node ("ExSeq", [Qast.Loc; el])
-;;
-
-let mkmatchcase _ p aso w e =
- let p =
- match aso with
- Qast.Option (Some p2) -> Qast.Node ("PaAli", [Qast.Loc; p; p2])
- | Qast.Option None -> p
- | _ -> Qast.Node ("PaAli", [Qast.Loc; p; aso])
- in
- Qast.Tuple [p; w; e]
-;;
-
-let neg_string n =
- let len = String.length n in
- if len > 0 && n.[0] = '-' then String.sub n 1 (len - 1) else "-" ^ n
-;;
-
-let mkumin _ f arg =
- match arg with
- Qast.Node ("ExInt", [Qast.Loc; Qast.Str n]) when int_of_string n > 0 ->
- let n = neg_string n in Qast.Node ("ExInt", [Qast.Loc; Qast.Str n])
- | Qast.Node ("ExFlo", [Qast.Loc; Qast.Str n])
- when float_of_string n > 0.0 ->
- let n = neg_string n in Qast.Node ("ExFlo", [Qast.Loc; Qast.Str n])
- | _ ->
- match f with
- Qast.Str f ->
- let f = "~" ^ f in
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str f]); arg])
- | _ -> assert false
-;;
-
-let mkuminpat _ f is_int s =
- let s =
- match s with
- Qast.Str s -> Qast.Str (neg_string s)
- | s -> failwith "bad unary minus"
- in
- match is_int with
- Qast.Bool true -> Qast.Node ("PaInt", [Qast.Loc; s])
- | Qast.Bool false -> Qast.Node ("PaFlo", [Qast.Loc; s])
- | _ -> assert false
-;;
-
-let mklistexp _ last =
- let rec loop top =
- function
- Qast.List [] ->
- begin match last with
- Qast.Option (Some e) -> e
- | Qast.Option None -> Qast.Node ("ExUid", [Qast.Loc; Qast.Str "[]"])
- | a -> a
- end
- | Qast.List (e1 :: el) ->
- Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExUid", [Qast.Loc; Qast.Str "::"]);
- e1]);
- loop false (Qast.List el)])
- | a -> a
- in
- loop true
-;;
-
-let mklistpat _ last =
- let rec loop top =
- function
- Qast.List [] ->
- begin match last with
- Qast.Option (Some p) -> p
- | Qast.Option None -> Qast.Node ("PaUid", [Qast.Loc; Qast.Str "[]"])
- | a -> a
- end
- | Qast.List (p1 :: pl) ->
- Qast.Node
- ("PaApp",
- [Qast.Loc;
- Qast.Node
- ("PaApp",
- [Qast.Loc; Qast.Node ("PaUid", [Qast.Loc; Qast.Str "::"]);
- p1]);
- loop false (Qast.List pl)])
- | a -> a
- in
- loop true
-;;
-
-let mkexprident loc i j =
- let rec loop m =
- function
- Qast.Node ("ExAcc", [_; x; y]) ->
- loop (Qast.Node ("ExAcc", [Qast.Loc; m; x])) y
- | e -> Qast.Node ("ExAcc", [Qast.Loc; m; e])
- in
- loop (Qast.Node ("ExUid", [Qast.Loc; i])) j
-;;
-
-let mkassert _ e =
- match e with
- Qast.Node ("ExUid", [_; Qast.Str "False"]) ->
- Qast.Node ("ExAsf", [Qast.Loc])
- | _ -> Qast.Node ("ExAsr", [Qast.Loc; e])
-;;
-
-let append_elem el e = Qast.Apply ("@", [el; Qast.List [e]]);;
-
-let not_yet_warned_antiq = ref true;;
-let warn_antiq loc vers =
- if !not_yet_warned_antiq then
- begin
- not_yet_warned_antiq := false;
- !(Pcaml.warning) loc
- (Printf.sprintf
- "use of antiquotation syntax deprecated since version %s" vers)
- end
-;;
-
-let not_yet_warned_variant = ref true;;
-let warn_variant _ =
- if !not_yet_warned_variant then
- begin
- not_yet_warned_variant := false;
- !(Pcaml.warning) (0, 1)
- (Printf.sprintf
- "use of syntax of variants types deprecated since version 3.05")
- end
-;;
-
-let not_yet_warned_seq = ref true;;
-let warn_sequence _ =
- if !not_yet_warned_seq then
- begin
- not_yet_warned_seq := false;
- !(Pcaml.warning) (0, 1)
- (Printf.sprintf
- "use of syntax of sequences deprecated since version 3.01.1")
- end
-;;
-
-Grammar.extend
- (let _ = (sig_item : 'sig_item Grammar.Entry.e)
- and _ = (str_item : 'str_item Grammar.Entry.e)
- and _ = (ctyp : 'ctyp Grammar.Entry.e)
- and _ = (patt : 'patt Grammar.Entry.e)
- and _ = (expr : 'expr Grammar.Entry.e)
- and _ = (module_type : 'module_type Grammar.Entry.e)
- and _ = (module_expr : 'module_expr Grammar.Entry.e)
- and _ = (class_type : 'class_type Grammar.Entry.e)
- and _ = (class_expr : 'class_expr Grammar.Entry.e)
- and _ = (class_sig_item : 'class_sig_item Grammar.Entry.e)
- and _ = (class_str_item : 'class_str_item Grammar.Entry.e)
- and _ = (let_binding : 'let_binding Grammar.Entry.e)
- and _ = (type_declaration : 'type_declaration Grammar.Entry.e)
- and _ = (ipatt : 'ipatt Grammar.Entry.e)
- and _ = (with_constr : 'with_constr Grammar.Entry.e)
- and _ = (row_field : 'row_field Grammar.Entry.e) in
- let grammar_entry_create s =
- Grammar.Entry.create (Grammar.of_entry sig_item) s
- in
- let rebind_exn : 'rebind_exn Grammar.Entry.e =
- grammar_entry_create "rebind_exn"
- and module_binding : 'module_binding Grammar.Entry.e =
- grammar_entry_create "module_binding"
- and module_rec_binding : 'module_rec_binding Grammar.Entry.e =
- grammar_entry_create "module_rec_binding"
- and module_declaration : 'module_declaration Grammar.Entry.e =
- grammar_entry_create "module_declaration"
- and module_rec_declaration : 'module_rec_declaration Grammar.Entry.e =
- grammar_entry_create "module_rec_declaration"
- and cons_expr_opt : 'cons_expr_opt Grammar.Entry.e =
- grammar_entry_create "cons_expr_opt"
- and dummy : 'dummy Grammar.Entry.e = grammar_entry_create "dummy"
- and fun_binding : 'fun_binding Grammar.Entry.e =
- grammar_entry_create "fun_binding"
- and match_case : 'match_case Grammar.Entry.e =
- grammar_entry_create "match_case"
- and as_patt_opt : 'as_patt_opt Grammar.Entry.e =
- grammar_entry_create "as_patt_opt"
- and label_expr : 'label_expr Grammar.Entry.e =
- grammar_entry_create "label_expr"
- and fun_def : 'fun_def Grammar.Entry.e = grammar_entry_create "fun_def"
- and cons_patt_opt : 'cons_patt_opt Grammar.Entry.e =
- grammar_entry_create "cons_patt_opt"
- and label_patt : 'label_patt Grammar.Entry.e =
- grammar_entry_create "label_patt"
- and label_ipatt : 'label_ipatt Grammar.Entry.e =
- grammar_entry_create "label_ipatt"
- and type_patt : 'type_patt Grammar.Entry.e =
- grammar_entry_create "type_patt"
- and constrain : 'constrain Grammar.Entry.e =
- grammar_entry_create "constrain"
- and type_parameter : 'type_parameter Grammar.Entry.e =
- grammar_entry_create "type_parameter"
- and constructor_declaration : 'constructor_declaration Grammar.Entry.e =
- grammar_entry_create "constructor_declaration"
- and label_declaration : 'label_declaration Grammar.Entry.e =
- grammar_entry_create "label_declaration"
- and ident : 'ident Grammar.Entry.e = grammar_entry_create "ident"
- and class_declaration : 'class_declaration Grammar.Entry.e =
- grammar_entry_create "class_declaration"
- and class_fun_binding : 'class_fun_binding Grammar.Entry.e =
- grammar_entry_create "class_fun_binding"
- and class_type_parameters : 'class_type_parameters Grammar.Entry.e =
- grammar_entry_create "class_type_parameters"
- and class_fun_def : 'class_fun_def Grammar.Entry.e =
- grammar_entry_create "class_fun_def"
- and class_structure : 'class_structure Grammar.Entry.e =
- grammar_entry_create "class_structure"
- and class_self_patt : 'class_self_patt Grammar.Entry.e =
- grammar_entry_create "class_self_patt"
- and as_lident : 'as_lident Grammar.Entry.e =
- grammar_entry_create "as_lident"
- and polyt : 'polyt Grammar.Entry.e = grammar_entry_create "polyt"
- and cvalue_binding : 'cvalue_binding Grammar.Entry.e =
- grammar_entry_create "cvalue_binding"
- and label : 'label Grammar.Entry.e = grammar_entry_create "label"
- and class_self_type : 'class_self_type Grammar.Entry.e =
- grammar_entry_create "class_self_type"
- and class_description : 'class_description Grammar.Entry.e =
- grammar_entry_create "class_description"
- and class_type_declaration : 'class_type_declaration Grammar.Entry.e =
- grammar_entry_create "class_type_declaration"
- and field_expr : 'field_expr Grammar.Entry.e =
- grammar_entry_create "field_expr"
- and field : 'field Grammar.Entry.e = grammar_entry_create "field"
- and typevar : 'typevar Grammar.Entry.e = grammar_entry_create "typevar"
- and row_field_list : 'row_field_list Grammar.Entry.e =
- grammar_entry_create "row_field_list"
- and name_tag : 'name_tag Grammar.Entry.e = grammar_entry_create "name_tag"
- and patt_tcon : 'patt_tcon Grammar.Entry.e =
- grammar_entry_create "patt_tcon"
- and ipatt_tcon : 'ipatt_tcon Grammar.Entry.e =
- grammar_entry_create "ipatt_tcon"
- and eq_expr : 'eq_expr Grammar.Entry.e = grammar_entry_create "eq_expr"
- and warning_variant : 'warning_variant Grammar.Entry.e =
- grammar_entry_create "warning_variant"
- and warning_sequence : 'warning_sequence Grammar.Entry.e =
- grammar_entry_create "warning_sequence"
- and sequence : 'sequence Grammar.Entry.e = grammar_entry_create "sequence"
- and expr_ident : 'expr_ident Grammar.Entry.e =
- grammar_entry_create "expr_ident"
- and patt_label_ident : 'patt_label_ident Grammar.Entry.e =
- grammar_entry_create "patt_label_ident"
- and when_expr_opt : 'when_expr_opt Grammar.Entry.e =
- grammar_entry_create "when_expr_opt"
- and mod_ident : 'mod_ident Grammar.Entry.e =
- grammar_entry_create "mod_ident"
- and clty_longident : 'clty_longident Grammar.Entry.e =
- grammar_entry_create "clty_longident"
- and class_longident : 'class_longident Grammar.Entry.e =
- grammar_entry_create "class_longident"
- and direction_flag : 'direction_flag Grammar.Entry.e =
- grammar_entry_create "direction_flag"
- in
- [Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "struct");
- Gramext.srules
- [[Gramext.Slist0
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (str_item : 'str_item Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (s : 'str_item) (loc : int * int) ->
- (s : 'e__1))])],
- Gramext.action
- (fun (a : 'e__1 list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "end")],
- Gramext.action
- (fun _ (st : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("MeStr", [Qast.Loc; st]) : 'module_expr));
- [Gramext.Stoken ("", "functor"); Gramext.Stoken ("", "(");
- Gramext.Snterm
- (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm
- (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e));
- Gramext.Stoken ("", ")"); Gramext.Stoken ("", "->"); Gramext.Sself],
- Gramext.action
- (fun (me : 'module_expr) _ _ (t : 'module_type) _ (i : 'a_UIDENT) _ _
- (loc : int * int) ->
- (Qast.Node ("MeFun", [Qast.Loc; i; t; me]) : 'module_expr))];
- None, None,
- [[Gramext.Sself; Gramext.Sself],
- Gramext.action
- (fun (me2 : 'module_expr) (me1 : 'module_expr) (loc : int * int) ->
- (Qast.Node ("MeApp", [Qast.Loc; me1; me2]) : 'module_expr))];
- None, None,
- [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
- Gramext.action
- (fun (me2 : 'module_expr) _ (me1 : 'module_expr) (loc : int * int) ->
- (Qast.Node ("MeAcc", [Qast.Loc; me1; me2]) : 'module_expr))];
- Some "simple", None,
- [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (me : 'module_expr) _ (loc : int * int) ->
- (me : 'module_expr));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":");
- Gramext.Snterm
- (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (mt : 'module_type) _ (me : 'module_expr) _
- (loc : int * int) ->
- (Qast.Node ("MeTyc", [Qast.Loc; me; mt]) : 'module_expr));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'a_UIDENT) (loc : int * int) ->
- (Qast.Node ("MeUid", [Qast.Loc; i]) : 'module_expr))]];
- Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), None,
- [Some "top", None,
- [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) (loc : int * int) ->
- (Qast.Node ("StExp", [Qast.Loc; e]) : 'str_item));
- [Gramext.Stoken ("", "value");
- Gramext.srules
- [[Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("", "rec")],
- Gramext.action
- (fun (x : string) (loc : int * int) ->
- (Qast.Str x : 'e__3))])],
- Gramext.action
- (fun (a : 'e__3 option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))];
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (let_binding : 'let_binding Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (a : 'let_binding list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]],
- Gramext.action
- (fun (l : 'a_list) (r : 'a_opt) _ (loc : int * int) ->
- (Qast.Node ("StVal", [Qast.Loc; o2b r; l]) : 'str_item));
- [Gramext.Stoken ("", "type");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (type_declaration : 'type_declaration Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (a : 'type_declaration list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]],
- Gramext.action
- (fun (tdl : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("StTyp", [Qast.Loc; tdl]) : 'str_item));
- [Gramext.Stoken ("", "open");
- Gramext.Snterm
- (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'mod_ident) _ (loc : int * int) ->
- (Qast.Node ("StOpn", [Qast.Loc; i]) : 'str_item));
- [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "type");
- Gramext.Snterm
- (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm
- (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))],
- Gramext.action
- (fun (mt : 'module_type) _ (i : 'a_UIDENT) _ _ (loc : int * int) ->
- (Qast.Node ("StMty", [Qast.Loc; i; mt]) : 'str_item));
- [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "rec");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (module_rec_binding :
- 'module_rec_binding Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (a : 'module_rec_binding list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]],
- Gramext.action
- (fun (nmtmes : 'a_list) _ _ (loc : int * int) ->
- (Qast.Node ("StRecMod", [Qast.Loc; nmtmes]) : 'str_item));
- [Gramext.Stoken ("", "module");
- Gramext.Snterm
- (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj
- (module_binding : 'module_binding Grammar.Entry.e))],
- Gramext.action
- (fun (mb : 'module_binding) (i : 'a_UIDENT) _ (loc : int * int) ->
- (Qast.Node ("StMod", [Qast.Loc; i; mb]) : 'str_item));
- [Gramext.Stoken ("", "include");
- Gramext.Snterm
- (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))],
- Gramext.action
- (fun (me : 'module_expr) _ (loc : int * int) ->
- (Qast.Node ("StInc", [Qast.Loc; me]) : 'str_item));
- [Gramext.Stoken ("", "external");
- Gramext.Snterm
- (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.srules
- [[Gramext.Slist1
- (Gramext.Snterm
- (Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e)))],
- Gramext.action
- (fun (a : 'a_STRING list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]],
- Gramext.action
- (fun (pd : 'a_list) _ (t : 'ctyp) _ (i : 'a_LIDENT) _
- (loc : int * int) ->
- (Qast.Node ("StExt", [Qast.Loc; i; t; pd]) : 'str_item));
- [Gramext.Stoken ("", "exception");
- Gramext.Snterm
- (Grammar.Entry.obj
- (constructor_declaration :
- 'constructor_declaration Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj (rebind_exn : 'rebind_exn Grammar.Entry.e))],
- Gramext.action
- (fun (b : 'rebind_exn) (ctl : 'constructor_declaration) _
- (loc : int * int) ->
- (let (_, c, tl) =
- match ctl with
- Qast.Tuple [xx1; xx2; xx3] -> xx1, xx2, xx3
- | _ ->
- match () with
- _ -> raise (Match_failure ("q_MLast.ml", 302, 19))
- in
- Qast.Node ("StExc", [Qast.Loc; c; tl; b]) :
- 'str_item));
- [Gramext.Stoken ("", "declare");
- Gramext.srules
- [[Gramext.Slist0
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (str_item : 'str_item Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (s : 'str_item) (loc : int * int) ->
- (s : 'e__2))])],
- Gramext.action
- (fun (a : 'e__2 list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "end")],
- Gramext.action
- (fun _ (st : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("StDcl", [Qast.Loc; st]) : 'str_item))]];
- Grammar.Entry.obj (rebind_exn : 'rebind_exn Grammar.Entry.e), None,
- [None, None,
- [[],
- Gramext.action (fun (loc : int * int) -> (Qast.List [] : 'rebind_exn));
- [Gramext.Stoken ("", "=");
- Gramext.Snterm
- (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))],
- Gramext.action
- (fun (sl : 'mod_ident) _ (loc : int * int) -> (sl : 'rebind_exn))]];
- Grammar.Entry.obj (module_binding : 'module_binding Grammar.Entry.e),
- None,
- [None, Some Gramext.RightA,
- [[Gramext.Stoken ("", "=");
- Gramext.Snterm
- (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))],
- Gramext.action
- (fun (me : 'module_expr) _ (loc : int * int) ->
- (me : 'module_binding));
- [Gramext.Stoken ("", ":");
- Gramext.Snterm
- (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm
- (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))],
- Gramext.action
- (fun (me : 'module_expr) _ (mt : 'module_type) _ (loc : int * int) ->
- (Qast.Node ("MeTyc", [Qast.Loc; me; mt]) : 'module_binding));
- [Gramext.Stoken ("", "(");
- Gramext.Snterm
- (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm
- (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e));
- Gramext.Stoken ("", ")"); Gramext.Sself],
- Gramext.action
- (fun (mb : 'module_binding) _ (mt : 'module_type) _ (m : 'a_UIDENT) _
- (loc : int * int) ->
- (Qast.Node ("MeFun", [Qast.Loc; m; mt; mb]) : 'module_binding))]];
- Grammar.Entry.obj
- (module_rec_binding : 'module_rec_binding Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm
- (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm
- (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))],
- Gramext.action
- (fun (me : 'module_expr) _ (mt : 'module_type) _ (m : 'a_UIDENT)
- (loc : int * int) ->
- (Qast.Tuple [m; me; mt] : 'module_rec_binding))]];
- Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "functor"); Gramext.Stoken ("", "(");
- Gramext.Snterm
- (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e));
- Gramext.Stoken ("", ":"); Gramext.Sself; Gramext.Stoken ("", ")");
- Gramext.Stoken ("", "->"); Gramext.Sself],
- Gramext.action
- (fun (mt : 'module_type) _ _ (t : 'module_type) _ (i : 'a_UIDENT) _ _
- (loc : int * int) ->
- (Qast.Node ("MtFun", [Qast.Loc; i; t; mt]) : 'module_type))];
- None, None,
- [[Gramext.Sself; Gramext.Stoken ("", "with");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (with_constr : 'with_constr Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (a : 'with_constr list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]],
- Gramext.action
- (fun (wcl : 'a_list) _ (mt : 'module_type) (loc : int * int) ->
- (Qast.Node ("MtWit", [Qast.Loc; mt; wcl]) : 'module_type))];
- None, None,
- [[Gramext.Stoken ("", "sig");
- Gramext.srules
- [[Gramext.Slist0
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (sig_item : 'sig_item Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (s : 'sig_item) (loc : int * int) ->
- (s : 'e__4))])],
- Gramext.action
- (fun (a : 'e__4 list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "end")],
- Gramext.action
- (fun _ (sg : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("MtSig", [Qast.Loc; sg]) : 'module_type))];
- None, None,
- [[Gramext.Sself; Gramext.Sself],
- Gramext.action
- (fun (m2 : 'module_type) (m1 : 'module_type) (loc : int * int) ->
- (Qast.Node ("MtApp", [Qast.Loc; m1; m2]) : 'module_type))];
- None, None,
- [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
- Gramext.action
- (fun (m2 : 'module_type) _ (m1 : 'module_type) (loc : int * int) ->
- (Qast.Node ("MtAcc", [Qast.Loc; m1; m2]) : 'module_type))];
- Some "simple", None,
- [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (mt : 'module_type) _ (loc : int * int) ->
- (mt : 'module_type));
- [Gramext.Stoken ("", "'");
- Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'ident) _ (loc : int * int) ->
- (Qast.Node ("MtQuo", [Qast.Loc; i]) : 'module_type));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'a_LIDENT) (loc : int * int) ->
- (Qast.Node ("MtLid", [Qast.Loc; i]) : 'module_type));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'a_UIDENT) (loc : int * int) ->
- (Qast.Node ("MtUid", [Qast.Loc; i]) : 'module_type))]];
- Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None,
- [Some "top", None,
- [[Gramext.Stoken ("", "value");
- Gramext.Snterm
- (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'ctyp) _ (i : 'a_LIDENT) _ (loc : int * int) ->
- (Qast.Node ("SgVal", [Qast.Loc; i; t]) : 'sig_item));
- [Gramext.Stoken ("", "type");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (type_declaration : 'type_declaration Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (a : 'type_declaration list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]],
- Gramext.action
- (fun (tdl : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("SgTyp", [Qast.Loc; tdl]) : 'sig_item));
- [Gramext.Stoken ("", "open");
- Gramext.Snterm
- (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'mod_ident) _ (loc : int * int) ->
- (Qast.Node ("SgOpn", [Qast.Loc; i]) : 'sig_item));
- [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "rec");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (module_rec_declaration :
- 'module_rec_declaration Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (a : 'module_rec_declaration list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]],
- Gramext.action
- (fun (mds : 'a_list) _ _ (loc : int * int) ->
- (Qast.Node ("SgRecMod", [Qast.Loc; mds]) : 'sig_item));
- [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "type");
- Gramext.Snterm
- (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm
- (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))],
- Gramext.action
- (fun (mt : 'module_type) _ (i : 'a_UIDENT) _ _ (loc : int * int) ->
- (Qast.Node ("SgMty", [Qast.Loc; i; mt]) : 'sig_item));
- [Gramext.Stoken ("", "module");
- Gramext.Snterm
- (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj
- (module_declaration : 'module_declaration Grammar.Entry.e))],
- Gramext.action
- (fun (mt : 'module_declaration) (i : 'a_UIDENT) _ (loc : int * int) ->
- (Qast.Node ("SgMod", [Qast.Loc; i; mt]) : 'sig_item));
- [Gramext.Stoken ("", "include");
- Gramext.Snterm
- (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))],
- Gramext.action
- (fun (mt : 'module_type) _ (loc : int * int) ->
- (Qast.Node ("SgInc", [Qast.Loc; mt]) : 'sig_item));
- [Gramext.Stoken ("", "external");
- Gramext.Snterm
- (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.srules
- [[Gramext.Slist1
- (Gramext.Snterm
- (Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e)))],
- Gramext.action
- (fun (a : 'a_STRING list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]],
- Gramext.action
- (fun (pd : 'a_list) _ (t : 'ctyp) _ (i : 'a_LIDENT) _
- (loc : int * int) ->
- (Qast.Node ("SgExt", [Qast.Loc; i; t; pd]) : 'sig_item));
- [Gramext.Stoken ("", "exception");
- Gramext.Snterm
- (Grammar.Entry.obj
- (constructor_declaration :
- 'constructor_declaration Grammar.Entry.e))],
- Gramext.action
- (fun (ctl : 'constructor_declaration) _ (loc : int * int) ->
- (let (_, c, tl) =
- match ctl with
- Qast.Tuple [xx1; xx2; xx3] -> xx1, xx2, xx3
- | _ ->
- match () with
- _ -> raise (Match_failure ("q_MLast.ml", 360, 19))
- in
- Qast.Node ("SgExc", [Qast.Loc; c; tl]) :
- 'sig_item));
- [Gramext.Stoken ("", "declare");
- Gramext.srules
- [[Gramext.Slist0
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (sig_item : 'sig_item Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (s : 'sig_item) (loc : int * int) ->
- (s : 'e__5))])],
- Gramext.action
- (fun (a : 'e__5 list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "end")],
- Gramext.action
- (fun _ (st : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("SgDcl", [Qast.Loc; st]) : 'sig_item))]];
- Grammar.Entry.obj
- (module_declaration : 'module_declaration Grammar.Entry.e),
- None,
- [None, Some Gramext.RightA,
- [[Gramext.Stoken ("", "(");
- Gramext.Snterm
- (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm
- (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e));
- Gramext.Stoken ("", ")"); Gramext.Sself],
- Gramext.action
- (fun (mt : 'module_declaration) _ (t : 'module_type) _ (i : 'a_UIDENT)
- _ (loc : int * int) ->
- (Qast.Node ("MtFun", [Qast.Loc; i; t; mt]) : 'module_declaration));
- [Gramext.Stoken ("", ":");
- Gramext.Snterm
- (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))],
- Gramext.action
- (fun (mt : 'module_type) _ (loc : int * int) ->
- (mt : 'module_declaration))]];
- Grammar.Entry.obj
- (module_rec_declaration : 'module_rec_declaration Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm
- (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))],
- Gramext.action
- (fun (mt : 'module_type) _ (m : 'a_UIDENT) (loc : int * int) ->
- (Qast.Tuple [m; mt] : 'module_rec_declaration))]];
- Grammar.Entry.obj (with_constr : 'with_constr Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "module");
- Gramext.Snterm
- (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm
- (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))],
- Gramext.action
- (fun (me : 'module_expr) _ (i : 'mod_ident) _ (loc : int * int) ->
- (Qast.Node ("WcMod", [Qast.Loc; i; me]) : 'with_constr));
- [Gramext.Stoken ("", "type");
- Gramext.Snterm
- (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e));
- Gramext.srules
- [[Gramext.Slist0
- (Gramext.Snterm
- (Grammar.Entry.obj
- (type_parameter : 'type_parameter Grammar.Entry.e)))],
- Gramext.action
- (fun (a : 'type_parameter list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'ctyp) _ (tpl : 'a_list) (i : 'mod_ident) _
- (loc : int * int) ->
- (Qast.Node ("WcTyp", [Qast.Loc; i; tpl; t]) : 'with_constr))]];
- Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), None,
- [Some "top", Some Gramext.RightA,
- [[Gramext.Stoken ("", "while"); Gramext.Sself; Gramext.Stoken ("", "do");
- Gramext.Stoken ("", "{");
- Gramext.Snterm
- (Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e));
- Gramext.Stoken ("", "}")],
- Gramext.action
- (fun _ (seq : 'sequence) _ _ (e : 'expr) _ (loc : int * int) ->
- (Qast.Node ("ExWhi", [Qast.Loc; e; seq]) : 'expr));
- [Gramext.Stoken ("", "for");
- Gramext.Snterm
- (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e));
- Gramext.Stoken ("", "="); Gramext.Sself;
- Gramext.Snterm
- (Grammar.Entry.obj
- (direction_flag : 'direction_flag Grammar.Entry.e));
- Gramext.Sself; Gramext.Stoken ("", "do"); Gramext.Stoken ("", "{");
- Gramext.Snterm
- (Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e));
- Gramext.Stoken ("", "}")],
- Gramext.action
- (fun _ (seq : 'sequence) _ _ (e2 : 'expr) (df : 'direction_flag)
- (e1 : 'expr) _ (i : 'a_LIDENT) _ (loc : int * int) ->
- (Qast.Node ("ExFor", [Qast.Loc; i; e1; e2; df; seq]) : 'expr));
- [Gramext.Stoken ("", "do"); Gramext.Stoken ("", "{");
- Gramext.Snterm
- (Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e));
- Gramext.Stoken ("", "}")],
- Gramext.action
- (fun _ (seq : 'sequence) _ _ (loc : int * int) ->
- (mksequence Qast.Loc seq : 'expr));
- [Gramext.Stoken ("", "if"); Gramext.Sself; Gramext.Stoken ("", "then");
- Gramext.Sself; Gramext.Stoken ("", "else"); Gramext.Sself],
- Gramext.action
- (fun (e3 : 'expr) _ (e2 : 'expr) _ (e1 : 'expr) _ (loc : int * int) ->
- (Qast.Node ("ExIfe", [Qast.Loc; e1; e2; e3]) : 'expr));
- [Gramext.Stoken ("", "try"); Gramext.Sself; Gramext.Stoken ("", "with");
- Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
- Gramext.Stoken ("", "->"); Gramext.Sself],
- Gramext.action
- (fun (e1 : 'expr) _ (p1 : 'ipatt) _ (e : 'expr) _ (loc : int * int) ->
- (Qast.Node
- ("ExTry",
- [Qast.Loc; e;
- Qast.List [Qast.Tuple [p1; Qast.Option None; e1]]]) :
- 'expr));
- [Gramext.Stoken ("", "try"); Gramext.Sself; Gramext.Stoken ("", "with");
- Gramext.Stoken ("", "[");
- Gramext.srules
- [[Gramext.Slist0sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (match_case : 'match_case Grammar.Entry.e)),
- Gramext.Stoken ("", "|"))],
- Gramext.action
- (fun (a : 'match_case list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (l : 'a_list) _ _ (e : 'expr) _ (loc : int * int) ->
- (Qast.Node ("ExTry", [Qast.Loc; e; l]) : 'expr));
- [Gramext.Stoken ("", "match"); Gramext.Sself;
- Gramext.Stoken ("", "with");
- Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
- Gramext.Stoken ("", "->"); Gramext.Sself],
- Gramext.action
- (fun (e1 : 'expr) _ (p1 : 'ipatt) _ (e : 'expr) _ (loc : int * int) ->
- (Qast.Node
- ("ExMat",
- [Qast.Loc; e;
- Qast.List [Qast.Tuple [p1; Qast.Option None; e1]]]) :
- 'expr));
- [Gramext.Stoken ("", "match"); Gramext.Sself;
- Gramext.Stoken ("", "with"); Gramext.Stoken ("", "[");
- Gramext.srules
- [[Gramext.Slist0sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (match_case : 'match_case Grammar.Entry.e)),
- Gramext.Stoken ("", "|"))],
- Gramext.action
- (fun (a : 'match_case list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (l : 'a_list) _ _ (e : 'expr) _ (loc : int * int) ->
- (Qast.Node ("ExMat", [Qast.Loc; e; l]) : 'expr));
- [Gramext.Stoken ("", "fun");
- Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj (fun_def : 'fun_def Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'fun_def) (p : 'ipatt) _ (loc : int * int) ->
- (Qast.Node
- ("ExFun",
- [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]) :
- 'expr));
- [Gramext.Stoken ("", "fun"); Gramext.Stoken ("", "[");
- Gramext.srules
- [[Gramext.Slist0sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (match_case : 'match_case Grammar.Entry.e)),
- Gramext.Stoken ("", "|"))],
- Gramext.action
- (fun (a : 'match_case list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (l : 'a_list) _ _ (loc : int * int) ->
- (Qast.Node ("ExFun", [Qast.Loc; l]) : 'expr));
- [Gramext.Stoken ("", "let"); Gramext.Stoken ("", "module");
- Gramext.Snterm
- (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj
- (module_binding : 'module_binding Grammar.Entry.e));
- Gramext.Stoken ("", "in"); Gramext.Sself],
- Gramext.action
- (fun (e : 'expr) _ (mb : 'module_binding) (m : 'a_UIDENT) _ _
- (loc : int * int) ->
- (Qast.Node ("ExLmd", [Qast.Loc; m; mb; e]) : 'expr));
- [Gramext.Stoken ("", "let");
- Gramext.srules
- [[Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("", "rec")],
- Gramext.action
- (fun (x : string) (loc : int * int) ->
- (Qast.Str x : 'e__6))])],
- Gramext.action
- (fun (a : 'e__6 option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))];
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (let_binding : 'let_binding Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (a : 'let_binding list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "in"); Gramext.Sself],
- Gramext.action
- (fun (x : 'expr) _ (l : 'a_list) (r : 'a_opt) _ (loc : int * int) ->
- (Qast.Node ("ExLet", [Qast.Loc; o2b r; l; x]) : 'expr))];
- Some "where", None,
- [[Gramext.Sself; Gramext.Stoken ("", "where");
- Gramext.srules
- [[Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("", "rec")],
- Gramext.action
- (fun (x : string) (loc : int * int) ->
- (Qast.Str x : 'e__7))])],
- Gramext.action
- (fun (a : 'e__7 option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))];
- Gramext.Snterm
- (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e))],
- Gramext.action
- (fun (lb : 'let_binding) (rf : 'a_opt) _ (e : 'expr)
- (loc : int * int) ->
- (Qast.Node ("ExLet", [Qast.Loc; o2b rf; Qast.List [lb]; e]) :
- 'expr))];
- Some ":=", Some Gramext.NonA,
- [[Gramext.Sself; Gramext.Stoken ("", ":="); Gramext.Sself;
- Gramext.Snterm (Grammar.Entry.obj (dummy : 'dummy Grammar.Entry.e))],
- Gramext.action
- (fun _ (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node ("ExAss", [Qast.Loc; e1; e2]) : 'expr))];
- Some "||", Some Gramext.RightA,
- [[Gramext.Sself; Gramext.Stoken ("", "||"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "||"]);
- e1]);
- e2]) :
- 'expr))];
- Some "&&", Some Gramext.RightA,
- [[Gramext.Sself; Gramext.Stoken ("", "&&"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "&&"]);
- e1]);
- e2]) :
- 'expr))];
- Some "<", Some Gramext.LeftA,
- [[Gramext.Sself; Gramext.Stoken ("", "!="); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "!="]);
- e1]);
- e2]) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "=="); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "=="]);
- e1]);
- e2]) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "<>"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "<>"]);
- e1]);
- e2]) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "="); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "="]);
- e1]);
- e2]) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", ">="); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str ">="]);
- e1]);
- e2]) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "<="); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "<="]);
- e1]);
- e2]) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", ">"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str ">"]);
- e1]);
- e2]) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "<"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "<"]);
- e1]);
- e2]) :
- 'expr))];
- Some "^", Some Gramext.RightA,
- [[Gramext.Sself; Gramext.Stoken ("", "@"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "@"]);
- e1]);
- e2]) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "^"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "^"]);
- e1]);
- e2]) :
- 'expr))];
- Some "+", Some Gramext.LeftA,
- [[Gramext.Sself; Gramext.Stoken ("", "-."); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "-."]);
- e1]);
- e2]) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "+."); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "+."]);
- e1]);
- e2]) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "-"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "-"]);
- e1]);
- e2]) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "+"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "+"]);
- e1]);
- e2]) :
- 'expr))];
- Some "*", Some Gramext.LeftA,
- [[Gramext.Sself; Gramext.Stoken ("", "mod"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "mod"]);
- e1]);
- e2]) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "lxor"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node ("ExLid", [Qast.Loc; Qast.Str "lxor"]); e1]);
- e2]) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "lor"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "lor"]);
- e1]);
- e2]) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "land"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node ("ExLid", [Qast.Loc; Qast.Str "land"]); e1]);
- e2]) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "/."); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "/."]);
- e1]);
- e2]) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "*."); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "*."]);
- e1]);
- e2]) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "/"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "/"]);
- e1]);
- e2]) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "*"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "*"]);
- e1]);
- e2]) :
- 'expr))];
- Some "**", Some Gramext.RightA,
- [[Gramext.Sself; Gramext.Stoken ("", "lsr"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "lsr"]);
- e1]);
- e2]) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "lsl"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "lsl"]);
- e1]);
- e2]) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "asr"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "asr"]);
- e1]);
- e2]) :
- 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "**"); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc;
- Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "**"]);
- e1]);
- e2]) :
- 'expr))];
- Some "unary minus", Some Gramext.NonA,
- [[Gramext.Stoken ("", "-."); Gramext.Sself],
- Gramext.action
- (fun (e : 'expr) _ (loc : int * int) ->
- (mkumin Qast.Loc (Qast.Str "-.") e : 'expr));
- [Gramext.Stoken ("", "-"); Gramext.Sself],
- Gramext.action
- (fun (e : 'expr) _ (loc : int * int) ->
- (mkumin Qast.Loc (Qast.Str "-") e : 'expr))];
- Some "apply", Some Gramext.LeftA,
- [[Gramext.Stoken ("", "lazy"); Gramext.Sself],
- Gramext.action
- (fun (e : 'expr) _ (loc : int * int) ->
- (Qast.Node ("ExLaz", [Qast.Loc; e]) : 'expr));
- [Gramext.Stoken ("", "assert"); Gramext.Sself],
- Gramext.action
- (fun (e : 'expr) _ (loc : int * int) ->
- (mkassert Qast.Loc e : 'expr));
- [Gramext.Sself; Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) (e1 : 'expr) (loc : int * int) ->
- (Qast.Node ("ExApp", [Qast.Loc; e1; e2]) : 'expr))];
- Some ".", Some Gramext.LeftA,
- [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
- Gramext.action
- (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node ("ExAcc", [Qast.Loc; e1; e2]) : 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Stoken ("", "[");
- Gramext.Sself; Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (e2 : 'expr) _ _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node ("ExSte", [Qast.Loc; e1; e2]) : 'expr));
- [Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Stoken ("", "(");
- Gramext.Sself; Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (e2 : 'expr) _ _ (e1 : 'expr) (loc : int * int) ->
- (Qast.Node ("ExAre", [Qast.Loc; e1; e2]) : 'expr))];
- Some "~-", Some Gramext.NonA,
- [[Gramext.Stoken ("", "~-."); Gramext.Sself],
- Gramext.action
- (fun (e : 'expr) _ (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "~-."]);
- e]) :
- 'expr));
- [Gramext.Stoken ("", "~-"); Gramext.Sself],
- Gramext.action
- (fun (e : 'expr) _ (loc : int * int) ->
- (Qast.Node
- ("ExApp",
- [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "~-"]);
- e]) :
- 'expr))];
- Some "simple", None,
- [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
- Gramext.action (fun _ (e : 'expr) _ (loc : int * int) -> (e : 'expr));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ",");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)),
- Gramext.Stoken ("", ","))],
- Gramext.action
- (fun (a : 'expr list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (el : 'a_list) _ (e : 'expr) _ (loc : int * int) ->
- (Qast.Node ("ExTup", [Qast.Loc; Qast.Cons (e, el)]) : 'expr));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (t : 'ctyp) _ (e : 'expr) _ (loc : int * int) ->
- (Qast.Node ("ExTyc", [Qast.Loc; e; t]) : 'expr));
- [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ _ (loc : int * int) ->
- (Qast.Node ("ExUid", [Qast.Loc; Qast.Str "()"]) : 'expr));
- [Gramext.Stoken ("", "{"); Gramext.Stoken ("", "("); Gramext.Sself;
- Gramext.Stoken ("", ")"); Gramext.Stoken ("", "with");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (label_expr : 'label_expr Grammar.Entry.e)),
- Gramext.Stoken ("", ";"))],
- Gramext.action
- (fun (a : 'label_expr list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "}")],
- Gramext.action
- (fun _ (lel : 'a_list) _ _ (e : 'expr) _ _ (loc : int * int) ->
- (Qast.Node ("ExRec", [Qast.Loc; lel; Qast.Option (Some e)]) :
- 'expr));
- [Gramext.Stoken ("", "{");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (label_expr : 'label_expr Grammar.Entry.e)),
- Gramext.Stoken ("", ";"))],
- Gramext.action
- (fun (a : 'label_expr list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "}")],
- Gramext.action
- (fun _ (lel : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("ExRec", [Qast.Loc; lel; Qast.Option None]) : 'expr));
- [Gramext.Stoken ("", "[|");
- Gramext.srules
- [[Gramext.Slist0sep
- (Gramext.Snterm
- (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)),
- Gramext.Stoken ("", ";"))],
- Gramext.action
- (fun (a : 'expr list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "|]")],
- Gramext.action
- (fun _ (el : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("ExArr", [Qast.Loc; el]) : 'expr));
- [Gramext.Stoken ("", "[");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)),
- Gramext.Stoken ("", ";"))],
- Gramext.action
- (fun (a : 'expr list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Snterm
- (Grammar.Entry.obj (cons_expr_opt : 'cons_expr_opt Grammar.Entry.e));
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (last : 'cons_expr_opt) (el : 'a_list) _ (loc : int * int) ->
- (mklistexp Qast.Loc last el : 'expr));
- [Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ _ (loc : int * int) ->
- (Qast.Node ("ExUid", [Qast.Loc; Qast.Str "[]"]) : 'expr));
- [Gramext.Snterm
- (Grammar.Entry.obj (expr_ident : 'expr_ident Grammar.Entry.e))],
- Gramext.action (fun (i : 'expr_ident) (loc : int * int) -> (i : 'expr));
- [Gramext.Snterm (Grammar.Entry.obj (a_CHAR : 'a_CHAR Grammar.Entry.e))],
- Gramext.action
- (fun (s : 'a_CHAR) (loc : int * int) ->
- (Qast.Node ("ExChr", [Qast.Loc; s]) : 'expr));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e))],
- Gramext.action
- (fun (s : 'a_STRING) (loc : int * int) ->
- (Qast.Node ("ExStr", [Qast.Loc; s]) : 'expr));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_FLOAT : 'a_FLOAT Grammar.Entry.e))],
- Gramext.action
- (fun (s : 'a_FLOAT) (loc : int * int) ->
- (Qast.Node ("ExFlo", [Qast.Loc; s]) : 'expr));
- [Gramext.Snterm (Grammar.Entry.obj (a_INT : 'a_INT Grammar.Entry.e))],
- Gramext.action
- (fun (s : 'a_INT) (loc : int * int) ->
- (Qast.Node ("ExInt", [Qast.Loc; s]) : 'expr))]];
- Grammar.Entry.obj (cons_expr_opt : 'cons_expr_opt Grammar.Entry.e), None,
- [None, None,
- [[],
- Gramext.action
- (fun (loc : int * int) -> (Qast.Option None : 'cons_expr_opt));
- [Gramext.Stoken ("", "::");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (loc : int * int) ->
- (Qast.Option (Some e) : 'cons_expr_opt))]];
- Grammar.Entry.obj (dummy : 'dummy Grammar.Entry.e), None,
- [None, None,
- [[], Gramext.action (fun (loc : int * int) -> (() : 'dummy))]];
- Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) (loc : int * int) -> (Qast.List [e] : 'sequence));
- [Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (e : 'expr) (loc : int * int) -> (Qast.List [e] : 'sequence));
- [Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e));
- Gramext.Stoken ("", ";"); Gramext.Sself],
- Gramext.action
- (fun (el : 'sequence) _ (e : 'expr) (loc : int * int) ->
- (Qast.Cons (e, el) : 'sequence));
- [Gramext.Stoken ("", "let");
- Gramext.srules
- [[Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("", "rec")],
- Gramext.action
- (fun (x : string) (loc : int * int) ->
- (Qast.Str x : 'e__8))])],
- Gramext.action
- (fun (a : 'e__8 option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))];
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (let_binding : 'let_binding Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (a : 'let_binding list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.srules
- [[Gramext.Stoken ("", ";")],
- Gramext.action (fun (x : string) (loc : int * int) -> (x : 'e__9));
- [Gramext.Stoken ("", "in")],
- Gramext.action (fun (x : string) (loc : int * int) -> (x : 'e__9))];
- Gramext.Sself],
- Gramext.action
- (fun (el : 'sequence) _ (l : 'a_list) (rf : 'a_opt) _
- (loc : int * int) ->
- (Qast.List
- [Qast.Node
- ("ExLet", [Qast.Loc; o2b rf; l; mksequence Qast.Loc el])] :
- 'sequence))]];
- Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'fun_binding) (p : 'ipatt) (loc : int * int) ->
- (Qast.Tuple [p; e] : 'let_binding))]];
- Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e), None,
- [None, Some Gramext.RightA,
- [[Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) ->
- (Qast.Node ("ExTyc", [Qast.Loc; e; t]) : 'fun_binding));
- [Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (loc : int * int) -> (e : 'fun_binding));
- [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
- Gramext.Sself],
- Gramext.action
- (fun (e : 'fun_binding) (p : 'ipatt) (loc : int * int) ->
- (Qast.Node
- ("ExFun",
- [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]) :
- 'fun_binding))]];
- Grammar.Entry.obj (match_case : 'match_case Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj (as_patt_opt : 'as_patt_opt Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj (when_expr_opt : 'when_expr_opt Grammar.Entry.e));
- Gramext.Stoken ("", "->");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (w : 'when_expr_opt) (aso : 'as_patt_opt)
- (p : 'patt) (loc : int * int) ->
- (mkmatchcase Qast.Loc p aso w e : 'match_case))]];
- Grammar.Entry.obj (as_patt_opt : 'as_patt_opt Grammar.Entry.e), None,
- [None, None,
- [[],
- Gramext.action
- (fun (loc : int * int) -> (Qast.Option None : 'as_patt_opt));
- [Gramext.Stoken ("", "as");
- Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))],
- Gramext.action
- (fun (p : 'patt) _ (loc : int * int) ->
- (Qast.Option (Some p) : 'as_patt_opt))]];
- Grammar.Entry.obj (when_expr_opt : 'when_expr_opt Grammar.Entry.e), None,
- [None, None,
- [[],
- Gramext.action
- (fun (loc : int * int) -> (Qast.Option None : 'when_expr_opt));
- [Gramext.Stoken ("", "when");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (loc : int * int) ->
- (Qast.Option (Some e) : 'when_expr_opt))]];
- Grammar.Entry.obj (label_expr : 'label_expr Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (patt_label_ident : 'patt_label_ident Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'fun_binding) (i : 'patt_label_ident) (loc : int * int) ->
- (Qast.Tuple [i; e] : 'label_expr))]];
- Grammar.Entry.obj (expr_ident : 'expr_ident Grammar.Entry.e), None,
- [None, Some Gramext.RightA,
- [[Gramext.Snterm
- (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e));
- Gramext.Stoken ("", "."); Gramext.Sself],
- Gramext.action
- (fun (j : 'expr_ident) _ (i : 'a_UIDENT) (loc : int * int) ->
- (mkexprident Qast.Loc i j : 'expr_ident));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'a_UIDENT) (loc : int * int) ->
- (Qast.Node ("ExUid", [Qast.Loc; i]) : 'expr_ident));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'a_LIDENT) (loc : int * int) ->
- (Qast.Node ("ExLid", [Qast.Loc; i]) : 'expr_ident))]];
- Grammar.Entry.obj (fun_def : 'fun_def Grammar.Entry.e), None,
- [None, Some Gramext.RightA,
- [[Gramext.Stoken ("", "->");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action (fun (e : 'expr) _ (loc : int * int) -> (e : 'fun_def));
- [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
- Gramext.Sself],
- Gramext.action
- (fun (e : 'fun_def) (p : 'ipatt) (loc : int * int) ->
- (Qast.Node
- ("ExFun",
- [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]) :
- 'fun_def))]];
- Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), None,
- [None, Some Gramext.LeftA,
- [[Gramext.Sself; Gramext.Stoken ("", "|"); Gramext.Sself],
- Gramext.action
- (fun (p2 : 'patt) _ (p1 : 'patt) (loc : int * int) ->
- (Qast.Node ("PaOrp", [Qast.Loc; p1; p2]) : 'patt))];
- None, Some Gramext.NonA,
- [[Gramext.Sself; Gramext.Stoken ("", ".."); Gramext.Sself],
- Gramext.action
- (fun (p2 : 'patt) _ (p1 : 'patt) (loc : int * int) ->
- (Qast.Node ("PaRng", [Qast.Loc; p1; p2]) : 'patt))];
- None, Some Gramext.LeftA,
- [[Gramext.Sself; Gramext.Sself],
- Gramext.action
- (fun (p2 : 'patt) (p1 : 'patt) (loc : int * int) ->
- (Qast.Node ("PaApp", [Qast.Loc; p1; p2]) : 'patt))];
- None, Some Gramext.LeftA,
- [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
- Gramext.action
- (fun (p2 : 'patt) _ (p1 : 'patt) (loc : int * int) ->
- (Qast.Node ("PaAcc", [Qast.Loc; p1; p2]) : 'patt))];
- Some "simple", None,
- [[Gramext.Stoken ("", "_")],
- Gramext.action
- (fun _ (loc : int * int) ->
- (Qast.Node ("PaAny", [Qast.Loc]) : 'patt));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ",");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)),
- Gramext.Stoken ("", ","))],
- Gramext.action
- (fun (a : 'patt list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (pl : 'a_list) _ (p : 'patt) _ (loc : int * int) ->
- (Qast.Node ("PaTup", [Qast.Loc; Qast.Cons (p, pl)]) : 'patt));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "as");
- Gramext.Sself; Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (p2 : 'patt) _ (p : 'patt) _ (loc : int * int) ->
- (Qast.Node ("PaAli", [Qast.Loc; p; p2]) : 'patt));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (t : 'ctyp) _ (p : 'patt) _ (loc : int * int) ->
- (Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'patt));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
- Gramext.action (fun _ (p : 'patt) _ (loc : int * int) -> (p : 'patt));
- [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ _ (loc : int * int) ->
- (Qast.Node ("PaUid", [Qast.Loc; Qast.Str "()"]) : 'patt));
- [Gramext.Stoken ("", "{");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (label_patt : 'label_patt Grammar.Entry.e)),
- Gramext.Stoken ("", ";"))],
- Gramext.action
- (fun (a : 'label_patt list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "}")],
- Gramext.action
- (fun _ (lpl : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("PaRec", [Qast.Loc; lpl]) : 'patt));
- [Gramext.Stoken ("", "[|");
- Gramext.srules
- [[Gramext.Slist0sep
- (Gramext.Snterm
- (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)),
- Gramext.Stoken ("", ";"))],
- Gramext.action
- (fun (a : 'patt list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "|]")],
- Gramext.action
- (fun _ (pl : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("PaArr", [Qast.Loc; pl]) : 'patt));
- [Gramext.Stoken ("", "[");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)),
- Gramext.Stoken ("", ";"))],
- Gramext.action
- (fun (a : 'patt list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Snterm
- (Grammar.Entry.obj (cons_patt_opt : 'cons_patt_opt Grammar.Entry.e));
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (last : 'cons_patt_opt) (pl : 'a_list) _ (loc : int * int) ->
- (mklistpat Qast.Loc last pl : 'patt));
- [Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ _ (loc : int * int) ->
- (Qast.Node ("PaUid", [Qast.Loc; Qast.Str "[]"]) : 'patt));
- [Gramext.Stoken ("", "-");
- Gramext.Snterm
- (Grammar.Entry.obj (a_FLOAT : 'a_FLOAT Grammar.Entry.e))],
- Gramext.action
- (fun (s : 'a_FLOAT) _ (loc : int * int) ->
- (mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool false) s : 'patt));
- [Gramext.Stoken ("", "-");
- Gramext.Snterm (Grammar.Entry.obj (a_INT : 'a_INT Grammar.Entry.e))],
- Gramext.action
- (fun (s : 'a_INT) _ (loc : int * int) ->
- (mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool true) s : 'patt));
- [Gramext.Snterm (Grammar.Entry.obj (a_CHAR : 'a_CHAR Grammar.Entry.e))],
- Gramext.action
- (fun (s : 'a_CHAR) (loc : int * int) ->
- (Qast.Node ("PaChr", [Qast.Loc; s]) : 'patt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e))],
- Gramext.action
- (fun (s : 'a_STRING) (loc : int * int) ->
- (Qast.Node ("PaStr", [Qast.Loc; s]) : 'patt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_FLOAT : 'a_FLOAT Grammar.Entry.e))],
- Gramext.action
- (fun (s : 'a_FLOAT) (loc : int * int) ->
- (Qast.Node ("PaFlo", [Qast.Loc; s]) : 'patt));
- [Gramext.Snterm (Grammar.Entry.obj (a_INT : 'a_INT Grammar.Entry.e))],
- Gramext.action
- (fun (s : 'a_INT) (loc : int * int) ->
- (Qast.Node ("PaInt", [Qast.Loc; s]) : 'patt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (s : 'a_UIDENT) (loc : int * int) ->
- (Qast.Node ("PaUid", [Qast.Loc; s]) : 'patt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (s : 'a_LIDENT) (loc : int * int) ->
- (Qast.Node ("PaLid", [Qast.Loc; s]) : 'patt))]];
- Grammar.Entry.obj (cons_patt_opt : 'cons_patt_opt Grammar.Entry.e), None,
- [None, None,
- [[],
- Gramext.action
- (fun (loc : int * int) -> (Qast.Option None : 'cons_patt_opt));
- [Gramext.Stoken ("", "::");
- Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))],
- Gramext.action
- (fun (p : 'patt) _ (loc : int * int) ->
- (Qast.Option (Some p) : 'cons_patt_opt))]];
- Grammar.Entry.obj (label_patt : 'label_patt Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (patt_label_ident : 'patt_label_ident Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))],
- Gramext.action
- (fun (p : 'patt) _ (i : 'patt_label_ident) (loc : int * int) ->
- (Qast.Tuple [i; p] : 'label_patt))]];
- Grammar.Entry.obj (patt_label_ident : 'patt_label_ident Grammar.Entry.e),
- None,
- [None, Some Gramext.LeftA,
- [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
- Gramext.action
- (fun (p2 : 'patt_label_ident) _ (p1 : 'patt_label_ident)
- (loc : int * int) ->
- (Qast.Node ("PaAcc", [Qast.Loc; p1; p2]) : 'patt_label_ident))];
- Some "simple", Some Gramext.RightA,
- [[Gramext.Snterm
- (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'a_LIDENT) (loc : int * int) ->
- (Qast.Node ("PaLid", [Qast.Loc; i]) : 'patt_label_ident));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'a_UIDENT) (loc : int * int) ->
- (Qast.Node ("PaUid", [Qast.Loc; i]) : 'patt_label_ident))]];
- Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "_")],
- Gramext.action
- (fun _ (loc : int * int) ->
- (Qast.Node ("PaAny", [Qast.Loc]) : 'ipatt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (s : 'a_LIDENT) (loc : int * int) ->
- (Qast.Node ("PaLid", [Qast.Loc; s]) : 'ipatt));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ",");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)),
- Gramext.Stoken ("", ","))],
- Gramext.action
- (fun (a : 'ipatt list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (pl : 'a_list) _ (p : 'ipatt) _ (loc : int * int) ->
- (Qast.Node ("PaTup", [Qast.Loc; Qast.Cons (p, pl)]) : 'ipatt));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "as");
- Gramext.Sself; Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (p2 : 'ipatt) _ (p : 'ipatt) _ (loc : int * int) ->
- (Qast.Node ("PaAli", [Qast.Loc; p; p2]) : 'ipatt));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (t : 'ctyp) _ (p : 'ipatt) _ (loc : int * int) ->
- (Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'ipatt));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
- Gramext.action (fun _ (p : 'ipatt) _ (loc : int * int) -> (p : 'ipatt));
- [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ _ (loc : int * int) ->
- (Qast.Node ("PaUid", [Qast.Loc; Qast.Str "()"]) : 'ipatt));
- [Gramext.Stoken ("", "{");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (label_ipatt : 'label_ipatt Grammar.Entry.e)),
- Gramext.Stoken ("", ";"))],
- Gramext.action
- (fun (a : 'label_ipatt list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "}")],
- Gramext.action
- (fun _ (lpl : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("PaRec", [Qast.Loc; lpl]) : 'ipatt))]];
- Grammar.Entry.obj (label_ipatt : 'label_ipatt Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (patt_label_ident : 'patt_label_ident Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))],
- Gramext.action
- (fun (p : 'ipatt) _ (i : 'patt_label_ident) (loc : int * int) ->
- (Qast.Tuple [i; p] : 'label_ipatt))]];
- Grammar.Entry.obj (type_declaration : 'type_declaration Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (type_patt : 'type_patt Grammar.Entry.e));
- Gramext.srules
- [[Gramext.Slist0
- (Gramext.Snterm
- (Grammar.Entry.obj
- (type_parameter : 'type_parameter Grammar.Entry.e)))],
- Gramext.action
- (fun (a : 'type_parameter list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.srules
- [[Gramext.Slist0
- (Gramext.Snterm
- (Grammar.Entry.obj
- (constrain : 'constrain Grammar.Entry.e)))],
- Gramext.action
- (fun (a : 'constrain list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]],
- Gramext.action
- (fun (cl : 'a_list) (tk : 'ctyp) _ (tpl : 'a_list) (n : 'type_patt)
- (loc : int * int) ->
- (Qast.Tuple [n; tpl; tk; cl] : 'type_declaration))]];
- Grammar.Entry.obj (type_patt : 'type_patt Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (n : 'a_LIDENT) (loc : int * int) ->
- (Qast.Tuple [Qast.Loc; n] : 'type_patt))]];
- Grammar.Entry.obj (constrain : 'constrain Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "constraint");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (loc : int * int) ->
- (Qast.Tuple [t1; t2] : 'constrain))]];
- Grammar.Entry.obj (type_parameter : 'type_parameter Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("", "-"); Gramext.Stoken ("", "'");
- Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'ident) _ _ (loc : int * int) ->
- (Qast.Tuple [i; Qast.Tuple [Qast.Bool false; Qast.Bool true]] :
- 'type_parameter));
- [Gramext.Stoken ("", "+"); Gramext.Stoken ("", "'");
- Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'ident) _ _ (loc : int * int) ->
- (Qast.Tuple [i; Qast.Tuple [Qast.Bool true; Qast.Bool false]] :
- 'type_parameter));
- [Gramext.Stoken ("", "'");
- Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'ident) _ (loc : int * int) ->
- (Qast.Tuple [i; Qast.Tuple [Qast.Bool false; Qast.Bool false]] :
- 'type_parameter))]];
- Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), None,
- [None, Some Gramext.LeftA,
- [[Gramext.Sself; Gramext.Stoken ("", "=="); Gramext.Sself],
- Gramext.action
- (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (loc : int * int) ->
- (Qast.Node ("TyMan", [Qast.Loc; t1; t2]) : 'ctyp))];
- None, Some Gramext.LeftA,
- [[Gramext.Sself; Gramext.Stoken ("", "as"); Gramext.Sself],
- Gramext.action
- (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (loc : int * int) ->
- (Qast.Node ("TyAli", [Qast.Loc; t1; t2]) : 'ctyp))];
- None, Some Gramext.LeftA,
- [[Gramext.Stoken ("", "!");
- Gramext.srules
- [[Gramext.Slist1
- (Gramext.Snterm
- (Grammar.Entry.obj (typevar : 'typevar Grammar.Entry.e)))],
- Gramext.action
- (fun (a : 'typevar list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "."); Gramext.Sself],
- Gramext.action
- (fun (t : 'ctyp) _ (pl : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("TyPol", [Qast.Loc; pl; t]) : 'ctyp))];
- Some "arrow", Some Gramext.RightA,
- [[Gramext.Sself; Gramext.Stoken ("", "->"); Gramext.Sself],
- Gramext.action
- (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (loc : int * int) ->
- (Qast.Node ("TyArr", [Qast.Loc; t1; t2]) : 'ctyp))];
- Some "label", Some Gramext.NonA,
- [[Gramext.Snterm
- (Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e));
- Gramext.Sself],
- Gramext.action
- (fun (t : 'ctyp) (i : 'a_OPTLABEL) (loc : int * int) ->
- (Qast.Node ("TyOlb", [Qast.Loc; i; t]) : 'ctyp));
- [Gramext.Snterm
- (Grammar.Entry.obj
- (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e));
- Gramext.Stoken ("", ":"); Gramext.Sself],
- Gramext.action
- (fun (t : 'ctyp) _ (i : 'a_QUESTIONIDENT) (loc : int * int) ->
- (Qast.Node ("TyOlb", [Qast.Loc; i; t]) : 'ctyp));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e));
- Gramext.Sself],
- Gramext.action
- (fun (t : 'ctyp) (i : 'a_LABEL) (loc : int * int) ->
- (Qast.Node ("TyLab", [Qast.Loc; i; t]) : 'ctyp));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e));
- Gramext.Stoken ("", ":"); Gramext.Sself],
- Gramext.action
- (fun (t : 'ctyp) _ (i : 'a_TILDEIDENT) (loc : int * int) ->
- (Qast.Node ("TyLab", [Qast.Loc; i; t]) : 'ctyp))];
- None, Some Gramext.LeftA,
- [[Gramext.Sself; Gramext.Sself],
- Gramext.action
- (fun (t2 : 'ctyp) (t1 : 'ctyp) (loc : int * int) ->
- (Qast.Node ("TyApp", [Qast.Loc; t1; t2]) : 'ctyp))];
- None, Some Gramext.LeftA,
- [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
- Gramext.action
- (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (loc : int * int) ->
- (Qast.Node ("TyAcc", [Qast.Loc; t1; t2]) : 'ctyp))];
- Some "simple", None,
- [[Gramext.Stoken ("", "{");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (label_declaration : 'label_declaration Grammar.Entry.e)),
- Gramext.Stoken ("", ";"))],
- Gramext.action
- (fun (a : 'label_declaration list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "}")],
- Gramext.action
- (fun _ (ldl : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("TyRec", [Qast.Loc; Qast.Bool false; ldl]) : 'ctyp));
- [Gramext.Stoken ("", "[");
- Gramext.srules
- [[Gramext.Slist0sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (constructor_declaration :
- 'constructor_declaration Grammar.Entry.e)),
- Gramext.Stoken ("", "|"))],
- Gramext.action
- (fun (a : 'constructor_declaration list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (cdl : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("TySum", [Qast.Loc; Qast.Bool false; cdl]) : 'ctyp));
- [Gramext.Stoken ("", "private"); Gramext.Stoken ("", "{");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (label_declaration : 'label_declaration Grammar.Entry.e)),
- Gramext.Stoken ("", ";"))],
- Gramext.action
- (fun (a : 'label_declaration list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "}")],
- Gramext.action
- (fun _ (ldl : 'a_list) _ _ (loc : int * int) ->
- (Qast.Node ("TyRec", [Qast.Loc; Qast.Bool true; ldl]) : 'ctyp));
- [Gramext.Stoken ("", "private"); Gramext.Stoken ("", "[");
- Gramext.srules
- [[Gramext.Slist0sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (constructor_declaration :
- 'constructor_declaration Grammar.Entry.e)),
- Gramext.Stoken ("", "|"))],
- Gramext.action
- (fun (a : 'constructor_declaration list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (cdl : 'a_list) _ _ (loc : int * int) ->
- (Qast.Node ("TySum", [Qast.Loc; Qast.Bool true; cdl]) : 'ctyp));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
- Gramext.action (fun _ (t : 'ctyp) _ (loc : int * int) -> (t : 'ctyp));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "*");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)),
- Gramext.Stoken ("", "*"))],
- Gramext.action
- (fun (a : 'ctyp list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (tl : 'a_list) _ (t : 'ctyp) _ (loc : int * int) ->
- (Qast.Node ("TyTup", [Qast.Loc; Qast.Cons (t, tl)]) : 'ctyp));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'a_UIDENT) (loc : int * int) ->
- (Qast.Node ("TyUid", [Qast.Loc; i]) : 'ctyp));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'a_LIDENT) (loc : int * int) ->
- (Qast.Node ("TyLid", [Qast.Loc; i]) : 'ctyp));
- [Gramext.Stoken ("", "_")],
- Gramext.action
- (fun _ (loc : int * int) ->
- (Qast.Node ("TyAny", [Qast.Loc]) : 'ctyp));
- [Gramext.Stoken ("", "'");
- Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'ident) _ (loc : int * int) ->
- (Qast.Node ("TyQuo", [Qast.Loc; i]) : 'ctyp))]];
- Grammar.Entry.obj
- (constructor_declaration : 'constructor_declaration Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (ci : 'a_UIDENT) (loc : int * int) ->
- (Qast.Tuple [Qast.Loc; ci; Qast.List []] :
- 'constructor_declaration));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e));
- Gramext.Stoken ("", "of");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (a : 'ctyp list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]],
- Gramext.action
- (fun (cal : 'a_list) _ (ci : 'a_UIDENT) (loc : int * int) ->
- (Qast.Tuple [Qast.Loc; ci; cal] : 'constructor_declaration))]];
- Grammar.Entry.obj
- (label_declaration : 'label_declaration Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.srules
- [[Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("", "mutable")],
- Gramext.action
- (fun (x : string) (loc : int * int) ->
- (Qast.Str x : 'e__10))])],
- Gramext.action
- (fun (a : 'e__10 option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))];
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'ctyp) (mf : 'a_opt) _ (i : 'a_LIDENT) (loc : int * int) ->
- (Qast.Tuple [Qast.Loc; i; o2b mf; t] : 'label_declaration))]];
- Grammar.Entry.obj (ident : 'ident Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))],
- Gramext.action (fun (i : 'a_UIDENT) (loc : int * int) -> (i : 'ident));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'a_LIDENT) (loc : int * int) -> (i : 'ident))]];
- Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e), None,
- [None, Some Gramext.RightA,
- [[Gramext.Snterm
- (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e));
- Gramext.Stoken ("", "."); Gramext.Sself],
- Gramext.action
- (fun (j : 'mod_ident) _ (i : 'a_UIDENT) (loc : int * int) ->
- (Qast.Cons (i, j) : 'mod_ident));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'a_LIDENT) (loc : int * int) ->
- (Qast.List [i] : 'mod_ident));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'a_UIDENT) (loc : int * int) ->
- (Qast.List [i] : 'mod_ident))]];
- Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "class"); Gramext.Stoken ("", "type");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (class_type_declaration :
- 'class_type_declaration Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (a : 'class_type_declaration list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]],
- Gramext.action
- (fun (ctd : 'a_list) _ _ (loc : int * int) ->
- (Qast.Node ("StClt", [Qast.Loc; ctd]) : 'str_item));
- [Gramext.Stoken ("", "class");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (class_declaration : 'class_declaration Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (a : 'class_declaration list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]],
- Gramext.action
- (fun (cd : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("StCls", [Qast.Loc; cd]) : 'str_item))]];
- Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "class"); Gramext.Stoken ("", "type");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (class_type_declaration :
- 'class_type_declaration Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (a : 'class_type_declaration list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]],
- Gramext.action
- (fun (ctd : 'a_list) _ _ (loc : int * int) ->
- (Qast.Node ("SgClt", [Qast.Loc; ctd]) : 'sig_item));
- [Gramext.Stoken ("", "class");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (class_description : 'class_description Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (a : 'class_description list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]],
- Gramext.action
- (fun (cd : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("SgCls", [Qast.Loc; cd]) : 'sig_item))]];
- Grammar.Entry.obj
- (class_declaration : 'class_declaration Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.srules
- [[Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("", "virtual")],
- Gramext.action
- (fun (x : string) (loc : int * int) ->
- (Qast.Str x : 'e__11))])],
- Gramext.action
- (fun (a : 'e__11 option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))];
- Gramext.Snterm
- (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj
- (class_type_parameters : 'class_type_parameters Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj
- (class_fun_binding : 'class_fun_binding Grammar.Entry.e))],
- Gramext.action
- (fun (cfb : 'class_fun_binding) (ctp : 'class_type_parameters)
- (i : 'a_LIDENT) (vf : 'a_opt) (loc : int * int) ->
- (Qast.Record
- ["ciLoc", Qast.Loc; "ciVir", o2b vf; "ciPrm", ctp; "ciNam", i;
- "ciExp", cfb] :
- 'class_declaration))]];
- Grammar.Entry.obj
- (class_fun_binding : 'class_fun_binding Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
- Gramext.Sself],
- Gramext.action
- (fun (cfb : 'class_fun_binding) (p : 'ipatt) (loc : int * int) ->
- (Qast.Node ("CeFun", [Qast.Loc; p; cfb]) : 'class_fun_binding));
- [Gramext.Stoken ("", ":");
- Gramext.Snterm
- (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm
- (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))],
- Gramext.action
- (fun (ce : 'class_expr) _ (ct : 'class_type) _ (loc : int * int) ->
- (Qast.Node ("CeTyc", [Qast.Loc; ce; ct]) : 'class_fun_binding));
- [Gramext.Stoken ("", "=");
- Gramext.Snterm
- (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))],
- Gramext.action
- (fun (ce : 'class_expr) _ (loc : int * int) ->
- (ce : 'class_fun_binding))]];
- Grammar.Entry.obj
- (class_type_parameters : 'class_type_parameters Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("", "[");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (type_parameter : 'type_parameter Grammar.Entry.e)),
- Gramext.Stoken ("", ","))],
- Gramext.action
- (fun (a : 'type_parameter list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (tpl : 'a_list) _ (loc : int * int) ->
- (Qast.Tuple [Qast.Loc; tpl] : 'class_type_parameters));
- [],
- Gramext.action
- (fun (loc : int * int) ->
- (Qast.Tuple [Qast.Loc; Qast.List []] : 'class_type_parameters))]];
- Grammar.Entry.obj (class_fun_def : 'class_fun_def Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "->");
- Gramext.Snterm
- (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))],
- Gramext.action
- (fun (ce : 'class_expr) _ (loc : int * int) -> (ce : 'class_fun_def));
- [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
- Gramext.Sself],
- Gramext.action
- (fun (ce : 'class_fun_def) (p : 'ipatt) (loc : int * int) ->
- (Qast.Node ("CeFun", [Qast.Loc; p; ce]) : 'class_fun_def))]];
- Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e), None,
- [Some "top", None,
- [[Gramext.Stoken ("", "let");
- Gramext.srules
- [[Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("", "rec")],
- Gramext.action
- (fun (x : string) (loc : int * int) ->
- (Qast.Str x : 'e__12))])],
- Gramext.action
- (fun (a : 'e__12 option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))];
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (let_binding : 'let_binding Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (a : 'let_binding list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "in"); Gramext.Sself],
- Gramext.action
- (fun (ce : 'class_expr) _ (lb : 'a_list) (rf : 'a_opt) _
- (loc : int * int) ->
- (Qast.Node ("CeLet", [Qast.Loc; o2b rf; lb; ce]) : 'class_expr));
- [Gramext.Stoken ("", "fun");
- Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj
- (class_fun_def : 'class_fun_def Grammar.Entry.e))],
- Gramext.action
- (fun (ce : 'class_fun_def) (p : 'ipatt) _ (loc : int * int) ->
- (Qast.Node ("CeFun", [Qast.Loc; p; ce]) : 'class_expr))];
- Some "apply", Some Gramext.NonA,
- [[Gramext.Sself;
- Gramext.Snterml
- (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), "label")],
- Gramext.action
- (fun (e : 'expr) (ce : 'class_expr) (loc : int * int) ->
- (Qast.Node ("CeApp", [Qast.Loc; ce; e]) : 'class_expr))];
- Some "simple", None,
- [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (ce : 'class_expr) _ (loc : int * int) -> (ce : 'class_expr));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":");
- Gramext.Snterm
- (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (ct : 'class_type) _ (ce : 'class_expr) _ (loc : int * int) ->
- (Qast.Node ("CeTyc", [Qast.Loc; ce; ct]) : 'class_expr));
- [Gramext.Stoken ("", "object");
- Gramext.srules
- [[Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj
- (class_self_patt : 'class_self_patt Grammar.Entry.e)))],
- Gramext.action
- (fun (a : 'class_self_patt option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))];
- Gramext.Snterm
- (Grammar.Entry.obj
- (class_structure : 'class_structure Grammar.Entry.e));
- Gramext.Stoken ("", "end")],
- Gramext.action
- (fun _ (cf : 'class_structure) (cspo : 'a_opt) _ (loc : int * int) ->
- (Qast.Node ("CeStr", [Qast.Loc; cspo; cf]) : 'class_expr));
- [Gramext.Snterm
- (Grammar.Entry.obj
- (class_longident : 'class_longident Grammar.Entry.e))],
- Gramext.action
- (fun (ci : 'class_longident) (loc : int * int) ->
- (Qast.Node ("CeCon", [Qast.Loc; ci; Qast.List []]) : 'class_expr));
- [Gramext.Snterm
- (Grammar.Entry.obj
- (class_longident : 'class_longident Grammar.Entry.e));
- Gramext.Stoken ("", "[");
- Gramext.srules
- [[Gramext.Slist0sep
- (Gramext.Snterm
- (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)),
- Gramext.Stoken ("", ","))],
- Gramext.action
- (fun (a : 'ctyp list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (ctcl : 'a_list) _ (ci : 'class_longident) (loc : int * int) ->
- (Qast.Node ("CeCon", [Qast.Loc; ci; ctcl]) : 'class_expr))]];
- Grammar.Entry.obj (class_structure : 'class_structure Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.srules
- [[Gramext.Slist0
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (class_str_item : 'class_str_item Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (cf : 'class_str_item) (loc : int * int) ->
- (cf : 'e__13))])],
- Gramext.action
- (fun (a : 'e__13 list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]],
- Gramext.action
- (fun (cf : 'a_list) (loc : int * int) -> (cf : 'class_structure))]];
- Grammar.Entry.obj (class_self_patt : 'class_self_patt Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("", "(");
- Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (t : 'ctyp) _ (p : 'patt) _ (loc : int * int) ->
- (Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'class_self_patt));
- [Gramext.Stoken ("", "(");
- Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (p : 'patt) _ (loc : int * int) -> (p : 'class_self_patt))]];
- Grammar.Entry.obj (class_str_item : 'class_str_item Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("", "initializer");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (se : 'expr) _ (loc : int * int) ->
- (Qast.Node ("CrIni", [Qast.Loc; se]) : 'class_str_item));
- [Gramext.Stoken ("", "type");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (loc : int * int) ->
- (Qast.Node ("CrCtr", [Qast.Loc; t1; t2]) : 'class_str_item));
- [Gramext.Stoken ("", "method");
- Gramext.srules
- [[Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("", "private")],
- Gramext.action
- (fun (x : string) (loc : int * int) ->
- (Qast.Str x : 'e__17))])],
- Gramext.action
- (fun (a : 'e__17 option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))];
- Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
- Gramext.srules
- [[Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj (polyt : 'polyt Grammar.Entry.e)))],
- Gramext.action
- (fun (a : 'polyt option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))];
- Gramext.Snterm
- (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'fun_binding) (topt : 'a_opt) (l : 'label) (pf : 'a_opt) _
- (loc : int * int) ->
- (Qast.Node ("CrMth", [Qast.Loc; l; o2b pf; e; topt]) :
- 'class_str_item));
- [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual");
- Gramext.srules
- [[Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("", "private")],
- Gramext.action
- (fun (x : string) (loc : int * int) ->
- (Qast.Str x : 'e__16))])],
- Gramext.action
- (fun (a : 'e__16 option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))];
- Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'ctyp) _ (l : 'label) (pf : 'a_opt) _ _ (loc : int * int) ->
- (Qast.Node ("CrVir", [Qast.Loc; l; o2b pf; t]) : 'class_str_item));
- [Gramext.Stoken ("", "value");
- Gramext.srules
- [[Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("", "mutable")],
- Gramext.action
- (fun (x : string) (loc : int * int) ->
- (Qast.Str x : 'e__15))])],
- Gramext.action
- (fun (a : 'e__15 option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))];
- Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj
- (cvalue_binding : 'cvalue_binding Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'cvalue_binding) (lab : 'label) (mf : 'a_opt) _
- (loc : int * int) ->
- (Qast.Node ("CrVal", [Qast.Loc; lab; o2b mf; e]) :
- 'class_str_item));
- [Gramext.Stoken ("", "inherit");
- Gramext.Snterm
- (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e));
- Gramext.srules
- [[Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj
- (as_lident : 'as_lident Grammar.Entry.e)))],
- Gramext.action
- (fun (a : 'as_lident option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]],
- Gramext.action
- (fun (pb : 'a_opt) (ce : 'class_expr) _ (loc : int * int) ->
- (Qast.Node ("CrInh", [Qast.Loc; ce; pb]) : 'class_str_item));
- [Gramext.Stoken ("", "declare");
- Gramext.srules
- [[Gramext.Slist0
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (class_str_item : 'class_str_item Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (s : 'class_str_item) (loc : int * int) ->
- (s : 'e__14))])],
- Gramext.action
- (fun (a : 'e__14 list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "end")],
- Gramext.action
- (fun _ (st : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("CrDcl", [Qast.Loc; st]) : 'class_str_item))]];
- Grammar.Entry.obj (as_lident : 'as_lident Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "as");
- Gramext.Snterm
- (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'a_LIDENT) _ (loc : int * int) -> (i : 'as_lident))]];
- Grammar.Entry.obj (polyt : 'polyt Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action (fun (t : 'ctyp) _ (loc : int * int) -> (t : 'polyt))]];
- Grammar.Entry.obj (cvalue_binding : 'cvalue_binding Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("", ":>");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) ->
- (Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option None; t]) :
- 'cvalue_binding));
- [Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", ":>");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (t2 : 'ctyp) _ (t : 'ctyp) _ (loc : int * int) ->
- (Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option (Some t); t2]) :
- 'cvalue_binding));
- [Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) ->
- (Qast.Node ("ExTyc", [Qast.Loc; e; t]) : 'cvalue_binding));
- [Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (loc : int * int) -> (e : 'cvalue_binding))]];
- Grammar.Entry.obj (label : 'label Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'a_LIDENT) (loc : int * int) -> (i : 'label))]];
- Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "object");
- Gramext.srules
- [[Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj
- (class_self_type : 'class_self_type Grammar.Entry.e)))],
- Gramext.action
- (fun (a : 'class_self_type option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))];
- Gramext.srules
- [[Gramext.Slist0
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (class_sig_item : 'class_sig_item Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (csf : 'class_sig_item) (loc : int * int) ->
- (csf : 'e__18))])],
- Gramext.action
- (fun (a : 'e__18 list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "end")],
- Gramext.action
- (fun _ (csf : 'a_list) (cst : 'a_opt) _ (loc : int * int) ->
- (Qast.Node ("CtSig", [Qast.Loc; cst; csf]) : 'class_type));
- [Gramext.Snterm
- (Grammar.Entry.obj
- (clty_longident : 'clty_longident Grammar.Entry.e))],
- Gramext.action
- (fun (id : 'clty_longident) (loc : int * int) ->
- (Qast.Node ("CtCon", [Qast.Loc; id; Qast.List []]) : 'class_type));
- [Gramext.Snterm
- (Grammar.Entry.obj
- (clty_longident : 'clty_longident Grammar.Entry.e));
- Gramext.Stoken ("", "[");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)),
- Gramext.Stoken ("", ","))],
- Gramext.action
- (fun (a : 'ctyp list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (tl : 'a_list) _ (id : 'clty_longident) (loc : int * int) ->
- (Qast.Node ("CtCon", [Qast.Loc; id; tl]) : 'class_type));
- [Gramext.Stoken ("", "[");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", "]"); Gramext.Stoken ("", "->"); Gramext.Sself],
- Gramext.action
- (fun (ct : 'class_type) _ _ (t : 'ctyp) _ (loc : int * int) ->
- (Qast.Node ("CtFun", [Qast.Loc; t; ct]) : 'class_type))]];
- Grammar.Entry.obj (class_self_type : 'class_self_type Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("", "(");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (t : 'ctyp) _ (loc : int * int) -> (t : 'class_self_type))]];
- Grammar.Entry.obj (class_sig_item : 'class_sig_item Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("", "type");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (loc : int * int) ->
- (Qast.Node ("CgCtr", [Qast.Loc; t1; t2]) : 'class_sig_item));
- [Gramext.Stoken ("", "method");
- Gramext.srules
- [[Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("", "private")],
- Gramext.action
- (fun (x : string) (loc : int * int) ->
- (Qast.Str x : 'e__22))])],
- Gramext.action
- (fun (a : 'e__22 option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))];
- Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'ctyp) _ (l : 'label) (pf : 'a_opt) _ (loc : int * int) ->
- (Qast.Node ("CgMth", [Qast.Loc; l; o2b pf; t]) : 'class_sig_item));
- [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual");
- Gramext.srules
- [[Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("", "private")],
- Gramext.action
- (fun (x : string) (loc : int * int) ->
- (Qast.Str x : 'e__21))])],
- Gramext.action
- (fun (a : 'e__21 option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))];
- Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'ctyp) _ (l : 'label) (pf : 'a_opt) _ _ (loc : int * int) ->
- (Qast.Node ("CgVir", [Qast.Loc; l; o2b pf; t]) : 'class_sig_item));
- [Gramext.Stoken ("", "value");
- Gramext.srules
- [[Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("", "mutable")],
- Gramext.action
- (fun (x : string) (loc : int * int) ->
- (Qast.Str x : 'e__20))])],
- Gramext.action
- (fun (a : 'e__20 option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))];
- Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'ctyp) _ (l : 'label) (mf : 'a_opt) _ (loc : int * int) ->
- (Qast.Node ("CgVal", [Qast.Loc; l; o2b mf; t]) : 'class_sig_item));
- [Gramext.Stoken ("", "inherit");
- Gramext.Snterm
- (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))],
- Gramext.action
- (fun (cs : 'class_type) _ (loc : int * int) ->
- (Qast.Node ("CgInh", [Qast.Loc; cs]) : 'class_sig_item));
- [Gramext.Stoken ("", "declare");
- Gramext.srules
- [[Gramext.Slist0
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (class_sig_item : 'class_sig_item Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (s : 'class_sig_item) (loc : int * int) ->
- (s : 'e__19))])],
- Gramext.action
- (fun (a : 'e__19 list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "end")],
- Gramext.action
- (fun _ (st : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("CgDcl", [Qast.Loc; st]) : 'class_sig_item))]];
- Grammar.Entry.obj
- (class_description : 'class_description Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.srules
- [[Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("", "virtual")],
- Gramext.action
- (fun (x : string) (loc : int * int) ->
- (Qast.Str x : 'e__23))])],
- Gramext.action
- (fun (a : 'e__23 option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))];
- Gramext.Snterm
- (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj
- (class_type_parameters : 'class_type_parameters Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm
- (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))],
- Gramext.action
- (fun (ct : 'class_type) _ (ctp : 'class_type_parameters)
- (n : 'a_LIDENT) (vf : 'a_opt) (loc : int * int) ->
- (Qast.Record
- ["ciLoc", Qast.Loc; "ciVir", o2b vf; "ciPrm", ctp; "ciNam", n;
- "ciExp", ct] :
- 'class_description))]];
- Grammar.Entry.obj
- (class_type_declaration : 'class_type_declaration Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.srules
- [[Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("", "virtual")],
- Gramext.action
- (fun (x : string) (loc : int * int) ->
- (Qast.Str x : 'e__24))])],
- Gramext.action
- (fun (a : 'e__24 option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))];
- Gramext.Snterm
- (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj
- (class_type_parameters : 'class_type_parameters Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm
- (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))],
- Gramext.action
- (fun (cs : 'class_type) _ (ctp : 'class_type_parameters)
- (n : 'a_LIDENT) (vf : 'a_opt) (loc : int * int) ->
- (Qast.Record
- ["ciLoc", Qast.Loc; "ciVir", o2b vf; "ciPrm", ctp; "ciNam", n;
- "ciExp", cs] :
- 'class_type_declaration))]];
- Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
- Some (Gramext.Level "apply"),
- [None, Some Gramext.LeftA,
- [[Gramext.Stoken ("", "new");
- Gramext.Snterm
- (Grammar.Entry.obj
- (class_longident : 'class_longident Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'class_longident) _ (loc : int * int) ->
- (Qast.Node ("ExNew", [Qast.Loc; i]) : 'expr))]];
- Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
- Some (Gramext.Level "."),
- [None, None,
- [[Gramext.Sself; Gramext.Stoken ("", "#");
- Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e))],
- Gramext.action
- (fun (lab : 'label) _ (e : 'expr) (loc : int * int) ->
- (Qast.Node ("ExSnd", [Qast.Loc; e; lab]) : 'expr))]];
- Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("", "{<");
- Gramext.srules
- [[Gramext.Slist0sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (field_expr : 'field_expr Grammar.Entry.e)),
- Gramext.Stoken ("", ";"))],
- Gramext.action
- (fun (a : 'field_expr list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", ">}")],
- Gramext.action
- (fun _ (fel : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("ExOvr", [Qast.Loc; fel]) : 'expr));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":>");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (t : 'ctyp) _ (e : 'expr) _ (loc : int * int) ->
- (Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option None; t]) : 'expr));
- [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", ":>");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (t2 : 'ctyp) _ (t : 'ctyp) _ (e : 'expr) _ (loc : int * int) ->
- (Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option (Some t); t2]) :
- 'expr))]];
- Grammar.Entry.obj (field_expr : 'field_expr Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
- Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (l : 'label) (loc : int * int) ->
- (Qast.Tuple [l; e] : 'field_expr))]];
- Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("", "<");
- Gramext.srules
- [[Gramext.Slist0sep
- (Gramext.Snterm
- (Grammar.Entry.obj (field : 'field Grammar.Entry.e)),
- Gramext.Stoken ("", ";"))],
- Gramext.action
- (fun (a : 'field list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.srules
- [[Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("", "..")],
- Gramext.action
- (fun (x : string) (loc : int * int) ->
- (Qast.Str x : 'e__25))])],
- Gramext.action
- (fun (a : 'e__25 option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))];
- Gramext.Stoken ("", ">")],
- Gramext.action
- (fun _ (v : 'a_opt) (ml : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("TyObj", [Qast.Loc; ml; o2b v]) : 'ctyp));
- [Gramext.Stoken ("", "#");
- Gramext.Snterm
- (Grammar.Entry.obj
- (class_longident : 'class_longident Grammar.Entry.e))],
- Gramext.action
- (fun (id : 'class_longident) _ (loc : int * int) ->
- (Qast.Node ("TyCls", [Qast.Loc; id]) : 'ctyp))]];
- Grammar.Entry.obj (field : 'field Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'ctyp) _ (lab : 'a_LIDENT) (loc : int * int) ->
- (Qast.Tuple [lab; t] : 'field))]];
- Grammar.Entry.obj (typevar : 'typevar Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "'");
- Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'ident) _ (loc : int * int) -> (i : 'typevar))]];
- Grammar.Entry.obj (clty_longident : 'clty_longident Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'a_LIDENT) (loc : int * int) ->
- (Qast.List [i] : 'clty_longident));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e));
- Gramext.Stoken ("", "."); Gramext.Sself],
- Gramext.action
- (fun (l : 'clty_longident) _ (m : 'a_UIDENT) (loc : int * int) ->
- (Qast.Cons (m, l) : 'clty_longident))]];
- Grammar.Entry.obj (class_longident : 'class_longident Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'a_LIDENT) (loc : int * int) ->
- (Qast.List [i] : 'class_longident));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e));
- Gramext.Stoken ("", "."); Gramext.Sself],
- Gramext.action
- (fun (l : 'class_longident) _ (m : 'a_UIDENT) (loc : int * int) ->
- (Qast.Cons (m, l) : 'class_longident))]];
- Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("", "["); Gramext.Stoken ("", "<");
- Gramext.Snterm
- (Grammar.Entry.obj
- (row_field_list : 'row_field_list Grammar.Entry.e));
- Gramext.Stoken ("", ">");
- Gramext.srules
- [[Gramext.Slist1
- (Gramext.Snterm
- (Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e)))],
- Gramext.action
- (fun (a : 'name_tag list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (ntl : 'a_list) _ (rfl : 'row_field_list) _ _
- (loc : int * int) ->
- (Qast.Node
- ("TyVrn",
- [Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))]) :
- 'ctyp));
- [Gramext.Stoken ("", "["); Gramext.Stoken ("", "<");
- Gramext.Snterm
- (Grammar.Entry.obj
- (row_field_list : 'row_field_list Grammar.Entry.e));
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) ->
- (Qast.Node
- ("TyVrn",
- [Qast.Loc; rfl;
- Qast.Option (Some (Qast.Option (Some (Qast.List []))))]) :
- 'ctyp));
- [Gramext.Stoken ("", "["); Gramext.Stoken ("", ">");
- Gramext.Snterm
- (Grammar.Entry.obj
- (row_field_list : 'row_field_list Grammar.Entry.e));
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) ->
- (Qast.Node
- ("TyVrn",
- [Qast.Loc; rfl; Qast.Option (Some (Qast.Option None))]) :
- 'ctyp));
- [Gramext.Stoken ("", "["); Gramext.Stoken ("", "=");
- Gramext.Snterm
- (Grammar.Entry.obj
- (row_field_list : 'row_field_list Grammar.Entry.e));
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) ->
- (Qast.Node ("TyVrn", [Qast.Loc; rfl; Qast.Option None]) :
- 'ctyp))]];
- Grammar.Entry.obj (row_field_list : 'row_field_list Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.srules
- [[Gramext.Slist0sep
- (Gramext.Snterm
- (Grammar.Entry.obj (row_field : 'row_field Grammar.Entry.e)),
- Gramext.Stoken ("", "|"))],
- Gramext.action
- (fun (a : 'row_field list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]],
- Gramext.action
- (fun (rfl : 'a_list) (loc : int * int) -> (rfl : 'row_field_list))]];
- Grammar.Entry.obj (row_field : 'row_field Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'ctyp) (loc : int * int) ->
- (Qast.Node ("RfInh", [t]) : 'row_field));
- [Gramext.Stoken ("", "`");
- Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e));
- Gramext.Stoken ("", "of");
- Gramext.srules
- [[Gramext.Sopt
- (Gramext.srules
- [[Gramext.Stoken ("", "&")],
- Gramext.action
- (fun (x : string) (loc : int * int) ->
- (Qast.Str x : 'e__26))])],
- Gramext.action
- (fun (a : 'e__26 option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))];
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)),
- Gramext.Stoken ("", "&"))],
- Gramext.action
- (fun (a : 'ctyp list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]],
- Gramext.action
- (fun (l : 'a_list) (ao : 'a_opt) _ (i : 'ident) _ (loc : int * int) ->
- (Qast.Node ("RfTag", [i; o2b ao; l]) : 'row_field));
- [Gramext.Stoken ("", "`");
- Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'ident) _ (loc : int * int) ->
- (Qast.Node ("RfTag", [i; Qast.Bool true; Qast.List []]) :
- 'row_field))]];
- Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "`");
- Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'ident) _ (loc : int * int) -> (i : 'name_tag))]];
- Grammar.Entry.obj (patt : 'patt Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("", "?"); Gramext.Stoken ("", "(");
- Gramext.Snterm
- (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e));
- Gramext.srules
- [[Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))],
- Gramext.action
- (fun (a : 'eq_expr option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))];
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (eo : 'a_opt) (p : 'patt_tcon) _ _ (loc : int * int) ->
- (Qast.Node
- ("PaOlb",
- [Qast.Loc; Qast.Str "";
- Qast.Option (Some (Qast.Tuple [p; eo]))]) :
- 'patt));
- [Gramext.Snterm
- (Grammar.Entry.obj
- (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'a_QUESTIONIDENT) (loc : int * int) ->
- (Qast.Node ("PaOlb", [Qast.Loc; i; Qast.Option None]) : 'patt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e));
- Gramext.Stoken ("", "(");
- Gramext.Snterm
- (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e));
- Gramext.srules
- [[Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))],
- Gramext.action
- (fun (a : 'eq_expr option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))];
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (eo : 'a_opt) (p : 'patt_tcon) _ (i : 'a_OPTLABEL)
- (loc : int * int) ->
- (Qast.Node
- ("PaOlb",
- [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) :
- 'patt));
- [Gramext.Snterm
- (Grammar.Entry.obj
- (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e));
- Gramext.Stoken ("", ":"); Gramext.Stoken ("", "(");
- Gramext.Snterm
- (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e));
- Gramext.srules
- [[Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))],
- Gramext.action
- (fun (a : 'eq_expr option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))];
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (eo : 'a_opt) (p : 'patt_tcon) _ _ (i : 'a_QUESTIONIDENT)
- (loc : int * int) ->
- (Qast.Node
- ("PaOlb",
- [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) :
- 'patt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'a_TILDEIDENT) (loc : int * int) ->
- (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option None]) : 'patt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e));
- Gramext.Sself],
- Gramext.action
- (fun (p : 'patt) (i : 'a_LABEL) (loc : int * int) ->
- (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option (Some p)]) :
- 'patt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e));
- Gramext.Stoken ("", ":"); Gramext.Sself],
- Gramext.action
- (fun (p : 'patt) _ (i : 'a_TILDEIDENT) (loc : int * int) ->
- (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option (Some p)]) :
- 'patt));
- [Gramext.Stoken ("", "#");
- Gramext.Snterm
- (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))],
- Gramext.action
- (fun (sl : 'mod_ident) _ (loc : int * int) ->
- (Qast.Node ("PaTyp", [Qast.Loc; sl]) : 'patt));
- [Gramext.Stoken ("", "`");
- Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
- Gramext.action
- (fun (s : 'ident) _ (loc : int * int) ->
- (Qast.Node ("PaVrn", [Qast.Loc; s]) : 'patt))]];
- Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))],
- Gramext.action (fun (p : 'patt) (loc : int * int) -> (p : 'patt_tcon));
- [Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'ctyp) _ (p : 'patt) (loc : int * int) ->
- (Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'patt_tcon))]];
- Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "?"); Gramext.Stoken ("", "(");
- Gramext.Snterm
- (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e));
- Gramext.srules
- [[Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))],
- Gramext.action
- (fun (a : 'eq_expr option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))];
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (eo : 'a_opt) (p : 'ipatt_tcon) _ _ (loc : int * int) ->
- (Qast.Node
- ("PaOlb",
- [Qast.Loc; Qast.Str "";
- Qast.Option (Some (Qast.Tuple [p; eo]))]) :
- 'ipatt));
- [Gramext.Snterm
- (Grammar.Entry.obj
- (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'a_QUESTIONIDENT) (loc : int * int) ->
- (Qast.Node ("PaOlb", [Qast.Loc; i; Qast.Option None]) : 'ipatt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e));
- Gramext.Stoken ("", "(");
- Gramext.Snterm
- (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e));
- Gramext.srules
- [[Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))],
- Gramext.action
- (fun (a : 'eq_expr option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))];
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (eo : 'a_opt) (p : 'ipatt_tcon) _ (i : 'a_OPTLABEL)
- (loc : int * int) ->
- (Qast.Node
- ("PaOlb",
- [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) :
- 'ipatt));
- [Gramext.Snterm
- (Grammar.Entry.obj
- (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e));
- Gramext.Stoken ("", ":"); Gramext.Stoken ("", "(");
- Gramext.Snterm
- (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e));
- Gramext.srules
- [[Gramext.Sopt
- (Gramext.Snterm
- (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))],
- Gramext.action
- (fun (a : 'eq_expr option) (loc : int * int) ->
- (Qast.Option a : 'a_opt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))];
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (eo : 'a_opt) (p : 'ipatt_tcon) _ _ (i : 'a_QUESTIONIDENT)
- (loc : int * int) ->
- (Qast.Node
- ("PaOlb",
- [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) :
- 'ipatt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'a_TILDEIDENT) (loc : int * int) ->
- (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option None]) : 'ipatt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e));
- Gramext.Sself],
- Gramext.action
- (fun (p : 'ipatt) (i : 'a_LABEL) (loc : int * int) ->
- (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option (Some p)]) :
- 'ipatt));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e));
- Gramext.Stoken ("", ":"); Gramext.Sself],
- Gramext.action
- (fun (p : 'ipatt) _ (i : 'a_TILDEIDENT) (loc : int * int) ->
- (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option (Some p)]) :
- 'ipatt))]];
- Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))],
- Gramext.action
- (fun (p : 'ipatt) (loc : int * int) -> (p : 'ipatt_tcon));
- [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'ctyp) _ (p : 'ipatt) (loc : int * int) ->
- (Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'ipatt_tcon))]];
- Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "=");
- Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) _ (loc : int * int) -> (e : 'eq_expr))]];
- Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
- Some (Gramext.After "apply"),
- [Some "label", Some Gramext.NonA,
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'a_QUESTIONIDENT) (loc : int * int) ->
- (Qast.Node ("ExOlb", [Qast.Loc; i; Qast.Option None]) : 'expr));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e));
- Gramext.Sself],
- Gramext.action
- (fun (e : 'expr) (i : 'a_OPTLABEL) (loc : int * int) ->
- (Qast.Node ("ExOlb", [Qast.Loc; i; Qast.Option (Some e)]) :
- 'expr));
- [Gramext.Snterm
- (Grammar.Entry.obj
- (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e));
- Gramext.Stoken ("", ":"); Gramext.Sself],
- Gramext.action
- (fun (e : 'expr) _ (i : 'a_QUESTIONIDENT) (loc : int * int) ->
- (Qast.Node ("ExOlb", [Qast.Loc; i; Qast.Option (Some e)]) :
- 'expr));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e))],
- Gramext.action
- (fun (i : 'a_TILDEIDENT) (loc : int * int) ->
- (Qast.Node ("ExLab", [Qast.Loc; i; Qast.Option None]) : 'expr));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e));
- Gramext.Sself],
- Gramext.action
- (fun (e : 'expr) (i : 'a_LABEL) (loc : int * int) ->
- (Qast.Node ("ExLab", [Qast.Loc; i; Qast.Option (Some e)]) :
- 'expr));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e));
- Gramext.Stoken ("", ":"); Gramext.Sself],
- Gramext.action
- (fun (e : 'expr) _ (i : 'a_TILDEIDENT) (loc : int * int) ->
- (Qast.Node ("ExLab", [Qast.Loc; i; Qast.Option (Some e)]) :
- 'expr))]];
- Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("", "`");
- Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
- Gramext.action
- (fun (s : 'ident) _ (loc : int * int) ->
- (Qast.Node ("ExVrn", [Qast.Loc; s]) : 'expr))]];
- Grammar.Entry.obj (direction_flag : 'direction_flag Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("", "downto")],
- Gramext.action
- (fun _ (loc : int * int) -> (Qast.Bool false : 'direction_flag));
- [Gramext.Stoken ("", "to")],
- Gramext.action
- (fun _ (loc : int * int) -> (Qast.Bool true : 'direction_flag))]];
- Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("", "[|");
- Gramext.Snterm
- (Grammar.Entry.obj
- (warning_variant : 'warning_variant Grammar.Entry.e));
- Gramext.Stoken ("", "<");
- Gramext.Snterm
- (Grammar.Entry.obj
- (row_field_list : 'row_field_list Grammar.Entry.e));
- Gramext.Stoken ("", ">");
- Gramext.srules
- [[Gramext.Slist1
- (Gramext.Snterm
- (Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e)))],
- Gramext.action
- (fun (a : 'name_tag list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "|]")],
- Gramext.action
- (fun _ (ntl : 'a_list) _ (rfl : 'row_field_list) _ _ _
- (loc : int * int) ->
- (Qast.Node
- ("TyVrn",
- [Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))]) :
- 'ctyp));
- [Gramext.Stoken ("", "[|");
- Gramext.Snterm
- (Grammar.Entry.obj
- (warning_variant : 'warning_variant Grammar.Entry.e));
- Gramext.Stoken ("", "<");
- Gramext.Snterm
- (Grammar.Entry.obj
- (row_field_list : 'row_field_list Grammar.Entry.e));
- Gramext.Stoken ("", "|]")],
- Gramext.action
- (fun _ (rfl : 'row_field_list) _ _ _ (loc : int * int) ->
- (Qast.Node
- ("TyVrn",
- [Qast.Loc; rfl;
- Qast.Option (Some (Qast.Option (Some (Qast.List []))))]) :
- 'ctyp));
- [Gramext.Stoken ("", "[|");
- Gramext.Snterm
- (Grammar.Entry.obj
- (warning_variant : 'warning_variant Grammar.Entry.e));
- Gramext.Stoken ("", ">");
- Gramext.Snterm
- (Grammar.Entry.obj
- (row_field_list : 'row_field_list Grammar.Entry.e));
- Gramext.Stoken ("", "|]")],
- Gramext.action
- (fun _ (rfl : 'row_field_list) _ _ _ (loc : int * int) ->
- (Qast.Node
- ("TyVrn",
- [Qast.Loc; rfl; Qast.Option (Some (Qast.Option None))]) :
- 'ctyp));
- [Gramext.Stoken ("", "[|");
- Gramext.Snterm
- (Grammar.Entry.obj
- (warning_variant : 'warning_variant Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj
- (row_field_list : 'row_field_list Grammar.Entry.e));
- Gramext.Stoken ("", "|]")],
- Gramext.action
- (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) ->
- (Qast.Node ("TyVrn", [Qast.Loc; rfl; Qast.Option None]) :
- 'ctyp))]];
- Grammar.Entry.obj (warning_variant : 'warning_variant Grammar.Entry.e),
- None,
- [None, None,
- [[],
- Gramext.action
- (fun (loc : int * int) ->
- (warn_variant Qast.Loc : 'warning_variant))]];
- Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
- Some (Gramext.Level "top"),
- [None, None,
- [[Gramext.Stoken ("", "while"); Gramext.Sself; Gramext.Stoken ("", "do");
- Gramext.srules
- [[Gramext.Slist0
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__29))])],
- Gramext.action
- (fun (a : 'e__29 list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Snterm
- (Grammar.Entry.obj
- (warning_sequence : 'warning_sequence Grammar.Entry.e));
- Gramext.Stoken ("", "done")],
- Gramext.action
- (fun _ _ (seq : 'a_list) _ (e : 'expr) _ (loc : int * int) ->
- (Qast.Node ("ExWhi", [Qast.Loc; e; seq]) : 'expr));
- [Gramext.Stoken ("", "for");
- Gramext.Snterm
- (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e));
- Gramext.Stoken ("", "="); Gramext.Sself;
- Gramext.Snterm
- (Grammar.Entry.obj
- (direction_flag : 'direction_flag Grammar.Entry.e));
- Gramext.Sself; Gramext.Stoken ("", "do");
- Gramext.srules
- [[Gramext.Slist0
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__28))])],
- Gramext.action
- (fun (a : 'e__28 list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Snterm
- (Grammar.Entry.obj
- (warning_sequence : 'warning_sequence Grammar.Entry.e));
- Gramext.Stoken ("", "done")],
- Gramext.action
- (fun _ _ (seq : 'a_list) _ (e2 : 'expr) (df : 'direction_flag)
- (e1 : 'expr) _ (i : 'a_LIDENT) _ (loc : int * int) ->
- (Qast.Node ("ExFor", [Qast.Loc; i; e1; e2; df; seq]) : 'expr));
- [Gramext.Stoken ("", "do");
- Gramext.srules
- [[Gramext.Slist0
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__27))])],
- Gramext.action
- (fun (a : 'e__27 list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "return");
- Gramext.Snterm
- (Grammar.Entry.obj
- (warning_sequence : 'warning_sequence Grammar.Entry.e));
- Gramext.Sself],
- Gramext.action
- (fun (e : 'expr) _ _ (seq : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("ExSeq", [Qast.Loc; append_elem seq e]) : 'expr))]];
- Grammar.Entry.obj (warning_sequence : 'warning_sequence Grammar.Entry.e),
- None,
- [None, None,
- [[],
- Gramext.action
- (fun (loc : int * int) ->
- (warn_sequence Qast.Loc : 'warning_sequence))]];
- Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("ANTIQUOT", "list")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "list" loc a : 'sequence))]];
- Grammar.Entry.obj (expr_ident : 'expr_ident Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("ANTIQUOT", "")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "" loc a : 'expr_ident))]];
- Grammar.Entry.obj (patt_label_ident : 'patt_label_ident Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("ANTIQUOT", "")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "" loc a : 'patt_label_ident))]];
- Grammar.Entry.obj (when_expr_opt : 'when_expr_opt Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("ANTIQUOT", "when")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "when" loc a : 'when_expr_opt))]];
- Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("ANTIQUOT", "")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "" loc a : 'mod_ident))]];
- Grammar.Entry.obj (clty_longident : 'clty_longident Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'clty_longident))]];
- Grammar.Entry.obj (class_longident : 'class_longident Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'class_longident))]];
- Grammar.Entry.obj (direction_flag : 'direction_flag Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("ANTIQUOT", "to")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "to" loc a : 'direction_flag))]];
- Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("", "object"); Gramext.Stoken ("ANTIQUOT", "");
- Gramext.Stoken ("", ";");
- Gramext.srules
- [[Gramext.Slist0
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (class_str_item : 'class_str_item Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (cf : 'class_str_item) (loc : int * int) ->
- (cf : 'e__30))])],
- Gramext.action
- (fun (a : 'e__30 list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "end")],
- Gramext.action
- (fun _ (csl : 'a_list) _ (x : string) _ (loc : int * int) ->
- (let _ = warn_antiq loc "3.05" in
- Qast.Node
- ("CeStr",
- [Qast.Loc; Qast.Option None;
- Qast.Cons (antiquot "" loc x, csl)]) :
- 'class_expr));
- [Gramext.Stoken ("", "object"); Gramext.Stoken ("ANTIQUOT", "");
- Gramext.Snterm
- (Grammar.Entry.obj
- (class_structure : 'class_structure Grammar.Entry.e));
- Gramext.Stoken ("", "end")],
- Gramext.action
- (fun _ (cf : 'class_structure) (x : string) _ (loc : int * int) ->
- (let _ = warn_antiq loc "3.05" in
- Qast.Node ("CeStr", [Qast.Loc; antiquot "" loc x; cf]) :
- 'class_expr))]];
- Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "object"); Gramext.Stoken ("ANTIQUOT", "");
- Gramext.Stoken ("", ";");
- Gramext.srules
- [[Gramext.Slist0
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (class_sig_item : 'class_sig_item Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (csf : 'class_sig_item) (loc : int * int) ->
- (csf : 'e__32))])],
- Gramext.action
- (fun (a : 'e__32 list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "end")],
- Gramext.action
- (fun _ (csf : 'a_list) _ (x : string) _ (loc : int * int) ->
- (let _ = warn_antiq loc "3.05" in
- Qast.Node
- ("CtSig",
- [Qast.Loc; Qast.Option None;
- Qast.Cons (antiquot "" loc x, csf)]) :
- 'class_type));
- [Gramext.Stoken ("", "object"); Gramext.Stoken ("ANTIQUOT", "");
- Gramext.srules
- [[Gramext.Slist0
- (Gramext.srules
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (class_sig_item : 'class_sig_item Grammar.Entry.e));
- Gramext.Stoken ("", ";")],
- Gramext.action
- (fun _ (csf : 'class_sig_item) (loc : int * int) ->
- (csf : 'e__31))])],
- Gramext.action
- (fun (a : 'e__31 list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "end")],
- Gramext.action
- (fun _ (csf : 'a_list) (x : string) _ (loc : int * int) ->
- (let _ = warn_antiq loc "3.05" in
- Qast.Node ("CtSig", [Qast.Loc; antiquot "" loc x; csf]) :
- 'class_type))]];
- Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
- Some (Gramext.Level "top"),
- [None, None,
- [[Gramext.Stoken ("", "let"); Gramext.Stoken ("ANTIQUOT", "rec");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (let_binding : 'let_binding Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (a : 'let_binding list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "in"); Gramext.Sself],
- Gramext.action
- (fun (x : 'expr) _ (l : 'a_list) (r : string) _ (loc : int * int) ->
- (let _ = warn_antiq loc "3.06+18" in
- Qast.Node ("ExLet", [Qast.Loc; antiquot "rec" loc r; l; x]) :
- 'expr))]];
- Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e),
- Some (Gramext.Level "top"),
- [None, None,
- [[Gramext.Stoken ("", "value"); Gramext.Stoken ("ANTIQUOT", "rec");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (let_binding : 'let_binding Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (a : 'let_binding list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]],
- Gramext.action
- (fun (l : 'a_list) (r : string) _ (loc : int * int) ->
- (let _ = warn_antiq loc "3.06+18" in
- Qast.Node ("StVal", [Qast.Loc; antiquot "rec" loc r; l]) :
- 'str_item))]];
- Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e),
- Some (Gramext.Level "top"),
- [None, None,
- [[Gramext.Stoken ("", "let"); Gramext.Stoken ("ANTIQUOT", "rec");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (let_binding : 'let_binding Grammar.Entry.e)),
- Gramext.Stoken ("", "and"))],
- Gramext.action
- (fun (a : 'let_binding list) (loc : int * int) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))];
- Gramext.Stoken ("", "in"); Gramext.Sself],
- Gramext.action
- (fun (ce : 'class_expr) _ (lb : 'a_list) (r : string) _
- (loc : int * int) ->
- (let _ = warn_antiq loc "3.06+18" in
- Qast.Node ("CeLet", [Qast.Loc; antiquot "rec" loc r; lb; ce]) :
- 'class_expr))]];
- Grammar.Entry.obj (class_str_item : 'class_str_item Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("", "value"); Gramext.Stoken ("ANTIQUOT", "mut");
- Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj
- (cvalue_binding : 'cvalue_binding Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'cvalue_binding) (lab : 'label) (mf : string) _
- (loc : int * int) ->
- (let _ = warn_antiq loc "3.06+18" in
- Qast.Node ("CrVal", [Qast.Loc; lab; antiquot "mut" loc mf; e]) :
- 'class_str_item));
- [Gramext.Stoken ("", "inherit");
- Gramext.Snterm
- (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e));
- Gramext.Stoken ("ANTIQUOT", "as")],
- Gramext.action
- (fun (pb : string) (ce : 'class_expr) _ (loc : int * int) ->
- (let _ = warn_antiq loc "3.06+18" in
- Qast.Node ("CrInh", [Qast.Loc; ce; antiquot "as" loc pb]) :
- 'class_str_item))]];
- Grammar.Entry.obj (class_sig_item : 'class_sig_item Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("", "value"); Gramext.Stoken ("ANTIQUOT", "mut");
- Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
- Gramext.Stoken ("", ":");
- Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
- Gramext.action
- (fun (t : 'ctyp) _ (l : 'label) (mf : string) _ (loc : int * int) ->
- (let _ = warn_antiq loc "3.06+18" in
- Qast.Node ("CgVal", [Qast.Loc; l; antiquot "mut" loc mf; t]) :
- 'class_sig_item))]]]);;
-
-Grammar.extend
- (let _ = (str_item : 'str_item Grammar.Entry.e)
- and _ = (sig_item : 'sig_item Grammar.Entry.e) in
- let grammar_entry_create s =
- Grammar.Entry.create (Grammar.of_entry str_item) s
- in
- let dir_param : 'dir_param Grammar.Entry.e =
- grammar_entry_create "dir_param"
- in
- [Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "#");
- Gramext.Snterm
- (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj (dir_param : 'dir_param Grammar.Entry.e))],
- Gramext.action
- (fun (dp : 'dir_param) (n : 'a_LIDENT) _ (loc : int * int) ->
- (Qast.Node ("StDir", [Qast.Loc; n; dp]) : 'str_item))]];
- Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "#");
- Gramext.Snterm
- (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e));
- Gramext.Snterm
- (Grammar.Entry.obj (dir_param : 'dir_param Grammar.Entry.e))],
- Gramext.action
- (fun (dp : 'dir_param) (n : 'a_LIDENT) _ (loc : int * int) ->
- (Qast.Node ("SgDir", [Qast.Loc; n; dp]) : 'sig_item))]];
- Grammar.Entry.obj (dir_param : 'dir_param Grammar.Entry.e), None,
- [None, None,
- [[],
- Gramext.action
- (fun (loc : int * int) -> (Qast.Option None : 'dir_param));
- [Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
- Gramext.action
- (fun (e : 'expr) (loc : int * int) ->
- (Qast.Option (Some e) : 'dir_param));
- [Gramext.Stoken ("ANTIQUOT", "opt")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "opt" loc a : 'dir_param))]]]);;
-
-(* Antiquotations *)
-
-Grammar.extend
- [Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("ANTIQUOT", "")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "" loc a : 'module_expr));
- [Gramext.Stoken ("ANTIQUOT", "mexp")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "mexp" loc a : 'module_expr))]];
- Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e),
- Some (Gramext.Level "top"),
- [None, None,
- [[Gramext.Stoken ("ANTIQUOT", "")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "" loc a : 'str_item));
- [Gramext.Stoken ("ANTIQUOT", "stri")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "stri" loc a : 'str_item))]];
- Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("ANTIQUOT", "")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "" loc a : 'module_type));
- [Gramext.Stoken ("ANTIQUOT", "mtyp")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "mtyp" loc a : 'module_type))]];
- Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e),
- Some (Gramext.Level "top"),
- [None, None,
- [[Gramext.Stoken ("ANTIQUOT", "")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "" loc a : 'sig_item));
- [Gramext.Stoken ("ANTIQUOT", "sigi")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "sigi" loc a : 'sig_item))]];
- Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("", "(");
- Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (el : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("ExTup", [Qast.Loc; el]) : 'expr));
- [Gramext.Stoken ("ANTIQUOT", "anti")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (Qast.Node ("ExAnt", [Qast.Loc; antiquot "anti" loc a]) : 'expr));
- [Gramext.Stoken ("ANTIQUOT", "")],
- Gramext.action
- (fun (a : string) (loc : int * int) -> (antiquot "" loc a : 'expr));
- [Gramext.Stoken ("ANTIQUOT", "exp")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "exp" loc a : 'expr))]];
- Grammar.Entry.obj (patt : 'patt Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("", "(");
- Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (pl : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("PaTup", [Qast.Loc; pl]) : 'patt));
- [Gramext.Stoken ("ANTIQUOT", "anti")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (Qast.Node ("PaAnt", [Qast.Loc; antiquot "anti" loc a]) : 'patt));
- [Gramext.Stoken ("ANTIQUOT", "")],
- Gramext.action
- (fun (a : string) (loc : int * int) -> (antiquot "" loc a : 'patt));
- [Gramext.Stoken ("ANTIQUOT", "pat")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "pat" loc a : 'patt))]];
- Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("", "(");
- Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (pl : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("PaTup", [Qast.Loc; pl]) : 'ipatt));
- [Gramext.Stoken ("ANTIQUOT", "anti")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (Qast.Node ("PaAnt", [Qast.Loc; antiquot "anti" loc a]) : 'ipatt));
- [Gramext.Stoken ("ANTIQUOT", "")],
- Gramext.action
- (fun (a : string) (loc : int * int) -> (antiquot "" loc a : 'ipatt));
- [Gramext.Stoken ("ANTIQUOT", "pat")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "pat" loc a : 'ipatt))]];
- Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("", "(");
- Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e));
- Gramext.Stoken ("", ")")],
- Gramext.action
- (fun _ (tl : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("TyTup", [Qast.Loc; tl]) : 'ctyp));
- [Gramext.Stoken ("ANTIQUOT", "")],
- Gramext.action
- (fun (a : string) (loc : int * int) -> (antiquot "" loc a : 'ctyp));
- [Gramext.Stoken ("ANTIQUOT", "typ")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "typ" loc a : 'ctyp))]];
- Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("ANTIQUOT", "")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "" loc a : 'class_expr))]];
- Grammar.Entry.obj (class_str_item : 'class_str_item Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("ANTIQUOT", "")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "" loc a : 'class_str_item))]];
- Grammar.Entry.obj (class_sig_item : 'class_sig_item Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("ANTIQUOT", "")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "" loc a : 'class_sig_item))]];
- Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("ANTIQUOT", "")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "" loc a : 'class_type))]];
- Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("", "{<");
- Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e));
- Gramext.Stoken ("", ">}")],
- Gramext.action
- (fun _ (fel : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("ExOvr", [Qast.Loc; fel]) : 'expr))]];
- Grammar.Entry.obj (patt : 'patt Grammar.Entry.e),
- Some (Gramext.Level "simple"),
- [None, None,
- [[Gramext.Stoken ("", "#");
- Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) _ (loc : int * int) ->
- (Qast.Node ("PaTyp", [Qast.Loc; a]) : 'patt))]];
- Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("ANTIQUOT", "list")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "list" loc a : 'a_list))]];
- Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("ANTIQUOT", "opt")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "opt" loc a : 'a_opt))]];
- Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("UIDENT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) -> (Qast.Str i : 'a_UIDENT));
- [Gramext.Stoken ("ANTIQUOT", "")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "" loc a : 'a_UIDENT));
- [Gramext.Stoken ("ANTIQUOT", "uid")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "uid" loc a : 'a_UIDENT))]];
- Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("LIDENT", "")],
- Gramext.action
- (fun (i : string) (loc : int * int) -> (Qast.Str i : 'a_LIDENT));
- [Gramext.Stoken ("ANTIQUOT", "")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "" loc a : 'a_LIDENT));
- [Gramext.Stoken ("ANTIQUOT", "lid")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "lid" loc a : 'a_LIDENT))]];
- Grammar.Entry.obj (a_INT : 'a_INT Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("INT", "")],
- Gramext.action
- (fun (s : string) (loc : int * int) -> (Qast.Str s : 'a_INT));
- [Gramext.Stoken ("ANTIQUOT", "")],
- Gramext.action
- (fun (a : string) (loc : int * int) -> (antiquot "" loc a : 'a_INT));
- [Gramext.Stoken ("ANTIQUOT", "int")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "int" loc a : 'a_INT))]];
- Grammar.Entry.obj (a_FLOAT : 'a_FLOAT Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("FLOAT", "")],
- Gramext.action
- (fun (s : string) (loc : int * int) -> (Qast.Str s : 'a_FLOAT));
- [Gramext.Stoken ("ANTIQUOT", "")],
- Gramext.action
- (fun (a : string) (loc : int * int) -> (antiquot "" loc a : 'a_FLOAT));
- [Gramext.Stoken ("ANTIQUOT", "flo")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "flo" loc a : 'a_FLOAT))]];
- Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("STRING", "")],
- Gramext.action
- (fun (s : string) (loc : int * int) -> (Qast.Str s : 'a_STRING));
- [Gramext.Stoken ("ANTIQUOT", "")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "" loc a : 'a_STRING));
- [Gramext.Stoken ("ANTIQUOT", "str")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "str" loc a : 'a_STRING))]];
- Grammar.Entry.obj (a_CHAR : 'a_CHAR Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("CHAR", "")],
- Gramext.action
- (fun (s : string) (loc : int * int) -> (Qast.Str s : 'a_CHAR));
- [Gramext.Stoken ("ANTIQUOT", "")],
- Gramext.action
- (fun (a : string) (loc : int * int) -> (antiquot "" loc a : 'a_CHAR));
- [Gramext.Stoken ("ANTIQUOT", "chr")],
- Gramext.action
- (fun (a : string) (loc : int * int) ->
- (antiquot "chr" loc a : 'a_CHAR))]];
- Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("TILDEIDENT", "")],
- Gramext.action
- (fun (s : string) (loc : int * int) -> (Qast.Str s : 'a_TILDEIDENT));
- [Gramext.Stoken ("", "~"); Gramext.Stoken ("ANTIQUOT", "")],
- Gramext.action
- (fun (a : string) _ (loc : int * int) ->
- (antiquot "" loc a : 'a_TILDEIDENT))]];
- Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("LABEL", "")],
- Gramext.action
- (fun (s : string) (loc : int * int) -> (Qast.Str s : 'a_LABEL))]];
- Grammar.Entry.obj (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Stoken ("QUESTIONIDENT", "")],
- Gramext.action
- (fun (s : string) (loc : int * int) ->
- (Qast.Str s : 'a_QUESTIONIDENT));
- [Gramext.Stoken ("", "?"); Gramext.Stoken ("ANTIQUOT", "")],
- Gramext.action
- (fun (a : string) _ (loc : int * int) ->
- (antiquot "" loc a : 'a_QUESTIONIDENT))]];
- Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Stoken ("OPTLABEL", "")],
- Gramext.action
- (fun (s : string) (loc : int * int) -> (Qast.Str s : 'a_OPTLABEL))]]];;
-
-let apply_entry e =
- let f s = Grammar.Entry.parse e (Stream.of_string s) in
- let expr s = Qast.to_expr (f s) in
- let patt s = Qast.to_patt (f s) in Quotation.ExAst (expr, patt)
-;;
-
-let sig_item_eoi = Grammar.Entry.create gram "signature item" in
-Grammar.extend
- [Grammar.Entry.obj (sig_item_eoi : 'sig_item_eoi Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e));
- Gramext.Stoken ("EOI", "")],
- Gramext.action
- (fun _ (x : 'sig_item) (loc : int * int) -> (x : 'sig_item_eoi))]]];
-Quotation.add "sig_item" (apply_entry sig_item_eoi);;
-
-let str_item_eoi = Grammar.Entry.create gram "structure item" in
-Grammar.extend
- [Grammar.Entry.obj (str_item_eoi : 'str_item_eoi Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e));
- Gramext.Stoken ("EOI", "")],
- Gramext.action
- (fun _ (x : 'str_item) (loc : int * int) -> (x : 'str_item_eoi))]]];
-Quotation.add "str_item" (apply_entry str_item_eoi);;
-
-let ctyp_eoi = Grammar.Entry.create gram "type" in
-Grammar.extend
- [Grammar.Entry.obj (ctyp_eoi : 'ctyp_eoi Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
- Gramext.Stoken ("EOI", "")],
- Gramext.action
- (fun _ (x : 'ctyp) (loc : int * int) -> (x : 'ctyp_eoi))]]];
-Quotation.add "ctyp" (apply_entry ctyp_eoi);;
-
-let patt_eoi = Grammar.Entry.create gram "pattern" in
-Grammar.extend
- [Grammar.Entry.obj (patt_eoi : 'patt_eoi Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e));
- Gramext.Stoken ("EOI", "")],
- Gramext.action
- (fun _ (x : 'patt) (loc : int * int) -> (x : 'patt_eoi))]]];
-Quotation.add "patt" (apply_entry patt_eoi);;
-
-let expr_eoi = Grammar.Entry.create gram "expression" in
-Grammar.extend
- [Grammar.Entry.obj (expr_eoi : 'expr_eoi Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e));
- Gramext.Stoken ("EOI", "")],
- Gramext.action
- (fun _ (x : 'expr) (loc : int * int) -> (x : 'expr_eoi))]]];
-Quotation.add "expr" (apply_entry expr_eoi);;
-
-let module_type_eoi = Grammar.Entry.create gram "module type" in
-Grammar.extend
- [Grammar.Entry.obj (module_type_eoi : 'module_type_eoi Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e));
- Gramext.Stoken ("EOI", "")],
- Gramext.action
- (fun _ (x : 'module_type) (loc : int * int) ->
- (x : 'module_type_eoi))]]];
-Quotation.add "module_type" (apply_entry module_type_eoi);;
-
-let module_expr_eoi = Grammar.Entry.create gram "module expression" in
-Grammar.extend
- [Grammar.Entry.obj (module_expr_eoi : 'module_expr_eoi Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e));
- Gramext.Stoken ("EOI", "")],
- Gramext.action
- (fun _ (x : 'module_expr) (loc : int * int) ->
- (x : 'module_expr_eoi))]]];
-Quotation.add "module_expr" (apply_entry module_expr_eoi);;
-
-let class_type_eoi = Grammar.Entry.create gram "class_type" in
-Grammar.extend
- [Grammar.Entry.obj (class_type_eoi : 'class_type_eoi Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e));
- Gramext.Stoken ("EOI", "")],
- Gramext.action
- (fun _ (x : 'class_type) (loc : int * int) ->
- (x : 'class_type_eoi))]]];
-Quotation.add "class_type" (apply_entry class_type_eoi);;
-
-let class_expr_eoi = Grammar.Entry.create gram "class_expr" in
-Grammar.extend
- [Grammar.Entry.obj (class_expr_eoi : 'class_expr_eoi Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e));
- Gramext.Stoken ("EOI", "")],
- Gramext.action
- (fun _ (x : 'class_expr) (loc : int * int) ->
- (x : 'class_expr_eoi))]]];
-Quotation.add "class_expr" (apply_entry class_expr_eoi);;
-
-let class_sig_item_eoi = Grammar.Entry.create gram "class_sig_item" in
-Grammar.extend
- [Grammar.Entry.obj
- (class_sig_item_eoi : 'class_sig_item_eoi Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (class_sig_item : 'class_sig_item Grammar.Entry.e));
- Gramext.Stoken ("EOI", "")],
- Gramext.action
- (fun _ (x : 'class_sig_item) (loc : int * int) ->
- (x : 'class_sig_item_eoi))]]];
-Quotation.add "class_sig_item" (apply_entry class_sig_item_eoi);;
-
-let class_str_item_eoi = Grammar.Entry.create gram "class_str_item" in
-Grammar.extend
- [Grammar.Entry.obj
- (class_str_item_eoi : 'class_str_item_eoi Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj
- (class_str_item : 'class_str_item Grammar.Entry.e));
- Gramext.Stoken ("EOI", "")],
- Gramext.action
- (fun _ (x : 'class_str_item) (loc : int * int) ->
- (x : 'class_str_item_eoi))]]];
-Quotation.add "class_str_item" (apply_entry class_str_item_eoi);;
-
-let with_constr_eoi = Grammar.Entry.create gram "with constr" in
-Grammar.extend
- [Grammar.Entry.obj (with_constr_eoi : 'with_constr_eoi Grammar.Entry.e),
- None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (with_constr : 'with_constr Grammar.Entry.e));
- Gramext.Stoken ("EOI", "")],
- Gramext.action
- (fun _ (x : 'with_constr) (loc : int * int) ->
- (x : 'with_constr_eoi))]]];
-Quotation.add "with_constr" (apply_entry with_constr_eoi);;
-
-let row_field_eoi = Grammar.Entry.create gram "row_field" in
-Grammar.extend
- [Grammar.Entry.obj (row_field_eoi : 'row_field_eoi Grammar.Entry.e), None,
- [None, None,
- [[Gramext.Snterm
- (Grammar.Entry.obj (row_field : 'row_field Grammar.Entry.e));
- Gramext.Stoken ("EOI", "")],
- Gramext.action
- (fun _ (x : 'row_field) (loc : int * int) -> (x : 'row_field_eoi))]]];
-Quotation.add "row_field" (apply_entry row_field_eoi);;
diff --git a/camlp4/ocaml_src/odyl/.cvsignore b/camlp4/ocaml_src/odyl/.cvsignore
deleted file mode 100644
index 18deb61827..0000000000
--- a/camlp4/ocaml_src/odyl/.cvsignore
+++ /dev/null
@@ -1,2 +0,0 @@
-odyl
-odyl_config.ml
diff --git a/camlp4/ocaml_src/odyl/.depend b/camlp4/ocaml_src/odyl/.depend
deleted file mode 100644
index b63c10b0b6..0000000000
--- a/camlp4/ocaml_src/odyl/.depend
+++ /dev/null
@@ -1,6 +0,0 @@
-odyl_main.cmo: $(OTOP)/otherlibs/dynlink/dynlink.cmi odyl_config.cmo \
- odyl_main.cmi
-odyl_main.cmx: odyl_config.cmx \
- odyl_main.cmi
-odyl.cmo: odyl_config.cmo odyl_main.cmi
-odyl.cmx: odyl_config.cmx odyl_main.cmx
diff --git a/camlp4/ocaml_src/odyl/Makefile b/camlp4/ocaml_src/odyl/Makefile
deleted file mode 100644
index bd59608b8e..0000000000
--- a/camlp4/ocaml_src/odyl/Makefile
+++ /dev/null
@@ -1,61 +0,0 @@
-# This file has been generated by program: do not edit!
-
-include ../../config/Makefile
-
-SHELL=/bin/sh
-
-INCLUDES=-I $(OTOP)/otherlibs/dynlink
-OCAMLCFLAGS=-warn-error A $(INCLUDES)
-LINKFLAGS=$(INCLUDES)
-
-OBJS=odyl_config.cmo odyl_main.cmo
-
-all: odyl$(EXE)
-
-opt: odyl.cmxa odyl.cmx
-
-odyl$(EXE): odyl.cma odyl.cmo
- $(OCAMLC) odyl.cma odyl.cmo -o odyl$(EXE)
-
-odyl.cma: $(OBJS)
- $(OCAMLC) $(LINKFLAGS) dynlink.cma $(OBJS) -a -o odyl.cma
-
-odyl.cmxa: $(OBJS:.cmo=.cmx)
- $(OCAMLOPT) $(LINKFLAGS) $(OBJS:.cmo=.cmx) -a -o odyl.cmxa
-
-odyl_main.cmx: odyl_main.ml
- $(CAMLP4_COMM) -nolib -DOPT -o odyl_main.ppo odyl_main.ml
- $(OCAMLOPT) -c -impl odyl_main.ppo
- rm -f odyl_main.ppo
-
-odyl_config.ml:
- (echo 'let standard_library ='; \
- echo ' try Sys.getenv "CAMLP4LIB" with Not_found -> '; \
- echo ' try Sys.getenv "OCAMLLIB" ^ "/camlp4" with Not_found -> '; \
- echo ' try Sys.getenv "CAMLLIB" ^ "/camlp4" with Not_found -> '; \
- echo ' "$(LIBDIR)/camlp4"') \
- | sed -e 's|\\|/|g' > odyl_config.ml
-
-clean::
- rm -f *.cm* *.pp[io] *.$(O) *.bak .*.bak *.out *.opt *.$(A)
- rm -f odyl_config.ml odyl$(EXE)
-
-depend:
- cp .depend .depend.bak
- > .depend
- @for i in *.mli *.ml; do \
- ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \
- sed -e 's| $(OTOP)/otherlibs/dynlink/dynlink.cmx||' | \
- sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \
- done
-
-promote:
-
-compare:
-
-install:
- -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)"
- cp odyl.cmo odyl.cma odyl_main.cmi $(LIBDIR)/camlp4/.
- if test -f odyl.cmxa; then cp odyl.cmxa odyl.$(A) $(LIBDIR)/camlp4/.; fi
-
-include .depend
diff --git a/camlp4/ocaml_src/odyl/Makefile.Mac b/camlp4/ocaml_src/odyl/Makefile.Mac
deleted file mode 100644
index 41b16d30e4..0000000000
--- a/camlp4/ocaml_src/odyl/Makefile.Mac
+++ /dev/null
@@ -1,49 +0,0 @@
-#######################################################################
-# #
-# Camlp4 #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. Distributed only by permission. #
-# #
-#######################################################################
-
-# This file has been generated by program: do not edit!
-
-INCLUDES = -I "{OTOP}otherlibs:dynlink:"
-OCAMLCFLAGS = {INCLUDES}
-LINKFLAGS = {INCLUDES}
-
-OBJS = odyl_config.cmo odyl_main.cmo
-
-all Ä odyl
-
-odyl Ä odyl.cma odyl.cmo
- {OCAMLC} odyl.cma odyl.cmo -o odyl
-
-odyl.cma Ä {OBJS}
- {OCAMLC} {LINKFLAGS} dynlink.cma {OBJS} -a -o odyl.cma
-
-odyl_config.cmo Ä
- echo 'let standard_library =' > odyl_config.ml
- echo ' try Sys.getenv "CAMLP4LIB" with' >> odyl_config.ml
- echo ' Not_found -> "'{P4LIBDIR}'"' >> odyl_config.ml
- {OCAMLC} {OCAMLCFLAGS} -c odyl_config.ml
-
-clean ÄÄ
- delete -i odyl_config.ml odyl
-
-{dependrule}
-
-promote Ä $OutOfDate
-
-compare Ä $OutOfDate
-
-install Ä
- (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null
- (newfolder "{BINDIR}" || set status 0) ³ dev:null
- duplicate -y odyl.cmo odyl.cma "{P4LIBDIR}"
- duplicate -y odyl "{BINDIR}"
-
-{defrules}
diff --git a/camlp4/ocaml_src/odyl/Makefile.Mac.depend b/camlp4/ocaml_src/odyl/Makefile.Mac.depend
deleted file mode 100644
index adaff27755..0000000000
--- a/camlp4/ocaml_src/odyl/Makefile.Mac.depend
+++ /dev/null
@@ -1,4 +0,0 @@
-odyl_main.cmoÄ odyl_config.cmo odyl_main.cmi
-odyl_main.cmxÄ odyl_config.cmx odyl_main.cmi
-odyl.cmoÄ odyl_config.cmo odyl_main.cmi
-odyl.cmxÄ odyl_config.cmx odyl_main.cmx
diff --git a/camlp4/ocaml_src/odyl/odyl.ml b/camlp4/ocaml_src/odyl/odyl.ml
deleted file mode 100644
index 096e13eeb4..0000000000
--- a/camlp4/ocaml_src/odyl/odyl.ml
+++ /dev/null
@@ -1,50 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-let apply_load () =
- let i = ref 1 in
- let stop = ref false in
- while not !stop && !i < Array.length Sys.argv do
- let s = Sys.argv.(!i) in
- if s = "-I" && !i + 1 < Array.length Sys.argv then
- begin Odyl_main.directory Sys.argv.(!i + 1); i := !i + 2 end
- else if s = "-nolib" then begin Odyl_main.nolib := true; incr i end
- else if s = "-where" then
- begin
- print_string Odyl_config.standard_library;
- print_newline ();
- flush stdout;
- exit 0
- end
- else if s = "--" then begin incr i; stop := true; () end
- else if String.length s > 0 && s.[0] == '-' then stop := true
- else if
- Filename.check_suffix s ".cmo" || Filename.check_suffix s ".cma"
- then
- begin Odyl_main.loadfile s; incr i end
- else stop := true
- done
-;;
-
-let main () =
- try apply_load (); !(Odyl_main.go) () with
- Odyl_main.Error (fname, str) ->
- flush stdout;
- Printf.eprintf "Error while loading \"%s\": " fname;
- Printf.eprintf "%s.\n" str;
- flush stderr;
- exit 2
-;;
-
-Printexc.catch main ();;
diff --git a/camlp4/ocaml_src/odyl/odyl_main.ml b/camlp4/ocaml_src/odyl/odyl_main.ml
deleted file mode 100644
index 22e5e65d93..0000000000
--- a/camlp4/ocaml_src/odyl/odyl_main.ml
+++ /dev/null
@@ -1,77 +0,0 @@
-(* camlp4r pa_macro.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-let go = ref (fun () -> ());;
-let name = ref "odyl";;
-
-let first_arg_no_load () =
- let rec loop i =
- if i < Array.length Sys.argv then
- match Sys.argv.(i) with
- "-I" -> loop (i + 2)
- | "-nolib" -> loop (i + 1)
- | "-where" -> loop (i + 1)
- | "--" -> i + 1
- | s ->
- if Filename.check_suffix s ".cmo" || Filename.check_suffix s ".cma"
- then
- loop (i + 1)
- else i
- else i
- in
- loop 1
-;;
-
-Arg.current := first_arg_no_load () - 1;;
-
-(* Load files in core *)
-
-let find_in_path path name =
- if not (Filename.is_implicit name) then
- if Sys.file_exists name then name else raise Not_found
- else
- let rec try_dir =
- function
- [] -> raise Not_found
- | dir :: rem ->
- let fullname = Filename.concat dir name in
- if Sys.file_exists fullname then fullname else try_dir rem
- in
- try_dir path
-;;
-
-exception Error of string * string;;
-
-let nolib = ref false;;
-let initialized = ref false;;
-let path = ref ([] : string list);;
-
-let loadfile file =
- if not !initialized then
- begin
- begin Dynlink.init (); Dynlink.allow_unsafe_modules true end;
- initialized := true
- end;
- let path =
- if !nolib then !path else Odyl_config.standard_library :: !path
- in
- let fname =
- try find_in_path (List.rev path) file with
- Not_found -> raise (Error (file, "file not found in path"))
- in
- try Dynlink.loadfile fname with
- Dynlink.Error e -> raise (Error (fname, Dynlink.error_message e))
-;;
-
-let directory d = path := d :: !path;;
diff --git a/camlp4/ocaml_src/odyl/odyl_main.mli b/camlp4/ocaml_src/odyl/odyl_main.mli
deleted file mode 100644
index be441a6c84..0000000000
--- a/camlp4/ocaml_src/odyl/odyl_main.mli
+++ /dev/null
@@ -1,13 +0,0 @@
-(* camlp4r *)
-(* This file has been generated by program: do not edit! *)
-
-exception Error of string * string;;
-
-val nolib : bool ref;;
-val initialized : bool ref;;
-val path : string list ref;;
-val loadfile : string -> unit;;
-val directory : string -> unit;;
-
-val go : (unit -> unit) ref;;
-val name : string ref;;
diff --git a/camlp4/ocaml_src/tools/camlp4_comm.mpw b/camlp4/ocaml_src/tools/camlp4_comm.mpw
deleted file mode 100644
index ff837e7745..0000000000
--- a/camlp4/ocaml_src/tools/camlp4_comm.mpw
+++ /dev/null
@@ -1,27 +0,0 @@
-#######################################################################
-# #
-# Camlp4 #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. Distributed only by permission. #
-# #
-#######################################################################
-
-# $Id$
-
-set echo 0
-
-exit if {#} < 1
-
-if "{1}" =~ /(Å)¨0.mli/
- echo duplicate -y {1} {¨0}.ppi
- duplicate -y "{1}" "{¨0}.ppi"
-else if "{1}" =~ /(Å)¨0.ml/
- echo duplicate -y {1} {¨0}.ppo
- duplicate -y "{1}" "{¨0}.ppo"
-else
- echo duplicate -y {1} {1}.ppo
- duplicate -y "{1}" "{1}.ppo"
-end
diff --git a/camlp4/ocaml_src/tools/camlp4_comm.sh b/camlp4/ocaml_src/tools/camlp4_comm.sh
deleted file mode 100755
index 357a929520..0000000000
--- a/camlp4/ocaml_src/tools/camlp4_comm.sh
+++ /dev/null
@@ -1,9 +0,0 @@
-#!/bin/sh
-
-if test "`basename $1 .mli`.mli" = "$1"; then
- echo cp $1 `basename $1 .mli`.ppi
- cp $1 `basename $1 .mli`.ppi
-else
- echo cp $1 `basename $1 .ml`.ppo
- cp $1 `basename $1 .ml`.ppo
-fi
diff --git a/camlp4/ocaml_src/tools/extract_crc.mpw b/camlp4/ocaml_src/tools/extract_crc.mpw
deleted file mode 100644
index 91dc4ddf9a..0000000000
--- a/camlp4/ocaml_src/tools/extract_crc.mpw
+++ /dev/null
@@ -1,3 +0,0 @@
-# $Id$
-
-"{OTOP}boot:ocamlrun" "{OTOP}otherlibs:dynlink:extract_crc" {"parameters"}
diff --git a/camlp4/ocaml_src/tools/ocamlc.mpw b/camlp4/ocaml_src/tools/ocamlc.mpw
deleted file mode 100644
index 7e594c03eb..0000000000
--- a/camlp4/ocaml_src/tools/ocamlc.mpw
+++ /dev/null
@@ -1,3 +0,0 @@
-#
-
-"{OTOP}boot:ocamlrun" "{OTOP}ocamlc" -I "{OTOP}stdlib" {"parameters"}
diff --git a/camlp4/ocaml_src/tools/ocamlc.sh b/camlp4/ocaml_src/tools/ocamlc.sh
deleted file mode 100755
index ee654c2c6f..0000000000
--- a/camlp4/ocaml_src/tools/ocamlc.sh
+++ /dev/null
@@ -1,8 +0,0 @@
-#!/bin/sh -e
-if test "`basename $OTOP`" != "ocaml_stuff"; then
- COMM=$OTOP/ocamlcomp.sh
-else
- COMM=ocamlc$OPT
-fi
-echo $COMM $*
-$COMM $*
diff --git a/camlp4/ocaml_src/tools/ocamlopt.sh b/camlp4/ocaml_src/tools/ocamlopt.sh
deleted file mode 100755
index 1fb669d670..0000000000
--- a/camlp4/ocaml_src/tools/ocamlopt.sh
+++ /dev/null
@@ -1,8 +0,0 @@
-#!/bin/sh -e
-if test "`basename $OTOP`" != "ocaml_stuff"; then
- COMM=$OTOP/ocamlcompopt.sh
-else
- COMM=ocamlopt$OPT
-fi
-echo $COMM $*
-$COMM $*
diff --git a/camlp4/ocaml_stuff/otherlibs/dynlink/.depend b/camlp4/ocaml_stuff/otherlibs/dynlink/.depend
deleted file mode 100644
index e69de29bb2..0000000000
--- a/camlp4/ocaml_stuff/otherlibs/dynlink/.depend
+++ /dev/null
diff --git a/camlp4/ocaml_stuff/parsing/.depend b/camlp4/ocaml_stuff/parsing/.depend
deleted file mode 100644
index 4364f56e08..0000000000
--- a/camlp4/ocaml_stuff/parsing/.depend
+++ /dev/null
@@ -1,2 +0,0 @@
-location.cmi: ../utils/warnings.cmi
-parsetree.cmi: asttypes.cmi location.cmi longident.cmi
diff --git a/camlp4/ocaml_stuff/utils/.depend b/camlp4/ocaml_stuff/utils/.depend
deleted file mode 100644
index 2804128851..0000000000
--- a/camlp4/ocaml_stuff/utils/.depend
+++ /dev/null
@@ -1,2 +0,0 @@
-config.cmo: config.cmi
-config.cmx: config.cmi
diff --git a/camlp4/ocpp/.cvsignore b/camlp4/ocpp/.cvsignore
deleted file mode 100644
index baef26c63b..0000000000
--- a/camlp4/ocpp/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-*.cm[oia]
-ocpp
-crc.ml
diff --git a/camlp4/ocpp/.depend b/camlp4/ocpp/.depend
deleted file mode 100644
index e69de29bb2..0000000000
--- a/camlp4/ocpp/.depend
+++ /dev/null
diff --git a/camlp4/ocpp/Makefile b/camlp4/ocpp/Makefile
deleted file mode 100644
index 60729e323c..0000000000
--- a/camlp4/ocpp/Makefile
+++ /dev/null
@@ -1,25 +0,0 @@
-# $Id$
-
-include ../config/Makefile
-
-SHELL=/bin/sh
-
-INCLUDES=-I ../camlp4 -I ../boot -I ../odyl -I $(OTOP)/otherlibs/dynlink
-OCAMLCFLAGS=-warn-error A $(INCLUDES)
-LINKFLAGS=$(INCLUDES)
-OBJS=ocpp.cmo
-
-all: ocpp$(EXE)
-
-ocpp$(EXE): $(OBJS)
- $(OCAMLC) $(LINKFLAGS) ../boot/stdpp.cmo ../camlp4/quotation.cmo ../odyl/odyl.cma $(OBJS) ../odyl/odyl.cmo -linkall -o ocpp$(EXE)
-
-clean::
- rm -f *.cm[ioa] *.pp[io] *.o *.out *.bak .*.bak ocpp$(EXE)
-
-install:
- -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)"
- cp $(OBJS) "$(LIBDIR)/camlp4/."
- cp ocpp$(EXE) "$(BINDIR)/."
-
-depend:
diff --git a/camlp4/ocpp/Makefile.Mac b/camlp4/ocpp/Makefile.Mac
deleted file mode 100644
index 5994a500c4..0000000000
--- a/camlp4/ocpp/Makefile.Mac
+++ /dev/null
@@ -1,41 +0,0 @@
-#######################################################################
-# #
-# Camlp4 #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. Distributed only by permission. #
-# #
-#######################################################################
-
-# $Id$
-
-INCLUDES = -I ::camlp4: -I ::boot: -I ::odyl: -I "{OTOP}otherlibs:dynlink:"
-OCAMLCFLAGS = {INCLUDES}
-LINKFLAGS = {INCLUDES}
-OBJS = crc.cmo ocpp.cmo
-INTERFACES = -I "{OLIBDIR}" Arg Array Callback Char Digest Filename Format ¶
- Gc Genlex Hashtbl Lexing List Map Obj Oo Parsing Pervasives ¶
- Printexc Printf Queue Random Set Sort Stack Stream String Sys ¶
- Weak -I ::boot: Gramext Grammar Plexer Stdpp Token -I ::camlp4: ¶
- MLast Quotation
-
-all Ä ocpp
-
-ocpp Ä {OBJS}
- {OCAMLC} {LINKFLAGS} ::boot:stdpp.cmo ::camlp4:quotation.cmo ¶
- ::odyl:odyl.cma {OBJS} ::odyl:odyl.cmo -linkall -o ocpp
-
-clean ÄÄ
- delete -i ocpp
-
-install Ä
- (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null
- (newfolder "{BINDIR}" || set status 0) ³ dev:null
- duplicate -y {OBJS} "{P4LIBDIR}"
- duplicate -y ocpp "{BINDIR}"
-
-depend Ä $OutOfDate
-
-{defrules}
diff --git a/camlp4/ocpp/ocpp.ml b/camlp4/ocpp/ocpp.ml
deleted file mode 100644
index afe517c0e5..0000000000
--- a/camlp4/ocpp/ocpp.ml
+++ /dev/null
@@ -1,140 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-value buff = ref (String.create 80);
-value store len x =
- do {
- if len >= String.length buff.val then
- buff.val := buff.val ^ String.create (String.length buff.val)
- else ();
- buff.val.[len] := x;
- succ len
- }
-;
-value get_buff len = String.sub buff.val 0 len;
-
-value rec copy_strip_locate cs =
- match cs with parser
- [ [: `'$' :] -> maybe_locate cs
- | [: `c :] -> do { print_char c; copy_strip_locate cs }
- | [: :] -> () ]
-and maybe_locate cs =
- match cs with parser
- [ [: `'1'..'9' :] -> locate cs
- | [: :] -> do { print_char '$'; copy_strip_locate cs } ]
-and locate cs =
- match cs with parser
- [ [: `'0'..'9' :] -> locate cs
- | [: `':' :] -> inside_locate cs
- | [: :] -> raise (Stream.Error "colon char expected") ]
-and inside_locate cs =
- match cs with parser
- [ [: `'$' :] -> copy_strip_locate cs
- | [: `'\\'; `c :] -> do { print_char c; inside_locate cs }
- | [: `c :] -> do { print_char c; inside_locate cs }
- | [: :] -> raise (Stream.Error "end of file in locate directive") ]
-;
-
-value quot name pos str =
- let exp =
- try
- match Quotation.find name with
- [ Quotation.ExStr f -> f
- | _ -> raise Not_found ]
- with
- [ Not_found ->
- Stdpp.raise_with_loc (pos, pos + String.length str) Not_found ]
- in
- let new_str =
- try exp True str with
- [ Stdpp.Exc_located (p1, p2) exc ->
- Stdpp.raise_with_loc (pos + p1, pos + p2) exc
- | exc -> Stdpp.raise_with_loc (pos, pos + String.length str) exc ]
- in
- let cs = Stream.of_string new_str in copy_strip_locate cs
-;
-
-value rec ident len =
- parser
- [ [: `('A'..'Z' | 'a'..'z' | '0'..'9' | '_' | ''' as c); s :] ->
- ident (store len c) s
- | [: :] -> get_buff len ]
-;
-
-value rec copy cs =
- match cs with parser
- [ [: `'<' :] -> maybe_quot cs
- | [: `'"' :] -> do { print_char '"'; inside_string cs }
- | [: `c :] -> do { print_char c; copy cs }
- | [: :] -> () ]
-and maybe_quot cs =
- match cs with parser
- [ [: `'<' :] ep -> inside_quot "" ep 0 cs
- | [: `':'; i = ident 0; `'<' ? "less char expected" :] ep ->
- inside_quot i ep 0 cs
- | [: :] -> do { print_char '<'; copy cs } ]
-and inside_quot name pos len cs =
- match cs with parser
- [ [: `'>' :] -> maybe_end_quot name pos len cs
- | [: `c :] -> inside_quot name pos (store len c) cs
- | [: :] -> raise (Stream.Error "end of file in quotation") ]
-and maybe_end_quot name pos len cs =
- match cs with parser
- [ [: `'>' :] -> do { quot name pos (get_buff len); copy cs }
- | [: :] -> inside_quot name pos (store len '>') cs ]
-and inside_string cs =
- match cs with parser
- [ [: `'"' :] -> do { print_char '"'; copy cs }
- | [: `c :] -> do { print_char c; inside_string cs }
- | [: :] -> raise (Stream.Error "end of file in string") ]
-;
-
-value copy_quot cs = do { copy cs; flush stdout; };
-
-value loc_fmt =
- match Sys.os_type with
- [ "MacOS" ->
- format_of_string "File \"%s\"; line %d; characters %d to %d\n### "
- | _ ->
- format_of_string "File \"%s\", line %d, characters %d-%d:\n" ]
-;
-
-value print_location loc file =
- let (fname, line, c1, c2) = Stdpp.line_of_loc file loc in
- do { Printf.eprintf loc_fmt file line c1 c2; flush stderr; }
-;
-
-value file = ref "";
-Arg.parse [] (fun x -> file.val := x) "ocpp <objects> <file>";
-
-value main () =
- try
- if file.val <> "" then
- copy_quot (Stream.of_channel (open_in_bin file.val))
- else ()
- with exc ->
- do {
- print_newline ();
- flush stdout;
- let exc =
- match exc with
- [ Stdpp.Exc_located loc exc -> do { print_location loc file.val; exc }
- | exc -> exc ]
- in
- raise exc
- }
-;
-
-Odyl_main.name.val := "ocpp";
-Odyl_main.go.val := main;
diff --git a/camlp4/odyl/.cvsignore b/camlp4/odyl/.cvsignore
deleted file mode 100644
index 8ae0ebb068..0000000000
--- a/camlp4/odyl/.cvsignore
+++ /dev/null
@@ -1,4 +0,0 @@
-*.cm[oia]
-odyl
-*.lib
-odyl_config.ml
diff --git a/camlp4/odyl/.depend b/camlp4/odyl/.depend
deleted file mode 100644
index b63c10b0b6..0000000000
--- a/camlp4/odyl/.depend
+++ /dev/null
@@ -1,6 +0,0 @@
-odyl_main.cmo: $(OTOP)/otherlibs/dynlink/dynlink.cmi odyl_config.cmo \
- odyl_main.cmi
-odyl_main.cmx: odyl_config.cmx \
- odyl_main.cmi
-odyl.cmo: odyl_config.cmo odyl_main.cmi
-odyl.cmx: odyl_config.cmx odyl_main.cmx
diff --git a/camlp4/odyl/Makefile b/camlp4/odyl/Makefile
deleted file mode 100644
index 73dc854e6f..0000000000
--- a/camlp4/odyl/Makefile
+++ /dev/null
@@ -1,61 +0,0 @@
-# $Id$
-
-include ../config/Makefile
-
-SHELL=/bin/sh
-
-INCLUDES=-I $(OTOP)/otherlibs/dynlink
-OCAMLCFLAGS=-warn-error A $(INCLUDES)
-LINKFLAGS=$(INCLUDES)
-
-OBJS=odyl_config.cmo odyl_main.cmo
-
-all: odyl$(EXE)
-
-opt: odyl.cmxa odyl.cmx
-
-odyl$(EXE): odyl.cma odyl.cmo
- $(OCAMLC) odyl.cma odyl.cmo -o odyl$(EXE)
-
-odyl.cma: $(OBJS)
- $(OCAMLC) $(LINKFLAGS) dynlink.cma $(OBJS) -a -o odyl.cma
-
-odyl.cmxa: $(OBJS:.cmo=.cmx)
- $(OCAMLOPT) $(LINKFLAGS) $(OBJS:.cmo=.cmx) -a -o odyl.cmxa
-
-odyl_main.cmx: odyl_main.ml
- $(CAMLP4_COMM) -nolib -DOPT -o odyl_main.ppo odyl_main.ml
- $(OCAMLOPT) -c -impl odyl_main.ppo
- rm -f odyl_main.ppo
-
-odyl_config.ml:
- (echo 'let standard_library ='; \
- echo ' try Sys.getenv "CAMLP4LIB" with Not_found -> '; \
- echo ' try Sys.getenv "OCAMLLIB" ^ "/camlp4" with Not_found -> '; \
- echo ' try Sys.getenv "CAMLLIB" ^ "/camlp4" with Not_found -> '; \
- echo ' "$(LIBDIR)/camlp4"') \
- | sed -e 's|\\|/|g' > odyl_config.ml
-
-clean::
- rm -f *.cm* *.pp[io] *.$(O) *.bak .*.bak *.out *.opt *.$(A)
- rm -f odyl_config.ml odyl$(EXE)
-
-depend:
- cp .depend .depend.bak
- > .depend
- @for i in *.mli *.ml; do \
- ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \
- sed -e 's| $(OTOP)/otherlibs/dynlink/dynlink.cmx||' | \
- sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \
- done
-
-promote:
-
-compare:
-
-install:
- -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)"
- cp odyl.cmo odyl.cma odyl_main.cmi $(LIBDIR)/camlp4/.
- if test -f odyl.cmxa; then cp odyl.cmxa odyl.$(A) $(LIBDIR)/camlp4/.; fi
-
-include .depend
diff --git a/camlp4/odyl/Makefile.Mac b/camlp4/odyl/Makefile.Mac
deleted file mode 100644
index 9814cec67e..0000000000
--- a/camlp4/odyl/Makefile.Mac
+++ /dev/null
@@ -1,49 +0,0 @@
-#######################################################################
-# #
-# Camlp4 #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. Distributed only by permission. #
-# #
-#######################################################################
-
-# $Id$
-
-INCLUDES = -I "{OTOP}otherlibs:dynlink:"
-OCAMLCFLAGS = {INCLUDES}
-LINKFLAGS = {INCLUDES}
-
-OBJS = odyl_config.cmo odyl_main.cmo
-
-all Ä odyl
-
-odyl Ä odyl.cma odyl.cmo
- {OCAMLC} odyl.cma odyl.cmo -o odyl
-
-odyl.cma Ä {OBJS}
- {OCAMLC} {LINKFLAGS} dynlink.cma {OBJS} -a -o odyl.cma
-
-odyl_config.cmo Ä
- echo 'let standard_library =' > odyl_config.ml
- echo ' try Sys.getenv "CAMLP4LIB" with' >> odyl_config.ml
- echo ' Not_found -> "'{P4LIBDIR}'"' >> odyl_config.ml
- {OCAMLC} {OCAMLCFLAGS} -c odyl_config.ml
-
-clean ÄÄ
- delete -i odyl_config.ml odyl
-
-{dependrule}
-
-promote Ä $OutOfDate
-
-compare Ä $OutOfDate
-
-install Ä
- (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null
- (newfolder "{BINDIR}" || set status 0) ³ dev:null
- duplicate -y odyl.cmo odyl.cma "{P4LIBDIR}"
- duplicate -y odyl "{BINDIR}"
-
-{defrules}
diff --git a/camlp4/odyl/Makefile.Mac.depend b/camlp4/odyl/Makefile.Mac.depend
deleted file mode 100644
index adaff27755..0000000000
--- a/camlp4/odyl/Makefile.Mac.depend
+++ /dev/null
@@ -1,4 +0,0 @@
-odyl_main.cmoÄ odyl_config.cmo odyl_main.cmi
-odyl_main.cmxÄ odyl_config.cmx odyl_main.cmi
-odyl.cmoÄ odyl_config.cmo odyl_main.cmi
-odyl.cmxÄ odyl_config.cmx odyl_main.cmx
diff --git a/camlp4/odyl/odyl.ml b/camlp4/odyl/odyl.ml
deleted file mode 100644
index 0bd4b17473..0000000000
--- a/camlp4/odyl/odyl.ml
+++ /dev/null
@@ -1,51 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-value apply_load () =
- let i = ref 1 in
- let stop = ref False in
- while not stop.val && i.val < Array.length Sys.argv do {
- let s = Sys.argv.(i.val) in
- if s = "-I" && i.val + 1 < Array.length Sys.argv then do {
- Odyl_main.directory Sys.argv.(i.val + 1);
- i.val := i.val + 2
- }
- else if s = "-nolib" then do { Odyl_main.nolib.val := True; incr i }
- else if s = "-where" then do {
- print_string Odyl_config.standard_library;
- print_newline ();
- flush stdout;
- exit 0
- }
- else if s = "--" then do { incr i; stop.val := True; () }
- else if String.length s > 0 && s.[0] == '-' then stop.val := True
- else if Filename.check_suffix s ".cmo" || Filename.check_suffix s ".cma"
- then do { Odyl_main.loadfile s; incr i }
- else stop.val := True
- }
-;
-
-value main () =
- try do { apply_load () ; Odyl_main.go.val () } with
- [ Odyl_main.Error fname str ->
- do {
- flush stdout;
- Printf.eprintf "Error while loading \"%s\": " fname;
- Printf.eprintf "%s.\n" str;
- flush stderr;
- exit 2
- } ]
-;
-
-Printexc.catch main ();
diff --git a/camlp4/odyl/odyl_main.ml b/camlp4/odyl/odyl_main.ml
deleted file mode 100644
index c0996568d0..0000000000
--- a/camlp4/odyl/odyl_main.ml
+++ /dev/null
@@ -1,82 +0,0 @@
-(* camlp4r pa_macro.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-value go = ref (fun () -> ());
-value name = ref "odyl";
-
-value first_arg_no_load () =
- loop 1 where rec loop i =
- if i < Array.length Sys.argv then
- match Sys.argv.(i) with
- [ "-I" -> loop (i + 2)
- | "-nolib" -> loop (i + 1)
- | "-where" -> loop (i + 1)
- | "--" -> i + 1
- | s ->
- if Filename.check_suffix s ".cmo"
- || Filename.check_suffix s ".cma" then loop (i + 1)
- else i ]
- else i
-;
-
-Arg.current.val := first_arg_no_load () - 1;
-
-(* Load files in core *)
-
-value find_in_path path name =
- if not (Filename.is_implicit name) then
- if Sys.file_exists name then name else raise Not_found
- else
- let rec try_dir =
- fun
- [ [] -> raise Not_found
- | [dir :: rem] ->
- let fullname = Filename.concat dir name in
- if Sys.file_exists fullname then fullname else try_dir rem ]
- in
- try_dir path
-;
-
-exception Error of string and string;
-
-value nolib = ref False;
-value initialized = ref False;
-value path = ref ([] : list string);
-
-value loadfile file =
- IFDEF OPT THEN
- raise (Error file "native-code program cannot do a dynamic load")
- ELSE do {
- if not initialized.val then do {
- IFDEF OPT THEN ()
- ELSE do { Dynlink.init (); Dynlink.allow_unsafe_modules True }
- END;
- initialized.val := True
- }
- else ();
- let path =
- if nolib.val then path.val
- else [Odyl_config.standard_library :: path.val]
- in
- let fname =
- try find_in_path (List.rev path) file with
- [ Not_found -> raise (Error file "file not found in path") ]
- in
- try Dynlink.loadfile fname with
- [ Dynlink.Error e -> raise (Error fname (Dynlink.error_message e)) ]
- }
- END
-;
-
-value directory d = path.val := [d :: path.val];
diff --git a/camlp4/odyl/odyl_main.mli b/camlp4/odyl/odyl_main.mli
deleted file mode 100644
index db47805370..0000000000
--- a/camlp4/odyl/odyl_main.mli
+++ /dev/null
@@ -1,13 +0,0 @@
-(* camlp4r *)
-(* $Id$ *)
-
-exception Error of string and string;
-
-value nolib : ref bool;
-value initialized : ref bool;
-value path : ref (list string);
-value loadfile : string -> unit;
-value directory : string -> unit;
-
-value go : ref (unit -> unit);
-value name : ref string;
diff --git a/camlp4/tools/apply.sh b/camlp4/tools/apply.sh
deleted file mode 100755
index 078b1d501e..0000000000
--- a/camlp4/tools/apply.sh
+++ /dev/null
@@ -1,31 +0,0 @@
-#!/bin/sh
-# $Id$
-
-ARGS1=
-FILE=
-while test "" != "$1"; do
- case $1 in
- *.ml*) FILE=$1;;
- *) ARGS1="$ARGS1 $1";;
- esac
- shift
-done
-
-# FILE must exist and be non empty (at least one line)
-test -s "$FILE" || exit 1
-
-
-
-set - `awk 'NR == 1' "$FILE"`
-if test "$2" = "camlp4r" -o "$2" = "camlp4"; then
- COMM="../boot/$2 -nolib -I ../boot -I ../etc"
- shift; shift
- ARGS2=`echo $* | sed -e "s/[()*]//g"`
-else
- COMM="../boot/camlp4 -nolib -I ../boot -I ../etc pa_o.cmo"
- ARGS2=
-fi
-
-OTOP=../..
-echo $OTOP/boot/ocamlrun $COMM $ARGS2 $ARGS1 $FILE 1>&2
-$OTOP/boot/ocamlrun $COMM $ARGS2 $ARGS1 $FILE
diff --git a/camlp4/tools/camlp4_comm.mpw b/camlp4/tools/camlp4_comm.mpw
deleted file mode 100644
index 274bead93d..0000000000
--- a/camlp4/tools/camlp4_comm.mpw
+++ /dev/null
@@ -1,53 +0,0 @@
-#######################################################################
-# #
-# Camlp4 #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. Distributed only by permission. #
-# #
-#######################################################################
-
-# $Id$
-
-set echo 0
-
-exit if {#} < 1
-
-set args1 ""
-set file ""
-loop
- break if {#} == 0
- if "{1}" =~ /Å.mlÅ/
- set file "{1}"
- else
- set args1 "{args1} `quote "{1}"`"
- end
- shift
-end
-
-set firstline "`streamedit -e '1 exit' "{file}"`" ³ dev:null || set status 0
-
-if "{firstline}" =~ /[Â ]+ camlp4r (Å)¨0/
- set args0 "`echo "{¨0}" | streamedit -e '1,$ replace -c ° /[()*]/ ""' ¶
- -e '1,$ replace -c ° /.¶// ":"'`"
- set comm "{OTOP}boot:ocamlrun ::boot:camlp4r -nolib -I ::boot:"
- echo "{comm} {args0} {args1} {file}"
- {comm} {args0} {args1} "{file}"
-else if "{firstline}" =~ /[Â ]+ camlp4 (Å)¨0/
- set args0 "`echo "{¨0}" | streamedit -e '1,$ replace -c ° /[()*]/ ""' ¶
- -e '1,$ replace -c ° /.¶// ":"'`"
- set comm "{OTOP}boot:ocamlrun ::boot:camlp4 -nolib -I ::boot:"
- echo "{comm} {args0} {args1} {file}"
- {comm} {args0} {args1} "{file}"
-else if "{file}" =~ /(Å)¨0.mli/
- echo duplicate -y {file} {¨0}.ppi
- duplicate -y "{file}" "{¨0}.ppi"
-else if "{file}" =~ /(Å)¨0.ml/
- echo duplicate -y {file} {¨0}.ppo
- duplicate -y "{file}" "{¨0}.ppo"
-else
- echo duplicate -y {file} {file}.ppo
- duplicate -y "{file}" "{file}.ppo"
-end
diff --git a/camlp4/tools/camlp4_comm.sh b/camlp4/tools/camlp4_comm.sh
deleted file mode 100755
index b6bb8f87ed..0000000000
--- a/camlp4/tools/camlp4_comm.sh
+++ /dev/null
@@ -1,38 +0,0 @@
-#!/bin/sh
-# $Id$
-
-ARGS1=
-FILE=
-QUIET=no
-while test "" != "$1"; do
- case $1 in
- -q) QUIET=yes;;
- *.ml*) FILE=$1;;
- *) ARGS1="$ARGS1 $1";;
- esac
- shift
-done
-
-# FILE must exist and be non empty (at least one line)
-test -s "$FILE" || exit 1
-
-set - `awk 'NR == 1' "$FILE"`
-if test "$2" = "camlp4r" -o "$2" = "camlp4"; then
- COMM="ocamlrun$EXE ../boot/$2$EXE -nolib -I ../boot"
- if test "`basename $OTOP`" != "ocaml_stuff"; then
- COMM="$OTOP/boot/$COMM"
- fi
- shift; shift
- ARGS2=`echo $* | sed -e "s/[()*]//g"`
-# ARGS1="$ARGS1 -verbose"
- if test "$QUIET" = "no"; then echo $COMM $ARGS2 $ARGS1 $FILE; fi
- $COMM $ARGS2 $ARGS1 $FILE
-else
- if test "`basename $FILE .mli`.mli" = "$FILE"; then
- OFILE=`basename $FILE .mli`.ppi
- else
- OFILE=`basename $FILE .ml`.ppo
- fi
- if test "$QUIET" = "no"; then echo cp $FILE $OFILE; fi
- cp $FILE $OFILE
-fi
diff --git a/camlp4/tools/conv.sh b/camlp4/tools/conv.sh
deleted file mode 100755
index 64a4e2b1d3..0000000000
--- a/camlp4/tools/conv.sh
+++ /dev/null
@@ -1,22 +0,0 @@
-#!/bin/sh
-DIR=`expr "$0" : "\(.*\)/.*" "|" "."`
-
-INCL=
-FILE=
-while test "" != "$1"; do
- case $1 in
- -I) INCL="$INCL -I $2"; shift;;
- *) FILE=$1;;
- esac
- shift
-done
-
-set - `awk 'NR == 1' "$FILE"`
-if test "$2" = "camlp4r" -o "$2" = "camlp4"; then
- COMM="$OTOP/boot/ocamlrun $DIR/../boot/$2 -nolib -I $DIR/../boot $INCL $DIR/../etc/pr_o.cmo"
- shift; shift
- ARGS=`echo $* | sed -e "s/[()*]//g"`
- $COMM $ARGS -ss $FILE
-else
- cat $FILE
-fi
diff --git a/camlp4/tools/extract_crc.mpw b/camlp4/tools/extract_crc.mpw
deleted file mode 100644
index 91dc4ddf9a..0000000000
--- a/camlp4/tools/extract_crc.mpw
+++ /dev/null
@@ -1,3 +0,0 @@
-# $Id$
-
-"{OTOP}boot:ocamlrun" "{OTOP}otherlibs:dynlink:extract_crc" {"parameters"}
diff --git a/camlp4/tools/extract_crc.sh b/camlp4/tools/extract_crc.sh
deleted file mode 100755
index e69de29bb2..0000000000
--- a/camlp4/tools/extract_crc.sh
+++ /dev/null
diff --git a/camlp4/tools/ocamlc.mpw b/camlp4/tools/ocamlc.mpw
deleted file mode 100644
index 6e21e9bf19..0000000000
--- a/camlp4/tools/ocamlc.mpw
+++ /dev/null
@@ -1,3 +0,0 @@
-# $Id$
-
-"{OTOP}boot:ocamlrun" "{OTOP}ocamlc" -I "{OTOP}stdlib:" {"parameters"}
diff --git a/camlp4/tools/ocamlc.sh b/camlp4/tools/ocamlc.sh
deleted file mode 100755
index ee654c2c6f..0000000000
--- a/camlp4/tools/ocamlc.sh
+++ /dev/null
@@ -1,8 +0,0 @@
-#!/bin/sh -e
-if test "`basename $OTOP`" != "ocaml_stuff"; then
- COMM=$OTOP/ocamlcomp.sh
-else
- COMM=ocamlc$OPT
-fi
-echo $COMM $*
-$COMM $*
diff --git a/camlp4/tools/ocamlopt.sh b/camlp4/tools/ocamlopt.sh
deleted file mode 100755
index 1fb669d670..0000000000
--- a/camlp4/tools/ocamlopt.sh
+++ /dev/null
@@ -1,8 +0,0 @@
-#!/bin/sh -e
-if test "`basename $OTOP`" != "ocaml_stuff"; then
- COMM=$OTOP/ocamlcompopt.sh
-else
- COMM=ocamlopt$OPT
-fi
-echo $COMM $*
-$COMM $*
diff --git a/camlp4/top/.cvsignore b/camlp4/top/.cvsignore
deleted file mode 100644
index df1824f495..0000000000
--- a/camlp4/top/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-*.cm[oia]
diff --git a/camlp4/top/.depend b/camlp4/top/.depend
deleted file mode 100644
index d7aebc7bc5..0000000000
--- a/camlp4/top/.depend
+++ /dev/null
@@ -1,14 +0,0 @@
-camlp4_top.cmo: ../camlp4/ast2pt.cmi ../camlp4/mLast.cmi \
- $(OTOP)/parsing/parsetree.cmi ../camlp4/pcaml.cmi \
- $(OTOP)/toplevel/topdirs.cmi $(OTOP)/toplevel/toploop.cmi \
- $(OTOP)/utils/warnings.cmi
-camlp4_top.cmx: ../camlp4/ast2pt.cmx ../camlp4/mLast.cmi \
- $(OTOP)/parsing/parsetree.cmi ../camlp4/pcaml.cmx \
- $(OTOP)/toplevel/topdirs.cmx $(OTOP)/toplevel/toploop.cmx \
- $(OTOP)/utils/warnings.cmx
-oprint.cmo: $(OTOP)/typing/outcometree.cmi $(OTOP)/toplevel/toploop.cmi
-oprint.cmx: $(OTOP)/typing/outcometree.cmi $(OTOP)/toplevel/toploop.cmx
-rprint.cmo: $(OTOP)/parsing/asttypes.cmi $(OTOP)/typing/outcometree.cmi \
- $(OTOP)/toplevel/toploop.cmi
-rprint.cmx: $(OTOP)/parsing/asttypes.cmi $(OTOP)/typing/outcometree.cmi \
- $(OTOP)/toplevel/toploop.cmx
diff --git a/camlp4/top/Makefile b/camlp4/top/Makefile
deleted file mode 100644
index 4ea4e46bc2..0000000000
--- a/camlp4/top/Makefile
+++ /dev/null
@@ -1,52 +0,0 @@
-# $Id$
-
-include ../config/Makefile
-
-INCLUDES=-I ../camlp4 -I ../boot -I $(OTOP)/utils -I $(OTOP)/parsing -I $(OTOP)/typing -I $(OTOP)/toplevel
-OCAMLCFLAGS=-warn-error A $(INCLUDES)
-
-CAMLP4_OBJS=$(OTOP)/utils/config.cmo ../boot/stdpp.cmo ../boot/token.cmo ../boot/plexer.cmo ../boot/gramext.cmo ../boot/grammar.cmo ../boot/extfold.cmo ../boot/extfun.cmo ../boot/fstream.cmo ../camlp4/quotation.cmo ../camlp4/ast2pt.cmo ../camlp4/reloc.cmo ../camlp4/spretty.cmo ../camlp4/pcaml.cmo
-TOP=camlp4_top.cmo
-ROBJS=$(CAMLP4_OBJS) ../meta/pa_r.cmo ../meta/pa_rp.cmo rprint.cmo $(TOP)
-SOBJS=$(CAMLP4_OBJS) ../etc/pa_scheme.cmo $(TOP)
-OOBJS=$(CAMLP4_OBJS) ../etc/pa_o.cmo ../etc/pa_op.cmo $(TOP)
-OOOBJS=$(CAMLP4_OBJS) ../etc/pa_o.cmo ../etc/pa_oop.cmo $(TOP)
-OBJS=$(OTOP)/utils/config.cmo ../camlp4/quotation.cmo ../camlp4/reloc.cmo ../camlp4/ast2pt.cmo ../camlp4/spretty.cmo ../camlp4/pcaml.cmo camlp4_top.cmo
-
-TARGET=camlp4o.cma camlp4r.cma camlp4sch.cma camlp4_top.cma
-
-all: $(TARGET)
-
-camlp4oo.cma: $(OOOBJS)
- $(OCAMLC) $(OOOBJS) -linkall -a -o camlp4oo.cma
-
-camlp4o.cma: $(OOBJS)
- $(OCAMLC) $(OOBJS) -linkall -a -o camlp4o.cma
-
-camlp4r.cma: $(ROBJS)
- $(OCAMLC) $(ROBJS) -linkall -a -o camlp4r.cma
-
-camlp4sch.cma: $(SOBJS)
- $(OCAMLC) $(SOBJS) -linkall -a -o camlp4sch.cma
-
-camlp4_top.cma: $(OBJS)
- $(OCAMLC) $(OBJS) -a -o camlp4_top.cma
-
-clean::
- rm -f *.cm[ioa] *.pp[io] *.o *.bak .*.bak $(TARGET)
-
-depend:
- cp .depend .depend.bak
- > .depend
- @for i in *.mli *.ml; do \
- ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \
- sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \
- done
-
-get_promote:
-
-install:
- -$(MKDIR) "$(LIBDIR)/camlp4"
- cp $(TARGET) "$(LIBDIR)/camlp4/."
-
-include .depend
diff --git a/camlp4/top/Makefile.Mac b/camlp4/top/Makefile.Mac
deleted file mode 100644
index bb2aa44506..0000000000
--- a/camlp4/top/Makefile.Mac
+++ /dev/null
@@ -1,60 +0,0 @@
-#######################################################################
-# #
-# Camlp4 #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. Distributed only by permission. #
-# #
-#######################################################################
-
-# $Id$
-
-INCLUDES = -I ::camlp4: -I ::boot: -I "{OTOP}utils:" -I "{OTOP}parsing:" ¶
- -I "{OTOP}typing:" -I "{OTOP}toplevel:"
-OCAMLCFLAGS = {INCLUDES}
-
-CAMLP4_OBJS = "{OTOP}utils:config.cmo" ::boot:stdpp.cmo ::boot:token.cmo ¶
- ::boot:plexer.cmo ¶
- ::boot:gramext.cmo ::boot:grammar.cmo ::boot:extfold.cmo ::boot:extfun.cmo ¶
- ::boot:fstream.cmo ¶
- ::camlp4:quotation.cmo ¶
- ::camlp4:ast2pt.cmo ::camlp4:reloc.cmo ::camlp4:spretty.cmo ¶
- ::camlp4:pcaml.cmo
-TOP = camlp4_top.cmo
-ROBJS = {CAMLP4_OBJS} ::meta:pa_r.cmo ::meta:pa_rp.cmo rprint.cmo {TOP}
-OOBJS = {CAMLP4_OBJS} ::etc:pa_o.cmo ::etc:pa_op.cmo {TOP}
-OOOBJS = {CAMLP4_OBJS} ::etc:pa_o.cmo ::etc:pa_oop.cmo {TOP}
-OBJS = "{OTOP}utils:config.cmo" ::camlp4:quotation.cmo ::camlp4:reloc.cmo ¶
- ::camlp4:ast2pt.cmo ::camlp4:spretty.cmo ¶
- ::camlp4:pcaml.cmo camlp4_top.cmo
-
-TARGETS = camlp4o.cma camlp4r.cma camlp4_top.cma
-
-all Ä {TARGETS}
-
-camlp4oo.cma Ä {OOOBJS}
- {OCAMLC} {OOOBJS} -linkall -a -o camlp4oo.cma
-
-camlp4o.cma Ä {OOBJS}
- {OCAMLC} {OOBJS} -linkall -a -o camlp4o.cma
-
-camlp4r.cma Ä {ROBJS}
- {OCAMLC} {ROBJS} -linkall -a -o camlp4r.cma
-
-camlp4_top.cma Ä {OBJS}
- {OCAMLC} {OBJS} -a -o camlp4_top.cma
-
-clean ÄÄ
- delete -i {TARGETS}
-
-{dependrule}
-
-get_promote Ä $OutOfDate
-
-install Ä
- (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null
- duplicate -y {TARGETS} "{P4LIBDIR}"
-
-{defrules}
diff --git a/camlp4/top/Makefile.Mac.depend b/camlp4/top/Makefile.Mac.depend
deleted file mode 100644
index 6b7096dadb..0000000000
--- a/camlp4/top/Makefile.Mac.depend
+++ /dev/null
@@ -1,2 +0,0 @@
-camlp4_top.cmoÄ ::camlp4:ast2pt.cmo ::camlp4:mLast.cmi ::camlp4:pcaml.cmi
-camlp4_top.cmxÄ ::camlp4:ast2pt.cmx ::camlp4:mLast.cmi ::camlp4:pcaml.cmx
diff --git a/camlp4/top/camlp4_top.ml b/camlp4/top/camlp4_top.ml
deleted file mode 100644
index 4d0d12f785..0000000000
--- a/camlp4/top/camlp4_top.ml
+++ /dev/null
@@ -1,172 +0,0 @@
-(* camlp4r q_MLast.cmo *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Parsetree;
-open Lexing;
-open Stdpp;
-
-value highlight_locations lb loc1 loc2 =
- try
- let pos0 = - lb.lex_abs_pos in
- do {
- if pos0 < 0 then raise Exit else ();
- let pos_at_bol = ref 0 in
- print_string "Toplevel input:\n# ";
- for pos = 0 to lb.lex_buffer_len - pos0 - 1 do {
- let c = lb.lex_buffer.[pos + pos0] in
- if c = '\n' then do {
- if pos_at_bol.val <= fst loc1 && snd loc1 <= pos then do {
- print_string "\n ";
- for i = pos_at_bol.val to fst loc1 - 1 do { print_char ' ' };
- for i = fst loc1 to snd loc1 - 1 do { print_char '^' };
- print_char '\n'
- }
- else if pos_at_bol.val <= fst loc1 && fst loc1 < pos then do {
- print_char '\r';
- print_char (if pos_at_bol.val = 0 then '#' else ' ');
- print_char ' ';
- for i = pos_at_bol.val to fst loc1 - 1 do { print_char '.' };
- print_char '\n'
- }
- else if pos_at_bol.val <= snd loc1 && snd loc1 < pos then do {
- for i = pos - 1 downto snd loc1 do { print_string "\008.\008" };
- print_char '\n'
- }
- else print_char '\n';
- pos_at_bol.val := pos + 1;
- if pos < lb.lex_buffer_len - pos0 - 1 then
- print_string " "
- else ()
- }
- else print_char c
- };
- flush stdout
- }
- with
- [ Exit -> () ]
-;
-
-value print_location lb loc =
- if String.length Toploop.input_name.val = 0 then
- highlight_locations lb loc (-1, -1)
- else Toploop.print_location Format.err_formatter (Ast2pt.mkloc loc)
-;
-
-value wrap f shfn lb =
- let cs =
- let shift = shfn lb in
- Stream.from
- (fun i ->
- if i < shift then Some ' '
- else do {
- while
- lb.lex_curr_pos >= lb.lex_buffer_len &&
- not lb.lex_eof_reached
- do {
- lb.refill_buff lb
- };
- if lb.lex_curr_pos >= lb.lex_buffer_len then None
- else do {
- let c = lb.lex_buffer.[lb.lex_curr_pos] in
- lb.lex_curr_pos := lb.lex_curr_pos + 1;
- Some c
- }
- })
- in
- try f cs with
- [ Exc_located _ (Sys.Break as x) -> raise x
- | End_of_file as x -> raise x
- | x ->
- let x =
- match x with
- [ Exc_located loc x -> do { print_location lb loc; x }
- | x -> x ]
- in
- do {
- match x with
- [ Stream.Failure | Stream.Error _ -> Pcaml.sync.val cs
- | _ -> () ];
- Format.open_hovbox 0;
- Pcaml.report_error x;
- Format.close_box ();
- Format.print_newline ();
- raise Exit
- } ]
-;
-
-value first_phrase = ref True;
-
-value toplevel_phrase cs =
- do {
- if Sys.interactive.val && first_phrase.val then do {
- first_phrase.val := False;
- Printf.eprintf "\tCamlp4 Parsing version %s\n\n" Pcaml.version;
- flush stderr;
- }
- else ();
- match Grammar.Entry.parse Pcaml.top_phrase cs with
- [ Some phr -> Ast2pt.phrase phr
- | None -> raise End_of_file ];
- }
-;
-
-value use_file cs =
- let v = Pcaml.input_file.val in
- do {
- Pcaml.input_file.val := Toploop.input_name.val;
- let restore () = Pcaml.input_file.val := v in
- try
- let (pl0, eoi) =
- loop () where rec loop () =
- let (pl, stopped_at_directive) =
- Grammar.Entry.parse Pcaml.use_file cs
- in
- if stopped_at_directive then
- match pl with
- [ [MLast.StDir _ "load" (Some <:expr< $str:s$ >>)] ->
- do { Topdirs.dir_load Format.std_formatter s; loop () }
- | [MLast.StDir _ "directory" (Some <:expr< $str:s$ >>)] ->
- do { Topdirs.dir_directory s; loop () }
- | _ -> (pl, False) ]
- else (pl, True)
- in
- let pl =
- if eoi then []
- else
- loop () where rec loop () =
- let (pl, stopped_at_directive) =
- Grammar.Entry.parse Pcaml.use_file cs
- in
- if stopped_at_directive then pl @ loop () else pl
- in
- let r = pl0 @ pl in
- let r = List.map Ast2pt.phrase r in
- do { restore (); r }
- with e ->
- do { restore (); raise e }
- }
-;
-
-Toploop.parse_toplevel_phrase.val :=
- wrap toplevel_phrase (fun _ -> 0)
-;
-
-Toploop.parse_use_file.val :=
- wrap use_file (fun lb -> lb.lex_curr_pos - lb.lex_start_pos)
-;
-
-Pcaml.warning.val :=
- fun loc txt ->
- Toploop.print_warning (Ast2pt.mkloc loc) Format.err_formatter
- (Warnings.Other txt);
diff --git a/camlp4/top/oprint.ml b/camlp4/top/oprint.ml
deleted file mode 100644
index 15600c2411..0000000000
--- a/camlp4/top/oprint.ml
+++ /dev/null
@@ -1,597 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Format;
-open Outcometree;
-
-exception Ellipsis;
-value cautious f ppf arg =
- try f ppf arg with [ Ellipsis -> fprintf ppf "..." ]
-;
-
-value rec print_ident ppf =
- fun
- [ Oide_ident s -> fprintf ppf "%s" s
- | Oide_dot id s -> fprintf ppf "%a.%s" print_ident id s
- | Oide_apply id1 id2 ->
- fprintf ppf "%a(%a)" print_ident id1 print_ident id2 ]
-;
-
-value value_ident ppf name =
- if List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"]
- then
- fprintf ppf "( %s )" name
- else
- match name.[0] with
- [ 'a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' ->
- fprintf ppf "%s" name
- | _ -> fprintf ppf "( %s )" name ]
-;
-
-(* Values *)
-
-value print_out_value ppf tree =
- let rec print_tree ppf =
- fun
- [ Oval_tuple tree_list ->
- fprintf ppf "@[%a@]" (print_tree_list print_tree_1 ",") tree_list
- | tree -> print_tree_1 ppf tree ]
- and print_tree_1 ppf =
- fun
- [ Oval_constr name [param] ->
- fprintf ppf "@[<1>%a@ %a@]" print_ident name print_simple_tree param
- | Oval_constr name ([_ :: _] as params) ->
- fprintf ppf "@[<1>%a@ (%a)@]" print_ident name
- (print_tree_list print_tree_1 ",") params
- | Oval_variant name (Some param) ->
- fprintf ppf "@[<2>`%s@ %a@]" name print_simple_tree param
- | tree -> print_simple_tree ppf tree ]
- and print_simple_tree ppf =
- fun
- [ Oval_int i -> fprintf ppf "%i" i
- | Oval_int32 i -> fprintf ppf "%ldl" i
- | Oval_int64 i -> fprintf ppf "%LdL" i
- | Oval_nativeint i -> fprintf ppf "%ndn" i
- | Oval_float f -> fprintf ppf "%F" f
- | Oval_char c -> fprintf ppf "%C" c
- | Oval_string s ->
- try fprintf ppf "%S" s with
- [ Invalid_argument "String.create" -> fprintf ppf "<huge string>" ]
- | Oval_list tl ->
- fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree_1 ";") tl
- | Oval_array tl ->
- fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ";") tl
- | Oval_constr name [] -> print_ident ppf name
- | Oval_variant name None -> fprintf ppf "`%s" name
- | Oval_stuff s -> fprintf ppf "%s" s
- | Oval_record fel ->
- fprintf ppf "@[<1>{%a}@]" (cautious (print_fields True)) fel
- | Oval_ellipsis -> raise Ellipsis
- | Oval_printer f -> f ppf
- | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree) tree ]
- and print_fields first ppf =
- fun
- [ [] -> ()
- | [(name, tree) :: fields] ->
- do {
- if not first then fprintf ppf ";@ " else ();
- fprintf ppf "@[<1>%a@ =@ %a@]" print_ident name
- (cautious print_tree) tree;
- print_fields False ppf fields
- } ]
- and print_tree_list print_item sep ppf tree_list =
- let rec print_list first ppf =
- fun
- [ [] -> ()
- | [tree :: tree_list] ->
- do {
- if not first then fprintf ppf "%s@ " sep else ();
- print_item ppf tree;
- print_list False ppf tree_list
- } ]
- in
- cautious (print_list True) ppf tree_list
- in
- cautious print_tree ppf tree
-;
-
-(* Types *)
-
-value rec print_list_init pr sep ppf =
- fun
- [ [] -> ()
- | [a :: l] -> do { sep ppf; pr ppf a; print_list_init pr sep ppf l } ]
-;
-
-value pr_vars =
- print_list (fun ppf s -> fprintf ppf "'%s" s) (fun ppf -> fprintf ppf "@ ")
-;
-
-value rec print_list pr sep ppf =
- fun
- [ [] -> ()
- | [a] -> pr ppf a
- | [a :: l] -> do { pr ppf a; sep ppf; print_list pr sep ppf l } ]
-;
-
-value pr_present =
- print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ")
-;
-
-value rec print_out_type ppf =
- fun
- [ Otyp_alias ty s -> fprintf ppf "@[%a as '%s@]" print_out_type ty s
- | Otyp_poly sl ty ->
- fprintf ppf "@[<hov 2>%a.@ %a@]"
- pr_vars sl
- print_out_type ty
- | ty -> print_out_type_1 ppf ty ]
-and print_out_type_1 ppf =
- fun
- [ Otyp_arrow lab ty1 ty2 ->
- fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "")
- print_out_type_2 ty1 print_out_type_1 ty2
- | ty -> print_out_type_2 ppf ty ]
-and print_out_type_2 ppf =
- fun
- [ Otyp_tuple tyl ->
- fprintf ppf "@[<0>%a@]" (print_typlist print_simple_out_type " *") tyl
- | ty -> print_simple_out_type ppf ty ]
-and print_simple_out_type ppf =
- fun
- [ Otyp_class ng id tyl ->
- fprintf ppf "@[%a%s#%a@]" print_typargs tyl (if ng then "_" else "")
- print_ident id
- | Otyp_constr id tyl ->
- fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id
- | Otyp_object fields rest ->
- fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields
- | Otyp_stuff s -> fprintf ppf "%s" s
- | Otyp_var ng s -> fprintf ppf "'%s%s" (if ng then "_" else "") s
- | Otyp_variant non_gen row_fields closed tags ->
- let print_present ppf =
- fun
- [ None | Some [] -> ()
- | Some l -> fprintf ppf "@;<1 -2>> @[<hov>%a@]" pr_present l ]
- in
- let print_fields ppf =
- fun
- [ Ovar_fields fields ->
- print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ")
- ppf fields
- | Ovar_name id tyl ->
- fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id ]
- in
- fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a]@]" (if non_gen then "_" else "")
- (if closed then if tags = None then " " else "< "
- else if tags = None then "> "
- else "? ")
- print_fields row_fields print_present tags
- | Otyp_alias _ _ | Otyp_poly _ | Otyp_arrow _ _ _ | Otyp_tuple _ as ty ->
- fprintf ppf "@[<1>(%a)@]" print_out_type ty
- | Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_private _
- | Otyp_manifest _ _ -> () ]
-and print_fields rest ppf =
- fun
- [ [] ->
- match rest with
- [ Some non_gen -> fprintf ppf "%s.." (if non_gen then "_" else "")
- | None -> () ]
- | [(s, t)] ->
- do {
- fprintf ppf "%s : %a" s print_out_type t;
- match rest with
- [ Some _ -> fprintf ppf ";@ "
- | None -> () ];
- print_fields rest ppf []
- }
- | [(s, t) :: l] ->
- fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l ]
-and print_row_field ppf (l, opt_amp, tyl) =
- let pr_of ppf =
- if opt_amp then fprintf ppf " of@ &@ "
- else if tyl <> [] then fprintf ppf " of@ "
- else fprintf ppf ""
- in
- fprintf ppf "@[<hv 2>`%s%t%a@]" l pr_of (print_typlist print_out_type " &")
- tyl
-and print_typlist print_elem sep ppf =
- fun
- [ [] -> ()
- | [ty] -> print_elem ppf ty
- | [ty :: tyl] ->
- fprintf ppf "%a%s@ %a" print_elem ty sep (print_typlist print_elem sep)
- tyl ]
-and print_typargs ppf =
- fun
- [ [] -> ()
- | [ty1] -> fprintf ppf "%a@ " print_simple_out_type ty1
- | tyl ->
- fprintf ppf "@[<1>(%a)@]@ " (print_typlist print_out_type ",") tyl ]
-;
-
-(* Signature items *)
-
-value print_out_class_params ppf =
- fun
- [ [] -> ()
- | tyl ->
- fprintf ppf "@[<1>[%a]@]@ "
- (print_list (fun ppf x -> fprintf ppf "'%s" x)
- (fun ppf -> fprintf ppf ", "))
- tyl ]
-;
-
-value rec print_out_class_type ppf =
- fun
- [ Octy_constr id tyl ->
- let pr_tyl ppf =
- fun
- [ [] -> ()
- | tyl ->
- fprintf ppf "@[<1>[%a]@]@ " (print_typlist print_out_type ",")
- tyl ]
- in
- fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id
- | Octy_fun lab ty cty ->
- fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "")
- print_out_type_2 ty print_out_class_type cty
- | Octy_signature self_ty csil ->
- let pr_param ppf =
- fun
- [ Some ty -> fprintf ppf "@ @[(%a)@]" print_out_type ty
- | None -> () ]
- in
- fprintf ppf "@[<hv 2>@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty
- (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ "))
- csil ]
-and print_out_class_sig_item ppf =
- fun
- [ Ocsg_constraint ty1 ty2 ->
- fprintf ppf "@[<2>constraint %a =@ %a@]" print_out_type ty1
- print_out_type ty2
- | Ocsg_method name priv virt ty ->
- fprintf ppf "@[<2>method %s%s%s :@ %a@]"
- (if priv then "private " else "") (if virt then "virtual " else "")
- name print_out_type ty
- | Ocsg_value name mut ty ->
- fprintf ppf "@[<2>val %s%s :@ %a@]" (if mut then "mutable " else "")
- name print_out_type ty ]
-;
-
-value rec print_out_module_type ppf =
- fun
- [ Omty_abstract -> ()
- | Omty_functor name mty_arg mty_res ->
- fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name
- print_out_module_type mty_arg print_out_module_type mty_res
- | Omty_ident id -> fprintf ppf "%a" print_ident id
- | Omty_signature sg ->
- fprintf ppf "@[<hv 2>sig@ %a@;<1 -2>end@]" print_signature_body sg ]
-and print_signature_body ppf =
- fun
- [ [] -> ()
- | [item] -> print_out_sig_item ppf item
- | [item :: items] ->
- fprintf ppf "%a@ %a" print_out_sig_item item
- print_signature_body items ]
-and print_out_sig_item ppf =
- fun
- [ Osig_class vir_flag name params clt ->
- fprintf ppf "@[<2>class%s@ %a%s@ :@ %a@]"
- (if vir_flag then " virtual" else "") print_out_class_params params
- name print_out_class_type clt
- | Osig_class_type vir_flag name params clt ->
- fprintf ppf "@[<2>class type%s@ %a%s@ =@ %a@]"
- (if vir_flag then " virtual" else "") print_out_class_params params
- name print_out_class_type clt
- | Osig_exception id tyl ->
- fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl)
- | Osig_modtype name Omty_abstract ->
- fprintf ppf "@[<2>module type %s@]" name
- | Osig_modtype name mty ->
- fprintf ppf "@[<2>module type %s =@ %a@]" name print_out_module_type mty
- | Osig_module name mty ->
- fprintf ppf "@[<2>module %s :@ %a@]" name print_out_module_type mty
- | Osig_type tdl -> print_out_type_decl_list ppf tdl
- | Osig_value name ty prims ->
- let kwd = if prims = [] then "val" else "external" in
- let pr_prims ppf =
- fun
- [ [] -> ()
- | [s :: sl] ->
- do {
- fprintf ppf "@ = \"%s\"" s;
- List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl
- } ]
- in
- fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident name
- print_out_type ty pr_prims prims ]
-and print_out_type_decl_list ppf =
- fun
- [ [] -> ()
- | [x] -> print_out_type_decl "type" ppf x
- | [x :: l] ->
- do {
- print_out_type_decl "type" ppf x;
- List.iter (fun x -> fprintf ppf "@ %a" (print_out_type_decl "and") x)
- l
- } ]
-and print_out_type_decl kwd ppf (name, args, ty, constraints) =
- let print_constraints ppf params =
- List.iter
- (fun (ty1, ty2) ->
- fprintf ppf "@ @[<2>constraint %a =@ %a@]" print_out_type
- ty1 print_out_type ty2)
- params
- in
- let type_parameter ppf (ty, (co, cn)) =
- fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "")
- ty
- in
- let type_defined ppf =
- match args with
- [ [] -> fprintf ppf "%s" name
- | [arg] -> fprintf ppf "@[%a@ %s@]" type_parameter arg name
- | _ ->
- fprintf ppf "@[(@[%a)@]@ %s@]"
- (print_list type_parameter (fun ppf -> fprintf ppf ",@ ")) args
- name ]
- in
- let print_manifest ppf =
- fun
- [ Otyp_manifest ty _ -> fprintf ppf " =@ %a" print_out_type ty
- | _ -> () ]
- in
- let print_name_args ppf =
- fprintf ppf "%s %t%a" kwd type_defined print_manifest ty
- in
- let ty =
- match ty with
- [ Otyp_manifest _ ty -> ty
- | _ -> ty ]
- in
- match ty with
- [ Otyp_abstract ->
- fprintf ppf "@[<2>@[<hv 2>%t@]%a@]" print_name_args print_constraints
- constraints
- | Otyp_record lbls ->
- fprintf ppf "@[<2>@[<hv 2>%t = {%a@;<1 -2>}@]@ %a@]" print_name_args
- (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls
- print_constraints constraints
- | Otyp_sum constrs ->
- fprintf ppf "@[<2>@[<hv 2>%t =@;<1 2>%a@]%a@]" print_name_args
- (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs
- print_constraints constraints
- | ty ->
- fprintf ppf "@[<2>@[<hv 2>%t =@ %a@]%a@]" print_name_args
- print_out_type ty print_constraints constraints ]
-and print_out_constr ppf (name, tyl) =
- match tyl with
- [ [] -> fprintf ppf "%s" name
- | _ ->
- fprintf ppf "@[<2>%s of@ %a@]" name
- (print_typlist print_simple_out_type " *") tyl ]
-and print_out_label ppf (name, mut, arg) =
- fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name
- print_out_type arg
-;
-
-(* Signature items *)
-
-value print_out_class_params ppf =
- fun
- [ [] -> ()
- | tyl ->
- fprintf ppf "@[<1>[%a]@]@ "
- (print_list (fun ppf x -> fprintf ppf "'%s" x)
- (fun ppf -> fprintf ppf ", "))
- tyl ]
-;
-
-value rec print_out_class_type ppf =
- fun
- [ Octy_constr id tyl ->
- let pr_tyl ppf =
- fun
- [ [] -> ()
- | tyl ->
- fprintf ppf "@[<1>[%a]@]@ "
- (print_typlist print_out_type ",") tyl ]
- in
- fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id
- | Octy_fun lab ty cty ->
- fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "")
- print_out_type_2 ty print_out_class_type cty
- | Octy_signature self_ty csil ->
- let pr_param ppf =
- fun
- [ Some ty -> fprintf ppf "@ @[(%a)@]" print_out_type ty
- | None -> () ]
- in
- fprintf ppf "@[<hv 2>@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty
- (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ "))
- csil ]
-and print_out_class_sig_item ppf =
- fun
- [ Ocsg_constraint ty1 ty2 ->
- fprintf ppf "@[<2>constraint %a =@ %a@]" print_out_type ty1
- print_out_type ty2
- | Ocsg_method name priv virt ty ->
- fprintf ppf "@[<2>method %s%s%s :@ %a@]"
- (if priv then "private " else "") (if virt then "virtual " else "")
- name print_out_type ty
- | Ocsg_value name mut ty ->
- fprintf ppf "@[<2>val %s%s :@ %a@]" (if mut then "mutable " else "")
- name print_out_type ty ]
-;
-
-value rec print_out_module_type ppf =
- fun
- [ Omty_abstract -> ()
- | Omty_functor name mty_arg mty_res ->
- fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name
- print_out_module_type mty_arg print_out_module_type mty_res
- | Omty_ident id -> fprintf ppf "%a" print_ident id
- | Omty_signature sg ->
- fprintf ppf "@[<hv 2>sig@ %a@;<1 -2>end@]" print_signature_body sg ]
-and print_signature_body ppf =
- fun
- [ [] -> ()
- | [item] -> print_out_sig_item ppf item
- | [item :: items] ->
- fprintf ppf "%a@ %a" print_out_sig_item item print_signature_body
- items ]
-and print_out_sig_item ppf =
- fun
- [ Osig_class vir_flag name params clt ->
- fprintf ppf "@[<2>class%s@ %a%s@ :@ %a@]"
- (if vir_flag then " virtual" else "") print_out_class_params params
- name print_out_class_type clt
- | Osig_class_type vir_flag name params clt ->
- fprintf ppf "@[<2>class type%s@ %a%s@ =@ %a@]"
- (if vir_flag then " virtual" else "") print_out_class_params params
- name print_out_class_type clt
- | Osig_exception id tyl ->
- fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl)
- | Osig_modtype name Omty_abstract ->
- fprintf ppf "@[<2>module type %s@]" name
- | Osig_modtype name mty ->
- fprintf ppf "@[<2>module type %s =@ %a@]" name print_out_module_type mty
- | Osig_module name mty ->
- fprintf ppf "@[<2>module %s :@ %a@]" name print_out_module_type mty
- | Osig_type tdl -> print_out_type_decl_list ppf tdl
- | Osig_value name ty prims ->
- let kwd = if prims = [] then "val" else "external" in
- let pr_prims ppf =
- fun
- [ [] -> ()
- | [s :: sl] ->
- do {
- fprintf ppf "@ = \"%s\"" s;
- List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl
- } ]
- in
- fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident name print_out_type
- ty pr_prims prims ]
-and print_out_type_decl_list ppf =
- fun
- [ [] -> ()
- | [x] -> print_out_type_decl "type" ppf x
- | [x :: l] ->
- do {
- print_out_type_decl "type" ppf x;
- List.iter (fun x -> fprintf ppf "@ %a" (print_out_type_decl "and") x)
- l
- } ]
-and print_out_type_decl kwd ppf (name, args, ty, constraints) =
- let print_constraints ppf params =
- List.iter
- (fun (ty1, ty2) ->
- fprintf ppf "@ @[<2>constraint %a =@ %a@]" print_out_type ty1
- print_out_type ty2)
- params
- in
- let type_parameter ppf (ty, (co, cn)) =
- fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "")
- ty
- in
- let type_defined ppf =
- match args with
- [ [] -> fprintf ppf "%s" name
- | [arg] -> fprintf ppf "@[%a@ %s@]" type_parameter arg name
- | _ ->
- fprintf ppf "@[(@[%a)@]@ %s@]"
- (print_list type_parameter (fun ppf -> fprintf ppf ",@ ")) args
- name ]
- in
- let print_manifest ppf =
- fun
- [ Otyp_manifest ty _ -> fprintf ppf " =@ %a" print_out_type ty
- | _ -> () ]
- in
- let print_name_args ppf =
- fprintf ppf "%s %t%a" kwd type_defined print_manifest ty
- in
- let ty =
- match ty with
- [ Otyp_manifest _ ty -> ty
- | _ -> ty ]
- in
- match ty with
- [ Otyp_abstract ->
- fprintf ppf "@[<2>@[<hv 2>%t@]%a@]" print_name_args print_constraints
- constraints
- | Otyp_record lbls ->
- fprintf ppf "@[<2>@[<hv 2>%t = {%a@;<1 -2>}@]@ %a@]" print_name_args
- (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls
- print_constraints constraints
- | Otyp_sum constrs ->
- fprintf ppf "@[<2>@[<hv 2>%t =@;<1 2>%a@]%a@]" print_name_args
- (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs
- print_constraints constraints
- | ty ->
- fprintf ppf "@[<2>@[<hv 2>%t =@ %a@]%a@]" print_name_args
- print_out_type ty print_constraints constraints ]
-and print_out_constr ppf (name, tyl) =
- match tyl with
- [ [] -> fprintf ppf "%s" name
- | _ ->
- fprintf ppf "@[<2>%s of@ %a@]" name
- (print_typlist print_simple_out_type " *") tyl ]
-and print_out_label ppf (name, mut, arg) =
- fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name
- print_out_type arg
-;
-
-(* Phrases *)
-
-value print_out_exception ppf exn outv =
- match exn with
- [ Sys.Break -> fprintf ppf "Interrupted.@."
- | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@."
- | Stack_overflow ->
- fprintf ppf "Stack overflow during evaluation (looping recursion?).@."
- | _ ->
- fprintf ppf "@[Exception:@ %a.@]@." Toploop.print_out_value.val outv ]
-;
-
-value rec print_items ppf =
- fun
- [ [] -> ()
- | [(tree, valopt) :: items] ->
- do {
- match valopt with
- [ Some v ->
- fprintf ppf "@[<2>%a =@ %a@]" Toploop.print_out_sig_item.val tree
- Toploop.print_out_value.val v
- | None -> fprintf ppf "@[%a@]" Toploop.print_out_sig_item.val tree ];
- if items <> [] then fprintf ppf "@ %a" print_items items else ()
- } ]
-;
-
-value print_out_phrase ppf =
- fun
- [ Ophr_eval outv ty ->
- fprintf ppf "@[- : %a@ =@ %a@]@." Toploop.print_out_type.val ty
- Toploop.print_out_value.val outv
- | Ophr_signature [] -> ()
- | Ophr_signature items -> fprintf ppf "@[<v>%a@]@." print_items items
- | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv ]
-;
-
-Toploop.print_out_value.val := print_out_value;
-Toploop.print_out_type.val := print_out_type;
-Toploop.print_out_sig_item.val := print_out_sig_item;
-Toploop.print_out_phrase.val := print_out_phrase;
diff --git a/camlp4/top/rprint.ml b/camlp4/top/rprint.ml
deleted file mode 100644
index 76f19fe11e..0000000000
--- a/camlp4/top/rprint.ml
+++ /dev/null
@@ -1,422 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Format;
-open Outcometree;
-
-exception Ellipsis;
-value cautious f ppf arg =
- try f ppf arg with [ Ellipsis -> fprintf ppf "..." ]
-;
-
-value rec print_ident ppf =
- fun
- [ Oide_ident s -> fprintf ppf "%s" s
- | Oide_dot id s -> fprintf ppf "%a.%s" print_ident id s
- | Oide_apply id1 id2 ->
- fprintf ppf "%a(%a)" print_ident id1 print_ident id2 ]
-;
-
-value value_ident ppf name =
- if List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"]
- then
- fprintf ppf "( %s )" name
- else
- match name.[0] with
- [ 'a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' ->
- fprintf ppf "%s" name
- | _ -> fprintf ppf "( %s )" name ]
-;
-
-(* Values *)
-
-value print_out_value ppf tree =
- let rec print_tree ppf =
- fun
- [ Oval_constr name ([_ :: _] as params) ->
- fprintf ppf "@[<1>%a@ %a@]" print_ident name
- (print_tree_list print_simple_tree "") params
- | Oval_variant name (Some param) ->
- fprintf ppf "@[<2>`%s@ %a@]" name print_simple_tree param
- | tree -> print_simple_tree ppf tree ]
- and print_simple_tree ppf =
- fun
- [ Oval_int i -> fprintf ppf "%i" i
- | Oval_int32 i -> fprintf ppf "%ldl" i
- | Oval_int64 i -> fprintf ppf "%LdL" i
- | Oval_nativeint i -> fprintf ppf "%ndn" i
- | Oval_float f -> fprintf ppf "%.12g" f
- | Oval_char c -> fprintf ppf "'%s'" (Char.escaped c)
- | Oval_string s ->
- try fprintf ppf "\"%s\"" (String.escaped s) with
- [ Invalid_argument "String.create" -> fprintf ppf "<huge string>" ]
- | Oval_list tl ->
- fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree ";") tl
- | Oval_array tl ->
- fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree ";") tl
- | Oval_constr (Oide_ident "true") [] -> fprintf ppf "True"
- | Oval_constr (Oide_ident "false") [] -> fprintf ppf "False"
- | Oval_constr name [] -> print_ident ppf name
- | Oval_variant name None -> fprintf ppf "`%s" name
- | Oval_stuff s -> fprintf ppf "%s" s
- | Oval_record fel ->
- fprintf ppf "@[<1>{%a}@]" (cautious (print_fields True)) fel
- | Oval_tuple tree_list ->
- fprintf ppf "@[(%a)@]" (print_tree_list print_tree ",") tree_list
- | Oval_ellipsis -> raise Ellipsis
- | Oval_printer f -> f ppf
- | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree) tree ]
- and print_fields first ppf =
- fun
- [ [] -> ()
- | [(name, tree) :: fields] ->
- let name =
- match name with
- [ Oide_ident "contents" -> Oide_ident "val"
- | x -> x ]
- in
- do {
- if not first then fprintf ppf ";@ " else ();
- fprintf ppf "@[<1>%a=@,%a@]" print_ident name (cautious print_tree)
- tree;
- print_fields False ppf fields
- } ]
- and print_tree_list print_item sep ppf tree_list =
- let rec print_list first ppf =
- fun
- [ [] -> ()
- | [tree :: tree_list] ->
- do {
- if not first then fprintf ppf "%s@ " sep else ();
- print_item ppf tree;
- print_list False ppf tree_list
- } ]
- in
- cautious (print_list True) ppf tree_list
- in
- cautious print_tree ppf tree
-;
-
-value rec print_list pr sep ppf =
- fun
- [ [] -> ()
- | [a] -> pr ppf a
- | [a :: l] -> do { pr ppf a; sep ppf; print_list pr sep ppf l } ]
-;
-
-value pr_vars =
- print_list (fun ppf s -> fprintf ppf "'%s" s) (fun ppf -> fprintf ppf "@ ")
-;
-
-value pr_present =
- print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ")
-;
-
-(* Types *)
-
-value rec print_out_type ppf =
- fun
- [ Otyp_alias ty s -> fprintf ppf "@[%a as '%s@]" print_out_type ty s
- | ty -> print_out_type_1 ppf ty ]
-and print_out_type_1 ppf =
- fun
- [ Otyp_arrow lab ty1 ty2 ->
- fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "")
- print_out_type_2 ty1 print_out_type_1 ty2
- | Otyp_poly sl ty ->
- fprintf ppf "@[<hov 2>%a.@ %a@]"
- pr_vars sl
- print_out_type ty
- | ty -> print_out_type_2 ppf ty ]
-and print_out_type_2 ppf =
- fun
- [ Otyp_constr id ([_ :: _] as tyl) ->
- fprintf ppf "@[%a@;<1 2>%a@]" print_ident id
- (print_typlist print_simple_out_type "") tyl
- | ty -> print_simple_out_type ppf ty ]
-and print_simple_out_type ppf =
- let rec print_tkind ppf =
- fun
- [ Otyp_var ng s -> fprintf ppf "'%s%s" (if ng then "_" else "") s
- | Otyp_constr id [] -> fprintf ppf "@[%a@]" print_ident id
- | Otyp_tuple tyl ->
- fprintf ppf "@[<1>(%a)@]" (print_typlist print_out_type " *") tyl
- | Otyp_stuff s -> fprintf ppf "%s" s
- | Otyp_variant non_gen row_fields closed tags ->
- let print_present ppf =
- fun
- [ None | Some [] -> ()
- | Some l -> fprintf ppf "@;<1 -2>> @[<hov>%a@]" pr_present l ]
- in
- let print_fields ppf =
- fun
- [ Ovar_fields fields ->
- print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ")
- ppf fields
- | Ovar_name id tyl ->
- fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id ]
- in
- fprintf ppf "%s[|%s@[<hv>@[<hv>%a@]%a|]@]" (if non_gen then "_" else "")
- (if closed then if tags = None then " " else "< "
- else if tags = None then "> "
- else "? ")
- print_fields row_fields
- print_present tags
- | Otyp_object fields rest ->
- fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields
- | Otyp_class ng id tyl ->
- fprintf ppf "@[%a%s#%a@]" print_typargs tyl (if ng then "_" else "")
- print_ident id
- | Otyp_manifest ty1 ty2 ->
- fprintf ppf "@[<2>%a ==@ %a@]" print_out_type ty1 print_out_type ty2
- | Otyp_sum constrs priv ->
- fprintf ppf "@[<hv>%a[ %a ]@]" print_private priv
- (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs
- | Otyp_record lbls priv ->
- fprintf ppf "@[<hv 2>%a{ %a }@]" print_private priv
- (print_list print_out_label (fun ppf -> fprintf ppf ";@ ")) lbls
- | Otyp_abstract -> fprintf ppf "'abstract"
- | Otyp_alias _ _ | Otyp_poly _ _
- | Otyp_arrow _ _ _ | Otyp_constr _ [_ :: _] as ty ->
- fprintf ppf "@[<1>(%a)@]" print_out_type ty ]
- and print_private ppf =
- fun
- [ Asttypes.Public -> ()
- | Asttypes.Private -> fprintf ppf "private "
- ]
- in
- print_tkind ppf
-and print_out_constr ppf (name, tyl) =
- match tyl with
- [ [] -> fprintf ppf "%s" name
- | _ ->
- fprintf ppf "@[<2>%s of@ %a@]" name
- (print_typlist print_out_type " and") tyl ]
-and print_out_label ppf (name, mut, arg) =
- fprintf ppf "@[<2>%s :@ %s%a@]" name (if mut then "mutable " else "")
- print_out_type arg
-and print_fields rest ppf =
- fun
- [ [] ->
- match rest with
- [ Some non_gen -> fprintf ppf "%s.." (if non_gen then "_" else "")
- | None -> () ]
- | [(s, t)] ->
- do {
- fprintf ppf "%s : %a" s print_out_type t;
- match rest with
- [ Some _ -> fprintf ppf ";@ "
- | None -> () ];
- print_fields rest ppf []
- }
- | [(s, t) :: l] ->
- fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l ]
-and print_row_field ppf (l, opt_amp, tyl) =
- let pr_of ppf =
- if opt_amp then fprintf ppf " of@ &@ "
- else if tyl <> [] then fprintf ppf " of@ "
- else fprintf ppf ""
- in
- fprintf ppf "@[<hv 2>`%s%t%a@]" l pr_of (print_typlist print_out_type " &")
- tyl
-and print_typlist print_elem sep ppf =
- fun
- [ [] -> ()
- | [ty] -> print_elem ppf ty
- | [ty :: tyl] ->
- fprintf ppf "%a%s@ %a" print_elem ty sep (print_typlist print_elem sep)
- tyl ]
-and print_typargs ppf =
- fun
- [ [] -> ()
- | [ty1] -> fprintf ppf "%a@ " print_simple_out_type ty1
- | tyl ->
- fprintf ppf "@[<1>(%a)@]@ " (print_typlist print_out_type ",") tyl ]
-;
-
-value print_out_class_params ppf =
- fun
- [ [] -> ()
- | tyl ->
- fprintf ppf "@[<1>[%a]@]@ "
- (print_list (fun ppf x -> fprintf ppf "'%s" x)
- (fun ppf -> fprintf ppf ", "))
- tyl ]
-;
-
-(* Signature items *)
-
-value rec print_out_class_type ppf =
- fun
- [ Octy_constr id tyl ->
- let pr_tyl ppf =
- fun
- [ [] -> ()
- | tyl ->
- fprintf ppf "@[<1>[%a]@]@ "
- (print_typlist Toploop.print_out_type.val ",") tyl ]
- in
- fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id
- | Octy_fun lab ty cty ->
- fprintf ppf "@[%s[ %a ] ->@ %a@]" (if lab <> "" then lab ^ ":" else "")
- Toploop.print_out_type.val ty print_out_class_type cty
- | Octy_signature self_ty csil ->
- let pr_param ppf =
- fun
- [ Some ty -> fprintf ppf "@ @[(%a)@]" Toploop.print_out_type.val ty
- | None -> () ]
- in
- fprintf ppf "@[<hv 2>@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty
- (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ "))
- csil ]
-and print_out_class_sig_item ppf =
- fun
- [ Ocsg_constraint ty1 ty2 ->
- fprintf ppf "@[<2>type %a =@ %a;@]" Toploop.print_out_type.val ty1
- Toploop.print_out_type.val ty2
- | Ocsg_method name priv virt ty ->
- fprintf ppf "@[<2>method %s%s%s :@ %a;@]"
- (if priv then "private " else "") (if virt then "virtual " else "")
- name Toploop.print_out_type.val ty
- | Ocsg_value name mut ty ->
- fprintf ppf "@[<2>value %s%s :@ %a;@]" (if mut then "mutable " else "")
- name Toploop.print_out_type.val ty ]
-;
-
-value rec print_out_module_type ppf =
- fun
- [ Omty_ident id -> fprintf ppf "%a" print_ident id
- | Omty_signature sg ->
- fprintf ppf "@[<hv 2>sig@ %a@;<1 -2>end@]"
- Toploop.print_out_signature.val sg
- | Omty_functor name mty_arg mty_res ->
- fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name
- print_out_module_type mty_arg print_out_module_type mty_res
- | Omty_abstract -> () ]
-and print_out_signature ppf =
- fun
- [ [] -> ()
- | [item] -> fprintf ppf "%a;" Toploop.print_out_sig_item.val item
- | [item :: items] ->
- fprintf ppf "%a;@ %a" Toploop.print_out_sig_item.val item
- print_out_signature items ]
-and print_out_sig_item ppf =
- fun
- [ Osig_class vir_flag name params clt ->
- fprintf ppf "@[<2>class%s@ %a%s@ :@ %a@]"
- (if vir_flag then " virtual" else "") print_out_class_params params
- name Toploop.print_out_class_type.val clt
- | Osig_class_type vir_flag name params clt ->
- fprintf ppf "@[<2>class type%s@ %a%s@ =@ %a@]"
- (if vir_flag then " virtual" else "") print_out_class_params params
- name Toploop.print_out_class_type.val clt
- | Osig_exception id tyl ->
- fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl)
- | Osig_modtype name Omty_abstract ->
- fprintf ppf "@[<2>module type %s@]" name
- | Osig_modtype name mty ->
- fprintf ppf "@[<2>module type %s =@ %a@]" name
- Toploop.print_out_module_type.val mty
- | Osig_module name mty ->
- fprintf ppf "@[<2>module %s :@ %a@]" name
- Toploop.print_out_module_type.val mty
- | Osig_type tdl -> print_out_type_decl_list ppf tdl
- | Osig_value name ty prims ->
- let kwd = if prims = [] then "value" else "external" in
- let pr_prims ppf =
- fun
- [ [] -> ()
- | [s :: sl] ->
- do {
- fprintf ppf "@ = \"%s\"" s;
- List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl
- } ]
- in
- fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident name
- Toploop.print_out_type.val ty pr_prims prims ]
-and print_out_type_decl_list ppf =
- fun
- [ [] -> ()
- | [x] -> print_out_type_decl "type" ppf x
- | [x :: l] ->
- do {
- print_out_type_decl "type" ppf x;
- List.iter (fun x -> fprintf ppf "@ %a" (print_out_type_decl "and") x)
- l
- } ]
-and print_out_type_decl kwd ppf (name, args, ty, constraints) =
- let constrain ppf (ty, ty') =
- fprintf ppf "@ @[<2>constraint %a =@ %a@]" Toploop.print_out_type.val ty
- Toploop.print_out_type.val ty'
- in
- let print_constraints ppf params = List.iter (constrain ppf) params in
- let type_parameter ppf (ty, (co, cn)) =
- fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "")
- ty
- in
- let type_defined ppf =
- match args with
- [ [] -> fprintf ppf "%s" name
- | [arg] -> fprintf ppf "%s %a" name type_parameter arg
- | _ ->
- fprintf ppf "%s@ %a" name
- (print_list type_parameter (fun ppf -> fprintf ppf "@ ")) args ]
- in
- fprintf ppf "@[<2>@[<hv 2>@[%s %t@] =@ %a@]%a@]" kwd type_defined
- Toploop.print_out_type.val ty print_constraints constraints
-;
-
-(* Phrases *)
-
-value print_out_exception ppf exn outv =
- match exn with
- [ Sys.Break -> fprintf ppf "Interrupted.@."
- | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@."
- | Stack_overflow ->
- fprintf ppf "Stack overflow during evaluation (looping recursion?).@."
- | _ ->
- fprintf ppf "@[Exception:@ %a.@]@." Toploop.print_out_value.val outv ]
-;
-
-value rec print_items ppf =
- fun
- [ [] -> ()
- | [(tree, valopt) :: items] ->
- do {
- match valopt with
- [ Some v ->
- fprintf ppf "@[<2>%a =@ %a@]" Toploop.print_out_sig_item.val tree
- Toploop.print_out_value.val v
- | None -> fprintf ppf "@[%a@]" Toploop.print_out_sig_item.val tree ];
- if items <> [] then fprintf ppf "@ %a" print_items items else ()
- } ]
-;
-
-value print_out_phrase ppf =
- fun
- [ Ophr_eval outv ty ->
- fprintf ppf "@[- : %a@ =@ %a@]@." Toploop.print_out_type.val ty
- Toploop.print_out_value.val outv
- | Ophr_signature [] -> ()
- | Ophr_signature items -> fprintf ppf "@[<v>%a@]@." print_items items
- | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv ]
-;
-
-Toploop.print_out_value.val := print_out_value;
-Toploop.print_out_type.val := print_out_type;
-Toploop.print_out_class_type.val := print_out_class_type;
-Toploop.print_out_module_type.val := print_out_module_type;
-Toploop.print_out_sig_item.val := print_out_sig_item;
-Toploop.print_out_signature.val := print_out_signature;
-Toploop.print_out_phrase.val := print_out_phrase;
diff --git a/config/.cvsignore b/config/.cvsignore
deleted file mode 100644
index eaf9ea5524..0000000000
--- a/config/.cvsignore
+++ /dev/null
@@ -1,4 +0,0 @@
-m.h
-s.h
-Makefile
-
diff --git a/config/Makefile-templ b/config/Makefile-templ
deleted file mode 100644
index d442a8c3e4..0000000000
--- a/config/Makefile-templ
+++ /dev/null
@@ -1,310 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-### Compile-time configuration
-
-########## General configuration
-
-### Where to install the binaries
-BINDIR=/usr/local/bin
-
-### Where to install the standard library
-LIBDIR=/usr/local/lib/ocaml
-STUBLIBDIR=$(LIBDIR)/stublibs
-
-### Where to install the man pages
-# Man pages for commands go in $(MANDIR)/man$(MANEXT)
-# Man pages for the library go in $(MANDIR)/mano
-MANDIR=/usr/local/man
-MANEXT=1
-
-### Do #! scripts work on your system?
-### Beware: on some systems (e.g. SunOS 4), this will work only if
-### the string "#!$(BINDIR)/ocamlrun" is less than 32 characters long.
-### In doubt, set SHARPBANGSCRIPTS to false.
-SHARPBANGSCRIPTS=true
-#SHARPBANGSCRIPTS=false
-
-########## Configuration for the bytecode compiler
-
-### Which C compiler to use for the bytecode interpreter.
-### Performance of the bytecode interpreter is *much* improved
-### if Gnu CC version 2 is used.
-#BYTECC=gcc
-#BYTECC=cc
-
-### Additional compile-time options for $(BYTECC).
-# If using gcc on Intel 386 or Motorola 68k:
-# (the -fno-defer-pop option circumvents a bug in certain versions of gcc)
-#BYTECCCOMPOPTS=-fno-defer-pop -Wall
-# If using gcc and being superstitious:
-#BYTECCCOMPOPTS=-Wall
-# Under NextStep:
-#BYTECCCOMPOPTS=-U__GNUC__ -fno-defer-pop -Wall
-# Otherwise:
-#BYTECCCOMPOPTS=
-
-### Additional link-time options for $(BYTECC)
-### If using GCC on a Dec Alpha under OSF1:
-#BYTECCLINKOPTS=-Wl,-T,12000000 -Wl,-D,14000000
-# To support dynamic loading of shared libraries (they need to look at
-# our own symbols):
-#BYTECCLINKOPTS=-Wl,-E
-# Otherwise:
-#BYTECCLINKOPTS=
-
-### Libraries needed
-# On most platforms:
-#CCLIBS=-lcurses -ltermcap -lm
-
-### How to invoke the C preprocessor
-# This is not needed anymore. Leave these lines commented out.
-# On most machines:
-#CPP=/lib/cpp -P
-# Under Solaris:
-#CPP=/usr/ccs/lib/cpp -P
-# Under FreeBSD:
-#CPP=cpp -P
-
-### How to invoke ranlib
-# BSD-style:
-#RANLIB=ranlib
-#RANLIBCMD=ranlib
-# If ranlib is not needed:
-#RANLIB=ar rs
-#RANLIBCMD=
-
-### Shared library support
-# Extension for shared libraries: so if supported, a if not supported
-#SO=so
-#SO=a
-# Set to nothing if shared libraries supported, and to -custom if not supported
-#CUSTOM_IF_NOT_SHARED=
-#CUSTOM_IF_NOT_SHARED=-custom
-# Options to $(BYTECC) to produce shared objects (e.g. PIC)
-#SHAREDCCCOMPOPTS=-fPIC
-# How to build a shared library, invoked with output .so as first arg
-# and object files as remaining args
-#MKSHAREDLIB=gcc -shared -o
-# Compile-time option to $(BYTECC) to add a directory to be searched
-# at run-time for shared libraries
-#BYTECCRPATH=-Wl,-rpath
-
-############# Configuration for the native-code compiler
-
-### Name of architecture for the native-code compiler
-### Currently supported:
-###
-### alpha Digital/Compaq Alpha machines under DUnix/Tru64 or Linux
-### i386 Intel Pentium PCs under Linux, *BSD*, NextStep
-### sparc Sun Sparcstation under SunOS 4.1 or Solaris 2
-### mips SGI machines under IRIX
-### hppa HP 9000/700 under HPUX
-### power Mac OS X; IBM RS6000 and PowerPC workstations under AIX
-### ia64 Intel Itanium/IA64 under Linux
-### arm ARM under Linux
-###
-### Set ARCH=none if your machine is not supported
-#ARCH=alpha
-#ARCH=i386
-#ARCH=sparc
-#ARCH=mips
-#ARCH=hppa
-#ARCH=power
-#ARCH=ia64
-#ARCH=arm
-#ARCH=none
-
-### Name of architecture model for the native-code compiler.
-### Some architectures come in several slightly different flavors
-### that share a common code generator. This variable tailors the
-### behavior of the code generator to the particular flavor used.
-### Currently needed only if ARCH=power; leave MODEL=default for
-### other architectures.
-### If ARCH=power: choose between
-### MODEL=rs6000 The original IBM RS6000 workstations
-### (RIOS and RIOS2 processors)
-### MODEL=ppc The newer PowerPC processors
-### (Motorola/IBM PPC601, PPC603, PPC604, G3, G4, etc)
-### The Motorola PPC601 is compatible with both models, but the newer
-### PPCs will work only with MODEL=ppc, and the older IBM RS6000
-### workstations will work only with MODEL=rs6000.
-###
-### For other architectures: leave MODEL=default
-###
-#MODEL=rs6000
-#MODEL=ppc
-#MODEL=default
-
-### Name of operating system family for the native-code compiler.
-### If ARCH=sparc: choose between
-### SYSTEM=sunos SunOS 4.1
-### SYSTEM=solaris Solaris 2
-###
-### If ARCH=i386: choose between
-### SYSTEM=linux_aout Linux with a.out binaries
-### SYSTEM=linux_elf Linux with ELF binaries
-### SYSTEM=bsd FreeBSD, probably works for NetBSD also
-### SYSTEM=nextstep NextStep
-###
-### For other architectures: set SYSTEM=unknown
-###
-#SYSTEM=sunos
-#SYSTEM=solaris
-#SYSTEM=linux
-#SYSTEM=linux_elf
-#SYSTEM=bsd
-#SYSTEM=nextstep
-#SYSTEM=unknown
-
-### Which C compiler to use for the native-code compiler.
-### cc is better than gcc on the Mips and Alpha.
-#NATIVECC=cc
-#NATIVECC=gcc
-
-### Additional compile-time options for $(NATIVECC).
-# For cc on the Alpha:
-#NATIVECCCOMPOPTS=-std1
-# For cc on the Mips:
-#NATIVECCCOMPOPTS=-std
-# For gcc if superstitious:
-#NATIVECCCOMPOPTS=-Wall
-
-### Additional link-time options for $(NATIVECC)
-#NATIVECCLINKOPTS=
-
-# Compile-time option to $(NATIVECC) to add a directory to be searched
-# at run-time for shared libraries
-#NATIVECCRPATH=-Wl,-rpath
-
-### Flags for the assembler
-# For the Alpha or the Mips:
-#ASFLAGS=-O2
-# For the PowerPC:
-#ASFLAGS=-u -m ppc -w
-# For the RS6000:
-#ASFLAGS=-u -m pwr -w
-# Otherwise:
-#ASFLAGS=
-
-### Command and flags to use for assembling .S files (often with preprocessing)
-# If gcc is available:
-#ASPP=gcc
-#ASPPFLAGS=-c -DSYS_$(SYSTEM)
-# On SunOS and Solaris:
-#ASPP=$(AS)
-#ASPPFLAGS=-P -DSYS_$(SYSTEM)
-# Otherwise:
-#ASPP=$(AS)
-#ASPPFLAGS=
-
-### Extra flags to use for assembling .S files in profiling mode
-# On Digital Unix:
-#ASPPPROFFLAGS=-pg -DPROFILING
-# Otherwise:
-#ASPPPROFFLAGS=-DPROFILING
-
-### Whether profiling with gprof is supported
-# If yes: (x86/Linux, Alpha/Digital Unix, Sparc/Solaris):
-#PROFILING=prof
-# If no: (all others)
-#PROFILING=noprof
-
-### Option to give to the C compiler for profiling
-#CC_PROFILE=-pg
-#CC_PROFILE=-xpg
-
-### How to perform a partial link
-PARTIALLD=ld -r $(NATIVECCLINKOPTS)
-PACKLD=$(PARTIALLD)
-
-### Path to the "objcopy" program from GNU binutils.
-# You need a sufficiently recent version of the binutils so that
-# the option --redefine-sym is supported by objcopy.
-# Leave blank if you don't have "objcopy", but then "ocamlopt -pack"
-# will not work
-#BINUTILS_OBJCOPY=/usr/bin/objcopy
-
-### Path to the "nm" program from GNU binutils.
-# Other versions of nm do *not* work for our purposes.
-# Leave blank if you don't have GNU "nm", but then "ocamlopt -pack"
-# will not work
-#BINUTILS_NM=/usr/bin/nm
-
-############# Configuration for the contributed libraries
-
-### Which libraries to compile and install
-# Currently available:
-# unix Unix system calls
-# str Regular expressions and high-level string processing
-# num Arbitrary-precision rational arithmetic
-# threads Lightweight concurrent processes
-# systhreads Same as threads, requires POSIX threads
-# graph Portable drawing primitives for X11
-# dynlink Dynamic linking of bytecode
-# labltk Tcl/Tk interface
-# bigarray Large, multidimensional numerical arrays
-
-OTHERLIBRARIES=unix str num threads graph dynlink labltk bigarray
-
-### Name of the target architecture for the "num" library
-# Known targets:
-# x86 68K vax ns mips alpha pyramid i960
-# sparc supersparc sparc-solaris supersparc-solaris
-# See the file otherlibs/num/README for more explanations.
-# If you don't know, leave BIGNUM_ARCH=C, which selects a portable
-# C implementation of these routines.
-BIGNUM_ARCH=alpha
-
-### Link-time options to ocamlc or ocamlopt for linking with POSIX threads
-# Needed for the "systhreads" package
-# Usually:
-#PTHREAD_LINK=-cclib -lpthread
-# For Solaris:
-#PTHREAD_LINK=-cclib -lpthread -cclib -lposix4
-
-### -I options for finding the X11/*.h includes
-# Needed for the "graph" and "labltk" packages
-# Usually:
-#X11_INCLUDES=-I/usr/X11R6/include
-# For SunOS with OpenLook:
-#X11_INCLUDES=/usr/openwin/include
-
-### Link-time options to ocamlc or ocamlopt for linking with X11 libraries
-# Needed for the "graph" and "labltk" packages
-# Usually:
-#X11_LINK=-lX11
-# For SunOS with OpenLook:
-#X11_LINK=-L$(X11_LIB) -lX11
-
-### -I options for finding the include file ndbm.h
-# Needed for the "dbm" package
-# Usually:
-#DBM_INCLUDES=
-# For recent Linux systems:
-#DBM_INCLUDES=-I/usr/include/gdbm
-
-### Preprocessor options for finding tcl.h and tk.h
-# Needed for the "labltk" package
-# Required only if not in the standard include path.
-# For Tcl/Tk 8.0 on FreeBSD:
-#TK_DEFS="-I/usr/local/include/tcl8.0 -I/usr/local/include/tk8.0"
-
-### Linker options for linking tcl and tk libraries
-# Needed for the "labltk" package
-# Usually (with appropriate version numbers):
-#TK_LINK="-ltk8.0 -ltcl8.0"
-# For Tcl/Tk 8.0 on FreeBSD:
-#TK_LINK="-L/usr/local/lib -ltk8.0 -ltcl8.0"
diff --git a/config/Makefile.mingw b/config/Makefile.mingw
deleted file mode 100644
index b7b02a15f5..0000000000
--- a/config/Makefile.mingw
+++ /dev/null
@@ -1,123 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-# Configuration for Windows, Mingw compiler
-
-######### General configuration
-
-PREFIX=C:/ocamlmgw
-
-### Where to install the binaries
-BINDIR=$(PREFIX)/bin
-
-### Where to install the standard library
-LIBDIR=$(PREFIX)/lib
-
-### Where to install the stub DLLs
-STUBLIBDIR=$(LIBDIR)/stublibs
-
-### Where to install the info files
-DISTRIB=$(PREFIX)
-
-########## Toolchain and OS dependencies
-
-TOOLCHAIN=mingw
-CCOMPTYPE=cc
-O=o
-A=a
-S=s
-SO=s.o
-DO=d.o
-EXE=.exe
-
-########## Configuration for the bytecode compiler
-
-### Which C compiler to use for the bytecode interpreter.
-BYTECC=gcc -mno-cygwin
-
-### Additional compile-time options for $(BYTECC). (For static linking.)
-BYTECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused
-
-### Additional link-time options for $(BYTECC). (For static linking.)
-BYTECCLINKOPTS=
-
-### Additional compile-time options for $(BYTECC). (For building a DLL.)
-DLLCCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused -DCAML_DLL
-
-### Libraries needed
-BYTECCLIBS=
-NATIVECCLIBS=
-
-### How to invoke the C preprocessor
-CPP=$(BYTECC) -E
-
-### How to build a DLL
-MKDLL=$(BYTECC) -shared -o $(1) -Wl,--out-implib,$(2) $(3)
-
-### How to build a static library
-MKLIB=rm -f $(1); ar rcs $(1) $(2)
-
-### Canonicalize the name of a system library
-SYSLIB=-l$(1)
-
-### The ranlib command
-RANLIBCMD=ranlib
-
-############# Configuration for the native-code compiler
-
-### Name of architecture for the native-code compiler
-ARCH=i386
-
-### Name of architecture model for the native-code compiler.
-MODEL=default
-
-### Name of operating system family for the native-code compiler.
-SYSTEM=mingw
-
-### Which C compiler to use for the native-code compiler.
-NATIVECC=$(BYTECC)
-
-### Additional compile-time options for $(NATIVECC).
-NATIVECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused
-
-### Additional link-time options for $(NATIVECC)
-NATIVECCLINKOPTS=
-
-### Build partially-linked object file
-PARTIALLD=ld -r $(NATIVECCLINKOPTS)
-PACKLD=$(PARTIALLD)
-
-### nm and objcopy from GNU binutils
-BINUTILS_NM=nm
-BINUTILS_OBJCOPY=objcopy
-
-############# Configuration for the contributed libraries
-
-OTHERLIBRARIES=win32unix systhreads str num win32graph dynlink bigarray labltk
-
-### Name of the target architecture for the "num" library
-BIGNUM_ARCH=C
-
-### Configuration for LablTk
-# Set TK_ROOT to the directory where you installed TCL/TK 8.3
-# There must be no spaces or special characters in $(TK_ROOT)
-TK_ROOT=c:/tcl
-TK_DEFS=-I$(TK_ROOT)/include
-TK_LINK=$(TK_ROOT)/lib/tk83.lib $(TK_ROOT)/lib/tcl83.lib
-
-############# Aliases for common commands
-
-MAKEREC=$(MAKE) -f Makefile.nt
-MAKECMD=$(MAKE)
diff --git a/config/Makefile.msvc b/config/Makefile.msvc
deleted file mode 100644
index 7144f9e01e..0000000000
--- a/config/Makefile.msvc
+++ /dev/null
@@ -1,129 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-# Configuration for Windows, Visual C++ compiler
-
-######### General configuration
-
-PREFIX=C:/ocaml
-
-### Where to install the binaries.
-BINDIR=$(PREFIX)/bin
-
-### Where to install the standard library
-LIBDIR=$(PREFIX)/lib
-
-### Where to install the stub DLLs
-STUBLIBDIR=$(LIBDIR)/stublibs
-
-### Where to install the info files
-DISTRIB=$(PREFIX)
-
-########## Toolchain and OS dependencies
-
-TOOLCHAIN=msvc
-CCOMPTYPE=msvc
-O=obj
-A=lib
-S=asm
-SO=s.obj
-DO=d.obj
-EXE=.exe
-
-########## Configuration for the bytecode compiler
-
-### Which C compiler to use for the bytecode interpreter.
-BYTECC=cl /nologo
-
-### Additional compile-time options for $(BYTECC). (For static linking.)
-BYTECCCOMPOPTS=/Ox /MT
-
-### Additional link-time options for $(BYTECC). (For static linking.)
-BYTECCLINKOPTS=/MT
-
-### Additional compile-time options for $(BYTECC). (For building a DLL.)
-DLLCCCOMPOPTS=/Ox /MD -DCAML_DLL
-
-### Libraries needed
-BYTECCLIBS=advapi32.lib
-NATIVECCLIBS=advapi32.lib
-
-### How to invoke the C preprocessor
-CPP=cl /nologo /EP
-
-### How to build a DLL
-MKDLL=link /nologo /dll /out:$(1) /implib:$(2) $(3)
-
-### How to build a static library
-MKLIB=lib /nologo /debugtype:CV /out:$(1) $(2)
-
-### Canonicalize the name of a system library
-SYSLIB=$(1).lib
-
-### The ranlib command
-RANLIBCMD=
-
-############# Configuration for the native-code compiler
-
-### Name of architecture for the native-code compiler
-ARCH=i386
-
-### Name of architecture model for the native-code compiler.
-MODEL=default
-
-### Name of operating system family for the native-code compiler.
-SYSTEM=win32
-
-### Which C compiler to use for the native-code compiler.
-NATIVECC=cl /nologo
-
-### Additional compile-time options for $(NATIVECC).
-NATIVECCCOMPOPTS=/Ox /MT
-
-### Additional link-time options for $(NATIVECC)
-NATIVECCLINKOPTS=/MT
-
-### Build partially-linked object file
-PARTIALLD=lib /nologo /debugtype:cv
-PACKLD=ld -r --oformat pe-i386
-
-### nm and objcopy are missing
-BINUTILS_NM=nm
-BINUTILS_OBJCOPY=objcopy
-
-############# Configuration for the contributed libraries
-
-OTHERLIBRARIES=win32unix systhreads str num win32graph dynlink bigarray labltk
-
-### Name of the target architecture for the "num" library
-BIGNUM_ARCH=C
-
-### Configuration for LablTk
-# Set TK_ROOT to the directory where you installed TCL/TK 8.3
-TK_ROOT=c:/tcl
-TK_DEFS=-I$(TK_ROOT)/include
-# The following definition avoids hard-wiring $(TK_ROOT) in the libraries
-# produced by OCaml, and is therefore required for binary distribution
-# of these libraries. However, $(TK_ROOT) must be added to the LIB
-# environment variable, as described in README.win32.
-TK_LINK=tk83.lib tcl83.lib
-# An alternative definition that avoids mucking with the LIB variable,
-# but hard-wires the Tcl/Tk location in the binaries
-# TK_LINK=$(TK_ROOT)/tk83.lib $(TK_ROOT)/tcl83.lib
-
-############# Aliases for common commands
-
-MAKEREC=$(MAKE) -f Makefile.nt
-MAKECMD=$(MAKE)
diff --git a/config/auto-aux/align.c b/config/auto-aux/align.c
deleted file mode 100644
index 0bedf77a02..0000000000
--- a/config/auto-aux/align.c
+++ /dev/null
@@ -1,103 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <stdio.h>
-#include <signal.h>
-#include <setjmp.h>
-
-long foo;
-
-void access16(short int *p)
-{
- foo = *p;
-}
-
-void access32(long int *p)
-{
- foo = *p;
-}
-
-jmp_buf failure;
-
-void sig_handler(int dummy)
-{
- longjmp(failure, 1);
-}
-
-int test(void (*fct) (/* ??? */), char *p)
-{
- int res;
-
- signal(SIGSEGV, sig_handler);
- signal(SIGBUS, sig_handler);
- if(setjmp(failure) == 0) {
- fct(p);
- res = 0;
- } else {
- res = 1;
- }
- signal(SIGSEGV, SIG_DFL);
- signal(SIGBUS, SIG_DFL);
- return res;
-}
-
-jmp_buf timer;
-
-void alarm_handler(int dummy)
-{
- longjmp(timer, 1);
-}
-
-void use(int n)
-{
- return;
-}
-
-int speedtest(char *p)
-{
- int * q;
- volatile int total;
- int i;
- volatile int sum;
-
- signal(SIGALRM, alarm_handler);
- sum = 0;
- if (setjmp(timer) == 0) {
- alarm(1);
- total = 0;
- while(1) {
- for (q = (int *) p, i = 1000; i > 0; q++, i--)
- sum += *q;
- total++;
- }
- }
- use(sum);
- signal(SIGALRM, SIG_DFL);
- return total;
-}
-
-main(void)
-{
- long n[1001];
- int speed_aligned, speed_unaligned;
-
- if (test(access16, (char *) n + 1)) exit(1);
- if (test(access32, (char *) n + 1)) exit(1);
- if (test(access32, (char *) n + 2)) exit(1);
- speed_aligned = speedtest((char *) n);
- speed_unaligned = speedtest((char *) n + 1);
- if (speed_aligned >= 3 * speed_unaligned) exit(1);
- exit(0);
-}
diff --git a/config/auto-aux/ansi.c b/config/auto-aux/ansi.c
deleted file mode 100644
index f1a416b857..0000000000
--- a/config/auto-aux/ansi.c
+++ /dev/null
@@ -1,21 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1997 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-int main()
-{
-#ifdef __STDC__
- return 0;
-#else
- return 1;
-#endif
-}
diff --git a/config/auto-aux/async_io.c b/config/auto-aux/async_io.c
deleted file mode 100644
index 2b5faa2d70..0000000000
--- a/config/auto-aux/async_io.c
+++ /dev/null
@@ -1,60 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <stdio.h>
-#include <fcntl.h>
-#include <signal.h>
-#include <errno.h>
-#include <sys/types.h>
-#include <sys/socket.h>
-#include "s.h"
-
-int signalled;
-
-void sigio_handler(int arg)
-{
- signalled = 1;
-}
-
-int main(void)
-{
-#if defined(SIGIO) && defined(FASYNC) && defined(F_SETFL) && defined(F_SETOWN)
- int p[2];
- int ret;
-#define OUT 0
-#define IN 1
- if (socketpair(PF_UNIX, SOCK_STREAM, 0, p) == -1) return 1;
- signalled = 0;
- signal(SIGIO, sigio_handler);
- ret = fcntl(p[OUT], F_GETFL, 0);
- fcntl(p[OUT], F_SETFL, ret | FASYNC);
- fcntl(p[OUT], F_SETOWN, getpid());
- switch(fork()) {
- case -1:
- return 1;
- case 0:
- close(p[OUT]);
- write(p[IN], "x", 1);
- sleep(1);
- exit(0);
- default:
- close(p[IN]);
- while(wait(NULL) == -1 && errno == EINTR) /*nothing*/;
- }
- if (signalled) return 0; else return 1;
-#else
- return 1;
-#endif
-}
diff --git a/config/auto-aux/bytecopy.c b/config/auto-aux/bytecopy.c
deleted file mode 100644
index 923b444e5b..0000000000
--- a/config/auto-aux/bytecopy.c
+++ /dev/null
@@ -1,34 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-char buffer[27];
-
-#ifdef reverse
-#define cpy(s1,s2,n) copy(s2,s1,n)
-#else
-#define cpy copy
-#endif
-
-int main(int argc, char ** argv)
-{
- cpy("abcdefghijklmnopqrstuvwxyz", buffer, 27);
- if (strcmp(buffer, "abcdefghijklmnopqrstuvwxyz") != 0) exit(1);
- cpy(buffer, buffer+3, 26-3);
- if (strcmp(buffer, "abcabcdefghijklmnopqrstuvw") != 0) exit(1);
- cpy("abcdefghijklmnopqrstuvwxyz", buffer, 27);
- cpy(buffer+3, buffer, 26-3);
- if (strcmp(buffer, "defghijklmnopqrstuvwxyzxyz") != 0) exit(1);
- exit(0);
-}
diff --git a/config/auto-aux/dblalign.c b/config/auto-aux/dblalign.c
deleted file mode 100644
index 9b44a774e2..0000000000
--- a/config/auto-aux/dblalign.c
+++ /dev/null
@@ -1,55 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <stdio.h>
-#include <signal.h>
-#include <setjmp.h>
-
-double foo;
-
-void access_double(double *p)
-{
- foo = *p;
-}
-
-jmp_buf failure;
-
-void sig_handler(int sig)
-{
- longjmp(failure, 1);
-}
-
-int main(void)
-{
- long n[10];
- int res;
- signal(SIGSEGV, sig_handler);
-#ifdef SIGBUS
- signal(SIGBUS, sig_handler);
-#endif
- if(setjmp(failure) == 0) {
- access_double((double *) n);
- access_double((double *) (n+1));
- res = 0;
- } else {
- res = 1;
- }
- signal(SIGSEGV, SIG_DFL);
-#ifdef SIGBUS
- signal(SIGBUS, SIG_DFL);
-#endif
- exit(res);
-}
-
diff --git a/config/auto-aux/divmod.c b/config/auto-aux/divmod.c
deleted file mode 100644
index 24d3786cec..0000000000
--- a/config/auto-aux/divmod.c
+++ /dev/null
@@ -1,47 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Test semantics of division and modulus for negative arguments */
-
-long div4[] =
-{ -4,-3,-3,-3,-3,-2,-2,-2,-2,-1,-1,-1,-1,0,0,0,
- 0,0,0,0,1,1,1,1,2,2,2,2,3,3,3,3,4 };
-
-long divm4[] =
-{ 4,3,3,3,3,2,2,2,2,1,1,1,1,0,0,0,
- 0,0,0,0,-1,-1,-1,-1,-2,-2,-2,-2,-3,-3,-3,-3,-4 };
-
-long mod4[] =
-{ 0,-3,-2,-1,0,-3,-2,-1,0,-3,-2,-1,0,-3,-2,-1,
- 0,1,2,3,0,1,2,3,0,1,2,3,0,1,2,3,0 };
-
-long modm4[] =
-{ 0,-3,-2,-1,0,-3,-2,-1,0,-3,-2,-1,0,-3,-2,-1,
- 0,1,2,3,0,1,2,3,0,1,2,3,0,1,2,3,0 };
-
-long q1 = 4;
-long q2 = -4;
-
-int main()
-{
- int i;
- for (i = -16; i <= 16; i++) {
- if (i / q1 != div4[i+16]) return 1;
- if (i / q2 != divm4[i+16]) return 1;
- if (i % q1 != mod4[i+16]) return 1;
- if (i % q2 != modm4[i+16]) return 1;
- }
- return 0;
-}
diff --git a/config/auto-aux/elf.c b/config/auto-aux/elf.c
deleted file mode 100644
index 026c4838eb..0000000000
--- a/config/auto-aux/elf.c
+++ /dev/null
@@ -1,26 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1999 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <stdio.h>
-
-int main(int argc, char ** argv)
-{
-#ifdef __ELF__
- printf("elf\n");
-#else
- printf("aout\n");
-#endif
- return 0;
-}
diff --git a/config/auto-aux/endian.c b/config/auto-aux/endian.c
deleted file mode 100644
index def617f0f5..0000000000
--- a/config/auto-aux/endian.c
+++ /dev/null
@@ -1,41 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "m.h"
-
-#ifndef ARCH_SIXTYFOUR
-long intval = 0x41424344L;
-char * bigendian = "ABCD";
-char * littleendian = "DCBA";
-#else
-long intval = 0x4142434445464748L;
-char * bigendian = "ABCDEFGH";
-char * littleendian = "HGFEDCBA";
-#endif
-
-main(void)
-{
- long n[2];
- char * p;
-
- n[0] = intval;
- n[1] = 0;
- p = (char *) n;
- if (strcmp(p, bigendian) == 0)
- exit(0);
- if (strcmp(p, littleendian) == 0)
- exit(1);
- exit(2);
-}
diff --git a/config/auto-aux/getgroups.c b/config/auto-aux/getgroups.c
deleted file mode 100644
index 1ed8a1fbb1..0000000000
--- a/config/auto-aux/getgroups.c
+++ /dev/null
@@ -1,32 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <sys/types.h>
-#include <limits.h>
-
-#ifdef NGROUPS_MAX
-
-int main(void)
-{
- int gidset[NGROUPS_MAX];
- if (getgroups(NGROUPS_MAX, gidset) == -1) return 1;
- return 0;
-}
-
-#else
-
-int main(void) { return 1; }
-
-#endif
diff --git a/config/auto-aux/gethostbyaddr.c b/config/auto-aux/gethostbyaddr.c
deleted file mode 100644
index c5dd129719..0000000000
--- a/config/auto-aux/gethostbyaddr.c
+++ /dev/null
@@ -1,51 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 2002 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#ifndef _REENTRANT
-/* This helps detection on Digital Unix... */
-#define _REENTRANT
-#endif
-
-#include <sys/types.h>
-#include <netdb.h>
-
-int main(int argc, char ** argv)
-{
-#if NUM_ARGS == 7
- char * address;
- int length;
- int type;
- struct hostent h;
- char buffer[10];
- int buflen;
- int h_errnop;
- struct hostent * hp;
- hp = gethostbyaddr_r(address, length, type, &h,
- buffer, buflen, &h_errnop);
-#elif NUM_ARGS == 8
- char * address;
- int length;
- int type;
- struct hostent h;
- char buffer[10];
- int buflen;
- int h_errnop;
- struct hostent * hp;
- int rc;
- rc = gethostbyaddr_r(address, length, type, &h,
- buffer, buflen, &hp, &h_errnop);
-#endif
- return 0;
-}
diff --git a/config/auto-aux/gethostbyname.c b/config/auto-aux/gethostbyname.c
deleted file mode 100644
index 043b9d3343..0000000000
--- a/config/auto-aux/gethostbyname.c
+++ /dev/null
@@ -1,41 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 2002 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#ifndef _REENTRANT
-/* This helps detection on Digital Unix... */
-#define _REENTRANT
-#endif
-
-#include <sys/types.h>
-#include <netdb.h>
-
-int main(int argc, char ** argv)
-{
-#if NUM_ARGS == 5
- struct hostent *hp;
- struct hostent h;
- char buffer[1000];
- int h_errno;
- hp = gethostbyname_r("www.caml.org", &h, buffer, 10, &h_errno);
-#elif NUM_ARGS == 6
- struct hostent *hp;
- struct hostent h;
- char buffer[1000];
- int h_errno;
- int rc;
- rc = gethostbyname_r("www.caml.org", &h, buffer, 10, &hp, &h_errno);
-#endif
- return 0;
-}
diff --git a/config/auto-aux/hasgot b/config/auto-aux/hasgot
deleted file mode 100755
index 99384768a9..0000000000
--- a/config/auto-aux/hasgot
+++ /dev/null
@@ -1,28 +0,0 @@
-#!/bin/sh
-
-opts=""
-libs="$cclibs"
-args=$*
-rm -f hasgot.c
-while : ; do
- case "$1" in
- -i) echo "#include <$2>" >> hasgot.c; shift;;
- -t) echo "$2 the_$2;" >> hasgot.c; shift;;
- -l*|-L*|-F*) libs="$libs $1";;
- -framework) libs="$libs $1 $2"; shift;;
- -*) opts="$opts $1";;
- *) break;;
- esac
- shift
-done
-
-(echo "main() {"
- for f in $*; do echo " $f();"; done
- echo "}") >> hasgot.c
-
-if test "$verbose" = yes; then
- echo "hasgot $args: $cc $opts -o tst hasgot.c $libs" >&2
- exec $cc $opts -o tst hasgot.c $libs > /dev/null
-else
- exec $cc $opts -o tst hasgot.c $libs > /dev/null 2>/dev/null
-fi
diff --git a/config/auto-aux/ia32sse2.c b/config/auto-aux/ia32sse2.c
deleted file mode 100644
index d4f72e7728..0000000000
--- a/config/auto-aux/ia32sse2.c
+++ /dev/null
@@ -1,22 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 2003 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Test whether IA32 assembler supports SSE2 instructions */
-
-int main()
-{
- asm("pmuludq %mm1, %mm0");
- return 0;
-}
diff --git a/config/auto-aux/int64align.c b/config/auto-aux/int64align.c
deleted file mode 100644
index 5c77b39c58..0000000000
--- a/config/auto-aux/int64align.c
+++ /dev/null
@@ -1,56 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 2000 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <stdio.h>
-#include <signal.h>
-#include <setjmp.h>
-#include "m.h"
-
-ARCH_INT64_TYPE foo;
-
-void access_int64(ARCH_INT64_TYPE *p)
-{
- foo = *p;
-}
-
-jmp_buf failure;
-
-void sig_handler(int sig)
-{
- longjmp(failure, 1);
-}
-
-int main(void)
-{
- long n[10];
- int res;
- signal(SIGSEGV, sig_handler);
-#ifdef SIGBUS
- signal(SIGBUS, sig_handler);
-#endif
- if(setjmp(failure) == 0) {
- access_int64((ARCH_INT64_TYPE *) n);
- access_int64((ARCH_INT64_TYPE *) (n+1));
- res = 0;
- } else {
- res = 1;
- }
- signal(SIGSEGV, SIG_DFL);
-#ifdef SIGBUS
- signal(SIGBUS, SIG_DFL);
-#endif
- exit(res);
-}
-
diff --git a/config/auto-aux/longlong.c b/config/auto-aux/longlong.c
deleted file mode 100644
index bcdf4c974b..0000000000
--- a/config/auto-aux/longlong.c
+++ /dev/null
@@ -1,43 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <stdio.h>
-#include <string.h>
-
-/* Check for the availability of "long long" type as per ISO C9X */
-
-/* Meaning of return code:
- 0 long long OK, printf with %ll
- 1 long long OK, printf with %q
- 2 long long OK, no printf
- 3 long long not suitable */
-
-int main(int argc, char **argv)
-{
- long long l;
- unsigned long long u;
- char buffer[64];
-
- if (sizeof(long long) != 8) return 3;
- l = 123456789123456789LL;
- buffer[0] = '\0';
- sprintf(buffer, "%lld", l);
- if (strcmp(buffer, "123456789123456789") == 0) return 0;
- /* the MacOS X library uses qd to format long longs */
- buffer[0] = '\0';
- sprintf (buffer, "%qd", l);
- if (strcmp (buffer, "123456789123456789") == 0) return 1;
- return 2;
-}
diff --git a/config/auto-aux/runtest b/config/auto-aux/runtest
deleted file mode 100755
index ce65bd07f1..0000000000
--- a/config/auto-aux/runtest
+++ /dev/null
@@ -1,8 +0,0 @@
-#!/bin/sh
-if test "$verbose" = yes; then
-echo "runtest: $cc -o tst $* $cclibs" >&2
-$cc -o tst $* $cclibs || exit 100
-else
-$cc -o tst $* $cclibs 2> /dev/null || exit 100
-fi
-exec ./tst
diff --git a/config/auto-aux/schar.c b/config/auto-aux/schar.c
deleted file mode 100644
index 55d49f31a7..0000000000
--- a/config/auto-aux/schar.c
+++ /dev/null
@@ -1,23 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-char foo[]="\377";
-
-int main(int argc, char ** argv)
-{
- int i;
- i = foo[0];
- exit(i != -1);
-}
diff --git a/config/auto-aux/schar2.c b/config/auto-aux/schar2.c
deleted file mode 100644
index d1d781a53e..0000000000
--- a/config/auto-aux/schar2.c
+++ /dev/null
@@ -1,23 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-signed char foo[]="\377";
-
-int main(int argc, char ** argv)
-{
- int i;
- i = foo[0];
- exit(i != -1);
-}
diff --git a/config/auto-aux/searchpath b/config/auto-aux/searchpath
deleted file mode 100755
index 9b31267f67..0000000000
--- a/config/auto-aux/searchpath
+++ /dev/null
@@ -1,9 +0,0 @@
-#!/bin/sh
-# Find a program in the path
-
-IFS=':'
-for dir in $PATH; do
- if test -z "$dir"; then dir=.; fi
- if test -f $dir/$1; then exit 0; fi
-done
-exit 1
diff --git a/config/auto-aux/sharpbang b/config/auto-aux/sharpbang
deleted file mode 100755
index eb447baa6e..0000000000
--- a/config/auto-aux/sharpbang
+++ /dev/null
@@ -1,2 +0,0 @@
-#! /bin/cat
-exit 1
diff --git a/config/auto-aux/sharpbang2 b/config/auto-aux/sharpbang2
deleted file mode 100755
index 3753096347..0000000000
--- a/config/auto-aux/sharpbang2
+++ /dev/null
@@ -1,2 +0,0 @@
-#! /usr/bin/cat
-exit 1
diff --git a/config/auto-aux/sighandler.c b/config/auto-aux/sighandler.c
deleted file mode 100644
index 7e748df572..0000000000
--- a/config/auto-aux/sighandler.c
+++ /dev/null
@@ -1,23 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <signal.h>
-
-int main(void)
-{
- SIGRETURN (*old)();
- old = signal(SIGQUIT, SIG_DFL);
- return 0;
-}
diff --git a/config/auto-aux/signals.c b/config/auto-aux/signals.c
deleted file mode 100644
index df0a8b0b50..0000000000
--- a/config/auto-aux/signals.c
+++ /dev/null
@@ -1,68 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* To determine the semantics of signal handlers
- (System V: signal is reset to default behavior on entrance to the handler
- BSD: signal handler remains active). */
-
-#include <stdio.h>
-#include <signal.h>
-
-/* Find a signal that is ignored by default */
-
-#ifdef SIGCHLD
-#define IGNSIG SIGCHLD
-#else
-#ifdef SIGIO
-#define IGNSIG SIGIO
-#else
-#ifdef SIGCLD
-#define IGNSIG SIGCLD
-#else
-#ifdef SIGPWR
-#define IGNSIG SIGPWR
-#endif
-#endif
-#endif
-#endif
-
-#ifdef IGNSIG
-
-int counter;
-
-void sig_handler(int dummy)
-{
- counter++;
-}
-
-int main(int argc, char **argv)
-{
- signal(IGNSIG, sig_handler);
- counter = 0;
- kill(getpid(), IGNSIG);
- kill(getpid(), IGNSIG);
- return (counter == 2 ? 0 : 1);
-}
-
-#else
-
-/* If no suitable signal was found, assume System V */
-
-int main(int argc, char ** argv)
-{
- return 1;
-}
-
-#endif
diff --git a/config/auto-aux/sizes.c b/config/auto-aux/sizes.c
deleted file mode 100644
index 992c47a658..0000000000
--- a/config/auto-aux/sizes.c
+++ /dev/null
@@ -1,23 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <stdio.h>
-
-int main(int argc, char **argv)
-{
- printf("%d %d %d %d\n",
- sizeof(int), sizeof(long), sizeof(long *), sizeof(short));
- return 0;
-}
diff --git a/config/auto-aux/solaris-ld b/config/auto-aux/solaris-ld
deleted file mode 100644
index 3ab90bceff..0000000000
--- a/config/auto-aux/solaris-ld
+++ /dev/null
@@ -1,7 +0,0 @@
-#!/bin/sh
-# Determine if gcc calls the Solaris ld or the GNU ld
-# Exit code is 0 for Solaris ld, 1 for GNU ld
-
-echo "int main() { return 0; }" > hasgot.c
-$cc -v -o tst hasgot.c 2>&1 | grep -s '^ld:' > /dev/null
-exit $?
diff --git a/config/auto-aux/stackov.c b/config/auto-aux/stackov.c
deleted file mode 100644
index a1aa0b7ecf..0000000000
--- a/config/auto-aux/stackov.c
+++ /dev/null
@@ -1,68 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 2001 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <stdio.h>
-#include <signal.h>
-#include <sys/resource.h>
-
-static char sig_alt_stack[SIGSTKSZ];
-static char * system_stack_top;
-
-#if defined(TARGET_i386) && defined(SYS_linux_elf)
-static void segv_handler(int signo, struct sigcontext sc)
-{
- char * fault_addr = (char *) sc.cr2;
-#else
-static void segv_handler(int signo, siginfo_t * info, void * context)
-{
- char * fault_addr = (char *) info->si_addr;
-#endif
- struct rlimit limit;
-
- if (getrlimit(RLIMIT_STACK, &limit) == 0 &&
- ((long) fault_addr & (sizeof(long) - 1)) == 0 &&
- fault_addr < system_stack_top &&
- fault_addr >= system_stack_top - limit.rlim_cur - 0x2000) {
- _exit(0);
- } else {
- _exit(4);
- }
-}
-
-int main(int argc, char ** argv)
-{
- struct sigaltstack stk;
- struct sigaction act;
-
- stk.ss_sp = sig_alt_stack;
- stk.ss_size = SIGSTKSZ;
- stk.ss_flags = 0;
-#if defined(TARGET_i386) && defined(SYS_linux_elf)
- act.sa_handler = (void (*)(int)) segv_handler;
- act.sa_flags = SA_ONSTACK | SA_NODEFER;
-#else
- act.sa_sigaction = segv_handler;
- act.sa_flags = SA_SIGINFO | SA_ONSTACK | SA_NODEFER;
-#endif
- sigemptyset(&act.sa_mask);
- system_stack_top = (char *) &act;
- if (sigaltstack(&stk, NULL) != 0) { perror("sigaltstack"); return 2; }
- if (sigaction(SIGSEGV, &act, NULL) != 0) { perror("sigaction"); return 2; }
- /* We used to trigger a stack overflow at this point to test whether
- the code above works, but this causes problems with POSIX threads
- on some BSD systems. So, instead, we just test that all this
- code compiles, indicating that the required syscalls are there. */
- return 0;
-}
diff --git a/config/auto-aux/tclversion.c b/config/auto-aux/tclversion.c
deleted file mode 100644
index 77c0bb729e..0000000000
--- a/config/auto-aux/tclversion.c
+++ /dev/null
@@ -1,8 +0,0 @@
-#include <stdio.h>
-#include <tcl.h>
-#include <tk.h>
-
-main ()
-{
- puts(TCL_VERSION);
-}
diff --git a/config/auto-aux/trycompile b/config/auto-aux/trycompile
deleted file mode 100755
index 797a1c3869..0000000000
--- a/config/auto-aux/trycompile
+++ /dev/null
@@ -1,7 +0,0 @@
-#!/bin/sh
-if test "$verbose" = yes; then
-echo "trycompile: $cc -o tst $* $cclibs" >&2
-$cc -o tst $* $cclibs || exit 100
-else
-$cc -o tst $* $cclibs 2> /dev/null || exit 100
-fi
diff --git a/config/config.Mac b/config/config.Mac
deleted file mode 100644
index 51594dd25c..0000000000
--- a/config/config.Mac
+++ /dev/null
@@ -1,76 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Damien Doligez, Projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-### Compile-time configuration
-
-########## General configuration
-
-### Where to install the MPW tool binaries (must be in your command path)
-set -e BINDIR "{mpw}User Commands:"
-
-### Where to install the standard library for MPW tools
-set -e LIBDIR "{mpw}User Commands:ocaml-lib:"
-
-### Where to install the help file
-set -e HELPFILE "{mpw}OCaml.help"
-
-### Where to install the application and the standard library
-set -e APPLIDIR "{mpw}:OCaml-distrib:"
-
-
-############# Configuration for the contributed libraries
-
-### Which libraries to compile and install
-# Currently available:
-# bigarray Statically-allocated arrays
-# dynlink Dynamic linking of bytecode
-# graph Graphics (for the standalone application only)
-# num Arbitrary-precision rational arithmetic
-# str Regular expressions and high-level string processing
-#
-# You need all of them to build the standalone application.
-
-set -e OTHERLIBRARIES "bigarray dynlink graph num str"
-
-
-############# To compile in debug mode (or not)
-
-# compile without debugging info / with optimisations
-unset adbgflag ldbgflag
-set -e cdbgflag "-d NDEBUG"
-
-# compile with debugging info / without optimisations
-#set -e adbgflag "-sym on -d DEBUG -wb -l"
-#set -e cdbgflag "-sym on -d DEBUG"
-#set -e ldbgflag "-sym on"
-
-
-############# Configuration for the native-code compiler
-# (not used for the moment)
-
-set -e ARCH none
-set -e MODEL ppc
-set -e SYSTEM unknown
-set -e NATIVECC MrC
-
-############# Version numbers (do not change)
-
-set -e OCAMLMAJOR 3
-set -e OCAMLMINOR "04"
-set -e MAJOR 1
-set -e MINOR 0
-set -e BUGFIX 0
-set -e STAGE a
-set -e REV 11
diff --git a/config/gnu/config.guess b/config/gnu/config.guess
deleted file mode 100755
index 4a903edf44..0000000000
--- a/config/gnu/config.guess
+++ /dev/null
@@ -1,1366 +0,0 @@
-#! /bin/sh
-# Attempt to guess a canonical system name.
-# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
-# Free Software Foundation, Inc.
-
-timestamp='2003-11-23'
-
-# This file is free software; you can redistribute it and/or modify it
-# under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful, but
-# WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-# General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-#
-# As a special exception to the GNU General Public License, if you
-# distribute this file as part of a program that contains a
-# configuration script generated by Autoconf, you may include it under
-# the same distribution terms that you use for the rest of that program.
-
-# Written by Per Bothner <bothner@cygnus.com>.
-# Please send patches to <config-patches@gnu.org>.
-#
-# This script attempts to guess a canonical system name similar to
-# config.sub. If it succeeds, it prints the system name on stdout, and
-# exits with 0. Otherwise, it exits with 1.
-#
-# The plan is that this can be called by configure scripts if you
-# don't specify an explicit build system type.
-
-me=`echo "$0" | sed -e 's,.*/,,'`
-
-usage="\
-Usage: $0 [OPTION]
-
-Output the configuration name of the system \`$me' is run on.
-
-Operation modes:
- -h, --help print this help, then exit
- -t, --time-stamp print date of last modification, then exit
- -v, --version print version number, then exit
-
-Report bugs and patches to <config-patches@gnu.org>."
-
-version="\
-GNU config.guess ($timestamp)
-
-Originally written by Per Bothner.
-Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
-Free Software Foundation, Inc.
-
-This is free software; see the source for copying conditions. There is NO
-warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
-
-help="
-Try \`$me --help' for more information."
-
-# Parse command line
-while test $# -gt 0 ; do
- case $1 in
- --time-stamp | --time* | -t )
- echo "$timestamp" ; exit 0 ;;
- --version | -v )
- echo "$version" ; exit 0 ;;
- --help | --h* | -h )
- echo "$usage"; exit 0 ;;
- -- ) # Stop option processing
- shift; break ;;
- - ) # Use stdin as input.
- break ;;
- -* )
- echo "$me: invalid option $1$help" >&2
- exit 1 ;;
- * )
- break ;;
- esac
-done
-
-if test $# != 0; then
- echo "$me: too many arguments$help" >&2
- exit 1
-fi
-
-
-dummy=dummy-$$
-trap 'rm -f $dummy.c $dummy.o $dummy.rel $dummy; exit 1' 1 2 15
-
-# CC_FOR_BUILD -- compiler used by this script.
-# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still
-# use `HOST_CC' if defined, but it is deprecated.
-
-case $CC_FOR_BUILD,$HOST_CC,$CC in
- ,,) echo "int dummy(){}" > $dummy.c
- for c in cc gcc c89 ; do
- ($c $dummy.c -c -o $dummy.o) >/dev/null 2>&1
- if test $? = 0 ; then
- CC_FOR_BUILD="$c"; break
- fi
- done
- rm -f $dummy.c $dummy.o $dummy.rel
- if test x"$CC_FOR_BUILD" = x ; then
- CC_FOR_BUILD=no_compiler_found
- fi
- ;;
- ,,*) CC_FOR_BUILD=$CC ;;
- ,*,*) CC_FOR_BUILD=$HOST_CC ;;
-esac
-
-# This is needed to find uname on a Pyramid OSx when run in the BSD universe.
-# (ghazi@noc.rutgers.edu 8/24/94.)
-if (test -f /.attbin/uname) >/dev/null 2>&1 ; then
- PATH=$PATH:/.attbin ; export PATH
-fi
-
-UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown
-UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown
-UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown
-UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown
-
-# Note: order is significant - the case branches are not exclusive.
-
-case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
- *:NetBSD:*:*)
- # Netbsd (nbsd) targets should (where applicable) match one or
- # more of the tupples: *-*-netbsdelf*, *-*-netbsdaout*,
- # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently
- # switched to ELF, *-*-netbsd* would select the old
- # object file format. This provides both forward
- # compatibility and a consistent mechanism for selecting the
- # object file format.
- # Determine the machine/vendor (is the vendor relevant).
- case "${UNAME_MACHINE}" in
- amiga) machine=m68k-unknown ;;
- arm32) machine=arm-unknown ;;
- atari*) machine=m68k-atari ;;
- sun3*) machine=m68k-sun ;;
- mac68k) machine=m68k-apple ;;
- macppc) machine=powerpc-apple ;;
- hp3[0-9][05]) machine=m68k-hp ;;
- ibmrt|romp-ibm) machine=romp-ibm ;;
- *) machine=${UNAME_MACHINE}-unknown ;;
- esac
- # The Operating System including object format, if it has switched
- # to ELF recently, or will in the future.
- case "${UNAME_MACHINE}" in
- i386|sparc|amiga|arm*|hp300|mvme68k|vax|atari|luna68k|mac68k|news68k|next68k|pc532|sun3*|x68k)
- if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \
- | grep __ELF__ >/dev/null
- then
- # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout).
- # Return netbsd for either. FIX?
- os=netbsd
- else
- os=netbsdelf
- fi
- ;;
- *)
- os=netbsd
- ;;
- esac
- # The OS release
- release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'`
- # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM:
- # contains redundant information, the shorter form:
- # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used.
- echo "${machine}-${os}${release}"
- exit 0 ;;
- alpha:OSF1:*:*)
- if test $UNAME_RELEASE = "V4.0"; then
- UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'`
- fi
- # A Vn.n version is a released version.
- # A Tn.n version is a released field test version.
- # A Xn.n version is an unreleased experimental baselevel.
- # 1.2 uses "1.2" for uname -r.
- cat <<EOF >$dummy.s
- .data
-\$Lformat:
- .byte 37,100,45,37,120,10,0 # "%d-%x\n"
-
- .text
- .globl main
- .align 4
- .ent main
-main:
- .frame \$30,16,\$26,0
- ldgp \$29,0(\$27)
- .prologue 1
- .long 0x47e03d80 # implver \$0
- lda \$2,-1
- .long 0x47e20c21 # amask \$2,\$1
- lda \$16,\$Lformat
- mov \$0,\$17
- not \$1,\$18
- jsr \$26,printf
- ldgp \$29,0(\$26)
- mov 0,\$16
- jsr \$26,exit
- .end main
-EOF
- $CC_FOR_BUILD $dummy.s -o $dummy 2>/dev/null
- if test "$?" = 0 ; then
- case `./$dummy` in
- 0-0)
- UNAME_MACHINE="alpha"
- ;;
- 1-0)
- UNAME_MACHINE="alphaev5"
- ;;
- 1-1)
- UNAME_MACHINE="alphaev56"
- ;;
- 1-101)
- UNAME_MACHINE="alphapca56"
- ;;
- 2-303)
- UNAME_MACHINE="alphaev6"
- ;;
- 2-307)
- UNAME_MACHINE="alphaev67"
- ;;
- esac
- fi
- rm -f $dummy.s $dummy
- echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[VTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'`
- exit 0 ;;
- Alpha\ *:Windows_NT*:*)
- # How do we know it's Interix rather than the generic POSIX subsystem?
- # Should we change UNAME_MACHINE based on the output of uname instead
- # of the specific Alpha model?
- echo alpha-pc-interix
- exit 0 ;;
- 21064:Windows_NT:50:3)
- echo alpha-dec-winnt3.5
- exit 0 ;;
- Amiga*:UNIX_System_V:4.0:*)
- echo m68k-unknown-sysv4
- exit 0;;
- amiga:OpenBSD:*:*)
- echo m68k-unknown-openbsd${UNAME_RELEASE}
- exit 0 ;;
- *:[Aa]miga[Oo][Ss]:*:*)
- echo ${UNAME_MACHINE}-unknown-amigaos
- exit 0 ;;
- arc64:OpenBSD:*:*)
- echo mips64el-unknown-openbsd${UNAME_RELEASE}
- exit 0 ;;
- arc:OpenBSD:*:*)
- echo mipsel-unknown-openbsd${UNAME_RELEASE}
- exit 0 ;;
- hkmips:OpenBSD:*:*)
- echo mips-unknown-openbsd${UNAME_RELEASE}
- exit 0 ;;
- pmax:OpenBSD:*:*)
- echo mipsel-unknown-openbsd${UNAME_RELEASE}
- exit 0 ;;
- sgi:OpenBSD:*:*)
- echo mips-unknown-openbsd${UNAME_RELEASE}
- exit 0 ;;
- wgrisc:OpenBSD:*:*)
- echo mipsel-unknown-openbsd${UNAME_RELEASE}
- exit 0 ;;
- *:OS/390:*:*)
- echo i370-ibm-openedition
- exit 0 ;;
- arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*)
- echo arm-acorn-riscix${UNAME_RELEASE}
- exit 0;;
- SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*)
- echo hppa1.1-hitachi-hiuxmpp
- exit 0;;
- Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*)
- # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE.
- if test "`(/bin/universe) 2>/dev/null`" = att ; then
- echo pyramid-pyramid-sysv3
- else
- echo pyramid-pyramid-bsd
- fi
- exit 0 ;;
- NILE*:*:*:dcosx)
- echo pyramid-pyramid-svr4
- exit 0 ;;
- sun4H:SunOS:5.*:*)
- echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
- exit 0 ;;
- sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*)
- echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
- exit 0 ;;
- i86pc:SunOS:5.*:*)
- echo i386-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
- exit 0 ;;
- sun4*:SunOS:6*:*)
- # According to config.sub, this is the proper way to canonicalize
- # SunOS6. Hard to guess exactly what SunOS6 will be like, but
- # it's likely to be more like Solaris than SunOS4.
- echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
- exit 0 ;;
- sun4*:SunOS:*:*)
- case "`/usr/bin/arch -k`" in
- Series*|S4*)
- UNAME_RELEASE=`uname -v`
- ;;
- esac
- # Japanese Language versions have a version number like `4.1.3-JL'.
- echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'`
- exit 0 ;;
- sun3*:SunOS:*:*)
- echo m68k-sun-sunos${UNAME_RELEASE}
- exit 0 ;;
- sun*:*:4.2BSD:*)
- UNAME_RELEASE=`(cat /etc/motd | awk 'NR == 1 {print substr($5,1,3)}') 2>/dev/null`
- test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3
- case "`/bin/arch`" in
- sun3)
- echo m68k-sun-sunos${UNAME_RELEASE}
- ;;
- sun4)
- echo sparc-sun-sunos${UNAME_RELEASE}
- ;;
- esac
- exit 0 ;;
- aushp:SunOS:*:*)
- echo sparc-auspex-sunos${UNAME_RELEASE}
- exit 0 ;;
- atari*:OpenBSD:*:*)
- echo m68k-unknown-openbsd${UNAME_RELEASE}
- exit 0 ;;
- # The situation for MiNT is a little confusing. The machine name
- # can be virtually everything (everything which is not
- # "atarist" or "atariste" at least should have a processor
- # > m68000). The system name ranges from "MiNT" over "FreeMiNT"
- # to the lowercase version "mint" (or "freemint"). Finally
- # the system name "TOS" denotes a system which is actually not
- # MiNT. But MiNT is downward compatible to TOS, so this should
- # be no problem.
- atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*)
- echo m68k-atari-mint${UNAME_RELEASE}
- exit 0 ;;
- atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*)
- echo m68k-atari-mint${UNAME_RELEASE}
- exit 0 ;;
- *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*)
- echo m68k-atari-mint${UNAME_RELEASE}
- exit 0 ;;
- milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*)
- echo m68k-milan-mint${UNAME_RELEASE}
- exit 0 ;;
- hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*)
- echo m68k-hades-mint${UNAME_RELEASE}
- exit 0 ;;
- *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*)
- echo m68k-unknown-mint${UNAME_RELEASE}
- exit 0 ;;
- sun3*:OpenBSD:*:*)
- echo m68k-unknown-openbsd${UNAME_RELEASE}
- exit 0 ;;
- mac68k:OpenBSD:*:*)
- echo m68k-unknown-openbsd${UNAME_RELEASE}
- exit 0 ;;
- mvme68k:OpenBSD:*:*)
- echo m68k-unknown-openbsd${UNAME_RELEASE}
- exit 0 ;;
- mvme88k:OpenBSD:*:*)
- echo m88k-unknown-openbsd${UNAME_RELEASE}
- exit 0 ;;
- powerpc:machten:*:*)
- echo powerpc-apple-machten${UNAME_RELEASE}
- exit 0 ;;
- RISC*:Mach:*:*)
- echo mips-dec-mach_bsd4.3
- exit 0 ;;
- RISC*:ULTRIX:*:*)
- echo mips-dec-ultrix${UNAME_RELEASE}
- exit 0 ;;
- VAX*:ULTRIX*:*:*)
- echo vax-dec-ultrix${UNAME_RELEASE}
- exit 0 ;;
- 2020:CLIX:*:* | 2430:CLIX:*:*)
- echo clipper-intergraph-clix${UNAME_RELEASE}
- exit 0 ;;
- mips:*:*:UMIPS | mips:*:*:RISCos)
- sed 's/^ //' << EOF >$dummy.c
-#ifdef __cplusplus
-#include <stdio.h> /* for printf() prototype */
- int main (int argc, char *argv[]) {
-#else
- int main (argc, argv) int argc; char *argv[]; {
-#endif
- #if defined (host_mips) && defined (MIPSEB)
- #if defined (SYSTYPE_SYSV)
- printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0);
- #endif
- #if defined (SYSTYPE_SVR4)
- printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0);
- #endif
- #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD)
- printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0);
- #endif
- #endif
- exit (-1);
- }
-EOF
- $CC_FOR_BUILD $dummy.c -o $dummy \
- && ./$dummy `echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` \
- && rm -f $dummy.c $dummy && exit 0
- rm -f $dummy.c $dummy
- echo mips-mips-riscos${UNAME_RELEASE}
- exit 0 ;;
- Motorola:PowerMAX_OS:*:*)
- echo powerpc-motorola-powermax
- exit 0 ;;
- Night_Hawk:Power_UNIX:*:*)
- echo powerpc-harris-powerunix
- exit 0 ;;
- m88k:CX/UX:7*:*)
- echo m88k-harris-cxux7
- exit 0 ;;
- m88k:*:4*:R4*)
- echo m88k-motorola-sysv4
- exit 0 ;;
- m88k:*:3*:R3*)
- echo m88k-motorola-sysv3
- exit 0 ;;
- AViiON:dgux:*:*)
- # DG/UX returns AViiON for all architectures
- UNAME_PROCESSOR=`/usr/bin/uname -p`
- if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ]
- then
- if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \
- [ ${TARGET_BINARY_INTERFACE}x = x ]
- then
- echo m88k-dg-dgux${UNAME_RELEASE}
- else
- echo m88k-dg-dguxbcs${UNAME_RELEASE}
- fi
- else
- echo i586-dg-dgux${UNAME_RELEASE}
- fi
- exit 0 ;;
- M88*:DolphinOS:*:*) # DolphinOS (SVR3)
- echo m88k-dolphin-sysv3
- exit 0 ;;
- M88*:*:R3*:*)
- # Delta 88k system running SVR3
- echo m88k-motorola-sysv3
- exit 0 ;;
- XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3)
- echo m88k-tektronix-sysv3
- exit 0 ;;
- Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD)
- echo m68k-tektronix-bsd
- exit 0 ;;
- *:IRIX*:*:*)
- echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'`
- exit 0 ;;
- ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX.
- echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id
- exit 0 ;; # Note that: echo "'`uname -s`'" gives 'AIX '
- i*86:AIX:*:*)
- echo i386-ibm-aix
- exit 0 ;;
- ia64:AIX:*:*)
- if [ -x /usr/bin/oslevel ] ; then
- IBM_REV=`/usr/bin/oslevel`
- else
- IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE}
- fi
- echo ${UNAME_MACHINE}-ibm-aix${IBM_REV}
- exit 0 ;;
- *:AIX:2:3)
- if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then
- sed 's/^ //' << EOF >$dummy.c
- #include <sys/systemcfg.h>
-
- main()
- {
- if (!__power_pc())
- exit(1);
- puts("powerpc-ibm-aix3.2.5");
- exit(0);
- }
-EOF
- $CC_FOR_BUILD $dummy.c -o $dummy && ./$dummy && rm -f $dummy.c $dummy && exit 0
- rm -f $dummy.c $dummy
- echo rs6000-ibm-aix3.2.5
- elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then
- echo rs6000-ibm-aix3.2.4
- else
- echo rs6000-ibm-aix3.2
- fi
- exit 0 ;;
- *:AIX:*:[45])
- IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | awk 'NR == 1 { print $1 }'`
- if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then
- IBM_ARCH=rs6000
- else
- IBM_ARCH=powerpc
- fi
- if [ -x /usr/bin/oslevel ] ; then
- IBM_REV=`/usr/bin/oslevel`
- else
- IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE}
- fi
- echo ${IBM_ARCH}-ibm-aix${IBM_REV}
- exit 0 ;;
- *:AIX:*:*)
- echo rs6000-ibm-aix
- exit 0 ;;
- ibmrt:4.4BSD:*|romp-ibm:BSD:*)
- echo romp-ibm-bsd4.4
- exit 0 ;;
- ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and
- echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to
- exit 0 ;; # report: romp-ibm BSD 4.3
- *:BOSX:*:*)
- echo rs6000-bull-bosx
- exit 0 ;;
- DPX/2?00:B.O.S.:*:*)
- echo m68k-bull-sysv3
- exit 0 ;;
- 9000/[34]??:4.3bsd:1.*:*)
- echo m68k-hp-bsd
- exit 0 ;;
- hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*)
- echo m68k-hp-bsd4.4
- exit 0 ;;
- 9000/[34678]??:HP-UX:*:*)
- HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'`
- case "${UNAME_MACHINE}" in
- 9000/31? ) HP_ARCH=m68000 ;;
- 9000/[34]?? ) HP_ARCH=m68k ;;
- 9000/[678][0-9][0-9])
- case "${HPUX_REV}" in
- 11.[0-9][0-9])
- if [ -x /usr/bin/getconf ]; then
- sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null`
- sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null`
- case "${sc_cpu_version}" in
- 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0
- 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1
- 532) # CPU_PA_RISC2_0
- case "${sc_kernel_bits}" in
- 32) HP_ARCH="hppa2.0n" ;;
- 64) HP_ARCH="hppa2.0w" ;;
- esac ;;
- esac
- fi ;;
- esac
- if [ "${HP_ARCH}" = "" ]; then
- sed 's/^ //' << EOF >$dummy.c
-
- #define _HPUX_SOURCE
- #include <stdlib.h>
- #include <unistd.h>
-
- int main ()
- {
- #if defined(_SC_KERNEL_BITS)
- long bits = sysconf(_SC_KERNEL_BITS);
- #endif
- long cpu = sysconf (_SC_CPU_VERSION);
-
- switch (cpu)
- {
- case CPU_PA_RISC1_0: puts ("hppa1.0"); break;
- case CPU_PA_RISC1_1: puts ("hppa1.1"); break;
- case CPU_PA_RISC2_0:
- #if defined(_SC_KERNEL_BITS)
- switch (bits)
- {
- case 64: puts ("hppa2.0w"); break;
- case 32: puts ("hppa2.0n"); break;
- default: puts ("hppa2.0"); break;
- } break;
- #else /* !defined(_SC_KERNEL_BITS) */
- puts ("hppa2.0"); break;
- #endif
- default: puts ("hppa1.0"); break;
- }
- exit (0);
- }
-EOF
- (CCOPTS= $CC_FOR_BUILD $dummy.c -o $dummy 2>/dev/null ) && HP_ARCH=`./$dummy`
- if test -z "$HP_ARCH"; then HP_ARCH=hppa; fi
- rm -f $dummy.c $dummy
- fi ;;
- esac
- echo ${HP_ARCH}-hp-hpux${HPUX_REV}
- exit 0 ;;
- ia64:HP-UX:*:*)
- HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'`
- echo ia64-hp-hpux${HPUX_REV}
- exit 0 ;;
- 3050*:HI-UX:*:*)
- sed 's/^ //' << EOF >$dummy.c
- #include <unistd.h>
- int
- main ()
- {
- long cpu = sysconf (_SC_CPU_VERSION);
- /* The order matters, because CPU_IS_HP_MC68K erroneously returns
- true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct
- results, however. */
- if (CPU_IS_PA_RISC (cpu))
- {
- switch (cpu)
- {
- case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break;
- case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break;
- case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break;
- default: puts ("hppa-hitachi-hiuxwe2"); break;
- }
- }
- else if (CPU_IS_HP_MC68K (cpu))
- puts ("m68k-hitachi-hiuxwe2");
- else puts ("unknown-hitachi-hiuxwe2");
- exit (0);
- }
-EOF
- $CC_FOR_BUILD $dummy.c -o $dummy && ./$dummy && rm -f $dummy.c $dummy && exit 0
- rm -f $dummy.c $dummy
- echo unknown-hitachi-hiuxwe2
- exit 0 ;;
- 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* )
- echo hppa1.1-hp-bsd
- exit 0 ;;
- 9000/8??:4.3bsd:*:*)
- echo hppa1.0-hp-bsd
- exit 0 ;;
- *9??*:MPE/iX:*:*)
- echo hppa1.0-hp-mpeix
- exit 0 ;;
- hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* )
- echo hppa1.1-hp-osf
- exit 0 ;;
- hp8??:OSF1:*:*)
- echo hppa1.0-hp-osf
- exit 0 ;;
- i*86:OSF1:*:*)
- if [ -x /usr/sbin/sysversion ] ; then
- echo ${UNAME_MACHINE}-unknown-osf1mk
- else
- echo ${UNAME_MACHINE}-unknown-osf1
- fi
- exit 0 ;;
- parisc*:Lites*:*:*)
- echo hppa1.1-hp-lites
- exit 0 ;;
- hppa*:OpenBSD:*:*)
- echo hppa-unknown-openbsd
- exit 0 ;;
- C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*)
- echo c1-convex-bsd
- exit 0 ;;
- C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*)
- if getsysinfo -f scalar_acc
- then echo c32-convex-bsd
- else echo c2-convex-bsd
- fi
- exit 0 ;;
- C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*)
- echo c34-convex-bsd
- exit 0 ;;
- C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*)
- echo c38-convex-bsd
- exit 0 ;;
- C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*)
- echo c4-convex-bsd
- exit 0 ;;
- CRAY*X-MP:*:*:*)
- echo xmp-cray-unicos
- exit 0 ;;
- CRAY*Y-MP:*:*:*)
- echo ymp-cray-unicos${UNAME_RELEASE}
- exit 0 ;;
- CRAY*[A-Z]90:*:*:*)
- echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \
- | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \
- -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/
- exit 0 ;;
- CRAY*TS:*:*:*)
- echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
- exit 0 ;;
- CRAY*T3D:*:*:*)
- echo alpha-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
- exit 0 ;;
- CRAY*T3E:*:*:*)
- echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
- exit 0 ;;
- CRAY*SV1:*:*:*)
- echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
- exit 0 ;;
- CRAY-2:*:*:*)
- echo cray2-cray-unicos
- exit 0 ;;
- F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*)
- FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'`
- FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'`
- FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'`
- echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}"
- exit 0 ;;
- hp300:OpenBSD:*:*)
- echo m68k-unknown-openbsd${UNAME_RELEASE}
- exit 0 ;;
- i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*)
- echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE}
- exit 0 ;;
- sparc*:BSD/OS:*:*)
- echo sparc-unknown-bsdi${UNAME_RELEASE}
- exit 0 ;;
- *:BSD/OS:*:*)
- echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE}
- exit 0 ;;
- *:FreeBSD:*:*)
- echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`
- exit 0 ;;
- *:OpenBSD:*:*)
- echo ${UNAME_MACHINE}-unknown-openbsd`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'`
- exit 0 ;;
- i*:CYGWIN*:*)
- echo ${UNAME_MACHINE}-pc-cygwin
- exit 0 ;;
- i*:MINGW*:*)
- echo ${UNAME_MACHINE}-pc-mingw32
- exit 0 ;;
- i*:PW*:*)
- echo ${UNAME_MACHINE}-pc-pw32
- exit 0 ;;
- i*:Windows_NT*:* | Pentium*:Windows_NT*:*)
- # How do we know it's Interix rather than the generic POSIX subsystem?
- # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we
- # UNAME_MACHINE based on the output of uname instead of i386?
- echo i386-pc-interix
- exit 0 ;;
- i*:UWIN*:*)
- echo ${UNAME_MACHINE}-pc-uwin
- exit 0 ;;
- p*:CYGWIN*:*)
- echo powerpcle-unknown-cygwin
- exit 0 ;;
- prep*:SunOS:5.*:*)
- echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
- exit 0 ;;
- *:GNU:*:*)
- echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'`
- exit 0 ;;
- i*86:Minix:*:*)
- echo ${UNAME_MACHINE}-pc-minix
- exit 0 ;;
- arm*:Linux:*:*)
- echo ${UNAME_MACHINE}-unknown-linux-gnu
- exit 0 ;;
- sa110:Linux:*:*)
- echo arm-unknown-linux-gnu
- exit 0 ;;
- ia64:Linux:*:*)
- echo ${UNAME_MACHINE}-unknown-linux
- exit 0 ;;
- m68*:Linux:*:*)
- echo ${UNAME_MACHINE}-unknown-linux-gnu
- exit 0 ;;
- mips:Linux:*:*)
- cat >$dummy.c <<EOF
-#ifdef __cplusplus
-#include <stdio.h> /* for printf() prototype */
-int main (int argc, char *argv[]) {
-#else
-int main (argc, argv) int argc; char *argv[]; {
-#endif
-#ifdef __MIPSEB__
- printf ("%s-unknown-linux-gnu\n", argv[1]);
-#endif
-#ifdef __MIPSEL__
- printf ("%sel-unknown-linux-gnu\n", argv[1]);
-#endif
- return 0;
-}
-EOF
- $CC_FOR_BUILD $dummy.c -o $dummy 2>/dev/null && ./$dummy "${UNAME_MACHINE}" && rm -f $dummy.c $dummy && exit 0
- rm -f $dummy.c $dummy
- ;;
- ppc:Linux:*:*)
- # Determine Lib Version
- cat >$dummy.c <<EOF
-#include <features.h>
-#if defined(__GLIBC__)
-extern char __libc_version[];
-extern char __libc_release[];
-#endif
-main(argc, argv)
- int argc;
- char *argv[];
-{
-#if defined(__GLIBC__)
- printf("%s %s\n", __libc_version, __libc_release);
-#else
- printf("unknown\n");
-#endif
- return 0;
-}
-EOF
- LIBC=""
- $CC_FOR_BUILD $dummy.c -o $dummy 2>/dev/null
- if test "$?" = 0 ; then
- ./$dummy | grep 1\.99 > /dev/null
- if test "$?" = 0 ; then LIBC="libc1" ; fi
- fi
- rm -f $dummy.c $dummy
- echo powerpc-unknown-linux-gnu${LIBC}
- exit 0 ;;
- alpha:Linux:*:*)
- cat <<EOF >$dummy.s
- .data
- \$Lformat:
- .byte 37,100,45,37,120,10,0 # "%d-%x\n"
- .text
- .globl main
- .align 4
- .ent main
- main:
- .frame \$30,16,\$26,0
- ldgp \$29,0(\$27)
- .prologue 1
- .long 0x47e03d80 # implver \$0
- lda \$2,-1
- .long 0x47e20c21 # amask \$2,\$1
- lda \$16,\$Lformat
- mov \$0,\$17
- not \$1,\$18
- jsr \$26,printf
- ldgp \$29,0(\$26)
- mov 0,\$16
- jsr \$26,exit
- .end main
-EOF
- LIBC=""
- $CC_FOR_BUILD $dummy.s -o $dummy 2>/dev/null
- if test "$?" = 0 ; then
- case `./$dummy` in
- 0-0) UNAME_MACHINE="alpha" ;;
- 1-0) UNAME_MACHINE="alphaev5" ;;
- 1-1) UNAME_MACHINE="alphaev56" ;;
- 1-101) UNAME_MACHINE="alphapca56" ;;
- 2-303) UNAME_MACHINE="alphaev6" ;;
- 2-307) UNAME_MACHINE="alphaev67" ;;
- esac
- objdump --private-headers $dummy | \
- grep ld.so.1 > /dev/null
- if test "$?" = 0 ; then
- LIBC="libc1"
- fi
- fi
- rm -f $dummy.s $dummy
- echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC}
- exit 0 ;;
- parisc:Linux:*:* | hppa:Linux:*:*)
- # Look for CPU level
- case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in
- PA7*) echo hppa1.1-unknown-linux-gnu ;;
- PA8*) echo hppa2.0-unknown-linux-gnu ;;
- *) echo hppa-unknown-linux-gnu ;;
- esac
- exit 0 ;;
- parisc64:Linux:*:* | hppa64:Linux:*:*)
- echo hppa64-unknown-linux-gnu
- exit 0 ;;
- s390:Linux:*:* | s390x:Linux:*:*)
- echo ${UNAME_MACHINE}-ibm-linux
- exit 0 ;;
- sh*:Linux:*:*)
- echo ${UNAME_MACHINE}-unknown-linux-gnu
- exit 0 ;;
- sparc:Linux:*:* | sparc64:Linux:*:*)
- echo ${UNAME_MACHINE}-unknown-linux-gnu
- exit 0 ;;
- x86_64:Linux:*:*)
- echo x86_64-unknown-linux-gnu
- exit 0 ;;
- i*86:Linux:*:*)
- # The BFD linker knows what the default object file format is, so
- # first see if it will tell us. cd to the root directory to prevent
- # problems with other programs or directories called `ld' in the path.
- ld_supported_targets=`cd /; ld --help 2>&1 \
- | sed -ne '/supported targets:/!d
- s/[ ][ ]*/ /g
- s/.*supported targets: *//
- s/ .*//
- p'`
- case "$ld_supported_targets" in
- elf32-i386)
- TENTATIVE="${UNAME_MACHINE}-pc-linux-gnu"
- ;;
- a.out-i386-linux)
- echo "${UNAME_MACHINE}-pc-linux-gnuaout"
- exit 0 ;;
- coff-i386)
- echo "${UNAME_MACHINE}-pc-linux-gnucoff"
- exit 0 ;;
- "")
- # Either a pre-BFD a.out linker (linux-gnuoldld) or
- # one that does not give us useful --help.
- echo "${UNAME_MACHINE}-pc-linux-gnuoldld"
- exit 0 ;;
- esac
- # Determine whether the default compiler is a.out or elf
- cat >$dummy.c <<EOF
-#include <features.h>
-#ifdef __cplusplus
-#include <stdio.h> /* for printf() prototype */
- int main (int argc, char *argv[]) {
-#else
- int main (argc, argv) int argc; char *argv[]; {
-#endif
-#ifdef __ELF__
-# ifdef __GLIBC__
-# if __GLIBC__ >= 2
- printf ("%s-pc-linux-gnu\n", argv[1]);
-# else
- printf ("%s-pc-linux-gnulibc1\n", argv[1]);
-# endif
-# else
- printf ("%s-pc-linux-gnulibc1\n", argv[1]);
-# endif
-#else
- printf ("%s-pc-linux-gnuaout\n", argv[1]);
-#endif
- return 0;
-}
-EOF
- $CC_FOR_BUILD $dummy.c -o $dummy 2>/dev/null && ./$dummy "${UNAME_MACHINE}" && rm -f $dummy.c $dummy && exit 0
- rm -f $dummy.c $dummy
- test x"${TENTATIVE}" != x && echo "${TENTATIVE}" && exit 0
- ;;
-# ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. earlier versions
-# are messed up and put the nodename in both sysname and nodename.
- i*86:DYNIX/ptx:4*:*)
- echo i386-sequent-sysv4
- exit 0 ;;
- i*86:UNIX_SV:4.2MP:2.*)
- # Unixware is an offshoot of SVR4, but it has its own version
- # number series starting with 2...
- # I am not positive that other SVR4 systems won't match this,
- # I just have to hope. -- rms.
- # Use sysv4.2uw... so that sysv4* matches it.
- echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION}
- exit 0 ;;
- i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*)
- UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'`
- if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then
- echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL}
- else
- echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL}
- fi
- exit 0 ;;
- i*86:*:5:[78]*)
- case `/bin/uname -X | grep "^Machine"` in
- *486*) UNAME_MACHINE=i486 ;;
- *Pentium*) UNAME_MACHINE=i586 ;;
- *Pent*|*Celeron) UNAME_MACHINE=i686 ;;
- esac
- echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION}
- exit 0 ;;
- i*86:*:3.2:*)
- if test -f /usr/options/cb.name; then
- UNAME_REL=`sed -n 's/.*Version //p' </usr/options/cb.name`
- echo ${UNAME_MACHINE}-pc-isc$UNAME_REL
- elif /bin/uname -X 2>/dev/null >/dev/null ; then
- UNAME_REL=`(/bin/uname -X|egrep Release|sed -e 's/.*= //')`
- (/bin/uname -X|egrep i80486 >/dev/null) && UNAME_MACHINE=i486
- (/bin/uname -X|egrep '^Machine.*Pentium' >/dev/null) \
- && UNAME_MACHINE=i586
- (/bin/uname -X|egrep '^Machine.*Pent ?II' >/dev/null) \
- && UNAME_MACHINE=i686
- (/bin/uname -X|egrep '^Machine.*Pentium Pro' >/dev/null) \
- && UNAME_MACHINE=i686
- echo ${UNAME_MACHINE}-pc-sco$UNAME_REL
- else
- echo ${UNAME_MACHINE}-pc-sysv32
- fi
- exit 0 ;;
- i*86:*DOS:*:*)
- echo ${UNAME_MACHINE}-pc-msdosdjgpp
- exit 0 ;;
- pc:*:*:*)
- # Left here for compatibility:
- # uname -m prints for DJGPP always 'pc', but it prints nothing about
- # the processor, so we play safe by assuming i386.
- echo i386-pc-msdosdjgpp
- exit 0 ;;
- Intel:Mach:3*:*)
- echo i386-pc-mach3
- exit 0 ;;
- paragon:*:*:*)
- echo i860-intel-osf1
- exit 0 ;;
- i860:*:4.*:*) # i860-SVR4
- if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then
- echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4
- else # Add other i860-SVR4 vendors below as they are discovered.
- echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4
- fi
- exit 0 ;;
- mini*:CTIX:SYS*5:*)
- # "miniframe"
- echo m68010-convergent-sysv
- exit 0 ;;
- M68*:*:R3V[567]*:*)
- test -r /sysV68 && echo 'm68k-motorola-sysv' && exit 0 ;;
- 3[34]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 4850:*:4.0:3.0)
- OS_REL=''
- test -r /etc/.relid \
- && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid`
- /bin/uname -p 2>/dev/null | grep 86 >/dev/null \
- && echo i486-ncr-sysv4.3${OS_REL} && exit 0
- /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \
- && echo i586-ncr-sysv4.3${OS_REL} && exit 0 ;;
- 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*)
- /bin/uname -p 2>/dev/null | grep 86 >/dev/null \
- && echo i486-ncr-sysv4 && exit 0 ;;
- m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*)
- echo m68k-unknown-lynxos${UNAME_RELEASE}
- exit 0 ;;
- mc68030:UNIX_System_V:4.*:*)
- echo m68k-atari-sysv4
- exit 0 ;;
- i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.0*:*)
- echo i386-unknown-lynxos${UNAME_RELEASE}
- exit 0 ;;
- TSUNAMI:LynxOS:2.*:*)
- echo sparc-unknown-lynxos${UNAME_RELEASE}
- exit 0 ;;
- rs6000:LynxOS:2.*:*)
- echo rs6000-unknown-lynxos${UNAME_RELEASE}
- exit 0 ;;
- PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.0*:*)
- echo powerpc-unknown-lynxos${UNAME_RELEASE}
- exit 0 ;;
- SM[BE]S:UNIX_SV:*:*)
- echo mips-dde-sysv${UNAME_RELEASE}
- exit 0 ;;
- RM*:ReliantUNIX-*:*:*)
- echo mips-sni-sysv4
- exit 0 ;;
- RM*:SINIX-*:*:*)
- echo mips-sni-sysv4
- exit 0 ;;
- *:SINIX-*:*:*)
- if uname -p 2>/dev/null >/dev/null ; then
- UNAME_MACHINE=`(uname -p) 2>/dev/null`
- echo ${UNAME_MACHINE}-sni-sysv4
- else
- echo ns32k-sni-sysv
- fi
- exit 0 ;;
- PENTIUM:CPunix:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort
- # says <Richard.M.Bartel@ccMail.Census.GOV>
- echo i586-unisys-sysv4
- exit 0 ;;
- *:UNIX_System_V:4*:FTX*)
- # From Gerald Hewes <hewes@openmarket.com>.
- # How about differentiating between stratus architectures? -djm
- echo hppa1.1-stratus-sysv4
- exit 0 ;;
- *:*:*:FTX*)
- # From seanf@swdc.stratus.com.
- echo i860-stratus-sysv4
- exit 0 ;;
- mc68*:A/UX:*:*)
- echo m68k-apple-aux${UNAME_RELEASE}
- exit 0 ;;
- news*:NEWS-OS:6*:*)
- echo mips-sony-newsos6
- exit 0 ;;
- R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*)
- if [ -d /usr/nec ]; then
- echo mips-nec-sysv${UNAME_RELEASE}
- else
- echo mips-unknown-sysv${UNAME_RELEASE}
- fi
- exit 0 ;;
- BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only.
- echo powerpc-be-beos
- exit 0 ;;
- BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only.
- echo powerpc-apple-beos
- exit 0 ;;
- BePC:BeOS:*:*) # BeOS running on Intel PC compatible.
- echo i586-pc-beos
- exit 0 ;;
- SX-4:SUPER-UX:*:*)
- echo sx4-nec-superux${UNAME_RELEASE}
- exit 0 ;;
- SX-5:SUPER-UX:*:*)
- echo sx5-nec-superux${UNAME_RELEASE}
- exit 0 ;;
- osfmach3_ppc:*:*:*)
- echo powerpc-unknown-linux
- exit 0 ;;
- Power*:Rhapsody:*:*)
- echo powerpc-apple-rhapsody${UNAME_RELEASE}
- exit 0 ;;
- *:Rhapsody:*:*)
- echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE}
- exit 0 ;;
- *:Darwin:*:*)
- echo `uname -p`-apple-darwin${UNAME_RELEASE}
- exit 0 ;;
- *:procnto*:*:* | *:QNX:[0123456789]*:*)
- if test "${UNAME_MACHINE}" = "x86pc"; then
- UNAME_MACHINE=pc
- fi
- echo `uname -p`-${UNAME_MACHINE}-nto-qnx
- exit 0 ;;
- *:QNX:*:4*)
- echo i386-pc-qnx
- exit 0 ;;
- NSR-[KW]:NONSTOP_KERNEL:*:*)
- echo nsr-tandem-nsk${UNAME_RELEASE}
- exit 0 ;;
- *:NonStop-UX:*:*)
- echo mips-compaq-nonstopux
- exit 0 ;;
- BS2000:POSIX*:*:*)
- echo bs2000-siemens-sysv
- exit 0 ;;
- DS/*:UNIX_System_V:*:*)
- echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE}
- exit 0 ;;
- *:Plan9:*:*)
- # "uname -m" is not consistent, so use $cputype instead. 386
- # is converted to i386 for consistency with other x86
- # operating systems.
- if test "$cputype" = "386"; then
- UNAME_MACHINE=i386
- else
- UNAME_MACHINE="$cputype"
- fi
- echo ${UNAME_MACHINE}-unknown-plan9
- exit 0 ;;
- i*86:OS/2:*:*)
- # If we were able to find `uname', then EMX Unix compatibility
- # is probably installed.
- echo ${UNAME_MACHINE}-pc-os2-emx
- exit 0 ;;
- *:TOPS-10:*:*)
- echo pdp10-unknown-tops10
- exit 0 ;;
- *:TENEX:*:*)
- echo pdp10-unknown-tenex
- exit 0 ;;
- KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*)
- echo pdp10-dec-tops20
- exit 0 ;;
- XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*)
- echo pdp10-xkl-tops20
- exit 0 ;;
- *:TOPS-20:*:*)
- echo pdp10-unknown-tops20
- exit 0 ;;
- *:ITS:*:*)
- echo pdp10-unknown-its
- exit 0 ;;
-esac
-
-#echo '(No uname command or uname output not recognized.)' 1>&2
-#echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2
-
-cat >$dummy.c <<EOF
-#ifdef _SEQUENT_
-# include <sys/types.h>
-# include <sys/utsname.h>
-#endif
-main ()
-{
-#if defined (sony)
-#if defined (MIPSEB)
- /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed,
- I don't know.... */
- printf ("mips-sony-bsd\n"); exit (0);
-#else
-#include <sys/param.h>
- printf ("m68k-sony-newsos%s\n",
-#ifdef NEWSOS4
- "4"
-#else
- ""
-#endif
- ); exit (0);
-#endif
-#endif
-
-#if defined (__arm) && defined (__acorn) && defined (__unix)
- printf ("arm-acorn-riscix"); exit (0);
-#endif
-
-#if defined (hp300) && !defined (hpux)
- printf ("m68k-hp-bsd\n"); exit (0);
-#endif
-
-#if defined (NeXT)
- char * arch;
- int version;
-#if !defined (__ARCHITECTURE__)
- arch = "m68k";
-#else
- arch = __ARCHITECTURE__;
- if (strcmp(arch, "hppa") == 0) arch = "hppa1.1";
-#endif
- version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`;
- printf ("%s-next-nextstep%d\n", arch, version);
- exit (0);
-#endif
-
-#if defined (MULTIMAX) || defined (n16)
-#if defined (UMAXV)
- printf ("ns32k-encore-sysv\n"); exit (0);
-#else
-#if defined (CMU)
- printf ("ns32k-encore-mach\n"); exit (0);
-#else
- printf ("ns32k-encore-bsd\n"); exit (0);
-#endif
-#endif
-#endif
-
-#if defined (__386BSD__)
- printf ("i386-pc-bsd\n"); exit (0);
-#endif
-
-#if defined (sequent)
-#if defined (i386)
- printf ("i386-sequent-dynix\n"); exit (0);
-#endif
-#if defined (ns32000)
- printf ("ns32k-sequent-dynix\n"); exit (0);
-#endif
-#endif
-
-#if defined (_SEQUENT_)
- struct utsname un;
-
- uname(&un);
-
- if (strncmp(un.version, "V2", 2) == 0) {
- printf ("i386-sequent-ptx2\n"); exit (0);
- }
- if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */
- printf ("i386-sequent-ptx1\n"); exit (0);
- }
- printf ("i386-sequent-ptx\n"); exit (0);
-
-#endif
-
-#if defined (vax)
-# if !defined (ultrix)
-# include <sys/param.h>
-# if defined (BSD)
-# if BSD == 43
- printf ("vax-dec-bsd4.3\n"); exit (0);
-# else
-# if BSD == 199006
- printf ("vax-dec-bsd4.3reno\n"); exit (0);
-# else
- printf ("vax-dec-bsd\n"); exit (0);
-# endif
-# endif
-# else
- printf ("vax-dec-bsd\n"); exit (0);
-# endif
-# else
- printf ("vax-dec-ultrix\n"); exit (0);
-# endif
-#endif
-
-#if defined (alliant) && defined (i860)
- printf ("i860-alliant-bsd\n"); exit (0);
-#endif
-
- exit (1);
-}
-EOF
-
-$CC_FOR_BUILD $dummy.c -o $dummy 2>/dev/null && ./$dummy && rm -f $dummy.c $dummy && exit 0
-rm -f $dummy.c $dummy
-
-# Apollos put the system type in the environment.
-
-test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit 0; }
-
-# Convex versions that predate uname can use getsysinfo(1)
-
-if [ -x /usr/convex/getsysinfo ]
-then
- case `getsysinfo -f cpu_type` in
- c1*)
- echo c1-convex-bsd
- exit 0 ;;
- c2*)
- if getsysinfo -f scalar_acc
- then echo c32-convex-bsd
- else echo c2-convex-bsd
- fi
- exit 0 ;;
- c34*)
- echo c34-convex-bsd
- exit 0 ;;
- c38*)
- echo c38-convex-bsd
- exit 0 ;;
- c4*)
- echo c4-convex-bsd
- exit 0 ;;
- esac
-fi
-
-cat >&2 <<EOF
-$0: unable to guess system type
-
-This script, last modified $timestamp, has failed to recognize
-the operating system you are using. It is advised that you
-download the most up to date version of the config scripts from
-
- ftp://ftp.gnu.org/pub/gnu/config/
-
-If the version you run ($0) is already up to date, please
-send the following data and any information you think might be
-pertinent to <config-patches@gnu.org> in order to provide the needed
-information to handle your system.
-
-config.guess timestamp = $timestamp
-
-uname -m = `(uname -m) 2>/dev/null || echo unknown`
-uname -r = `(uname -r) 2>/dev/null || echo unknown`
-uname -s = `(uname -s) 2>/dev/null || echo unknown`
-uname -v = `(uname -v) 2>/dev/null || echo unknown`
-
-/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null`
-/bin/uname -X = `(/bin/uname -X) 2>/dev/null`
-
-hostinfo = `(hostinfo) 2>/dev/null`
-/bin/universe = `(/bin/universe) 2>/dev/null`
-/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null`
-/bin/arch = `(/bin/arch) 2>/dev/null`
-/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null`
-/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null`
-
-UNAME_MACHINE = ${UNAME_MACHINE}
-UNAME_RELEASE = ${UNAME_RELEASE}
-UNAME_SYSTEM = ${UNAME_SYSTEM}
-UNAME_VERSION = ${UNAME_VERSION}
-EOF
-
-exit 1
-
-# Local variables:
-# eval: (add-hook 'write-file-hooks 'time-stamp)
-# time-stamp-start: "timestamp='"
-# time-stamp-format: "%:y-%02m-%02d"
-# time-stamp-end: "'"
-# End:
diff --git a/config/gnu/config.sub b/config/gnu/config.sub
deleted file mode 100755
index fdcc42bcce..0000000000
--- a/config/gnu/config.sub
+++ /dev/null
@@ -1,1375 +0,0 @@
-#! /bin/sh
-# Configuration validation subroutine script.
-# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
-# Free Software Foundation, Inc.
-
-timestamp='2001-06-08'
-
-# This file is (in principle) common to ALL GNU software.
-# The presence of a machine in this file suggests that SOME GNU software
-# can handle that machine. It does not imply ALL GNU software can.
-#
-# This file is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 59 Temple Place - Suite 330,
-# Boston, MA 02111-1307, USA.
-
-# As a special exception to the GNU General Public License, if you
-# distribute this file as part of a program that contains a
-# configuration script generated by Autoconf, you may include it under
-# the same distribution terms that you use for the rest of that program.
-
-# Please send patches to <config-patches@gnu.org>.
-#
-# Configuration subroutine to validate and canonicalize a configuration type.
-# Supply the specified configuration type as an argument.
-# If it is invalid, we print an error message on stderr and exit with code 1.
-# Otherwise, we print the canonical config type on stdout and succeed.
-
-# This file is supposed to be the same for all GNU packages
-# and recognize all the CPU types, system types and aliases
-# that are meaningful with *any* GNU software.
-# Each package is responsible for reporting which valid configurations
-# it does not support. The user should be able to distinguish
-# a failure to support a valid configuration from a meaningless
-# configuration.
-
-# The goal of this file is to map all the various variations of a given
-# machine specification into a single specification in the form:
-# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM
-# or in some cases, the newer four-part form:
-# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM
-# It is wrong to echo any other type of specification.
-
-me=`echo "$0" | sed -e 's,.*/,,'`
-
-usage="\
-Usage: $0 [OPTION] CPU-MFR-OPSYS
- $0 [OPTION] ALIAS
-
-Canonicalize a configuration name.
-
-Operation modes:
- -h, --help print this help, then exit
- -t, --time-stamp print date of last modification, then exit
- -v, --version print version number, then exit
-
-Report bugs and patches to <config-patches@gnu.org>."
-
-version="\
-GNU config.sub ($timestamp)
-
-Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
-Free Software Foundation, Inc.
-
-This is free software; see the source for copying conditions. There is NO
-warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
-
-help="
-Try \`$me --help' for more information."
-
-# Parse command line
-while test $# -gt 0 ; do
- case $1 in
- --time-stamp | --time* | -t )
- echo "$timestamp" ; exit 0 ;;
- --version | -v )
- echo "$version" ; exit 0 ;;
- --help | --h* | -h )
- echo "$usage"; exit 0 ;;
- -- ) # Stop option processing
- shift; break ;;
- - ) # Use stdin as input.
- break ;;
- -* )
- echo "$me: invalid option $1$help"
- exit 1 ;;
-
- *local*)
- # First pass through any local machine types.
- echo $1
- exit 0;;
-
- * )
- break ;;
- esac
-done
-
-case $# in
- 0) echo "$me: missing argument$help" >&2
- exit 1;;
- 1) ;;
- *) echo "$me: too many arguments$help" >&2
- exit 1;;
-esac
-
-# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any).
-# Here we must recognize all the valid KERNEL-OS combinations.
-maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'`
-case $maybe_os in
- nto-qnx* | linux-gnu* | storm-chaos* | os2-emx* | windows32-*)
- os=-$maybe_os
- basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`
- ;;
- *)
- basic_machine=`echo $1 | sed 's/-[^-]*$//'`
- if [ $basic_machine != $1 ]
- then os=`echo $1 | sed 's/.*-/-/'`
- else os=; fi
- ;;
-esac
-
-### Let's recognize common machines as not being operating systems so
-### that things like config.sub decstation-3100 work. We also
-### recognize some manufacturers as not being operating systems, so we
-### can provide default operating systems below.
-case $os in
- -sun*os*)
- # Prevent following clause from handling this invalid input.
- ;;
- -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \
- -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \
- -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \
- -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\
- -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \
- -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \
- -apple | -axis)
- os=
- basic_machine=$1
- ;;
- -sim | -cisco | -oki | -wec | -winbond)
- os=
- basic_machine=$1
- ;;
- -scout)
- ;;
- -wrs)
- os=-vxworks
- basic_machine=$1
- ;;
- -chorusos*)
- os=-chorusos
- basic_machine=$1
- ;;
- -chorusrdb)
- os=-chorusrdb
- basic_machine=$1
- ;;
- -hiux*)
- os=-hiuxwe2
- ;;
- -sco5)
- os=-sco3.2v5
- basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
- ;;
- -sco4)
- os=-sco3.2v4
- basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
- ;;
- -sco3.2.[4-9]*)
- os=`echo $os | sed -e 's/sco3.2./sco3.2v/'`
- basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
- ;;
- -sco3.2v[4-9]*)
- # Don't forget version if it is 3.2v4 or newer.
- basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
- ;;
- -sco*)
- os=-sco3.2v2
- basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
- ;;
- -udk*)
- basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
- ;;
- -isc)
- os=-isc2.2
- basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
- ;;
- -clix*)
- basic_machine=clipper-intergraph
- ;;
- -isc*)
- basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
- ;;
- -lynx*)
- os=-lynxos
- ;;
- -ptx*)
- basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'`
- ;;
- -windowsnt*)
- os=`echo $os | sed -e 's/windowsnt/winnt/'`
- ;;
- -psos*)
- os=-psos
- ;;
- -mint | -mint[0-9]*)
- basic_machine=m68k-atari
- os=-mint
- ;;
-esac
-
-# Decode aliases for certain CPU-COMPANY combinations.
-case $basic_machine in
- # Recognize the basic CPU types without company name.
- # Some are omitted here because they have special meanings below.
- tahoe | i860 | ia64 | m32r | m68k | m68000 | m88k | ns32k | arc \
- | arm | arme[lb] | arm[bl]e | armv[2345] | armv[345][lb] | strongarm | xscale \
- | pyramid | mn10200 | mn10300 | tron | a29k \
- | 580 | i960 | h8300 \
- | x86 | ppcbe | mipsbe | mipsle | shbe | shle \
- | hppa | hppa1.0 | hppa1.1 | hppa2.0 | hppa2.0w | hppa2.0n \
- | hppa64 \
- | alpha | alphaev[4-8] | alphaev56 | alphapca5[67] \
- | alphaev6[78] \
- | we32k | ns16k | clipper | i370 | sh | sh[34] \
- | powerpc | powerpcle \
- | 1750a | dsp16xx | pdp10 | pdp11 \
- | mips16 | mips64 | mipsel | mips64el \
- | mips64orion | mips64orionel | mipstx39 | mipstx39el \
- | mips64vr4300 | mips64vr4300el | mips64vr4100 | mips64vr4100el \
- | mips64vr5000 | miprs64vr5000el | mcore | s390 | s390x \
- | sparc | sparclet | sparclite | sparc64 | sparcv9 | sparcv9b \
- | v850 | c4x \
- | thumb | d10v | d30v | fr30 | avr | openrisc | tic80 \
- | pj | pjl | h8500 | z8k)
- basic_machine=$basic_machine-unknown
- ;;
- m6811 | m68hc11 | m6812 | m68hc12)
- # Motorola 68HC11/12.
- basic_machine=$basic_machine-unknown
- os=-none
- ;;
- m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k)
- ;;
-
- # We use `pc' rather than `unknown'
- # because (1) that's what they normally are, and
- # (2) the word "unknown" tends to confuse beginning users.
- i*86 | x86_64)
- basic_machine=$basic_machine-pc
- ;;
- # Object if more than one company name word.
- *-*-*)
- echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2
- exit 1
- ;;
- # Recognize the basic CPU types with company name.
- # FIXME: clean up the formatting here.
- vax-* | tahoe-* | i*86-* | i860-* | ia64-* | m32r-* | m68k-* | m68000-* \
- | m88k-* | sparc-* | ns32k-* | fx80-* | arc-* | c[123]* \
- | arm-* | armbe-* | armle-* | armv*-* | strongarm-* | xscale-* \
- | mips-* | pyramid-* | tron-* | a29k-* | romp-* | rs6000-* \
- | power-* | none-* | 580-* | cray2-* | h8300-* | h8500-* | i960-* \
- | xmp-* | ymp-* \
- | x86-* | ppcbe-* | mipsbe-* | mipsle-* | shbe-* | shle-* \
- | hppa-* | hppa1.0-* | hppa1.1-* | hppa2.0-* | hppa2.0w-* \
- | hppa2.0n-* | hppa64-* \
- | alpha-* | alphaev[4-8]-* | alphaev56-* | alphapca5[67]-* \
- | alphaev6[78]-* \
- | we32k-* | cydra-* | ns16k-* | pn-* | np1-* | xps100-* \
- | clipper-* | orion-* \
- | sparclite-* | pdp10-* | pdp11-* | sh-* | sh[34]-* | sh[34]eb-* \
- | powerpc-* | powerpcle-* | sparc64-* | sparcv9-* | sparcv9b-* | sparc86x-* \
- | mips16-* | mips64-* | mipsel-* \
- | mips64el-* | mips64orion-* | mips64orionel-* \
- | mips64vr4100-* | mips64vr4100el-* | mips64vr4300-* | mips64vr4300el-* \
- | mipstx39-* | mipstx39el-* | mcore-* \
- | f30[01]-* | f700-* | s390-* | s390x-* | sv1-* | t3e-* \
- | [cjt]90-* \
- | m88110-* | m680[01234]0-* | m683?2-* | m68360-* | z8k-* | d10v-* \
- | thumb-* | v850-* | d30v-* | tic30-* | tic80-* | c30-* | fr30-* \
- | bs2000-* | tic54x-* | c54x-* | x86_64-* | pj-* | pjl-*)
- ;;
- # Recognize the various machine names and aliases which stand
- # for a CPU type and a company and sometimes even an OS.
- 386bsd)
- basic_machine=i386-unknown
- os=-bsd
- ;;
- 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc)
- basic_machine=m68000-att
- ;;
- 3b*)
- basic_machine=we32k-att
- ;;
- a29khif)
- basic_machine=a29k-amd
- os=-udi
- ;;
- adobe68k)
- basic_machine=m68010-adobe
- os=-scout
- ;;
- alliant | fx80)
- basic_machine=fx80-alliant
- ;;
- altos | altos3068)
- basic_machine=m68k-altos
- ;;
- am29k)
- basic_machine=a29k-none
- os=-bsd
- ;;
- amdahl)
- basic_machine=580-amdahl
- os=-sysv
- ;;
- amiga | amiga-*)
- basic_machine=m68k-unknown
- ;;
- amigaos | amigados)
- basic_machine=m68k-unknown
- os=-amigaos
- ;;
- amigaunix | amix)
- basic_machine=m68k-unknown
- os=-sysv4
- ;;
- apollo68)
- basic_machine=m68k-apollo
- os=-sysv
- ;;
- apollo68bsd)
- basic_machine=m68k-apollo
- os=-bsd
- ;;
- aux)
- basic_machine=m68k-apple
- os=-aux
- ;;
- balance)
- basic_machine=ns32k-sequent
- os=-dynix
- ;;
- convex-c1)
- basic_machine=c1-convex
- os=-bsd
- ;;
- convex-c2)
- basic_machine=c2-convex
- os=-bsd
- ;;
- convex-c32)
- basic_machine=c32-convex
- os=-bsd
- ;;
- convex-c34)
- basic_machine=c34-convex
- os=-bsd
- ;;
- convex-c38)
- basic_machine=c38-convex
- os=-bsd
- ;;
- cray | ymp)
- basic_machine=ymp-cray
- os=-unicos
- ;;
- cray2)
- basic_machine=cray2-cray
- os=-unicos
- ;;
- [cjt]90)
- basic_machine=${basic_machine}-cray
- os=-unicos
- ;;
- crds | unos)
- basic_machine=m68k-crds
- ;;
- cris | cris-* | etrax*)
- basic_machine=cris-axis
- ;;
- da30 | da30-*)
- basic_machine=m68k-da30
- ;;
- decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn)
- basic_machine=mips-dec
- ;;
- delta | 3300 | motorola-3300 | motorola-delta \
- | 3300-motorola | delta-motorola)
- basic_machine=m68k-motorola
- ;;
- delta88)
- basic_machine=m88k-motorola
- os=-sysv3
- ;;
- dpx20 | dpx20-*)
- basic_machine=rs6000-bull
- os=-bosx
- ;;
- dpx2* | dpx2*-bull)
- basic_machine=m68k-bull
- os=-sysv3
- ;;
- ebmon29k)
- basic_machine=a29k-amd
- os=-ebmon
- ;;
- elxsi)
- basic_machine=elxsi-elxsi
- os=-bsd
- ;;
- encore | umax | mmax)
- basic_machine=ns32k-encore
- ;;
- es1800 | OSE68k | ose68k | ose | OSE)
- basic_machine=m68k-ericsson
- os=-ose
- ;;
- fx2800)
- basic_machine=i860-alliant
- ;;
- genix)
- basic_machine=ns32k-ns
- ;;
- gmicro)
- basic_machine=tron-gmicro
- os=-sysv
- ;;
- go32)
- basic_machine=i386-pc
- os=-go32
- ;;
- h3050r* | hiux*)
- basic_machine=hppa1.1-hitachi
- os=-hiuxwe2
- ;;
- h8300hms)
- basic_machine=h8300-hitachi
- os=-hms
- ;;
- h8300xray)
- basic_machine=h8300-hitachi
- os=-xray
- ;;
- h8500hms)
- basic_machine=h8500-hitachi
- os=-hms
- ;;
- harris)
- basic_machine=m88k-harris
- os=-sysv3
- ;;
- hp300-*)
- basic_machine=m68k-hp
- ;;
- hp300bsd)
- basic_machine=m68k-hp
- os=-bsd
- ;;
- hp300hpux)
- basic_machine=m68k-hp
- os=-hpux
- ;;
- hp3k9[0-9][0-9] | hp9[0-9][0-9])
- basic_machine=hppa1.0-hp
- ;;
- hp9k2[0-9][0-9] | hp9k31[0-9])
- basic_machine=m68000-hp
- ;;
- hp9k3[2-9][0-9])
- basic_machine=m68k-hp
- ;;
- hp9k6[0-9][0-9] | hp6[0-9][0-9])
- basic_machine=hppa1.0-hp
- ;;
- hp9k7[0-79][0-9] | hp7[0-79][0-9])
- basic_machine=hppa1.1-hp
- ;;
- hp9k78[0-9] | hp78[0-9])
- # FIXME: really hppa2.0-hp
- basic_machine=hppa1.1-hp
- ;;
- hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893)
- # FIXME: really hppa2.0-hp
- basic_machine=hppa1.1-hp
- ;;
- hp9k8[0-9][13679] | hp8[0-9][13679])
- basic_machine=hppa1.1-hp
- ;;
- hp9k8[0-9][0-9] | hp8[0-9][0-9])
- basic_machine=hppa1.0-hp
- ;;
- hppa-next)
- os=-nextstep3
- ;;
- hppaosf)
- basic_machine=hppa1.1-hp
- os=-osf
- ;;
- hppro)
- basic_machine=hppa1.1-hp
- os=-proelf
- ;;
- i370-ibm* | ibm*)
- basic_machine=i370-ibm
- ;;
-# I'm not sure what "Sysv32" means. Should this be sysv3.2?
- i*86v32)
- basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
- os=-sysv32
- ;;
- i*86v4*)
- basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
- os=-sysv4
- ;;
- i*86v)
- basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
- os=-sysv
- ;;
- i*86sol2)
- basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
- os=-solaris2
- ;;
- i386mach)
- basic_machine=i386-mach
- os=-mach
- ;;
- i386-vsta | vsta)
- basic_machine=i386-unknown
- os=-vsta
- ;;
- iris | iris4d)
- basic_machine=mips-sgi
- case $os in
- -irix*)
- ;;
- *)
- os=-irix4
- ;;
- esac
- ;;
- isi68 | isi)
- basic_machine=m68k-isi
- os=-sysv
- ;;
- m88k-omron*)
- basic_machine=m88k-omron
- ;;
- magnum | m3230)
- basic_machine=mips-mips
- os=-sysv
- ;;
- merlin)
- basic_machine=ns32k-utek
- os=-sysv
- ;;
- mingw32)
- basic_machine=i386-pc
- os=-mingw32
- ;;
- miniframe)
- basic_machine=m68000-convergent
- ;;
- *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*)
- basic_machine=m68k-atari
- os=-mint
- ;;
- mipsel*-linux*)
- basic_machine=mipsel-unknown
- os=-linux-gnu
- ;;
- mips*-linux*)
- basic_machine=mips-unknown
- os=-linux-gnu
- ;;
- mips3*-*)
- basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`
- ;;
- mips3*)
- basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown
- ;;
- mmix*)
- basic_machine=mmix-knuth
- os=-mmixware
- ;;
- monitor)
- basic_machine=m68k-rom68k
- os=-coff
- ;;
- msdos)
- basic_machine=i386-pc
- os=-msdos
- ;;
- mvs)
- basic_machine=i370-ibm
- os=-mvs
- ;;
- ncr3000)
- basic_machine=i486-ncr
- os=-sysv4
- ;;
- netbsd386)
- basic_machine=i386-unknown
- os=-netbsd
- ;;
- netwinder)
- basic_machine=armv4l-rebel
- os=-linux
- ;;
- news | news700 | news800 | news900)
- basic_machine=m68k-sony
- os=-newsos
- ;;
- news1000)
- basic_machine=m68030-sony
- os=-newsos
- ;;
- news-3600 | risc-news)
- basic_machine=mips-sony
- os=-newsos
- ;;
- necv70)
- basic_machine=v70-nec
- os=-sysv
- ;;
- next | m*-next )
- basic_machine=m68k-next
- case $os in
- -nextstep* )
- ;;
- -ns2*)
- os=-nextstep2
- ;;
- *)
- os=-nextstep3
- ;;
- esac
- ;;
- nh3000)
- basic_machine=m68k-harris
- os=-cxux
- ;;
- nh[45]000)
- basic_machine=m88k-harris
- os=-cxux
- ;;
- nindy960)
- basic_machine=i960-intel
- os=-nindy
- ;;
- mon960)
- basic_machine=i960-intel
- os=-mon960
- ;;
- nonstopux)
- basic_machine=mips-compaq
- os=-nonstopux
- ;;
- np1)
- basic_machine=np1-gould
- ;;
- nsr-tandem)
- basic_machine=nsr-tandem
- ;;
- op50n-* | op60c-*)
- basic_machine=hppa1.1-oki
- os=-proelf
- ;;
- OSE68000 | ose68000)
- basic_machine=m68000-ericsson
- os=-ose
- ;;
- os68k)
- basic_machine=m68k-none
- os=-os68k
- ;;
- pa-hitachi)
- basic_machine=hppa1.1-hitachi
- os=-hiuxwe2
- ;;
- paragon)
- basic_machine=i860-intel
- os=-osf
- ;;
- pbd)
- basic_machine=sparc-tti
- ;;
- pbb)
- basic_machine=m68k-tti
- ;;
- pc532 | pc532-*)
- basic_machine=ns32k-pc532
- ;;
- pentium | p5 | k5 | k6 | nexgen)
- basic_machine=i586-pc
- ;;
- pentiumpro | p6 | 6x86 | athlon)
- basic_machine=i686-pc
- ;;
- pentiumii | pentium2)
- basic_machine=i686-pc
- ;;
- pentium-* | p5-* | k5-* | k6-* | nexgen-*)
- basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'`
- ;;
- pentiumpro-* | p6-* | 6x86-* | athlon-*)
- basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'`
- ;;
- pentiumii-* | pentium2-*)
- basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'`
- ;;
- pn)
- basic_machine=pn-gould
- ;;
- power) basic_machine=power-ibm
- ;;
- ppc) basic_machine=powerpc-unknown
- ;;
- ppc-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'`
- ;;
- ppcle | powerpclittle | ppc-le | powerpc-little)
- basic_machine=powerpcle-unknown
- ;;
- ppcle-* | powerpclittle-*)
- basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'`
- ;;
- ps2)
- basic_machine=i386-ibm
- ;;
- pw32)
- basic_machine=i586-unknown
- os=-pw32
- ;;
- rom68k)
- basic_machine=m68k-rom68k
- os=-coff
- ;;
- rm[46]00)
- basic_machine=mips-siemens
- ;;
- rtpc | rtpc-*)
- basic_machine=romp-ibm
- ;;
- sa29200)
- basic_machine=a29k-amd
- os=-udi
- ;;
- sequent)
- basic_machine=i386-sequent
- ;;
- sh)
- basic_machine=sh-hitachi
- os=-hms
- ;;
- sparclite-wrs)
- basic_machine=sparclite-wrs
- os=-vxworks
- ;;
- sps7)
- basic_machine=m68k-bull
- os=-sysv2
- ;;
- spur)
- basic_machine=spur-unknown
- ;;
- st2000)
- basic_machine=m68k-tandem
- ;;
- stratus)
- basic_machine=i860-stratus
- os=-sysv4
- ;;
- sun2)
- basic_machine=m68000-sun
- ;;
- sun2os3)
- basic_machine=m68000-sun
- os=-sunos3
- ;;
- sun2os4)
- basic_machine=m68000-sun
- os=-sunos4
- ;;
- sun3os3)
- basic_machine=m68k-sun
- os=-sunos3
- ;;
- sun3os4)
- basic_machine=m68k-sun
- os=-sunos4
- ;;
- sun4os3)
- basic_machine=sparc-sun
- os=-sunos3
- ;;
- sun4os4)
- basic_machine=sparc-sun
- os=-sunos4
- ;;
- sun4sol2)
- basic_machine=sparc-sun
- os=-solaris2
- ;;
- sun3 | sun3-*)
- basic_machine=m68k-sun
- ;;
- sun4)
- basic_machine=sparc-sun
- ;;
- sun386 | sun386i | roadrunner)
- basic_machine=i386-sun
- ;;
- sv1)
- basic_machine=sv1-cray
- os=-unicos
- ;;
- symmetry)
- basic_machine=i386-sequent
- os=-dynix
- ;;
- t3e)
- basic_machine=t3e-cray
- os=-unicos
- ;;
- tic54x | c54x*)
- basic_machine=tic54x-unknown
- os=-coff
- ;;
- tx39)
- basic_machine=mipstx39-unknown
- ;;
- tx39el)
- basic_machine=mipstx39el-unknown
- ;;
- tower | tower-32)
- basic_machine=m68k-ncr
- ;;
- udi29k)
- basic_machine=a29k-amd
- os=-udi
- ;;
- ultra3)
- basic_machine=a29k-nyu
- os=-sym1
- ;;
- v810 | necv810)
- basic_machine=v810-nec
- os=-none
- ;;
- vaxv)
- basic_machine=vax-dec
- os=-sysv
- ;;
- vms)
- basic_machine=vax-dec
- os=-vms
- ;;
- vpp*|vx|vx-*)
- basic_machine=f301-fujitsu
- ;;
- vxworks960)
- basic_machine=i960-wrs
- os=-vxworks
- ;;
- vxworks68)
- basic_machine=m68k-wrs
- os=-vxworks
- ;;
- vxworks29k)
- basic_machine=a29k-wrs
- os=-vxworks
- ;;
- w65*)
- basic_machine=w65-wdc
- os=-none
- ;;
- w89k-*)
- basic_machine=hppa1.1-winbond
- os=-proelf
- ;;
- windows32)
- basic_machine=i386-pc
- os=-windows32-msvcrt
- ;;
- xmp)
- basic_machine=xmp-cray
- os=-unicos
- ;;
- xps | xps100)
- basic_machine=xps100-honeywell
- ;;
- z8k-*-coff)
- basic_machine=z8k-unknown
- os=-sim
- ;;
- none)
- basic_machine=none-none
- os=-none
- ;;
-
-# Here we handle the default manufacturer of certain CPU types. It is in
-# some cases the only manufacturer, in others, it is the most popular.
- w89k)
- basic_machine=hppa1.1-winbond
- ;;
- op50n)
- basic_machine=hppa1.1-oki
- ;;
- op60c)
- basic_machine=hppa1.1-oki
- ;;
- mips)
- if [ x$os = x-linux-gnu ]; then
- basic_machine=mips-unknown
- else
- basic_machine=mips-mips
- fi
- ;;
- romp)
- basic_machine=romp-ibm
- ;;
- rs6000)
- basic_machine=rs6000-ibm
- ;;
- vax)
- basic_machine=vax-dec
- ;;
- pdp10)
- # there are many clones, so DEC is not a safe bet
- basic_machine=pdp10-unknown
- ;;
- pdp11)
- basic_machine=pdp11-dec
- ;;
- we32k)
- basic_machine=we32k-att
- ;;
- sh3 | sh4)
- basic_machine=sh-unknown
- ;;
- sparc | sparcv9 | sparcv9b)
- basic_machine=sparc-sun
- ;;
- cydra)
- basic_machine=cydra-cydrome
- ;;
- orion)
- basic_machine=orion-highlevel
- ;;
- orion105)
- basic_machine=clipper-highlevel
- ;;
- mac | mpw | mac-mpw)
- basic_machine=m68k-apple
- ;;
- pmac | pmac-mpw)
- basic_machine=powerpc-apple
- ;;
- c4x*)
- basic_machine=c4x-none
- os=-coff
- ;;
- *-unknown)
- # Make sure to match an already-canonicalized machine name.
- ;;
- *)
- echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2
- exit 1
- ;;
-esac
-
-# Here we canonicalize certain aliases for manufacturers.
-case $basic_machine in
- *-digital*)
- basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'`
- ;;
- *-commodore*)
- basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'`
- ;;
- *)
- ;;
-esac
-
-# Decode manufacturer-specific aliases for certain operating systems.
-
-if [ x"$os" != x"" ]
-then
-case $os in
- # First match some system type aliases
- # that might get confused with valid system types.
- # -solaris* is a basic system type, with this one exception.
- -solaris1 | -solaris1.*)
- os=`echo $os | sed -e 's|solaris1|sunos4|'`
- ;;
- -solaris)
- os=-solaris2
- ;;
- -svr4*)
- os=-sysv4
- ;;
- -unixware*)
- os=-sysv4.2uw
- ;;
- -gnu/linux*)
- os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'`
- ;;
- # First accept the basic system types.
- # The portable systems comes first.
- # Each alternative MUST END IN A *, to match a version number.
- # -sysv* is not here because it comes later, after sysvr4.
- -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \
- | -*vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[34]*\
- | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \
- | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \
- | -aos* \
- | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \
- | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \
- | -hiux* | -386bsd* | -netbsd* | -openbsd* | -freebsd* | -riscix* \
- | -lynxos* | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \
- | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \
- | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \
- | -chorusos* | -chorusrdb* \
- | -cygwin* | -pe* | -psos* | -moss* | -proelf* | -rtems* \
- | -mingw32* | -linux-gnu* | -uxpv* | -beos* | -mpeix* | -udk* \
- | -interix* | -uwin* | -rhapsody* | -darwin* | -opened* \
- | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \
- | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* | -os2*)
- # Remember, each alternative MUST END IN *, to match a version number.
- ;;
- -qnx*)
- case $basic_machine in
- x86-* | i*86-*)
- ;;
- *)
- os=-nto$os
- ;;
- esac
- ;;
- -nto*)
- os=-nto-qnx
- ;;
- -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \
- | -windows* | -osx | -abug | -netware* | -os9* | -beos* \
- | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*)
- ;;
- -mac*)
- os=`echo $os | sed -e 's|mac|macos|'`
- ;;
- -linux*)
- os=`echo $os | sed -e 's|linux|linux-gnu|'`
- ;;
- -sunos5*)
- os=`echo $os | sed -e 's|sunos5|solaris2|'`
- ;;
- -sunos6*)
- os=`echo $os | sed -e 's|sunos6|solaris3|'`
- ;;
- -opened*)
- os=-openedition
- ;;
- -wince*)
- os=-wince
- ;;
- -osfrose*)
- os=-osfrose
- ;;
- -osf*)
- os=-osf
- ;;
- -utek*)
- os=-bsd
- ;;
- -dynix*)
- os=-bsd
- ;;
- -acis*)
- os=-aos
- ;;
- -386bsd)
- os=-bsd
- ;;
- -ctix* | -uts*)
- os=-sysv
- ;;
- -ns2 )
- os=-nextstep2
- ;;
- -nsk*)
- os=-nsk
- ;;
- # Preserve the version number of sinix5.
- -sinix5.*)
- os=`echo $os | sed -e 's|sinix|sysv|'`
- ;;
- -sinix*)
- os=-sysv4
- ;;
- -triton*)
- os=-sysv3
- ;;
- -oss*)
- os=-sysv3
- ;;
- -svr4)
- os=-sysv4
- ;;
- -svr3)
- os=-sysv3
- ;;
- -sysvr4)
- os=-sysv4
- ;;
- # This must come after -sysvr4.
- -sysv*)
- ;;
- -ose*)
- os=-ose
- ;;
- -es1800*)
- os=-ose
- ;;
- -xenix)
- os=-xenix
- ;;
- -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*)
- os=-mint
- ;;
- -none)
- ;;
- *)
- # Get rid of the `-' at the beginning of $os.
- os=`echo $os | sed 's/[^-]*-//'`
- echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2
- exit 1
- ;;
-esac
-else
-
-# Here we handle the default operating systems that come with various machines.
-# The value should be what the vendor currently ships out the door with their
-# machine or put another way, the most popular os provided with the machine.
-
-# Note that if you're going to try to match "-MANUFACTURER" here (say,
-# "-sun"), then you have to tell the case statement up towards the top
-# that MANUFACTURER isn't an operating system. Otherwise, code above
-# will signal an error saying that MANUFACTURER isn't an operating
-# system, and we'll never get to this point.
-
-case $basic_machine in
- *-acorn)
- os=-riscix1.2
- ;;
- arm*-rebel)
- os=-linux
- ;;
- arm*-semi)
- os=-aout
- ;;
- pdp10-*)
- os=-tops20
- ;;
- pdp11-*)
- os=-none
- ;;
- *-dec | vax-*)
- os=-ultrix4.2
- ;;
- m68*-apollo)
- os=-domain
- ;;
- i386-sun)
- os=-sunos4.0.2
- ;;
- m68000-sun)
- os=-sunos3
- # This also exists in the configure program, but was not the
- # default.
- # os=-sunos4
- ;;
- m68*-cisco)
- os=-aout
- ;;
- mips*-cisco)
- os=-elf
- ;;
- mips*-*)
- os=-elf
- ;;
- *-tti) # must be before sparc entry or we get the wrong os.
- os=-sysv3
- ;;
- sparc-* | *-sun)
- os=-sunos4.1.1
- ;;
- *-be)
- os=-beos
- ;;
- *-ibm)
- os=-aix
- ;;
- *-wec)
- os=-proelf
- ;;
- *-winbond)
- os=-proelf
- ;;
- *-oki)
- os=-proelf
- ;;
- *-hp)
- os=-hpux
- ;;
- *-hitachi)
- os=-hiux
- ;;
- i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent)
- os=-sysv
- ;;
- *-cbm)
- os=-amigaos
- ;;
- *-dg)
- os=-dgux
- ;;
- *-dolphin)
- os=-sysv3
- ;;
- m68k-ccur)
- os=-rtu
- ;;
- m88k-omron*)
- os=-luna
- ;;
- *-next )
- os=-nextstep
- ;;
- *-sequent)
- os=-ptx
- ;;
- *-crds)
- os=-unos
- ;;
- *-ns)
- os=-genix
- ;;
- i370-*)
- os=-mvs
- ;;
- *-next)
- os=-nextstep3
- ;;
- *-gould)
- os=-sysv
- ;;
- *-highlevel)
- os=-bsd
- ;;
- *-encore)
- os=-bsd
- ;;
- *-sgi)
- os=-irix
- ;;
- *-siemens)
- os=-sysv4
- ;;
- *-masscomp)
- os=-rtu
- ;;
- f30[01]-fujitsu | f700-fujitsu)
- os=-uxpv
- ;;
- *-rom68k)
- os=-coff
- ;;
- *-*bug)
- os=-coff
- ;;
- *-apple)
- os=-macos
- ;;
- *-atari*)
- os=-mint
- ;;
- *)
- os=-none
- ;;
-esac
-fi
-
-# Here we handle the case where we know the os, and the CPU type, but not the
-# manufacturer. We pick the logical manufacturer.
-vendor=unknown
-case $basic_machine in
- *-unknown)
- case $os in
- -riscix*)
- vendor=acorn
- ;;
- -sunos*)
- vendor=sun
- ;;
- -aix*)
- vendor=ibm
- ;;
- -beos*)
- vendor=be
- ;;
- -hpux*)
- vendor=hp
- ;;
- -mpeix*)
- vendor=hp
- ;;
- -hiux*)
- vendor=hitachi
- ;;
- -unos*)
- vendor=crds
- ;;
- -dgux*)
- vendor=dg
- ;;
- -luna*)
- vendor=omron
- ;;
- -genix*)
- vendor=ns
- ;;
- -mvs* | -opened*)
- vendor=ibm
- ;;
- -ptx*)
- vendor=sequent
- ;;
- -vxsim* | -vxworks*)
- vendor=wrs
- ;;
- -aux*)
- vendor=apple
- ;;
- -hms*)
- vendor=hitachi
- ;;
- -mpw* | -macos*)
- vendor=apple
- ;;
- -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*)
- vendor=atari
- ;;
- esac
- basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"`
- ;;
-esac
-
-echo $basic_machine$os
-exit 0
-
-# Local variables:
-# eval: (add-hook 'write-file-hooks 'time-stamp)
-# time-stamp-start: "timestamp='"
-# time-stamp-format: "%:y-%02m-%02d"
-# time-stamp-end: "'"
-# End:
diff --git a/config/m-MacOS.h b/config/m-MacOS.h
deleted file mode 100644
index ec3b65c41b..0000000000
--- a/config/m-MacOS.h
+++ /dev/null
@@ -1,33 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Moscova, INRIA Rocquencourt */
-/* */
-/* Copyright 2000 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#define ARCH_BIG_ENDIAN
-
-#define SIZEOF_INT 4
-#define SIZEOF_LONG 4
-#define SIZEOF_SHORT 2
-
-#if powerc
-#define ARCH_INT64_TYPE long long
-#define ARCH_UINT64_TYPE unsigned long long
-#define ARCH_INT64_PRINTF_FORMAT "ll"
-#endif
-
-#if powerc
-#define CPU_TYPE_STRING "PPC"
-#else
-#define CPU_TYPE_STRING "68k"
-#define THREADED_CODE
-#endif
diff --git a/config/m-nt.h b/config/m-nt.h
deleted file mode 100644
index 46e8817bd7..0000000000
--- a/config/m-nt.h
+++ /dev/null
@@ -1,34 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Machine configuration, Intel x86 processors, Win32,
- Visual C++ or Mingw compiler */
-
-#undef ARCH_SIXTYFOUR
-#undef ARCH_BIG_ENDIAN
-#undef ARCH_ALIGN_DOUBLE
-#define SIZEOF_INT 4
-#define SIZEOF_LONG 4
-#define SIZEOF_SHORT 2
-#ifdef __MINGW32__
-#define ARCH_INT64_TYPE long long
-#define ARCH_UINT64_TYPE unsigned long long
-#else
-#define ARCH_INT64_TYPE __int64
-#define ARCH_UINT64_TYPE unsigned __int64
-#endif
-#define ARCH_INT64_PRINTF_FORMAT "I64"
-#undef NONSTANDARD_DIV_MOD
-
diff --git a/config/m-templ.h b/config/m-templ.h
deleted file mode 100644
index fdfc0c8c85..0000000000
--- a/config/m-templ.h
+++ /dev/null
@@ -1,81 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Processor dependencies */
-
-#define ARCH_SIXTYFOUR
-
-/* Define ARCH_SIXTYFOUR if the processor has a natural word size of 64 bits.
- That is, both sizeof(long) = 8 and sizeof(char *) = 8.
- Otherwise, leave ARCH_SIXTYFOUR undefined. This assumes
- sizeof(long) = sizeof(char *) = 4. */
-
-#define ARCH_BIG_ENDIAN
-
-/* Define ARCH_BIG_ENDIAN if the processor is big endian (the most
- significant byte of an integer stored in memory comes first).
- Leave ARCH_BIG_ENDIAN undefined if the processor is little-endian
- (the least significant byte comes first).
-*/
-
-#define ARCH_ALIGN_DOUBLE
-
-/* Define ARCH_ALIGN_DOUBLE if the processor requires doubles to be
- doubleword-aligned. Leave ARCH_ALIGN_DOUBLE undefined if the processor
- supports word-aligned doubles. */
-
-#undef ARCH_CODE32
-
-/* Define ARCH_CODE32 if, on a 64-bit machine, code pointers fit in 32 bits,
- i.e. the code segment resides in the low 4G of the addressing space.
- ARCH_CODE32 is ignored on 32-bit machines. */
-
-#define SIZEOF_INT 4
-#define SIZEOF_LONG 4
-#define SIZEOF_SHORT 2
-
-/* Define SIZEOF_INT, SIZEOF_LONG and SIZEOF_SHORT to the sizes in byte
- of the C types "int", "long" and "short", respectively. */
-
-#define ARCH_INT64_TYPE long long
-#define ARCH_UINT64_TYPE unsigned long long
-
-/* Define ARCH_INT64_TYPE and ARCH_UINT64_TYPE to 64-bit integer types,
- typically "long long" and "unsigned long long" on 32-bit platforms,
- and "long" and "unsigned long" on 64-bit platforms.
- If the C compiler doesn't support any 64-bit integer type,
- leave both ARCH_INT64_TYPE and ARCH_UINT64_TYPE undefined. */
-
-#define ARCH_INT64_PRINTF_FORMAT "ll"
-
-/* Define ARCH_INT64_PRINTF_FORMAT to the printf format used for formatting
- values of type ARCH_INT64_TYPE. This is usually "ll" on 32-bit
- platforms and "l" on 64-bit platforms.
- Leave undefined if ARCH_INT64_TYPE is undefined. */
-
-#define ARCH_ALIGN_INT64
-
-/* Define ARCH_ALIGN_INT64 if the processor requires 64-bit integers to be
- doubleword-aligned. Leave ARCH_ALIGN_INT64 undefined if the processor
- supports word-aligned 64-bit integers. Leave undefined if
- 64-bit integers are not supported. */
-
-#undef NONSTANDARD_DIV_MOD
-
-/* Leave NONSTANDARD_DIV_MOD undefined if the C operators / and % implement
- round-towards-zero semantics, as specified by ISO C 9x and implemented
- by most contemporary processors. Otherwise, or if you don't know,
- define NONSTANDARD_DIV_MOD: this will select a slower but correct
- software emulation of division and modulus. */
diff --git a/config/s-MacOS.h b/config/s-MacOS.h
deleted file mode 100644
index 0138ced95b..0000000000
--- a/config/s-MacOS.h
+++ /dev/null
@@ -1,20 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Moscova, INRIA Rocquencourt */
-/* */
-/* Copyright 2000 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#define OCAML_OS_TYPE "MacOS"
-#define HAS_STRERROR
-#define HAS_GETCWD
-
-#define HAS_UI
diff --git a/config/s-nt.h b/config/s-nt.h
deleted file mode 100644
index 5eaf3770f4..0000000000
--- a/config/s-nt.h
+++ /dev/null
@@ -1,29 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Operating system dependencies, Intel x86 processors, Windows NT */
-
-#define OCAML_OS_TYPE "Win32"
-
-#undef BSD_SIGNALS
-#define HAS_STRERROR
-#define HAS_SOCKETS
-#define HAS_GETCWD
-#define HAS_UTIME
-#define HAS_DUP2
-#define HAS_GETHOSTNAME
-#define HAS_MKTIME
-#define HAS_PUTENV
-#define HAS_LOCALE
diff --git a/config/s-templ.h b/config/s-templ.h
deleted file mode 100644
index 8411ce41c9..0000000000
--- a/config/s-templ.h
+++ /dev/null
@@ -1,207 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Operating system and standard library dependencies. */
-
-/* 0. Operating system type string. */
-
-#define OCAML_OS_TYPE "Unix"
-/* #define OCAML_OS_TYPE "Win32" */
-/* #define OCAML_OS_TYPE "MacOS" */
-
-/* 1. For the runtime system. */
-
-#define POSIX_SIGNALS
-
-/* Define POSIX_SIGNALS if signal handling is POSIX-compliant.
- In particular, sigaction(), sigprocmask() and the operations on
- sigset_t are provided. */
-
-#define BSD_SIGNALS
-
-/* Define BSD_SIGNALS if signal handlers have the BSD semantics: the handler
- remains attached to the signal when the signal is received. Leave it
- undefined if signal handlers have the System V semantics: the signal
- resets the behavior to default. */
-
-#define HAS_SIGSETMASK
-
-/* Define HAS_SIGSETMASK if you have sigsetmask(), as in BSD. */
-
-#define HAS_TERMCAP
-
-/* Define HAS_TERMCAP if you have the termcap functions to read the
- terminal database, e.g. tgetent(), tgetstr(), tgetnum(), tputs().
- Also add the required libraries (e.g. -lcurses -ltermcap) to $(CCLIBS)
- in ../Makefile.config */
-
-#define HAS_STRERROR
-
-/* Define HAS_STRERROR if you have strerror(). */
-
-#define SUPPORT_DYNAMIC_LINKING
-
-/* Define SUPPORT_DYNAMIC_LINKING if dynamic loading of C stub code
- via dlopen() is available. */
-
-/* 2. For the Unix library. */
-
-#define HAS_SOCKETS
-
-/* Define HAS_SOCKETS if you have BSD sockets. */
-
-#define HAS_SOCKLEN_T
-
-/* Define HAS_SOCKLEN_T if the type socklen_t is defined in
- /usr/include/sys/socket.h. */
-
-#define HAS_UNISTD
-
-/* Define HAS_UNISTD if you have /usr/include/unistd.h. */
-
-#define HAS_DIRENT
-
-/* Define HAS_DIRENT if you have /usr/include/dirent.h and the result of
- readdir() is of type struct dirent *.
- Otherwise, we'll load /usr/include/sys/dir.h, and readdir() is expected to
- return a struct direct *. */
-
-#define HAS_REWINDDIR
-
-/* Define HAS_REWINDDIR if you have rewinddir(). */
-
-#define HAS_LOCKF
-
-/* Define HAS_LOCKF if the library provides the lockf() function. */
-
-#define HAS_MKFIFO
-
-/* Define HAS_MKFIFO if the library provides the mkfifo() function. */
-
-#define HAS_GETCWD
-#define HAS_GETWD
-
-/* Define HAS_GETCWD if the library provides the getcwd() function. */
-/* Define HAS_GETWD if the library provides the getwd() function. */
-
-#define HAS_GETPRIORITY
-
-/* Define HAS_GETPRIORITY if the library provides getpriority() and
- setpriority(). Otherwise, we'll use nice(). */
-
-#define HAS_UTIME
-#define HAS_UTIMES
-
-/* Define HAS_UTIME if you have /usr/include/utime.h and the library
- provides utime(). Define HAS_UTIMES if the library provides utimes(). */
-
-#define HAS_DUP2
-
-/* Define HAS_DUP2 if you have dup2(). */
-
-#define HAS_FCHMOD
-
-/* Define HAS_FCHMOD if you have fchmod() and fchown(). */
-
-#define HAS_TRUNCATE
-
-/* Define HAS_TRUNCATE if you have truncate() and
- ftruncate(). */
-
-#define HAS_SELECT
-
-/* Define HAS_SELECT if you have select(). */
-
-#define HAS_SYS_SELECT_H
-
-/* Define HAS_SYS_SELECT_H if /usr/include/sys/select.h exists
- and should be included before using select(). */
-
-#define HAS_SYMLINK
-
-/* Define HAS_SYMLINK if you have symlink() and readlink() and lstat(). */
-
-#define HAS_WAIT4
-#define HAS_WAITPID
-
-/* Define HAS_WAIT4 if you have wait4().
- Define HAS_WAITPID if you have waitpid(). */
-
-#define HAS_GETGROUPS
-
-/* Define HAS_GETGROUPS if you have getgroups(). */
-
-#define HAS_TERMIOS
-
-/* Define HAS_TERMIOS if you have /usr/include/termios.h and it is
- Posix-compliant. */
-
-#define HAS_ASYNC_IO
-
-/* Define HAS_ASYNC_IO if BSD-style asynchronous I/O are supported
- (the process can request to be sent a SIGIO signal when a descriptor
- is ready for reading). */
-
-#define HAS_SETITIMER
-
-/* Define HAS_SETITIMER if you have setitimer(). */
-
-#define HAS_GETHOSTNAME
-
-/* Define HAS_GETHOSTNAME if you have gethostname(). */
-
-#define HAS_UNAME
-
-/* Define HAS_UNAME if you have uname(). */
-
-#define HAS_GETTIMEOFDAY
-
-/* Define HAS_GETTIMEOFDAY if you have gettimeofday(). */
-
-#define HAS_MKTIME
-
-/* Define HAS_MKTIME if you have mktime(). */
-
-#define HAS_SETSID
-
-/* Define HAS_SETSID if you have setsid(). */
-
-#define HAS_PUTENV
-
-/* Define HAS_PUTENV if you have putenv(). */
-
-#define HAS_LOCALE
-
-/* Define HAS_LOCALE if you have the include file <locale.h> and the
- setlocale() function. */
-
-#define HAS_MMAP
-
-/* Define HAS_MMAP if you have the include file <sys/mman.h> and the
- functions mmap() and munmap(). */
-
-#define HAS_GETHOSTBYNAME_R 6
-
-/* Define HAS_GETHOSTBYNAME_R if gethostbyname_r() is available.
- The value of this symbol is the number of arguments of
- gethostbyname_r(): either 5 or 6 depending on prototype.
- (5 is the Solaris version, 6 is the Linux version). */
-
-#define HAS_GETHOSTBYADDR_R 8
-
-/* Define HAS_GETHOSTBYADDR_R if gethostbyname_r() is available.
- The value of this symbol is the number of arguments of
- gethostbyaddr_r(): either 7 or 8 depending on prototype.
- (7 is the Solaris version, 8 is the Linux version). */
diff --git a/configure b/configure
deleted file mode 100755
index 8380147c4e..0000000000
--- a/configure
+++ /dev/null
@@ -1,1533 +0,0 @@
-#! /bin/sh
-
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-configure_options="$*"
-prefix=/usr/local
-bindir=''
-libdir=''
-mandir=''
-manext=1
-host_type=unknown
-ccoption=''
-cclibs=''
-curseslibs=''
-mathlib='-lm'
-dllib=''
-x11_include_dir=''
-x11_lib_dir=''
-tk_wanted=yes
-pthread_wanted=yes
-tk_defs=''
-tk_libs=''
-tk_x11=yes
-dl_defs=''
-verbose=no
-withcurses=yes
-withsharedlibs=yes
-binutils_dir=''
-gcc_warnings="-Wall -Wno-unused"
-
-# Try to turn internationalization off, can cause config.guess to malfunction!
-unset LANG
-unset LC_ALL LC_CTYPE LC_COLLATE LC_MESSAGES LC_MONETARY LC_NUMERIC LC_TIME
-
-# Turn off some MacOS X debugging stuff, same reason
-unset RC_TRACE_ARCHIVES RC_TRACE_DYLIBS RC_TRACE_PREBINDING_DISABLED
-
-# Parse command-line arguments
-
-while : ; do
- case "$1" in
- "") break;;
- -prefix|--prefix)
- prefix=$2; shift;;
- -bindir|--bindir)
- bindir=$2; shift;;
- -libdir|--libdir)
- libdir=$2; shift;;
- -mandir|--mandir)
- case "$2" in
- */man[1-9ln])
- mandir=`echo $2 | sed -e 's|^\(.*\)/man.$|\1|'`
- manext=`echo $2 | sed -e 's/^.*\(.\)$/\1/'`;;
- *)
- mandir=$2
- manext=1;;
- esac
- shift;;
- -host*|--host*)
- host_type=$2; shift;;
- -cc*)
- ccoption="$2"; shift;;
- -lib*)
- cclibs="$2 $cclibs"; shift;;
- -no-curses)
- withcurses=no;;
- -no-shared-libs)
- withsharedlibs=no;;
- -x11include*|--x11include*)
- x11_include_dir=$2; shift;;
- -x11lib*|--x11lib*)
- x11_lib_dir=$2; shift;;
- -with-pthread*|--with-pthread*)
- ;; # Ignored for backward compatibility
- -no-pthread*|--no-pthread*)
- pthread_wanted=no;;
- -no-tk|--no-tk)
- tk_wanted=no;;
- -tkdefs*|--tkdefs*)
- tk_defs=$2; shift;;
- -tklibs*|--tklibs*)
- tk_libs=$2; shift;;
- -tk-no-x11|--tk-no-x11)
- tk_x11=no;;
- -dldefs*|--dldefs*)
- dl_defs="$2"; shift;;
- -dllibs*|--dllibs*)
- dllib="$2"; shift;;
- -binutils*|--binutils*)
- binutils_dir=$2; shift;;
- -verbose|--verbose)
- verbose=yes;;
- *) echo "Unknown option \"$1\"." 1>&2; exit 2;;
- esac
- shift
-done
-
-# Sanity checks
-
-case "$prefix" in
- /*) ;;
- *) echo "The -prefix directory must be absolute." 1>&2; exit 2;;
-esac
-case "$bindir" in
- /*) ;;
- "") ;;
- *) echo "The -bindir directory must be absolute." 1>&2; exit 2;;
-esac
-case "$libdir" in
- /*) ;;
- "") ;;
- *) echo "The -libdir directory must be absolute." 1>&2; exit 2;;
-esac
-case "$mandir" in
- /*) ;;
- "") ;;
- *) echo "The -mandir directory must be absolute." 1>&2; exit 2;;
-esac
-
-# Generate the files
-
-cd config/auto-aux
-rm -f s.h m.h Makefile
-touch s.h m.h Makefile
-
-# Write options to Makefile
-
-echo "# generated by ./configure $configure_options" >> Makefile
-
-# Where to install
-
-echo "PREFIX=$prefix" >> Makefile
-case "$bindir" in
- "") echo 'BINDIR=$(PREFIX)/bin' >> Makefile
- bindir="$prefix/bin";;
- *) echo "BINDIR=$bindir" >> Makefile;;
-esac
-case "$libdir" in
- "") echo 'LIBDIR=$(PREFIX)/lib/ocaml' >> Makefile
- libdir="$prefix/lib/ocaml";;
- *) echo "LIBDIR=$libdir" >> Makefile;;
-esac
-echo 'STUBLIBDIR=$(LIBDIR)/stublibs' >> Makefile
-case "$mandir" in
- "") echo 'MANDIR=$(PREFIX)/man' >> Makefile
- mandir="$prefix/man";;
- *) echo "MANDIR=$mandir" >> Makefile;;
-esac
-echo "MANEXT=$manext" >> Makefile
-
-# Determine the system type
-
-if test "$host_type" = "unknown"; then
- if host_type=`../gnu/config.guess`; then :; else
- echo "Cannot guess host type"
- echo "You must specify one with the -host option"
- exit 2
- fi
-fi
-if host=`../gnu/config.sub $host_type`; then :; else
- echo "Please specify the correct host type with the -host option"
- exit 2
-fi
-echo "Configuring for a $host ..."
-
-# Do we have gcc?
-
-if test -z "$ccoption"; then
- if sh ./searchpath gcc; then
- echo "gcc found"
- cc=gcc
- else
- cc=cc
- fi
-else
- cc="$ccoption"
-fi
-
-# Check for buggy versions of GCC
-
-buggycc="no"
-
-case "$host,$cc" in
- i[3456]86-*-*,gcc*)
- case `$cc --version` in
- 2.7.2.1) cat <<'EOF'
-
-WARNING: you are using gcc version 2.7.2.1 on an Intel x86 processor.
-This version of gcc is known to generate incorrect code for the
-Objective Caml runtime system on some Intel x86 machines. (The symptom
-is a crash of boot/ocamlc when compiling stdlib/pervasives.mli.)
-In particular, the version of gcc 2.7.2.1 that comes with
-Linux RedHat 4.x / Intel is affected by this problem.
-Other Linux distributions might also be affected.
-If you are using one of these configurations, you are strongly advised
-to use another version of gcc, such as 2.95, which are
-known to work well with Objective Caml.
-
-Press <enter> to proceed or <interrupt> to stop.
-EOF
- read reply;;
- 2.96*) cat <<'EOF'
-
-WARNING: you are using gcc version 2.96 on an Intel x86 processor.
-Certain patched versions of gcc 2.96 are known to generate incorrect
-code for the Objective Caml runtime system. (The symptom is a segmentation
-violation on boot/ocamlc.) Those incorrectly patched versions can be found
-in RedHat 7.2 and Mandrake 8.0 and 8.1; other Linux distributions
-might also be affected. (See bug #57760 on bugzilla.redhat.com)
-
-Auto-configuration will now select gcc compiler flags that work around
-the problem. Still, if you observe segmentation faults while running
-ocamlc or ocamlopt, you are advised to try another version of gcc,
-such as 2.95.3 or 3.2.
-
-EOF
- buggycc="gcc.2.96";;
-
- esac;;
-esac
-
-# Configure the bytecode compiler
-
-bytecc="$cc"
-bytecccompopts=""
-bytecclinkopts=""
-ostype="Unix"
-exe=""
-
-case "$bytecc,$host" in
- cc,*-*-nextstep*)
- # GNU C extensions disabled, but __GNUC__ still defined!
- bytecccompopts="-fno-defer-pop $gcc_warnings -U__GNUC__ -posix"
- bytecclinkopts="-posix";;
- *,*-*-rhapsody*)
- # Almost the same as NeXTStep
- bytecccompopts="-fno-defer-pop $gcc_warnings -DSHRINKED_GNUC"
- mathlib="";;
- *,*-*-darwin*)
- # Almost the same as rhapsody
- bytecccompopts="-fno-defer-pop -no-cpp-precomp $gcc_warnings"
- mathlib="";;
- *,*-*-beos*)
- bytecccompopts="-fno-defer-pop $gcc_warnings"
- # No -lm library
- mathlib="";;
- gcc,alpha*-*-osf*)
- bytecccompopts="-fno-defer-pop $gcc_warnings"
- if cc="$bytecc" sh ./hasgot -mieee; then
- bytecccompopts="-mieee $bytecccompopts";
- fi
- # Put code and static data in lower 4GB
- bytecclinkopts="-Wl,-T,12000000 -Wl,-D,14000000"
- # Tell gcc that we can use 32-bit code addresses for threaded code
- echo "#define ARCH_CODE32" >> m.h;;
- cc,alpha*-*-osf*)
- bytecccompopts="-std1 -ieee";;
- gcc,alpha*-*-linux*)
- if cc="$bytecc" sh ./hasgot -mieee; then
- bytecccompopts="-mieee $bytecccompopts";
- fi;;
- cc,mips-*-irix6*)
- # Add -n32 flag to ensure compatibility with native-code compiler
- bytecccompopts="-n32"
- # Turn off warning "unused library"
- bytecclinkopts="-n32 -Wl,-woff,84";;
- cc*,mips-*-irix6*)
- # (For those who want to force "cc -64")
- # Turn off warning "unused library"
- bytecclinkopts="-Wl,-woff,84";;
- *,alpha*-*-unicos*)
- # For the Cray T3E
- bytecccompopts="-DUMK";;
- gcc*,powerpc-*-aix4.3*)
- # Avoid name-space pollution by requiring Unix98-conformant includes
- bytecccompopts="-fno-defer-pop $gcc_warnings -D_XOPEN_SOURCE=500";;
- *,powerpc-*-aix4.3*)
- bytecccompopts="-D_XOPEN_SOURCE=500";;
- gcc*,*-*-cygwin*)
- bytecccompopts="-fno-defer-pop $gcc_warnings -U_WIN32"
- exe=".exe"
- ostype="Cygwin";;
- gcc*,x86_64-*-linux*)
- bytecccompopts="-fno-defer-pop $gcc_warnings"
- # Tell gcc that we can use 32-bit code addresses for threaded code
- echo "#define ARCH_CODE32" >> m.h;;
- gcc*)
- bytecccompopts="-fno-defer-pop $gcc_warnings";;
-esac
-
-# Configure compiler to use in further tests
-
-cc="$bytecc -O $bytecclinkopts"
-export cc cclibs verbose
-
-# Check C compiler
-
-sh ./runtest ansi.c
-case $? in
- 0) echo "The C compiler is ANSI-compliant.";;
- 1) echo "The C compiler $cc is not ANSI-compliant."
- echo "You need an ANSI C compiler to build Objective Caml."
- exit 2;;
- *) echo "Unable to compile the test program."
- echo "Make sure the C compiler $cc is properly installed."
- exit 2;;
-esac
-
-# Check the sizes of data types
-
-echo "Checking the sizes of integers and pointers..."
-set `sh ./runtest sizes.c`
-case "$2,$3" in
- 4,4) echo "OK, this is a regular 32 bit architecture."
- echo "#undef ARCH_SIXTYFOUR" >> m.h;;
- 8,8) echo "Wow! A 64 bit architecture!"
- echo "#define ARCH_SIXTYFOUR" >> m.h;;
- *,8) echo "Wow! A 64 bit architecture!"
- echo "Unfortunately, Objective Caml cannot work in the case"
- echo "sizeof(long) != sizeof(long *)."
- echo "Objective Caml won't run on this architecture."
- exit 2;;
- *,*) echo "This architecture seems to be neither 32 bits nor 64 bits."
- echo "Objective Caml won't run on this architecture."
- exit 2;;
- *) echo "Unable to compile the test program."
- echo "Make sure the C compiler $cc is properly installed."
- exit 2;;
-esac
-if test $1 != 4 && test $2 != 4 && test $4 != 4; then
- echo "Sorry, we can't find a 32-bit integer type"
- echo "(sizeof(short) = $4, sizeof(int) = $1, sizeof(long) = $2)"
- echo "Objective Caml won't run on this architecture."
- exit 2
-fi
-
-echo "#define SIZEOF_INT $1" >> m.h
-echo "#define SIZEOF_LONG $2" >> m.h
-echo "#define SIZEOF_SHORT $4" >> m.h
-
-if test $2 = 8; then
- echo "#define ARCH_INT64_TYPE long" >> m.h
- echo "#define ARCH_UINT64_TYPE unsigned long" >> m.h
- echo '#define ARCH_INT64_PRINTF_FORMAT "l"' >> m.h
- int64_native=true
-else
- sh ./runtest longlong.c
- case $? in
- 0) echo "64-bit \"long long\" integer type found (printf with \"%ll\")."
- echo "#define ARCH_INT64_TYPE long long" >> m.h
- echo "#define ARCH_UINT64_TYPE unsigned long long" >> m.h
- echo '#define ARCH_INT64_PRINTF_FORMAT "ll"' >> m.h
- int64_native=true;;
- 1) echo "64-bit \"long long\" integer type found (printf with \"%q\")."
- echo "#define ARCH_INT64_TYPE long long" >> m.h
- echo "#define ARCH_UINT64_TYPE unsigned long long" >> m.h
- echo '#define ARCH_INT64_PRINTF_FORMAT "q"' >> m.h
- int64_native=true;;
- 2) echo "64-bit \"long long\" integer type found (but no printf)."
- echo "#define ARCH_INT64_TYPE long long" >> m.h
- echo "#define ARCH_UINT64_TYPE unsigned long long" >> m.h
- echo '#undef ARCH_INT64_PRINTF_FORMAT' >> m.h
- int64_native=true;;
- *) echo "No suitable 64-bit integer type found, will use software emulation."
- echo "#undef ARCH_INT64_TYPE" >> m.h
- echo "#undef ARCH_UINT64_TYPE" >> m.h
- echo '#undef ARCH_INT64_PRINTF_FORMAT' >> m.h
- int64_native=false;;
- esac
-fi
-
-# Determine endianness
-
-sh ./runtest endian.c
-case $? in
- 0) echo "This is a big-endian architecture."
- echo "#define ARCH_BIG_ENDIAN" >> m.h;;
- 1) echo "This is a little-endian architecture."
- echo "#undef ARCH_BIG_ENDIAN" >> m.h;;
- 2) echo "This architecture seems to be neither big endian nor little endian."
- echo "Objective Caml won't run on this architecture."
- exit 2;;
- *) echo "Something went wrong during endianness determination."
- echo "You'll have to figure out endianness yourself"
- echo "(option ARCH_BIG_ENDIAN in m.h).";;
-esac
-
-# Determine alignment constraints
-
-case "$host" in
- sparc-*-*|hppa*-*-*)
- # On Sparc V9 with certain versions of gcc, determination of double
- # alignment is not reliable (PR#1521), hence force it.
- # Same goes for hppa.
- echo "Doubles must be doubleword-aligned."
- echo "#define ARCH_ALIGN_DOUBLE" >> m.h;;
- *)
- sh ./runtest dblalign.c
- case $? in
- 0) echo "Doubles can be word-aligned."
- echo "#undef ARCH_ALIGN_DOUBLE" >> m.h;;
- 1) echo "Doubles must be doubleword-aligned."
- echo "#define ARCH_ALIGN_DOUBLE" >> m.h;;
- *) echo "Something went wrong during alignment determination for doubles."
- echo "I'm going to assume this architecture has alignment constraints over doubles."
- echo "That's a safe bet: Objective Caml will work even if"
- echo "this architecture has actually no alignment constraints."
- echo "#define ARCH_ALIGN_DOUBLE" >> m.h;;
- esac;;
-esac
-
-if $int64_native; then
- sh ./runtest int64align.c
- case $? in
- 0) echo "64-bit integers can be word-aligned."
- echo "#undef ARCH_ALIGN_INT64" >> m.h;;
- 1) echo "64-bit integers must be doubleword-aligned."
- echo "#define ARCH_ALIGN_INT64" >> m.h;;
- *) echo "Something went wrong during alignment determination for 64-bit integers."
- echo "I'm going to assume this architecture has alignment constraints."
- echo "That's a safe bet: Objective Caml will work even if"
- echo "this architecture has actually no alignment constraints."
- echo "#define ARCH_ALIGN_INT64" >> m.h;;
- esac
-else
- echo "#undef ARCH_ALIGN_INT64" >> m.h
-fi
-
-# Check semantics of division and modulus
-
-sh ./runtest divmod.c
-case $? in
- 0) echo "Native division and modulus have round-towards-zero semantics, will use them."
- echo "#undef NONSTANDARD_DIV_MOD" >> m.h;;
- 1) echo "Native division and modulus do not have round-towards-zero semantics, will use software emulation."
- echo "#define NONSTANDARD_DIV_MOD" >> m.h;;
- *) echo "Something went wrong while checking native division and modulus, please report it."
- echo "#define NONSTANDARD_DIV_MOD" >> m.h;;
-esac
-
-# Shared library support
-
-shared_libraries_supported=false
-dl_needs_underscore=false
-sharedcccompopts=''
-mksharedlib=''
-byteccrpath=''
-mksharedlibrpath=''
-
-if test $withsharedlibs = "yes"; then
- case "$host" in
- *-*-linux-gnu|*-*-linux|*-*-freebsd[3-9]*)
- sharedcccompopts="-fPIC"
- mksharedlib="$bytecc -shared -o"
- bytecclinkopts="$bytecclinkopts -Wl,-E"
- byteccrpath="-Wl,-rpath,"
- mksharedlibrpath="-Wl,-rpath,"
- shared_libraries_supported=true;;
- alpha*-*-osf*)
- case "$bytecc" in
- cc*) sharedcccompopts="";;
- gcc*) sharedcccompopts="-fPIC";;
- esac
- mksharedlib="ld -shared -expect_unresolved '*' -o"
- byteccrpath="-Wl,-rpath,"
- mksharedlibrpath="-rpath "
- shared_libraries_supported=true;;
- *-*-solaris2*)
- case "$bytecc" in
- gcc*)
- sharedcccompopts="-fPIC"
- if sh ./solaris-ld; then
- mksharedlib="$bytecc -shared -o"
- byteccrpath="-R"
- mksharedlibrpath="-R"
- else
- mksharedlib="$bytecc -shared -o"
- bytecclinkopts="$bytecclinkopts -Wl,-E"
- byteccrpath="-Wl,-rpath,"
- mksharedlibrpath="-Wl,-rpath,"
- fi
- shared_libraries_supported=true;;
- *)
- sharedcccompopts="-KPIC"
- byteccrpath="-R"
- mksharedlibrpath="-R"
- mksharedlib="/usr/ccs/bin/ld -G -o"
- shared_libraries_supported=true;;
- esac;;
- mips*-*-irix[56]*)
- case "$bytecc" in
- cc*) sharedcccompopts="";;
- gcc*) sharedcccompopts="-fPIC";;
- esac
- mksharedlib="ld -shared -rdata_shared -o"
- byteccrpath="-Wl,-rpath,"
- mksharedlibrpath="-rpath "
- shared_libraries_supported=true;;
- powerpc-apple-darwin*)
- mksharedlib="cc -bundle -flat_namespace -undefined suppress -o"
- bytecccompopts="$dl_defs $bytecccompopts"
- #sharedcccompopts="-fnocommon"
- dl_needs_underscore=true
- shared_libraries_supported=true;;
- esac
-fi
-
-# Further machine-specific hacks
-
-case "$host" in
- ia64-*-linux*|alpha*-*-linux*|x86_64-*-linux*)
- echo "Will use mmap() instead of malloc() for allocation of major heap chunks."
- echo "#define USE_MMAP_INSTEAD_OF_MALLOC" >> s.h;;
-esac
-
-# Configure the native-code compiler
-
-arch=none
-model=default
-system=unknown
-
-case "$host" in
- alpha*-*-osf*) arch=alpha; system=digital;;
- alpha*-*-linux*) arch=alpha; system=linux;;
- alpha*-*-freebsd*) arch=alpha; system=freebsd;;
- alpha*-*-netbsd*) arch=alpha; system=netbsd;;
- alpha*-*-openbsd*) arch=alpha; system=openbsd;;
- sparc*-*-sunos4.*) arch=sparc; system=sunos;;
- sparc*-*-solaris2.*) arch=sparc; system=solaris;;
- sparc*-*-*bsd*) arch=sparc; system=bsd;;
- sparc*-*-linux*) arch=sparc; system=linux;;
- i[3456]86-*-linux*) arch=i386; system=linux_`sh ./runtest elf.c`;;
- i[3456]86-*-*bsd*) arch=i386; system=bsd_`sh ./runtest elf.c`;;
- i[3456]86-*-nextstep*) arch=i386; system=nextstep;;
- i[3456]86-*-solaris*) arch=i386; system=solaris;;
- i[3456]86-*-beos*) arch=i386; system=beos;;
- i[3456]86-*-cygwin*) arch=i386; system=cygwin;;
- mips-*-irix6*) arch=mips; system=irix;;
- hppa1.1-*-hpux*) arch=hppa; system=hpux;;
- hppa2.0*-*-hpux*) arch=hppa; system=hpux;;
- hppa1.1-*-nextstep*) arch=hppa; system=nextstep;;
- rs6000-*-aix*) arch=power; model=rs6000; system=aix;;
- powerpc-*-aix*) arch=power; model=ppc; system=aix;;
- powerpc-*-linux*) arch=power; model=ppc; system=elf;;
- powerpc-*-netbsd*) arch=power; model=ppc; system=bsd;;
- powerpc-*-rhapsody*) arch=power; model=ppc; system=rhapsody;;
- powerpc-*-darwin*) arch=power; model=ppc; system=rhapsody;;
- arm*-*-linux*) arch=arm; system=linux;;
- ia64-*-linux*) arch=ia64; system=linux;;
- x86_64-*-linux*) arch=amd64; system=linux;;
-esac
-
-if test -z "$ccoption"; then
- case "$arch,$system,$cc" in
- alpha,digital,gcc*) nativecc=cc;;
- mips,*,gcc*) nativecc=cc;;
- *) nativecc="$bytecc";;
- esac
-else
- nativecc="$ccoption"
-fi
-
-nativecccompopts=''
-nativecclinkopts=''
-nativeccrpath="$byteccrpath"
-
-case "$arch,$nativecc,$system,$host_type" in
- alpha,cc*,digital,*) nativecccompopts=-std1;;
- mips,cc*,irix,*) nativecccompopts=-n32
- nativecclinkopts="-n32 -Wl,-woff,84";;
- power,gcc*,aix,*aix4.3*)
- nativecccompopts="$gcc_warnings -D_XOPEN_SOURCE=500";;
- power,*,aix,*aix4.3*)
- nativecccompopts="-D_XOPEN_SOURCE=500";;
- *,*,nextstep,*) nativecccompopts="$gcc_warnings -U__GNUC__ -posix"
- nativecclinkopts="-posix";;
- *,*,rhapsody,*darwin6*)
- nativecccompopts="$gcc_warnings -DDARWIN_VERSION_6 $dl_defs";;
- *,*,rhapsody,*) nativecccompopts="$gcc_warnings -DSHRINKED_GNUC";;
- *,gcc*,cygwin,*) nativecccompopts="$gcc_warnings -U_WIN32";;
- *,gcc*,*,*) nativecccompopts="$gcc_warnings";;
-esac
-
-asflags=''
-aspp='$(AS)'
-asppflags=''
-asppprofflags='-DPROFILING'
-
-case "$arch,$model,$system" in
- alpha,*,digital) asflags='-O2'; asppflags='-O2 -DSYS_$(SYSTEM)';
- asppprofflags='-pg -DPROFILING';;
- alpha,*,linux) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
- alpha,*,freebsd) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
- alpha,*,netbsd) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
- alpha,*,openbsd) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
- mips,*,irix) asflags='-n32 -O2'; asppflags="$asflags";;
- sparc,*,bsd) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
- sparc,*,linux) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
- sparc,*,*) case "$cc" in
- gcc*) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
- *) asppflags='-P -DSYS_$(SYSTEM)';;
- esac;;
- i386,*,solaris) aspp='/usr/ccs/bin/as'; asppflags='-P -DSYS_$(SYSTEM)';;
- i386,*,*) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
- hppa,*,*) aspp="$cc"; asppflags='-traditional -c -DSYS_$(SYSTEM)';;
- power,rs6000,aix) asflags='-u -m pwr -w'; asppflags="$asflags";;
- power,ppc,aix) asflags='-u -m ppc -w'; asppflags="$asflags";;
- power,*,elf) aspp='gcc'; asppflags='-c';;
- power,*,bsd) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
- power,*,rhapsody) ;;
- arm,*,linux) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
- ia64,*,linux) asflags=-xexplicit
- aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM) -Wa,-xexplicit';;
- amd64,*,*) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
-esac
-
-cc_profile='-pg'
-case "$arch,$model,$system" in
- alpha,*,digital) profiling='prof';;
- i386,*,linux_elf) profiling='prof';;
- i386,*,bsd_elf) profiling='prof';;
- sparc,*,solaris)
- profiling='prof'
- case "$nativecc" in gcc*) ;; *) cc_profile='-xpg';; esac;;
- *) profiling='noprof';;
-esac
-
-# Where are GNU binutils?
-
-binutils_objcopy=''
-binutils_nm=''
-
-if test "$arch" != "none"; then
- binutils_path="${binutils_dir}:${PATH}:/usr/libexec/binutils"
- old_IFS="$IFS"
- IFS=':'
- for d in ${binutils_path}; do
- if test -z "$d"; then continue; fi
- if test -f "$d/objcopy" && test -f "$d/nm"; then
- echo "objcopy and nm found in $d"
- if test `$d/objcopy --help | grep -s -c 'redefine-sym'` -eq 0; then
- echo "$d/objcopy does not support option --redefine-sym, discarded"
- continue;
- fi
- if test `$d/nm --version | grep -s -c 'GNU nm'` -eq 0; then
- echo "$d/nm is not from GNU binutils, discarded"
- continue;
- fi
- binutils_objcopy="$d/objcopy"
- binutils_nm="$d/nm"
- break
- fi
- done
- IFS="$old_IFS"
-fi
-
-# Where is ranlib?
-
-if sh ./searchpath ranlib; then
- echo "ranlib found"
- echo "RANLIB=ranlib" >> Makefile
- echo "RANLIBCMD=ranlib" >> Makefile
-else
- echo "ranlib not used"
- echo "RANLIB=ar rs" >> Makefile
- echo "RANLIBCMD=" >> Makefile
-fi
-
-# Do #! scripts work?
-
-if (SHELL=/bin/sh; export SHELL; (./sharpbang || ./sharpbang2) >/dev/null); then
- echo "#! appears to work in shell scripts"
- case "$host" in
- *-*-sunos*|*-*-unicos*)
- echo "We won't use it, though, because under SunOS and Unicos it breaks"
- echo "on pathnames longer than 30 characters"
- echo "SHARPBANGSCRIPTS=false" >> Makefile;;
- *-*-cygwin*)
- echo "We won't use it, though, because of conflicts with .exe extension"
- echo "under Cygwin"
- echo "SHARPBANGSCRIPTS=false" >> Makefile;;
- *)
- echo "SHARPBANGSCRIPTS=true" >> Makefile;;
- esac
-else
- echo "No support for #! in shell scripts"
- echo "SHARPBANGSCRIPTS=false" >> Makefile
-fi
-
-# Write the OS type (Unix or Cygwin)
-
-echo "#define OCAML_OS_TYPE \"$ostype\"" >> s.h
-echo "#define OCAML_STDLIB_DIR \"$libdir\"" >> s.h
-
-# Use 64-bit file offset if possible
-
-bytecccompopts="$bytecccompopts -D_FILE_OFFSET_BITS=64"
-nativecccompopts="$nativecccompopts -D_FILE_OFFSET_BITS=64"
-
-# Check the semantics of signal handlers
-
-if sh ./hasgot sigaction sigprocmask; then
- echo "POSIX signal handling found."
- echo "#define POSIX_SIGNALS" >> s.h
-else
- if sh ./runtest signals.c; then
- echo "Signals have the BSD semantics."
- echo "#define BSD_SIGNALS" >> s.h
- else
- echo "Signals have the System V semantics."
- fi
- if sh ./hasgot sigsetmask; then
- echo "sigsetmask() found"
- echo "#define HAS_SIGSETMASK" >> s.h
- fi
-fi
-
-# For the sys module
-
-if sh ./hasgot strerror; then
- echo "strerror() found."
- echo "#define HAS_STRERROR" >> s.h
-fi
-
-if sh ./hasgot times; then
- echo "times() found."
- echo "#define HAS_TIMES" >> s.h
-fi
-
-# For the terminfo module
-
-if test "$withcurses" = "yes"; then
- for libs in "" "-lcurses" "-ltermcap" "-lcurses -ltermcap" "-lncurses"; do
- if sh ./hasgot $libs tgetent tgetstr tgetnum tputs; then
- echo "termcap functions found (with libraries '$libs')"
- echo "#define HAS_TERMCAP" >> s.h
- curseslibs="${libs}"
- break
- fi
- done
-fi
-
-# Configuration for the libraries
-
-otherlibraries="unix str num dynlink bigarray"
-
-# For the Unix library
-
-has_sockets=no
-if sh ./hasgot socket socketpair bind listen accept connect; then
- echo "You have BSD sockets."
- echo "#define HAS_SOCKETS" >> s.h
- has_sockets=yes
-elif sh ./hasgot -lnsl -lsocket socket socketpair bind listen accept connect; then
- echo "You have BSD sockets (with libraries '-lnsl -lsocket')"
- cclibs="$cclibs -lnsl -lsocket"
- echo "#define HAS_SOCKETS" >> s.h
- has_sockets=yes
-fi
-
-if sh ./hasgot -i sys/socket.h -t socklen_t; then
- echo "socklen_t is defined in <sys/socket.h>"
- echo "#define HAS_SOCKLEN_T" >> s.h
-fi
-
-if sh ./hasgot inet_aton; then
- echo "inet_aton() found."
- echo "#define HAS_INET_ATON" >> s.h
-fi
-
-if sh ./hasgot -i unistd.h; then
- echo "unistd.h found."
- echo "#define HAS_UNISTD" >> s.h
-fi
-
-if sh ./hasgot -i sys/types.h -t off_t; then
- echo "off_t is defined in <sys/types.h>"
- echo "#define HAS_OFF_T" >> s.h
-fi
-
-if sh ./hasgot -i sys/types.h -i dirent.h; then
- echo "dirent.h found."
- echo "#define HAS_DIRENT" >> s.h
-fi
-
-if sh ./hasgot rewinddir; then
- echo "rewinddir() found."
- echo "#define HAS_REWINDDIR" >> s.h
-fi
-
-if sh ./hasgot lockf; then
- echo "lockf() found."
- echo "#define HAS_LOCKF" >> s.h
-fi
-
-if sh ./hasgot mkfifo; then
- echo "mkfifo() found."
- echo "#define HAS_MKFIFO" >> s.h
-fi
-
-if sh ./hasgot getcwd; then
- echo "getcwd() found."
- echo "#define HAS_GETCWD" >> s.h
-fi
-
-if sh ./hasgot getwd; then
- echo "getwd() found."
- echo "#define HAS_GETWD" >> s.h
-fi
-
-if sh ./hasgot getpriority setpriority; then
- echo "getpriority() found."
- echo "#define HAS_GETPRIORITY" >> s.h
-fi
-
-if sh ./hasgot -i sys/types.h -i utime.h && sh ./hasgot utime; then
- echo "utime() found."
- echo "#define HAS_UTIME" >> s.h
-fi
-
-if sh ./hasgot utimes; then
- echo "utimes() found."
- echo "#define HAS_UTIMES" >> s.h
-fi
-
-if sh ./hasgot dup2; then
- echo "dup2() found."
- echo "#define HAS_DUP2" >> s.h
-fi
-
-if sh ./hasgot fchmod fchown; then
- echo "fchmod() found."
- echo "#define HAS_FCHMOD" >> s.h
-fi
-
-if sh ./hasgot truncate ftruncate; then
- echo "truncate() found."
- echo "#define HAS_TRUNCATE" >> s.h
-fi
-
-select_include=''
-if sh ./hasgot -i sys/types.h -i sys/select.h; then
- echo "sys/select.h found."
- echo "#define HAS_SYS_SELECT_H" >> s.h
- select_include='-i sys/select.h'
-fi
-
-has_select=no
-if sh ./hasgot select && \
- sh ./hasgot -i sys/types.h $select_include -t fd_set ; then
- echo "select() found."
- echo "#define HAS_SELECT" >> s.h
- has_select=yes
-fi
-
-if sh ./hasgot symlink readlink lstat; then
- echo "symlink() found."
- echo "#define HAS_SYMLINK" >> s.h
-fi
-
-has_wait=no
-if sh ./hasgot waitpid; then
- echo "waitpid() found."
- echo "#define HAS_WAITPID" >> s.h
- has_wait=yes
-fi
-
-if sh ./hasgot wait4; then
- echo "wait4() found."
- echo "#define HAS_WAIT4" >> s.h
- has_wait=yes
-fi
-
-if sh ./hasgot -i limits.h && sh ./runtest getgroups.c; then
- echo "getgroups() found."
- echo "#define HAS_GETGROUPS" >> s.h
-fi
-
-if sh ./hasgot -i termios.h &&
- sh ./hasgot tcgetattr tcsetattr tcsendbreak tcflush tcflow; then
- echo "POSIX termios found."
- echo "#define HAS_TERMIOS" >> s.h
-fi
-
-# Async I/O under OSF1 3.x are so buggy that the test program hangs...
-testasyncio=true
-if test -f /usr/bin/uname; then
- case "`/usr/bin/uname -s -r`" in
- "OSF1 V3."*) testasyncio=false;;
- esac
-fi
-if $testasyncio && sh ./runtest async_io.c; then
- echo "Asynchronous I/O are supported."
- echo "#define HAS_ASYNC_IO" >> s.h
-fi
-
-has_setitimer=no
-if sh ./hasgot setitimer; then
- echo "setitimer() found."
- echo "#define HAS_SETITIMER" >> s.h
- has_setitimer="yes"
-fi
-
-if sh ./hasgot gethostname; then
- echo "gethostname() found."
- echo "#define HAS_GETHOSTNAME" >> s.h
-fi
-
-if sh ./hasgot -i sys/utsname.h && sh ./hasgot uname; then
- echo "uname() found."
- echo "#define HAS_UNAME" >> s.h
-fi
-
-has_gettimeofday=no
-if sh ./hasgot gettimeofday; then
- echo "gettimeofday() found."
- echo "#define HAS_GETTIMEOFDAY" >> s.h
- has_gettimeofday="yes"
-fi
-
-if sh ./hasgot mktime; then
- echo "mktime() found."
- echo "#define HAS_MKTIME" >> s.h
-fi
-
-case "$host" in
- *-*-cygwin*) ;; # setsid emulation under Cygwin breaks the debugger
- *) if sh ./hasgot setsid; then
- echo "setsid() found."
- echo "#define HAS_SETSID" >> s.h
- fi;;
-esac
-
-if sh ./hasgot putenv; then
- echo "putenv() found."
- echo "#define HAS_PUTENV" >> s.h
-fi
-
-if sh ./hasgot -i locale.h && sh ./hasgot setlocale; then
- echo "setlocale() and <locale.h> found."
- echo "#define HAS_LOCALE" >> s.h
-fi
-
-if sh ./hasgot -i mach-o/dyld.h && sh ./hasgot NSLinkModule; then
- echo "NSLinkModule() found. Using darwin dynamic loading."
- echo "#define HAS_NSLINKMODULE" >> s.h
-elif sh ./hasgot $dllib dlopen; then
- echo "dlopen() found."
-elif sh ./hasgot $dllib -ldl dlopen; then
- echo "dlopen() found in -ldl."
- dllib="$dllib -ldl"
-else
- shared_libraries_supported=no
-fi
-
-if $shared_libraries_supported; then
- echo "Dynamic loading of shared libraries is supported."
- echo "#define SUPPORT_DYNAMIC_LINKING" >> s.h
- if $dl_needs_underscore; then
- echo '#define DL_NEEDS_UNDERSCORE' >>s.h
- fi
-fi
-
-if sh ./hasgot -i sys/types.h -i sys/mman.h && sh ./hasgot mmap munmap; then
- echo "mmap() found."
- echo "#define HAS_MMAP" >> s.h
-fi
-
-nargs=none
-for i in 5 6; do
- if sh ./trycompile -DNUM_ARGS=${i} gethostbyname.c; then nargs=$i; break; fi
-done
-if test $nargs != "none"; then
- echo "gethostbyname_r() found (with ${nargs} arguments)."
- echo "#define HAS_GETHOSTBYNAME_R $nargs" >> s.h
-fi
-
-nargs=none
-for i in 7 8; do
- if sh ./trycompile -DNUM_ARGS=${i} gethostbyaddr.c; then nargs=$i; break; fi
-done
-if test $nargs != "none"; then
- echo "gethostbyaddr_r() found (with ${nargs} arguments)."
- echo "#define HAS_GETHOSTBYADDR_R $nargs" >> s.h
-fi
-
-# Determine if the debugger is supported
-
-if test "$has_sockets" = "yes"; then
- echo "Replay debugger supported."
- debugger="ocamldebugger"
-else
- echo "No replay debugger (missing system calls)"
- debugger=""
-fi
-
-
-# Determine if system stack overflows can be detected
-
-case "$arch,$system" in
- i386,linux_elf)
- echo "System stack overflow can be detected."
- echo "#define HAS_STACK_OVERFLOW_DETECTION" >> s.h;;
- *)
- echo "Cannot detect system stack overflow.";;
-esac
-
-# Determine the target architecture for the "num" library
-
-case "$host" in
- alpha*-*-*) bng_arch=alpha; bng_asm_level=1;;
- i[3456]86-*-*) bng_arch=ia32
- if `sh ./trycompile ia32sse2.c`
- then bng_asm_level=2
- else bng_asm_level=1
- fi;;
- mips-*-*) bng_arch=mips; bng_asm_level=1;;
- powerpc-*-*) bng_arch=ppc; bng_asm_level=1;;
- sparc*-*-*) bng_arch=sparc; bng_asm_level=1;;
- x86_64-*-*) bng_arch=amd64; bng_asm_level=1;;
- *) bng_arch=generic; bng_asm_level=0;;
-esac
-
-echo "BNG_ARCH=$bng_arch" >> Makefile
-echo "BNG_ASM_LEVEL=$bng_asm_level" >> Makefile
-
-# Determine if the POSIX threads library is supported
-
-case "$host" in
- *-*-solaris*) pthread_link="-lpthread -lposix4";;
- *-*-freebsd*) pthread_link="-pthread";;
- *-*-openbsd*) pthread_link="-pthread";;
- *) pthread_link="-lpthread";;
-esac
-
-if test "$pthread_wanted" = "yes"; then
-if ./hasgot -i pthread.h $pthread_link pthread_self; then
- echo "POSIX threads library supported."
- otherlibraries="$otherlibraries systhreads"
- bytecccompopts="$bytecccompopts -D_REENTRANT"
- nativecccompopts="$nativecccompopts -D_REENTRANT"
- case "$host" in
- *-*-freebsd*)
- bytecccompopts="$bytecccompopts -D_THREAD_SAFE"
- nativecccompopts="$nativecccompopts -D_THREAD_SAFE";;
- *-*-openbsd*)
- bytecccompopts="$bytecccompopts -pthread"
- asppflags="$asppflags -pthread"
- nativecccompopts="$nativecccompopts -pthread";;
- esac
- echo "Options for linking with POSIX threads: $pthread_link"
- echo "PTHREAD_LINK=$pthread_link" >> Makefile
- if sh ./hasgot $pthread_link sigwait; then
- echo "sigwait() found"
- echo "#define HAS_SIGWAIT" >> s.h
- fi
-else
- echo "POSIX threads not found."
-fi
-fi
-
-# Determine if the bytecode thread library is supported
-
-if test "$has_select" = "yes" \
-&& test "$has_setitimer" = "yes" \
-&& test "$has_gettimeofday" = "yes" \
-&& test "$has_wait" = "yes"; then
- echo "Bytecode threads library supported."
- otherlibraries="$otherlibraries threads"
-else
- echo "Bytecode threads library not supported (missing system calls)"
-fi
-
-# Determine the location of X include files and libraries
-
-x11_include="not found"
-x11_link="not found"
-
-for dir in \
- $x11_include_dir \
- \
- /usr/X11R6/include \
- /usr/include/X11R6 \
- /usr/local/X11R6/include \
- /usr/local/include/X11R6 \
- /opt/X11R6/include \
- \
- /usr/X11/include \
- /usr/include/X11 \
- /usr/local/X11/include \
- /usr/local/include/X11 \
- /opt/X11/include \
- \
- /usr/X11R5/include \
- /usr/include/X11R5 \
- /usr/local/X11R5/include \
- /usr/local/include/X11R5 \
- /usr/local/x11r5/include \
- /opt/X11R5/include \
- \
- /usr/X11R4/include \
- /usr/include/X11R4 \
- /usr/local/X11R4/include \
- /usr/local/include/X11R4 \
- \
- /usr/X386/include \
- /usr/x386/include \
- /usr/XFree86/include/X11 \
- \
- /usr/include \
- /usr/local/include \
- /usr/unsupported/include \
- /usr/athena/include \
- /usr/lpp/Xamples/include \
- \
- /usr/openwin/include \
- /usr/openwin/share/include \
- ; \
-do
- if test -f $dir/X11/X.h; then
- x11_include=$dir
- break
- fi
-done
-
-if test "$x11_include" = "not found"; then
- x11_try_lib_dir=''
-else
- x11_try_lib_dir=`echo $x11_include | sed -e 's|include|lib|'`
-fi
-
-for dir in \
- $x11_lib_dir \
- $x11_try_lib_dir \
- \
- /usr/X11R6/lib \
- /usr/lib/X11R6 \
- /usr/local/X11R6/lib \
- /usr/local/lib/X11R6 \
- /opt/X11R6/lib \
- \
- /usr/X11/lib \
- /usr/lib/X11 \
- /usr/local/X11/lib \
- /usr/local/lib/X11 \
- /opt/X11/lib \
- \
- /usr/X11R5/lib \
- /usr/lib/X11R5 \
- /usr/local/X11R5/lib \
- /usr/local/lib/X11R5 \
- /usr/local/x11r5/lib \
- /opt/X11R5/lib \
- \
- /usr/X11R4/lib \
- /usr/lib/X11R4 \
- /usr/local/X11R4/lib \
- /usr/local/lib/X11R4 \
- \
- /usr/X386/lib \
- /usr/x386/lib \
- /usr/XFree86/lib/X11 \
- \
- /usr/lib \
- /usr/local/lib \
- /usr/unsupported/lib \
- /usr/athena/lib \
- /usr/lpp/Xamples/lib \
- /lib/usr/lib/X11 \
- \
- /usr/openwin/lib \
- /usr/openwin/share/lib \
- ; \
-do
- if test -f $dir/libX11.a || \
- test -f $dir/libX11.so || \
- test -f $dir/libX11.dll.a || \
- test -f $dir/libX11.sa; then
- if test $dir = /usr/lib; then
- x11_link="-lX11"
- else
- x11_link="-L$dir -lX11"
- x11_libs="-L$dir"
- fi
- break
- fi
-done
-
-
-if test "$x11_include" = "not found" || test "$x11_link" = "not found"
-then
- echo "X11 not found, the \"graph\" library will not be supported."
- x11_include=""
-else
- echo "Location of X11 include files: $x11_include/X11"
- echo "Options for linking with X11: $x11_link"
- otherlibraries="$otherlibraries graph"
- if test "$x11_include" = "/usr/include"; then
- x11_include=""
- else
- x11_include="-I$x11_include"
- fi
- echo "X11_INCLUDES=$x11_include" >> Makefile
- echo "X11_LINK=$x11_link" >> Makefile
-fi
-
-# See if we can compile the dbm library
-
-dbm_include="not found"
-dbm_link="not found"
-use_gdbm_ndbm=no
-
-for dir in /usr/include /usr/include/db1 /usr/include/gdbm; do
- if test -f $dir/ndbm.h; then
- dbm_include=$dir
- if sh ./hasgot dbm_open; then
- dbm_link=""
- elif sh ./hasgot -lndbm dbm_open; then
- dbm_link="-lndbm"
- elif sh ./hasgot -ldb1 dbm_open; then
- dbm_link="-ldb1"
- elif sh ./hasgot -lgdbm dbm_open; then
- dbm_link="-lgdbm"
- elif sh ./hasgot -lgdbm_compat -lgdbm dbm_open; then
- dbm_link="-lgdbm_compat -lgdbm"
- fi
- break
- fi
- if test -f $dir/gdbm-ndbm.h; then
- dbm_include=$dir
- use_gdbm_ndbm=yes
- if sh ./hasgot -lgdbm_compat -lgdbm dbm_open; then
- dbm_link="-lgdbm_compat -lgdbm"
- fi
- break
- fi
-done
-if test "$dbm_include" = "not found" || test "$dbm_link" = "not found"; then
- echo "NDBM not found, the \"dbm\" library will not be supported."
-else
- echo "NDBM found (in $dbm_include)"
- if test "$dbm_include" = "/usr/include"; then
- dbm_include=""
- else
- dbm_include="-I$dbm_include"
- fi
- echo "DBM_INCLUDES=$dbm_include" >> Makefile
- echo "DBM_LINK=$dbm_link" >> Makefile
- if test "$use_gdbm_ndbm" = "yes"; then
- echo "#define DBM_USES_GDBM_NDBM" >> s.h
- fi
- otherlibraries="$otherlibraries dbm"
-fi
-
-# Look for tcl/tk
-
-echo "Configuring LablTk..."
-
-if test $tk_wanted = no; then
- has_tk=false
-elif test $tk_x11 = no; then
- has_tk=true
-elif test "$x11_include" = "not found" || test "$x11_link" = "not found"; then
- echo "X11 not found."
- has_tk=false
-else
- tk_x11_include="$x11_include"
- tk_x11_libs="$x11_libs -lX11"
- has_tk=true
-fi
-
-if test $has_tk = true; then
- tcl_version=''
- tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c`
- if test -z "$tcl_version" && test -z "$tk_defs"; then
- tk_defs=-I/usr/local/include
- tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c`
- fi
- if test -z "$tcl_version"; then
- tk_defs="-I/usr/local/include/tcl8.2 -I/usr/local/include/tk8.2"
- tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c`
- fi
- if test -z "$tcl_version"; then
- tk_defs="-I/usr/local/include/tcl8.3 -I/usr/local/include/tk8.3"
- tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c`
- fi
- if test -z "$tcl_version"; then
- tk_defs="-I/usr/local/include/tcl8.4 -I/usr/local/include/tk8.4"
- tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c`
- fi
- if test -z "$tcl_version"; then
- tk_defs="-I/usr/include/tcl8.2 -I/usr/include/tk8.2"
- tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c`
- fi
- if test -z "$tcl_version"; then
- tk_defs="-I/usr/include/tcl8.3 -I/usr/include/tk8.3"
- tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c`
- fi
- if test -z "$tcl_version"; then
- tk_defs="-I/usr/include/tcl8.4 -I/usr/include/tk8.4"
- tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c`
- fi
- if test -z "$tcl_version"; then
- tk_defs="-I/sw/include"
- tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c`
- fi
- if test -n "$tcl_version"; then
- echo "tcl.h version $tcl_version found with \"$tk_defs\"."
- case $tcl_version in
- 7.5) tclmaj=7 tclmin=5 tkmaj=4 tkmin=1 ;;
- 7.6) tclmaj=7 tclmin=6 tkmaj=4 tkmin=2 ;;
- 8.0) tclmaj=8 tclmin=0 tkmaj=8 tkmin=0 ;;
- 8.1) tclmaj=8 tclmin=1 tkmaj=8 tkmin=1 ;;
- 8.2) tclmaj=8 tclmin=2 tkmaj=8 tkmin=2 ;;
- 8.3) tclmaj=8 tclmin=3 tkmaj=8 tkmin=3 ;;
- 8.4) tclmaj=8 tclmin=4 tkmaj=8 tkmin=4 ;;
- *) echo "This version is not known."; has_tk=false ;;
- esac
- else
- echo "tcl.h not found."
- has_tk=false
- fi
-fi
-
-if test $has_tk = true; then
- if sh ./hasgot $tk_x11_include $tk_defs -i tk.h; then
- echo "tk.h found."
- else
- echo "tk.h not found."
- has_tk=false
- fi
-fi
-
-tkauxlibs="$mathlib $dllib"
-tcllib=''
-tklib=''
-if test $has_tk = true; then
- if sh ./hasgot $tk_libs $tk_x11_libs $tkauxlibs Tcl_DoOneEvent
- then tk_libs="$tk_libs $dllib"
- elif sh ./hasgot $tk_libs -ltcl$tclmaj.$tclmin $tkauxlibs Tcl_DoOneEvent
- then
- tk_libs="$tk_libs -ltk$tkmaj.$tkmin -ltcl$tclmaj.$tclmin $dllib"
- elif sh ./hasgot $tk_libs -ltcl$tclmaj$tclmin $tkauxlibs Tcl_DoOneEvent
- then
- tk_libs="$tk_libs -ltk$tkmaj$tkmin -ltcl$tclmaj$tclmin $dllib"
- elif test -z "$tk_libs" && tk_libs=-L/usr/local/lib && \
- sh ./hasgot $tk_libs -ltcl$tclmaj.$tclmin $tkauxlibs Tcl_DoOneEvent
- then
- tk_libs="$tk_libs -ltk$tkmaj.$tkmin -ltcl$tclmaj.$tclmin $dllib"
- elif sh ./hasgot $tk_libs -ltcl$tclmaj$tclmin $tkauxlibs Tcl_DoOneEvent
- then
- tk_libs="$tk_libs -ltk$tkmaj$tkmin -ltcl$tclmaj$tclmin $dllib"
-# elif sh ./hasgot $tk_libs -ltcl $tkauxlibs Tcl_DoOneEvent; then
-# tk_libs="$tk_libs -ltk -ltcl"
- elif sh ./hasgot -L/sw/lib $tk_libs -ltcl$tclmaj.$tclmin $tkauxlibs \
- Tcl_DoOneEvent
- then tk_libs="-L/sw/lib -ltk$tkmaj.$tkmin -ltcl$tclmaj.$tclmin $dllib"
- else
- echo "Tcl library not found."
- has_tk=false
- fi
-fi
-if test $has_tk = true; then
- if sh ./hasgot $tk_libs $tk_x11_libs $tkauxlibs Tk_SetGrid; then
- echo "Tcl/Tk libraries found."
- elif sh ./hasgot -L/sw/lib $tk_libs $tk_x11_libs $tkauxlibs Tk_SetGrid; then
- tk_libs="-L/sw/lib $tk_libs"
- echo "Tcl/Tk libraries found."
- else
- echo "Tcl library found."
- echo "Tk library not found."
- has_tk=false
- fi
-fi
-
-if test $has_tk = true; then
- if test $tk_x11 = yes; then
- echo "TK_DEFS=$tk_defs "'$(X11_INCLUDES)' >> Makefile
- echo "TK_LINK=$tk_libs "'$(X11_LINK)' >> Makefile
- else
- echo "TK_DEFS=$tk_defs" >> Makefile
- echo "TK_LINK=$tk_libs" >> Makefile
- fi
- otherlibraries="$otherlibraries labltk"
-else
- echo "Configuration failed, LablTk will not be built."
-fi
-
-# Camlp4
-
-(
-cd ../../camlp4/config
-EXE=$exe ./configure_batch -bindir "$bindir" -libdir "$libdir" -mandir "$mandir" -ocaml-top ../.. > /dev/null
-)
-
-# Final twiddling of compiler options to work around known bugs
-
-nativeccprofopts="$nativecccompopts"
-case "$buggycc" in
- gcc.2.96)
- bytecccompopts="$bytecccompopts -fomit-frame-pointer"
- nativecccompopts="$nativecccompopts -fomit-frame-pointer";;
-esac
-
-# Finish generated files
-
-cclibs="$cclibs $mathlib"
-
-echo "BYTECC=$bytecc" >> Makefile
-echo "BYTECCCOMPOPTS=$bytecccompopts" >> Makefile
-echo "BYTECCLINKOPTS=$bytecclinkopts" >> Makefile
-echo "BYTECCLIBS=$cclibs $dllib $curseslibs $pthread_link" >> Makefile
-echo "BYTECCRPATH=$byteccrpath" >> Makefile
-echo "EXE=$exe" >> Makefile
-echo "SUPPORTS_SHARED_LIBRARIES=$shared_libraries_supported" >> Makefile
-echo "SHAREDCCCOMPOPTS=$sharedcccompopts" >> Makefile
-echo "MKSHAREDLIB=$mksharedlib" >> Makefile
-echo "MKSHAREDLIBRPATH=$mksharedlibrpath" >> Makefile
-echo "ARCH=$arch" >> Makefile
-echo "MODEL=$model" >> Makefile
-echo "SYSTEM=$system" >> Makefile
-echo "NATIVECC=$nativecc" >> Makefile
-echo "NATIVECCCOMPOPTS=$nativecccompopts" >> Makefile
-echo "NATIVECCPROFOPTS=$nativeccprofopts" >> Makefile
-echo "NATIVECCLINKOPTS=$nativecclinkopts" >> Makefile
-echo "NATIVECCRPATH=$nativeccrpath" >> Makefile
-echo "NATIVECCLIBS=$cclibs $dllib" >> Makefile
-echo "ASFLAGS=$asflags" >> Makefile
-echo "ASPP=$aspp" >> Makefile
-echo "ASPPFLAGS=$asppflags" >> Makefile
-echo "ASPPPROFFLAGS=$asppprofflags" >> Makefile
-echo "PROFILING=$profiling" >> Makefile
-echo "BINUTILS_OBJCOPY=$binutils_objcopy" >> Makefile
-echo "BINUTILS_NM=$binutils_nm" >> Makefile
-echo "DYNLINKOPTS=$dllib" >> Makefile
-echo "OTHERLIBRARIES=$otherlibraries" >> Makefile
-echo "DEBUGGER=$debugger" >> Makefile
-echo "CC_PROFILE=$cc_profile" >> Makefile
-
-rm -f tst hasgot.c
-rm -f ../m.h ../s.h ../Makefile
-mv m.h s.h Makefile ..
-
-# Print a summary
-
-echo
-echo "** Configuration summary **"
-echo
-echo "Directories where Objective Caml will be installed:"
-echo " binaries.................. $bindir"
-echo " standard library.......... $libdir"
-echo " manual pages.............. $mandir (with extension .$manext)"
-
-echo "Configuration for the bytecode compiler:"
-echo " C compiler used........... $bytecc"
-echo " options for compiling..... $bytecccompopts"
-echo " options for linking....... $bytecclinkopts $cclibs $dllib $curseslibs $pthread_link"
-if $shared_libraries_supported; then
-echo " shared libraries are supported"
-echo " options for compiling..... $sharedcccompopts $bytecccompopts"
-echo " command for building...... $mksharedlib lib.so $mksharedlibrpath/a/path objs"
-else
-echo " shared libraries not supported"
-fi
-
-echo "Configuration for the native-code compiler:"
-if test "$arch" = "none"; then
- echo " (not supported on this platform)"
-else
- if test "$model" = "default"; then
- echo " hardware architecture..... $arch"
- else
- echo " hardware architecture..... $arch ($model)"
- fi
- if test "$system" = "unknown"; then : ; else
- echo " OS variant................ $system"
- fi
- echo " C compiler used........... $nativecc"
- echo " options for compiling..... $nativecccompopts"
- echo " options for linking....... $nativecclinkopts $cclibs"
- echo " assembler ................ \$(AS) $asflags"
- echo " preprocessed assembler ... $aspp $asppflags"
- if test "$profiling" = "prof"; then
- echo " profiling with gprof ..... supported"
- else
- echo " profiling with gprof ..... not supported"
- fi
- if test -n "$binutils_objcopy" && test -n "$binutils_nm"; then
- echo " ocamlopt -pack ........... supported"
- else
- echo " ocamlopt -pack ........... not supported (no binutils)"
- fi
-fi
-
-if test "$debugger" = "ocamldebugger"; then
- echo "Source-level replay debugger: supported"
-else
- echo "Source-level replay debugger: not supported"
-fi
-
-echo "Additional libraries supported:"
-echo " $otherlibraries"
-
-echo "Configuration for the \"num\" library:"
-echo " target architecture ...... $bng_arch (asm level $bng_asm_level)"
-
-if test "$x11_include" != "not found" && test "$x11_lib" != "not found"; then
-echo "Configuration for the \"graph\" library:"
-echo " options for compiling .... $x11_include"
-echo " options for linking ...... $x11_link"
-fi
-
-if test $has_tk = true; then
-echo "Configuration for the \"labltk\" library:"
-echo " use tcl/tk version ....... $tcl_version"
-echo " options for compiling .... $tk_defs"
-echo " options for linking ...... $tk_libs"
-else
-echo "The \"labltk\" library: not found"
-fi
diff --git a/debugger/.cvsignore b/debugger/.cvsignore
deleted file mode 100644
index b608cf5532..0000000000
--- a/debugger/.cvsignore
+++ /dev/null
@@ -1,4 +0,0 @@
-lexer.ml
-parser.ml
-parser.mli
-ocamldebug
diff --git a/debugger/.depend b/debugger/.depend
deleted file mode 100644
index 3a303e336d..0000000000
--- a/debugger/.depend
+++ /dev/null
@@ -1,189 +0,0 @@
-breakpoints.cmi: ../bytecomp/instruct.cmi primitives.cmi
-checkpoints.cmi: debugcom.cmi primitives.cmi
-debugcom.cmi: primitives.cmi
-envaux.cmi: ../typing/env.cmi ../bytecomp/instruct.cmi ../typing/path.cmi
-eval.cmi: debugcom.cmi ../typing/env.cmi ../typing/ident.cmi \
- ../bytecomp/instruct.cmi ../parsing/longident.cmi parser_aux.cmi \
- ../typing/path.cmi ../typing/types.cmi
-events.cmi: ../bytecomp/instruct.cmi
-frames.cmi: ../bytecomp/instruct.cmi primitives.cmi
-input_handling.cmi: primitives.cmi
-loadprinter.cmi: ../otherlibs/dynlink/dynlink.cmi ../parsing/longident.cmi
-parser.cmi: ../parsing/longident.cmi parser_aux.cmi
-parser_aux.cmi: ../parsing/longident.cmi primitives.cmi
-pattern_matching.cmi: debugcom.cmi parser_aux.cmi ../typing/typedtree.cmi
-pos.cmi: ../bytecomp/instruct.cmi
-primitives.cmi: ../otherlibs/unix/unix.cmi
-printval.cmi: debugcom.cmi ../typing/env.cmi parser_aux.cmi \
- ../typing/path.cmi ../typing/types.cmi
-program_loading.cmi: primitives.cmi
-show_information.cmi: ../bytecomp/instruct.cmi
-symbols.cmi: ../bytecomp/instruct.cmi
-time_travel.cmi: primitives.cmi
-unix_tools.cmi: ../otherlibs/unix/unix.cmi
-breakpoints.cmo: checkpoints.cmi debugcom.cmi exec.cmi \
- ../bytecomp/instruct.cmi pos.cmi primitives.cmi source.cmi symbols.cmi \
- breakpoints.cmi
-breakpoints.cmx: checkpoints.cmx debugcom.cmx exec.cmx \
- ../bytecomp/instruct.cmx pos.cmx primitives.cmx source.cmx symbols.cmx \
- breakpoints.cmi
-checkpoints.cmo: debugcom.cmi int64ops.cmi primitives.cmi checkpoints.cmi
-checkpoints.cmx: debugcom.cmx int64ops.cmx primitives.cmx checkpoints.cmi
-command_line.cmo: breakpoints.cmi checkpoints.cmi ../utils/config.cmi \
- ../typing/ctype.cmi debugcom.cmi debugger_config.cmi envaux.cmi eval.cmi \
- events.cmi frames.cmi history.cmi input_handling.cmi \
- ../bytecomp/instruct.cmi int64ops.cmi ../parsing/lexer.cmi \
- loadprinter.cmi ../utils/misc.cmi parameters.cmi parser.cmi \
- parser_aux.cmi pos.cmi primitives.cmi printval.cmi program_loading.cmi \
- program_management.cmi show_information.cmi show_source.cmi source.cmi \
- symbols.cmi time_travel.cmi ../typing/types.cmi \
- ../otherlibs/unix/unix.cmi unix_tools.cmi command_line.cmi
-command_line.cmx: breakpoints.cmx checkpoints.cmx ../utils/config.cmx \
- ../typing/ctype.cmx debugcom.cmx debugger_config.cmx envaux.cmx eval.cmx \
- events.cmx frames.cmx history.cmx input_handling.cmx \
- ../bytecomp/instruct.cmx int64ops.cmx ../parsing/lexer.cmx \
- loadprinter.cmx ../utils/misc.cmx parameters.cmx parser.cmx \
- parser_aux.cmi pos.cmx primitives.cmx printval.cmx program_loading.cmx \
- program_management.cmx show_information.cmx show_source.cmx source.cmx \
- symbols.cmx time_travel.cmx ../typing/types.cmx \
- ../otherlibs/unix/unix.cmx unix_tools.cmx command_line.cmi
-debugcom.cmo: input_handling.cmi int64ops.cmi ../utils/misc.cmi \
- primitives.cmi debugcom.cmi
-debugcom.cmx: input_handling.cmx int64ops.cmx ../utils/misc.cmx \
- primitives.cmx debugcom.cmi
-debugger_config.cmo: int64ops.cmi debugger_config.cmi
-debugger_config.cmx: int64ops.cmx debugger_config.cmi
-envaux.cmo: ../typing/env.cmi ../bytecomp/instruct.cmi ../utils/misc.cmi \
- ../typing/mtype.cmi ../typing/path.cmi ../typing/printtyp.cmi \
- ../typing/types.cmi envaux.cmi
-envaux.cmx: ../typing/env.cmx ../bytecomp/instruct.cmx ../utils/misc.cmx \
- ../typing/mtype.cmx ../typing/path.cmx ../typing/printtyp.cmx \
- ../typing/types.cmx envaux.cmi
-eval.cmo: ../typing/btype.cmi ../typing/ctype.cmi debugcom.cmi \
- debugger_config.cmi ../typing/env.cmi frames.cmi ../typing/ident.cmi \
- ../bytecomp/instruct.cmi ../parsing/longident.cmi ../utils/misc.cmi \
- parser_aux.cmi ../typing/path.cmi ../typing/predef.cmi \
- ../typing/printtyp.cmi printval.cmi ../bytecomp/symtable.cmi \
- ../typing/types.cmi eval.cmi
-eval.cmx: ../typing/btype.cmx ../typing/ctype.cmx debugcom.cmx \
- debugger_config.cmx ../typing/env.cmx frames.cmx ../typing/ident.cmx \
- ../bytecomp/instruct.cmx ../parsing/longident.cmx ../utils/misc.cmx \
- parser_aux.cmi ../typing/path.cmx ../typing/predef.cmx \
- ../typing/printtyp.cmx printval.cmx ../bytecomp/symtable.cmx \
- ../typing/types.cmx eval.cmi
-events.cmo: checkpoints.cmi ../bytecomp/instruct.cmi primitives.cmi \
- symbols.cmi events.cmi
-events.cmx: checkpoints.cmx ../bytecomp/instruct.cmx primitives.cmx \
- symbols.cmx events.cmi
-exec.cmo: exec.cmi
-exec.cmx: exec.cmi
-frames.cmo: checkpoints.cmi debugcom.cmi events.cmi ../bytecomp/instruct.cmi \
- ../utils/misc.cmi primitives.cmi symbols.cmi frames.cmi
-frames.cmx: checkpoints.cmx debugcom.cmx events.cmx ../bytecomp/instruct.cmx \
- ../utils/misc.cmx primitives.cmx symbols.cmx frames.cmi
-history.cmo: checkpoints.cmi debugger_config.cmi int64ops.cmi \
- ../utils/misc.cmi primitives.cmi history.cmi
-history.cmx: checkpoints.cmx debugger_config.cmx int64ops.cmx \
- ../utils/misc.cmx primitives.cmx history.cmi
-input_handling.cmo: ../parsing/lexer.cmi primitives.cmi \
- ../otherlibs/unix/unix.cmi input_handling.cmi
-input_handling.cmx: ../parsing/lexer.cmx primitives.cmx \
- ../otherlibs/unix/unix.cmx input_handling.cmi
-int64ops.cmo: int64ops.cmi
-int64ops.cmx: int64ops.cmi
-lexer.cmo: parser.cmi primitives.cmi
-lexer.cmx: parser.cmx primitives.cmx
-loadprinter.cmo: ../utils/config.cmi ../typing/ctype.cmi debugger_config.cmi \
- ../otherlibs/dynlink/dynlink.cmi ../typing/env.cmi ../typing/ident.cmi \
- ../parsing/longident.cmi ../utils/misc.cmi ../typing/path.cmi \
- ../typing/printtyp.cmi printval.cmi ../bytecomp/symtable.cmi \
- ../typing/types.cmi loadprinter.cmi
-loadprinter.cmx: ../utils/config.cmx ../typing/ctype.cmx debugger_config.cmx \
- ../otherlibs/dynlink/dynlink.cmx ../typing/env.cmx ../typing/ident.cmx \
- ../parsing/longident.cmx ../utils/misc.cmx ../typing/path.cmx \
- ../typing/printtyp.cmx printval.cmx ../bytecomp/symtable.cmx \
- ../typing/types.cmx loadprinter.cmi
-main.cmo: checkpoints.cmi command_line.cmi ../utils/config.cmi \
- debugger_config.cmi exec.cmi frames.cmi input_handling.cmi \
- ../utils/misc.cmi parameters.cmi primitives.cmi program_management.cmi \
- show_information.cmi time_travel.cmi ../otherlibs/unix/unix.cmi \
- unix_tools.cmi
-main.cmx: checkpoints.cmx command_line.cmx ../utils/config.cmx \
- debugger_config.cmx exec.cmx frames.cmx input_handling.cmx \
- ../utils/misc.cmx parameters.cmx primitives.cmx program_management.cmx \
- show_information.cmx time_travel.cmx ../otherlibs/unix/unix.cmx \
- unix_tools.cmx
-parameters.cmo: ../utils/config.cmi envaux.cmi ../utils/misc.cmi \
- primitives.cmi parameters.cmi
-parameters.cmx: ../utils/config.cmx envaux.cmx ../utils/misc.cmx \
- primitives.cmx parameters.cmi
-parser.cmo: input_handling.cmi int64ops.cmi ../parsing/longident.cmi \
- parser_aux.cmi primitives.cmi parser.cmi
-parser.cmx: input_handling.cmx int64ops.cmx ../parsing/longident.cmx \
- parser_aux.cmi primitives.cmx parser.cmi
-pattern_matching.cmo: ../typing/ctype.cmi debugcom.cmi debugger_config.cmi \
- ../utils/misc.cmi parser_aux.cmi ../typing/typedtree.cmi \
- pattern_matching.cmi
-pattern_matching.cmx: ../typing/ctype.cmx debugcom.cmx debugger_config.cmx \
- ../utils/misc.cmx parser_aux.cmi ../typing/typedtree.cmx \
- pattern_matching.cmi
-pos.cmo: ../bytecomp/instruct.cmi primitives.cmi source.cmi pos.cmi
-pos.cmx: ../bytecomp/instruct.cmx primitives.cmx source.cmx pos.cmi
-primitives.cmo: ../otherlibs/unix/unix.cmi primitives.cmi
-primitives.cmx: ../otherlibs/unix/unix.cmx primitives.cmi
-printval.cmo: debugcom.cmi ../toplevel/genprintval.cmi ../utils/misc.cmi \
- ../typing/oprint.cmi ../typing/outcometree.cmi parser_aux.cmi \
- ../typing/path.cmi ../typing/printtyp.cmi ../bytecomp/symtable.cmi \
- ../typing/types.cmi printval.cmi
-printval.cmx: debugcom.cmx ../toplevel/genprintval.cmx ../utils/misc.cmx \
- ../typing/oprint.cmx ../typing/outcometree.cmi parser_aux.cmi \
- ../typing/path.cmx ../typing/printtyp.cmx ../bytecomp/symtable.cmx \
- ../typing/types.cmx printval.cmi
-program_loading.cmo: debugger_config.cmi input_handling.cmi ../utils/misc.cmi \
- parameters.cmi primitives.cmi ../otherlibs/unix/unix.cmi unix_tools.cmi \
- program_loading.cmi
-program_loading.cmx: debugger_config.cmx input_handling.cmx ../utils/misc.cmx \
- parameters.cmx primitives.cmx ../otherlibs/unix/unix.cmx unix_tools.cmx \
- program_loading.cmi
-program_management.cmo: breakpoints.cmi debugcom.cmi debugger_config.cmi \
- history.cmi input_handling.cmi ../bytecomp/instruct.cmi int64ops.cmi \
- ../utils/misc.cmi parameters.cmi primitives.cmi program_loading.cmi \
- symbols.cmi time_travel.cmi ../otherlibs/unix/unix.cmi unix_tools.cmi \
- program_management.cmi
-program_management.cmx: breakpoints.cmx debugcom.cmx debugger_config.cmx \
- history.cmx input_handling.cmx ../bytecomp/instruct.cmx int64ops.cmx \
- ../utils/misc.cmx parameters.cmx primitives.cmx program_loading.cmx \
- symbols.cmx time_travel.cmx ../otherlibs/unix/unix.cmx unix_tools.cmx \
- program_management.cmi
-show_information.cmo: breakpoints.cmi checkpoints.cmi debugcom.cmi events.cmi \
- frames.cmi ../bytecomp/instruct.cmi ../utils/misc.cmi primitives.cmi \
- printval.cmi show_source.cmi symbols.cmi show_information.cmi
-show_information.cmx: breakpoints.cmx checkpoints.cmx debugcom.cmx events.cmx \
- frames.cmx ../bytecomp/instruct.cmx ../utils/misc.cmx primitives.cmx \
- printval.cmx show_source.cmx symbols.cmx show_information.cmi
-show_source.cmo: debugger_config.cmi ../utils/misc.cmi parameters.cmi \
- primitives.cmi source.cmi show_source.cmi
-show_source.cmx: debugger_config.cmx ../utils/misc.cmx parameters.cmx \
- primitives.cmx source.cmx show_source.cmi
-source.cmo: ../utils/config.cmi ../utils/misc.cmi primitives.cmi source.cmi
-source.cmx: ../utils/config.cmx ../utils/misc.cmx primitives.cmx source.cmi
-symbols.cmo: ../bytecomp/bytesections.cmi debugcom.cmi debugger_config.cmi \
- ../bytecomp/instruct.cmi primitives.cmi ../bytecomp/symtable.cmi \
- symbols.cmi
-symbols.cmx: ../bytecomp/bytesections.cmx debugcom.cmx debugger_config.cmx \
- ../bytecomp/instruct.cmx primitives.cmx ../bytecomp/symtable.cmx \
- symbols.cmi
-time_travel.cmo: breakpoints.cmi checkpoints.cmi debugcom.cmi \
- debugger_config.cmi events.cmi exec.cmi input_handling.cmi \
- ../bytecomp/instruct.cmi int64ops.cmi ../utils/misc.cmi primitives.cmi \
- program_loading.cmi symbols.cmi trap_barrier.cmi time_travel.cmi
-time_travel.cmx: breakpoints.cmx checkpoints.cmx debugcom.cmx \
- debugger_config.cmx events.cmx exec.cmx input_handling.cmx \
- ../bytecomp/instruct.cmx int64ops.cmx ../utils/misc.cmx primitives.cmx \
- program_loading.cmx symbols.cmx trap_barrier.cmx time_travel.cmi
-trap_barrier.cmo: checkpoints.cmi debugcom.cmi exec.cmi trap_barrier.cmi
-trap_barrier.cmx: checkpoints.cmx debugcom.cmx exec.cmx trap_barrier.cmi
-unix_tools.cmo: ../utils/misc.cmi primitives.cmi ../otherlibs/unix/unix.cmi \
- unix_tools.cmi
-unix_tools.cmx: ../utils/misc.cmx primitives.cmx ../otherlibs/unix/unix.cmx \
- unix_tools.cmi
diff --git a/debugger/Makefile b/debugger/Makefile
deleted file mode 100644
index 674fda9c7a..0000000000
--- a/debugger/Makefile
+++ /dev/null
@@ -1,114 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-include ../config/Makefile
-
-CAMLC=../ocamlcomp.sh
-COMPFLAGS=-warn-error A $(INCLUDES)
-LINKFLAGS=-linkall -I ../otherlibs/unix
-CAMLYACC=../boot/ocamlyacc
-YACCFLAGS=
-CAMLLEX=../boot/ocamlrun ../boot/ocamllex
-CAMLDEP=../boot/ocamlrun ../tools/ocamldep
-DEPFLAGS=$(INCLUDES)
-
-INCLUDES=\
- -I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../toplevel \
- -I ../otherlibs/unix -I ../otherlibs/dynlink
-
-OTHEROBJS=\
- ../otherlibs/unix/unix.cma \
- ../utils/misc.cmo ../utils/config.cmo \
- ../utils/tbl.cmo ../utils/clflags.cmo ../utils/consistbl.cmo \
- ../parsing/longident.cmo \
- ../typing/ident.cmo ../typing/path.cmo ../typing/types.cmo \
- ../typing/btype.cmo ../typing/primitive.cmo ../typing/typedtree.cmo \
- ../typing/subst.cmo ../typing/predef.cmo \
- ../typing/datarepr.cmo ../typing/env.cmo ../typing/oprint.cmo \
- ../typing/ctype.cmo ../typing/printtyp.cmo ../typing/mtype.cmo \
- ../bytecomp/runtimedef.cmo ../bytecomp/bytesections.cmo \
- ../bytecomp/dll.cmo ../bytecomp/symtable.cmo \
- ../bytecomp/opcodes.cmo ../bytecomp/meta.cmo \
- ../toplevel/genprintval.cmo \
- ../otherlibs/dynlink/dynlink.cmo
-
-OBJS=\
- int64ops.cmo \
- primitives.cmo \
- unix_tools.cmo \
- debugger_config.cmo \
- envaux.cmo \
- parameters.cmo \
- lexer.cmo \
- input_handling.cmo \
- debugcom.cmo \
- exec.cmo \
- source.cmo \
- pos.cmo \
- checkpoints.cmo \
- symbols.cmo \
- events.cmo \
- breakpoints.cmo \
- trap_barrier.cmo \
- history.cmo \
- program_loading.cmo \
- printval.cmo \
- show_source.cmo \
- time_travel.cmo \
- program_management.cmo \
- frames.cmo \
- eval.cmo \
- show_information.cmo \
- loadprinter.cmo \
- parser.cmo \
- command_line.cmo \
- main.cmo
-
-all: ocamldebug$(EXE)
-
-ocamldebug$(EXE): $(OBJS) $(OTHEROBJS)
- $(CAMLC) $(LINKFLAGS) -o ocamldebug$(EXE) -linkall $(OTHEROBJS) $(OBJS)
-
-install:
- cp ocamldebug$(EXE) $(BINDIR)/ocamldebug$(EXE)
-
-clean::
- rm -f ocamldebug$(EXE)
- rm -f *.cmo *.cmi
-
-.SUFFIXES:
-.SUFFIXES: .ml .cmo .mli .cmi
-
-.ml.cmo:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.mli.cmi:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-depend: beforedepend
- $(CAMLDEP) $(DEPFLAGS) *.mli *.ml > .depend
-
-lexer.ml: lexer.mll
- $(CAMLLEX) lexer.mll
-clean::
- rm -f lexer.ml
-beforedepend:: lexer.ml
-
-parser.ml parser.mli: parser.mly
- $(CAMLYACC) parser.mly
-clean::
- rm -f parser.ml parser.mli
-beforedepend:: parser.ml parser.mli
-
-include .depend
diff --git a/debugger/breakpoints.ml b/debugger/breakpoints.ml
deleted file mode 100644
index 09695d87ba..0000000000
--- a/debugger/breakpoints.ml
+++ /dev/null
@@ -1,222 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(******************************* Breakpoints ***************************)
-
-open Checkpoints
-open Debugcom
-open Instruct
-open Primitives
-open Printf
-open Source
-
-(*** Debugging. ***)
-let debug_breakpoints = ref false
-
-(*** Data. ***)
-
-(* Number of the last added breakpoint. *)
-let breakpoint_number = ref 0
-
-(* Breakpoint number -> event. *)
-let breakpoints = ref ([] : (int * debug_event) list)
-
-(* Program counter -> breakpoint count. *)
-let positions = ref ([] : (int * int ref) list)
-
-(* Versions of the breakpoint list. *)
-let current_version = ref 0
-let max_version = ref 0
-
-(*** Miscellaneous. ***)
-
-(* Mark breakpoints as installed in current checkpoint. *)
-let copy_breakpoints () =
- !current_checkpoint.c_breakpoints <- !positions;
- !current_checkpoint.c_breakpoint_version <- !current_version
-
-(* Announce a new version of the breakpoint list. *)
-let new_version () =
- incr max_version;
- current_version := !max_version
-
-(*** Information about breakpoints. ***)
-
-let breakpoints_count () =
- List.length !breakpoints
-
-(* List of breakpoints at `pc'. *)
-let rec breakpoints_at_pc pc =
- begin try
- let ev = Symbols.event_at_pc pc in
- match ev.ev_repr with
- Event_child {contents = pc'} -> breakpoints_at_pc pc'
- | _ -> []
- with Not_found ->
- []
- end
- @
- List.map fst (filter (function (_, {ev_pos = pos}) -> pos = pc) !breakpoints)
-
-(* Is there a breakpoint at `pc' ? *)
-let breakpoint_at_pc pc =
- breakpoints_at_pc pc <> []
-
-(*** Set and remove breakpoints ***)
-
-(* Remove all breakpoints. *)
-let remove_breakpoints pos =
- if !debug_breakpoints then
- (print_string "Removing breakpoints..."; print_newline ());
- List.iter
- (function (pos, _) ->
- if !debug_breakpoints then begin
- print_int pos;
- print_newline()
- end;
- reset_instr pos;
- Symbols.set_event_at_pc pos)
- pos
-
-(* Set all breakpoints. *)
-let set_breakpoints pos =
- if !debug_breakpoints then
- (print_string "Setting breakpoints..."; print_newline ());
- List.iter
- (function (pos, _) ->
- if !debug_breakpoints then begin
- print_int pos;
- print_newline()
- end;
- set_breakpoint pos)
- pos
-
-(* Ensure the current version in installed in current checkpoint. *)
-let update_breakpoints () =
- if !debug_breakpoints then begin
- prerr_string "Updating breakpoints... ";
- prerr_int !current_checkpoint.c_breakpoint_version;
- prerr_string " ";
- prerr_int !current_version;
- prerr_endline ""
- end;
- if !current_checkpoint.c_breakpoint_version <> !current_version then
- Exec.protect
- (function () ->
- remove_breakpoints !current_checkpoint.c_breakpoints;
- set_breakpoints !positions;
- copy_breakpoints ())
-
-let change_version version pos =
- Exec.protect
- (function () ->
- current_version := version;
- positions := pos)
-
-(* Execute given function with no breakpoint in current checkpoint. *)
-(* --- `goto' runs faster this way (does not stop on each breakpoint). *)
-let execute_without_breakpoints f =
- let version = !current_version
- and pos = !positions
- in
- change_version 0 [];
- try
- f ();
- change_version version pos
- with
- x ->
- change_version version pos
-
-(* Add a position in the position list. *)
-(* Change version if necessary. *)
-let insert_position pos =
- try
- incr (List.assoc pos !positions)
- with
- Not_found ->
- positions := (pos, ref 1) :: !positions;
- new_version ()
-
-(* Remove a position in the position list. *)
-(* Change version if necessary. *)
-let remove_position pos =
- let count = List.assoc pos !positions in
- decr count;
- if !count = 0 then begin
- positions := assoc_remove !positions pos;
- new_version ()
- end
-
-(* Insert a new breakpoint in lists. *)
-let rec new_breakpoint =
- function
- {ev_repr = Event_child pc} ->
- new_breakpoint (Symbols.any_event_at_pc !pc)
- | event ->
- Exec.protect
- (function () ->
- incr breakpoint_number;
- insert_position event.ev_pos;
- breakpoints := (!breakpoint_number, event) :: !breakpoints);
- printf "Breakpoint %d at %d : %s" !breakpoint_number event.ev_pos
- (Pos.get_desc event);
- print_newline ()
-
-(* Remove a breakpoint from lists. *)
-let remove_breakpoint number =
- try
- let pos = (List.assoc number !breakpoints).ev_pos in
- Exec.protect
- (function () ->
- breakpoints := assoc_remove !breakpoints number;
- remove_position pos)
- with
- Not_found ->
- prerr_endline ("No breakpoint number " ^ (string_of_int number) ^ ".");
- raise Not_found
-
-let remove_all_breakpoints () =
- List.iter (function (number, _) -> remove_breakpoint number) !breakpoints
-
-(*** Temporary breakpoints. ***)
-
-(* Temporary breakpoint position. *)
-let temporary_breakpoint_position = ref (None : int option)
-
-(* Execute `funct' with a breakpoint added at `pc'. *)
-(* --- Used by `finish'. *)
-let exec_with_temporary_breakpoint pc funct =
- let previous_version = !current_version in
- let remove () =
- temporary_breakpoint_position := None;
- current_version := previous_version;
- let count = List.assoc pc !positions in
- decr count;
- if !count = 0 then begin
- positions := assoc_remove !positions pc;
- reset_instr pc;
- Symbols.set_event_at_pc pc
- end
-
- in
- Exec.protect (function () -> insert_position pc);
- temporary_breakpoint_position := Some pc;
- try
- funct ();
- Exec.protect remove
- with
- x ->
- Exec.protect remove;
- raise x
diff --git a/debugger/breakpoints.mli b/debugger/breakpoints.mli
deleted file mode 100644
index 091f609981..0000000000
--- a/debugger/breakpoints.mli
+++ /dev/null
@@ -1,61 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(******************************* Breakpoints ***************************)
-
-open Primitives
-open Instruct
-
-(*** Debugging. ***)
-val debug_breakpoints : bool ref
-
-(*** Information about breakpoints. ***)
-
-val breakpoints_count : unit -> int
-
-(* Breakpoint number -> debug_event_kind. *)
-val breakpoints : (int * debug_event) list ref
-
-(* Is there a breakpoint at `pc' ? *)
-val breakpoint_at_pc : int -> bool
-
-(* List of breakpoints at `pc'. *)
-val breakpoints_at_pc : int -> int list
-
-(*** Set and remove breakpoints ***)
-
-(* Ensure the current version in installed in current checkpoint. *)
-val update_breakpoints : unit -> unit
-
-(* Execute given function with no breakpoint in current checkpoint. *)
-(* --- `goto' run faster so (does not stop on each breakpoint). *)
-val execute_without_breakpoints : (unit -> unit) -> unit
-
-(* Insert a new breakpoint in lists. *)
-val new_breakpoint : debug_event -> unit
-
-(* Remove a breakpoint from lists. *)
-val remove_breakpoint : int -> unit
-
-val remove_all_breakpoints : unit -> unit
-
-(*** Temporary breakpoints. ***)
-
-(* Temporary breakpoint position. *)
-val temporary_breakpoint_position : int option ref
-
-(* Execute `funct' with a breakpoint added at `pc'. *)
-(* --- Used by `finish'. *)
-val exec_with_temporary_breakpoint : int -> (unit -> unit) -> unit
diff --git a/debugger/checkpoints.ml b/debugger/checkpoints.ml
deleted file mode 100644
index ffcff35e36..0000000000
--- a/debugger/checkpoints.ml
+++ /dev/null
@@ -1,85 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(*************************** Checkpoints *******************************)
-
-open Int64ops
-open Debugcom
-open Primitives
-
-(*** A type for checkpoints. ***)
-
-type checkpoint_state =
- C_stopped
- | C_running of int64
-
-(* `c_valid' is true if and only if the corresponding
- * process is connected to the debugger.
- * `c_parent' is the checkpoint whose process is parent
- * of the checkpoint one (`root' if no parent).
- * c_pid = -2 for root pseudo-checkpoint.
- * c_pid = 0 for ghost checkpoints.
- * c_pid = -1 for kill checkpoints.
- *)
-type checkpoint = {
- mutable c_time : int64;
- mutable c_pid : int;
- mutable c_fd : io_channel;
- mutable c_valid : bool;
- mutable c_report : report option;
- mutable c_state : checkpoint_state;
- mutable c_parent : checkpoint;
- mutable c_breakpoint_version : int;
- mutable c_breakpoints : (int * int ref) list;
- mutable c_trap_barrier : int
- }
-
-(*** Pseudo-checkpoint `root'. ***)
-(* --- Parents of all checkpoints which have no parent. *)
-let rec root = {
- c_time = _0;
- c_pid = -2;
- c_fd = std_io;
- c_valid = false;
- c_report = None;
- c_state = C_stopped;
- c_parent = root;
- c_breakpoint_version = 0;
- c_breakpoints = [];
- c_trap_barrier = 0
- }
-
-(*** Current state ***)
-let checkpoints =
- ref ([] : checkpoint list)
-
-let current_checkpoint =
- ref root
-
-let current_time () =
- !current_checkpoint.c_time
-
-let current_report () =
- !current_checkpoint.c_report
-
-let current_pc () =
- match current_report () with
- None | Some {rep_type = Exited | Uncaught_exc} -> None
- | Some {rep_program_pointer = pc } -> Some pc
-
-let current_pc_sp () =
- match current_report () with
- None | Some {rep_type = Exited | Uncaught_exc} -> None
- | Some {rep_program_pointer = pc; rep_stack_pointer = sp } -> Some (pc, sp)
diff --git a/debugger/checkpoints.mli b/debugger/checkpoints.mli
deleted file mode 100644
index 17c1037aa2..0000000000
--- a/debugger/checkpoints.mli
+++ /dev/null
@@ -1,58 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(***************************** Checkpoints *****************************)
-
-open Primitives
-open Debugcom
-
-(*** A type for checkpoints. ***)
-
-type checkpoint_state =
- C_stopped
- | C_running of int64
-
-(* `c_valid' is true if and only if the corresponding
- * process is connected to the debugger.
- * `c_parent' is the checkpoint whose process is parent
- * of the checkpoint one (`root' if no parent).
- * c_pid = 2 for root pseudo-checkpoint.
- * c_pid = 0 for ghost checkpoints.
- * c_pid = -1 for kill checkpoints.
- *)
-type checkpoint =
- {mutable c_time : int64;
- mutable c_pid : int;
- mutable c_fd : io_channel;
- mutable c_valid : bool;
- mutable c_report : report option;
- mutable c_state : checkpoint_state;
- mutable c_parent : checkpoint;
- mutable c_breakpoint_version : int;
- mutable c_breakpoints : (int * int ref) list;
- mutable c_trap_barrier : int}
-
-(*** Pseudo-checkpoint `root'. ***)
-(* --- Parents of all checkpoints which have no parent. *)
-val root : checkpoint
-
-(*** Current state ***)
-val checkpoints : checkpoint list ref
-val current_checkpoint : checkpoint ref
-
-val current_time : unit -> int64
-val current_report : unit -> report option
-val current_pc : unit -> int option
-val current_pc_sp : unit -> (int * int) option
diff --git a/debugger/command_line.ml b/debugger/command_line.ml
deleted file mode 100644
index 7651b53f32..0000000000
--- a/debugger/command_line.ml
+++ /dev/null
@@ -1,1084 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(************************ Reading and executing commands ***************)
-
-open Int64ops
-open Format
-open Misc
-open Instruct
-open Unix
-open Debugger_config
-open Types
-open Primitives
-open Unix_tools
-open Parser
-open Parser_aux
-open Lexer
-open Input_handling
-open Debugcom
-open Program_loading
-open Program_management
-open Lexing
-open Parameters
-open Show_source
-open Show_information
-open Time_travel
-open Events
-open Symbols
-open Source
-open Breakpoints
-open Checkpoints
-open Frames
-open Printval
-
-(** Instructions, variables and infos lists. **)
-type dbg_instruction =
- { instr_name: string; (* Name of command *)
- instr_prio: bool; (* Has priority *)
- instr_action: formatter -> lexbuf -> unit;
- (* What to do *)
- instr_repeat: bool; (* Can be repeated *)
- instr_help: string } (* Help message *)
-
-let instruction_list = ref ([] : dbg_instruction list)
-
-type dbg_variable =
- { var_name: string; (* Name of variable *)
- var_action: (lexbuf -> unit) * (formatter -> unit);
- (* Reading, writing fns *)
- var_help: string } (* Help message *)
-
-let variable_list = ref ([] : dbg_variable list)
-
-type dbg_info =
- { info_name: string; (* Name of info *)
- info_action: lexbuf -> unit; (* What to do *)
- info_help: string } (* Help message *)
-
-let info_list = ref ([] : dbg_info list)
-
-(** Utilities. **)
-let error text =
- eprintf "%s@." text;
- raise Toplevel
-
-let eol =
- end_of_line Lexer.lexeme
-
-let matching_elements list name instr =
- filter (function a -> isprefix instr (name a)) !list
-
-let all_matching_instructions =
- matching_elements instruction_list (fun i -> i.instr_name)
-
-(* itz 04-21-96 don't do priority completion in emacs mode *)
-(* XL 25-02-97 why? I find it very confusing. *)
-
-let matching_instructions instr =
- let all = all_matching_instructions instr in
- let prio = filter (fun i -> i.instr_prio) all in
- if prio = [] then all else prio
-
-let matching_variables =
- matching_elements variable_list (fun v -> v.var_name)
-
-let matching_infos =
- matching_elements info_list (fun i -> i.info_name)
-
-let find_ident name matcher action alternative ppf lexbuf =
- match identifier_or_eol Lexer.lexeme lexbuf with
- | None -> alternative ppf
- | Some ident ->
- match matcher ident with
- | [] -> error ("Unknown " ^ name ^ ".")
- | [a] -> action a ppf lexbuf
- | _ -> error ("Ambiguous " ^ name ^ ".")
-
-let find_variable action alternative ppf lexbuf =
- find_ident "variable name" matching_variables action alternative ppf lexbuf
-
-let find_info action alternative ppf lexbuf =
- find_ident "info command" matching_infos action alternative ppf lexbuf
-
-let add_breakpoint_at_pc pc =
- try
- new_breakpoint (any_event_at_pc pc)
- with
- | Not_found ->
- eprintf "Can't add breakpoint at pc %i : no event there.@." pc;
- raise Toplevel
-
-let add_breakpoint_after_pc pc =
- let rec try_add n =
- if n < 3 then begin
- try
- new_breakpoint (any_event_at_pc (pc + n * 4))
- with
- | Not_found ->
- try_add (n+1)
- end else begin
- error
- "Can't add breakpoint at beginning of function: no event there"
- end
- in try_add 0
-
-let convert_module mdle =
- match mdle with
- | Some m ->
- (* Strip .ml extension if any, and capitalize *)
- String.capitalize(if Filename.check_suffix m ".ml"
- then Filename.chop_suffix m ".ml"
- else m)
- | None ->
- try
- let (x, _) = current_point () in x
- with
- | Not_found ->
- error "Not in a module."
-
-(** Toplevel. **)
-let current_line = ref ""
-
-let interprete_line ppf line =
- current_line := line;
- let lexbuf = Lexing.from_string line in
- try
- match identifier_or_eol Lexer.lexeme lexbuf with
- | Some x ->
- begin match matching_instructions x with
- | [] ->
- error "Unknown command."
- | [i] ->
- i.instr_action ppf lexbuf;
- resume_user_input ();
- i.instr_repeat
- | l ->
- error "Ambiguous command."
- end
- | None ->
- resume_user_input ();
- false
- with
- | Parsing.Parse_error ->
- error "Syntax error."
-
-let line_loop ppf line_buffer =
- resume_user_input ();
- let previous_line = ref "" in
- try
- while true do
- if !loaded then
- History.add_current_time ();
- let new_line = string_trim (line line_buffer) in
- let line =
- if new_line <> "" then
- new_line
- else
- !previous_line
- in
- previous_line := "";
- if interprete_line ppf line then
- previous_line := line
- done
- with
- | Exit ->
- stop_user_input ()
- | Sys_error s ->
- error ("System error : " ^ s)
-
-(** Instructions. **)
-let instr_cd ppf lexbuf =
- let dir = argument_eol argument lexbuf in
- if ask_kill_program () then
- try
- Sys.chdir (expand_path dir)
- with
- | Sys_error s ->
- error s
-
-let instr_shell ppf lexbuf =
- let cmdarg = argument_list_eol argument lexbuf in
- let cmd = String.concat " " cmdarg in
- (* perhaps we should use $SHELL -c ? *)
- let err = Sys.command cmd in
- if (err != 0) then
- eprintf "Shell command %S failed with exit code %d\n%!" cmd err
-
-let instr_pwd ppf lexbuf =
- eol lexbuf;
- ignore(system "/bin/pwd")
-
-let instr_dir ppf lexbuf =
- let new_directory = argument_list_eol argument lexbuf in
- if new_directory = [] then begin
- if yes_or_no "Reinitialize directory list" then begin
- Config.load_path := !default_load_path;
- Envaux.reset_cache ();
- flush_buffer_list ()
- end
- end
- else
- List.iter (function x -> add_path (expand_path x))
- (List.rev new_directory);
- let print_dirs ppf l = List.iter (function x -> fprintf ppf "@ %s" x) l in
- fprintf ppf "@[<2>Directories :%a@]@." print_dirs !Config.load_path
-
-let instr_kill ppf lexbuf =
- eol lexbuf;
- if not !loaded then error "The program is not being run.";
- if (yes_or_no "Kill the program being debugged") then begin
- kill_program ();
- show_no_point()
- end
-
-let instr_run ppf lexbuf =
- eol lexbuf;
- ensure_loaded ();
- reset_named_values ();
- run ();
- show_current_event ppf;;
-
-let instr_reverse ppf lexbuf =
- eol lexbuf;
- ensure_loaded ();
- reset_named_values();
- back_run ();
- show_current_event ppf
-
-let instr_step ppf lexbuf =
- let step_count =
- match opt_signed_int64_eol Lexer.lexeme lexbuf with
- | None -> _1
- | Some x -> x
- in
- ensure_loaded ();
- reset_named_values();
- step step_count;
- show_current_event ppf
-
-let instr_back ppf lexbuf =
- let step_count =
- match opt_signed_int64_eol Lexer.lexeme lexbuf with
- | None -> _1
- | Some x -> x
- in
- ensure_loaded ();
- reset_named_values();
- step (_0 -- step_count);
- show_current_event ppf
-
-let instr_finish ppf lexbuf =
- eol lexbuf;
- ensure_loaded ();
- reset_named_values();
- finish ();
- show_current_event ppf
-
-let instr_next ppf lexbuf =
- let step_count =
- match opt_integer_eol Lexer.lexeme lexbuf with
- | None -> 1
- | Some x -> x
- in
- ensure_loaded ();
- reset_named_values();
- next step_count;
- show_current_event ppf
-
-let instr_start ppf lexbuf =
- eol lexbuf;
- ensure_loaded ();
- reset_named_values();
- start ();
- show_current_event ppf
-
-let instr_previous ppf lexbuf =
- let step_count =
- match opt_integer_eol Lexer.lexeme lexbuf with
- | None -> 1
- | Some x -> x
- in
- ensure_loaded ();
- reset_named_values();
- previous step_count;
- show_current_event ppf
-
-let instr_goto ppf lexbuf =
- let time = int64_eol Lexer.lexeme lexbuf in
- ensure_loaded ();
- reset_named_values();
- go_to time;
- show_current_event ppf
-
-let instr_quit _ =
- raise Exit
-
-let print_variable_list ppf =
- let pr_vars ppf = List.iter (fun v -> fprintf ppf "%s@ " v.var_name) in
- fprintf ppf "List of variables :%a@." pr_vars !variable_list
-
-let print_info_list ppf =
- let pr_infos ppf = List.iter (fun i -> fprintf ppf "%s@ " i.info_name) in
- fprintf ppf "List of info commands :%a@." pr_infos !info_list
-
-let instr_complete ppf lexbuf =
- let ppf = Format.err_formatter in
- let rec print_list l =
- try
- eol lexbuf;
- List.iter (function i -> fprintf ppf "%s@." i) l
- with _ ->
- remove_file !user_channel
- and match_list lexbuf =
- match identifier_or_eol Lexer.lexeme lexbuf with
- | None ->
- List.map (fun i -> i.instr_name) !instruction_list
- | Some x ->
- match matching_instructions x with
- | [ {instr_name = ("set" | "show" as i_full)} ] ->
- if x = i_full then begin
- match identifier_or_eol Lexer.lexeme lexbuf with
- | Some ident ->
- begin match matching_variables ident with
- | [v] -> if v.var_name = ident then [] else [v.var_name]
- | l -> List.map (fun v -> v.var_name) l
- end
- | None ->
- List.map (fun v -> v.var_name) !variable_list
- end
- else [i_full]
- | [ {instr_name = "info"} ] ->
- if x = "info" then begin
- match identifier_or_eol Lexer.lexeme lexbuf with
- | Some ident ->
- begin match matching_infos ident with
- | [i] -> if i.info_name = ident then [] else [i.info_name]
- | l -> List.map (fun i -> i.info_name) l
- end
- | None ->
- List.map (fun i -> i.info_name) !info_list
- end
- else ["info"]
- | [ {instr_name = "help"} ] ->
- if x = "help" then match_list lexbuf else ["help"]
- | [ i ] ->
- if x = i.instr_name then [] else [i.instr_name]
- | l ->
- List.map (fun i -> i.instr_name) l
- in
- print_list(match_list lexbuf)
-
-let instr_help ppf lexbuf =
- let pr_instrs ppf =
- List.iter (fun i -> fprintf ppf "%s@ " i.instr_name) in
- match identifier_or_eol Lexer.lexeme lexbuf with
- | Some x ->
- let print_help nm hlp =
- eol lexbuf;
- fprintf ppf "%s : %s@." nm hlp in
- begin match matching_instructions x with
- | [] ->
- eol lexbuf;
- fprintf ppf "No matching command.@."
- | [ {instr_name = "set"} ] ->
- find_variable
- (fun v _ _ ->
- print_help ("set " ^ v.var_name) ("set " ^ v.var_help))
- (fun ppf ->
- print_help "set" "set debugger variable.";
- print_variable_list ppf)
- ppf
- lexbuf
- | [ {instr_name = "show"} ] ->
- find_variable
- (fun v _ _ ->
- print_help ("show " ^ v.var_name) ("show " ^ v.var_help))
- (fun v ->
- print_help "show" "display debugger variable.";
- print_variable_list ppf)
- ppf
- lexbuf
- | [ {instr_name = "info"} ] ->
- find_info
- (fun i _ _ -> print_help ("info " ^ i.info_name) i.info_help)
- (fun ppf ->
- print_help "info"
- "display infos about the program being debugged.";
- print_info_list ppf)
- ppf
- lexbuf
- | [i] ->
- print_help i.instr_name i.instr_help
- | l ->
- eol lexbuf;
- fprintf ppf "Ambiguous command \"%s\" : %a@." x pr_instrs l
- end
- | None ->
- fprintf ppf "List of commands :%a@." pr_instrs !instruction_list
-
-(* Printing values *)
-
-let print_expr depth ev env ppf expr =
- try
- let (v, ty) = Eval.expression ev env expr in
- print_named_value depth expr env v ppf ty
- with
- | Eval.Error msg ->
- Eval.report_error ppf msg;
- raise Toplevel
-
-let print_command depth ppf lexbuf =
- let exprs = expression_list_eol Lexer.lexeme lexbuf in
- ensure_loaded ();
- let env =
- try
- Envaux.env_of_event !selected_event
- with
- | Envaux.Error msg ->
- Envaux.report_error ppf msg;
- raise Toplevel
- in
- List.iter (print_expr depth !selected_event env ppf) exprs
-
-let instr_print ppf lexbuf = print_command !max_printer_depth ppf lexbuf
-
-let instr_display ppf lexbuf = print_command 1 ppf lexbuf
-
-(* Loading of command files *)
-
-let extract_filename arg =
- (* Allow enclosing filename in quotes *)
- let l = String.length arg in
- let pos1 = if l > 0 && arg.[0] = '"' then 1 else 0 in
- let pos2 = if l > 0 && arg.[l-1] = '"' then l-1 else l in
- String.sub arg pos1 (pos2 - pos1)
-
-let instr_source ppf lexbuf =
- let file = extract_filename(argument_eol argument lexbuf)
- and old_state = !interactif
- and old_channel = !user_channel in
- let io_chan =
- try
- io_channel_of_descr
- (openfile (find_in_path !Config.load_path (expand_path file))
- [O_RDONLY] 0)
- with
- | Not_found -> error "Source file not found."
- | (Unix_error _) as x -> Unix_tools.report_error x; raise Toplevel
- in
- try
- interactif := false;
- user_channel := io_chan;
- line_loop ppf (Lexing.from_function read_user_input);
- close_io io_chan;
- interactif := old_state;
- user_channel := old_channel
- with
- | x ->
- stop_user_input ();
- close_io io_chan;
- interactif := old_state;
- user_channel := old_channel;
- raise x
-
-let instr_set =
- find_variable
- (fun {var_action = (funct, _)} ppf lexbuf -> funct lexbuf)
- (function ppf -> error "Argument required.")
-
-let instr_show =
- find_variable
- (fun {var_action = (_, funct)} ppf lexbuf -> eol lexbuf; funct ppf)
- (function ppf ->
- List.iter
- (function {var_name = nm; var_action = (_, funct)} ->
- fprintf ppf "%s : " nm;
- funct ppf)
- !variable_list)
-
-let instr_info =
- find_info
- (fun i ppf lexbuf -> i.info_action lexbuf)
- (function ppf ->
- error "\"info\" must be followed by the name of an info command.")
-
-let instr_break ppf lexbuf =
- let argument = break_argument_eol Lexer.lexeme lexbuf in
- ensure_loaded ();
- match argument with
- | BA_none -> (* break *)
- (match !selected_event with
- | Some ev ->
- new_breakpoint ev
- | None ->
- error "Can't add breakpoint at this point.")
- | BA_pc pc -> (* break PC *)
- add_breakpoint_at_pc pc
- | BA_function expr -> (* break FUNCTION *)
- let env =
- try
- Envaux.env_of_event !selected_event
- with
- | Envaux.Error msg ->
- Envaux.report_error ppf msg;
- raise Toplevel
- in
- begin try
- let (v, ty) = Eval.expression !selected_event env expr in
- match (Ctype.repr ty).desc with
- | Tarrow _ ->
- add_breakpoint_after_pc (Remote_value.closure_code v)
- | _ ->
- eprintf "Not a function.@.";
- raise Toplevel
- with
- | Eval.Error msg ->
- Eval.report_error ppf msg;
- raise Toplevel
- end
- | BA_pos1 (mdle, line, column) -> (* break @ [MODULE] LINE [COL] *)
- let module_name = convert_module mdle in
- new_breakpoint
- (try
- let buffer =
- try get_buffer module_name with
- | Not_found ->
- eprintf "No source file for %s.@." module_name;
- raise Toplevel
- in
- match column with
- | None ->
- event_at_pos module_name (fst (pos_of_line buffer line))
- | Some col ->
- event_near_pos module_name (point_of_coord buffer line col)
- with
- | Not_found -> (* event_at_pos / event_near pos *)
- eprintf "Can't find any event there.@.";
- raise Toplevel
- | Out_of_range -> (* pos_of_line / point_of_coord *)
- eprintf "Position out of range.@.";
- raise Toplevel)
- | BA_pos2 (mdle, position) -> (* break @ [MODULE] # POSITION *)
- try
- new_breakpoint (event_near_pos (convert_module mdle) position)
- with
- | Not_found ->
- eprintf "Can't find any event there.@."
-
-let instr_delete ppf lexbuf =
- match integer_list_eol Lexer.lexeme lexbuf with
- | [] ->
- if breakpoints_count () <> 0 && yes_or_no "Delete all breakpoints"
- then remove_all_breakpoints ()
- | breakpoints ->
- List.iter
- (function x -> try remove_breakpoint x with | Not_found -> ())
- breakpoints
-
-let instr_frame ppf lexbuf =
- let frame_number =
- match opt_integer_eol Lexer.lexeme lexbuf with
- | None -> !current_frame
- | Some x -> x
- in
- ensure_loaded ();
- try
- select_frame frame_number;
- show_current_frame ppf true
- with
- | Not_found ->
- error ("No frame number " ^ string_of_int frame_number ^ ".")
-
-let instr_backtrace ppf lexbuf =
- let number =
- match opt_signed_integer_eol Lexer.lexeme lexbuf with
- | None -> 0
- | Some x -> x in
- ensure_loaded ();
- match current_report() with
- | None | Some {rep_type = Exited | Uncaught_exc} -> ()
- | Some _ ->
- let frame_counter = ref 0 in
- let print_frame first_frame last_frame = function
- | None ->
- fprintf ppf
- "(Encountered a function with no debugging information)@.";
- false
- | Some event ->
- if !frame_counter >= first_frame then
- show_one_frame !frame_counter ppf event;
- incr frame_counter;
- if !frame_counter >= last_frame then begin
- fprintf ppf "(More frames follow)@."
- end;
- !frame_counter < last_frame in
- if number = 0 then
- do_backtrace (print_frame 0 max_int)
- else if number > 0 then
- do_backtrace (print_frame 0 number)
- else begin
- let num_frames = stack_depth() in
- if num_frames < 0 then begin
- fprintf ppf
- "(Encountered a function with no debugging information)";
- print_newline()
- end else
- do_backtrace (print_frame (num_frames + number) max_int)
- end
-
-let instr_up ppf lexbuf =
- let offset =
- match opt_signed_integer_eol Lexer.lexeme lexbuf with
- | None -> 1
- | Some x -> x
- in
- ensure_loaded ();
- try
- select_frame (!current_frame + offset);
- show_current_frame ppf true
- with
- | Not_found -> error "No such frame."
-
-let instr_down ppf lexbuf =
- let offset =
- match opt_signed_integer_eol Lexer.lexeme lexbuf with
- | None -> 1
- | Some x -> x
- in
- ensure_loaded ();
- try
- select_frame (!current_frame - offset);
- show_current_frame ppf true
- with
- | Not_found -> error "No such frame."
-
-let instr_last ppf lexbuf =
- let count =
- match opt_signed_int64_eol Lexer.lexeme lexbuf with
- | None -> _1
- | Some x -> x
- in
- reset_named_values();
- go_to (History.previous_time count);
- show_current_event ppf
-
-let instr_list ppf lexbuf =
- let (mo, beg, e) = list_arguments_eol Lexer.lexeme lexbuf in
- let (curr_mod, point) =
- try
- selected_point ()
- with
- | Not_found ->
- ("", -1)
- in
- let mdle = convert_module mo in
- let beginning =
- match beg with
- | None when (mo <> None) || (point = -1) ->
- 1
- | None ->
- let buffer =
- try get_buffer mdle with
- | Not_found -> error ("No source file for " ^ mdle ^ ".")
- in
- begin try
- max 1 ((snd (line_of_pos buffer point)) - 10)
- with Out_of_range ->
- 1
- end
- | Some x -> x
- in
- let en =
- match e with
- | None -> beginning + 20
- | Some x -> x
- in
- if mdle = curr_mod then
- show_listing mdle beginning en point
- (current_event_is_before ())
- else
- show_listing mdle beginning en (-1) true
-
-(** Variables. **)
-let raw_variable kill name =
- (function lexbuf ->
- let argument = argument_eol argument lexbuf in
- if (not kill) || ask_kill_program () then name := argument),
- function ppf -> fprintf ppf "%s@." !name
-
-let raw_line_variable kill name =
- (function lexbuf ->
- let argument = argument_eol line_argument lexbuf in
- if (not kill) || ask_kill_program () then name := argument),
- function ppf -> fprintf ppf "%s@." !name
-
-let integer_variable kill min msg name =
- (function lexbuf ->
- let argument = integer_eol Lexer.lexeme lexbuf in
- if argument < min then print_endline msg
- else if (not kill) || ask_kill_program () then name := argument),
- function ppf -> fprintf ppf "%i@." !name
-
-let int64_variable kill min msg name =
- (function lexbuf ->
- let argument = int64_eol Lexer.lexeme lexbuf in
- if argument < min then print_endline msg
- else if (not kill) || ask_kill_program () then name := argument),
- function ppf -> fprintf ppf "%Li@." !name
-
-let boolean_variable kill name =
- (function lexbuf ->
- let argument =
- match identifier_eol Lexer.lexeme lexbuf with
- | "on" -> true
- | "of" | "off" -> false
- | _ -> error "Syntax error."
- in
- if (not kill) || ask_kill_program () then name := argument),
- function ppf -> fprintf ppf "%s@." (if !name then "on" else "off")
-
-let path_variable kill name =
- (function lexbuf ->
- let argument = argument_eol argument lexbuf in
- if (not kill) || ask_kill_program () then
- name := make_absolute (expand_path argument)),
- function ppf -> fprintf ppf "%s@." !name
-
-let loading_mode_variable ppf =
- (find_ident
- "loading mode"
- (matching_elements (ref loading_modes) fst)
- (fun (_, mode) ppf lexbuf ->
- eol lexbuf; set_launching_function mode)
- (function ppf -> error "Syntax error.")
- ppf),
- function ppf ->
- let rec find = function
- | [] -> ()
- | (name, funct) :: l ->
- if funct == !launching_func then fprintf ppf "%s" name else find l
- in
- find loading_modes;
- fprintf ppf "@."
-
-(** Infos. **)
-
-let pr_modules ppf mods =
- let pr_mods ppf = List.iter (function x -> fprintf ppf "%s@ " x) in
- fprintf ppf "Used modules :@.%a@?" pr_mods mods
-
-let info_modules ppf lexbuf =
- eol lexbuf;
- ensure_loaded ();
- pr_modules ppf !modules
-(********
- print_endline "Opened modules :";
- if !opened_modules_names = [] then
- print_endline "(no module opened)."
- else
- (List.iter (function x -> print_string x; print_space) !opened_modules_names;
- print_newline ())
-*********)
-
-let info_checkpoints ppf lexbuf =
- eol lexbuf;
- if !checkpoints = [] then fprintf ppf "No checkpoint.@."
- else
- (if !debug_breakpoints then
- (prerr_endline " Time Pid Version";
- List.iter
- (function
- {c_time = time; c_pid = pid; c_breakpoint_version = version} ->
- Printf.printf "%19Ld %5d %d\n" time pid version)
- !checkpoints)
- else
- (print_endline " Time Pid";
- List.iter
- (function
- {c_time = time; c_pid = pid} ->
- Printf.printf "%19Ld %5d\n" time pid)
- !checkpoints))
-
-let info_one_breakpoint ppf (num, ev) =
- fprintf ppf "%3d %10d %s@." num ev.ev_pos (Pos.get_desc ev);
-;;
-
-let info_breakpoints ppf lexbuf =
- eol lexbuf;
- if !breakpoints = [] then fprintf ppf "No breakpoints.@."
- else begin
- fprintf ppf "Num Address Where@.";
- List.iter (info_one_breakpoint ppf) (List.rev !breakpoints);
- end
-;;
-
-let info_events ppf lexbuf =
- ensure_loaded ();
- let mdle = convert_module (opt_identifier_eol Lexer.lexeme lexbuf) in
- print_endline ("Module : " ^ mdle);
- print_endline " Address Character Kind Repr.";
- List.iter
- (function ev ->
- Printf.printf
- "%10d %10d %10s %10s\n"
- ev.ev_pos
- ev.ev_char.Lexing.pos_cnum
- ((match ev.ev_kind with
- Event_before -> "before"
- | Event_after _ -> "after"
- | Event_pseudo -> "pseudo")
- ^
- (match ev.ev_info with
- Event_function -> "/fun"
- | Event_return _ -> "/ret"
- | Event_other -> ""))
- (match ev.ev_repr with
- Event_none -> ""
- | Event_parent _ -> "(repr)"
- | Event_child repr -> string_of_int !repr))
- (events_in_module mdle)
-
-(** User-defined printers **)
-
-let instr_load_printer ppf lexbuf =
- let filename = extract_filename(argument_eol argument lexbuf) in
- try
- Loadprinter.loadfile ppf filename
- with Loadprinter.Error e ->
- Loadprinter.report_error ppf e; raise Toplevel
-
-let instr_install_printer ppf lexbuf =
- let lid = longident_eol Lexer.lexeme lexbuf in
- try
- Loadprinter.install_printer ppf lid
- with Loadprinter.Error e ->
- Loadprinter.report_error ppf e; raise Toplevel
-
-let instr_remove_printer ppf lexbuf =
- let lid = longident_eol Lexer.lexeme lexbuf in
- try
- Loadprinter.remove_printer lid
- with Loadprinter.Error e ->
- Loadprinter.report_error ppf e; raise Toplevel
-
-(** Initialization. **)
-let init ppf =
- instruction_list := [
- { instr_name = "cd"; instr_prio = false;
- instr_action = instr_cd; instr_repeat = true; instr_help =
-"set working directory to DIR for debugger and program being debugged." };
- { instr_name = "complete"; instr_prio = false;
- instr_action = instr_complete; instr_repeat = false; instr_help =
-"complete word at cursor according to context. Useful for Emacs." };
- { instr_name = "pwd"; instr_prio = false;
- instr_action = instr_pwd; instr_repeat = true; instr_help =
-"print working directory." };
- { instr_name = "directory"; instr_prio = false;
- instr_action = instr_dir; instr_repeat = false; instr_help =
-"add directory DIR to beginning of search path for source and\n\
-interface files.\n\
-Forget cached info on source file locations and line positions.\n\
-With no argument, reset the search path." };
- { instr_name = "kill"; instr_prio = false;
- instr_action = instr_kill; instr_repeat = true; instr_help =
-"kill the program being debugged." };
- { instr_name = "help"; instr_prio = false;
- instr_action = instr_help; instr_repeat = true; instr_help =
-"print list of commands." };
- { instr_name = "quit"; instr_prio = false;
- instr_action = instr_quit; instr_repeat = false; instr_help =
-"exit the debugger." };
- { instr_name = "shell"; instr_prio = false;
- instr_action = instr_shell; instr_repeat = true; instr_help =
-"Execute a given COMMAND thru the system shell." };
- (* Displacements *)
- { instr_name = "run"; instr_prio = true;
- instr_action = instr_run; instr_repeat = true; instr_help =
-"run the program from current position." };
- { instr_name = "reverse"; instr_prio = false;
- instr_action = instr_reverse; instr_repeat = true; instr_help =
-"run the program backward from current position." };
- { instr_name = "step"; instr_prio = true;
- instr_action = instr_step; instr_repeat = true; instr_help =
-"step program until it reaches the next event.\n\
-Argument N means do this N times (or till program stops for another reason)." };
- { instr_name = "backstep"; instr_prio = true;
- instr_action = instr_back; instr_repeat = true; instr_help =
-"step program backward until it reaches the previous event.\n\
-Argument N means do this N times (or till program stops for another reason)." };
- { instr_name = "goto"; instr_prio = false;
- instr_action = instr_goto; instr_repeat = true; instr_help =
-"go to the given time." };
- { instr_name = "finish"; instr_prio = true;
- instr_action = instr_finish; instr_repeat = true; instr_help =
-"execute until topmost stack frame returns." };
- { instr_name = "next"; instr_prio = true;
- instr_action = instr_next; instr_repeat = true; instr_help =
-"step program until it reaches the next event.\n\
-Skip over function calls.\n\
-Argument N means do this N times (or till program stops for another reason)." };
- { instr_name = "start"; instr_prio = false;
- instr_action = instr_start; instr_repeat = true; instr_help =
-"execute backward until the current function is exited." };
- { instr_name = "previous"; instr_prio = false;
- instr_action = instr_previous; instr_repeat = true; instr_help =
-"step program until it reaches the previous event.\n\
-Skip over function calls.\n\
-Argument N means do this N times (or till program stops for another reason)." };
- { instr_name = "print"; instr_prio = true;
- instr_action = instr_print; instr_repeat = true; instr_help =
-"print value of expressions (deep printing)." };
- { instr_name = "display"; instr_prio = true;
- instr_action = instr_display; instr_repeat = true; instr_help =
-"print value of expressions (shallow printing)." };
- { instr_name = "source"; instr_prio = false;
- instr_action = instr_source; instr_repeat = true; instr_help =
-"read command from file FILE." };
- (* Breakpoints *)
- { instr_name = "break"; instr_prio = false;
- instr_action = instr_break; instr_repeat = false; instr_help =
-"Set breakpoint at specified line or function.\n\
-Syntax: break function-name\n\
- break @ [module] linenum\n\
- break @ [module] # characternum" };
- { instr_name = "delete"; instr_prio = false;
- instr_action = instr_delete; instr_repeat = false; instr_help =
-"delete some breakpoints.\n\
-Arguments are breakpoint numbers with spaces in between.\n\
-To delete all breakpoints, give no argument." };
- { instr_name = "set"; instr_prio = false;
- instr_action = instr_set; instr_repeat = false; instr_help =
-"--unused--" };
- { instr_name = "show"; instr_prio = false;
- instr_action = instr_show; instr_repeat = true; instr_help =
-"--unused--" };
- { instr_name = "info"; instr_prio = false;
- instr_action = instr_info; instr_repeat = true; instr_help =
-"--unused--" };
- (* Frames *)
- { instr_name = "frame"; instr_prio = false;
- instr_action = instr_frame; instr_repeat = true; instr_help =
-"select and print a stack frame.\n\
-With no argument, print the selected stack frame.\n\
-An argument specifies the frame to select." };
- { instr_name = "backtrace"; instr_prio = false;
- instr_action = instr_backtrace; instr_repeat = true; instr_help =
-"print backtrace of all stack frames, or innermost COUNT frames.\n\
-With a negative argument, print outermost -COUNT frames." };
- { instr_name = "bt"; instr_prio = false;
- instr_action = instr_backtrace; instr_repeat = true; instr_help =
-"print backtrace of all stack frames, or innermost COUNT frames.\n\
-With a negative argument, print outermost -COUNT frames." };
- { instr_name = "up"; instr_prio = false;
- instr_action = instr_up; instr_repeat = true; instr_help =
-"select and print stack frame that called this one.\n\
-An argument says how many frames up to go." };
- { instr_name = "down"; instr_prio = false;
- instr_action = instr_down; instr_repeat = true; instr_help =
-"select and print stack frame called by this one.\n\
-An argument says how many frames down to go." };
- { instr_name = "last"; instr_prio = true;
- instr_action = instr_last; instr_repeat = true; instr_help =
-"go back to previous time." };
- { instr_name = "list"; instr_prio = false;
- instr_action = instr_list; instr_repeat = true; instr_help =
-"list the source code." };
- (* User-defined printers *)
- { instr_name = "load_printer"; instr_prio = false;
- instr_action = instr_load_printer; instr_repeat = false; instr_help =
-"load in the debugger a .cmo or .cma file containing printing functions." };
- { instr_name = "install_printer"; instr_prio = false;
- instr_action = instr_install_printer; instr_repeat = false; instr_help =
-"use the given function for printing values of its input type.\n\
-The code for the function must have previously been loaded in the debugger\n\
-using \"load_printer\"." };
- { instr_name = "remove_printer"; instr_prio = false;
- instr_action = instr_remove_printer; instr_repeat = false; instr_help =
-"stop using the given function for printing values of its input type." }
-];
- variable_list := [
- (* variable name, (writing, reading), help reading, help writing *)
- { var_name = "arguments";
- var_action = raw_line_variable true arguments;
- var_help =
-"arguments to give program being debugged when it is started." };
- { var_name = "program";
- var_action = path_variable true program_name;
- var_help =
-"name of program to be debugged." };
- { var_name = "loadingmode";
- var_action = loading_mode_variable ppf;
- var_help =
-"mode of loading.\n\
-It can be either :
- direct : the program is directly called by the debugger.\n\
- runtime : the debugger execute `ocamlrun programname arguments'.\n\
- manual : the program is not launched by the debugger,\n\
- but manually by the user." };
- { var_name = "processcount";
- var_action = integer_variable false 1 "Must be >= 1."
- checkpoint_max_count;
- var_help =
-"maximum number of process to keep." };
- { var_name = "checkpoints";
- var_action = boolean_variable false make_checkpoints;
- var_help =
-"whether to make checkpoints or not." };
- { var_name = "bigstep";
- var_action = int64_variable false _1 "Must be >= 1."
- checkpoint_big_step;
- var_help =
-"step between checkpoints during long displacements." };
- { var_name = "smallstep";
- var_action = int64_variable false _1 "Must be >= 1."
- checkpoint_small_step;
- var_help =
-"step between checkpoints during small displacements." };
- { var_name = "socket";
- var_action = raw_variable true socket_name;
- var_help =
-"name of the socket used by communications debugger-runtime." };
- { var_name = "history";
- var_action = integer_variable false 0 "" history_size;
- var_help =
-"history size." };
- { var_name = "print_depth";
- var_action = integer_variable false 1 "Must be at least 1"
- max_printer_depth;
- var_help =
-"maximal depth for printing of values." };
- { var_name = "print_length";
- var_action = integer_variable false 1 "Must be at least 1"
- max_printer_steps;
- var_help =
-"maximal number of value nodes printed." }];
-
- info_list :=
- (* info name, function, help *)
- [{ info_name = "modules";
- info_action = info_modules ppf;
- info_help = "list opened modules." };
- { info_name = "checkpoints";
- info_action = info_checkpoints ppf;
- info_help = "list checkpoints." };
- { info_name = "breakpoints";
- info_action = info_breakpoints ppf;
- info_help = "list breakpoints." };
- { info_name = "events";
- info_action = info_events ppf;
- info_help = "list events in MODULE (default is current module)." }]
-
-let _ = init std_formatter
diff --git a/debugger/command_line.mli b/debugger/command_line.mli
deleted file mode 100644
index dd2349d2c4..0000000000
--- a/debugger/command_line.mli
+++ /dev/null
@@ -1,22 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(************************ Reading and executing commands ***************)
-
-open Lexing;;
-open Format;;
-
-val interprete_line : formatter -> string -> bool;;
-val line_loop : formatter -> lexbuf -> unit;;
diff --git a/debugger/debugcom.ml b/debugger/debugcom.ml
deleted file mode 100644
index edec454727..0000000000
--- a/debugger/debugcom.ml
+++ /dev/null
@@ -1,278 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Low-level communication with the debuggee *)
-
-open Int64ops
-open Primitives
-
-(* The current connection with the debuggee *)
-
-let conn = ref Primitives.std_io
-
-let set_current_connection io_chan =
- conn := io_chan
-
-(* Modify the program code *)
-
-let set_event pos =
- output_char !conn.io_out 'e';
- output_binary_int !conn.io_out pos
-
-let set_breakpoint pos =
- output_char !conn.io_out 'B';
- output_binary_int !conn.io_out pos
-
-let reset_instr pos =
- output_char !conn.io_out 'i';
- output_binary_int !conn.io_out pos
-
-(* Basic commands for flow control *)
-
-type execution_summary =
- Event
- | Breakpoint
- | Exited
- | Trap_barrier
- | Uncaught_exc
-
-type report = {
- rep_type : execution_summary;
- rep_event_count : int;
- rep_stack_pointer : int;
- rep_program_pointer : int
-}
-
-type checkpoint_report =
- Checkpoint_done of int
- | Checkpoint_failed
-
-(* Run the debuggee for N events *)
-
-let do_go_smallint n =
- output_char !conn.io_out 'g';
- output_binary_int !conn.io_out n;
- flush !conn.io_out;
- Input_handling.execute_with_other_controller
- Input_handling.exit_main_loop
- !conn
- (function () ->
- Input_handling.main_loop ();
- let summary =
- match input_char !conn.io_in with
- 'e' -> Event
- | 'b' -> Breakpoint
- | 'x' -> Exited
- | 's' -> Trap_barrier
- | 'u' -> Uncaught_exc
- | _ -> Misc.fatal_error "Debugcom.do_go" in
- let event_counter = input_binary_int !conn.io_in in
- let stack_pos = input_binary_int !conn.io_in in
- let pc = input_binary_int !conn.io_in in
- { rep_type = summary;
- rep_event_count = event_counter;
- rep_stack_pointer = stack_pos;
- rep_program_pointer = pc })
-
-let rec do_go n =
- assert (n >= _0);
- if n > max_small_int then(
- ignore (do_go_smallint max_int);
- do_go (n -- max_small_int)
- )else(
- do_go_smallint (Int64.to_int n)
- )
-;;
-
-(* Perform a checkpoint *)
-
-let do_checkpoint () =
- output_char !conn.io_out 'c';
- flush !conn.io_out;
- let pid = input_binary_int !conn.io_in in
- if pid = -1 then Checkpoint_failed else Checkpoint_done pid
-
-(* Kill the given process. *)
-let stop chan =
- try
- output_char chan.io_out 's';
- flush chan.io_out
- with
- Sys_error _ | End_of_file -> ()
-
-(* Ask a process to wait for its child which has been killed. *)
-(* (so as to eliminate zombies). *)
-let wait_child chan =
- try
- output_char chan.io_out 'w'
- with
- Sys_error _ | End_of_file -> ()
-
-(* Move to initial frame (that of current function). *)
-(* Return stack position and current pc *)
-
-let initial_frame () =
- output_char !conn.io_out '0';
- flush !conn.io_out;
- let stack_pos = input_binary_int !conn.io_in in
- let pc = input_binary_int !conn.io_in in
- (stack_pos, pc)
-
-let set_initial_frame () =
- ignore(initial_frame ())
-
-(* Move up one frame *)
-(* Return stack position and current pc.
- If there's no frame above, return (-1, 0). *)
-
-let up_frame stacksize =
- output_char !conn.io_out 'U';
- output_binary_int !conn.io_out stacksize;
- flush !conn.io_out;
- let stack_pos = input_binary_int !conn.io_in in
- let pc = if stack_pos = -1 then 0 else input_binary_int !conn.io_in in
- (stack_pos, pc)
-
-(* Get and set the current frame position *)
-
-let get_frame () =
- output_char !conn.io_out 'f';
- flush !conn.io_out;
- let stack_pos = input_binary_int !conn.io_in in
- let pc = input_binary_int !conn.io_in in
- (stack_pos, pc)
-
-let set_frame stack_pos =
- output_char !conn.io_out 'S';
- output_binary_int !conn.io_out stack_pos
-
-(* Set the trap barrier to given stack position. *)
-
-let set_trap_barrier pos =
- output_char !conn.io_out 'b';
- output_binary_int !conn.io_out pos
-
-(* Handling of remote values *)
-
-let value_size = if 1 lsl 31 = 0 then 4 else 8
-
-let input_remote_value ic =
- let v = String.create value_size in
- really_input ic v 0 value_size; v
-
-let output_remote_value ic v =
- output ic v 0 value_size
-
-exception Marshalling_error
-
-module Remote_value =
- struct
- type t = Remote of string | Local of Obj.t
-
- let obj = function
- | Local obj -> Obj.obj obj
- | Remote v ->
- output_char !conn.io_out 'M';
- output_remote_value !conn.io_out v;
- flush !conn.io_out;
- try
- input_value !conn.io_in
- with End_of_file | Failure _ ->
- raise Marshalling_error
-
- let is_block = function
- | Local obj -> Obj.is_block obj
- | Remote v -> Obj.is_block (Array.unsafe_get (Obj.magic v : Obj.t array) 0)
-
- let tag = function
- | Local obj -> Obj.tag obj
- | Remote v ->
- output_char !conn.io_out 'H';
- output_remote_value !conn.io_out v;
- flush !conn.io_out;
- let header = input_binary_int !conn.io_in in
- header land 0xFF
-
- let size = function
- | Local obj -> Obj.size obj
- | Remote v ->
- output_char !conn.io_out 'H';
- output_remote_value !conn.io_out v;
- flush !conn.io_out;
- let header = input_binary_int !conn.io_in in
- if header land 0xFF = Obj.double_array_tag && Sys.word_size = 32
- then header lsr 11
- else header lsr 10
-
- let field v n =
- match v with
- | Local obj -> Local(Obj.field obj n)
- | Remote v ->
- output_char !conn.io_out 'F';
- output_remote_value !conn.io_out v;
- output_binary_int !conn.io_out n;
- flush !conn.io_out;
- if input_byte !conn.io_in = 0 then
- Remote(input_remote_value !conn.io_in)
- else begin
- let buf = String.create 8 in
- really_input !conn.io_in buf 0 8;
- let floatbuf = float n (* force allocation of a new float *) in
- String.unsafe_blit buf 0 (Obj.magic floatbuf) 0 8;
- Local(Obj.repr floatbuf)
- end
-
- let of_int n =
- Local(Obj.repr n)
-
- let local pos =
- output_char !conn.io_out 'L';
- output_binary_int !conn.io_out pos;
- flush !conn.io_out;
- Remote(input_remote_value !conn.io_in)
-
- let from_environment pos =
- output_char !conn.io_out 'E';
- output_binary_int !conn.io_out pos;
- flush !conn.io_out;
- Remote(input_remote_value !conn.io_in)
-
- let global pos =
- output_char !conn.io_out 'G';
- output_binary_int !conn.io_out pos;
- flush !conn.io_out;
- Remote(input_remote_value !conn.io_in)
-
- let accu () =
- output_char !conn.io_out 'A';
- flush !conn.io_out;
- Remote(input_remote_value !conn.io_in)
-
- let closure_code = function
- | Local obj -> assert false
- | Remote v ->
- output_char !conn.io_out 'C';
- output_remote_value !conn.io_out v;
- flush !conn.io_out;
- input_binary_int !conn.io_in
-
- let same rv1 rv2 =
- match (rv1, rv2) with
- (Local obj1, Local obj2) -> obj1 == obj2
- | (Remote v1, Remote v2) -> v1 = v2
- (* string equality -> equality of remote pointers *)
- | (_, _) -> false
-
- end
diff --git a/debugger/debugcom.mli b/debugger/debugcom.mli
deleted file mode 100644
index 447e45d9e2..0000000000
--- a/debugger/debugcom.mli
+++ /dev/null
@@ -1,102 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Low-level communication with the debuggee *)
-
-type execution_summary =
- Event
- | Breakpoint
- | Exited
- | Trap_barrier
- | Uncaught_exc
-
-type report =
- { rep_type : execution_summary;
- rep_event_count : int;
- rep_stack_pointer : int;
- rep_program_pointer : int }
-
-type checkpoint_report =
- Checkpoint_done of int
- | Checkpoint_failed
-
-(* Set the current connection with the debuggee *)
-val set_current_connection : Primitives.io_channel -> unit
-
-(* Put an event at given pc *)
-val set_event : int -> unit
-
-(* Put a breakpoint at given pc *)
-val set_breakpoint : int -> unit
-
-(* Remove breakpoint or event at given pc *)
-val reset_instr : int -> unit
-
-(* Create a new checkpoint (the current process forks). *)
-val do_checkpoint : unit -> checkpoint_report
-
-(* Step N events. *)
-val do_go : int64 -> report
-
-(* Tell given process to terminate *)
-val stop : Primitives.io_channel -> unit
-
-(* Tell given process to wait for its children *)
-val wait_child : Primitives.io_channel -> unit
-
-(* Move to initial frame (that of current function). *)
-(* Return stack position and current pc *)
-val initial_frame : unit -> int * int
-val set_initial_frame : unit -> unit
-
-(* Get the current frame position *)
-(* Return stack position and current pc *)
-val get_frame : unit -> int * int
-
-(* Set the current frame *)
-val set_frame : int -> unit
-
-(* Move up one frame *)
-(* Return stack position and current pc.
- If there's no frame above, return (-1, 0). *)
-val up_frame : int -> int * int
-
-(* Set the trap barrier to given stack position. *)
-val set_trap_barrier : int -> unit
-
-(* Handling of remote values *)
-
-exception Marshalling_error
-
-module Remote_value :
- sig
- type t
-
- val obj : t -> 'a
- val is_block : t -> bool
- val tag : t -> int
- val size : t -> int
- val field : t -> int -> t
- val same : t -> t -> bool
-
- val of_int : int -> t
-
- val local : int -> t
- val from_environment : int -> t
- val global : int -> t
- val accu : unit -> t
- val closure_code : t -> int
-
- end
diff --git a/debugger/debugger_config.ml b/debugger/debugger_config.ml
deleted file mode 100644
index fa6fd7018f..0000000000
--- a/debugger/debugger_config.ml
+++ /dev/null
@@ -1,75 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(**************************** Configuration file ***********************)
-
-open Int64ops
-
-exception Toplevel
-
-(*** Miscellaneous parameters. ***)
-
-(*ISO 6429 color sequences
-00 to restore default color
-01 for brighter colors
-04 for underlined text
-05 for flashing text
-30 for black foreground
-31 for red foreground
-32 for green foreground
-33 for yellow (or brown) foreground
-34 for blue foreground
-35 for purple foreground
-36 for cyan foreground
-37 for white (or gray) foreground
-40 for black background
-41 for red background
-42 for green background
-43 for yellow (or brown) background
-44 for blue background
-45 for purple background
-46 for cyan background
-47 for white (or gray) background
-let debugger_prompt = "\027[1;04m(ocd)\027[0m "
-and event_mark_before = "\027[1;31m$\027[0m"
-and event_mark_after = "\027[1;34m$\027[0m"
-*)
-let debugger_prompt = "(ocd) "
-let event_mark_before = "<|b|>"
-let event_mark_after = "<|a|>"
-
-(* Name of shell used to launch the debuggee *)
-let shell = "/bin/sh"
-
-(* Name of the Objective Caml runtime. *)
-let runtime_program = "ocamlrun"
-
-(* Time history size (for `last') *)
-let history_size = ref 30
-
-(*** Time travel parameters. ***)
-
-(* Step between checkpoints for long displacements.*)
-let checkpoint_big_step = ref (~~ "10000")
-
-(* Idem for small ones. *)
-let checkpoint_small_step = ref (~~ "1000")
-
-(* Maximum number of checkpoints. *)
-let checkpoint_max_count = ref 15
-
-(* Whether to keep checkpoints or not. *)
-let make_checkpoints = ref true
-
diff --git a/debugger/debugger_config.mli b/debugger/debugger_config.mli
deleted file mode 100644
index 44f4fe582a..0000000000
--- a/debugger/debugger_config.mli
+++ /dev/null
@@ -1,35 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(********************** Configuration file *****************************)
-
-exception Toplevel
-
-(*** Miscellaneous parameters. ***)
-
-val debugger_prompt : string
-val event_mark_before : string
-val event_mark_after : string
-val shell : string
-val runtime_program : string
-val history_size : int ref
-
-(*** Time travel paramaters. ***)
-
-val checkpoint_big_step : int64 ref
-val checkpoint_small_step : int64 ref
-val checkpoint_max_count : int ref
-val make_checkpoints : bool ref
-
diff --git a/debugger/envaux.ml b/debugger/envaux.ml
deleted file mode 100644
index ba8d6dff59..0000000000
--- a/debugger/envaux.ml
+++ /dev/null
@@ -1,83 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Misc
-open Types
-open Env
-
-type error =
- Module_not_found of Path.t
-
-exception Error of error
-
-let env_cache =
- (Hashtbl.create 59 : (Env.summary, Env.t) Hashtbl.t)
-
-let reset_cache () =
- Hashtbl.clear env_cache;
- Env.reset_cache()
-
-let extract_sig env mty =
- match Mtype.scrape env mty with
- Tmty_signature sg -> sg
- | _ -> fatal_error "Envaux.extract_sig"
-
-let rec env_from_summary sum =
- try
- Hashtbl.find env_cache sum
- with Not_found ->
- let env =
- match sum with
- Env_empty ->
- Env.empty
- | Env_value(s, id, desc) ->
- Env.add_value id desc (env_from_summary s)
- | Env_type(s, id, desc) ->
- Env.add_type id desc (env_from_summary s)
- | Env_exception(s, id, desc) ->
- Env.add_exception id desc (env_from_summary s)
- | Env_module(s, id, desc) ->
- Env.add_module id desc (env_from_summary s)
- | Env_modtype(s, id, desc) ->
- Env.add_modtype id desc (env_from_summary s)
- | Env_class(s, id, desc) ->
- Env.add_class id desc (env_from_summary s)
- | Env_cltype (s, id, desc) ->
- Env.add_cltype id desc (env_from_summary s)
- | Env_open(s, path) ->
- let env = env_from_summary s in
- let mty =
- try
- Env.find_module path env
- with Not_found ->
- raise (Error (Module_not_found path))
- in
- Env.open_signature path (extract_sig env mty) env
- in
- Hashtbl.add env_cache sum env;
- env
-
-let env_of_event =
- function
- None -> Env.empty
- | Some ev -> env_from_summary ev.Instruct.ev_typenv
-
-(* Error report *)
-
-open Format
-
-let report_error ppf = function
- | Module_not_found p ->
- fprintf ppf "@[Cannot find module %a@].@." Printtyp.path p
diff --git a/debugger/envaux.mli b/debugger/envaux.mli
deleted file mode 100644
index 8b122cc347..0000000000
--- a/debugger/envaux.mli
+++ /dev/null
@@ -1,33 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Format
-
-(* Convert environment summaries to environments *)
-
-val env_of_event: Instruct.debug_event option -> Env.t
-
-(* Empty the environment caches. To be called when load_path changes. *)
-
-val reset_cache: unit -> unit
-
-(* Error report *)
-
-type error =
- Module_not_found of Path.t
-
-exception Error of error
-
-val report_error: formatter -> error -> unit
diff --git a/debugger/eval.ml b/debugger/eval.ml
deleted file mode 100644
index a53589382a..0000000000
--- a/debugger/eval.ml
+++ /dev/null
@@ -1,207 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Debugger_config
-open Misc
-open Path
-open Instruct
-open Types
-open Parser_aux
-
-type error =
- Unbound_identifier of Ident.t
- | Not_initialized_yet of Path.t
- | Unbound_long_identifier of Longident.t
- | Unknown_name of int
- | Tuple_index of type_expr * int * int
- | Array_index of int * int
- | List_index of int * int
- | String_index of string * int * int
- | Wrong_item_type of type_expr * int
- | Wrong_label of type_expr * string
- | Not_a_record of type_expr
- | No_result
-
-exception Error of error
-
-let abstract_type =
- Btype.newgenty (Tconstr (Pident (Ident.create "<abstr>"), [], ref Mnil))
-
-let rec path event = function
- Pident id ->
- if Ident.global id then
- Debugcom.Remote_value.global (Symtable.get_global_position id)
- else
- begin match event with
- Some ev ->
- begin try
- let pos = Ident.find_same id ev.ev_compenv.ce_stack in
- Debugcom.Remote_value.local (ev.ev_stacksize - pos)
- with Not_found ->
- try
- let pos = Ident.find_same id ev.ev_compenv.ce_heap in
- Debugcom.Remote_value.from_environment pos
- with Not_found ->
- raise(Error(Unbound_identifier id))
- end
- | None ->
- raise(Error(Unbound_identifier id))
- end
- | Pdot(root, fieldname, pos) ->
- let v = path event root in
- if not (Debugcom.Remote_value.is_block v) then
- raise(Error(Not_initialized_yet root));
- Debugcom.Remote_value.field v pos
- | Papply(p1, p2) ->
- fatal_error "Eval.path: Papply"
-
-let rec expression event env = function
- E_ident lid ->
- begin try
- let (p, valdesc) = Env.lookup_value lid env in
- (begin match valdesc.val_kind with
- Val_ivar (_, cl_num) ->
- let (p0, _) =
- Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
- in
- let v = path event p0 in
- let i = path event p in
- Debugcom.Remote_value.field v (Debugcom.Remote_value.obj i)
- | _ ->
- path event p
- end,
- Ctype.correct_levels valdesc.val_type)
- with Not_found ->
- raise(Error(Unbound_long_identifier lid))
- end
- | E_result ->
- begin match event with
- Some {ev_kind = Event_after ty} when !Frames.current_frame = 0 ->
- (Debugcom.Remote_value.accu(), ty)
- | _ ->
- raise(Error(No_result))
- end
- | E_name n ->
- begin try
- Printval.find_named_value n
- with Not_found ->
- raise(Error(Unknown_name n))
- end
- | E_item(arg, n) ->
- let (v, ty) = expression event env arg in
- begin match (Ctype.repr(Ctype.expand_head env ty)).desc with
- Ttuple ty_list ->
- if n < 1 || n > List.length ty_list
- then raise(Error(Tuple_index(ty, List.length ty_list, n)))
- else (Debugcom.Remote_value.field v (n-1), List.nth ty_list (n-1))
- | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_array ->
- let size = Debugcom.Remote_value.size v in
- if n >= size
- then raise(Error(Array_index(size, n)))
- else (Debugcom.Remote_value.field v n, ty_arg)
- | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_list ->
- let rec nth pos v =
- if not (Debugcom.Remote_value.is_block v) then
- raise(Error(List_index(pos, n)))
- else if pos = n then
- (Debugcom.Remote_value.field v 0, ty_arg)
- else
- nth (pos + 1) (Debugcom.Remote_value.field v 1)
- in nth 0 v
- | Tconstr(path, [], _) when Path.same path Predef.path_string ->
- let s = (Debugcom.Remote_value.obj v : string) in
- if n >= String.length s
- then raise(Error(String_index(s, String.length s, n)))
- else (Debugcom.Remote_value.of_int(Char.code s.[n]),
- Predef.type_char)
- | _ ->
- raise(Error(Wrong_item_type(ty, n)))
- end
- | E_field(arg, lbl) ->
- let (v, ty) = expression event env arg in
- begin match (Ctype.repr(Ctype.expand_head env ty)).desc with
- Tconstr(path, args, _) ->
- let tydesc = Env.find_type path env in
- begin match tydesc.type_kind with
- Type_record(lbl_list, repr, priv) ->
- let (pos, ty_res) =
- find_label lbl env ty path tydesc 0 lbl_list in
- (Debugcom.Remote_value.field v pos, ty_res)
- | _ -> raise(Error(Not_a_record ty))
- end
- | _ -> raise(Error(Not_a_record ty))
- end
-
-and find_label lbl env ty path tydesc pos = function
- [] ->
- raise(Error(Wrong_label(ty, lbl)))
- | (name, mut, ty_arg) :: rem ->
- if name = lbl then begin
- let ty_res =
- Btype.newgenty(Tconstr(path, tydesc.type_params, ref Mnil))
- in
- (pos,
- try Ctype.apply env [ty_res] ty_arg [ty] with Ctype.Cannot_apply ->
- abstract_type)
- end else
- find_label lbl env ty path tydesc (pos + 1) rem
-
-(* Error report *)
-
-open Format
-
-let report_error ppf = function
- | Unbound_identifier id ->
- fprintf ppf "@[Unbound identifier %s@]@." (Ident.name id)
- | Not_initialized_yet path ->
- fprintf ppf
- "@[The module path %a is not yet initialized.@ \
- Please run program forward@ \
- until its initialization code is executed.@]@."
- Printtyp.path path
- | Unbound_long_identifier lid ->
- fprintf ppf "@[Unbound identifier %a@]@." Printtyp.longident lid
- | Unknown_name n ->
- fprintf ppf "@[Unknown value name $%i@]@." n
- | Tuple_index(ty, len, pos) ->
- Printtyp.reset_and_mark_loops ty;
- fprintf ppf
- "@[Cannot extract field number %i from a %i-components \
- tuple of type@ %a@]@."
- pos len Printtyp.type_expr ty
- | Array_index(len, pos) ->
- fprintf ppf
- "@[Cannot extract element number %i from array of length %i@]@." pos len
- | List_index(len, pos) ->
- fprintf ppf
- "@[Cannot extract element number %i from list of length %i@]@." pos len
- | String_index(s, len, pos) ->
- fprintf ppf
- "@[Cannot extract character number %i@ \
- from the following string of length %i:@ %S@]@."
- pos len s
- | Wrong_item_type(ty, pos) ->
- fprintf ppf
- "@[Cannot extract item number %i from a value of type@ %a@]@."
- pos Printtyp.type_expr ty
- | Wrong_label(ty, lbl) ->
- fprintf ppf
- "@[The record type@ %a@ has no label named %s@]@."
- Printtyp.type_expr ty lbl
- | Not_a_record ty ->
- fprintf ppf
- "@[The type@ %a@ is not a record type@]@." Printtyp.type_expr ty
- | No_result ->
- fprintf ppf "@[No result available at current program event@]@."
diff --git a/debugger/eval.mli b/debugger/eval.mli
deleted file mode 100644
index b2a2998f14..0000000000
--- a/debugger/eval.mli
+++ /dev/null
@@ -1,40 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Types
-open Parser_aux
-open Format
-
-val expression :
- Instruct.debug_event option -> Env.t -> expression ->
- Debugcom.Remote_value.t * type_expr
-
-type error =
- | Unbound_identifier of Ident.t
- | Not_initialized_yet of Path.t
- | Unbound_long_identifier of Longident.t
- | Unknown_name of int
- | Tuple_index of type_expr * int * int
- | Array_index of int * int
- | List_index of int * int
- | String_index of string * int * int
- | Wrong_item_type of type_expr * int
- | Wrong_label of type_expr * string
- | Not_a_record of type_expr
- | No_result
-
-exception Error of error
-
-val report_error: formatter -> error -> unit
diff --git a/debugger/events.ml b/debugger/events.ml
deleted file mode 100644
index 5fb501ed34..0000000000
--- a/debugger/events.ml
+++ /dev/null
@@ -1,65 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(********************************* Events ******************************)
-
-open Instruct
-open Primitives
-open Checkpoints
-
-(* Previous `pc'. *)
-(* Save time if `update_current_event' is called *)
-(* several times at the same point. *)
-let old_pc = ref (None : int option)
-
-(*** Current events. ***)
-
-(* Event at current position *)
-let current_event =
- ref (None : debug_event option)
-
-(* Recompute the current event *)
-let update_current_event () =
- match current_pc () with
- None ->
- current_event := None;
- old_pc := None
- | (Some pc) as opt_pc when opt_pc <> !old_pc ->
- current_event := begin try
- Some (Symbols.event_at_pc pc)
- with Not_found ->
- None
- end;
- old_pc := opt_pc
- | _ ->
- ()
-
-(* Current position in source. *)
-(* Raise `Not_found' if not on an event (beginning or end of program). *)
-let current_point () =
- match !current_event with
- None ->
- raise Not_found
- | Some {ev_char = point; ev_module = mdle} ->
- (mdle, point.Lexing.pos_cnum)
-
-let current_event_is_before () =
- match !current_event with
- None ->
- raise Not_found
- | Some {ev_kind = Event_before} ->
- true
- | _ ->
- false
diff --git a/debugger/events.mli b/debugger/events.mli
deleted file mode 100644
index 8c47399571..0000000000
--- a/debugger/events.mli
+++ /dev/null
@@ -1,31 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Instruct
-
-(** Current events. **)
-
-(* The event at current position. *)
-val current_event : debug_event option ref
-
-(* Recompute the current event *)
-val update_current_event : unit -> unit
-
-(* Current position in source. *)
-(* Raise `Not_found' if not on an event (beginning or end of program). *)
-val current_point : unit -> string * int
-
-val current_event_is_before : unit -> bool
-
diff --git a/debugger/exec.ml b/debugger/exec.ml
deleted file mode 100644
index d97a8c4e7d..0000000000
--- a/debugger/exec.ml
+++ /dev/null
@@ -1,50 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Handling of keyboard interrupts *)
-
-let interrupted = ref false
-
-let is_protected = ref false
-
-let break signum =
- if !is_protected
- then interrupted := true
- else raise Sys.Break
-
-let _ =
- Sys.set_signal Sys.sigint (Sys.Signal_handle break);
- Sys.set_signal Sys.sigpipe (Sys.Signal_handle (fun _ -> raise End_of_file))
-
-let protect f =
- if !is_protected then
- f ()
- else begin
- is_protected := true;
- if not !interrupted then
- f ();
- is_protected := false;
- if !interrupted then begin interrupted := false; raise Sys.Break end
- end
-
-let unprotect f =
- if not !is_protected then
- f ()
- else begin
- is_protected := false;
- if !interrupted then begin interrupted := false; raise Sys.Break end;
- f ();
- is_protected := true
- end
diff --git a/debugger/exec.mli b/debugger/exec.mli
deleted file mode 100644
index 9d3b986048..0000000000
--- a/debugger/exec.mli
+++ /dev/null
@@ -1,19 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Handling of keyboard interrupts *)
-
-val protect : (unit -> unit) -> unit
-val unprotect : (unit -> unit) -> unit
diff --git a/debugger/frames.ml b/debugger/frames.ml
deleted file mode 100644
index cb76e013a6..0000000000
--- a/debugger/frames.ml
+++ /dev/null
@@ -1,129 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(***************************** Frames **********************************)
-
-open Instruct
-open Primitives
-open Debugcom
-open Checkpoints
-open Events
-open Symbols
-
-(* Current frame number *)
-let current_frame = ref 0
-
-(* Event at selected position *)
-let selected_event = ref (None : debug_event option)
-
-(* Selected position in source. *)
-(* Raise `Not_found' if not on an event. *)
-let selected_point () =
- match !selected_event with
- None ->
- raise Not_found
- | Some {ev_char = point; ev_module = mdle} ->
- (mdle, point.Lexing.pos_cnum)
-
-let selected_event_is_before () =
- match !selected_event with
- None ->
- raise Not_found
- | Some {ev_kind = Event_before} ->
- true
- | _ ->
- false
-
-(* Move up `frame_count' frames, assuming current frame pointer
- corresponds to event `event'. Return event of final frame. *)
-
-let rec move_up frame_count event =
- if frame_count <= 0 then event else begin
- let (sp, pc) = up_frame event.ev_stacksize in
- if sp < 0 then raise Not_found;
- move_up (frame_count - 1) (any_event_at_pc pc)
- end
-
-(* Select a frame. *)
-(* Raise `Not_found' if no such frame. *)
-(* --- Assume the current events have already been updated. *)
-let select_frame frame_number =
- if frame_number < 0 then raise Not_found;
- let (initial_sp, _) = get_frame() in
- try
- match !current_event with
- None ->
- raise Not_found
- | Some curr_event ->
- match !selected_event with
- Some sel_event when frame_number >= !current_frame ->
- selected_event :=
- Some(move_up (frame_number - !current_frame) sel_event);
- current_frame := frame_number
- | _ ->
- set_initial_frame();
- selected_event := Some(move_up frame_number curr_event);
- current_frame := frame_number
- with Not_found ->
- set_frame initial_sp;
- raise Not_found
-
-(* Select a frame. *)
-(* Same as `select_frame' but raise no exception if the frame is not found. *)
-(* --- Assume the currents events have already been updated. *)
-let try_select_frame frame_number =
- try
- select_frame frame_number
- with
- Not_found ->
- ()
-
-(* Return to default frame (frame 0). *)
-let reset_frame () =
- set_initial_frame();
- selected_event := !current_event;
- current_frame := 0
-
-(* Perform a stack backtrace.
- Call the given function with the events for each stack frame,
- or None if we've encountered a stack frame with no debugging info
- attached. Stop when the function returns false, or frame with no
- debugging info reached, or top of stack reached. *)
-
-let do_backtrace action =
- match !current_event with
- None -> Misc.fatal_error "Frames.do_backtrace"
- | Some curr_ev ->
- let (initial_sp, _) = get_frame() in
- set_initial_frame();
- let event = ref curr_ev in
- begin try
- while action (Some !event) do
- let (sp, pc) = up_frame !event.ev_stacksize in
- if sp < 0 then raise Exit;
- event := any_event_at_pc pc
- done
- with Exit -> ()
- | Not_found -> ignore (action None)
- end;
- set_frame initial_sp
-
-(* Return the number of frames in the stack *)
-
-let stack_depth () =
- let num_frames = ref 0 in
- do_backtrace (function Some ev -> incr num_frames; true
- | None -> num_frames := -1; false);
- !num_frames
diff --git a/debugger/frames.mli b/debugger/frames.mli
deleted file mode 100644
index 0906171f2e..0000000000
--- a/debugger/frames.mli
+++ /dev/null
@@ -1,55 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(****************************** Frames *********************************)
-
-open Instruct
-open Primitives
-
-(* Current frame number *)
-val current_frame : int ref
-
-(* Event at selected position. *)
-val selected_event : debug_event option ref
-
-(* Selected position in source. *)
-(* Raise `Not_found' if not on an event. *)
-val selected_point : unit -> string * int
-
-val selected_event_is_before : unit -> bool
-
-(* Select a frame. *)
-(* Raise `Not_found' if no such frame. *)
-(* --- Assume the currents events have already been updated. *)
-val select_frame : int -> unit
-
-(* Select a frame. *)
-(* Same as `select_frame' but raise no exception if the frame is not found. *)
-(* --- Assume the currents events have already been updated. *)
-val try_select_frame : int -> unit
-
-(* Return to default frame (frame 0). *)
-val reset_frame : unit -> unit
-
-(* Perform a stack backtrace.
- Call the given function with the events for each stack frame,
- or None if we've encountered a stack frame with no debugging info
- attached. Stop when the function returns false, or frame with no
- debugging info reached, or top of stack reached. *)
-val do_backtrace : (debug_event option -> bool) -> unit
-
-(* Return the number of frames in the stack, or (-1) if it can't be
- determined because some frames have no debugging info. *)
-val stack_depth : unit -> int
diff --git a/debugger/history.ml b/debugger/history.ml
deleted file mode 100644
index 31a6e7ad2a..0000000000
--- a/debugger/history.ml
+++ /dev/null
@@ -1,44 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Int64ops
-open Checkpoints
-open Misc
-open Primitives
-open Debugger_config
-
-let history = ref ([] : int64 list)
-
-let empty_history () =
- history := []
-
-let add_current_time () =
- let time = current_time () in
- if !history = [] then
- history := [time]
- else if time <> List.hd !history then
- history := list_truncate !history_size (time::!history)
-
-let previous_time_1 () =
- match !history with
- _::((time::_) as hist) ->
- history := hist; time
- | _ ->
- prerr_endline "No more information."; raise Toplevel
-
-let rec previous_time n =
- if n = _1
- then previous_time_1()
- else begin ignore(previous_time_1()); previous_time(pre64 n) end
diff --git a/debugger/history.mli b/debugger/history.mli
deleted file mode 100644
index 249629fdb9..0000000000
--- a/debugger/history.mli
+++ /dev/null
@@ -1,20 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-val empty_history : unit -> unit
-
-val add_current_time : unit -> unit
-
-val previous_time : int64 -> int64
diff --git a/debugger/input_handling.ml b/debugger/input_handling.ml
deleted file mode 100644
index 5aac814b9a..0000000000
--- a/debugger/input_handling.ml
+++ /dev/null
@@ -1,148 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(**************************** Input control ****************************)
-
-open Unix
-open Primitives
-
-(*** Actives files. ***)
-
-(* List of the actives files. *)
-let active_files =
- ref ([] : (file_descr * ((io_channel -> unit) * io_channel)) list)
-
-(* Add a file to the list of actives files. *)
-let add_file file controller =
- active_files := (file.io_fd, (controller, file))::!active_files
-
-(* Remove a file from the list of actives files. *)
-let remove_file file =
- active_files := assoc_remove !active_files file.io_fd
-
-(* Change the controller for the given file. *)
-let change_controller file controller =
- remove_file file; add_file file controller
-
-(* Return the controller currently attached to the given file. *)
-let current_controller file =
- fst (List.assoc file.io_fd !active_files)
-
-(* Execute a function with `controller' attached to `file'. *)
-(* ### controller file funct *)
-let execute_with_other_controller controller file funct =
- let old_controller = current_controller file in
- change_controller file controller;
- try
- let result = funct () in
- change_controller file old_controller;
- result
- with
- x ->
- change_controller file old_controller;
- raise x
-
-(*** The "Main Loop" ***)
-
-let continue_main_loop =
- ref true
-
-let exit_main_loop _ =
- continue_main_loop := false
-
-(* Handle active files until `continue_main_loop' is false. *)
-let main_loop () =
- let old_state = !continue_main_loop in
- try
- continue_main_loop := true;
- while !continue_main_loop do
- try
- let (input, _, _) =
- select (List.map fst !active_files) [] [] (-1.)
- in
- List.iter
- (function fd ->
- let (funct, iochan) = (List.assoc fd !active_files) in
- funct iochan)
- input
- with
- Unix_error (EINTR, _, _) -> ()
- done;
- continue_main_loop := old_state
- with
- x ->
- continue_main_loop := old_state;
- raise x
-
-(*** Managing user inputs ***)
-
-(* Are we in interactive mode ? *)
-let interactif = ref true
-
-let current_prompt = ref ""
-
-(* Where the user input come from. *)
-let user_channel = ref std_io
-
-let read_user_input buffer length =
- main_loop ();
- input !user_channel.io_in buffer 0 length
-
-(* Stop reading user input. *)
-let stop_user_input () =
- remove_file !user_channel
-
-(* Resume reading user input. *)
-let resume_user_input () =
- if not (List.mem_assoc !user_channel.io_fd !active_files) then begin
- if !interactif then begin
- print_string !current_prompt;
- flush Pervasives.stdout
- end;
- add_file !user_channel exit_main_loop
- end
-
-(* Ask user a yes or no question. *)
-let yes_or_no message =
- if !interactif then
- let old_prompt = !current_prompt in
- try
- current_prompt := message ^ " ? (y or n) ";
- let answer =
- let rec ask () =
- resume_user_input ();
- let line =
- string_trim (Lexer.line (Lexing.from_function read_user_input))
- in
- stop_user_input ();
- match (if String.length line > 0 then line.[0] else ' ') with
- 'y' -> true
- | 'n' -> false
- | _ ->
- print_string "Please answer y or n.";
- print_newline ();
- ask ()
- in
- ask ()
- in
- current_prompt := old_prompt;
- answer
- with
- x ->
- current_prompt := old_prompt;
- stop_user_input ();
- raise x
- else
- false
diff --git a/debugger/input_handling.mli b/debugger/input_handling.mli
deleted file mode 100644
index 872b880816..0000000000
--- a/debugger/input_handling.mli
+++ /dev/null
@@ -1,63 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(***************************** Input control ***************************)
-
-open Primitives
-
-(*** Actives files. ***)
-
-(* Add a file to the list of active files. *)
-val add_file : io_channel -> (io_channel -> unit) -> unit
-
-(* Remove a file from the list of actives files. *)
-val remove_file : io_channel -> unit
-
-(* Return the controller currently attached to the given file. *)
-val current_controller : io_channel -> (io_channel -> unit)
-
-(* Execute a function with `controller' attached to `file'. *)
-(* ### controller file funct *)
-val execute_with_other_controller :
- (io_channel -> unit) -> io_channel -> (unit -> 'a) -> 'a
-
-(*** The "Main Loop" ***)
-
-(* Call this function for exiting the main loop. *)
-val exit_main_loop : 'a -> unit
-
-(* Handle active files until `continue_main_loop' is false. *)
-val main_loop : unit -> unit
-
-(*** Managing user inputs ***)
-
-(* Are we in interactive mode ? *)
-val interactif : bool ref
-
-val current_prompt : string ref
-
-(* Where the user input come from. *)
-val user_channel : io_channel ref
-
-val read_user_input : string -> int -> int
-
-(* Stop reading user input. *)
-val stop_user_input : unit -> unit
-
-(* Resume reading user input. *)
-val resume_user_input : unit -> unit
-
-(* Ask user a yes or no question. *)
-val yes_or_no : string -> bool
diff --git a/debugger/int64ops.ml b/debugger/int64ops.ml
deleted file mode 100644
index b854a6c343..0000000000
--- a/debugger/int64ops.ml
+++ /dev/null
@@ -1,26 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Damien Doligez, projet Moscova, INRIA Rocqencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(****************** arithmetic operators for Int64 *********************)
-
-let ( ++ ) = Int64.add;;
-let ( -- ) = Int64.sub;;
-let suc64 = Int64.succ;;
-let pre64 = Int64.pred;;
-let _0 = Int64.zero;;
-let _1 = Int64.one;;
-let _minus1 = Int64.minus_one;;
-let ( ~~ ) = Int64.of_string;;
-let max_small_int = Int64.of_int max_int;;
-let to_int = Int64.to_int;;
diff --git a/debugger/int64ops.mli b/debugger/int64ops.mli
deleted file mode 100644
index 98f7228d3d..0000000000
--- a/debugger/int64ops.mli
+++ /dev/null
@@ -1,26 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Damien Doligez, projet Moscova, INRIA Rocqencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(****************** arithmetic operators for Int64 *********************)
-
-val ( ++ ) : int64 -> int64 -> int64;;
-val ( -- ) : int64 -> int64 -> int64;;
-val suc64 : int64 -> int64;;
-val pre64 : int64 -> int64;;
-val _0 : int64;;
-val _1 : int64;;
-val _minus1 : int64;;
-val ( ~~ ) : string -> int64;;
-val max_small_int : int64;;
-val to_int : int64 -> int;;
diff --git a/debugger/lexer.mll b/debugger/lexer.mll
deleted file mode 100644
index 17293f62c4..0000000000
--- a/debugger/lexer.mll
+++ /dev/null
@@ -1,98 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-{
-
-open Primitives
-open Parser
-
-}
-
-rule line = (* Read a whole line *)
- parse
- ([ ^ '\n' '\r' ]* as s) ('\n' | '\r' | "\r\n")
- { s }
- | [ ^ '\n' '\r' ]*
- { Lexing.lexeme lexbuf }
- | eof
- { raise Exit }
-
-and argument = (* Read a raw argument *)
- parse
- [ ^ ' ' '\t' ]+
- { ARGUMENT (Lexing.lexeme lexbuf) }
- | [' ' '\t']+
- { argument lexbuf }
- | eof
- { EOL }
- | _
- { raise Parsing.Parse_error }
-
-and line_argument =
- parse
- _ *
- { ARGUMENT (Lexing.lexeme lexbuf) }
- | eof
- { EOL }
-
-and lexeme = (* Read a lexeme *)
- parse
- [' ' '\t'] +
- { lexeme lexbuf }
- | ['a'-'z' '\223'-'\246' '\248'-'\255' '_']
- (['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255'
- '\'' '0'-'9' ]) *
- { LIDENT(Lexing.lexeme lexbuf) }
- | ['A'-'Z' '\192'-'\214' '\216'-'\222' ]
- (['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255'
- '\'' '0'-'9' ]) *
- { UIDENT(Lexing.lexeme lexbuf) }
- | '"' [^ '"']* "\""
- { let s = Lexing.lexeme lexbuf in
- LIDENT(String.sub s 1 (String.length s - 2)) }
- | ['0'-'9']+
- | '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+
- | '0' ['o' 'O'] ['0'-'7']+
- | '0' ['b' 'B'] ['0'-'1']+
- { INTEGER (Int64.of_string (Lexing.lexeme lexbuf)) }
- | '*'
- { STAR }
- | "-"
- { MINUS }
- | "."
- { DOT }
- | "#"
- { SHARP }
- | "@"
- { AT }
- | "$"
- { DOLLAR }
- | "!"
- { BANG }
- | "("
- { LPAREN }
- | ")"
- { RPAREN }
- | "["
- { LBRACKET }
- | "]"
- { RBRACKET }
- | ['!' '?' '~' '=' '<' '>' '|' '&' '$' '@' '^' '+' '-' '*' '/' '%']
- ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] *
- { OPERATOR (Lexing.lexeme lexbuf) }
- | eof
- { EOL }
- | _
- { raise Parsing.Parse_error }
diff --git a/debugger/loadprinter.ml b/debugger/loadprinter.ml
deleted file mode 100644
index ef86b7146e..0000000000
--- a/debugger/loadprinter.ml
+++ /dev/null
@@ -1,172 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1997 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Loading and installation of user-defined printer functions *)
-
-open Misc
-open Debugger_config
-open Longident
-open Path
-open Types
-
-(* Error report *)
-
-type error =
- | Load_failure of Dynlink.error
- | Unbound_identifier of Longident.t
- | Unavailable_module of string * Longident.t
- | Wrong_type of Longident.t
- | No_active_printer of Longident.t
-
-exception Error of error
-
-(* Symtable has global state, and normally holds the symbol table
- for the debuggee. We need to switch it temporarily to the
- symbol table for the debugger. *)
-
-let debugger_symtable = ref (None: Symtable.global_map option)
-
-let use_debugger_symtable fn arg =
- let old_symtable = Symtable.current_state() in
- begin match !debugger_symtable with
- | None ->
- Dynlink.init();
- Dynlink.allow_unsafe_modules true;
- debugger_symtable := Some(Symtable.current_state())
- | Some st ->
- Symtable.restore_state st
- end;
- try
- let result = fn arg in
- debugger_symtable := Some(Symtable.current_state());
- Symtable.restore_state old_symtable;
- result
- with exn ->
- Symtable.restore_state old_symtable;
- raise exn
-
-(* Load a .cmo or .cma file *)
-
-open Format
-
-let rec loadfiles ppf name =
- try
- let filename = find_in_path !Config.load_path name in
- use_debugger_symtable Dynlink.loadfile filename;
- let d = Filename.dirname name in
- if d <> Filename.current_dir_name then begin
- if not (List.mem d !Config.load_path) then
- Config.load_path := d :: !Config.load_path;
- end;
- fprintf ppf "File %s loaded@." filename;
- true
- with
- | Dynlink.Error (Dynlink.Unavailable_unit unit) ->
- loadfiles ppf (String.uncapitalize unit ^ ".cmo")
- &&
- loadfiles ppf name
- | Not_found ->
- fprintf ppf "Cannot find file %s@." name;
- false
- | Dynlink.Error e ->
- raise(Error(Load_failure e))
-
-let loadfile ppf name =
- ignore(loadfiles ppf name)
-
-(* Return the value referred to by a path (as in toplevel/topdirs) *)
-(* Note: evaluation proceeds in the debugger memory space, not in
- the debuggee. *)
-
-let rec eval_path = function
- Pident id -> Symtable.get_global_value id
- | Pdot(p, s, pos) -> Obj.field (eval_path p) pos
- | Papply(p1, p2) -> fatal_error "Loadprinter.eval_path"
-
-(* Install, remove a printer (as in toplevel/topdirs) *)
-
-let match_printer_type desc typename =
- let (printer_type, _) =
- try
- Env.lookup_type (Ldot(Lident "Topdirs", typename)) Env.empty
- with Not_found ->
- raise (Error(Unbound_identifier(Ldot(Lident "Topdirs", typename)))) in
- Ctype.init_def(Ident.current_time());
- Ctype.begin_def();
- let ty_arg = Ctype.newvar() in
- Ctype.unify Env.empty
- (Ctype.newconstr printer_type [ty_arg])
- (Ctype.instance desc.val_type);
- Ctype.end_def();
- Ctype.generalize ty_arg;
- ty_arg
-
-let find_printer_type lid =
- try
- let (path, desc) = Env.lookup_value lid Env.empty in
- let (ty_arg, is_old_style) =
- try
- (match_printer_type desc "printer_type_new", false)
- with Ctype.Unify _ ->
- (match_printer_type desc "printer_type_old", true) in
- (ty_arg, path, is_old_style)
- with
- | Not_found -> raise(Error(Unbound_identifier lid))
- | Ctype.Unify _ -> raise(Error(Wrong_type lid))
-
-let install_printer ppf lid =
- let (ty_arg, path, is_old_style) = find_printer_type lid in
- let v =
- try
- use_debugger_symtable eval_path path
- with Symtable.Error(Symtable.Undefined_global s) ->
- raise(Error(Unavailable_module(s, lid))) in
- let print_function =
- if is_old_style then
- (fun formatter repr -> (Obj.obj v) (Obj.obj repr))
- else
- (fun formatter repr -> (Obj.obj v) formatter (Obj.obj repr)) in
- Printval.install_printer path ty_arg ppf print_function
-
-let remove_printer lid =
- let (ty_arg, path, is_old_style) = find_printer_type lid in
- try
- Printval.remove_printer path
- with Not_found ->
- raise(Error(No_active_printer lid))
-
-(* Error report *)
-
-open Format
-
-let report_error ppf = function
- | Load_failure e ->
- fprintf ppf "@[Error during code loading: %s@]@."
- (Dynlink.error_message e)
- | Unbound_identifier lid ->
- fprintf ppf "@[Unbound identifier %a@]@."
- Printtyp.longident lid
- | Unavailable_module(md, lid) ->
- fprintf ppf
- "@[The debugger does not contain the code for@ %a.@ \
- Please load an implementation of %s first.@]@."
- Printtyp.longident lid md
- | Wrong_type lid ->
- fprintf ppf "@[%a has the wrong type for a printing function.@]@."
- Printtyp.longident lid
- | No_active_printer lid ->
- fprintf ppf "@[%a is not currently active as a printing function.@]@."
- Printtyp.longident lid
-
-
diff --git a/debugger/loadprinter.mli b/debugger/loadprinter.mli
deleted file mode 100644
index bdaf77a285..0000000000
--- a/debugger/loadprinter.mli
+++ /dev/null
@@ -1,34 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1997 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Loading and installation of user-defined printer functions *)
-
-open Format
-
-val loadfile : formatter -> string -> unit
-val install_printer : formatter -> Longident.t -> unit
-val remove_printer : Longident.t -> unit
-
-(* Error report *)
-
-type error =
- | Load_failure of Dynlink.error
- | Unbound_identifier of Longident.t
- | Unavailable_module of string * Longident.t
- | Wrong_type of Longident.t
- | No_active_printer of Longident.t
-
-exception Error of error
-
-val report_error: formatter -> error -> unit
diff --git a/debugger/main.ml b/debugger/main.ml
deleted file mode 100644
index 0bb2dda19c..0000000000
--- a/debugger/main.ml
+++ /dev/null
@@ -1,132 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Primitives
-open Misc
-open Input_handling
-open Command_line
-open Debugger_config
-open Checkpoints
-open Time_travel
-open Parameters
-open Program_management
-open Frames
-open Show_information
-open Format
-
-let line_buffer = Lexing.from_function read_user_input
-
-let rec loop ppf =
- line_loop ppf line_buffer;
- if !loaded && (not (yes_or_no "The program is running. Quit anyway")) then
- loop ppf
-
-let rec protect ppf loop =
- try
- loop ppf
- with
- | End_of_file ->
- protect ppf (function ppf ->
- forget_process
- !current_checkpoint.c_fd
- !current_checkpoint.c_pid;
- pp_print_flush ppf ();
- stop_user_input ();
- loop ppf)
- | Toplevel ->
- protect ppf (function ppf ->
- pp_print_flush ppf ();
- stop_user_input ();
- loop ppf)
- | Sys.Break ->
- protect ppf (function ppf ->
- fprintf ppf "Interrupted.@.";
- Exec.protect (function () ->
- stop_user_input ();
- if !loaded then begin
- try_select_frame 0;
- show_current_event ppf;
- end);
- loop ppf)
- | Current_checkpoint_lost ->
- protect ppf (function ppf ->
- fprintf ppf "Trying to recover...@.";
- stop_user_input ();
- recover ();
- try_select_frame 0;
- show_current_event ppf;
- loop ppf)
- | x ->
- kill_program ();
- raise x
-
-let toplevel_loop () = protect Format.std_formatter loop
-
-(* Parsing of command-line arguments *)
-
-exception Found_program_name
-
-let anonymous s =
- program_name := Unix_tools.make_absolute s; raise Found_program_name
-let add_include d =
- default_load_path :=
- Misc.expand_directory Config.standard_library d :: !default_load_path
-let set_socket s =
- socket_name := s
-let set_checkpoints n =
- checkpoint_max_count := n
-let set_directory dir =
- Sys.chdir dir
-let set_emacs () =
- emacs := true
-
-let speclist =
- ["-I", Arg.String add_include,
- "<dir> Add <dir> to the list of include directories";
- "-s", Arg.String set_socket,
- "<filename> Set the name of the communication socket";
- "-c", Arg.Int set_checkpoints,
- "<count> Set max number of checkpoints kept";
- "-cd", Arg.String set_directory,
- "<dir> Change working directory";
- "-emacs", Arg.Unit set_emacs,
- "For running the debugger under emacs"]
-
-let main () =
- try
- socket_name := "/tmp/camldebug" ^ (string_of_int (Unix.getpid ()));
- begin try
- Arg.parse speclist anonymous "";
- Arg.usage speclist
- "No program name specified\n\
- Usage: ocamldebug [options] <program> [arguments]\n\
- Options are:";
- exit 2
- with Found_program_name ->
- for j = !Arg.current + 1 to Array.length Sys.argv - 1 do
- arguments := !arguments ^ " " ^ (Filename.quote Sys.argv.(j))
- done
- end;
- current_prompt := debugger_prompt;
- printf "\tObjective Caml Debugger version %s@.@." Config.version;
- Config.load_path := !default_load_path;
- toplevel_loop (); (* Toplevel. *)
- kill_program ();
- exit 0
- with Toplevel ->
- exit 2
-
-let _ =
- Printexc.catch (Unix.handle_unix_error main) ()
diff --git a/debugger/parameters.ml b/debugger/parameters.ml
deleted file mode 100644
index 67078b2fc3..0000000000
--- a/debugger/parameters.ml
+++ /dev/null
@@ -1,35 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Miscellaneous parameters *)
-
-open Primitives
-open Config
-open Misc
-
-let program_loaded = ref false
-let program_name = ref ""
-let socket_name = ref ""
-let arguments = ref ""
-
-let default_load_path =
- ref [ Filename.current_dir_name; Config.standard_library ]
-
-let add_path dir =
- load_path := dir :: except dir !load_path;
- Envaux.reset_cache()
-
-(* Used by emacs ? *)
-let emacs = ref false
diff --git a/debugger/parameters.mli b/debugger/parameters.mli
deleted file mode 100644
index c80d39d124..0000000000
--- a/debugger/parameters.mli
+++ /dev/null
@@ -1,26 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Miscellaneous parameters *)
-
-val program_name : string ref
-val socket_name : string ref
-val arguments : string ref
-val default_load_path : string list ref
-
-val add_path : string -> unit
-
-(* Used by emacs ? *)
-val emacs : bool ref
diff --git a/debugger/parser.mly b/debugger/parser.mly
deleted file mode 100644
index 6c7b2ddb26..0000000000
--- a/debugger/parser.mly
+++ /dev/null
@@ -1,239 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Jerome Vouillon, projet Cristal, INRIA Rocquencourt */
-/* Objective Caml port by John Malecki and Xavier Leroy */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-%{
-
-open Int64ops
-open Primitives
-open Input_handling
-open Longident
-open Parser_aux
-
-%}
-
-%token <string> ARGUMENT
-%token <string> LIDENT
-%token <string> UIDENT
-%token <string> OPERATOR
-%token <int64> INTEGER
-%token STAR /* * */
-%token MINUS /* - */
-%token DOT /* . */
-%token SHARP /* # */
-%token AT /* @ */
-%token DOLLAR /* $ */
-%token BANG /* ! */
-%token LPAREN /* ( */
-%token RPAREN /* ) */
-%token LBRACKET /* [ */
-%token RBRACKET /* ] */
-%token EOL
-
-%right DOT
-%right BANG
-
-%start argument_list_eol
-%type <string list> argument_list_eol
-
-%start argument_eol
-%type <string> argument_eol
-
-%start integer_list_eol
-%type <int list> integer_list_eol
-
-%start integer_eol
-%type <int> integer_eol
-
-%start int64_eol
-%type <int64> int64_eol
-
-%start integer
-%type <int> integer
-
-%start opt_integer_eol
-%type <int option> opt_integer_eol
-
-%start opt_signed_integer_eol
-%type <int option> opt_signed_integer_eol
-
-%start opt_signed_int64_eol
-%type <int64 option> opt_signed_int64_eol
-
-%start identifier
-%type <string> identifier
-
-%start identifier_eol
-%type <string> identifier_eol
-
-%start identifier_or_eol
-%type <string option> identifier_or_eol
-
-%start opt_identifier
-%type <string option> opt_identifier
-
-%start opt_identifier_eol
-%type <string option> opt_identifier_eol
-
-%start expression_list_eol
-%type <Parser_aux.expression list> expression_list_eol
-
-%start break_argument_eol
-%type <Parser_aux.break_arg> break_argument_eol
-
-%start list_arguments_eol
-%type <string option * int option * int option> list_arguments_eol
-
-%start end_of_line
-%type <unit> end_of_line
-
-%start longident_eol
-%type <Longident.t> longident_eol
-
-%%
-
-/* Raw arguments */
-
-argument_list_eol :
- ARGUMENT argument_list_eol
- { $1::$2 }
- | end_of_line
- { [] };
-
-argument_eol :
- ARGUMENT end_of_line
- { $1 };
-
-/* Integer */
-
-integer_list_eol :
- INTEGER integer_list_eol
- { (to_int $1) :: $2 }
- | end_of_line
- { [] };
-
-integer_eol :
- INTEGER end_of_line
- { to_int $1 };
-
-int64_eol :
- INTEGER end_of_line
- { $1 };
-
-integer :
- INTEGER
- { to_int $1 };
-
-opt_integer_eol :
- INTEGER end_of_line
- { Some (to_int $1) }
- | end_of_line
- { None };
-
-opt_int64_eol :
- INTEGER end_of_line
- { Some $1 }
- | end_of_line
- { None };
-
-opt_signed_integer_eol :
- MINUS integer_eol
- { Some (- $2) }
- | opt_integer_eol
- { $1 };
-
-opt_signed_int64_eol :
- MINUS int64_eol
- { Some (Int64.neg $2) }
- | opt_int64_eol
- { $1 };
-
-/* Identifiers and long identifiers */
-
-longident :
- LIDENT { Lident $1 }
- | module_path DOT LIDENT { Ldot($1, $3) }
- | OPERATOR { Lident $1 }
-;
-
-module_path :
- UIDENT { Lident $1 }
- | module_path DOT UIDENT { Ldot($1, $3) }
-;
-
-longident_eol :
- longident end_of_line { $1 };
-
-identifier :
- LIDENT { $1 }
- | UIDENT { $1 };
-
-identifier_eol :
- identifier end_of_line { $1 };
-
-identifier_or_eol :
- identifier { Some $1 }
- | end_of_line { None };
-
-opt_identifier :
- identifier { Some $1 }
- | { None };
-
-opt_identifier_eol :
- opt_identifier end_of_line { $1 };
-
-/* Expressions */
-
-expression:
- longident { E_ident $1 }
- | STAR { E_result }
- | DOLLAR INTEGER { E_name (to_int $2) }
- | expression DOT INTEGER { E_item($1, (to_int $3)) }
- | expression DOT LBRACKET INTEGER RBRACKET { E_item($1, (to_int $4)) }
- | expression DOT LPAREN INTEGER RPAREN { E_item($1, (to_int $4)) }
- | expression DOT LIDENT { E_field($1, $3) }
- | BANG expression { E_field($2, "contents") }
- | LPAREN expression RPAREN { $2 }
-;
-
-/* Lists of expressions */
-
-expression_list_eol :
- expression expression_list_eol { $1::$2 }
- | end_of_line { [] }
-;
-
-/* Arguments for breakpoint */
-
-break_argument_eol :
- end_of_line { BA_none }
- | integer_eol { BA_pc $1 }
- | expression end_of_line { BA_function $1 }
- | AT opt_identifier INTEGER opt_integer_eol { BA_pos1 ($2, (to_int $3), $4)}
- | AT opt_identifier SHARP integer_eol { BA_pos2 ($2, $4) }
-;
-
-/* Arguments for list */
-
-list_arguments_eol :
- opt_identifier integer opt_integer_eol
- { ($1, Some $2, $3) }
- | opt_identifier_eol
- { ($1, None, None) };
-
-/* End of line */
-
-end_of_line :
- EOL { stop_user_input () }
-;
diff --git a/debugger/parser_aux.mli b/debugger/parser_aux.mli
deleted file mode 100644
index 7ea63fb8c2..0000000000
--- a/debugger/parser_aux.mli
+++ /dev/null
@@ -1,34 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(*open Globals*)
-
-open Primitives
-
-type expression =
- E_ident of Longident.t (* x or Mod.x *)
- | E_name of int (* $xxx *)
- | E_item of expression * int (* x.1 x.[2] x.(3) *)
- | E_field of expression * string (* x.lbl !x *)
- | E_result
-
-type break_arg =
- BA_none (* break *)
- | BA_pc of int (* break PC *)
- | BA_function of expression (* break FUNCTION *)
- | BA_pos1 of string option * int * int option
- (* break @ [MODULE] LINE [POS] *)
- | BA_pos2 of string option * int (* break @ [MODULE] # OFFSET *)
-
diff --git a/debugger/pattern_matching.ml b/debugger/pattern_matching.ml
deleted file mode 100644
index a04dcae5b0..0000000000
--- a/debugger/pattern_matching.ml
+++ /dev/null
@@ -1,251 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(************************ Simple pattern matching **********************)
-
-open Debugger_config
-(*open Primitives*)
-open Misc
-(*open Const*)
-(*open Globals*)
-(*open Builtins*)
-open Typedtree
-(*open Modules*)
-(*open Symtable*)
-(*open Value*)
-open Parser_aux
-
-(*
-let rec find_constr tag = function
- [] ->
- fatal_error "find_constr: unknown constructor for this type"
- | constr::rest ->
- match constr.info.cs_tag with
- ConstrRegular(t, _) ->
- if t == tag then constr else find_constr tag rest
- | ConstrExtensible _ ->
- fatal_error "find_constr: extensible"
-
-let find_exception tag =
- let (qualid, stamp) = get_exn_of_num tag in
- let rec select_exn = function
- [] ->
- raise Not_found
- | constr :: rest ->
- match constr.info.cs_tag with
- ConstrExtensible(_,st) ->
- if st == stamp then constr else select_exn rest
- | ConstrRegular(_,_) ->
- fatal_error "find_exception: regular" in
- select_exn(hashtbl__find_all (find_module qualid.qual).mod_constrs qualid.id)
-*)
-
-let error_matching () =
- prerr_endline "Pattern matching failed";
- raise Toplevel
-
-(*
-let same_name {qualid = name1} =
- function
- GRname name2 ->
- (name2 = "") || (name1.id = name2)
- | GRmodname name2 ->
- name1 = name2
-
-let check_same_constr constr constr2 =
- try
- if not (same_name constr constr2) then
- error_matching ()
- with
- Desc_not_found ->
- prerr_endline "Undefined constructor.";
- raise Toplevel
-*)
-
-let rec pattern_matching pattern obj ty =
- match pattern with
- P_dummy ->
- []
- | P_variable var ->
- [var, obj, ty]
- | _ ->
- match (Ctype.repr ty).desc with
- Tvar | Tarrow _ ->
- error_matching ()
- | Ttuple(ty_list) ->
- (match pattern with
- P_tuple pattern_list ->
- pattern_matching_list pattern_list obj ty_list
- | P_nth (n, patt) ->
- if n >= List.length ty_list then
- (prerr_endline "Out of range."; raise Toplevel);
- pattern_matching patt (Debugcom.get_field obj n) (List.nth ty_list n)
- | _ ->
- error_matching ())
- | Tconstr(cstr, [ty_arg],_) when same_type_constr cstr constr_type_list ->
- (match pattern with
- P_list pattern_list ->
- let (last, list) =
- it_list
- (fun (current, list) pattern ->
- if value_tag current = 0 then error_matching ();
- (Debugcom.get_field current 1,
- (pattern, Debugcom.get_field current 0)::list))
- (obj, [])
- pattern_list
- in
- if value_tag last <> 0 then error_matching ();
- flat_map
- (function (x, y) -> pattern_matching x y ty_arg)
- (rev list)
- | P_nth (n, patt) ->
- let rec find k current =
- if value_tag current = 0 then
- (prerr_endline "Out of range."; raise Toplevel);
- if k = 0 then
- pattern_matching patt (Debugcom.get_field current 0) ty_arg
- else
- find (k - 1) (Debugcom.get_field current 1)
- in
- find n obj
- | P_concat (pattern1, pattern2) ->
- if value_tag obj == 0 then error_matching ();
- (pattern_matching pattern1 (Debugcom.get_field obj 0) ty_arg)
- @ (pattern_matching pattern2 (Debugcom.get_field obj 1) ty)
- | _ ->
- error_matching ())
- | Tconstr(cstr, [ty_arg]) when same_type_constr cstr constr_type_vect ->
- (match pattern with
- P_nth (n, patt) ->
- if n >= value_size obj then
- (prerr_endline "Out of range."; raise Toplevel);
- pattern_matching patt (Debugcom.get_field obj n) ty_arg
- | _ ->
- error_matching ())
- | Tconstr(cstr, ty_list) ->
- (match cstr.info.ty_abbr with
- Tabbrev(params, body) ->
- pattern_matching pattern obj (expand_abbrev params body ty_list)
- | _ ->
- match_concrete_type pattern obj cstr ty ty_list)
-
-and match_concrete_type pattern obj cstr ty ty_list =
- let typ_descr =
- type_descr_of_type_constr cstr in
- match typ_descr.info.ty_desc with
- Abstract_type ->
- error_matching ()
- | Variant_type constr_list ->
- let tag = value_tag obj in
- (try
- let constr =
- if same_type_constr cstr constr_type_exn then
- find_exception tag
- else
- find_constr tag constr_list
- in
- let (ty_res, ty_arg) =
- type_pair_instance (constr.info.cs_res, constr.info.cs_arg)
- in
- filter (ty_res, ty);
- match constr.info.cs_kind with
- Constr_constant ->
- error_matching ()
- | Constr_regular ->
- (match pattern with
- P_constr (constr2, patt) ->
- check_same_constr constr constr2;
- pattern_matching patt (Debugcom.get_field obj 0) ty_arg
- | _ ->
- error_matching ())
- | Constr_superfluous n ->
- (match pattern with
- P_constr (constr2, patt) ->
- check_same_constr constr constr2;
- (match patt with
- P_tuple pattern_list ->
- pattern_matching_list
- pattern_list
- obj
- (filter_product n ty_arg)
- | P_nth (n2, patt) ->
- let ty_list = filter_product n ty_arg in
- if n2 >= n then
- (prerr_endline "Out of range.";
- raise Toplevel);
- pattern_matching
- patt
- (Debugcom.get_field obj n2)
- (List.nth ty_list n2)
- | P_variable var ->
- [var,
- obj,
- {typ_desc = Tproduct (filter_product n ty_arg);
- typ_level = generic}]
- | P_dummy ->
- []
- | _ ->
- error_matching ())
- | _ ->
- error_matching ())
- with
- Not_found ->
- error_matching ()
- | Unify ->
- fatal_error "pattern_matching: types should match")
- | Record_type label_list ->
- let match_field (label, patt) =
- let lbl =
- try
- primitives__find
- (function l -> same_name l label)
- label_list
- with Not_found ->
- prerr_endline "Label not found.";
- raise Toplevel
- in
- let (ty_res, ty_arg) =
- type_pair_instance (lbl.info.lbl_res, lbl.info.lbl_arg)
- in
- (try
- filter (ty_res, ty)
- with Unify ->
- fatal_error "pattern_matching: types should match");
- pattern_matching patt (Debugcom.get_field obj lbl.info.lbl_pos) ty_arg
- in
- (match pattern with
- P_record pattern_label_list ->
- flat_map match_field pattern_label_list
- | _ ->
- error_matching ())
- | Abbrev_type(_,_) ->
- fatal_error "pattern_matching: abbrev type"
-
-and pattern_matching_list pattern_list obj ty_list =
- let val_list =
- try
- pair__combine (pattern_list, ty_list)
- with
- Invalid_argument _ -> error_matching ()
- in
- flat_map
- (function (x, y, z) -> pattern_matching x y z)
- (rev
- (snd
- (it_list
- (fun (num, list) (pattern, typ) ->
- (num + 1, (pattern, Debugcom.get_field obj num, typ)::list))
- (0, [])
- val_list)))
diff --git a/debugger/pattern_matching.mli b/debugger/pattern_matching.mli
deleted file mode 100644
index 3490edef69..0000000000
--- a/debugger/pattern_matching.mli
+++ /dev/null
@@ -1,21 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(************************ Simple pattern matching **********************)
-
-open Parser_aux
-
-val pattern_matching :
- pattern -> Debugcom.remote_value -> Typedtree.type_expr -> (string * Debugcom.remote_value * Typedtree.type_expr) list;;
diff --git a/debugger/pos.ml b/debugger/pos.ml
deleted file mode 100644
index 235de121d0..0000000000
--- a/debugger/pos.ml
+++ /dev/null
@@ -1,37 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Damien Doligez, projet Moscova, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2003 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Instruct;;
-open Lexing;;
-open Primitives;;
-open Source;;
-
-let get_desc ev =
- if ev.ev_char.pos_fname <> ""
- then Printf.sprintf "file %s, line %d, character %d"
- ev.ev_char.pos_fname ev.ev_char.pos_lnum
- (ev.ev_char.pos_cnum - ev.ev_char.pos_bol + 1)
- else begin
- let filename = source_of_module ev.ev_module in
- try
- let (start, line) = line_of_pos (get_buffer ev.ev_module)
- ev.ev_char.pos_cnum
- in
- Printf.sprintf "file %s, line %d, character %d"
- filename line (ev.ev_char.pos_cnum - start + 1)
- with Not_found | Out_of_range ->
- Printf.sprintf "file %s, character %d"
- filename (ev.ev_char.pos_cnum + 1)
- end
-;;
diff --git a/debugger/pos.mli b/debugger/pos.mli
deleted file mode 100644
index e7632e4274..0000000000
--- a/debugger/pos.mli
+++ /dev/null
@@ -1,15 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Damien Doligez, projet Moscova, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2003 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-val get_desc : Instruct.debug_event -> string;;
diff --git a/debugger/primitives.ml b/debugger/primitives.ml
deleted file mode 100644
index 1ad27e8a68..0000000000
--- a/debugger/primitives.ml
+++ /dev/null
@@ -1,194 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(*********************** Basic functions and types *********************)
-
-(*** Miscellaneous ***)
-exception Out_of_range
-
-let nothing _ = ()
-
-(*** Operations on lists. ***)
-
-(* Remove an element from a list *)
-let except e l =
- let rec except_e = function
- [] -> []
- | elem::l -> if e = elem then l else elem::except_e l
- in except_e l
-
-(* Position of an element in a list. Head of list has position 0. *)
-let index a l =
- let rec index_rec i = function
- [] -> raise Not_found
- | b::l -> if a = b then i else index_rec (i + 1) l
- in index_rec 0 l
-
-(* Remove an element from an association list *)
-let assoc_remove lst elem =
- let rec remove =
- function
- [] -> []
- | ((a, _) as c::t) ->
- if a = elem then t
- else c::(remove t)
- in remove lst
-
-(* Nth element of a list. *)
-let rec list_nth p0 p1 =
- match (p0,p1) with
- ([], _) ->
- invalid_arg "list_nth"
- | ((a::_), 0) ->
- a
- | ((_::l), n) ->
- list_nth l (n - 1)
-
-(* Return the `n' first elements of `l' *)
-(* ### n l -> l' *)
-let rec list_truncate =
- fun
- p0 p1 -> match (p0,p1) with (0, _) -> []
- | (_, []) -> []
- | (n, (a::l)) -> a::(list_truncate (n - 1) l)
-
-(* Separe the `n' first elements of `l' and the others *)
-(* ### n list -> (first, last) *)
-let rec list_truncate2 =
- fun
- p0 p1 -> match (p0,p1) with (0, l) ->
- ([], l)
- | (_, []) ->
- ([], [])
- | (n, (a::l)) ->
- let (first, last) = (list_truncate2 (n - 1) l) in
- (a::first, last)
-
-(* Replace x by y in list l *)
-(* ### x y l -> l' *)
-let list_replace x y =
- let rec repl =
- function
- [] -> []
- | a::l ->
- if a == x then y::l
- else a::(repl l)
- in repl
-
-(* Filter `list' according to `predicate'. *)
-(* ### predicate list -> list' *)
-let filter p =
- let rec filter2 =
- function
- [] ->
- []
- | a::l ->
- if p a then
- a::(filter2 l)
- else
- filter2 l
- in filter2
-
-(* Find the first element `element' of `list' *)
-(* so that `predicate element' holds. *)
-(* ### predicate list -> element *)
-let find p =
- let rec find2 =
- function
- [] ->
- raise Not_found
- | a::l ->
- if p a then a
- else find2 l
- in find2
-
-(*** Operations on strings. ***)
-
-(* Return the position of the first occurence of char `c' in string `s' *)
-(* Raise `Not_found' if `s' does not contain `c'. *)
-(* ### c s -> pos *)
-let string_pos s c =
- let i = ref 0 and l = String.length s in
- while !i < l && String.get s !i != c do i := !i + 1 done;
- if !i = l then raise Not_found;
- !i
-
-(* Remove blanks (spaces and tabs) at beginning and end of a string. *)
-let is_space = function
- | ' ' | '\t' -> true | _ -> false
-
-let string_trim s =
- let l = String.length s and i = ref 0 in
- while
- !i < l && is_space (String.get s !i)
- do
- incr i
- done;
- let j = ref (l - 1) in
- while
- !j >= !i && is_space (String.get s !j)
- do
- decr j
- done;
- String.sub s !i (!j - !i + 1)
-
-(* isprefix s1 s2 returns true if s1 is a prefix of s2. *)
-
-let isprefix s1 s2 =
- let l1 = String.length s1 and l2 = String.length s2 in
- (l1 = l2 && s1 = s2) || (l1 < l2 && s1 = String.sub s2 0 l1)
-
-(* Split a string at the given delimiter char *)
-
-let split_string sep str =
- let rec split i j =
- if j >= String.length str then
- if i >= j then [] else [String.sub str i (j-i)]
- else if str.[j] = sep then
- if i >= j
- then skip_sep (j+1)
- else String.sub str i (j-i) :: skip_sep (j+1)
- else
- split i (j+1)
- and skip_sep j =
- if j < String.length str && str.[j] = sep
- then skip_sep (j+1)
- else split j j
- in split 0 0
-
-(*** I/O channels ***)
-
-type io_channel = {
- io_in : in_channel;
- io_out : out_channel;
- io_fd : Unix.file_descr
- }
-
-let io_channel_of_descr fd = {
- io_in = Unix.in_channel_of_descr fd;
- io_out = Unix.out_channel_of_descr fd;
- io_fd = fd
- }
-
-let close_io io_channel =
- close_out_noerr io_channel.io_out;
- close_in_noerr io_channel.io_in;
-;;
-
-let std_io = {
- io_in = stdin;
- io_out = stdout;
- io_fd = Unix.stdin
- }
diff --git a/debugger/primitives.mli b/debugger/primitives.mli
deleted file mode 100644
index 40effea556..0000000000
--- a/debugger/primitives.mli
+++ /dev/null
@@ -1,86 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(********************* Basic functions and types ***********************)
-
-(*** Miscellaneous ***)
-val nothing : 'a -> unit
-
-(*** Types and exceptions. ***)
-exception Out_of_range
-
-(*** Operations on lists. ***)
-
-(* Remove an element from a list *)
-val except : 'a -> 'a list -> 'a list
-
-(* Position of an element in a list. Head of list has position 0. *)
-val index : 'a -> 'a list -> int
-
-(* Remove on element from an association list. *)
-val assoc_remove : ('a * 'b) list -> 'a -> ('a * 'b) list
-
-(* Nth element of a list. *)
-val list_nth : 'a list -> int -> 'a
-
-(* Return the `n' first elements of `l'. *)
-(* ### n l -> l' *)
-val list_truncate : int -> 'a list -> 'a list
-
-(* Separe the `n' first elements of `l' and the others. *)
-(* ### n list -> (first, last) *)
-val list_truncate2 : int -> 'a list -> 'a list * 'a list
-
-(* Replace x by y in list l *)
-(* ### x y l -> l' *)
-val list_replace : 'a -> 'a -> 'a list -> 'a list
-
-(* Filter `list' according to `predicate'. *)
-(* ### predicate list -> list' *)
-val filter : ('a -> bool) -> 'a list -> 'a list
-
-(* Find the first element `element' of `list' *)
-(* so that `predicate element' holds. *)
-(* Raise `Not_found' if no such element. *)
-(* ### predicate list -> element *)
-val find : ('a -> bool) -> 'a list -> 'a
-
-(*** Operations on strings. ***)
-
-(* Return the position of the first occurence of char `c' in string `s' *)
-(* Raise `Not_found' if `s' does not contain `c'. *)
-(* ### c s -> pos *)
-val string_pos : string -> char -> int
-
-(* Remove blanks (spaces and tabs) at beginning and end of a string. *)
-val string_trim : string -> string
-
-(* isprefix s1 s2 returns true if s1 is a prefix of s2. *)
-val isprefix : string -> string -> bool
-
-(* Split a string at the given delimiter char *)
-val split_string : char -> string -> string list
-
-(*** I/O channels ***)
-
-type io_channel = {
- io_in : in_channel;
- io_out : out_channel;
- io_fd : Unix.file_descr
- }
-
-val io_channel_of_descr : Unix.file_descr -> io_channel
-val close_io : io_channel -> unit
-val std_io : io_channel
diff --git a/debugger/printval.ml b/debugger/printval.ml
deleted file mode 100644
index 4fa3055b04..0000000000
--- a/debugger/printval.ml
+++ /dev/null
@@ -1,111 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* To print values *)
-
-open Misc
-open Obj
-open Format
-open Parser_aux
-open Path
-open Types
-
-(* To name printed and ellipsed values *)
-
-let named_values =
- (Hashtbl.create 29 : (int, Debugcom.Remote_value.t * type_expr) Hashtbl.t)
-let next_name = ref 1
-
-let reset_named_values () =
- Hashtbl.clear named_values;
- next_name := 1
-
-let name_value v ty =
- let name = !next_name in
- incr next_name;
- Hashtbl.add named_values name (v, ty);
- name
-
-let find_named_value name =
- Hashtbl.find named_values name
-
-let check_depth ppf depth obj ty =
- if depth <= 0 then begin
- let n = name_value obj ty in
- Some (Outcometree.Oval_stuff ("$" ^ string_of_int n))
- end else None
-
-module EvalPath =
- struct
- type value = Debugcom.Remote_value.t
- exception Error
- let rec eval_path = function
- Pident id ->
- begin try
- Debugcom.Remote_value.global (Symtable.get_global_position id)
- with Symtable.Error _ ->
- raise Error
- end
- | Pdot(root, fieldname, pos) ->
- let v = eval_path root in
- if not (Debugcom.Remote_value.is_block v)
- then raise Error
- else Debugcom.Remote_value.field v pos
- | Papply(p1, p2) ->
- raise Error
- let same_value = Debugcom.Remote_value.same
- end
-
-module Printer = Genprintval.Make(Debugcom.Remote_value)(EvalPath)
-
-let install_printer path ty ppf fn =
- Printer.install_printer path ty
- (fun ppf remote_val ->
- try
- fn ppf (Obj.repr (Debugcom.Remote_value.obj remote_val))
- with
- Debugcom.Marshalling_error ->
- fprintf ppf "<cannot fetch remote object>")
-
-let remove_printer = Printer.remove_printer
-
-let max_printer_depth = ref 20
-let max_printer_steps = ref 300
-
-let print_exception ppf obj =
- let t = Printer.outval_of_untyped_exception obj in
- !Oprint.out_value ppf t
-
-let print_value max_depth env obj (ppf : Format.formatter) ty =
- let t =
- Printer.outval_of_value !max_printer_steps max_depth
- (check_depth ppf) env obj ty in
- !Oprint.out_value ppf t
-
-let print_named_value max_depth exp env obj ppf ty =
- let print_value_name ppf = function
- | E_ident lid ->
- Printtyp.longident ppf lid
- | E_name n ->
- fprintf ppf "$%i" n
- | _ ->
- let n = name_value obj ty in
- fprintf ppf "$%i" n in
- Printtyp.reset_and_mark_loops ty;
- fprintf ppf "@[<2>%a :@ %a@ =@ %a@]@."
- print_value_name exp
- Printtyp.type_expr ty
- (print_value max_depth env obj) ty
-
diff --git a/debugger/printval.mli b/debugger/printval.mli
deleted file mode 100644
index d100a4333b..0000000000
--- a/debugger/printval.mli
+++ /dev/null
@@ -1,33 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Format
-
-val max_printer_depth : int ref
-val max_printer_steps : int ref
-
-val print_exception: formatter -> Debugcom.Remote_value.t -> unit
-val print_named_value :
- int -> Parser_aux.expression -> Env.t ->
- Debugcom.Remote_value.t -> formatter -> Types.type_expr ->
- unit
-
-val reset_named_values : unit -> unit
-val find_named_value : int -> Debugcom.Remote_value.t * Types.type_expr
-
-val install_printer :
- Path.t -> Types.type_expr -> formatter ->
- (formatter -> Obj.t -> unit) -> unit
-val remove_printer : Path.t -> unit
diff --git a/debugger/program_loading.ml b/debugger/program_loading.ml
deleted file mode 100644
index edcf3b1ed7..0000000000
--- a/debugger/program_loading.ml
+++ /dev/null
@@ -1,114 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Program loading *)
-
-open Unix
-open Misc
-open Debugger_config
-open Parameters
-open Input_handling
-
-(*** Debugging. ***)
-
-let debug_loading = ref false
-
-(*** Load a program. ***)
-
-(* Function used for launching the program. *)
-let launching_func = ref (function () -> ())
-
-let load_program () =
- !launching_func ();
- main_loop ()
-
-(*** Launching functions. ***)
-
-(* A generic function for launching the program *)
-let generic_exec cmdline = function () ->
- if !debug_loading then
- prerr_endline "Launching program...";
- let child =
- try
- fork ()
- with x ->
- Unix_tools.report_error x;
- raise Toplevel in
- match child with
- 0 ->
- begin try
- match fork () with
- 0 -> (* Try to detach the process from the controlling terminal,
- so that it does not receive SIGINT on ctrl-C. *)
- begin try ignore(setsid()) with Invalid_argument _ -> () end;
- execv shell [| shell; "-c"; cmdline() |]
- | _ -> exit 0
- with x ->
- Unix_tools.report_error x;
- exit 1
- end
- | _ ->
- match wait () with
- (_, WEXITED 0) -> ()
- | _ -> raise Toplevel
-
-(* Execute the program by calling the runtime explicitely *)
-let exec_with_runtime =
- generic_exec
- (function () ->
- Printf.sprintf "CAML_DEBUG_SOCKET=%s %s %s %s"
- !socket_name
- runtime_program
- !program_name
- !arguments)
-
-(* Excute the program directly *)
-let exec_direct =
- generic_exec
- (function () ->
- Printf.sprintf "CAML_DEBUG_SOCKET=%s %s %s"
- !socket_name
- !program_name
- !arguments)
-
-(* Ask the user. *)
-let exec_manual =
- function () ->
- print_newline ();
- print_string "Waiting for connection...";
- print_string ("(the socket is " ^ !socket_name ^ ")");
- print_newline ()
-
-(*** Selection of the launching function. ***)
-
-type launching_function = (unit -> unit)
-
-let loading_modes =
- ["direct", exec_direct;
- "runtime", exec_with_runtime;
- "manual", exec_manual]
-
-let set_launching_function func =
- launching_func := func
-
-(* Initialization *)
-
-let _ =
- set_launching_function exec_direct
-
-(*** Connection. ***)
-
-let connection = ref Primitives.std_io
-let connection_opened = ref false
diff --git a/debugger/program_loading.mli b/debugger/program_loading.mli
deleted file mode 100644
index d1210d1ab0..0000000000
--- a/debugger/program_loading.mli
+++ /dev/null
@@ -1,34 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(*** Debugging. ***)
-
-val debug_loading : bool ref
-
-(*** Load program ***)
-
-(* Function used for launching the program. *)
-val launching_func : (unit -> unit) ref
-
-val load_program : unit -> unit
-
-type launching_function = (unit -> unit)
-
-val loading_modes : (string * launching_function) list
-val set_launching_function : launching_function -> unit
-
-(** Connection **)
-val connection : Primitives.io_channel ref
-val connection_opened : bool ref
diff --git a/debugger/program_management.ml b/debugger/program_management.ml
deleted file mode 100644
index ec5877fc26..0000000000
--- a/debugger/program_management.ml
+++ /dev/null
@@ -1,157 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Manage the loading of the program *)
-
-open Int64ops
-open Unix
-open Unix_tools
-open Debugger_config
-open Misc
-open Instruct
-open Primitives
-open Parameters
-open Input_handling
-open Debugcom
-open Program_loading
-open Time_travel
-
-(*** Connection opening and control. ***)
-
-(* Name of the file if the socket is in the unix domain.*)
-let file_name = ref (None : string option)
-
-(* Default connection handler. *)
-let buffer = String.create 1024
-let control_connection pid fd =
- if (read fd.io_fd buffer 0 1024) = 0 then
- forget_process fd pid
- else begin
- prerr_string "Garbage data from process ";
- prerr_int pid;
- prerr_endline ""
- end
-
-(* Accept a connection from another process. *)
-let accept_connection continue fd =
- let (sock, _) = accept fd.io_fd in
- let io_chan = io_channel_of_descr sock in
- let pid = input_binary_int io_chan.io_in in
- if pid = -1 then begin
- let pid' = input_binary_int io_chan.io_in in
- new_checkpoint pid' io_chan;
- Input_handling.add_file io_chan (control_connection pid');
- continue ()
- end
- else begin
- if set_file_descriptor pid io_chan then
- Input_handling.add_file io_chan (control_connection pid)
- end
-
-(* Initialize the socket. *)
-let open_connection address continue =
- try
- let (sock_domain, sock_address) = convert_address address in
- file_name :=
- (match sock_address with
- ADDR_UNIX file ->
- Some file
- | _ ->
- None);
- let sock = socket sock_domain SOCK_STREAM 0 in
- (try
- bind sock sock_address;
- listen sock 3;
- connection := io_channel_of_descr sock;
- Input_handling.add_file !connection (accept_connection continue);
- connection_opened := true
- with x -> close sock; raise x)
- with
- Failure _ -> raise Toplevel
- | (Unix_error _) as err -> report_error err; raise Toplevel
-
-(* Close the socket. *)
-let close_connection () =
- if !connection_opened then begin
- connection_opened := false;
- Input_handling.remove_file !connection;
- close_io !connection;
- match !file_name with
- Some file ->
- unlink file
- | None ->
- ()
- end
-
-(*** Kill program. ***)
-let loaded = ref false
-
-let kill_program () =
- Breakpoints.remove_all_breakpoints ();
- History.empty_history ();
- kill_all_checkpoints ();
- loaded := false;
- close_connection ()
-
-let ask_kill_program () =
- if not !loaded then
- true
- else
- let answer = yes_or_no "A program is being debugged already. Kill it" in
- if answer then
- kill_program ();
- answer
-
-(*** Program loading and initializations. ***)
-
-let initialize_loading () =
- if !debug_loading then
- prerr_endline "Loading debugging informations...";
- begin try access !program_name [F_OK]
- with Unix_error _ ->
- prerr_endline "Program not found.";
- raise Toplevel;
- end;
- Symbols.read_symbols !program_name;
- if !debug_loading then
- prerr_endline "Opening a socket...";
- open_connection !socket_name
- (function () ->
- go_to _0;
- Symbols.set_all_events();
- exit_main_loop ())
-
-(* Ensure the program is already loaded. *)
-let ensure_loaded () =
- if not !loaded then begin
- print_string "Loading program... ";
- flush Pervasives.stdout;
- if !program_name = "" then begin
- prerr_endline "No program specified.";
- raise Toplevel
- end;
- try
- initialize_loading();
- !launching_func ();
- if !debug_loading then
- prerr_endline "Waiting for connection...";
- main_loop ();
- loaded := true;
- prerr_endline "done."
- with
- x ->
- kill_program();
- raise x
- end
diff --git a/debugger/program_management.mli b/debugger/program_management.mli
deleted file mode 100644
index 8e2f28e54e..0000000000
--- a/debugger/program_management.mli
+++ /dev/null
@@ -1,27 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(*** Program loading and initializations. ***)
-
-val loaded : bool ref
-val ensure_loaded : unit -> unit
-
-(*** Kill program. ***)
-val kill_program : unit -> unit
-
-(* Ask wether to kill the program or not. *)
-(* If yes, kill it. *)
-(* Return true iff the program has been killed. *)
-val ask_kill_program : unit -> bool
diff --git a/debugger/show_information.ml b/debugger/show_information.ml
deleted file mode 100644
index 7492ddc2e1..0000000000
--- a/debugger/show_information.ml
+++ /dev/null
@@ -1,94 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Instruct
-open Format
-open Primitives
-open Debugcom
-open Checkpoints
-open Events
-open Symbols
-open Frames
-open Show_source
-open Breakpoints
-
-(* Display information about the current event. *)
-let show_current_event ppf =
- fprintf ppf "Time : %Li" (current_time ());
- (match current_pc () with
- | Some pc ->
- fprintf ppf " - pc : %i" pc
- | _ -> ());
- update_current_event ();
- reset_frame ();
- match current_report () with
- | None ->
- fprintf ppf "@.Beginning of program.@.";
- show_no_point ()
- | Some {rep_type = (Event | Breakpoint); rep_program_pointer = pc} ->
- let (mdle, point) = current_point () in
- fprintf ppf " - module %s@." mdle;
- (match breakpoints_at_pc pc with
- | [] ->
- ()
- | [breakpoint] ->
- fprintf ppf "Breakpoint : %i@." breakpoint
- | breakpoints ->
- fprintf ppf "Breakpoints : %a@."
- (fun ppf l ->
- List.iter
- (function x -> fprintf ppf "%i " x) l)
- (List.sort compare breakpoints));
- show_point mdle point (current_event_is_before ()) true
- | Some {rep_type = Exited} ->
- fprintf ppf "@.Program exit.@.";
- show_no_point ()
- | Some {rep_type = Uncaught_exc} ->
- fprintf ppf
- "@.Program end.@.\
- @[Uncaught exception:@ %a@]@."
- Printval.print_exception (Debugcom.Remote_value.accu ());
- show_no_point ()
- | Some {rep_type = Trap_barrier} ->
- (* Trap_barrier not visible outside *)
- (* of module `time_travel'. *)
- Misc.fatal_error "Show_information.show_current_event"
-
-(* Display short information about one frame. *)
-
-let show_one_frame framenum ppf event =
- fprintf ppf "#%i Pc : %i %s char %i@."
- framenum event.ev_pos event.ev_module event.ev_char.Lexing.pos_cnum
-
-(* Display information about the current frame. *)
-(* --- `select frame' must have succeded before calling this function. *)
-let show_current_frame ppf selected =
- match !selected_event with
- | None ->
- fprintf ppf "@.No frame selected.@."
- | Some sel_ev ->
- show_one_frame !current_frame ppf sel_ev;
- begin match breakpoints_at_pc sel_ev.ev_pos with
- | [] -> ()
- | [breakpoint] ->
- fprintf ppf "Breakpoint : %i@." breakpoint
- | breakpoints ->
- fprintf ppf "Breakpoints : %a@."
- (fun ppf l ->
- List.iter (function x -> fprintf ppf "%i " x) l)
- (List.sort compare breakpoints);
- end;
- show_point sel_ev.ev_module sel_ev.ev_char.Lexing.pos_cnum
- (selected_event_is_before ()) selected
diff --git a/debugger/show_information.mli b/debugger/show_information.mli
deleted file mode 100644
index 3069f93321..0000000000
--- a/debugger/show_information.mli
+++ /dev/null
@@ -1,26 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Format;;
-
-(* Display information about the current event. *)
-val show_current_event : formatter -> unit;;
-
-(* Display information about the current frame. *)
-(* --- `select frame' must have succeded before calling this function. *)
-val show_current_frame : formatter -> bool -> unit;;
-
-(* Display short information about one frame. *)
-val show_one_frame : int -> formatter -> Instruct.debug_event -> unit
diff --git a/debugger/show_source.ml b/debugger/show_source.ml
deleted file mode 100644
index dd798cd5c8..0000000000
--- a/debugger/show_source.ml
+++ /dev/null
@@ -1,79 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Debugger_config
-open Parameters
-open Misc
-open Primitives
-open Source
-open Printf
-
-(* Print a line; return the beginning of the next line *)
-let print_line buffer line_number start point before =
- let next = next_linefeed buffer start
- and content = buffer_content buffer
- in
- printf "%i " line_number;
- if point <= next && point >= start then
- (print_string (String.sub content start (point - start));
- print_string (if before then event_mark_before else event_mark_after);
- print_string (String.sub content point (next - point)))
- else
- print_string (String.sub content start (next - start));
- print_newline ();
- next
-
-(* Tell Emacs we are nowhere in the source. *)
-let show_no_point () =
- if !emacs then printf "\026\026H\n"
-
-(* Print the line containing the point *)
-let show_point mdle point before selected =
- if !emacs && selected then
- begin try
- let source = source_of_module mdle in
- printf "\026\026M%s:%i" source point;
- printf "%s\n" (if before then ":before" else ":after")
- with
- Not_found -> (* get_buffer *)
- prerr_endline ("No source file for " ^ mdle ^ ".");
- show_no_point ()
- end
- else
- begin try
- let buffer = get_buffer mdle in
- let (start, line_number) = line_of_pos buffer point in
- ignore(print_line buffer line_number start point before)
- with
- Out_of_range -> (* line_of_pos *)
- prerr_endline "Position out of range."
- | Not_found -> (* get_buffer *)
- prerr_endline ("No source file for " ^ mdle ^ ".")
- end
-
-(* Display part of the source. *)
-let show_listing mdle start stop point before =
- try
- let buffer = get_buffer mdle in
- let rec aff (line_start, line_number) =
- if line_number <= stop then
- aff (print_line buffer line_number line_start point before + 1, line_number + 1)
- in
- aff (pos_of_line buffer start)
- with
- Out_of_range -> (* pos_of_line *)
- prerr_endline "Position out of range."
- | Not_found -> (* get_buffer *)
- prerr_endline ("No source file for " ^ mdle ^ ".")
diff --git a/debugger/show_source.mli b/debugger/show_source.mli
deleted file mode 100644
index 29f2f8c67e..0000000000
--- a/debugger/show_source.mli
+++ /dev/null
@@ -1,23 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Print the line containing the point *)
-val show_point : string -> int -> bool -> bool -> unit;;
-
-(* Tell Emacs we are nowhere in the source. *)
-val show_no_point : unit -> unit;;
-
-(* Display part of the source. *)
-val show_listing : string -> int -> int -> int -> bool -> unit;;
diff --git a/debugger/source.ml b/debugger/source.ml
deleted file mode 100644
index f937c782a0..0000000000
--- a/debugger/source.ml
+++ /dev/null
@@ -1,153 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(************************ Source management ****************************)
-
-open Misc
-open Primitives
-
-(*** Conversion function. ***)
-
-let source_of_module mdle =
- find_in_path_uncap !Config.load_path (mdle ^ ".ml")
-
-(*** Buffer cache ***)
-
-(* Buffer and cache (to associate lines and positions in the buffer). *)
-type buffer = string * (int * int) list ref
-
-let buffer_max_count = ref 10
-
-let cache_size = 30
-
-let buffer_list =
- ref ([] : (string * buffer) list)
-
-let flush_buffer_list () =
- buffer_list := []
-
-let get_buffer mdle =
- try List.assoc mdle !buffer_list with
- Not_found ->
- let inchan = open_in_bin (source_of_module mdle) in
- let (content, _) as buffer =
- (String.create (in_channel_length inchan), ref [])
- in
- unsafe_really_input inchan content 0 (in_channel_length inchan);
- buffer_list :=
- (list_truncate !buffer_max_count ((mdle, buffer)::!buffer_list));
- buffer
-
-let buffer_content =
- (fst : buffer -> string)
-
-let buffer_length x =
- String.length (buffer_content x)
-
-(*** Position conversions. ***)
-
-type position = int * int
-
-(* Insert a new pair (position, line) in the cache of the given buffer. *)
-let insert_pos buffer ((position, line) as pair) =
- let rec new_list =
- function
- [] ->
- [(position, line)]
- | ((pos, lin) as a::l) as l' ->
- if lin < line then
- pair::l'
- else if lin = line then
- l'
- else
- a::(new_list l)
- in
- let buffer_cache = snd buffer in
- buffer_cache := new_list !buffer_cache
-
-(* Position of the next linefeed after `pos'. *)
-(* Position just after the buffer end if no linefeed found. *)
-(* Raise `Out_of_range' if already there. *)
-let next_linefeed (buffer, _) pos =
- let len = String.length buffer in
- if pos >= len then
- raise Out_of_range
- else
- let rec search p =
- if p = len || String.get buffer p = '\n' then
- p
- else
- search (succ p)
- in
- search pos
-
-(* Go to next line. *)
-let next_line buffer (pos, line) =
- (next_linefeed buffer pos + 1, line + 1)
-
-(* Convert a position in the buffer to a line number. *)
-let line_of_pos buffer position =
- let rec find =
- function
- | [] ->
- if position < 0 then
- raise Out_of_range
- else
- (0, 1)
- | ((pos, line) as pair)::l ->
- if pos > position then
- find l
- else
- pair
- and find_line previous =
- let (pos, line) as next = next_line buffer previous in
- if pos <= position then
- find_line next
- else
- previous
- in
- let result = find_line (find !(snd buffer)) in
- insert_pos buffer result;
- result
-
-(* Convert a line number to a position. *)
-let pos_of_line buffer line =
- let rec find =
- function
- [] ->
- if line <= 0 then
- raise Out_of_range
- else
- (0, 1)
- | ((pos, lin) as pair)::l ->
- if lin > line then
- find l
- else
- pair
- and find_pos previous =
- let (_, lin) as next = next_line buffer previous in
- if lin <= line then
- find_pos next
- else
- previous
- in
- let result = find_pos (find !(snd buffer)) in
- insert_pos buffer result;
- result
-
-(* Convert a coordinate (line / column) into a position. *)
-(* --- The first line and column are line 1 and column 1. *)
-let point_of_coord buffer line column =
- fst (pos_of_line buffer line) + (pred column)
diff --git a/debugger/source.mli b/debugger/source.mli
deleted file mode 100644
index cfd5fe0705..0000000000
--- a/debugger/source.mli
+++ /dev/null
@@ -1,58 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(************************ Source management ****************************)
-
-(*** Conversion function. ***)
-
-val source_of_module: string -> string
-
-(*** buffer cache ***)
-
-type buffer
-
-val buffer_max_count : int ref
-
-val flush_buffer_list : unit -> unit
-
-val get_buffer : string -> buffer
-
-val buffer_content : buffer -> string
-val buffer_length : buffer -> int
-
-(*** Position conversions. ***)
-
-(* Pair (position, line) where `position' is the position in character of *)
-(* the beginning of the line (first character is 0) and `line' is its *)
-(* number (first line number is 1). *)
-type position = int * int
-
-(* Position of the next linefeed after `pos'. *)
-(* Position just after the buffer end if no linefeed found. *)
-(* Raise `Out_of_range' if already there. *)
-val next_linefeed : buffer -> int -> int
-
-(* Go to next line. *)
-val next_line : buffer -> position -> position
-
-(* Convert a position in the buffer to a line number. *)
-val line_of_pos : buffer -> int -> position
-
-(* Convert a line number to a position. *)
-val pos_of_line : buffer -> int -> position
-
-(* Convert a coordinate (line / column) into a position. *)
-(* --- The first line and column are line 1 and column 1. *)
-val point_of_coord : buffer -> int -> int -> int
diff --git a/debugger/symbols.ml b/debugger/symbols.ml
deleted file mode 100644
index 031bec6402..0000000000
--- a/debugger/symbols.ml
+++ /dev/null
@@ -1,169 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Handling of symbol tables (globals and events) *)
-
-open Instruct
-open Debugger_config (* Toplevel *)
-
-let modules =
- ref ([] : string list)
-
-let events =
- ref ([] : debug_event list)
-let events_by_pc =
- (Hashtbl.create 257 : (int, debug_event) Hashtbl.t)
-let events_by_module =
- (Hashtbl.create 17 : (string, debug_event array) Hashtbl.t)
-let all_events_by_module =
- (Hashtbl.create 17 : (string, debug_event list) Hashtbl.t)
-
-let relocate_event orig ev =
- ev.ev_pos <- orig + ev.ev_pos;
- match ev.ev_repr with
- Event_parent repr -> repr := ev.ev_pos
- | _ -> ()
-
-let read_symbols' bytecode_file =
- let ic = open_in_bin bytecode_file in
- begin try
- Bytesections.read_toc ic;
- ignore(Bytesections.seek_section ic "SYMB");
- with Bytesections.Bad_magic_number | Not_found ->
- prerr_string bytecode_file; prerr_endline " is not a bytecode file.";
- raise Toplevel
- end;
- Symtable.restore_state (input_value ic);
- begin try
- ignore (Bytesections.seek_section ic "DBUG")
- with Not_found ->
- prerr_string bytecode_file; prerr_endline " has no debugging info.";
- raise Toplevel
- end;
- let num_eventlists = input_binary_int ic in
- let eventlists = ref [] in
- for i = 1 to num_eventlists do
- let orig = input_binary_int ic in
- let evl = (input_value ic : debug_event list) in
- (* Relocate events in event list *)
- List.iter (relocate_event orig) evl;
- eventlists := evl :: !eventlists
- done;
- close_in_noerr ic;
- !eventlists
-
-let read_symbols bytecode_file =
- let all_events = read_symbols' bytecode_file in
-
- modules := []; events := [];
- Hashtbl.clear events_by_pc; Hashtbl.clear events_by_module;
- Hashtbl.clear all_events_by_module;
-
- List.iter
- (fun evl ->
- List.iter
- (fun ev ->
- events := ev :: !events;
- Hashtbl.add events_by_pc ev.ev_pos ev)
- evl)
- all_events;
-
- List.iter
- (function
- [] -> ()
- | ev :: _ as evl ->
- let md = ev.ev_module in
- let cmp ev1 ev2 = compare ev1.ev_char.Lexing.pos_cnum
- ev2.ev_char.Lexing.pos_cnum
- in
- let sorted_evl = List.sort cmp evl in
- modules := md :: !modules;
- Hashtbl.add all_events_by_module md sorted_evl;
- let real_evl =
- Primitives.filter
- (function
- {ev_kind = Event_pseudo} -> false
- | _ -> true)
- sorted_evl
- in
- Hashtbl.add events_by_module md (Array.of_list real_evl))
- all_events
-
-let any_event_at_pc pc =
- Hashtbl.find events_by_pc pc
-
-let event_at_pc pc =
- let ev = any_event_at_pc pc in
- match ev.ev_kind with
- Event_pseudo -> raise Not_found
- | _ -> ev
-
-let set_event_at_pc pc =
- try ignore(event_at_pc pc); Debugcom.set_event pc
- with Not_found -> ()
-
-(* List all events in module *)
-let events_in_module mdle =
- try
- Hashtbl.find all_events_by_module mdle
- with Not_found ->
- []
-
-(* Binary search of event at or just after char *)
-let find_event ev char =
- let rec bsearch lo hi =
- if lo >= hi then begin
- if ev.(hi).ev_char.Lexing.pos_cnum < char then raise Not_found;
- hi
- end else begin
- let pivot = (lo + hi) / 2 in
- let e = ev.(pivot) in
- if char <= e.ev_char.Lexing.pos_cnum then bsearch lo pivot
- else bsearch (pivot + 1) hi
- end
- in
- bsearch 0 (Array.length ev - 1)
-
-(* Return first event after the given position. *)
-(* Raise [Not_found] if module is unknown or no event is found. *)
-let event_at_pos md char =
- let ev = Hashtbl.find events_by_module md in
- ev.(find_event ev char)
-
-(* Return event closest to given position *)
-(* Raise [Not_found] if module is unknown or no event is found. *)
-let event_near_pos md char =
- let ev = Hashtbl.find events_by_module md in
- try
- let pos = find_event ev char in
- (* Desired event is either ev.(pos) or ev.(pos - 1),
- whichever is closest *)
- if pos > 0 && char - ev.(pos - 1).ev_char.Lexing.pos_cnum
- <= ev.(pos).ev_char.Lexing.pos_cnum - char
- then ev.(pos - 1)
- else ev.(pos)
- with Not_found ->
- let pos = Array.length ev - 1 in
- if pos < 0 then raise Not_found;
- ev.(pos)
-
-(* Flip "event" bit on all instructions *)
-let set_all_events () =
- Hashtbl.iter
- (fun pc ev ->
- match ev.ev_kind with
- Event_pseudo -> ()
- | _ -> Debugcom.set_event ev.ev_pos)
- events_by_pc
diff --git a/debugger/symbols.mli b/debugger/symbols.mli
deleted file mode 100644
index 0cb1e2e573..0000000000
--- a/debugger/symbols.mli
+++ /dev/null
@@ -1,44 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Modules used by the program. *)
-val modules : string list ref
-
-(* Read debugging info from executable file *)
-val read_symbols : string -> unit
-
-(* Flip "event" bit on all instructions *)
-val set_all_events : unit -> unit
-
-(* Return event at given PC, or raise Not_found *)
-(* Can also return pseudo-event at beginning of functions *)
-val any_event_at_pc : int -> Instruct.debug_event
-
-(* Return event at given PC, or raise Not_found *)
-val event_at_pc : int -> Instruct.debug_event
-(* Set event at given PC *)
-val set_event_at_pc : int -> unit
-
-(* List the events in `module'. *)
-val events_in_module : string -> Instruct.debug_event list
-
-(* First event after the given position. *)
-(* --- Raise `Not_found' if no such event. *)
-val event_at_pos : string -> int -> Instruct.debug_event
-
-(* Closest event from given position. *)
-(* --- Raise `Not_found' if no such event. *)
-val event_near_pos : string -> int -> Instruct.debug_event
-
diff --git a/debugger/time_travel.ml b/debugger/time_travel.ml
deleted file mode 100644
index eb98f1059c..0000000000
--- a/debugger/time_travel.ml
+++ /dev/null
@@ -1,642 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(**************************** Time travel ******************************)
-
-open Int64ops
-open Instruct
-open Events
-open Debugcom
-open Primitives
-open Checkpoints
-open Breakpoints
-open Trap_barrier
-open Input_handling
-open Debugger_config
-open Program_loading
-
-exception Current_checkpoint_lost
-
-let remove_1st key list =
- let rec remove =
- function
- [] -> []
- | a::l -> if a == key then l else a::(remove l)
- in
- remove list
-
-(*** Debugging. ***)
-
-let debug_time_travel = ref false
-
-(*** Internal utilities. ***)
-
-(* Insert a checkpoint in the checkpoint list.
- * Raise `Exit' if there is already a checkpoint at the same time.
- *)
-let insert_checkpoint ({c_time = time} as checkpoint) =
- let rec traverse =
- function
- [] -> [checkpoint]
- | (({c_time = t} as a)::l) as l' ->
- if t > time then
- a::(traverse l)
- else if t = time then
- raise Exit
- else
- checkpoint::l'
- in
- checkpoints := traverse !checkpoints
-
-(* Remove a checkpoint from the checkpoint list.
- * --- No error if not found.
- *)
-let remove_checkpoint checkpoint =
- checkpoints := remove_1st checkpoint !checkpoints
-
-(* Wait for the process used by `checkpoint' to connect.
- * --- Usually not called (the process is already connected).
- *)
-let wait_for_connection checkpoint =
- try
- Exec.unprotect
- (function () ->
- let old_controller = Input_handling.current_controller !connection in
- execute_with_other_controller
- (function
- fd ->
- old_controller fd;
- if checkpoint.c_valid = true then
- exit_main_loop ())
- !connection
- main_loop)
- with
- Sys.Break ->
- checkpoint.c_parent <- root;
- remove_checkpoint checkpoint;
- checkpoint.c_pid <- -1;
- raise Sys.Break
-
-(* Select a checkpoint as current. *)
-let set_current_checkpoint checkpoint =
- if !debug_time_travel then
- prerr_endline ("Select : " ^ (string_of_int checkpoint.c_pid));
- if not checkpoint.c_valid then
- wait_for_connection checkpoint;
- current_checkpoint := checkpoint;
- set_current_connection checkpoint.c_fd
-
-(* Kill `checkpoint'. *)
-let kill_checkpoint checkpoint =
- if !debug_time_travel then
- prerr_endline ("Kill : " ^ (string_of_int checkpoint.c_pid));
- if checkpoint.c_pid > 0 then (* Ghosts don't have to be killed ! *)
- (if not checkpoint.c_valid then
- wait_for_connection checkpoint;
- stop checkpoint.c_fd;
- if checkpoint.c_parent.c_pid > 0 then
- wait_child checkpoint.c_parent.c_fd;
- checkpoint.c_parent <- root;
- close_io checkpoint.c_fd;
- remove_file checkpoint.c_fd;
- remove_checkpoint checkpoint);
- checkpoint.c_pid <- -1 (* Don't exist anymore *)
-
-(*** Cleaning the checkpoint list. ***)
-
-(* Separe checkpoints before (<=) and after (>) `t'. *)
-(* ### t checkpoints -> (after, before) *)
-let cut t =
- let rec cut_t =
- function
- [] -> ([], [])
- | ({c_time = t'} as a::l) as l' ->
- if t' <= t then
- ([], l')
- else
- let (b, e) = cut_t l in
- (a::b, e)
- in
- cut_t
-
-(* Partition the checkpoints list. *)
-let cut2 t0 t l =
- let rec cut2_t0 t =
- function
- [] -> []
- | l ->
- let (after, before) = cut (t0 -- t -- _1) l in
- let l = cut2_t0 (t ++ t) before in
- after::l
- in
- let (after, before) = cut (t0 -- _1) l in
- after::(cut2_t0 t before)
-
-(* Separe first elements and last element of a list of checkpoint. *)
-let chk_merge2 cont =
- let rec chk_merge2_cont =
- function
- [] -> cont
- | [a] ->
- let (accepted, rejected) = cont in
- (a::accepted, rejected)
- | a::l ->
- let (accepted, rejected) = chk_merge2_cont l in
- (accepted, a::rejected)
- in chk_merge2_cont
-
-(* Separe the checkpoint list. *)
-(* ### list -> accepted * rejected *)
-let rec chk_merge =
- function
- [] -> ([], [])
- | l::tail ->
- chk_merge2 (chk_merge tail) l
-
-let new_checkpoint_list checkpoint_count accepted rejected =
- if List.length accepted >= checkpoint_count then
- let (k, l) = list_truncate2 checkpoint_count accepted in
- (k, l @ rejected)
- else
- let (k, l) =
- list_truncate2 (checkpoint_count - List.length accepted) rejected
- in
- (List.merge (fun {c_time = t1} {c_time = t2} -> compare t2 t1) accepted k,
- l)
-
-(* Clean the checkpoint list. *)
-(* Reference time is `time'. *)
-let clean_checkpoints time checkpoint_count =
- let (after, before) = cut time !checkpoints in
- let (accepted, rejected) =
- chk_merge (cut2 time !checkpoint_small_step before)
- in
- let (kept, lost) =
- new_checkpoint_list checkpoint_count accepted after
- in
- List.iter kill_checkpoint (lost @ rejected);
- checkpoints := kept
-
-(*** Internal functions for moving. ***)
-
-(* Find the first checkpoint before (or at) `time'.
- * Ask for reloading the program if necessary.
- *)
-let find_checkpoint_before time =
- let rec find =
- function
- [] ->
- print_string "Can't go that far in the past !"; print_newline ();
- if yes_or_no "Reload program" then begin
- load_program ();
- find !checkpoints
- end
- else
- raise Toplevel
- | { c_time = t } as a::l ->
- if t > time then
- find l
- else
- a
- in find !checkpoints
-
-(* Make a copy of the current checkpoint and clean the checkpoint list. *)
-(* --- The new checkpoint in not put in the list. *)
-let duplicate_current_checkpoint () =
- let checkpoint = !current_checkpoint in
- if not checkpoint.c_valid then
- wait_for_connection checkpoint;
- let new_checkpoint = (* Ghost *)
- {c_time = checkpoint.c_time;
- c_pid = 0;
- c_fd = checkpoint.c_fd;
- c_valid = false;
- c_report = checkpoint.c_report;
- c_state = C_stopped;
- c_parent = checkpoint;
- c_breakpoint_version = checkpoint.c_breakpoint_version;
- c_breakpoints = checkpoint.c_breakpoints;
- c_trap_barrier = checkpoint.c_trap_barrier}
- in
- checkpoints := list_replace checkpoint new_checkpoint !checkpoints;
- set_current_checkpoint checkpoint;
- clean_checkpoints (checkpoint.c_time ++ _1) (!checkpoint_max_count - 1);
- if new_checkpoint.c_pid = 0 then (* The ghost has not been killed *)
- (match do_checkpoint () with (* Duplicate checkpoint *)
- Checkpoint_done pid ->
- (new_checkpoint.c_pid <- pid;
- if !debug_time_travel then
- prerr_endline ("Waiting for connection : " ^ (string_of_int pid)))
- | Checkpoint_failed ->
- prerr_endline
- "A fork failed. Reducing maximum number of checkpoints.";
- checkpoint_max_count := List.length !checkpoints - 1;
- remove_checkpoint new_checkpoint)
-
-(* Was the movement interrupted ? *)
-(* --- An exception could have been used instead, *)
-(* --- but it is not clear where it should be caught. *)
-(* --- For instance, it should not be caught in `step' *)
-(* --- (as `step' is used in `next_1'). *)
-(* --- On the other side, other modules does not need to know *)
-(* --- about this exception. *)
-let interrupted = ref false
-
-(* Informations about last breakpoint encountered *)
-let last_breakpoint = ref None
-
-(* Ensure we stop on an event. *)
-let rec stop_on_event report =
- match report with
- {rep_type = Breakpoint; rep_program_pointer = pc;
- rep_stack_pointer = sp} ->
- last_breakpoint := Some (pc, sp);
- update_current_event ();
- begin match !current_event with
- None -> find_event ()
- | Some _ -> ()
- end
- | {rep_type = Trap_barrier; rep_stack_pointer = trap_frame} ->
- (* No event at current position. *)
- find_event ()
- | _ ->
- ()
-
-and find_event () =
- if !debug_time_travel then begin
- print_string "Searching next event...";
- print_newline ()
- end;
- let report = do_go _1 in
- !current_checkpoint.c_report <- Some report;
- stop_on_event report
-
-(* Internal function for running debugged program.
- * Requires `duration > 0'.
- *)
-let internal_step duration =
- match current_report () with
- Some {rep_type = Exited | Uncaught_exc} -> ()
- | _ ->
- Exec.protect
- (function () ->
- if !make_checkpoints then
- duplicate_current_checkpoint ()
- else
- remove_checkpoint !current_checkpoint;
- update_breakpoints ();
- update_trap_barrier ();
- !current_checkpoint.c_state <- C_running duration;
- let report = do_go duration in
- !current_checkpoint.c_report <- Some report;
- !current_checkpoint.c_state <- C_stopped;
- if report.rep_type = Event then begin
- !current_checkpoint.c_time <-
- !current_checkpoint.c_time ++ duration;
- interrupted := false;
- last_breakpoint := None
- end
- else begin
- !current_checkpoint.c_time <-
- !current_checkpoint.c_time ++ duration
- -- (Int64.of_int report.rep_event_count) ++ _1;
- interrupted := true;
- last_breakpoint := None;
- stop_on_event report
- end;
- (try
- insert_checkpoint !current_checkpoint
- with
- Exit ->
- kill_checkpoint !current_checkpoint;
- set_current_checkpoint
- (find_checkpoint_before (current_time ()))));
- if !debug_time_travel then begin
- print_string "Checkpoints : pid(time)"; print_newline ();
- List.iter
- (function {c_time = time; c_pid = pid; c_valid = valid} ->
- Printf.printf "%d(%Ld)%s " pid time
- (if valid then "" else "(invalid)"))
- !checkpoints;
- print_newline ()
- end
-
-(*** Miscellaneous functions (exported). ***)
-
-(* Create a checkpoint at time 0 (new program). *)
-let new_checkpoint pid fd =
- let new_checkpoint =
- {c_time = _0;
- c_pid = pid;
- c_fd = fd;
- c_valid = true;
- c_report = None;
- c_state = C_stopped;
- c_parent = root;
- c_breakpoint_version = 0;
- c_breakpoints = [];
- c_trap_barrier = 0}
- in
- insert_checkpoint new_checkpoint
-
-(* Set the file descriptor of a checkpoint *)
-(* (a new process has connected with the debugger). *)
-(* --- Return `true' on success (close the connection otherwise). *)
-let set_file_descriptor pid fd =
- let rec find =
- function
- [] ->
- prerr_endline "Unexpected connection";
- close_io fd;
- false
- | ({c_pid = pid'} as checkpoint)::l ->
- if pid <> pid' then
- find l
- else
- (checkpoint.c_fd <- fd;
- checkpoint.c_valid <- true;
- true)
- in
- if !debug_time_travel then
- prerr_endline ("New connection : " ^(string_of_int pid));
- find (!current_checkpoint::!checkpoints)
-
-(* Kill all the checkpoints. *)
-let kill_all_checkpoints () =
- List.iter kill_checkpoint (!current_checkpoint::!checkpoints)
-
-(* Kill a checkpoint without killing the process. *)
-(* (used when connection with the process is lost). *)
-(* --- Assume that the checkpoint is valid. *)
-let forget_process fd pid =
- let checkpoint =
- find (function c -> c.c_pid = pid) (!current_checkpoint::!checkpoints)
- in
- Printf.eprintf "Lost connection with process %d" pid;
- if checkpoint = !current_checkpoint then begin
- Printf.eprintf " (active process)\n";
- match !current_checkpoint.c_state with
- C_stopped ->
- Printf.eprintf "at time %Ld" !current_checkpoint.c_time
- | C_running duration ->
- Printf.eprintf "between time %Ld and time %Ld"
- !current_checkpoint.c_time
- (!current_checkpoint.c_time ++ duration)
- end;
- Printf.eprintf "\n"; flush stderr;
- Input_handling.remove_file fd;
- close_io checkpoint.c_fd;
- remove_file checkpoint.c_fd;
- remove_checkpoint checkpoint;
- checkpoint.c_pid <- -1; (* Don't exist anymore *)
- if checkpoint.c_parent.c_pid > 0 then
- wait_child checkpoint.c_parent.c_fd;
- if checkpoint = !current_checkpoint then
- raise Current_checkpoint_lost
-
-(* Try to recover when the current checkpoint is lost. *)
-let recover () =
- set_current_checkpoint
- (find_checkpoint_before (current_time ()))
-
-(*** Simple movements. ***)
-
-(* Forward stepping. Requires `duration >= 0'. *)
-let rec step_forward duration =
- if duration > !checkpoint_small_step then begin
- let first_step =
- if duration > !checkpoint_big_step then
- !checkpoint_big_step
- else
- !checkpoint_small_step
- in
- internal_step first_step;
- if not !interrupted then
- step_forward (duration -- first_step)
- end
- else if duration != _0 then
- internal_step duration
-
-(* Go to time `time' from current checkpoint (internal). *)
-let internal_go_to time =
- let duration = time -- (current_time ()) in
- if duration > _0 then
- execute_without_breakpoints (function () -> step_forward duration)
-
-(* Move to a given time. *)
-let go_to time =
- let checkpoint = find_checkpoint_before time in
- set_current_checkpoint checkpoint;
- internal_go_to time
-
-(* Return the time of the last breakpoint *)
-(* between current time and `max_time'. *)
-let rec find_last_breakpoint max_time =
- let rec find break =
- let time = current_time () in
- step_forward (max_time -- time);
- match !last_breakpoint, !temporary_breakpoint_position with
- (Some _, _) when current_time () < max_time ->
- find !last_breakpoint
- | (Some (pc, _), Some pc') when pc = pc' ->
- (max_time, !last_breakpoint)
- | _ ->
- (time, break)
- in
- find
- (match current_pc_sp () with
- (Some (pc, _)) as state when breakpoint_at_pc pc -> state
- | _ -> None)
-
-
-(* Run from `time_max' back to `time'. *)
-(* --- Assume 0 <= time < time_max *)
-let rec back_to time time_max =
- let
- {c_time = t} as checkpoint = find_checkpoint_before (pre64 time_max)
- in
- go_to (max time t);
- let (new_time, break) = find_last_breakpoint time_max in
- if break <> None || (new_time <= time) then begin
- go_to new_time;
- interrupted := break <> None;
- last_breakpoint := break
- end else
- back_to time new_time
-
-(* Backward stepping. *)
-(* --- Assume duration > 1 *)
-let step_backward duration =
- let time = current_time () in
- if time > _0 then
- back_to (max _0 (time -- duration)) time
-
-(* Run the program from current time. *)
-(* Stop at the first breakpoint, or at the end of the program. *)
-let rec run () =
- internal_step !checkpoint_big_step;
- if not !interrupted then
- run ()
-
-(* Run backward the program form current time. *)
-(* Stop at the first breakpoint, or at the beginning of the program. *)
-let back_run () =
- if current_time () > _0 then
- back_to _0 (current_time ())
-
-(* Step in any direction. *)
-(* Stop at the first brakpoint, or after `duration' steps. *)
-let step duration =
- if duration >= _0 then
- step_forward duration
- else
- step_backward (_0 -- duration)
-
-(*** Next, finish. ***)
-
-(* Finish current function. *)
-let finish () =
- update_current_event ();
- match !current_event with
- None ->
- prerr_endline "`finish' not meaningful in outermost frame.";
- raise Toplevel
- | Some curr_event ->
- set_initial_frame();
- let (frame, pc) = up_frame curr_event.ev_stacksize in
- if frame < 0 then begin
- prerr_endline "`finish' not meaningful in outermost frame.";
- raise Toplevel
- end;
- begin
- try ignore(Symbols.any_event_at_pc pc)
- with Not_found ->
- prerr_endline "Calling function has no debugging information.";
- raise Toplevel
- end;
- exec_with_trap_barrier
- frame
- (fun () ->
- exec_with_temporary_breakpoint
- pc
- (fun () ->
- while
- run ();
- match !last_breakpoint with
- Some (pc', frame') when pc = pc' ->
- interrupted := false;
- frame <> frame'
- | _ ->
- false
- do
- ()
- done))
-
-let next_1 () =
- update_current_event ();
- match !current_event with
- None -> (* Beginning of the program. *)
- step _1
- | Some event1 ->
- let (frame1, pc1) = initial_frame() in
- step _1;
- if not !interrupted then begin
- update_current_event ();
- match !current_event with
- None -> ()
- | Some event2 ->
- let (frame2, pc2) = initial_frame() in
- (* Call `finish' if we've entered a function. *)
- if frame1 >= 0 && frame2 >= 0 &&
- frame2 - event2.ev_stacksize > frame1 - event1.ev_stacksize
- then finish()
- end
-
-(* Same as `step' (forward) but skip over function calls. *)
-let rec next =
- function
- 0 -> ()
- | n ->
- next_1 ();
- if not !interrupted then
- next (n - 1)
-
-(* Run backward until just before current function. *)
-let start () =
- update_current_event ();
- match !current_event with
- None ->
- prerr_endline "`start not meaningful in outermost frame.";
- raise Toplevel
- | Some curr_event ->
- let (frame, _) = initial_frame() in
- let (frame', pc) = up_frame curr_event.ev_stacksize in
- if frame' < 0 then begin
- prerr_endline "`start not meaningful in outermost frame.";
- raise Toplevel
- end;
- let nargs =
- match
- try Symbols.any_event_at_pc pc with Not_found ->
- prerr_endline "Calling function has no debugging information.";
- raise Toplevel
- with
- {ev_info = Event_return nargs} -> nargs
- | _ -> Misc.fatal_error "Time_travel.start"
- in
- let offset = if nargs < 4 then 1 else 2 in
- let pc = pc - 4 * offset in
- while
- exec_with_temporary_breakpoint pc back_run;
- match !last_breakpoint with
- Some (pc', frame') when pc = pc' ->
- step _minus1;
- (not !interrupted)
- &&
- (frame' - nargs > frame - curr_event.ev_stacksize)
- | _ ->
- false
- do
- ()
- done
-
-let previous_1 () =
- update_current_event ();
- match !current_event with
- None -> (* End of the program. *)
- step _minus1
- | Some event1 ->
- let (frame1, pc1) = initial_frame() in
- step _minus1;
- if not !interrupted then begin
- update_current_event ();
- match !current_event with
- None -> ()
- | Some event2 ->
- let (frame2, pc2) = initial_frame() in
- (* Call `start' if we've entered a function. *)
- if frame1 >= 0 && frame2 >= 0 &&
- frame2 - event2.ev_stacksize > frame1 - event1.ev_stacksize
- then start()
- end
-
-(* Same as `step' (backward) but skip over function calls. *)
-let rec previous =
- function
- 0 -> ()
- | n ->
- previous_1 ();
- if not !interrupted then
- previous (n - 1)
diff --git a/debugger/time_travel.mli b/debugger/time_travel.mli
deleted file mode 100644
index 81d01a6678..0000000000
--- a/debugger/time_travel.mli
+++ /dev/null
@@ -1,36 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(**************************** Time travel ******************************)
-
-open Primitives
-
-exception Current_checkpoint_lost
-
-val new_checkpoint : int -> io_channel -> unit
-val set_file_descriptor : int -> io_channel -> bool
-val kill_all_checkpoints : unit -> unit
-val forget_process : io_channel -> int -> unit
-val recover : unit -> unit
-
-val go_to : int64 -> unit
-
-val run : unit -> unit
-val back_run : unit -> unit
-val step : int64 -> unit
-val finish : unit -> unit
-val next : int -> unit
-val start : unit -> unit
-val previous : int -> unit
diff --git a/debugger/trap_barrier.ml b/debugger/trap_barrier.ml
deleted file mode 100644
index dba9c929f7..0000000000
--- a/debugger/trap_barrier.ml
+++ /dev/null
@@ -1,47 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(************************** Trap barrier *******************************)
-
-open Debugcom
-open Checkpoints
-
-let current_trap_barrier = ref 0
-
-let install_trap_barrier pos =
- current_trap_barrier := pos
-
-let remove_trap_barrier () =
- current_trap_barrier := 0
-
-(* Ensure the trap barrier state is up to date in current checkpoint. *)
-let update_trap_barrier () =
- if !current_checkpoint.c_trap_barrier <> !current_trap_barrier then
- Exec.protect
- (function () ->
- set_trap_barrier !current_trap_barrier;
- !current_checkpoint.c_trap_barrier <- !current_trap_barrier)
-
-(* Execute `funct' with a trap barrier. *)
-(* --- Used by `finish'. *)
-let exec_with_trap_barrier trap_barrier funct =
- try
- install_trap_barrier trap_barrier;
- funct ();
- remove_trap_barrier ()
- with
- x ->
- remove_trap_barrier ();
- raise x
diff --git a/debugger/trap_barrier.mli b/debugger/trap_barrier.mli
deleted file mode 100644
index 28bba5a3eb..0000000000
--- a/debugger/trap_barrier.mli
+++ /dev/null
@@ -1,27 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(************************* Trap barrier ********************************)
-
-val install_trap_barrier : int -> unit
-
-val remove_trap_barrier : unit -> unit
-
-(* Ensure the trap barrier state is up to date in current checkpoint. *)
-val update_trap_barrier : unit -> unit
-
-(* Execute `funct' with a trap barrier. *)
-(* --- Used by `finish'. *)
-val exec_with_trap_barrier : int -> (unit -> unit) -> unit
diff --git a/debugger/unix_tools.ml b/debugger/unix_tools.ml
deleted file mode 100644
index 5061bb1ddf..0000000000
--- a/debugger/unix_tools.ml
+++ /dev/null
@@ -1,141 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(****************** Tools for Unix *************************************)
-
-open Misc
-open Unix
-open Primitives
-
-(*** Convert a socket name into a socket address. ***)
-let convert_address address =
- try
- let n = string_pos address ':' in
- let host = String.sub address 0 n
- and port = String.sub address (n + 1) (String.length address - n - 1)
- in
- (PF_INET,
- ADDR_INET
- ((try inet_addr_of_string host with Failure _ ->
- try (gethostbyname host).h_addr_list.(0) with Not_found ->
- prerr_endline ("Unknown host : " ^ host);
- failwith "Can't convert address"),
- (try int_of_string port with Failure _ ->
- prerr_endline "The port number should be an integer";
- failwith "Can't convert address")))
- with Not_found ->
- (PF_UNIX, ADDR_UNIX address)
-
-(*** Report a unix error. ***)
-let report_error = function
- | Unix_error (err, fun_name, arg) ->
- prerr_string "Unix error : '";
- prerr_string fun_name;
- prerr_string "' failed";
- if String.length arg > 0 then
- (prerr_string " on '";
- prerr_string arg;
- prerr_string "'");
- prerr_string " : ";
- prerr_endline (error_message err)
- | _ -> fatal_error "report_error: not a Unix error"
-
-(* Find program `name' in `PATH'. *)
-(* Return the full path if found. *)
-(* Raise `Not_found' otherwise. *)
-let search_in_path name =
- let check name =
- try access name [X_OK]; name with Unix_error _ -> raise Not_found
- in
- if not (Filename.is_implicit name) then
- check name
- else
- let path = Sys.getenv "PATH" in
- let length = String.length path in
- let rec traverse pointer =
- if (pointer >= length) || (path.[pointer] = ':') then
- pointer
- else
- traverse (pointer + 1)
- in
- let rec find pos =
- let pos2 = traverse pos in
- let directory = (String.sub path pos (pos2 - pos)) in
- let fullname =
- if directory = "" then name else directory ^ "/" ^ name
- in
- try check fullname with
- | Not_found ->
- if pos2 < length then find (pos2 + 1)
- else raise Not_found
- in
- find 0
-
-(* Expand a path. *)
-(* ### path -> path' *)
-let rec expand_path ch =
- let rec subst_variable ch =
- try
- let pos = string_pos ch '$' in
- if (pos + 1 < String.length ch) && (ch.[pos + 1] = '$') then
- (String.sub ch 0 (pos + 1))
- ^ (subst_variable
- (String.sub ch (pos + 2) (String.length ch - pos - 2)))
- else
- (String.sub ch 0 pos)
- ^ (subst2 (String.sub ch (pos + 1) (String.length ch - pos - 1)))
- with Not_found ->
- ch
- and subst2 ch =
- let suiv =
- let i = ref 0 in
- while !i < String.length ch &&
- (let c = ch.[!i] in (c >= 'a' && c <= 'z')
- || (c >= 'A' && c <= 'Z')
- || (c >= '0' && c <= '9')
- || c = '_')
- do incr i done;
- !i
- in (Sys.getenv (String.sub ch 0 suiv))
- ^ (subst_variable (String.sub ch suiv (String.length ch - suiv)))
- in
- let ch = subst_variable ch in
- let concat_root nom ch2 =
- try Filename.concat (getpwnam nom).pw_dir ch2
- with Not_found ->
- "~" ^ nom
- in
- if ch.[0] = '~' then
- try
- match string_pos ch '/' with
- 1 ->
- (let tail = String.sub ch 2 (String.length ch - 2)
- in
- try Filename.concat (Sys.getenv "HOME") tail
- with Not_found ->
- concat_root (Sys.getenv "LOGNAME") tail)
- | n -> concat_root
- (String.sub ch 1 (n - 1))
- (String.sub ch (n + 1) (String.length ch - n - 1))
- with
- Not_found ->
- expand_path (ch ^ "/")
- else ch
-
-let make_absolute name =
- if Filename.is_relative name
- then Filename.concat (getcwd ()) name
- else name
-;;
diff --git a/debugger/unix_tools.mli b/debugger/unix_tools.mli
deleted file mode 100644
index b5e4ee6ca4..0000000000
--- a/debugger/unix_tools.mli
+++ /dev/null
@@ -1,34 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* Objective Caml port by John Malecki and Xavier Leroy *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(**************************** Tools for Unix ***************************)
-
-open Unix
-
-(* Convert a socket name into a socket address. *)
-val convert_address : string -> socket_domain * sockaddr
-
-(* Report an unix error. *)
-val report_error : exn -> unit
-
-(* Find program `name' in `PATH'. *)
-(* Return the full path if found. *)
-(* Raise `Not_found' otherwise. *)
-val search_in_path : string -> string
-
-(* Path expansion. *)
-val expand_path : string -> string
-
-val make_absolute : string -> string
diff --git a/driver/compile.ml b/driver/compile.ml
deleted file mode 100644
index 52cf87d4a4..0000000000
--- a/driver/compile.ml
+++ /dev/null
@@ -1,121 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* The batch compiler *)
-
-open Misc
-open Config
-open Format
-open Typedtree
-
-(* Initialize the search path.
- The current directory is always searched first,
- then the directories specified with the -I option (in command-line order),
- then the standard library directory (unless the -nostdlib option is given).
- *)
-
-let init_path () =
- let dirs =
- if !Clflags.use_threads then "+threads" :: !Clflags.include_dirs
- else if !Clflags.use_vmthreads then "+vmthreads" :: !Clflags.include_dirs
- else !Clflags.include_dirs in
- let exp_dirs =
- List.map (expand_directory Config.standard_library) dirs in
- load_path := "" :: List.rev_append exp_dirs (Clflags.std_include_dir ());
- Env.reset_cache()
-
-(* Return the initial environment in which compilation proceeds. *)
-
-(* Note: do not do init_path() in initial_env, this breaks
- toplevel initialization (PR#1775) *)
-let initial_env () =
- Ident.reinit();
- try
- if !Clflags.nopervasives
- then Env.initial
- else Env.open_pers_signature "Pervasives" Env.initial
- with Not_found ->
- fatal_error "cannot open pervasives.cmi"
-
-(* Compile a .mli file *)
-
-let interface ppf sourcefile =
- init_path();
- let prefixname = chop_extension_if_any sourcefile in
- let modulename = String.capitalize(Filename.basename prefixname) in
- let inputfile = Pparse.preprocess sourcefile in
- try
- let ast =
- Pparse.file ppf inputfile Parse.interface ast_intf_magic_number in
- if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
- let sg = Typemod.transl_signature (initial_env()) ast in
- if !Clflags.print_types then
- fprintf std_formatter "%a@." Printtyp.signature
- (Typemod.simplify_signature sg);
- Warnings.check_fatal ();
- if not !Clflags.print_types then
- Env.save_signature sg modulename (prefixname ^ ".cmi");
- Pparse.remove_preprocessed inputfile
- with e ->
- Pparse.remove_preprocessed_if_ast inputfile;
- raise e
-
-(* Compile a .ml file *)
-
-let print_if ppf flag printer arg =
- if !flag then fprintf ppf "%a@." printer arg;
- arg
-
-let (++) x f = f x
-
-let implementation ppf sourcefile =
- init_path();
- let prefixname = chop_extension_if_any sourcefile in
- let modulename = String.capitalize(Filename.basename prefixname) in
- let inputfile = Pparse.preprocess sourcefile in
- let env = initial_env() in
- if !Clflags.print_types then begin
- try ignore(
- Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
- ++ print_if ppf Clflags.dump_parsetree Printast.implementation
- ++ Typemod.type_implementation sourcefile prefixname modulename env)
- with x ->
- Pparse.remove_preprocessed_if_ast inputfile;
- raise x
- end else begin
- let objfile = prefixname ^ ".cmo" in
- let oc = open_out_bin objfile in
- try
- Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
- ++ print_if ppf Clflags.dump_parsetree Printast.implementation
- ++ Typemod.type_implementation sourcefile prefixname modulename env
- ++ Translmod.transl_implementation modulename
- ++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
- ++ Simplif.simplify_lambda
- ++ print_if ppf Clflags.dump_lambda Printlambda.lambda
- ++ Bytegen.compile_implementation modulename
- ++ print_if ppf Clflags.dump_instr Printinstr.instrlist
- ++ Emitcode.to_file oc modulename;
- Warnings.check_fatal ();
- Pparse.remove_preprocessed inputfile;
- close_out oc;
- with x ->
- close_out oc;
- remove_file objfile;
- Pparse.remove_preprocessed_if_ast inputfile;
- raise x
- end
-
-let c_file name =
- if Ccomp.compile_file name <> 0 then exit 2
diff --git a/driver/compile.mli b/driver/compile.mli
deleted file mode 100644
index 2271d103e3..0000000000
--- a/driver/compile.mli
+++ /dev/null
@@ -1,24 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Compile a .ml or .mli file *)
-
-open Format
-
-val interface: formatter -> string -> unit
-val implementation: formatter -> string -> unit
-val c_file: string -> unit
-
-val initial_env: unit -> Env.t
-val init_path: unit -> unit
diff --git a/driver/errors.ml b/driver/errors.ml
deleted file mode 100644
index 03cd5690cf..0000000000
--- a/driver/errors.ml
+++ /dev/null
@@ -1,69 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* WARNING: if you change something in this file, you must look at
- opterrors.ml to see if you need to make the same changes there.
-*)
-
-open Format
-
-(* Report an error *)
-
-let report_error ppf exn =
- let report ppf = function
- | Lexer.Error(err, loc) ->
- Location.print ppf loc;
- Lexer.report_error ppf err
- | Syntaxerr.Error err ->
- Syntaxerr.report_error ppf err
- | Pparse.Error ->
- fprintf ppf "Preprocessor error"
- | Env.Error err ->
- Env.report_error ppf err
- | Ctype.Tags(l, l') -> fprintf ppf
- "In this program,@ variant constructors@ `%s and `%s@ \
- have the same hash value.@ Change one of them." l l'
- | Typecore.Error(loc, err) ->
- Location.print ppf loc; Typecore.report_error ppf err
- | Typetexp.Error(loc, err) ->
- Location.print ppf loc; Typetexp.report_error ppf err
- | Typedecl.Error(loc, err) ->
- Location.print ppf loc; Typedecl.report_error ppf err
- | Typeclass.Error(loc, err) ->
- Location.print ppf loc; Typeclass.report_error ppf err
- | Includemod.Error err ->
- Includemod.report_error ppf err
- | Typemod.Error(loc, err) ->
- Location.print ppf loc; Typemod.report_error ppf err
- | Translcore.Error(loc, err) ->
- Location.print ppf loc; Translcore.report_error ppf err
- | Translclass.Error(loc, err) ->
- Location.print ppf loc; Translclass.report_error ppf err
- | Translmod.Error(loc, err) ->
- Location.print ppf loc; Translmod.report_error ppf err
- | Symtable.Error code ->
- Symtable.report_error ppf code
- | Bytelink.Error code ->
- Bytelink.report_error ppf code
- | Bytelibrarian.Error code ->
- Bytelibrarian.report_error ppf code
- | Bytepackager.Error code ->
- Bytepackager.report_error ppf code
- | Sys_error msg ->
- fprintf ppf "I/O error: %s" msg
- | Warnings.Errors (n) ->
- fprintf ppf "@.Error: %d error-enabled warnings occurred." n
- | x -> fprintf ppf "@]"; raise x in
-
- fprintf ppf "@[%a@]@." report exn
diff --git a/driver/errors.mli b/driver/errors.mli
deleted file mode 100644
index ac203a53ef..0000000000
--- a/driver/errors.mli
+++ /dev/null
@@ -1,18 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Error report *)
-open Format
-
-val report_error: formatter -> exn -> unit
diff --git a/driver/main.ml b/driver/main.ml
deleted file mode 100644
index 7bbbf05666..0000000000
--- a/driver/main.ml
+++ /dev/null
@@ -1,156 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Config
-open Clflags
-
-let process_interface_file ppf name =
- Compile.interface ppf name
-
-let process_implementation_file ppf name =
- Compile.implementation ppf name;
- objfiles := (Misc.chop_extension_if_any name ^ ".cmo") :: !objfiles
-
-let process_file ppf name =
- if Filename.check_suffix name ".ml"
- || Filename.check_suffix name ".mlt" then begin
- Compile.implementation ppf name;
- objfiles := (Misc.chop_extension_if_any name ^ ".cmo") :: !objfiles
- end
- else if Filename.check_suffix name !Config.interface_suffix then
- Compile.interface ppf name
- else if Filename.check_suffix name ".cmo"
- || Filename.check_suffix name ".cma" then
- objfiles := name :: !objfiles
- else if Filename.check_suffix name ext_obj
- || Filename.check_suffix name ext_lib then
- ccobjs := name :: !ccobjs
- else if Filename.check_suffix name ext_dll then
- dllibs := name :: !dllibs
- else if Filename.check_suffix name ".c" then begin
- Compile.c_file name;
- match Sys.os_type with
- | "MacOS" -> ccobjs := (name ^ ".o") :: (name ^ ".x") :: !ccobjs
- | _ ->
- ccobjs := (Filename.chop_suffix (Filename.basename name) ".c" ^ ext_obj)
- :: !ccobjs
- end
- else
- raise(Arg.Bad("don't know what to do with " ^ name))
-
-let print_version_and_library () =
- print_string "The Objective Caml compiler, version ";
- print_string Config.version; print_newline();
- print_string "Standard library directory: ";
- print_string Config.standard_library; print_newline();
- exit 0
-
-let print_version_string () =
- print_string Config.version; print_newline(); exit 0
-
-let print_standard_library () =
- print_string Config.standard_library; print_newline(); exit 0
-
-let usage = "Usage: ocamlc <options> <files>\nOptions are:"
-
-(* Error messages to standard error formatter *)
-let anonymous = process_file Format.err_formatter;;
-let impl = process_implementation_file Format.err_formatter;;
-let intf = process_interface_file Format.err_formatter;;
-
-module Options = Main_args.Make_options (struct
- let set r () = r := true
- let unset r () = r := false
- let _a = set make_archive
- let _c = set compile_only
- let _cc s = c_compiler := s; c_linker := s
- let _cclib s = ccobjs := Misc.rev_split_words s @ !ccobjs
- let _ccopt s = ccopts := s :: !ccopts
- let _custom = set custom_runtime
- let _dllib s = dllibs := Misc.rev_split_words s @ !dllibs
- let _dllpath s = dllpaths := !dllpaths @ [s]
- let _dtypes = set save_types
- let _g = set debug
- let _i () = print_types := true; compile_only := true
- let _I s = include_dirs := s :: !include_dirs
- let _impl = impl
- let _intf = intf
- let _intf_suffix s = Config.interface_suffix := s
- let _labels = unset classic
- let _linkall = set link_everything
- let _make_runtime () =
- custom_runtime := true; make_runtime := true; link_everything := true
- let _noassert = set noassert
- let _nolabels = set classic
- let _noautolink = set no_auto_link
- let _nostdlib = set no_std_include
- let _o s = output_name := Some s
- let _output_obj () = output_c_object := true; custom_runtime := true
- let _pack = set make_package
- let _pp s = preprocessor := Some s
- let _principal = set principal
- let _rectypes = set recursive_types
- let _thread = set use_threads
- let _vmthread = set use_vmthreads
- let _unsafe = set fast
- let _use_prims s = use_prims := s
- let _use_runtime s = use_runtime := s
- let _v = print_version_and_library
- let _version = print_version_string
- let _w = (Warnings.parse_options false)
- let _warn_error = (Warnings.parse_options true)
- let _where = print_standard_library
- let _verbose = set verbose
- let _nopervasives = set nopervasives
- let _dparsetree = set dump_parsetree
- let _drawlambda = set dump_rawlambda
- let _dlambda = set dump_lambda
- let _dinstr = set dump_instr
- let anonymous = anonymous
-end)
-
-let extract_output = function
- | Some s -> s
- | None ->
- prerr_endline
- "Please specify the name of the output file, using option -o";
- exit 2
-
-let default_output = function
- | Some s -> s
- | None -> Config.default_executable_name
-
-let main () =
- try
- Arg.parse Options.list anonymous usage;
- if !make_archive then begin
- Compile.init_path();
- Bytelibrarian.create_archive (List.rev !objfiles)
- (extract_output !output_name)
- end
- else if !make_package then begin
- Compile.init_path();
- Bytepackager.package_files (List.rev !objfiles)
- (extract_output !output_name)
- end
- else if not !compile_only && !objfiles <> [] then begin
- Compile.init_path();
- Bytelink.link (List.rev !objfiles) (default_output !output_name)
- end;
- exit 0
- with x ->
- Errors.report_error Format.err_formatter x;
- exit 2
-
-let _ = main ()
diff --git a/driver/main.mli b/driver/main.mli
deleted file mode 100644
index d175a3ca26..0000000000
--- a/driver/main.mli
+++ /dev/null
@@ -1,17 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Damien Doligez, projet Moscova, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2000 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(*
- this "empty" file is here to speed up garbage collection in ocamlc.opt
-*)
diff --git a/driver/main_args.ml b/driver/main_args.ml
deleted file mode 100644
index a94b0e8a87..0000000000
--- a/driver/main_args.ml
+++ /dev/null
@@ -1,156 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Damien Doligez, projet Para, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1998 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-module Make_options (F :
- sig
- val _a : unit -> unit
- val _c : unit -> unit
- val _cc : string -> unit
- val _cclib : string -> unit
- val _ccopt : string -> unit
- val _custom : unit -> unit
- val _dllib : string -> unit
- val _dllpath : string -> unit
- val _dtypes : unit -> unit
- val _g : unit -> unit
- val _i : unit -> unit
- val _I : string -> unit
- val _impl : string -> unit
- val _intf : string -> unit
- val _intf_suffix : string -> unit
- val _labels : unit -> unit
- val _linkall : unit -> unit
- val _make_runtime : unit -> unit
- val _noassert : unit -> unit
- val _noautolink : unit -> unit
- val _nolabels : unit -> unit
- val _nostdlib : unit -> unit
- val _o : string -> unit
- val _output_obj : unit -> unit
- val _pack : unit -> unit
- val _pp : string -> unit
- val _principal : unit -> unit
- val _rectypes : unit -> unit
- val _thread : unit -> unit
- val _vmthread : unit -> unit
- val _unsafe : unit -> unit
- val _use_prims : string -> unit
- val _use_runtime : string -> unit
- val _v : unit -> unit
- val _version : unit -> unit
- val _verbose : unit -> unit
- val _w : string -> unit
- val _warn_error : string -> unit
- val _where : unit -> unit
-
- val _nopervasives : unit -> unit
- val _dparsetree : unit -> unit
- val _drawlambda : unit -> unit
- val _dlambda : unit -> unit
- val _dinstr : unit -> unit
- val anonymous : string -> unit
- end) =
-struct
- let list = [
- "-a", Arg.Unit F._a, " Build a library";
- "-c", Arg.Unit F._c, " Compile only (do not link)";
- "-cc", Arg.String F._cc,
- "<command> Use <command> as the C compiler and linker";
- "-cclib", Arg.String F._cclib, "<opt> Pass option <opt> to the C linker";
- "-ccopt", Arg.String F._ccopt,
- "<opt> Pass option <opt> to the C compiler and linker";
- "-custom", Arg.Unit F._custom, " Link in custom mode";
- "-dllib", Arg.String F._dllib,
- "<lib> Use the dynamically-loaded library <lib>";
- "-dllpath", Arg.String F._dllpath,
- "<dir> Add <dir> to the run-time search path for shared libraries";
- "-dtypes", Arg.Unit F._dtypes, " Save type information in <filename>.annot";
- "-g", Arg.Unit F._g, " Save debugging information";
- "-i", Arg.Unit F._i, " Print inferred interface";
- "-I", Arg.String F._I,
- "<dir> Add <dir> to the list of include directories";
- "-impl", Arg.String F._impl, "<file> Compile <file> as a .ml file";
- "-intf", Arg.String F._intf, "<file> Compile <file> as a .mli file";
- "-intf-suffix", Arg.String F._intf_suffix,
- "<string> Suffix for interface files (default: .mli)";
- "-intf_suffix", Arg.String F._intf_suffix,
- "<string> (deprecated) same as -intf-suffix";
- "-labels", Arg.Unit F._labels, " Use commuting label mode";
- "-linkall", Arg.Unit F._linkall, " Link all modules, even unused ones";
- "-make-runtime", Arg.Unit F._make_runtime,
- " Build a runtime system with given C objects and libraries";
- "-make_runtime", Arg.Unit F._make_runtime,
- " (deprecated) same as -make-runtime";
- "-modern", Arg.Unit F._labels, " (deprecated) same as -labels";
- "-noassert", Arg.Unit F._noassert, " Don't compile assertion checks";
- "-noautolink", Arg.Unit F._noautolink,
- " Don't automatically link C libraries specified in .cma files";
- "-nolabels", Arg.Unit F._nolabels, " Ignore non-optional labels in types";
- "-nostdlib", Arg.Unit F._nostdlib,
- " do not add default directory to the list of include directories";
- "-o", Arg.String F._o, "<file> Set output file name to <file>";
- "-output-obj", Arg.Unit F._output_obj,
- " Output a C object file instead of an executable";
- "-pack", Arg.Unit F._pack,
- " Package the given .cmo files into one .cmo";
- "-pp", Arg.String F._pp,
- "<command> Pipe sources through preprocessor <command>";
- "-principal", Arg.Unit F._principal,
- " Check principality of type inference";
- "-rectypes", Arg.Unit F._rectypes, " Allow arbitrary recursive types";
- "-thread", Arg.Unit F._thread, " Generate code that supports the system threads library";
- "-unsafe", Arg.Unit F._unsafe,
- " No bounds checking on array and string access";
- "-use-runtime", Arg.String F._use_runtime,
- "<file> Generate bytecode for the given runtime system";
- "-use_runtime", Arg.String F._use_runtime,
- "<file> (deprecated) same as -use-runtime";
- "-v", Arg.Unit F._v,
- " Print compiler version and location of standard library and exit";
- "-version", Arg.Unit F._version, " Print compiler version and exit";
- "-verbose", Arg.Unit F._verbose, " Print calls to external commands";
- "-vmthread", Arg.Unit F._vmthread, " Generate code that supports the threads library with VM-level scheduling";
- "-w", Arg.String F._w,
- "<flags> Enable or disable warnings according to <flags>:\n\
- \032 A/a enable/disable all warnings\n\
- \032 C/c enable/disable suspicious comment\n\
- \032 D/d enable/disable deprecated features\n\
- \032 E/e enable/disable fragile match\n\
- \032 F/f enable/disable partially applied function\n\
- \032 L/l enable/disable labels omitted in application\n\
- \032 M/m enable/disable overriden method\n\
- \032 P/p enable/disable partial match\n\
- \032 S/s enable/disable non-unit statement\n\
- \032 U/u enable/disable unused match case\n\
- \032 V/v enable/disable hidden instance variable\n\
- \032 X/x enable/disable all other warnings\n\
- \032 default setting is \"Ale\"\n\
- \032 (all warnings but labels and fragile match enabled)";
- "-warn-error" , Arg.String F._warn_error,
- "<flags> Treat the warnings enabled by <flags> as errors.\n\
- \032 See option -w for the list of flags.\n\
- \032 Default setting is \"a\" (warnings are not errors)";
- "-where", Arg.Unit F._where,
- " Print location of standard library and exit";
- "-nopervasives", Arg.Unit F._nopervasives, " (undocumented)";
- "-dparsetree", Arg.Unit F._dparsetree, " (undocumented)";
- "-drawlambda", Arg.Unit F._drawlambda, " (undocumented)";
- "-dlambda", Arg.Unit F._dlambda, " (undocumented)";
- "-dinstr", Arg.Unit F._dinstr, " (undocumented)";
- "-use-prims", Arg.String F._use_prims, "<file> (undocumented)";
-
- "-", Arg.String F.anonymous,
- "<file> Treat <file> as a file name (even if it starts with `-')";
- ]
-end;;
diff --git a/driver/main_args.mli b/driver/main_args.mli
deleted file mode 100644
index 1233b51443..0000000000
--- a/driver/main_args.mli
+++ /dev/null
@@ -1,66 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Damien Doligez, projet Para, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1998 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-module Make_options (F :
- sig
- val _a : unit -> unit
- val _c : unit -> unit
- val _cc : string -> unit
- val _cclib : string -> unit
- val _ccopt : string -> unit
- val _custom : unit -> unit
- val _dllib : string -> unit
- val _dllpath : string -> unit
- val _dtypes : unit -> unit
- val _g : unit -> unit
- val _i : unit -> unit
- val _I : string -> unit
- val _impl : string -> unit
- val _intf : string -> unit
- val _intf_suffix : string -> unit
- val _labels : unit -> unit
- val _linkall : unit -> unit
- val _make_runtime : unit -> unit
- val _noassert : unit -> unit
- val _noautolink : unit -> unit
- val _nolabels : unit -> unit
- val _nostdlib : unit -> unit
- val _o : string -> unit
- val _output_obj : unit -> unit
- val _pack : unit -> unit
- val _pp : string -> unit
- val _principal : unit -> unit
- val _rectypes : unit -> unit
- val _thread : unit -> unit
- val _vmthread : unit -> unit
- val _unsafe : unit -> unit
- val _use_prims : string -> unit
- val _use_runtime : string -> unit
- val _v : unit -> unit
- val _version : unit -> unit
- val _verbose : unit -> unit
- val _w : string -> unit
- val _warn_error : string -> unit
- val _where : unit -> unit
-
- val _nopervasives : unit -> unit
- val _dparsetree : unit -> unit
- val _drawlambda : unit -> unit
- val _dlambda : unit -> unit
- val _dinstr : unit -> unit
- val anonymous : string -> unit
- end) :
- sig
- val list : (string * Arg.spec * string) list
- end
diff --git a/driver/ocamlcomp.sh.in b/driver/ocamlcomp.sh.in
deleted file mode 100644
index 2aeb2de20b..0000000000
--- a/driver/ocamlcomp.sh.in
+++ /dev/null
@@ -1,5 +0,0 @@
-#!/bin/sh
-
-topdir=`dirname $0`
-
-exec @compiler@ -nostdlib -I $topdir/stdlib "$@"
diff --git a/driver/optcompile.ml b/driver/optcompile.ml
deleted file mode 100644
index 0e52920f39..0000000000
--- a/driver/optcompile.ml
+++ /dev/null
@@ -1,110 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* The batch compiler *)
-
-open Misc
-open Config
-open Format
-open Typedtree
-
-(* Initialize the search path.
- The current directory is always searched first,
- then the directories specified with the -I option (in command-line order),
- then the standard library directory. *)
-
-let init_path () =
- let dirs =
- if !Clflags.use_threads
- then "+threads" :: !Clflags.include_dirs
- else !Clflags.include_dirs in
- let exp_dirs =
- List.map (expand_directory Config.standard_library) dirs in
- load_path := "" :: List.rev_append exp_dirs (Clflags.std_include_dir ());
- Env.reset_cache()
-
-(* Return the initial environment in which compilation proceeds. *)
-
-let initial_env () =
- Ident.reinit();
- try
- if !Clflags.nopervasives
- then Env.initial
- else Env.open_pers_signature "Pervasives" Env.initial
- with Not_found ->
- fatal_error "cannot open Pervasives.cmi"
-
-(* Compile a .mli file *)
-
-let interface ppf sourcefile =
- init_path();
- let prefixname = Misc.chop_extension_if_any sourcefile in
- let modulename = String.capitalize(Filename.basename prefixname) in
- let inputfile = Pparse.preprocess sourcefile in
- try
- let ast =
- Pparse.file ppf inputfile Parse.interface ast_intf_magic_number in
- if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
- let sg = Typemod.transl_signature (initial_env()) ast in
- if !Clflags.print_types then
- fprintf std_formatter "%a@." Printtyp.signature
- (Typemod.simplify_signature sg);
- Warnings.check_fatal ();
- if not !Clflags.print_types then
- Env.save_signature sg modulename (prefixname ^ ".cmi");
- Pparse.remove_preprocessed inputfile
- with e ->
- Pparse.remove_preprocessed_if_ast inputfile;
- raise e
-
-(* Compile a .ml file *)
-
-let print_if ppf flag printer arg =
- if !flag then fprintf ppf "%a@." printer arg;
- arg
-
-let (++) x f = f x
-let (+++) (x, y) f = (x, f y)
-
-let implementation ppf sourcefile =
- init_path();
- let prefixname = Misc.chop_extension_if_any sourcefile in
- let modulename = String.capitalize(Filename.basename prefixname) in
- let inputfile = Pparse.preprocess sourcefile in
- let env = initial_env() in
- Compilenv.reset modulename;
- try
- if !Clflags.print_types then ignore(
- Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
- ++ print_if ppf Clflags.dump_parsetree Printast.implementation
- ++ Typemod.type_implementation sourcefile prefixname modulename env)
- else begin
- Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
- ++ print_if ppf Clflags.dump_parsetree Printast.implementation
- ++ Typemod.type_implementation sourcefile prefixname modulename env
- ++ Translmod.transl_store_implementation modulename
- +++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
- +++ Simplif.simplify_lambda
- +++ print_if ppf Clflags.dump_lambda Printlambda.lambda
- ++ Asmgen.compile_implementation prefixname ppf;
- Compilenv.save_unit_info (prefixname ^ ".cmx");
- end;
- Warnings.check_fatal ();
- Pparse.remove_preprocessed inputfile
- with x ->
- Pparse.remove_preprocessed_if_ast inputfile;
- raise x
-
-let c_file name =
- if Ccomp.compile_file name <> 0 then exit 2
diff --git a/driver/optcompile.mli b/driver/optcompile.mli
deleted file mode 100644
index 2271d103e3..0000000000
--- a/driver/optcompile.mli
+++ /dev/null
@@ -1,24 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Compile a .ml or .mli file *)
-
-open Format
-
-val interface: formatter -> string -> unit
-val implementation: formatter -> string -> unit
-val c_file: string -> unit
-
-val initial_env: unit -> Env.t
-val init_path: unit -> unit
diff --git a/driver/opterrors.ml b/driver/opterrors.ml
deleted file mode 100644
index a59e6f265e..0000000000
--- a/driver/opterrors.ml
+++ /dev/null
@@ -1,71 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* WARNING: if you change something in this file, you must look at
- errors.ml to see if you need to make the same changes there.
-*)
-
-open Format
-
-(* Report an error *)
-
-let report_error ppf exn =
- let report ppf = function
- | Lexer.Error(err, l) ->
- Location.print ppf l;
- Lexer.report_error ppf err
- | Syntaxerr.Error err ->
- Syntaxerr.report_error ppf err
- | Pparse.Error ->
- fprintf ppf "Preprocessor error"
- | Env.Error err ->
- Env.report_error ppf err
- | Ctype.Tags(l, l') -> fprintf ppf
- "In this program,@ variant constructors@ `%s and `%s@ \
- have the same hash value.@ Change one of them." l l'
- | Typecore.Error(loc, err) ->
- Location.print ppf loc; Typecore.report_error ppf err
- | Typetexp.Error(loc, err) ->
- Location.print ppf loc; Typetexp.report_error ppf err
- | Typedecl.Error(loc, err) ->
- Location.print ppf loc; Typedecl.report_error ppf err
- | Typeclass.Error(loc, err) ->
- Location.print ppf loc; Typeclass.report_error ppf err
- | Includemod.Error err ->
- Includemod.report_error ppf err
- | Typemod.Error(loc, err) ->
- Location.print ppf loc; Typemod.report_error ppf err
- | Translcore.Error(loc, err) ->
- Location.print ppf loc; Translcore.report_error ppf err
- | Translclass.Error(loc, err) ->
- Location.print ppf loc; Translclass.report_error ppf err
- | Translmod.Error(loc, err) ->
- Location.print ppf loc; Translmod.report_error ppf err
- | Compilenv.Error code ->
- Compilenv.report_error ppf code
- | Asmgen.Error code ->
- Asmgen.report_error ppf code
- | Asmlink.Error code ->
- Asmlink.report_error ppf code
- | Asmlibrarian.Error code ->
- Asmlibrarian.report_error ppf code
- | Asmpackager.Error code ->
- Asmpackager.report_error ppf code
- | Sys_error msg ->
- fprintf ppf "I/O error: %s" msg
- | Warnings.Errors (n) ->
- fprintf ppf "@.Error: %d error-enabled warnings occurred." n
- | x -> fprintf ppf "@]"; raise x in
-
- fprintf ppf "@[%a@]@." report exn
diff --git a/driver/opterrors.mli b/driver/opterrors.mli
deleted file mode 100644
index d09dc733b6..0000000000
--- a/driver/opterrors.mli
+++ /dev/null
@@ -1,17 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Error report *)
-
-val report_error: Format.formatter -> exn -> unit
diff --git a/driver/optmain.ml b/driver/optmain.ml
deleted file mode 100644
index 6483bff95d..0000000000
--- a/driver/optmain.ml
+++ /dev/null
@@ -1,204 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Config
-open Clflags
-
-let process_interface_file ppf name =
- Optcompile.interface ppf name
-
-let process_implementation_file ppf name =
- Optcompile.implementation ppf name;
- objfiles := (Misc.chop_extension_if_any name ^ ".cmx") :: !objfiles
-
-let process_file ppf name =
- if Filename.check_suffix name ".ml"
- || Filename.check_suffix name ".mlt" then begin
- Optcompile.implementation ppf name;
- objfiles := (Misc.chop_extension_if_any name ^ ".cmx") :: !objfiles
- end
- else if Filename.check_suffix name !Config.interface_suffix then
- Optcompile.interface ppf name
- else if Filename.check_suffix name ".cmx"
- || Filename.check_suffix name ".cmxa" then
- objfiles := name :: !objfiles
- else if Filename.check_suffix name ext_obj
- || Filename.check_suffix name ext_lib then
- ccobjs := name :: !ccobjs
- else if Filename.check_suffix name ".c" then begin
- Optcompile.c_file name;
- ccobjs := (Filename.chop_suffix (Filename.basename name) ".c" ^ ext_obj)
- :: !ccobjs
- end
- else
- raise(Arg.Bad("don't know what to do with " ^ name))
-
-let print_version_and_library () =
- print_string "The Objective Caml native-code compiler, version ";
- print_string Config.version; print_newline();
- print_string "Standard library directory: ";
- print_string Config.standard_library; print_newline();
- exit 0
-
-let print_version_string () =
- print_string Config.version; print_newline(); exit 0
-
-let print_standard_library () =
- print_string Config.standard_library; print_newline(); exit 0
-
-let extract_output = function
- | Some s -> s
- | None ->
- prerr_endline
- "Please specify the name of the output file, using option -o";
- exit 2
-
-let default_output = function
- | Some s -> s
- | None -> Config.default_executable_name
-
-let usage = "Usage: ocamlopt <options> <files>\nOptions are:"
-
-let main () =
- native_code := true;
- c_compiler := Config.native_c_compiler;
- c_linker := Config.native_c_linker;
- let ppf = Format.err_formatter in
- try
- Arg.parse (Arch.command_line_options @ [
- "-a", Arg.Set make_archive, " Build a library";
- "-c", Arg.Set compile_only, " Compile only (do not link)";
- "-cc", Arg.String(fun s -> c_compiler := s; c_linker := s),
- "<comp> Use <comp> as the C compiler and linker";
- "-cclib", Arg.String(fun s ->
- ccobjs := Misc.rev_split_words s @ !ccobjs),
- "<opt> Pass option <opt> to the C linker";
- "-ccopt", Arg.String(fun s -> ccopts := s :: !ccopts),
- "<opt> Pass option <opt> to the C compiler and linker";
- "-compact", Arg.Clear optimize_for_speed,
- " Optimize code size rather than speed";
- "-dtypes", Arg.Set save_types,
- " Save type information in <filename>.annot";
- "-i", Arg.Unit (fun () -> print_types := true; compile_only := true),
- " Print inferred interface";
- "-I", Arg.String(fun dir -> include_dirs := dir :: !include_dirs),
- "<dir> Add <dir> to the list of include directories";
- "-impl", Arg.String (process_implementation_file ppf),
- "<file> Compile <file> as a .ml file";
- "-inline", Arg.Int(fun n -> inline_threshold := n * 8),
- "<n> Set aggressiveness of inlining to <n>";
- "-intf", Arg.String (process_interface_file ppf),
- "<file> Compile <file> as a .mli file";
- "-intf-suffix", Arg.String (fun s -> Config.interface_suffix := s),
- "<file> Suffix for interface files (default: .mli)";
- "-intf_suffix", Arg.String (fun s -> Config.interface_suffix := s),
- "<file> (deprecated) same as -intf-suffix";
- "-labels", Arg.Clear classic, " Use commuting label mode";
- "-linkall", Arg.Set link_everything,
- " Link all modules, even unused ones";
- "-noassert", Arg.Set noassert, " Don't compile assertion checks";
- "-noautolink", Arg.Set no_auto_link,
- " Don't automatically link C libraries specified in .cma files";
- "-nolabels", Arg.Set classic, " Ignore non-optional labels in types";
- "-nostdlib", Arg.Set no_std_include,
- " do not add standard directory to the list of include directories";
- "-o", Arg.String(fun s -> output_name := Some s),
- "<file> Set output file name to <file>";
- "-output-obj", Arg.Unit(fun () -> output_c_object := true),
- " Output a C object file instead of an executable";
- "-p", Arg.Set gprofile,
- " Compile and link with profiling support for \"gprof\"\n\
- \t(not supported on all platforms)";
- "-pack", Arg.Set make_package,
- " Package the given .cmx files into one .cmx";
- "-pp", Arg.String(fun s -> preprocessor := Some s),
- "<command> Pipe sources through preprocessor <command>";
- "-principal", Arg.Set principal,
- " Check principality of type inference";
- "-rectypes", Arg.Set recursive_types,
- " Allow arbitrary recursive types";
- "-S", Arg.Set keep_asm_file, " Keep intermediate assembly file";
- "-thread", Arg.Set use_threads, " Generate code that supports the system threads library";
- "-unsafe", Arg.Set fast,
- " No bounds checking on array and string access";
- "-v", Arg.Unit print_version_and_library,
- " Print compiler version and standard library location and exit";
- "-version", Arg.Unit print_version_string,
- " Print compiler version and exit";
- "-verbose", Arg.Set verbose, " Print calls to external commands";
- "-w", Arg.String (Warnings.parse_options false),
- "<flags> Enable or disable warnings according to <flags>:\n\
- \032 A/a enable/disable all warnings\n\
- \032 C/c enable/disable suspicious comment\n\
- \032 D/d enable/disable deprecated features\n\
- \032 E/e enable/disable fragile match\n\
- \032 F/f enable/disable partially applied function\n\
- \032 L/l enable/disable labels omitted in application\n\
- \032 M/m enable/disable overriden methods\n\
- \032 P/p enable/disable partial match\n\
- \032 S/s enable/disable non-unit statement\n\
- \032 U/u enable/disable unused match case\n\
- \032 V/v enable/disable hidden instance variables\n\
- \032 X/x enable/disable all other warnings\n\
- \032 default setting is \"Ale\"\n\
- \032 (all warnings but labels and fragile match enabled)";
- "-warn-error" , Arg.String (Warnings.parse_options true),
- "<flags> Treat the warnings enabled by <flags> as errors.\n\
- \032 See option -w for the list of flags.\n\
- \032 Default setting is \"a\" (warnings are not errors)";
- "-where", Arg.Unit print_standard_library,
- " Print location of standard library and exit";
-
- "-nopervasives", Arg.Set nopervasives, " (undocumented)";
- "-dparsetree", Arg.Set dump_parsetree, " (undocumented)";
- "-drawlambda", Arg.Set dump_rawlambda, " (undocumented)";
- "-dlambda", Arg.Set dump_lambda, " (undocumented)";
- "-dcmm", Arg.Set dump_cmm, " (undocumented)";
- "-dsel", Arg.Set dump_selection, " (undocumented)";
- "-dcombine", Arg.Set dump_combine, " (undocumented)";
- "-dlive", Arg.Unit(fun () -> dump_live := true;
- Printmach.print_live := true),
- " (undocumented)";
- "-dspill", Arg.Set dump_spill, " (undocumented)";
- "-dsplit", Arg.Set dump_split, " (undocumented)";
- "-dinterf", Arg.Set dump_interf, " (undocumented)";
- "-dprefer", Arg.Set dump_prefer, " (undocumented)";
- "-dalloc", Arg.Set dump_regalloc, " (undocumented)";
- "-dreload", Arg.Set dump_reload, " (undocumented)";
- "-dscheduling", Arg.Set dump_scheduling, " (undocumented)";
- "-dlinear", Arg.Set dump_linear, " (undocumented)";
- "-dstartup", Arg.Set keep_startup_file, " (undocumented)";
- "-", Arg.String (process_file ppf),
- "<file> Treat <file> as a file name (even if it starts with `-')"
- ]) (process_file ppf) usage;
- if !make_archive then begin
- Optcompile.init_path();
- Asmlibrarian.create_archive (List.rev !objfiles)
- (extract_output !output_name)
- end
- else if !make_package then begin
- Optcompile.init_path();
- Asmpackager.package_files ppf (List.rev !objfiles)
- (extract_output !output_name)
- end
- else if not !compile_only && !objfiles <> [] then begin
- Optcompile.init_path();
- Asmlink.link ppf (List.rev !objfiles) (default_output !output_name)
- end;
- exit 0
- with x ->
- Opterrors.report_error ppf x;
- exit 2
-
-let _ = main ()
diff --git a/driver/optmain.mli b/driver/optmain.mli
deleted file mode 100644
index 628d2d398b..0000000000
--- a/driver/optmain.mli
+++ /dev/null
@@ -1,17 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Damien Doligez, projet Moscova, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2000 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(*
- this "empty" file is here to speed up garbage collection in ocamlopt.opt
-*)
diff --git a/driver/pparse.ml b/driver/pparse.ml
deleted file mode 100644
index da65a5525b..0000000000
--- a/driver/pparse.ml
+++ /dev/null
@@ -1,81 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Format
-
-exception Error
-
-(* Optionally preprocess a source file *)
-
-let preprocess sourcefile =
- match !Clflags.preprocessor with
- None -> sourcefile
- | Some pp ->
- let tmpfile = Filename.temp_file "camlpp" "" in
- let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in
- if Ccomp.command comm <> 0 then begin
- Misc.remove_file tmpfile;
- raise Error;
- end;
- tmpfile
-
-let remove_preprocessed inputfile =
- match !Clflags.preprocessor with
- None -> ()
- | Some _ -> Misc.remove_file inputfile
-
-let remove_preprocessed_if_ast inputfile =
- match !Clflags.preprocessor with
- None -> ()
- | Some _ ->
- if inputfile <> !Location.input_name then Misc.remove_file inputfile
-
-(* Parse a file or get a dumped syntax tree in it *)
-
-exception Outdated_version
-
-let file ppf inputfile parse_fun ast_magic =
- let ic = open_in_bin inputfile in
- let is_ast_file =
- try
- let buffer = String.create (String.length ast_magic) in
- really_input ic buffer 0 (String.length ast_magic);
- if buffer = ast_magic then true
- else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then
- raise Outdated_version
- else false
- with
- Outdated_version ->
- Misc.fatal_error "Ocaml and preprocessor have incompatible versions"
- | _ -> false
- in
- let ast =
- try
- if is_ast_file then begin
- if !Clflags.fast then
- fprintf ppf "@[Warning: %s@]@."
- "option -unsafe used with a preprocessor returning a syntax tree";
- Location.input_name := input_value ic;
- input_value ic
- end else begin
- seek_in ic 0;
- Location.input_name := inputfile;
- let lexbuf = Lexing.from_channel ic in
- Location.init lexbuf inputfile;
- parse_fun lexbuf
- end
- with x -> close_in ic; raise x
- in
- close_in ic;
- ast
diff --git a/driver/pparse.mli b/driver/pparse.mli
deleted file mode 100644
index 0ed0391360..0000000000
--- a/driver/pparse.mli
+++ /dev/null
@@ -1,22 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Format
-
-exception Error
-
-val preprocess : string -> string
-val remove_preprocessed : string -> unit
-val remove_preprocessed_if_ast : string -> unit
-val file : formatter -> string -> (Lexing.lexbuf -> 'a) -> string -> 'a
diff --git a/emacs/.cvsignore b/emacs/.cvsignore
deleted file mode 100644
index e7e261fca6..0000000000
--- a/emacs/.cvsignore
+++ /dev/null
@@ -1,2 +0,0 @@
-ocamltags
-
diff --git a/emacs/Makefile b/emacs/Makefile
deleted file mode 100644
index d6c57f79ea..0000000000
--- a/emacs/Makefile
+++ /dev/null
@@ -1,64 +0,0 @@
-# $Id$
-
-include ../config/Makefile
-
-# Files to install
-FILES= caml-font.el caml-hilit.el caml.el camldebug.el \
- inf-caml.el caml-compat.el caml-help.el caml-types.el \
- caml-xemacs.el caml-emacs.el
-
-# Where to install. If empty, automatically determined.
-#EMACSDIR=
-
-# Name of Emacs executable
-EMACS=emacs
-
-# Where to install ocamltags script
-SCRIPTDIR = $(BINDIR)
-
-# Command for byte-compiling the files
-COMPILECMD=(progn \
- (setq load-path (cons "." load-path)) \
- (byte-compile-file "caml-xemacs.el") \
- (byte-compile-file "caml-emacs.el") \
- (byte-compile-file "caml.el") \
- (byte-compile-file "inf-caml.el") \
- (byte-compile-file "caml-help.el") \
- (byte-compile-file "caml-types.el") \
- (byte-compile-file "camldebug.el"))
-
-install:
- @if test "$(EMACSDIR)" = ""; then \
- set xxx `($(EMACS) --batch --eval "(mapcar 'print load-path)") \
- 2>/dev/null | \
- sed -n -e '/\/site-lisp/s/"//gp'`; \
- if test "$$2" = ""; then \
- echo "Cannot determine Emacs site-lisp directory"; \
- exit 2; \
- fi; \
- $(MAKE) EMACSDIR="$$2" simple-install; \
- else \
- $(MAKE) simple-install; \
- fi
-
-# install the .el files, but do not compile them.
-install-el:
- $(MAKE) NOCOMPILE=true install
-
-simple-install:
- @echo "Installing in $(EMACSDIR)..."
- if test -d $(EMACSDIR); then : ; else mkdir -p $(EMACSDIR); fi
- cp $(FILES) $(EMACSDIR)
- if [ -z "$(NOCOMPILE)" ]; then \
- cd $(EMACSDIR); $(EMACS) --batch --eval '$(COMPILECMD)'; \
- fi
-
-ocamltags: ocamltags.in
- sed -e 's:@EMACS@:$(EMACS):' ocamltags.in >ocamltags
- chmod a+x ocamltags
-
-install-ocamltags: ocamltags
- cp ocamltags $(SCRIPTDIR)/ocamltags
-
-clean:
- rm -f ocamltags *~ #*#
diff --git a/emacs/README b/emacs/README
deleted file mode 100644
index f6bf63e842..0000000000
--- a/emacs/README
+++ /dev/null
@@ -1,198 +0,0 @@
- O'Caml emacs mode, snapshot of $Date$
-
-The files in this archive define a caml-mode for emacs, for editing
-Objective Caml and Objective Label programs, as well as an
-inferior-caml-mode, to run a toplevel.
-
-Caml-mode supports indentation, compilation and error retrieving,
-sending phrases to the toplevel. Moreover support for hilit,
-font-lock and imenu was added.
-
-This package is based on the original caml-mode for caml-light by
-Xavier Leroy, extended with indentation by Ian Zimmerman. For details
-see README.itz, which is the README from Ian Zimmerman's package.
-
-To use it, just put the .el files in your path, and add the following
-three lines in your .emacs.
-
- (setq auto-mode-alist
- (cons '("\\.ml[iylp]?$" . caml-mode) auto-mode-alist))
- (autoload 'caml-mode "caml" "Major mode for editing Caml code." t)
- (autoload 'run-caml "inf-caml" "Run an inferior Caml process." t)
-
-I added camldebug.el from the original distribution, since there will
-soon be a debugger for Objective Caml, but I do not know enough about
-it.
-
-To install the mode itself, edit the Makefile and do
-
- % make install
-
-To install ocamltags, do
-
- % make install-ocamltags
-
-To use highlighting capabilities, add ONE of the following two lines
-to your .emacs. The second one works better on recent versions of
-emacs.
-
- (if window-system (require 'caml-hilit))
- (if window-system (require 'caml-font))
-
-caml.el and inf-caml.el can be used collectively, but it might be a
-good idea to copy caml-hilit.el or caml-font.el to you own directory,
-and edit it to your taste and colors.
-
-Main key bindings:
-
-TAB indent current line
-M-C-q indent phrase
-M-C-h mark phrase
-C-c C-a switch between interface and implementation
-C-c C-c compile (usually make)
-C-x` goto next error (also mouse button 2 in the compilation log)
-
-Once you have started caml by M-x run-caml:
-
-M-C-x send phrase to inferior caml process
-C-c C-r send region to inferior caml process
-C-c C-s show inferior caml process
-C-c` goto error in expression sent by M-C-x
-
-For other bindings, see C-h b.
-
-Changes log:
------------
-
-Version 3.05:
--------------
-* improved interaction with inferior caml mode
-
-* access help from the source
-
-* fixes in indentation code
-
-Version 3.03:
--------------
-* process ;; properly
-
-Version 3.00:
--------------
-* adapt to new label syntax
-
-* intelligent indentation of parenthesis
-
-Version 2.02:
--------------
-* improved ocamltags <ITZ and JG>
-
-* added support for multibyte characters in emacs 20
-
-Version 2.01+:
---------------
-* corrected a bug in caml-font.el <Adam P. Jenkins>
-
-* corrected abbreviations and added ocamltags script <Ian T Zimmerman>
-
-Version 2.01:
-------------
-* code for interactive errors added by ITZ
-
-Version 2.00:
-------------
-* changed the algorithm to skip comments
-
-* adapted for the new object syntax
-
-Version 1.07:
-------------
-* next-error bug fix by John Malecki
-
-* camldebug.el modified by Xavier Leroy
-
-Version 1.06:
-------------
-* new keywords in O'Caml 1.06
-
-* compatibility with GNU Emacs 20
-
-* changed from caml-imenu-disable to caml-imenu-enable (off by default)
-
-Version 1.05:
-------------
-* a few indentation bugs corrected. let, val ... are now indented
- correctly even when you write them at the beginning of a line.
-
-* added a Caml menu, and Imenu support. Imenu menu can be disabled
- by setting the variable caml-imenu-disable to t.
- Xemacs support for the Menu, but no Imenu.
-
-* key bindings closer to lisp-mode.
-
-* O'Labl compatibility (":" is part of words) may be switched off by
- setting caml-olabl-disable to t.
-
-* camldebug.el was updated by Xavier Leroy.
-
-Version 1.03b:
--------------
-* many bugs corrected.
-
-* (partial) compatibility with Caml-Light added.
- (setq caml-quote-char "`")
- (setq inferior-caml-program "camllight")
- Literals will be correctly understood and highlighted. However,
- indentation rules are still Objective Caml's: this just happens to
- work well in most cases, but is only intended for occasional use.
-
-* as many people asked for it, application is now indented. This seems
- to work well: this time differences in indentation between the
- compiler's source and this mode are really exceptionnal. On the
- other hand, you may think that some special cases are strange. No
- miracle.
-
-* nicer behaviour when sending a phrase/region to the inferior caml
- process.
-
-Version 1.03:
-------------
-* support of Objective Caml and Objective Label.
-
-* an indentation very close to mine, which happens to be the same as
- Xavier's, since the sources of the Objective Caml compiler do not
- change if you indent them in this mode.
-
-* highlighting.
-
-Some remarks about the style supported:
---------------------------------------
-
-Since Objective Caml's syntax is very liberal (more than 100
-shift-reduce conflicts with yacc), automatic indentation is far from
-easy. Moreover, you expect the indentation to be not purely syntactic,
-but also semantic: reflecting the meaning of your program.
-
-This mode tries to be intelligent. For instance some operators are
-indented differently in the middle and at the end of a line (thanks to
-Ian Zimmerman). Also, we do not indent after if .. then .. else, when
-else is on the same line, to reflect that this idiom is equivalent to
-a return instruction in a more imperative language, or after the in of
-let .. in, since you may see that as an assignment.
-
-However, you may want to use a different indentation style. This is
-made partly possible by a number of variables at the beginning of
-caml.el. Try to set them. However this only changes the size of
-indentations, not really the look of your program. This is enough to
-disable the two idioms above, but to do anything more you will have to
-edit the code... Enjoy!
-
-This mode does not force you to put ;; in your program. This means
-that we had to use a heuristic to decide where a phrase starts and
-stops, to speed up the code. A phrase starts when any of the keywords
-let, type, class, module, functor, exception, val, external, appears
-at the beginning of a line. Using the first column for such keywords
-in other cases may confuse the phrase selection function.
-
-Comments and bug reports to
-
- Jacques Garrigue <garrigue@kurims.kyoto-u.ac.jp>
diff --git a/emacs/README.itz b/emacs/README.itz
deleted file mode 100644
index 8e1366f478..0000000000
--- a/emacs/README.itz
+++ /dev/null
@@ -1,177 +0,0 @@
-DESCRIPTION:
-
-This directory contains files to help editing Caml code, running a
-Caml toplevel, and running the Caml debugger under the Gnu Emacs editor.
-
-AUTHORS:
-
-Ian T Zimmerman <itz@rahul.net> added indentation to caml mode, beefed
-up camldebug to work much like gud/gdb.
-
-Xavier Leroy (Xavier.Leroy@inria.fr), Jerome Vouillon (Jerome.Vouillon@ens.fr).
-camldebug.el is derived from FSF code.
-
-CONTENTS:
-
- caml.el A major mode for editing Caml code in Gnu Emacs
- inf-caml.el To run a Caml toplevel under Emacs, with input and
- output in an Emacs buffer.
- camldebug.el To run the Caml debugger under Emacs.
-
-
-NOTE FOR EMACS 18 USERS:
-
-This package will no longer work with Emacs 18.x. Sorry. You really
-should consider upgrading to Emacs 19.
-
-USAGE:
-
-Add the following lines to your .emacs file:
-
-(setq auto-mode-alist (cons '("\\.ml[iylp]?" . caml-mode) auto-mode-alist))
-(autoload 'caml-mode "caml" "Major mode for editing Caml code." t)
-(autoload 'run-caml "inf-caml" "Run an inferior Caml process." t)
-(autoload 'camldebug "camldebug" "Run the Caml debugger." t)
-
-The Caml major mode is triggered by visiting a file with extension .ml,
-.mli, .mly. .mll or .mlp, or manually by M-x caml-mode. It gives you the
-correct syntax table for the Caml language. For a brief description of
-the indentation capabilities, see below under NEWS.
-
-The Caml mode also allows you to run batch Caml compilations from
-Emacs (using M-x compile) and browse the errors (C-x `). Typing C-x `
-sets the point at the beginning of the erroneous program fragment, and
-the mark at the end. Under Emacs 19, the program fragment is
-temporarily highlighted.
-
-M-x run-caml starts a Caml toplevel with input and output in an Emacs
-buffer named *inferior-caml*. This gives you the full power of Emacs
-to edit the input to the Caml toplevel. This mode is based on comint
-so you get all the usual comint features, including command history.
-
-After M-x run-caml, typing C-c C-e or M-C-x in a buffer in Caml mode
-sends the current phrase (containing the point) to the Caml toplevel,
-and evaluates it.
-
-M-x camldebug FILE starts the Caml debugger camldebug on the executable
-FILE, with input and output in an Emacs buffer named *camldebug-FILE*.
-For a brief description of the commands available in this buffer, see
-NEWS below.
-
-NEWS:
-
-Ok, so this is the really important part of this file :-) I took the
-original package from the contrib subdirectory of the caml-light
-distribution, and hacked on it. First, I added real syntax dependent
-indentation to caml mode. Like Xavier has said, it was hard (and I
-knew it would be), but I refused to believe it was impossible, partly
-because I knew of a Standard ML mode with indentation (written by
-Matthew Morley).
-
-Indentation works pretty much like in other programming modes. C-j at
-the end of a line starts a new line properly indented. M-C-\ indents
-the current region (this may take a while :-)). I incorporated a
-slightly different TAB function, one that I use in other modes: if TAB
-is pressed while the point is not in line indentation, the line is
-indented to the column where point is (instead of just inserting a TAB
-character - you can always to that with C-q C-i). This way, you can
-indent a line any time, regardless of where the point lies, by hitting
-TAB twice in succession. If you don't like this behaviour (but you
-should), it's quite easy to add to your startup code like this:
-
-(defun caml-old-style-indent ()
- (if (caml-in-indentation)
- (caml-indent-command)
- (insert "\t")))
-
-(add-hook 'caml-mode-hook
- (function (lambda ()
- (define-key 'caml-mode-map "\t"
- caml-old-style-indent))))
-
-You can customize the appearance of your caml code by twiddling the
-variables listed at the start of caml.el. Good luck. :-)
-
-Other news in caml mode are the various caml-insert-*-form commands. I
-believe they are self-explanatory - just do a C-h m in a caml buffer
-to see what you've got.
-
-The ohter major news is that I changed camldebug mode considerably. I
-took many clues from the gud "Grand Unified Debugger" mode distributed
-with modern versions of Emacs. The main benefit here is that you can
-do debugger commands _from your caml source buffer_. Commands with the
-C-c prefix in the debugger buffer have counterparts which do the same
-thing (well, a similar thing) in the source buffer, with the C-x C-a
-prefix.
-
-I made the existing debugger commands smarter in that they now attempt
-to guess the correct parameter to the underlying camldebug command. A
-numeric argument will always override that guess. For example, the
-guess for C-c C-b (camldebug-break) is to set a breakpoint at the
-current event (which was the only behaviour provided with the old
-camldebug.el). But C-u 1 C-c C-b will now send "break 1" to the
-camldebug process, setting a break at code address 1.
-
-This also allowed me to add many more commands for which the
-underlying camldebug commands require a parameter. The best way to
-learn about them is to do C-h m in the camldebug buffer, and then C-h
-f for the commands you'll see listed.
-
-Finally, I added command completion. To use it, you'll have to apply
-the provided patch to the debugger itself
-(contrib/debugger/command_line_interpreter.ml), and recompile it
-(you'll get one warning from the compiler; it is safe to ignore
-it). Then hitting TAB in the following situation, for example:
-
-(cdb) pri_
-
-will complete the "pri" to "print".
-
-CAVEATS:
-
-I don't use X and haven't tested this stuff under the X mode of
-emacs. It is entirely possible (though not very probable) that I
-introduced some undesirable interaction between X (fontification,
-highlighting,...) and caml mode. I will welcome reports of such
-problems (see REPORTING below), but I won't be able to do much about
-them unless you also provide a patch.
-
-I don't know if the informational messages produced by camldebug are
-internationalized. If they are, the debugger mode won't work unless
-you set the language to English. The mode uses the messages to
-synchronize with camldebug, and looks for fixed Emacs regular
-expressions that match them. This may be fixed (if necessary) in a
-future release.
-
-BUGS:
-
-In the debugger buffer, it's possible to overflow your mental stack by
-asking for help on help on help on help on help on help on help on
-help...
-
-THANKS:
-
-Xavier Leroy <Xavier.Leroy@inria.fr> for Caml-light. Used together with the
-Emacs interface, it is about the most pleasant programming environment
-I've known on any platform.
-
-Eric Raymond <esr@thyrsus.com> for gud, which camldebug mode apes.
-
-Barry Warsaw <bwarsaw@cen.com> for elp, without which I wouldn't have
-been able to get the indentation code to perform acceptably.
-
-Gareth Rees <Gareth.Rees@cl.cam.ac.uk> for suggestions how to speed up
-Emacs regular expression search, even if I didn't use them in the end.
-
-Bill Dubuque <wgd@martigny.ai.mit.edu> for alerting me to the
-necessity of guarding against C-g inside Emacs code which modifies
-syntax tables.
-
-REPORTING:
-
-Bug reports (preferably with patches), suggestions, donations etc. to:
-
-Ian T Zimmerman +-------------------------------------------+
-Box 13445 I With so many executioners available, I
-Berkeley CA 94712 USA I suicide is a really foolish thing to do. I
-mailto:itz@rahul.net +-------------------------------------------+
diff --git a/emacs/caml-compat.el b/emacs/caml-compat.el
deleted file mode 100644
index 63b4a480fd..0000000000
--- a/emacs/caml-compat.el
+++ /dev/null
@@ -1,28 +0,0 @@
-;; function definitions for old versions of emacs
-
-;; indent-line-to
-
-(if (not (fboundp 'indent-line-to))
- (defun indent-line-to (column)
- "Indent current line to COLUMN.
-
-This function removes or adds spaces and tabs at beginning of line
-only if necessary. It leaves point at end of indentation."
- (if (= (current-indentation) column)
- (back-to-indentation)
- (beginning-of-line 1)
- (delete-horizontal-space)
- (indent-to column))))
-
-;; buffer-substring-no-properties
-
-(cond
- ((fboundp 'buffer-substring-no-properties))
- ((fboundp 'buffer-substring-without-properties)
- (defalias 'buffer-substring-no-properties
- 'buffer-substring-without-properties))
- (t
- (defalias 'buffer-substring-no-properties 'buffer-substring)))
-
-(provide 'caml-compat)
-
diff --git a/emacs/caml-emacs.el b/emacs/caml-emacs.el
deleted file mode 100644
index 5f35c2451a..0000000000
--- a/emacs/caml-emacs.el
+++ /dev/null
@@ -1,29 +0,0 @@
-;; for caml-help.el
-(defalias 'caml-info-other-window 'info-other-window)
-
-;; for caml-types.el
-
-(defalias 'caml-line-beginning-position 'line-beginning-position)
-
-(defalias 'caml-read-event 'read-event)
-(defalias 'caml-window-edges 'window-edges)
-(defun caml-mouse-vertical-position ()
- (cddr (mouse-position)))
-(defalias 'caml-ignore-event-p 'integer-or-marker-p)
-(defalias 'caml-mouse-movement-p 'mouse-movement-p)
-(defalias 'caml-sit-for 'sit-for)
-
-(defmacro caml-track-mouse (&rest body) (cons 'track-mouse body))
-
-(defun caml-event-window (e) (posn-window (event-start e)))
-(defun caml-event-point-start (e) (posn-point (event-start e)))
-(defun caml-event-point-end (e) (posn-point (event-end e)))
-
-(defun caml-release-event-p (original event)
- (and (equal (event-basic-type original) (event-basic-type event))
- (let ((modifiers (event-modifiers event)))
- (or (member 'drag modifiers)
- (member 'click modifiers)))))
-
-
-(provide 'caml-emacs)
diff --git a/emacs/caml-font.el b/emacs/caml-font.el
deleted file mode 100644
index 678b2a5020..0000000000
--- a/emacs/caml-font.el
+++ /dev/null
@@ -1,125 +0,0 @@
-;; useful colors
-
-(cond
- ((x-display-color-p)
- (cond
- ((not (memq 'font-lock-type-face (face-list)))
- ; make the necessary faces
- (make-face 'Firebrick)
- (set-face-foreground 'Firebrick "Firebrick")
- (make-face 'RosyBrown)
- (set-face-foreground 'RosyBrown "RosyBrown")
- (make-face 'Purple)
- (set-face-foreground 'Purple "Purple")
- (make-face 'MidnightBlue)
- (set-face-foreground 'MidnightBlue "MidnightBlue")
- (make-face 'DarkGoldenRod)
- (set-face-foreground 'DarkGoldenRod "DarkGoldenRod")
- (make-face 'DarkOliveGreen)
- (set-face-foreground 'DarkOliveGreen "DarkOliveGreen4")
- (make-face 'CadetBlue)
- (set-face-foreground 'CadetBlue "CadetBlue")
- ; assign them as standard faces
- (setq font-lock-comment-face 'Firebrick)
- (setq font-lock-string-face 'RosyBrown)
- (setq font-lock-keyword-face 'Purple)
- (setq font-lock-function-name-face 'MidnightBlue)
- (setq font-lock-variable-name-face 'DarkGoldenRod)
- (setq font-lock-type-face 'DarkOliveGreen)
- (setq font-lock-reference-face 'CadetBlue)))
- ; extra faces for documention
- (make-face 'Stop)
- (set-face-foreground 'Stop "White")
- (set-face-background 'Stop "Red")
- (make-face 'Doc)
- (set-face-foreground 'Doc "Red")
- (setq font-lock-stop-face 'Stop)
- (setq font-lock-doccomment-face 'Doc)
-))
-
-; The same definition is in caml.el:
-; we don't know in which order they will be loaded.
-(defvar caml-quote-char "'"
- "*Quote for character constants. \"'\" for Objective Caml, \"`\" for Caml-Light.")
-
-(defconst caml-font-lock-keywords
- (list
-;stop special comments
- '("\\(^\\|[^\"]\\)\\((\\*\\*/\\*\\*)\\)"
- 2 font-lock-stop-face)
-;doccomments
- '("\\(^\\|[^\"]\\)\\((\\*\\*[^*]*\\([^)*][^*]*\\*+\\)*)\\)"
- 2 font-lock-doccomment-face)
-;comments
- '("\\(^\\|[^\"]\\)\\((\\*[^*]*\\*+\\([^)*][^*]*\\*+\\)*)\\)"
- 2 font-lock-comment-face)
-;character literals
- (cons (concat caml-quote-char "\\(\\\\\\([ntbr" caml-quote-char "\\]\\|"
- "[0-9][0-9][0-9]\\)\\|.\\)" caml-quote-char
- "\\|\"[^\"\\]*\\(\\\\\\(.\\|\n\\)[^\"\\]*\\)*\"")
- 'font-lock-string-face)
-;modules and constructors
- '("`?\\<[A-Z][A-Za-z0-9_']*\\>" . font-lock-function-name-face)
-;definition
- (cons (concat
- "\\<\\(a\\(nd\\|s\\)\\|c\\(onstraint\\|lass\\)"
- "\\|ex\\(ception\\|ternal\\)\\|fun\\(ct\\(ion\\|or\\)\\)?"
- "\\|in\\(herit\\|itializer\\)?\\|let"
- "\\|m\\(ethod\\|utable\\|odule\\)"
- "\\|of\\|p\\(arser\\|rivate\\)\\|rec\\|type"
- "\\|v\\(al\\|irtual\\)\\)\\>")
- 'font-lock-type-face)
-;blocking
- '("\\<\\(begin\\|end\\|object\\|s\\(ig\\|truct\\)\\)\\>"
- . font-lock-keyword-face)
-;control
- (cons (concat
- "\\<\\(do\\(ne\\|wnto\\)?\\|else\\|for\\|i\\(f\\|gnore\\)"
- "\\|lazy\\|match\\|new\\|or\\|t\\(hen\\|o\\|ry\\)"
- "\\|w\\(h\\(en\\|ile\\)\\|ith\\)\\)\\>"
- "\\|\|\\|->\\|&\\|#")
- 'font-lock-reference-face)
- '("\\<raise\\>" . font-lock-comment-face)
-;labels (and open)
- '("\\(\\([~?]\\|\\<\\)[a-z][a-zA-Z0-9_']*:\\)[^:=]" 1
- font-lock-variable-name-face)
- '("\\<\\(assert\\|open\\|include\\)\\>\\|[~?][ (]*[a-z][a-zA-Z0-9_']*"
- . font-lock-variable-name-face)))
-
-(defconst inferior-caml-font-lock-keywords
- (append
- (list
-;inferior
- '("^[#-]" . font-lock-comment-face))
- caml-font-lock-keywords))
-
-;; font-lock commands are similar for caml-mode and inferior-caml-mode
-(add-hook 'caml-mode-hook
- '(lambda ()
- (cond
- ((fboundp 'global-font-lock-mode)
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults
- '(caml-font-lock-keywords nil nil ((?' . "w") (?_ . "w")))))
- (t
- (setq font-lock-keywords caml-font-lock-keywords)))
- (make-local-variable 'font-lock-keywords-only)
- (setq font-lock-keywords-only t)
- (font-lock-mode 1)))
-
-(defun inferior-caml-mode-font-hook ()
- (cond
- ((fboundp 'global-font-lock-mode)
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults
- '(inferior-caml-font-lock-keywords
- nil nil ((?' . "w") (?_ . "w")))))
- (t
- (setq font-lock-keywords inferior-caml-font-lock-keywords)))
- (make-local-variable 'font-lock-keywords-only)
- (setq font-lock-keywords-only t)
- (font-lock-mode 1))
-
-(add-hook 'inferior-caml-mode-hooks 'inferior-caml-mode-font-hook)
-
-(provide 'caml-font)
diff --git a/emacs/caml-help.el b/emacs/caml-help.el
deleted file mode 100644
index ea082bf242..0000000000
--- a/emacs/caml-help.el
+++ /dev/null
@@ -1,815 +0,0 @@
-;; caml-info.el --- contextual completion and help to caml-mode
-
-;; Didier Remy, November 2001.
-
-;; This provides two functions completion and help
-;; look for caml-complete and caml-help
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; This is a preliminary version.
-;;
-;; Possible improvements?
-;; - dump some databaes: Info, Lib, ...
-;; - accept a search path for local libraries instead of current dir
-;; (then distinguish between different modules lying in different
-;; directories)
-;; - improve the construction for info files.
-;;
-;; Abstract over
-;; - the viewing method and the database, so that the documentation for
-;; and identifier could be search in
-;; * info / html / man / mli's sources
-;; * viewed in emacs or using an external previewer.
-;;
-;; Take all identifiers (labels, Constructors, exceptions, etc.)
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-(eval-and-compile
- (if (and (boundp 'running-xemacs) running-xemacs)
- (require 'caml-xemacs)
- (require 'caml-emacs)))
-
-;; Loading or building databases.
-;;
-
-;; variables to be customized
-
-(defvar ocaml-lib-path 'lazy
- "Path list for ocaml lib sources (mli files)
-
-'lazy means ask ocaml to find it for your at first use.")
-(defun ocaml-lib-path ()
- "Computes if necessary and returns the path for ocaml libs"
- (if (listp ocaml-lib-path) nil
- (setq ocaml-lib-path
- (split-string
- (shell-command-to-string
- (or
- (and (boundp 'inferior-caml-program)
- (string-match "\\([^ ]*/ocaml\\)\\( \\|$\\)"
- inferior-caml-program)
- (let ((file
- (concat (match-string 1 inferior-caml-program)
- "c")))
- (and (file-executable-p file)
- (concat file " -where"))))
- "ocamlc -where")))))
- ocaml-lib-path)
-
-
-
-;; General purpose auxiliary functions
-
-(defun ocaml-capitalize (s)
- (concat (capitalize (substring s 0 1)) (substring s 1)))
-
-(defun ocaml-uncapitalize (s)
- (if (> (length s) 0)
- (concat (downcase (substring s 0 1)) (substring s 1))
- s))
-
-(defun iter (f l) (while (consp l) (apply f (list (car l))) (setq l (cdr l))))
-
-(defun ocaml-find-files (path filter &optional depth split)
- (let* ((path-string
- (if (stringp path)
- (if (file-directory-p path) path nil)
- (mapconcat '(lambda (d) (if (file-directory-p d) d))
- path " ")))
- (command
- (and path-string
- (concat "find " path-string
- " '(' " filter " ')' "
- (if depth (concat " -maxdepth " (int-to-string depth)))
- (if split nil " -printf '%\p '")
- )))
- (files
- (and command (shell-command-to-string command))))
- (if (and split (stringp files)) (split-string files "\n") files)
- ))
-
-;; Specialized auxiliary functions
-
-
-;; Global table of modules contents of modules loaded lazily.
-
-(defvar ocaml-module-alist 'lazy
- "A-list of modules with how and where to find help information.
- 'delay means non computed yet")
-
-(defun ocaml-add-mli-modules (modules tag &optional path)
- (let ((files
- (ocaml-find-files (or path (ocaml-lib-path))
- "-type f -name '*.mli'" 1 t)))
- (while (consp files)
- (if (string-match "\\([^/]*\\).mli" (car files))
- (let* ((module (ocaml-capitalize (match-string 1 (car files))))
- (dir (file-name-directory (car files)))
- (dirp (member dir (ocaml-lib-path))))
- (if (and (consp dirp) (string-equal dir (car dirp)))
- (setq dir (car dirp)))
- (if (assoc module modules) nil
- (setq modules
- (cons (cons module (cons (cons tag dir) 'lazy)) modules))
- )))
- (setq files (cdr files)))
- modules))
-
-(defun ocaml-add-path (dir &optional path)
- "Extend ocaml-module-alist with modules of DIR relative to PATH"
- (interactive "D")
- (let* ((old (ocaml-lib-path))
- (new
- (if (file-name-absolute-p dir) dir
- (concat
- (or (find-if '(lambda (p) (file-directory-p (concat p "/" dir)))
- (cons default-directory old))
- (error "Directory not found"))
- "/" dir))))
- (setq ocaml-lib-path (cons (car old) (cons new (cdr old))))
- (setq ocaml-module-alist
- (ocaml-add-mli-modules (ocaml-module-alist) 'lib new))))
-
-(defun ocaml-module-alist ()
- "Call by need value of variable ocaml-module-alist"
- (if (listp ocaml-module-alist)
- nil
- ;; build list of mli files
- (setq ocaml-module-alist (ocaml-add-mli-modules nil 'lib))
- ;; dumping information ? TODO
- )
- ocaml-module-alist)
-
-(defun ocaml-get-or-make-module (module &optional tag)
- (let ((info (assoc module (ocaml-module-alist))))
- (if info nil
- (setq info (cons module (cons (cons 'local default-directory) 'lazy)))
- (setq ocaml-module-alist (cons info ocaml-module-alist))
- )
- info))
-
-;; Symbols of module are lazily computed
-
-(defun ocaml-module-filename (module)
- (let ((module (ocaml-uncapitalize module)) (name))
- (if (file-exists-p (setq name (concat module ".mli"))) nil
- (let ((tmp (ocaml-lib-path)))
- (while (consp tmp)
- (setq name (concat (car tmp) "/" module ".mli"))
- (if (file-exists-p name) (setq tmp nil)
- (setq name nil)))))
- name))
-
-(defun ocaml-module-symbols (module-info)
- (let* ((module (car module-info))
- (tail (and module-info (cdr module-info)))
- (tag (caar tail))
- (dir (cdar tail))
- (file)
- (alist))
- (if (listp (cdr tail))
- (cdr tail)
- (if (equal tag 'info)
- (setq dir (car ocaml-lib-path)) ; XXX to be fixed
- )
- (setq file (concat dir "/" (ocaml-uncapitalize module) ".mli"))
- (message file)
- (save-window-excursion
- (set-buffer (get-buffer-create "*caml-help*"))
- (if (and file (file-exists-p file))
- (progn
- (message "Scanning module %s" file)
- (insert-file-contents file))
- (message "Module %s not found" module))
- (while (re-search-forward
- "\\([ \t]*val\\|let\\|external\\| [|]\\) \\([a-zA-Z_0-9'][a-zA-Z_0-9']*\\)\\|^ *[{]* \\([a-z_][A-Za-z_0-9]*\\) : [^;\n][^;\n]*;"
- (point-max) 'move)
- (pop-to-buffer (current-buffer))
- (setq alist (cons (or (match-string 2) (match-string 3)) alist)))
- (erase-buffer)
- )
- (setcdr tail alist)
- alist)
- ))
-
-;; Local list of visible modules.
-
-(defvar ocaml-visible-modules 'lazy
- "A-list of open modules, local to every file.")
-(make-variable-buffer-local 'ocaml-visible-modules)
-(defun ocaml-visible-modules ()
- (if (listp ocaml-visible-modules) nil
- (progn
- (setq ocaml-visible-modules
- (list (ocaml-get-or-make-module "Pervasives")))
- (save-excursion
- (goto-char (point-min))
- (while (re-search-forward "^ *open *\\([A-Z][a-zA-Z'_0-9]*\\)"
- (point-max) t)
- (let ((module (match-string 1)))
- (if (assoc module ocaml-visible-modules) nil
- (setq ocaml-visible-modules
- (cons (ocaml-get-or-make-module module)
- ocaml-visible-modules)))))
- )))
- ocaml-visible-modules)
-
-(defun ocaml-open-module (arg)
- "*Make module of name ARG visible whe ARG is a string.
-When call interactively, make completion over known modules."
- (interactive "P")
- (if (not (stringp arg))
- (let ((modules (ocaml-module-alist)))
- (setq arg
- (completing-read "Open module: " modules))))
- (if (and (stringp arg) (not (equal arg "")))
- (progn
- (if (assoc arg (ocaml-visible-modules))
- (ocaml-close-module arg))
- (setq ocaml-visible-modules
- (cons (ocaml-get-or-make-module arg) (ocaml-visible-modules)))
- ))
- (message "%S" (mapcar 'car (ocaml-visible-modules))))
-
-(defun ocaml-close-module (arg)
- "*Close module of name ARG when ARG is a string.
-When call interactively, make completion over visible modules.
-Otherwise if ARG is true, close all modules and reset to default. "
- (interactive "P")
- (if (= (prefix-numeric-value arg) 4)
- (setq ocaml-visible-modules 'lazy)
- (let* ((modules (ocaml-visible-modules)))
- (if (null modules) (error "No visible module to close"))
- (unless (stringp arg)
- (setq arg
- (completing-read
- (concat "Close module [" (caar modules) "] : ")
- modules))
- (if (equal arg "") (setq arg (caar modules))))
- (setq ocaml-visible-modules
- (remove-if '(lambda (m) (equal (car m) arg))
- ocaml-visible-modules))
- ))
- (message "%S" (mapcar 'car (ocaml-visible-modules))))
-
-
-;; Look for identifiers around point
-
-(defun ocaml-qualified-identifier (&optional show)
- "Search for a qualified identifier (Path. entry) around point.
-
-Entry may be nil.
-Currently, the path may only be nil or a single Module.
-For paths is of the form Module.Path', it returns Module
-and always nil for entry.
-
-If defined Module and Entry are represented by a region in the buffer,
-and are nil otherwise.
-
-For debugging purposes, it returns the string Module.entry if called
-with an optional non-nil argument.
-"
- (save-excursion
- (let ((module) (entry))
- (if (looking-at "[ \n]") (skip-chars-backward " "))
- (if (re-search-backward
- "\\([^A-Za-z0-9_.']\\|\\`\\)\\([A-Za-z0-9_']*[.]\\)*[A-Za-z0-9_']*\\="
- (- (point) 100) t)
- (progn
- (or (looking-at "\\`[A-Za-z)-9_.]") (forward-char 1))
- (if (looking-at "\\<\\([A-Za-z_][A-Za-z0-9_']*\\)[.]")
- (progn
- (setq module (cons (match-beginning 1) (match-end 1)))
- (goto-char (match-end 0))))
- (if (looking-at "\\<\\([A-Za-z_][A-Za-z0-9_']*\\)\\>")
- (setq entry (cons (match-beginning 1) (match-end 1))))))
- (if show
- (concat
- (and module (buffer-substring (car module) (cdr module)))
- "."
- (and entry (buffer-substring (car entry) (cdr entry))))
- (cons module entry))
- )))
-
-;; completion around point
-
-(defun ocaml-completion (pattern module)
- (let ((list
- (or
- (and module
- (list
- (or (assoc module (ocaml-module-alist))
- (error "Unknown module %s" module))))
- (ocaml-visible-modules))))
- (message "Completion from %s" (mapconcat 'car list " "))
- (if (null pattern)
- (apply 'append (mapcar 'ocaml-module-symbols list))
- (let ((pat (concat "^" (regexp-quote pattern))) (res))
- (iter
- '(lambda (l)
- (iter '(lambda (x)
- (if (string-match pat (car l))
- (if (member x res) nil (setq res (cons x res)))))
- (ocaml-module-symbols l)))
- list)
- res)
- )))
-
-(defun caml-complete (arg)
- "Does completion for OCaml identifiers qualified.
-
-It attemps to recognize an qualified identifier Module . entry
-around point using function \\[ocaml-qualified-identifier].
-
-If Module is defined, it does completion for identifier in Module.
-
-If Module is undefined, it does completion in visible modules.
-Then, if completion fails, it does completion among all modules
-where identifier is defined."
- (interactive "p")
- (let* ((module-entry (ocaml-qualified-identifier)) (entry)
- (module)
- (beg) (end) (pattern))
- (if (car module-entry)
- (progn
- (setq module
- (buffer-substring (caar module-entry) (cdar module-entry)))
- (or (assoc module (ocaml-module-alist))
- (and (setq module
- (completing-read "Module: " (ocaml-module-alist)
- nil nil module))
- (save-excursion
- (goto-char (caar module-entry))
- (delete-region (caar module-entry) (cdar module-entry))
- (insert module) t)
- (setq module-entry (ocaml-qualified-identifier))
- (car module-entry)
- (progn (setq entry (cdr module-entry)) t))
- (error "Unknown module %s" module))))
- (if (consp (cdr module-entry))
- (progn
- (setq beg (cadr module-entry))
- (setq end (cddr module-entry)))
- (if (and module
- (save-excursion
- (goto-char (cdar module-entry))
- (looking-at " *[.]")))
- (progn
- (setq beg (match-end 0))
- (setq end beg))))
- (if (not (and beg end))
- (error "Did not find anything to complete around point")
-
- (setq pattern (buffer-substring beg end))
- (let* ((all-completions (ocaml-completion pattern module))
- (completion
- (try-completion pattern (mapcar 'list all-completions))))
- (cond ((eq completion t))
-
- ((null completion)
- (let*
- ((modules (ocaml-find-module pattern))
- (visible (intersection modules (ocaml-visible-modules)))
- (hist)
- (module
- (cond
- ((null modules)
- nil)
- ((equal (length modules) 1)
- (caar modules))
- ((equal (length visible) 1)
- (caar visible))
- (t
- (setq hist (mapcar 'car modules))
- (completing-read "Module: " modules nil t
- "" (cons hist 0)))
- )))
- (if (null module)
- (error "Can't find completion for \"%s\"" pattern)
- (message "Completion found in module %s" module)
- (if (and (consp module-entry) (consp (cdr module-entry)))
- (delete-region (caar module-entry) end)
- (delete-region beg end))
- (insert module "." pattern))))
-
- ((not (string-equal pattern completion))
- (delete-region beg end)
- (goto-char beg)
- (insert completion))
-
- (t
- (with-output-to-temp-buffer "*Completions*"
- (display-completion-list all-completions))
- ))
- ))))
-
-
-;; Info files (only in ocamldoc style)
-
-
-(defvar ocaml-info-prefix "ocaml-lib"
- "Prefix of ocaml info files describing library modules.
-Suffix .info will be added to info files.
-Additional suffix .gz may be added if info files are compressed.
-")
-;;
-
-(defun ocaml-hevea-info-add-entries (entries dir name)
- (let*
- ((filter
- (concat "-type f -regex '.*/" name
- "\\(.info\\|\\)\\(-[0-9]*\\|\\)\\([.]gz\\|\\)'"
- ))
- (section-regexp
- "\\* \\(Section [1-9][0-9--]*\\)::[ \t][ \t]*Module *\\([A-Z][A-Za-z_0-9]*\\)")
- (files (ocaml-find-files dir filter))
- (command))
- ;; scanning info files
- (if (or (null files)
- (not (stringp files))
- (string-match files "^ *$"))
- (message "No info file found: %s." (mapconcat 'identity files " "))
- (message "Scanning info files %s." files)
- (save-window-excursion
- (set-buffer (get-buffer-create "*caml-help*"))
- (setq command
- (concat "zcat -f " files
- " | grep -e '" section-regexp "'"))
- (message "Scanning files with: %s" command)
- (or (shell-command command (current-buffer))
- (error "Error while scanning"))
- (goto-char (point-min))
- (while (re-search-forward section-regexp (point-max) t)
- (let* ((module (match-string 2))
- (section (match-string 1)))
- ;; (message "%s %s" module section)
- (if (assoc module entries) nil
- (setq entries
- (cons (cons module (concat "(" name ")" section))
- entries))
- )))
- (let ((buf (get-buffer "*caml-help*")))
- (if buf (kill-buffer buf)))))
- entries))
-
-(defun ocaml-hevea-info ()
- "The default way to create an info data base from the value
-of \\[Info-default-directory-list] and the base name \\[ocaml-info-name]
-of files to look for.
-
-This uses info files produced by HeVeA.
-"
- (let ((collect) (seen))
- (iter '(lambda (d)
- (if (member d seen) nil
- (setq collect
- (ocaml-hevea-info-add-entries
- collect d ocaml-info-prefix))
- (setq done (cons d seen))))
- Info-directory-list)
- collect))
-
-(defun ocaml-ocamldoc-info-add-entries (entries dir name)
- (let*
- ((module-regexp "^Node: \\([A-Z][A-Za-z_0-9]*\\)[^ ]")
- (command
- (concat
- "find " dir " -type f -regex '.*/" name
- "\\(.info\\|\\)\\([.]gz\\|\\)' -print0"
- " | xargs -0 zcat -f | grep '" module-regexp "'")))
- (message "Scanning info files in %s" dir)
- (save-window-excursion
- (set-buffer (get-buffer-create "*caml-help*"))
- (or (shell-command command (current-buffer)) (error "HERE"))
- (goto-char (point-min))
- (while (re-search-forward module-regexp (point-max) t)
- (if (equal (char-after (match-end 1)) 127)
- (let* ((module (match-string 1)))
- (if (assoc module entries) nil
- (setq entries
- (cons (cons module (concat "(" name ")" module))
- entries))
- ))))
- ; (kill-buffer (current-buffer))
- )
- entries))
-
-(defun ocaml-ocamldoc-info ()
- "The default way to create an info data base from the value
-of \\[Info-default-directory-list] and the base name \\[ocaml-info-name]
-of files to look for.
-
-This uses info files produced by ocamldoc."
- (require 'info)
- (let ((collect) (seen))
- (iter '(lambda (d)
- (if (member d seen) nil
- (setq collect
- (ocaml-ocamldoc-info-add-entries collect d
- ocaml-info-prefix))
- (setq done (cons d seen))))
- Info-directory-list)
- collect))
-
-;; Continuing
-
-(defvar ocaml-info-alist 'ocaml-ocamldoc-info
- "A-list binding module names to info entries:
-
- nil means do not use info.
-
- A function to build the list lazily (at the first call). The result of
-the function call will be assign permanently to this variable for future
-uses. We provide two default functions \\[ocaml-info-default-function]
-(info produced by HeVeA is the default) and \\[ocaml-info-default-function]
-(info produced by ocamldoc).
-
- Otherwise, this value should be an alist binding module names to info
-entries of the form to \"(entry)section\" be taken by the \\[info]
-command. An entry may be an info module or a complete file name."
-)
-
-(defun ocaml-info-alist ()
- "Call by need value of variable ocaml-info-alist"
- (cond
- ((listp ocaml-info-alist))
- ((functionp ocaml-info-alist)
- (setq ocaml-info-alist (apply ocaml-info-alist nil)))
- (t
- (error "wrong type for ocaml-info-alist")))
- ocaml-info-alist)
-
-;; help around point
-
-(defun ocaml-find-module (symbol &optional module-list)
- (let ((list (or module-list (ocaml-module-alist)))
- (collect))
- (while (consp list)
- (if (member symbol (ocaml-module-symbols (car list)))
- (setq collect (cons (car list) collect)))
- (setq list (cdr list)))
- (nreverse collect)
- ))
-
-(defun ocaml-buffer-substring (region)
- (and region (buffer-substring-no-properties (car region) (cdr region))))
-
-;; Help function.
-
-
-(defun ocaml-goto-help (&optional module entry same-window)
- "Searches info manual for MODULE and ENTRY in MODULE.
-If unspecified, MODULE and ENTRY are inferred from the position in the
-current buffer using \\[ocaml-qualified-identifier]."
- (interactive)
- (let ((window (selected-window))
- (info-section (assoc module (ocaml-info-alist))))
- (if info-section
- (caml-info-other-window (cdr info-section))
- (ocaml-visible-modules)
- (let* ((module-info
- (or (assoc module (ocaml-module-alist))
- (and (file-exists-p
- (concat (ocaml-uncapitalize module) ".mli"))
- (ocaml-get-or-make-module module))))
- (location (cdr (cadr module-info))))
- (cond
- (location
- (let ((file (concat location (ocaml-uncapitalize module) ".mli")))
- (if (window-live-p same-window)
- (progn (select-window same-window)
- (view-mode-exit view-return-to-alist view-exit-action))
- ;; (view-buffer (find-file-noselect file) 'view))
- )
- (view-file-other-window file)
- (bury-buffer (current-buffer))))
- (info-section (error "Aborted"))
- (t (error "No help for module %s" module))))
- )
- (if (stringp entry)
- (let ((here (point))
- (case-fold-search nil))
- (goto-char (point-min))
- (if (or (re-search-forward
- (concat "\\(val\\|exception\\|type\\|external\\|[|{;]\\) +"
- (regexp-quote entry))
- (point-max) t)
- (re-search-forward
- (concat "type [^{]*{[^}]*" (regexp-quote entry) " :")
- (point-max) t)
- (progn
- (if (window-live-p window) (select-window window))
- (error "Entry %s not found in module %s"
- entry module))
- ;; (search-forward entry (point-max) t)
- )
- (recenter 1)
- (progn
- (message "Help for entry %s not found in module %s"
- entry module)
- (goto-char here)))))
- (ocaml-link-activate (cdr info-section))
- (if (window-live-p window) (select-window window))
- ))
-
-(defun caml-help (arg)
- "Find documentation for OCaml qualified identifiers.
-
-It attemps to recognize an qualified identifier of the form
-``Module . entry'' around point using function `ocaml-qualified-identifier'.
-
-If Module is undetermined it is temptatively guessed from the identifier name
-and according to visible modules. If this is still unsucessful, the user is
-then prompted for a Module name.
-
-The documentation for Module is first seach in the info manual if available,
-then in the ``module.mli'' source file. The entry is then searched in the documentation.
-
-Visible modules are computed only once, at the first call.
-Modules can be made visible explicitly with `ocaml-open-module' and
-hidden with `ocaml-close-module'.
-
-Prefix arg 0 forces recompilation of visible modules (and their content)
-from the file content.
-
-Prefix arg 4 prompts for Module and identifier instead of guessing values
-from the possition of point in the current buffer.
-"
- (interactive "p")
- (let ((module) (entry) (module-entry))
- (cond
- ((= arg 4)
- (or (and
- (setq module
- (completing-read "Module: " (ocaml-module-alist)
- nil t "" (cons 'hist 0)))
- (not (string-equal module "")))
- (error "Quit"))
- (let ((symbols
- (mapcar 'list
- (ocaml-module-symbols
- (assoc module (ocaml-module-alist))))))
- (setq entry (completing-read "Value: " symbols nil t)))
- (if (string-equal entry "") (setq entry nil))
- )
- (t
- (if (= arg 0) (setq ocaml-visible-modules 'lazy))
- (setq module-entry (ocaml-qualified-identifier))
- (setq entry (ocaml-buffer-substring (cdr module-entry)))
- (setq module
- (or (ocaml-buffer-substring (car module-entry))
- (let ((modules
- (or (ocaml-find-module entry (ocaml-visible-modules))
- (ocaml-find-module entry)))
- (hist) (default))
- (cond
- ((null modules)
- (error "No module found for entry %s" entry))
- ((equal (length modules) 1)
- (caar modules))
- (t
- (setq hist (mapcar 'car modules))
- (setq default (car hist))
- (setq module
- (completing-read
- (concat "Module: "
- (and default (concat "[" default "] ")))
- modules nil t "" (cons 'hist 0)))
- (if (string-equal module "") default module))
- ))))
- ))
- (message "Help for %s%s%s" module (if entry "." "") (or entry ""))
- (ocaml-goto-help module entry)
- ))
-
-;; auto-links
-
-(defconst ocaml-link-regexp
- "\\(type\\|and\\) \\('[a-z] +\\|(\\('[a-z], *\\)*'[a-z])\\|\\) *\\([a-zA-Z0-9_]*\\)\\( *$\\| =\\)")
-(defconst ocaml-longident-regexp
- "\\([A-Z][a-zA-Z_0]*\\)[.]\\([a-zA-Z][A-Za-z0-9_]*\\)")
-
-(defvar ocaml-links nil
- "Local links in the current of last info node or interface file.
-
-The car of the list is a key that indentifies the module to prevent
-recompilation when next help command is relative to the same module.
-The cdr is a list of elments, each of which is an string and a pair of
-buffer positions."
-)
-(make-variable-buffer-local 'ocaml-links)
-
-(defun ocaml-info-links (section)
- (cdr
- (if (and ocaml-links section (equal (car ocaml-links) section))
- ocaml-links
- (save-excursion
- (goto-char (point-min))
- (let ((regexp (concat (if (equal major-mode 'Info-mode) "^ - " "^")
- ocaml-link-regexp))
- (all))
- (while (re-search-forward regexp (point-max) t)
- (setq all
- (cons (cons (match-string 4)
- (cons (match-beginning 4)
- (match-end 4)))
- all)))
- (setq ocaml-links (cons section all))
- )))))
-
-(defvar ocaml-link-map (make-sparse-keymap))
-(define-key ocaml-link-map [mouse-2] 'ocaml-link-goto)
-
-(defun ocaml-link-goto (click)
- (interactive "e")
- (let* ((pos (caml-event-point-start click))
- (win (caml-event-window click))
- (buf (window-buffer win))
- (window (selected-window))
- (link))
- (setq link
- (with-current-buffer buf
- (buffer-substring
- (previous-single-property-change (+ pos 1) 'local-map
- buf (- pos 100))
- (next-single-property-change pos 'local-map
- buf (+ pos 100)))))
- (if (string-match (concat "^" ocaml-longident-regexp "$") link)
- (ocaml-goto-help (match-string 1 link) (match-string 2 link) win)
- (if (not (equal (window-buffer window) buf))
- (switch-to-buffer-other-window buf))
- (if (setq link (assoc link (cdr ocaml-links)))
- (progn
- (goto-char (cadr link))
- (recenter 1)))
- (if (window-live-p window) (select-window window))
- )))
-
-(cond
- ((and (x-display-color-p)
- (not (memq 'ocaml-link-face (face-list))))
- (make-face 'ocaml-link-face)
- (set-face-foreground 'ocaml-link-face "Purple")))
-
-
-(defun ocaml-link-activate (section)
- (let ((links (ocaml-info-links section)))
- (if links
- (let ((regexp (concat "[^A-Za-z0-9'_]\\("
- ocaml-longident-regexp "\\|"
- (mapconcat 'car links "\\|")
- "\\)[^A-Za-z0-9'_]"))
- (case-fold-search nil))
- (goto-char (point-min))
- (let ((buffer-read-only nil)
- ;; use of dynamic scoping, need not be restored!
- (modified-p (buffer-modified-p)))
- (unwind-protect
- (save-excursion
- (goto-char (point-min))
- (while (re-search-forward regexp (point-max) t)
- (put-text-property (match-beginning 1) (match-end 1)
- 'mouse-face 'highlight)
- (put-text-property (match-beginning 1) (match-end 1)
- 'local-map ocaml-link-map)
- (if (x-display-color-p)
- (put-text-property (match-beginning 1) (match-end 1)
- 'face 'ocaml-link-face)))
- )
- ;; need to restore flag if buffer was unmodified.
- (unless modified-p (set-buffer-modified-p nil))
- ))
- ))))
-
-
-
-;; bindings ---now in caml.el
-
-; (and
-; (boundp 'caml-mode-map)
-; (keymapp caml-mode-map)
-; (progn
-; (define-key caml-mode-map [?\C-c?i] 'ocaml-add-path)
-; (define-key caml-mode-map [?\C-c?]] 'ocaml-close-module)
-; (define-key caml-mode-map [?\C-c?[] 'ocaml-open-module)
-; (define-key caml-mode-map [?\C-c?\C-h] 'caml-help)
-; (define-key caml-mode-map [?\C-c?\t] 'caml-complete)
-; (let ((map (lookup-key caml-mode-map [menu-bar caml])))
-; (and
-; (keymapp map)
-; (progn
-; (define-key map [separator-help] '("---"))
-; (define-key map [open] '("Open add path" . ocaml-add-path ))
-; (define-key map [close]
-; '("Close module for help" . ocaml-close-module))
-; (define-key map [open] '("Open module for help" . ocaml-open-module))
-; (define-key map [help] '("Help for identifier" . caml-help))
-; (define-key map [complete] '("Complete identifier" . caml-complete))
-; )
-; ))))
-
-
-(provide 'caml-help)
diff --git a/emacs/caml-hilit.el b/emacs/caml-hilit.el
deleted file mode 100644
index 7b48a8119f..0000000000
--- a/emacs/caml-hilit.el
+++ /dev/null
@@ -1,53 +0,0 @@
-; Highlighting patterns for hilit19 under caml-mode
-
-; defined also in caml.el
-(defvar caml-quote-char "'"
- "*Quote for character constants. \"'\" for Objective Caml, \"`\" for Caml-Light.")
-
-(defconst caml-mode-patterns
- (list
-;comments
- '("\\(^\\|[^\"]\\)\\((\\*[^*]*\\*+\\([^)*][^*]*\\*+\\)*)\\)"
- 2 comment)
-;string
- (list 'hilit-string-find (string-to-char caml-quote-char) 'string)
- (list (concat caml-quote-char "\\(\\\\\\([ntbr" caml-quote-char "\\]\\|"
- "[0-9][0-9][0-9]\\)\\|.\\)" caml-quote-char)
- nil
- 'string)
-;labels
- '("\\(\\([~?]\\|\\<\\)[a-z][a-zA-Z0-9_']*:\\)[^:=]" 1 brown)
- '("[~?][ (]*[a-z][a-zA-Z0-9_']*" nil brown)
-;modules
- '("\\<\\(assert\\|open\\|include\\)\\>" nil brown)
- '("`?\\<[A-Z][A-Za-z0-9_\']*\\>" nil MidnightBlue)
-;definition
- (list (concat
- "\\<\\(a\\(nd\\|s\\)\\|c\\(onstraint\\|lass\\)"
- "\\|ex\\(ception\\|ternal\\)\\|fun\\(ct\\(ion\\|or\\)\\)?"
- "\\|in\\(herit\\)?\\|let\\|m\\(ethod\\|utable\\|odule\\)"
- "\\|of\\|p\\(arser\\|rivate\\)\\|rec\\|type"
- "\\|v\\(al\\|irtual\\)\\)\\>")
- nil 'ForestGreen)
-;blocking
- '("\\<\\(object\\|struct\\|sig\\|begin\\|end\\)\\>" 2 include)
-;control
- (list (concat
- "\\<\\(do\\(ne\\|wnto\\)?\\|else\\|for\\|i\\(f\\|gnore\\)"
- "\\|lazy\\|match\\|new\\|or\\|t\\(hen\\|o\\|ry\\)"
- "\\|w\\(h\\(en\\|ile\\)\\|ith\\)\\)\\>"
- "\\|\|\\|->\\|&\\|#")
- nil 'keyword)
- '(";" nil struct))
- "Hilit19 patterns used for Caml mode")
-
-(hilit-set-mode-patterns 'caml-mode caml-mode-patterns)
-(hilit-set-mode-patterns
- 'inferior-caml-mode
- (append
- (list
-;inferior
- '("^[#-]" nil firebrick))
- caml-mode-patterns))
-
-(provide 'caml-hilit)
diff --git a/emacs/caml-types.el b/emacs/caml-types.el
deleted file mode 100644
index 743dd2f8ec..0000000000
--- a/emacs/caml-types.el
+++ /dev/null
@@ -1,572 +0,0 @@
-;(***********************************************************************)
-;(* *)
-;(* Objective Caml *)
-;(* *)
-;(* Damien Doligez, projet Moscova, INRIA Rocquencourt *)
-;(* *)
-;(* Copyright 2003 Institut National de Recherche en Informatique et *)
-;(* en Automatique. All rights reserved. This file is distributed *)
-;(* under the terms of the Q Public License version 1.0. *)
-;(* *)
-;(***********************************************************************)
-
-;(* $Id$ *)
-
-; An emacs-lisp complement to the "-dtypes" option of ocamlc and ocamlopt.
-
-;; XEmacs compatibility
-
-(eval-and-compile
- (if (and (boundp 'running-xemacs) running-xemacs)
- (require 'caml-xemacs)
- (require 'caml-emacs)))
-
-
-
-(defvar caml-types-location-re nil "Regexp to parse *.annot files.
-
-Annotation files *.annot may be generated with the \"-dtypes\" option
-of ocamlc and ocamlopt.
-
-Their format is:
-
- file ::= block *
- block ::= position <SP> position <LF> annotation *
- position ::= filename <SP> num <SP> num <SP> num
- annotation ::= keyword open-paren <LF> <SP> <SP> data <LF> close-paren
-
- <SP> is a space character (ASCII 0x20)
- <LF> is a line-feed character (ASCII 0x0A)
- num is a sequence of decimal digits
- filename is a string with the lexical conventions of O'Caml
- open-paren is an open parenthesis (ASCII 0x28)
- close-paren is a closed parenthesis (ASCII 0x29)
- data is any sequence of characters where <LF> is always followed by
- at least two space characters.
-
-- in each block, the two positions are respectively the start and the
-- end of the range described by the block.
-- in a position, the filename is the name of the file, the first num
- is the line number, the second num is the offset of the beginning
- of the line, the third num is the offset of the position itself.
-- the char number within the line is the difference between the third
- and second nums.
-
-For the moment, the only possible keyword is \"type\"."
-)
-
-(let* ((caml-types-filename-re "\"\\(\\([^\\\"]\\|\\\\.\\)*\\)\"")
- (caml-types-number-re "\\([0-9]*\\)")
- (caml-types-position-re
- (concat caml-types-filename-re " "
- caml-types-number-re " "
- caml-types-number-re " "
- caml-types-number-re)))
- (setq caml-types-location-re
- (concat "^" caml-types-position-re " " caml-types-position-re)))
-
-(defvar caml-types-expr-ovl (make-overlay 1 1))
-
-(make-face 'caml-types-face)
-(set-face-doc-string 'caml-types-face
- "face for hilighting expressions and types")
-(if (not (face-differs-from-default-p 'caml-types-face))
- (set-face-background 'caml-types-face "#88FF44"))
-
-(defvar caml-types-typed-ovl (make-overlay 1 1))
-
-(make-face 'caml-types-typed-face)
-(set-face-doc-string 'caml-types-typed-face
- "face for hilighting typed expressions")
-(if (not (face-differs-from-default-p 'caml-types-typed-face))
- (set-face-background 'caml-types-typed-face "#FF8844"))
-
-(overlay-put caml-types-expr-ovl 'face 'caml-types-face)
-(overlay-put caml-types-typed-ovl 'face 'caml-types-typed-face)
-
-
-(defvar caml-types-annotation-tree nil)
-(defvar caml-types-annotation-date nil)
-(make-variable-buffer-local 'caml-types-annotation-tree)
-(make-variable-buffer-local 'caml-types-annotation-date)
-
-(defvar caml-types-buffer-name "*caml-types*"
- "Name of buffer for diplaying caml types")
-(defvar caml-types-buffer nil
- "buffer for diplaying caml types")
-
-(defun caml-types-show-type (arg)
- "Show the type of expression or pattern at point.
- The smallest expression or pattern that contains point is
- temporarily highlighted. Its type is highlighted in the .annot
- file and the mark is set to the beginning of the type.
- The type is also displayed in the mini-buffer.
-
- Hints on using the type display:
- . If you want the type of an identifier, put point within any
- occurrence of this identifier.
- . If you want the result type of a function application, put point
- at the first space after the function name.
- . If you want the type of a list, put point on a bracket, on a
- semicolon, or on the :: constructor.
- . Even if type checking fails, you can still look at the types
- in the file, up to where the type checker failed.
-
-Types are also diplayed in the buffer *caml-types*, which buffer is
-display when the commande is called with Prefix argument 4.
-
-See also `caml-types-explore' for exploration by mouse dragging.
-See `caml-types-location-re' for annotation file format.
-"
- (interactive "p")
- (let* ((target-buf (current-buffer))
- (target-file (file-name-nondirectory (buffer-file-name)))
- (target-line (1+ (count-lines (point-min)
- (caml-line-beginning-position))))
- (target-bol (caml-line-beginning-position))
- (target-cnum (point))
- (type-file (concat (file-name-sans-extension (buffer-file-name))
- ".annot")))
- (caml-types-preprocess type-file)
- (unless caml-types-buffer
- (setq caml-types-buffer (get-buffer-create caml-types-buffer-name)))
- (let* ((targ-loc (vector target-file target-line target-bol target-cnum))
- (node (caml-types-find-location targ-loc ()
- caml-types-annotation-tree)))
- (cond
- ((null node)
- (delete-overlay caml-types-expr-ovl)
- (message "Point is not within a typechecked expression or pattern.")
- ; (with-current-buffer type-buf (narrow-to-region 1 1))
- )
- (t
- (let ((left (caml-types-get-pos target-buf (elt node 0)))
- (right (caml-types-get-pos target-buf (elt node 1)))
- (type (elt node 2)))
- (move-overlay caml-types-expr-ovl left right target-buf)
- (with-current-buffer caml-types-buffer
- (erase-buffer)
- (insert type)
- (message (format "type: %s" type)))
- ))))
- (if (and (= arg 4)
- (not (window-live-p (get-buffer-window caml-types-buffer))))
- (display-buffer caml-types-buffer))
- (unwind-protect
- (caml-sit-for 60)
- (delete-overlay caml-types-expr-ovl)
- )))
-
-(defun caml-types-preprocess (type-file)
- (let* ((type-date (nth 5 (file-attributes type-file)))
- (target-file (file-name-nondirectory (buffer-file-name)))
- (target-date (nth 5 (file-attributes target-file))))
- (unless (and caml-types-annotation-tree
- type-date
- caml-types-annotation-date
- (not (caml-types-date< caml-types-annotation-date type-date)))
- (if (and type-date target-date (caml-types-date< type-date target-date))
- (error (format "%s is more recent than %s" target-file type-file)))
- (message "Reading annotation file...")
- (let* ((type-buf (caml-types-find-file type-file))
- (tree (with-current-buffer type-buf
- (widen)
- (goto-char (point-min))
- (caml-types-build-tree target-file))))
- (setq caml-types-annotation-tree tree
- caml-types-annotation-date type-date)
- (kill-buffer type-buf)
- (message ""))
- )))
-
-(defun caml-types-date< (date1 date2)
- (or (< (car date1) (car date2))
- (and (= (car date1) (car date2))
- (< (nth 1 date1) (nth 1 date2)))))
-
-
-; we use an obarray for hash-consing the strings within each tree
-
-(defun caml-types-make-hash-table ()
- (make-vector 255 0))
-
-(defun caml-types-hcons (elem table)
- (symbol-name (intern elem table)))
-
-
-; tree of intervals
-; each node is a vector
-; [ pos-left pos-right type-info child child child... ]
-; type-info =
-; () if this node does not correspond to an annotated interval
-; (type-start . type-end) address of the annotation in the .annot file
-
-(defun caml-types-build-tree (target-file)
- (let ((stack ())
- (accu ())
- (table (caml-types-make-hash-table))
- (type-info ()))
- (while (re-search-forward caml-types-location-re () t)
- (let ((l-file (file-name-nondirectory (match-string 1)))
- (l-line (string-to-int (match-string 3)))
- (l-bol (string-to-int (match-string 4)))
- (l-cnum (string-to-int (match-string 5)))
- (r-file (file-name-nondirectory (match-string 6)))
- (r-line (string-to-int (match-string 8)))
- (r-bol (string-to-int (match-string 9)))
- (r-cnum (string-to-int (match-string 10))))
- (unless (caml-types-not-in-file l-file r-file target-file)
- (while (and (re-search-forward "^" () t)
- (not (looking-at "type"))
- (not (looking-at "\\\"")))
- (forward-char 1))
- (setq type-info
- (if (looking-at
- "^type(\n\\( \\([^\n)]\\|.)\\|\n[^)]\\)*\\)\n)")
- (caml-types-hcons (match-string 1) table)))
- (setq accu ())
- (while (and stack
- (caml-types-pos-contains l-cnum r-cnum (car stack)))
- (setq accu (cons (car stack) accu))
- (setq stack (cdr stack)))
- (let* ((left-pos (vector l-file l-line l-bol l-cnum))
- (right-pos (vector r-file r-line r-bol r-cnum))
- (node (caml-types-make-node left-pos right-pos type-info
- accu)))
- (setq stack (cons node stack))))))
- (if (null stack)
- (error "no annotations found for this source file")
- (let* ((left-pos (elt (car (last stack)) 0))
- (right-pos (elt (car stack) 1)))
- (if (null (cdr stack))
- (car stack)
- (caml-types-make-node left-pos right-pos () (nreverse stack)))))))
-
-(defun caml-types-not-in-file (l-file r-file target-file)
- (or (and (not (string= l-file target-file))
- (not (string= l-file "")))
- (and (not (string= r-file target-file))
- (not (string= r-file "")))))
-
-(defun caml-types-make-node (left-pos right-pos type-info children)
- (let ((result (make-vector (+ 3 (length children)) ()))
- (i 3))
- (aset result 0 left-pos)
- (aset result 1 right-pos)
- (aset result 2 type-info)
- (while children
- (aset result i (car children))
- (setq children (cdr children))
- (setq i (1+ i)))
- result))
-
-(defun caml-types-pos-contains (l-cnum r-cnum node)
- (and (<= l-cnum (elt (elt node 0) 3))
- (>= r-cnum (elt (elt node 1) 3))))
-
-(defun caml-types-find-location (targ-pos curr node)
- (if (not (caml-types-pos-inside targ-pos node))
- curr
- (if (elt node 2)
- (setq curr node))
- (let ((i (caml-types-search node targ-pos)))
- (if (and (> i 3)
- (caml-types-pos-inside targ-pos (elt node (1- i))))
- (caml-types-find-location targ-pos curr (elt node (1- i)))
- curr))))
-
-; trouve le premier fils qui commence apres la position
-; ou (length node) si tous commencent avant
-(defun caml-types-search (node pos)
- (let ((min 3)
- (max (length node))
- med)
- (while (< min max)
- (setq med (/ (+ min max) 2))
- (if (caml-types-pos<= (elt (elt node med) 0) pos)
- (setq min (1+ med))
- (setq max med)))
- min))
-
-(defun caml-types-pos-inside (pos node)
- (let ((left-pos (elt node 0))
- (right-pos (elt node 1)))
- (and (caml-types-pos<= left-pos pos)
- (caml-types-pos> right-pos pos))))
-
-(defun caml-types-find-interval (buf targ-pos node)
- (let ((nleft (elt node 0))
- (nright (elt node 1))
- (left ())
- (right ())
- i)
- (cond
- ((not (caml-types-pos-inside targ-pos node))
- (if (not (caml-types-pos<= nleft targ-pos))
- (setq right nleft))
- (if (not (caml-types-pos> nright targ-pos))
- (setq left nright)))
- (t
- (setq left nleft
- right nright)
- (setq i (caml-types-search node targ-pos))
- (if (< i (length node))
- (setq right (elt (elt node i) 0)))
- (if (> i 3)
- (setq left (elt (elt node (1- i)) 1)))))
- (cons (if left
- (caml-types-get-pos buf left)
- (with-current-buffer buf (point-min)))
- (if right
- (caml-types-get-pos buf right)
- (with-current-buffer buf (point-max))))))
-
-
-;; Warning: these comparison functions are not symmetric.
-;; The first argument determines the format:
-;; when its file component is empty, only the cnum is compared.
-
-(defun caml-types-pos<= (pos1 pos2)
- (let ((file1 (elt pos1 0))
- (line1 (elt pos1 1))
- (bol1 (elt pos1 2))
- (cnum1 (elt pos1 3))
- (file2 (elt pos2 0))
- (line2 (elt pos2 1))
- (bol2 (elt pos2 2))
- (cnum2 (elt pos2 3)))
- (if (string= file1 "")
- (<= cnum1 cnum2)
- (and (string= file1 file2)
- (or (< line1 line2)
- (and (= line1 line2)
- (<= (- cnum1 bol1) (- cnum2 bol2))))))))
-
-(defun caml-types-pos> (pos1 pos2)
- (let ((file1 (elt pos1 0))
- (line1 (elt pos1 1))
- (bol1 (elt pos1 2))
- (cnum1 (elt pos1 3))
- (file2 (elt pos2 0))
- (line2 (elt pos2 1))
- (bol2 (elt pos2 2))
- (cnum2 (elt pos2 3)))
- (if (string= file1 "")
- (> cnum1 cnum2)
- (and (string= file1 file2)
- (or (> line1 line2)
- (and (= line1 line2)
- (> (- cnum1 bol1) (- cnum2 bol2))))))))
-
-(defun caml-types-get-pos (buf pos)
- (save-excursion
- (set-buffer buf)
- (goto-line (elt pos 1))
- (forward-char (- (elt pos 3) (elt pos 2)))
- (point)))
-
-; find-file-read-only-noselect seems to be missing from emacs...
-(defun caml-types-find-file (name)
- (let (buf)
- (cond
- ((setq buf (get-file-buffer name))
- (unless (verify-visited-file-modtime buf)
- (if (buffer-modified-p buf)
- (find-file-noselect name)
- (with-current-buffer buf (revert-buffer t t)))
- ))
- ((and (file-readable-p name)
- (setq buf (find-file-noselect name)))
- (with-current-buffer buf (toggle-read-only 1))
- )
- (t
- (error "No annotation file. You should compile with option \"-dtypes\"."))
- )
- buf))
-
-(defun caml-types-mouse-ignore (event)
- (interactive "e")
- nil)
-
-(defun caml-types-time ()
- (let ((time (current-time)))
- (+ (* (mod (cadr time) 1000) 1000)
- (/ (cadr (cdr time)) 1000))))
-
-(defun caml-types-explore (event)
- "Explore type annotations by mouse dragging.
-
-The expression under the mouse is highlighted and its type is displayed
-in the minibuffer, until the move is released, much as `caml-types-show-type'.
-The function uses two overlays.
-
- . One overlay delimits the largest region whose all subnodes
- are well-typed.
- . Another overlay delimits the current node under the mouse (whose type
- annotation is beeing displayed).
-"
- (interactive "e")
- (set-buffer (window-buffer (caml-event-window event)))
- (let* ((target-buf (current-buffer))
- (target-file (file-name-nondirectory (buffer-file-name)))
- (type-file (concat (file-name-sans-extension (buffer-file-name))
- ".annot"))
- (target-line) (target-bol)
- target-pos
- Left Right limits cnum node mes type
- region
- (window (caml-event-window event))
- target-tree
- (speed 100)
- (last-time (caml-types-time))
- (original-event event)
- )
- (select-window window)
- (unwind-protect
- (progn
- (caml-types-preprocess type-file)
- (setq target-tree caml-types-annotation-tree)
- (unless caml-types-buffer
- (setq caml-types-buffer
- (get-buffer-create caml-types-buffer-name)))
- ;; (message "Drag the mouse to explore types")
- (unwind-protect
- (caml-track-mouse
- (while event
- (cond
- ;; we ignore non mouse events
- ((caml-ignore-event-p event))
- ;; we stop when the original button is released
- ((caml-release-event-p original-event event)
- (setq event nil))
- ;; we scroll when the motion is outside the window
- ((and (caml-mouse-movement-p event)
- (not (and (equal window (caml-event-window event))
- (integer-or-marker-p
- (caml-event-point-end event)))))
- (let* ((win (caml-window-edges window))
- (top (nth 1 win))
- (bottom (- (nth 3 win) 1))
- mouse
- time
- )
- (while (and
- (caml-sit-for 0 (/ 500 speed))
- (setq time (caml-types-time))
- (> (- time last-time) (/ 500 speed))
- (setq mouse (caml-mouse-vertical-position))
- (or (< mouse top) (>= mouse bottom))
- )
- (setq last-time time)
- (cond
- ((< mouse top)
- (setq speed (- top mouse))
- (condition-case nil
- (scroll-down 1)
- (error (message "Beginning of buffer!"))))
- ((>= mouse bottom)
- (setq speed (+ 1 (- mouse bottom)))
- (condition-case nil
- (scroll-up 1)
- (error (message "End of buffer!"))))
- )
- (setq speed (* speed speed))
- )))
- ;; main action, when the motion is inside the window
- ;; or on orginal button down event
- ((or (caml-mouse-movement-p event)
- (equal original-event event))
- (setq cnum (caml-event-point-end event))
- (if (and region
- (<= (car region) cnum) (< cnum (cdr region)))
- ;; mouse remains in outer region
- nil
- ;; otherwise, reset the outer region
- (setq region
- (caml-types-typed-make-overlay
- target-buf (caml-event-point-start event))))
- (if
- (and limits
- (>= cnum (car limits)) (< cnum (cdr limits)))
- ;; inner region is unchanged
- nil
- ;; recompute the inner region and type annotation
- (setq target-bol
- (save-excursion
- (goto-char cnum) (caml-line-beginning-position))
- target-line (1+ (count-lines (point-min)
- target-bol))
- target-pos
- (vector target-file target-line target-bol cnum))
- (save-excursion
- (setq node (caml-types-find-location
- target-pos () target-tree))
- (set-buffer caml-types-buffer)
- (erase-buffer)
- (cond
- (node
- (setq Left
- (caml-types-get-pos target-buf (elt node 0))
- Right
- (caml-types-get-pos target-buf (elt node 1)))
- (move-overlay
- caml-types-expr-ovl Left Right target-buf)
- (setq limits
- (caml-types-find-interval target-buf
- target-pos node)
- type (elt node 2))
- )
- (t
- (delete-overlay caml-types-expr-ovl)
- (setq type "*no type information*")
- (setq limits
- (caml-types-find-interval
- target-buf target-pos target-tree))
- ))
- (setq mes (format "type: %s" type))
- (insert type)
- ))
- (message mes)
- )
- )
- ;; we read next event, unless it is nil, and loop back.
- (if event (setq event (caml-read-event)))
- )
- )
- ;; delete overlays at end of exploration
- (delete-overlay caml-types-expr-ovl)
- (delete-overlay caml-types-typed-ovl)
- ))
- ;; When an error occurs, the mouse release event has not been read.
- ;; We could wait for mouse release to prevent execution of
- ;; a binding of mouse release, such as cut or paste.
- ;; In most common cases, next event will be the mouse release.
- ;; However, it could also be a key stroke before mouse release.
- ;; Emacs does not allow to test whether mouse is up or down.
- ;; Not sure it is robust to loop for mouse release after an error
- ;; occured, as is done for exploration.
- ;; So far, we just ignore next event. (Next line also be uncommenting.)
- (if event (caml-read-event))
- )))
-
-(defun caml-types-typed-make-overlay (target-buf pos)
- (interactive "p")
- (let ((start pos) (end pos) len node left right)
- (setq len (length caml-types-annotation-tree))
- (while (> len 3)
- (setq len (- len 1))
- (setq node (aref caml-types-annotation-tree len))
- (if (and (equal target-buf (current-buffer))
- (setq left (caml-types-get-pos target-buf (elt node 0))
- right (caml-types-get-pos target-buf (elt node 1)))
- (<= left pos) (> right pos)
- )
- (setq start (min start left)
- end (max end right))
- ))
- (move-overlay caml-types-typed-ovl
- (max (point-min) (- start 1))
- (min (point-max) (+ end 1)) target-buf)
- (cons start end)))
-
-(provide 'caml-types)
diff --git a/emacs/caml-xemacs.el b/emacs/caml-xemacs.el
deleted file mode 100644
index ff49391576..0000000000
--- a/emacs/caml-xemacs.el
+++ /dev/null
@@ -1,39 +0,0 @@
-(require 'overlay)
-
-;; for caml-help.el
-(defun caml-info-other-window (arg)
- (save-excursion (info arg))
- (view-buffer-other-window "*info*"))
-
-;; for caml-types.el
-(defun caml-line-beginning-position ()
- (save-excursion (beginning-of-line) (point)))
-
-(defalias 'caml-read-event 'next-event)
-(defalias 'caml-window-edges 'window-pixel-edges)
-(defun caml-mouse-vertical-position ()
- (let ((e (mouse-position-as-motion-event)))
- (and e (event-y-pixel e))))
-(defalias 'caml-mouse-movement-p 'motion-event-p)
-(defun caml-event-window (e)
- (and (mouse-event-p e) (event-window e)))
-(defun caml-event-point-start (e) (event-closest-point e))
-(defun caml-event-point-end (e) (event-closest-point e))
-(defun caml-ignore-event-p (e)
- (if (and (key-press-event-p e) (equal (key-binding e) 'keyboard-quit))
- (keyboard-quit))
- (not (mouse-event-p e)))
-
-
-(defun caml-sit-for (sec &optional mili)
- (sit-for (+ sec (if mili (* 0.001 mili)))))
-
-
-
-(defmacro caml-track-mouse (&rest body) (cons 'progn body))
-
-(defun caml-release-event-p (original event)
- (and (button-release-event-p event)
- (equal (event-button original) (event-button event))))
-
-(provide 'caml-xemacs)
diff --git a/emacs/caml.el b/emacs/caml.el
deleted file mode 100644
index 8e6da6a251..0000000000
--- a/emacs/caml.el
+++ /dev/null
@@ -1,1894 +0,0 @@
-;;; caml.el --- O'Caml code editing commands for Emacs
-
-;; Xavier Leroy, july 1993.
-
-;;indentation code is Copyright (C) 1996 by Ian T Zimmerman <itz@rahul.net>
-;;copying: covered by the current FSF General Public License.
-
-;; indentation code adapted for Objective Caml by Jacques Garrigue,
-;; july 1997. <garrigue@kurims.kyoto-u.ac.jp>
-
-;;user customizable variables
-(defvar caml-quote-char "'"
- "*Quote for character constants. \"'\" for Objective Caml, \"`\" for Caml-Light.")
-
-(defvar caml-imenu-enable nil
- "*Enable Imenu support.")
-
-(defvar caml-mode-indentation 2
- "*Used for \\[caml-unindent-command].")
-
-(defvar caml-lookback-limit 5000
- "*How far to look back for syntax things in caml mode.")
-
-(defvar caml-max-indent-priority 8
- "*Bounds priority of operators permitted to affect caml indentation.
-
-Priorities are assigned to `interesting' caml operators as follows:
-
- all keywords 0 to 7 8
- type, val, ... + 0 7
- :: ^ 6
- @ 5
- := <- 4
- if 3
- fun, let, match ... 2
- module 1
- opening keywords 0.")
-
-(defvar caml-apply-extra-indent 2
- "*How many spaces to add to indentation for an application in caml mode.")
-(make-variable-buffer-local 'caml-apply-extra-indent)
-
-(defvar caml-begin-indent 2
- "*How many spaces to indent from a begin keyword in caml mode.")
-(make-variable-buffer-local 'caml-begin-indent)
-
-(defvar caml-class-indent 2
- "*How many spaces to indent from a class keyword in caml mode.")
-(make-variable-buffer-local 'caml-class-indent)
-
-(defvar caml-exception-indent 2
- "*How many spaces to indent from a exception keyword in caml mode.")
-(make-variable-buffer-local 'caml-exception-indent)
-
-(defvar caml-for-indent 2
- "*How many spaces to indent from a for keyword in caml mode.")
-(make-variable-buffer-local 'caml-for-indent)
-
-(defvar caml-fun-indent 2
- "*How many spaces to indent from a fun keyword in caml mode.")
-(make-variable-buffer-local 'caml-fun-indent)
-
-(defvar caml-function-indent 4
- "*How many spaces to indent from a function keyword in caml mode.")
-(make-variable-buffer-local 'caml-function-indent)
-
-(defvar caml-if-indent 2
- "*How many spaces to indent from a if keyword in caml mode.")
-(make-variable-buffer-local 'caml-if-indent)
-
-(defvar caml-if-else-indent 0
- "*How many spaces to indent from an if .. else line in caml mode.")
-(make-variable-buffer-local 'caml-if-else-indent)
-
-(defvar caml-inherit-indent 2
- "*How many spaces to indent from a inherit keyword in caml mode.")
-(make-variable-buffer-local 'caml-inherit-indent)
-
-(defvar caml-initializer-indent 2
- "*How many spaces to indent from a initializer keyword in caml mode.")
-(make-variable-buffer-local 'caml-initializer-indent)
-
-(defvar caml-include-indent 2
- "*How many spaces to indent from a include keyword in caml mode.")
-(make-variable-buffer-local 'caml-include-indent)
-
-(defvar caml-let-indent 2
- "*How many spaces to indent from a let keyword in caml mode.")
-(make-variable-buffer-local 'caml-let-indent)
-
-(defvar caml-let-in-indent 0
- "*How many spaces to indent from a let .. in keyword in caml mode.")
-(make-variable-buffer-local 'caml-let-in-indent)
-
-(defvar caml-match-indent 2
- "*How many spaces to indent from a match keyword in caml mode.")
-(make-variable-buffer-local 'caml-match-indent)
-
-(defvar caml-method-indent 2
- "*How many spaces to indent from a method keyword in caml mode.")
-(make-variable-buffer-local 'caml-method-indent)
-
-(defvar caml-module-indent 2
- "*How many spaces to indent from a module keyword in caml mode.")
-(make-variable-buffer-local 'caml-module-indent)
-
-(defvar caml-object-indent 2
- "*How many spaces to indent from a object keyword in caml mode.")
-(make-variable-buffer-local 'caml-object-indent)
-
-(defvar caml-of-indent 2
- "*How many spaces to indent from a of keyword in caml mode.")
-(make-variable-buffer-local 'caml-of-indent)
-
-(defvar caml-parser-indent 4
- "*How many spaces to indent from a parser keyword in caml mode.")
-(make-variable-buffer-local 'caml-parser-indent)
-
-(defvar caml-sig-indent 2
- "*How many spaces to indent from a sig keyword in caml mode.")
-(make-variable-buffer-local 'caml-sig-indent)
-
-(defvar caml-struct-indent 2
- "*How many spaces to indent from a struct keyword in caml mode.")
-(make-variable-buffer-local 'caml-struct-indent)
-
-(defvar caml-try-indent 2
- "*How many spaces to indent from a try keyword in caml mode.")
-(make-variable-buffer-local 'caml-try-indent)
-
-(defvar caml-type-indent 4
- "*How many spaces to indent from a type keyword in caml mode.")
-(make-variable-buffer-local 'caml-type-indent)
-
-(defvar caml-val-indent 2
- "*How many spaces to indent from a val keyword in caml mode.")
-(make-variable-buffer-local 'caml-val-indent)
-
-(defvar caml-while-indent 2
- "*How many spaces to indent from a while keyword in caml mode.")
-(make-variable-buffer-local 'caml-while-indent)
-
-(defvar caml-::-indent 2
- "*How many spaces to indent from a :: operator in caml mode.")
-(make-variable-buffer-local 'caml-::-indent)
-
-(defvar caml-@-indent 2
- "*How many spaces to indent from a @ operator in caml mode.")
-(make-variable-buffer-local 'caml-@-indent)
-
-(defvar caml-:=-indent 2
- "*How many spaces to indent from a := operator in caml mode.")
-(make-variable-buffer-local 'caml-:=-indent)
-
-(defvar caml-<--indent 2
- "*How many spaces to indent from a <- operator in caml mode.")
-(make-variable-buffer-local 'caml-<--indent)
-
-(defvar caml-->-indent 2
- "*How many spaces to indent from a -> operator in caml mode.")
-(make-variable-buffer-local 'caml-->-indent)
-
-(defvar caml-lb-indent 2
- "*How many spaces to indent from a \[ operator in caml mode.")
-(make-variable-buffer-local 'caml-lb-indent)
-
-(defvar caml-lc-indent 2
- "*How many spaces to indent from a \{ operator in caml mode.")
-(make-variable-buffer-local 'caml-lc-indent)
-
-(defvar caml-lp-indent 1
- "*How many spaces to indent from a \( operator in caml mode.")
-(make-variable-buffer-local 'caml-lp-indent)
-
-(defvar caml-and-extra-indent nil
- "*Extra indent for caml lines starting with the and keyword.
-Usually negative. nil is align on master.")
-(make-variable-buffer-local 'caml-and-extra-indent)
-
-(defvar caml-do-extra-indent nil
- "*Extra indent for caml lines starting with the do keyword.
-Usually negative. nil is align on master.")
-(make-variable-buffer-local 'caml-do-extra-indent)
-
-(defvar caml-done-extra-indent nil
- "*Extra indent for caml lines starting with the done keyword.
-Usually negative. nil is align on master.")
-(make-variable-buffer-local 'caml-done-extra-indent)
-
-(defvar caml-else-extra-indent nil
- "*Extra indent for caml lines starting with the else keyword.
-Usually negative. nil is align on master.")
-(make-variable-buffer-local 'caml-else-extra-indent)
-
-(defvar caml-end-extra-indent nil
- "*Extra indent for caml lines starting with the end keyword.
-Usually negative. nil is align on master.")
-(make-variable-buffer-local 'caml-end-extra-indent)
-
-(defvar caml-in-extra-indent nil
- "*Extra indent for caml lines starting with the in keyword.
-Usually negative. nil is align on master.")
-(make-variable-buffer-local 'caml-in-extra-indent)
-
-(defvar caml-then-extra-indent nil
- "*Extra indent for caml lines starting with the then keyword.
-Usually negative. nil is align on master.")
-(make-variable-buffer-local 'caml-then-extra-indent)
-
-(defvar caml-to-extra-indent -1
- "*Extra indent for caml lines starting with the to keyword.
-Usually negative. nil is align on master.")
-(make-variable-buffer-local 'caml-to-extra-indent)
-
-(defvar caml-with-extra-indent nil
- "*Extra indent for caml lines starting with the with keyword.
-Usually negative. nil is align on master.")
-(make-variable-buffer-local 'caml-with-extra-indent)
-
-(defvar caml-comment-indent 3
- "*Indent inside comments.")
-(make-variable-buffer-local 'caml-comment-indent)
-
-(defvar caml-|-extra-indent -2
- "*Extra indent for caml lines starting with the | operator.
-Usually negative. nil is align on master.")
-(make-variable-buffer-local 'caml-|-extra-indent)
-
-(defvar caml-rb-extra-indent -2
- "*Extra indent for caml lines statring with ].
-Usually negative. nil is align on master.")
-
-(defvar caml-rc-extra-indent -2
- "*Extra indent for caml lines starting with }.
-Usually negative. nil is align on master.")
-
-(defvar caml-rp-extra-indent -1
- "*Extra indent for caml lines starting with ).
-Usually negative. nil is align on master.")
-
-(defvar caml-electric-indent t
- "*Non-nil means electrically indent lines starting with |, ] or }.
-
-Many people find eletric keys irritating, so you can disable them if
-you are one.")
-
-(defvar caml-electric-close-vector t
- "*Non-nil means electrically insert a | before a vector-closing ].
-
-Many people find eletric keys irritating, so you can disable them if
-you are one. You should probably have this on, though, if you also
-have caml-electric-indent on, which see.")
-
-;;code
-(if (or (not (fboundp 'indent-line-to))
- (not (fboundp 'buffer-substring-no-properties)))
- (require 'caml-compat))
-
-(defvar caml-shell-active nil
- "Non nil when a subshell is running.")
-
-(defvar running-xemacs (string-match "XEmacs" emacs-version)
- "Non-nil if we are running in the XEmacs environment.")
-
-(defvar caml-mode-map nil
- "Keymap used in Caml mode.")
-(if caml-mode-map
- ()
- (setq caml-mode-map (make-sparse-keymap))
- (define-key caml-mode-map "|" 'caml-electric-pipe)
- (define-key caml-mode-map "}" 'caml-electric-pipe)
- (define-key caml-mode-map "]" 'caml-electric-rb)
- (define-key caml-mode-map "\t" 'caml-indent-command)
- (define-key caml-mode-map [backtab] 'caml-unindent-command)
-
-;itz 04-21-96 instead of defining a new function, use defadvice
-;that way we get out effect even when we do \C-x` in compilation buffer
-; (define-key caml-mode-map "\C-x`" 'caml-next-error)
-
- (if running-xemacs
- (define-key caml-mode-map 'backspace 'backward-delete-char-untabify)
- (define-key caml-mode-map "\177" 'backward-delete-char-untabify))
-
- ;; caml-types
- (define-key caml-mode-map [?\C-c?\C-t] 'caml-types-show-type)
- ;; must be a mouse-down event. Can be any button and any prefix
- (define-key caml-mode-map [?\C-c down-mouse-1] 'caml-types-explore)
- ;; caml-help
- (define-key caml-mode-map [?\C-c?i] 'ocaml-add-path)
- (define-key caml-mode-map [?\C-c?]] 'ocaml-close-module)
- (define-key caml-mode-map [?\C-c?[] 'ocaml-open-module)
- (define-key caml-mode-map [?\C-c?\C-h] 'caml-help)
- (define-key caml-mode-map [?\C-c?\t] 'caml-complete)
- ;; others
- (define-key caml-mode-map "\C-cb" 'caml-insert-begin-form)
- (define-key caml-mode-map "\C-cf" 'caml-insert-for-form)
- (define-key caml-mode-map "\C-ci" 'caml-insert-if-form)
- (define-key caml-mode-map "\C-cl" 'caml-insert-let-form)
- (define-key caml-mode-map "\C-cm" 'caml-insert-match-form)
- (define-key caml-mode-map "\C-ct" 'caml-insert-try-form)
- (define-key caml-mode-map "\C-cw" 'caml-insert-while-form)
- (define-key caml-mode-map "\C-c`" 'caml-goto-phrase-error)
- (define-key caml-mode-map "\C-c\C-a" 'caml-find-alternate-file)
- (define-key caml-mode-map "\C-c\C-c" 'compile)
- (define-key caml-mode-map "\C-c\C-e" 'caml-eval-phrase)
- (define-key caml-mode-map "\C-c\C-\[" 'caml-backward-to-less-indent)
- (define-key caml-mode-map "\C-c\C-\]" 'caml-forward-to-less-indent)
- (define-key caml-mode-map "\C-c\C-q" 'caml-indent-phrase)
- (define-key caml-mode-map "\C-c\C-r" 'caml-eval-region)
- (define-key caml-mode-map "\C-c\C-s" 'caml-show-subshell)
- (define-key caml-mode-map "\M-\C-h" 'caml-mark-phrase)
- (define-key caml-mode-map "\M-\C-q" 'caml-indent-phrase)
- (define-key caml-mode-map "\M-\C-x" 'caml-eval-phrase)
-
- (if running-xemacs nil ; if not running xemacs
- (let ((map (make-sparse-keymap "Caml"))
- (forms (make-sparse-keymap "Forms")))
- (define-key caml-mode-map "\C-c\C-d" 'caml-show-imenu)
- (define-key caml-mode-map [menu-bar] (make-sparse-keymap))
- (define-key caml-mode-map [menu-bar caml] (cons "Caml" map))
- ;; caml-help
-
- (define-key map [open] '("Open add path" . ocaml-add-path ))
- (define-key map [close]
- '("Close module for help" . ocaml-close-module))
- (define-key map [open] '("Open module for help" . ocaml-open-module))
- (define-key map [help] '("Help for identifier" . caml-help))
- (define-key map [complete] '("Complete identifier" . caml-complete))
- (define-key map [separator-help] '("---"))
-
- ;; caml-types
- (define-key map [show-type]
- '("Show type at point" . caml-types-show-type ))
- (define-key map [separator-types] '("---"))
-
- ;; others
- (define-key map [run-caml] '("Start subshell..." . run-caml))
- (define-key map [compile] '("Compile..." . compile))
- (define-key map [switch-view]
- '("Switch view" . caml-find-alternate-file))
- (define-key map [separator-format] '("--"))
- (define-key map [forms] (cons "Forms" forms))
- (define-key map [show-imenu] '("Show index" . caml-show-imenu))
- (put 'caml-show-imenu 'menu-enable '(not caml-imenu-shown))
- (define-key map [show-subshell] '("Show subshell" . caml-show-subshell))
- (put 'caml-show-subshell 'menu-enable 'caml-shell-active)
- (define-key map [eval-phrase] '("Eval phrase" . caml-eval-phrase))
- (put 'caml-eval-phrase 'menu-enable 'caml-shell-active)
- (define-key map [indent-phrase] '("Indent phrase" . caml-indent-phrase))
- (define-key forms [while]
- '("while .. do .. done" . caml-insert-while-form))
- (define-key forms [try] '("try .. with .." . caml-insert-try-form))
- (define-key forms [match] '("match .. with .." . caml-insert-match-form))
- (define-key forms [let] '("let .. in .." . caml-insert-let-form))
- (define-key forms [if] '("if .. then .. else .." . caml-insert-if-form))
- (define-key forms [begin] '("for .. do .. done" . caml-insert-for-form))
- (define-key forms [begin] '("begin .. end" . caml-insert-begin-form)))))
-
-(defvar caml-mode-xemacs-menu
- (if running-xemacs
- '("Caml"
- [ "Indent phrase" caml-indent-phrase :keys "C-M-q" ]
- [ "Eval phrase" caml-eval-phrase
- :active caml-shell-active :keys "C-M-x" ]
- [ "Show subshell" caml-show-subshell caml-shell-active ]
- ("Forms"
- [ "while .. do .. done" caml-insert-while-form t]
- [ "try .. with .." caml-insert-try-form t ]
- [ "match .. with .." caml-insert-match-form t ]
- [ "let .. in .." caml-insert-let-form t ]
- [ "if .. then .. else .." caml-insert-if-form t ]
- [ "for .. do .. done" caml-insert-for-form t ]
- [ "begin .. end" caml-insert-begin-form t ])
- "---"
- [ "Switch view" caml-find-alternate-file t ]
- [ "Compile..." compile t ]
- [ "Start subshell..." run-caml t ]
- "---"
- [ "Show type at point" caml-types-show-type t ]
- "---"
- [ "Complete identifier" caml-complete t ]
- [ "Help for identifier" caml-help t ]
- [ "Add path for documentation" ocaml-add-path t ]
- [ "Open module for documentation" ocaml-open t ]
- [ "Close module for documentation" ocaml-close t ]
- ))
- "Menu to add to the menubar when running Xemacs")
-
-(defvar caml-mode-syntax-table nil
- "Syntax table in use in Caml mode buffers.")
-(if caml-mode-syntax-table
- ()
- (setq caml-mode-syntax-table (make-syntax-table))
- ; backslash is an escape sequence
- (modify-syntax-entry ?\\ "\\" caml-mode-syntax-table)
- ; ( is first character of comment start
- (modify-syntax-entry ?\( "()1" caml-mode-syntax-table)
- ; * is second character of comment start,
- ; and first character of comment end
- (modify-syntax-entry ?* ". 23" caml-mode-syntax-table)
- ; ) is last character of comment end
- (modify-syntax-entry ?\) ")(4" caml-mode-syntax-table)
- ; backquote was a string-like delimiter (for character literals)
- ; (modify-syntax-entry ?` "\"" caml-mode-syntax-table)
- ; quote and underscore are part of words
- (modify-syntax-entry ?' "w" caml-mode-syntax-table)
- (modify-syntax-entry ?_ "w" caml-mode-syntax-table)
- ; ISO-latin accented letters and EUC kanjis are part of words
- (let ((i 160))
- (while (< i 256)
- (modify-syntax-entry i "w" caml-mode-syntax-table)
- (setq i (1+ i)))))
-
-(defvar caml-mode-abbrev-table nil
- "Abbrev table used for Caml mode buffers.")
-(if caml-mode-abbrev-table nil
- (setq caml-mode-abbrev-table (make-abbrev-table))
- (define-abbrev caml-mode-abbrev-table "and" "and" 'caml-abbrev-hook)
- (define-abbrev caml-mode-abbrev-table "do" "do" 'caml-abbrev-hook)
- (define-abbrev caml-mode-abbrev-table "done" "done" 'caml-abbrev-hook)
- (define-abbrev caml-mode-abbrev-table "else" "else" 'caml-abbrev-hook)
- (define-abbrev caml-mode-abbrev-table "end" "end" 'caml-abbrev-hook)
- (define-abbrev caml-mode-abbrev-table "in" "in" 'caml-abbrev-hook)
- (define-abbrev caml-mode-abbrev-table "then" "then" 'caml-abbrev-hook)
- (define-abbrev caml-mode-abbrev-table "with" "with" 'caml-abbrev-hook))
-
-;; Other internal variables
-
-(defvar caml-last-noncomment-pos nil
- "Caches last buffer position determined not inside a caml comment.")
-(make-variable-buffer-local 'caml-last-noncomment-pos)
-
-;;last-noncomment-pos can be a simple position, because we nil it
-;;anyway whenever buffer changes upstream. last-comment-start and -end
-;;have to be markers, because we preserve them when the changes' end
-;;doesn't overlap with the comment's start.
-
-(defvar caml-last-comment-start nil
- "A marker caching last determined caml comment start.")
-(make-variable-buffer-local 'caml-last-comment-start)
-
-(defvar caml-last-comment-end nil
- "A marker caching last determined caml comment end.")
-(make-variable-buffer-local 'caml-last-comment-end)
-
-(make-variable-buffer-local 'before-change-function)
-
-(defvar caml-imenu-shown nil
- "True if we have computed definition list.")
-(make-variable-buffer-local 'caml-imenu-shown)
-
-(defconst caml-imenu-search-regexp
- (concat "\\<in\\>\\|"
- "^[ \t]*\\(let\\|class\\|type\\|m\\(odule\\|ethod\\)"
- "\\|functor\\|and\\|val\\)[ \t]+"
- "\\(\\('[a-zA-Z0-9]+\\|([^)]+)"
- "\\|mutable\\|private\\|rec\\|type\\)[ \t]+\\)?"
- "\\([a-zA-Z][a-zA-Z0-9_']*\\)"))
-
-;;; The major mode
-(eval-when-compile
- (if (and (boundp 'running-xemacs) running-xemacs) nil
- (require 'imenu)))
-
-;;
-(defvar caml-mode-hook nil
- "Hook for caml-mode")
-
-(defun caml-mode ()
- "Major mode for editing Caml code.
-
-\\{caml-mode-map}"
-
- (interactive)
- (kill-all-local-variables)
- (setq major-mode 'caml-mode)
- (setq mode-name "caml")
- (use-local-map caml-mode-map)
- (set-syntax-table caml-mode-syntax-table)
- (setq local-abbrev-table caml-mode-abbrev-table)
- (make-local-variable 'paragraph-start)
- (setq paragraph-start (concat "^$\\|" page-delimiter))
- (make-local-variable 'paragraph-separate)
- (setq paragraph-separate paragraph-start)
- (make-local-variable 'paragraph-ignore-fill-prefix)
- (setq paragraph-ignore-fill-prefix t)
- (make-local-variable 'require-final-newline)
- (setq require-final-newline t)
- (make-local-variable 'comment-start)
- (setq comment-start "(*")
- (make-local-variable 'comment-end)
- (setq comment-end "*)")
- (make-local-variable 'comment-column)
- (setq comment-column 40)
- (make-local-variable 'comment-start-skip)
- (setq comment-start-skip "(\\*+ *")
- (make-local-variable 'parse-sexp-ignore-comments)
- (setq parse-sexp-ignore-comments nil)
- (make-local-variable 'indent-line-function)
- (setq indent-line-function 'caml-indent-command)
- ;itz Fri Sep 25 13:23:49 PDT 1998
- (make-local-variable 'add-log-current-defun-function)
- (setq add-log-current-defun-function 'caml-current-defun)
- ;itz 03-25-96
- (setq before-change-function 'caml-before-change-function)
- (setq caml-last-noncomment-pos nil)
- (setq caml-last-comment-start (make-marker))
- (setq caml-last-comment-end (make-marker))
- ;garrigue 27-11-96
- (setq case-fold-search nil)
- ;garrigue july 97
- (if running-xemacs ; from Xemacs lisp mode
- (if (and (featurep 'menubar)
- current-menubar)
- (progn
- ;; make a local copy of the menubar, so our modes don't
- ;; change the global menubar
- (set-buffer-menubar current-menubar)
- (add-submenu nil caml-mode-xemacs-menu)))
- ;imenu support (not for Xemacs)
- (make-local-variable 'imenu-create-index-function)
- (setq imenu-create-index-function 'caml-create-index-function)
- (make-local-variable 'imenu-generic-expression)
- (setq imenu-generic-expression caml-imenu-search-regexp)
- (if (and caml-imenu-enable (< (buffer-size) 10000))
- (caml-show-imenu)))
- (run-hooks 'caml-mode-hook))
-
-(defun caml-set-compile-command ()
- "Hook to set compile-command locally, unless there is a Makefile in the
- current directory."
- (interactive)
- (unless (or (null buffer-file-name)
- (file-exists-p "makefile")
- (file-exists-p "Makefile"))
- (let* ((filename (file-name-nondirectory buffer-file-name))
- (basename (file-name-sans-extension filename))
- (command nil))
- (cond
- ((string-match ".*\\.mli\$" filename)
- (setq command "ocamlc -c"))
- ((string-match ".*\\.ml\$" filename)
- (setq command "ocamlc -c") ; (concat "ocamlc -o " basename)
- )
- ((string-match ".*\\.mll\$" filename)
- (setq command "ocamllex"))
- ((string-match ".*\\.mll\$" filename)
- (setq command "ocamlyacc"))
- )
- (if command
- (progn
- (make-local-variable 'compile-command)
- (setq compile-command (concat command " " filename))))
- )))
-
-(add-hook 'caml-mode-hook 'caml-set-compile-command)
-
-;;; Auxiliary function. Garrigue 96-11-01.
-
-(defun caml-find-alternate-file ()
- (interactive)
- (let ((name (buffer-file-name)))
- (if (string-match "^\\(.*\\)\\.\\(ml\\|mli\\)$" name)
- (find-file
- (concat
- (caml-match-string 1 name)
- (if (string= "ml" (caml-match-string 2 name)) ".mli" ".ml"))))))
-
-;;; subshell support
-
-(defun caml-eval-region (start end)
- "Send the current region to the inferior Caml process."
- (interactive"r")
- (require 'inf-caml)
- (inferior-caml-eval-region start end))
-
-;; old version ---to be deleted later
-;
-; (defun caml-eval-phrase ()
-; "Send the current Caml phrase to the inferior Caml process."
-; (interactive)
-; (save-excursion
-; (let ((bounds (caml-mark-phrase)))
-; (inferior-caml-eval-region (car bounds) (cdr bounds)))))
-
-(defun caml-eval-phrase (arg &optional min max)
- "Send the phrase containing the point to the CAML process.
-With prefix-arg send as many phrases as its numeric value,
-If an error occurs during evalutaion, stop at this phrase and
-repport the error.
-
-Return nil if noerror and position of error if any.
-
-If arg's numeric value is zero or negative, evaluate the current phrase
-or as many as prefix arg, ignoring evaluation errors.
-This allows to jump other erroneous phrases.
-
-Optional arguments min max defines a region within which the phrase
-should lies."
- (interactive "p")
- (require 'inf-caml)
- (inferior-caml-eval-phrase arg min max))
-
-(defun caml-eval-buffer (arg)
- "Evaluate the buffer from the beginning to the phrase under the point.
-With prefix arg, evaluate past the whole buffer, no stopping at
-the current point."
- (interactive "p")
- (let ((here (point)) err)
- (goto-char (point-min))
- (setq err
- (caml-eval-phrase 500 (point-min) (if arg (point-max) here)))
- (if err (set-mark err))
- (goto-char here)))
-
-(defun caml-show-subshell ()
- (interactive)
- (require 'inf-caml)
- (inferior-caml-show-subshell))
-
-
-;;; Imenu support
-(defun caml-show-imenu ()
- (interactive)
- (require 'imenu)
- (switch-to-buffer (current-buffer))
- (imenu-add-to-menubar "Defs")
- (setq caml-imenu-shown t))
-
-(defun caml-prev-index-position-function ()
- (let (found data)
- (while (and (setq found
- (re-search-backward caml-imenu-search-regexp nil 'move))
- (progn (setq data (match-data)) t)
- (or (caml-in-literal-p)
- (caml-in-comment-p)
- (if (looking-at "in") (caml-find-in-match)))))
- (set-match-data data)
- found))
-(defun caml-create-index-function ()
- (let (value-alist
- type-alist
- class-alist
- method-alist
- module-alist
- and-alist
- all-alist
- menu-alist
- (prev-pos (point-max))
- index)
- (goto-char prev-pos)
- (imenu-progress-message prev-pos 0 t)
- ;; collect definitions
- (while (caml-prev-index-position-function)
- (setq index (cons (caml-match-string 5) (point)))
- (imenu-progress-message prev-pos nil t)
- (setq all-alist (cons index all-alist))
- (cond
- ((looking-at "[ \t]*and")
- (setq and-alist (cons index and-alist)))
- ((looking-at "[ \t]*let")
- (setq value-alist (cons index (append and-alist value-alist)))
- (setq and-alist nil))
- ((looking-at "[ \t]*type")
- (setq type-alist (cons index (append and-alist type-alist)))
- (setq and-alist nil))
- ((looking-at "[ \t]*class")
- (setq class-alist (cons index (append and-alist class-alist)))
- (setq and-alist nil))
- ((looking-at "[ \t]*val")
- (setq value-alist (cons index value-alist)))
- ((looking-at "[ \t]*\\(module\\|functor\\)")
- (setq module-alist (cons index module-alist)))
- ((looking-at "[ \t]*method")
- (setq method-alist (cons index method-alist)))))
- ;; build menu
- (mapcar
- '(lambda (pair)
- (if (symbol-value (cdr pair))
- (setq menu-alist
- (cons
- (cons (car pair)
- (sort (symbol-value (cdr pair)) 'imenu--sort-by-name))
- menu-alist))))
- '(("Values" . value-alist)
- ("Types" . type-alist)
- ("Modules" . module-alist)
- ("Methods" . method-alist)
- ("Classes" . class-alist)))
- (if all-alist (setq menu-alist (cons (cons "Index" all-alist) menu-alist)))
- (imenu-progress-message prev-pos 100 t)
- menu-alist))
-
-;;; Indentation stuff
-
-(defun caml-in-indentation ()
- "Tests whether all characters between beginning of line and point
-are blanks."
- (save-excursion
- (skip-chars-backward " \t")
- (bolp)))
-
-;;; The command
-;;; Sorry, I didn't like the previous behaviour... Garrigue 96/11/01
-
-(defun caml-indent-command (&optional p)
- "Indent the current line in Caml mode.
-
-Compute new indentation based on caml syntax. If prefixed, indent
-the line all the way to where point is."
-
- (interactive "*p")
- (cond
- ((and p (> p 1)) (indent-line-to (current-column)))
- ((caml-in-indentation) (indent-line-to (caml-compute-final-indent)))
- (t (save-excursion
- (indent-line-to
- (caml-compute-final-indent))))))
-
-(defun caml-unindent-command ()
-
- "Decrease indentation by one level in Caml mode.
-
-Works only if the point is at the beginning of an indented line
-\(i.e. all characters between beginning of line and point are
-blanks\). Does nothing otherwise. The unindent size is given by the
-variable caml-mode-indentation."
-
- (interactive "*")
- (let* ((begline
- (save-excursion
- (beginning-of-line)
- (point)))
- (current-offset
- (- (point) begline)))
- (if (and (>= current-offset caml-mode-indentation)
- (caml-in-indentation))
- (backward-delete-char-untabify caml-mode-indentation))))
-
-;;;
-;;; Error processing
-;;;
-
-;; Error positions are given in bytes, not in characters
-;; This function switches to monobyte mode
-
-(if (not (fboundp 'char-bytes))
- (defalias 'forward-byte 'forward-char)
- (defun caml-char-bytes (ch)
- (let ((l (char-bytes ch)))
- (if (> l 1) (- l 1) l)))
- (defun forward-byte (count)
- (if (> count 0)
- (while (> count 0)
- (let ((char (char-after)))
- (if (null char)
- (setq count 0)
- (setq count (- count (caml-char-bytes (char-after))))
- (forward-char))))
- (while (< count 0)
- (let ((char (char-after)))
- (if (null char)
- (setq count 0)
- (setq count (+ count (caml-char-bytes (char-before))))
- (backward-char))))
- )))
-
-(require 'compile)
-
-;; In Emacs 19, the regexps in compilation-error-regexp-alist do not
-;; match the error messages when the language is not English.
-;; Hence we add a regexp.
-
-(defconst caml-error-regexp
- "^[A-\377]+ \"\\([^\"\n]+\\)\", [A-\377]+ \\([0-9]+\\)[-,:]"
- "Regular expression matching the error messages produced by camlc.")
-
-(if (boundp 'compilation-error-regexp-alist)
- (or (assoc caml-error-regexp
- compilation-error-regexp-alist)
- (setq compilation-error-regexp-alist
- (cons (list caml-error-regexp 1 2)
- compilation-error-regexp-alist))))
-
-;; A regexp to extract the range info
-
-(defconst caml-error-chars-regexp
- ".*, .*, [A-\377]+ \\([0-9]+\\)-\\([0-9]+\\):"
- "Regular expression extracting the character numbers
-from an error message produced by camlc.")
-
-;; Wrapper around next-error.
-
-(defvar caml-error-overlay nil)
-
-;;itz 04-21-96 somebody didn't get the documetation for next-error
-;;right. When the optional argument is a number n, it should move
-;;forward n errors, not reparse.
-
-;itz 04-21-96 instead of defining a new function, use defadvice
-;that way we get our effect even when we do \C-x` in compilation buffer
-
-(defadvice next-error (after caml-next-error activate)
- "Reads the extra positional information provided by the Caml compiler.
-
-Puts the point and the mark exactly around the erroneous program
-fragment. The erroneous fragment is also temporarily highlighted if
-possible."
-
- (if (eq major-mode 'caml-mode)
- (let (bol beg end)
- (save-excursion
- (set-buffer
- (if (boundp 'compilation-last-buffer)
- compilation-last-buffer ;Emacs 19
- "*compilation*")) ;Emacs 18
- (save-excursion
- (goto-char (window-point (get-buffer-window (current-buffer))))
- (if (looking-at caml-error-chars-regexp)
- (setq beg
- (string-to-int
- (buffer-substring (match-beginning 1) (match-end 1)))
- end
- (string-to-int
- (buffer-substring (match-beginning 2) (match-end 2)))))))
- (cond (beg
- (setq end (- end beg))
- (beginning-of-line)
- (forward-byte beg)
- (setq beg (point))
- (forward-byte end)
- (setq end (point))
- (goto-char beg)
- (push-mark end t)
- (cond ((fboundp 'make-overlay)
- (if caml-error-overlay ()
- (setq caml-error-overlay (make-overlay 1 1))
- (overlay-put caml-error-overlay 'face 'region))
- (unwind-protect
- (progn
- (move-overlay caml-error-overlay
- beg end (current-buffer))
- (sit-for 60))
- (delete-overlay caml-error-overlay)))))))))
-
-;; Usual match-string doesn't work properly with font-lock-mode
-;; on some emacs.
-
-(defun caml-match-string (num &optional string)
-
- "Return string of text matched by last search, without properties.
-
-NUM specifies which parenthesized expression in the last regexp.
-Value is nil if NUMth pair didn't match, or there were less than NUM
-pairs. Zero means the entire text matched by the whole regexp or
-whole string."
-
- (let* ((data (match-data))
- (begin (nth (* 2 num) data))
- (end (nth (1+ (* 2 num)) data)))
- (if string (substring string begin end)
- (buffer-substring-no-properties begin end))))
-
-;; itz Thu Sep 24 19:02:42 PDT 1998 this is to have some level of
-;; comfort when sending phrases to the toplevel and getting errors.
-(defun caml-goto-phrase-error ()
- "Find the error location in current Caml phrase."
- (interactive)
- (require 'inf-caml)
- (let ((bounds (save-excursion (caml-mark-phrase))))
- (inferior-caml-goto-error (car bounds) (cdr bounds))))
-
-;;; Phrases
-
-;itz the heuristics used to see if we're `between two phrases'
-;didn't seem right to me.
-
-(defconst caml-phrase-start-keywords
- (concat "\\<\\(class\\|ex\\(ternal\\|ception\\)\\|functor"
- "\\|let\\|module\\|open\\|type\\|val\\)\\>")
- "Keywords starting phrases in files")
-
-;; a phrase starts when a toplevel keyword is at the beginning of a line
-(defun caml-at-phrase-start-p ()
- (and (bolp)
- (or (looking-at "#")
- (looking-at caml-phrase-start-keywords))))
-
-(defun caml-skip-comments-forward ()
- (skip-chars-forward " \n\t")
- (while (or (looking-at comment-start-skip) (caml-in-comment-p))
- (if (= (following-char) ?\)) (forward-char)
- (search-forward comment-end))
- (skip-chars-forward " \n\t")))
-
-(defun caml-skip-comments-backward ()
- (skip-chars-backward " \n\t")
- (while (and (eq (preceding-char) ?\)) (eq (char-after (- (point) 2)) ?*))
- (backward-char)
- (while (caml-in-comment-p) (search-backward comment-start))
- (skip-chars-backward " \n\t")))
-
-(defconst caml-phrase-sep-keywords (concat ";;\\|" caml-phrase-start-keywords))
-
-(defun caml-find-phrase (&optional min-pos max-pos)
- "Find the CAML phrase containing the point.
-Return the position of the beginning of the phrase, and move point
-to the end.
-"
- (interactive)
- (if (not min-pos) (setq min-pos (point-min)))
- (if (not max-pos) (setq max-pos (point-max)))
- (let (beg end use-semi kwop)
- ;(caml-skip-comments-backward)
- (cond
- ; shall we have special processing for semicolons?
- ;((and (eq (char-before (- (point) 1)) ?\;) (eq (char-before) ?\;))
- ; (forward-char)
- ; (caml-skip-comments-forward)
- ; (setq beg (point))
- ; (while (and (search-forward ";;" max-pos 'move)
- ; (or (caml-in-comment-p) (caml-in-literal-p)))))
- (t
- (caml-skip-comments-forward)
- (if (caml-at-phrase-start-p) (forward-char))
- (while (and (cond
- ((re-search-forward caml-phrase-sep-keywords max-pos 'move)
- (goto-char (match-beginning 0)) t))
- (or (not (or (bolp) (looking-at ";;")))
- (caml-in-comment-p)
- (caml-in-literal-p)))
- (forward-char))
- (setq end (+ (point) (if (looking-at ";;") 2 0)))
- (while (and
- (setq kwop (caml-find-kwop caml-phrase-sep-keywords min-pos))
- (not (string= kwop ";;"))
- (not (bolp))))
- (if (string= kwop ";;") (forward-char 2))
- (if (not kwop) (goto-char min-pos))
- (caml-skip-comments-forward)
- (setq beg (point))
- (if (>= beg end) (error "no phrase before point"))
- (goto-char end)))
- (caml-skip-comments-forward)
- beg))
-
-(defun caml-mark-phrase (&optional min-pos max-pos)
- "Put mark at end of this Caml phrase, point at beginning.
-"
- (interactive)
- (let* ((beg (caml-find-phrase min-pos max-pos)) (end (point)))
- (push-mark)
- (goto-char beg)
- (cons beg end)))
-
-;;itz Fri Sep 25 12:58:13 PDT 1998 support for adding change-log entries
-(defun caml-current-defun ()
- (save-excursion
- (caml-mark-phrase)
- (if (not (looking-at caml-phrase-start-keywords)) nil
- (re-search-forward caml-phrase-start-keywords)
- (let ((done nil))
- (while (not done)
- (cond
- ((looking-at "\\s ")
- (skip-syntax-forward " "))
- ((char-equal (following-char) ?\( )
- (forward-sexp 1))
- ((char-equal (following-char) ?')
- (skip-syntax-forward "w_"))
- (t (setq done t)))))
- (re-search-forward "\\(\\sw\\|\\s_\\)+")
- (match-string 0))))
-
-(defun caml-overlap (b1 e1 b2 e2)
- (<= (max b1 b2) (min e1 e2)))
-
-;this clears the last comment cache if necessary
-(defun caml-before-change-function (begin end)
- (if (and caml-last-noncomment-pos
- (> caml-last-noncomment-pos begin))
- (setq caml-last-noncomment-pos nil))
- (if (and (marker-position caml-last-comment-start)
- (marker-position caml-last-comment-end)
- (caml-overlap begin end
- caml-last-comment-start
- caml-last-comment-end))
- (prog2
- (set-marker caml-last-comment-start nil)
- (set-marker caml-last-comment-end nil)))
- (let ((orig-function (default-value 'before-change-function)))
- (if orig-function (funcall orig-function begin end))))
-
-(defun caml-in-literal-p ()
- "Returns non-nil if point is inside a caml literal."
- (let* ((start-literal (concat "[\"" caml-quote-char "]"))
- (char-literal
- (concat "\\([^\\]\\|\\\\\\.\\|\\\\[0-9][0-9][0-9]\\)"
- caml-quote-char))
- (pos (point))
- (eol (progn (end-of-line 1) (point)))
- state in-str)
- (beginning-of-line 1)
- (while (and (not state)
- (re-search-forward start-literal eol t)
- (<= (point) pos))
- (cond
- ((string= (caml-match-string 0) "\"")
- (setq in-str t)
- (while (and in-str (not state)
- (re-search-forward "\"\\|\\\\\"" eol t))
- (if (> (point) pos) (setq state t))
- (if (string= (caml-match-string 0) "\"") (setq in-str nil)))
- (if in-str (setq state t)))
- ((looking-at char-literal)
- (if (and (>= pos (match-beginning 0)) (< pos (match-end 0)))
- (setq state t)
- (goto-char (match-end 0))))))
- (goto-char pos)
- state))
-
-(defun caml-forward-comment ()
- "Skip one (eventually nested) comment."
- (let ((count 1) match)
- (while (> count 0)
- (if (not (re-search-forward "(\\*\\|\\*)" nil 'move))
- (setq count -1)
- (setq match (caml-match-string 0))
- (cond
- ((caml-in-literal-p)
- nil)
- ((string= match comment-start)
- (setq count (1+ count)))
- (t
- (setq count (1- count))))))
- (= count 0)))
-
-(defun caml-backward-comment ()
- "Skip one (eventually nested) comment."
- (let ((count 1) match)
- (while (> count 0)
- (if (not (re-search-backward "(\\*\\|\\*)" nil 'move))
- (setq count -1)
- (setq match (caml-match-string 0))
- (cond
- ((caml-in-literal-p)
- nil)
- ((string= match comment-start)
- (setq count (1- count)))
- (t
- (setq count (1+ count))))))
- (= count 0)))
-
-(defun caml-in-comment-p ()
- "Returns non-nil if point is inside a caml comment.
-Returns nil for the parenthesis openning a comment."
- ;;we look for comments differently than literals. there are two
- ;;reasons for this. first, caml has nested comments and it is not so
- ;;clear that parse-partial-sexp supports them; second, if proper
- ;;style is used, literals are never split across lines, so we don't
- ;;have to worry about bogus phrase breaks inside literals, while we
- ;;have to account for that possibility in comments.
- (if caml-last-comment-start
- (save-excursion
- (let* ((cached-pos caml-last-noncomment-pos)
- (cached-begin (marker-position caml-last-comment-start))
- (cached-end (marker-position caml-last-comment-end)))
- (cond
- ((and cached-begin cached-end
- (< cached-begin (point)) (< (point) cached-end)) t)
- ((and cached-pos (= cached-pos (point))) nil)
- ((and cached-pos (> cached-pos (point))
- (< (abs (- cached-pos (point))) caml-lookback-limit))
- (let (end found (here (point)))
- ; go back to somewhere sure
- (goto-char cached-pos)
- (while (> (point) here)
- ; look for the end of a comment
- (while (and (if (search-backward comment-end (1- here) 'move)
- (setq end (match-end 0))
- (setq end nil))
- (caml-in-literal-p)))
- (if end (setq found (caml-backward-comment))))
- (if (and found (= (point) here)) (setq end nil))
- (if (not end)
- (setq caml-last-noncomment-pos here)
- (set-marker caml-last-comment-start (point))
- (set-marker caml-last-comment-end end))
- end))
- (t
- (let (begin found (here (point)))
- ;; go back to somewhere sure (or far enough)
- (goto-char
- (if cached-pos cached-pos (- (point) caml-lookback-limit)))
- (while (< (point) here)
- ;; look for the beginning of a comment
- (while (and (if (search-forward comment-start (1+ here) 'move)
- (setq begin (match-beginning 0))
- (setq begin nil))
- (caml-in-literal-p)))
- (if begin (setq found (caml-forward-comment))))
- (if (and found (= (point) here)) (setq begin nil))
- (if (not begin)
- (setq caml-last-noncomment-pos here)
- (set-marker caml-last-comment-start begin)
- (set-marker caml-last-comment-end (point)))
- begin)))))))
-
-;; Various constants and regexps
-
-(defconst caml-before-expr-prefix
- (concat "\\<\\(asr\\|begin\\|class\\|do\\(wnto\\)?\\|else"
- "\\|i\\(f\\|n\\(herit\\|itializer\\)?\\)"
- "\\|f\\(or\\|un\\(ct\\(ion\\|or\\)\\)?\\)"
- "\\|l\\(and\\|or\\|s[lr]\\|xor\\)\\|m\\(atch\\|od\\)"
- "\\|o[fr]\\|parser\\|s\\(ig\\|truct\\)\\|t\\(hen\\|o\\|ry\\)"
- "\\|w\\(h\\(en\\|ile\\)\\|ith\\)\\)\\>\\|:begin\\>"
- "\\|[=<>@^|&+-*/$%][!$%*+-./:<=>?@^|~]*\\|:[:=]\\|[[({,;]")
-
- "Keywords that may appear immediately before an expression.
-Used to distinguish it from toplevel let construct.")
-
-(defconst caml-matching-kw-regexp
- (concat
- "\\<\\(and\\|do\\(ne\\)?\\|e\\(lse\\|nd\\)\\|in\\|t\\(hen\\|o\\)"
- "\\|with\\)\\>\\|[^[|]|")
- "Regexp used in caml mode for skipping back over nested blocks.")
-
-(defconst caml-matching-kw-alist
- '(("|" . caml-find-pipe-match)
- (";" . caml-find-semi-match)
- ("," . caml-find-comma-match)
- ("end" . caml-find-end-match)
- ("done" . caml-find-done-match)
- ("in" . caml-find-in-match)
- ("with" . caml-find-with-match)
- ("else" . caml-find-else-match)
- ("then" . caml-find-then-match)
- ("to" . caml-find-done-match)
- ("do" . caml-find-done-match)
- ("and" . caml-find-and-match))
-
- "Association list used in caml mode for skipping back over nested blocks.")
-
-(defconst caml-kwop-regexps (make-vector 9 nil)
- "Array of regexps representing caml keywords of different priorities.")
-
-(defun caml-in-expr-p ()
- (let ((pos (point)) (in-expr t))
- (caml-find-kwop
- (concat caml-before-expr-prefix "\\|"
- caml-matching-kw-regexp "\\|"
- (aref caml-kwop-regexps caml-max-indent-priority)))
- (cond
- ; special case for ;;
- ((and (> (point) 1) (= (preceding-char) ?\;) (= (following-char) ?\;))
- (setq in-expr nil))
- ((looking-at caml-before-expr-prefix)
- (if (not (looking-at "(\\*")) (goto-char (match-end 0)))
- (skip-chars-forward " \t\n")
- (while (looking-at "(\\*")
- (forward-char)
- (caml-forward-comment)
- (skip-chars-forward " \t\n"))
- (if (<= pos (point)) (setq in-expr nil))))
- (goto-char pos)
- in-expr))
-
-(defun caml-at-sexp-close-p ()
- (or (char-equal ?\) (following-char))
- (char-equal ?\] (following-char))
- (char-equal ?} (following-char))))
-
-(defun caml-find-kwop (kwop-regexp &optional min-pos)
- "Look back for a caml keyword or operator matching KWOP-REGEXP.
-Second optional argument MIN-POS bounds the search.
-
-Ignore occurences inside literals. If found, return a list of two
-values: the actual text of the keyword or operator, and a boolean
-indicating whether the keyword was one we looked for explicitly
-{non-nil}, or on the other hand one of the block-terminating
-keywords."
-
- (let ((start-literal (concat "[\"" caml-quote-char "]"))
- found kwop)
- (while (and (> (point) 1) (not found)
- (re-search-backward kwop-regexp min-pos 'move))
- (setq kwop (caml-match-string 0))
- (cond
- ((looking-at "(\\*")
- (if (> (point) 1) (backward-char)))
- ((caml-in-comment-p)
- (search-backward "(" min-pos 'move))
- ((looking-at start-literal))
- ((caml-in-literal-p)
- (re-search-backward start-literal min-pos 'move)) ;ugly hack
- ((setq found t))))
- (if found
- (if (not (string-match "\\`[^|[]|[^]|]?\\'" kwop)) ;arrrrgh!!
- kwop
- (forward-char 1) "|") nil)))
-
-; Association list of indentation values based on governing keywords.
-;
-;Each element is of the form (KEYWORD OP-TYPE PRIO INDENT). OP-TYPE is
-;non-nil for operator-type nodes, which affect indentation in a
-;different way from keywords: subsequent lines are indented to the
-;actual occurrence of an operator, but relative to the indentation of
-;the line where the governing keyword occurs.
-
-(defconst caml-no-indent 0)
-
-(defconst caml-kwop-alist
- '(("begin" nil 6 caml-begin-indent)
- (":begin" nil 6 caml-begin-indent) ; hack
- ("class" nil 0 caml-class-indent)
- ("constraint" nil 0 caml-val-indent)
- ("sig" nil 1 caml-sig-indent)
- ("struct" nil 1 caml-struct-indent)
- ("exception" nil 0 caml-exception-indent)
- ("for" nil 6 caml-for-indent)
- ("fun" nil 3 caml-fun-indent)
- ("function" nil 3 caml-function-indent)
- ("if" nil 6 caml-if-indent)
- ("if-else" nil 6 caml-if-else-indent)
- ("include" nil 0 caml-include-indent)
- ("inherit" nil 0 caml-inherit-indent)
- ("initializer" nil 0 caml-initializer-indent)
- ("let" nil 6 caml-let-indent)
- ("let-in" nil 6 caml-let-in-indent)
- ("match" nil 6 caml-match-indent)
- ("method" nil 0 caml-method-indent)
- ("module" nil 0 caml-module-indent)
- ("object" nil 6 caml-object-indent)
- ("of" nil 7 caml-of-indent)
- ("open" nil 0 caml-no-indent)
- ("parser" nil 3 caml-parser-indent)
- ("try" nil 6 caml-try-indent)
- ("type" nil 0 caml-type-indent)
- ("val" nil 0 caml-val-indent)
- ("when" nil 2 caml-if-indent)
- ("while" nil 6 caml-while-indent)
- ("::" t 5 caml-::-indent)
- ("@" t 4 caml-@-indent)
- ("^" t 4 caml-@-indent)
- (":=" nil 3 caml-:=-indent)
- ("<-" nil 3 caml-<--indent)
- ("->" nil 2 caml-->-indent)
- ("\[" t 8 caml-lb-indent)
- ("{" t 8 caml-lc-indent)
- ("\(" t 8 caml-lp-indent)
- ("|" nil 2 caml-no-indent)
- (";;" nil 0 caml-no-indent))
-; if-else and let-in are not keywords but idioms
-; "|" is not in the regexps
-; all these 3 values correspond to hard-coded names
-
-"Association list of indentation values based on governing keywords.
-
-Each element is of the form (KEYWORD OP-TYPE PRIO INDENT). OP-TYPE is
-non-nil for operator-type nodes, which affect indentation in a
-different way from keywords: subsequent lines are indented to the
-actual occurrence of an operator, but relative to the indentation of
-the line where the governing keyword occurs.")
-
-;;Originally, we had caml-kwop-regexp create these at runtime, from an
-;;additional field in caml-kwop-alist. That proved way too slow,
-;;although I still can't understand why. itz
-
-(aset caml-kwop-regexps 0
- (concat
- "\\<\\(begin\\|object\\|for\\|s\\(ig\\|truct\\)\\|while\\)\\>"
- "\\|:begin\\>\\|[[({]\\|;;"))
-(aset caml-kwop-regexps 1
- (concat (aref caml-kwop-regexps 0) "\\|\\<\\(class\\|module\\)\\>"))
-(aset caml-kwop-regexps 2
- (concat
- (aref caml-kwop-regexps 1)
- "\\|\\<\\(fun\\(ction\\)?\\|initializer\\|let\\|m\\(atch\\|ethod\\)"
- "\\|parser\\|try\\|val\\)\\>\\|->"))
-(aset caml-kwop-regexps 3
- (concat (aref caml-kwop-regexps 2) "\\|\\<if\\|when\\>"))
-(aset caml-kwop-regexps 4
- (concat (aref caml-kwop-regexps 3) "\\|:=\\|<-"))
-(aset caml-kwop-regexps 5
- (concat (aref caml-kwop-regexps 4) "\\|@"))
-(aset caml-kwop-regexps 6
- (concat (aref caml-kwop-regexps 5) "\\|::\\|\\^"))
-(aset caml-kwop-regexps 7
- (concat
- (aref caml-kwop-regexps 0)
- "\\|\\<\\(constraint\\|exception\\|in\\(herit\\|clude\\)"
- "\\|o\\(f\\|pen\\)\\|type\\|val\\)\\>"))
-(aset caml-kwop-regexps 8
- (concat (aref caml-kwop-regexps 6)
- "\\|\\<\\(constraint\\|exception\\|in\\(herit\\|clude\\)"
- "\\|o\\(f\\|pen\\)\\|type\\)\\>"))
-
-(defun caml-find-done-match ()
- (let ((unbalanced 1) (kwop t))
- (while (and (not (= 0 unbalanced)) kwop)
- (setq kwop (caml-find-kwop "\\<\\(done\\|for\\|while\\)\\>"))
- (cond
- ((not kwop))
- ((string= kwop "done") (setq unbalanced (1+ unbalanced)))
- (t (setq unbalanced (1- unbalanced)))))
- kwop))
-
-(defun caml-find-end-match ()
- (let ((unbalanced 1) (kwop t))
- (while (and (not (= 0 unbalanced)) kwop)
- (setq kwop
- (caml-find-kwop
- "\\<\\(end\\|begin\\|object\\|s\\(ig\\|truct\\)\\)\\>\\|:begin\\>\\|;;"))
- (cond
- ((not kwop))
- ((string= kwop ";;") (setq kwop nil) (forward-line 1))
- ((string= kwop "end") (setq unbalanced (1+ unbalanced)))
- ( t (setq unbalanced (1- unbalanced)))))
- (if (string= kwop ":begin") "begin"
- kwop)))
-
-(defun caml-find-in-match ()
- (let ((unbalanced 1) (kwop t))
- (while (and (not (= 0 unbalanced)) kwop)
- (setq kwop (caml-find-kwop "\\<\\(in\\|let\\|end\\)\\>"))
- (cond
- ((not kwop))
- ((string= kwop "end") (caml-find-end-match))
- ((string= kwop "in") (setq unbalanced (1+ unbalanced)))
- (t (setq unbalanced (1- unbalanced)))))
- kwop))
-
-(defun caml-find-with-match ()
- (let ((unbalanced 1) (kwop t))
- (while (and (not (= 0 unbalanced)) kwop)
- (setq kwop
- (caml-find-kwop
- "\\<\\(with\\|try\\|m\\(atch\\|odule\\)\\|functor\\)\\>\\|[{}()]"))
- (cond
- ((not kwop))
- ((caml-at-sexp-close-p)
- (caml-find-paren-match (following-char)))
- ((string= kwop "with")
- (setq unbalanced (1+ unbalanced)))
- ((or (string= kwop "module")
- (string= kwop "functor")
- (string= kwop "{")
- (string= kwop "("))
- (setq unbalanced 0))
- (t (setq unbalanced (1- unbalanced)))))
- kwop))
-
-(defun caml-find-paren-match (close)
- (let ((unbalanced 1)
- (regexp (cond ((= close ?\)) "[()]")
- ((= close ?\]) "[][]")
- ((= close ?\}) "[{}]"))))
- (while (and (> unbalanced 0)
- (caml-find-kwop regexp))
- (if (= close (following-char))
- (setq unbalanced (1+ unbalanced))
- (setq unbalanced (1- unbalanced))))))
-
-(defun caml-find-then-match (&optional from-else)
- (let ((bol (if from-else
- (save-excursion
- (progn (beginning-of-line) (point)))))
- kwop done matching-fun)
- (while (not done)
- (setq kwop
- (caml-find-kwop
- "\\<\\(e\\(nd\\|lse\\)\\|done\\|then\\|if\\|with\\)\\>\\|[])};]"))
- (cond
- ((not kwop) (setq done t))
- ((caml-at-sexp-close-p)
- (caml-find-paren-match (following-char)))
- ((string= kwop "if") (setq done t))
- ((string= kwop "then")
- (if (not from-else) (setq kwop (caml-find-then-match))))
- ((setq matching-fun (cdr-safe (assoc kwop caml-matching-kw-alist)))
- (setq kwop (funcall matching-fun)))))
- (if (and bol (>= (point) bol))
- "if-else"
- kwop)))
-
-(defun caml-find-pipe-match ()
- (let ((done nil) (kwop)
- (re (concat
- "\\<\\(try\\|match\\|with\\|function\\|parser\\|type"
- "\\|e\\(nd\\|lse\\)\\|done\\|then\\|in\\)\\>"
- "\\|[^[|]|\\|[])}]")))
- (while (not done)
- (setq kwop (caml-find-kwop re))
- (cond
- ((not kwop) (setq done t))
- ((looking-at "[^[|]\\(|\\)")
- (goto-char (match-beginning 1))
- (setq kwop "|")
- (setq done t))
- ((caml-at-sexp-close-p)
- (caml-find-paren-match (following-char)))
- ((string= kwop "with")
- (setq kwop (caml-find-with-match))
- (setq done t))
- ((string= kwop "parser")
- (if (re-search-backward "\\<with\\>" (- (point) 5) t)
- (setq kwop (caml-find-with-match)))
- (setq done t))
- ((string= kwop "done") (caml-find-done-match))
- ((string= kwop "end") (caml-find-end-match))
- ((string= kwop "then") (caml-find-then-match))
- ((string= kwop "else") (caml-find-else-match))
- ((string= kwop "in") (caml-find-in-match))
- (t (setq done t))))
- kwop))
-
-(defun caml-find-and-match ()
- (let ((done nil) (kwop))
- (while (not done)
- (setq kwop (caml-find-kwop
- "\\<\\(object\\|exception\\|let\\|type\\|end\\|in\\)\\>"))
- (cond
- ((not kwop) (setq done t))
- ((string= kwop "end") (caml-find-end-match))
- ((string= kwop "in") (caml-find-in-match))
- (t (setq done t))))
- kwop))
-
-(defun caml-find-else-match ()
- (caml-find-then-match t))
-
-(defun caml-find-semi-match ()
- (caml-find-kwop-skipping-blocks 2))
-
-(defun caml-find-comma-match ()
- (caml-find-kwop-skipping-blocks 3))
-
-(defun caml-find-kwop-skipping-blocks (prio)
- "Look back for a caml keyword matching caml-kwop-regexps [PRIO].
-
- Skip nested blocks."
-
- (let ((done nil) (kwop nil) (matching-fun)
- (kwop-list (aref caml-kwop-regexps prio)))
- (while (not done)
- (setq kwop (caml-find-kwop
- (concat caml-matching-kw-regexp
- (cond ((> prio 3) "\\|[])},;]\\|")
- ((> prio 2) "\\|[])};]\\|")
- (t "\\|[])}]\\|"))
- kwop-list)))
- (cond
- ((not kwop) (setq done t))
- ((caml-at-sexp-close-p)
- (caml-find-paren-match (following-char)))
- ((or (string= kwop ";;")
- (and (string= kwop ";") (= (preceding-char) ?\;)))
- (forward-line 1)
- (setq kwop ";;")
- (setq done t))
- ((and (>= prio 2) (string= kwop "|")) (setq done t))
- ((string= kwop "end") (caml-find-end-match))
- ((string= kwop "done") (caml-find-done-match))
- ((string= kwop "in")
- (cond ((and (caml-find-in-match) (>= prio 2))
- (setq kwop "let-in")
- (setq done t))))
- ((and (string= kwop "parser") (>= prio 2)
- (re-search-backward "\\<with\\>" (- (point) 5) t))
- (setq kwop (caml-find-with-match))
- (setq done t))
- ((setq matching-fun (cdr-safe (assoc kwop caml-matching-kw-alist)))
- (setq kwop (funcall matching-fun))
- (if (looking-at kwop-list) (setq done t)))
- (t (let* ((kwop-info (assoc kwop caml-kwop-alist))
- (is-op (and (nth 1 kwop-info)
- ; check that we are not at beginning of line
- (let ((pos (point)) bti)
- (back-to-indentation)
- (setq bti (point))
- (goto-char pos)
- (< bti pos)))))
- (if (and is-op (looking-at
- (concat (regexp-quote kwop)
- "|?[ \t]*\\(\n\\|(\\*\\)")))
- (setq kwop-list
- (aref caml-kwop-regexps (nth 2 kwop-info)))
- (setq done t))))))
- kwop))
-
-(defun caml-compute-basic-indent (prio)
- "Compute indent of current caml line, ignoring leading keywords.
-
-Find the `governing node' for current line. Compute desired
-indentation based on the node and the indentation alists.
-Assumes point is exactly at line indentation.
-Does not preserve point."
-
- (let* (in-expr
- (kwop (cond
- ((looking-at ";;")
- (beginning-of-line 1))
- ((looking-at "|\\([^]|]\\|\\'\\)")
- (caml-find-pipe-match))
- ((and (looking-at caml-phrase-start-keywords)
- (caml-in-expr-p))
- (caml-find-end-match))
- ((and (looking-at caml-matching-kw-regexp)
- (assoc (caml-match-string 0) caml-matching-kw-alist))
- (funcall (cdr-safe (assoc (caml-match-string 0)
- caml-matching-kw-alist))))
- ((looking-at
- (aref caml-kwop-regexps caml-max-indent-priority))
- (let* ((kwop (caml-match-string 0))
- (kwop-info (assoc kwop caml-kwop-alist))
- (prio (if kwop-info (nth 2 kwop-info)
- caml-max-indent-priority)))
- (if (and (looking-at (aref caml-kwop-regexps 0))
- (not (looking-at "object"))
- (caml-in-expr-p))
- (setq in-expr t))
- (caml-find-kwop-skipping-blocks prio)))
- (t
- (if (and (= prio caml-max-indent-priority) (caml-in-expr-p))
- (setq in-expr t))
- (caml-find-kwop-skipping-blocks prio))))
- (kwop-info (assoc kwop caml-kwop-alist))
- (indent-diff
- (cond
- ((not kwop-info) (beginning-of-line 1) 0)
- ((looking-at "[[({][|<]?[ \t]*")
- (length (caml-match-string 0)))
- ((nth 1 kwop-info) (symbol-value (nth 3 kwop-info)))
- (t
- (let ((pos (point)))
- (back-to-indentation)
-; (if (looking-at "\\<let\\>") (goto-char pos))
- (- (symbol-value (nth 3 kwop-info))
- (if (looking-at "|") caml-|-extra-indent 0))))))
- (extra (if in-expr caml-apply-extra-indent 0)))
- (+ indent-diff extra (current-column))))
-
-(defconst caml-leading-kwops-regexp
- (concat
- "\\<\\(and\\|do\\(ne\\)?\\|e\\(lse\\|nd\\)\\|in"
- "\\|t\\(hen\\|o\\)\\|with\\)\\>\\|[]|})]")
-
- "Regexp matching caml keywords which need special indentation.")
-
-(defconst caml-leading-kwops-alist
- '(("and" caml-and-extra-indent 2)
- ("do" caml-do-extra-indent 0)
- ("done" caml-done-extra-indent 0)
- ("else" caml-else-extra-indent 3)
- ("end" caml-end-extra-indent 0)
- ("in" caml-in-extra-indent 2)
- ("then" caml-then-extra-indent 3)
- ("to" caml-to-extra-indent 0)
- ("with" caml-with-extra-indent 2)
- ("|" caml-|-extra-indent 2)
- ("]" caml-rb-extra-indent 0)
- ("}" caml-rc-extra-indent 0)
- (")" caml-rp-extra-indent 0))
-
- "Association list of special caml keyword indent values.
-
-Each member is of the form (KEYWORD EXTRA-INDENT PRIO) where
-EXTRA-INDENT is the variable holding extra indentation amount for
-KEYWORD (usually negative) and PRIO is upper bound on priority of
-matching nodes to determine KEYWORD's final indentation.")
-
-(defun caml-compute-final-indent ()
- (save-excursion
- (back-to-indentation)
- (cond
- ((and (bolp) (looking-at comment-start-skip)) (current-column))
- ((caml-in-comment-p)
- (let ((closing (looking-at "\\*)"))
- (comment-mark (looking-at "\\*")))
- (caml-backward-comment)
- (looking-at comment-start-skip)
- (+ (current-column)
- (cond
- (closing 1)
- (comment-mark 1)
- (t caml-comment-indent)))))
- (t (let* ((leading (looking-at caml-leading-kwops-regexp))
- (assoc-val (if leading (assoc (caml-match-string 0)
- caml-leading-kwops-alist)))
- (extra (if leading (symbol-value (nth 1 assoc-val)) 0))
- (prio (if leading (nth 2 assoc-val)
- caml-max-indent-priority))
- (basic (caml-compute-basic-indent prio)))
- (max 0 (if extra (+ extra basic) (current-column))))))))
-
-
-
-(defun caml-split-string ()
- "Called whenever a line is broken inside a caml string literal."
- (insert-before-markers "\"^\"")
- (backward-char 1))
-
-(defadvice indent-new-comment-line (around
- caml-indent-new-comment-line
- activate)
-
- "Handle multi-line strings in caml mode."
-
-;this advice doesn't make sense in other modes. I wish there were a
-;cleaner way to do this: I haven't found one.
-
- (let ((hooked (and (eq major-mode 'caml-mode) (caml-in-literal-p)))
- (split-mark))
- (if (not hooked) nil
- (setq split-mark (set-marker (make-marker) (point)))
- (caml-split-string))
- ad-do-it
- (if (not hooked) nil
- (goto-char split-mark)
- (set-marker split-mark nil))))
-
-(defadvice newline-and-indent (around
- caml-newline-and-indent
- activate)
-
- "Handle multi-line strings in caml mode."
-
- (let ((hooked (and (eq major-mode 'caml-mode) (caml-in-literal-p)))
- (split-mark))
- (if (not hooked) nil
- (setq split-mark (set-marker (make-marker) (point)))
- (caml-split-string))
- ad-do-it
- (if (not hooked) nil
- (goto-char split-mark)
- (set-marker split-mark nil))))
-
-(defun caml-electric-pipe ()
- "If inserting a | or } operator at beginning of line, reindent the line.
-
-Unfortunately there is a situation where this mechanism gets
-confused. It's when | is the first character of a |] sequence. This is
-a misfeature of caml syntax and cannot be fixed, however, as a
-workaround, the electric ] inserts | itself if the matching [ is
-followed by |."
-
- (interactive "*")
- (let ((electric (and caml-electric-indent
- (caml-in-indentation)
- (not (caml-in-comment-p)))))
- (self-insert-command 1)
- (if electric (save-excursion (caml-indent-command)))))
-
-(defun caml-electric-rb ()
- "If inserting a ] operator at beginning of line, reindent the line.
-
-Also, if the matching [ is followed by a | and this ] is not preceded
-by |, insert one."
-
- (interactive "*")
- (let* ((prec (preceding-char))
- (use-pipe (and caml-electric-close-vector
- (not (caml-in-comment-p))
- (not (caml-in-literal-p))
- (or (not (numberp prec))
- (not (char-equal ?| prec)))))
- (electric (and caml-electric-indent
- (caml-in-indentation)
- (not (caml-in-comment-p)))))
- (self-insert-command 1)
- (if electric (save-excursion (caml-indent-command)))
- (if (and use-pipe
- (save-excursion
- (condition-case nil
- (prog2
- (backward-list 1)
- (looking-at "\\[|"))
- (error ""))))
- (save-excursion
- (backward-char 1)
- (insert "|")))))
-
-(defun caml-abbrev-hook ()
- "If inserting a leading keyword at beginning of line, reindent the line."
- ;itz unfortunately we need a special case
- (if (and (not (caml-in-comment-p)) (not (= last-command-char ?_)))
- (let* ((bol (save-excursion (beginning-of-line) (point)))
- (kw (save-excursion
- (and (re-search-backward "^[ \t]*\\(\\sw+\\)\\=" bol t)
- (caml-match-string 1)))))
- (if kw
- (let ((indent (save-excursion
- (goto-char (match-beginning 1))
- (caml-indent-command)
- (current-column)))
- (abbrev-correct (if (= last-command-char ?\ ) 1 0)))
- (indent-to (- indent
- (or
- (symbol-value
- (nth 1
- (assoc kw caml-leading-kwops-alist)))
- 0)
- abbrev-correct)))))))
-
-; (defun caml-indent-phrase ()
-; (interactive "*")
-; (let ((bounds (caml-mark-phrase)))
-; (indent-region (car bounds) (cdr bounds) nil)))
-
-;;; Additional commands by Didier to report errors in toplevel mode
-
-(defun caml-skip-blank-forward ()
- (if (looking-at "[ \t\n]*\\((\\*\\([^*]\\|[^(]\\*[^)]\\)*\\*)[ \t\n]*\\)*")
- (goto-char (match-end 0))))
-
-;; to mark phrases, so that repeated calls will take several of them
-;; knows little about Ocaml appart literals and comments, so it should work
-;; with other dialects as long as ;; marks the end of phrase.
-
-(defun caml-indent-phrase (arg)
- "Indent current phrase
-with prefix arg, indent that many phrases starting with the current phrase."
- (interactive "p")
- (save-excursion
- (let ((beg (caml-find-phrase)))
- (while (progn (setq arg (- arg 1)) (> arg 0)) (caml-find-phrase))
- (indent-region beg (point) nil))))
-
-(defun caml-indent-buffer ()
- (interactive)
- (indent-region (point-min) (point-max) nil))
-
-(defun caml-backward-to-less-indent (&optional n)
- "Move cursor back N lines with less or same indentation."
- (interactive "p")
- (beginning-of-line 1)
- (if (< n 0) (caml-forward-to-less-indent (- n))
- (while (> n 0)
- (let ((i (current-indentation)))
- (forward-line -1)
- (while (or (> (current-indentation) i)
- (caml-in-comment-p)
- (looking-at
- (concat "[ \t]*\\(\n\\|" comment-start-skip "\\)")))
- (forward-line -1)))
- (setq n (1- n))))
- (back-to-indentation))
-
-(defun caml-forward-to-less-indent (&optional n)
- "Move cursor back N lines with less or same indentation."
- (interactive "p")
- (beginning-of-line 1)
- (if (< n 0) (caml-backward-to-less-indent (- n))
- (while (> n 0)
- (let ((i (current-indentation)))
- (forward-line 1)
- (while (or (> (current-indentation) i)
- (caml-in-comment-p)
- (looking-at
- (concat "[ \t]*\\(\n\\|" comment-start-skip "\\)")))
- (forward-line 1)))
- (setq n (1- n))))
- (back-to-indentation))
-
-(defun caml-insert-begin-form ()
- "Inserts a nicely formatted begin-end form, leaving a mark after end."
- (interactive "*")
- (let ((prec (preceding-char)))
- (if (and (numberp prec) (not (char-equal ?\ (char-syntax prec))))
- (insert " ")))
- (let* ((c (current-indentation)) (i (+ caml-begin-indent c)))
- (insert "begin\n\nend")
- (push-mark)
- (indent-line-to c)
- (forward-line -1)
- (indent-line-to i)))
-
-(defun caml-insert-for-form ()
- "Inserts a nicely formatted for-do-done form, leaving a mark after do(ne)."
- (interactive "*")
- (let ((prec (preceding-char)))
- (if (and (numberp prec) (not (char-equal ?\ (char-syntax prec))))
- (insert " ")))
- (let* ((c (current-indentation)) (i (+ caml-for-indent c)))
- (insert "for do\n\ndone")
- (push-mark)
- (indent-line-to c)
- (forward-line -1)
- (indent-line-to i)
- (push-mark)
- (beginning-of-line 1)
- (backward-char 4)))
-
-(defun caml-insert-if-form ()
- "Insert nicely formatted if-then-else form leaving mark after then, else."
- (interactive "*")
- (let ((prec (preceding-char)))
- (if (and (numberp prec) (not (char-equal ?\ (char-syntax prec))))
- (insert " ")))
- (let* ((c (current-indentation)) (i (+ caml-if-indent c)))
- (insert "if\n\nthen\n\nelse\n")
- (indent-line-to i)
- (push-mark)
- (forward-line -1)
- (indent-line-to c)
- (forward-line -1)
- (indent-line-to i)
- (push-mark)
- (forward-line -1)
- (indent-line-to c)
- (forward-line -1)
- (indent-line-to i)))
-
-(defun caml-insert-match-form ()
- "Insert nicely formatted match-with form leaving mark after with."
- (interactive "*")
- (let ((prec (preceding-char)))
- (if (and (numberp prec) (not (char-equal ?\ (char-syntax prec))))
- (insert " ")))
- (let* ((c (current-indentation)) (i (+ caml-match-indent c)))
- (insert "match\n\nwith\n")
- (indent-line-to i)
- (push-mark)
- (forward-line -1)
- (indent-line-to c)
- (forward-line -1)
- (indent-line-to i)))
-
-(defun caml-insert-let-form ()
- "Insert nicely formatted let-in form leaving mark after in."
- (interactive "*")
- (let ((prec (preceding-char)))
- (if (and (numberp prec) (not (char-equal ?\ (char-syntax prec))))
- (insert " ")))
- (let* ((c (current-indentation)))
- (insert "let in\n")
- (indent-line-to c)
- (push-mark)
- (forward-line -1)
- (forward-char (+ c 4))))
-
-(defun caml-insert-try-form ()
- "Insert nicely formatted try-with form leaving mark after with."
- (interactive "*")
- (let ((prec (preceding-char)))
- (if (and (numberp prec) (not (char-equal ?\ (char-syntax prec))))
- (insert " ")))
- (let* ((c (current-indentation)) (i (+ caml-try-indent c)))
- (insert "try\n\nwith\n")
- (indent-line-to i)
- (push-mark)
- (forward-line -1)
- (indent-line-to c)
- (forward-line -1)
- (indent-line-to i)))
-
-(defun caml-insert-while-form ()
- "Insert nicely formatted while-do-done form leaving mark after do, done."
- (interactive "*")
- (let ((prec (preceding-char)))
- (if (and (numberp prec) (not (char-equal ?\ (char-syntax prec))))
- (insert " ")))
- (let* ((c (current-indentation)) (i (+ caml-if-indent c)))
- (insert "while do\n\ndone")
- (push-mark)
- (indent-line-to c)
- (forward-line -1)
- (indent-line-to i)
- (push-mark)
- (beginning-of-line 1)
- (backward-char 4)))
-
-(autoload 'run-caml "inf-caml" "Run an inferior Caml process." t)
-
-(autoload 'caml-types-show-type "caml-types"
- "Show the type of expression or pattern at point." t)
-(autoload 'caml-types-explore "caml-types"
- "Explore type annotations by mouse dragging." t)
-
-(autoload 'caml-help "caml-help"
- "Show documentation for qualilifed OCaml identifier." t)
-(autoload 'caml-complete "caml-help"
- "Does completion for documented qualified OCaml identifier." t)
-(autoload 'ocaml-open-module "caml-help"
- "Add module in documentation search path." t)
-(autoload 'ocaml-close-module "caml-help"
- "Remove module from documentation search path." t)
-(autoload 'ocaml-add-path "caml-help"
- "Add search path for documentation." t)
-
-;;; caml.el ends here
-
-(provide 'caml)
diff --git a/emacs/camldebug.el b/emacs/camldebug.el
deleted file mode 100644
index c66343a4e1..0000000000
--- a/emacs/camldebug.el
+++ /dev/null
@@ -1,754 +0,0 @@
-;;; Run camldebug under Emacs
-;;; Derived from gdb.el.
-;;; gdb.el is Copyright (C) 1988 Free Software Foundation, Inc, and is part
-;;; of GNU Emacs
-;;; Modified by Jerome Vouillon, 1994.
-;;; Modified by Ian T. Zimmerman, 1996.
-;;; Modified by Xavier Leroy, 1997.
-
-;; This file is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 1, or (at your option)
-;; any later version.
-
-;; This file is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;;itz 04-06-96 I pondered basing this on gud. The potential advantages
-;;were: automatic bugfix , keymaps and menus propagation.
-;;Disadvantages: gud is not so clean itself, there is little common
-;;functionality it abstracts (most of the stuff is done in the
-;;debugger specific parts anyway), and, most seriously, gud sees it
-;;fit to add C-x C-a bindings to the _global_ map, so there would be a
-;;conflict between camldebug and gdb, for instance. While it's OK to
-;;assume that a sane person doesn't use gdb and dbx at the same time,
-;;it's not so OK (IMHO) for gdb and camldebug.
-
-;; Xavier Leroy, 21/02/97: adaptation to ocamldebug.
-
-(require 'comint)
-(require 'shell)
-(require 'caml)
-(require 'derived)
-(require 'thingatpt)
-
-;;; Variables.
-
-(defvar camldebug-last-frame)
-(defvar camldebug-delete-prompt-marker)
-(defvar camldebug-filter-accumulator nil)
-(defvar camldebug-last-frame-displayed-p)
-(defvar camldebug-filter-function)
-
-(defvar camldebug-prompt-pattern "^(ocd) *"
- "A regexp to recognize the prompt for ocamldebug.")
-
-(defvar camldebug-overlay-event nil
- "Overlay for displaying the current event.")
-(defvar camldebug-overlay-under nil
- "Overlay for displaying the current event.")
-(defvar camldebug-event-marker nil
- "Marker for displaying the current event.")
-
-(defvar camldebug-track-frame t
- "*If non-nil, always display current frame position in another window.")
-
-(cond
- (window-system
- (make-face 'camldebug-event)
- (make-face 'camldebug-underline)
- (if (not (face-differs-from-default-p 'camldebug-event))
- (invert-face 'camldebug-event))
- (if (not (face-differs-from-default-p 'camldebug-underline))
- (set-face-underline-p 'camldebug-underline t))
- (setq camldebug-overlay-event (make-overlay 1 1))
- (overlay-put camldebug-overlay-event 'face 'camldebug-event)
- (setq camldebug-overlay-under (make-overlay 1 1))
- (overlay-put camldebug-overlay-under 'face 'camldebug-underline))
- (t
- (setq camldebug-event-marker (make-marker))
- (setq overlay-arrow-string "=>")))
-
-;;; Camldebug mode.
-
-(define-derived-mode camldebug-mode comint-mode "Inferior CDB"
-
- "Major mode for interacting with an inferior Camldebug process.
-
-The following commands are available:
-
-\\{camldebug-mode-map}
-
-\\[camldebug-display-frame] displays in the other window
-the last line referred to in the camldebug buffer.
-
-\\[camldebug-step], \\[camldebug-back] and \\[camldebug-next], in the camldebug window,
-call camldebug to step, backstep or next and then update the other window
-with the current file and position.
-
-If you are in a source file, you may select a point to break
-at, by doing \\[camldebug-break].
-
-Commands:
-Many commands are inherited from comint mode.
-Additionally we have:
-
-\\[camldebug-display-frame] display frames file in other window
-\\[camldebug-step] advance one line in program
-C-x SPACE sets break point at current line."
-
- (mapcar 'make-local-variable
- '(camldebug-last-frame-displayed-p camldebug-last-frame
- camldebug-delete-prompt-marker camldebug-filter-function
- camldebug-filter-accumulator paragraph-start))
- (setq
- camldebug-last-frame nil
- camldebug-delete-prompt-marker (make-marker)
- camldebug-filter-accumulator ""
- camldebug-filter-function 'camldebug-marker-filter
- comint-prompt-regexp camldebug-prompt-pattern
- comint-dynamic-complete-functions (cons 'camldebug-complete
- comint-dynamic-complete-functions)
- paragraph-start comint-prompt-regexp
- camldebug-last-frame-displayed-p t)
- (make-local-variable 'shell-dirtrackp)
- (setq shell-dirtrackp t)
- (setq comint-input-sentinel 'shell-directory-tracker))
-
-;;; Keymaps.
-
-(defun camldebug-numeric-arg (arg)
- (and arg (prefix-numeric-value arg)))
-
-(defmacro def-camldebug (name key &optional doc args)
-
- "Define camldebug-NAME to be a command sending NAME ARGS and bound
-to KEY, with optional doc string DOC. Certain %-escapes in ARGS are
-interpreted specially if present. These are:
-
- %m module name of current module.
- %d directory of current source file.
- %c number of current character position
- %e text of the caml variable surrounding point.
-
- The `current' source file is the file of the current buffer (if
-we're in a caml buffer) or the source file current at the last break
-or step (if we're in the camldebug buffer), and the `current' module
-name is the filename stripped of any *.ml* suffixes (this assumes the
-usual correspondence between module and file naming is observed). The
-`current' position is that of the current buffer (if we're in a source
-file) or the position of the last break or step (if we're in the
-camldebug buffer).
-
-If a numeric is present, it overrides any ARGS flags and its string
-representation is simply concatenated with the COMMAND."
-
- (let* ((fun (intern (format "camldebug-%s" name))))
- (list 'progn
- (if doc
- (list 'defun fun '(arg)
- doc
- '(interactive "P")
- (list 'camldebug-call name args
- '(camldebug-numeric-arg arg))))
- (list 'define-key 'camldebug-mode-map
- (concat "\C-c" key)
- (list 'quote fun))
- (list 'define-key 'caml-mode-map
- (concat "\C-x\C-a" key)
- (list 'quote fun)))))
-
-(def-camldebug "step" "\C-s" "Step one event forward.")
-(def-camldebug "backstep" "\C-k" "Step one event backward.")
-(def-camldebug "run" "\C-r" "Run the program.")
-(def-camldebug "reverse" "\C-v" "Run the program in reverse.")
-(def-camldebug "last" "\C-l" "Go to latest time in execution history.")
-(def-camldebug "backtrace" "\C-t" "Print the call stack.")
-(def-camldebug "finish" "\C-f" "Finish executing current function.")
-(def-camldebug "print" "\C-p" "Print value of symbol at point." "%e")
-(def-camldebug "display" "\C-d" "Display value of symbol at point." "%e")
-(def-camldebug "next" "\C-n" "Step one event forward (skip functions)")
-(def-camldebug "up" "<" "Go up N stack frames (numeric arg) with display")
-(def-camldebug "down" ">" "Go down N stack frames (numeric arg) with display")
-(def-camldebug "break" "\C-b" "Set breakpoint at current line."
- "@ \"%m\" # %c")
-
-(defun camldebug-mouse-display (click)
- "Display value of $NNN clicked on."
- (interactive "e")
- (let* ((start (event-start click))
- (window (car start))
- (pos (car (cdr start)))
- symb)
- (save-excursion
- (select-window window)
- (goto-char pos)
- (setq symb (thing-at-point 'symbol))
- (if (string-match "^\\$[0-9]+$" symb)
- (camldebug-call "display" symb)))))
-
-(define-key camldebug-mode-map [mouse-2] 'camldebug-mouse-display)
-
-(defun camldebug-kill-filter (string)
- ;gob up stupid questions :-)
- (setq camldebug-filter-accumulator
- (concat camldebug-filter-accumulator string))
- (if (not (string-match "\\(.* \\)(y or n) "
- camldebug-filter-accumulator)) nil
- (setq camldebug-kill-output
- (cons t (match-string 1 camldebug-filter-accumulator)))
- (setq camldebug-filter-accumulator ""))
- (if (string-match comint-prompt-regexp camldebug-filter-accumulator)
- (let ((output (substring camldebug-filter-accumulator
- (match-beginning 0))))
- (setq camldebug-kill-output
- (cons nil (substring camldebug-filter-accumulator 0
- (1- (match-beginning 0)))))
- (setq camldebug-filter-accumulator "")
- output)
- ""))
-
-(def-camldebug "kill" "\C-k")
-
-(defun camldebug-kill ()
- "Kill the program."
- (interactive)
- (let ((camldebug-kill-output))
- (save-excursion
- (set-buffer current-camldebug-buffer)
- (let ((proc (get-buffer-process (current-buffer)))
- (camldebug-filter-function 'camldebug-kill-filter))
- (camldebug-call "kill")
- (while (not (and camldebug-kill-output
- (zerop (length camldebug-filter-accumulator))))
- (accept-process-output proc))))
- (if (not (car camldebug-kill-output))
- (error (cdr camldebug-kill-output))
- (sit-for 0 300)
- (camldebug-call-1 (if (y-or-n-p (cdr camldebug-kill-output)) "y" "n")))))
-;;FIXME: camldebug doesn't output the Hide marker on kill
-
-(defun camldebug-goto-filter (string)
- ;accumulate onto previous output
- (setq camldebug-filter-accumulator
- (concat camldebug-filter-accumulator string))
- (if (not (string-match (concat "\\(\n\\|\\`\\)[ \t]*\\([0-9]+\\)[ \t]+"
- camldebug-goto-position
- "[ \t]*\\(before\\|after\\)\n")
- camldebug-filter-accumulator)) nil
- (setq camldebug-goto-output
- (match-string 2 camldebug-filter-accumulator))
- (setq camldebug-filter-accumulator
- (substring camldebug-filter-accumulator (1- (match-end 0)))))
- (if (not (string-match comint-prompt-regexp
- camldebug-filter-accumulator)) nil
- (setq camldebug-goto-output (or camldebug-goto-output 'fail))
- (setq camldebug-filter-accumulator ""))
- (if (string-match "\n\\(.*\\)\\'" camldebug-filter-accumulator)
- (setq camldebug-filter-accumulator
- (match-string 1 camldebug-filter-accumulator)))
- "")
-
-(def-camldebug "goto" "\C-g")
-(defun camldebug-goto (&optional time)
-
- "Go to the execution time TIME.
-
-Without TIME, the command behaves as follows: In the camldebug buffer,
-if the point at buffer end, goto time 0\; otherwise, try to obtain the
-time from context around point. In a caml mode buffer, try to find the
-time associated in execution history with the current point location.
-
-With a negative TIME, move that many lines backward in the camldebug
-buffer, then try to obtain the time from context around point."
-
- (interactive "P")
- (cond
- (time
- (let ((ntime (camldebug-numeric-arg time)))
- (if (>= ntime 0) (camldebug-call "goto" nil ntime)
- (save-selected-window
- (select-window (get-buffer-window current-camldebug-buffer))
- (save-excursion
- (if (re-search-backward "^Time : [0-9]+ - pc : [0-9]+ "
- nil t (- 1 ntime))
- (camldebug-goto nil)
- (error "I don't have %d times in my history"
- (- 1 ntime))))))))
- ((eq (current-buffer) current-camldebug-buffer)
- (let ((time (cond
- ((eobp) 0)
- ((save-excursion
- (beginning-of-line 1)
- (looking-at "^Time : \\([0-9]+\\) - pc : [0-9]+ "))
- (string-to-int (match-string 1)))
- ((string-to-int (camldebug-format-command "%e"))))))
- (camldebug-call "goto" nil time)))
- (t
- (let ((module (camldebug-module-name (buffer-file-name)))
- (camldebug-goto-position (int-to-string (1- (point))))
- (camldebug-goto-output) (address))
- ;get a list of all events in the current module
- (save-excursion
- (set-buffer current-camldebug-buffer)
- (let* ((proc (get-buffer-process (current-buffer)))
- (camldebug-filter-function 'camldebug-goto-filter))
- (camldebug-call-1 (concat "info events " module))
- (while (not (and camldebug-goto-output
- (zerop (length camldebug-filter-accumulator))))
- (accept-process-output proc))
- (setq address (if (eq camldebug-goto-output 'fail) nil
- (re-search-backward
- (concat "^Time : \\([0-9]+\\) - pc : "
- camldebug-goto-output
- " - module "
- module "$") nil t)
- (match-string 1)))))
- (if address (camldebug-call "goto" nil (string-to-int address))
- (error "No time at %s at %s" module camldebug-goto-position))))))
-
-
-(defun camldebug-delete-filter (string)
- (setq camldebug-filter-accumulator
- (concat camldebug-filter-accumulator string))
- (if (not (string-match
- (concat "\\(\n\\|\\`\\)[ \t]*\\([0-9]+\\)[ \t]+[0-9]+[ \t]*in "
- (regexp-quote camldebug-delete-file)
- ", character "
- camldebug-delete-position "\n")
- camldebug-filter-accumulator)) nil
- (setq camldebug-delete-output
- (match-string 2 camldebug-filter-accumulator))
- (setq camldebug-filter-accumulator
- (substring camldebug-filter-accumulator (1- (match-end 0)))))
- (if (not (string-match comint-prompt-regexp
- camldebug-filter-accumulator)) nil
- (setq camldebug-delete-output (or camldebug-delete-output 'fail))
- (setq camldebug-filter-accumulator ""))
- (if (string-match "\n\\(.*\\)\\'" camldebug-filter-accumulator)
- (setq camldebug-filter-accumulator
- (match-string 1 camldebug-filter-accumulator)))
- "")
-
-
-(def-camldebug "delete" "\C-d")
-
-(defun camldebug-delete (&optional arg)
- "Delete the breakpoint numbered ARG.
-
-Without ARG, the command behaves as follows: In the camldebug buffer,
-try to obtain the time from context around point. In a caml mode
-buffer, try to find the breakpoint associated with the current point
-location.
-
-With a negative ARG, look for the -ARGth breakpoint pattern in the
-camldebug buffer, then try to obtain the breakpoint info from context
-around point."
-
- (interactive "P")
- (cond
- (arg
- (let ((narg (camldebug-numeric-arg arg)))
- (if (> narg 0) (camldebug-call "delete" nil narg)
- (save-excursion
- (set-buffer current-camldebug-buffer)
- (if (re-search-backward "^Breakpoint [0-9]+ at [0-9]+ : file "
- nil t (- 1 narg))
- (camldebug-delete nil)
- (error "I don't have %d breakpoints in my history"
- (- 1 narg)))))))
- ((eq (current-buffer) current-camldebug-buffer)
- (let* ((bpline "^Breakpoint \\([0-9]+\\) at [0-9]+ : file ")
- (arg (cond
- ((eobp)
- (save-excursion (re-search-backward bpline nil t))
- (string-to-int (match-string 1)))
- ((save-excursion
- (beginning-of-line 1)
- (looking-at bpline))
- (string-to-int (match-string 1)))
- ((string-to-int (camldebug-format-command "%e"))))))
- (camldebug-call "delete" nil arg)))
- (t
- (let ((camldebug-delete-file
- (concat (camldebug-format-command "%m") ".ml"))
- (camldebug-delete-position (camldebug-format-command "%c")))
- (save-excursion
- (set-buffer current-camldebug-buffer)
- (let ((proc (get-buffer-process (current-buffer)))
- (camldebug-filter-function 'camldebug-delete-filter)
- (camldebug-delete-output))
- (camldebug-call-1 "info break")
- (while (not (and camldebug-delete-output
- (zerop (length
- camldebug-filter-accumulator))))
- (accept-process-output proc))
- (if (eq camldebug-delete-output 'fail)
- (error "No breakpoint in %s at %s"
- camldebug-delete-file
- camldebug-delete-position)
- (camldebug-call "delete" nil
- (string-to-int camldebug-delete-output)))))))))
-
-(defun camldebug-complete-filter (string)
- (setq camldebug-filter-accumulator
- (concat camldebug-filter-accumulator string))
- (while (string-match "\\(\n\\|\\`\\)\\(.+\\)\n"
- camldebug-filter-accumulator)
- (setq camldebug-complete-list
- (cons (match-string 2 camldebug-filter-accumulator)
- camldebug-complete-list))
- (setq camldebug-filter-accumulator
- (substring camldebug-filter-accumulator
- (1- (match-end 0)))))
- (if (not (string-match comint-prompt-regexp
- camldebug-filter-accumulator)) nil
- (setq camldebug-complete-list
- (or camldebug-complete-list 'fail))
- (setq camldebug-filter-accumulator ""))
- (if (string-match "\n\\(.*\\)\\'" camldebug-filter-accumulator)
- (setq camldebug-filter-accumulator
- (match-string 1 camldebug-filter-accumulator)))
- "")
-
-(defun camldebug-complete ()
-
- "Perform completion on the camldebug command preceding point."
-
- (interactive)
- (let* ((end (point))
- (command (save-excursion
- (beginning-of-line)
- (and (looking-at comint-prompt-regexp)
- (goto-char (match-end 0)))
- (buffer-substring (point) end)))
- (camldebug-complete-list nil) (command-word))
-
- ;; Find the word break. This match will always succeed.
- (string-match "\\(\\`\\| \\)\\([^ ]*\\)\\'" command)
- (setq command-word (match-string 2 command))
-
- ;itz 04-21-96 if we are trying to complete a word of nonzero
- ;length, chop off the last character. This is a nasty hack, but it
- ;works - in general, not just for this set of words: the comint
- ;call below will weed out false matches - and it avoids further
- ;mucking with camldebug's lexer.
- (if (> (length command-word) 0)
- (setq command (substring command 0 (1- (length command)))))
-
- (let ((camldebug-filter-function 'camldebug-complete-filter))
- (camldebug-call-1 (concat "complete " command))
- (set-marker camldebug-delete-prompt-marker nil)
- (while (not (and camldebug-complete-list
- (zerop (length camldebug-filter-accumulator))))
- (accept-process-output (get-buffer-process
- (current-buffer)))))
- (if (eq camldebug-complete-list 'fail)
- (setq camldebug-complete-list nil))
- (setq camldebug-complete-list
- (sort camldebug-complete-list 'string-lessp))
- (comint-dynamic-simple-complete command-word camldebug-complete-list)))
-
-(define-key camldebug-mode-map "\C-l" 'camldebug-refresh)
-(define-key camldebug-mode-map "\t" 'comint-dynamic-complete)
-(define-key camldebug-mode-map "\M-?" 'comint-dynamic-list-completions)
-
-(define-key caml-mode-map "\C-x " 'camldebug-break)
-
-
-(defvar current-camldebug-buffer nil)
-
-
-;;;###autoload
-(defvar camldebug-command-name "ocamldebug"
- "*Pathname for executing camldebug.")
-
-;;;###autoload
-(defun camldebug (path)
- "Run camldebug on program FILE in buffer *camldebug-FILE*.
-The directory containing FILE becomes the initial working directory
-and source-file directory for camldebug. If you wish to change this, use
-the camldebug commands `cd DIR' and `directory'."
- (interactive "fRun ocamldebug on file: ")
- (setq path (expand-file-name path))
- (let ((file (file-name-nondirectory path)))
- (pop-to-buffer (concat "*camldebug-" file "*"))
- (setq default-directory (file-name-directory path))
- (message "Current directory is %s" default-directory)
- (make-comint (concat "camldebug-" file)
- (substitute-in-file-name camldebug-command-name)
- nil
- "-emacs" "-cd" default-directory file)
- (set-process-filter (get-buffer-process (current-buffer))
- 'camldebug-filter)
- (set-process-sentinel (get-buffer-process (current-buffer))
- 'camldebug-sentinel)
- (camldebug-mode)
- (camldebug-set-buffer)))
-
-(defun camldebug-set-buffer ()
- (if (eq major-mode 'camldebug-mode)
- (setq current-camldebug-buffer (current-buffer))
- (save-selected-window (pop-to-buffer current-camldebug-buffer))))
-
-;;; Filter and sentinel.
-
-(defun camldebug-marker-filter (string)
- (setq camldebug-filter-accumulator
- (concat camldebug-filter-accumulator string))
- (let ((output "") (begin))
- ;; Process all the complete markers in this chunk.
- (while (setq begin
- (string-match
- "\032\032\\(H\\|M\\(.+\\):\\(.+\\):\\(before\\|after\\)\\)\n"
- camldebug-filter-accumulator))
- (setq camldebug-last-frame
- (if (char-equal ?H (aref camldebug-filter-accumulator
- (1+ (1+ begin)))) nil
- (list (match-string 2 camldebug-filter-accumulator)
- (string-to-int
- (match-string 3 camldebug-filter-accumulator))
- (string= "before"
- (match-string 4
- camldebug-filter-accumulator))))
- output (concat output
- (substring camldebug-filter-accumulator
- 0 begin))
- ;; Set the accumulator to the remaining text.
- camldebug-filter-accumulator (substring
- camldebug-filter-accumulator
- (match-end 0))
- camldebug-last-frame-displayed-p nil))
-
- ;; Does the remaining text look like it might end with the
- ;; beginning of another marker? If it does, then keep it in
- ;; camldebug-filter-accumulator until we receive the rest of it. Since we
- ;; know the full marker regexp above failed, it's pretty simple to
- ;; test for marker starts.
- (if (string-match "\032.*\\'" camldebug-filter-accumulator)
- (progn
- ;; Everything before the potential marker start can be output.
- (setq output (concat output (substring camldebug-filter-accumulator
- 0 (match-beginning 0))))
-
- ;; Everything after, we save, to combine with later input.
- (setq camldebug-filter-accumulator
- (substring camldebug-filter-accumulator (match-beginning 0))))
-
- (setq output (concat output camldebug-filter-accumulator)
- camldebug-filter-accumulator ""))
-
- output))
-
-(defun camldebug-filter (proc string)
- (let ((output))
- (if (buffer-name (process-buffer proc))
- (let ((process-window))
- (save-excursion
- (set-buffer (process-buffer proc))
- ;; If we have been so requested, delete the debugger prompt.
- (if (marker-buffer camldebug-delete-prompt-marker)
- (progn
- (delete-region (process-mark proc)
- camldebug-delete-prompt-marker)
- (set-marker camldebug-delete-prompt-marker nil)))
- (setq output (funcall camldebug-filter-function string))
- ;; Don't display the specified file unless
- ;; (1) point is at or after the position where output appears
- ;; and (2) this buffer is on the screen.
- (setq process-window (and camldebug-track-frame
- (not camldebug-last-frame-displayed-p)
- (>= (point) (process-mark proc))
- (get-buffer-window (current-buffer))))
- ;; Insert the text, moving the process-marker.
- (comint-output-filter proc output))
- (if process-window
- (save-selected-window
- (select-window process-window)
- (camldebug-display-frame)))))))
-
-(defun camldebug-sentinel (proc msg)
- (cond ((null (buffer-name (process-buffer proc)))
- ;; buffer killed
- ;; Stop displaying an arrow in a source file.
- (camldebug-remove-current-event)
- (set-process-buffer proc nil))
- ((memq (process-status proc) '(signal exit))
- ;; Stop displaying an arrow in a source file.
- (camldebug-remove-current-event)
- ;; Fix the mode line.
- (setq mode-line-process
- (concat ": "
- (symbol-name (process-status proc))))
- (let* ((obuf (current-buffer)))
- ;; save-excursion isn't the right thing if
- ;; process-buffer is current-buffer
- (unwind-protect
- (progn
- ;; Write something in *compilation* and hack its mode line,
- (set-buffer (process-buffer proc))
- ;; Force mode line redisplay soon
- (set-buffer-modified-p (buffer-modified-p))
- (if (eobp)
- (insert ?\n mode-name " " msg)
- (save-excursion
- (goto-char (point-max))
- (insert ?\n mode-name " " msg)))
- ;; If buffer and mode line will show that the process
- ;; is dead, we can delete it now. Otherwise it
- ;; will stay around until M-x list-processes.
- (delete-process proc))
- ;; Restore old buffer, but don't restore old point
- ;; if obuf is the cdb buffer.
- (set-buffer obuf))))))
-
-
-(defun camldebug-refresh (&optional arg)
- "Fix up a possibly garbled display, and redraw the mark."
- (interactive "P")
- (camldebug-display-frame)
- (recenter arg))
-
-(defun camldebug-display-frame ()
- "Find, obey and delete the last filename-and-line marker from CDB.
-The marker looks like \\032\\032FILENAME:CHARACTER\\n.
-Obeying it means displaying in another window the specified file and line."
- (interactive)
- (camldebug-set-buffer)
- (if (not camldebug-last-frame)
- (camldebug-remove-current-event)
- (camldebug-display-line (car camldebug-last-frame)
- (car (cdr camldebug-last-frame))
- (car (cdr (cdr camldebug-last-frame)))))
- (setq camldebug-last-frame-displayed-p t))
-
-;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen
-;; and that its character CHARACTER is visible.
-;; Put the mark on this character in that buffer.
-
-(defun camldebug-display-line (true-file character kind)
- (let* ((pre-display-buffer-function nil) ; screw it, put it all in one screen
- (pop-up-windows t)
- (buffer (find-file-noselect true-file))
- (window (display-buffer buffer t))
- (pos))
- (save-excursion
- (set-buffer buffer)
- (save-restriction
- (widen)
- (setq pos (+ (point-min) character))
- (camldebug-set-current-event pos (current-buffer) kind))
- (cond ((or (< pos (point-min)) (> pos (point-max)))
- (widen)
- (goto-char pos))))
- (set-window-point window pos)))
-
-;;; Events.
-
-(defun camldebug-remove-current-event ()
- (if window-system
- (progn
- (delete-overlay camldebug-overlay-event)
- (delete-overlay camldebug-overlay-under))
- (setq overlay-arrow-position nil)))
-
-(defun camldebug-set-current-event (pos buffer before)
- (if window-system
- (if before
- (progn
- (move-overlay camldebug-overlay-event pos (1+ pos) buffer)
- (move-overlay camldebug-overlay-under
- (+ pos 1) (+ pos 3) buffer))
- (move-overlay camldebug-overlay-event (1- pos) pos buffer)
- (move-overlay camldebug-overlay-under (- pos 3) (- pos 1) buffer))
- (save-excursion
- (set-buffer buffer)
- (goto-char pos)
- (beginning-of-line)
- (move-marker camldebug-event-marker (point))
- (setq overlay-arrow-position camldebug-event-marker))))
-
-;;; Miscellaneous.
-
-(defun camldebug-module-name (filename)
- (substring filename (string-match "\\([^/]*\\)\\.ml$" filename) (match-end 1)))
-
-;;; The camldebug-call function must do the right thing whether its
-;;; invoking keystroke is from the camldebug buffer itself (via
-;;; major-mode binding) or a caml buffer. In the former case, we want
-;;; to supply data from camldebug-last-frame. Here's how we do it:
-
-(defun camldebug-format-command (str)
- (let* ((insource (not (eq (current-buffer) current-camldebug-buffer)))
- (frame (if insource nil camldebug-last-frame)) (result))
- (while (and str (string-match "\\([^%]*\\)%\\([mdcep]\\)" str))
- (let ((key (string-to-char (substring str (match-beginning 2))))
- (cmd (substring str (match-beginning 1) (match-end 1)))
- (subst))
- (setq str (substring str (match-end 2)))
- (cond
- ((eq key ?m)
- (setq subst (camldebug-module-name
- (if insource (buffer-file-name) (nth 0 frame)))))
- ((eq key ?d)
- (setq subst (file-name-directory
- (if insource (buffer-file-name) (nth 0 frame)))))
- ((eq key ?c)
- (setq subst (int-to-string
- (if insource (1- (point)) (nth 1 frame)))))
- ((eq key ?e)
- (setq subst (thing-at-point 'symbol))))
- (setq result (concat result cmd subst))))
- ;; There might be text left in STR when the loop ends.
- (concat result str)))
-
-(defun camldebug-call (command &optional fmt arg)
- "Invoke camldebug COMMAND displaying source in other window.
-
-Certain %-escapes in FMT are interpreted specially if present.
-These are:
-
- %m module name of current module.
- %d directory of current source file.
- %c number of current character position
- %e text of the caml variable surrounding point.
-
- The `current' source file is the file of the current buffer (if
-we're in a caml buffer) or the source file current at the last break
-or step (if we're in the camldebug buffer), and the `current' module
-name is the filename stripped of any *.ml* suffixes (this assumes the
-usual correspondence between module and file naming is observed). The
-`current' position is that of the current buffer (if we're in a source
-file) or the position of the last break or step (if we're in the
-camldebug buffer).
-
-If ARG is present, it overrides any FMT flags and its string
-representation is simply concatenated with the COMMAND."
-
- ;; Make sure debugger buffer is displayed in a window.
- (camldebug-set-buffer)
- (message "Command: %s" (camldebug-call-1 command fmt arg)))
-
-(defun camldebug-call-1 (command &optional fmt arg)
-
- ;; Record info on the last prompt in the buffer and its position.
- (save-excursion
- (set-buffer current-camldebug-buffer)
- (goto-char (process-mark (get-buffer-process current-camldebug-buffer)))
- (let ((pt (point)))
- (beginning-of-line)
- (if (looking-at comint-prompt-regexp)
- (set-marker camldebug-delete-prompt-marker (point)))))
- (let ((cmd (cond
- (arg (concat command " " (int-to-string arg)))
- (fmt (camldebug-format-command
- (concat command " " fmt)))
- (command))))
- (process-send-string (get-buffer-process current-camldebug-buffer)
- (concat cmd "\n"))
- cmd))
-
-
-(provide 'camldebug)
diff --git a/emacs/inf-caml.el b/emacs/inf-caml.el
deleted file mode 100644
index f24a7a71fe..0000000000
--- a/emacs/inf-caml.el
+++ /dev/null
@@ -1,348 +0,0 @@
-;;; inf-caml.el --- run the Caml toplevel in an Emacs buffer
-
-;; Xavier Leroy, july 1993.
-
-;; modified by Jacques Garrigue, july 1997.
-
-(require 'comint)
-(require 'caml)
-
-;; User modifiable variables
-
-;; Whether you want the output buffer to be diplayed when you send a phrase
-
-(defvar caml-display-when-eval t
- "*If true, display the inferior caml buffer when evaluating expressions.")
-
-
-;; End of User modifiable variables
-
-
-(defvar inferior-caml-mode-map nil)
-(if inferior-caml-mode-map nil
- (setq inferior-caml-mode-map
- (copy-keymap comint-mode-map)))
-
-;; Augment Caml mode, so you can process Caml code in the source files.
-
-(defvar inferior-caml-program "ocaml"
- "*Program name for invoking an inferior Caml from Emacs.")
-
-(defun inferior-caml-mode ()
- "Major mode for interacting with an inferior Caml process.
-Runs a Caml toplevel as a subprocess of Emacs, with I/O through an
-Emacs buffer. A history of input phrases is maintained. Phrases can
-be sent from another buffer in Caml mode.
-
-\\{inferior-caml-mode-map}"
- (interactive)
- (comint-mode)
- (setq comint-prompt-regexp "^# ?")
- (setq major-mode 'inferior-caml-mode)
- (setq mode-name "Inferior Caml")
- (make-local-variable 'paragraph-start)
- (setq paragraph-start (concat "^$\\|" page-delimiter))
- (make-local-variable 'paragraph-separate)
- (setq paragraph-separate paragraph-start)
- (make-local-variable 'paragraph-ignore-fill-prefix)
- (setq paragraph-ignore-fill-prefix t)
- (make-local-variable 'require-final-newline)
- (setq require-final-newline t)
- (make-local-variable 'comment-start)
- (setq comment-start "(*")
- (make-local-variable 'comment-end)
- (setq comment-end "*)")
- (make-local-variable 'comment-column)
- (setq comment-column 40)
- (make-local-variable 'comment-start-skip)
- (setq comment-start-skip "(\\*+ *")
- (make-local-variable 'parse-sexp-ignore-comments)
- (setq parse-sexp-ignore-comments nil)
- (use-local-map inferior-caml-mode-map)
- (run-hooks 'inferior-caml-mode-hooks))
-
-
-(defconst inferior-caml-buffer-subname "inferior-caml")
-(defconst inferior-caml-buffer-name
- (concat "*" inferior-caml-buffer-subname "*"))
-
-;; for compatibility with xemacs
-
-(defun caml-sit-for (second &optional mili redisplay)
- (if (and (boundp 'running-xemacs) running-xemacs)
- (sit-for (if mili (+ second (* mili 0.001)) second) redisplay)
- (sit-for second mili redisplay)))
-
-;; To show result of evaluation at toplevel
-
-(defvar inferior-caml-output nil)
-(defun inferior-caml-signal-output (s)
- (if (string-match "[^ ]" s) (setq inferior-caml-output t)))
-
-(defun inferior-caml-mode-output-hook ()
- (setq comint-output-filter-functions
- (list (function inferior-caml-signal-output))))
-(add-hook 'inferior-caml-mode-hooks 'inferior-caml-mode-output-hook)
-
-;; To launch ocaml whenever needed
-
-(defun caml-run-process-if-needed (&optional cmd)
- (if (comint-check-proc inferior-caml-buffer-name) nil
- (if (not cmd)
- (if (comint-check-proc inferior-caml-buffer-name)
- (setq cmd inferior-caml-program)
- (setq cmd (read-from-minibuffer "Caml toplevel to run: "
- inferior-caml-program))))
- (setq inferior-caml-program cmd)
- (let ((cmdlist (inferior-caml-args-to-list cmd))
- (process-connection-type nil))
- (set-buffer (apply (function make-comint)
- inferior-caml-buffer-subname
- (car cmdlist) nil (cdr cmdlist)))
- (inferior-caml-mode)
- (display-buffer inferior-caml-buffer-name)
- t)
- (setq caml-shell-active t)
- ))
-
-;; patched to from original run-caml sharing code with
-;; caml-run-process-when-needed
-
-(defun run-caml (&optional cmd)
- "Run an inferior Caml process.
-Input and output via buffer `*inferior-caml*'."
- (interactive
- (list (if (not (comint-check-proc inferior-caml-buffer-name))
- (read-from-minibuffer "Caml toplevel to run: "
- inferior-caml-program))))
- (caml-run-process-if-needed cmd)
- (switch-to-buffer-other-window inferior-caml-buffer-name))
-
-
-(defun inferior-caml-args-to-list (string)
- (let ((where (string-match "[ \t]" string)))
- (cond ((null where) (list string))
- ((not (= where 0))
- (cons (substring string 0 where)
- (inferior-caml-args-to-list (substring string (+ 1 where)
- (length string)))))
- (t (let ((pos (string-match "[^ \t]" string)))
- (if (null pos)
- nil
- (inferior-caml-args-to-list (substring string pos
- (length string)))))))))
-
-(defun inferior-caml-show-subshell ()
- (interactive)
- (caml-run-process-if-needed)
- (display-buffer inferior-caml-buffer-name)
- ; Added by Didier to move the point of inferior-caml to end of buffer
- (let ((buf (current-buffer))
- (caml-buf (get-buffer inferior-caml-buffer-name))
- (count 0))
- (while
- (and (< count 10)
- (not (equal (buffer-name (current-buffer))
- inferior-caml-buffer-name)))
- (next-multiframe-window)
- (setq count (+ count 1)))
- (if (equal (buffer-name (current-buffer))
- inferior-caml-buffer-name)
- (end-of-buffer))
- (while
- (> count 0)
- (previous-multiframe-window)
- (setq count (- count 1)))
- )
-)
-
-;; patched by Didier to move cursor after evaluation
-
-(defun inferior-caml-eval-region (start end)
- "Send the current region to the inferior Caml process."
- (interactive "r")
- (save-excursion (caml-run-process-if-needed))
- (save-excursion
- (goto-char end)
- (caml-skip-comments-backward)
- (comint-send-region inferior-caml-buffer-name start (point))
- ;; normally, ";;" are part of the region
- (if (and (>= (point) 2)
- (prog2 (backward-char 2) (looking-at ";;")))
- (comint-send-string inferior-caml-buffer-name "\n")
- (comint-send-string inferior-caml-buffer-name ";;\n"))
- ;; the user may not want to see the output buffer
- (if caml-display-when-eval
- (display-buffer inferior-caml-buffer-name t))))
-
-;; jump to errors produced by ocaml compiler
-
-(defun inferior-caml-goto-error (start end)
- "Jump to the location of the last error as indicated by inferior toplevel."
- (interactive "r")
- (let ((loc (+ start
- (save-excursion
- (set-buffer (get-buffer inferior-caml-buffer-name))
- (re-search-backward
- (concat comint-prompt-regexp
- "[ \t]*Characters[ \t]+\\([0-9]+\\)-[0-9]+:$"))
- (string-to-int (match-string 1))))))
- (goto-char loc)))
-
-
-;;; orgininal inf-caml.el ended here
-
-;; as eval-phrase, but ignores errors.
-
-(defun inferior-caml-just-eval-phrase (arg &optional min max)
- "Send the phrase containing the point to the CAML process.
-With prefix-arg send as many phrases as its numeric value,
-ignoring possible errors during evaluation.
-
-Optional arguments min max defines a region within which the phrase
-should lies."
- (interactive "p")
- (let ((beg))
- (while (> arg 0)
- (setq arg (- arg 1))
- (setq beg (caml-find-phrase min max))
- (caml-eval-region beg (point)))
- beg))
-
-(defvar caml-previous-output nil
- "tells the beginning of output in the shell-output buffer, so that the
-output can be retreived later, asynchronously.")
-
-;; enriched version of eval-phrase, to repport errors.
-
-(defun inferior-caml-eval-phrase (arg &optional min max)
- "Send the phrase containing the point to the CAML process.
-With prefix-arg send as many phrases as its numeric value,
-If an error occurs during evalutaion, stop at this phrase and
-repport the error.
-
-Return nil if noerror and position of error if any.
-
-If arg's numeric value is zero or negative, evaluate the current phrase
-or as many as prefix arg, ignoring evaluation errors.
-This allows to jump other erroneous phrases.
-
-Optional arguments min max defines a region within which the phrase
-should lies."
- (interactive "p")
- (if (save-excursion (caml-run-process-if-needed))
- (progn
- (setq inferior-caml-output nil)
- (caml-wait-output 10 1)))
- (if (< arg 1) (inferior-caml-just-eval-phrase (max 1 (- 0 arg)) min max)
- (let ((proc (get-buffer-process inferior-caml-buffer-name))
- (buf (current-buffer))
- previous-output orig beg end err)
- (save-window-excursion
- (while (and (> arg 0) (not err))
- (setq previous-output (marker-position (process-mark proc)))
- (setq caml-previous-output previous-output)
- (setq inferior-caml-output nil)
- (setq orig (inferior-caml-just-eval-phrase 1 min max))
- (caml-wait-output)
- (switch-to-buffer inferior-caml-buffer-name nil)
- (goto-char previous-output)
- (cond ((re-search-forward
- " *Characters \\([01-9][01-9]*\\)-\\([1-9][01-9]*\\):\n[^W]"
- (point-max) t)
- (setq beg (string-to-int (caml-match-string 1)))
- (setq end (string-to-int (caml-match-string 2)))
- (switch-to-buffer buf)
- (goto-char orig)
- (forward-byte end)
- (setq end (point))
- (goto-char orig)
- (forward-byte beg)
- (setq beg (point))
- (setq err beg)
- )
- ((looking-at
- "Toplevel input:\n[>]\\([^\n]*\\)\n[>]\\(\\( *\\)^*\\)\n")
- (let ((expr (caml-match-string 1))
- (column (- (match-end 3) (match-beginning 3)))
- (width (- (match-end 2) (match-end 3))))
- (if (string-match "^\\(.*\\)[<]EOF[>]$" expr)
- (setq expr (substring expr (match-beginning 1) (match-end 1))))
- (switch-to-buffer buf)
- (re-search-backward
- (concat "^" (regexp-quote expr) "$")
- (- orig 10))
- (goto-char (+ (match-beginning 0) column))
- (setq end (+ (point) width)))
- (setq err beg))
- ((looking-at
- "Toplevel input:\n>[.]*\\([^.].*\n\\)\\([>].*\n\\)*[>]\\(.*[^.]\\)[.]*\n")
- (let* ((e1 (caml-match-string 1))
- (e2 (caml-match-string 3))
- (expr
- (concat
- (regexp-quote e1) "\\(.*\n\\)*" (regexp-quote e2))))
- (switch-to-buffer buf)
- (re-search-backward expr orig 'move)
- (setq end (match-end 0)))
- (setq err beg))
- (t
- (switch-to-buffer buf)))
- (setq arg (- arg 1))
- )
- (pop-to-buffer inferior-caml-buffer-name)
- (if err
- (goto-char (point-max))
- (goto-char previous-output)
- (goto-char (point-max)))
- (pop-to-buffer buf))
- (if err (progn (beep) (caml-overlay-region (point) end))
- (if inferior-caml-output
- (message "No error")
- (message "No output yet...")
- ))
- err)))
-
-(defun caml-overlay-region (beg end &optional wait)
- (interactive "%r")
- (cond ((fboundp 'make-overlay)
- (if caml-error-overlay ()
- (setq caml-error-overlay (make-overlay 1 1))
- (overlay-put caml-error-overlay 'face 'region))
- (unwind-protect
- (progn
- (move-overlay caml-error-overlay beg end (current-buffer))
- (beep) (if wait (read-event) (caml-sit-for 60)))
- (delete-overlay caml-error-overlay)))))
-
-;; wait some amount for ouput, that is, until inferior-caml-output is set
-;; to true. Hence, interleaves sitting for shorts delays and checking the
-;; flag. Give up after some time. Typing into the source buffer will cancel
-;; waiting, i.e. may report 'No result yet'
-
-(defun caml-wait-output (&optional before after)
- (let ((c 1))
- (caml-sit-for 0 (or before 1))
- (let ((c 1))
- (while (and (not inferior-caml-output) (< c 99) (caml-sit-for 0 c t))
- (setq c (+ c 1))))
- (caml-sit-for (or after 0) 1)))
-
-;; To insert the last output from caml at point
-(defun caml-insert-last-output ()
- "Insert the result of the evaluation of previous phrase"
- (interactive)
- (let ((pos (process-mark (get-buffer-process inferior-caml-buffer-name))))
- (insert-buffer-substring inferior-caml-buffer-name
- caml-previous-output (- pos 2))))
-
-;; additional bindings
-
-;(let ((map (lookup-key caml-mode-map [menu-bar caml])))
-; (define-key map [indent-buffer] '("Indent buffer" . caml-indent-buffer))
-; (define-key map [eval-buffer] '("Eval buffer" . caml-eval-buffer))
-;)
-;(define-key caml-mode-map "\C-c\C-b" 'caml-eval-buffer)
-
-
-(provide 'inf-caml)
diff --git a/emacs/ocamltags.in b/emacs/ocamltags.in
deleted file mode 100644
index a67565394e..0000000000
--- a/emacs/ocamltags.in
+++ /dev/null
@@ -1,128 +0,0 @@
-":" ; @EMACS@ -batch -l $0 "$@" ; status=$? ; : '--*-Emacs-Lisp-*--' <<';'
-
-;; Copyright (C) 1998 Ian Zimmerman <itz@transbay.net>
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2 of the
-;; License, or (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; General Public License for more details.
-;; $Id$
-
-(require 'caml)
-
-;;itz Fri Oct 30 13:08:37 PST 1998 support for creating TAGS files
-;; itz Sun Dec 27 10:26:08 PST 1998 adapted very slightly from
-;; Jacques' caml-create-index-function
-(defun caml-tags-create-index-function ()
- (let (all-alist index)
- (goto-char (point-max))
- ;; collect definitions
- (while (caml-prev-index-position-function)
- (if (looking-at "[ \t]*val") nil
- (setq index (cons (caml-match-string 5) (point)))
- (setq all-alist (cons index all-alist))))
- all-alist))
-
-(defun caml-tags-file (filename)
- (let* ((output-buffer (current-buffer))
- (basename (file-name-nondirectory filename))
- (backpatch (prog2
- (insert " \n" basename)
- (point))))
- (find-file-read-only filename)
- (caml-mode)
- (let ((all-alist (caml-tags-create-index-function))
- (done nil)
- (current-line 1)
- (last-point (point-min)))
- (mapcar
- (lambda (pair)
- (let ((tag-name (car pair)) (tag-pos (cdr pair)))
- (goto-char tag-pos)
- (setq current-line
- (+ current-line (count-lines last-point (point))))
- (setq last-point (point))
- (end-of-line 1)
- (let ((output-line (format "%s%s%d,%d\n"
- (buffer-substring last-point (point))
- tag-name current-line tag-pos)))
- (save-excursion
- (set-buffer output-buffer)
- (insert output-line)))))
- all-alist))
- (kill-buffer (current-buffer))
- (set-buffer output-buffer)
- (let ((index-size (- (point) backpatch)))
- (goto-char backpatch)
- (insert "," (int-to-string index-size) "\n")
- (goto-char (point-max)))))
-
-(defsubst prefix-p (prefix str)
- (and (<= (length prefix) (length str))
- (string= prefix (substring str 0 (length prefix)))))
-
-(defsubst eat-args (n)
- (setq command-line-args-left (nthcdr n command-line-args-left)))
-
-;; see Emacs source file print.c
-(defun print-error-message (data)
- (let ((errname (car data)) errmsg is-file-error tail i)
- (if (eq errname 'error)
- (progn
- (setq data (cdr data))
- (if (not (consp data)) (setq data nil))
- (setq errmsg (car data))
- (setq is-file-error nil))
- (setq errmsg (get errname 'error-message))
- (setq is-file-error (memq 'file-error (get errname 'error-conditions))))
- (setq tail (cdr-safe data))
- (if (and is-file-error tail)
- (setq errmsg (car tail) tail (cdr tail)))
- (if (stringp errmsg) (princ errmsg)
- (princ "peculiar error"))
- (setq i 0)
- (while (consp tail)
- (princ (if (eq i 0) ": " ", "))
- (if is-file-error (princ (car tail))
- (prin1 (car tail)))
- (setq tail (cdr tail) i (1+ i)))
- (princ "\n")))
-
-
-(setq gc-cons-threshold 1000000)
-
-(setq output-file "TAGS")
-(setq append-flag nil)
-(setq status 0)
-
-(condition-case foobar
- (progn
- (while (and command-line-args-left
- (let ((arg (car command-line-args-left)))
- (cond
- ((prefix-p arg "-output-file")
- (setq output-file (nth 1 command-line-args-left))
- (eat-args 2) t)
- ((prefix-p arg "-append")
- (setq append-flag t)
- (eat-args 1) t)
- (t nil)))))
-
- (find-file output-file)
- (if append-flag (goto-char (point-max))
- (erase-buffer))
- (while command-line-args-left
- (caml-tags-file (car command-line-args-left))
- (setq command-line-args-left (cdr command-line-args-left)))
- (save-buffer 0))
- (error (setq status 1) (print-error-message foobar)))
-
-(kill-emacs status)
-
-;
-
-":" ; exit $status
diff --git a/lex/.cvsignore b/lex/.cvsignore
deleted file mode 100644
index 9f4f308da4..0000000000
--- a/lex/.cvsignore
+++ /dev/null
@@ -1,6 +0,0 @@
-parser.ml
-parser.mli
-lexer.ml
-ocamllex
-ocamllex.opt
-parser.output
diff --git a/lex/.depend b/lex/.depend
deleted file mode 100644
index b21bfd9361..0000000000
--- a/lex/.depend
+++ /dev/null
@@ -1,32 +0,0 @@
-common.cmi: lexgen.cmi syntax.cmi
-compact.cmi: lexgen.cmi
-lexer.cmi: parser.cmi
-lexgen.cmi: syntax.cmi
-output.cmi: common.cmi compact.cmi lexgen.cmi syntax.cmi
-outputbis.cmi: common.cmi lexgen.cmi syntax.cmi
-parser.cmi: syntax.cmi
-syntax.cmi: cset.cmi
-common.cmo: lexgen.cmi syntax.cmi common.cmi
-common.cmx: lexgen.cmx syntax.cmx common.cmi
-compact.cmo: lexgen.cmi table.cmi compact.cmi
-compact.cmx: lexgen.cmx table.cmx compact.cmi
-cset.cmo: cset.cmi
-cset.cmx: cset.cmi
-lexer.cmo: parser.cmi syntax.cmi lexer.cmi
-lexer.cmx: parser.cmx syntax.cmx lexer.cmi
-lexgen.cmo: cset.cmi syntax.cmi table.cmi lexgen.cmi
-lexgen.cmx: cset.cmx syntax.cmx table.cmx lexgen.cmi
-main.cmo: common.cmi compact.cmi lexer.cmi lexgen.cmi output.cmi \
- outputbis.cmi parser.cmi syntax.cmi
-main.cmx: common.cmx compact.cmx lexer.cmx lexgen.cmx output.cmx \
- outputbis.cmx parser.cmx syntax.cmx
-output.cmo: common.cmi compact.cmi lexgen.cmi syntax.cmi output.cmi
-output.cmx: common.cmx compact.cmx lexgen.cmx syntax.cmx output.cmi
-outputbis.cmo: common.cmi lexgen.cmi syntax.cmi outputbis.cmi
-outputbis.cmx: common.cmx lexgen.cmx syntax.cmx outputbis.cmi
-parser.cmo: cset.cmi syntax.cmi parser.cmi
-parser.cmx: cset.cmx syntax.cmx parser.cmi
-syntax.cmo: cset.cmi syntax.cmi
-syntax.cmx: cset.cmx syntax.cmi
-table.cmo: table.cmi
-table.cmx: table.cmi
diff --git a/lex/Makefile b/lex/Makefile
deleted file mode 100644
index 2e593133f2..0000000000
--- a/lex/Makefile
+++ /dev/null
@@ -1,71 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-# The lexer generator
-CAMLC=../boot/ocamlrun ../boot/ocamlc -nostdlib -I ../boot
-CAMLOPT=../boot/ocamlrun ../ocamlopt -nostdlib -I ../stdlib
-COMPFLAGS=-warn-error A
-CAMLYACC=../boot/ocamlyacc
-YACCFLAGS=-v
-CAMLLEX=../boot/ocamlrun ../boot/ocamllex
-CAMLDEP=../boot/ocamlrun ../tools/ocamldep
-
-
-OBJS=cset.cmo syntax.cmo parser.cmo lexer.cmo table.cmo lexgen.cmo compact.cmo common.cmo output.cmo outputbis.cmo main.cmo
-
-all: ocamllex
-allopt: ocamllex.opt
-
-ocamllex: $(OBJS)
- $(CAMLC) $(LINKFLAGS) -o ocamllex $(OBJS)
-
-ocamllex.opt: $(OBJS:.cmo=.cmx)
- $(CAMLOPT) -o ocamllex.opt $(OBJS:.cmo=.cmx)
-
-clean::
- rm -f ocamllex ocamllex.opt
- rm -f *.cmo *.cmi *.cmx *.o *~
-
-parser.ml parser.mli: parser.mly
- $(CAMLYACC) $(YACCFLAGS) parser.mly
-
-clean::
- rm -f parser.ml parser.mli parser.output
-
-beforedepend:: parser.ml parser.mli
-
-lexer.ml: lexer.mll
- $(CAMLLEX) lexer.mll
-
-clean::
- rm -f lexer.ml
-
-beforedepend:: lexer.ml
-
-.SUFFIXES:
-.SUFFIXES: .ml .cmo .mli .cmi .cmx
-
-.ml.cmo:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.mli.cmi:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-depend: beforedepend
- $(CAMLDEP) *.mli *.ml > .depend
-
-include .depend
diff --git a/lex/Makefile.Mac b/lex/Makefile.Mac
deleted file mode 100644
index 4640011d08..0000000000
--- a/lex/Makefile.Mac
+++ /dev/null
@@ -1,63 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-# The lexer generator
-
-CAMLC = ::boot:ocamlrun ::boot:ocamlc -I ::boot:
-COMPFLAGS =
-LINKFLAGS =
-CAMLYACC = ::boot:ocamlyacc
-YACCFLAGS =
-CAMLLEX = ::boot:ocamlrun ::boot:ocamllex
-CAMLDEP = ::boot:ocamlrun ::tools:ocamldep
-DEPFLAGS =
-
-OBJS = parser.cmo lexer.cmo lexgen.cmo compact.cmo output.cmo main.cmo
-
-all Ä ocamllex
-
-ocamllex Ä {OBJS}
- {CAMLC} {LINKFLAGS} -o ocamllex {OBJS}
-
-clean ÄÄ
- delete -i ocamllex
- delete -i Å.cm[io] || set status 0
-
-parser.mli Ä parser.ml
- echo -n
-
-parser.ml Ä parser.mly
- {CAMLYACC} {YACCFLAGS} parser.mly
-
-clean ÄÄ
- delete -i parser.ml parser.mli
-
-beforedepend ÄÄ parser.ml parser.mli
-
-lexer.ml Ä lexer.mll
- {CAMLLEX} lexer.mll
-
-clean ÄÄ
- delete -i lexer.ml
-
-beforedepend ÄÄ lexer.ml
-
-.cmo Ä .ml
- {CAMLC} -c {COMPFLAGS} {default}.ml
-
-.cmi Ä .mli
- {CAMLC} -c {COMPFLAGS} {default}.mli
-
-depend Ä beforedepend
- {CAMLDEP} Å.mli Å.ml > Makefile.Mac.depend
diff --git a/lex/Makefile.Mac.depend b/lex/Makefile.Mac.depend
deleted file mode 100644
index 73e2f7f32e..0000000000
--- a/lex/Makefile.Mac.depend
+++ /dev/null
@@ -1,17 +0,0 @@
-compact.cmiÄ lexgen.cmi
-lexer.cmiÄ parser.cmi
-lexgen.cmiÄ syntax.cmi
-output.cmiÄ compact.cmi lexgen.cmi syntax.cmi
-parser.cmiÄ syntax.cmi
-compact.cmoÄ lexgen.cmi compact.cmi
-compact.cmxÄ lexgen.cmx compact.cmi
-lexer.cmoÄ parser.cmi syntax.cmi lexer.cmi
-lexer.cmxÄ parser.cmx syntax.cmi lexer.cmi
-lexgen.cmoÄ syntax.cmi lexgen.cmi
-lexgen.cmxÄ syntax.cmi lexgen.cmi
-main.cmoÄ compact.cmi lexer.cmi lexgen.cmi output.cmi parser.cmi syntax.cmi
-main.cmxÄ compact.cmx lexer.cmx lexgen.cmx output.cmx parser.cmx syntax.cmi
-output.cmoÄ compact.cmi lexgen.cmi syntax.cmi output.cmi
-output.cmxÄ compact.cmx lexgen.cmx syntax.cmi output.cmi
-parser.cmoÄ syntax.cmi parser.cmi
-parser.cmxÄ syntax.cmi parser.cmi
diff --git a/lex/Makefile.nt b/lex/Makefile.nt
deleted file mode 100644
index ab2a42a109..0000000000
--- a/lex/Makefile.nt
+++ /dev/null
@@ -1,73 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-# The lexer generator
-
-CAMLC=../boot/ocamlrun ../boot/ocamlc -I ../boot
-CAMLOPT=../boot/ocamlrun ../ocamlopt -I ../stdlib
-COMPFLAGS=-warn-error A
-LINKFLAGS=
-CAMLYACC=../boot/ocamlyacc
-YACCFLAGS=-v
-CAMLLEX=../boot/ocamlrun ../boot/ocamllex
-CAMLDEP=../boot/ocamlrun ../tools/ocamldep
-DEPFLAGS=
-
-OBJS=cset.cmo syntax.cmo parser.cmo lexer.cmo table.cmo lexgen.cmo compact.cmo common.cmo output.cmo outputbis.cmo main.cmo
-
-all: ocamllex syntax.cmo
-allopt: ocamllex.opt
-
-ocamllex: $(OBJS)
- $(CAMLC) $(LINKFLAGS) -o ocamllex $(OBJS)
-
-ocamllex.opt: $(OBJS:.cmo=.cmx)
- $(CAMLOPT) -o ocamllex.opt $(OBJS:.cmo=.cmx)
-
-clean::
- rm -f ocamllex ocamllex.opt
- rm -f *.cmo *.cmi *.cmx *.$(O)
-
-parser.ml parser.mli: parser.mly
- $(CAMLYACC) $(YACCFLAGS) parser.mly
-
-clean::
- rm -f parser.ml parser.mli
-
-beforedepend:: parser.ml parser.mli
-
-lexer.ml: lexer.mll
- $(CAMLLEX) lexer.mll
-
-clean::
- rm -f lexer.ml
-
-beforedepend:: lexer.ml
-
-.SUFFIXES:
-.SUFFIXES: .ml .cmo .mli .cmi .cmx
-
-.ml.cmo:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.mli.cmi:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-depend: beforedepend
- $(CAMLDEP) *.mli *.ml > .depend
-
-include .depend
diff --git a/lex/common.ml b/lex/common.ml
deleted file mode 100644
index f56e7a869d..0000000000
--- a/lex/common.ml
+++ /dev/null
@@ -1,153 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Luc Maranget, projet Moscova, *)
-(* INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-open Printf
-open Syntax
-open Lexgen
-
-
-(* To copy the ML code fragments *)
-
-type line_tracker = {
- file : string;
- oc : out_channel;
- ic : in_channel;
- mutable cur_line : int;
-};;
-
-let open_tracker file oc = {
- file = file;
- oc = oc;
- ic = open_in_bin file;
- cur_line = 1;
-};;
-
-let close_tracker tr = close_in_noerr tr.ic;;
-
-let update_tracker tr =
- fprintf tr.oc "\n";
- flush tr.oc;
- let cr_seen = ref false in
- try while true do
- match input_char tr.ic with
- | '\010' when not !cr_seen -> tr.cur_line <- tr.cur_line + 1;
- | '\013' -> cr_seen := true; tr.cur_line <- tr.cur_line + 1;
- | _ -> cr_seen := false;
- done with End_of_file ->
- fprintf tr.oc "# %d \"%s\"\n" (tr.cur_line+1) tr.file;
-;;
-
-let copy_buffer = String.create 1024
-
-let copy_chars_unix ic oc start stop =
- let n = ref (stop - start) in
- while !n > 0 do
- let m = input ic copy_buffer 0 (min !n 1024) in
- output oc copy_buffer 0 m;
- n := !n - m
- done
-
-let copy_chars_win32 ic oc start stop =
- for i = start to stop - 1 do
- let c = input_char ic in
- if c <> '\r' then output_char oc c
- done
-
-let copy_chars =
- match Sys.os_type with
- "Win32" | "Cygwin" -> copy_chars_win32
- | _ -> copy_chars_unix
-
-let copy_chunk sourcefile ic oc trl loc add_parens =
- if loc.start_pos < loc.end_pos || add_parens then begin
- fprintf oc "# %d \"%s\"\n" loc.start_line sourcefile;
- if add_parens then begin
- for i = 1 to loc.start_col - 1 do output_char oc ' ' done;
- output_char oc '(';
- end else begin
- for i = 1 to loc.start_col do output_char oc ' ' done;
- end;
- seek_in ic loc.start_pos;
- copy_chars ic oc loc.start_pos loc.end_pos;
- if add_parens then output_char oc ')';
- update_tracker trl;
- end
-
-(* Various memory actions *)
-
-let output_mem_access oc i = fprintf oc "lexbuf.Lexing.lex_mem.(%d)" i
-
-let output_memory_actions pref oc = function
- | [] -> ()
- | mvs ->
- output_string oc "(* " ;
- fprintf oc "L=%d " (List.length mvs) ;
- List.iter
- (fun mv -> match mv with
- | Copy (tgt, src) ->
- fprintf oc "[%d] <- [%d] ;" tgt src
- | Set tgt ->
- fprintf oc "[%d] <- p ; " tgt)
- mvs ;
- output_string oc " *)\n" ;
- List.iter
- (fun mv -> match mv with
- | Copy (tgt, src) ->
- fprintf oc
- "%s%a <- %a ;\n"
- pref output_mem_access tgt output_mem_access src
- | Set tgt ->
- fprintf oc "%s%a <- lexbuf.Lexing.lex_curr_pos ;\n"
- pref output_mem_access tgt)
- mvs
-
-let output_base_mem oc = function
- | Mem i -> output_mem_access oc i
- | Start -> fprintf oc "lexbuf.Lexing.lex_start_pos"
- | End -> fprintf oc "lexbuf.Lexing.lex_curr_pos"
-
-let output_tag_access oc = function
- | Sum (a,0) ->
- output_base_mem oc a
- | Sum (a,i) ->
- fprintf oc "(%a + %d)" output_base_mem a i
-
-let output_env oc env =
- let pref = ref "let" in
- match env with
- | [] -> ()
- | _ ->
- List.iter
- (fun (x,v) ->
- begin match v with
- | Ident_string (o,nstart,nend) ->
- fprintf oc
- "\n %s %s = Lexing.sub_lexeme%s lexbuf %a %a"
- !pref x (if o then "_opt" else "")
- output_tag_access nstart output_tag_access nend
- | Ident_char (o,nstart) ->
- fprintf oc
- "\n %s %s = Lexing.sub_lexeme_char%s lexbuf %a"
- !pref x (if o then "_opt" else "")
- output_tag_access nstart
- end ;
- pref := "and")
- env ;
- fprintf oc " in\n"
-
-(* Output the user arguments *)
-let output_args oc args =
- List.iter (fun x -> (output_string oc x; output_char oc ' ')) args
-
-(* quiet flag *)
-let quiet_mode = ref false;;
diff --git a/lex/common.mli b/lex/common.mli
deleted file mode 100644
index 4210d21d88..0000000000
--- a/lex/common.mli
+++ /dev/null
@@ -1,25 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Damien Doligez, projet Moscova, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-type line_tracker;;
-val open_tracker : string -> out_channel -> line_tracker
-val close_tracker : line_tracker -> unit
-val copy_chunk :
- string ->
- in_channel -> out_channel -> line_tracker -> Syntax.location -> bool -> unit
-val output_mem_access : out_channel -> int -> unit
-val output_memory_actions :
- string -> out_channel -> Lexgen.memory_action list -> unit
-val output_env : out_channel -> (string * Lexgen.ident_info) list -> unit
-val output_args : out_channel -> string list -> unit
-
-val quiet_mode : bool ref;;
diff --git a/lex/compact.ml b/lex/compact.ml
deleted file mode 100644
index 9475ab6e57..0000000000
--- a/lex/compact.ml
+++ /dev/null
@@ -1,234 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Compaction of an automata *)
-
-open Lexgen
-
-(* Code for memory actions *)
-let code = Table.create 0
-
-(* instructions are 2 8-bits integers, a 0xff byte means return *)
-
-let emit_int i = Table.emit code i
-
-let ins_mem i c = match i with
- | Copy (dst, src) -> dst::src::c
- | Set dst -> dst::0xff::c
-
-
-let ins_tag i c = match i with
- | SetTag (dst, src) -> dst::src::c
- | EraseTag dst -> dst::0xff::c
-
-
-let do_emit_code c =
- let r = Table.size code in
- List.iter emit_int c ;
- emit_int 0xff ;
- r
-
-let memory = Hashtbl.create 101
-
-let mem_emit_code c =
- try Hashtbl.find memory c with
- | Not_found ->
- let r = do_emit_code c in
- Hashtbl.add memory c r ;
- r
-
-(* Code address 0 is the empty code (ie do nothing) *)
-let _ = mem_emit_code []
-
-let emit_tag_code c = mem_emit_code (List.fold_right ins_tag c [])
-and emit_mem_code c =mem_emit_code (List.fold_right ins_mem c [])
-
-(*******************************************)
-(* Compact the transition and check arrays *)
-(*******************************************)
-
-
-(* Determine the integer occurring most frequently in an array *)
-
-let most_frequent_elt v =
- let frequencies = Hashtbl.create 17 in
- let max_freq = ref 0 in
- let most_freq = ref (v.(0)) in
- for i = 0 to Array.length v - 1 do
- let e = v.(i) in
- let r =
- try
- Hashtbl.find frequencies e
- with Not_found ->
- let r = ref 1 in Hashtbl.add frequencies e r; r in
- incr r;
- if !r > !max_freq then begin max_freq := !r; most_freq := e end
- done;
- !most_freq
-
-(* Transform an array into a list of (position, non-default element) *)
-
-let non_default_elements def v =
- let rec nondef i =
- if i >= Array.length v then [] else begin
- let e = v.(i) in
- if e = def then nondef(i+1) else (i, e) :: nondef(i+1)
- end in
- nondef 0
-
-
-type t_compact =
- {mutable c_trans : int array ;
- mutable c_check : int array ;
- mutable c_last_used : int ; }
-
-let create_compact () =
- { c_trans = Array.create 1024 0 ;
- c_check = Array.create 1024 (-1) ;
- c_last_used = 0 ; }
-
-let reset_compact c =
- c.c_trans <- Array.create 1024 0 ;
- c.c_check <- Array.create 1024 (-1) ;
- c.c_last_used <- 0
-
-(* One compacted table for transitions, one other for memory actions *)
-let trans = create_compact ()
-and moves = create_compact ()
-
-
-let grow_compact c =
- let old_trans = c.c_trans
- and old_check = c.c_check in
- let n = Array.length old_trans in
- c.c_trans <- Array.create (2*n) 0;
- Array.blit old_trans 0 c.c_trans 0 c.c_last_used;
- c.c_check <- Array.create (2*n) (-1);
- Array.blit old_check 0 c.c_check 0 c.c_last_used
-
-let do_pack state_num orig compact =
- let default = most_frequent_elt orig in
- let nondef = non_default_elements default orig in
- let rec pack_from b =
- while
- b + 257 > Array.length compact.c_trans
- do
- grow_compact compact
- done;
- let rec try_pack = function
- [] -> b
- | (pos, v) :: rem ->
- if compact.c_check.(b + pos) = -1 then
- try_pack rem
- else pack_from (b+1) in
- try_pack nondef in
- let base = pack_from 0 in
- List.iter
- (fun (pos, v) ->
- compact.c_trans.(base + pos) <- v;
- compact.c_check.(base + pos) <- state_num)
- nondef;
- if base + 257 > compact.c_last_used then
- compact.c_last_used <- base + 257;
- (base, default)
-
-let pack_moves state_num move_t =
- let move_v = Array.create 257 0
- and move_m = Array.create 257 0 in
- for i = 0 to 256 do
- let act,c = move_t.(i) in
- move_v.(i) <- (match act with Backtrack -> -1 | Goto n -> n) ;
- move_m.(i) <- emit_mem_code c
- done ;
- let pk_trans = do_pack state_num move_v trans
- and pk_moves = do_pack state_num move_m moves in
- pk_trans, pk_moves
-
-
-(* Build the tables *)
-
-type lex_tables =
- { tbl_base: int array; (* Perform / Shift *)
- tbl_backtrk: int array; (* No_remember / Remember *)
- tbl_default: int array; (* Default transition *)
- tbl_trans: int array; (* Transitions (compacted) *)
- tbl_check: int array; (* Check (compacted) *)
-(* code addresses are managed in a similar fashion as transitions *)
- tbl_base_code : int array; (* code ptr / base for Shift *)
- tbl_backtrk_code : int array; (* nothing / code when Remember *)
-(* moves to execute before transitions (compacted) *)
- tbl_default_code : int array;
- tbl_trans_code : int array;
- tbl_check_code : int array;
-(* byte code itself *)
- tbl_code: int array;}
-
-
-let compact_tables state_v =
- let n = Array.length state_v in
- let base = Array.create n 0
- and backtrk = Array.create n (-1)
- and default = Array.create n 0
- and base_code = Array.create n 0
- and backtrk_code = Array.create n 0
- and default_code = Array.create n 0 in
- for i = 0 to n - 1 do
- match state_v.(i) with
- | Perform (n,c) ->
- base.(i) <- -(n+1) ;
- base_code.(i) <- emit_tag_code c
- | Shift(trans, move) ->
- begin match trans with
- | No_remember -> ()
- | Remember (n,c) ->
- backtrk.(i) <- n ;
- backtrk_code.(i) <- emit_tag_code c
- end;
- let (b_trans, d_trans),(b_moves,d_moves) = pack_moves i move in
- base.(i) <- b_trans; default.(i) <- d_trans ;
- base_code.(i) <- b_moves; default_code.(i) <- d_moves ;
- done;
- let code = Table.trim code in
- let tables =
- if Array.length code > 1 then
- { tbl_base = base;
- tbl_backtrk = backtrk;
- tbl_default = default;
- tbl_trans = Array.sub trans.c_trans 0 trans.c_last_used;
- tbl_check = Array.sub trans.c_check 0 trans.c_last_used;
- tbl_base_code = base_code ;
- tbl_backtrk_code = backtrk_code;
- tbl_default_code = default_code;
- tbl_trans_code = Array.sub moves.c_trans 0 moves.c_last_used;
- tbl_check_code = Array.sub moves.c_check 0 moves.c_last_used;
- tbl_code = code}
- else (* when no memory moves, do not emit related tables *)
- { tbl_base = base;
- tbl_backtrk = backtrk;
- tbl_default = default;
- tbl_trans = Array.sub trans.c_trans 0 trans.c_last_used;
- tbl_check = Array.sub trans.c_check 0 trans.c_last_used;
- tbl_base_code = [||] ;
- tbl_backtrk_code = [||];
- tbl_default_code = [||];
- tbl_trans_code = [||];
- tbl_check_code = [||];
- tbl_code = [||]}
- in
- reset_compact trans ;
- reset_compact moves ;
- tables
-
-
-
diff --git a/lex/compact.mli b/lex/compact.mli
deleted file mode 100644
index e52dc7d2c8..0000000000
--- a/lex/compact.mli
+++ /dev/null
@@ -1,33 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Compaction of an automata *)
-type lex_tables =
- { tbl_base: int array; (* Perform / Shift *)
- tbl_backtrk: int array; (* No_remember / Remember *)
- tbl_default: int array; (* Default transition *)
- tbl_trans: int array; (* Transitions (compacted) *)
- tbl_check: int array; (* Check (compacted) *)
-(* code addresses are managed in a similar fashion as transitions *)
- tbl_base_code : int array; (* code ptr / base for Shift *)
- tbl_backtrk_code : int array; (* nothing / code when Remember *)
-(* moves to execute before transitions (compacted) *)
- tbl_default_code : int array;
- tbl_trans_code : int array;
- tbl_check_code : int array;
-(* byte code itself *)
- tbl_code: int array;}
-
-
-val compact_tables: Lexgen.automata array -> lex_tables
diff --git a/lex/cset.ml b/lex/cset.ml
deleted file mode 100644
index 84c2a77142..0000000000
--- a/lex/cset.ml
+++ /dev/null
@@ -1,94 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Luc Maranget, Jerome Vouillon projet Cristal, *)
-(* INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-type t = (int * int) list
-
-
-let empty = []
-let is_empty = function
- | [] -> true
- | _ -> false
-
-let singleton c = [c,c]
-
-let interval c1 c2 =
- if c1 <= c2 then [c1,c2]
- else [c2,c1]
-
-
-let rec union s1 s2 = match s1,s2 with
-| [],_ -> s2
-| _,[] -> s1
-| (c1,d1) as p1::r1, (c2,d2)::r2 ->
- if c1 > c2 then
- union s2 s1
- else begin (* c1 <= c2 *)
- if d1+1 < c2 then
- p1::union r1 s2
- else if d1 < d2 then
- union ((c1,d2)::r2) r1
- else
- union s1 r2
- end
-
-let rec inter l l' = match l, l' with
- _, [] -> []
- | [], _ -> []
- | (c1, c2)::r, (c1', c2')::r' ->
- if c2 < c1' then
- inter r l'
- else if c2' < c1 then
- inter l r'
- else if c2 < c2' then
- (max c1 c1', c2)::inter r l'
- else
- (max c1 c1', c2')::inter l r'
-
-let rec diff l l' = match l, l' with
- _, [] -> l
- | [], _ -> []
- | (c1, c2)::r, (c1', c2')::r' ->
- if c2 < c1' then
- (c1, c2)::diff r l'
- else if c2' < c1 then
- diff l r'
- else
- let r'' = if c2' < c2 then (c2' + 1, c2) :: r else r in
- if c1 < c1' then
- (c1, c1' - 1)::diff r'' r'
- else
- diff r'' r'
-
-
-let eof = singleton 256
-and all_chars = interval 0 255
-and all_chars_eof = interval 0 256
-
-let complement s = diff all_chars s
-
-let env_to_array env = match env with
-| [] -> assert false
-| (_,x)::rem ->
- let res = Array.create 257 x in
- List.iter
- (fun (c,y) ->
- List.iter
- (fun (i,j) ->
- for k=i to j do
- res.(k) <- y
- done)
- c)
- rem ;
- res
-
-
diff --git a/lex/cset.mli b/lex/cset.mli
deleted file mode 100644
index 0ebcac0e5f..0000000000
--- a/lex/cset.mli
+++ /dev/null
@@ -1,32 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Luc Maranget, Jerome Vouillon projet Cristal, *)
-(* INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* Set of characters encoded as list of intervals *)
-
-type t
-
-val empty : t
-val is_empty : t -> bool
-val all_chars : t
-val all_chars_eof : t
-val eof : t
-val singleton : int -> t
-val interval : int -> int -> t
-val union : t -> t -> t
-val inter : t -> t -> t
-val diff : t -> t -> t
-val complement : t -> t
-val env_to_array : (t * 'a) list -> 'a array
-
-
-
diff --git a/lex/lexer.mli b/lex/lexer.mli
deleted file mode 100644
index 569a5b266f..0000000000
--- a/lex/lexer.mli
+++ /dev/null
@@ -1,20 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-val main: Lexing.lexbuf -> Parser.token
-
-exception Lexical_error of string * int * int
-
-val line_num: int ref
-val line_start_pos: int ref
diff --git a/lex/lexer.mll b/lex/lexer.mll
deleted file mode 100644
index 5249ca8bc0..0000000000
--- a/lex/lexer.mll
+++ /dev/null
@@ -1,273 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* The lexical analyzer for lexer definitions. Bootstrapped! *)
-
-{
-open Syntax
-open Parser
-
-(* Auxiliaries for the lexical analyzer *)
-
-let brace_depth = ref 0
-and comment_depth = ref 0
-
-let in_pattern () = !brace_depth = 0 && !comment_depth = 0
-
-exception Lexical_error of string * int * int
-
-let string_buff = Buffer.create 256
-
-let reset_string_buffer () = Buffer.clear string_buff
-
-let store_string_char c = Buffer.add_char string_buff c
-
-let get_stored_string () = Buffer.contents string_buff
-
-let char_for_backslash = function
- 'n' -> '\n'
- | 't' -> '\t'
- | 'b' -> '\b'
- | 'r' -> '\r'
- | c -> c
-
-
-let line_num = ref 1
-let line_start_pos = ref 0
-
-let handle_lexical_error fn lexbuf =
- let line = !line_num
- and column = Lexing.lexeme_start lexbuf - !line_start_pos + 1 in
- try
- fn lexbuf
- with Lexical_error (msg, 0, 0) ->
- raise(Lexical_error(msg, line, column))
-
-let get_input_name () = Sys.argv.(Array.length Sys.argv - 1)
-
-let warning lexbuf msg =
- Printf.eprintf "ocamllex warning:\nFile \"%s\", line %d, character %d: %s.\n"
- (get_input_name ()) !line_num
- (Lexing.lexeme_start lexbuf - !line_start_pos+1) msg;
- flush stderr
-
-let decimal_code c d u =
- 100 * (Char.code c - 48) + 10 * (Char.code d - 48) + (Char.code u - 48)
-
-let char_for_hexadecimal_code d u =
- let d1 = Char.code d in
- let val1 = if d1 >= 97 then d1 - 87
- else if d1 >= 65 then d1 - 55
- else d1 - 48
- in
- let d2 = Char.code u in
- let val2 = if d2 >= 97 then d2 - 87
- else if d2 >= 65 then d2 - 55
- else d2 - 48
- in
- Char.chr (val1 * 16 + val2)
-
-}
-
-let identstart =
- ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255']
-let identbody =
- ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
-let backslash_escapes =
- ['\\' '"' '\'' 'n' 't' 'b' 'r']
-
-rule main = parse
- [' ' '\013' '\009' '\012' ] +
- { main lexbuf }
- | '\010'
- { line_start_pos := Lexing.lexeme_end lexbuf;
- incr line_num;
- main lexbuf }
- | "(*"
- { comment_depth := 1;
- handle_lexical_error comment lexbuf;
- main lexbuf }
- | '_' { Tunderscore }
- | identstart identbody *
- { match Lexing.lexeme lexbuf with
- "rule" -> Trule
- | "parse" -> Tparse
- | "shortest" -> Tparse_shortest
- | "and" -> Tand
- | "eof" -> Teof
- | "let" -> Tlet
- | "as" -> Tas
- | s -> Tident s }
- | '"'
- { reset_string_buffer();
- handle_lexical_error string lexbuf;
- Tstring(get_stored_string()) }
-(* note: ''' is a valid character literall (by contrast with the compiler) *)
- | "'" [^ '\\'] "'"
- { Tchar(Char.code(Lexing.lexeme_char lexbuf 1)) }
- | "'" '\\' backslash_escapes "'"
- { Tchar(Char.code(char_for_backslash (Lexing.lexeme_char lexbuf 2))) }
- | "'" '\\' (['0'-'9'] as c) (['0'-'9'] as d) (['0'-'9'] as u)"'"
- { let v = decimal_code c d u in
- if v > 255 then
- raise
- (Lexical_error
- (Printf.sprintf "illegal escape sequence \\%c%c%c" c d u,
- !line_num, Lexing.lexeme_start lexbuf - !line_start_pos+1))
- else
- Tchar v }
- | "'" '\\' 'x'
- (['0'-'9' 'a'-'f' 'A'-'F'] as d) (['0'-'9' 'a'-'f' 'A'-'F'] as u) "'"
- { Tchar(Char.code(char_for_hexadecimal_code d u)) }
- | "'" '\\' (_ as c)
- { raise
- (Lexical_error
- (Printf.sprintf "illegal escape sequence \\%c" c,
- !line_num, Lexing.lexeme_start lexbuf - !line_start_pos+1))
- }
- | '{'
- { let n1 = Lexing.lexeme_end lexbuf
- and l1 = !line_num
- and s1 = !line_start_pos in
- brace_depth := 1;
- let n2 = handle_lexical_error action lexbuf in
- Taction({start_pos = n1; end_pos = n2;
- start_line = l1; start_col = n1 - s1}) }
- | '=' { Tequal }
- | '|' { Tor }
- | '[' { Tlbracket }
- | ']' { Trbracket }
- | '*' { Tstar }
- | '?' { Tmaybe }
- | '+' { Tplus }
- | '(' { Tlparen }
- | ')' { Trparen }
- | '^' { Tcaret }
- | '-' { Tdash }
- | eof { Tend }
- | _
- { raise(Lexical_error
- ("illegal character " ^ String.escaped(Lexing.lexeme lexbuf),
- !line_num, Lexing.lexeme_start lexbuf - !line_start_pos+1)) }
-
-
-(* String parsing comes from the compiler lexer *)
-and string = parse
- '"'
- { () }
- | '\\' ("\010" | "\013" | "\013\010") [' ' '\009'] *
- { line_start_pos := Lexing.lexeme_end lexbuf;
- incr line_num;
- string lexbuf }
- | '\\' (backslash_escapes as c)
- { store_string_char(char_for_backslash c);
- string lexbuf }
- | '\\' (['0'-'9'] as c) (['0'-'9'] as d) (['0'-'9'] as u)
- { let v = decimal_code c d u in
- if in_pattern () && v > 255 then
- warning lexbuf
- (Printf.sprintf
- "illegal backslash escape in string: `\\%c%c%c'" c d u) ;
- store_string_char (Char.chr v);
- string lexbuf }
- | '\\' 'x' (['0'-'9' 'a'-'f' 'A'-'F'] as d) (['0'-'9' 'a'-'f' 'A'-'F'] as u)
- { store_string_char (char_for_hexadecimal_code d u) ;
- string lexbuf }
- | '\\' (_ as c)
- {if in_pattern () then
- warning lexbuf
- (Printf.sprintf "illegal backslash escape in string: `\\%c'" c) ;
- store_string_char '\\' ;
- store_string_char c ;
- string lexbuf }
- | eof
- { raise(Lexical_error("unterminated string", 0, 0)) }
- | '\010'
- { store_string_char '\010';
- line_start_pos := Lexing.lexeme_end lexbuf;
- incr line_num;
- string lexbuf }
- | _ as c
- { store_string_char c;
- string lexbuf }
-
-(*
- Lexers comment and action are quite similar,
- they should lex both strings and characters,
- in order not to be confused by what is inside then
-*)
-
-and comment = parse
- "(*"
- { incr comment_depth; comment lexbuf }
- | "*)"
- { decr comment_depth;
- if !comment_depth = 0 then () else comment lexbuf }
- | '"'
- { reset_string_buffer();
- string lexbuf;
- reset_string_buffer();
- comment lexbuf }
- | "'"
- { skip_char lexbuf ;
- comment lexbuf }
- | eof
- { raise(Lexical_error("unterminated comment", 0, 0)) }
- | '\010'
- { line_start_pos := Lexing.lexeme_end lexbuf;
- incr line_num;
- comment lexbuf }
- | _
- { comment lexbuf }
-
-and action = parse
- '{'
- { incr brace_depth;
- action lexbuf }
- | '}'
- { decr brace_depth;
- if !brace_depth = 0 then Lexing.lexeme_start lexbuf else action lexbuf }
- | '"'
- { reset_string_buffer();
- handle_lexical_error string lexbuf;
- reset_string_buffer();
- action lexbuf }
- | "'"
- { skip_char lexbuf ;
- action lexbuf }
- | "(*"
- { comment_depth := 1;
- comment lexbuf;
- action lexbuf }
- | eof
- { raise (Lexical_error("unterminated action", 0, 0)) }
- | '\010'
- { line_start_pos := Lexing.lexeme_end lexbuf;
- incr line_num;
- action lexbuf }
- | _
- { action lexbuf }
-
-and skip_char = parse
- | '\\'? '\010' "'"
- { line_start_pos := Lexing.lexeme_end lexbuf;
- incr line_num }
- | [^ '\\' '\''] "'" (* regular character *)
-(* one character and numeric escape sequences *)
- | '\\' _ "'"
- | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
- | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "'"
- {()}
-(* A dieu va ! *)
- | "" {()}
diff --git a/lex/lexgen.ml b/lex/lexgen.ml
deleted file mode 100644
index ccd82d95a0..0000000000
--- a/lex/lexgen.ml
+++ /dev/null
@@ -1,1174 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, *)
-(* Luc Maranget, projet Moscova, *)
-(* INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Compiling a lexer definition *)
-
-open Syntax
-open Printf
-
-exception Memory_overflow
-
-(* Deep abstract syntax for regular expressions *)
-
-type tag_info = {id : string ; start : bool ; action : int}
-
-type regexp =
- Empty
- | Chars of int * bool
- | Action of int
- | Tag of tag_info
- | Seq of regexp * regexp
- | Alt of regexp * regexp
- | Star of regexp
-
-type tag_base = Start | End | Mem of int
-type tag_addr = Sum of (tag_base * int)
-type ident_info =
- | Ident_string of bool * tag_addr * tag_addr
- | Ident_char of bool * tag_addr
-type t_env = (string * ident_info) list
-
-type ('args,'action) lexer_entry =
- { lex_name: string;
- lex_regexp: regexp;
- lex_mem_tags: int ;
- lex_actions: (int * t_env * 'action) list }
-
-
-type automata =
- Perform of int * tag_action list
- | Shift of automata_trans * (automata_move * memory_action list) array
-
-and automata_trans =
- No_remember
- | Remember of int * tag_action list
-
-and automata_move =
- Backtrack
- | Goto of int
-
-and memory_action =
- | Copy of int * int
- | Set of int
-
-and tag_action = SetTag of int * int | EraseTag of int
-
-(* Representation of entry points *)
-
-type ('args,'action) automata_entry =
- { auto_name: string;
- auto_args: 'args ;
- auto_mem_size : int ;
- auto_initial_state: int * memory_action list;
- auto_actions: (int * t_env * 'action) list }
-
-
-(* A lot of sets and map structures *)
-
-module Ints = Set.Make(struct type t = int let compare = compare end)
-
-module Tags = Set.Make(struct type t = tag_info let compare = compare end)
-
-module TagMap =
- Map.Make (struct type t = tag_info let compare = compare end)
-
-module StringSet =
- Set.Make (struct type t = string let compare = Pervasives.compare end)
-module StringMap =
- Map.Make (struct type t = string let compare = Pervasives.compare end)
-
-(*********************)
-(* Variable cleaning *)
-(*********************)
-
-(* Silently eliminate nested variables *)
-
-let rec do_remove_nested to_remove = function
- | Bind (e,x) ->
- if StringSet.mem x to_remove then
- do_remove_nested to_remove e
- else
- Bind (do_remove_nested (StringSet.add x to_remove) e, x)
- | Epsilon|Eof|Characters _ as e -> e
- | Sequence (e1, e2) ->
- Sequence
- (do_remove_nested to_remove e1, do_remove_nested to_remove e2)
- | Alternative (e1, e2) ->
- Alternative
- (do_remove_nested to_remove e1, do_remove_nested to_remove e2)
- | Repetition e ->
- Repetition (do_remove_nested to_remove e)
-
-let remove_nested_as e = do_remove_nested StringSet.empty e
-
-(*********************)
-(* Variable analysis *)
-(*********************)
-
-(*
- Optional variables.
- A variable is optional when matching of regexp does not
- implies it binds.
- The typical case is:
- ("" | 'a' as x) -> optional
- ("" as x | 'a' as x) -> non-optional
-*)
-
-let stringset_delta s1 s2 =
- StringSet.union
- (StringSet.diff s1 s2)
- (StringSet.diff s2 s1)
-
-let rec find_all_vars = function
- | Characters _|Epsilon|Eof ->
- StringSet.empty
- | Bind (e,x) ->
- StringSet.add x (find_all_vars e)
- | Sequence (e1,e2)|Alternative (e1,e2) ->
- StringSet.union (find_all_vars e1) (find_all_vars e2)
- | Repetition e -> find_all_vars e
-
-
-let rec do_find_opt = function
- | Characters _|Epsilon|Eof -> StringSet.empty, StringSet.empty
- | Bind (e,x) ->
- let opt,all = do_find_opt e in
- opt, StringSet.add x all
- | Sequence (e1,e2) ->
- let opt1,all1 = do_find_opt e1
- and opt2,all2 = do_find_opt e2 in
- StringSet.union opt1 opt2, StringSet.union all1 all2
- | Alternative (e1,e2) ->
- let opt1,all1 = do_find_opt e1
- and opt2,all2 = do_find_opt e2 in
- StringSet.union
- (stringset_delta opt1 opt2)
- (stringset_delta all1 all2),
- StringSet.union all1 all2
- | Repetition e ->
- let r = find_all_vars e in
- r,r
-
-let find_optional e =
- let r,_ = do_find_opt e in r
-
-(*
- Double variables
- A variable is double when it can be bound more than once
- in a single matching
- The typical case is:
- (e1 as x) (e2 as x)
-
-*)
-
-let rec do_find_double = function
- | Characters _|Epsilon|Eof -> StringSet.empty, StringSet.empty
- | Bind (e,x) ->
- let dbl,all = do_find_double e in
- (if StringSet.mem x all then
- StringSet.add x dbl
- else
- dbl),
- StringSet.add x all
- | Sequence (e1,e2) ->
- let dbl1, all1 = do_find_double e1
- and dbl2, all2 = do_find_double e2 in
- StringSet.union
- (StringSet.inter all1 all2)
- (StringSet.union dbl1 dbl2),
- StringSet.union all1 all2
- | Alternative (e1,e2) ->
- let dbl1, all1 = do_find_double e1
- and dbl2, all2 = do_find_double e2 in
- StringSet.union dbl1 dbl2,
- StringSet.union all1 all2
- | Repetition e ->
- let r = find_all_vars e in
- r,r
-
-let find_double e = do_find_double e
-
-(*
- Type of variables:
- A variable is bound to a char when all its occurences
- bind a pattern of length 1.
- The typical case is:
- (_ as x) -> char
-*)
-
-let add_some x = function
- | Some i -> Some (x+i)
- | None -> None
-
-let add_some_some x y = match x,y with
-| Some i, Some j -> Some (i+j)
-| _,_ -> None
-
-let rec do_find_chars sz = function
- | Epsilon|Eof -> StringSet.empty, StringSet.empty, sz
- | Characters _ -> StringSet.empty, StringSet.empty, add_some 1 sz
- | Bind (e,x) ->
- let c,s,e_sz = do_find_chars (Some 0) e in
- begin match e_sz with
- | Some 1 ->
- StringSet.add x c,s,add_some 1 sz
- | _ ->
- c, StringSet.add x s, add_some_some sz e_sz
- end
- | Sequence (e1,e2) ->
- let c1,s1,sz1 = do_find_chars sz e1 in
- let c2,s2,sz2 = do_find_chars sz1 e2 in
- StringSet.union c1 c2,
- StringSet.union s1 s2,
- sz2
- | Alternative (e1,e2) ->
- let c1,s1,sz1 = do_find_chars sz e1
- and c2,s2,sz2 = do_find_chars sz e2 in
- StringSet.union c1 c2,
- StringSet.union s1 s2,
- (if sz1 = sz2 then sz1 else None)
- | Repetition e -> do_find_chars None e
-
-
-
-let find_chars e =
- let c,s,_ = do_find_chars (Some 0) e in
- StringSet.diff c s
-
-(*******************************)
-(* From shallow to deep syntax *)
-(*******************************)
-
-let chars = ref ([] : Cset.t list)
-let chars_count = ref 0
-
-
-let rec encode_regexp char_vars act = function
- Epsilon -> Empty
- | Characters cl ->
- let n = !chars_count in
- chars := cl :: !chars;
- incr chars_count;
- Chars(n,false)
- | Eof ->
- let n = !chars_count in
- chars := Cset.eof :: !chars;
- incr chars_count;
- Chars(n,true)
- | Sequence(r1,r2) ->
- let r1 = encode_regexp char_vars act r1 in
- let r2 = encode_regexp char_vars act r2 in
- Seq (r1, r2)
- | Alternative(r1,r2) ->
- let r1 = encode_regexp char_vars act r1 in
- let r2 = encode_regexp char_vars act r2 in
- Alt(r1, r2)
- | Repetition r ->
- let r = encode_regexp char_vars act r in
- Star r
- | Bind (r,x) ->
- let r = encode_regexp char_vars act r in
- if StringSet.mem x char_vars then
- Seq (Tag {id=x ; start=true ; action=act},r)
- else
- Seq (Tag {id=x ; start=true ; action=act},
- Seq (r, Tag {id=x ; start=false ; action=act}))
-
-
-(* Optimisation,
- Static optimization :
- Replace tags by offsets relative to the beginning
- or end of matched string.
- Dynamic optimization:
- Replace some non-optional, non-double tags by offsets w.r.t
- a previous similar tag.
-*)
-
-let incr_pos = function
- | None -> None
- | Some i -> Some (i+1)
-
-let decr_pos = function
- | None -> None
- | Some i -> Some (i-1)
-
-
-let opt = true
-
-let mk_seq r1 r2 = match r1,r2 with
-| Empty,_ -> r2
-| _,Empty -> r1
-| _,_ -> Seq (r1,r2)
-
-let add_pos p i = match p with
-| Some (Sum (a,n)) -> Some (Sum (a,n+i))
-| None -> None
-
-let opt_regexp all_vars char_vars optional_vars double_vars r =
-
-(* From removed tags to their addresses *)
- let env = Hashtbl.create 17 in
-
-(* First static optimizations, from start position *)
- let rec size_forward pos = function
- | Empty|Chars (_,true)|Tag _ -> Some pos
- | Chars (_,false) -> Some (pos+1)
- | Seq (r1,r2) ->
- begin match size_forward pos r1 with
- | None -> None
- | Some pos -> size_forward pos r2
- end
- | Alt (r1,r2) ->
- let pos1 = size_forward pos r1
- and pos2 = size_forward pos r2 in
- if pos1=pos2 then pos1 else None
- | Star _ -> None
- | Action _ -> assert false in
-
- let rec simple_forward pos r = match r with
- | Tag n ->
- if StringSet.mem n.id double_vars then
- r,Some pos
- else begin
- Hashtbl.add env (n.id,n.start) (Sum (Start, pos)) ;
- Empty,Some pos
- end
- | Empty -> r, Some pos
- | Chars (_,is_eof) ->
- r,Some (if is_eof then pos else pos+1)
- | Seq (r1,r2) ->
- let r1,pos = simple_forward pos r1 in
- begin match pos with
- | None -> mk_seq r1 r2,None
- | Some pos ->
- let r2,pos = simple_forward pos r2 in
- mk_seq r1 r2,pos
- end
- | Alt (r1,r2) ->
- let pos1 = size_forward pos r1
- and pos2 = size_forward pos r2 in
- r,(if pos1=pos2 then pos1 else None)
- | Star _ -> r,None
- | Action _ -> assert false in
-
-(* Then static optimizations, from end position *)
- let rec size_backward pos = function
- | Empty|Chars (_,true)|Tag _ -> Some pos
- | Chars (_,false) -> Some (pos-1)
- | Seq (r1,r2) ->
- begin match size_backward pos r2 with
- | None -> None
- | Some pos -> size_backward pos r1
- end
- | Alt (r1,r2) ->
- let pos1 = size_backward pos r1
- and pos2 = size_backward pos r2 in
- if pos1=pos2 then pos1 else None
- | Star _ -> None
- | Action _ -> assert false in
-
-
- let rec simple_backward pos r = match r with
- | Tag n ->
- if StringSet.mem n.id double_vars then
- r,Some pos
- else begin
- Hashtbl.add env (n.id,n.start) (Sum (End, pos)) ;
- Empty,Some pos
- end
- | Empty -> r,Some pos
- | Chars (_,is_eof) ->
- r,Some (if is_eof then pos else pos-1)
- | Seq (r1,r2) ->
- let r2,pos = simple_backward pos r2 in
- begin match pos with
- | None -> mk_seq r1 r2,None
- | Some pos ->
- let r1,pos = simple_backward pos r1 in
- mk_seq r1 r2,pos
- end
- | Alt (r1,r2) ->
- let pos1 = size_backward pos r1
- and pos2 = size_backward pos r2 in
- r,(if pos1=pos2 then pos1 else None)
- | Star _ -> r,None
- | Action _ -> assert false in
-
- let r =
- if opt then
- let r,_ = simple_forward 0 r in
- let r,_ = simple_backward 0 r in
- r
- else
- r in
-
- let loc_count = ref 0 in
- let get_tag_addr t =
- try
- Hashtbl.find env t
- with
- | Not_found ->
- let n = !loc_count in
- incr loc_count ;
- Hashtbl.add env t (Sum (Mem n,0)) ;
- Sum (Mem n,0) in
-
- let rec alloc_exp pos r = match r with
- | Tag n ->
- if StringSet.mem n.id double_vars then
- r,pos
- else begin match pos with
- | Some a ->
- Hashtbl.add env (n.id,n.start) a ;
- Empty,pos
- | None ->
- let a = get_tag_addr (n.id,n.start) in
- r,Some a
- end
-
- | Empty -> r,pos
- | Chars (_,is_eof) -> r,(if is_eof then pos else add_pos pos 1)
- | Seq (r1,r2) ->
- let r1,pos = alloc_exp pos r1 in
- let r2,pos = alloc_exp pos r2 in
- mk_seq r1 r2,pos
- | Alt (_,_) ->
- let off = size_forward 0 r in
- begin match off with
- | Some i -> r,add_pos pos i
- | None -> r,None
- end
- | Star _ -> r,None
- | Action _ -> assert false in
-
- let r,_ = alloc_exp None r in
- let m =
- StringSet.fold
- (fun x r ->
- let v =
- if StringSet.mem x char_vars then
- Ident_char
- (StringSet.mem x optional_vars, get_tag_addr (x,true))
- else
- Ident_string
- (StringSet.mem x optional_vars,
- get_tag_addr (x,true),
- get_tag_addr (x,false)) in
- (x,v)::r)
- all_vars [] in
- m,r, !loc_count
-
-
-
-let encode_casedef casedef =
- let r =
- List.fold_left
- (fun (reg,actions,count,ntags) (expr, act) ->
- let expr = remove_nested_as expr in
- let char_vars = find_chars expr in
- let r = encode_regexp char_vars count expr
- and opt_vars = find_optional expr
- and double_vars,all_vars = find_double expr in
- let m,r,loc_ntags =
- opt_regexp all_vars char_vars opt_vars double_vars r in
- Alt(reg, Seq(r, Action count)),
- (count, m ,act) :: actions,
- (succ count),
- max loc_ntags ntags)
- (Empty, [], 0, 0)
- casedef in
- r
-
-let encode_lexdef def =
- chars := [];
- chars_count := 0;
- let entry_list =
- List.map
- (fun {name=entry_name ; args=args ; shortest=shortest ; clauses= casedef} ->
- let (re,actions,_,ntags) = encode_casedef casedef in
- { lex_name = entry_name;
- lex_regexp = re;
- lex_mem_tags = ntags ;
- lex_actions = List.rev actions },args,shortest)
- def in
- let chr = Array.of_list (List.rev !chars) in
- chars := [];
- (chr, entry_list)
-
-(* To generate directly a NFA from a regular expression.
- Confer Aho-Sethi-Ullman, dragon book, chap. 3
- Extension to tagged automata.
- Confer
- Ville Larikari
- ``NFAs with Tagged Transitions, their Conversion to Deterministic
- Automata and Application to Regular Expressions''.
- Symposium on String Processing and Information Retrieval (SPIRE 2000),
- http://kouli.iki.fi/~vlaurika/spire2000-tnfa.ps
-(See also)
- http://kouli.iki.fi/~vlaurika/regex-submatch.ps.gz
-*)
-
-type t_transition =
- OnChars of int
- | ToAction of int
-
-type transition = t_transition * Tags.t
-
-let compare_trans (t1,tags1) (t2,tags2) =
- match Pervasives.compare t1 t2 with
- | 0 -> Tags.compare tags1 tags2
- | r -> r
-
-
-module TransSet =
- Set.Make(struct type t = transition let compare = compare end)
-
-let rec nullable = function
- | Empty|Tag _ -> true
- | Chars (_,_)|Action _ -> false
- | Seq(r1,r2) -> nullable r1 && nullable r2
- | Alt(r1,r2) -> nullable r1 || nullable r2
- | Star r -> true
-
-let rec emptymatch = function
- | Empty | Chars (_,_) | Action _ -> Tags.empty
- | Tag t -> Tags.add t Tags.empty
- | Seq (r1,r2) -> Tags.union (emptymatch r1) (emptymatch r2)
- | Alt(r1,r2) ->
- if nullable r1 then
- emptymatch r1
- else
- emptymatch r2
- | Star r ->
- if nullable r then
- emptymatch r
- else
- Tags.empty
-
-let addtags transs tags =
- TransSet.fold
- (fun (t,tags_t) r -> TransSet.add (t, Tags.union tags tags_t) r)
- transs TransSet.empty
-
-
-let rec firstpos = function
- Empty|Tag _ -> TransSet.empty
- | Chars (pos,_) -> TransSet.add (OnChars pos,Tags.empty) TransSet.empty
- | Action act -> TransSet.add (ToAction act,Tags.empty) TransSet.empty
- | Seq(r1,r2) ->
- if nullable r1 then
- TransSet.union (firstpos r1) (addtags (firstpos r2) (emptymatch r1))
- else
- firstpos r1
- | Alt(r1,r2) -> TransSet.union (firstpos r1) (firstpos r2)
- | Star r -> firstpos r
-
-
-(* Berry-sethi followpos *)
-let followpos size entry_list =
- let v = Array.create size TransSet.empty in
- let rec fill s = function
- | Empty|Action _|Tag _ -> ()
- | Chars (n,_) -> v.(n) <- s
- | Alt (r1,r2) ->
- fill s r1 ; fill s r2
- | Seq (r1,r2) ->
- fill
- (if nullable r2 then
- TransSet.union (firstpos r2) (addtags s (emptymatch r2))
- else
- (firstpos r2))
- r1 ;
- fill s r2
- | Star r ->
- fill (TransSet.union (firstpos r) s) r in
- List.iter (fun (entry,_,_) -> fill TransSet.empty entry.lex_regexp) entry_list ;
- v
-
-(************************)
-(* The algorithm itself *)
-(************************)
-
-let no_action = max_int
-
-module StateSet =
- Set.Make (struct type t = t_transition let compare = Pervasives.compare end)
-
-
-module MemMap =
- Map.Make (struct type t = int let compare = Pervasives.compare end)
-
-type 'a dfa_state =
- {final : int * ('a * int TagMap.t) ;
- others : ('a * int TagMap.t) MemMap.t}
-
-(*
-let dtag oc t =
- fprintf oc "%s<%s>" t.id (if t.start then "s" else "e")
-
-let dmem_map dp ds m =
- MemMap.iter
- (fun k x ->
- eprintf "%d -> " k ; dp x ; ds ())
- m
-
-and dtag_map dp ds m =
- TagMap.iter
- (fun t x ->
- dtag stderr t ; eprintf " -> " ; dp x ; ds ())
- m
-
-let dstate {final=(act,(_,m)) ; others=o} =
- if act <> no_action then begin
- eprintf "final=%d " act ;
- dtag_map (fun x -> eprintf "%d" x) (fun () -> prerr_string " ,") m ;
- prerr_endline ""
- end ;
- dmem_map
- (fun (_,m) ->
- dtag_map (fun x -> eprintf "%d" x) (fun () -> prerr_string " ,") m)
- (fun () -> prerr_endline "")
- o
-*)
-
-let dfa_state_empty =
- {final=(no_action, (max_int,TagMap.empty)) ;
- others=MemMap.empty}
-
-and dfa_state_is_empty {final=(act,_) ; others=o} =
- act = no_action &&
- o = MemMap.empty
-
-
-(* A key is an abstraction on a dfa state,
- two states with the same key can be made the same by
- copying some memory cells into others *)
-
-
-module StateSetSet =
- Set.Make (struct type t = StateSet.t let compare = StateSet.compare end)
-
-type t_equiv = {tag:tag_info ; equiv:StateSetSet.t}
-
-module MemKey =
- Set.Make
- (struct
- type t = t_equiv
-
- let compare e1 e2 = match Pervasives.compare e1.tag e2.tag with
- | 0 -> StateSetSet.compare e1.equiv e2.equiv
- | r -> r
- end)
-
-type dfa_key = {kstate : StateSet.t ; kmem : MemKey.t}
-
-(* Map a state to its key *)
-let env_to_class m =
- let env1 =
- MemMap.fold
- (fun _ (tag,s) r ->
- try
- let ss = TagMap.find tag r in
- let r = TagMap.remove tag r in
- TagMap.add tag (StateSetSet.add s ss) r
- with
- | Not_found ->
- TagMap.add tag (StateSetSet.add s StateSetSet.empty) r)
- m TagMap.empty in
- TagMap.fold
- (fun tag ss r -> MemKey.add {tag=tag ; equiv=ss} r)
- env1 MemKey.empty
-
-
-(* trans is nfa_state, m is associated memory map *)
-let inverse_mem_map trans m r =
- TagMap.fold
- (fun tag addr r ->
- try
- let otag,s = MemMap.find addr r in
- assert (tag = otag) ;
- let r = MemMap.remove addr r in
- MemMap.add addr (tag,StateSet.add trans s) r
- with
- | Not_found ->
- MemMap.add addr (tag,StateSet.add trans StateSet.empty) r)
- m r
-
-let inverse_mem_map_other n (_,m) r = inverse_mem_map (OnChars n) m r
-
-let get_key {final=(act,(_,m_act)) ; others=o} =
- let env =
- MemMap.fold inverse_mem_map_other
- o
- (if act = no_action then MemMap.empty
- else inverse_mem_map (ToAction act) m_act MemMap.empty) in
- let state_key =
- MemMap.fold (fun n _ r -> StateSet.add (OnChars n) r) o
- (if act=no_action then StateSet.empty
- else StateSet.add (ToAction act) StateSet.empty) in
- let mem_key = env_to_class env in
- {kstate = state_key ; kmem = mem_key}
-
-
-let key_compare k1 k2 = match StateSet.compare k1.kstate k2.kstate with
-| 0 -> MemKey.compare k1.kmem k2.kmem
-| r -> r
-
-(* Association dfa_state -> state_num *)
-
-module StateMap =
- Map.Make(struct type t = dfa_key let compare = key_compare end)
-
-let state_map = ref (StateMap.empty : int StateMap.t)
-let todo = Stack.create()
-let next_state_num = ref 0
-let next_mem_cell = ref 0
-let temp_pending = ref false
-let tag_cells = Hashtbl.create 17
-let state_table = Table.create dfa_state_empty
-
-
-let reset_state_mem () =
- state_map := StateMap.empty;
- Stack.clear todo;
- next_state_num := 0 ;
- let _ = Table.trim state_table in
- ()
-
-(* Allocation of memory cells *)
-let reset_cell_mem ntags =
- next_mem_cell := ntags ;
- Hashtbl.clear tag_cells ;
- temp_pending := false
-
-let do_alloc_temp () =
- temp_pending := true ;
- let n = !next_mem_cell in
- n
-
-let do_alloc_cell used t =
- let available =
- try Hashtbl.find tag_cells t with Not_found -> Ints.empty in
- try
- Ints.choose (Ints.diff available used)
- with
- | Not_found ->
- temp_pending := false ;
- let n = !next_mem_cell in
- if n >= 255 then raise Memory_overflow ;
- Hashtbl.replace tag_cells t (Ints.add n available) ;
- incr next_mem_cell ;
- n
-
-let is_old_addr a = a >= 0
-and is_new_addr a = a < 0
-
-let old_in_map m r =
- TagMap.fold
- (fun _ addr r ->
- if is_old_addr addr then
- Ints.add addr r
- else
- r)
- m r
-
-let alloc_map used m mvs =
- TagMap.fold
- (fun tag a (r,mvs) ->
- let a,mvs =
- if is_new_addr a then
- let a = do_alloc_cell used tag in
- a,Ints.add a mvs
- else a,mvs in
- TagMap.add tag a r,mvs)
- m (TagMap.empty,mvs)
-
-let create_new_state {final=(act,(_,m_act)) ; others=o} =
- let used =
- MemMap.fold (fun _ (_,m) r -> old_in_map m r)
- o (old_in_map m_act Ints.empty) in
-
- let new_m_act,mvs = alloc_map used m_act Ints.empty in
- let new_o,mvs =
- MemMap.fold (fun k (x,m) (r,mvs) ->
- let m,mvs = alloc_map used m mvs in
- MemMap.add k (x,m) r,mvs)
- o (MemMap.empty,mvs) in
- {final=(act,(0,new_m_act)) ; others=new_o},
- Ints.fold (fun x r -> Set x::r) mvs []
-
-type new_addr_gen = {mutable count : int ; mutable env : int TagMap.t}
-
-let create_new_addr_gen () = {count = -1 ; env = TagMap.empty}
-
-let alloc_new_addr tag r =
- try
- TagMap.find tag r.env
- with
- | Not_found ->
- let a = r.count in
- r.count <- a-1 ;
- r.env <- TagMap.add tag a r.env ;
- a
-
-
-let create_mem_map tags gen =
- Tags.fold
- (fun tag r -> TagMap.add tag (alloc_new_addr tag gen) r)
- tags TagMap.empty
-
-let create_init_state pos =
- let gen = create_new_addr_gen () in
- let st =
- TransSet.fold
- (fun (t,tags) st ->
- match t with
- | ToAction n ->
- let on,otags = st.final in
- if n < on then
- {st with final = (n, (0,create_mem_map tags gen))}
- else
- st
- | OnChars n ->
- try
- let _ = MemMap.find n st.others in assert false
- with
- | Not_found ->
- {st with others =
- MemMap.add n (0,create_mem_map tags gen) st.others})
- pos dfa_state_empty in
- st
-
-
-let get_map t st = match t with
-| ToAction _ -> let _,(_,m) = st.final in m
-| OnChars n ->
- let (_,m) = MemMap.find n st.others in
- m
-
-let dest = function | Copy (d,_) | Set d -> d
-and orig = function | Copy (_,o) -> o | Set _ -> -1
-
-let pmv oc mv = fprintf oc "%d <- %d" (dest mv) (orig mv)
-let pmvs oc mvs =
- List.iter (fun mv -> fprintf oc "%a " pmv mv) mvs ;
- output_char oc '\n' ; flush oc
-
-
-(* Topological sort << a la louche >> *)
-let sort_mvs mvs =
- let rec do_rec r mvs = match mvs with
- | [] -> r
- | _ ->
- let dests =
- List.fold_left
- (fun r mv -> Ints.add (dest mv) r)
- Ints.empty mvs in
- let rem,here =
- List.partition
- (fun mv -> Ints.mem (orig mv) dests)
- mvs in
- match here with
- | [] ->
- begin match rem with
- | Copy (d,_)::_ ->
- let d' = do_alloc_temp () in
- Copy (d',d)::
- do_rec r
- (List.map
- (fun mv ->
- if orig mv = d then
- Copy (dest mv,d')
- else
- mv)
- rem)
- | _ -> assert false
- end
- | _ -> do_rec (here@r) rem in
- do_rec [] mvs
-
-let move_to mem_key src tgt =
- let mvs =
- MemKey.fold
- (fun {tag=tag ; equiv=m} r ->
- StateSetSet.fold
- (fun s r ->
- try
- let t = StateSet.choose s in
- let src = TagMap.find tag (get_map t src)
- and tgt = TagMap.find tag (get_map t tgt) in
- if src <> tgt then begin
- if is_new_addr src then
- Set tgt::r
- else
- Copy (tgt, src)::r
- end else
- r
- with
- | Not_found -> assert false)
- m r)
- mem_key [] in
-(* Moves are topologically sorted *)
- sort_mvs mvs
-
-
-let get_state st =
- let key = get_key st in
- try
- let num = StateMap.find key !state_map in
- num,move_to key.kmem st (Table.get state_table num)
- with Not_found ->
- let num = !next_state_num in
- incr next_state_num;
- let st,mvs = create_new_state st in
- Table.emit state_table st ;
- state_map := StateMap.add key num !state_map;
- Stack.push (st, num) todo;
- num,mvs
-
-let map_on_all_states f old_res =
- let res = ref old_res in
- begin try
- while true do
- let (st, i) = Stack.pop todo in
- let r = f st in
- res := (r, i) :: !res
- done
- with Stack.Empty -> ()
- end;
- !res
-
-let goto_state st =
- if
- dfa_state_is_empty st
- then
- Backtrack,[]
- else
- let n,moves = get_state st in
- Goto n,moves
-
-(****************************)
-(* compute reachable states *)
-(****************************)
-
-let add_tags_to_map gen tags m =
- Tags.fold
- (fun tag m ->
- let m = TagMap.remove tag m in
- TagMap.add tag (alloc_new_addr tag gen) m)
- tags m
-
-let apply_transition gen r pri m = function
- | ToAction n,tags ->
- let on,(opri,_) = r.final in
- if n < on || (on=n && pri < opri) then
- let m = add_tags_to_map gen tags m in
- {r with final=n,(pri,m)}
- else r
- | OnChars n,tags ->
- try
- let (opri,_) = MemMap.find n r.others in
- if pri < opri then
- let m = add_tags_to_map gen tags m in
- {r with others=MemMap.add n (pri,m) (MemMap.remove n r.others)}
- else
- r
- with
- | Not_found ->
- let m = add_tags_to_map gen tags m in
- {r with others=MemMap.add n (pri,m) r.others}
-
-(* add transitions ts to new state r
- transitions in ts start from state pri and memory map m
-*)
-let apply_transitions gen r pri m ts =
- TransSet.fold
- (fun t r -> apply_transition gen r pri m t)
- ts r
-
-
-(* For a given nfa_state pos, refine char partition *)
-let rec split_env gen follow pos m s = function
- | [] -> assert false
- | (s1,st1) as p::rem ->
- let here = Cset.inter s s1 in
- if Cset.is_empty here then
- p::split_env gen follow pos m s rem
- else
- let rest = Cset.diff s here in
- let rem =
- if Cset.is_empty rest then
- rem
- else
- split_env gen follow pos m rest rem
- and new_st = apply_transitions gen st1 pos m follow in
- let stay = Cset.diff s1 here in
- if Cset.is_empty stay then
- (here, new_st)::rem
- else
- (stay, st1)::(here, new_st)::rem
-
-
-(* For all nfa_state pos in a dfa state st *)
-let comp_shift gen chars follow st =
- MemMap.fold
- (fun pos (_,m) env -> split_env gen follow.(pos) pos m chars.(pos) env)
- st [Cset.all_chars_eof,dfa_state_empty]
-
-
-let reachs chars follow st =
- let gen = create_new_addr_gen () in
-(* build a association list (char set -> new state) *)
- let env = comp_shift gen chars follow st in
-(* change it into (char set -> new state_num) *)
- let env =
- List.map
- (fun (s,dfa_state) -> s,goto_state dfa_state) env in
-(* finally build the char indexed array -> new state num *)
- let shift = Cset.env_to_array env in
- shift
-
-
-let get_tag_mem n env t =
- try
- TagMap.find t env.(n)
- with
- | Not_found -> assert false
-
-let do_tag_actions n env m =
-
- let used,r =
- TagMap.fold (fun t m (used,r) ->
- let a = get_tag_mem n env t in
- Ints.add a used,SetTag (a,m)::r) m (Ints.empty,[]) in
- let _,r =
- TagMap.fold
- (fun tag m (used,r) ->
- if not (Ints.mem m used) && tag.start then
- Ints.add m used, EraseTag m::r
- else
- used,r)
- env.(n) (used,r) in
- r
-
-
-let translate_state shortest_match tags chars follow st =
- let (n,(_,m)) = st.final in
- if MemMap.empty = st.others then
- Perform (n,do_tag_actions n tags m)
- else if shortest_match then begin
- if n=no_action then
- Shift (No_remember,reachs chars follow st.others)
- else
- Perform(n, do_tag_actions n tags m)
- end else begin
- Shift (
- (if n = no_action then
- No_remember
- else
- Remember (n,do_tag_actions n tags m)),
- reachs chars follow st.others)
- end
-
-(*
-let dtags chan tags =
- Tags.iter
- (fun t -> fprintf chan " %a" dtag t)
- tags
-
-let dtransset s =
- TransSet.iter
- (fun trans -> match trans with
- | OnChars i,tags ->
- eprintf " (-> %d,%a)" i dtags tags
- | ToAction i,tags ->
- eprintf " ([%d],%a)" i dtags tags)
- s
-
-let dfollow t =
- eprintf "follow=[" ;
- for i = 0 to Array.length t-1 do
- eprintf "%d:" i ;
- dtransset t.(i)
- done ;
- prerr_endline "]"
-*)
-
-let make_tag_entry id start act a r = match a with
- | Sum (Mem m,0) ->
- TagMap.add {id=id ; start=start ; action=act} m r
- | _ -> r
-
-let extract_tags l =
- let envs = Array.create (List.length l) TagMap.empty in
- List.iter
- (fun (act,m,_) ->
- envs.(act) <-
- List.fold_right
- (fun (x,v) r -> match v with
- | Ident_char (_,t) -> make_tag_entry x true act t r
- | Ident_string (_,t1,t2) ->
- make_tag_entry x true act t1
- (make_tag_entry x false act t2 r))
- m TagMap.empty)
- l ;
- envs
-
-
-let make_dfa lexdef =
- let (chars, entry_list) = encode_lexdef lexdef in
- let follow = followpos (Array.length chars) entry_list in
-(*
- dfollow follow ;
-*)
- reset_state_mem () ;
- let r_states = ref [] in
- let initial_states =
- List.map
- (fun (le,args,shortest) ->
- let tags = extract_tags le.lex_actions in
- reset_cell_mem le.lex_mem_tags ;
- let pos_set = firstpos le.lex_regexp in
-(*
- prerr_string "trans={" ; dtransset pos_set ; prerr_endline "}" ;
-*)
- let init_state = create_init_state pos_set in
- let init_num = get_state init_state in
- r_states :=
- map_on_all_states
- (translate_state shortest tags chars follow) !r_states ;
- { auto_name = le.lex_name;
- auto_args = args ;
- auto_mem_size =
- (if !temp_pending then !next_mem_cell+1 else !next_mem_cell) ;
- auto_initial_state = init_num ;
- auto_actions = le.lex_actions })
- entry_list in
- let states = !r_states in
-(*
- prerr_endline "** states **" ;
- for i = 0 to !next_state_num-1 do
- eprintf "+++ %d +++\n" i ;
- dstate (Table.get state_table i) ;
- prerr_endline ""
- done ;
- eprintf "%d states\n" !next_state_num ;
-*)
- let actions = Array.create !next_state_num (Perform (0,[])) in
- List.iter (fun (act, i) -> actions.(i) <- act) states;
- reset_state_mem () ;
- reset_cell_mem 0 ;
- (initial_states, actions)
diff --git a/lex/lexgen.mli b/lex/lexgen.mli
deleted file mode 100644
index cd7f6474a8..0000000000
--- a/lex/lexgen.mli
+++ /dev/null
@@ -1,59 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-
-(* raised when there are too many bindings (>= 254 memory cells) *)
-exception Memory_overflow
-
-
-(* Representation of automata *)
-
-
-type automata =
- Perform of int * tag_action list
- | Shift of automata_trans * (automata_move * memory_action list) array
-and automata_trans =
- No_remember
- | Remember of int * tag_action list
-and automata_move =
- Backtrack
- | Goto of int
-and memory_action =
- | Copy of int * int
- | Set of int
-
-and tag_action = SetTag of int * int | EraseTag of int
-
-
-(* Representation of entry points *)
-type tag_base = Start | End | Mem of int
-type tag_addr = Sum of (tag_base * int)
-type ident_info =
- | Ident_string of bool * tag_addr * tag_addr
- | Ident_char of bool * tag_addr
-type t_env = (string * ident_info) list
-
-type ('args,'action) automata_entry =
- { auto_name: string;
- auto_args: 'args ;
- auto_mem_size : int ;
- auto_initial_state: int * memory_action list ;
- auto_actions: (int * t_env * 'action) list }
-
-(* The entry point *)
-
-val make_dfa :
- ('args, 'action) Syntax.entry list ->
- ('args, 'action) automata_entry list * automata array
-
diff --git a/lex/main.ml b/lex/main.ml
deleted file mode 100644
index d97820151f..0000000000
--- a/lex/main.ml
+++ /dev/null
@@ -1,102 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* The lexer generator. Command-line parsing. *)
-
-open Syntax
-open Lexgen
-
-let ml_automata = ref false
-let source_name = ref None
-let output_name = ref None
-
-let usage = "usage: ocamlex [options] sourcefile"
-
-let specs =
- ["-ml", Arg.Set ml_automata,
- " Output code that does not use the Lexing module built-in automata interpreter";
- "-o", Arg.String (fun x -> output_name := Some x),
- " <file> Set output file name to <file>";
- "-q", Arg.Set Common.quiet_mode, " Do not display informational messages";
- ]
-
-let _ =
- Arg.parse
- specs
- (fun name -> source_name := Some name)
- usage
-
-
-let main () =
-
- let source_name = match !source_name with
- | None -> Arg.usage specs usage ; exit 2
- | Some name -> name in
- let dest_name = match !output_name with
- | Some name -> name
- | None ->
- if Filename.check_suffix source_name ".mll" then
- Filename.chop_suffix source_name ".mll" ^ ".ml"
- else
- source_name ^ ".ml" in
-
- let ic = open_in_bin source_name in
- let oc = open_out dest_name in
- let tr = Common.open_tracker dest_name oc in
- let lexbuf = Lexing.from_channel ic in
- try
- let def = Parser.lexer_definition Lexer.main lexbuf in
- let (entries, transitions) = Lexgen.make_dfa def.entrypoints in
- if !ml_automata then begin
- Outputbis.output_lexdef
- source_name ic oc tr
- def.header entries transitions def.trailer
- end else begin
- let tables = Compact.compact_tables transitions in
- Output.output_lexdef source_name ic oc tr
- def.header tables entries def.trailer
- end;
- close_in ic;
- close_out oc;
- Common.close_tracker tr;
- with exn ->
- close_in ic;
- close_out oc;
- Common.close_tracker tr;
- Sys.remove dest_name;
- begin match exn with
- Parsing.Parse_error ->
- Printf.fprintf stderr
- "File \"%s\", line %d, character %d: syntax error.\n"
- source_name !Lexer.line_num
- (Lexing.lexeme_start lexbuf - !Lexer.line_start_pos)
- | Lexer.Lexical_error(msg, line, col) ->
- Printf.fprintf stderr
- "File \"%s\", line %d, character %d: %s.\n"
- source_name line col msg
- | Lexgen.Memory_overflow ->
- Printf.fprintf stderr
- "File \"%s\":\n Position memory overflow, too many bindings\n"
- source_name
- | Output.Table_overflow ->
- Printf.fprintf stderr
- "File \"%s\":\ntransition table overflow, automaton is too big\n"
- source_name
- | _ ->
- raise exn
- end;
- exit 3
-
-let _ = (* Printexc.catch *) main (); exit 0
-
diff --git a/lex/output.ml b/lex/output.ml
deleted file mode 100644
index c01b76ff03..0000000000
--- a/lex/output.ml
+++ /dev/null
@@ -1,140 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Output the DFA tables and its entry points *)
-
-open Printf
-open Syntax
-open Lexgen
-open Compact
-open Common
-
-(* To output an array of short ints, encoded as a string *)
-
-let output_byte oc b =
- output_char oc '\\';
- output_char oc (Char.chr(48 + b / 100));
- output_char oc (Char.chr(48 + (b / 10) mod 10));
- output_char oc (Char.chr(48 + b mod 10))
-
-let output_array oc v =
- output_string oc " \"";
- for i = 0 to Array.length v - 1 do
- output_byte oc (v.(i) land 0xFF);
- output_byte oc ((v.(i) asr 8) land 0xFF);
- if i land 7 = 7 then output_string oc "\\\n "
- done;
- output_string oc "\""
-
-let output_byte_array oc v =
- output_string oc " \"";
- for i = 0 to Array.length v - 1 do
- output_byte oc (v.(i) land 0xFF);
- if i land 15 = 15 then output_string oc "\\\n "
- done;
- output_string oc "\""
-
-(* Output the tables *)
-
-let output_tables oc tbl =
- output_string oc "let __ocaml_lex_tables = {\n";
-
- fprintf oc " Lexing.lex_base = \n%a;\n" output_array tbl.tbl_base;
- fprintf oc " Lexing.lex_backtrk = \n%a;\n" output_array tbl.tbl_backtrk;
- fprintf oc " Lexing.lex_default = \n%a;\n" output_array tbl.tbl_default;
- fprintf oc " Lexing.lex_trans = \n%a;\n" output_array tbl.tbl_trans;
- fprintf oc " Lexing.lex_check = \n%a;\n" output_array tbl.tbl_check;
- fprintf oc " Lexing.lex_base_code = \n%a;\n" output_array tbl.tbl_base_code;
-
- fprintf oc " Lexing.lex_backtrk_code = \n%a;\n"
- output_array tbl.tbl_backtrk_code;
- fprintf oc " Lexing.lex_default_code = \n%a;\n"
- output_array tbl.tbl_default_code;
- fprintf oc " Lexing.lex_trans_code = \n%a;\n"
- output_array tbl.tbl_trans_code;
- fprintf oc " Lexing.lex_check_code = \n%a;\n"
- output_array tbl.tbl_check_code;
- fprintf oc " Lexing.lex_code = \n%a;\n" output_byte_array tbl.tbl_code;
-
- output_string oc "}\n\n"
-
-
-(* Output the entries *)
-
-let output_entry sourcefile ic oc oci e =
- let init_num, init_moves = e.auto_initial_state in
- fprintf oc "%s %alexbuf =
- %a%a __ocaml_lex_%s_rec %alexbuf %d\n"
- e.auto_name
- output_args e.auto_args
- (fun oc x ->
- if x > 0 then
- fprintf oc "lexbuf.Lexing.lex_mem <- Array.create %d (-1) ; " x)
- e.auto_mem_size
- (output_memory_actions " ") init_moves
- e.auto_name
- output_args e.auto_args
- init_num;
- fprintf oc "and __ocaml_lex_%s_rec %alexbuf __ocaml_lex_state =\n"
- e.auto_name output_args e.auto_args ;
- fprintf oc " match Lexing.%sengine"
- (if e.auto_mem_size == 0 then "" else "new_");
- fprintf oc " __ocaml_lex_tables __ocaml_lex_state lexbuf with\n ";
- List.iter
- (fun (num, env, loc) ->
- fprintf oc " | ";
- fprintf oc "%d ->\n" num;
- output_env oc env;
- copy_chunk sourcefile ic oc oci loc true;
- fprintf oc "\n")
- e.auto_actions;
- fprintf oc " | n -> lexbuf.Lexing.refill_buff lexbuf; \
- __ocaml_lex_%s_rec %alexbuf n\n\n"
- e.auto_name output_args e.auto_args
-
-(* Main output function *)
-
-exception Table_overflow
-
-let output_lexdef sourcefile ic oc oci header tables entry_points trailer =
- if not !Common.quiet_mode then
- Printf.printf "%d states, %d transitions, table size %d bytes\n"
- (Array.length tables.tbl_base)
- (Array.length tables.tbl_trans)
- (2 * (Array.length tables.tbl_base + Array.length tables.tbl_backtrk +
- Array.length tables.tbl_default + Array.length tables.tbl_trans +
- Array.length tables.tbl_check));
- let size_groups =
- (2 * (Array.length tables.tbl_base_code +
- Array.length tables.tbl_backtrk_code +
- Array.length tables.tbl_default_code +
- Array.length tables.tbl_trans_code +
- Array.length tables.tbl_check_code) +
- Array.length tables.tbl_code) in
- if size_groups > 0 && not !Common.quiet_mode then
- Printf.printf "%d additional bytes used for bindings\n" size_groups ;
- flush stdout;
- if Array.length tables.tbl_trans > 0x8000 then raise Table_overflow;
- copy_chunk sourcefile ic oc oci header false;
- output_tables oc tables;
- begin match entry_points with
- [] -> ()
- | entry1 :: entries ->
- output_string oc "let rec "; output_entry sourcefile ic oc oci entry1;
- List.iter
- (fun e -> output_string oc "and "; output_entry sourcefile ic oc oci e)
- entries;
- output_string oc ";;\n\n";
- end;
- copy_chunk sourcefile ic oc oci trailer false
diff --git a/lex/output.mli b/lex/output.mli
deleted file mode 100644
index 85f89b30ce..0000000000
--- a/lex/output.mli
+++ /dev/null
@@ -1,25 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Output the DFA tables and its entry points *)
-
-val output_lexdef:
- string -> in_channel -> out_channel -> Common.line_tracker ->
- Syntax.location ->
- Compact.lex_tables ->
- (string list, Syntax.location) Lexgen.automata_entry list ->
- Syntax.location ->
- unit
-
-exception Table_overflow
diff --git a/lex/outputbis.ml b/lex/outputbis.ml
deleted file mode 100644
index be1c6af5d5..0000000000
--- a/lex/outputbis.ml
+++ /dev/null
@@ -1,193 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Output the DFA tables and its entry points *)
-
-open Printf
-open Syntax
-open Lexgen
-open Common
-
-let output_auto_defs oc =
- fprintf oc "let __ocaml_lex_init_lexbuf lexbuf mem_size =
- let pos = lexbuf.Lexing.lex_curr_pos in
- lexbuf.Lexing.lex_mem <- Array.create mem_size (-1) ;
- lexbuf.Lexing.lex_start_pos <- pos ;
- lexbuf.Lexing.lex_last_pos <- pos ;
- lexbuf.Lexing.lex_last_action <- -1
-
-" ;
-
- output_string oc
- "let rec __ocaml_lex_next_char lexbuf =
- if lexbuf.Lexing.lex_curr_pos >= lexbuf.Lexing.lex_buffer_len then begin
- if lexbuf.Lexing.lex_eof_reached then
- 256
- else begin
- lexbuf.Lexing.refill_buff lexbuf ;
- __ocaml_lex_next_char lexbuf
- end
- end else begin
- let i = lexbuf.Lexing.lex_curr_pos in
- let c = lexbuf.Lexing.lex_buffer.[i] in
- lexbuf.Lexing.lex_curr_pos <- i+1 ;
- Char.code c
- end
-
-"
-
-
-let output_pats oc pats = List.iter (fun p -> fprintf oc "|%d" p) pats
-
-let output_action oc mems r =
- output_memory_actions " " oc mems ;
- match r with
- | Backtrack ->
- fprintf oc
- " lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_last_pos ;\n" ;
- fprintf oc " lexbuf.Lexing.lex_last_action\n"
- | Goto n ->
- fprintf oc " __ocaml_lex_state%d lexbuf\n" n
-
-let output_pat oc i =
- if i >= 256 then
- fprintf oc "|eof"
- else
- fprintf oc "|'%s'" (Char.escaped (Char.chr i))
-
-let output_clause oc pats mems r =
- fprintf oc "(* " ;
- List.iter (output_pat oc) pats ;
- fprintf oc " *)\n" ;
- fprintf oc " %a ->\n" output_pats pats ; output_action oc mems r
-
-let output_default_clause oc mems r =
- fprintf oc " | _ ->\n" ; output_action oc mems r
-
-
-let output_moves oc moves =
- let t = Hashtbl.create 17 in
- let add_move i (m,mems) =
- let mems,r = try Hashtbl.find t m with Not_found -> mems,[] in
- Hashtbl.replace t m (mems,(i::r)) in
-
- for i = 0 to 256 do
- add_move i moves.(i)
- done ;
-
- let most_frequent = ref Backtrack
- and most_mems = ref []
- and size = ref 0 in
- Hashtbl.iter
- (fun m (mems,pats) ->
- let size_m = List.length pats in
- if size_m > !size then begin
- most_frequent := m ;
- most_mems := mems ;
- size := size_m
- end)
- t ;
- Hashtbl.iter
- (fun m (mems,pats) ->
- if m <> !most_frequent then output_clause oc (List.rev pats) mems m)
- t ;
- output_default_clause oc !most_mems !most_frequent
-
-
-let output_tag_actions pref oc mvs =
- output_string oc "(*" ;
- List.iter
- (fun i -> match i with
- | SetTag (t,m) -> fprintf oc " t%d <- [%d] ;" t m
- | EraseTag t -> fprintf oc " t%d <- -1 ;" t)
- mvs ;
- output_string oc " *)\n" ;
- List.iter
- (fun i -> match i with
- | SetTag (t,m) ->
- fprintf oc "%s%a <- %a ;\n"
- pref output_mem_access t output_mem_access m
- | EraseTag t ->
- fprintf oc "%s%a <- -1 ;\n"
- pref output_mem_access t)
- mvs
-
-let output_trans pref oc i trans =
- fprintf oc "%s __ocaml_lex_state%d lexbuf = " pref i ;
- match trans with
- | Perform (n,mvs) ->
- output_tag_actions " " oc mvs ;
- fprintf oc " %d\n" n
- | Shift (trans, move) ->
- begin match trans with
- | Remember (n,mvs) ->
- output_tag_actions " " oc mvs ;
- fprintf oc
- " lexbuf.Lexing.lex_last_pos <- lexbuf.Lexing.lex_curr_pos ;\n" ;
- fprintf oc " lexbuf.Lexing.lex_last_action <- %d ;\n" n
- | No_remember -> ()
- end ;
- fprintf oc " match __ocaml_lex_next_char lexbuf with\n" ;
- output_moves oc move
-
-let output_automata oc auto =
- output_auto_defs oc ;
- let n = Array.length auto in
- output_trans "let rec" oc 0 auto.(0) ;
- for i = 1 to n-1 do
- output_trans "\nand" oc i auto.(i)
- done ;
- output_char oc '\n'
-
-
-(* Output the entries *)
-
-let output_entry sourcefile ic oc tr e =
- let init_num, init_moves = e.auto_initial_state in
- fprintf oc "%s %alexbuf =
- __ocaml_lex_init_lexbuf lexbuf %d; %a
- let __ocaml_lex_result = __ocaml_lex_state%d lexbuf in
- lexbuf.Lexing.lex_start_p <- lexbuf.Lexing.lex_curr_p;
- lexbuf.Lexing.lex_curr_p <- {lexbuf.Lexing.lex_curr_p with
- Lexing.pos_cnum = lexbuf.Lexing.lex_abs_pos + lexbuf.Lexing.lex_curr_pos};
- match __ocaml_lex_result with\n"
- e.auto_name output_args e.auto_args
- e.auto_mem_size (output_memory_actions " ") init_moves init_num ;
- List.iter
- (fun (num, env, loc) ->
- fprintf oc " | ";
- fprintf oc "%d ->\n" num;
- output_env oc env ;
- copy_chunk sourcefile ic oc tr loc true;
- fprintf oc "\n")
- e.auto_actions;
- fprintf oc " | _ -> raise (Failure \"lexing: empty token\")\n\n\n"
-
-
-(* Main output function *)
-
-let output_lexdef sourcefile ic oc tr header entry_points transitions trailer =
-
- copy_chunk sourcefile ic oc tr header false;
- output_automata oc transitions ;
- begin match entry_points with
- [] -> ()
- | entry1 :: entries ->
- output_string oc "let rec "; output_entry sourcefile ic oc tr entry1;
- List.iter
- (fun e -> output_string oc "and "; output_entry sourcefile ic oc tr e)
- entries;
- output_string oc ";;\n\n";
- end;
- copy_chunk sourcefile ic oc tr trailer false
diff --git a/lex/outputbis.mli b/lex/outputbis.mli
deleted file mode 100644
index 76f00672bf..0000000000
--- a/lex/outputbis.mli
+++ /dev/null
@@ -1,21 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Luc Maranget projet Moscova INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-val output_lexdef :
- string ->
- in_channel ->
- out_channel ->
- Common.line_tracker ->
- Syntax.location ->
- (string list, Syntax.location) Lexgen.automata_entry list ->
- Lexgen.automata array -> Syntax.location -> unit
diff --git a/lex/parser.mly b/lex/parser.mly
deleted file mode 100644
index a1921309b2..0000000000
--- a/lex/parser.mly
+++ /dev/null
@@ -1,174 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* The grammar for lexer definitions */
-
-%{
-open Syntax
-
-(* Auxiliaries for the parser. *)
-
-let named_regexps =
- (Hashtbl.create 13 : (string, regular_expression) Hashtbl.t)
-
-let regexp_for_string s =
- let rec re_string n =
- if n >= String.length s then Epsilon
- else if succ n = String.length s then
- Characters (Cset.singleton (Char.code s.[n]))
- else
- Sequence
- (Characters(Cset.singleton (Char.code s.[n])),
- re_string (succ n))
- in re_string 0
-
-let rec remove_as = function
- | Bind (e,_) -> remove_as e
- | Epsilon|Eof|Characters _ as e -> e
- | Sequence (e1, e2) -> Sequence (remove_as e1, remove_as e2)
- | Alternative (e1, e2) -> Alternative (remove_as e1, remove_as e2)
- | Repetition e -> Repetition (remove_as e)
-
-%}
-
-%token <string> Tident
-%token <int> Tchar
-%token <string> Tstring
-%token <Syntax.location> Taction
-%token Trule Tparse Tparse_shortest Tand Tequal Tend Tor Tunderscore Teof Tlbracket Trbracket
-%token Tstar Tmaybe Tplus Tlparen Trparen Tcaret Tdash Tlet Tas
-
-%right Tas
-%left Tor
-%nonassoc CONCAT
-%nonassoc Tmaybe Tstar Tplus
- Tident Tchar Tstring Tunderscore Teof Tlbracket Tlparen
-
-%start lexer_definition
-%type <Syntax.lexer_definition> lexer_definition
-
-%%
-
-lexer_definition:
- header named_regexps Trule definition other_definitions header Tend
- { {header = $1;
- entrypoints = $4 :: List.rev $5;
- trailer = $6} }
-;
-header:
- Taction
- { $1 }
- | /*epsilon*/
- { { start_pos = 0; end_pos = 0; start_line = 1; start_col = 0 } }
-;
-named_regexps:
- named_regexps Tlet Tident Tequal regexp
- { Hashtbl.add named_regexps $3 $5 }
- | /*epsilon*/
- { () }
-;
-other_definitions:
- other_definitions Tand definition
- { $3::$1 }
- | /*epsilon*/
- { [] }
-;
-definition:
- Tident arguments Tequal Tparse entry
- { {name=$1 ; shortest=false ; args=$2 ; clauses=$5} }
- | Tident arguments Tequal Tparse_shortest entry
- { {name=$1 ; shortest=true ; args=$2 ; clauses=$5} }
-;
-
-arguments:
- Tident arguments { $1::$2 }
-| /*epsilon*/ { [] }
-;
-
-
-entry:
- case rest_of_entry
- { $1::List.rev $2 }
-| Tor case rest_of_entry
- { $2::List.rev $3 }
-;
-
-rest_of_entry:
- rest_of_entry Tor case
- { $3::$1 }
- |
- { [] }
-;
-case:
- regexp Taction
- { ($1,$2) }
-;
-regexp:
- Tunderscore
- { Characters Cset.all_chars }
- | Teof
- { Eof }
- | Tchar
- { Characters (Cset.singleton $1) }
- | Tstring
- { regexp_for_string $1 }
- | Tlbracket char_class Trbracket
- { Characters $2 }
- | regexp Tstar
- { Repetition $1 }
- | regexp Tmaybe
- { Alternative(Epsilon, $1) }
- | regexp Tplus
- { Sequence(Repetition (remove_as $1), $1) }
- | regexp Tor regexp
- { Alternative($1,$3) }
- | regexp regexp %prec CONCAT
- { Sequence($1,$2) }
- | Tlparen regexp Trparen
- { $2 }
- | Tident
- { try
- Hashtbl.find named_regexps $1
- with Not_found ->
- prerr_string "Reference to unbound regexp name `";
- prerr_string $1;
- prerr_string "' at char ";
- prerr_int (Parsing.symbol_start());
- prerr_newline();
- exit 2 }
- | regexp Tas ident
- {Bind ($1, $3)}
-;
-
-ident:
- Tident {$1}
-;
-
-char_class:
- Tcaret char_class1
- { Cset.complement $2 }
- | char_class1
- { $1 }
-;
-char_class1:
- Tchar Tdash Tchar
- { Cset.interval $1 $3 }
- | Tchar
- { Cset.singleton $1 }
- | char_class1 char_class1 %prec CONCAT
- { Cset.union $1 $2 }
-;
-
-%%
-
diff --git a/lex/syntax.ml b/lex/syntax.ml
deleted file mode 100644
index e5b3f219b9..0000000000
--- a/lex/syntax.ml
+++ /dev/null
@@ -1,44 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* This apparently useless implmentation file is in fact required
- by the pa_ocamllex syntax extension *)
-
-(* The shallow abstract syntax *)
-
-type location =
- { start_pos: int;
- end_pos: int;
- start_line: int;
- start_col: int }
-
-type regular_expression =
- Epsilon
- | Characters of Cset.t
- | Eof
- | Sequence of regular_expression * regular_expression
- | Alternative of regular_expression * regular_expression
- | Repetition of regular_expression
- | Bind of regular_expression * string
-
-type ('arg,'action) entry =
- {name:string ;
- shortest : bool ;
- args : 'arg ;
- clauses : (regular_expression * 'action) list}
-
-type lexer_definition =
- { header: location;
- entrypoints: ((string list, location) entry) list;
- trailer: location }
diff --git a/lex/syntax.mli b/lex/syntax.mli
deleted file mode 100644
index 368a5d0ba8..0000000000
--- a/lex/syntax.mli
+++ /dev/null
@@ -1,41 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* The shallow abstract syntax *)
-
-type location =
- { start_pos: int;
- end_pos: int;
- start_line: int;
- start_col: int }
-
-type regular_expression =
- Epsilon
- | Characters of Cset.t
- | Eof
- | Sequence of regular_expression * regular_expression
- | Alternative of regular_expression * regular_expression
- | Repetition of regular_expression
- | Bind of regular_expression * string
-
-type ('arg,'action) entry =
- {name:string ;
- shortest : bool ;
- args : 'arg ;
- clauses : (regular_expression * 'action) list}
-
-type lexer_definition =
- { header: location;
- entrypoints: ((string list, location) entry) list;
- trailer: location }
diff --git a/lex/table.ml b/lex/table.ml
deleted file mode 100644
index 402f52be8b..0000000000
--- a/lex/table.ml
+++ /dev/null
@@ -1,56 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-type 'a t = {mutable next : int ; mutable data : 'a array}
-
-let default_size = 32
-;;
-
-let create x = {next = 0 ; data = Array.create default_size x}
-and reset t = t.next <- 0
-;;
-
-let incr_table table new_size =
- let t = Array.create new_size table.data.(0) in
- Array.blit table.data 0 t 0 (Array.length table.data) ;
- table.data <- t
-
-let emit table i =
- let size = Array.length table.data in
- if table.next >= size then
- incr_table table (2*size);
- table.data.(table.next) <- i ;
- table.next <- table.next + 1
-;;
-
-
-exception Error
-
-let get t i =
- if 0 <= i && i < t.next then
- t.data.(i)
- else
- raise Error
-
-let trim t =
- let r = Array.sub t.data 0 t.next in
- reset t ;
- r
-
-let iter t f =
- let size = t.next
- and data = t.data in
- for i = 0 to size-1 do
- f data.(i)
- done
-
-let size t = t.next
diff --git a/lex/table.mli b/lex/table.mli
deleted file mode 100644
index e5d55f9652..0000000000
--- a/lex/table.mli
+++ /dev/null
@@ -1,33 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* Table used for code emission, ie extensible arrays *)
-type 'a t
-
-val create : 'a -> 'a t
-
-val emit : 'a t -> 'a -> unit
-
-val iter : 'a t -> ('a -> unit) -> unit
-
-val trim : 'a t -> 'a array
-
-
-exception Error
-
-val get : 'a t -> int -> 'a
-
-
-
-val size : 'a t -> int
-
-
diff --git a/maccaml/.cvsignore b/maccaml/.cvsignore
deleted file mode 100644
index efe28a120b..0000000000
--- a/maccaml/.cvsignore
+++ /dev/null
@@ -1,12 +0,0 @@
-stdlib
-*.c.x
-*.cp.x
-*.xcoff
-*.dbg
-appliprims
-appli
-prims.c
-Objective*Caml
-OCaml.68k
-OCaml.PPC
-dummy_fragment
diff --git a/maccaml/Makefile.Mac b/maccaml/Makefile.Mac
deleted file mode 100644
index c9b0f0e9a4..0000000000
--- a/maccaml/Makefile.Mac
+++ /dev/null
@@ -1,121 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-VERSIONSTR = ¶
- "¶"{OCAMLMAJOR}.{OCAMLMINOR}/Mac{MAJOR}.{MINOR}.{BUGFIX}{STAGE}{REV}¶""
-
-COPYRIGHTSTR = "¶"Copyright 1991-2001 INRIA¶""
-
-XIncludes = -i ::byterun:,::config: ¶
- -i ":WASTE:WASTE 1.3 Distribution:WASTE C/C++ Headers:"
-
-PPCC = mrc -proto strict -w 6,35
-PPCCplus = mrcpp
-PPCCOptions = {XIncludes} {cdbgflag}
-PPCLinkOptions = -d {ldbgflag}
-PPCCamlrunLibs = ::otherlibs:num:libnums.x ¶
- ::otherlibs:bigarray:libbigarray.x ¶
- ::byterun:libcamlrun-gui.x ¶
- ::otherlibs:str:libstr.x
-PPCWELibs = ":WASTE:WASTE 1.3 Distribution:WASTELib.x"
-PPCSysLibs = "{PPCLibraries}MrCPlusLib.o" ¶
- "{PPCLibraries}PPCStdCLib.o" ¶
- "{PPCLibraries}StdCRuntime.o" ¶
- "{PPCLibraries}PPCCRuntime.o" ¶
- "{PPCLibraries}PPCToolLibs.o" ¶
- "{SharedLibraries}InterfaceLib" ¶
- "{SharedLibraries}StdCLib" ¶
- "{sharedlibraries}MathLib" ¶
- "{sharedlibraries}DragLib"
-PPCLibs = {ppccamlrunlibs} {ppcwelibs} {ppcsyslibs}
-
-camllibs = ::otherlibs:graph:graphics.cma ¶
- ::otherlibs:num:nums.cma ¶
- ::otherlibs:bigarray:bigarray.cma ¶
-
-primfiles = ::byterun:primitives prim_bigarray prim_graph prim_num prim_str
-
-RezDefs = -d MAJORVNUM={MAJOR} -d MINORVNUM=0x{MINOR}{BUGFIX} ¶
- -d STAGE={STAGE} -d DEVVNUM={REV} ¶
- -d VERSIONSTR={VERSIONSTR} -d COPYRIGHTSTR={COPYRIGHTSTR}
-
-PPCOBJS = aboutbox.c.x appleevents.c.x clipboard.c.x ¶
- drag.c.x errors.c.x ¶
- events.c.x files.c.x glue.c.x ¶
- graph.c.x lcontrols.c.x lib.c.x main.c.x mcmemory.c.x ¶
- menus.c.x mcmisc.c.x modalfilter.c.x prefs.c.x prims.c.x ¶
- print.c.x scroll.c.x windows.c.x
-
-all Ä appli appliprims ocamlconstants.h appli.r "Objective Caml"
- set status 0
-
-appliprims Ä {primfiles}
- catenate {primfiles} > appliprims
-
-prims.c Ä appliprims
- begin
- echo '#include "mlvalues.h"'
- echo '#include "prims.h"'
- streamedit -e '1,$ change "extern value " . "();"' appliprims
- echo 'c_primitive builtin_cprim [] = {'
- streamedit -e '1,$ change " " . ","' appliprims
- echo '0 };'
- echo 'char * names_of_builtin_cprim [] = {'
- streamedit -e '1,$ change " ¶"" . "¶","' appliprims
- echo '0 };'
- end > prims.c
-
-OCaml.PPC Ä {PPCOBJS} {ppccamlrunlibs}
- ppclink -o OCaml.PPC {ppclinkoptions} {PPCOBJS} {ppclibs}
- rename -y OCaml.PPC.xcoff "Objective Caml.xcoff" || set status 0
-
-dummy_fragment Ä dummy_fragment.c.x
- ppclink -xm l -o dummy_fragment {ppclinkoptions} dummy_fragment.c.x
-
-appli ÄÄ OCaml.PPC dummy_fragment
- delete -i appli
- mergefragment -a OCaml.PPC appli
- mergefragment dummy_fragment appli
-
-"Objective Caml" Ä appliprims appli.r ocamlconstants.h appli ¶
- ::toplevellib.cma {camllibs} ::toplevel:topmain.cmo
- :ocamlmkappli ¶
- -ocamlc "::boot:ocamlrun ::boot:ocamlc -I ::stdlib: -linkall" ¶
- {rezdefs} -lib : -name "Objective Caml" -r ocaml.r ¶
- -creator Caml -prefsize 5000 -minsize 3000 ¶
- ::toplevellib.cma {camllibs} ::toplevel:topmain.cmo
-
-install Ä appli appli.r appliprims ocamlconstants.h ocamlmkappli ¶
- "Objective Caml"
- duplicate -y "Objective Caml" ¶
- `exists "objective caml.xcoff" ¶
- "::test:Moretest:graph_example.ml" ¶
- ` ¶
- "{APPLIDIR}"
- duplicate -y appli appli.r appliprims ocamlconstants.h "{LIBDIR}"
- duplicate -y ocamlmkappli "{BINDIR}"
-
-partialclean Ä
- delete -i "Objective Caml"
-
-clean Ä
- delete -i -y {OBJS} {PPCOBJS} OCaml.68k OCaml.PPC ¶
- "Objective Caml" appliprims prims.c null :config ¶
- dummy_fragment dummy_fragment.c.x dummy_fragment.xcoff ¶
- "Objective Caml.xcoff" "Objective Caml.dbg"
-
-depend Ä prims.c
- begin
- makedepend -w -objext .x Å.c
- end | streamedit -e "/¶t/ replace // ' ' -c °" > Makefile.Mac.depend
diff --git a/maccaml/Makefile.Mac.depend b/maccaml/Makefile.Mac.depend
deleted file mode 100644
index b225a6e065..0000000000
--- a/maccaml/Makefile.Mac.depend
+++ /dev/null
@@ -1,2032 +0,0 @@
-#*** Dependencies: Cut here ***
-# These dependencies were produced at 20:33:24 on Tue, Aug 21, 2001 by MakeDepend
-
-:aboutbox.c.x Ä ¶
- :aboutbox.c ¶
- :main.h ¶
- "{CIncludes}"limits.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"stdio.h ¶
- "{CIncludes}"stdlib.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"AERegistry.h ¶
- "{CIncludes}"AppleEvents.h ¶
- "{CIncludes}"ControlDefinitions.h ¶
- "{CIncludes}"Controls.h ¶
- "{CIncludes}"Devices.h ¶
- "{CIncludes}"Dialogs.h ¶
- "{CIncludes}"DiskInit.h ¶
- "{CIncludes}"Drag.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"FixMath.h ¶
- "{CIncludes}"Folders.h ¶
- "{CIncludes}"Fonts.h ¶
- "{CIncludes}"Gestalt.h ¶
- "{CIncludes}"LowMem.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MacWindows.h ¶
- "{CIncludes}"Menus.h ¶
- "{CIncludes}"Power.h ¶
- "{CIncludes}"Printing.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"QDOffscreen.h ¶
- "{CIncludes}"QuickDraw.h ¶
- "{CIncludes}"Resources.h ¶
- "{CIncludes}"Scrap.h ¶
- "{CIncludes}"Script.h ¶
- "{CIncludes}"SegLoad.h ¶
- "{CIncludes}"Sound.h ¶
- "{CIncludes}"StandardFile.h ¶
- "{CIncludes}"Strings.h ¶
- "{CIncludes}"TextUtils.h ¶
- "{CIncludes}"ToolUtils.h ¶
- ::byterun:rotatecursor.h ¶
- :ocamlconstants.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"VaListTDef.h ¶
- "{CIncludes}"WCharTDef.h ¶
- "{CIncludes}"MacErrors.h ¶
- "{CIncludes}"MixedMode.h ¶
- "{CIncludes}"AEDataModel.h ¶
- "{CIncludes}"AEInteraction.h ¶
- "{CIncludes}"Appearance.h ¶
- "{CIncludes}"CarbonEvents.h ¶
- "{CIncludes}"Lists.h ¶
- "{CIncludes}"MacHelp.h ¶
- "{CIncludes}"CFString.h ¶
- "{CIncludes}"TextEdit.h ¶
- "{CIncludes}"Icons.h ¶
- "{CIncludes}"Collections.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"NameRegistry.h ¶
- "{CIncludes}"CodeFragments.h ¶
- "{CIncludes}"Multiprocessing.h ¶
- "{CIncludes}"DriverFamilyMatching.h ¶
- "{CIncludes}"Disks.h ¶
- "{CIncludes}"Events.h ¶
- "{CIncludes}"ATSTypes.h ¶
- "{CIncludes}"TextCommon.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"Aliases.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"CGContext.h ¶
- "{CIncludes}"IntlResources.h ¶
- "{CIncludes}"NumberFormatting.h ¶
- "{CIncludes}"StringCompare.h ¶
- "{CIncludes}"DateTimeUtils.h ¶
- "{CIncludes}"Notification.h ¶
- "{CIncludes}"Balloons.h ¶
- "{CIncludes}"CFBase.h ¶
- "{CIncludes}"CFArray.h ¶
- "{CIncludes}"CFData.h ¶
- "{CIncludes}"CFDictionary.h ¶
- "{CIncludes}"stdarg.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"CFBundle.h ¶
- "{CIncludes}"CGBase.h ¶
- "{CIncludes}"CGAffineTransform.h ¶
- "{CIncludes}"CGColorSpace.h ¶
- "{CIncludes}"CGFont.h ¶
- "{CIncludes}"CGImage.h ¶
- "{CIncludes}"CGPDFDocument.h ¶
- "{CIncludes}"TypeSelect.h ¶
- "{CIncludes}"CFURL.h ¶
- "{CIncludes}"stddef.h ¶
- "{CIncludes}"CGGeometry.h ¶
- "{CIncludes}"CGDataProvider.h
-
-:appleevents.c.x Ä ¶
- :appleevents.c ¶
- :main.h ¶
- "{CIncludes}"limits.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"stdio.h ¶
- "{CIncludes}"stdlib.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"AERegistry.h ¶
- "{CIncludes}"AppleEvents.h ¶
- "{CIncludes}"ControlDefinitions.h ¶
- "{CIncludes}"Controls.h ¶
- "{CIncludes}"Devices.h ¶
- "{CIncludes}"Dialogs.h ¶
- "{CIncludes}"DiskInit.h ¶
- "{CIncludes}"Drag.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"FixMath.h ¶
- "{CIncludes}"Folders.h ¶
- "{CIncludes}"Fonts.h ¶
- "{CIncludes}"Gestalt.h ¶
- "{CIncludes}"LowMem.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MacWindows.h ¶
- "{CIncludes}"Menus.h ¶
- "{CIncludes}"Power.h ¶
- "{CIncludes}"Printing.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"QDOffscreen.h ¶
- "{CIncludes}"QuickDraw.h ¶
- "{CIncludes}"Resources.h ¶
- "{CIncludes}"Scrap.h ¶
- "{CIncludes}"Script.h ¶
- "{CIncludes}"SegLoad.h ¶
- "{CIncludes}"Sound.h ¶
- "{CIncludes}"StandardFile.h ¶
- "{CIncludes}"Strings.h ¶
- "{CIncludes}"TextUtils.h ¶
- "{CIncludes}"ToolUtils.h ¶
- ::byterun:rotatecursor.h ¶
- :ocamlconstants.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"VaListTDef.h ¶
- "{CIncludes}"WCharTDef.h ¶
- "{CIncludes}"MacErrors.h ¶
- "{CIncludes}"MixedMode.h ¶
- "{CIncludes}"AEDataModel.h ¶
- "{CIncludes}"AEInteraction.h ¶
- "{CIncludes}"Appearance.h ¶
- "{CIncludes}"CarbonEvents.h ¶
- "{CIncludes}"Lists.h ¶
- "{CIncludes}"MacHelp.h ¶
- "{CIncludes}"CFString.h ¶
- "{CIncludes}"TextEdit.h ¶
- "{CIncludes}"Icons.h ¶
- "{CIncludes}"Collections.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"NameRegistry.h ¶
- "{CIncludes}"CodeFragments.h ¶
- "{CIncludes}"Multiprocessing.h ¶
- "{CIncludes}"DriverFamilyMatching.h ¶
- "{CIncludes}"Disks.h ¶
- "{CIncludes}"Events.h ¶
- "{CIncludes}"ATSTypes.h ¶
- "{CIncludes}"TextCommon.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"Aliases.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"CGContext.h ¶
- "{CIncludes}"IntlResources.h ¶
- "{CIncludes}"NumberFormatting.h ¶
- "{CIncludes}"StringCompare.h ¶
- "{CIncludes}"DateTimeUtils.h ¶
- "{CIncludes}"Notification.h ¶
- "{CIncludes}"Balloons.h ¶
- "{CIncludes}"CFBase.h ¶
- "{CIncludes}"CFArray.h ¶
- "{CIncludes}"CFData.h ¶
- "{CIncludes}"CFDictionary.h ¶
- "{CIncludes}"stdarg.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"CFBundle.h ¶
- "{CIncludes}"CGBase.h ¶
- "{CIncludes}"CGAffineTransform.h ¶
- "{CIncludes}"CGColorSpace.h ¶
- "{CIncludes}"CGFont.h ¶
- "{CIncludes}"CGImage.h ¶
- "{CIncludes}"CGPDFDocument.h ¶
- "{CIncludes}"TypeSelect.h ¶
- "{CIncludes}"CFURL.h ¶
- "{CIncludes}"stddef.h ¶
- "{CIncludes}"CGGeometry.h ¶
- "{CIncludes}"CGDataProvider.h
-
-:clipboard.c.x Ä ¶
- :clipboard.c ¶
- :main.h ¶
- "{CIncludes}"limits.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"stdio.h ¶
- "{CIncludes}"stdlib.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"AERegistry.h ¶
- "{CIncludes}"AppleEvents.h ¶
- "{CIncludes}"ControlDefinitions.h ¶
- "{CIncludes}"Controls.h ¶
- "{CIncludes}"Devices.h ¶
- "{CIncludes}"Dialogs.h ¶
- "{CIncludes}"DiskInit.h ¶
- "{CIncludes}"Drag.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"FixMath.h ¶
- "{CIncludes}"Folders.h ¶
- "{CIncludes}"Fonts.h ¶
- "{CIncludes}"Gestalt.h ¶
- "{CIncludes}"LowMem.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MacWindows.h ¶
- "{CIncludes}"Menus.h ¶
- "{CIncludes}"Power.h ¶
- "{CIncludes}"Printing.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"QDOffscreen.h ¶
- "{CIncludes}"QuickDraw.h ¶
- "{CIncludes}"Resources.h ¶
- "{CIncludes}"Scrap.h ¶
- "{CIncludes}"Script.h ¶
- "{CIncludes}"SegLoad.h ¶
- "{CIncludes}"Sound.h ¶
- "{CIncludes}"StandardFile.h ¶
- "{CIncludes}"Strings.h ¶
- "{CIncludes}"TextUtils.h ¶
- "{CIncludes}"ToolUtils.h ¶
- ::byterun:rotatecursor.h ¶
- :ocamlconstants.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"VaListTDef.h ¶
- "{CIncludes}"WCharTDef.h ¶
- "{CIncludes}"MacErrors.h ¶
- "{CIncludes}"MixedMode.h ¶
- "{CIncludes}"AEDataModel.h ¶
- "{CIncludes}"AEInteraction.h ¶
- "{CIncludes}"Appearance.h ¶
- "{CIncludes}"CarbonEvents.h ¶
- "{CIncludes}"Lists.h ¶
- "{CIncludes}"MacHelp.h ¶
- "{CIncludes}"CFString.h ¶
- "{CIncludes}"TextEdit.h ¶
- "{CIncludes}"Icons.h ¶
- "{CIncludes}"Collections.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"NameRegistry.h ¶
- "{CIncludes}"CodeFragments.h ¶
- "{CIncludes}"Multiprocessing.h ¶
- "{CIncludes}"DriverFamilyMatching.h ¶
- "{CIncludes}"Disks.h ¶
- "{CIncludes}"Events.h ¶
- "{CIncludes}"ATSTypes.h ¶
- "{CIncludes}"TextCommon.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"Aliases.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"CGContext.h ¶
- "{CIncludes}"IntlResources.h ¶
- "{CIncludes}"NumberFormatting.h ¶
- "{CIncludes}"StringCompare.h ¶
- "{CIncludes}"DateTimeUtils.h ¶
- "{CIncludes}"Notification.h ¶
- "{CIncludes}"Balloons.h ¶
- "{CIncludes}"CFBase.h ¶
- "{CIncludes}"CFArray.h ¶
- "{CIncludes}"CFData.h ¶
- "{CIncludes}"CFDictionary.h ¶
- "{CIncludes}"stdarg.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"CFBundle.h ¶
- "{CIncludes}"CGBase.h ¶
- "{CIncludes}"CGAffineTransform.h ¶
- "{CIncludes}"CGColorSpace.h ¶
- "{CIncludes}"CGFont.h ¶
- "{CIncludes}"CGImage.h ¶
- "{CIncludes}"CGPDFDocument.h ¶
- "{CIncludes}"TypeSelect.h ¶
- "{CIncludes}"CFURL.h ¶
- "{CIncludes}"stddef.h ¶
- "{CIncludes}"CGGeometry.h ¶
- "{CIncludes}"CGDataProvider.h
-
-:drag.c.x Ä ¶
- :drag.c ¶
- :main.h ¶
- "{CIncludes}"limits.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"stdio.h ¶
- "{CIncludes}"stdlib.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"AERegistry.h ¶
- "{CIncludes}"AppleEvents.h ¶
- "{CIncludes}"ControlDefinitions.h ¶
- "{CIncludes}"Controls.h ¶
- "{CIncludes}"Devices.h ¶
- "{CIncludes}"Dialogs.h ¶
- "{CIncludes}"DiskInit.h ¶
- "{CIncludes}"Drag.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"FixMath.h ¶
- "{CIncludes}"Folders.h ¶
- "{CIncludes}"Fonts.h ¶
- "{CIncludes}"Gestalt.h ¶
- "{CIncludes}"LowMem.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MacWindows.h ¶
- "{CIncludes}"Menus.h ¶
- "{CIncludes}"Power.h ¶
- "{CIncludes}"Printing.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"QDOffscreen.h ¶
- "{CIncludes}"QuickDraw.h ¶
- "{CIncludes}"Resources.h ¶
- "{CIncludes}"Scrap.h ¶
- "{CIncludes}"Script.h ¶
- "{CIncludes}"SegLoad.h ¶
- "{CIncludes}"Sound.h ¶
- "{CIncludes}"StandardFile.h ¶
- "{CIncludes}"Strings.h ¶
- "{CIncludes}"TextUtils.h ¶
- "{CIncludes}"ToolUtils.h ¶
- ::byterun:rotatecursor.h ¶
- :ocamlconstants.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"VaListTDef.h ¶
- "{CIncludes}"WCharTDef.h ¶
- "{CIncludes}"MacErrors.h ¶
- "{CIncludes}"MixedMode.h ¶
- "{CIncludes}"AEDataModel.h ¶
- "{CIncludes}"AEInteraction.h ¶
- "{CIncludes}"Appearance.h ¶
- "{CIncludes}"CarbonEvents.h ¶
- "{CIncludes}"Lists.h ¶
- "{CIncludes}"MacHelp.h ¶
- "{CIncludes}"CFString.h ¶
- "{CIncludes}"TextEdit.h ¶
- "{CIncludes}"Icons.h ¶
- "{CIncludes}"Collections.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"NameRegistry.h ¶
- "{CIncludes}"CodeFragments.h ¶
- "{CIncludes}"Multiprocessing.h ¶
- "{CIncludes}"DriverFamilyMatching.h ¶
- "{CIncludes}"Disks.h ¶
- "{CIncludes}"Events.h ¶
- "{CIncludes}"ATSTypes.h ¶
- "{CIncludes}"TextCommon.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"Aliases.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"CGContext.h ¶
- "{CIncludes}"IntlResources.h ¶
- "{CIncludes}"NumberFormatting.h ¶
- "{CIncludes}"StringCompare.h ¶
- "{CIncludes}"DateTimeUtils.h ¶
- "{CIncludes}"Notification.h ¶
- "{CIncludes}"Balloons.h ¶
- "{CIncludes}"CFBase.h ¶
- "{CIncludes}"CFArray.h ¶
- "{CIncludes}"CFData.h ¶
- "{CIncludes}"CFDictionary.h ¶
- "{CIncludes}"stdarg.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"CFBundle.h ¶
- "{CIncludes}"CGBase.h ¶
- "{CIncludes}"CGAffineTransform.h ¶
- "{CIncludes}"CGColorSpace.h ¶
- "{CIncludes}"CGFont.h ¶
- "{CIncludes}"CGImage.h ¶
- "{CIncludes}"CGPDFDocument.h ¶
- "{CIncludes}"TypeSelect.h ¶
- "{CIncludes}"CFURL.h ¶
- "{CIncludes}"stddef.h ¶
- "{CIncludes}"CGGeometry.h ¶
- "{CIncludes}"CGDataProvider.h
-
-:dummy_fragment.c.x Ä ¶
- :dummy_fragment.c
-
-:errors.c.x Ä ¶
- :errors.c ¶
- :main.h ¶
- "{CIncludes}"limits.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"stdio.h ¶
- "{CIncludes}"stdlib.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"AERegistry.h ¶
- "{CIncludes}"AppleEvents.h ¶
- "{CIncludes}"ControlDefinitions.h ¶
- "{CIncludes}"Controls.h ¶
- "{CIncludes}"Devices.h ¶
- "{CIncludes}"Dialogs.h ¶
- "{CIncludes}"DiskInit.h ¶
- "{CIncludes}"Drag.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"FixMath.h ¶
- "{CIncludes}"Folders.h ¶
- "{CIncludes}"Fonts.h ¶
- "{CIncludes}"Gestalt.h ¶
- "{CIncludes}"LowMem.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MacWindows.h ¶
- "{CIncludes}"Menus.h ¶
- "{CIncludes}"Power.h ¶
- "{CIncludes}"Printing.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"QDOffscreen.h ¶
- "{CIncludes}"QuickDraw.h ¶
- "{CIncludes}"Resources.h ¶
- "{CIncludes}"Scrap.h ¶
- "{CIncludes}"Script.h ¶
- "{CIncludes}"SegLoad.h ¶
- "{CIncludes}"Sound.h ¶
- "{CIncludes}"StandardFile.h ¶
- "{CIncludes}"Strings.h ¶
- "{CIncludes}"TextUtils.h ¶
- "{CIncludes}"ToolUtils.h ¶
- ::byterun:rotatecursor.h ¶
- :ocamlconstants.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"VaListTDef.h ¶
- "{CIncludes}"WCharTDef.h ¶
- "{CIncludes}"MacErrors.h ¶
- "{CIncludes}"MixedMode.h ¶
- "{CIncludes}"AEDataModel.h ¶
- "{CIncludes}"AEInteraction.h ¶
- "{CIncludes}"Appearance.h ¶
- "{CIncludes}"CarbonEvents.h ¶
- "{CIncludes}"Lists.h ¶
- "{CIncludes}"MacHelp.h ¶
- "{CIncludes}"CFString.h ¶
- "{CIncludes}"TextEdit.h ¶
- "{CIncludes}"Icons.h ¶
- "{CIncludes}"Collections.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"NameRegistry.h ¶
- "{CIncludes}"CodeFragments.h ¶
- "{CIncludes}"Multiprocessing.h ¶
- "{CIncludes}"DriverFamilyMatching.h ¶
- "{CIncludes}"Disks.h ¶
- "{CIncludes}"Events.h ¶
- "{CIncludes}"ATSTypes.h ¶
- "{CIncludes}"TextCommon.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"Aliases.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"CGContext.h ¶
- "{CIncludes}"IntlResources.h ¶
- "{CIncludes}"NumberFormatting.h ¶
- "{CIncludes}"StringCompare.h ¶
- "{CIncludes}"DateTimeUtils.h ¶
- "{CIncludes}"Notification.h ¶
- "{CIncludes}"Balloons.h ¶
- "{CIncludes}"CFBase.h ¶
- "{CIncludes}"CFArray.h ¶
- "{CIncludes}"CFData.h ¶
- "{CIncludes}"CFDictionary.h ¶
- "{CIncludes}"stdarg.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"CFBundle.h ¶
- "{CIncludes}"CGBase.h ¶
- "{CIncludes}"CGAffineTransform.h ¶
- "{CIncludes}"CGColorSpace.h ¶
- "{CIncludes}"CGFont.h ¶
- "{CIncludes}"CGImage.h ¶
- "{CIncludes}"CGPDFDocument.h ¶
- "{CIncludes}"TypeSelect.h ¶
- "{CIncludes}"CFURL.h ¶
- "{CIncludes}"stddef.h ¶
- "{CIncludes}"CGGeometry.h ¶
- "{CIncludes}"CGDataProvider.h
-
-:events.c.x Ä ¶
- :events.c ¶
- :main.h ¶
- "{CIncludes}"limits.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"stdio.h ¶
- "{CIncludes}"stdlib.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"AERegistry.h ¶
- "{CIncludes}"AppleEvents.h ¶
- "{CIncludes}"ControlDefinitions.h ¶
- "{CIncludes}"Controls.h ¶
- "{CIncludes}"Devices.h ¶
- "{CIncludes}"Dialogs.h ¶
- "{CIncludes}"DiskInit.h ¶
- "{CIncludes}"Drag.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"FixMath.h ¶
- "{CIncludes}"Folders.h ¶
- "{CIncludes}"Fonts.h ¶
- "{CIncludes}"Gestalt.h ¶
- "{CIncludes}"LowMem.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MacWindows.h ¶
- "{CIncludes}"Menus.h ¶
- "{CIncludes}"Power.h ¶
- "{CIncludes}"Printing.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"QDOffscreen.h ¶
- "{CIncludes}"QuickDraw.h ¶
- "{CIncludes}"Resources.h ¶
- "{CIncludes}"Scrap.h ¶
- "{CIncludes}"Script.h ¶
- "{CIncludes}"SegLoad.h ¶
- "{CIncludes}"Sound.h ¶
- "{CIncludes}"StandardFile.h ¶
- "{CIncludes}"Strings.h ¶
- "{CIncludes}"TextUtils.h ¶
- "{CIncludes}"ToolUtils.h ¶
- ::byterun:rotatecursor.h ¶
- :ocamlconstants.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"VaListTDef.h ¶
- "{CIncludes}"WCharTDef.h ¶
- "{CIncludes}"MacErrors.h ¶
- "{CIncludes}"MixedMode.h ¶
- "{CIncludes}"AEDataModel.h ¶
- "{CIncludes}"AEInteraction.h ¶
- "{CIncludes}"Appearance.h ¶
- "{CIncludes}"CarbonEvents.h ¶
- "{CIncludes}"Lists.h ¶
- "{CIncludes}"MacHelp.h ¶
- "{CIncludes}"CFString.h ¶
- "{CIncludes}"TextEdit.h ¶
- "{CIncludes}"Icons.h ¶
- "{CIncludes}"Collections.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"NameRegistry.h ¶
- "{CIncludes}"CodeFragments.h ¶
- "{CIncludes}"Multiprocessing.h ¶
- "{CIncludes}"DriverFamilyMatching.h ¶
- "{CIncludes}"Disks.h ¶
- "{CIncludes}"Events.h ¶
- "{CIncludes}"ATSTypes.h ¶
- "{CIncludes}"TextCommon.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"Aliases.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"CGContext.h ¶
- "{CIncludes}"IntlResources.h ¶
- "{CIncludes}"NumberFormatting.h ¶
- "{CIncludes}"StringCompare.h ¶
- "{CIncludes}"DateTimeUtils.h ¶
- "{CIncludes}"Notification.h ¶
- "{CIncludes}"Balloons.h ¶
- "{CIncludes}"CFBase.h ¶
- "{CIncludes}"CFArray.h ¶
- "{CIncludes}"CFData.h ¶
- "{CIncludes}"CFDictionary.h ¶
- "{CIncludes}"stdarg.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"CFBundle.h ¶
- "{CIncludes}"CGBase.h ¶
- "{CIncludes}"CGAffineTransform.h ¶
- "{CIncludes}"CGColorSpace.h ¶
- "{CIncludes}"CGFont.h ¶
- "{CIncludes}"CGImage.h ¶
- "{CIncludes}"CGPDFDocument.h ¶
- "{CIncludes}"TypeSelect.h ¶
- "{CIncludes}"CFURL.h ¶
- "{CIncludes}"stddef.h ¶
- "{CIncludes}"CGGeometry.h ¶
- "{CIncludes}"CGDataProvider.h
-
-:files.c.x Ä ¶
- :files.c ¶
- :main.h ¶
- "{CIncludes}"limits.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"stdio.h ¶
- "{CIncludes}"stdlib.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"AERegistry.h ¶
- "{CIncludes}"AppleEvents.h ¶
- "{CIncludes}"ControlDefinitions.h ¶
- "{CIncludes}"Controls.h ¶
- "{CIncludes}"Devices.h ¶
- "{CIncludes}"Dialogs.h ¶
- "{CIncludes}"DiskInit.h ¶
- "{CIncludes}"Drag.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"FixMath.h ¶
- "{CIncludes}"Folders.h ¶
- "{CIncludes}"Fonts.h ¶
- "{CIncludes}"Gestalt.h ¶
- "{CIncludes}"LowMem.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MacWindows.h ¶
- "{CIncludes}"Menus.h ¶
- "{CIncludes}"Power.h ¶
- "{CIncludes}"Printing.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"QDOffscreen.h ¶
- "{CIncludes}"QuickDraw.h ¶
- "{CIncludes}"Resources.h ¶
- "{CIncludes}"Scrap.h ¶
- "{CIncludes}"Script.h ¶
- "{CIncludes}"SegLoad.h ¶
- "{CIncludes}"Sound.h ¶
- "{CIncludes}"StandardFile.h ¶
- "{CIncludes}"Strings.h ¶
- "{CIncludes}"TextUtils.h ¶
- "{CIncludes}"ToolUtils.h ¶
- ::byterun:rotatecursor.h ¶
- :ocamlconstants.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"VaListTDef.h ¶
- "{CIncludes}"WCharTDef.h ¶
- "{CIncludes}"MacErrors.h ¶
- "{CIncludes}"MixedMode.h ¶
- "{CIncludes}"AEDataModel.h ¶
- "{CIncludes}"AEInteraction.h ¶
- "{CIncludes}"Appearance.h ¶
- "{CIncludes}"CarbonEvents.h ¶
- "{CIncludes}"Lists.h ¶
- "{CIncludes}"MacHelp.h ¶
- "{CIncludes}"CFString.h ¶
- "{CIncludes}"TextEdit.h ¶
- "{CIncludes}"Icons.h ¶
- "{CIncludes}"Collections.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"NameRegistry.h ¶
- "{CIncludes}"CodeFragments.h ¶
- "{CIncludes}"Multiprocessing.h ¶
- "{CIncludes}"DriverFamilyMatching.h ¶
- "{CIncludes}"Disks.h ¶
- "{CIncludes}"Events.h ¶
- "{CIncludes}"ATSTypes.h ¶
- "{CIncludes}"TextCommon.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"Aliases.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"CGContext.h ¶
- "{CIncludes}"IntlResources.h ¶
- "{CIncludes}"NumberFormatting.h ¶
- "{CIncludes}"StringCompare.h ¶
- "{CIncludes}"DateTimeUtils.h ¶
- "{CIncludes}"Notification.h ¶
- "{CIncludes}"Balloons.h ¶
- "{CIncludes}"CFBase.h ¶
- "{CIncludes}"CFArray.h ¶
- "{CIncludes}"CFData.h ¶
- "{CIncludes}"CFDictionary.h ¶
- "{CIncludes}"stdarg.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"CFBundle.h ¶
- "{CIncludes}"CGBase.h ¶
- "{CIncludes}"CGAffineTransform.h ¶
- "{CIncludes}"CGColorSpace.h ¶
- "{CIncludes}"CGFont.h ¶
- "{CIncludes}"CGImage.h ¶
- "{CIncludes}"CGPDFDocument.h ¶
- "{CIncludes}"TypeSelect.h ¶
- "{CIncludes}"CFURL.h ¶
- "{CIncludes}"stddef.h ¶
- "{CIncludes}"CGGeometry.h ¶
- "{CIncludes}"CGDataProvider.h
-
-:glue.c.x Ä ¶
- :glue.c ¶
- "{CIncludes}"CursorCtl.h ¶
- "{CIncludes}"fcntl.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"stdlib.h ¶
- :main.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"WCharTDef.h ¶
- "{CIncludes}"limits.h ¶
- "{CIncludes}"stdio.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"AERegistry.h ¶
- "{CIncludes}"AppleEvents.h ¶
- "{CIncludes}"ControlDefinitions.h ¶
- "{CIncludes}"Controls.h ¶
- "{CIncludes}"Devices.h ¶
- "{CIncludes}"Dialogs.h ¶
- "{CIncludes}"DiskInit.h ¶
- "{CIncludes}"Drag.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"FixMath.h ¶
- "{CIncludes}"Folders.h ¶
- "{CIncludes}"Fonts.h ¶
- "{CIncludes}"Gestalt.h ¶
- "{CIncludes}"LowMem.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MacWindows.h ¶
- "{CIncludes}"Menus.h ¶
- "{CIncludes}"Power.h ¶
- "{CIncludes}"Printing.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"QDOffscreen.h ¶
- "{CIncludes}"QuickDraw.h ¶
- "{CIncludes}"Resources.h ¶
- "{CIncludes}"Scrap.h ¶
- "{CIncludes}"Script.h ¶
- "{CIncludes}"SegLoad.h ¶
- "{CIncludes}"Sound.h ¶
- "{CIncludes}"StandardFile.h ¶
- "{CIncludes}"Strings.h ¶
- "{CIncludes}"TextUtils.h ¶
- "{CIncludes}"ToolUtils.h ¶
- ::byterun:rotatecursor.h ¶
- :ocamlconstants.h ¶
- "{CIncludes}"VaListTDef.h ¶
- "{CIncludes}"MacErrors.h ¶
- "{CIncludes}"MixedMode.h ¶
- "{CIncludes}"AEDataModel.h ¶
- "{CIncludes}"AEInteraction.h ¶
- "{CIncludes}"Appearance.h ¶
- "{CIncludes}"CarbonEvents.h ¶
- "{CIncludes}"Lists.h ¶
- "{CIncludes}"MacHelp.h ¶
- "{CIncludes}"CFString.h ¶
- "{CIncludes}"TextEdit.h ¶
- "{CIncludes}"Icons.h ¶
- "{CIncludes}"Collections.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"NameRegistry.h ¶
- "{CIncludes}"CodeFragments.h ¶
- "{CIncludes}"Multiprocessing.h ¶
- "{CIncludes}"DriverFamilyMatching.h ¶
- "{CIncludes}"Disks.h ¶
- "{CIncludes}"Events.h ¶
- "{CIncludes}"ATSTypes.h ¶
- "{CIncludes}"TextCommon.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"Aliases.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"CGContext.h ¶
- "{CIncludes}"IntlResources.h ¶
- "{CIncludes}"NumberFormatting.h ¶
- "{CIncludes}"StringCompare.h ¶
- "{CIncludes}"DateTimeUtils.h ¶
- "{CIncludes}"Notification.h ¶
- "{CIncludes}"Balloons.h ¶
- "{CIncludes}"CFBase.h ¶
- "{CIncludes}"CFArray.h ¶
- "{CIncludes}"CFData.h ¶
- "{CIncludes}"CFDictionary.h ¶
- "{CIncludes}"stdarg.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"CFBundle.h ¶
- "{CIncludes}"CGBase.h ¶
- "{CIncludes}"CGAffineTransform.h ¶
- "{CIncludes}"CGColorSpace.h ¶
- "{CIncludes}"CGFont.h ¶
- "{CIncludes}"CGImage.h ¶
- "{CIncludes}"CGPDFDocument.h ¶
- "{CIncludes}"TypeSelect.h ¶
- "{CIncludes}"CFURL.h ¶
- "{CIncludes}"stddef.h ¶
- "{CIncludes}"CGGeometry.h ¶
- "{CIncludes}"CGDataProvider.h
-
-:graph.c.x Ä ¶
- :graph.c ¶
- "{CIncludes}"memory.h ¶
- :main.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"limits.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"stdio.h ¶
- "{CIncludes}"stdlib.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"AERegistry.h ¶
- "{CIncludes}"AppleEvents.h ¶
- "{CIncludes}"ControlDefinitions.h ¶
- "{CIncludes}"Controls.h ¶
- "{CIncludes}"Devices.h ¶
- "{CIncludes}"Dialogs.h ¶
- "{CIncludes}"DiskInit.h ¶
- "{CIncludes}"Drag.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"FixMath.h ¶
- "{CIncludes}"Folders.h ¶
- "{CIncludes}"Fonts.h ¶
- "{CIncludes}"Gestalt.h ¶
- "{CIncludes}"LowMem.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MacWindows.h ¶
- "{CIncludes}"Menus.h ¶
- "{CIncludes}"Power.h ¶
- "{CIncludes}"Printing.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"QDOffscreen.h ¶
- "{CIncludes}"QuickDraw.h ¶
- "{CIncludes}"Resources.h ¶
- "{CIncludes}"Scrap.h ¶
- "{CIncludes}"Script.h ¶
- "{CIncludes}"SegLoad.h ¶
- "{CIncludes}"Sound.h ¶
- "{CIncludes}"StandardFile.h ¶
- "{CIncludes}"Strings.h ¶
- "{CIncludes}"TextUtils.h ¶
- "{CIncludes}"ToolUtils.h ¶
- ::byterun:rotatecursor.h ¶
- :ocamlconstants.h ¶
- "{CIncludes}"MixedMode.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"VaListTDef.h ¶
- "{CIncludes}"WCharTDef.h ¶
- "{CIncludes}"MacErrors.h ¶
- "{CIncludes}"AEDataModel.h ¶
- "{CIncludes}"AEInteraction.h ¶
- "{CIncludes}"Appearance.h ¶
- "{CIncludes}"CarbonEvents.h ¶
- "{CIncludes}"Lists.h ¶
- "{CIncludes}"MacHelp.h ¶
- "{CIncludes}"CFString.h ¶
- "{CIncludes}"TextEdit.h ¶
- "{CIncludes}"Icons.h ¶
- "{CIncludes}"Collections.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"NameRegistry.h ¶
- "{CIncludes}"CodeFragments.h ¶
- "{CIncludes}"Multiprocessing.h ¶
- "{CIncludes}"DriverFamilyMatching.h ¶
- "{CIncludes}"Disks.h ¶
- "{CIncludes}"Events.h ¶
- "{CIncludes}"ATSTypes.h ¶
- "{CIncludes}"TextCommon.h ¶
- "{CIncludes}"Aliases.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"CGContext.h ¶
- "{CIncludes}"IntlResources.h ¶
- "{CIncludes}"NumberFormatting.h ¶
- "{CIncludes}"StringCompare.h ¶
- "{CIncludes}"DateTimeUtils.h ¶
- "{CIncludes}"Notification.h ¶
- "{CIncludes}"Balloons.h ¶
- "{CIncludes}"CFBase.h ¶
- "{CIncludes}"CFArray.h ¶
- "{CIncludes}"CFData.h ¶
- "{CIncludes}"CFDictionary.h ¶
- "{CIncludes}"stdarg.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"CFBundle.h ¶
- "{CIncludes}"CGBase.h ¶
- "{CIncludes}"CGAffineTransform.h ¶
- "{CIncludes}"CGColorSpace.h ¶
- "{CIncludes}"CGFont.h ¶
- "{CIncludes}"CGImage.h ¶
- "{CIncludes}"CGPDFDocument.h ¶
- "{CIncludes}"TypeSelect.h ¶
- "{CIncludes}"CFURL.h ¶
- "{CIncludes}"stddef.h ¶
- "{CIncludes}"CGGeometry.h ¶
- "{CIncludes}"CGDataProvider.h
-
-:lcontrols.c.x Ä ¶
- :lcontrols.c ¶
- "{CIncludes}"Controls.h ¶
- "{CIncludes}"FixMath.h ¶
- "{CIncludes}"ToolUtils.h ¶
- :main.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"QuickDraw.h ¶
- "{CIncludes}"Menus.h ¶
- "{CIncludes}"TextEdit.h ¶
- "{CIncludes}"Drag.h ¶
- "{CIncludes}"Icons.h ¶
- "{CIncludes}"Collections.h ¶
- "{CIncludes}"MacErrors.h ¶
- "{CIncludes}"TextUtils.h ¶
- "{CIncludes}"limits.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"stdio.h ¶
- "{CIncludes}"stdlib.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"AERegistry.h ¶
- "{CIncludes}"AppleEvents.h ¶
- "{CIncludes}"ControlDefinitions.h ¶
- "{CIncludes}"Devices.h ¶
- "{CIncludes}"Dialogs.h ¶
- "{CIncludes}"DiskInit.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"Folders.h ¶
- "{CIncludes}"Fonts.h ¶
- "{CIncludes}"Gestalt.h ¶
- "{CIncludes}"LowMem.h ¶
- "{CIncludes}"MacWindows.h ¶
- "{CIncludes}"Power.h ¶
- "{CIncludes}"Printing.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"QDOffscreen.h ¶
- "{CIncludes}"Resources.h ¶
- "{CIncludes}"Scrap.h ¶
- "{CIncludes}"Script.h ¶
- "{CIncludes}"SegLoad.h ¶
- "{CIncludes}"Sound.h ¶
- "{CIncludes}"StandardFile.h ¶
- "{CIncludes}"Strings.h ¶
- ::byterun:rotatecursor.h ¶
- :ocamlconstants.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"MixedMode.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"CGContext.h ¶
- "{CIncludes}"Events.h ¶
- "{CIncludes}"TextCommon.h ¶
- "{CIncludes}"CFString.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"CodeFragments.h ¶
- "{CIncludes}"NumberFormatting.h ¶
- "{CIncludes}"StringCompare.h ¶
- "{CIncludes}"DateTimeUtils.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"VaListTDef.h ¶
- "{CIncludes}"WCharTDef.h ¶
- "{CIncludes}"AEDataModel.h ¶
- "{CIncludes}"AEInteraction.h ¶
- "{CIncludes}"Appearance.h ¶
- "{CIncludes}"CarbonEvents.h ¶
- "{CIncludes}"Lists.h ¶
- "{CIncludes}"MacHelp.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"NameRegistry.h ¶
- "{CIncludes}"Multiprocessing.h ¶
- "{CIncludes}"DriverFamilyMatching.h ¶
- "{CIncludes}"Disks.h ¶
- "{CIncludes}"ATSTypes.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"Aliases.h ¶
- "{CIncludes}"IntlResources.h ¶
- "{CIncludes}"CGBase.h ¶
- "{CIncludes}"CGAffineTransform.h ¶
- "{CIncludes}"CGColorSpace.h ¶
- "{CIncludes}"CGFont.h ¶
- "{CIncludes}"CGImage.h ¶
- "{CIncludes}"CGPDFDocument.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"CFBase.h ¶
- "{CIncludes}"CFArray.h ¶
- "{CIncludes}"CFData.h ¶
- "{CIncludes}"CFDictionary.h ¶
- "{CIncludes}"stdarg.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"CFBundle.h ¶
- "{CIncludes}"TypeSelect.h ¶
- "{CIncludes}"Notification.h ¶
- "{CIncludes}"Balloons.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"stddef.h ¶
- "{CIncludes}"CGGeometry.h ¶
- "{CIncludes}"CGDataProvider.h ¶
- "{CIncludes}"CFURL.h
-
-:lib.c.x Ä ¶
- :lib.c ¶
- :main.h ¶
- "{CIncludes}"limits.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"stdio.h ¶
- "{CIncludes}"stdlib.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"AERegistry.h ¶
- "{CIncludes}"AppleEvents.h ¶
- "{CIncludes}"ControlDefinitions.h ¶
- "{CIncludes}"Controls.h ¶
- "{CIncludes}"Devices.h ¶
- "{CIncludes}"Dialogs.h ¶
- "{CIncludes}"DiskInit.h ¶
- "{CIncludes}"Drag.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"FixMath.h ¶
- "{CIncludes}"Folders.h ¶
- "{CIncludes}"Fonts.h ¶
- "{CIncludes}"Gestalt.h ¶
- "{CIncludes}"LowMem.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MacWindows.h ¶
- "{CIncludes}"Menus.h ¶
- "{CIncludes}"Power.h ¶
- "{CIncludes}"Printing.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"QDOffscreen.h ¶
- "{CIncludes}"QuickDraw.h ¶
- "{CIncludes}"Resources.h ¶
- "{CIncludes}"Scrap.h ¶
- "{CIncludes}"Script.h ¶
- "{CIncludes}"SegLoad.h ¶
- "{CIncludes}"Sound.h ¶
- "{CIncludes}"StandardFile.h ¶
- "{CIncludes}"Strings.h ¶
- "{CIncludes}"TextUtils.h ¶
- "{CIncludes}"ToolUtils.h ¶
- ::byterun:rotatecursor.h ¶
- :ocamlconstants.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"VaListTDef.h ¶
- "{CIncludes}"WCharTDef.h ¶
- "{CIncludes}"MacErrors.h ¶
- "{CIncludes}"MixedMode.h ¶
- "{CIncludes}"AEDataModel.h ¶
- "{CIncludes}"AEInteraction.h ¶
- "{CIncludes}"Appearance.h ¶
- "{CIncludes}"CarbonEvents.h ¶
- "{CIncludes}"Lists.h ¶
- "{CIncludes}"MacHelp.h ¶
- "{CIncludes}"CFString.h ¶
- "{CIncludes}"TextEdit.h ¶
- "{CIncludes}"Icons.h ¶
- "{CIncludes}"Collections.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"NameRegistry.h ¶
- "{CIncludes}"CodeFragments.h ¶
- "{CIncludes}"Multiprocessing.h ¶
- "{CIncludes}"DriverFamilyMatching.h ¶
- "{CIncludes}"Disks.h ¶
- "{CIncludes}"Events.h ¶
- "{CIncludes}"ATSTypes.h ¶
- "{CIncludes}"TextCommon.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"Aliases.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"CGContext.h ¶
- "{CIncludes}"IntlResources.h ¶
- "{CIncludes}"NumberFormatting.h ¶
- "{CIncludes}"StringCompare.h ¶
- "{CIncludes}"DateTimeUtils.h ¶
- "{CIncludes}"Notification.h ¶
- "{CIncludes}"Balloons.h ¶
- "{CIncludes}"CFBase.h ¶
- "{CIncludes}"CFArray.h ¶
- "{CIncludes}"CFData.h ¶
- "{CIncludes}"CFDictionary.h ¶
- "{CIncludes}"stdarg.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"CFBundle.h ¶
- "{CIncludes}"CGBase.h ¶
- "{CIncludes}"CGAffineTransform.h ¶
- "{CIncludes}"CGColorSpace.h ¶
- "{CIncludes}"CGFont.h ¶
- "{CIncludes}"CGImage.h ¶
- "{CIncludes}"CGPDFDocument.h ¶
- "{CIncludes}"TypeSelect.h ¶
- "{CIncludes}"CFURL.h ¶
- "{CIncludes}"stddef.h ¶
- "{CIncludes}"CGGeometry.h ¶
- "{CIncludes}"CGDataProvider.h
-
-:main.c.x Ä ¶
- :main.c ¶
- :main.h ¶
- "{CIncludes}"limits.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"stdio.h ¶
- "{CIncludes}"stdlib.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"AERegistry.h ¶
- "{CIncludes}"AppleEvents.h ¶
- "{CIncludes}"ControlDefinitions.h ¶
- "{CIncludes}"Controls.h ¶
- "{CIncludes}"Devices.h ¶
- "{CIncludes}"Dialogs.h ¶
- "{CIncludes}"DiskInit.h ¶
- "{CIncludes}"Drag.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"FixMath.h ¶
- "{CIncludes}"Folders.h ¶
- "{CIncludes}"Fonts.h ¶
- "{CIncludes}"Gestalt.h ¶
- "{CIncludes}"LowMem.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MacWindows.h ¶
- "{CIncludes}"Menus.h ¶
- "{CIncludes}"Power.h ¶
- "{CIncludes}"Printing.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"QDOffscreen.h ¶
- "{CIncludes}"QuickDraw.h ¶
- "{CIncludes}"Resources.h ¶
- "{CIncludes}"Scrap.h ¶
- "{CIncludes}"Script.h ¶
- "{CIncludes}"SegLoad.h ¶
- "{CIncludes}"Sound.h ¶
- "{CIncludes}"StandardFile.h ¶
- "{CIncludes}"Strings.h ¶
- "{CIncludes}"TextUtils.h ¶
- "{CIncludes}"ToolUtils.h ¶
- ::byterun:rotatecursor.h ¶
- :ocamlconstants.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"VaListTDef.h ¶
- "{CIncludes}"WCharTDef.h ¶
- "{CIncludes}"MacErrors.h ¶
- "{CIncludes}"MixedMode.h ¶
- "{CIncludes}"AEDataModel.h ¶
- "{CIncludes}"AEInteraction.h ¶
- "{CIncludes}"Appearance.h ¶
- "{CIncludes}"CarbonEvents.h ¶
- "{CIncludes}"Lists.h ¶
- "{CIncludes}"MacHelp.h ¶
- "{CIncludes}"CFString.h ¶
- "{CIncludes}"TextEdit.h ¶
- "{CIncludes}"Icons.h ¶
- "{CIncludes}"Collections.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"NameRegistry.h ¶
- "{CIncludes}"CodeFragments.h ¶
- "{CIncludes}"Multiprocessing.h ¶
- "{CIncludes}"DriverFamilyMatching.h ¶
- "{CIncludes}"Disks.h ¶
- "{CIncludes}"Events.h ¶
- "{CIncludes}"ATSTypes.h ¶
- "{CIncludes}"TextCommon.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"Aliases.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"CGContext.h ¶
- "{CIncludes}"IntlResources.h ¶
- "{CIncludes}"NumberFormatting.h ¶
- "{CIncludes}"StringCompare.h ¶
- "{CIncludes}"DateTimeUtils.h ¶
- "{CIncludes}"Notification.h ¶
- "{CIncludes}"Balloons.h ¶
- "{CIncludes}"CFBase.h ¶
- "{CIncludes}"CFArray.h ¶
- "{CIncludes}"CFData.h ¶
- "{CIncludes}"CFDictionary.h ¶
- "{CIncludes}"stdarg.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"CFBundle.h ¶
- "{CIncludes}"CGBase.h ¶
- "{CIncludes}"CGAffineTransform.h ¶
- "{CIncludes}"CGColorSpace.h ¶
- "{CIncludes}"CGFont.h ¶
- "{CIncludes}"CGImage.h ¶
- "{CIncludes}"CGPDFDocument.h ¶
- "{CIncludes}"TypeSelect.h ¶
- "{CIncludes}"CFURL.h ¶
- "{CIncludes}"stddef.h ¶
- "{CIncludes}"CGGeometry.h ¶
- "{CIncludes}"CGDataProvider.h
-
-:mcmemory.c.x Ä ¶
- :mcmemory.c ¶
- :main.h ¶
- "{CIncludes}"limits.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"stdio.h ¶
- "{CIncludes}"stdlib.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"AERegistry.h ¶
- "{CIncludes}"AppleEvents.h ¶
- "{CIncludes}"ControlDefinitions.h ¶
- "{CIncludes}"Controls.h ¶
- "{CIncludes}"Devices.h ¶
- "{CIncludes}"Dialogs.h ¶
- "{CIncludes}"DiskInit.h ¶
- "{CIncludes}"Drag.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"FixMath.h ¶
- "{CIncludes}"Folders.h ¶
- "{CIncludes}"Fonts.h ¶
- "{CIncludes}"Gestalt.h ¶
- "{CIncludes}"LowMem.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MacWindows.h ¶
- "{CIncludes}"Menus.h ¶
- "{CIncludes}"Power.h ¶
- "{CIncludes}"Printing.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"QDOffscreen.h ¶
- "{CIncludes}"QuickDraw.h ¶
- "{CIncludes}"Resources.h ¶
- "{CIncludes}"Scrap.h ¶
- "{CIncludes}"Script.h ¶
- "{CIncludes}"SegLoad.h ¶
- "{CIncludes}"Sound.h ¶
- "{CIncludes}"StandardFile.h ¶
- "{CIncludes}"Strings.h ¶
- "{CIncludes}"TextUtils.h ¶
- "{CIncludes}"ToolUtils.h ¶
- ::byterun:rotatecursor.h ¶
- :ocamlconstants.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"VaListTDef.h ¶
- "{CIncludes}"WCharTDef.h ¶
- "{CIncludes}"MacErrors.h ¶
- "{CIncludes}"MixedMode.h ¶
- "{CIncludes}"AEDataModel.h ¶
- "{CIncludes}"AEInteraction.h ¶
- "{CIncludes}"Appearance.h ¶
- "{CIncludes}"CarbonEvents.h ¶
- "{CIncludes}"Lists.h ¶
- "{CIncludes}"MacHelp.h ¶
- "{CIncludes}"CFString.h ¶
- "{CIncludes}"TextEdit.h ¶
- "{CIncludes}"Icons.h ¶
- "{CIncludes}"Collections.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"NameRegistry.h ¶
- "{CIncludes}"CodeFragments.h ¶
- "{CIncludes}"Multiprocessing.h ¶
- "{CIncludes}"DriverFamilyMatching.h ¶
- "{CIncludes}"Disks.h ¶
- "{CIncludes}"Events.h ¶
- "{CIncludes}"ATSTypes.h ¶
- "{CIncludes}"TextCommon.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"Aliases.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"CGContext.h ¶
- "{CIncludes}"IntlResources.h ¶
- "{CIncludes}"NumberFormatting.h ¶
- "{CIncludes}"StringCompare.h ¶
- "{CIncludes}"DateTimeUtils.h ¶
- "{CIncludes}"Notification.h ¶
- "{CIncludes}"Balloons.h ¶
- "{CIncludes}"CFBase.h ¶
- "{CIncludes}"CFArray.h ¶
- "{CIncludes}"CFData.h ¶
- "{CIncludes}"CFDictionary.h ¶
- "{CIncludes}"stdarg.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"CFBundle.h ¶
- "{CIncludes}"CGBase.h ¶
- "{CIncludes}"CGAffineTransform.h ¶
- "{CIncludes}"CGColorSpace.h ¶
- "{CIncludes}"CGFont.h ¶
- "{CIncludes}"CGImage.h ¶
- "{CIncludes}"CGPDFDocument.h ¶
- "{CIncludes}"TypeSelect.h ¶
- "{CIncludes}"CFURL.h ¶
- "{CIncludes}"stddef.h ¶
- "{CIncludes}"CGGeometry.h ¶
- "{CIncludes}"CGDataProvider.h
-
-:mcmisc.c.x Ä ¶
- :mcmisc.c ¶
- :main.h ¶
- "{CIncludes}"limits.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"stdio.h ¶
- "{CIncludes}"stdlib.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"AERegistry.h ¶
- "{CIncludes}"AppleEvents.h ¶
- "{CIncludes}"ControlDefinitions.h ¶
- "{CIncludes}"Controls.h ¶
- "{CIncludes}"Devices.h ¶
- "{CIncludes}"Dialogs.h ¶
- "{CIncludes}"DiskInit.h ¶
- "{CIncludes}"Drag.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"FixMath.h ¶
- "{CIncludes}"Folders.h ¶
- "{CIncludes}"Fonts.h ¶
- "{CIncludes}"Gestalt.h ¶
- "{CIncludes}"LowMem.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MacWindows.h ¶
- "{CIncludes}"Menus.h ¶
- "{CIncludes}"Power.h ¶
- "{CIncludes}"Printing.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"QDOffscreen.h ¶
- "{CIncludes}"QuickDraw.h ¶
- "{CIncludes}"Resources.h ¶
- "{CIncludes}"Scrap.h ¶
- "{CIncludes}"Script.h ¶
- "{CIncludes}"SegLoad.h ¶
- "{CIncludes}"Sound.h ¶
- "{CIncludes}"StandardFile.h ¶
- "{CIncludes}"Strings.h ¶
- "{CIncludes}"TextUtils.h ¶
- "{CIncludes}"ToolUtils.h ¶
- ::byterun:rotatecursor.h ¶
- :ocamlconstants.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"VaListTDef.h ¶
- "{CIncludes}"WCharTDef.h ¶
- "{CIncludes}"MacErrors.h ¶
- "{CIncludes}"MixedMode.h ¶
- "{CIncludes}"AEDataModel.h ¶
- "{CIncludes}"AEInteraction.h ¶
- "{CIncludes}"Appearance.h ¶
- "{CIncludes}"CarbonEvents.h ¶
- "{CIncludes}"Lists.h ¶
- "{CIncludes}"MacHelp.h ¶
- "{CIncludes}"CFString.h ¶
- "{CIncludes}"TextEdit.h ¶
- "{CIncludes}"Icons.h ¶
- "{CIncludes}"Collections.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"NameRegistry.h ¶
- "{CIncludes}"CodeFragments.h ¶
- "{CIncludes}"Multiprocessing.h ¶
- "{CIncludes}"DriverFamilyMatching.h ¶
- "{CIncludes}"Disks.h ¶
- "{CIncludes}"Events.h ¶
- "{CIncludes}"ATSTypes.h ¶
- "{CIncludes}"TextCommon.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"Aliases.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"CGContext.h ¶
- "{CIncludes}"IntlResources.h ¶
- "{CIncludes}"NumberFormatting.h ¶
- "{CIncludes}"StringCompare.h ¶
- "{CIncludes}"DateTimeUtils.h ¶
- "{CIncludes}"Notification.h ¶
- "{CIncludes}"Balloons.h ¶
- "{CIncludes}"CFBase.h ¶
- "{CIncludes}"CFArray.h ¶
- "{CIncludes}"CFData.h ¶
- "{CIncludes}"CFDictionary.h ¶
- "{CIncludes}"stdarg.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"CFBundle.h ¶
- "{CIncludes}"CGBase.h ¶
- "{CIncludes}"CGAffineTransform.h ¶
- "{CIncludes}"CGColorSpace.h ¶
- "{CIncludes}"CGFont.h ¶
- "{CIncludes}"CGImage.h ¶
- "{CIncludes}"CGPDFDocument.h ¶
- "{CIncludes}"TypeSelect.h ¶
- "{CIncludes}"CFURL.h ¶
- "{CIncludes}"stddef.h ¶
- "{CIncludes}"CGGeometry.h ¶
- "{CIncludes}"CGDataProvider.h
-
-:menus.c.x Ä ¶
- :menus.c ¶
- :main.h ¶
- "{CIncludes}"limits.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"stdio.h ¶
- "{CIncludes}"stdlib.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"AERegistry.h ¶
- "{CIncludes}"AppleEvents.h ¶
- "{CIncludes}"ControlDefinitions.h ¶
- "{CIncludes}"Controls.h ¶
- "{CIncludes}"Devices.h ¶
- "{CIncludes}"Dialogs.h ¶
- "{CIncludes}"DiskInit.h ¶
- "{CIncludes}"Drag.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"FixMath.h ¶
- "{CIncludes}"Folders.h ¶
- "{CIncludes}"Fonts.h ¶
- "{CIncludes}"Gestalt.h ¶
- "{CIncludes}"LowMem.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MacWindows.h ¶
- "{CIncludes}"Menus.h ¶
- "{CIncludes}"Power.h ¶
- "{CIncludes}"Printing.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"QDOffscreen.h ¶
- "{CIncludes}"QuickDraw.h ¶
- "{CIncludes}"Resources.h ¶
- "{CIncludes}"Scrap.h ¶
- "{CIncludes}"Script.h ¶
- "{CIncludes}"SegLoad.h ¶
- "{CIncludes}"Sound.h ¶
- "{CIncludes}"StandardFile.h ¶
- "{CIncludes}"Strings.h ¶
- "{CIncludes}"TextUtils.h ¶
- "{CIncludes}"ToolUtils.h ¶
- ::byterun:rotatecursor.h ¶
- :ocamlconstants.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"VaListTDef.h ¶
- "{CIncludes}"WCharTDef.h ¶
- "{CIncludes}"MacErrors.h ¶
- "{CIncludes}"MixedMode.h ¶
- "{CIncludes}"AEDataModel.h ¶
- "{CIncludes}"AEInteraction.h ¶
- "{CIncludes}"Appearance.h ¶
- "{CIncludes}"CarbonEvents.h ¶
- "{CIncludes}"Lists.h ¶
- "{CIncludes}"MacHelp.h ¶
- "{CIncludes}"CFString.h ¶
- "{CIncludes}"TextEdit.h ¶
- "{CIncludes}"Icons.h ¶
- "{CIncludes}"Collections.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"NameRegistry.h ¶
- "{CIncludes}"CodeFragments.h ¶
- "{CIncludes}"Multiprocessing.h ¶
- "{CIncludes}"DriverFamilyMatching.h ¶
- "{CIncludes}"Disks.h ¶
- "{CIncludes}"Events.h ¶
- "{CIncludes}"ATSTypes.h ¶
- "{CIncludes}"TextCommon.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"Aliases.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"CGContext.h ¶
- "{CIncludes}"IntlResources.h ¶
- "{CIncludes}"NumberFormatting.h ¶
- "{CIncludes}"StringCompare.h ¶
- "{CIncludes}"DateTimeUtils.h ¶
- "{CIncludes}"Notification.h ¶
- "{CIncludes}"Balloons.h ¶
- "{CIncludes}"CFBase.h ¶
- "{CIncludes}"CFArray.h ¶
- "{CIncludes}"CFData.h ¶
- "{CIncludes}"CFDictionary.h ¶
- "{CIncludes}"stdarg.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"CFBundle.h ¶
- "{CIncludes}"CGBase.h ¶
- "{CIncludes}"CGAffineTransform.h ¶
- "{CIncludes}"CGColorSpace.h ¶
- "{CIncludes}"CGFont.h ¶
- "{CIncludes}"CGImage.h ¶
- "{CIncludes}"CGPDFDocument.h ¶
- "{CIncludes}"TypeSelect.h ¶
- "{CIncludes}"CFURL.h ¶
- "{CIncludes}"stddef.h ¶
- "{CIncludes}"CGGeometry.h ¶
- "{CIncludes}"CGDataProvider.h
-
-:modalfilter.c.x Ä ¶
- :modalfilter.c ¶
- :main.h ¶
- "{CIncludes}"limits.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"stdio.h ¶
- "{CIncludes}"stdlib.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"AERegistry.h ¶
- "{CIncludes}"AppleEvents.h ¶
- "{CIncludes}"ControlDefinitions.h ¶
- "{CIncludes}"Controls.h ¶
- "{CIncludes}"Devices.h ¶
- "{CIncludes}"Dialogs.h ¶
- "{CIncludes}"DiskInit.h ¶
- "{CIncludes}"Drag.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"FixMath.h ¶
- "{CIncludes}"Folders.h ¶
- "{CIncludes}"Fonts.h ¶
- "{CIncludes}"Gestalt.h ¶
- "{CIncludes}"LowMem.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MacWindows.h ¶
- "{CIncludes}"Menus.h ¶
- "{CIncludes}"Power.h ¶
- "{CIncludes}"Printing.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"QDOffscreen.h ¶
- "{CIncludes}"QuickDraw.h ¶
- "{CIncludes}"Resources.h ¶
- "{CIncludes}"Scrap.h ¶
- "{CIncludes}"Script.h ¶
- "{CIncludes}"SegLoad.h ¶
- "{CIncludes}"Sound.h ¶
- "{CIncludes}"StandardFile.h ¶
- "{CIncludes}"Strings.h ¶
- "{CIncludes}"TextUtils.h ¶
- "{CIncludes}"ToolUtils.h ¶
- ::byterun:rotatecursor.h ¶
- :ocamlconstants.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"VaListTDef.h ¶
- "{CIncludes}"WCharTDef.h ¶
- "{CIncludes}"MacErrors.h ¶
- "{CIncludes}"MixedMode.h ¶
- "{CIncludes}"AEDataModel.h ¶
- "{CIncludes}"AEInteraction.h ¶
- "{CIncludes}"Appearance.h ¶
- "{CIncludes}"CarbonEvents.h ¶
- "{CIncludes}"Lists.h ¶
- "{CIncludes}"MacHelp.h ¶
- "{CIncludes}"CFString.h ¶
- "{CIncludes}"TextEdit.h ¶
- "{CIncludes}"Icons.h ¶
- "{CIncludes}"Collections.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"NameRegistry.h ¶
- "{CIncludes}"CodeFragments.h ¶
- "{CIncludes}"Multiprocessing.h ¶
- "{CIncludes}"DriverFamilyMatching.h ¶
- "{CIncludes}"Disks.h ¶
- "{CIncludes}"Events.h ¶
- "{CIncludes}"ATSTypes.h ¶
- "{CIncludes}"TextCommon.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"Aliases.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"CGContext.h ¶
- "{CIncludes}"IntlResources.h ¶
- "{CIncludes}"NumberFormatting.h ¶
- "{CIncludes}"StringCompare.h ¶
- "{CIncludes}"DateTimeUtils.h ¶
- "{CIncludes}"Notification.h ¶
- "{CIncludes}"Balloons.h ¶
- "{CIncludes}"CFBase.h ¶
- "{CIncludes}"CFArray.h ¶
- "{CIncludes}"CFData.h ¶
- "{CIncludes}"CFDictionary.h ¶
- "{CIncludes}"stdarg.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"CFBundle.h ¶
- "{CIncludes}"CGBase.h ¶
- "{CIncludes}"CGAffineTransform.h ¶
- "{CIncludes}"CGColorSpace.h ¶
- "{CIncludes}"CGFont.h ¶
- "{CIncludes}"CGImage.h ¶
- "{CIncludes}"CGPDFDocument.h ¶
- "{CIncludes}"TypeSelect.h ¶
- "{CIncludes}"CFURL.h ¶
- "{CIncludes}"stddef.h ¶
- "{CIncludes}"CGGeometry.h ¶
- "{CIncludes}"CGDataProvider.h
-
-:prefs.c.x Ä ¶
- :prefs.c ¶
- :main.h ¶
- "{CIncludes}"limits.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"stdio.h ¶
- "{CIncludes}"stdlib.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"AERegistry.h ¶
- "{CIncludes}"AppleEvents.h ¶
- "{CIncludes}"ControlDefinitions.h ¶
- "{CIncludes}"Controls.h ¶
- "{CIncludes}"Devices.h ¶
- "{CIncludes}"Dialogs.h ¶
- "{CIncludes}"DiskInit.h ¶
- "{CIncludes}"Drag.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"FixMath.h ¶
- "{CIncludes}"Folders.h ¶
- "{CIncludes}"Fonts.h ¶
- "{CIncludes}"Gestalt.h ¶
- "{CIncludes}"LowMem.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MacWindows.h ¶
- "{CIncludes}"Menus.h ¶
- "{CIncludes}"Power.h ¶
- "{CIncludes}"Printing.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"QDOffscreen.h ¶
- "{CIncludes}"QuickDraw.h ¶
- "{CIncludes}"Resources.h ¶
- "{CIncludes}"Scrap.h ¶
- "{CIncludes}"Script.h ¶
- "{CIncludes}"SegLoad.h ¶
- "{CIncludes}"Sound.h ¶
- "{CIncludes}"StandardFile.h ¶
- "{CIncludes}"Strings.h ¶
- "{CIncludes}"TextUtils.h ¶
- "{CIncludes}"ToolUtils.h ¶
- ::byterun:rotatecursor.h ¶
- :ocamlconstants.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"VaListTDef.h ¶
- "{CIncludes}"WCharTDef.h ¶
- "{CIncludes}"MacErrors.h ¶
- "{CIncludes}"MixedMode.h ¶
- "{CIncludes}"AEDataModel.h ¶
- "{CIncludes}"AEInteraction.h ¶
- "{CIncludes}"Appearance.h ¶
- "{CIncludes}"CarbonEvents.h ¶
- "{CIncludes}"Lists.h ¶
- "{CIncludes}"MacHelp.h ¶
- "{CIncludes}"CFString.h ¶
- "{CIncludes}"TextEdit.h ¶
- "{CIncludes}"Icons.h ¶
- "{CIncludes}"Collections.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"NameRegistry.h ¶
- "{CIncludes}"CodeFragments.h ¶
- "{CIncludes}"Multiprocessing.h ¶
- "{CIncludes}"DriverFamilyMatching.h ¶
- "{CIncludes}"Disks.h ¶
- "{CIncludes}"Events.h ¶
- "{CIncludes}"ATSTypes.h ¶
- "{CIncludes}"TextCommon.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"Aliases.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"CGContext.h ¶
- "{CIncludes}"IntlResources.h ¶
- "{CIncludes}"NumberFormatting.h ¶
- "{CIncludes}"StringCompare.h ¶
- "{CIncludes}"DateTimeUtils.h ¶
- "{CIncludes}"Notification.h ¶
- "{CIncludes}"Balloons.h ¶
- "{CIncludes}"CFBase.h ¶
- "{CIncludes}"CFArray.h ¶
- "{CIncludes}"CFData.h ¶
- "{CIncludes}"CFDictionary.h ¶
- "{CIncludes}"stdarg.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"CFBundle.h ¶
- "{CIncludes}"CGBase.h ¶
- "{CIncludes}"CGAffineTransform.h ¶
- "{CIncludes}"CGColorSpace.h ¶
- "{CIncludes}"CGFont.h ¶
- "{CIncludes}"CGImage.h ¶
- "{CIncludes}"CGPDFDocument.h ¶
- "{CIncludes}"TypeSelect.h ¶
- "{CIncludes}"CFURL.h ¶
- "{CIncludes}"stddef.h ¶
- "{CIncludes}"CGGeometry.h ¶
- "{CIncludes}"CGDataProvider.h
-
-:prims.c.x Ä ¶
- :prims.c
-
-:print.c.x Ä ¶
- :print.c ¶
- :main.h ¶
- "{CIncludes}"limits.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"stdio.h ¶
- "{CIncludes}"stdlib.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"AERegistry.h ¶
- "{CIncludes}"AppleEvents.h ¶
- "{CIncludes}"ControlDefinitions.h ¶
- "{CIncludes}"Controls.h ¶
- "{CIncludes}"Devices.h ¶
- "{CIncludes}"Dialogs.h ¶
- "{CIncludes}"DiskInit.h ¶
- "{CIncludes}"Drag.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"FixMath.h ¶
- "{CIncludes}"Folders.h ¶
- "{CIncludes}"Fonts.h ¶
- "{CIncludes}"Gestalt.h ¶
- "{CIncludes}"LowMem.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MacWindows.h ¶
- "{CIncludes}"Menus.h ¶
- "{CIncludes}"Power.h ¶
- "{CIncludes}"Printing.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"QDOffscreen.h ¶
- "{CIncludes}"QuickDraw.h ¶
- "{CIncludes}"Resources.h ¶
- "{CIncludes}"Scrap.h ¶
- "{CIncludes}"Script.h ¶
- "{CIncludes}"SegLoad.h ¶
- "{CIncludes}"Sound.h ¶
- "{CIncludes}"StandardFile.h ¶
- "{CIncludes}"Strings.h ¶
- "{CIncludes}"TextUtils.h ¶
- "{CIncludes}"ToolUtils.h ¶
- ::byterun:rotatecursor.h ¶
- :ocamlconstants.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"VaListTDef.h ¶
- "{CIncludes}"WCharTDef.h ¶
- "{CIncludes}"MacErrors.h ¶
- "{CIncludes}"MixedMode.h ¶
- "{CIncludes}"AEDataModel.h ¶
- "{CIncludes}"AEInteraction.h ¶
- "{CIncludes}"Appearance.h ¶
- "{CIncludes}"CarbonEvents.h ¶
- "{CIncludes}"Lists.h ¶
- "{CIncludes}"MacHelp.h ¶
- "{CIncludes}"CFString.h ¶
- "{CIncludes}"TextEdit.h ¶
- "{CIncludes}"Icons.h ¶
- "{CIncludes}"Collections.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"NameRegistry.h ¶
- "{CIncludes}"CodeFragments.h ¶
- "{CIncludes}"Multiprocessing.h ¶
- "{CIncludes}"DriverFamilyMatching.h ¶
- "{CIncludes}"Disks.h ¶
- "{CIncludes}"Events.h ¶
- "{CIncludes}"ATSTypes.h ¶
- "{CIncludes}"TextCommon.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"Aliases.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"CGContext.h ¶
- "{CIncludes}"IntlResources.h ¶
- "{CIncludes}"NumberFormatting.h ¶
- "{CIncludes}"StringCompare.h ¶
- "{CIncludes}"DateTimeUtils.h ¶
- "{CIncludes}"Notification.h ¶
- "{CIncludes}"Balloons.h ¶
- "{CIncludes}"CFBase.h ¶
- "{CIncludes}"CFArray.h ¶
- "{CIncludes}"CFData.h ¶
- "{CIncludes}"CFDictionary.h ¶
- "{CIncludes}"stdarg.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"CFBundle.h ¶
- "{CIncludes}"CGBase.h ¶
- "{CIncludes}"CGAffineTransform.h ¶
- "{CIncludes}"CGColorSpace.h ¶
- "{CIncludes}"CGFont.h ¶
- "{CIncludes}"CGImage.h ¶
- "{CIncludes}"CGPDFDocument.h ¶
- "{CIncludes}"TypeSelect.h ¶
- "{CIncludes}"CFURL.h ¶
- "{CIncludes}"stddef.h ¶
- "{CIncludes}"CGGeometry.h ¶
- "{CIncludes}"CGDataProvider.h
-
-:scroll.c.x Ä ¶
- :scroll.c ¶
- :main.h ¶
- "{CIncludes}"limits.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"stdio.h ¶
- "{CIncludes}"stdlib.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"AERegistry.h ¶
- "{CIncludes}"AppleEvents.h ¶
- "{CIncludes}"ControlDefinitions.h ¶
- "{CIncludes}"Controls.h ¶
- "{CIncludes}"Devices.h ¶
- "{CIncludes}"Dialogs.h ¶
- "{CIncludes}"DiskInit.h ¶
- "{CIncludes}"Drag.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"FixMath.h ¶
- "{CIncludes}"Folders.h ¶
- "{CIncludes}"Fonts.h ¶
- "{CIncludes}"Gestalt.h ¶
- "{CIncludes}"LowMem.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MacWindows.h ¶
- "{CIncludes}"Menus.h ¶
- "{CIncludes}"Power.h ¶
- "{CIncludes}"Printing.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"QDOffscreen.h ¶
- "{CIncludes}"QuickDraw.h ¶
- "{CIncludes}"Resources.h ¶
- "{CIncludes}"Scrap.h ¶
- "{CIncludes}"Script.h ¶
- "{CIncludes}"SegLoad.h ¶
- "{CIncludes}"Sound.h ¶
- "{CIncludes}"StandardFile.h ¶
- "{CIncludes}"Strings.h ¶
- "{CIncludes}"TextUtils.h ¶
- "{CIncludes}"ToolUtils.h ¶
- ::byterun:rotatecursor.h ¶
- :ocamlconstants.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"VaListTDef.h ¶
- "{CIncludes}"WCharTDef.h ¶
- "{CIncludes}"MacErrors.h ¶
- "{CIncludes}"MixedMode.h ¶
- "{CIncludes}"AEDataModel.h ¶
- "{CIncludes}"AEInteraction.h ¶
- "{CIncludes}"Appearance.h ¶
- "{CIncludes}"CarbonEvents.h ¶
- "{CIncludes}"Lists.h ¶
- "{CIncludes}"MacHelp.h ¶
- "{CIncludes}"CFString.h ¶
- "{CIncludes}"TextEdit.h ¶
- "{CIncludes}"Icons.h ¶
- "{CIncludes}"Collections.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"NameRegistry.h ¶
- "{CIncludes}"CodeFragments.h ¶
- "{CIncludes}"Multiprocessing.h ¶
- "{CIncludes}"DriverFamilyMatching.h ¶
- "{CIncludes}"Disks.h ¶
- "{CIncludes}"Events.h ¶
- "{CIncludes}"ATSTypes.h ¶
- "{CIncludes}"TextCommon.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"Aliases.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"CGContext.h ¶
- "{CIncludes}"IntlResources.h ¶
- "{CIncludes}"NumberFormatting.h ¶
- "{CIncludes}"StringCompare.h ¶
- "{CIncludes}"DateTimeUtils.h ¶
- "{CIncludes}"Notification.h ¶
- "{CIncludes}"Balloons.h ¶
- "{CIncludes}"CFBase.h ¶
- "{CIncludes}"CFArray.h ¶
- "{CIncludes}"CFData.h ¶
- "{CIncludes}"CFDictionary.h ¶
- "{CIncludes}"stdarg.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"CFBundle.h ¶
- "{CIncludes}"CGBase.h ¶
- "{CIncludes}"CGAffineTransform.h ¶
- "{CIncludes}"CGColorSpace.h ¶
- "{CIncludes}"CGFont.h ¶
- "{CIncludes}"CGImage.h ¶
- "{CIncludes}"CGPDFDocument.h ¶
- "{CIncludes}"TypeSelect.h ¶
- "{CIncludes}"CFURL.h ¶
- "{CIncludes}"stddef.h ¶
- "{CIncludes}"CGGeometry.h ¶
- "{CIncludes}"CGDataProvider.h
-
-:windows.c.x Ä ¶
- :windows.c ¶
- :main.h ¶
- "{CIncludes}"limits.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"stdio.h ¶
- "{CIncludes}"stdlib.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"AERegistry.h ¶
- "{CIncludes}"AppleEvents.h ¶
- "{CIncludes}"ControlDefinitions.h ¶
- "{CIncludes}"Controls.h ¶
- "{CIncludes}"Devices.h ¶
- "{CIncludes}"Dialogs.h ¶
- "{CIncludes}"DiskInit.h ¶
- "{CIncludes}"Drag.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"FixMath.h ¶
- "{CIncludes}"Folders.h ¶
- "{CIncludes}"Fonts.h ¶
- "{CIncludes}"Gestalt.h ¶
- "{CIncludes}"LowMem.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MacWindows.h ¶
- "{CIncludes}"Menus.h ¶
- "{CIncludes}"Power.h ¶
- "{CIncludes}"Printing.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"QDOffscreen.h ¶
- "{CIncludes}"QuickDraw.h ¶
- "{CIncludes}"Resources.h ¶
- "{CIncludes}"Scrap.h ¶
- "{CIncludes}"Script.h ¶
- "{CIncludes}"SegLoad.h ¶
- "{CIncludes}"Sound.h ¶
- "{CIncludes}"StandardFile.h ¶
- "{CIncludes}"Strings.h ¶
- "{CIncludes}"TextUtils.h ¶
- "{CIncludes}"ToolUtils.h ¶
- ::byterun:rotatecursor.h ¶
- :ocamlconstants.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"VaListTDef.h ¶
- "{CIncludes}"WCharTDef.h ¶
- "{CIncludes}"MacErrors.h ¶
- "{CIncludes}"MixedMode.h ¶
- "{CIncludes}"AEDataModel.h ¶
- "{CIncludes}"AEInteraction.h ¶
- "{CIncludes}"Appearance.h ¶
- "{CIncludes}"CarbonEvents.h ¶
- "{CIncludes}"Lists.h ¶
- "{CIncludes}"MacHelp.h ¶
- "{CIncludes}"CFString.h ¶
- "{CIncludes}"TextEdit.h ¶
- "{CIncludes}"Icons.h ¶
- "{CIncludes}"Collections.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"NameRegistry.h ¶
- "{CIncludes}"CodeFragments.h ¶
- "{CIncludes}"Multiprocessing.h ¶
- "{CIncludes}"DriverFamilyMatching.h ¶
- "{CIncludes}"Disks.h ¶
- "{CIncludes}"Events.h ¶
- "{CIncludes}"ATSTypes.h ¶
- "{CIncludes}"TextCommon.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"Aliases.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"CGContext.h ¶
- "{CIncludes}"IntlResources.h ¶
- "{CIncludes}"NumberFormatting.h ¶
- "{CIncludes}"StringCompare.h ¶
- "{CIncludes}"DateTimeUtils.h ¶
- "{CIncludes}"Notification.h ¶
- "{CIncludes}"Balloons.h ¶
- "{CIncludes}"CFBase.h ¶
- "{CIncludes}"CFArray.h ¶
- "{CIncludes}"CFData.h ¶
- "{CIncludes}"CFDictionary.h ¶
- "{CIncludes}"stdarg.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"CFBundle.h ¶
- "{CIncludes}"CGBase.h ¶
- "{CIncludes}"CGAffineTransform.h ¶
- "{CIncludes}"CGColorSpace.h ¶
- "{CIncludes}"CGFont.h ¶
- "{CIncludes}"CGImage.h ¶
- "{CIncludes}"CGPDFDocument.h ¶
- "{CIncludes}"TypeSelect.h ¶
- "{CIncludes}"CFURL.h ¶
- "{CIncludes}"stddef.h ¶
- "{CIncludes}"CGGeometry.h ¶
- "{CIncludes}"CGDataProvider.h
-
diff --git a/maccaml/SHORTCUTS b/maccaml/SHORTCUTS
deleted file mode 100644
index 144c7328e9..0000000000
--- a/maccaml/SHORTCUTS
+++ /dev/null
@@ -1,9 +0,0 @@
-option-click a scrollbar's arrow -> scroll by one pixel
-
-Enter in the toplevel window -> go to bottom of window and append
-a newline
-
-Drag & drop to the toplevel window -> go to bottom of window and
-append the dragged text
-
-Command-period in the toplevel window -> interrupt O'Caml's computation
diff --git a/maccaml/WASTE/.cvsignore b/maccaml/WASTE/.cvsignore
deleted file mode 100644
index 652f7a0453..0000000000
--- a/maccaml/WASTE/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-WASTE*1.3*Distribution
diff --git a/maccaml/WASTE/Makefile b/maccaml/WASTE/Makefile
deleted file mode 100644
index 1b927fd88d..0000000000
--- a/maccaml/WASTE/Makefile
+++ /dev/null
@@ -1,507 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-
-# Makefile for the WASTE library (version 1.3)
-
-# Put this makefile into the "WASTE 1.3 Distribution" folder.
-# If you type "Make all", it will build five files:
-#
-# WASTELib.o the WASTE library (classic 68k version)
-# WASTELib.CFMo the WASTE library (CFM 68k version)
-# WASTELib.x the WASTE library (PPC version)
-# "WASTE Demo (CFM)" the demo application (CFM 68k and CFM PPC)
-# "WASTE Demo (classic)" the demo application (classic 68k and CFM PPC)
-
-# You can easily change the WASTE options, the compiler options, and the
-# libraries to suit your needs. (see below)
-
-
-#### WASTE Options. See ":WASTE 1.3:Private Includes:WASTEIntf.h" for details.
-
-# The defaults are shown here.
-#WEDefs = -d WASTE_DEBUG=0 ¶
-# -d WASTE_OBJECTS=1 ¶
-# -d WASTE_TSM_SUPPORT=1 ¶
-# -d WASTE_DRAG_AND_DROP=1 ¶
-# -d WASTE_USE_UPPS=GENERATINGCFM ¶
-# -d WASTE_NO_SYNCH=0 ¶
-# -d WASTE_NO_RO_CARET=1 ¶
-# -d WASTE_IC_SUPPORT=1 ¶
-# -d WASTE_OBJECTS_ARE_GLYPHS=0 ¶
-# -d WASTE_RESOLVE_FONT_DESIGNATORS=1 ¶
-# -d WASTE_WECALTEXT_DOES_REDRAW=0 ¶
-# -d WASTE_TRANSLUCENT_DRAGS=0
-
-WEDefs = -d WASTE_DEBUG=0 ¶
- -d WASTE_OBJECTS=0 ¶
- -d WASTE_TSM_SUPPORT=0 ¶
- -d WASTE_DRAG_AND_DROP=1 ¶
- -d WASTE_USE_UPPS=GENERATINGCFM ¶
- -d WASTE_NO_SYNCH=0 ¶
- -d WASTE_NO_RO_CARET=0 ¶
- -d WASTE_IC_SUPPORT=0 ¶
- -d WASTE_OBJECTS_ARE_GLYPHS=0 ¶
- -d WASTE_RESOLVE_FONT_DESIGNATORS=1 ¶
- -d WASTE_WECALTEXT_DOES_REDRAW=0 ¶
- -d WASTE_TRANSLUCENT_DRAGS=0
-
-
-#### Compilers and their options.
-
-# Uncomment this definition to get a debugging version of the library.
-debugflag = -sym on
-
-# Classic 68k
-C = sc
-COptions = {Defs} {Incl} -model far -w 17 -proto strict {debugflag}
-#C = mwc68k
-#COptions = {Defs} {Incl} -model far
-
-# CFM 68k
-CFMC = sc
-CFMCOptions = {Defs} {Incl} -model cfmflat -w 17 -proto strict {debugflag}
-#CFMC = {c}
-#CFMCOptions = {coptions}
-
-# PPC
-PPCC = mrc
-PPCCOptions = {Defs} {Incl} -w 35 -sym on
-
-
-#### Libraries for the demo application
-
-Libs = "{libraries}MacRuntime.o" ¶
- "{clibraries}StdCLib.far.o" ¶
- "{libraries}Interface.o"
-#Libs = "{mw68klibraries}macos.lib" ¶
-# "{mw68klibraries}ANSI (N/4i/8d) C.68K.Lib"
-
-CFMLibs = "{CFM68kLibraries}NuMacRuntime.o" ¶
- "{sharedlibraries}StdCLib" ¶
- "{sharedlibraries}DragLib" ¶
- "{sharedlibraries}InterfaceLib"
-#CFMLibs = {Libs}
-
-PPCLibs = "{ppclibraries}PPCCRuntime.o" ¶
- "{sharedlibraries}StdCLib" ¶
- "{ppclibraries}StdCRuntime.o" ¶
- "{sharedlibraries}DragLib" ¶
- "{sharedlibraries}InterfaceLib" ¶
-
-
-#### Common definitions
-
-# Compiler options
-Incl = -i ":WASTE C/C++ Headers:" {OHIncl} {WEIncl} {WDIncl} {WTIncl}
-Defs = {WEDefs} -d inline=static
-
-
-#### Main target
-
-all Ä everything
-
-
-#### :WASTE 1.3:
-
-WEObj = ¶
- ':WASTE 1.3:Source:WEAccessors.c.o' ¶
- ':WASTE 1.3:Source:WEBirthDeath.c.o' ¶
- ':WASTE 1.3:Source:WEDebug.c.o' ¶
- ':WASTE 1.3:Source:WEDrawing.c.o' ¶
- ':WASTE 1.3:Source:WEFontTables.c.o' ¶
- ':WASTE 1.3:Source:WEHighLevelEditing.c.o' ¶
- ':WASTE 1.3:Source:WEICGlue.c.o' ¶
- ':WASTE 1.3:Source:WEInlineInput.c.o' ¶
- ':WASTE 1.3:Source:WELineLayout.c.o' ¶
- ':WASTE 1.3:Source:WELongCoords.c.o' ¶
- ':WASTE 1.3:Source:WELowLevelEditing.c.o' ¶
- ':WASTE 1.3:Source:WEMouse.c.o' ¶
- ':WASTE 1.3:Source:WEObjects.c.o' ¶
- ':WASTE 1.3:Source:WEScraps.c.o' ¶
- ':WASTE 1.3:Source:WESelecting.c.o' ¶
- ':WASTE 1.3:Source:WESelectors.c.o' ¶
- ':WASTE 1.3:Source:WEUserSelectors.c.o' ¶
- ':WASTE 1.3:Source:WEUtilities.c.o' ¶
-
-WECFMObj = ¶
- ':WASTE 1.3:Source:WEAccessors.c.CFMo' ¶
- ':WASTE 1.3:Source:WEBirthDeath.c.CFMo' ¶
- ':WASTE 1.3:Source:WEDebug.c.CFMo' ¶
- ':WASTE 1.3:Source:WEDrawing.c.CFMo' ¶
- ':WASTE 1.3:Source:WEFontTables.c.CFMo' ¶
- ':WASTE 1.3:Source:WEHighLevelEditing.c.CFMo' ¶
- ':WASTE 1.3:Source:WEICGlue.c.CFMo' ¶
- ':WASTE 1.3:Source:WEInlineInput.c.CFMo' ¶
- ':WASTE 1.3:Source:WELineLayout.c.CFMo' ¶
- ':WASTE 1.3:Source:WELongCoords.c.CFMo' ¶
- ':WASTE 1.3:Source:WELowLevelEditing.c.CFMo' ¶
- ':WASTE 1.3:Source:WEMouse.c.CFMo' ¶
- ':WASTE 1.3:Source:WEObjects.c.CFMo' ¶
- ':WASTE 1.3:Source:WEScraps.c.CFMo' ¶
- ':WASTE 1.3:Source:WESelecting.c.CFMo' ¶
- ':WASTE 1.3:Source:WESelectors.c.CFMo' ¶
- ':WASTE 1.3:Source:WEUserSelectors.c.CFMo' ¶
- ':WASTE 1.3:Source:WEUtilities.c.CFMo' ¶
-
-WEPPCObj = ¶
- ':WASTE 1.3:Source:WEAccessors.c.x' ¶
- ':WASTE 1.3:Source:WEBirthDeath.c.x' ¶
- ':WASTE 1.3:Source:WEDebug.c.x' ¶
- ':WASTE 1.3:Source:WEDrawing.c.x' ¶
- ':WASTE 1.3:Source:WEFontTables.c.x' ¶
- ':WASTE 1.3:Source:WEHighLevelEditing.c.x' ¶
- ':WASTE 1.3:Source:WEICGlue.c.x' ¶
- ':WASTE 1.3:Source:WEInlineInput.c.x' ¶
- ':WASTE 1.3:Source:WELineLayout.c.x' ¶
- ':WASTE 1.3:Source:WELongCoords.c.x' ¶
- ':WASTE 1.3:Source:WELowLevelEditing.c.x' ¶
- ':WASTE 1.3:Source:WEMouse.c.x' ¶
- ':WASTE 1.3:Source:WEObjects.c.x' ¶
- ':WASTE 1.3:Source:WEScraps.c.x' ¶
- ':WASTE 1.3:Source:WESelecting.c.x' ¶
- ':WASTE 1.3:Source:WESelectors.c.x' ¶
- ':WASTE 1.3:Source:WEUserSelectors.c.x' ¶
- ':WASTE 1.3:Source:WEUtilities.c.x' ¶
-
-WEIncl = -i ":WASTE 1.3:Private Includes:" ¶
- -i ":WASTE 1.3:Internet Config Headers:"
-
-WETarg = WASTELib.o WASTELib.CFMo WASTELib.x
-
-WASTELib.o Ä {WEObj}
- lib -o WASTELib.o {WEObj}
-
-WASTELib.CFMo Ä {WECFMObj}
- lib -o WASTELib.CFMo {WECFMObj}
-
-WASTELib.x Ä {WEPPCObj}
- ppclink {debugflag} -xm library -o WASTELib.x {WEPPCObj}
-
-clean ÄÄ
- delete -i {WEObj} {WECFMObj} {WEPPCObj} {WETarg}
-
-
-#### :Extras:Sample Object Handlers:
-
-OHObj = ":Extras:Sample Object Handlers:WEObjectHandlers.c.o"
-OHCFMObj = ":Extras:Sample Object Handlers:WEObjectHandlers.c.CFMo"
-OHPPCObj = ":Extras:Sample Object Handlers:WEObjectHandlers.c.x"
-OHIncl = -i ":Extras:Sample Object Handlers:"
-OHTarg = {OHObj} {OHCFMObj} {OHPPCObj}
-
-clean ÄÄ
- delete -i {OHTarg}
-
-
-#### :Extras:WASTE Tabs 1.3.2:
-
-WTObj = ¶
- ":Extras:WASTE Tabs 1.3.2:WETabs.c.o" ¶
- ":Extras:WASTE Tabs 1.3.2:WETabHooks.c.o"¶
-
-WTCFMObj = ¶
- ":Extras:WASTE Tabs 1.3.2:WETabs.c.CFMo" ¶
- ":Extras:WASTE Tabs 1.3.2:WETabHooks.c.CFMo" ¶
-
-WTPPCObj = ¶
- ":Extras:WASTE Tabs 1.3.2:WETabs.c.x" ¶
- ":Extras:WASTE Tabs 1.3.2:WETabHooks.c.x" ¶
-
-WTIncl = -i ":Extras:Waste Tabs 1.3.2:"
-WTTarg = {WTObj} {WTCFMObj} {WTPPCObj}
-
-clean ÄÄ
- delete -i {WTTarg}
-
-
-#### :Demo:Source:
-
-WDObj = ¶
- :Demo:Source:DialogUtils.c.o ¶
- :Demo:Source:LongControls.c.o ¶
- ':Demo:Source:SmartScroll Stuff:SmartScroll.c.o' ¶
- :Demo:Source:WEDemoAbout.c.o ¶
- :Demo:Source:WEDemoDrags.c.o ¶
- :Demo:Source:WEDemoEvents.c.o ¶
- :Demo:Source:WEDemoFiles.c.o ¶
- :Demo:Source:WEDemoInit.c.o ¶
- :Demo:Source:WEDemoIntf.c.o ¶
- :Demo:Source:WEDemoMain.c.o ¶
- :Demo:Source:WEDemoMenus.c.o ¶
- :Demo:Source:WEDemoScripting.c.o ¶
- :Demo:Source:WEDemoWindows.c.o ¶
- :Demo:Source:qd.c.o ¶
-
-WDLibs = WASTELib.o {WTObj} {OHObj}
-
-WDCFMObj = ¶
- :Demo:Source:DialogUtils.c.CFMo ¶
- :Demo:Source:LongControls.c.CFMo ¶
- ':Demo:Source:SmartScroll Stuff:SmartScroll.c.CFMo' ¶
- :Demo:Source:WEDemoAbout.c.CFMo ¶
- :Demo:Source:WEDemoDrags.c.CFMo ¶
- :Demo:Source:WEDemoEvents.c.CFMo ¶
- :Demo:Source:WEDemoFiles.c.CFMo ¶
- :Demo:Source:WEDemoInit.c.CFMo ¶
- :Demo:Source:WEDemoIntf.c.CFMo ¶
- :Demo:Source:WEDemoMain.c.CFMo ¶
- :Demo:Source:WEDemoMenus.c.CFMo ¶
- :Demo:Source:WEDemoScripting.c.CFMo ¶
- :Demo:Source:WEDemoWindows.c.CFMo ¶
- :Demo:Source:qd.c.CFMo ¶
-
-WDCFMLibs = WASTELib.CFMo {WTCFMObj} {OHCFMObj}
-
-WDPPCObj = ¶
- :Demo:Source:DialogUtils.c.x ¶
- :Demo:Source:LongControls.c.x ¶
- ':Demo:Source:SmartScroll Stuff:SmartScroll.c.x' ¶
- :Demo:Source:WEDemoAbout.c.x ¶
- :Demo:Source:WEDemoDrags.c.x ¶
- :Demo:Source:WEDemoEvents.c.x ¶
- :Demo:Source:WEDemoFiles.c.x ¶
- :Demo:Source:WEDemoInit.c.x ¶
- :Demo:Source:WEDemoIntf.c.x ¶
- :Demo:Source:WEDemoMain.c.x ¶
- :Demo:Source:WEDemoMenus.c.x ¶
- :Demo:Source:WEDemoScripting.c.x ¶
- :Demo:Source:WEDemoWindows.c.x ¶
- :Demo:Source:qd.c.x ¶
-
-WDPPCLibs = WASTELib.x {WTPPCObj} {OHPPCObj}
-
-WDIncl = -i ":Demo:Source:" -i ":Demo:Source:SmartScroll Stuff:"
-
-WDTarg = "WASTE Demo (classic)" "WASTE Demo (CFM)"
-
-:Demo:Source:qd.c Ä
- echo "#include <QuickDraw.h>¶nQDGlobals qd;¶n" > :Demo:Source:qd.c
-
-:Demo:Source:size.r Ä
- begin
- echo '#include "Types.r"'
- echo 'resource '¶''SIZE'¶'' (-1) {'
- echo 'reserved,'
- echo 'acceptSuspendResumeEvents,'
- echo 'reserved,'
- echo 'canBackground,'
- echo 'multiFinderAware,'
- echo 'backgroundAndForeground,'
- echo 'dontGetFrontClicks,'
- echo 'ignoreChildDiedEvents,'
- echo 'is32BitCompatible,'
- echo 'isHighLevelEventAware,'
- echo 'localAndRemoteHLEvents,'
- echo 'notStationeryAware,'
- echo 'dontUseTextEditServices,'
- echo 'reserved,'
- echo 'reserved,'
- echo 'reserved,'
- echo '262144,'
- echo '196608'
- echo '};'
- end > :Demo:Source:size.r
-
-"WASTE Demo (classic)" ÄÄ {WDObj} {WDLibs}
- ilink -c OEDE {WDObj} {WDLibs} {Libs} -o "WASTE Demo (classic)" ¶
- -model far -compact -pad 0 -state nouse
-
-"WASTE Demo (classic)" ÄÄ {WDPPCObj} {WDPPCLibs}
- ppclink -c OEDE {WDPPCObj} {WDPPCLibs} {PPCLibs} ¶
- -fragname 'WASTE Demo PPC' -sym on
- mergefragment -z PPCLink.out "WASTE Demo (classic)"
- delete -i PPCLink.out
- rename -y PPCLink.out.xcoff "WASTE Demo (classic).xcoff"
-
-"WASTE Demo (classic)" ÄÄ :Demo:Source:WEDemo.rsrc :Demo:Source:size.r
- begin
- echo 'include ":Demo:Source:WEDemo.rsrc";'
- echo '#include ":Demo:Source:size.r"'
- end | rez -a -c OEDE -o "WASTE Demo (classic)"
- setfile -a Bi "WASTE Demo (classic)"
-
-"WASTE Demo (CFM)" ÄÄ {WDCFMObj} {WDCFMLibs}
- ilink -c OEDE {WDCFMObj} {WDCFMLibs} {CFMLibs} -o "WASTE Demo (CFM)" ¶
- -model cfmseg -state nouse -fragname 'WASTE Demo 68k'
-
-"WASTE Demo (CFM)" ÄÄ {WDPPCObj} {WDPPCLibs}
- ppclink -c OEDE {WDPPCObj} {WDPPCLibs} {PPCLibs} ¶
- -fragname 'WASTE Demo PPC' -sym on
- mergefragment -z PPCLink.out "WASTE Demo (CFM)"
- delete -i PPCLink.out
- rename -y PPCLink.out.xcoff "WASTE Demo (CFM).xcoff"
-
-"WASTE Demo (CFM)" ÄÄ :Demo:Source:WEDemo.rsrc :Demo:Source:size.r
- begin
- echo 'include ":Demo:Source:WEDemo.rsrc";'
- echo '#include ":Demo:Source:size.r";'
- end | rez -a -c OEDE -o "WASTE Demo (CFM)"
- setfile -a Bi "WASTE Demo (CFM)"
-
-clean ÄÄ
- delete -i {WDObj} {WDCFMObj} {WDPPCObj} {WDTarg}
- delete -i :Demo:Source:size.r :Demo:Source:qd.c
- delete -i "WASTE Demo (CFM).xcoff" "WASTE Demo (classic).xcoff"
-
-
-#### Main target (continued)
-
-everything Ä {OHTarg} {WETarg} {WDTarg}
-
-
-#### Default rule for CFM-68k compilation.
-
-.c.CFMo Ä .c
- {CFMC} {depdir}{default}.c -o {targdir}{default}.c.CFMo {CFMCOptions}
-
-
-#### Dependencies
-
-':Extras:Sample Object Handlers:WEObjectHandlers.c.o' ¶
-':Extras:Sample Object Handlers:WEObjectHandlers.c.CFMo' ¶
-':Extras:Sample Object Handlers:WEObjectHandlers.c.x' ¶
-Ä ":Extras:Sample Object Handlers:WEObjectHandlers.h" ¶
- ":WASTE C/C++ Headers:WASTE.h" ¶
- ":WASTE C/C++ Headers:LongCoords.h"
-
-':WASTE 1.3:Source:WEAccessors.c.o' ¶
-':WASTE 1.3:Source:WEAccessors.c.CFMo' ¶
-':WASTE 1.3:Source:WEAccessors.c.x' ¶
-':WASTE 1.3:Source:WEBirthDeath.c.o' ¶
-':WASTE 1.3:Source:WEBirthDeath.c.CFMo' ¶
-':WASTE 1.3:Source:WEBirthDeath.c.x' ¶
-':WASTE 1.3:Source:WEDebug.c.o' ¶
-':WASTE 1.3:Source:WEDebug.c.CFMo' ¶
-':WASTE 1.3:Source:WEDebug.c.x' ¶
-':WASTE 1.3:Source:WEDrawing.c.o' ¶
-':WASTE 1.3:Source:WEDrawing.c.CFMo' ¶
-':WASTE 1.3:Source:WEDrawing.c.x' ¶
-':WASTE 1.3:Source:WEFontTables.c.o' ¶
-':WASTE 1.3:Source:WEFontTables.c.CFMo' ¶
-':WASTE 1.3:Source:WEFontTables.c.x' ¶
-':WASTE 1.3:Source:WEHighLevelEditing.c.o' ¶
-':WASTE 1.3:Source:WEHighLevelEditing.c.CFMo' ¶
-':WASTE 1.3:Source:WEHighLevelEditing.c.x' ¶
-':WASTE 1.3:Source:WEICGlue.c.o' ¶
-':WASTE 1.3:Source:WEICGlue.c.CFMo' ¶
-':WASTE 1.3:Source:WEICGlue.c.x' ¶
-':WASTE 1.3:Source:WEInlineInput.c.o' ¶
-':WASTE 1.3:Source:WEInlineInput.c.CFMo' ¶
-':WASTE 1.3:Source:WEInlineInput.c.x' ¶
-':WASTE 1.3:Source:WELineLayout.c.o' ¶
-':WASTE 1.3:Source:WELineLayout.c.CFMo' ¶
-':WASTE 1.3:Source:WELineLayout.c.x' ¶
-':WASTE 1.3:Source:WELongCoords.c.o' ¶
-':WASTE 1.3:Source:WELongCoords.c.CFMo' ¶
-':WASTE 1.3:Source:WELongCoords.c.x' ¶
-':WASTE 1.3:Source:WELowLevelEditing.c.o' ¶
-':WASTE 1.3:Source:WELowLevelEditing.c.CFMo' ¶
-':WASTE 1.3:Source:WELowLevelEditing.c.x' ¶
-':WASTE 1.3:Source:WEMouse.c.o' ¶
-':WASTE 1.3:Source:WEMouse.c.CFMo' ¶
-':WASTE 1.3:Source:WEMouse.c.x' ¶
-':WASTE 1.3:Source:WEObjects.c.o' ¶
-':WASTE 1.3:Source:WEObjects.c.CFMo' ¶
-':WASTE 1.3:Source:WEObjects.c.x' ¶
-':WASTE 1.3:Source:WEScraps.c.o' ¶
-':WASTE 1.3:Source:WEScraps.c.CFMo' ¶
-':WASTE 1.3:Source:WEScraps.c.x' ¶
-':WASTE 1.3:Source:WESelecting.c.o' ¶
-':WASTE 1.3:Source:WESelecting.c.CFMo' ¶
-':WASTE 1.3:Source:WESelecting.c.x' ¶
-':WASTE 1.3:Source:WESelectors.c.o' ¶
-':WASTE 1.3:Source:WESelectors.c.CFMo' ¶
-':WASTE 1.3:Source:WESelectors.c.x' ¶
-':WASTE 1.3:Source:WEUserSelectors.c.o' ¶
-':WASTE 1.3:Source:WEUserSelectors.c.CFMo' ¶
-':WASTE 1.3:Source:WEUserSelectors.c.x' ¶
-':WASTE 1.3:Source:WEUtilities.c.o' ¶
-':WASTE 1.3:Source:WEUtilities.c.CFMo' ¶
-':WASTE 1.3:Source:WEUtilities.c.x' ¶
-Ä ":WASTE 1.3:Private Includes:WASTEIntf.h" ¶
- ":WASTE 1.3:Private Includes:LongCoords.h"
-
-":WASTE 1.3:Source:WEMouse.c.o" ¶
-":WASTE 1.3:Source:WEMouse.c.CFMo" ¶
-":WASTE 1.3:Source:WEMouse.c.x" ¶
-Ä ":Waste 1.3:Internet Config Headers:ICTypes.h" ¶
- ":Waste 1.3:Internet Config Headers:ICAPI.h"
-
-":WASTE 1.3:Source:WEICGlue.c.o" ¶
-":WASTE 1.3:Source:WEICGlue.c.CFMo" ¶
-":WASTE 1.3:Source:WEICGlue.c.x" ¶
-Ä ":Waste 1.3:Internet Config Headers:ICComponentSelectors.h" ¶
- ":Waste 1.3:Internet Config Headers:ICAPI.h"
-
-:Demo:Source:DialogUtils.c.o ¶
-:Demo:Source:DialogUtils.c.CFMo ¶
-:Demo:Source:DialogUtils.c.x ¶
-:Demo:Source:LongControls.c.o ¶
-:Demo:Source:LongControls.c.CFMo ¶
-:Demo:Source:LongControls.c.x ¶
-:Demo:Source:WEDemoAbout.c.o ¶
-:Demo:Source:WEDemoAbout.c.CFMo ¶
-:Demo:Source:WEDemoAbout.c.x ¶
-:Demo:Source:WEDemoDrags.c.o ¶
-:Demo:Source:WEDemoDrags.c.CFMo ¶
-:Demo:Source:WEDemoDrags.c.x ¶
-:Demo:Source:WEDemoEvents.c.o ¶
-:Demo:Source:WEDemoEvents.c.CFMo ¶
-:Demo:Source:WEDemoEvents.c.x ¶
-:Demo:Source:WEDemoFiles.c.o ¶
-:Demo:Source:WEDemoFiles.c.CFMo ¶
-:Demo:Source:WEDemoFiles.c.x ¶
-:Demo:Source:WEDemoInit.c.o ¶
-:Demo:Source:WEDemoInit.c.CFMo ¶
-:Demo:Source:WEDemoInit.c.x ¶
-:Demo:Source:WEDemoIntf.c.o ¶
-:Demo:Source:WEDemoIntf.c.CFMo ¶
-:Demo:Source:WEDemoIntf.c.x ¶
-:Demo:Source:WEDemoMain.c.o ¶
-:Demo:Source:WEDemoMain.c.CFMo ¶
-:Demo:Source:WEDemoMain.c.x ¶
-:Demo:Source:WEDemoMenus.c.o ¶
-:Demo:Source:WEDemoMenus.c.CFMo ¶
-:Demo:Source:WEDemoMenus.c.x ¶
-:Demo:Source:WEDemoScripting.c.o ¶
-:Demo:Source:WEDemoScripting.c.CFMo ¶
-:Demo:Source:WEDemoScripting.c.x ¶
-:Demo:Source:WEDemoWindows.c.o ¶
-:Demo:Source:WEDemoWindows.c.CFMo ¶
-:Demo:Source:WEDemoWindows.c.x ¶
-Ä ":Demo:Source:WEDemoIntf.h" ¶
- ":WASTE C/C++ Headers:WASTE.h"
-
-:Demo:Source:WEDemoInit.c.o ¶
-:Demo:Source:WEDemoInit.c.CFMo ¶
-:Demo:Source:WEDemoInit.c.x ¶
-Ä ":Demo:Source:SmartScroll Stuff:SmartScroll.h" ¶
- ":Extras:Sample Object Handlers:WEObjectHandlers.h"
-
-:Demo:Source:WEDemoMenus.c.o ¶
-:Demo:Source:WEDemoMenus.c.CFMo ¶
-:Demo:Source:WEDemoMenus.c.x ¶
-Ä ":Extras:WASTE Tabs 1.3.2:WETabs.h"
-
-:Demo:Source:WEDemoWindows.c.o ¶
-:Demo:Source:WEDemoWindows.c.CFMo ¶
-:Demo:Source:WEDemoWindows.c.x ¶
-Ä ":WASTE C/C++ Headers:LongCoords.h" ¶
- ":Demo:Source:SmartScroll Stuff:SmartScroll.h"
-
-':Demo:Source:SmartScroll Stuff:SmartScroll.c.o' ¶
-':Demo:Source:SmartScroll Stuff:SmartScroll.c.CFMo' ¶
-':Demo:Source:SmartScroll Stuff:SmartScroll.c.x' ¶
-Ä ':Demo:Source:SmartScroll Stuff:SmartScroll.h'
diff --git a/maccaml/WASTE/README b/maccaml/WASTE/README
deleted file mode 100644
index fd8e5e1e7f..0000000000
--- a/maccaml/WASTE/README
+++ /dev/null
@@ -1,5 +0,0 @@
-WASTE 1.3 is needed to build the O'Caml standalone application.
-
-Get WASTE 1.3 from <ftp://ftp.boingo.com/dan/WASTE/>
-and unpack it in this directory (maccaml:WASTE:) to create the folder
-"WASTE 1.3 Distribution".
diff --git a/maccaml/aboutbox.c b/maccaml/aboutbox.c
deleted file mode 100644
index 92cb198255..0000000000
--- a/maccaml/aboutbox.c
+++ /dev/null
@@ -1,125 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Para, INRIA Rocquencourt */
-/* */
-/* Copyright 1997 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "main.h"
-
-static WindowPtr aboutbox = NULL;
-static UserItemUPP DrawAboutUPP = NULL;
-
-#define kItemText 2
-
-static pascal void DrawAbout (DialogPtr d, short item)
-{
-#pragma unused (item)
- WEHandle we = WinGetWE (d);
-
- Assert (we != NULL);
- WEUpdate (d->visRgn, we);
-}
-
-void OpenAboutBox (void)
-{
- OSErr err;
- short itemtype;
- Handle item;
- Rect itemrect;
- LongRect lr;
- WEHandle we = NULL;
- WStatusH st = NULL;
- Handle txt = NULL, copr = NULL;
- TextStyle ts;
-
- if (DrawAboutUPP == NULL) DrawAboutUPP = NewUserItemProc (DrawAbout);
-
- if (aboutbox != NULL){
- SelectWindow (aboutbox);
- }else{
- aboutbox = GetNewDialog (kDialogAbout, NULL, (WindowPtr) -1L);
- if (aboutbox == NULL){
- err = memFullErr;
- goto failed;
- }
- SetPort (aboutbox);
-
- err = WinAllocStatus (aboutbox);
- if (err != noErr) goto failed;
-
- st = WinGetStatus (aboutbox);
- Assert (st != NULL);
- (*st)->kind = kWinAbout;
-
- GetDialogItem (aboutbox, kItemText, &itemtype, &item, &itemrect);
- SetDialogItem (aboutbox, kItemText, itemtype, (Handle) DrawAboutUPP, &itemrect);
- WERectToLongRect (&itemrect, &lr);
- err = WENew (&lr, &lr, 0, &we);
- if (err != noErr) goto failed;
-
- (*st)->we = we;
-
- GetFNum ("\pGeneva", &ts.tsFont);
- ts.tsSize = 10;
- err = WESetStyle (weDoFont + weDoSize, &ts, we);
- if (err != noErr) goto failed;
-
- txt = GetResource ('TEXT', kAboutText1);
- err = ResError (); if (err != noErr){ err = noErr; goto failed; }
- DetachResource (txt);
-
- copr = GetResource ('TEXT', kAboutText2);
- err = ResError ();
- if (err == noErr){
- HLock (copr);
- err = HandAndHand (copr, txt);
- /* ignore errors */
- HUnlock (copr);
- ReleaseResource (copr);
- copr = NULL;
- }
-
- err = WEUseText (txt, we);
- if (err != noErr) goto failed;
- err = WECalText (we);
- if (err != noErr) goto failed;
-
- WEFeatureFlag (weFReadOnly, weBitSet, we);
-
- return;
-
- failed:
- if (copr != NULL) DisposeHandle (copr);
- if (txt != NULL) DisposeHandle (txt);
- if (we != NULL) WEDispose (we);
- if (st != NULL) DisposeHandle ((Handle) st);
- if (aboutbox != NULL) DisposeWindow (aboutbox);
- aboutbox = NULL;
- ErrorAlertGeneric (err);
- }
-}
-
-void CloseAboutBox (WindowPtr w)
-{
- WStatusH st = WinGetStatus (w);
- WEHandle we = WinGetWE (w);
-
- Assert (w == aboutbox);
-
- Assert (we != NULL);
- WEDispose (we);
- Assert (st != NULL);
- DisposeHandle ((Handle) st);
- Assert (w != NULL);
- DisposeDialog (w);
- aboutbox = NULL;
-}
diff --git a/maccaml/appleevents.c b/maccaml/appleevents.c
deleted file mode 100644
index cad35c032e..0000000000
--- a/maccaml/appleevents.c
+++ /dev/null
@@ -1,147 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Para, INRIA Rocquencourt */
-/* */
-/* Copyright 1997 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "main.h"
-
-static OSErr GotRequiredParams (const AppleEvent *ae)
-{
- OSErr err;
- DescType type;
- Size sz;
-
- err = AEGetAttributePtr (ae, keyMissedKeywordAttr, typeWildCard, &type, NULL,
- 0, &sz);
- if (err == errAEDescNotFound) return noErr;
- if (err == noErr) return errAEParamMissed;
- return err;
-}
-
-static pascal OSErr HandleOpenApplication (const AppleEvent *ae,
- AppleEvent *reply, long refCon)
-{
-#pragma unused (ae, reply, refCon)
- launch_toplevel_requested = 1;
- return noErr;
-}
-
-static pascal OSErr HandleQuitApplication (const AppleEvent *ae,
- AppleEvent *reply, long refCon)
-{
-#pragma unused (ae, reply, refCon)
- WindowPtr w = FrontWindow ();
- WStatusH st;
- int request_interaction = prefs.asksavetop && winToplevel != NULL;
- OSErr err;
-
- while (w != NULL){
- WinUpdateStatus (w);
- st = WinGetStatus (w);
- if (st != NULL && (*st)->menuflags.save){
- request_interaction = 1;
- }
- w = GetNextWindow (w);
- }
- if (request_interaction){
- err = AEInteractWithUser (kAEDefaultTimeout, NULL, ProcessEventUPP);
- if (err != noErr) return err;
- }
- err = DoQuit ();
- if (err != noErr) return err;
-
- return noErr;
-}
-
-static pascal OSErr HandleOpenDocuments (const AppleEvent *ae,
- AppleEvent *reply, long refCon)
-{
-#pragma unused (reply, refCon)
- FSSpec filespec;
- AEDescList doclist = {0, NULL};
- OSErr err;
- long i, len;
- Size sz;
- AEKeyword key;
- DescType type;
-
- launch_toplevel_requested = 1;
-
- err = AEGetParamDesc (ae, keyDirectObject, typeAEList, &doclist);
- if (err != noErr) goto failed;
-
- err = GotRequiredParams (ae);
- if (err != noErr) goto failed;
-
- err = AECountItems (&doclist, &len);
- if (err != noErr) goto failed;
-
- for (i = 1; i <= len; i++){
- err = AEGetNthPtr (&doclist, i, typeFSS, &key, &type, &filespec,
- sizeof (filespec), &sz);
- if (err != noErr) goto failed;
- err = FileOpen (&filespec);
- if (err != noErr){
- OSErr err2 = AEInteractWithUser (kAEDefaultTimeout, NULL,ProcessEventUPP);
- if (err2 == noErr){
- ErrorAlertCantOpen (filespec.name, err);
- }else{
- if (err2 == errAENoUserInteraction) err = err2;
- goto failed;
- }
- }
- }
- AEDisposeDesc (&doclist);
- return noErr;
-
- failed:
- if (doclist.dataHandle != NULL) AEDisposeDesc (&doclist);
- return err;
-}
-
-static pascal OSErr HandlePrintDocuments (const AppleEvent *ae,
- AppleEvent *reply, long refCon)
-{
-#pragma unused (ae, reply, refCon)
- return errAEEventNotHandled; /* XXX */
-}
-
-OSErr InstallAEHandlers (void)
-{
- OSErr err;
-
- err = AEInstallEventHandler (kCoreEventClass, kAEOpenApplication,
- NewAEEventHandlerProc (HandleOpenApplication),
- 0, false);
- if (err != noErr) goto failed;
-
- err = AEInstallEventHandler (kCoreEventClass, kAEQuitApplication,
- NewAEEventHandlerProc (HandleQuitApplication),
- 0, false);
- if (err != noErr) goto failed;
-
- err = AEInstallEventHandler (kCoreEventClass, kAEOpenDocuments,
- NewAEEventHandlerProc (HandleOpenDocuments),
- 0, false);
- if (err != noErr) goto failed;
-
- err = AEInstallEventHandler (kCoreEventClass, kAEPrintDocuments,
- NewAEEventHandlerProc (HandlePrintDocuments),
- 0, false);
- if (err != noErr) goto failed;
-
- return noErr;
-
- failed:
- return err;
-}
diff --git a/maccaml/appli.r b/maccaml/appli.r
deleted file mode 100644
index a238f9c125..0000000000
--- a/maccaml/appli.r
+++ /dev/null
@@ -1,808 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Moscova, INRIA Rocquencourt */
-/* */
-/* Copyright 2000 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-
-#include "Types.r"
-#include "Sound.r"
-
-#include "ocamlconstants.h"
-
-
-/* These 5 resources are meant to be overridden. */
-
-data 'Line' (1000) { "%a\000" }; /* command line template */
-
-data 'Line' (1001) { "" }; /* environment template */
-
-data 'TEXT' (1000, purgeable) { /* kAboutText1 */
- "\n"
- APPLNAME "\n"
- "\n"
- "\n"
- "\n"
- "\n"
- "\n"
-};
-
-data 'cicn' (1000) { /* kApplicationIcon */
- $"0000 0000 8020 0000 0000 0020 0020 0000 0000 0000 0000 0048"
- $"0000 0048 0000 0000 0008 0001 0008 0000 0000 0000 0000 0000"
- $"0000 0000 0000 0004 0000 0000 0020 0020 0000 0000 0004 0000"
- $"0000 0020 0020 0000 0000 0000 0000 001F F01C 003F F83E 007F"
- $"FC7E 00FF FEFC 01FF FFF8 03FF FFF0 07FF FFE0 0FFF FFE0 1FFF"
- $"FFF0 3FFF FFF8 7FFF FFFC FFFF FFFF FFFF FFFF FFFF FFFF 7FFF"
- $"FFFF 3FFF FFFF 1FFF FFFF 0FFF FFFF 07FF FFFF 03FF FFFF 01FF"
- $"FFFE 00FF FFFF 007F FFFF 003F FFFF 001F FFFE 000F FFFC 0007"
- $"FFF8 0003 FFF0 0001 FFE0 0000 FF80 0000 7F00 0000 0000 001F"
- $"F01C 0030 3826 0048 7C5E 0084 E69C 0103 C338 0200 9E70 0400"
- $"24E0 0800 49E0 1000 9330 2001 2618 4002 4E0C 8002 9A07 8001"
- $"7C07 C002 8007 6002 E007 3007 FC07 1806 1FC7 0C00 01FF 0600"
- $"003F 0300 0007 0180 000E 00C0 001F 0060 003F 0030 007F 0018"
- $"00FE 000C 01FC 0006 03F8 0003 07F0 0001 8FE0 0000 DF80 0000"
- $"7F00 0000 0000 0000 002F 0000 FFFF FFFF FFFF 0001 FFFF FFFF"
- $"6666 0002 FFFF CCCC CCCC 0003 FFFF CCCC 9999 0004 FFFF CCCC"
- $"6666 0005 FFFF 9999 9999 0006 FFFF 0000 3333 0007 CCCC CCCC"
- $"CCCC 0008 CCCC CCCC 9999 0009 CCCC CCCC 6666 000A CCCC 9999"
- $"9999 000B CCCC 9999 6666 000C CCCC 9999 3333 000D CCCC 6666"
- $"6666 000E CCCC 6666 3333 000F 9999 9999 9999 0010 9999 9999"
- $"6666 0011 9999 9999 3333 0012 9999 6666 6666 0013 9999 6666"
- $"3333 0014 9999 3333 6666 0015 9999 3333 3333 0016 9999 0000"
- $"3333 0017 9999 0000 0000 0018 6666 6666 6666 0019 6666 6666"
- $"3333 001A 6666 3333 6666 001B 6666 3333 3333 001C 6666 3333"
- $"0000 001D 6666 0000 3333 001E 3333 3333 0000 001F 3333 0000"
- $"3333 0020 3333 0000 0000 0021 0000 0000 3333 0022 8888 0000"
- $"0000 0023 4444 0000 0000 0024 1111 0000 0000 0025 0000 1111"
- $"0000 0026 EEEE EEEE EEEE 0027 DDDD DDDD DDDD 0028 BBBB BBBB"
- $"BBBB 0029 AAAA AAAA AAAA 002A 8888 8888 8888 002B 7777 7777"
- $"7777 002C 5555 5555 5555 002D 4444 4444 4444 002E 2222 2222"
- $"2222 002F 1111 1111 1111 0000 0000 0000 0000 0000 0000 0000"
- $"0000 0000 0000 0000 0000 0000 0000 0000 0000 0000 0000 0000"
- $"0000 0000 0029 0F29 0F29 0F29 0F18 0000 0000 0000 0022 062D"
- $"0000 0000 0000 0000 0000 0000 2A2B 2600 0000 0027 2C2A 2D00"
- $"0000 0000 1606 1622 2D00 0000 0000 0000 0000 002A 2700 2B26"
- $"0000 072D 2928 2A2D 0000 002C 0717 171F 2D00 0000 0000 0000"
- $"0000 2A07 0000 262B 2607 2C29 2827 282A 2D00 2C01 0F2B 2E2D"
- $"0000 0000 0000 0000 002A 2700 0000 0026 2B2C 2928 0707 030A"
- $"0F11 0410 1B23 2C00 0000 0000 0000 0000 2A27 0000 0000 0000"
- $"2628 0702 0803 0A0A 1104 0C1B 1E2D 0000 0000 0000 0000 002A"
- $"2700 0000 0000 0000 2627 080A 0503 0F13 040B 1B1E 1A00 0000"
- $"0000 0000 0000 2A07 0000 0000 0000 0000 2708 0A03 1015 1304"
- $"0B1C 1E0A 2C00 0000 0000 0000 002A 2700 0000 0000 0000 0026"
- $"0A05 0312 1B13 040B 1C1F 0E03 0A18 0000 0000 0000 2A27 0000"
- $"0000 0000 0000 0028 0403 0E1B 1304 0C1B 1E1B 1203 030B 2C00"
- $"0000 002A 2700 0000 0000 0000 0000 2705 0312 1B13 040B 1B24"
- $"1B15 1310 0303 0A2C 0000 2A27 0000 0000 0000 0000 0000 0703"
- $"141C 1B09 0C1B 252F 1513 0D0B 0303 090A 182A 2C07 0000 0000"
- $"0000 0000 0026 1215 1B0B 0B0D 0A0B 0303 0303 0303 0303 050B"
- $"2B12 2D2C 2800 0000 0000 0000 0026 261C 1B05 0A12 120B 0B03"
- $"0303 0303 030A 0B0A 2B11 002D 2C07 0000 0000 0000 0000 0711"
- $"0B1B 151E 1B1B 1519 120B 0A0B 0B0B 1212 2A29 0000 2D2D 0700"
- $"0000 0000 0027 120B 1319 2B12 1B1D 1E1B 1B1B 1B12 2C15 1213"
- $"0F29 0000 002D 2C07 0000 0000 0008 2C2C 2A0A 2726 2729 1223"
- $"2320 1E1D 1C2D 1B1B 2A29 0000 0000 2D2D 2800 0000 272C 0A28"
- $"2727 2727 2727 0728 2912 1219 2C1B 1B1B 2B29 0000 0000 002D"
- $"2C28 0000 0721 2D2C 182A 2928 2807 0707 0707 0707 0707 0F2B"
- $"2B29 0000 0000 0000 2D2C 2800 0026 2707 2829 290F 0F0F 2928"
- $"2828 2828 2828 2A2E 2D2D 0000 0000 0000 002D 2C28 0000 0026"
- $"2727 2727 2707 2829 0F0F 0F0F 0F29 2E2D 2D00 0000 0000 0000"
- $"0000 2D2C 2800 0000 0000 0000 2727 2707 0707 0707 282F 2D2D"
- $"2D2D 0000 0000 0000 0000 002D 2C28 0000 0000 0000 0000 0000"
- $"2727 2728 2F2C 2D2D 2D2D 0000 0000 0000 0000 0000 2D2C 2800"
- $"0000 0000 0000 0000 0000 072F 2D2D 2D2D 2D2D 0000 0000 0000"
- $"0000 0000 002D 2C28 0000 0000 0000 0000 0007 2E2D 2D2D 2D2D"
- $"2D00 0000 0000 0000 0000 0000 0000 2D2C 2800 0000 0000 0000"
- $"072E 2D2D 2D2D 2D2D 0000 0000 0000 0000 0000 0000 0000 002D"
- $"2C28 0000 0000 0007 2E2D 2D2D 2D2D 2D00 0000 0000 0000 0000"
- $"0000 0000 0000 0000 2D2C 2900 0000 072E 2D2D 2D2D 2D2D 0000"
- $"0000 0000 0000 0000 0000 0000 0000 0000 002D 2C28 2607 2F2D"
- $"2D2D 2D2D 2D00 0000 0000 0000 0000 0000 0000 0000 0000 0000"
- $"0000 2D2D 282E 2D2D 2D2D 2D00 0000 0000 0000 0000 0000 0000"
- $"0000 0000 0000 0000 0000 002D 2E2D 2D2D 2D2D 0000 0000 0000"
- $"0000"
-};
-
-data 'ICON' (1000) { /* kApplicationIcon */
- $"0000 0000 001F F01C 0030 3826 0048 7C5E 0084 E69C 0103 C338"
- $"0200 9E70 0400 24E0 0800 49E0 1000 9330 2001 2618 4002 4E0C"
- $"8002 9A07 8001 7C07 C002 8007 6002 E007 3007 FC07 1806 1FC7"
- $"0C00 01FF 0600 003F 0300 0007 0180 000E 00C0 001F 0060 003F"
- $"0030 007F 0018 00FE 000C 01FC 0006 03F8 0003 07F0 0001 8FE0"
- $"0000 DF80 0000 7F00"
-};
-
-
-/* The other resources should not need to be changed. */
-
-data 'TEXT' (kAboutText2, purgeable) {
- "Includes (parts of) Objective Caml, MPW libraries,"
- "and the WASTE text engine.\n"
- "\n"
- "Objective Caml Copyright 1991-2001 INRIA, all rights reserved.\n"
- "MPW © 1983-2001 by Apple Computer, Inc., all rights reserved\n"
- "WASTE text engine © 1993-1998 Marco Piovanelli\n"
-};
-
-resource 'SIZE' (-1) {
- reserved,
- acceptSuspendResumeEvents,
- reserved,
- canBackground,
- doesActivateOnFGSwitch,
- backgroundAndForeground,
- dontGetFrontClicks,
- ignoreChildDiedEvents,
- is32BitCompatible,
- isHighLevelEventAware,
- localAndRemoteHLEvents,
- isStationeryAware,
- dontuseTextEditServices,
- reserved,
- reserved,
- reserved,
- PREFSIZE * 1024,
- MINSIZE * 1024
-};
-
-type 'Kequ' {
- wide array KequArray {
- byte any = 0 command = 1;
- byte char;
- byte item;
- fill byte;
- };
-};
-
-resource 'Kequ' (kKeysOK) {
- {
- any, charReturn, 1,
- any, charEnter, 1,
- any, 'o', 1,
- any, 'O', 1,
- }
-};
-
-resource 'Kequ' (kKeysSaveDontCancel) {
- {
- any, charReturn, 1,
- any, charEnter, 1,
- any, 'y', 1,
- any, 'Y', 1,
- any, 's', 1,
- any, 'S', 1,
-
- any, charEscape, 2,
- command, '.', 2,
- any, 'c', 2,
- any, 'C', 2,
-
- any, 'n', 3,
- any, 'N', 3,
- any, 'd', 3,
- any, 'D', 3,
- }
-};
-
-resource 'ALRT' (kAlertBug) {
- {60, 61, 260, 451}, kAlertBug,
- {
- OK, visible, silent,
- OK, visible, silent,
- OK, visible, silent,
- OK, visible, silent,
- },
- alertPositionParentWindowScreen
-};
-
-resource 'DITL' (kAlertBug) {
- {
- {160, 310, 180, 368}, Button {enabled, "Quit"},
-
- {10, 70, 80, 368},
- StaticText {disabled, /* Don't change this occurrence of Obj Caml */
- "You have discovered a bug in Objective Caml. Please"
- " report the following information to <caml-bugs@inria.fr>."
- },
-
- {80, 20, 145, 368},
- StaticText {disabled, "file: ^1\nline: ^2\nexpr: ^0"},
- }
-};
-
-resource 'ALRT' (kAlertNotYet) {
- {60, 81, 160, 431}, kAlertNotYet,
- {
- OK, visible, silent,
- OK, visible, silent,
- OK, visible, silent,
- OK, visible, silent,
- },
- alertPositionParentWindowScreen
-};
-
-resource 'DITL' (kAlertNotYet) {
- {
- {60, 270, 80, 328}, Button {enabled, "OK"},
-
- {10, 70, 45, 328},
- StaticText {disabled, "This feature is not yet implemented." },
- }
-};
-
-resource 'ALRT' (kAlertNeedSys7) {
- {60, 81, 200, 431}, kAlertNeedSys7,
- {
- OK, visible, silent,
- OK, visible, silent,
- OK, visible, silent,
- OK, visible, silent,
- },
- alertPositionMainScreen
-};
-
-resource 'DITL' (kAlertNeedSys7) {
- {
- {100, 270, 120, 328},
- Button {enabled, "Quit"},
-
- {10, 70, 85, 328},
- StaticText {
- disabled,
- APPLNAME " cannot run on MacOS versions prior to System 7."
- },
-
- {10, 20, 42, 52}, Icon {disabled, kApplicationIcon},
- }
-};
-
-resource 'ALRT' (kAlertNeed32BitQD) {
- {60, 81, 200, 431}, kAlertNeed32BitQD,
- {
- OK, visible, silent,
- OK, visible, silent,
- OK, visible, silent,
- OK, visible, silent,
- },
- alertPositionMainScreen
-};
-
-resource 'DITL' (kAlertNeed32BitQD) {
- {
- {100, 270, 120, 328},
- Button {enabled, "Quit"},
-
- {10, 70, 85, 328},
- StaticText {
- disabled,
- APPLNAME " needs a Macintosh with 32-bit color QuickDraw."
- },
-
- {10, 20, 42, 52}, Icon {disabled, kApplicationIcon},
- }
-};
-
-resource 'ALRT' (kAlertExit) {
- {60, 81, 210, 431}, kAlertExit,
- {
- OK, visible, silent,
- OK, visible, silent,
- OK, visible, silent,
- OK, visible, silent,
- },
- alertPositionParentWindowScreen
-};
-
-resource 'DITL' (kAlertExit) {
- {
- {110, 270, 130, 328}, Button {enabled, "OK"},
-
- {10, 70, 95, 328},
- StaticText {
- disabled,
- "The " APPLNAME " toplevel loop has terminated^0^1.\n\n"
- "Any further input in the toplevel window will be ignored."
- },
- }
-};
-
-resource 'ALRT' (kAlertErrorMsg) {
- {60, 81, 200, 431}, kAlertErrorMsg,
- {
- OK, visible, sound1,
- OK, visible, sound1,
- OK, visible, sound1,
- OK, visible, sound1,
- },
- alertPositionParentWindowScreen
-};
-
-resource 'DITL' (kAlertErrorMsg) {
- {
- {100, 270, 120, 328}, Button {enabled, "OK"},
- {10, 70, 85, 328}, StaticText { disabled, "^0^1^2^3" },
- }
-};
-
-resource 'ALRT' (kAlertErrorNum) {
- {60, 81, 200, 431}, kAlertErrorNum,
- {
- OK, visible, sound1,
- OK, visible, sound1,
- OK, visible, sound1,
- OK, visible, sound1,
- },
- alertPositionParentWindowScreen
-};
-
-resource 'DITL' (kAlertErrorNum) {
- {
- {100, 270, 120, 328}, Button {enabled, "OK"},
-
- {10, 70, 85, 328},
- StaticText { disabled, "An error occurred.\n\nerror code = ^3" },
- }
-};
-
-resource 'ALRT' (kAlertGeneric) {
- {60, 81, 200, 431}, kAlertGeneric,
- {
- OK, visible, sound1,
- OK, visible, sound1,
- OK, visible, sound1,
- OK, visible, sound1,
- },
- alertPositionParentWindowScreen
-};
-
-resource 'DITL' (kAlertGeneric) {
- {
- {100, 270, 120, 328}, Button {enabled, "OK"},
-
- {10, 20, 85, 378},
- StaticText { disabled, "^0^1^2^3" },
- }
-};
-
-resource 'ALRT' (kAlertSaveAsk) {
- {60, 81, 200, 431}, kAlertSaveAsk,
- {
- OK, visible, silent,
- OK, visible, silent,
- OK, visible, silent,
- OK, visible, silent,
- },
- alertPositionParentWindowScreen
-};
-
-resource 'DITL' (kAlertSaveAsk) {
- {
- {100, 270, 120, 328}, Button {enabled, "Save"},
- {100, 202, 120, 260}, Button {enabled, "Cancel"},
- {100, 22, 120, 110}, Button {enabled, "Don't Save"},
- {10, 70, 85, 328}, StaticText { disabled, "Save \"^0\" before ^1 ?" },
- {10, 20, 42, 52}, Icon {disabled, kApplicationIcon},
- }
-};
-
-resource 'DLOG' (kDialogAbout) {
- {70, 60, 285, 470},
- noGrowDocProc,
- visible,
- goAway,
- 0,
- kDialogAbout,
- "About " APPLNAME,
- alertPositionMainScreen
-};
-
-resource 'DITL' (kDialogAbout) {
- {
- {10, 20, 42, 52}, Icon {disabled, kApplicationIcon},
- {10, 72, 205, 400}, UserItem { disabled },
- }
-};
-
-resource 'MBAR' (kMenuBar) {
- { kMenuApple, kMenuFile, kMenuEdit, kMenuWindows, }
-};
-
-resource 'MENU' (kMenuApple) {
- kMenuApple,
- textMenuProc,
- 0x7FFFFFFD,
- enabled,
- apple,
- {
- "About " APPLNAME "É", noIcon, noKey, noMark, plain,
- "-", noIcon, noKey, noMark, plain,
- }
-};
-
-resource 'MENU' (kMenuFile) {
- kMenuFile,
- textMenuProc,
- 0x7FFFFB7B,
- enabled,
- "File",
- {
- "New", noIcon, "N", noMark, plain,
- "OpenÉ", noIcon, "O", noMark, plain,
- "-", noIcon, noKey, noMark, plain,
- "Close", noIcon, "W", noMark, plain,
- "Save", noIcon, "S", noMark, plain,
- "Save asÉ", noIcon, noKey, noMark, plain,
- "Revert to Saved", noIcon, noKey, noMark, plain,
- "-", noIcon, noKey, noMark, plain,
- "Page SetupÉ", noIcon, nokey, noMark, plain,
- "PrintÉ", noIcon, "P", noMark, plain,
- "-", noIcon, noKey, noMark, plain,
- "Quit", noIcon, "Q", noMark, plain,
- }
-};
-
-resource 'MENU' (kMenuEdit) {
- kMenuEdit,
- textMenuProc,
- 0x7FFFFFBD,
- enabled,
- "Edit",
- {
- "Undo", noIcon, "Z", noMark, plain,
- "-", noIcon, noKey, noMark, plain,
- "Cut", noIcon, "X", noMark, plain,
- "Copy", noIcon, "C", noMark, plain,
- "Paste", noIcon, "V", noMark, plain,
- "Clear", noIcon, noKey, noMark, plain,
- "Select All", noIcon, "A", noMark, plain,
- "Show Clipboard", noIcon, noKey, noMark, plain,
- "-", noIcon, noKey, noMark, plain,
- "FindÉ", noIcon, "F", noMark, plain,
- "ReplaceÉ", noIcon, "R", noMark, plain,
- "-", noIcon, noKey, noMark, plain,
- "PreferencesÉ", noIcon, noKey, noMark, plain,
- }
-};
-
-resource 'MENU' (kMenuWindows) {
- kMenuWindows,
- textMenuProc,
- 0x7FFFFFF9,
- enabled,
- "Windows",
- {
- "Toplevel", noIcon, "T", noMark, plain,
- "Graphics", noIcon, "G", noMark, plain,
- "-", noIcon, noKey, noMark, plain,
- }
-};
-
-resource 'STR#' (kUndoStrings) {
- {
- "Cannot undo",
- "Undo", "Redo",
- "Undo Typing", "Redo Typing",
- "Undo Cut", "Redo Cut",
- "Undo Paste", "Redo Paste",
- "Undo Clear", "Redo Clear",
- "Undo Drag & Drop", "Redo Drag & Drop",
- /* Style change is not supported. */
- }
-};
-
-resource 'STR#' (kMiscStrings, purgeable) {
- {
- APPLNAME " Preferences",
- "Untitled",
- "closing",
- "quitting",
- "Unable to open \"",
- "\". ",
- "Save file as:",
- "",
- "Unable to write to \"",
- " with error code ",
- }
-};
-
-resource 'STR#' (kErrorStrings, purgeable) {
- {
- "There is not enough memory.",
- "The disk is full.",
- "The directory is full.",
- "Too many files are already open.",
- "The file does not exist.",
- "The disk is write-protected.",
- "The file is locked.",
- "The disk is locked.",
- "The file is in use.",
- "The file is already open (by " APPLNAME " or another application).",
- "The disk was ejected.",
- "The file is locked or you do not have the permission to open it.",
- "You do not have the permission to write to this file.",
- "The folder does not exist.",
- "The connection to the file server was closed or broken.",
- "A hardware error occurred during input or output.",
- }
-};
-
-resource 'STR ' (kPrefsDescriptionStr, purgeable) {
- "This document describes user preferences for " APPLNAME ". "
- "You cannot open or print this document. To be "
- "effective, this document must be stored in the Preferences "
- "folder of the System Folder."
-};
-
-resource 'WIND' (kToplevelWinTemplate) {
- {40, 4, 342, 512},
- zoomDocProc,
- invisible,
- noGoAway,
- 0,
- APPLNAME " Toplevel",
- noAutoCenter
-};
-
-resource 'WIND' (kGraphicsWinTemplate) {
- {40, 4, 342, 512},
- zoomDocProc,
- invisible,
- goAway,
- 0,
- APPLNAME " Graphics",
- noAutoCenter
-};
-
-resource 'WIND' (kDocumentWinTemplate) {
- {45, 10, 342, 512},
- zoomDocProc,
- visible,
- goAway,
- 0,
- "Untitled",
- staggerMainScreen
-};
-
-resource 'CNTL' (kScrollBarTemplate) {
- {0, 0, 16, 16},
- 0,
- invisible,
- 0, 0,
- scrollBarProc,
- 0,
- ""
-};
-
-resource 'acur' (0) {
- {1000, 1001, 1002, 1003, }
-};
-
-resource 'CURS' (1000) {
- $"07C0 1F30 3F08 7F04 7F04 FF02 FF02 FFFE"
- $"81FE 81FE 41FC 41FC 21F8 19F0 07C0",
- $"07C0 1FF0 3FF8 7FFC 7FFC FFFE FFFE FFFE"
- $"FFFE FFFE 7FFC 7FFC 3FF8 1FF0 07C0",
- {7, 7}
-};
-
-resource 'CURS' (1001) {
- $"07C0 1FF0 3FF8 5FF4 4FE4 87C2 8382 8102"
- $"8382 87C2 4FE4 5FF4 3FF8 1FF0 07C0",
- $"07C0 1FF0 3FF8 7FFC 7FFC FFFE FFFE FFFE"
- $"FFFE FFFE 7FFC 7FFC 3FF8 1FF0 07C0",
- {7, 7}
-};
-
-resource 'CURS' (1002) {
- $"07C0 19F0 21F8 41FC 41FC 81FE 81FE FFFE"
- $"FF02 FF02 7F04 7F04 3F08 1F30 07C0",
- $"07C0 1FF0 3FF8 7FFC 7FFC FFFE FFFE FFFE"
- $"FFFE FFFE 7FFC 7FFC 3FF8 1FF0 07C0",
- {7, 7}
-};
-
-resource 'CURS' (1003) {
- $"07C0 1830 2008 701C 783C FC7E FEFE FFFE"
- $"FEFE FC7E 783C 701C 2008 1830 07C0",
- $"07C0 1FF0 3FF8 7FFC 7FFC FFFE FFFE FFFE"
- $"FFFE FFFE 7FFC 7FFC 3FF8 1FF0 07C0",
- {7, 7}
-};
-
-resource 'snd ' (1002){
- FormatOne{
- { sampledSynth, 0x80 },
- },
- {
- hasData, soundCmd {0x2C},
- noData, ampCmd {127},
- noData, freqDurationCmd {0x4321, 60},
- noData, quietCmd {},
- },
- {
- 4,
- Rate22K,
- 0, 4,
- 0,
- 60,
- $"FF01FF01"
- }
-};
-
-resource 'snd ' (1004){
- FormatOne{
- { sampledSynth, 0x80 },
- },
- {
- hasData, soundCmd {0x2C},
- noData, ampCmd {127},
- noData, freqDurationCmd {0x4321, 60},
- noData, quietCmd {},
- },
- {
- 4,
- Rate22K,
- 0, 4,
- 0,
- 60,
- $"FF800180"
- }
-};
-
-resource 'snd ' (1008){
- FormatOne{
- { sampledSynth, 0x80 },
- },
- {
- hasData, soundCmd {0x2C},
- noData, ampCmd {127},
- noData, freqDurationCmd {0x4321, 60},
- noData, quietCmd {},
- },
- {
- 8,
- Rate22K,
- 0, 8,
- 0,
- 60,
- $"FFDA8026012680DA"
- }
-};
-
-resource 'snd ' (1032){
- FormatOne{
- { sampledSynth, 0x80 },
- },
- {
- hasData, soundCmd {0x2C},
- noData, ampCmd {127},
- noData, freqDurationCmd {0x4321, 60},
- noData, quietCmd {},
- },
- {
- 32,
- Rate22K,
- 0, 32,
- 0,
- 60,
- $"FFFDF5EADAC7B19980674F3926160B0301030B1626394F678099B1C7DAEAF5FD"
- }
-};
-
-
-resource 'snd ' (1128){
- FormatOne{
- { sampledSynth, 0x80 },
- },
- {
- hasData, soundCmd {0x2C},
- noData, ampCmd {127},
- noData, freqDurationCmd {0x4321, 60},
- noData, quietCmd {},
- },
- {
- 128,
- Rate22K,
- 0, 128,
- 0,
- 60,
- $"FFFFFEFEFDFBFAF8F5F3F0EDEAE6E2DEDAD5D1CCC7C1BCB6B1ABA59F99938C86"
- $"807A746D67615B554F4A443F39342F2B26221E1A1613100D0B08060503020201"
- $"01010202030506080B0D1013161A1E22262B2F34393F444A4F555B61676D747A"
- $"80868C93999FA5ABB1B6BCC1C7CCD1D5DADEE2E6EAEDF0F3F5F8FAFBFDFEFEFF"
- }
-};
-
-resource 'snd ' (1512, "foo"){
- FormatOne{
- { sampledSynth, 0x80 },
- },
- {
- hasData, soundCmd {0x2C},
- noData, ampCmd {127},
- noData, freqDurationCmd {0x4321, 60},
- noData, quietCmd {},
- },
- {
- 512,
- Rate22K,
- 0, 512,
- 0,
- 60,
- $"FFFFFFFFFFFFFFFFFEFEFEFEFEFDFDFDFDFCFCFCFBFBFAFAFAF9F9F8F8F7F6F6"
- $"F5F5F4F3F3F2F1F1F0EFEFEEEDECEBEAEAE9E8E7E6E5E4E3E2E1E0DFDEDDDCDB"
- $"DAD9D8D6D5D4D3D2D1CFCECDCCCAC9C8C7C5C4C3C1C0BFBDBCBAB9B8B6B5B3B2"
- $"B1AFAEACABA9A8A6A5A3A2A09F9D9C9A999796949391908E8C8B898886858382"
- $"807E7D7B7A7877757472706F6D6C6A696766646361605E5D5B5A585755545251"
- $"4F4E4D4B4A484746444341403F3D3C3B39383736343332312F2E2D2C2B2A2827"
- $"262524232221201F1E1D1C1B1A1918171616151413121111100F0F0E0D0D0C0B"
- $"0B0A0A0908080707060606050504040403030303020202020201010101010101"
- $"0101010101010101020202020203030303040404050506060607070808090A0A"
- $"0B0B0C0D0D0E0F0F1011111213141516161718191A1B1C1D1E1F202122232425"
- $"2627282A2B2C2D2E2F31323334363738393B3C3D3F404143444647484A4B4D4E"
- $"4F5152545557585A5B5D5E606163646667696A6C6D6F7072747577787A7B7D7E"
- $"808283858688898B8C8E909193949697999A9C9D9FA0A2A3A5A6A8A9ABACAEAF"
- $"B1B2B3B5B6B8B9BABCBDBFC0C1C3C4C5C7C8C9CACCCDCECFD1D2D3D4D5D6D8D9"
- $"DADBDCDDDEDFE0E1E2E3E4E5E6E7E8E9EAEAEBECEDEEEFEFF0F1F1F2F3F3F4F5"
- $"F5F6F6F7F8F8F9F9FAFAFAFBFBFCFCFCFDFDFDFDFEFEFEFEFEFFFFFFFFFFFFFF"
- }
-};
-
-resource 'FREF' (128) {
- 'APPL',
- 0,
- ""
-};
-
-resource 'FREF' (129) {
- 'TEXT',
- 1,
- ""
-};
-
-resource 'FREF' (130) {
- 'sEXT',
- 2,
- ""
-};
-
-resource 'BNDL' (128) {
- CREATOR,
- 0,
- { /* array TypeArray: 2 elements */
- /* [1] */
- 'FREF',
- { /* array IDArray: 3 elements */
- /* [1] */
- 0, 128,
- /* [2] */
- 1, 129,
- /* [3] */
- 2, 130
- },
- /* [2] */
- 'ICN#',
- { /* array IDArray: 3 elements */
- /* [1] */
- 0, 1000,
- /* [2] */
- 1, 1001,
- /* [3] */
- 2, 1002
- }
- }
-};
-
-data CREATOR (0) {
- $"00" /* . */
-};
diff --git a/maccaml/clipboard.c b/maccaml/clipboard.c
deleted file mode 100644
index 0e09065fb2..0000000000
--- a/maccaml/clipboard.c
+++ /dev/null
@@ -1,40 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Para, INRIA Rocquencourt */
-/* */
-/* Copyright 1998 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "main.h"
-
-WindowPtr clip_window = NULL;
-
-/* Open clipboard window or bring it to the front. */
-void ClipShow (void)
-{
- if (clip_window != NULL){
- SelectWindow (clip_window);
- }else{
- XXX ();
- }
-}
-
-void ClipClose (void)
-{
- XXX ();
-}
-
-void ClipChanged (void)
-{
- if (clip_window != NULL){
- XXX ();
- }
-}
diff --git a/maccaml/drag.c b/maccaml/drag.c
deleted file mode 100644
index 64bf909cf3..0000000000
--- a/maccaml/drag.c
+++ /dev/null
@@ -1,241 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Para, INRIA Rocquencourt */
-/* */
-/* Copyright 1997 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "main.h"
-
-static DragTrackingHandlerUPP MyTrackingHandlerUPP = NULL;
-static DragReceiveHandlerUPP MyReceiveHandlerUPP = NULL;
-
-static OSErr ToplevelTrackDrag (DragTrackingMessage message, DragReference drag)
-{
- static int canacceptdrag = 0;
- static int hilited = 0;
- WEReference we = WinGetWE (winToplevel);
- short readonly;
- Point mouse;
- RgnHandle rgn = NewRgn ();
- Rect viewrect;
- LongRect lviewrect;
- OSErr err;
- DragAttributes attributes;
-
- Assert (we != NULL);
- switch (message){
-
- case kDragTrackingEnterWindow:
- readonly = WEFeatureFlag (weFReadOnly, weBitTest, we);
- WEFeatureFlag (weFReadOnly, weBitClear, we);
- canacceptdrag = WECanAcceptDrag (drag, we);
- if (readonly) WEFeatureFlag (weFReadOnly, weBitSet, we);
- break;
-
- case kDragTrackingInWindow:
- if (canacceptdrag){
- err = GetDragAttributes (drag, &attributes);
- if (err != noErr) goto failed;
- err = GetDragMouse (drag, &mouse, nil);
- if (err != noErr) goto failed;
- GlobalToLocal (&mouse);
- WEGetViewRect (&lviewrect, we);
- WELongRectToRect (&lviewrect, &viewrect);
- InsetRect (&viewrect, -kTextMarginH, 0);
- if (PtInRect (mouse, &viewrect)){
- if (!hilited && (attributes & kDragHasLeftSenderWindow)){
- RectRgn (rgn, &viewrect);
- InsetRgn (rgn, 0, -kTextMarginV);
- ShowDragHilite (drag, rgn, true);
- DisposeRgn (rgn);
- hilited = 1;
- }
- }else{
- if (hilited){
- HideDragHilite (drag);
- hilited = 0;
- }
- }
- }
- break;
-
- case kDragTrackingLeaveWindow:
- if (hilited){
- HideDragHilite (drag);
- hilited = 0;
- }
- break;
-
- default: break;
- }
- return noErr;
-
- failed: return err;
-}
-
-static pascal OSErr MyTrackingHandler (DragTrackingMessage message, WindowPtr w,
- void *refCon, DragReference drag)
-{
- #pragma unused (refCon)
- WEReference we;
-
- switch (WinGetKind (w)){
- case kWinUnknown:
- case kWinUninitialised:
- case kWinAbout:
- case kWinGraphics:
- case kWinPrefs:
- case kWinClipboard:
- return noErr;
-
- case kWinToplevel:
- return ToplevelTrackDrag (message, drag);
-
- case kWinDocument:
- we = WinGetWE (w); Assert (we != NULL);
- return WETrackDrag (message, drag, we);
-
- default:
- Assert (0);
- return noErr;
- }
-}
-
-static OSErr ToplevelReceiveDrag (DragReference drag, WEReference we)
-{
- GrafPtr saveport;
- short readonly = 0;
- Boolean canaccept;
- OSErr err;
- Point mouse;
- LongRect lviewrect;
- Rect viewrect;
- UInt16 nitems;
- UInt16 i;
- ItemReference itemref;
- Handle h = NULL;
- Size sz, curlen;
- long dest, selstart, selend = -1;
-
- PushWindowPort (winToplevel);
-
- readonly = WEFeatureFlag (weFReadOnly, weBitTest, we);
- if (readonly) WEFeatureFlag (weFReadOnly, weBitClear, we);
- canaccept = WECanAcceptDrag (drag, we);
- if (!canaccept){ err = badDragFlavorErr; goto failed; }
-
- err = GetDragMouse (drag, &mouse, nil);
- if (err != noErr) goto failed;
- GlobalToLocal (&mouse);
- WEGetViewRect (&lviewrect, we);
- WELongRectToRect (&lviewrect, &viewrect);
- if (!PtInRect (mouse, &viewrect)){ err = dragNotAcceptedErr; goto failed; }
-
- /* XXX Ne pas coller si le drag vient de la mme fentre et la souris
- est revenue dans la sŽlection. */
-
- h = NewHandle (0);
- err = MemError (); if (err != noErr) goto failed;
- curlen = 0;
-
- err = CountDragItems (drag, &nitems);
- if (err != noErr) goto failed;
-
- for (i = 1; i <= nitems; i++){
- err = GetDragItemReferenceNumber (drag, i, &itemref);
- if (err != noErr) goto failed;
- err = GetFlavorDataSize (drag, itemref, kTypeText, &sz);
- if (err != noErr) goto failed;
- SetHandleSize (h, curlen + sz);
- err = MemError (); if (err != noErr) goto failed;
- HLock (h);
- err = GetFlavorData (drag, itemref, kTypeText, (*h)+curlen, &sz, 0);
- HUnlock (h);
- if (err != noErr) goto failed;
- curlen += sz;
- }
- dest = WEGetTextLength (we);
- WEGetSelection (&selstart, &selend, we);
- WESetSelection (dest, dest, we);
- WESetStyle (weDoFont + weDoFace + weDoSize + weDoColor + weDoReplaceFace,
- &prefs.unread, we);
- HLock (h);
- err = WEInsert (*h, curlen, NULL, NULL, we);
- HUnlock (h);
- if (err != noErr) goto failed;
- WESetSelection (dest + curlen, dest + curlen, we);
- ScrollToEnd (winToplevel);
-
- DisposeHandle (h);
- PopPort;
- return noErr;
-
- failed:
- if (h != NULL) DisposeHandle (h);
- if (selend != -1) WESetSelection (selstart, selend, we);
- if (readonly) WEFeatureFlag (weFReadOnly, weBitSet, we);
- PopPort;
- return err;
-}
-
-static pascal OSErr MyReceiveHandler (WindowPtr w, void *refCon,
- DragReference drag)
-{
- #pragma unused (refCon)
- WEReference we;
-
- switch (WinGetKind (w)){
- case kWinUnknown:
- case kWinUninitialised:
- case kWinAbout:
- case kWinGraphics:
- case kWinPrefs:
- case kWinClipboard:
- return noErr;
- case kWinToplevel:
- we = WinGetWE (w); Assert (we != NULL);
- return ToplevelReceiveDrag (drag, we);
- case kWinDocument:
- we = WinGetWE (w); Assert (we != NULL);
- return WEReceiveDrag (drag, we);
- default:
- Assert (0);
- return noErr;
- }
-}
-
-OSErr InstallDragHandlers (void)
-{
- OSErr err;
-
- MyTrackingHandlerUPP = NewDragTrackingHandlerProc (MyTrackingHandler);
- MyReceiveHandlerUPP = NewDragReceiveHandlerProc (MyReceiveHandler);
-
- err = InstallTrackingHandler (MyTrackingHandlerUPP, NULL, NULL);
- if (err != noErr) return err;
- err = InstallReceiveHandler (MyReceiveHandlerUPP, NULL, NULL);
- if (err != noErr){
- RemoveTrackingHandler (MyTrackingHandlerUPP, NULL);
- return err;
- }
- return noErr;
-}
-
-OSErr RemoveDragHandlers (void)
-{
- OSErr err1, err2;
-
- err1 = RemoveTrackingHandler (MyTrackingHandlerUPP, NULL);
- err2 = RemoveReceiveHandler (MyReceiveHandlerUPP, NULL);
- if (err2 != noErr && err1 == noErr) return err2;
- return err1;
-}
diff --git a/maccaml/dummy_fragment.c b/maccaml/dummy_fragment.c
deleted file mode 100644
index 2a924f1d6a..0000000000
--- a/maccaml/dummy_fragment.c
+++ /dev/null
@@ -1 +0,0 @@
-/* This file intentionally left blank. */
diff --git a/maccaml/errors.c b/maccaml/errors.c
deleted file mode 100644
index bf32ce4e9f..0000000000
--- a/maccaml/errors.c
+++ /dev/null
@@ -1,114 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Para, INRIA Rocquencourt */
-/* */
-/* Copyright 1997 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "main.h"
-
-static int exiting = 0;
-
-void assert_failure (char *condition, char *file, int line)
-{
- Str255 buf;
-
- if (exiting) ExitToShell ();
- exiting = 1;
- NumToString ((long) line, buf);
- ParamText (c2pstr (condition), c2pstr (file), buf, NULL);
- InitCursor ();
- modalkeys = kKeysOK;
- StopAlert (kAlertBug, myModalFilterUPP);
- FinaliseAndQuit ();
-}
-
-void XXX (void)
-{
- InitCursor ();
- modalkeys = kKeysOK;
- StopAlert (kAlertNotYet, myModalFilterUPP);
-}
-
-void ErrorAlert (short msg1, Str255 bufmsg2, short msg3, OSErr err)
-{
- Str255 bufmsg1, bufmsg3, bufmsg4;
- short msg;
-
- switch (err){
- case noErr:
- case userCanceledErr: return;
-
- case mFulErr:
- case memFullErr:
- case cTempMemErr:
- case cNoMemErr:
- case updPixMemErr: msg = kMemFull; break;
- case dskFulErr:
- case afpDiskFull: msg = kDiskFull; break;
- case dirFulErr: msg = kDirFull; break;
- case tmfoErr:
- case afpTooManyFilesOpen: msg = kTooManyFiles; break;
- case fnfErr: msg = kFileNotFound; break;
- case wPrErr: msg = kWriteProtect; break;
- case fLckdErr:
- case afpObjectLocked: msg = kFileLocked; break;
- case vLckdErr:
- case afpVolLocked: msg = kVolLocked; break;
- case fBsyErr:
- case afpFileBusy: msg = kFileBusy; break;
- case opWrErr: msg = kFileOpen; break;
- case volOffLinErr: msg = kVolOffLine; break;
- case permErr:
- case afpAccessDenied: msg = kPermDenied; break;
- case wrPermErr: msg = kWritePermDenied; break;
- case dirNFErr: msg = kDirNotFound; break;
- case volGoneErr:
- case afpSessClosed: msg = kDisconnected; break;
- case ioErr: msg = kIOError; break;
-
- default: msg = 0; break;
- }
-
- GetIndString (bufmsg1, kMiscStrings, msg1);
- GetIndString (bufmsg3, kMiscStrings, msg3);
-
- if (msg != 0){
- GetIndString (bufmsg4, kErrorStrings, msg);
- ParamText (bufmsg1, bufmsg2, bufmsg3, bufmsg4);
- }else{
- NumToString (err, bufmsg4);
- ParamText (bufmsg1, bufmsg2, bufmsg3, bufmsg4);
- }
- InitCursor ();
- modalkeys = kKeysOK;
- StopAlert (msg ? kAlertErrorMsg : kAlertErrorNum, myModalFilterUPP);
-}
-
-void ErrorAlertCantOpen (Str255 filename, OSErr err)
-{
- ErrorAlert (kCannotOpenIdx, filename, kCloseQuoteIdx, err);
-}
-
-void ErrorAlertGeneric (OSErr err)
-{
- ErrorAlert (kEmptyIdx, "\p", kEmptyIdx, err);
-}
-
-OSErr InitialiseErrors (void)
-{
- /* XXX CouldAlert is not in any library ?!?
- CouldAlert (kAlertErrorMsg);
- CouldAlert (kAlertErrorNum);
- CouldAlert (kAlertBug);
- */
- return noErr;
-}
diff --git a/maccaml/events.c b/maccaml/events.c
deleted file mode 100644
index 7411482094..0000000000
--- a/maccaml/events.c
+++ /dev/null
@@ -1,319 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Para, INRIA Rocquencourt */
-/* */
-/* Copyright 1997 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "main.h"
-
-/* [intr_requested] is true if the user typed command-period and the
- SIGINT signal was not yet delivered.
-*/
-int intr_requested = 0;
-
-UInt32 last_event_date = 0;
-
-UInt32 evtSleep = 0;
-static RgnHandle mouseRegion = NULL;
-static RgnHandle pointRegion = NULL;
-
-static void AdjustCursor (Point mouse, RgnHandle mouseRegion)
-{
- WindowPtr w = FrontWindow ();
- WEHandle we = WinGetWE (w);
- int k = WinGetKind (w);
- Boolean res;
-
- SetRectRgn (mouseRegion, -SHRT_MAX, -SHRT_MAX, SHRT_MAX, SHRT_MAX);
- if (we != NULL && k != kWinAbout){
- if (w == winToplevel){
- res = AdjustRotatingCursor ();
- if (res) return;
- }
- res = WEAdjustCursor (mouse, mouseRegion, we);
- if (res) return;
- }
- SetCursor (&qd.arrow);
-}
-
-static void DoActivate (EventRecord *evt)
-{
- WindowPtr w = (WindowPtr) evt->message;
-
- if (GetWindowKind (w) != userKind) return; /*XXX*/
- WinActivateDeactivate (evt->modifiers & activeFlag, w);
-}
-
-static void DoDiskEvent (EventRecord *evt)
-{
- OSErr err;
- Point pt;
-
- if (evt->message >> 16 != noErr){
- DILoad ();
- err = DIBadMount (pt, evt->message); /* [pt] is ignored */
- if (err != noErr && err != 1 && err != 2){
- ErrorAlertGeneric (err); /* XXX or nothing ? */
- }
- DIUnload ();
- }
-}
-
-static void DoKeyDown (EventRecord *evt)
-{
- short chr = evt->message & charCodeMask;
- Boolean isCmdKey = (evt->modifiers & cmdKey) != 0;
-
- if (chr == 0x10){
- switch ((evt->message & keyCodeMask) >> 8){
- case keyF1:
- isCmdKey = 1;
- chr = 'z';
- break;
- case keyF2:
- isCmdKey = 1;
- chr = 'x';
- break;
- case keyF3:
- isCmdKey = 1;
- chr = 'c';
- break;
- case keyF4:
- isCmdKey = 1;
- chr = 'v';
- break;
- default:
- chr = -1;
- }
- }
- if (isCmdKey && chr == '.'
- && FrontWindow () == winToplevel
- && evt->what != autoKey){
- FlushUnreadInput ();
- raise (SIGINT);
- }
- if (isCmdKey && chr >= 0x20){
- UpdateMenus ();
- DoMenuChoice (MenuKey (chr), evt->modifiers);
- }else{
- WindowPtr w = FrontWindow ();
- if (chr != -1 && w != NULL){
- WinDoKey (w, chr, evt);
- }
- }
-}
-
-static void DoMouseDown (EventRecord *event)
-{
- WindowPtr w;
- short partCode;
-
- partCode = FindWindow (event->where, &w);
- switch (partCode){
- case inMenuBar:
- UpdateMenus ();
- DoMenuChoice (MenuSelect (event->where), event->modifiers);
- break;
- case inSysWindow:
- SystemClick (event, w);
- break;
- case inContent:
- WinDoContentClick (event, w);
- break;
- case inDrag:
- WinDoDrag (event->where, w);
- break;
- case inGrow:
- WinDoGrow (event->where, w);
- break;
- case inGoAway:
- if (TrackGoAway (w, event->where)) WinDoClose (closingWindow, w);
- break;
- case inZoomIn:
- case inZoomOut:
- if (TrackBox (w, event->where, partCode)) WinDoZoom (w, partCode);
- break;
- }
-}
-
-/* XXX recuperer les mouse-up pour matcher les mouse-down ? */
-static void DoMouseUp (EventRecord *e)
-{
- short partCode;
- WindowPtr w;
- Point hitpt;
- GrafPtr saveport;
- Rect r;
-
- if (FrontWindow () != winGraphics) return;
- partCode = FindWindow (e->where, &w);
- if (partCode != inContent) return;
- PushWindowPort (winGraphics);
- hitpt = e->where;
- GlobalToLocal (&hitpt);
- ScrollCalcGraph (winGraphics, &r);
- if (PtInRect (hitpt, &r)) GraphGotEvent (e);
- PopPort;
- return;
-}
-
-static void DoNullEvent (EventRecord *event)
-{
-#pragma unused (event)
- WindowPtr w = FrontWindow ();
-
- if (w != NULL) WinDoIdle (w);
-}
-
-static void DoOSEvent (EventRecord *event)
-{
- int msg = (event->message & osEvtMessageMask) >> 24;
- WindowPtr w;
-
- switch (msg){
- case suspendResumeMessage:
- w = FrontWindow ();
- if (w != NULL){
- Boolean state = !! (event->message & resumeFlag);
- WinActivateDeactivate (state, w);
- }
- if (event->message & convertClipboardFlag) ClipChanged ();
- case mouseMovedMessage: ;
- }
-}
-
-static void DoUpdate (EventRecord *evt)
-{
- WindowPtr w = (WindowPtr) evt->message;
-
- if (GetWindowKind (w) != userKind) return; /*XXX*/
- WinUpdate (w);
-}
-
-static void DoDialogEvent (EventRecord *evt)
-{
- DialogPtr dlg;
- short itm;
-
- if (evt->what == diskEvt){
- DoDiskEvent (evt);
- return;
- }else if (evt->what == keyDown || evt->what == autoKey){
- if (evt->modifiers & cmdKey){
- DoKeyDown (evt);
- return;
- }else{
- switch ((evt->message & charCodeMask) >> 8){
- case '\n':
- XXX (); /*XXX return key*/
- return;
- case '\033':
- XXX (); /*XXX escape key */
- return;
- default: break;
- }
- }
- }
- if (DialogSelect (evt, &dlg, &itm)){
- switch (WinGetKind (dlg)){
- case kWinAbout:
- Assert (0); /* No item is enabled. */
- break;
- case kWinPrefs:
- XXX ();
- break;
- default:
- Assert (0); /* Other windows are not dialogs. */
- break;
- }
- }
-}
-
-static pascal Boolean ProcessEvent (EventRecord *evt, long *sleep,
- RgnHandle *rgn)
-{
- if (evt->what <= osEvt) AdjustCursor (evt->where, mouseRegion);
- if (IsDialogEvent (evt)){
- DoDialogEvent (evt);
- }else{
- switch (evt->what){
- case nullEvent:
- DoNullEvent (evt);
- break;
- case mouseDown:
- DoMouseDown (evt);
- break;
- case mouseUp: /* Needed for the graphics window. */
- DoMouseUp (evt);
- break;
- case keyDown:
- case autoKey:
- DoKeyDown (evt);
- break;
- case updateEvt:
- DoUpdate (evt);
- break;
- case activateEvt:
- DoActivate (evt);
- break;
- case diskEvt:
- DoDiskEvent (evt);
- break;
- case osEvt:
- DoOSEvent (evt);
- break;
- case kHighLevelEvent:
- AEProcessAppleEvent (evt);
- break;
- }
- }
- *sleep = evt->what == nullEvent ? evtSleep : 0;
- *rgn = mouseRegion;
- return false;
-}
-
-void GetAndProcessEvents (WaitEventOption wait, short oldx, short oldy)
-{
- EventRecord evt;
- long dummysleep;
- RgnHandle dummyregion;
- UInt32 cursleep = (wait == noWait) ? 0 : evtSleep;
- RgnHandle currgn;
-
- if (wait == waitMove){
- currgn = pointRegion;
- SetRectRgn (pointRegion, oldx, oldy, oldx+1, oldy+1);
- }else{
- currgn = mouseRegion;
- }
-
- WaitNextEvent (everyEvent, &evt, cursleep, currgn);
- ProcessEvent (&evt, &dummysleep, &dummyregion);
-
- while (evt.what != nullEvent){
- WaitNextEvent (everyEvent, &evt, 0, NULL);
- ProcessEvent (&evt, &dummysleep, &dummyregion);
- }
-}
-
-AEIdleUPP ProcessEventUPP;
-
-OSErr InitialiseEvents (void)
-{
- OSErr err;
-
- mouseRegion = NewRgn (); /* XXX out of memory ? */
- pointRegion = NewRgn (); /* XXX out of memory ? */
- ProcessEventUPP = NewAEIdleProc (ProcessEvent);
- err = InstallAEHandlers ();
- return err;
-}
diff --git a/maccaml/files.c b/maccaml/files.c
deleted file mode 100644
index ae94adcc45..0000000000
--- a/maccaml/files.c
+++ /dev/null
@@ -1,427 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Para, INRIA Rocquencourt */
-/* */
-/* Copyright 1997 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "main.h"
-
-static unsigned long nuntitled = 0;
-static unsigned long count = 2;
-
-/* XXX prŽvoir le cas o on peut Žcrire le texte mais pas les ressources
- -> resrefnum peut tre -1 quand datarefnum est valide
-*/
-
-static void MakeUntitledTitle (Str255 result)
-{
- char buffer [15];
-
- GetIndString (result, kMiscStrings, kUntitledIdx);
- if (nuntitled != 0){
- if (result [0] > 240) result [0] = 240;
- sprintf (buffer, " %lu", count); Assert (strlen (buffer) < 15);
- strcpy ((char *) result + result [0] + 1, buffer);
- result [0] += strlen (buffer);
- ++ count;
- }else{
- count = 2;
- }
- ++ nuntitled;
-}
-
-static void FreeUntitledTitle ()
-{
- -- nuntitled;
-}
-
-/* Close the file associated with the window, saving it if needed. */
-OSErr FileDoClose (WindowPtr w, ClosingOption close)
-{
- WStatusH st;
- WEHandle we;
- Str255 savingprompt, filename;
- short item;
- OSErr err;
-
- Assert (WinGetKind (w) == kWinDocument);
- WinUpdateStatus (w);
- st = WinGetStatus (w); Assert (st != NULL);
- we = WinGetWE (w); Assert (we != NULL);
- GetWTitle (w, filename);
- if ((*st)->menuflags.save){
- GetIndString (savingprompt, kMiscStrings, kClosingIdx + close);
- ParamText (filename, savingprompt, NULL, NULL);
- InitCursor ();
- modalkeys = kKeysSaveDontCancel;
- item = Alert (kAlertSaveAsk, myModalFilterUPP);
- switch (item){
- case 1: /* Yes */
- err = FileDoSave (w, 0);
- if (err != noErr) return err;
- break;
- case 2: /* Cancel */
- return userCanceledErr;
- case 3: /* No */
- break;
- default: Assert (0);
- }
- }else{
- if ((*st)->resrefnum != -1){
- /* XXX sauver fenetre, selection, scrollbars */
- }
- }
- if ((*st)->datarefnum == -1){
- Assert ((*st)->resrefnum == -1);
- FreeUntitledTitle ();
- }else{
- FSClose ((*st)->datarefnum);
- if ((*st)->resrefnum != -1) CloseResFile ((*st)->resrefnum);
- }
- return noErr;
-}
-
-/* Open a new untitled window. */
-void FileNew (void)
-{
- Str255 titlebuf;
- WindowPtr w;
- OSErr err;
- WStatusH st;
-
- MakeUntitledTitle (titlebuf);
- w = WinOpenDocument ((StringPtr) titlebuf);
- if (w == NULL) {err = 0/*XXX*/; goto failed; }
- st = WinGetStatus (w); Assert (st != NULL);
- (*st)->datarefnum = (*st)->resrefnum = -1;
- return;
-
- failed:
- if (w != NULL) WinDoClose (closingWindow, w);
- ErrorAlertGeneric (err);
-}
-
-/* Open the specified file in a new window. */
-OSErr FileOpen (FSSpec *filespec)
- {
- WindowPtr w = NULL;
- WStatusH st;
- StringPtr title;
- Str255 titlebuf;
- short resrefnum = -1, datarefnum = -1;
- Size textsize;
- Handle texthandle = NULL;
- OSErr err;
- int template;
- SignedByte perm;
- FInfo fileinfo;
-
- err = FSpGetFInfo (filespec, &fileinfo);
- if (err != noErr) goto failed;
- if (fileinfo.fdFlags & kIsStationery){
- MakeUntitledTitle (titlebuf);
- title = (StringPtr) titlebuf;
- template = 1;
- }else{
- title = (StringPtr) filespec->name;
- template = 0;
- }
- perm = template ? fsRdPerm : fsRdWrPerm;
-
- err = FSpOpenDF (filespec, perm, &datarefnum);
- if (err != noErr){ datarefnum = -1; goto failed; }
- err = GetEOF (datarefnum, &textsize);
- if (err != noErr) goto failed;
- err = SetFPos (datarefnum, fsFromStart, 0L);
- if (err != noErr) goto failed;
- err = AllocHandle (textsize, &texthandle);
- if (err != noErr) goto failed;
- HLock (texthandle);
- err = FSRead (datarefnum, &textsize, *texthandle);
- HUnlock (texthandle);
- if (err != noErr) goto failed;
-
- /*XXX FSpCreateResFile (filespec, creator, type, 0); */
- resrefnum = FSpOpenResFile (filespec, perm);
- if (resrefnum != -1){
- /* XXX lire la position de la fentre, la sŽlection, les scrollbars */
- }
-
- w = WinOpenDocument (title);
- if (w == NULL) { err = 0/*XXX*/; goto failed; }
- st = WinGetStatus (w); Assert (st != NULL);
-
- WEUseText (texthandle, (*st)->we);
- WECalText ((*st)->we);
- WESetSelection (0, 0, (*st)->we); /* XXX */
- AdjustScrollBars (w);
- WEResetModCount ((*st)->we);
- (*st)->basemodcount = 0;
-
- if (template){
- FSClose (datarefnum);
- if (resrefnum != -1) CloseResFile (resrefnum);
- (*st)->datarefnum = (*st)->resrefnum = -1;
- }else{
- (*st)->datarefnum = datarefnum;
- (*st)->resrefnum = resrefnum;
- }
- return noErr;
-
- failed:
- if (texthandle != NULL) DisposeHandle (texthandle);
- if (datarefnum != -1) FSClose (datarefnum);
- if (resrefnum != -1) CloseResFile (resrefnum);
- if (w != NULL) WinDoClose (closingWindow, w);
- return err;
-}
-
-/* Get a file with the standard dialog and open it in a new window. */
-void FileDoGetOpen (void)
-{
- OSErr err;
- StandardFileReply sfreply;
- SFTypeList types = { 'TEXT' };
-
- StandardGetFile (NULL, 1, types, &sfreply);
- if (sfreply.sfGood){
- err = FileOpen (&sfreply.sfFile);
- if (err != noErr) ErrorAlertCantOpen (sfreply.sfFile.name, err);
- }
-}
-
-/* Revert w to the contents of its associated file. */
-void FileRevert (WindowPtr w)
-{
- WStatusH st;
- short err;
- Size textsize;
- Handle texthandle;
-
- /*XXX demander confirmation */
-
- st = WinGetStatus (w);
- Assert (st != NULL);
- Assert ((*st)->datarefnum != -1);
- Assert ((*st)->we != NULL);
-
- err = GetEOF ((*st)->datarefnum, &textsize);
- if (err != noErr) goto failed;
- err = SetFPos ((*st)->datarefnum, fsFromStart, 0L);
- if (err != noErr) goto failed;
- err = AllocHandle (textsize, &texthandle);
- if (err != noErr) goto failed;
- HLock (texthandle);
- err = FSRead ((*st)->datarefnum, &textsize, *texthandle);
- HUnlock (texthandle);
- if (err != noErr) goto failed;
-
- /* XXX lire la sŽlection (pas la scrollbar ?) */
-
- SetPortWindowPort (w);
- WEUseText (texthandle, (*st)->we);
- WECalText ((*st)->we);
- WEUpdate (NULL, (*st)->we);
- WESetSelection (0, 0, (*st)->we); /* XXX */
- AdjustScrollBars (w);
- WEResetModCount ((*st)->we);
- (*st)->basemodcount = 0;
- return;
-
- failed:
- if (texthandle != NULL) DisposeHandle (texthandle);
- ErrorAlertGeneric (err);
-}
-
-/* Save the text to datarefnum.
- If resrefnum != -1, save the window position and the current selection.
-*/
-static OSErr SaveText (WindowPtr w, short datarefnum, short resrefnum)
-{
- WStatusH st = WinGetStatus (w);
- Handle text;
- Size textsize;
- OSErr err;
-
- Assert (st != NULL);
- Assert ((*st)->we != NULL);
- err = SetEOF (datarefnum, 0L);
- if (err != noErr) goto failed;
- text = WEGetText ((*st)->we);
- textsize = GetHandleSize (text);
- HLock (text);
- err = FSWrite (datarefnum, &textsize, *text);
- HUnlock (text);
- if (err != noErr) goto failed;
- (*st)->basemodcount = WEGetModCount ((*st)->we);
-
- if (resrefnum != -1){
- /* XXX Žcrire la sŽlection et la position des scrollbars
- attention: pas de fail. */
- }
- return noErr;
-
- failed:
- return err;
-}
-
-/* Ask the user for a new file name, open both forks, and return
- the refnums.
-*/
-static OSErr PrepSaveAs (WindowPtr w, short *datarefnum, short *resrefnum,
- StandardFileReply *reply)
-{
- Str255 prompt, title;
- OSErr err;
- short auxrefnum = -1;
-
- *datarefnum = *resrefnum = -1;
-
- GetIndString (prompt, kMiscStrings, kSaveAsPromptIdx);
- GetWTitle (w, title);
- StandardPutFile (prompt, title, reply);
-
- if (reply->sfGood){
- if (reply->sfReplacing){
- err = FSpOpenDF (&reply->sfFile, fsRdWrPerm, datarefnum);
- if (err != noErr) *datarefnum = -1;
- if (err == opWrErr || err == fLckdErr || err == afpObjectLocked
- || err == permErr || err == afpAccessDenied || err == wrPermErr){
- ErrorAlert (kCannotWriteIdx, reply->sfFile.name, kCloseQuoteIdx, err);
- }
- if (err != noErr) goto failed;
-
- err = FSpOpenRF (&reply->sfFile, fsRdWrPerm, &auxrefnum);
- if (err != noErr) auxrefnum = -1;
- if (err == opWrErr || err == fLckdErr || err == afpObjectLocked
- || err == permErr || err == afpAccessDenied){
- ErrorAlert (kCannotWriteIdx, reply->sfFile.name, kCloseQuoteIdx, err);
- }
- if (err != noErr) goto failed;
-
- err = SetEOF (auxrefnum, 0L);
- if (err != noErr) goto failed;
- FSClose (auxrefnum); auxrefnum = -1;
- FSpCreateResFile (&reply->sfFile, kCreatorCaml,kTypeText,reply->sfScript);
- err = ResError (); if (err != noErr) goto failed;
- *resrefnum = FSpOpenResFile (&reply->sfFile, fsRdWrPerm);
- if (*resrefnum == -1){ err = ResError (); goto failed; } /*XXX ?? */
-
- err = SetEOF (*datarefnum, 0L);
- if (err != noErr) goto failed;
-
- }else{
- err = FSpCreate (&reply->sfFile, kCreatorCaml, kTypeText,reply->sfScript);
- if (err != noErr) goto failed;
- FSpCreateResFile (&reply->sfFile, kCreatorCaml,kTypeText,reply->sfScript);
- err = ResError (); if (err != noErr) goto failed;
- err = FSpOpenDF (&reply->sfFile, fsRdWrPerm, datarefnum);
- if (err != noErr){ *datarefnum = -1; goto failed; }
- *resrefnum = FSpOpenResFile (&reply->sfFile, fsRdWrPerm);
- if (*resrefnum == -1){ err = ResError (); goto failed; } /*XXX ?? */
- }
- }else{
- err = userCanceledErr;
- goto failed;
- }
- return noErr;
-
- failed:
- if (*datarefnum != -1) FSClose (*datarefnum);
- if (*resrefnum != -1) CloseResFile (*resrefnum);
- if (auxrefnum != -1) FSClose (auxrefnum);
- return err;
-}
-
-/* If saveasflag is true or there is no associated file,
- then ask for a new file name with the standard dialog
- and associate it with w.
-
- Save the contents of w to its associated file.
-*/
-static OSErr SaveDocument (WindowPtr w, int saveasflag)
-{
- WStatusH st = WinGetStatus (w);
- OSErr err;
- int changetitle = 0;
- short datarefnum = -1, resrefnum = -1;
-
- Assert (st != NULL);
- if (saveasflag || (*st)->datarefnum == -1){
- StandardFileReply reply;
-
- err = PrepSaveAs (w, &datarefnum, &resrefnum, &reply);
- if (err != noErr) goto failed;
-
- if ((*st)->datarefnum == -1){
- Assert ((*st)->resrefnum == -1);
- FreeUntitledTitle ();
- }else{
- FSClose ((*st)->datarefnum);
- if ((*st)->resrefnum != -1) CloseResFile ((*st)->resrefnum);
- (*st)->datarefnum = (*st)->resrefnum = -1;
- }
- (*st)->datarefnum = datarefnum;
- (*st)->resrefnum = resrefnum;
- SetWTitle (w, reply.sfFile.name);
- datarefnum = resrefnum = -1;
- }
- err = SaveText (w, (*st)->datarefnum, (*st)->resrefnum);
- if (err != noErr) goto failed;
- return noErr;
-
- failed:
- if (datarefnum != -1) FSClose (datarefnum);
- if (resrefnum != -1) CloseResFile (resrefnum);
- return err;
-}
-
-/* Save the toplevel window to a new file. Do not save the window
- position or the current selection.
-*/
-static OSErr SaveToplevel (void)
-{
- WStatusH st;
- StandardFileReply reply;
- short datarefnum = -1, resrefnum = -1;
- OSErr err;
-
- Assert (winToplevel != NULL);
- st = WinGetStatus (winToplevel);
- Assert (st != NULL);
-
- err = PrepSaveAs (winToplevel, &datarefnum, &resrefnum, &reply);
- if (err != noErr) goto failed;
- err = SaveText (winToplevel, datarefnum, -1);
- if (err != noErr) goto failed;
- FSClose (datarefnum);
- if (resrefnum != -1) CloseResFile (resrefnum);
- return noErr;
-
- failed:
- if (datarefnum != -1) FSClose (datarefnum);
- if (resrefnum != -1) CloseResFile (resrefnum);
- return err;
-}
-
-static OSErr SaveGraphics (void)
-{
- XXX ();
- return noErr;
-}
-
-OSErr FileDoSave (WindowPtr w, int saveasflag)
-{
- if (w == winToplevel) return SaveToplevel ();
- else if (w == winGraphics) return SaveGraphics ();
- else return SaveDocument (w, saveasflag);
-}
diff --git a/maccaml/glue.c b/maccaml/glue.c
deleted file mode 100644
index ea9b5f97fb..0000000000
--- a/maccaml/glue.c
+++ /dev/null
@@ -1,557 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Para, INRIA Rocquencourt */
-/* */
-/* Copyright 1998 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <CursorCtl.h>
-#include <fcntl.h>
-#include <signal.h>
-#include <stdlib.h>
-
-#include "alloc.h"
-#include "mlvalues.h"
-#include "rotatecursor.h"
-#include "signals.h"
-#include "ui.h"
-
-#include "main.h"
-
-/* These are defined by the ocamlrun library. */
-void caml_main(char **argv);
-Handle macos_getfullpathname (short vrefnum, long dirid);
-
-/* This pointer contains the environment variables. */
-char *envPtr = NULL;
-
-/* True if the Caml program is reading from the console. */
-static int caml_reading_console = 0;
-
-/* [Caml_working] is used to manage the processor idle state on
- PowerBooks. [Caml_working (1)] disables the idle state, and
- [Caml_working (0)] enables it.
-*/
-static int caml_at_work = 0;
-static void Caml_working (int newstate)
-{
- if (gHasPowerManager){
- if (caml_at_work && !newstate) EnableIdle ();
- if (!caml_at_work && newstate) DisableIdle ();
- }
- caml_at_work = newstate;
-}
-
-/*
- Animated cursor (only when toplevel window is frontmost).
-*/
-typedef struct {
- short nframes;
- short current;
- union {
- CursHandle h;
- struct { short id; short fill; } i;
- } frames [1];
-} **AnimCursHandle;
-
-static AnimCursHandle acurh = NULL;
-
-pascal void InitCursorCtl (acurHandle newCursors)
-{
-#pragma unused (newCursors)
- long i;
-
- if (acurh != NULL) return;
- acurh = (AnimCursHandle) GetResource ('acur', 0);
- for (i = 0; i < (*acurh)->nframes; i++){
- (*acurh)->frames[i].h = GetCursor ((*acurh)->frames[i].i.id);
- if ((*acurh)->frames[i].h == NULL){
- (*acurh)->frames[i].h = GetCursor (watchCursor);
- Assert ((*acurh)->frames[i].h != NULL);
- }
- }
- (*acurh)->current = 0;
-}
-
-pascal void RotateCursor (long counter)
-{
-#pragma unused (counter)
- if (acurh == NULL) InitCursorCtl (NULL);
- /* (*acurh)->current += (*acurh)->nframes + (counter >= 0 ? 1 : -1); */
- (*acurh)->current += (*acurh)->nframes + (caml_at_work ? 1 : -1);
- (*acurh)->current %= (*acurh)->nframes;
-}
-
-int AdjustRotatingCursor (void)
-{
- static Point oldmouse = {-1, -1};
- Point mouse;
- int res = 0;
-
- if (acurh == NULL) InitCursorCtl (NULL);
-
- GetMouse (&mouse);
- if (mouse.h != oldmouse.h || mouse.v != oldmouse.v){
- last_event_date = TickCount ();
- }
- if (caml_reading_console == 0 && TickCount () > last_event_date + 60){
- SetCursor (*((*acurh)->frames[(*acurh)->current].h));
- ShowCursor ();
- res = 1;
- }
- oldmouse = mouse;
- return res;
-}
-
-static pascal void interp_yield (long counter)
-{
- RotateCursor (counter);
- GetAndProcessEvents (noWait, 0, 0);
- if (intr_requested){
- intr_requested = 0;
- raise (SIGINT);
- }
-}
-
-/* Expand the percent escapes in the string specified by s.
- The escapes are:
- %a application file name
- %d full pathname of the current working directory (ends in ':')
- %t full pathname of the temporary directory (ends in ':')
- %% a percent sign "%"
-*/
-static OSErr expand_escapes (Handle s)
-{
- Size i, j, l;
- OSErr err;
- Handle curdir = NULL, tmpdir = NULL;
- char *ptr2;
- long len2;
-
- l = GetHandleSize (s) - 1;
- i = j = 0;
- while (i < l){
- if ((*s)[j] == '%'){
- switch ((*s)[j+1]){
- case 'a':
- ptr2 = (char *) LMGetCurApName () + 1;
- len2 = * (LMGetCurApName ());
- break;
- case 'd':
- if (curdir == NULL) curdir = macos_getfullpathname (0, 0);
- if (curdir == NULL){ err = fnfErr; goto failed; }
- HLock (curdir);
- ptr2 = *curdir;
- len2 = GetHandleSize (curdir);
- break;
- case 't':
- if (tmpdir == NULL){
- short vrefnum;
- long dirid;
- err = FindFolder (kOnSystemDisk, kTemporaryFolderType, true,
- &vrefnum, &dirid);
- tmpdir = macos_getfullpathname (vrefnum, dirid);
- if (tmpdir == NULL){ err = fnfErr; goto failed; }
- }
- HLock (tmpdir);
- ptr2 = *tmpdir;
- len2 = GetHandleSize (tmpdir);
- break;
- case '%':
- ptr2 = "%";
- len2 = 1;
- break;
- default:
- ptr2 = "";
- len2 = 0;
- break;
- }
- Munger (s, j, NULL, 2, ptr2, len2);
- j += len2 - 2;
- i += 1;
- }
- ++ i;
- ++ j;
- }
- if (curdir != NULL) DisposeHandle (curdir);
- if (tmpdir != NULL) DisposeHandle (tmpdir);
- return noErr;
-
- failed:
- if (curdir != NULL) DisposeHandle (curdir);
- if (tmpdir != NULL) DisposeHandle (tmpdir);
- return err;
-}
-
-/* [build_command_line] creates the array of strings that represents
- the command line according to the template found in
- the 'Line'(kCommandLineTemplate) resource and the environment
- variables according to the 'Line'(kEnvironmentTemplate).
-
- Each of these resources is a sequence of strings terminated by null
- bytes. In each string, percent escapes are expanded (see above for
- a description of percent escapes).
-
- Each resource ends with a null byte.
-*/
-static OSErr build_command_line (char ***p_argv)
-{
- Handle template = NULL;
- Size len, i, j;
- char *args = NULL;
- int argc;
- char **argv = NULL;
- OSErr err;
-
- template = GetResource ('Line', kCommandLineTemplate);
- if (template == NULL){ err = ResError (); goto failed; }
- err = expand_escapes (template); if (err != noErr) goto failed;
- len = GetHandleSize (template);
-
- args = malloc (len);
- if (args == NULL){ err = memFullErr; goto failed; }
- memmove (args, *template, len);
-
- argc = 0;
- for (i = 0; i < len; i++){
- if (args[i] == '\000') ++ argc;
- }
- argv = malloc ((argc+1) * sizeof (char *));
- if (argv == NULL){ err = memFullErr; goto failed; }
-
- i = j = 0;
- do{
- argv[j++] = args + i;
- while (args [i] != '\000') ++ i;
- ++ i;
- }while (i < len);
- argv [argc] = NULL;
-
- ReleaseResource (template);
-
- template = GetResource ('Line', kEnvironmentTemplate);
- if (template == NULL){ err = ResError (); goto failed; }
- err = expand_escapes (template); if (err != noErr) goto failed;
- len = GetHandleSize (template);
- envPtr = NewPtr (len);
- if (envPtr == NULL){ err = MemError (); goto failed; }
- memmove (envPtr, *template, len);
-
- *p_argv = argv;
- return noErr;
-
- failed:
- if (template != NULL) ReleaseResource (template);
- if (args != NULL) free (args);
- if (argv != NULL) free (argv);
- return err;
-}
-
-/* [launch_caml_main] is called by [main].
-
- After building the command line, [launch_caml_main] launches [caml_main]
- in a thread, then executes the GUI event loop in the main thread.
-*/
-
-OSErr launch_caml_main (void)
-{
- char **argv;
- OSErr err;
-
- rotatecursor_options (&something_to_do, 0, &interp_yield);
- err = WinOpenToplevel ();
- if (err != noErr) goto failed;
-
- err = build_command_line (&argv);
- if (err) goto failed;
-
- Caml_working (1);
- caml_main (argv);
- ui_exit (0);
-
- failed:
- return err;
-}
-
-/* console I/O functions */
-
-/* Management of error highlighting. */
-static int erroring = 0;
-static long error_curpos;
-static long error_anchor = -1;
-
-void FlushUnreadInput (void)
-{
- WEReference we;
- int active;
-
- we = WinGetWE (winToplevel);
- Assert (we != NULL);
-
- WEFeatureFlag (weFReadOnly, weBitClear, we);
- WESetSelection (wintopfrontier, wintopfrontier, we);
- WEFeatureFlag (weFOutlineHilite, weBitClear, we);
- active = WEIsActive (we);
- if (active) WEDeactivate (we);
- WESetSelection (wintopfrontier, WEGetTextLength (we), we);
- WEDelete (we);
- if (active) WEActivate (we);
- WEFeatureFlag (weFOutlineHilite, weBitSet, we);
-}
-
-int ui_read (int fd, char *buffer, unsigned int nCharsDesired)
-{
- long len, i;
- char **htext;
- WEReference we;
- long selstart, selend;
- Boolean active;
- short readonly, autoscroll;
- int atend;
-
- if (fd != 0) return read (fd, buffer, nCharsDesired);
-
- we = WinGetWE (winToplevel);
- Assert (we != NULL);
- htext = (char **) WEGetText (we);
-
- ++ caml_reading_console;
-
- while (1){
- char *p;
-
- len = WEGetTextLength (we);
- p = *htext;
- for (i = wintopfrontier; i < len; i++){
- if (p[i] == '\n') goto gotit;
- }
- GetAndProcessEvents (waitEvent, 0, 0);
- }
-
- gotit:
-
- len = i+1 - wintopfrontier;
- if (len > nCharsDesired) len = nCharsDesired;
- memmove (buffer, (*htext)+wintopfrontier, len);
-
- atend = ScrollAtEnd (winToplevel);
- autoscroll = WEFeatureFlag (weFAutoScroll, weBitTest, we);
- WEFeatureFlag (weFAutoScroll, weBitClear, we);
- WEGetSelection (&selstart, &selend, we);
- readonly = WEFeatureFlag (weFReadOnly, weBitTest, we);
- WEFeatureFlag (weFReadOnly, weBitClear, we);
- /* Always set an empty selection before changing OutlineHilite or
- the active status. */
- WESetSelection (wintopfrontier, wintopfrontier, we);
- WEFeatureFlag (weFOutlineHilite, weBitClear, we);
- active = WEIsActive (we);
- if (active) WEDeactivate (we);
- WESetSelection (wintopfrontier, wintopfrontier+len, we);
- WESetStyle (weDoFont + weDoFace + weDoSize + weDoColor + weDoReplaceFace,
- &prefs.input, we);
- WESetSelection (wintopfrontier, wintopfrontier, we);
- if (active) WEActivate (we);
- WEFeatureFlag (weFOutlineHilite, weBitSet, we);
- WESetSelection (selstart, selend, we);
- if (readonly) WEFeatureFlag (weFReadOnly, weBitSet, we);
- if (autoscroll) WEFeatureFlag (weFAutoScroll, weBitSet, we);
- AdjustScrollBars (winToplevel);
- if (atend) ScrollToEnd (winToplevel);
-
- WinAdvanceTopFrontier (len);
-
- -- caml_reading_console;
- return len;
-}
-
-int ui_write (int fd, char *buffer, unsigned int nChars)
-{
- long selstart, selend;
- WEReference we;
- OSErr err;
- short readonly, autoscroll;
- int atend;
-
- if (fd != 1 && fd != 2) return write (fd, buffer, nChars);
-
- Assert (nChars >= 0);
- we = WinGetWE (winToplevel);
- Assert (we != NULL);
-
- if (erroring){ /* overwrite mode to display errors; see terminfo_* */
- error_curpos += nChars;
- if (error_curpos > wintopfrontier) error_curpos = wintopfrontier;
- return nChars;
- }
-
- atend = ScrollAtEnd (winToplevel);
- autoscroll = WEFeatureFlag (weFAutoScroll, weBitTest, we);
- WEFeatureFlag (weFAutoScroll, weBitClear, we);
- WEGetSelection (&selstart, &selend, we);
- readonly = WEFeatureFlag (weFReadOnly, weBitTest, we);
- WEFeatureFlag (weFReadOnly, weBitClear, we);
- WESetSelection (wintopfrontier, wintopfrontier, we);
- WESetStyle (weDoFont + weDoFace + weDoSize + weDoColor + weDoReplaceFace,
- &prefs.output, we);
- err = WEInsert (buffer, nChars, NULL, NULL, we);
- if (err != noErr){
- WESetSelection (selstart, selend, we);
- return nChars;
- }
- if (selstart >= wintopfrontier){
- selstart += nChars;
- selend += nChars;
- }else if (selend > wintopfrontier){
- selend += nChars;
- }
- WESetSelection (selstart, selend, we);
- if (autoscroll) WEFeatureFlag (weFAutoScroll, weBitSet, we);
- AdjustScrollBars (winToplevel);
- if (atend) ScrollToEnd (winToplevel);
-
- WinAdvanceTopFrontier (nChars);
-
- return nChars;
-}
-
-void ui_print_stderr (char *msg, void *arg)
-{
- char buf [1000];
-
- sprintf (buf, msg, arg);
- ui_write (2, buf, strlen (buf));
-}
-
-void ui_exit (int return_code)
-{
-#pragma unused (return_code)
- Str255 buf0;
- Str255 buf1;
-
- caml_reading_console = 1; /* hack: don't display rotating cursor */
-
- if (return_code != 0){
- GetIndString (buf0, kMiscStrings, kWithErrorCodeIdx);
- NumToString ((long) return_code, buf1);
- }else{
- buf0[0] = 0;
- buf1[0] = 0;
- }
- ParamText (buf0, buf1, NULL, NULL);
- InitCursor ();
- modalkeys = kKeysOK;
- NoteAlert (kAlertExit, myModalFilterUPP);
-
- while (1) GetAndProcessEvents (waitEvent, 0, 0);
-
- if (winGraphics != NULL) WinCloseGraphics ();
- WinCloseToplevel ();
- rotatecursor_final ();
- FinaliseAndQuit ();
-}
-
-
-/*
- [getenv] in the standalone application
- envPtr is set up by launch_caml_main
-*/
-char *getenv (const char *name)
-{
- Size envlen, i, namelen;
-
- Assert (envPtr != NULL);
- envlen = GetPtrSize (envPtr);
- namelen = strlen (name);
- i = 0;
- do{
- if (!strncmp (envPtr + i, name, namelen) && envPtr [i+namelen] == '='){
- return envPtr + i + namelen + 1;
- }
- while (envPtr [i] != '\000') ++ i;
- ++ i;
- }while (i < envlen);
- return NULL;
-}
-
-
-/*
- [terminfo] stuff: change the style of displayed text to show the
- error locations. See also ui_write.
-*/
-
-value terminfo_setup (value vchan);
-value terminfo_backup (value lines);
-value terminfo_standout (value start);
-value terminfo_resume (value lines);
-
-#define Good_term_tag 0
-
-value terminfo_setup (value vchan)
-{
-#pragma unused (vchan)
- value result = alloc (1, Good_term_tag);
- Field (result, 0) = Val_int (1000000000);
- return result;
-}
-
-value terminfo_backup (value lines)
-{
- long i, j;
- Handle txt;
- char *p;
- WEReference we = WinGetWE (winToplevel);
-
- Assert (we != NULL);
- txt = WEGetText (we);
- p = (char *) *txt;
- j = wintopfrontier - 1;
-
- while (j >= 0 && p[j] != '\n') --j;
- for (i = 0; i < Long_val (lines); i++){
- Assert (p[j] == '\n' || j == -1);
- do{ --j; }while (j >= 0 && p[j] != '\n');
- }
- Assert (p[j] == '\n' || j == -1);
- error_curpos = j + 1;
- erroring = 1;
- error_anchor = -1;
- return Val_unit;
-}
-
-value terminfo_standout (value start)
-{
- if (Bool_val (start) && error_anchor == -1){
- error_anchor = error_curpos;
- }else if (!Bool_val (start) && error_anchor != -1){
- long selstart, selend;
- WEReference we = WinGetWE (winToplevel);
- short readonly;
-
- Assert (we != NULL);
- WEGetSelection (&selstart, &selend, we);
- readonly = WEFeatureFlag (weFReadOnly, weBitTest, we);
- if (readonly) WEFeatureFlag (weFReadOnly, weBitClear, we);
- WESetSelection (error_anchor, error_curpos, we);
- WESetStyle (weDoFont + weDoFace + weDoSize + weDoColor + weDoReplaceFace,
- &prefs.errors, we);
- if (readonly) WEFeatureFlag (weFReadOnly, weBitSet, we);
- WESetSelection (selstart, selend, we);
- error_anchor = -1;
- }
- return Val_unit;
-}
-
-value terminfo_resume (value lines)
-{
-#pragma unused (lines)
- erroring = 0;
- return Val_unit;
-}
diff --git a/maccaml/graph.c b/maccaml/graph.c
deleted file mode 100644
index 1bf03d9a37..0000000000
--- a/maccaml/graph.c
+++ /dev/null
@@ -1,1179 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Para, INRIA Rocquencourt */
-/* */
-/* Copyright 1998 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "alloc.h"
-#include "callback.h"
-#include "fail.h"
-#include "memory.h"
-#include "mlvalues.h"
-#include "signals.h"
-
-#include "main.h" /* Include main.h last or Assert will not work. */
-
-
-/* The off-screen buffer that holds the contents of the graphics arena. */
-static GWorldPtr gworld = NULL;
-
-/* An arbitrarily large rectangle (for clipping). */
-static Rect maxrect = { -SHRT_MAX, -SHRT_MAX, SHRT_MAX, SHRT_MAX };
-
-/* Coordinates (relative to the window) of the top-left corner
- of the graphics arena. */
-long x0, y0;
-
-/* Width and height of the graphics arena. */
-long w0, h0;
-
-RGBColor fgcolor;
-
-/* Convert from Caml coordinates to QD coordinates in the off-screen buffer. */
-/* Note: these conversions are self-inverse (see gr_current_point). */
-#define Bx(x) (x)
-#define By(y) (h0-1 - (y))
-
-/* Convert from Caml coordinates to QD coordinates in the window. */
-#define Wx(x) (Bx(x) + x0)
-#define Wy(y) (By(y) + y0)
-
-/* Convert from QD window coordinates to Caml coordinates. */
-#define Cx(x) ((x) - x0)
-#define Cy(y) (h0-1 - ((y) - y0))
-
-
-/***********************************************************************/
-/* User interface functions */
-/***********************************************************************/
-
-static void GraphUpdateGW (void)
-{
- Rect r;
- WStatusH st = WinGetStatus (winGraphics);
-
- Assert (st != NULL);
- Assert (gworld != NULL);
- WELongRectToRect (&(*st)->destrect, &r);
- OffsetRect (&r, winGraphics->portRect.left, winGraphics->portRect.top);
- UpdateGWorld (&gworld, 0, &r, NULL, NULL, clipPix);
-}
-
-void GraphNewSizePos (void)
-{
- GraphUpdateGW ();
-}
-
-/* The current port must be winGraphics when this function is called. */
-void GraphUpdate (void)
-{
- Rect r, src, dst;
- Boolean good;
- WStatusH st = WinGetStatus (winGraphics);
- RGBColor forecolor, backcolor;
-
- Assert (st != NULL);
- GraphUpdateGW ();
- good = LockPixels (GetGWorldPixMap (gworld)); Assert (good);
- WELongRectToRect (&(*st)->destrect, &r);
- WELongRectToRect (&(*st)->viewrect, &dst);
- src = dst;
- OffsetRect (&src, -r.left, -r.top);
- GetBackColor (&backcolor);
- GetForeColor (&forecolor);
- BackColor (whiteColor);
- ForeColor (blackColor);
- CopyBits (&((GrafPtr) gworld)->portBits, &((GrafPtr) winGraphics)->portBits,
- &src, &dst, srcCopy, NULL);
- RGBBackColor (&backcolor);
- RGBForeColor (&forecolor);
- UnlockPixels (GetGWorldPixMap (gworld));
-}
-
-/* All scrolling of the graphics window must go through this function
- so it can update the coordinates x0 and y0, and the pen location. */
-void GraphScroll (long dx, long dy)
-{
- Rect r;
- RgnHandle update = NewRgn ();
- WStatusH st = WinGetStatus (winGraphics);
- Point p;
- GrafPtr port;
-
- Assert (st != NULL);
- GetPort (&port);
- SetPort (winGraphics);
- WELongRectToRect (&(*st)->viewrect, &r);
- ScrollRect (&r, dx, dy, update);
- WEOffsetLongRect (&(*st)->destrect, dx, dy);
- SetClip (update);
- GraphUpdate ();
- ClipRect (&maxrect);
- DisposeRgn (update);
-
- x0 += dx;
- y0 += dy;
- GetPen (&p);
- MoveTo (p.h + dx, p.v + dy);
- SetPort (port);
-}
-
-/* Graphics event queue */
-#define GraphQsize 15
-static EventRecord graphQ[GraphQsize];
-static int graphQlen = 0;
-
-#define Succ(x) ((x) >= GraphQsize ? 0 : (x)+1)
-
-void GraphGotEvent (EventRecord *evt)
-{
- GrafPort *saveport;
-
- if (graphQlen < GraphQsize) ++ graphQlen;
- memmove (&(graphQ[1]), &(graphQ[0]), (graphQlen - 1) * sizeof (graphQ[0]));
-
- graphQ[0] = *evt;
-
- PushWindowPort (winGraphics);
- GlobalToLocal (&(graphQ[0].where));
- PopPort;
-}
-static void DequeueEvent (int i)
-{
- -- graphQlen;
- memmove (&(graphQ[i]), &(graphQ[i+1]), (graphQlen - i) * sizeof (graphQ[0]));
-}
-
-/***********************************************************************/
-/* Primitives for the graphics library */
-/***********************************************************************/
-
-value gr_open_graph (value vgeometry);
-value gr_close_graph (value unit);
-value gr_sigio_signal (value unit);
-value gr_sigio_handler (value unit);
-value gr_display_mode (value flag);
-value gr_remember_mode (value flag);
-value gr_synchronize (value unit);
-value gr_clear_graph (value unit);
-value gr_size_x (value unit);
-value gr_size_y (value unit);
-value gr_set_color (value vrgb);
-value gr_plot (value vx, value vy);
-value gr_point_color (value vx, value vy);
-value gr_moveto (value vx, value vy);
-value gr_current_x (value unit);
-value gr_current_y (value unit);
-value gr_lineto (value vx, value vy);
-value gr_draw_rect (value vx, value vy, value vw, value vh);
-value gr_draw_arc (value *argv, int argc);
-value gr_draw_arc_nat (value, value, value, value, value, value);
-value gr_set_line_width (value vwidth);
-value gr_fill_rect (value vx, value vy, value vw, value vh);
-value gr_fill_poly (value vpoints);
-value gr_fill_arc (value *argv, int argc);
-value gr_fill_arc_nat (value, value, value, value, value, value);
-value gr_draw_char (value vchr);
-value gr_draw_string (value vstr);
-value gr_set_font (value vfontname);
-value gr_set_text_size (value vsz);
-value gr_text_size (value vstr);
-value gr_make_image (value varray);
-value gr_dump_image (value vimage);
-value gr_draw_image (value vimage, value vx, value vy);
-value gr_create_image (value vw, value vh);
-value gr_blit_image (value vimage, value vx, value vy);
-value gr_wait_event (value veventlist);
-value gr_sound (value vfreq, value vdur);
-value gr_set_window_title (value title);
-
-#define UNIMPLEMENTED(f, args) \
-value f args; \
-value f args \
-{ \
- failwith ("not implemented: " #f); \
- return Val_unit; /* not reached */ \
-}
-
-UNIMPLEMENTED (gr_window_id, (value unit))
-UNIMPLEMENTED (gr_open_subwindow, (value x, value y, value w, value h))
-UNIMPLEMENTED (gr_close_subwindow, (value id))
-
-
-/**** Ancillary macros and function */
-
-/* double-buffer or write-through */
-static int grdisplay_mode;
-static int grremember_mode;
-
-/* Current state */
-static long cur_x, cur_y;
-static short cur_width, cur_font, cur_size;
-/* see also fgcolor */
-
-
-/* Drawing off-screen and on-screen simultaneously. The following three
- macros must always be used together and in this order.
-*/
-/* 1. Begin drawing in the off-screen buffer. */
-#define BeginOff { \
- CGrafPtr _saveport_; \
- GDHandle _savegdev_; \
- Rect _cliprect_; \
- if (grremember_mode) { \
- GetGWorld (&_saveport_, &_savegdev_); \
- LockPixels (GetGWorldPixMap (gworld)); \
- SetGWorld ((CGrafPtr) gworld, NULL);
-
-/* 2. Continue with on-screen drawing. */
-#define On \
- SetGWorld (_saveport_, _savegdev_); \
- UnlockPixels (GetGWorldPixMap (gworld)); \
- } \
- if (grdisplay_mode) { \
- SetPort (winGraphics); \
- ScrollCalcGraph (winGraphics, &_cliprect_); \
- ClipRect (&_cliprect_);
-
-/* 3. Clean up after drawing. */
-#define EndOffOn \
- ClipRect (&maxrect); \
- SetPort ((GrafPtr) _saveport_); \
- } \
-}
-
-/* Set up the current port unconditionally. This is for functions that
- don't draw (measurements and setting the graphport state).
- Usage: BeginOffAlways / EndOffAlways
- or BeginOffAlways / OnAlways / EndOffOnAlways
- */
-#define BeginOffAlways { \
- CGrafPtr _saveport_; \
- GDHandle _savegdev_; \
- GetGWorld (&_saveport_, &_savegdev_); \
- LockPixels (GetGWorldPixMap (gworld)); \
- SetGWorld ((CGrafPtr) gworld, NULL);
-
-#define EndOffAlways \
- SetGWorld (_saveport_, _savegdev_); \
- UnlockPixels (GetGWorldPixMap (gworld)); \
-}
-
-#define OnAlways \
- SetGWorld (_saveport_, _savegdev_); \
- UnlockPixels (GetGWorldPixMap (gworld)); \
- SetPort (winGraphics); \
-
-#define EndOffOnAlways \
- SetPort ((GrafPtr) _saveport_); \
-}
-
-/* Convert a red, green, or blue value from 8 bits to 16 bits. */
-#define RGB8to16(x) ((x) | ((x) << 8))
-
-/* Declare and convert x and y from vx and vy. */
-#define XY long x = Long_val (vx), y = Long_val (vy)
-
-
-static value * graphic_failure_exn = NULL;
-
-static void gr_fail(char *fmt, void *arg)
-{
- char buffer[1024];
-
- if (graphic_failure_exn == NULL) {
- graphic_failure_exn = caml_named_value("Graphics.Graphic_failure");
- if (graphic_failure_exn == NULL){
- invalid_argument("Exception Graphics.Graphic_failure not initialized,"
- " you must load graphics.cma");
- }
- }
- sprintf(buffer, fmt, arg);
- raise_with_string(*graphic_failure_exn, buffer);
-}
-
-static void gr_check_open (void)
-{
- if (winGraphics == NULL) gr_fail("graphic screen not opened", NULL);
-}
-
-/* Max_image_mem is the number of image pixels that can be allocated
- in one major GC cycle. The GC will speed up to match this allocation
- speed.
-*/
-#define Max_image_mem 1000000 /*FIXME Should use user pref. */
-
-#define Transparent (-1)
-
-struct grimage {
- final_fun f; /* Finalization function */
- long width, height; /* Dimensions of the image */
- GWorldPtr data; /* Pixels */
- GWorldPtr mask; /* Mask for transparent points, or NULL */
-};
-
-#define Grimage_wosize \
- ((sizeof (struct grimage) + sizeof (value) - 1) / sizeof (value))
-
-static void free_image (value vimage)
-{
- struct grimage *im = (struct grimage *) Bp_val (vimage);
-
- if (im->data != NULL) DisposeGWorld (im->data);
- if (im->mask != NULL) DisposeGWorld (im->mask);
-}
-
-static value alloc_image (long w, long h)
-{
- value res = alloc_final (Grimage_wosize, free_image, w*h, Max_image_mem);
- struct grimage *im = (struct grimage *) Bp_val (res);
- Rect r;
- QDErr err;
-
- im->width = w;
- im->height = h;
- im->mask = NULL;
- SetRect (&r, 0, 0, w, h);
- err = NewGWorld (&im->data, 32, &r, NULL, NULL, 0);
- if (err != noErr){
- im->data = NULL;
- gr_fail ("Cannot allocate image (error code %ld)", (void *) err);
- }
- return res;
-}
-
-static value gr_alloc_int_vect(mlsize_t size)
-{
- value res;
- mlsize_t i;
-
- if (size <= Max_young_wosize) {
- res = alloc(size, 0);
- } else {
- res = alloc_shr(size, 0);
- }
- for (i = 0; i < size; i++) {
- Field(res, i) = Val_long(0);
- }
- return res;
-}
-
-/***********************************************************************/
-
-value gr_open_graph (value vgeometry)
-{
- int i;
- short err;
- Rect r;
- WStatusH st;
-
- if (winGraphics == NULL){
- Assert (gworld == NULL);
-
- i = sscanf (String_val (vgeometry), "%ldx%ld", &w0, &h0);
- if (i < 2){
- w0 = 640;
- h0 = 480;
- }
- if (w0 < kMinWindowWidth - kScrollBarWidth - 1){
- w0 = kMinWindowWidth - kScrollBarWidth - 1;
- }
- if (h0 < kMinWindowHeight - kScrollBarWidth - 1){
- h0 = kMinWindowHeight - kScrollBarWidth - 1;
- }
-
- err = WinOpenGraphics (w0, h0);
- if (err != noErr) goto failed;
-
- x0 = y0 = 0;
-
- st = WinGetStatus (winGraphics); Assert (st != NULL);
- WELongRectToRect (&(*st)->destrect, &r);
- OffsetRect (&r, winGraphics->portRect.left, winGraphics->portRect.top);
- err = NewGWorld (&gworld, 0, &r, NULL, NULL, 0);
- if (err != noErr) goto failed;
-
- fgcolor.red = fgcolor.green = fgcolor.blue = 0;
- }
- /* Synchronise off-screen and on-screen by initialising everything. */
- grremember_mode = 1;
- grdisplay_mode = 1;
- gr_clear_graph (Val_unit);
- gr_moveto (Val_long (0), Val_long (0));
- gr_set_color (Val_long (0));
- gr_set_line_width (Val_long (0));
- gr_set_font ((value) "geneva"); /* XXX hack */
- gr_set_text_size (Val_long (12));
-
- return Val_unit;
-
- failed:
- if (gworld != NULL){
- DisposeGWorld (gworld);
- gworld = NULL;
- }
- if (winGraphics != NULL) WinCloseGraphics ();
- gr_fail ("open_graph failed (error %d)", (void *) (long) err);
- return Val_unit; /* not reached */
-}
-
-value gr_close_graph (value unit)
-{
-#pragma unused (unit)
- gr_check_open ();
- WinCloseGraphics ();
- DisposeGWorld (gworld);
- gworld = NULL;
- return Val_unit;
-}
-
-value gr_sigio_signal (value unit) /* Not used on MacOS */
-{
-#pragma unused (unit)
- return Val_unit;
-}
-
-value gr_sigio_handler (value unit) /* Not used on MacOS */
-{
-#pragma unused (unit)
- return Val_unit;
-}
-
-value gr_synchronize (value unit)
-{
-#pragma unused (unit)
- GrafPtr saveport;
-
- gr_check_open ();
- PushWindowPort (winGraphics);
- GraphUpdate ();
- PopPort;
- return Val_unit;
-}
-
-value gr_display_mode (value flag)
-{
- grdisplay_mode = Bool_val (flag);
- return Val_unit;
-}
-
-value gr_remember_mode (value flag)
-{
- grremember_mode = Bool_val (flag);
- return Val_unit;
-}
-
-value gr_clear_graph (value unit)
-{
-#pragma unused (unit)
- gr_check_open ();
- BeginOff
- EraseRect (&maxrect);
- On
- EraseRect (&maxrect);
- EndOffOn
- return unit;
-}
-
-value gr_size_x (value unit)
-{
-#pragma unused (unit)
- gr_check_open ();
- return Val_long (w0);
-}
-
-value gr_size_y (value unit)
-{
-#pragma unused (unit)
- gr_check_open ();
- return Val_long (h0);
-}
-
-value gr_set_color (value vrgb)
-{
- long rgb = Long_val (vrgb);
-
- gr_check_open ();
- fgcolor.red = RGB8to16 ((rgb >> 16) & 0xFF);
- fgcolor.green = RGB8to16 ((rgb >> 8) & 0xFF);
- fgcolor.blue = RGB8to16 (rgb & 0xFF);
- BeginOffAlways
- RGBForeColor (&fgcolor);
- OnAlways
- RGBForeColor (&fgcolor);
- EndOffOnAlways
- return Val_unit;
-}
-
-value gr_plot (value vx, value vy)
-{
- XY;
-
- gr_check_open ();
- BeginOff
- SetCPixel (Bx (x), By (y) - 1, &fgcolor);
- On
- SetCPixel (Wx (x), Wy (y) - 1, &fgcolor);
- EndOffOn
- return Val_unit;
-}
-
-value gr_point_color (value vx, value vy)
-{
- XY;
- RGBColor c;
-
- gr_check_open ();
- if (x < 0 || x >= w0 || y < 0 || y >= h0) return Val_long (-1);
- BeginOffAlways
- GetCPixel (Bx (x), By (y) - 1, &c);
- EndOffAlways
- return Val_long (((c.red & 0xFF00) << 8)
- | (c.green & 0xFF00)
- | ((c.blue & 0xFF00) >> 8));
-}
-
-value gr_moveto (value vx, value vy)
-{
- XY;
-
- gr_check_open ();
- cur_x = x; cur_y = y;
- return Val_unit;
-}
-
-value gr_current_x (value unit)
-{
-#pragma unused (unit)
-
- gr_check_open ();
- return Val_long (cur_x);
-}
-
-value gr_current_y (value unit)
-{
-#pragma unused (unit)
-
- gr_check_open ();
- return Val_long (cur_y);
-}
-
-value gr_lineto (value vx, value vy)
-{
- XY;
- int delta = cur_width / 2;
-
- gr_check_open ();
- BeginOff
- MoveTo (Bx (cur_x) - delta, By (cur_y) - delta);
- LineTo (Bx (x) - delta, By (y) - delta);
- On
- MoveTo (Wx (cur_x) - delta, Wy (cur_y) - delta);
- LineTo (Wx (x) - delta, Wy (y) - delta);
- EndOffOn
- cur_x = x; cur_y = y;
- return Val_unit;
-}
-
-value gr_draw_rect (value vx, value vy, value vw, value vh)
-{
- XY;
- long w = Long_val (vw), h = Long_val (vh);
- Rect r;
- int d1 = cur_width / 2;
- int d2 = cur_width - d1;
-
- gr_check_open ();
- BeginOff
- SetRect (&r, Bx (x) - d1, By (y+h) - d1, Bx (x+w) + d2, By (y) + d2);
- FrameRect (&r);
- On
- SetRect (&r, Wx (x) - d1, Wy (y+h) - d1, Wx (x+w) + d2, Wy (y) + d2);
- FrameRect (&r);
- EndOffOn
- return Val_unit;
-}
-
-value gr_draw_arc (value *argv, int argc)
-{
-#pragma unused (argc)
- return gr_draw_arc_nat (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
-}
-
-value gr_draw_arc_nat (value vx, value vy, value vrx, value vry, value va1,
- value va2)
-{
- XY;
- long rx = Long_val (vrx), ry = Long_val (vry);
- long a1 = Long_val (va1), a2 = Long_val (va2);
- Rect r;
- long qda1 = 90 - a1, qda2 = 90 - a2;
- int d1 = cur_width / 2;
- int d2 = cur_width - d1;
-
- gr_check_open ();
- BeginOff
- SetRect (&r, Bx(x-rx) - d1, By(y+ry) - d1, Bx(x+rx) + d2, By(y-ry) + d2);
- FrameArc (&r, qda1, qda2 - qda1);
- On
- SetRect (&r, Wx(x-rx) - d1, Wy(y+ry) - d1, Wx(x+rx) + d2, Wy(y-ry) + d2);
- FrameArc (&r, qda1, qda2 - qda1);
- EndOffOn
- return Val_unit;
-}
-
-value gr_set_line_width (value vwidth)
-{
- short width = Int_val (vwidth);
-
- if (width == 0) width = 1;
- gr_check_open ();
- BeginOffAlways
- PenSize (width, width);
- OnAlways
- PenSize (width, width);
- EndOffOnAlways
- cur_width = width;
- return Val_unit;
-}
-
-value gr_fill_rect (value vx, value vy, value vw, value vh)
-{
- XY;
- long w = Long_val (vw), h = Long_val (vh);
- Rect r;
-
- gr_check_open ();
- BeginOff
- SetRect (&r, Bx (x), By (y+h), Bx (x+w), By (y));
- PaintRect (&r);
- On
- SetRect (&r, Wx (x), Wy (y+h), Wx (x+w), Wy (y));
- PaintRect (&r);
- EndOffOn
- return Val_unit;
-}
-
-value gr_fill_poly (value vpoints)
-{
- long i, n = Wosize_val (vpoints);
- PolyHandle p;
-
- #define Bxx(i) Bx (Int_val (Field (Field (vpoints, (i)), 0)))
- #define Byy(i) By (Int_val (Field (Field (vpoints, (i)), 1)))
-
- gr_check_open ();
- if (n < 1) return Val_unit;
-
- p = OpenPoly ();
- MoveTo (Bxx (0), Byy (0));
- for (i = 1; i < n; i++) LineTo (Bxx (i), Byy (i));
- ClosePoly ();
- BeginOff
- PaintPoly (p);
- On
- OffsetPoly (p, x0, y0);
- PaintPoly (p);
- EndOffOn
- KillPoly (p);
- return Val_unit;
-}
-
-value gr_fill_arc (value *argv, int argc)
-{
-#pragma unused (argc)
- return gr_fill_arc_nat (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
-}
-
-value gr_fill_arc_nat (value vx, value vy, value vrx, value vry, value va1,
- value va2)
-{
- XY;
- long rx = Long_val (vrx), ry = Long_val (vry);
- long a1 = Long_val (va1), a2 = Long_val (va2);
- Rect r;
- long qda1 = 90 - a1, qda2 = 90 - a2;
-
- gr_check_open ();
- BeginOff
- SetRect (&r, Bx (x-rx), By (y+ry), Bx (x+rx), By (y-ry));
- PaintArc (&r, qda1, qda2 - qda1);
- On
- SetRect (&r, Wx (x-rx), Wy (y+ry), Wx (x+rx), Wy (y-ry));
- PaintArc (&r, qda1, qda2 - qda1);
- EndOffOn
- return Val_unit;
-}
-
-static void draw_text (char *txt, unsigned long len)
-{
- FontInfo info;
- unsigned long w;
-
- if (len > 32767) len = 32767;
-
- BeginOffAlways
- GetFontInfo (&info);
- w = TextWidth (txt, 0, len);
- EndOffAlways
-
- gr_check_open ();
- BeginOff
- MoveTo (Bx (cur_x), By (cur_y) - info.descent);
- DrawText (txt, 0, len);
- On
- MoveTo (Wx (cur_x), Wy (cur_y) - info.descent);
- DrawText (txt, 0, len);
- EndOffOn
- cur_x += w;
-}
-
-value gr_draw_char (value vchr)
-{
- char c = Int_val (vchr);
-
- draw_text (&c, 1);
- return Val_unit;
-}
-
-value gr_draw_string (value vstr)
-{
- mlsize_t len = string_length (vstr);
- char *str = String_val (vstr);
-
- draw_text (str, len);
- return Val_unit;
-}
-
-value gr_set_font (value vfontname)
-{
- Str255 pfontname;
- short fontnum;
-
- gr_check_open ();
- CopyCStringToPascal (String_val (vfontname), pfontname);
- GetFNum (pfontname, &fontnum);
- BeginOffAlways
- TextFont (fontnum);
- OnAlways
- TextFont (fontnum);
- EndOffOnAlways
- cur_font = fontnum;
- return Val_unit;
-}
-
-value gr_set_text_size (value vsz)
-{
- short sz = Int_val (vsz);
-
- gr_check_open ();
- BeginOffAlways
- TextSize (sz);
- OnAlways
- TextSize (sz);
- EndOffOnAlways
- cur_size = sz;
- return Val_unit;
-}
-
-value gr_text_size (value vstr)
-{
- mlsize_t len = string_length (vstr);
- char *str = String_val (vstr);
- value result = alloc_tuple (2);
- FontInfo info;
- long w, h;
-
- BeginOffAlways
- GetFontInfo (&info);
- w = TextWidth (str, 0, len);
- h = info.ascent + info.descent;
- EndOffAlways
- Field (result, 0) = Val_long (w);
- Field (result, 1) = Val_long (h);
- return result;
-}
-
-value gr_make_image (value varray)
-{
- long height = Wosize_val (varray);
- long width;
- long x, y;
- GWorldPtr w;
- value result, line;
- long color;
- RGBColor qdcolor;
- int has_transp = 0;
- CGrafPtr saveport;
- GDHandle savegdev;
-
- gr_check_open ();
- if (height == 0) return alloc_image (0, 0);
- width = Wosize_val (Field (varray, 0));
- for (y = 1; y < height; y++){
- if (Wosize_val (Field (varray, y)) != width){
- gr_fail("make_image: lines of different lengths", NULL);
- }
- }
-
- result = alloc_image (width, height);
- w = ((struct grimage *) Bp_val (result))->data;
-
- LockPixels (GetGWorldPixMap (w));
- GetGWorld (&saveport, &savegdev);
- SetGWorld ((CGrafPtr) w, NULL);
- for (y = 0; y < height; y++){
- line = Field (varray, y);
- for (x = 0; x < width; x++){
- color = Long_val (Field (line, x));
- if (color == Transparent) has_transp = 1;
- qdcolor.red = ((color >> 16) & 0xFF) | ((color >> 8) & 0xFF00);
- qdcolor.green = ((color >> 8) & 0xFF) | (color & 0xFF00);
- qdcolor.blue = (color & 0xFF) | ((color << 8) & 0xFF00);
- SetCPixel (x, y, &qdcolor);
- }
- }
- UnlockPixels (GetGWorldPixMap (w));
-
- if (has_transp){
- Rect r;
- QDErr err;
-
- SetRect (&r, 0, 0, width, height);
- err = NewGWorld (&w, 1, &r, NULL, NULL, 0);
- if (err != noErr){
- SetGWorld (saveport, savegdev);
- gr_fail ("Cannot allocate image (error code %d)", (void *) err);
- }
- LockPixels (GetGWorldPixMap (w));
- SetGWorld ((CGrafPtr) w, NULL);
- EraseRect (&maxrect);
- qdcolor.red = qdcolor.green = qdcolor.blue = 0;
- for (y = 0; y < height; y++){
- line = Field (varray, y);
- for (x = 0; x < width; x++){
- color = Long_val (Field (line, x));
- if (color != Transparent) SetCPixel (x, y, &qdcolor);
- }
- }
- UnlockPixels (GetGWorldPixMap (w));
- ((struct grimage *) Bp_val (result))->mask = w;
- }
-
- SetGWorld (saveport, savegdev);
-
- return result;
-}
-
-value gr_dump_image (value vimage)
-{
- value result = Val_unit;
- struct grimage *im = (struct grimage *) Bp_val (vimage);
- long width = im->width;
- long height = im->height;
- long x, y;
- GWorldPtr wdata = im->data;
- GWorldPtr wmask = im->mask;
- CGrafPtr saveport;
- GDHandle savegdev;
- RGBColor qdcolor;
- value line;
-
- gr_check_open ();
- Begin_roots2 (vimage, result);
- result = gr_alloc_int_vect (height);
- for (y = 0; y < height; y++){
- value v = gr_alloc_int_vect (width);
- modify (&Field (result, y), v);
- }
- End_roots ();
- GetGWorld (&saveport, &savegdev);
- LockPixels (GetGWorldPixMap (wdata));
- SetGWorld (wdata, NULL);
- for (y = 0; y < height; y++){
- line = Field (result, y);
- for (x = 0; x < width; x++){
- GetCPixel (x, y, &qdcolor);
- Field (line, x) = Val_long (((qdcolor.red & 0xFF00) << 8)
- | (qdcolor.green & 0xFF00)
- | ((qdcolor.blue & 0xFF00) >> 8));
- }
- }
- UnlockPixels (GetGWorldPixMap (wdata));
- if (wmask != NULL){
- LockPixels (GetGWorldPixMap (wmask));
- SetGWorld (wmask, NULL);
- for (y = 0; y < height; y++){
- line = Field (result, y);
- for (x = 0; x < width; x++){
- if (!GetPixel (x, y)) Field (line, x) = Val_long (Transparent);
- }
- }
- UnlockPixels (GetGWorldPixMap (wmask));
- }
- SetGWorld (saveport, savegdev);
- return result;
-}
-
-value gr_draw_image (value vimage, value vx, value vy)
-{
- XY;
- struct grimage *im = (struct grimage *) Bp_val (vimage);
- RGBColor forecolor, backcolor;
- Rect srcrect, dstrect;
-
- SetRect (&srcrect, 0, 0, im->width, im->height);
- if (im->mask != NULL){
- LockPixels (GetGWorldPixMap (im->data));
- LockPixels (GetGWorldPixMap (im->mask));
- BeginOff
- SetRect (&dstrect, Bx (x), By (y+im->height), Bx (x+im->width), By (y));
- GetBackColor (&backcolor);
- GetForeColor (&forecolor);
- BackColor (whiteColor);
- ForeColor (blackColor);
- CopyMask (&((GrafPtr) im->data)->portBits,
- &((GrafPtr) im->mask)->portBits,
- &((GrafPtr) gworld)->portBits,
- &srcrect, &srcrect, &dstrect);
- RGBBackColor (&backcolor);
- RGBForeColor (&forecolor);
- On
- SetRect (&dstrect, Wx (x), Wy (y+im->height), Wx (x+im->width), Wy (y));
- GetBackColor (&backcolor);
- GetForeColor (&forecolor);
- BackColor (whiteColor);
- ForeColor (blackColor);
- CopyMask (&((GrafPtr) im->data)->portBits,
- &((GrafPtr) im->mask)->portBits,
- &((GrafPtr) winGraphics)->portBits,
- &srcrect, &srcrect, &dstrect);
- RGBBackColor (&backcolor);
- RGBForeColor (&forecolor);
- EndOffOn
- UnlockPixels (GetGWorldPixMap (im->data));
- UnlockPixels (GetGWorldPixMap (im->mask));
- }else{
- LockPixels (GetGWorldPixMap (im->data));
- BeginOff
- SetRect (&dstrect, Bx (x), By (y+im->height), Bx (x+im->width), By (y));
- GetBackColor (&backcolor);
- GetForeColor (&forecolor);
- BackColor (whiteColor);
- ForeColor (blackColor);
- CopyBits (&((GrafPtr) im->data)->portBits, &((GrafPtr) gworld)->portBits,
- &srcrect, &dstrect, srcCopy, NULL);
- RGBBackColor (&backcolor);
- RGBForeColor (&forecolor);
- On
- SetRect (&dstrect, Wx (x), Wy (y+im->height), Wx (x+im->width), Wy (y));
- GetBackColor (&backcolor);
- GetForeColor (&forecolor);
- BackColor (whiteColor);
- ForeColor (blackColor);
- CopyBits (&((GrafPtr) im->data)->portBits,
- &((GrafPtr) winGraphics)->portBits, &srcrect, &dstrect, srcCopy,
- NULL);
- RGBBackColor (&backcolor);
- RGBForeColor (&forecolor);
- EndOffOn
- UnlockPixels (GetGWorldPixMap (im->data));
- }
- return Val_unit;
-}
-
-value gr_create_image (value vw, value vh)
-{
- return alloc_image (Long_val (vw), Long_val (vh));
-}
-
-value gr_blit_image (value vimage, value vx, value vy)
-{
- XY;
- struct grimage *im = (struct grimage *) Bp_val (vimage);
- Rect srcrect, dstrect, worldrect;
- CGrafPtr saveport;
- GDHandle savegdev;
-
- SetRect (&worldrect, 0, 0, w0, h0);
- SetRect (&srcrect, Bx (x), By (y+im->height), Bx (x+im->width), By (y));
- SectRect (&srcrect, &worldrect, &srcrect);
- dstrect = srcrect;
- OffsetRect (&dstrect, -Bx (x), -By (y+im->height));
-
- LockPixels (GetGWorldPixMap (im->data));
- LockPixels (GetGWorldPixMap (gworld));
- GetGWorld (&saveport, &savegdev);
- SetGWorld (im->data, NULL);
- BackColor (whiteColor);
- ForeColor (blackColor);
- CopyBits (&((GrafPtr) gworld)->portBits, &((GrafPtr) im->data)->portBits,
- &srcrect, &dstrect, srcCopy, NULL);
- SetGWorld (saveport, savegdev);
- UnlockPixels (GetGWorldPixMap (im->data));
- UnlockPixels (GetGWorldPixMap (gworld));
- return Val_unit;
-}
-
-int motion_requested = 0;
-short motion_oldx, motion_oldy;
-/* local coord versions of motion_oldx, motion_oldy */
-static Point lastpt = {SHRT_MAX - 1, SHRT_MAX - 1};
-
-#define Button_down_val 0
-#define Button_up_val 1
-#define Key_pressed_val 2
-#define Mouse_motion_val 3
-#define Poll_val 4
-
-value gr_wait_event (value veventlist)
-{
- int askmousedown = 0, askmouseup = 0, askkey = 0, askmotion = 0, askpoll = 0;
- GrafPtr saveport;
- value result;
- int mouse_x, mouse_y, button, keypressed, key;
- Point pt;
- int i;
-
- gr_check_open();
- PushWindowPort (winGraphics);
-
- while (veventlist != Val_int (0)) {
- switch (Int_val(Field (veventlist, 0))) {
- case Button_down_val: askmousedown = 1; break;
- case Button_up_val: askmouseup = 1; break;
- case Key_pressed_val: askkey = 1; break;
- case Mouse_motion_val: askmotion = 1; break;
- case Poll_val: askpoll = 1; break;
- default: Assert (0);
- }
- veventlist = Field (veventlist, 1);
- }
-
- enter_blocking_section ();
-
- while (1){
- while (graphQlen > 0 && graphQ[0].when + 300 < TickCount ()){
- DequeueEvent (0);
- }
- for (i = graphQlen - 1; i >= 0; i--){
- int what = graphQ[i].what;
- if (askpoll){
- if (what == keyDown || what == autoKey){
- GetMouse (&pt);
- mouse_x = pt.h;
- mouse_y = pt.v;
- button = Button ();
- keypressed = 1;
- key = graphQ[i].message & charCodeMask;
- goto gotevent;
- }
- }else if ( askmousedown && what == mouseDown
- || askmouseup && what == mouseUp){
- mouse_x = graphQ[i].where.h;
- mouse_y = graphQ[i].where.v;
- button = graphQ[i].what == mouseDown;
- keypressed = 0;
- DequeueEvent (i);
- goto gotevent;
- }else if (askkey && (what == keyDown || what == autoKey)){
- mouse_x = graphQ[i].where.h;
- mouse_y = graphQ[i].where.v;
- button = Button ();
- keypressed = 1;
- key = graphQ[i].message & charCodeMask;
- DequeueEvent (i);
- goto gotevent;
- }
- }
- GetMouse (&pt);
- if (askpoll || askmotion && (pt.h != lastpt.h || pt.v != lastpt.v)){
- mouse_x = pt.h;
- mouse_y = pt.v;
- button = Button ();
- keypressed = 0;
- goto gotevent;
- }
- if (askmotion){
- motion_requested = 1;
- pt = lastpt;
- LocalToGlobal (&pt);
- motion_oldx = pt.h;
- motion_oldy = pt.v;
- }
- GetAndProcessEvents (askmotion ? waitMove : waitEvent,
- motion_oldx, motion_oldy);
- }
-
- gotevent:
- PopPort;
- leave_blocking_section (); /* acquire master lock, handle signals */
- lastpt.h = mouse_x;
- lastpt.v = mouse_y;
- motion_requested = 0;
-
- result = alloc_tuple (5);
- Field (result, 0) = Val_int (Cx (mouse_x));
- Field (result, 1) = Val_int (Cy (mouse_y));
- Field (result, 2) = Val_bool (button);
- Field (result, 3) = Val_bool (keypressed);
- Field (result, 4) = Val_int (key);
- return result;
-}
-
-value gr_sound (value vfreq, value vdur)
-{
- long freq = Long_val (vfreq);
- long dur = Long_val (vdur);
- long scale;
- Handle h;
- OSErr err;
-
- if (dur <= 0 || freq <= 0) return Val_unit;
- if (dur > 5000) dur = 5000;
- if (freq > 20000) gr_fail ("sound: frequency is too high", NULL);
-
- if (freq > 11025) scale = 2;
- else if (freq > 5513) scale = 4;
- else if (freq > 1378) scale = 8;
- else if (freq > 345) scale = 32;
- else if (freq > 86) scale = 128;
- else scale = 512;
-
- h = GetResource ('snd ', 1000 + scale);
- if (h == NULL){
- gr_fail ("sound: resource error (code = %ld)", (void *) (long) ResError ());
- }
- err = HandToHand (&h);
- if (err != noErr) gr_fail ("sound: out of memory", NULL);
- *(unsigned short *)((*h)+kDurationOffset) = dur * 2;
- Assert (scale * freq < 0x10000);
- *(unsigned short *)((*h)+kSampleRateOffset) = scale * freq;
- HLock (h);
- err = SndPlay (NULL, (SndListHandle) h, false);
- HUnlock (h);
- if (err != noErr){
- gr_fail ("sound: cannot play sound (error code %ld)", (void *) (long) err);
- }
-
- return Val_unit;
-}
-
-value gr_set_window_title (value title)
-{
- Str255 ptitle;
-
- strcpy ((char *) ptitle, String_val (title));
- c2pstr ((char *) ptitle);
- SetWTitle (winGraphics, ptitle);
- return Val_unit;
-}
diff --git a/maccaml/lcontrols.c b/maccaml/lcontrols.c
deleted file mode 100644
index 2d0b3c2321..0000000000
--- a/maccaml/lcontrols.c
+++ /dev/null
@@ -1,246 +0,0 @@
-/*
- WASTE Demo Project:
- Macintosh Controls with Long Values
-
- Copyright © 1993-1996 Marco Piovanelli
- All Rights Reserved
-
- C port by John C. Daub
-*/
-
-/***************************************************************************
- This file is not subject to the O'Caml licence.
- It is a slightly modified version of "LongControls.c" from
- the WASTE Demo source (version 1.2).
- ***************************************************************************/
-/* $Id$ */
-
-#ifndef __CONTROLS__
-#include <Controls.h>
-#endif
-
-#ifndef __FIXMATH__
-#include <FixMath.h>
-#endif
-
-#ifndef __TOOLUTILS__
-#include <ToolUtils.h>
-#endif
-
-#include "main.h" /* The change */
-#define BSL(A, B) (((long) (A)) << (B)) /* is here */
-
-
-// long control auxiliary record used for keeping long settings
-// a handle to this record is stored in the reference field of the control record
-
-struct LCAuxRec
-{
- long value; // long value
- long min; // long min
- long max; // long max
-};
-typedef struct LCAuxRec LCAuxRec, *LCAuxPtr, **LCAuxHandle;
-
-
-OSErr LCAttach( ControlRef control )
-{
- Handle aux;
- LCAuxPtr pAux;
-
- /* allocate the auxiliary record that will hold long settings */
-
- if ( ( aux = NewHandleClear( sizeof( LCAuxRec ) ) ) == nil )
- {
- return MemError( );
- }
-
- /* store a handle to the auxiliary record in the contrlRfCon field */
-
- SetControlReference( control, (long) aux );
-
- /* copy current control settings into the auxiliary record */
-
- pAux = * (LCAuxHandle) aux;
- pAux->value = GetControlValue( control );
- pAux->min = GetControlMinimum( control );
- pAux->max = GetControlMaximum( control );
-
- return noErr;
-}
-
-void LCDetach( ControlRef control )
-{
- Handle aux;
-
- if ( ( aux = (Handle) GetControlReference( control ) ) != nil )
- {
- SetControlReference( control, 0L );
- DisposeHandle( aux );
- }
-}
-
-void LCSetValue( ControlRef control, long value )
-{
- LCAuxPtr pAux;
- short controlMin, controlMax, newControlValue;
-
- pAux = * (LCAuxHandle) GetControlReference( control );
-
- /* make sure value is in the range min...max */
-
- if ( value < pAux->min )
- {
- value = pAux->min;
- }
- if ( value > pAux->max )
- {
- value = pAux->max;
- }
-
- /* save value in auxiliary record */
-
- pAux->value = value;
-
- /* calculate new thumb position */
-
- controlMin = GetControlMinimum( control );
- controlMax = GetControlMaximum( control );
- newControlValue = controlMin + FixRound( FixMul ( FixDiv( value - pAux->min,
- pAux->max - pAux->min), BSL(controlMax - controlMin, 16 )));
-
- /* do nothing if the thumb position hasn't changed */
-
- if ( newControlValue != GetControlValue(control) )
- {
- SetControlValue( control, newControlValue );
- }
-}
-
-void LCSetMin( ControlRef control, long min )
-{
- LCAuxPtr pAux;
-
- pAux = * (LCAuxHandle) GetControlReference( control );
-
- /* make sure min is less than or equal to max */
-
- if ( min > pAux->max )
- {
- min = pAux->max;
- }
-
- /* save min in auxiliary record */
-
- pAux->min = min;
-
- /* set control minimum to min or SHRT_MIN, whichever is greater */
-
- SetControlMinimum( control, ( min >= SHRT_MIN ) ? min : SHRT_MIN );
-
- /* reset value */
-
- LCSetValue( control, pAux->value );
-}
-
-void LCSetMax( ControlRef control, long max )
-{
- LCAuxPtr pAux;
-
- pAux = * (LCAuxHandle) GetControlReference( control );
-
- /* make sure max is greater than or equal to min */
-
- if ( max < pAux->min )
- {
- max = pAux->min;
- }
-
- /* save max in auxiliary record */
-
- pAux->max = max;
-
- /* set control maximum to max or SHRT_MAX, whichever is less */
-
- SetControlMaximum( control, ( max <= SHRT_MAX ) ? max : SHRT_MAX );
-
- /* reset value */
-
- LCSetValue( control, pAux->value );
-}
-
-/* In each of these LCGetXXX() functions, there are 2 ways listed to do things. They are
- both the same thing and perform the same stuff, just one is easier to read than the
- other (IMHO). I asked Marco about it and he gave me the shorter code (what's commented
- in each function) and gave me this explanation:
-
- This version [the commented code] yields smaller and faster code
- (try disassembling both versions if you wish), but some people may
- find it somewhat harder to read.
-
- I agree with Marco that his code is better overall, but in the interest of readabilty
- (since this demo is a learning tool), I left my code in and put Marco's in commented
- out. Pick whichever you'd like to use.
-*/
-
-long LCGetValue( ControlRef control )
-{
- LCAuxPtr pAux;
-
- pAux = *((LCAuxHandle)GetControlReference( control ));
-
- return pAux->value;
-
-// this is Marco's code. Remember, this is a little harder to read, but overall
-// yields tighter code.
-
-// return (* (LCAuxHandle) GetControlReference(control)) -> value;
-
-}
-
-long LCGetMin( ControlRef control )
-{
- LCAuxPtr pAux;
-
- pAux = *((LCAuxHandle)GetControlReference( control ));
-
- return pAux->min;
-
-// this is Marco's code. Remember, this is a little harder to read, but overall
-// yields tighter code.
-
-// return (* (LCAuxHandle)GetControlReference(control)) -> min;
-
-}
-
-long LCGetMax( ControlRef control )
-{
- LCAuxPtr pAux;
-
- pAux = *((LCAuxHandle)GetControlReference( control ));
-
- return pAux->max;
-
-// this is Marco's code. Remember, this is a little harder to read, but overall
-// yields tighter code.
-
-// return (* (LCAuxHandle)GetControlReference(control)) -> max;
-
-}
-
-void LCSynch( ControlRef control )
-{
- LCAuxPtr pAux;
- short controlMin, controlMax, controlValue;
-
- controlMin = GetControlMinimum( control );
- controlMax = GetControlMaximum( control );
- controlValue = GetControlValue( control );
- pAux = * (LCAuxHandle) GetControlReference( control );
-
- /* calculate new long value */
-
- pAux->value = pAux->min + FixMul( FixRatio ( controlValue - controlMin,
- controlMax - controlMin), pAux->max - pAux->min );
-}
-
diff --git a/maccaml/lib.c b/maccaml/lib.c
deleted file mode 100644
index 2c556b4982..0000000000
--- a/maccaml/lib.c
+++ /dev/null
@@ -1,35 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Para, INRIA Rocquencourt */
-/* */
-/* Copyright 1998 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "main.h"
-
-/* These are declared in TextUtils.h but not implemented in Apple's
- libraries ?!
-*/
-
-void CopyPascalStringToC (ConstStr255Param src, char *dst)
-{
- strncpy (dst, (char *) src + 1, src[0]);
- dst [src[0]] = '\000';
-}
-
-void CopyCStringToPascal (const char *src, Str255 dst)
-{
- int l = strlen (src);
-
- l = l > 255 ? 255 : l;
- dst [0] = l;
- strncpy ((char *) dst + 1, src, l);
-}
diff --git a/maccaml/main.c b/maccaml/main.c
deleted file mode 100644
index 6a317e8c64..0000000000
--- a/maccaml/main.c
+++ /dev/null
@@ -1,125 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Para, INRIA Rocquencourt */
-/* */
-/* Copyright 1997 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "main.h"
-
-QDGlobals qd;
-int gHasDragAndDrop = 0;
-int gHasPowerManager = 0;
-int launch_toplevel_requested = 0;
-
-static OSErr Initialise (void)
-{
- long gestval;
- int i;
- OSErr err;
-
- SetApplLimit (GetApplLimit () - kExtraStackSpace);
- MaxApplZone ();
- for (i = 0; i < kMoreMasters; i++) MoreMasters ();
- InitGraf (&qd.thePort);
- InitFonts ();
- InitWindows ();
- InitMenus ();
- TEInit ();
- InitDialogs (nil);
- InitCursor ();
- FlushEvents (everyEvent, 0);
-
- /* Unload the clipboard to disk if it's too big. */
- if (InfoScrap ()->scrapSize > kScrapThreshold) UnloadScrap ();
-
- /* Check for system 7. */
- if (Gestalt (gestaltSystemVersion, &gestval) != noErr
- || gestval < kMinSystemVersion){
- InitCursor ();
- StopAlert (kAlertNeedSys7, NULL);
- ExitToShell ();
- }
-
- /* Check for 32-bit color QuickDraw. */
- if (Gestalt (gestaltQuickdrawVersion, &gestval) != noErr
- || gestval < gestalt32BitQD){
- InitCursor ();
- StopAlert (kAlertNeed32BitQD, NULL);
- ExitToShell ();
- }
-
- /* Check for Drag Manager. */
- if (Gestalt (gestaltDragMgrAttr, &gestval) == noErr
- && (gestval & (1 << gestaltDragMgrPresent))
- && (&NewDrag != NULL)){
- gHasDragAndDrop = 1;
- }
-
- /* Check for Power Manager. */
- if (Gestalt (gestaltPowerMgrAttr, &gestval) == noErr
- && (gestval & (1 << gestaltPMgrExists))){
- gHasPowerManager = 1;
- }
-
- err = InitialiseErrors ();
- if (err != noErr) goto problem;
-
- if (gHasDragAndDrop){
- err = InstallDragHandlers ();
- if (err != noErr) goto problem;
- }
-
- err = InitialiseEvents ();
- if (err != noErr) goto problem;
-
- err = InitialiseMenus ();
- if (err != noErr) goto problem;
-
- err = InitialiseScroll ();
- if (err != noErr) goto problem;
-
- err = InitialiseWindows ();
- if (err != noErr) goto problem;
-
- err = InitialiseModalFilter ();
- if (err != noErr) goto problem;
-
- ReadPrefs ();
-
- return noErr;
-
- problem: return err;
-}
-
-void FinaliseAndQuit (void)
-{
- if (gHasDragAndDrop) RemoveDragHandlers ();
- WritePrefs ();
- ExitToShell ();
-}
-
-int main (void)
-{
- OSErr err;
-
- err = Initialise ();
- if (err != noErr){
- FinaliseAndQuit ();
- }
- while (!launch_toplevel_requested){
- GetAndProcessEvents (waitEvent, 0, 0);
- }
- err = launch_caml_main (); /* launch bytecode interp and event loop */
- if (err != noErr) ErrorAlertGeneric (err);
- FinaliseAndQuit ();
- return 0; /* not reached */
-}
diff --git a/maccaml/main.h b/maccaml/main.h
deleted file mode 100644
index a380804e24..0000000000
--- a/maccaml/main.h
+++ /dev/null
@@ -1,264 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Para, INRIA Rocquencourt */
-/* */
-/* Copyright 1997 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <limits.h>
-#include <signal.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-
-#include <AERegistry.h>
-#include <AppleEvents.h>
-#include <ControlDefinitions.h>
-#include <Controls.h>
-#include <Devices.h>
-#include <Dialogs.h>
-#include <DiskInit.h>
-#include <Drag.h>
-#include <Finder.h>
-#include <FixMath.h>
-#include <Folders.h>
-#include <Fonts.h>
-#include <Gestalt.h>
-#include <LowMem.h>
-#include <MacTypes.h>
-#include <MacWindows.h>
-#include <Menus.h>
-#include <Power.h>
-#include <Printing.h>
-#include <Processes.h>
-#include <QDOffscreen.h>
-#include <QuickDraw.h>
-#include <Resources.h>
-#include <Scrap.h>
-#include <Script.h>
-#include <SegLoad.h>
-#include <Sound.h>
-#include <StandardFile.h>
-#include <Strings.h>
-#include <TextUtils.h>
-#include <ToolUtils.h>
-
-#include "WASTE.h"
-
-#include "::byterun:rotatecursor.h"
-
-#include "ocamlconstants.h"
-
-#if DEBUG
-#define Assert(cond) if (!(cond)) assert_failure (#cond, __FILE__, __LINE__)
-#else
-#define Assert(cond)
-#endif
-
-/* Vertical and Horizontal */
-#define V 0
-#define H 1
-
-typedef struct WStatus {
- int kind;
- short datarefnum; /* window's file (data fork) */
- short resrefnum; /* window's file (resource fork) or -1 */
- unsigned long basemodcount;
- struct menuflags {
- unsigned int save : 1;
- unsigned int save_as : 1;
- unsigned int revert : 1;
- unsigned int page_setup : 1;
- unsigned int print : 1;
- unsigned int cut : 1;
- unsigned int copy : 1;
- unsigned int paste : 1;
- unsigned int clear : 1;
- unsigned int select_all : 1;
- unsigned int find : 1;
- unsigned int replace : 1;
- } menuflags;
- long line_height;
- ControlHandle scrollbars [2];
- LongRect viewrect, destrect; /* view and dest for the graphics window */
- WEHandle we;
-} **WStatusH;
-
-typedef enum { closingWindow = 0, closingApp } ClosingOption;
-typedef enum { noWait = 0, waitMove, waitEvent } WaitEventOption;
-
-#define PREF_VERSION 2
-/* Increment PREF_VERSION at each change in struct prefs. */
-struct prefs {
- long version;
- int asksavetop;
- Rect toppos;
- Rect graphpos;
- Rect clippos;
- TextStyle text;
- TextStyle unread;
- TextStyle input;
- TextStyle output;
- TextStyle errors;
-};
-
-/* aboutbox.c */
-void OpenAboutBox (void);
-void CloseAboutBox (WindowPtr w);
-void DrawAboutIcon (void);
-
-/* appleevents.c */
-OSErr InstallAEHandlers (void);
-
-/* clipboard.c */
-void ClipShow (void);
-void ClipClose (void);
-void ClipChanged (void);
-
-/* drag.c */
-OSErr InstallDragHandlers (void);
-OSErr RemoveDragHandlers (void);
-
-/* errors.c */
-void assert_failure (char *condition, char *file, int line);
-void XXX (void);
-void ErrorAlert (short msg1, Str255 bufmsg2, short msg3, OSErr err);
-void ErrorAlertCantOpen (Str255 filename, OSErr err);
-void ErrorAlertGeneric (OSErr err);
-OSErr InitialiseErrors (void);
-
-/* events.c */
-extern int intr_requested;
-extern UInt32 last_event_date;
-extern UInt32 evtSleep;
-void GetAndProcessEvents (WaitEventOption wait, short oldx, short oldy);
-OSErr InitialiseEvents (void);
-extern AEIdleUPP ProcessEventUPP;
-
-/* files.c */
-OSErr FileDoClose (WindowPtr w, ClosingOption close);
-void FileDoGetOpen (void);
-void FileNew (void);
-OSErr FileOpen (FSSpec *filespec);
-void FileRevert (WindowPtr w);
-OSErr FileDoSave (WindowPtr w, int saveasflag);
-
-/* glue.c */
-OSErr launch_caml_main (void);
-int AdjustRotatingCursor (void);
-pascal void RotateCursor (long counter);
-void FlushUnreadInput (void);
-
-/* graph.c */
-extern int motion_requested;
-extern short motion_oldx, motion_oldy;
-void GraphGotEvent (EventRecord *evt);
-void GraphNewSizePos (void);
-void GraphScroll (long dx, long dy);
-void GraphUpdate (void);
-
-/* gusistuff.cp */
-void InitialiseGUSI (void);
-
-/* lcontrols.c */
-OSErr LCAttach( ControlRef );
-void LCDetach( ControlRef );
-void LCSetValue( ControlRef, long );
-void LCSetMin( ControlRef, long );
-void LCSetMax( ControlRef, long );
-long LCGetValue( ControlRef );
-long LCGetMin( ControlRef );
-long LCGetMax( ControlRef );
-void LCSynch( ControlRef );
-
-/* main.c */
-extern int gHasDragAndDrop;
-extern int gHasPowerManager;
-extern int launch_toplevel_requested;
-void FinaliseAndQuit (void);
-
-/* memory.c */
-OSErr AllocHandle (Size size, Handle *result);
-
-/* menus.c */
-void DoMenuChoice (long item, EventModifiers mods);
-OSErr DoQuit (void);
-OSErr InitialiseMenus (void);
-OSErr MenuWinAdd (WindowPtr w);
-void MenuWinRemove (WindowPtr w);
-void UpdateMenus (void);
-
-/* misc.c */
-void LocalToGlobalRect (Rect *r);
-
-/* modalfilter.c */
-extern short modalkeys;
-extern ModalFilterUPP myModalFilterUPP;
-OSErr InitialiseModalFilter (void);
-
-/* prefs.c */
-extern struct prefs prefs;
-void ReadPrefs (void);
-void WritePrefs (void);
-
-/* print.c */
-void FilePageSetup (void);
-void FilePrint (void);
-
-/* scroll.c */
-extern WEScrollUPP scrollFollowUPP;
-void AdjustScrollBars (WindowPtr w);
-OSErr InitialiseScroll (void);
-int ScrollAtEnd (WindowPtr w);
-void ScrollCalcText (WindowPtr w, Rect *r);
-void ScrollCalcGraph (WindowPtr w, Rect *r);
-void ScrollDoClick (WindowPtr w, Point where, EventModifiers mods);
-void ScrollNewSize (WindowPtr w);
-void ScrollToEnd (WindowPtr w);
-
-/* windows.c */
-extern WindowPtr winToplevel;
-extern WindowPtr winGraphics;
-extern long wintopfrontier;
-OSErr InitialiseWindows (void);
-void WinActivateDeactivate (int activate, WindowPtr w);
-void WinAdvanceTopFrontier (long length);
-OSErr WinAllocStatus (WindowPtr w);
-void WinCloseGraphics (void);
-void WinCloseToplevel (void);
-void WinDoContentClick (EventRecord *e, WindowPtr w);
-OSErr WinDoClose (ClosingOption closing, WindowPtr w);
-void WinDoDrag (Point where, WindowPtr w);
-void WinDoGrow (Point where, WindowPtr w);
-void WinDoIdle (WindowPtr w);
-void WinDoKey (WindowPtr w, short chr, EventRecord *e);
-void WinDoZoom (WindowPtr w, short partCode);
-WStatusH WinGetStatus (WindowPtr w);
-WEHandle WinGetWE (WindowPtr w);
-int WinGetKind (WindowPtr w);
-WindowPtr WinOpenDocument (StringPtr title);
-OSErr WinOpenGraphics (long width, long height);
-OSErr WinOpenToplevel (void);
-void WinClipboardStdState (Rect *r);
-void WinGraphicsStdState (Rect *r);
-void WinToplevelStdState (Rect *r);
-void WinUpdate (WindowPtr w);
-void WinUpdateStatus (WindowPtr w);
-
-/* useful macros */
-
-/* PushPort, PushWindowPort, and PopPort
- assume that there is a local variable [saveport]
-*/
-#define PushPort(p) do{ GetPort (&saveport); SetPort (p); }while(0)
-#define PushWindowPort(w) \
- do{ GetPort (&saveport); SetPortWindowPort (w); }while(0)
-#define PopPort do{ SetPort (saveport); }while(0)
diff --git a/maccaml/mcmemory.c b/maccaml/mcmemory.c
deleted file mode 100644
index 218b99f81a..0000000000
--- a/maccaml/mcmemory.c
+++ /dev/null
@@ -1,31 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Para, INRIA Rocquencourt */
-/* */
-/* Copyright 1998 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "main.h"
-
-/* Allocate from application memory or from Multifinder memory;
- always leave at least kMinimumMemory free in application memory.
-*/
-OSErr AllocHandle (Size size, Handle *result)
-{
- OSErr err;
-
- if (FreeMem () >= size + kMinimumMemory){
- *result = NewHandle (size);
- err = MemError ();
- }
- if (err != noErr) *result = TempNewHandle (size, &err);
- return err;
-}
diff --git a/maccaml/mcmisc.c b/maccaml/mcmisc.c
deleted file mode 100644
index 89adfe684e..0000000000
--- a/maccaml/mcmisc.c
+++ /dev/null
@@ -1,24 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Para, INRIA Rocquencourt */
-/* */
-/* Copyright 1998 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "main.h"
-
-void LocalToGlobalRect (Rect *r)
-{
- Point *p = (Point *) r;
-
- LocalToGlobal (&p[0]);
- LocalToGlobal (&p[1]);
-}
diff --git a/maccaml/menus.c b/maccaml/menus.c
deleted file mode 100644
index 81751824a0..0000000000
--- a/maccaml/menus.c
+++ /dev/null
@@ -1,339 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Para, INRIA Rocquencourt */
-/* */
-/* Copyright 1998 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "main.h"
-
-static void DoAppleChoice (short item, EventModifiers mods)
-{
-#pragma unused (mods)
- if (item == kItemAbout){
- OpenAboutBox ();
- }else{
- Str255 deskAccName;
- GetMenuItemText (GetMenuHandle (kMenuApple), item, deskAccName);
- OpenDeskAcc (deskAccName);
- }
-}
-
-OSErr DoQuit ()
-{
- WindowPtr w;
- OSErr err;
-
- while (1){
- w = FrontWindow ();
- while (1){
- if (w == NULL) goto done;
- if (GetWindowGoAwayFlag (w) && w != winGraphics) break;
- w = GetNextWindow (w);
- }
- err = WinDoClose (closingApp, w);
- if (err != noErr) return err;
- }
- done:
- if (winGraphics != NULL) WinCloseGraphics ();
- WinCloseToplevel ();
- rotatecursor_final ();
- FinaliseAndQuit ();
- return noErr;
-}
-
-static void DoFileChoice (short item, EventModifiers mods)
-{
-#pragma unused (mods)
- WindowPtr w = FrontWindow ();
-
- switch (item){
- case kItemNew:
- FileNew ();
- break;
- case kItemOpen:
- FileDoGetOpen ();
- break;
- case kItemClose:
- WinDoClose (closingWindow, w);
- break;
- case kItemSave:
- FileDoSave (w, 0);
- break;
- case kItemSaveAs:
- FileDoSave (w, 1);
- break;
- case kItemRevert:
- FileRevert (w);
- break;
- case kItemPageSetup:
- FilePageSetup ();
- break;
- case kItemPrint:
- FilePrint ();
- break;
- case kItemQuit:
- DoQuit ();
- break;
- default: Assert (0);
- }
-}
-
-static void DoEditChoice (short item, EventModifiers mods)
-{
-#pragma unused (mods)
- WindowPtr w = FrontWindow ();
- WEReference we = WinGetWE (w);
-
- switch (item){
- case kItemUndo:
- WEUndo (we);
- break;
- case kItemCut:
- WECut (we);
- ClipChanged ();
- break;
- case kItemCopy:
- WECopy (we);
- ClipChanged ();
- break;
- case kItemPaste:
- if (w == winToplevel){
- long selstart, selend;
- WEGetSelection (&selstart, &selend, we);
- if (selstart < wintopfrontier){
- selstart = selend = WEGetTextLength (we);
- WESetSelection (selstart, selend, we);
- WEFeatureFlag (weFReadOnly, weBitClear, we);
- }
- if (selstart == wintopfrontier && selend == selstart){
- WESetStyle (weDoFont + weDoSize + weDoColor + weDoFace+weDoReplaceFace,
- &prefs.unread, we);
- }
- WEFeatureFlag (weFMonoStyled, weBitSet, we);
- WEPaste (we);
- WEFeatureFlag (weFMonoStyled, weBitClear, we);
- }else{
- WEPaste (we);
- }
- break;
- case kItemClear:
- WEDelete (we);
- break;
- case kItemSelectAll:
- WESetSelection (0, LONG_MAX, we);
- break;
- case kItemShowClipboard:
- ClipShow ();
- break;
- case kItemFind:
- XXX ();
- break;
- case kItemReplace:
- XXX ();
- break;
- case kItemPreferences:
- XXX ();
- break;
- default: Assert (0);
- }
-}
-
-static WindowPtr **winTable; /* a handle */
-static long winTableLen = 0; /* number of entries in the table */
-
-static void DoWindowsChoice (short item, EventModifiers mods)
-{
-#pragma unused (mods)
- switch (item){
- case 1:
- Assert (winToplevel != NULL);
- SelectWindow (winToplevel);
- break;
- case 2:
- Assert (winGraphics != NULL);
- ShowWindow (winGraphics);
- SelectWindow (winGraphics);
- break;
- case 3:
- Assert (0);
- default:
- Assert (item - 4 >= 0 && item - 4 < winTableLen);
- SelectWindow ((*winTable)[item - 4]);
- break;
- }
-}
-
-void DoMenuChoice (long choice, EventModifiers mods)
-{
- short menu = HiWord (choice);
- short item = LoWord (choice);
-
- switch (menu){
- case 0: break;
- case kMenuApple:
- DoAppleChoice (item, mods);
- HiliteMenu (0);
- break;
- case kMenuFile:
- DoFileChoice (item, mods);
- HiliteMenu (0);
- break;
- case kMenuEdit:
- DoEditChoice (item, mods);
- HiliteMenu (0);
- break;
- case kMenuWindows:
- DoWindowsChoice (item, mods);
- HiliteMenu (0);
- break;
- default: Assert (0);
- }
-}
-
-OSErr InitialiseMenus (void)
-{
- OSErr err;
- Size s = 10;
-
- err = AllocHandle (s * sizeof (WindowPtr), (Handle *) &winTable);
- if (err != noErr) return err;
-
- SetMenuBar (GetNewMBar (kMenuBar));
- AppendResMenu (GetMenuHandle (kMenuApple), 'DRVR');
- DrawMenuBar ();
- return 0;
-}
-
-static void EnableDisableItem (MenuHandle menu, short item, int enable)
-{
- if (enable){
- EnableItem (menu, item);
- }else{
- DisableItem (menu, item);
- }
-}
-
-/* Add w to the windows menu. */
-OSErr MenuWinAdd (WindowPtr w)
-{
- MenuHandle m;
- Str255 title;
- Size s = GetHandleSize ((Handle) winTable) / sizeof (WindowPtr);
-
- if (s <= winTableLen){
- OSErr err;
- SetHandleSize ((Handle) winTable, (s + 10) * sizeof (WindowPtr));
- err = MemError (); if (err != noErr) return err;
- }
- (*winTable)[winTableLen] = w;
- ++ winTableLen;
-
- m = GetMenuHandle (kMenuWindows);
- AppendMenu (m, "\px");
- GetWTitle (w, title);
- SetMenuItemText (m, (winTableLen-1) + 4, title);
-
- return noErr;
-}
-
-/* Remove w from the windows menu; do nothing if w is not there. */
-void MenuWinRemove (WindowPtr w)
-{
- long i;
- MenuHandle m;
-
- i = 0;
- while (1){
- if (i >= winTableLen) return;
- if ((*winTable)[i] == w) break;
- ++ i;
- }
- Assert (i < winTableLen);
- m = GetMenuHandle (kMenuWindows);
- DeleteMenuItem (m, kItemDocuments + i);
- for (++i; i < winTableLen; i++) (*winTable)[i-1] = (*winTable)[i];
- -- winTableLen;
-}
-
-static void MenuWinUpdate (void)
-{
- long i;
- MenuHandle m = GetMenuHandle (kMenuWindows);
- WindowPtr w = FrontWindow ();
-
- SetItemMark (m, kItemToplevel, w == winToplevel ? diamondMark : noMark);
- SetItemMark (m, kItemGraphics, w == winGraphics ? diamondMark : noMark);
- for (i = 0; i < winTableLen; i++){
- SetItemMark (m, kItemDocuments + i,
- w == (*winTable)[i] ? diamondMark : noMark);
- }
-}
-
-void UpdateMenus (void)
-{
- WindowPtr w;
- WStatusH st;
- WEHandle we;
- MenuHandle m;
- Str255 text;
- struct menuflags flags = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
-
- w = FrontWindow ();
- st = WinGetStatus (w);
- we = WinGetWE (w);
-
- WinUpdateStatus (w);
-
- if (st != NULL) flags = (*st)->menuflags;
-
- m = GetMenuHandle (kMenuFile);
- /* New is always enabled. */
- /* Open is always enabled. */
- EnableDisableItem (m, kItemClose, w != NULL && GetWindowGoAwayFlag (w));
- EnableDisableItem (m, kItemSave, flags.save);
- EnableDisableItem (m, kItemSaveAs, flags.save_as);
- EnableDisableItem (m, kItemRevert, flags.revert);
- EnableDisableItem (m, kItemPageSetup, flags.page_setup);
- EnableDisableItem (m, kItemPrint, flags.print);
- /* Quit is always enabled. */
-
- m = GetMenuHandle (kMenuEdit);
- DisableItem (m, kItemUndo);
- GetIndString (text, kUndoStrings, 1);
- SetMenuItemText (m, kItemUndo, text);
- if (we != NULL){
- Boolean temp;
- WEActionKind ak;
-
- Assert (st != NULL);
-
- ak = WEGetUndoInfo (&temp, we);
- if (ak != weAKNone){
- GetIndString (text, kUndoStrings, 2*ak + temp);
- SetMenuItemText (m, kItemUndo, text);
- EnableItem (m, kItemUndo);
- }
- }
- EnableDisableItem (m, kItemCut, flags.cut);
- EnableDisableItem (m, kItemCopy, flags.copy);
- EnableDisableItem (m, kItemPaste, flags.paste);
- EnableDisableItem (m, kItemClear, flags.clear);
- EnableDisableItem (m, kItemSelectAll, flags.select_all);
- /* Show Clipboard is always enabled. */
- EnableDisableItem (m, kItemFind, flags.find);
- EnableDisableItem (m, kItemReplace, flags.replace);
- /* PreferencesÉ is always enabled. */
-
- MenuWinUpdate ();
- m = GetMenuHandle (kMenuWindows);
- EnableDisableItem (m, kItemGraphics, winGraphics != NULL);
-}
diff --git a/maccaml/modalfilter.c b/maccaml/modalfilter.c
deleted file mode 100644
index 741d120503..0000000000
--- a/maccaml/modalfilter.c
+++ /dev/null
@@ -1,83 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Para, INRIA Rocquencourt */
-/* */
-/* Copyright 1998 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "main.h"
-
-/* See ocaml.r before modifying this. */
-typedef struct {
- char mod;
- char chr;
- char item;
- char filler;
-} KeyEquRecord, **KeyEquHandle;
-
-short modalkeys;
-ModalFilterUPP myModalFilterUPP;
-
-/* Before calling ModalDialog with myModalFilter, set the dialog
- window's refcon to the resource number of the key equivalence
- list for the dialog.
-*/
-static pascal Boolean myModalFilter (DialogPtr d, EventRecord *evt,
- DialogItemIndex *item)
-{
- Boolean result = false;
- char key;
- int cmdflag;
- KeyEquHandle equivlist;
- int equivcount, i;
- short itemtype;
- Handle itemhandle;
- Rect itemrect;
- unsigned long ticks;
-
- switch (evt->what){
- case updateEvt:
- if ((WindowPtr) evt->message != d) WinUpdate ((WindowPtr) evt->message);
- break;
- case activateEvt:
- if ((WindowPtr) evt->message != d){
- WinActivateDeactivate (evt->modifiers & activeFlag,
- (WindowPtr) evt->message);
- }
- break;
- case keyDown: case autoKey:
- key = evt->message & charCodeMask;
- cmdflag = !!(evt->modifiers & cmdKey);
- equivlist = (KeyEquHandle) GetResource ('Kequ', modalkeys);
- if (equivlist != NULL){
- equivcount = GetHandleSize ((Handle) equivlist) / sizeof (KeyEquRecord);
- for (i = 0; i < equivcount; i++){
- if ((*equivlist)[i].chr == key && (!(*equivlist)[i].mod || cmdflag)){
- result = true;
- *item = (*equivlist)[i].item;
- GetDialogItem (d, *item, &itemtype, &itemhandle, &itemrect);
- HiliteControl ((ControlHandle) itemhandle, kControlButtonPart);
- Delay (kVisualDelay, &ticks);
- HiliteControl ((ControlHandle) itemhandle, 0);
- }
- }
- }
- break;
- default: break;
- }
- return result;
-}
-
-OSErr InitialiseModalFilter (void)
-{
- myModalFilterUPP = NewModalFilterProc (myModalFilter);
- return noErr;
-}
diff --git a/maccaml/ocaml.r b/maccaml/ocaml.r
deleted file mode 100644
index ea807fa536..0000000000
--- a/maccaml/ocaml.r
+++ /dev/null
@@ -1,479 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Para, INRIA Rocquencourt */
-/* */
-/* Copyright 1998 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "Types.r"
-
-#include "ocamlconstants.h"
-
-resource 'vers' (1) {
-#define d development
-#define a alpha
-#define b beta
- MAJORVNUM, MINORVNUM, STAGE, DEVVNUM,
- 0,
- VERSIONSTR,
- "Objective Caml version " VERSIONSTR "\n"
- COPYRIGHTSTR
-#undef d
-#undef a
-#undef b
-};
-
-data 'Line' (1000) { /* kCommandLineTemplate */
- "%a\000"
-};
-
-data 'Line' (1001) { /* kEnvironmentTemplate */
- "TempFolder=%t\000"
- "CAMLLIB=%dstdlib:\000"
-};
-
-data 'TEXT' (1000, purgeable) { /* kAboutText1 */
- "Objective Caml version " VERSIONSTR "\n"
- COPYRIGHTSTR "\n"
- "\n"
- "Xavier Leroy, Jer™me Vouillon, Jacques Garrigue, Damien Doligez, et al.\n"
- "\n"
- "\n"
-};
-
-
-/*****************************************************************
- derez -m 60 caml-icons.rsrc "{rincludes}types.r" ¶
- "{rincludes}finder.r" "{rincludes}icons.r" >> ocaml.r
-*/
-
-resource 'icl4' (1000) {
- $"0000 0000 000F FFFF F000 0000 0000 0000 0000 0000 00FF FFFF"
- $"FFF0 0000 0000 0000 0000 0000 FFFF FFFF FFFF 0000 0000 0000"
- $"FFFF FF0F FFFF BBBB BBBF F000 00FF FFF0 FAAA AAFF FFBB BBBB"
- $"BBBB BFFF FFFF FFF0 FAAA AAAF FFFF FFFF FFFF FFFF FFFF FFF0"
- $"FAAA AAAA FFFD DDFF FFFF FFFF FFFF FF00 FFAA AAAA AFFF CCFF"
- $"FFFF FFFF FFFF FF00 0FFA AAAA AAFF FCFF FFFF FBBF FFFF F000"
- $"00FF FAAA AAAF FFFF FFFF BBBB FFFF 0000 0000 FFAA AAAA FFFF"
- $"FFFF BBBB BBFF 0000 0000 0FFA AAAA AFFF FFFA ABBB BBBF F000"
- $"0000 0FFA AAAA ABBB BBFF AABB BBBB FF00 0000 FFFA AAAA BBBB"
- $"BBBF FAAB BBBB BFF0 0000 FFFA AAAB BBBB BBBB FFAA BBBB BBFF"
- $"0000 FFFA AAAB BBBB FFBB BFFA ABBB BBFF 0000 FFFA AAAB BBBB"
- $"FFBB BBFF AABA BBFF 0000 FFFA AAAB BBBB FFBB BBBF FAAA AAFF"
- $"0000 FFFA AAAB BBBB FFBB BBBB FFAA AAFF 0000 FFFA AAAA BBBB"
- $"FFBB BBBB BFFA AFFF 0000 FFFF AAAA ABBB FFFB BBBB BBFF AFBF"
- $"0000 0FFF AAAA AABB FFFB BBBB BBBF FFBF 0000 00FF AAAA AAA1"
- $"81FB BBBB BBBF FBBF 0000 000F AAAA A81A AFFF BBBB BBBF FBBF"
- $"0000 000F AAA1 8AAA AFFF FBBB BBBF FBBF 0000 00FF A81A 1AAA"
- $"AAAF FFBB BBBF FBBF 0000 00FA 11AA 8AAA AAAA FFFB BBFF FBF0"
- $"0000 0FF8 A8AA AAAA AAAA AFFF BFFF FBF0 0000 0F8A A8AA AAAA"
- $"AAAA AAFF FFFF FF00 0000 FFAA AAAA AAAA AAAA AFFF FFF0 0000"
- $"0000 FAAA AAAA AAAA AAAA FF00 0000 0000 0000 FFFF FFFF FFFF"
- $"FFFF F0"
-};
-
-resource 'icl4' (1001) {
- $"0FFF FFFF FFFF FFFF FFFF 0000 0000 0000 0F00 0000 0000 0000"
- $"000F F000 0000 0000 0F00 0000 0000 0000 000F CF00 0000 0000"
- $"0F00 0000 0FFF FF00 000F 0CF0 0000 0000 0F00 FFFF FFBB BFFF"
- $"FFFF 00CF 0000 0000 0F00 FAAF FFFF FFFF FFFF 0CCC F000 0000"
- $"0F00 FAAA FFFF FFFF FFFF FFFF FF00 0000 0F00 0FFA AFFF FFBB"
- $"FF00 DDDD DF00 0000 0F00 00FF AAFF FFAB BF00 CCCC CF00 0000"
- $"0F00 00FF AAAB BFAA BBF0 0000 CF00 0000 0F00 00FF AABB BBFA"
- $"ABBF 0000 CF00 0000 0F00 00FF AABB FBBF AAAF 0000 CF00 0000"
- $"0F00 00FF AABB FBBB FFFF 0000 CF00 0000 0F00 00FF AAAB FBBB"
- $"BFBF 0000 CF00 0000 0F00 000F AA81 FBBB BFBF 0000 CF00 0000"
- $"0F00 000F 818A AFBB BFBF 0000 CF00 0000 0F00 00FF 8A8A AAFB"
- $"BFF0 0000 CF00 0000 0F00 00F8 AAAA AAFF FF00 0000 CF00 0000"
- $"0F00 00FF FFFF FFF0 0000 0000 CF00 0000 0F00 0000 0000 0000"
- $"0000 0000 CF00 0000 0F00 0000 0000 0000 0000 0000 CF00 0000"
- $"0F00 0000 0000 0000 0000 0000 CF00 0000 0F00 0000 0000 0000"
- $"0000 0000 CF00 0000 0F00 FF00 FF00 0000 0000 0000 CF00 0000"
- $"0F00 FF00 FF00 0000 0000 0000 CF00 0000 0F00 0000 0000 0000"
- $"0000 0000 CF00 0000 0F00 FF00 FF00 0000 0000 0000 CFE0 0000"
- $"0F00 FF00 FF00 0000 0000 0000 CFEE E000 0F00 0F00 0F00 0000"
- $"0000 0000 CFEE EEE0 0F00 F000 F000 0000 0000 0000 CFEE EEE0"
- $"0F00 0000 0000 0000 0000 0000 CFEE E000 0FFF FFFF FFFF FFFF"
- $"FFFF FFFF FFE0"
-};
-
-resource 'icl4' (1002) {
- $"FFFF FFFF FFFF FFFF FFFF FFFF F000 0000 F000 0000 0000 0000"
- $"0000 0000 F000 0000 F00F F00F F000 0000 0000 0000 FFF0 0000"
- $"F00F F00F F000 0000 0000 0000 FDF0 0000 F000 0000 0000 0000"
- $"0000 0000 FDF0 0000 F00F F00F F000 0000 0000 0000 FDF0 0000"
- $"F00F F00F F000 0000 0000 0000 FDF0 0000 F000 F000 F000 0000"
- $"0000 0000 FDF0 0000 F00F 000F 0000 0000 0000 0000 FDF0 0000"
- $"F000 0000 0000 0000 0000 0000 FDF0 0000 F000 0000 0000 0000"
- $"0000 0000 FDF0 0000 F000 0000 0000 0000 0000 0000 FDF0 0000"
- $"F000 0000 FFFF F000 0000 0000 FDF0 0000 F00F FFFF FBBB FFFF"
- $"FFF0 0000 FDF0 0000 F00F AAFF FFFF FFFF FFF0 0000 FDF0 0000"
- $"F00F AAAF FFFF FFFF FF00 0000 FDF0 0000 F000 FFAA FFFF FBBF"
- $"F000 0000 FDF0 0000 F000 0FFA AFFF FABB F000 0000 FDF0 0000"
- $"F000 0FFA AABB FAAB BF00 0000 FDF0 0000 F000 0FFA ABBB BFAA"
- $"BBF0 0000 FDF0 0000 F000 0FFA ABBF BBFA AAF0 0000 FDF0 0000"
- $"F000 0FFA ABBF BBBF FFF0 0000 FDF0 0000 F000 0FFA AABF BBBB"
- $"FBF0 0000 FDF0 0000 F000 00FA A81F BBBB FBFF FFFF FDF0 0000"
- $"F000 00F8 18AA FBBB FBFC CCCF DCF0 0000 F000 0FF8 A8AA AFBB"
- $"FFFC CCFD CCF0 0000 F000 0F8A AAAA AFFF F0FC CFDC CCFE 0000"
- $"F000 0FFF FFFF FF00 00FC FDCC CCFE EE00 F000 0000 0000 0000"
- $"00FF DCCC CCFE EEEE FFFF FFFF FFFF FFFF FFFD CCCC CCFE EEEE"
- $"00FD DDDD DDDD DDDD DDDC CCCC CCFE EE00 00FF FFFF FFFF FFFF"
- $"FFFF FFFF FFFE"
-};
-
-resource 'icl8' (1000) {
- $"0000 0000 0000 0000 0000 00FF FFFF FFFF FF00 0000 0000 0000"
- $"0000 0000 0000 0000 0000 0000 0000 0000 0000 FFFF FFFF FFFF"
- $"FFFF FF00 0000 0000 0000 0000 0000 0000 0000 0000 0000 0000"
- $"FFFF FFFF FFFF FFFF FFFF FFFF 0000 0000 0000 0000 0000 0000"
- $"FFFF FFFF FFFF 00FF FFFF FFFF 0808 0808 0808 08FF FF00 0000"
- $"0000 FFFF FFFF FF00 FF33 3333 3333 FFFF FFFF 0808 0808 0808"
- $"0808 0808 08FF FFFF FFFF FFFF FFFF FF00 FF33 3333 3333 33FF"
- $"FFFF FFFF FFFF FFFF FFFF FFFF FFFF FFFF FFFF FFFF FFFF FF00"
- $"FF33 3333 3333 3333 FFFF FFF9 F9F9 FFFF FFFF FFFF FFFF FFFF"
- $"FFFF FFFF FFFF 0000 FFFF 3333 3333 3333 33FF FFFF F6F6 FFFF"
- $"FFFF FFFF FFFF FFFF FFFF FFFF FFFF 0000 00FF FF33 3333 3333"
- $"3333 FFFF FFF6 FFFF FFFF FFFF FF08 08FF FFFF FFFF FF00 0000"
- $"0000 FFFF FF33 3333 3333 33FF FFFF FFFF FFFF FFFF 0808 0808"
- $"FFFF FFFF 0000 0000 0000 0000 FFFF 3333 3333 3333 FFFF FFFF"
- $"FFFF FFFF 0808 0808 0808 FFFF 0000 0000 0000 0000 00FF FF33"
- $"3333 3333 33FF FFFF FFFF FF33 3308 0808 0808 08FF FF00 0000"
- $"0000 0000 00FF FF33 3333 3333 3308 0808 0808 FFFF 3333 0808"
- $"0808 0808 FFFF 0000 0000 0000 FFFF FF33 3333 3333 0808 0808"
- $"0808 08FF FF33 3308 0808 0808 08FF FF00 0000 0000 FFFF FF33"
- $"3333 3308 0808 0808 0808 0808 FFFF 3333 0808 0808 0808 FFFF"
- $"0000 0000 FFFF FF33 3333 3308 0808 0808 FFFF 0808 08FF FF33"
- $"3308 0808 0808 FFFF 0000 0000 FFFF FF33 3333 3308 0808 0808"
- $"FFFF 0808 0808 FFFF 3333 0833 0808 FFFF 0000 0000 FFFF FF33"
- $"3333 3308 0808 0808 FFFF 0808 0808 08FF FF33 3333 3333 FFFF"
- $"0000 0000 FFFF FF33 3333 3308 0808 0808 FFFF 0808 0808 0808"
- $"FFFF 3333 3333 FFFF 0000 0000 FFFF FF33 3333 3333 0808 0808"
- $"FFFF 0808 0808 0808 08FF FF33 33FF FFFF 0000 0000 FFFF FFFF"
- $"3333 3333 3308 0808 FFFF FF08 0808 0808 0808 FFFF 33FF 08FF"
- $"0000 0000 00FF FFFF 3333 3333 3333 0808 FFFF FF08 0808 0808"
- $"0808 08FF FFFF 08FF 0000 0000 0000 FFFF 3333 3333 3333 3305"
- $"E305 FF08 0808 0808 0808 08FF FF08 08FF 0000 0000 0000 00FF"
- $"3333 3333 33E3 0533 33FF FFFF 0808 0808 0808 08FF FF08 08FF"
- $"0000 0000 0000 00FF 3333 3305 E333 3333 33FF FFFF FF08 0808"
- $"0808 08FF FF08 08FF 0000 0000 0000 FFFF 33E3 0533 0533 3333"
- $"3333 33FF FFFF 0808 0808 08FF FF08 08FF 0000 0000 0000 FF33"
- $"0505 3333 E333 3333 3333 3333 FFFF FF08 0808 FFFF FF08 FF00"
- $"0000 0000 00FF FFE3 33E3 3333 3333 3333 3333 3333 33FF FFFF"
- $"08FF FFFF FF08 FF00 0000 0000 00FF E333 33E3 3333 3333 3333"
- $"3333 3333 3333 FFFF FFFF FFFF FFFF 0000 0000 0000 FFFF 3333"
- $"3333 3333 3333 3333 3333 3333 33FF FFFF FFFF FF00 0000 0000"
- $"0000 0000 FF33 3333 3333 3333 3333 3333 3333 3333 FFFF 0000"
- $"0000 0000 0000 0000 0000 0000 FFFF FFFF FFFF FFFF FFFF FFFF"
- $"FFFF FFFF FF"
-};
-
-resource 'icl8' (1001) {
- $"00FF FFFF FFFF FFFF FFFF FFFF FFFF FFFF FFFF FFFF 0000 0000"
- $"0000 0000 0000 0000 00FF F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5"
- $"F5F5 F5FF FF00 0000 0000 0000 0000 0000 00FF F5F5 F5F5 F5F5"
- $"F5F5 F5F5 F5F5 F5F5 F5F5 F5FF F8FF 0000 0000 0000 0000 0000"
- $"00FF F5F5 F5F5 F5F5 F5FF FFFF FFFF F5F5 F5F5 F5FF 00F8 FF00"
- $"0000 0000 0000 0000 00FF F5F5 FFFF FFFF FFFF 0808 08FF FFFF"
- $"FFFF FFFF 0000 F8FF 0000 0000 0000 0000 00FF F5F5 FF33 33FF"
- $"FFFF FFFF FFFF FFFF FFFF FFFF F5F6 F6F8 FF00 0000 0000 0000"
- $"00FF F5F5 FF33 3333 FFFF FFFF FFFF FFFF FFFF FFFF FFFF FFFF"
- $"FFFF 0000 0000 0000 00FF F5F5 F5FF FF33 33FF FFFF FFFF 0808"
- $"FFFF F5F5 F9F9 F9F9 F9FF 0000 0000 0000 00FF F5F5 F5F5 FFFF"
- $"3333 FFFF FFFF 3308 08FF F5F5 F7F7 F7F7 F7FF 0000 0000 0000"
- $"00FF F5F5 F5F5 FFFF 3333 3308 08FF 3333 0808 FFF5 F5F5 F5F5"
- $"F7FF 0000 0000 0000 00FF F5F5 F5F5 FFFF 3333 0808 0808 FF33"
- $"3308 08FF F5F5 F5F5 F7FF 0000 0000 0000 00FF F5F5 F5F5 FFFF"
- $"3333 0808 FF08 08FF 3333 33FF F5F5 F5F5 F7FF 0000 0000 0000"
- $"00FF F5F5 F5F5 FFFF 3333 0808 FF08 0808 FFFF FFFF F5F5 F5F5"
- $"F7FF 0000 0000 0000 00FF F5F5 F5F5 FFFF 3333 3308 FF08 0808"
- $"08FF 08FF F5F5 F5F5 F7FF 0000 0000 0000 00FF F5F5 F5F5 F5FF"
- $"3333 E305 FF08 0808 08FF 08FF F5F5 F5F5 F7FF 0000 0000 0000"
- $"00FF F5F5 F5F5 F5FF E305 E333 33FF 0808 08FF 08FF F5F5 F5F5"
- $"F7FF 0000 0000 0000 00FF F5F5 F5F5 FFFF E333 E333 3333 FF08"
- $"08FF FFF5 F5F5 F5F5 F7FF 0000 0000 0000 00FF F5F5 F5F5 FFE3"
- $"3333 3333 3333 FFFF FFFF F5F5 F5F5 F5F5 F7FF 0000 0000 0000"
- $"00FF F5F5 F5F5 FFFF FFFF FFFF FFFF FFF5 F5F5 F5F5 F5F5 F5F5"
- $"F7FF 0000 0000 0000 00FF F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5"
- $"F5F5 F5F5 F5F5 F5F5 F7FF 0000 0000 0000 00FF F5F5 F5F5 F5F5"
- $"F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F7FF 0000 0000 0000"
- $"00FF F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5"
- $"F7FF 0000 0000 0000 00FF F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5"
- $"F5F5 F5F5 F5F5 F5F5 F7FF 0000 0000 0000 00FF F5F5 FFFF F5F5"
- $"FFFF F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F7FF 0000 0000 0000"
- $"00FF F5F5 FFFF F5F5 FFFF F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5"
- $"F7FF 0000 0000 0000 00FF F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5"
- $"F5F5 F5F5 F5F5 F5F5 F7FF 0000 0000 0000 00FF F5F5 FFFF F5F5"
- $"FFFF F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F7FF FC00 0000 0000"
- $"00FF F5F5 FFFF F5F5 FFFF F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5"
- $"F7FF FCFC FC00 0000 00FF F5F5 F5FF F5F5 F5FF F5F5 F5F5 F5F5"
- $"F5F5 F5F5 F5F5 F5F5 F7FF FCFC FCFC FC00 00FF F5F5 FFF5 F5F5"
- $"FFF5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F7FF FCFC FCFC FC00"
- $"00FF F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5"
- $"F7FF FCFC FC00 0000 00FF FFFF FFFF FFFF FFFF FFFF FFFF FFFF"
- $"FFFF FFFF FFFF FFFF FFFF FC"
-};
-
-resource 'icl8' (1002) {
- $"FFFF FFFF FFFF FFFF FFFF FFFF FFFF FFFF FFFF FFFF FFFF FFFF"
- $"FF00 0000 0000 0000 FFF5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5"
- $"F5F5 F5F5 F5F5 F5F5 FF00 0000 0000 0000 FFF5 F5FF FFF5 F5FF"
- $"FFF5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 FFFF FF00 0000 0000"
- $"FFF5 F5FF FFF5 F5FF FFF5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5"
- $"FFF9 FF00 0000 0000 FFF5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5"
- $"F5F5 F5F5 F5F5 F5F5 FFF9 FF00 0000 0000 FFF5 F5FF FFF5 F5FF"
- $"FFF5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 FFF9 FF00 0000 0000"
- $"FFF5 F5FF FFF5 F5FF FFF5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5"
- $"FFF9 FF00 0000 0000 FFF5 F5F5 FFF5 F5F5 FFF5 F5F5 F5F5 F5F5"
- $"F5F5 F5F5 F5F5 F5F5 FFF9 FF00 0000 0000 FFF5 F5FF F5F5 F5FF"
- $"F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 FFF9 FF00 0000 0000"
- $"FFF5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5"
- $"FFF9 FF00 0000 0000 FFF5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5"
- $"F5F5 F5F5 F5F5 F5F5 FFF9 FF00 0000 0000 FFF5 F5F5 F5F5 F5F5"
- $"F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 FFF9 FF00 0000 0000"
- $"FFF5 F5F5 F5F5 F5F5 FFFF FFFF FFF5 F5F5 F5F5 F5F5 F5F5 F5F5"
- $"FFF9 FF00 0000 0000 FFF5 F5FF FFFF FFFF FF08 0808 FFFF FFFF"
- $"FFFF FFF5 F5F5 F5F5 FFF9 FF00 0000 0000 FFF5 F5FF 3333 FFFF"
- $"FFFF FFFF FFFF FFFF FFFF FFF5 F5F5 F5F5 FFF9 FF00 0000 0000"
- $"FFF5 F5FF 3333 33FF FFFF FFFF FFFF FFFF FFFF F5F5 F5F5 F5F5"
- $"FFF9 FF00 0000 0000 FFF5 F5F5 FFFF 3333 FFFF FFFF FF08 08FF"
- $"FFF5 F5F5 F5F5 F5F5 FFF9 FF00 0000 0000 FFF5 F5F5 F5FF FF33"
- $"33FF FFFF FF33 0808 FFF5 F5F5 F5F5 F5F5 FFF9 FF00 0000 0000"
- $"FFF5 F5F5 F5FF FF33 3333 0808 FF33 3308 08FF F5F5 F5F5 F5F5"
- $"FFF9 FF00 0000 0000 FFF5 F5F5 F5FF FF33 3308 0808 08FF 3333"
- $"0808 FFF5 F5F5 F5F5 FFF9 FF00 0000 0000 FFF5 F5F5 F5FF FF33"
- $"3308 08FF 0808 FF33 3333 FFF5 F5F5 F5F5 FFF9 FF00 0000 0000"
- $"FFF5 F5F5 F5FF FF33 3308 08FF 0808 08FF FFFF FFF5 F5F5 F5F5"
- $"FFF9 FF00 0000 0000 FFF5 F5F5 F5FF FF33 3333 08FF 0808 0808"
- $"FF08 FFF5 F5F5 F5F5 FFF9 FF00 0000 0000 FFF5 F5F5 F5F5 FF33"
- $"33E3 05FF 0808 0808 FF08 FFFF FFFF FFFF FFF9 FF00 0000 0000"
- $"FFF5 F5F5 F5F5 FFE3 05E3 3333 FF08 0808 FF08 FF2B 2B2B F7FF"
- $"F9F7 FF00 0000 0000 FFF5 F5F5 F5FF FFE3 33E3 3333 33FF 0808"
- $"FFFF FF2B 2BF7 FFF9 F72B FF00 0000 0000 FFF5 F5F5 F5FF E333"
- $"3333 3333 33FF FFFF FFF5 FF2B F7FF F9F7 2BF6 FFFC 0000 0000"
- $"FFF5 F5F5 F5FF FFFF FFFF FFFF FFFF F5F5 F5F5 FFF7 FFF9 F72B"
- $"F6F6 FFFC FCFC 0000 FFF5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5 F5F5"
- $"F5F5 FFFF F9F7 2BF6 F6F6 FFFC FCFC FCFC FFFF FFFF FFFF FFFF"
- $"FFFF FFFF FFFF FFFF FFFF FFF9 F72B F6F6 F6F6 FFFC FCFC FCFC"
- $"0000 FFF9 F9F9 F9F9 F9F9 F9F9 F9F9 F9F9 F9F9 F9F7 2BF6 F6F6"
- $"F6F6 FFFC FCFC 0000 0000 FFFF FFFF FFFF FFFF FFFF FFFF FFFF"
- $"FFFF FFFF FFFF FFFF FFFF FFFC"
-};
-
-resource 'ICN#' (1000) {
- { /* array: 2 elements */
- /* [1] */
- $"001F 8000 003F E000 00FF F000 FDF0 183E 83C0 07FE 81FF FFFE"
- $"80E3 FFFC C073 FFFC 603B F9F8 381F F0F0 0C0F F030 0607 E018"
- $"0600 300C 0E00 1806 0E00 0C03 0E00 C603 0E00 C303 0E00 C183"
- $"0E00 C0C3 0E00 C067 0F00 E035 0700 E01D 0301 E019 0106 7019"
- $"0118 7819 0368 1C19 02C8 0E3A 0740 077A 0640 03FC 0C00 07E0"
- $"0800 0C00 0F7F F8",
- /* [2] */
- $"001F 8000 003F E000 00FF F000 FDFF F83E FFFF FFFE FFFF FFFE"
- $"FFFF FFFC FFFF FFFC 7FFF FFF8 3FFF FFF0 0FFF FFF0 07FF FFF8"
- $"07FF FFFC 0FFF FFFE 0FFF FFFF 0FFF FFFF 0FFF FFFF 0FFF FFFF"
- $"0FFF FFFF 0FFF FFFF 0FFF FFFF 07FF FFFF 03FF FFFF 01FF FFFF"
- $"01FF FFFF 03FF FFFF 03FF FFFE 07FF FFFE 07FF FFFC 0FFF FFE0"
- $"0FFF FC00 0FFF F8"
- }
-};
-
-resource 'ICN#' (1001) {
- { /* array: 2 elements */
- /* [1] */
- $"7FFF F000 4000 1800 4000 1400 407C 1200 4FC7 F100 49FF F080"
- $"48FF FFC0 467C C040 433C 4040 4304 2040 4302 1040 4309 1040"
- $"4308 F040 4308 5040 4138 5040 41E4 5040 43A2 6040 4203 C040"
- $"43FE 0040 4000 0040 4000 0040 4000 0040 4000 0040 4CC0 0040"
- $"4CC0 0040 4000 0040 4CC0 0060 4CC0 0078 4440 007E 4880 007E"
- $"4000 0078 7FFF FFE0",
- /* [2] */
- $"7FFF F000 7FFF F800 7FFF FC00 7FFF FE00 7FFF FF00 7FFF FF80"
- $"7FFF FFC0 7FFF FFC0 7FFF FFC0 7FFF FFC0 7FFF FFC0 7FFF FFC0"
- $"7FFF FFC0 7FFF FFC0 7FFF FFC0 7FFF FFC0 7FFF FFC0 7FFF FFC0"
- $"7FFF FFC0 7FFF FFC0 7FFF FFC0 7FFF FFC0 7FFF FFC0 7FFF FFC0"
- $"7FFF FFC0 7FFF FFC0 7FFF FFE0 7FFF FFF8 7FFF FFFE 7FFF FFFE"
- $"7FFF FFF8 7FFF FFE0"
- }
-};
-
-resource 'ICN#' (1002) {
- { /* array: 2 elements */
- /* [1] */
- $"FFFF FF80 8000 0080 9980 00E0 9980 00A0 8000 00A0 9980 00A0"
- $"9980 00A0 8880 00A0 9100 00A0 8000 00A0 8000 00A0 8000 00A0"
- $"80F8 00A0 9F8F E0A0 93FF E0A0 91FF C0A0 8CF9 80A0 8678 80A0"
- $"8608 40A0 8604 20A0 8612 20A0 8611 E0A0 8610 A0A0 8270 BFA0"
- $"83C8 A120 8744 E220 8407 A430 87FC 283C 8000 303F FFFF E03F"
- $"2000 003C 3FFF FFF0",
- /* [2] */
- $"FFFF FF80 FFFF FF80 FFFF FFE0 FFFF FFE0 FFFF FFE0 FFFF FFE0"
- $"FFFF FFE0 FFFF FFE0 FFFF FFE0 FFFF FFE0 FFFF FFE0 FFFF FFE0"
- $"FFFF FFE0 FFFF FFE0 FFFF FFE0 FFFF FFE0 FFFF FFE0 FFFF FFE0"
- $"FFFF FFE0 FFFF FFE0 FFFF FFE0 FFFF FFE0 FFFF FFE0 FFFF FFE0"
- $"FFFF FFE0 FFFF FFE0 FFFF FFF0 FFFF FFFC FFFF FFFF FFFF FFFF"
- $"3FFF FFFC 3FFF FFF0"
- }
-};
-
-resource 'ics#' (1000) {
- { /* array: 2 elements */
- /* [1] */
- $"07C0 FC7F 9FFF 8FFE 67CC 33C4 3042 3021 3091 308F 3085 1385"
- $"1E45 3A26 203C 3FE0",
- /* [2] */
- $"07C0 FFFF FFFF FFFE 7FFC 3FFC 3FFE 3FFF 3FFF 3FFF 3FFF 1FFF"
- $"1FFF 3FFE 3FFC 3FE0"
- }
-};
-
-resource 'ics#' (1001) {
- { /* array: 2 elements */
- /* [1] */
- $"FFE0 8070 8058 8078 8008 8008 8008 B608 B608 8008 B608 B608"
- $"9208 A40E 800F FFFE",
- /* [2] */
- $"FFE0 FFF0 FFF8 FFF8 FFF8 FFF8 FFF8 FFF8 FFF8 FFF8 FFF8 FFF8"
- $"FFF8 FFFE FFFF FFFE"
- }
-};
-
-resource 'ics#' (1002) {
- { /* array: 2 elements */
- /* [1] */
- $"FFF8 800C B60C B60C 800C B60C B60C 920C A40C 800C 800C 807C"
- $"8054 8066 FFC7 7FFE",
- /* [2] */
- $"FFF8 FFFC FFFC FFFC FFFC FFFC FFFC FFFC FFFC FFFC FFFC FFFC"
- $"FFFC FFFE FFFF 7FFE"
- }
-};
-
-resource 'ics4' (1000) {
- $"0000 0FFF FF00 0000 FFFF FFBB BFFF FFFF FAAF FFFF FFFF FFFF"
- $"FAAA FFFF FFFF FFF0 0FFA AFFF FFBB FF00 00FF AAFF FFAB BF00"
- $"00FF AAAB BFAA BBF0 00FF AABB BBFA ABBF 00FF AABB FBBF AAAF"
- $"00FF AABB FBBB FFFF 00FF AAAB FBBB BFBF 000F AA81 FBBB BFBF"
- $"000F 818A AFBB BFBF 00FF 8A8A AAFB BFF0 00F8 AAAA AAFF FF00"
- $"00FF FFFF FFF0"
-};
-
-resource 'ics4' (1001) {
- $"FFFF FFFF FFF0 0000 F000 0000 0FFF 0000 F000 0000 0FCF F000"
- $"F000 0000 0FFF F000 F000 0000 00CC F000 F000 0000 000C F000"
- $"F000 0000 000C F000 F0FF 0FF0 000C F000 F0FF 0FF0 000C F000"
- $"F000 0000 000C F000 F0FF 0FF0 000C F000 F0FF 0FF0 000C F000"
- $"F00F 00F0 000C F000 F0F0 0F00 000C FEE0 F000 0000 000C FEEE"
- $"FFFF FFFF FFFF FEE0"
-};
-
-resource 'ics4' (1002) {
- $"FFFF FFFF FFFF F000 F000 0000 0000 FF00 F0FF 0FF0 0000 FF00"
- $"F0FF 0FF0 0000 FF00 F000 0000 0000 FF00 F0FF 0FF0 0000 FF00"
- $"F0FF 0FF0 0000 FF00 F00F 00F0 0000 FF00 F0F0 0F00 0000 FF00"
- $"F000 0000 0000 FF00 F000 0000 0000 FF00 F000 0000 0FFF FF00"
- $"F000 0000 0FCF DF00 F000 0000 0FFD CFE0 FFFF FFFF FFDC CFEE"
- $"0FFF FFFF FFFF FFE0"
-};
-
-resource 'ics8' (1000) {
- $"0000 0000 00FF FFFF FFFF 0000 0000 0000 FFFF FFFF FFFF 0808"
- $"08FF FFFF FFFF FFFF FF33 33FF FFFF FFFF FFFF FFFF FFFF FFFF"
- $"FF33 3333 FFFF FFFF FFFF FFFF FFFF FF00 00FF FF33 33FF FFFF"
- $"FFFF 0808 FFFF 0000 0000 FFFF 3333 FFFF FFFF 3308 08FF 0000"
- $"0000 FFFF 3333 3308 08FF 3333 0808 FF00 0000 FFFF 3333 0808"
- $"0808 FF33 3308 08FF 0000 FFFF 3333 0808 FF08 08FF 3333 33FF"
- $"0000 FFFF 3333 0808 FF08 0808 FFFF FFFF 0000 FFFF 3333 3308"
- $"FF08 0808 08FF 08FF 0000 00FF 3333 E305 FF08 0808 08FF 08FF"
- $"0000 00FF E305 E333 33FF 0808 08FF 08FF 0000 FFFF E333 E333"
- $"3333 FF08 08FF FF00 0000 FFE3 3333 3333 3333 FFFF FFFF 0000"
- $"0000 FFFF FFFF FFFF FFFF FF"
-};
-
-resource 'ics8' (1001) {
- $"FFFF FFFF FFFF FFFF FFFF FF00 0000 0000 FFF5 F5F5 F5F5 F5F5"
- $"F5FF FFFF 0000 0000 FFF5 F5F5 F5F5 F5F5 F5FF F6FF FF00 0000"
- $"FFF5 F5F5 F5F5 F5F5 F5FF FFFF FF00 0000 FFF5 F5F5 F5F5 F5F5"
- $"F5F5 F7F7 FF00 0000 FFF5 F5F5 F5F5 F5F5 F5F5 F5F7 FF00 0000"
- $"FFF5 F5F5 F5F5 F5F5 F5F5 F5F7 FF00 0000 FFF5 FFFF F5FF FFF5"
- $"F5F5 F5F7 FF00 0000 FFF5 FFFF F5FF FFF5 F5F5 F5F7 FF00 0000"
- $"FFF5 F5F5 F5F5 F5F5 F5F5 F5F7 FF00 0000 FFF5 FFFF F5FF FFF5"
- $"F5F5 F5F7 FF00 0000 FFF5 FFFF F5FF FFF5 F5F5 F5F7 FF00 0000"
- $"FFF5 F5FF F5F5 FFF5 F5F5 F5F7 FF00 0000 FFF5 FFF5 F5FF F5F5"
- $"F5F5 F5F7 FFFC FC00 FFF5 F5F5 F5F5 F5F5 F5F5 F5F7 FFFC FCFC"
- $"FFFF FFFF FFFF FFFF FFFF FFFF FFFC FC"
-};
-
-resource 'ics8' (1002) {
- $"FFFF FFFF FFFF FFFF FFFF FFFF FF00 0000 FFF5 F5F5 F5F5 F500"
- $"F5F5 F5F5 FFFF 0000 FFF5 FFFF F5FF FF00 F5F5 F5F5 FFFF 0000"
- $"FFF5 FFFF F5FF FF00 F5F5 F5F5 FFFF 0000 FFF5 F5F5 F5F5 F500"
- $"F5F5 F5F5 FFFF 0000 FFF5 FFFF F5FF FF00 F5F5 F5F5 FFFF 0000"
- $"FFF5 FFFF F5FF FF00 F5F5 F5F5 FFFF 0000 FFF5 F5FF F5F5 FF00"
- $"F5F5 F5F5 FFFF 0000 FFF5 FFF5 F5FF F500 F5F5 F5F5 FFFF 0000"
- $"FFF5 F5F5 F5F5 F500 F5F5 F5F5 FFFF 0000 FFF5 F5F5 F5F5 F5F5"
- $"F5F5 F5F5 FFFF 0000 FFF5 F5F5 F5F5 F5F5 F5FF FFFF FFFF 0000"
- $"FFF5 F5F5 F5F5 F5F5 F5FF F5FF F9FF 0000 FFF5 F5F5 F5F5 F5F5"
- $"F5FF FFF9 F7FF FC00 FFFF FFFF FFFF FFFF FFFF F9F7 F7FF FCFC"
- $"00FF FFFF FFFF FFFF FFFF FFFF FFFF FC"
-};
-
-resource 'ICON' (1000) {
- $"001F 8000 003F E000 00FF F000 FDF0 183E 83C0 07FE 81FF FFFE"
- $"80E3 FFFC C073 FFFC 603B F9F8 381F F0F0 0C0F F030 0607 E018"
- $"0600 300C 0E00 1806 0E00 0C03 0E00 C603 0E00 C303 0E00 C183"
- $"0E00 C0C3 0E00 C067 0F00 E035 0700 E01D 0301 E019 0106 7019"
- $"0118 7819 0368 1C19 02C8 0E3A 0740 077A 0640 03FC 0C00 07E0"
- $"0800 0C00 0FFF F8"
-};
-
-data 'cicn' (1000) {
- $"0000 0000 8010 0000 0000 0020 0020 0000 0000 0000 0000 0048"
- $"0000 0048 0000 0000 0004 0001 0004 0000 0000 0000 0000 0000"
- $"0000 0000 0000 0004 0000 0000 0020 0020 0000 0000 0004 0000"
- $"0000 0020 0020 0000 0000 001F 8000 003F E000 00FF F000 FDFF"
- $"F83E FFFF FFFE FFFF FFFE FFFF FFFC FFFF FFFC 7FFF FFF8 3FFF"
- $"FFF0 0FFF FFF0 07FF FFF8 07FF FFFC 0FFF FFFE 0FFF FFFF 0FFF"
- $"FFFF 0FFF FFFF 0FFF FFFF 0FFF FFFF 0FFF FFFF 0FFF FFFF 07FF"
- $"FFFF 03FF FFFF 01FF FFFF 01FF FFFF 03FF FFFF 03FF FFFE 07FF"
- $"FFFE 07FF FFFC 0FFF FFE0 0FFF FC00 0FFF F800 001F 8000 003F"
- $"E000 00FF F000 FDF0 183E 83C0 07FE 81FF FFFE 80E3 FFFC C073"
- $"FFFC 603B F9F8 381F F0F0 0C0F F030 0607 E018 0600 300C 0E00"
- $"1806 0E00 0C03 0E00 C603 0E00 C303 0E00 C183 0E00 C0C3 0E00"
- $"C067 0F00 E035 0700 E01D 0301 E019 0106 7019 0118 7819 0368"
- $"1C19 02C8 0E3A 0740 077A 0640 03FC 0C00 07E0 0800 0C00 0FFF"
- $"F800 0000 0000 0000 0007 0000 FFFF FFFF FFFF 0001 FFFF FFFF"
- $"0000 0002 CCCC 9999 6666 0003 8888 8888 8888 0004 DDDD DDDD"
- $"DDDD 0005 FFFF CCCC 9999 0006 0000 BBBB 0000 000F 0000 0000"
- $"0000 0000 0000 000F FFFF F000 0000 0000 0000 0000 0000 00FF"
- $"FFFF FFF0 0000 0000 0000 0000 0000 FFFF FFFF FFFF 0000 0000"
- $"0000 FFFF FF0F FFFF 5555 555F F000 00FF FFF0 F222 22FF FF55"
- $"5555 5555 5FFF FFFF FFF0 F222 222F FFFF FFFF FFFF FFFF FFFF"
- $"FFF0 F222 2222 FFF3 33FF FFFF FFFF FFFF FF00 FF22 2222 2FFF"
- $"44FF FFFF FFFF FFFF FF00 0FF2 2222 22FF F4FF FFFF F55F FFFF"
- $"F000 00FF F222 222F FFFF FFFF 5555 FFFF 0000 0000 FF22 2222"
- $"FFFF FFFF 5555 55FF 0000 0000 0FF2 2222 2FFF FFF2 2555 555F"
- $"F000 0000 0FF2 2222 2555 55FF 2255 5555 FF00 0000 FFF2 2222"
- $"5555 555F F225 5555 5FF0 0000 FFF2 2225 5555 5555 FF22 5555"
- $"55FF 0000 FFF2 2225 5555 FF55 5FF2 2555 55FF 0000 FFF2 2225"
- $"5555 FF55 55FF 2252 55FF 0000 FFF2 2225 5555 FF55 555F F222"
- $"22FF 0000 FFF2 2225 5555 FF55 5555 FF22 22FF 0000 FFF2 2222"
- $"5555 FF55 5555 5FF2 2FFF 0000 FFFF 2222 2555 FFF5 5555 55FF"
- $"2F5F 0000 0FFF 2222 2255 FFF5 5555 555F FF5F 0000 00FF 2222"
- $"2221 61F5 5555 555F F55F 0000 000F 2222 2612 2FFF 5555 555F"
- $"F55F 0000 000F 2221 6222 2FFF F555 555F F55F 0000 00FF 2612"
- $"1222 222F FF55 555F F55F 0000 00F2 1122 6222 2222 FFF5 55FF"
- $"F5F0 0000 0FF6 2622 2222 2222 2FFF 5FFF F5F0 0000 0F62 2622"
- $"2222 2222 22FF FFFF FF00 0000 FF22 2222 2222 2222 2FFF FFF0"
- $"0000 0000 F222 2222 2222 2222 FF00 0000 0000 0000 FFFF FFFF"
- $"FFFF FFFF F000 0000 0000"
-};
diff --git a/maccaml/ocamlconstants.h b/maccaml/ocamlconstants.h
deleted file mode 100644
index 1b3e1e6515..0000000000
--- a/maccaml/ocamlconstants.h
+++ /dev/null
@@ -1,187 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Para, INRIA Rocquencourt */
-/* */
-/* Copyright 1998 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#define kMinSystemVersion 0x700
-
-#define kExtraStackSpace (128 * 1024)
-#define kMoreMasters 6
-#define kScrapThreshold (4 * 1024)
-#define kMinimumMemory (32 * 1024)
-
-#define kTitleBarSpace 20
-#define kWinBorderSpace 5
-#define kPowerStripSpace 20
-#define kVisualDelay 8UL /* XXX use double-click time ?? */
-
-#define ktextwidth 32000
-#define kHorizScrollDelta 32
-#define kGraphScrollDelta 8
-#define kScrollBarWidth 15 /* not counting one of the borders. */
-#define kTextMarginV 3
-#define kTextMarginH 6
-#define kMinWindowWidth 64
-#define kMinWindowHeight 64
-
-#define keyPgUp 0x74
-#define keyPgDn 0x79
-#define keyHome 0x73
-#define keyEnd 0x77
-#define keyF1 0x7A
-#define keyF2 0x78
-#define keyF3 0x63
-#define keyF4 0x76
-
-#define charEnter 0x03
-#define charBackspace 0x08
-#define charReturn 0x0D
-#define charEscape 0x1B
-#define charArrowLeft 0x1C
-#define charArrowRight 0x1D
-#define charArrowUp 0x1E
-#define charArrowDown 0x1F
-#define charDelete 0x7F
-
-#define kWinUnknown 0
-#define kWinUninitialised 1
-#define kWinAbout 2
-#define kWinToplevel 3
-#define kWinGraphics 4
-#define kWinDocument 5
-#define kWinPrefs 6
-#define kWinClipboard 7
-
-#define kCreatorCaml 'Caml'
-#define kTypeText 'TEXT'
-
-/* Resource IDs */
-
-#define kToplevelWinTemplate 1000
-#define kGraphicsWinTemplate 1001
-#define kDocumentWinTemplate 1002
-
-#define kScrollBarTemplate 1000
-
-/* DO NOT CHANGE this definition. */
-#define kApplicationIcon 1000
-
-#define kDialogAbout 1000
-#define kAlertNeedSys7 1001
-#define kAlertBug 1002
-#define kAlertGeneric 1003
-#define kAlertExit 1004
-#define kDialogPrefs 1005
-#define kAlertNotYet 1006
-#define kAlertSaveAsk 1007
-#define kAlertErrorMsg 1008
-#define kAlertErrorNum 1009
-#define kAlertNeed32BitQD 1010
-
-#define kKeysOK 1000
-#define kKeysSaveDontCancel 1001
-
-#define kPrefsDescriptionStr 1000
-#define kApplicationMissing -16397
-
-#define kUndoStrings 1000
-
-#define kMiscStrings 1001
-#define kPrefsFileNameIdx 1
-#define kUntitledIdx 2
-#define kClosingIdx 3
-#define kQuittingIdx (kClosingIdx + 1)
-#define kCannotOpenIdx 5
-#define kCloseQuoteIdx 6
-#define kSaveAsPromptIdx 7
-#define kEmptyIdx 8
-#define kCannotWriteIdx 9
-#define kWithErrorCodeIdx 10
-
-#define kErrorStrings 1002
-#define kMemFull 1
-#define kDiskFull 2
-#define kDirFull 3
-#define kTooManyFiles 4
-#define kFileNotFound 5
-#define kWriteProtect 6
-#define kFileLocked 7
-#define kVolLocked 8
-#define kFileBusy 9
-#define kFileOpen 10
-#define kVolOffLine 11
-#define kPermDenied 12
-#define kWritePermDenied 13
-#define kDirNotFound 14
-#define kDisconnected 15
-#define kIOError 16
-
-#define kAboutText1 1000
-#define kAboutText2 1001
-
-#define kMenuBar 1000
-
-#define kCommandLineTemplate 1000
-#define kEnvironmentTemplate 1001
-
-
-/* Sound stuff */
-
-#define kDurationOffset 0x1E
-#define kSampleRateOffset 0x34
-
-
-/* Menus */
-
-#define kMenuApple 1000
-#define kMenuFile 1001
-#define kMenuEdit 1002
-#define kMenuWindows 1003
-
-/***** Apple menu */
-#define kItemAbout 1
-
-/***** File menu */
-#define kItemNew 1
-#define kItemOpen 2
-/* - */
-#define kItemClose 4
-#define kItemSave 5
-#define kItemSaveAs 6
-#define kItemRevert 7
-/* - */
-#define kItemPageSetup 9
-#define kItemPrint 10
-/* - */
-#define kItemQuit 12
-
-/***** Edit menu */
-#define kItemUndo 1
-/* - */
-#define kItemCut 3
-#define kItemCopy 4
-#define kItemPaste 5
-#define kItemClear 6
-#define kItemSelectAll 7
-#define kItemShowClipboard 8
-/* - */
-#define kItemFind 10
-#define kItemReplace 11
-/* - */
-#define kItemPreferences 13
-
-/***** Windows menu */
-#define kItemToplevel 1
-#define kItemGraphics 2
-/* - */
-#define kItemDocuments 4
diff --git a/maccaml/ocamlmkappli b/maccaml/ocamlmkappli
deleted file mode 100644
index c300c16a6c..0000000000
--- a/maccaml/ocamlmkappli
+++ /dev/null
@@ -1,89 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Damien Doligez, projet Moscova, INRIA Rocquencourt #
-# #
-# Copyright 2000 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-
-# ocamlmkappli -- build a standalone application
-
-# usage: ocamlmkappli [optionÉ] fileÉ
-# options:
-# -creator <code> use this creator code (default '????')
-# -ocamlc <command> use <command> as O'Caml compiler (default ocamlc)
-# -d <def> pass "-d <def>" option to Rez
-# -prefsize <int> set preferred memory size (kilobytes, default 4000)
-# -lib <folder> use library files from <folder> (default {CAMLLIB})
-# -minsize <int> set minimum memory size (megabytes, default 2000)
-# -name <name> set the name of the application (default a.out)
-# -r <file> add resources from this file (or rez source file)
-
-set echo 0
-
-set creator '????'
-set ocamlc ocamlc
-set rezopt ''
-set prefsize 4000
-set lib "{{CAMLLIB}}"
-set minsize 2000
-set name a.out
-set rezfiles ''
-
-set files ''
-
-loop
- break if {#} == 0
- if "{{1}}" == "-creator"
- set creator "{{2}}"
- shift
- else if "{{1}}" == "-ocamlc"
- set ocamlc "{{2}}"
- shift
- else if "{{1}}" == "-d"
- set rezopt "{{rezopt}} -d ``quote "{{2}}"``"
- shift
- else if "{{1}}" == "-prefsize"
- set prefsize {2}
- shift
- else if "{{1}}" == "-lib"
- set lib "{{2}}"
- shift
- else if "{{1}}" == "-minsize"
- set minsize {2}
- shift
- else if "{{1}}" == "-name"
- set name "{{2}}"
- shift
- else if "{{1}}" == "-r"
- set rezfiles "{{rezfiles}} ``quote "{{2}}"``"
- shift
- else
- set files "{{files}} ``quote "{{1}}"``"
- end
- shift
-end
-
-if {prefsize} < {minsize}
- set prefsize {minsize}
-end
-
-set tmp "{{tempfolder}}ocamlmkappli-`date -n`"
-delete -y -ay -i "{{tmp}}"
-
-duplicate -y "{{lib}}appli" "{{name}}"
-rez -d SystemSevenOrLater=1 -d PREFSIZE="{prefsize}" -d MINSIZE="{minsize}" ¶
- -d APPLNAME="¶"{{name}}¶"" -d CREATOR="'{{creator}}'" ¶
- -a -o "{{name}}" "{{lib}}appli.r" {rezopt} {rezfiles}
-{ocamlc} -use-prims "{{lib}}appliprims" {files} -o "{{tmp}}"
-catenate "{{tmp}}" >> "{{name}}"
-setfile -t APPL -c "{{creator}}" -a iB "{{name}}"
-
-delete -i "{{tmp}}"
diff --git a/maccaml/prefs.c b/maccaml/prefs.c
deleted file mode 100644
index 70f208550a..0000000000
--- a/maccaml/prefs.c
+++ /dev/null
@@ -1,127 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Para, INRIA Rocquencourt */
-/* */
-/* Copyright 1998 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "main.h"
-
-#define kPrefResource 1000
-
-struct prefs prefs;
-static struct prefs defpref;
-
-static void InitPrefs (void)
-{
- TextStyle defstyle;
-
- defpref.version = PREF_VERSION;
- defpref.asksavetop = 0;
- WinToplevelStdState (&defpref.toppos);
- WinGraphicsStdState (&defpref.graphpos);
- WinClipboardStdState (&defpref.clippos);
- GetFNum ("\pmonaco", &defstyle.tsFont);
- defstyle.tsSize = 9;
- defstyle.tsFace = 0;
- defstyle.tsColor.red = 0;
- defstyle.tsColor.green = 0;
- defstyle.tsColor.blue = 0;
- defpref.text = defpref.unread = defpref.input = defpref.output
- = defpref.errors = defstyle;
-
- defpref.unread.tsColor.green = 35000;
- defpref.input.tsColor.blue = 65535;
- defpref.errors.tsColor.red = 50000;
- defpref.errors.tsFace = underline;
-}
-
-void ReadPrefs (void)
-{
- short err;
- short vrefnum;
- long dirid;
- short refnum = -1;
- Handle prefsH = NULL;
- Str255 prefsfilename;
- FSSpec spec;
-
- InitPrefs ();
- GetIndString (prefsfilename, kMiscStrings, kPrefsFileNameIdx);
- err = FindFolder (kOnSystemDisk, kPreferencesFolderType, kCreateFolder,
- &vrefnum, &dirid);
- if (err != noErr) goto cantread;
- err = FSMakeFSSpec (vrefnum, dirid, prefsfilename, &spec);
- if (err != noErr) goto cantread;
- refnum = FSpOpenResFile (&spec, fsRdPerm);
- if (refnum == -1) goto cantread;
- prefsH = Get1Resource ('Oprf', kPrefResource);
- if (prefsH == NULL) goto cantread;
- if (GetHandleSize (prefsH) != sizeof (prefs)) goto cantread;
- if (**(long **)prefsH != PREF_VERSION) goto cantread;
- memmove (&prefs, *prefsH, sizeof (prefs));
- CloseResFile (refnum);
- return;
-
- cantread:
- if (refnum != -1) CloseResFile (refnum);
- prefs = defpref;
-}
-
-void WritePrefs (void)
-{
- short err;
- short vrefnum;
- long dirid;
- short refnum = -1;
- Handle prefsH = NULL;
- Str255 prefsfilename;
- FSSpec spec;
- Handle h;
-
- GetIndString (prefsfilename, kMiscStrings, kPrefsFileNameIdx);
- err = FindFolder (kOnSystemDisk, kPreferencesFolderType, kCreateFolder,
- &vrefnum, &dirid);
- if (err != noErr) goto cantwrite;
- err = FSMakeFSSpec (vrefnum, dirid, prefsfilename, &spec);
- if (err != noErr && err != fnfErr) goto cantwrite;
-
- if (err == fnfErr){
- if (!memcmp (&prefs, &defpref, sizeof (prefs))) return;
- else FSpCreateResFile (&spec, 0, 0, smSystemScript);
- }
- refnum = FSpOpenResFile (&spec, fsRdWrPerm);
- if (refnum == -1) goto cantwrite;
-
- prefsH = Get1Resource ('Oprf', kPrefResource);
- if (prefsH == NULL){
- err = AllocHandle (sizeof (prefs), (Handle *) &prefsH);
- if (err != noErr) goto cantwrite;
- AddResource (prefsH, 'Oprf', kPrefResource, "\pO'Caml prefs");
- }
- SetHandleSize (prefsH, sizeof (prefs));
- if (MemError () != noErr) goto cantwrite;
- memmove (*prefsH, &prefs, sizeof (prefs));
- ChangedResource (prefsH);
-
- h = GetResource ('STR ', kPrefsDescriptionStr);
- if (h != NULL){
- DetachResource (h);
- AddResource (h, 'STR ', kApplicationMissing, NULL);
- ChangedResource (h);
- }
-
- CloseResFile (refnum);
- return;
-
- cantwrite:
- if (refnum != -1) CloseResFile (refnum);
-}
diff --git a/maccaml/prim_bigarray b/maccaml/prim_bigarray
deleted file mode 100644
index abec389025..0000000000
--- a/maccaml/prim_bigarray
+++ /dev/null
@@ -1,18 +0,0 @@
-bigarray_blit
-bigarray_create
-bigarray_dim
-bigarray_fill
-bigarray_get_1
-bigarray_get_2
-bigarray_get_3
-bigarray_get_generic
-bigarray_init
-bigarray_map_file
-bigarray_num_dims
-bigarray_reshape
-bigarray_set_1
-bigarray_set_2
-bigarray_set_3
-bigarray_set_generic
-bigarray_slice
-bigarray_sub
diff --git a/maccaml/prim_graph b/maccaml/prim_graph
deleted file mode 100644
index 35c00284e9..0000000000
--- a/maccaml/prim_graph
+++ /dev/null
@@ -1,41 +0,0 @@
-gr_blit_image
-gr_clear_graph
-gr_close_graph
-gr_close_subwindow
-gr_create_image
-gr_current_x
-gr_current_y
-gr_display_mode
-gr_draw_arc
-gr_draw_arc_nat
-gr_draw_char
-gr_draw_image
-gr_draw_rect
-gr_draw_string
-gr_dump_image
-gr_fill_arc
-gr_fill_arc_nat
-gr_fill_poly
-gr_fill_rect
-gr_lineto
-gr_make_image
-gr_moveto
-gr_open_graph
-gr_open_subwindow
-gr_plot
-gr_point_color
-gr_remember_mode
-gr_set_color
-gr_set_font
-gr_set_line_width
-gr_set_text_size
-gr_set_window_title
-gr_sigio_handler
-gr_sigio_signal
-gr_size_x
-gr_size_y
-gr_sound
-gr_synchronize
-gr_text_size
-gr_wait_event
-gr_window_id
diff --git a/maccaml/prim_num b/maccaml/prim_num
deleted file mode 100644
index 9a30b25382..0000000000
--- a/maccaml/prim_num
+++ /dev/null
@@ -1,28 +0,0 @@
-add_nat
-blit_nat
-compare_digits_nat
-compare_nat
-complement_nat
-create_nat
-decr_nat
-div_digit_nat
-div_nat
-incr_nat
-initialize_nat
-is_digit_int
-is_digit_normalized
-is_digit_odd
-is_digit_zero
-land_digit_nat
-lor_digit_nat
-lxor_digit_nat
-mult_digit_nat
-mult_nat
-nth_digit_nat
-num_digits_nat
-num_leading_zero_bits_in_digit
-set_digit_nat
-set_to_zero_nat
-shift_left_nat
-shift_right_nat
-sub_nat
diff --git a/maccaml/prim_str b/maccaml/prim_str
deleted file mode 100644
index 00e31ec574..0000000000
--- a/maccaml/prim_str
+++ /dev/null
@@ -1,8 +0,0 @@
-str_compile_regexp
-str_string_match
-str_string_partial_match
-str_search_forward
-str_search_backward
-str_beginning_group
-str_end_group
-str_replacement_text
diff --git a/maccaml/print.c b/maccaml/print.c
deleted file mode 100644
index 43263add96..0000000000
--- a/maccaml/print.c
+++ /dev/null
@@ -1,131 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Para, INRIA Rocquencourt */
-/* */
-/* Copyright 1999 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "main.h"
-
-static short (*get_npages) (THPrint printrec);
-static short (*draw_page) (THPrint printrec, TPPrPort port, int pagenum);
-
-static THPrint curjobprintrec = NULL;
-
-/*
- dojobdialog = 0 -> no job dialog (use default settings)
- dojobdialog = 1 -> use job dialog
- dojobdialog = 2 -> no job dialog (use previous dialog settings)
-*/
-static short print_loop (int dojobdialog, THPrint docprintrec)
-{
- short ncopies, fstpage, lstpage, npages;
- OSErr err;
- GrafPtr saveport;
- TPPrPort printerport;
- TPrStatus prstatus;
- int copy, page, pgrun;
-
- GetPort (&saveport);
-
- PrOpen ();
- err = PrError (); if (err != noErr) goto failed_PrOpen;
-
- PrValidate (docprintrec);
- err = PrError (); if (err != noErr) goto failed_PrValidate;
-
- npages = (*get_npages) (docprintrec);
- switch (dojobdialog){
- case 0:
- if (curjobprintrec != NULL) DisposeHandle ((Handle) curjobprintrec);
- curjobprintrec = (THPrint) NewHandle (sizeof (TPrint));
- if (curjobprintrec == NULL) goto failed_alloc_curjobprintrec;
- PrintDefault (curjobprintrec);
- PrJobMerge (curjobprintrec, docprintrec);
- break;
- case 1:
- err = PrJobDialog (docprintrec);
- if (err) goto failed_PrJobDialog;
- if (curjobprintrec != NULL) DisposeHandle ((Handle) curjobprintrec);
- curjobprintrec = docprintrec;
- HandToHand ((Handle *) &curjobprintrec);
- if (curjobprintrec == NULL) goto failed_alloc_curjobprintrec;
- break;
- case 2:
- PrJobMerge (curjobprintrec, docprintrec);
- break;
- }
- ncopies = (*docprintrec)->prJob.iCopies;
- fstpage = (*docprintrec)->prJob.iFstPage;
- lstpage = (*docprintrec)->prJob.iLstPage;
- if (lstpage > npages) lstpage = npages;
-
- /* XXX Should display a status dialog box and use a IdleProc function */
-
- for (copy = 0; copy < ncopies; copy++){
- printerport = PrOpenDoc (docprintrec, NULL, NULL);
- err = PrError (); if (err != noErr) goto failed_PrOpenDoc;
- pgrun = 0;
- for (page = fstpage; page <= lstpage; page++){
- if (pgrun >= iPFMaxPgs){
- PrCloseDoc (printerport);
- err = PrError (); if (err != noErr) goto failed_PrCloseDoc;
- if ((*docprintrec)->prJob.bJDocLoop == bSpoolLoop){
- PrPicFile (docprintrec, NULL, NULL, NULL, &prstatus);
- }
- printerport = PrOpenDoc (docprintrec, NULL, NULL);
- err = PrError (); if (err != noErr) goto failed_PrOpenDoc;
- pgrun = 0;
- }
- PrOpenPage (printerport, NULL);
- err = PrError (); if (err != noErr) goto failed_PrOpenPage;
- err = (*draw_page) (docprintrec, printerport, page);
- if (err != noErr) goto failed_draw_page;
- PrClosePage (printerport);
- ++ pgrun;
- }
- PrCloseDoc (printerport);
- err = PrError (); if (err != noErr) goto failed_PrCloseDoc;
- if ((*docprintrec)->prJob.bJDocLoop == bSpoolLoop){
- PrPicFile (docprintrec, NULL, NULL, NULL, &prstatus);
- }
- }
- PrClose ();
- /*XXX close status dialog box here */
- SetPort (saveport);
- return noErr;
-
- failed_draw_page:
- PrClosePage (printerport);
- /* fall through */
- failed_PrOpenPage:
- PrCloseDoc (printerport);
- /* fall through */
- failed_PrOpenDoc:
- failed_PrCloseDoc:
- failed_alloc_curjobprintrec:
- failed_PrJobDialog:
- failed_PrValidate:
- PrClose ();
- /* fall through */
- failed_PrOpen:
- return err;
-}
-
-void FilePageSetup (void)
-{
- XXX ();
-}
-
-void FilePrint (void)
-{
- XXX ();
-}
diff --git a/maccaml/scroll.c b/maccaml/scroll.c
deleted file mode 100644
index e91a79bb01..0000000000
--- a/maccaml/scroll.c
+++ /dev/null
@@ -1,325 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Para, INRIA Rocquencourt */
-/* */
-/* Copyright 1998 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "main.h"
-
-WEScrollUPP scrollFollowUPP;
-static ControlActionUPP scrollUPP, scrollGraphUPP;
-
-static long scroll_step = 1;
-
-/* Bring destRect in sync with the scroll bars. */
-static void AdjustView (WStatusH st)
-{
- WEReference we = (*st)->we;
- ControlHandle hbar = (*st)->scrollbars[H];
- ControlHandle vbar = (*st)->scrollbars[V];
- LongRect view, dest;
- long dx, dy;
-
- Assert (hbar != NULL && vbar != NULL);
- if ((*st)->kind != kWinGraphics){
- Assert (we != NULL);
- WEGetViewRect (&view, we);
- WEGetDestRect (&dest, we);
- dx = view.left - dest.left - LCGetValue (hbar);
- dy = view.top - dest.top - LCGetValue (vbar);
- WEScroll (dx, dy, we);
- }else{
- dx = (*st)->viewrect.left - (*st)->destrect.left - LCGetValue (hbar);
- dy = (*st)->viewrect.top - (*st)->destrect.top - LCGetValue (vbar);
- GraphScroll (dx, dy);
- }
-}
-
-/* Recompute the max values and the thumb positions. */
-void AdjustScrollBars (WindowPtr w)
-{
- GrafPtr saveport;
- WStatusH st;
- LongRect view, dest;
- long xmax, xval, ymax, yval;
- long h;
-
- PushWindowPort (w);
-
- st = WinGetStatus (w);
- Assert (st != NULL);
- if ((*st)->kind == kWinGraphics){
- view = (*st)->viewrect;
- dest = (*st)->destrect;
- }else{
- WEGetViewRect (&view, (*st)->we);
- WEGetDestRect (&dest, (*st)->we);
- }
-
- yval = view.top - dest.top;
- ymax = yval + (dest.bottom - view.bottom);
- if (ymax < 0) ymax = 0;
-
- /* round up to nearest line_height */
- h = (*st)->line_height;
- ymax = (ymax + h - 1) / h * h;
-
- LCSetMax ((*st)->scrollbars[V], ymax);
- LCSetValue ((*st)->scrollbars[V], yval);
-
- xval = view.left - dest.left;
- xmax = xval + (dest.right - view.right);
- if (xmax < 0) xmax = 0;
- LCSetMax ((*st)->scrollbars[H], xmax);
- LCSetValue ((*st)->scrollbars[H], xval);
-
- if (xval > xmax || yval > ymax) AdjustView (st);
-
- PopPort;
-}
-
-/* Callback procedure for auto-scrolling the text. (called by WASTE) */
-static pascal void Follow (WEReference we)
-{
- WindowPtr w;
- OSErr err;
-
- err = WEGetInfo (weRefCon, &w, we);
- Assert (err == noErr);
- AdjustScrollBars (w);
-}
-
-/* Callback procedure for scrolling the text. (called by the Control Manager) */
-static pascal void Scroll (ControlHandle bar, ControlPartCode partcode)
-{
- long value;
-
- if (partcode == kControlNoPart) return;
- value = LCGetValue (bar);
- if (value < LCGetMax (bar) && scroll_step > 0
- || value > 0 && scroll_step < 0){
- LCSetValue (bar, value + scroll_step);
- AdjustView (WinGetStatus (FrontWindow ()));
- }
-}
-
-/* Callback procedure for scrolling the graphics. */
-static pascal void ScrollGraph (ControlHandle bar, ControlPartCode partcode)
-{
- long value;
-
- if (partcode == kControlNoPart) return;
- value = LCGetValue (bar);
- if (value < LCGetMax (bar) && scroll_step > 0
- || value > 0 && scroll_step < 0){
- LCSetValue (bar, value + scroll_step);
- AdjustView (WinGetStatus (FrontWindow ()));
- }
-}
-
-OSErr InitialiseScroll (void)
-{
- scrollFollowUPP = NewWEScrollProc (Follow);
- scrollUPP = NewControlActionProc (Scroll);
- scrollGraphUPP = NewControlActionProc (ScrollGraph);
- return noErr;
-}
-
-/* Calculate the contents rectangle for a text window with scrollbars. */
-void ScrollCalcText (WindowPtr w, Rect *r)
-{
- *r = w->portRect;
- r->bottom -= kScrollBarWidth;
- r->right -= kScrollBarWidth;
- InsetRect (r, kTextMarginH, kTextMarginV);
-}
-
-/* Calculate the contents rectangle for the graphics window. */
-void ScrollCalcGraph (WindowPtr w, Rect *r)
-{
- *r = w->portRect;
- r->bottom -= kScrollBarWidth;
- r->right -= kScrollBarWidth;
-}
-
-void ScrollDoClick (WindowPtr w, Point where, EventModifiers mods)
-{
- switch (WinGetKind (w)){
- case kWinToplevel:
- case kWinDocument: {
- WEReference we = WinGetWE (w);
- WStatusH st = WinGetStatus (w);
- LongRect view;
- ControlPartCode partcode;
- ControlHandle bar;
- long scrolldelta, pagesize;
-
- Assert (we != NULL && st != NULL);
- WEGetViewRect (&view, we);
- partcode = FindControl (where, w, &bar);
- if (bar == (*st)->scrollbars[V]){
- pagesize = view.bottom - view.top;
- scrolldelta = (*st)->line_height;
- }else if (bar == (*st)->scrollbars [H]){
- pagesize = view.right - view.left;
- scrolldelta = kHorizScrollDelta;
- }else{
- return;
- }
- switch (partcode){
- case kControlIndicatorPart:
- TrackControl (bar, where, NULL);
- LCSynch (bar);
- AdjustView (st);
- return;
- case kControlUpButtonPart:
- scroll_step = - (mods & optionKey ? 1 : scrolldelta);
- break;
- case kControlDownButtonPart:
- scroll_step = + (mods & optionKey ? 1 : scrolldelta);
- break;
- case kControlPageUpPart:
- scroll_step = - (pagesize - scrolldelta) / scrolldelta * scrolldelta;
- break;
- case kControlPageDownPart:
- scroll_step = + (pagesize - scrolldelta) / scrolldelta * scrolldelta;
- break;
- }
- TrackControl (bar, where, scrollUPP);
- break;
- }
- case kWinGraphics: {
- WStatusH st = WinGetStatus (w);
- ControlPartCode partcode;
- ControlHandle bar;
- long scrolldelta, pagesize;
-
- Assert (st != NULL);
- partcode = FindControl (where, w, &bar);
- scrolldelta = kGraphScrollDelta;
- if (bar == (*st)->scrollbars[V]){
- pagesize = (*st)->viewrect.bottom - (*st)->viewrect.top;
- }else if (bar == (*st)->scrollbars [H]){
- pagesize = (*st)->viewrect.right - (*st)->viewrect.left;
- }else{
- return;
- }
- switch (partcode){
- case kControlIndicatorPart:
- TrackControl (bar, where, NULL);
- LCSynch (bar);
- AdjustView (st);
- return;
- case kControlUpButtonPart:
- scroll_step = - (mods & optionKey ? 1 : scrolldelta);
- break;
- case kControlDownButtonPart:
- scroll_step = + (mods & optionKey ? 1 : scrolldelta);
- break;
- case kControlPageUpPart:
- scroll_step = - (pagesize - scrolldelta) / scrolldelta * scrolldelta;
- break;
- case kControlPageDownPart:
- scroll_step = + (pagesize - scrolldelta) / scrolldelta * scrolldelta;
- break;
- }
- TrackControl (bar, where, scrollGraphUPP);
- break;
- }
- case kWinPrefs:
- case kWinAbout:
- case kWinClipboard:
- default:
- Assert (0); /* These windows have no scroll bars. */
- break;
- }
-}
-
-/* Calculate and set the position of the scroll bars for w.
- Draw the scroll bars and the grow icon, and validate their region.
- Where applicable, this function must be called after WinWEResize or
- WinGraphResize.
- */
-void ScrollNewSize (WindowPtr w)
-{
- Rect port = w->portRect;
- WStatusH st = WinGetStatus (w);
- Rect r;
- ControlHandle bar;
- GrafPtr saveport;
-
- Assert (st != NULL);
-
- PushWindowPort (w);
-
- bar = (*st)->scrollbars[H];
- r.left = port.left - 1;
- r.right = port.right - kScrollBarWidth + 1;
- r.top = port.bottom - kScrollBarWidth;
- r.bottom = port.bottom + 1;
- HideControl (bar); /* Invalidates the rectangle */
- MoveControl (bar, r.left, r.top);
- SizeControl (bar, r.right - r.left, r.bottom - r.top);
- /* Only show the scrollbar if the window is active. */
- if (FrontWindow () == w){
- ValidRect (&r);
- ShowControl (bar);
- }
-
- bar = (*st)->scrollbars[V];
- r.left = port.right - kScrollBarWidth;
- r.right = port.right + 1;
- r.top = port.top - 1;
- r.bottom = port.bottom - kScrollBarWidth + 1;
- HideControl (bar); /* Invalidates the rectangle */
- MoveControl (bar, r.left, r.top);
- SizeControl (bar, r.right - r.left, r.bottom - r.top);
- /* Only show the scrollbar if the window is active. */
- if (FrontWindow () == w){
- ValidRect (&r);
- ShowControl (bar);
- }
-
- r = w->portRect;
- r.left = r.right - kScrollBarWidth;
- r.top = r.bottom - kScrollBarWidth;
- ValidRect (&r);
- DrawGrowIcon (w);
-
- AdjustScrollBars (w);
-
- PopPort;
-}
-
-/* Return 1 if the vertical scroll bar is at its max setting, 0 otherwise.
- (With 1 line fudge factor.)
-*/
-int ScrollAtEnd (WindowPtr w)
-{
- WStatusH st = WinGetStatus (w);
- long val, max;
-
- Assert (st != NULL);
- val = LCGetValue ((*st)->scrollbars[V]);
- max = LCGetMax ((*st)->scrollbars[V]);
- return val >= max - (*st)->line_height;
-}
-
-/* Scroll to the bottom of the document. */
-void ScrollToEnd (WindowPtr w)
-{
- WStatusH st = WinGetStatus (w);
-
- Assert (st != NULL);
- LCSetValue ((*st)->scrollbars[V], LCGetMax ((*st)->scrollbars[V]));
- AdjustView (st);
-}
diff --git a/maccaml/windows.c b/maccaml/windows.c
deleted file mode 100644
index 73d8b297fa..0000000000
--- a/maccaml/windows.c
+++ /dev/null
@@ -1,852 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Para, INRIA Rocquencourt */
-/* */
-/* Copyright 1998 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "main.h"
-
-WindowPtr winToplevel = NULL;
-WindowPtr winGraphics = NULL;
-long wintopfrontier = 0;
-
-static WELineBreakUPP charBreakUPP;
-
-/* WE hook for breaking line at char (not word) boundaries. */
-static pascal StyledLineBreakCode CharBreak
- (Ptr pText, SInt32 textLength, SInt32 textStart, SInt32 textEnd,
- Fixed *textWidth, SInt32 *textOffset, WEHandle hWE)
-{
-#pragma unused (textLength, hWE)
- long base = textStart;
- long len = textEnd - textStart;
- long l = 0;
- long i;
- short w;
- short text_width = HiWord (*textWidth);
-
- while (len > 0){
- if (pText [base] == '\n'){
- *textOffset = base + 1;
- return smBreakWord;
- }
-
- l = len >= 128 ? 128 : len;
- for (i = 0; i < l; i++){
- if (pText [base + i] == '\n') l = i;
- }
-
- w = TextWidth (pText, base, l);
- if (w > text_width){
- short locs [129];
- long i;
- MeasureText (l, pText + base, (Ptr) locs);
- for (i = 0; i < l; i++){
- if (locs [i+1] > text_width) break;
- }
- *textOffset = base + i;
- return smBreakChar;
- }
-
- len -= l;
- base += l;
- text_width -= w;
- }
- *textOffset = base;
- *textWidth = FixRatio (text_width, 1);
- return smBreakOverflow;
-}
-
-static void UpdateToplevelRO (void)
-{
- WEReference we = WinGetWE (winToplevel);
- long selstart, selend;
-
- Assert (we != NULL);
- WEGetSelection (&selstart, &selend, we);
- if (selstart >= wintopfrontier){
- WEFeatureFlag (weFReadOnly, weBitClear, we);
- }else{
- WEFeatureFlag (weFReadOnly, weBitSet, we);
- }
-}
-
-OSErr InitialiseWindows (void)
-{
- charBreakUPP = NewWELineBreakProc (CharBreak);
- return noErr;
-}
-
-/* The window becomes active if [activate] is true,
- inactive if false.
-*/
-void WinActivateDeactivate (int activate, WindowPtr w)
-{
- WStatusH st = WinGetStatus (w);
- WEHandle we = WinGetWE (w);
- VHSelect axis;
- GrafPtr saveport;
-
- if (st == NULL) return;
-
- PushWindowPort (w);
-
- if (we != NULL){
- if (activate) WEActivate (we); else WEDeactivate (we);
- }
- for (axis = V; axis <= H; axis++){
- ControlHandle bar = (*st)->scrollbars[axis];
- if (bar != NULL){
- if (activate) ShowControl (bar); else HideControl (bar);
- /* We sometimes get an activate without any previous deactivate.
- In this case, ShowControl will do nothing, but the control
- still needs to be redrawn. It will be done with the normal
- update mechanism. In the normal case, the control will be
- drawn twice, but what the hell. */
- /* ValidRect (&(*bar)->contrlRect); */
- }
- }
- /* There seems to be a bug in DrawGrowIcon that makes it draw an icon
- for non-resizable windows when processing a suspend/resume event.
- */
- if (GetWVariant (w) != noGrowDocProc) DrawGrowIcon (w);
-
- PopPort;
-}
-
-void WinAdvanceTopFrontier (long length)
-{
- wintopfrontier += length;
- UpdateToplevelRO ();
-}
-
-OSErr WinAllocStatus (WindowPtr w)
-{
- WStatusH st = NULL;
- OSErr err;
- struct menuflags f;
-
- err = AllocHandle (sizeof (struct WStatus), (Handle *) &st);
- if (err != noErr) return err;
- HLock ((Handle) st);
- (*st)->kind = kWinUninitialised;
- (*st)->datarefnum = -1;
- (*st)->resrefnum = -1;
- (*st)->basemodcount = 0;
- f.save = f.save_as = f.revert = f.page_setup = f.print = f.cut = f.copy =
- f.paste = f.clear = f.select_all = f.find = f.replace = 0;
- (*st)->menuflags = f;
- (*st)->scrollbars [V] = NULL;
- (*st)->scrollbars [H] = NULL;
- /* XXX initialiser les rectangles */
- (*st)->line_height = 1;
- (*st)->we = NULL;
- HUnlock ((Handle) st);
- SetWRefCon (w, (long) st);
- return noErr;
-}
-
-void WinCloseGraphics (void)
-{
- Rect r;
- GrafPtr saveport;
-
- Assert (winGraphics != NULL);
-
- PushWindowPort (winGraphics);
- r = winGraphics->portRect;
- LocalToGlobalRect (&r);
- prefs.graphpos = r;
- PopPort;
-
- DisposeWindow (winGraphics);
- winGraphics = NULL;
-}
-
-void WinCloseToplevel (void)
-{
- Rect r;
- GrafPtr saveport;
-
- if (winToplevel != NULL){
- PushWindowPort (winToplevel);
-
- r = winToplevel->portRect;
- LocalToGlobalRect (&r);
- prefs.toppos = r;
- if (prefs.asksavetop){
- XXX ();
- }
- PopPort;
- }
- DisposeWindow (winToplevel);
- winToplevel = NULL;
-}
-
-void WinDoContentClick (EventRecord *event, WindowPtr w)
-{
- int k = WinGetKind (w);
- int inback = !IsWindowHilited (w);
-
- switch (k){
-
- case kWinUnknown:
- case kWinAbout:
- case kWinClipboard:
- if (inback) SelectWindow (w);
- break;
-
- case kWinGraphics: {
- Point hitPt = event->where;
- GrafPtr saveport;
-
- PushWindowPort (w);
- GlobalToLocal (&hitPt);
- if (inback){
- SelectWindow (w);
- }else{
- Rect r;
- ScrollCalcGraph (w, &r);
- if (PtInRect (hitPt, &r)){
- GraphGotEvent (event);
- }else{
- ScrollDoClick (w, hitPt, event->modifiers);
- }
- }
- PopPort;
- break;
- }
-
- case kWinToplevel:
- case kWinDocument: {
- int handleit = !inback;
- GrafPtr saveport;
- Point hitPt = event->where;
- WEReference we = WinGetWE (w);
-
- Assert (we != NULL);
- PushWindowPort (w);
- GlobalToLocal (&hitPt);
-
- if (inback && gHasDragAndDrop){
- long selStart, selEnd;
- RgnHandle selRgn;
-
- WEGetSelection (&selStart, &selEnd, we);
- selRgn = WEGetHiliteRgn (selStart, selEnd, we);
- handleit = PtInRgn (hitPt, selRgn) && WaitMouseMoved (event->where);
- DisposeRgn (selRgn);
- }
- if (!handleit){
- SelectWindow (w);
- }else{
- Rect r;
- ScrollCalcText (w, &r);
- InsetRect (&r, -kTextMarginH, 0);
- if (PtInRect (hitPt, &r)){
- WEClick (hitPt, event->modifiers, event->when, we);
- if (w == winToplevel) UpdateToplevelRO ();
- }else{
- ScrollDoClick (w, hitPt, event->modifiers);
- }
- }
- PopPort;
- break;
- }
-
- default:
- Assert (0); /* There is no other window kind. */
- break;
- }
-}
-
-OSErr WinDoClose (ClosingOption close, WindowPtr w)
-{
- int k = WinGetKind (w);
- OSErr err;
- WStatusH st;
- WEHandle we;
-
- switch (k){
-
- case kWinUnknown:
- case kWinToplevel:
- default:
- Assert (0);
- return noErr;
-
- case kWinAbout:
- CloseAboutBox (w);
- return noErr;
-
- case kWinGraphics:
- HideWindow (winGraphics);
- return noErr;
-
- case kWinDocument:
- err = FileDoClose (w, close);
- if (err != noErr) return err;
- st = WinGetStatus (w); Assert (st != NULL);
- we = WinGetWE (w); Assert (we != NULL);
- LCDetach ((*st)->scrollbars[V]);
- LCDetach ((*st)->scrollbars[H]);
- WEDispose (we);
- DisposeHandle ((Handle) st);
- MenuWinRemove (w);
- DisposeWindow (w);
- return noErr;
-
- case kWinClipboard:
- XXX ();
- return noErr;
- }
-}
-
-void WinDoDrag (Point where, WindowPtr w)
-{
- Rect limits;
-
- limits = (*GetGrayRgn ())->rgnBBox;
- InsetRect (&limits, 4, 4);
- DragWindow (w, where, &limits);
- if (w == winGraphics) GraphNewSizePos ();
-}
-
-/* Invalidate the bottom and right margins. */
-static void WinInvalMargins (WindowPtr w)
-{
- Rect r;
-
- r = w->portRect;
- r.right -= kScrollBarWidth;
- r.left = r.right - kTextMarginH;
- r.bottom -= kScrollBarWidth;
- InvalRect (&r);
- r = w->portRect;
- r.bottom -= kScrollBarWidth;
- r.top = r.bottom - kTextMarginV;
- r.right -= kScrollBarWidth;
- InvalRect (&r);
-}
-
-static void WinGraphNewSize (WindowPtr w)
-{
- Rect r;
- WStatusH st = WinGetStatus (w);
-
- Assert (st != NULL);
- ScrollCalcGraph (w, &r);
- WERectToLongRect (&r, &(*st)->viewrect);
-}
-
-static void WinWENewSize (WindowPtr w, WEReference we)
-{
- Rect r;
- LongRect lr;
-
- ScrollCalcText (w, &r);
- WERectToLongRect (&r, &lr);
- WESetViewRect (&lr, we);
- WEGetDestRect (&lr, we);
- if (lr.right - lr.left != r.right - r.left){
- lr.right = lr.left + r.right - r.left;
- WESetDestRect (&lr, we);
- WECalText (we);
- InvalRect (&r);
- }
-}
-
-static void WinResize (WindowPtr w, short x, short y)
-{
- GrafPtr saveport;
- WEReference we = WinGetWE (w);
- Rect r;
-
- PushWindowPort (w);
-
- /* Invalidate the old grow icon and the text margin. */
- r = w->portRect;
- r.left = r.right - kScrollBarWidth;
- r.top = r.bottom - kScrollBarWidth;
- InvalRect (&r);
- if (we != NULL) WinInvalMargins (w);
-
- SizeWindow (w, x, y, true);
-
- /* Redraw the controls and invalidate whatever is needed. */
- if (we != NULL){
- WinWENewSize (w, we);
- WinInvalMargins (w);
- }
- if (w == winGraphics) WinGraphNewSize (w);
- ScrollNewSize (w);
- PopPort;
-}
-
-void WinDoGrow (Point where, WindowPtr w)
-{
- Rect r;
- long newsize;
- short x, y;
- WStatusH st;
-
- switch (WinGetKind (w)){
-
- case kWinUnknown:
- case kWinAbout:
- case kWinPrefs:
- Assert (0);
- break;
-
- case kWinToplevel:
- case kWinDocument:
- case kWinClipboard:
- SetRect (&r, kMinWindowWidth, kMinWindowHeight, SHRT_MAX, SHRT_MAX);
- break;
-
- case kWinGraphics:
- st = WinGetStatus (w);
- Assert (st != NULL);
- x = (*st)->destrect.right - (*st)->destrect.left + kScrollBarWidth + 1;
- y = (*st)->destrect.bottom - (*st)->destrect.top + kScrollBarWidth + 1;
- SetRect (&r, kMinWindowWidth, kMinWindowHeight, x, y);
- break;
- }
- newsize = GrowWindow (w, where, &r);
- if (newsize != 0) WinResize (w, LoWord (newsize), HiWord (newsize));
-}
-
-void WinDoIdle (WindowPtr w)
-{
- WEHandle we = WinGetWE (w);
-
- if (we != NULL) WEIdle (&evtSleep, we); else evtSleep = LONG_MAX;
-}
-
-void WinDoKey (WindowPtr w, short chr, EventRecord *e)
-{
- WEReference we;
- long selstart, selend;
-
- switch (WinGetKind (w)){
-
- case kWinToplevel:
- we = WinGetWE (w); Assert (we != NULL);
- WEGetSelection (&selstart, &selend, we);
- if (chr == charBackspace || chr == charDelete){
- if (selstart < wintopfrontier || selend == wintopfrontier) break;
- }
- if (chr == charEnter){
- long sel = WEGetTextLength (we);
- WESetSelection (sel, sel, we);
- chr = charReturn;
- }
- if (chr != charArrowLeft && chr != charArrowRight
- && chr != charArrowUp && chr != charArrowDown
- && selstart < wintopfrontier){
- selstart = selend = WEGetTextLength (we);
- WESetSelection (selstart, selend, we);
- WEFeatureFlag (weFReadOnly, weBitClear, we);
- }
- if (selstart == selend){
- WESetStyle (weDoFont + weDoFace + weDoSize + weDoColor + weDoReplaceFace,
- &prefs.unread, we);
- }
- /*XXX intercepter option-up/down, command-up/down, option-command-up/down */
- WEKey (chr, e->modifiers, we);
- UpdateToplevelRO ();
- break;
-
- case kWinDocument:
- we = WinGetWE (w); Assert (we != NULL);
- if (chr == charEnter){
- XXX (); /* XXX envoyer la phrase courante au toplevel */
- }
- /*XXX intercepter option-up/down, command-up/down, option-command-up/down
- -> myWEKey pour partager avec le toplevel */
- WEKey (chr, e->modifiers, we);
- break;
-
- case kWinGraphics:
- GraphGotEvent (e);
- break;
-
- case kWinAbout:
- CloseAboutBox (w);
- break;
-
- case kWinPrefs:
- XXX ();
- break;
-
- case kWinClipboard:
- break;
-
- default:
- Assert (0);
- break;
- }
-}
-
-void WinDoZoom (WindowPtr w, short partCode)
-{
-#pragma unused (w, partCode)
- XXX ();
-}
-
-/* Return a pointer to the window's descriptor record,
- NULL if there is none or w is NULL.
-*/
-WStatusH WinGetStatus (WindowPtr w)
-{
- WStatusH st;
- short wk;
-
- if (w == NULL) return NULL;
- wk = GetWindowKind (w);
- if (wk != kApplicationWindowKind && wk != kDialogWindowKind) return NULL;
- st = (WStatusH) GetWRefCon (w);
- Assert (st != NULL);
- return st;
-}
-
-WEHandle WinGetWE (WindowPtr w)
-{
- WStatusH st = WinGetStatus (w);
-
- if (st == NULL) return NULL;
- return (*st)->we;
-}
-
-int WinGetKind (WindowPtr w)
-{
- WStatusH st = WinGetStatus (w);
-
- if (st == NULL) return kWinUnknown;
- return (*st)->kind;
-}
-
-/* Initialize all the data structures associated with a text
- window: WE record and scroll bars.
-*/
-static OSErr WinTextInit (WindowPtr w, TextStyle *style)
-{
- OSErr err;
- WEReference we = NULL;
- WStatusH st = NULL;
- Rect viewrect;
- LongRect lviewrect, ldestrect;
- WERunInfo runinfo;
- int i;
- ControlHandle bar;
-
- err = WinAllocStatus (w);
- if (err != noErr) goto failed;
-
- st = WinGetStatus (w); Assert (st != NULL);
- HLock ((Handle) st);
-
- ScrollCalcText (w, &viewrect);
- WERectToLongRect (&viewrect, &lviewrect);
- ldestrect = lviewrect;
- ldestrect.right = ldestrect.left + ktextwidth;
- err = WENew (&ldestrect, &lviewrect,
- weDoAutoScroll + weDoOutlineHilite + weDoUndo
- + weDoDragAndDrop + weDoUseTempMem + weDoDrawOffscreen
- + weDoMonoStyled,
- &we);
- if (err != noErr) goto failed;
- WESetAlignment (weFlushLeft, we);
- WESetStyle (weDoFont + weDoFace + weDoSize + weDoColor + weDoReplaceFace,
- style, we);
- err = WESetInfo (weRefCon, &w, we); Assert (err == noErr);
- err = WESetInfo (weScrollProc, &scrollFollowUPP, we); Assert (err == noErr);
- err = WESetInfo (weLineBreakHook, &charBreakUPP, we); Assert (err == noErr);
- /* XXX ajouter un hiliteDropAreaHook pour les marges asymetriques. */
- (*st)->we = we;
-
- WEGetRunInfo (0, &runinfo, we);
- (*st)->line_height = runinfo.runHeight;
-
- (*st)->scrollbars [H] = (*st)->scrollbars [V] = NULL;
- for (i = V; i <= H; i++){
- bar = GetNewControl (kScrollBarTemplate, w);
- if (bar == NULL){ err = memFullErr; goto failed; }
- err = LCAttach (bar);
- if (err != noErr) goto failed;
- (*st)->scrollbars [i] = bar;
- }
-
- HUnlock ((Handle) st);
-
- WinWENewSize (w, we);
- ScrollNewSize (w);
-
- return noErr;
-
- failed:
- if (we != NULL) WEDispose (we);
- if (st != NULL){
- if ((*st)->scrollbars [V] != NULL) LCDetach ((*st)->scrollbars[V]);
- if ((*st)->scrollbars [H] != NULL) LCDetach ((*st)->scrollbars[H]);
- DisposeHandle ((Handle) st);
- }
- return err;
-}
-
-/* Open a new empty document window.
- In case of failure, display an alert and return NULL.
-*/
-WindowPtr WinOpenDocument (StringPtr name)
-{
- WStatusH st = NULL;
- WindowPtr w = NULL;
- OSErr err;
-
- w = GetNewCWindow (kDocumentWinTemplate, NULL, (WindowPtr) -1L);
- if (w == NULL){ err = memFullErr; goto failed; }
-
- SetWTitle (w, name);
- ShowWindow (w);
- SetPort (w);
-
- err = WinTextInit (w, &prefs.text);
- if (err != noErr) goto failed;
-
- st = WinGetStatus (w); Assert (st != NULL);
- (*st)->kind = kWinDocument;
- (*st)->menuflags.save_as = (*st)->menuflags.page_setup =
- (*st)->menuflags.print = (*st)->menuflags.paste = (*st)->menuflags.find =
- (*st)->menuflags.replace = 1;
-
- err = MenuWinAdd (w);
- if (err != noErr) goto failed;
-
- return w;
-
- failed:
- if (w != NULL) DisposeWindow (w); /* Also deallocates the scroll bars. */
- ErrorAlertGeneric (err);
- return NULL;
-}
-
-OSErr WinOpenGraphics (long width, long height)
-{
- WindowPtr w = NULL;
- WStatusH st = NULL;
- OSErr err;
- Rect r;
- int i;
- ControlHandle bar;
- long ww, hh;
-
- w = GetNewCWindow (kGraphicsWinTemplate, NULL, (WindowPtr) -1L);
- if (w == NULL){ err = memFullErr; goto failed; }
-
- /*XXX Calculer si la fenetre est hors de l'ecran -> stdstate */
- MoveWindow (w, prefs.graphpos.left, prefs.graphpos.top, false);
- ww = prefs.graphpos.right - prefs.graphpos.left;
- hh = prefs.graphpos.bottom - prefs.graphpos.top;
- if (ww < kMinWindowWidth) ww = kMinWindowWidth;
- if (ww > width + kScrollBarWidth) ww = width + kScrollBarWidth;
- if (hh < kMinWindowHeight) hh = kMinWindowHeight;
- if (hh > height + kScrollBarWidth) hh = height + kScrollBarWidth;
- SizeWindow (w, ww, hh, false);
- ShowWindow (w);
- SetPort (w);
-
- err = WinAllocStatus (w);
- if (err != noErr) goto failed;
-
- st = WinGetStatus (w); Assert (st != NULL);
- HLock ((Handle) st);
-
- ScrollCalcGraph (w, &r);
- WERectToLongRect (&r, &(*st)->viewrect);
- r.right = r.left + width;
- r.bottom = r.top + height;
- WERectToLongRect (&r, &(*st)->destrect);
- st = WinGetStatus (w); Assert (st != NULL);
- (*st)->kind = kWinGraphics;
- (*st)->menuflags.save_as = (*st)->menuflags.page_setup =
- (*st)->menuflags.print = 1;
-
- (*st)->scrollbars [H] = (*st)->scrollbars [V] = NULL;
- for (i = V; i <= H; i++){
- bar = GetNewControl (kScrollBarTemplate, w);
- if (bar == NULL){ err = memFullErr; goto failed; }
- err = LCAttach (bar);
- if (err != noErr) goto failed;
- (*st)->scrollbars [i] = bar;
- }
-
- HUnlock ((Handle) st);
-
- ScrollNewSize (w);
- winGraphics = w;
- return noErr;
-
- failed:
- if (st != NULL){
- if ((*st)->scrollbars [V] != NULL) LCDetach ((*st)->scrollbars[V]);
- if ((*st)->scrollbars [H] != NULL) LCDetach ((*st)->scrollbars[H]);
- DisposeHandle ((Handle) st);
- }
- winGraphics = NULL;
- if (w != NULL) DisposeWindow (w); /* Also deallocates the scroll bars. */
- return err;
-}
-
-OSErr WinOpenToplevel (void)
-{
- WindowPtr w = NULL;
- WStatusH st = NULL;
- WEHandle we = NULL;
- OSErr err;
-
- /* Open the toplevel behind all other windows. */
- w = GetNewCWindow (kToplevelWinTemplate, NULL, NULL);
- if (w == NULL){ err = memFullErr; goto failed; }
-
- /*XXX Calculer si la fenetre est hors de l'ecran -> stdstate */
- MoveWindow (w, prefs.toppos.left, prefs.toppos.top, false);
- SizeWindow (w, prefs.toppos.right - prefs.toppos.left,
- prefs.toppos.bottom - prefs.toppos.top, false);
- ShowWindow (w);
- SetPort (w);
-
- err = WinTextInit (w, &prefs.unread);
- if (err != noErr) goto failed;
-
- st = WinGetStatus (w); Assert (st != NULL);
- (*st)->kind = kWinToplevel;
- (*st)->menuflags.save_as = (*st)->menuflags.page_setup =
- (*st)->menuflags.print = (*st)->menuflags.find = 1;
-
- we = WinGetWE (w); Assert (we != NULL);
- WEFeatureFlag (weFUndo, weBitClear, we);
- WEFeatureFlag (weFMonoStyled, weBitClear, we);
-
- winToplevel = w;
- return noErr;
-
- failed:
- winToplevel = NULL;
- if (w != NULL) DisposeWindow (w); /* Also deallocates the scroll bars. */
- ErrorAlertGeneric (err);
- return err;
-}
-
-void WinClipboardStdState (Rect *r)
-{
- *r = (*GetGrayRgn ())->rgnBBox;
- r->bottom -= kWinBorderSpace;
- r->top = r->bottom - kMinWindowHeight;
- r->left += kWinBorderSpace;
- r->right -= 100;
-}
-
-void WinGraphicsStdState (Rect *r)
-{
- if (winGraphics == NULL){
- *r = (*GetGrayRgn ())->rgnBBox;
- r->top += kTitleBarSpace;
- r->left += kWinBorderSpace;
- r->bottom -= kWinBorderSpace;
- r->right -= kWinBorderSpace;
- }else{
- /* XXX To do for zoom */
- Assert (0);
- }
-}
-
-void WinToplevelStdState (Rect *r)
-{
- *r = (*GetGrayRgn ())->rgnBBox;
- r->top += kTitleBarSpace;
- r->bottom -= kPowerStripSpace;
- r->left += kWinBorderSpace;
- if (r->right > r->left + 506) r->right = r->left + 506;
-}
-
-void WinUpdate (WindowPtr w)
-{
- int k = WinGetKind (w);
- WEHandle we = WinGetWE (w);
- GrafPtr saveport;
- RgnHandle updateRgn;
-
- Assert (k != kWinUnknown);
-
- PushWindowPort (w);
- BeginUpdate (w);
- updateRgn = w->visRgn;
- if (!EmptyRgn (updateRgn)){
- EraseRgn (updateRgn);
- UpdateControls (w, updateRgn);
- DrawGrowIcon (w);
- if (k == kWinGraphics) GraphUpdate ();
- if (we != NULL) WEUpdate (updateRgn, we);
- }
- EndUpdate (w);
- PopPort;
-}
-
-void WinUpdateStatus (WindowPtr w)
-{
- long selstart, selend;
- WStatusH st = WinGetStatus (w);
- WEHandle we = WinGetWE (w);
- int readonly;
-
- if (st == NULL) return;
- switch ((*st)->kind){
- case kWinUnknown:
- case kWinAbout:
- case kWinPrefs:
- case kWinClipboard:
- case kWinGraphics:
- break;
- case kWinToplevel:
- Assert (we != NULL);
- WEGetSelection (&selstart, &selend, we);
- if (selend == selstart){
- (*st)->menuflags.cut = 0;
- (*st)->menuflags.copy = 0;
- (*st)->menuflags.clear = 0;
- }else{
- (*st)->menuflags.copy = 1;
- (*st)->menuflags.cut = (*st)->menuflags.clear =
- selstart >= wintopfrontier;
- }
- (*st)->menuflags.select_all = WEGetTextLength (we) != 0;
- readonly = WEFeatureFlag (weFReadOnly, weBitTest, we);
- WEFeatureFlag (weFReadOnly, weBitClear, we);
- (*st)->menuflags.paste = WECanPaste (we);
- if (readonly) WEFeatureFlag (weFReadOnly, weBitSet, we);
- break;
- case kWinDocument:
- Assert (we != NULL);
- WEGetSelection (&selstart, &selend, we);
- (*st)->menuflags.save = (*st)->menuflags.revert =
- (*st)->basemodcount != WEGetModCount (we);
- (*st)->menuflags.cut = (*st)->menuflags.copy = (*st)->menuflags.clear =
- selstart != selend;
- (*st)->menuflags.paste = WECanPaste (we);
- (*st)->menuflags.select_all = WEGetTextLength (we) != 0;
- break;
- case kWinUninitialised:
- default:
- Assert (0);
- break;
- }
-}
diff --git a/man/Makefile b/man/Makefile
deleted file mode 100644
index 4753c202ea..0000000000
--- a/man/Makefile
+++ /dev/null
@@ -1,22 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-include ../config/Makefile
-
-DIR=$(MANDIR)/man$(MANEXT)
-
-install:
- for i in *.m; do cp $$i $(DIR)/`basename $$i .m`.$(MANEXT); done
- echo '.so man$(MANEXT)/ocamlc.$(MANEXT)' > $(DIR)/ocamlc.opt.$(MANEXT)
- echo '.so man$(MANEXT)/ocamlopt.$(MANEXT)' > $(DIR)/ocamlopt.opt.$(MANEXT)
diff --git a/man/ocaml.help b/man/ocaml.help
deleted file mode 100644
index 466896dcc7..0000000000
--- a/man/ocaml.help
+++ /dev/null
@@ -1,138 +0,0 @@
--
-OCaml # Objective Caml toplevel
-Usage: ocaml <options>
-options are:
- -I <dir> Add <dir> to the list of include directories
- -unsafe No bound checking on array and string access
- -drawlambda (undocumented)
- -dlambda (undocumented)
- -dinstr (undocumented)
- -rectypes (undocumented)
-
--
-OCamlc # Objective Caml compiler
-Usage: ocamlc <options> <files>
-Options are:
- -a Build a library
- -c Compile only (do not link)
- -cc <comp> Use <comp> as the C compiler and linker
- -cclib <opt> Pass option <opt> to the C linker
- -ccopt <opt> Pass option <opt> to the C compiler and linker
- -g Save debugging information
- -i Print the types
- -I <dir> Add <dir> to the list of include directories
- -impl <file> Compile <file> as a .ml file
- -intf <file> Compile <file> as a .mli file
- -intf-suffix <file> Suffix for interface file (default: .mli)
- -intf_suffix <file> (deprecated) same as -intf-suffix
- -linkall Link all modules, even unused ones
- -make-runtime Build a runtime system with given C objects and libraries
- -make_runtime (deprecated) same as -make-runtime
- -noassert Do not compile assertion checks
- -o <file> Set output file name to <file>
- -output-obj Output a C object file instead of an executable
- -pp <command> Pipe sources through preprocessor <command>
- -thread Use thread-safe standard library
- -unsafe No bounds checking on array and string access
- -use-runtime <path> Generate bytecode for the given runtime system
- -use_runtime <path> (deprecated) same as -use-runtime
- -v Print compiler version number
- -verbose Print calls to external commands
- -w <flags> Enable or disable warnings according to <flags>:
- A/a enable/disable all warnings
- C/c enable/disable suspicious comment
- F/f enable/disable partially applied function
- M/m enable/disable overriden method
- P/p enable/disable partial match
- S/s enable/disable non-unit statement
- U/u enable/disable unused match case
- V/v enable/disable hidden instance variable
- X/x enable/disable all other warnings
- default setting is A (all warnings enabled)
- -nopervasives (undocumented)
- -dparsetree (undocumented)
- -drawlambda (undocumented)
- -dlambda (undocumented)
- -dinstr (undocumented)
- -use-prims <file> (undocumented)
- -rectypes (undocumented)
- - <file> Treat <file> as a file name (even if it starts with `-')
-
--
-OCamlc-custom # Objective Caml compiler for custom runtime mode
-Usage: ocamlc-custom <options> <files>
-Options are:
- -a Build a library
- -c Compile only (do not link)
- -cc <comp> Use <comp> as the C compiler and linker
- -cclib <opt> Pass option <opt> to the C linker
- -ccopt <opt> Pass option <opt> to the C compiler and linker
- -g Save debugging information
- -i Print the types
- -I <dir> Add <dir> to the list of include directories
- -impl <file> Compile <file> as a .ml file
- -intf <file> Compile <file> as a .mli file
- -intf-suffix <file> Suffix for interface file (default: .mli)
- -intf_suffix <file> (deprecated) same as -intf-suffix
- -linkall Link all modules, even unused ones
- -make-runtime Build a runtime system with given C objects and libraries
- -make_runtime (deprecated) same as -make-runtime
- -noassert Do not compile assertion checks
- -o <file> Set output file name to <file>
- -output-obj Output a C object file instead of an executable
- -pp <command> Pipe sources through preprocessor <command>
- -thread Use thread-safe standard library
- -unsafe No bounds checking on array and string access
- -use-runtime <path> Generate bytecode for the given runtime system
- -use_runtime <path> (deprecated) same as -use-runtime
- -v Print compiler version number
- -verbose Print calls to external commands
- -w <flags> Enable or disable warnings according to <flags>:
- A/a enable/disable all warnings
- C/c enable/disable suspicious comment
- F/f enable/disable partially applied function
- M/m enable/disable overriden method
- P/p enable/disable partial match
- S/s enable/disable non-unit statement
- U/u enable/disable unused match case
- V/v enable/disable hidden instance variable
- X/x enable/disable all other warnings
- default setting is A (all warnings enabled)
- -nopervasives (undocumented)
- -dparsetree (undocumented)
- -drawlambda (undocumented)
- -dlambda (undocumented)
- -dinstr (undocumented)
- -use-prims <file> (undocumented)
- -rectypes (undocumented)
- - <file> Treat <file> as a file name (even if it starts with `-')
-
--
-OCamlDep # Objective Caml dependency generator
-Usage: ocamldep [-I <dir>] <files>
- -I <dir> Add <dir> to the list of include directories
-
--
-OCamlLex # Objective Caml lexer generator
-OCamlLex name.mll
-
--
-OCamlRun # Objective Caml bytecode interpreter
-OCamlRun [-v] file [argumentsÉ]
- -v # print GC messages
-
-Environment variable:
-Set -e OCamlRunParam "<option>=<value>,É"
- h # initial size of the major heap
- i # minimum size increment for the major heap
- l # maximum stack size
- o # major GC speed setting
- O # heap compaction trigger setting
- s # size of the minor heap
- v # verbosity flags for GC messages
-
--
-OCamlYacc # Objective Caml parser generator
-OCamlYacc [-v] [-b string] file.mly
- -v # put verbose report in file.output
- -b string # name output files string.ml and string.mli
diff --git a/man/ocaml.m b/man/ocaml.m
deleted file mode 100644
index 7f7e5a6445..0000000000
--- a/man/ocaml.m
+++ /dev/null
@@ -1,101 +0,0 @@
-.TH OCAML 1
-
-.SH NAME
-ocaml \- The Objective Caml interactive toplevel
-
-
-.SH SYNOPSIS
-.B ocaml
-[
-.B \-unsafe
-]
-[
-.BI \-I \ lib-dir
-]
-[
-.I object-files
-]
-[
-.I script-file
-]
-.SH DESCRIPTION
-
-The
-.BR ocaml (1)
-command is the toplevel system for Objective Caml,
-that permits interactive use of the Objective Caml system through a
-read-eval-print loop. In this mode, the system repeatedly reads Caml
-phrases from the input, then typechecks, compile and evaluate
-them, then prints the inferred type and result value, if any. The
-system prints a # (sharp) prompt before reading each phrase.
-
-A toplevel phrase can span several lines. It is terminated by ;; (a
-double-semicolon). The syntax of toplevel phrases is as follows.
-
-The toplevel system is started by the command
-.BR ocaml (1).
-Phrases are read on standard input, results are printed on standard
-output, errors on standard error. End-of-file on standard input
-terminates
-.BR ocaml (1).
-
-If one or more
-.I object-files
-(ending in
-.B .cmo
-or
-.B .cma
- ) are given, they are loaded silently before starting the toplevel.
-
-If a
-.I script-file
-is given, phrases are read silently from the file, errors printed on
-standard error.
-.BR ocaml (1)
-exits after the execution of the last phrase.
-
-.SH OPTIONS
-
-The following command-line options are recognized by
-.BR ocaml (1).
-
-.TP
-.BI \-I \ directory
-Add the given directory to the list of directories searched for
-source and compiled files. By default, the current directory is
-searched first, then the standard library directory. Directories added
-with
-.B \-I
-are searched after the current directory, in the order in which they
-were given on the command line, but before the standard library
-directory.
-
-.TP
-.B \-unsafe
-Turn bound checking off on array and string accesses (the v.(i)
-and s.[i] constructs). Programs compiled with
-.B \-unsafe
-are therefore slightly faster, but unsafe: anything can happen if the program
-accesses an array or string outside of its bounds.
-
-.SH ENVIRONMENT VARIABLES
-
-.TP
-.B LC_CTYPE
-If set to iso_8859_1, accented characters (from the
-ISO Latin-1 character set) in string and character literals are
-printed as is; otherwise, they are printed as decimal escape sequences.
-
-.TP
-.B TERM
-When printing error messages, the toplevel system
-attempts to underline visually the location of the error. It
-consults the TERM variable to determines the type of output terminal
-and look up its capabilities in the terminal database.
-
-.SH SEE ALSO
-.BR ocamlc (1).
-.br
-.I The Objective Caml user's manual,
-chapter "The toplevel system".
-
diff --git a/man/ocamlc.m b/man/ocamlc.m
deleted file mode 100644
index 2f25d54e45..0000000000
--- a/man/ocamlc.m
+++ /dev/null
@@ -1,247 +0,0 @@
-.TH OCAMLC 1
-
-.SH NAME
-ocamlc \- The Objective Caml bytecode compiler
-
-
-.SH SYNOPSIS
-.B ocamlc
-[
-.B \-aciv
-]
-[
-.BI \-cclib \ libname
-]
-[
-.BI \-ccopt \ option
-]
-[
-.B \-custom
-]
-[
-.B \-unsafe
-]
-[
-.BI \-o \ exec-file
-]
-[
-.BI \-I \ lib-dir
-]
-.I filename ...
-
-.B ocamlc.opt
-.I (same options)
-
-.SH DESCRIPTION
-
-The Objective Caml bytecode compiler
-.BR ocamlc (1)
-compiles Caml source files to bytecode object files and link
-these object files to produce standalone bytecode executable files.
-These executable files are then run by the bytecode interpreter
-.BR ocamlrun (1).
-
-The
-.BR ocamlc (1)
-command has a command-line interface similar to the one of
-most C compilers. It accepts several types of arguments:
-
-Arguments ending in .mli are taken to be source files for
-compilation unit interfaces. Interfaces specify the names exported by
-compilation units: they declare value names with their types, define
-public data types, declare abstract data types, and so on. From the
-file
-.IR x \&.mli,
-the
-.BR ocamlc (1)
-compiler produces a compiled interface
-in the file
-.IR x \&.cmi.
-
-Arguments ending in .ml are taken to be source files for compilation
-unit implementations. Implementations provide definitions for the
-names exported by the unit, and also contain expressions to be
-evaluated for their side-effects. From the file
-.IR x \&.ml,
-the
-.BR ocamlc (1)
-compiler produces compiled object bytecode in the file
-.IR x \&.cmo.
-
-If the interface file
-.IR x \&.mli
-exists, the implementation
-.IR x \&.ml
-is checked against the corresponding compiled interface
-.IR x \&.cmi,
-which is assumed to exist. If no interface
-.IR x \&.mli
-is provided, the compilation of
-.IR x \&.ml
-produces a compiled interface file
-.IR x \&.cmi
-in addition to the compiled object code file
-.IR x \&.cmo.
-The file
-.IR x \&.cmi
-produced
-corresponds to an interface that exports everything that is defined in
-the implementation
-.IR x \&.ml.
-
-Arguments ending in .cmo are taken to be compiled object bytecode. These
-files are linked together, along with the object files obtained
-by compiling .ml arguments (if any), and the Caml Light standard
-library, to produce a standalone executable program. The order in
-which .cmo and.ml arguments are presented on the command line is
-relevant: compilation units are initialized in that order at
-run-time, and it is a link-time error to use a component of a unit
-before having initialized it. Hence, a given
-.IR x \&.cmo
-file must come before all .cmo files that refer to the unit
-.IR x .
-
-Arguments ending in .cma are taken to be libraries of object bytecode.
-A library of object bytecode packs in a single file a set of object
-bytecode files (.cmo files). Libraries are built with
-.B ocamlc \-a
-(see the description of the
-.B \-a
-option below). The object files
-contained in the library are linked as regular .cmo files (see above), in the order specified when the .cma file was built. The only difference is that if an object file
-contained in a library is not referenced anywhere in the program, then
-it is not linked in.
-
-Arguments ending in .c are passed to the C compiler, which generates a .o object file. This object file is linked with the program if the
-.B \-custom
-flag is set (see the description of
-.B \-custom
-below).
-
-Arguments ending in .o or.a are assumed to be C object files and
-libraries. They are passed to the C linker when linking in
-.B \-custom
-mode (see the description of
-.B \-custom
-below).
-
-.B ocamlc.opt
-is the same compiler as
-.BR ocamlc ,
-but compiled with the native-code compiler
-.BR ocamlopt (1).
-Thus, it behaves exactly like
-.BR ocamlc ,
-but compiles faster.
-.B ocamlc.opt
-is not available in all installations of Objective Caml.
-
-.SH OPTIONS
-
-The following command-line options are recognized by
-.BR ocamlc (1).
-
-.TP
-.B \-a
-Build a library (.cma file) with the object files (.cmo files) given on the command line, instead of linking them into an executable
-file. The name of the library can be set with the
-.B \-o
-option. The default name is
-.BR library.cma .
-
-.TP
-.B \-c
-Compile only. Suppress the linking phase of the
-compilation. Source code files are turned into compiled files, but no
-executable file is produced. This option is useful to
-compile modules separately.
-
-.TP
-.BI \-cclib\ -l libname
-Pass the
-.BI \-l libname
-option to the C linker when linking in
-``custom runtime'' mode (see the
-.B \-custom
-option). This causes the
-given C library to be linked with the program.
-
-.TP
-.B \-ccopt
-Pass the given option to the C compiler and linker, when linking in
-``custom runtime'' mode (see the
-.B \-custom
-option). For instance,
-.B -ccopt -L
-.I dir
-causes the C linker to search for C libraries in
-directory
-.IR dir .
-
-.TP
-.B \-custom
-Link in ``custom runtime'' mode. In the default linking mode, the
-linker produces bytecode that is intended to be executed with the
-shared runtime system,
-.BR ocamlrun (1).
-In the custom runtime mode, the
-linker produces an output file that contains both the runtime system
-and the bytecode for the program. The resulting file is larger, but it
-can be executed directly, even if the
-.BR ocamlrun (1)
-command is not
-installed. Moreover, the ``custom runtime'' mode enables linking Caml
-code with user-defined C functions.
-
-.TP
-.B \-i
-Cause the compiler to print all defined names (with their inferred
-types or their definitions) when compiling an implementation (.ml
-file). This can be useful to check the types inferred by the
-compiler. Also, since the output follows the syntax of interfaces, it
-can help in writing an explicit interface (.mli file) for a file: just
-redirect the standard output of the compiler to a .mli file, and edit
-that file to remove all declarations of unexported names.
-
-.TP
-.BI \-I directory
-Add the given directory to the list of directories searched for
-compiled interface files (.cmi) and compiled object code files
-(.cmo). By default, the current directory is searched first, then the
-standard library directory. Directories added with
-.B -I
-are searched
-after the current directory, in the order in which they were given on
-the command line, but before the standard library directory.
-
-.TP
-.BI \-o \ exec-file
-Specify the name of the output file produced by the linker. The
-default output name is
-.BR a.out ,
-in keeping with the Unix tradition. If the
-.B \-a
-option is given, specify the name of the library produced.
-
-.TP
-.B \-v
-Print the version number of the compiler.
-
-.TP
-.B \-unsafe
-Turn bound checking off on array and string accesses (the
-.B v.(i)
-and
-.B s.[i]
-constructs). Programs compiled with
-.B \-unsafe
-are therefore
-slightly faster, but unsafe: anything can happen if the program
-accesses an array or string outside of its bounds.
-
-.SH SEE ALSO
-.BR ocaml (1),
-.BR ocamlrun (1).
-.br
-.I The Objective Caml user's manual,
-chapter "Batch compilation".
diff --git a/man/ocamlcp.m b/man/ocamlcp.m
deleted file mode 100644
index 8b188ce4fc..0000000000
--- a/man/ocamlcp.m
+++ /dev/null
@@ -1,88 +0,0 @@
-.TH OCAMLCP 1
-
-.SH NAME
-ocamlcp \- The Objective Caml profiling compiler
-
-.SH SYNOPSIS
-.B ocamlcp
-[
-.I ocamlc options
-]
-[
-.BI \-p \ flags
-]
-.I filename ...
-
-.SH DESCRIPTION
-The
-.B ocamlcp
-script is a front-end to
-.BR ocamlc (1)
-that instruments the source code, adding code to record how many times
-functions are called, branches of conditionals are taken, ...
-Execution of instrumented code produces an execution profile in the
-file ocamlprof.dump, which can be read using
-.BR ocamlprof (1).
-
-.B ocamlcp
-accepts the same arguments and options as
-.BR ocamlc (1).
-
-.SH OPTIONS
-
-In addition to the
-.BR ocamlc (1)
-options,
-.B ocamlcp
-accepts the following option controlling the amount of profiling
-information:
-
-.TP
-.BR \-p \ letters
-The letters following
-.B -p
-indicate which parts of the program should be profiled:
-
-.TP
-.B a
-all options
-.TP
-.B f
-function calls : a count point is set at the beginning of function bodies
-.TP
-.B i
-if... then... else: count points are set in
-both "then" branch and "else" branch
-.TP
-.B l
-while, for loops: a count point is set at the beginning of
-the loop body
-.TP
-.B m
-"match" branches: a count point is set at the beginning of the
-body of each branch
-.TP
-.B t
-try...with branches: a count point is set at the
-beginning of the body of each branch
-
-For instance, compiling with
-.B ocamlcp \-pfilm
-profiles function calls, if... then... else..., loops, and pattern
-matching.
-
-Calling
-.BR ocamlcp (1)
-without the
-.B \-p
-option defaults to
-.B \-p fm
-meaning
-that only function calls and pattern matching are profiled.
-
-.SH SEE ALSO
-.BR ocamlc (1),
-.BR ocamlprof (1).
-.br
-.I The Objective Caml user's manual,
-chapter "Profiling".
diff --git a/man/ocamldebug.m b/man/ocamldebug.m
deleted file mode 100644
index 4e157ebfab..0000000000
--- a/man/ocamldebug.m
+++ /dev/null
@@ -1,37 +0,0 @@
-.TH OCAMLDEBUG 1
-
-.SH NAME
-ocamldebug \- the Objective Caml source-level replay debugger.
-.SH SYNOPSIS
-.B ocamldebug
-.I "[options] program [arguments]"
-.SH DESCRIPTION
-.B ocamldebug
-is the Objective Caml source-level replay debugger.
-.SH OPTIONS
-A summary of options are included below.
-For a complete description, see the html documentation in the ocaml-doc
-package.
-.TP
-.B \-I directory
-Add directory to the list of directories searched for source files and
-compiled files.
-.TP
-.B \-s socket
-Use socket for communicating with the debugged program.
-.TP
-.B \-c count
-Set the maximum number of simultaneously live checkpoints to count.
-.TP
-.B \-cd directory
-Run the debugger program from the given directory,
-instead of the current working directory.
-.TP
-.B \-emacs
-Tell the debugger it is executed under Emacs.
-.SH SEE ALSO
-ocamldebug is documented fully in the Ocaml HTML documentation.
-.SH AUTHOR
-This manual page was written by Sven LUTHER <luther@debian.org>,
-for the Debian GNU/Linux system (but may be used by others).
-
diff --git a/man/ocamldep.m b/man/ocamldep.m
deleted file mode 100644
index 4fa557bde9..0000000000
--- a/man/ocamldep.m
+++ /dev/null
@@ -1,79 +0,0 @@
-.TH OCAMLDEP 1
-
-.SH NAME
-ocamldep \- Dependency generator for Objective Caml
-
-.SH SYNOPSIS
-.B ocamldep
-[
-.BI \-I \ lib-dir
-]
-.I filename ...
-
-.SH DESCRIPTION
-
-The
-.BR ocamldep (1)
-command scans a set of Objective Caml source files
-(.ml and .mli files) for references to external compilation units,
-and outputs dependency lines in a format suitable for the
-.BR make (1)
-utility. This ensures that make will compile the source files in the
-correct order, and recompile those files that need to when a source
-file is modified.
-
-The typical usage is:
-.P
-ocamldep
-.I options
-*.mli *.ml > .depend
-.P
-where .depend is the file that should contain the
-dependencies.
-
-Dependencies are generated both for compiling with the bytecode
-compiler
-.BR ocamlc (1)
-and with the native-code compiler
-.BR ocamlopt (1).
-
-.SH OPTIONS
-
-The following command-line option is recognized by
-.BR ocamldep (1).
-
-.TP
-.BI \-I \ directory
-Add the given directory to the list of directories searched for
-source files. If a source file foo.ml mentions an external
-compilation unit Bar, a dependency on that unit's interface
-bar.cmi is generated only if the source for bar is found in the
-current directory or in one of the directories specified with
-.BR -I .
-Otherwise, Bar is assumed to be a module form the standard library,
-and no dependencies are generated. For programs that span multiple
-directories, it is recommended to pass
-.BR ocamldep (1)
-the same -I options that are passed to the compiler.
-
-.TP
-.BI \-native
-Generate dependencies for a pure native-code program (no bytecode
-version). When an implementation file (.ml file) has no explicit
-interface file (.mli file),
-.BR ocamldep (1)
-generates dependencies on the
-bytecode compiled file (.cmo file) to reflect interface changes.
-This can cause unnecessary bytecode recompilations for programs that
-are compiled to native-code only. The flag
-.BR -native
-causes dependencies on native compiled files (.cmx) to be generated instead
-of on .cmo files. (This flag makes no difference if all source files
-have explicit .mli interface files.)
-
-.SH SEE ALSO
-.BR ocamlc (1),
-.BR ocamlopt (1).
-.br
-.I The Objective Caml user's manual,
-chapter "Dependency generator".
diff --git a/man/ocamllex.m b/man/ocamllex.m
deleted file mode 100644
index 3b1340d331..0000000000
--- a/man/ocamllex.m
+++ /dev/null
@@ -1,71 +0,0 @@
-.TH OCAMLLEX 1
-
-.SH NAME
-ocamllex \- The Objective Caml lexer generator
-
-.SH SYNOPSIS
-.B ocamllex
-[
-.BI \-o \ output-file
-]
-[
-.B \-ml
-]
-.I filename.mll
-
-.SH DESCRIPTION
-
-The
-.BR ocamllex (1)
-command generates Objective Caml lexers from a set of regular
-expressions with associated semantic actions, in the style of
-.BR lex (1).
-
-Running
-.BR ocamllex (1)
-on the input file
-.IR lexer \&.mll
-produces Caml code for a lexical analyzer in file
-.IR lexer \&.ml.
-
-This file defines one lexing function per entry point in the lexer
-definition. These functions have the same names as the entry
-points. Lexing functions take as argument a lexer buffer, and return
-the semantic attribute of the corresponding entry point.
-
-Lexer buffers are an abstract data type implemented in the standard
-library module Lexing. The functions Lexing.from_channel,
-Lexing.from_string and Lexing.from_function create
-lexer buffers that read from an input channel, a character string, or
-any reading function, respectively.
-
-When used in conjunction with a parser generated by
-.BR ocamlyacc (1),
-the semantic actions compute a value belonging to the type token defined
-by the generated parsing module.
-
-.SH OPTIONS
-
-The
-.BR ocamllex (1)
-command recognizes the following options:
-
-.TP
-.BI \-o \ output-file
-Specify the output file name
-.IR output-file
-instead of the default naming convention.
-
-.TP
-.B \-ml
-Output code that does not use the Caml built-in automata
-interpreter. Instead, the automaton is encoded by Caml functions.
-This option is useful for debugging
-.BR ocamllex (1),
-using it for production lexers is not recommended.
-
-.SH SEE ALSO
-.BR ocamlyacc (1).
-.br
-.I The Objective Caml user's manual,
-chapter "Lexer and parser generators".
diff --git a/man/ocamlmktop.m b/man/ocamlmktop.m
deleted file mode 100644
index 1a956329c8..0000000000
--- a/man/ocamlmktop.m
+++ /dev/null
@@ -1,85 +0,0 @@
-.TH OCAMLMKTOP 1
-
-.SH NAME
-ocamlmktop \- Building custom toplevel systems
-
-.SH SYNOPSIS
-.B ocamlmktop
-[
-.B \-v
-]
-[
-.BI \-cclib \ libname
-]
-[
-.BI \-ccopt \ option
-]
-[
-.B \-custom
-[
-.BI \-o \ exec-file
-]
-[
-.BI \-I \ lib-dir
-]
-.I filename ...
-
-.SH DESCRIPTION
-
-The
-.BR ocamlmktop (1)
-command builds Objective Caml toplevels that
-contain user code preloaded at start-up.
-The
-.BR ocamlmktop (1)
-command takes as argument a set of
-.IR x \&.cmo
-and
-.IR x \&.cma
-files, and links them with the object files that implement the Objective
-Caml toplevel. If the
-.B -custom
-flag is given, C object files and libraries (.o and .a files) can also
-be given on the command line and are linked in the resulting toplevel.
-
-.SH OPTIONS
-
-The following command-line options are recognized by
-.BR ocamlmktop (1).
-
-.TP
-.B \-v
-Print the version number of the compiler.
-
-.TP
-.BI \-cclib\ -l libname
-Pass the
-.BI \-l libname
-option to the C linker when linking in
-``custom runtime'' mode (see the corresponding option for
-.BR ocamlc (1).
-
-.TP
-.B \-ccopt
-Pass the given option to the C compiler and linker, when linking in
-``custom runtime'' mode. See the corresponding option for
-.BR ocamlc (1).
-
-.TP
-.B \-custom
-Link in ``custom runtime'' mode. See the corresponding option for
-.BR ocamlc (1).
-
-.TP
-.BI \-I directory
-Add the given directory to the list of directories searched for
-compiled interface files (.cmo and .cma).
-
-.TP
-.BI \-o \ exec-file
-Specify the name of the toplevel file produced by the linker.
-The default is is
-.BR a.out .
-
-.SH SEE ALSO
-.BR ocamlc (1).
diff --git a/man/ocamlopt.m b/man/ocamlopt.m
deleted file mode 100644
index 6ef10f8117..0000000000
--- a/man/ocamlopt.m
+++ /dev/null
@@ -1,230 +0,0 @@
-.TH OCAMLOPT 1
-
-.SH NAME
-ocamlopt \- The Objective Caml native-code compiler
-
-
-.SH SYNOPSIS
-.B ocamlopt
-[
-.B \-acivS
-]
-[
-.BI \-cclib \ libname
-]
-[
-.BI \-ccopt \ option
-]
-[
-.B \-compact
-]
-[
-.B \-unsafe
-]
-[
-.BI \-o \ exec-file
-]
-[
-.BI \-I \ lib-dir
-]
-.I filename ...
-
-.B ocamlopt.opt
-.I (same options)
-
-.SH DESCRIPTION
-The Objective Caml high-performance
-native-code compiler
-.BR ocamlopt (1)
-compiles Caml source files to native code object files and link these
-object files to produce standalone executables.
-
-The
-.BR ocamlopt (1)
-command has a command-line interface very close to that
-of
-.BR ocamlc (1).
-It accepts the same types of arguments:
-
-Arguments ending in .mli are taken to be source files for
-compilation unit interfaces. Interfaces specify the names exported by
-compilation units: they declare value names with their types, define
-public data types, declare abstract data types, and so on. From the
-file
-.IR x \&.mli,
-the
-.BR ocamlopt (1)
-compiler produces a compiled interface
-in the file
-.IR x \&.cmi.
-The interface produced is identical to that
-produced by the bytecode compiler
-.BR ocamlc (1).
-
-Arguments ending in .ml are taken to be source files for compilation
-unit implementations. Implementations provide definitions for the
-names exported by the unit, and also contain expressions to be
-evaluated for their side-effects. From the file
-.IR x \&.ml,
-the
-.BR ocamlopt (1)
-compiler produces two files:
-.IR x \&.o,
-containing native object code, and
-.IR x \&.cmx,
-containing extra information for linking and
-optimization of the clients of the unit. The compiled implementation
-should always be referred to under the name
-.IR x \&.cmx
-(when given a .o file,
-.BR ocamlopt (1)
-assumes that it contains code compiled from C, not from Caml).
-
-The implementation is checked against the interface file
-.IR x \&.mli
-(if it exists) as described in the manual for
-.BR ocamlc (1).
-
-Arguments ending in .cmx are taken to be compiled object code. These
-files are linked together, along with the object files obtained
-by compiling .ml arguments (if any), and the Caml Light standard
-library, to produce a native-code executable program. The order in
-which .cmx and .ml arguments are presented on the command line is
-relevant: compilation units are initialized in that order at
-run-time, and it is a link-time error to use a component of a unit
-before having initialized it. Hence, a given
-.IR x \&.cmx
-file must come
-before all .cmx files that refer to the unit
-.IR x .
-
-Arguments ending in .cmxa are taken to be libraries of object code.
-Such a library packs in two files
-.IR lib \&.cmxa
-and
-.IR lib \&.a
-a set of object files (.cmx/.o files). Libraries are build with
-.B ocamlopt \-a
-(see the description of the
-.B \-a
-option below). The object
-files contained in the library are linked as regular .cmx files (see
-above), in the order specified when the library was built. The only
-difference is that if an object file contained in a library is not
-referenced anywhere in the program, then it is not linked in.
-
-Arguments ending in .c are passed to the C compiler, which generates
-a .o object file. This object file is linked with the program.
-
-Arguments ending in .o or .a are assumed to be C object files and
-libraries. They are linked with the program.
-
-The output of the linking phase is a regular Unix executable file. It
-does not need
-.BR ocamlrun (1)
-to run.
-
-.B ocamlopt.opt
-is the same compiler as
-.BR ocamlopt ,
-but compiled with itself instead of with the bytecode compiler
-.BR ocamlc (1).
-Thus, it behaves exactly like
-.BR ocamlopt ,
-but compiles faster.
-.B ocamlopt.opt
-is not available in all installations of Objective Caml.
-
-.SH OPTIONS
-
-The following command-line options are recognized by
-.BR ocamlopt (1).
-
-.TP
-.B \-a
-Build a library (.cmxa/.a file) with the object files (.cmx/.o
-files) given on the command line, instead of linking them into an
-executable file. The name of the library can be set with the
-.B \-o
-option. The default name is library.cmxa.
-
-.TP
-.B \-c
-Compile only. Suppress the linking phase of the
-compilation. Source code files are turned into compiled files, but no
-executable file is produced. This option is useful to
-compile modules separately.
-
-.TP
-.BI \-cclib\ -l libname
-Pass the
-.BI -l libname
-option to the linker. This causes the given C library to be linked
-with the program.
-
-.TP
-.BI \-ccopt \ option
-Pass the given option to the C compiler and linker. For instance,
-.B -ccopt -L
-.I dir
-causes the C linker to search for C libraries in
-directory
-.IR dir .
-
-.TP
-.B \-compact
-Optimize the produced code for space rather than for time. This
-results in smaller but slightly slower programs. The default is to
-optimize for speed.
-
-.TP
-.B \-i
-Cause the compiler to print all defined names (with their inferred
-types or their definitions) when compiling an implementation (.ml
-file). This can be useful to check the types inferred by the
-compiler. Also, since the output follows the syntax of interfaces, it
-can help in writing an explicit interface (.mli file) for a file:
-just redirect the standard output of the compiler to a .mli file,
-and edit that file to remove all declarations of unexported names.
-
-.TP
-.BI \-I \ directory
-Add the given directory to the list of directories searched for
-compiled interface files (.cmi) and compiled object code files
-(.cmo). By default, the current directory is searched first, then the
-standard library directory. Directories added with -I are searched
-after the current directory, in the order in which they were given on
-the command line, but before the standard library directory.
-
-.TP
-.BI \-o \ exec-file
-Specify the name of the output file produced by the linker. The
-default output name is a.out, in keeping with the Unix tradition. If
-the
-.B \-a
-option is given, specify the name of the library produced.
-
-.TP
-.B \-S
-Keep the assembly code produced during the compilation. The assembly
-code for the source file
-.IR x \&.ml
-is saved in the file
-.IR x \&.s.
-
-.TP
-.B \-v
-Print the version number of the compiler.
-
-.TP
-.B \-unsafe
-Turn bound checking off on array and string accesses (the v.(i) and
-s.[i] constructs). Programs compiled with -unsafe are therefore
-faster, but unsafe: anything can happen if the program accesses an
-array or string outside of its bounds.
-
-.SH SEE ALSO
-.BR ocamlc (1).
-.br
-.I The Objective Caml user's manual,
-chapter "Native-code compilation".
diff --git a/man/ocamlprof.m b/man/ocamlprof.m
deleted file mode 100644
index 0e1a68092b..0000000000
--- a/man/ocamlprof.m
+++ /dev/null
@@ -1,57 +0,0 @@
-.TH OCAMLPROF 1
-
-.SH NAME
-ocamlprof \- The Objective Caml profiler
-
-.SH SYNOPSIS
-.B ocamlprof
-[
-.BI \-f \ dump-file
-]
-[
-.BI \-F \ text
-]
-.I filename ...
-
-.SH DESCRIPTION
-The
-.B ocamlprof
-command prints execution counts gathered during the execution of a
-Objective Caml program instrumented with
-.BR ocamlcp (1).
-
-It produces a source listing of the program modules given as arguments
-where execution counts have been inserted as comments. For instance,
-.P
-ocamlprof foo.ml
-.P
-prints the source code for the foo module, with comments indicating
-how many times the functions in this module have been called. Naturally,
-this information is accurate only if the source file has not been modified
-since the profiling execution took place.
-
-.SH OPTIONS
-
-.TP
-.BI \-f \ dumpfile
-Specifies an alternate dump file of profiling information.
-The default is the file ocamlprof.dump in the current directory.
-.TP
-.BI \-F \ string
-Specifies an additional string to be output with profiling information.
-By default,
-.B ocamlprof
-will annotate progams with comments of the form
-.BI (* \ n \ *)
-where
-.I n
-is the counter value for a profiling point. With option
-.BI \-F \ string
-the annotation will be
-.BI (* \ s\ n \ *)
-
-.SH SEE ALSO
-.BR ocamlcp (1).
-.br
-.I The Objective Caml user's manual,
-chapter "Profiling".
diff --git a/man/ocamlrun.m b/man/ocamlrun.m
deleted file mode 100644
index 0fff44d766..0000000000
--- a/man/ocamlrun.m
+++ /dev/null
@@ -1,130 +0,0 @@
-.TH OCAMLRUN 1
-
-.SH NAME
-ocamlrun \- The Objective Caml bytecode interpreter
-
-.SH SYNOPSIS
-.B ocamlrun
-[
-.B \-v
-]
-.I filename argument ...
-
-.SH DESCRIPTION
-The
-.BR ocamlrun (1)
-command executes bytecode files produced by the
-linking phase of the
-.BR ocamlc (1)
-command.
-
-The first non-option argument is taken to be the name of the file
-containing the executable bytecode. (That file is searched in the
-executable path as well as in the current directory.) The remaining
-arguments are passed to the Caml Light program, in the string array
-Sys.argv. Element 0 of this array is the name of the
-bytecode executable file; elements 1 to
-.I n
-are the remaining arguments.
-
-In most cases, the bytecode
-executable files produced by the
-.BR ocamlc (1)
-command are self-executable,
-and manage to launch the
-.BR ocamlrun (1)
-command on themselves automatically.
-
-.SH OPTIONS
-
-The following command-line option is recognized by
-.BR ocamlrun (1).
-
-.TP
-.B \-v
-When set, the memory manager prints verbose messages on standard error
-to signal garbage collections and heap extensions.
-
-.SH ENVIRONMENT VARIABLES
-
-The following environment variable are also consulted:
-
-.TP
-.B OCAMLRUNPARAM
-Set the garbage collection parameters.
-(If
-.B OCAMLRUNPARAM
-is not set,
-.B CAMLRUNPARAM
-will be used instead.)
-This variable must be a sequence of parameter specifications.
-A parameter specification is an option letter followed by an =
-sign, a decimal number, and an optional multiplier. There are seven
-options:
-.TP
-.BR s \ (minor_heap_size)
-Size of the minor heap.
-.TP
-.BR i \ (major_heap_increment)
-Minimum size increment for the major heap.
-.TP
-.BR o \ (space_overhead)
-The major GC speed setting.
-.TP
-.BR O \ (max_overhead)
-The heap compaction trigger setting.
-.TP
-.BR l \ (stack_limit)
-The limit (in words) of the stack size.
-.TP
-.BR h
-The initial size of the major heap (in words).
-.TP
-.BR v \ (verbose)
-What GC messages to print to stderr. This is a sum of values selected
-from the following:
-.TP
-.BR 1
-Start of major GC cycle.
-.TP
-.BR 2
-Minor collection and major GC slice.
-.TP
-.BR 4
-Growing and shrinking of the heap.
-.TP
-.BR 8
-Resizing of stacks and memory manager tables.
-.TP
-.BR 16
-Heap compaction.
-.TP
-.BR 32
-Change of GC parameters.
-.TP
-.BR 64
-Computation of major GC slice size.
-
-The multiplier is
-.B k
-,
-.B M
-, or
-.B G
-, for multiplication by 2^10, 2^20, and 2^30 respectively.
-For example, on a 32-bit machine under bash, the command
-.B export OCAMLRUNPARAM='s=256k,v=1'
-tells a subsequent
-.B ocamlrun
-to set its initial minor heap size to 1 megabyte and to print
-a message at the start of each major GC cycle.
-
-.TP
-.B PATH
-List of directories searched to find the bytecode executable file.
-
-.SH SEE ALSO
-.BR ocamlc (1).
-.br
-.I The Objective Caml user's manual,
-chapter "Runtime system".
diff --git a/man/ocamlyacc.m b/man/ocamlyacc.m
deleted file mode 100644
index fb6b2f34d8..0000000000
--- a/man/ocamlyacc.m
+++ /dev/null
@@ -1,71 +0,0 @@
-.TH OCAMLYACC 1
-
-.SH NAME
-ocamlyacc \- The Objective Caml parser generator
-
-.SH SYNOPSIS
-.B ocamlyacc
-[
-.B -v
-]
-[
-.BI \-b prefix
-]
-.I filename.mly
-
-.SH DESCRIPTION
-
-The
-.BR ocamlyacc (1)
-command produces a parser from a LALR(1) context-free grammar
-specification with attached semantic actions, in the style of
-.BR yacc (1).
-Assuming the input file is
-.IR grammar \&.mly,
-running
-.B ocamlyacc
-produces Caml code for a parser in the file
-.IR grammar \&.ml,
-and its interface in file
-.IR grammar \&.mli.
-
-The generated module defines one parsing function per entry point in
-the grammar. These functions have the same names as the entry points.
-Parsing functions take as arguments a lexical analyzer (a function
-from lexer buffers to tokens) and a lexer buffer, and return the
-semantic attribute of the corresponding entry point. Lexical analyzer
-functions are usually generated from a lexer specification by the
-.BR ocamllex (1)
-program. Lexer buffers are an abstract data type
-implemented in the standard library module Lexing. Tokens are values from
-the concrete type token, defined in the interface file
-.IR grammar \&.mli
-produced by
-.BR ocamlyacc (1).
-
-.SH OPTIONS
-
-The
-.BR ocamlyacc (1)
-command recognizes the following options:
-
-.TP
-.B \-v
-Generate a description of the parsing tables and a report on conflicts
-resulting from ambiguities in the grammar. The description is put in
-file
-.IR grammar \&.output.
-
-.TP
-.BI \-b prefix
-Name the output files
-.IR prefix \&.ml,
-.IR prefix \&.mli,
-.IR prefix \&.output,
-instead of the default naming convention.
-
-.SH SEE ALSO
-.BR ocamllex (1).
-.br
-.I The Objective Caml user's manual,
-chapter "Lexer and parser generators".
diff --git a/ocamldoc/.cvsignore b/ocamldoc/.cvsignore
deleted file mode 100644
index 720ee641a5..0000000000
--- a/ocamldoc/.cvsignore
+++ /dev/null
@@ -1,16 +0,0 @@
-ocamldoc
-ocamldoc.opt
-odoc_crc.ml
-odoc_lexer.ml
-odoc_ocamlhtml.ml
-odoc_parser.ml
-odoc_parser.mli
-odoc_see_lexer.ml
-odoc_text_lexer.ml
-odoc_text_parser.ml
-odoc_text_parser.mli
-stdlib_man
-*.output
-test_stdlib
-test_latex
-test
diff --git a/ocamldoc/.depend b/ocamldoc/.depend
deleted file mode 100644
index 8af1586b24..0000000000
--- a/ocamldoc/.depend
+++ /dev/null
@@ -1,222 +0,0 @@
-odoc.cmo: ../utils/clflags.cmo ../utils/config.cmi ../utils/misc.cmi \
- odoc_analyse.cmi odoc_args.cmi odoc_crc.cmo odoc_dot.cmo odoc_global.cmi \
- odoc_html.cmo odoc_info.cmi odoc_latex.cmo odoc_man.cmo odoc_messages.cmo \
- odoc_texi.cmo ../typing/typedtree.cmi
-odoc.cmx: ../utils/clflags.cmx ../utils/config.cmx ../utils/misc.cmx \
- odoc_analyse.cmx odoc_args.cmx odoc_crc.cmx odoc_dot.cmx odoc_global.cmx \
- odoc_html.cmx odoc_info.cmx odoc_latex.cmx odoc_man.cmx odoc_messages.cmx \
- odoc_texi.cmx ../typing/typedtree.cmx
-odoc_analyse.cmo: ../utils/ccomp.cmi ../utils/clflags.cmo ../utils/config.cmi \
- ../typing/ctype.cmi ../typing/env.cmi ../typing/includemod.cmi \
- ../parsing/lexer.cmi ../parsing/location.cmi ../utils/misc.cmi \
- odoc_args.cmi odoc_ast.cmi odoc_class.cmo odoc_comments.cmi \
- odoc_cross.cmi odoc_dep.cmo odoc_global.cmi odoc_merge.cmi \
- odoc_messages.cmo odoc_misc.cmi odoc_module.cmo odoc_sig.cmi \
- odoc_types.cmi ../parsing/parse.cmi ../parsing/syntaxerr.cmi \
- ../bytecomp/translclass.cmi ../bytecomp/translcore.cmi \
- ../typing/typeclass.cmi ../typing/typecore.cmi ../typing/typedecl.cmi \
- ../typing/typedtree.cmi ../typing/typemod.cmi ../typing/typetexp.cmi \
- ../utils/warnings.cmi odoc_analyse.cmi
-odoc_analyse.cmx: ../utils/ccomp.cmx ../utils/clflags.cmx ../utils/config.cmx \
- ../typing/ctype.cmx ../typing/env.cmx ../typing/includemod.cmx \
- ../parsing/lexer.cmx ../parsing/location.cmx ../utils/misc.cmx \
- odoc_args.cmx odoc_ast.cmx odoc_class.cmx odoc_comments.cmx \
- odoc_cross.cmx odoc_dep.cmx odoc_global.cmx odoc_merge.cmx \
- odoc_messages.cmx odoc_misc.cmx odoc_module.cmx odoc_sig.cmx \
- odoc_types.cmx ../parsing/parse.cmx ../parsing/syntaxerr.cmx \
- ../bytecomp/translclass.cmx ../bytecomp/translcore.cmx \
- ../typing/typeclass.cmx ../typing/typecore.cmx ../typing/typedecl.cmx \
- ../typing/typedtree.cmx ../typing/typemod.cmx ../typing/typetexp.cmx \
- ../utils/warnings.cmx odoc_analyse.cmi
-odoc_args.cmo: ../utils/clflags.cmo ../utils/config.cmi ../utils/misc.cmi \
- odoc_global.cmi odoc_messages.cmo odoc_module.cmo odoc_types.cmi \
- odoc_args.cmi
-odoc_args.cmx: ../utils/clflags.cmx ../utils/config.cmx ../utils/misc.cmx \
- odoc_global.cmx odoc_messages.cmx odoc_module.cmx odoc_types.cmx \
- odoc_args.cmi
-odoc_ast.cmo: ../parsing/asttypes.cmi ../parsing/location.cmi \
- ../utils/misc.cmi odoc_args.cmi odoc_class.cmo odoc_env.cmi \
- odoc_exception.cmo odoc_global.cmi odoc_messages.cmo odoc_module.cmo \
- odoc_name.cmi odoc_parameter.cmo odoc_sig.cmi odoc_type.cmo \
- odoc_types.cmi odoc_value.cmo ../parsing/parsetree.cmi ../typing/path.cmi \
- ../typing/predef.cmi ../typing/typedtree.cmi ../typing/types.cmi \
- odoc_ast.cmi
-odoc_ast.cmx: ../parsing/asttypes.cmi ../parsing/location.cmx \
- ../utils/misc.cmx odoc_args.cmx odoc_class.cmx odoc_env.cmx \
- odoc_exception.cmx odoc_global.cmx odoc_messages.cmx odoc_module.cmx \
- odoc_name.cmx odoc_parameter.cmx odoc_sig.cmx odoc_type.cmx \
- odoc_types.cmx odoc_value.cmx ../parsing/parsetree.cmi ../typing/path.cmx \
- ../typing/predef.cmx ../typing/typedtree.cmx ../typing/types.cmx \
- odoc_ast.cmi
-odoc_class.cmo: odoc_name.cmi odoc_parameter.cmo odoc_types.cmi \
- odoc_value.cmo ../typing/types.cmi
-odoc_class.cmx: odoc_name.cmx odoc_parameter.cmx odoc_types.cmx \
- odoc_value.cmx ../typing/types.cmx
-odoc_comments.cmo: odoc_comments_global.cmi odoc_global.cmi odoc_lexer.cmo \
- odoc_messages.cmo odoc_parser.cmi odoc_see_lexer.cmo odoc_text.cmi \
- odoc_types.cmi odoc_comments.cmi
-odoc_comments.cmx: odoc_comments_global.cmx odoc_global.cmx odoc_lexer.cmx \
- odoc_messages.cmx odoc_parser.cmx odoc_see_lexer.cmx odoc_text.cmx \
- odoc_types.cmx odoc_comments.cmi
-odoc_comments_global.cmo: odoc_comments_global.cmi
-odoc_comments_global.cmx: odoc_comments_global.cmi
-odoc_cross.cmo: odoc_class.cmo odoc_exception.cmo odoc_messages.cmo \
- odoc_misc.cmi odoc_module.cmo odoc_name.cmi odoc_parameter.cmo \
- odoc_search.cmi odoc_type.cmo odoc_types.cmi odoc_value.cmo \
- odoc_cross.cmi
-odoc_cross.cmx: odoc_class.cmx odoc_exception.cmx odoc_messages.cmx \
- odoc_misc.cmx odoc_module.cmx odoc_name.cmx odoc_parameter.cmx \
- odoc_search.cmx odoc_type.cmx odoc_types.cmx odoc_value.cmx \
- odoc_cross.cmi
-odoc_dag2html.cmo: odoc_info.cmi odoc_dag2html.cmi
-odoc_dag2html.cmx: odoc_info.cmx odoc_dag2html.cmi
-odoc_dep.cmo: ../tools/depend.cmi odoc_misc.cmi odoc_module.cmo odoc_type.cmo \
- ../parsing/parsetree.cmi
-odoc_dep.cmx: ../tools/depend.cmx odoc_misc.cmx odoc_module.cmx odoc_type.cmx \
- ../parsing/parsetree.cmi
-odoc_dot.cmo: odoc_info.cmi
-odoc_dot.cmx: odoc_info.cmx
-odoc_env.cmo: ../typing/btype.cmi odoc_name.cmi ../typing/path.cmi \
- ../typing/predef.cmi ../typing/printtyp.cmi ../typing/types.cmi \
- odoc_env.cmi
-odoc_env.cmx: ../typing/btype.cmx odoc_name.cmx ../typing/path.cmx \
- ../typing/predef.cmx ../typing/printtyp.cmx ../typing/types.cmx \
- odoc_env.cmi
-odoc_exception.cmo: odoc_name.cmi odoc_types.cmi ../typing/types.cmi
-odoc_exception.cmx: odoc_name.cmx odoc_types.cmx ../typing/types.cmx
-odoc_global.cmo: ../utils/clflags.cmo odoc_global.cmi
-odoc_global.cmx: ../utils/clflags.cmx odoc_global.cmi
-odoc_html.cmo: odoc_dag2html.cmi odoc_info.cmi odoc_messages.cmo \
- odoc_ocamlhtml.cmo odoc_text.cmi
-odoc_html.cmx: odoc_dag2html.cmx odoc_info.cmx odoc_messages.cmx \
- odoc_ocamlhtml.cmx odoc_text.cmx
-odoc_info.cmo: odoc_analyse.cmi odoc_args.cmi odoc_class.cmo odoc_dep.cmo \
- odoc_exception.cmo odoc_global.cmi odoc_messages.cmo odoc_misc.cmi \
- odoc_module.cmo odoc_name.cmi odoc_parameter.cmo odoc_scan.cmo \
- odoc_search.cmi odoc_str.cmi odoc_type.cmo odoc_types.cmi odoc_value.cmo \
- ../typing/printtyp.cmi odoc_info.cmi
-odoc_info.cmx: odoc_analyse.cmx odoc_args.cmx odoc_class.cmx odoc_dep.cmx \
- odoc_exception.cmx odoc_global.cmx odoc_messages.cmx odoc_misc.cmx \
- odoc_module.cmx odoc_name.cmx odoc_parameter.cmx odoc_scan.cmx \
- odoc_search.cmx odoc_str.cmx odoc_type.cmx odoc_types.cmx odoc_value.cmx \
- ../typing/printtyp.cmx odoc_info.cmi
-odoc_latex.cmo: odoc_info.cmi odoc_latex_style.cmo odoc_messages.cmo \
- odoc_to_text.cmo
-odoc_latex.cmx: odoc_info.cmx odoc_latex_style.cmx odoc_messages.cmx \
- odoc_to_text.cmx
-odoc_lexer.cmo: odoc_args.cmi odoc_comments_global.cmi odoc_messages.cmo \
- odoc_parser.cmi
-odoc_lexer.cmx: odoc_args.cmx odoc_comments_global.cmx odoc_messages.cmx \
- odoc_parser.cmx
-odoc_man.cmo: odoc_info.cmi odoc_messages.cmo odoc_misc.cmi
-odoc_man.cmx: odoc_info.cmx odoc_messages.cmx odoc_misc.cmx
-odoc_merge.cmo: odoc_args.cmi odoc_class.cmo odoc_exception.cmo \
- odoc_messages.cmo odoc_module.cmo odoc_name.cmi odoc_parameter.cmo \
- odoc_type.cmo odoc_types.cmi odoc_value.cmo odoc_merge.cmi
-odoc_merge.cmx: odoc_args.cmx odoc_class.cmx odoc_exception.cmx \
- odoc_messages.cmx odoc_module.cmx odoc_name.cmx odoc_parameter.cmx \
- odoc_type.cmx odoc_types.cmx odoc_value.cmx odoc_merge.cmi
-odoc_messages.cmo: ../utils/config.cmi odoc_global.cmi
-odoc_messages.cmx: ../utils/config.cmx odoc_global.cmx
-odoc_misc.cmo: ../typing/btype.cmi ../typing/ctype.cmi ../typing/ident.cmi \
- ../parsing/longident.cmi odoc_messages.cmo odoc_types.cmi \
- ../typing/path.cmi ../typing/printtyp.cmi ../typing/types.cmi \
- odoc_misc.cmi
-odoc_misc.cmx: ../typing/btype.cmx ../typing/ctype.cmx ../typing/ident.cmx \
- ../parsing/longident.cmx odoc_messages.cmx odoc_types.cmx \
- ../typing/path.cmx ../typing/printtyp.cmx ../typing/types.cmx \
- odoc_misc.cmi
-odoc_module.cmo: odoc_class.cmo odoc_exception.cmo odoc_name.cmi \
- odoc_parameter.cmo odoc_type.cmo odoc_types.cmi odoc_value.cmo \
- ../typing/types.cmi
-odoc_module.cmx: odoc_class.cmx odoc_exception.cmx odoc_name.cmx \
- odoc_parameter.cmx odoc_type.cmx odoc_types.cmx odoc_value.cmx \
- ../typing/types.cmx
-odoc_name.cmo: ../typing/ident.cmi ../parsing/longident.cmi \
- ../typing/path.cmi odoc_name.cmi
-odoc_name.cmx: ../typing/ident.cmx ../parsing/longident.cmx \
- ../typing/path.cmx odoc_name.cmi
-odoc_opt.cmo: ../utils/clflags.cmo ../utils/config.cmi ../utils/misc.cmi \
- odoc_analyse.cmi odoc_args.cmi odoc_dot.cmo odoc_global.cmi odoc_html.cmo \
- odoc_info.cmi odoc_latex.cmo odoc_man.cmo odoc_messages.cmo odoc_texi.cmo \
- ../typing/typedtree.cmi
-odoc_opt.cmx: ../utils/clflags.cmx ../utils/config.cmx ../utils/misc.cmx \
- odoc_analyse.cmx odoc_args.cmx odoc_dot.cmx odoc_global.cmx odoc_html.cmx \
- odoc_info.cmx odoc_latex.cmx odoc_man.cmx odoc_messages.cmx odoc_texi.cmx \
- ../typing/typedtree.cmx
-odoc_parameter.cmo: odoc_types.cmi ../typing/types.cmi
-odoc_parameter.cmx: odoc_types.cmx ../typing/types.cmx
-odoc_parser.cmo: odoc_comments_global.cmi odoc_types.cmi odoc_parser.cmi
-odoc_parser.cmx: odoc_comments_global.cmx odoc_types.cmx odoc_parser.cmi
-odoc_scan.cmo: odoc_class.cmo odoc_exception.cmo odoc_module.cmo \
- odoc_type.cmo odoc_types.cmi odoc_value.cmo
-odoc_scan.cmx: odoc_class.cmx odoc_exception.cmx odoc_module.cmx \
- odoc_type.cmx odoc_types.cmx odoc_value.cmx
-odoc_search.cmo: odoc_class.cmo odoc_exception.cmo odoc_module.cmo \
- odoc_name.cmi odoc_parameter.cmo odoc_type.cmo odoc_types.cmi \
- odoc_value.cmo odoc_search.cmi
-odoc_search.cmx: odoc_class.cmx odoc_exception.cmx odoc_module.cmx \
- odoc_name.cmx odoc_parameter.cmx odoc_type.cmx odoc_types.cmx \
- odoc_value.cmx odoc_search.cmi
-odoc_see_lexer.cmo: odoc_parser.cmi
-odoc_see_lexer.cmx: odoc_parser.cmx
-odoc_sig.cmo: ../parsing/asttypes.cmi ../typing/btype.cmi \
- ../parsing/location.cmi ../utils/misc.cmi odoc_args.cmi odoc_class.cmo \
- odoc_env.cmi odoc_exception.cmo odoc_global.cmi odoc_merge.cmi \
- odoc_messages.cmo odoc_misc.cmi odoc_module.cmo odoc_name.cmi \
- odoc_parameter.cmo odoc_type.cmo odoc_types.cmi odoc_value.cmo \
- ../parsing/parsetree.cmi ../typing/path.cmi ../typing/typedtree.cmi \
- ../typing/types.cmi odoc_sig.cmi
-odoc_sig.cmx: ../parsing/asttypes.cmi ../typing/btype.cmx \
- ../parsing/location.cmx ../utils/misc.cmx odoc_args.cmx odoc_class.cmx \
- odoc_env.cmx odoc_exception.cmx odoc_global.cmx odoc_merge.cmx \
- odoc_messages.cmx odoc_misc.cmx odoc_module.cmx odoc_name.cmx \
- odoc_parameter.cmx odoc_type.cmx odoc_types.cmx odoc_value.cmx \
- ../parsing/parsetree.cmi ../typing/path.cmx ../typing/typedtree.cmx \
- ../typing/types.cmx odoc_sig.cmi
-odoc_str.cmo: odoc_exception.cmo odoc_messages.cmo odoc_misc.cmi \
- odoc_name.cmi odoc_type.cmo odoc_value.cmo odoc_str.cmi
-odoc_str.cmx: odoc_exception.cmx odoc_messages.cmx odoc_misc.cmx \
- odoc_name.cmx odoc_type.cmx odoc_value.cmx odoc_str.cmi
-odoc_texi.cmo: odoc_info.cmi odoc_messages.cmo odoc_to_text.cmo
-odoc_texi.cmx: odoc_info.cmx odoc_messages.cmx odoc_to_text.cmx
-odoc_text.cmo: odoc_text_lexer.cmo odoc_text_parser.cmi odoc_text.cmi
-odoc_text.cmx: odoc_text_lexer.cmx odoc_text_parser.cmx odoc_text.cmi
-odoc_text_lexer.cmo: odoc_text_parser.cmi
-odoc_text_lexer.cmx: odoc_text_parser.cmx
-odoc_text_parser.cmo: odoc_types.cmi odoc_text_parser.cmi
-odoc_text_parser.cmx: odoc_types.cmx odoc_text_parser.cmi
-odoc_to_text.cmo: odoc_info.cmi odoc_messages.cmo
-odoc_to_text.cmx: odoc_info.cmx odoc_messages.cmx
-odoc_type.cmo: odoc_name.cmi odoc_types.cmi ../typing/types.cmi
-odoc_type.cmx: odoc_name.cmx odoc_types.cmx ../typing/types.cmx
-odoc_types.cmo: odoc_messages.cmo odoc_types.cmi
-odoc_types.cmx: odoc_messages.cmx odoc_types.cmi
-odoc_value.cmo: odoc_name.cmi odoc_parameter.cmo odoc_types.cmi \
- ../typing/printtyp.cmi ../typing/types.cmi
-odoc_value.cmx: odoc_name.cmx odoc_parameter.cmx odoc_types.cmx \
- ../typing/printtyp.cmx ../typing/types.cmx
-odoc_analyse.cmi: odoc_module.cmo
-odoc_args.cmi: odoc_module.cmo odoc_types.cmi
-odoc_ast.cmi: odoc_module.cmo odoc_name.cmi odoc_sig.cmi \
- ../parsing/parsetree.cmi ../typing/path.cmi ../typing/typedtree.cmi \
- ../typing/types.cmi
-odoc_comments.cmi: odoc_types.cmi
-odoc_cross.cmi: odoc_module.cmo
-odoc_dag2html.cmi: odoc_info.cmi
-odoc_env.cmi: odoc_name.cmi ../typing/types.cmi
-odoc_info.cmi: odoc_class.cmo odoc_exception.cmo odoc_module.cmo \
- odoc_parameter.cmo odoc_search.cmi odoc_type.cmo odoc_types.cmi \
- odoc_value.cmo ../typing/types.cmi
-odoc_merge.cmi: odoc_module.cmo odoc_types.cmi
-odoc_misc.cmi: ../parsing/longident.cmi odoc_types.cmi ../typing/types.cmi
-odoc_name.cmi: ../typing/ident.cmi ../parsing/longident.cmi \
- ../typing/path.cmi
-odoc_parser.cmi: odoc_types.cmi
-odoc_search.cmi: odoc_class.cmo odoc_exception.cmo odoc_module.cmo \
- odoc_type.cmo odoc_types.cmi odoc_value.cmo
-odoc_sig.cmi: odoc_class.cmo odoc_env.cmi odoc_module.cmo odoc_name.cmi \
- odoc_type.cmo odoc_types.cmi ../parsing/parsetree.cmi ../typing/types.cmi
-odoc_str.cmi: odoc_exception.cmo odoc_type.cmo odoc_value.cmo
-odoc_text.cmi: odoc_types.cmi
-odoc_text_parser.cmi: odoc_types.cmi
diff --git a/ocamldoc/Changes.txt b/ocamldoc/Changes.txt
deleted file mode 100644
index 3f432819a3..0000000000
--- a/ocamldoc/Changes.txt
+++ /dev/null
@@ -1,101 +0,0 @@
-Current :
-OK - fixes: some bugs in the text parser
- ( ]} meaning end of code and somehting else instead of end of precode)
-OK - add: in Odoc_info: text_of_string, text_string_of_text, info_of_string
-OK - fix: better output of titles in html (use more the style)
-OK - add: -intro option to use a file content as ocamldoc comment to use as
-OK introduction for LaTeX document and HTML index page
-OK - add: the HTML generator generates the code of the module if available
-OK - add: field m_code for modules, to keep the code of top modules
-OK - fix: display "include Foo" instead of "include module Foo" in Latex, Man, Texi
-OK - fix: not display comments associated to include directives
-OK - fix: bad display of type parameters for class and class types
-- need to fix display of type parameters for inherited classes/class types
-
-
-======
-
-Release 3.05 :
- - added link tags in html header to reference sections and subsections
- in each page (for browser which handle those tags)
- - no titles nor lists in first sentence of text in indexes and latex titles
- - only one table for the titles in HTML output
- - fix of bad comment association for types in .ml files
- - dumps now contain a magic number, checked when dumps are loaded
- - new option -o to use with texi, latex and dot generators
- - new .code CSS class used
- - better output for classes and modules, with their type
- - added texinfo generator, by Olivier Andrieu
- - removed iso generator, which became the odoc_check custom generator
- - link syntax {{:url}text} added to the manual
- - (** comments in code is colorized in ocaml code html pages
- - new class .code in style
- - new generator : -dot . Output dot code to display
- modules or types dependencies.
- - new option -inv-merge-ml-mli to inverse the priority of
- .ml and .mli when merging
- - option -werr becomes -warn-error
- - possibility to define and reference section labels
- Exemple:
- (** {2:mysectionlabel My title bla bla bla} *)
- in module Foo
-
- This section is referenced with {!Foo.mysectionlabel} in
- a comment.
-
-Pre-release 4 :
- - new option -werr to treat ocamldoc warnings as errors
- - new option -hide to remove some modules from complete names,
- (e.g., print ref instead of Pervasives.ref)
- - HTML doc in classic style only contain indexes to existing element kinds
- (i.e. there is no class index if the doc does not contain any class.)
- - First description sentence now stops at the first period followed by a blank,
- or at the first blank line.
- - update of user manual
- - check report generator added (options -iso and -iso-{val|ty|cl|ex|mod})
- - Odoc_info.Scan.scanner base class added
- - support for custom tags (@xxx with xxx not a predefined tag), see manual
- - new classes info in Odoc_html, Odoc_to_text, Odoc_latex, and Odoc_man, which
- contains the functions for printing info structures
- - replacement of modules Odoc_html.Text and Odoc_latex.Text by
- classes Odoc_html.text and Odoc_latex.text to allow the redefinition
- of their methods in custom generators
- - bug fix : a shortcut list can be pu after a blank line
- - improved display of variant constructors, record fields and
- their comments in classic HTML
- - blank lines in comments become <p> in HTML instead of <br>
- - bug fix : there can be blanks between the last item
- and the ending } of a list
- - new option -latextitles
- - number of errors encountered is displayed
- - if at least one error occurs, exit code is not 0
- - more precise error messages
- - bug fix : \n and other blanks are accepted after, for example, {i
-
-Pre-release 3 :
- - option -stars
- - complete paths of executables in the generated Makefile
- - names of executables changed to ocamldoc and ocamldoc.opt
- - better LaTeX output
- - option -sepfiles for LaTeX
- - ocamldoc.sty used by the generated LaTeX
- - ocamldoc.hva added to use Hevea on the generated LaTeX
- - user manual updated
- - {[ ]} marks to put pre-formatted code on more than one line
- - {!Toto.tutu} to add cross references between elements
- - some bug fixes
-
-Rep-release 2 :
-- generator of texinfo files : odoc_texi.cma
-- use of CSS in generated html
-- new option -css-style to provide a different style sheet
-- improved html
-- added more precise titles in generated html pages
-- no more links to unknown elements
-- added indexes
-- simple html : added <LINK ...> in <HEAD> : compliant
- browsers should display quick access to modules and indexes in
- their navigation bar (for example, mozilla 0.9.5 is compliant)
-- '{bone}' doesn't work any more ; a space is required as in '{b one}'.
- Same for {e, {i, and some others marks. Check the manual
-- bug fixes \ No newline at end of file
diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile
deleted file mode 100644
index 772305bc4a..0000000000
--- a/ocamldoc/Makefile
+++ /dev/null
@@ -1,361 +0,0 @@
-#(***********************************************************************)
-#(* OCamldoc *)
-#(* *)
-#(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-#(* *)
-#(* Copyright 2001 Institut National de Recherche en Informatique et *)
-#(* en Automatique. All rights reserved. This file is distributed *)
-#(* under the terms of the Q Public License version 1.0. *)
-#(* *)
-#(***********************************************************************)
-
-# $Id$
-
-include ../config/Makefile
-
-# Various commands and dir
-##########################
-CAMLRUN=../boot/ocamlrun
-OCAMLC = ../ocamlcomp.sh
-OCAMLOPT = ../ocamlcompopt.sh
-OCAMLDEP = $(CAMLRUN) ../tools/ocamldep
-OCAMLLEX = $(CAMLRUN) ../boot/ocamllex
-OCAMLYACC= ../boot/ocamlyacc
-OCAMLLIB = $(LIBDIR)
-OCAMLBIN = $(BINDIR)
-EXTRAC_CRC = $(CAMLRUN) ../otherlibs/dynlink/extract_crc
-
-OCAMLPP=-pp './remove_DEBUG'
-
-# For installation
-##############
-MKDIR=mkdir -p
-CP=cp -f
-OCAMLDOC=ocamldoc
-OCAMLDOC_RUN=sh ./runocamldoc $(SUPPORTS_SHARED_LIBRARIES)
-OCAMLDOC_OPT=$(OCAMLDOC).opt
-OCAMLDOC_LIBCMA=odoc_info.cma
-OCAMLDOC_LIBCMI=odoc_info.cmi
-OCAMLDOC_LIBCMXA=odoc_info.cmxa
-OCAMLDOC_LIBA=odoc_info.a
-INSTALL_LIBDIR=$(OCAMLLIB)/ocamldoc
-INSTALL_BINDIR=$(OCAMLBIN)
-INSTALL_MANODIR=$(MANDIR)/man3
-
-INSTALL_MLIS=odoc_info.mli
-INSTALL_CMIS=$(INSTALL_MLIS:.mli=.cmi)
-
-# Compilation
-#############
-OCAMLSRCDIR=..
-INCLUDES_DEP=-I $(OCAMLSRCDIR)/parsing \
- -I $(OCAMLSRCDIR)/utils \
- -I $(OCAMLSRCDIR)/typing \
- -I $(OCAMLSRCDIR)/driver \
- -I $(OCAMLSRCDIR)/bytecomp \
- -I $(OCAMLSRCDIR)/tools \
- -I $(OCAMLSRCDIR)/toplevel/
-
-INCLUDES_NODEP= -I $(OCAMLSRCDIR)/stdlib \
- -I $(OCAMLSRCDIR)/otherlibs/str \
- -I $(OCAMLSRCDIR)/otherlibs/dynlink \
- -I $(OCAMLSRCDIR)/otherlibs/unix \
- -I $(OCAMLSRCDIR)/otherlibs/num \
- -I $(OCAMLSRCDIR)/otherlibs/graph
-
-INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP)
-
-COMPFLAGS=$(INCLUDES) -warn-error A
-LINKFLAGS=$(INCLUDES)
-
-CMOFILES= odoc_global.cmo\
- odoc_messages.cmo\
- odoc_types.cmo\
- odoc_misc.cmo\
- odoc_text_parser.cmo\
- odoc_text_lexer.cmo\
- odoc_text.cmo\
- odoc_name.cmo\
- odoc_parameter.cmo\
- odoc_value.cmo\
- odoc_type.cmo\
- odoc_exception.cmo\
- odoc_class.cmo\
- odoc_module.cmo\
- odoc_str.cmo\
- odoc_args.cmo\
- odoc_comments_global.cmo\
- odoc_parser.cmo\
- odoc_lexer.cmo\
- odoc_see_lexer.cmo\
- odoc_comments.cmo\
- odoc_env.cmo\
- odoc_merge.cmo\
- odoc_sig.cmo\
- odoc_ast.cmo\
- odoc_control.cmo\
- odoc_inherit.cmo\
- odoc_search.cmo\
- odoc_cross.cmo\
- odoc_dep.cmo\
- odoc_analyse.cmo\
- odoc_scan.cmo\
- odoc_info.cmo
-
-
-CMXFILES= $(CMOFILES:.cmo=.cmx)
-CMIFILES= $(CMOFILES:.cmo=.cmi)
-
-EXECMOFILES=$(CMOFILES)\
- odoc_dag2html.cmo\
- odoc_to_text.cmo\
- odoc_ocamlhtml.cmo\
- odoc_html.cmo\
- odoc_man.cmo\
- odoc_latex_style.cmo \
- odoc_latex.cmo\
- odoc_texi.cmo\
- odoc_dot.cmo
-
-EXECMXFILES= $(EXECMOFILES:.cmo=.cmx)
-EXECMIFILES= $(EXECMOFILES:.cmo=.cmi)
-
-LIBCMOFILES=$(CMOFILES)
-LIBCMXFILES= $(LIBCMOFILES:.cmo=.cmx)
-LIBCMIFILES= $(LIBCMOFILES:.cmo=.cmi)
-
-# Les cmo et cmx de la distrib OCAML
-OCAMLCMOFILES=$(OCAMLSRCDIR)/parsing/printast.cmo \
- $(OCAMLSRCDIR)/typing/ident.cmo \
- $(OCAMLSRCDIR)/utils/tbl.cmo \
- $(OCAMLSRCDIR)/utils/misc.cmo \
- $(OCAMLSRCDIR)/utils/config.cmo \
- $(OCAMLSRCDIR)/utils/clflags.cmo \
- $(OCAMLSRCDIR)/utils/warnings.cmo \
- $(OCAMLSRCDIR)/utils/ccomp.cmo \
- $(OCAMLSRCDIR)/utils/consistbl.cmo \
- $(OCAMLSRCDIR)/parsing/linenum.cmo\
- $(OCAMLSRCDIR)/parsing/location.cmo\
- $(OCAMLSRCDIR)/parsing/longident.cmo \
- $(OCAMLSRCDIR)/parsing/syntaxerr.cmo \
- $(OCAMLSRCDIR)/parsing/parser.cmo \
- $(OCAMLSRCDIR)/parsing/lexer.cmo \
- $(OCAMLSRCDIR)/parsing/parse.cmo \
- $(OCAMLSRCDIR)/typing/types.cmo \
- $(OCAMLSRCDIR)/typing/path.cmo \
- $(OCAMLSRCDIR)/typing/btype.cmo \
- $(OCAMLSRCDIR)/typing/predef.cmo \
- $(OCAMLSRCDIR)/typing/datarepr.cmo \
- $(OCAMLSRCDIR)/typing/subst.cmo \
- $(OCAMLSRCDIR)/typing/env.cmo \
- $(OCAMLSRCDIR)/typing/ctype.cmo \
- $(OCAMLSRCDIR)/typing/primitive.cmo \
- $(OCAMLSRCDIR)/typing/oprint.cmo \
- $(OCAMLSRCDIR)/typing/printtyp.cmo \
- $(OCAMLSRCDIR)/typing/includecore.cmo \
- $(OCAMLSRCDIR)/typing/typetexp.cmo \
- $(OCAMLSRCDIR)/typing/typedtree.cmo \
- $(OCAMLSRCDIR)/typing/parmatch.cmo \
- $(OCAMLSRCDIR)/typing/stypes.cmo \
- $(OCAMLSRCDIR)/typing/typecore.cmo \
- $(OCAMLSRCDIR)/typing/includeclass.cmo \
- $(OCAMLSRCDIR)/typing/typedecl.cmo \
- $(OCAMLSRCDIR)/typing/typeclass.cmo \
- $(OCAMLSRCDIR)/typing/mtype.cmo \
- $(OCAMLSRCDIR)/typing/includemod.cmo \
- $(OCAMLSRCDIR)/typing/typemod.cmo \
- $(OCAMLSRCDIR)/bytecomp/lambda.cmo \
- $(OCAMLSRCDIR)/bytecomp/typeopt.cmo \
- $(OCAMLSRCDIR)/bytecomp/printlambda.cmo \
- $(OCAMLSRCDIR)/bytecomp/switch.cmo \
- $(OCAMLSRCDIR)/bytecomp/matching.cmo \
- $(OCAMLSRCDIR)/bytecomp/translobj.cmo \
- $(OCAMLSRCDIR)/bytecomp/translcore.cmo \
- $(OCAMLSRCDIR)/bytecomp/translclass.cmo \
- $(OCAMLSRCDIR)/tools/depend.cmo
-
-OCAMLCMXFILES=$(OCAMLCMOFILES:.cmo=.cmx)
-
-STDLIB_MLIS=../stdlib/*.mli \
- ../otherlibs/unix/unix.mli \
- ../otherlibs/str/str.mli \
- ../otherlibs/bigarray/bigarray.mli \
- ../otherlibs/num/num.mli
-
-all: exe lib manpages
-exe: $(OCAMLDOC)
-lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI)
-
-opt.opt: exeopt libopt
-exeopt: $(OCAMLDOC_OPT)
-libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI)
-debug:
- make OCAMLPP=""
-
-$(OCAMLDOC): $(EXECMOFILES) odoc_crc.cmo odoc.cmo
- $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) odoc_crc.cmo odoc.cmo
-$(OCAMLDOC_OPT): $(EXECMXFILES) odoc_opt.cmx
- $(OCAMLOPT) -o $@ unix.cmxa str.cmxa $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES) odoc_opt.cmx
-
-$(OCAMLDOC_LIBCMA): $(LIBCMOFILES)
- $(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLCMOFILES) $(LIBCMOFILES)
-$(OCAMLDOC_LIBCMXA): $(LIBCMXFILES)
- $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLCMXFILES) $(LIBCMXFILES)
-
-manpages: stdlib_man/Pervasives.o
-
-odoc_crc.ml: $(CMIFILES)
- $(EXTRAC_CRC) $(INCLUDES) \
- Arg Arith_status Array Big_int Buffer Callback Char Digest Dynlink \
- Filename Format Gc Genlex Hashtbl \
- Lazy Lexing List Map Marshal Nat Nativeint \
- Num Obj CamlinternalOO Outcometree Parsing Pervasives Printexc \
- Printf Profiling Queue Random Ratio \
- Set Sort Stack Std_exit Str Stream \
- String Sys Topdirs Toploop Unix Weak \
- Printast Ident Tbl Misc Config Clflags Warnings Ccomp \
- Linenum Location Longident Syntaxerr Parser Lexer Parse \
- Types Path Btype Predef Datarepr Subst Env Ctype Primitive \
- Oprint Printtyp Includecore Typetexp Parmatch Typedtree Typecore \
- Includeclass Typedecl Typeclass Mtype Includemod Typemod \
- Lambda Typeopt Printlambda Switch Matching Translobj Translcore \
- Bytesections Runtimedef Symtable Opcodes Bytelink Bytelibrarian \
- Translclass Errors Main_args Asttypes Depend \
- Odoc_global Odoc_args Odoc_info Odoc_messages Odoc_types \
- Odoc_misc Odoc_text_parser Odoc_text_lexer \
- Odoc_text Odoc_comments_global Odoc_parser \
- Odoc_lexer Odoc_comments Odoc_name Odoc_parameter \
- Odoc_value Odoc_type Odoc_exception Odoc_class \
- Odoc_module Odoc_str Odoc_args Odoc_env \
- Odoc_sig Odoc_ast Odoc_control Odoc_inherit \
- Odoc_search Odoc_cross Odoc_merge Odoc_analyse \
- Odoc_dag2html Odoc_ocamlhtml Odoc_html Odoc_to_text \
- Odoc_latex_style Odoc_latex Odoc_man Odoc_texi Odoc_scan > $@
-
-# Parsers and lexers dependencies :
-###################################
-odoc_text_parser.ml: odoc_text_parser.mly
-odoc_text_parser.mli: odoc_text_parser.mly
-
-odoc_parser.ml: odoc_parser.mly
-odoc_parser.mli:odoc_parser.mly
-
-odoc_text_lexer.ml: odoc_text_lexer.mll
-
-odoc_lexer.ml:odoc_lexer.mll
-
-odoc_ocamlhtml.ml: odoc_ocamlhtml.mll
-
-odoc_see_lexer.ml: odoc_see_lexer.mll
-
-
-# generic rules :
-#################
-
-.SUFFIXES: .mll .mly .ml .mli .cmo .cmi .cmx
-
-.ml.cmo:
- $(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $<
-
-.mli.cmi:
- $(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $<
-
-.ml.cmx:
- $(OCAMLOPT) $(OCAMLPP) $(COMPFLAGS) -c $<
-
-.mll.ml:
- $(OCAMLLEX) $<
-
-.mly.ml:
- $(OCAMLYACC) -v $<
-
-.mly.mli:
- $(OCAMLYACC) -v $<
-
-# Installation targets
-######################
-install: dummy
- if test -d $(INSTALL_BINDIR); then : ; else $(MKDIR) $(INSTALL_BINDIR); fi
- if test -d $(INSTALL_LIBDIR); then : ; else $(MKDIR) $(INSTALL_LIBDIR); fi
- $(CP) $(OCAMLDOC)$(EXE) $(INSTALL_BINDIR)/$(OCAMLDOC)$(EXE)
- $(CP) ocamldoc.hva *.cmi $(GENERATORS) $(OCAMLDOC_LIBCMA) $(INSTALL_LIBDIR)
- $(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) $(INSTALL_LIBDIR)
- if test -d $(INSTALL_MANODIR); then : ; else $(MKDIR) $(INSTALL_MANODIR); fi
- $(CP) stdlib_man/* $(INSTALL_MANODIR)
-
-installopt:
- if test -f $(OCAMLDOC_OPT) ; then $(MAKE) installopt_really ; fi
-
-installopt_really:
- if test -d $(INSTALL_BINDIR); then : ; else $(MKDIR) $(INSTALL_BINDIR); fi
- if test -d $(INSTALL_LIBDIR); then : ; else $(MKDIR) $(INSTALL_LIBDIR); fi
- $(CP) $(OCAMLDOC_OPT) $(INSTALL_BINDIR)/$(OCAMLDOC_OPT)$(EXE)
- $(CP) ocamldoc.hva $(OCAMLDOC_LIBA) $(OCAMLDOC_LIBCMXA) $(INSTALL_LIBDIR)
- $(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) $(INSTALL_LIBDIR)
-
-# Testing :
-###########
-test: dummy
- $(MKDIR) $@
- $(OCAMLDOC_RUN) -html -colorize-code -sort -d $@ $(INCLUDES) -dump $@/ocamldoc.odoc odoc*.ml odoc*.mli
-
-test_stdlib: dummy
- $(MKDIR) $@
- $(OCAMLDOC_RUN) -html -colorize-code -sort -d $@ $(INCLUDES) -dump $@/stdlib.odoc -keep-code \
- ../stdlib/pervasives.ml ../stdlib/*.mli \
- ../otherlibs/unix/unix.mli \
- ../otherlibs/str/str.mli
-
-test_framed: dummy
- $(MKDIR) $@
- $(OCAMLDOC_RUN) -g odoc_fhtml.cmo -sort -colorize-code -d $@ $(INCLUDES) odoc*.ml odoc*.mli
-
-test_latex: dummy
- $(MKDIR) $@
- $(OCAMLDOC_RUN) -latex -sort -o $@/test.tex -d $@ $(INCLUDES) odoc*.ml odoc*.mli ../stdlib/*.mli ../otherlibs/unix/unix.mli
-
-test_man: dummy
- $(MKDIR) $@
- $(OCAMLDOC_RUN) -man -sort -d $@ $(INCLUDES) odoc*.ml odoc*.mli
-
-test_texi: dummy
- $(MKDIR) $@
- $(OCAMLDOC_RUN) -texi -sort -d $@ $(INCLUDES) odoc*.ml odoc*.mli
-
-stdlib_man/Pervasives.o: $(STDLIB_MLIS)
- $(MKDIR) stdlib_man
- $(OCAMLDOC_RUN) -man -d stdlib_man $(INCLUDES) \
- -t "OCaml library" -man-mini -man-suffix 3o \
- $(STDLIB_MLIS)
-
-autotest_stdlib: dummy
- $(MKDIR) $@
- $(OCAMLDOC_RUN) -g autotest/odoc_test.cmo\
- $(INCLUDES) -keep-code \
- ../stdlib/pervasives.ml ../stdlib/*.mli \
- ../otherlibs/unix/unix.mli \
- ../otherlibs/str/str.mli
-
-# backup, clean and depend :
-############################
-
-clean:: dummy
- @rm -f *~ \#*\#
- @rm -f $(OCAMLDOC)$(EXE) $(OCAMLDOC_OPT) *.cma *.cmxa *.cmo *.cmi *.cmx *.a *.o
- @rm -f odoc_parser.output odoc_text_parser.output
- @rm -f odoc_lexer.ml odoc_text_lexer.ml odoc_see_lexer.ml odoc_ocamlhtml.ml
- @rm -f odoc_parser.ml odoc_parser.mli odoc_text_parser.ml odoc_text_parser.mli odoc_crc.ml
- @rm -rf stdlib_man
-
-depend::
- $(OCAMLYACC) odoc_text_parser.mly
- $(OCAMLYACC) odoc_parser.mly
- $(OCAMLLEX) odoc_text_lexer.mll
- $(OCAMLLEX) odoc_lexer.mll
- $(OCAMLLEX) odoc_ocamlhtml.mll
- $(OCAMLLEX) odoc_see_lexer.mll
- $(OCAMLDEP) $(INCLUDES_DEP) *.mll *.mly *.ml *.mli > .depend
-
-dummy:
-
-include .depend
diff --git a/ocamldoc/Makefile.nt b/ocamldoc/Makefile.nt
deleted file mode 100644
index 470a711f02..0000000000
--- a/ocamldoc/Makefile.nt
+++ /dev/null
@@ -1,344 +0,0 @@
-#(***********************************************************************)
-#(* OCamldoc *)
-#(* *)
-#(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-#(* *)
-#(* Copyright 2001 Institut National de Recherche en Informatique et *)
-#(* en Automatique. All rights reserved. This file is distributed *)
-#(* under the terms of the Q Public License version 1.0. *)
-#(* *)
-#(***********************************************************************)
-
-# $Id$
-
-include ../config/Makefile
-
-CAMLRUN =../boot/ocamlrun
-OCAMLC =$(CAMLRUN) ../ocamlc -warn-error A
-OCAMLOPT =$(CAMLRUN) ../ocamlopt
-OCAMLLEX =$(CAMLRUN) ../boot/ocamllex
-OCAMLYACC=../boot/ocamlyacc
-
-OCAMLLIB = $(LIBDIR)
-OCAMLBIN = $(BINDIR)
-EXTRAC_CRC = $(CAMLRUN) ../otherlibs/dynlink/extract_crc
-
-OCAMLPP=-pp "grep -v DEBUG"
-
-# For installation
-##############
-MKDIR=mkdir
-CP=cp
-OCAMLDOC=ocamldoc
-OCAMLDOC_RUN=$(CAMLRUN) $(OCAMLDOC)
-OCAMLDOC_OPT=$(OCAMLDOC).opt
-OCAMLDOC_LIBCMA=odoc_info.cma
-OCAMLDOC_LIBCMI=odoc_info.cmi
-OCAMLDOC_LIBCMXA=odoc_info.cmxa
-OCAMLDOC_LIBA=odoc_info.$(A)
-INSTALL_LIBDIR=$(OCAMLLIB)/ocamldoc
-INSTALL_BINDIR=$(OCAMLBIN)
-
-INSTALL_MLIS=odoc_info.mli
-INSTALL_CMIS=$(INSTALL_MLIS:.mli=.cmi)
-
-# Compilation
-#############
-OCAMLSRCDIR=..
-INCLUDES_DEP=-I $(OCAMLSRCDIR)/parsing \
- -I $(OCAMLSRCDIR)/utils \
- -I $(OCAMLSRCDIR)/typing \
- -I $(OCAMLSRCDIR)/driver \
- -I $(OCAMLSRCDIR)/bytecomp \
- -I $(OCAMLSRCDIR)/tools \
- -I $(OCAMLSRCDIR)/toplevel/
-
-INCLUDES_NODEP= -I $(OCAMLSRCDIR)/stdlib \
- -I $(OCAMLSRCDIR)/otherlibs/str \
- -I $(OCAMLSRCDIR)/otherlibs/dynlink \
- -I $(OCAMLSRCDIR)/otherlibs/win32unix \
- -I $(OCAMLSRCDIR)/otherlibs/num \
- -I $(OCAMLSRCDIR)/otherlibs/win32graph
-
-INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP)
-
-COMPFLAGS=$(INCLUDES)
-LINKFLAGS=$(INCLUDES)
-
-CMOFILES= odoc_global.cmo\
- odoc_messages.cmo\
- odoc_types.cmo\
- odoc_misc.cmo\
- odoc_text_parser.cmo\
- odoc_text_lexer.cmo\
- odoc_text.cmo\
- odoc_name.cmo\
- odoc_parameter.cmo\
- odoc_value.cmo\
- odoc_type.cmo\
- odoc_exception.cmo\
- odoc_class.cmo\
- odoc_module.cmo\
- odoc_str.cmo\
- odoc_args.cmo\
- odoc_comments_global.cmo\
- odoc_parser.cmo\
- odoc_lexer.cmo\
- odoc_see_lexer.cmo\
- odoc_comments.cmo\
- odoc_env.cmo\
- odoc_merge.cmo\
- odoc_sig.cmo\
- odoc_ast.cmo\
- odoc_control.cmo\
- odoc_inherit.cmo\
- odoc_search.cmo\
- odoc_cross.cmo\
- odoc_dep.cmo\
- odoc_analyse.cmo\
- odoc_scan.cmo\
- odoc_info.cmo
-
-
-CMXFILES= $(CMOFILES:.cmo=.cmx)
-CMIFILES= $(CMOFILES:.cmo=.cmi)
-
-EXECMOFILES=$(CMOFILES)\
- odoc_dag2html.cmo\
- odoc_to_text.cmo\
- odoc_ocamlhtml.cmo\
- odoc_html.cmo\
- odoc_man.cmo\
- odoc_latex_style.cmo \
- odoc_latex.cmo\
- odoc_texi.cmo\
- odoc_dot.cmo\
-
-
-EXECMXFILES= $(EXECMOFILES:.cmo=.cmx)
-EXECMIFILES= $(EXECMOFILES:.cmo=.cmi)
-
-LIBCMOFILES=$(CMOFILES)
-LIBCMXFILES= $(LIBCMOFILES:.cmo=.cmx)
-LIBCMIFILES= $(LIBCMOFILES:.cmo=.cmi)
-
-# Les cmo et cmx de la distrib OCAML
-OCAMLCMOFILES=$(OCAMLSRCDIR)/parsing/printast.cmo \
- $(OCAMLSRCDIR)/typing/ident.cmo \
- $(OCAMLSRCDIR)/utils/tbl.cmo \
- $(OCAMLSRCDIR)/utils/misc.cmo \
- $(OCAMLSRCDIR)/utils/config.cmo \
- $(OCAMLSRCDIR)/utils/clflags.cmo \
- $(OCAMLSRCDIR)/utils/warnings.cmo \
- $(OCAMLSRCDIR)/utils/ccomp.cmo \
- $(OCAMLSRCDIR)/utils/consistbl.cmo \
- $(OCAMLSRCDIR)/parsing/linenum.cmo\
- $(OCAMLSRCDIR)/parsing/location.cmo\
- $(OCAMLSRCDIR)/parsing/longident.cmo \
- $(OCAMLSRCDIR)/parsing/syntaxerr.cmo \
- $(OCAMLSRCDIR)/parsing/parser.cmo \
- $(OCAMLSRCDIR)/parsing/lexer.cmo \
- $(OCAMLSRCDIR)/parsing/parse.cmo \
- $(OCAMLSRCDIR)/typing/types.cmo \
- $(OCAMLSRCDIR)/typing/path.cmo \
- $(OCAMLSRCDIR)/typing/btype.cmo \
- $(OCAMLSRCDIR)/typing/predef.cmo \
- $(OCAMLSRCDIR)/typing/datarepr.cmo \
- $(OCAMLSRCDIR)/typing/subst.cmo \
- $(OCAMLSRCDIR)/typing/env.cmo \
- $(OCAMLSRCDIR)/typing/ctype.cmo \
- $(OCAMLSRCDIR)/typing/primitive.cmo \
- $(OCAMLSRCDIR)/typing/oprint.cmo \
- $(OCAMLSRCDIR)/typing/printtyp.cmo \
- $(OCAMLSRCDIR)/typing/includecore.cmo \
- $(OCAMLSRCDIR)/typing/typetexp.cmo \
- $(OCAMLSRCDIR)/typing/parmatch.cmo \
- $(OCAMLSRCDIR)/typing/typedtree.cmo \
- $(OCAMLSRCDIR)/typing/stypes.cmo \
- $(OCAMLSRCDIR)/typing/typecore.cmo \
- $(OCAMLSRCDIR)/typing/includeclass.cmo \
- $(OCAMLSRCDIR)/typing/typedecl.cmo \
- $(OCAMLSRCDIR)/typing/typeclass.cmo \
- $(OCAMLSRCDIR)/typing/mtype.cmo \
- $(OCAMLSRCDIR)/typing/includemod.cmo \
- $(OCAMLSRCDIR)/typing/typemod.cmo \
- $(OCAMLSRCDIR)/bytecomp/lambda.cmo \
- $(OCAMLSRCDIR)/bytecomp/typeopt.cmo \
- $(OCAMLSRCDIR)/bytecomp/printlambda.cmo \
- $(OCAMLSRCDIR)/bytecomp/switch.cmo \
- $(OCAMLSRCDIR)/bytecomp/matching.cmo \
- $(OCAMLSRCDIR)/bytecomp/translobj.cmo \
- $(OCAMLSRCDIR)/bytecomp/translcore.cmo \
- $(OCAMLSRCDIR)/bytecomp/translclass.cmo \
- $(OCAMLSRCDIR)/tools/depend.cmo
-
-OCAMLCMXFILES=$(OCAMLCMOFILES:.cmo=.cmx)
-
-all: exe lib
-exe: $(OCAMLDOC)
-lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI)
-
-opt.opt: exeopt libopt
-exeopt: $(OCAMLDOC_OPT)
-libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI)
-debug:
- make OCAMLPP=""
-
-$(OCAMLDOC): $(EXECMOFILES) odoc_crc.cmo odoc.cmo
- $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) odoc_crc.cmo odoc.cmo
-$(OCAMLDOC_OPT): $(EXECMXFILES) odoc_opt.cmx
- $(OCAMLOPT) -o $@ unix.cmxa str.cmxa $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES) odoc_opt.cmx
-
-$(OCAMLDOC_LIBCMA): $(LIBCMOFILES)
- $(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLCMOFILES) $(LIBCMOFILES)
-$(OCAMLDOC_LIBCMXA): $(LIBCMXFILES)
- $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLCMXFILES) $(LIBCMXFILES)
-
-odoc_crc.ml: $(CMIFILES)
- $(EXTRAC_CRC) $(INCLUDES)\
- Arg Arith_status Array Big_int Buffer Callback Char Digest Dynlink \
- Filename Format Gc Genlex Hashtbl \
- Lazy Lexing List Map Marshal Nat Nativeint\
- Num Obj CamlinternalOO Outcometree Parsing Pervasives Printexc\
- Printf Profiling Queue Random Ratio\
- Set Sort Stack Std_exit Str Stream\
- String Sys Topdirs Toploop Unix Weak\
- Printast \
- Ident \
- Tbl \
- Misc \
- Config \
- Clflags \
- Warnings \
- Ccomp \
- Linenum\
- Location\
- Longident \
- Syntaxerr \
- Parser \
- Lexer \
- Parse \
- Types \
- Path \
- Btype \
- Predef \
- Datarepr \
- Subst \
- Env \
- Ctype \
- Primitive \
- Oprint \
- Printtyp \
- Includecore \
- Typetexp \
- Parmatch \
- Typedtree \
- Typecore \
- Includeclass \
- Typedecl \
- Typeclass \
- Mtype \
- Includemod \
- Typemod \
- Lambda \
- Typeopt \
- Printlambda \
- Switch \
- Matching \
- Translobj \
- Translcore \
- Bytesections \
- Runtimedef \
- Symtable \
- Opcodes \
- Bytelink \
- Bytelibrarian \
- Translclass \
- Errors \
- Main_args \
- Asttypes \
- Depend \
- Odoc_global Odoc_args Odoc_info Odoc_messages Odoc_types\
- Odoc_misc Odoc_text_parser Odoc_text_lexer\
- Odoc_text Odoc_comments_global Odoc_parser\
- Odoc_lexer Odoc_comments Odoc_name Odoc_parameter\
- Odoc_value Odoc_type Odoc_exception Odoc_class\
- Odoc_module Odoc_str Odoc_args Odoc_env\
- Odoc_sig Odoc_ast Odoc_control Odoc_inherit\
- Odoc_search Odoc_cross Odoc_merge Odoc_analyse\
- Odoc_dag2html Odoc_ocamlhtml Odoc_html Odoc_to_text \
- Odoc_latex_style Odoc_latex Odoc_man Odoc_texi Odoc_scan > $@
-
-# generic rules :
-#################
-
-.SUFFIXES: .mli .ml .cmi .cmo .cmx
-
-.mli.cmi:
- $(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $<
-
-.ml.cmo:
- $(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $<
-
-.ml.cmx:
- $(OCAMLOPT) $(OCAMLPP) $(COMPFLAGS) -c $<
-
-odoc_text_parser.ml odoc_text_parser.mli: odoc_text_parser.mly
- $(OCAMLYACC) odoc_text_parser.mly
-
-odoc_parser.ml odoc_parser.mli: odoc_parser.mly
- $(OCAMLYACC) odoc_parser.mly
-
-odoc_text_lexer.ml: odoc_text_lexer.mll
- $(OCAMLLEX) odoc_text_lexer.mll
-
-odoc_lexer.ml: odoc_lexer.mll
- $(OCAMLLEX) odoc_lexer.mll
-
-odoc_ocamlhtml.ml: odoc_ocamlhtml.mll
- $(OCAMLLEX) odoc_ocamlhtml.mll
-
-odoc_see_lexer.ml: odoc_see_lexer.mll
- $(OCAMLLEX) odoc_see_lexer.mll
-
-# Installation targets
-######################
-install: dummy
- $(MKDIR) -p $(INSTALL_BINDIR)
- $(MKDIR) -p $(INSTALL_LIBDIR)
- $(CP) $(OCAMLDOC) $(INSTALL_BINDIR)/$(OCAMLDOC).exe
- $(CP) ocamldoc.hva *.cmi $(GENERATORS) $(OCAMLDOC_LIBCMA) $(INSTALL_LIBDIR)
- $(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) $(INSTALL_LIBDIR)
-
-installopt:
- if test -f $(OCAMLDOC_OPT); then $(MAKEREC) installopt_really; fi
-
-installopt_really:
- $(MKDIR) -p $(INSTALL_BINDIR)
- $(MKDIR) -p $(INSTALL_LIBDIR)
- $(CP) $(OCAMLDOC_OPT) $(INSTALL_BINDIR)/$(OCAMLDOC_OPT).exe
- $(CP) ocamldoc.hva $(OCAMLDOC_LIBA) $(OCAMLDOC_LIBCMXA) $(INSTALL_LIBDIR)
- $(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) $(INSTALL_LIBDIR)
-
-
-# backup, clean and depend :
-############################
-
-clean:: dummy
- @rm -f *~ /#*/#
- @rm -f $(OCAMLDOC) $(OCAMLDOC_OPT) *.cma *.cmxa *.cmo *.cmi *.cmx *.$(A) *.$(O)
- @rm -f odoc_parser.output odoc_text_parser.output
- @rm -f odoc_lexer.ml odoc_text_lexer.ml odoc_see_lexer.ml odoc_ocamlhtml.ml
- @rm -f odoc_parser.ml odoc_parser.mli odoc_text_parser.ml odoc_text_parser.mli odoc_crc.ml
-
-depend::
- rm -f .depend
- $(OCAMLYACC) odoc_text_parser.mly
- $(OCAMLYACC) odoc_parser.mly
- $(OCAMLLEX) odoc_text_lexer.mll
- $(OCAMLLEX) odoc_lexer.mll
- $(OCAMLDEP) $(INCLUDES_DEP) *.mll *.mly *.ml *.mli > .depend
-
-dummy:
-
-include .depend
diff --git a/ocamldoc/ocamldoc.hva b/ocamldoc/ocamldoc.hva
deleted file mode 100644
index c78417f365..0000000000
--- a/ocamldoc/ocamldoc.hva
+++ /dev/null
@@ -1,10 +0,0 @@
-\usepackage{alltt}
-\newenvironment{ocamldoccode}{\begin{alltt}}{\end{alltt}}
-\newenvironment{ocamldocdescription}{\begin{quote}}{\end{quote}}
-\newenvironment{ocamldoccomment}{\begin{quote}}{\end{quote}}
-\newcommand\textbar{|}
-\newcommand\textbackslash{\begin{rawhtml}\\end{rawhtml}}
-\newcommand\textasciicircum{\^{}}
-\newcommand\sharp{#}
-
-
diff --git a/ocamldoc/ocamldoc.sty b/ocamldoc/ocamldoc.sty
deleted file mode 100644
index e01658b03a..0000000000
--- a/ocamldoc/ocamldoc.sty
+++ /dev/null
@@ -1,60 +0,0 @@
-%% Support macros for LaTeX documentation generated by ocamldoc.
-%% This file is in the public domain; do what you want with it.
-
-\NeedsTeXFormat{LaTeX2e}
-\ProvidesPackage{ocamldoc}
- [2001/12/04 v1.0 ocamldoc support]
-
-\newenvironment{ocamldoccode}{%
- \bgroup
- \leftskip\@totalleftmargin
- \rightskip\z@skip
- \parindent\z@
- \parfillskip\@flushglue
- \parskip\z@skip
- %\noindent
- \@@par\smallskip
- \@tempswafalse
- \def\par{%
- \if@tempswa
- \leavevmode\null\@@par\penalty\interlinepenalty
- \else
- \@tempswatrue
- \ifhmode\@@par\penalty\interlinepenalty\fi
- \fi}
- \obeylines
- \verbatim@font
- \let\org@prime~%
- \@noligs
- \let\org@dospecials\dospecials
- \g@remfrom@specials{\\}
- \g@remfrom@specials{\{}
- \g@remfrom@specials{\}}
- \let\do\@makeother
- \dospecials
- \let\dospecials\org@dospecials
- \frenchspacing\@vobeyspaces
- \everypar \expandafter{\the\everypar \unpenalty}}
-{\egroup\par}
-
-\def\g@remfrom@specials#1{%
- \def\@new@specials{}
- \def\@remove##1{%
- \ifx##1#1\else
- \g@addto@macro\@new@specials{\do ##1}\fi}
- \let\do\@remove\dospecials
- \let\dospecials\@new@specials
- }
-
-\newenvironment{ocamldocdescription}
-{\list{}{\rightmargin0pt \topsep0pt}\raggedright\item\relax}
-{\endlist\medskip}
-
-\newenvironment{ocamldoccomment}
-{\list{}{\leftmargin 2\leftmargini \rightmargin0pt \topsep0pt}\raggedright\item\relax}
-{\endlist}
-
-\let\ocamldocvspace\vspace
-\endinput
-
-
diff --git a/ocamldoc/odoc.ml b/ocamldoc/odoc.ml
deleted file mode 100644
index c8a1d9368a..0000000000
--- a/ocamldoc/odoc.ml
+++ /dev/null
@@ -1,128 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Main module for bytecode. *)
-
-open Config
-open Clflags
-open Misc
-open Format
-open Typedtree
-
-let print_DEBUG s = print_string s ; print_newline ()
-
-(* we check if we must load a module given on the command line *)
-let arg_list = Array.to_list Sys.argv
-let (cmo_or_cma_opt, paths) =
- let rec iter (f_opt, inc) = function
- [] | _ :: [] -> (f_opt, inc)
- | "-g" :: file :: q when
- ((Filename.check_suffix file "cmo") or
- (Filename.check_suffix file "cma")) &
- (f_opt = None) ->
- iter (Some file, inc) q
- | "-i" :: dir :: q ->
- iter (f_opt, inc @ [dir]) q
- | _ :: q ->
- iter (f_opt, inc) q
- in
- iter (None, []) arg_list
-
-let _ = print_DEBUG "Fin analyse des arguments pour le dynamic load"
-
-let _ =
- match cmo_or_cma_opt with
- None ->
- ()
- | Some file ->
- (* initializations for dynamic loading *)
- Dynlink.init ();
- Dynlink.allow_unsafe_modules true;
- try
- Dynlink.add_available_units Odoc_crc.crc_unit_list ;
- let _ = Dynlink.loadfile file in
- ()
- with
- Dynlink.Error e ->
- prerr_endline (Odoc_messages.load_file_error file (Dynlink.error_message e)) ;
- exit 1
- | Not_found ->
- prerr_endline (Odoc_messages.load_file_error file "Not_found");
- exit 1
- | Sys_error s ->
- prerr_endline (Odoc_messages.load_file_error file s);
- exit 1
-
-let _ = print_DEBUG "Fin du chargement dynamique éventuel"
-
-let default_html_generator = new Odoc_html.html
-let default_latex_generator = new Odoc_latex.latex
-let default_texi_generator = new Odoc_texi.texi
-let default_man_generator = new Odoc_man.man
-let default_dot_generator = new Odoc_dot.dot
-let _ = Odoc_args.parse
- (default_html_generator :> Odoc_args.doc_generator)
- (default_latex_generator :> Odoc_args.doc_generator)
- (default_texi_generator :> Odoc_args.doc_generator)
- (default_man_generator :> Odoc_args.doc_generator)
- (default_dot_generator :> Odoc_args.doc_generator)
-
-
-let loaded_modules =
- List.flatten
- (List.map
- (fun f ->
- Odoc_info.verbose (Odoc_messages.loading f);
- try
- let l = Odoc_analyse.load_modules f in
- Odoc_info.verbose Odoc_messages.ok;
- l
- with Failure s ->
- prerr_endline s ;
- incr Odoc_global.errors ;
- []
- )
- !Odoc_args.load
- )
-
-let modules = Odoc_analyse.analyse_files ~init: loaded_modules !Odoc_args.files
-
-let _ =
- match !Odoc_args.dump with
- None -> ()
- | Some f ->
- try Odoc_analyse.dump_modules f modules
- with Failure s ->
- prerr_endline s ;
- incr Odoc_global.errors
-
-let _ =
- match !Odoc_args.doc_generator with
- None ->
- ()
- | Some gen ->
- Odoc_info.verbose Odoc_messages.generating_doc;
- gen#generate modules;
- Odoc_info.verbose Odoc_messages.ok
-
-let _ =
- if !Odoc_global.errors > 0 then
- (
- prerr_endline (Odoc_messages.errors_occured !Odoc_global.errors) ;
- exit 1
- )
- else
- exit 0
-
-
-(* eof $Id$ *)
diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml
deleted file mode 100644
index 0ef95ee9b2..0000000000
--- a/ocamldoc/odoc_analyse.ml
+++ /dev/null
@@ -1,448 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Analysis of source files. This module is strongly inspired from driver/main.ml :-) *)
-
-let print_DEBUG s = print_string s ; print_newline ()
-
-open Config
-open Clflags
-open Misc
-open Format
-open Typedtree
-
-(** Initialize the search path.
- The current directory is always searched first,
- then the directories specified with the -I option (in command-line order),
- then the standard library directory. *)
-let init_path () =
- load_path :=
- "" :: List.rev (Config.standard_library :: !Clflags.include_dirs);
- Env.reset_cache()
-
-(** Return the initial environment in which compilation proceeds. *)
-let initial_env () =
- try
- if !Clflags.nopervasives
- then Env.initial
- else Env.open_pers_signature "Pervasives" Env.initial
- with Not_found ->
- fatal_error "cannot open pervasives.cmi"
-
-(** Optionally preprocess a source file *)
-let preprocess sourcefile =
- match !Clflags.preprocessor with
- None -> sourcefile
- | Some pp ->
- let tmpfile = Filename.temp_file "camlpp" "" in
- let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in
- if Ccomp.command comm <> 0 then begin
- remove_file tmpfile;
- Printf.eprintf "Preprocessing error\n";
- exit 2
- end;
- tmpfile
-
-(** Remove the input file if this file was the result of a preprocessing.*)
-let remove_preprocessed inputfile =
- match !Clflags.preprocessor with
- None -> ()
- | Some _ -> remove_file inputfile
-
-let remove_preprocessed_if_ast inputfile =
- match !Clflags.preprocessor with
- None -> ()
- | Some _ -> if inputfile <> !Location.input_name then remove_file inputfile
-
-exception Outdated_version
-
-(** Parse a file or get a dumped syntax tree in it *)
-let parse_file inputfile parse_fun ast_magic =
- let ic = open_in_bin inputfile in
- let is_ast_file =
- try
- let buffer = String.create (String.length ast_magic) in
- really_input ic buffer 0 (String.length ast_magic);
- if buffer = ast_magic then true
- else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then
- raise Outdated_version
- else false
- with
- Outdated_version ->
- fatal_error "Ocaml and preprocessor have incompatible versions"
- | _ -> false
- in
- let ast =
- try
- if is_ast_file then begin
- Location.input_name := input_value ic;
- input_value ic
- end else begin
- seek_in ic 0;
- Location.input_name := inputfile;
- let lexbuf = Lexing.from_channel ic in
- Location.init lexbuf inputfile;
- parse_fun lexbuf
- end
- with x -> close_in ic; raise x
- in
- close_in ic;
- ast
-
-let (++) x f = f x
-
-(** Analysis of an implementation file. Returns (Some typedtree) if
- no error occured, else None and an error message is printed.*)
-let process_implementation_file ppf sourcefile =
-
- init_path();
- let prefixname = Filename.chop_extension sourcefile in
- let modulename = String.capitalize(Filename.basename prefixname) in
- let inputfile = preprocess sourcefile in
- let env = initial_env () in
- try
- let parsetree = parse_file inputfile Parse.implementation ast_impl_magic_number in
- let typedtree = Typemod.type_implementation sourcefile prefixname modulename env parsetree in
- (Some (parsetree, typedtree), inputfile)
- with
- e ->
- match e with
- Syntaxerr.Error err ->
- fprintf Format.err_formatter "@[%a@]@."
- Syntaxerr.report_error err;
- None, inputfile
- | Failure s ->
- prerr_endline s;
- incr Odoc_global.errors ;
- None, inputfile
- | e ->
- raise e
-
-(** Analysis of an interface file. Returns (Some signature) if
- no error occured, else None and an error message is printed.*)
-let process_interface_file ppf sourcefile =
- init_path();
- let prefixname = Filename.chop_extension sourcefile in
- let modulename = String.capitalize(Filename.basename prefixname) in
- let inputfile = preprocess sourcefile in
- let ast = parse_file inputfile Parse.interface ast_intf_magic_number in
- let sg = Typemod.transl_signature (initial_env()) ast in
- Warnings.check_fatal ();
- (ast, sg, inputfile)
-
-(** The module used to analyse the parsetree and signature of an implementation file.*)
-module Ast_analyser = Odoc_ast.Analyser (Odoc_comments.Basic_info_retriever)
-
-(** The module used to analyse the parse tree and typed tree of an interface file.*)
-module Sig_analyser = Odoc_sig.Analyser (Odoc_comments.Basic_info_retriever)
-
-(** Handle an error. This is a partial copy of the compiler
- driver/error.ml file. We do this because there are
- some differences between the possibly raised exceptions
- in the bytecode (error.ml) and opt (opterros.ml) compilers
- and we don't want to take care of this. Besisdes, this
- differences only concern code generation (i believe).*)
-let process_error exn =
- let report ppf = function
- | Lexer.Error(err, loc) ->
- Location.print ppf loc;
- Lexer.report_error ppf err
- | Syntaxerr.Error err ->
- Syntaxerr.report_error ppf err
- | Env.Error err ->
- Env.report_error ppf err
- | Ctype.Tags(l, l') -> fprintf ppf
- "In this program,@ variant constructors@ `%s and `%s@ \
- have the same hash value." l l'
- | Typecore.Error(loc, err) ->
- Location.print ppf loc; Typecore.report_error ppf err
- | Typetexp.Error(loc, err) ->
- Location.print ppf loc; Typetexp.report_error ppf err
- | Typedecl.Error(loc, err) ->
- Location.print ppf loc; Typedecl.report_error ppf err
- | Includemod.Error err ->
- Includemod.report_error ppf err
- | Typemod.Error(loc, err) ->
- Location.print ppf loc; Typemod.report_error ppf err
- | Translcore.Error(loc, err) ->
- Location.print ppf loc; Translcore.report_error ppf err
- | Sys_error msg ->
- fprintf ppf "I/O error: %s" msg
- | Typeclass.Error(loc, err) ->
- Location.print ppf loc; Typeclass.report_error ppf err
- | Translclass.Error(loc, err) ->
- Location.print ppf loc; Translclass.report_error ppf err
- | Warnings.Errors (n) ->
- fprintf ppf "@.Error: %d error-enabled warnings occurred." n
- | x ->
- fprintf ppf "@]";
- fprintf ppf "Compilation error. Use the OCaml compiler to get more details."
- in
- Format.fprintf Format.err_formatter "@[%a@]@." report exn
-
-(** Process the given file, according to its extension. Return the Module.t created, if any.*)
-let process_file ppf sourcefile =
- if !Odoc_args.verbose then
- (
- print_string (Odoc_messages.analysing sourcefile) ;
- print_newline ();
- );
- if Filename.check_suffix sourcefile "ml" then
- (
- try
- let (parsetree_typedtree_opt, input_file) = process_implementation_file ppf sourcefile in
- match parsetree_typedtree_opt with
- None ->
- None
- | Some (parsetree, typedtree) ->
- let file_module = Ast_analyser.analyse_typed_tree sourcefile !Location.input_name parsetree typedtree in
-
- file_module.Odoc_module.m_top_deps <- Odoc_dep.impl_dependencies parsetree ;
-
- if !Odoc_args.verbose then
- (
- print_string Odoc_messages.ok;
- print_newline ()
- );
- remove_preprocessed input_file;
- Some file_module
- with
- | Sys_error s
- | Failure s ->
- prerr_endline s ;
- incr Odoc_global.errors ;
- None
- | e ->
- process_error e ;
- incr Odoc_global.errors ;
- None
- )
- else
- if Filename.check_suffix sourcefile "mli" then
- (
- try
- let (ast, signat, input_file) = process_interface_file ppf sourcefile in
- let file_module = Sig_analyser.analyse_signature sourcefile !Location.input_name ast signat in
-
- file_module.Odoc_module.m_top_deps <- Odoc_dep.intf_dependencies ast ;
-
- if !Odoc_args.verbose then
- (
- print_string Odoc_messages.ok;
- print_newline ()
- );
- remove_preprocessed input_file;
- Some file_module
- with
- | Sys_error s
- | Failure s ->
- prerr_endline s;
- incr Odoc_global.errors ;
- None
- | e ->
- process_error e ;
- incr Odoc_global.errors ;
- None
- )
- else
- (
- raise (Failure (Odoc_messages.unknown_extension sourcefile))
- )
-
-(** Remove the class elements after the stop special comment. *)
-let rec remove_class_elements_after_stop eles =
- match eles with
- [] -> []
- | ele :: q ->
- match ele with
- Odoc_class.Class_comment [ Odoc_types.Raw "/*" ] -> []
- | Odoc_class.Class_attribute _
- | Odoc_class.Class_method _
- | Odoc_class.Class_comment _ -> ele :: (remove_class_elements_after_stop q)
-
-(** Remove the class elements after the stop special comment in a class kind. *)
-let rec remove_class_elements_after_stop_in_class_kind k =
- match k with
- Odoc_class.Class_structure (inher, l) ->
- Odoc_class.Class_structure (inher, remove_class_elements_after_stop l)
- | Odoc_class.Class_apply _ -> k
- | Odoc_class.Class_constr _ -> k
- | Odoc_class.Class_constraint (k1, ctk) ->
- Odoc_class.Class_constraint (remove_class_elements_after_stop_in_class_kind k1,
- remove_class_elements_after_stop_in_class_type_kind ctk)
-
-(** Remove the class elements after the stop special comment in a class type kind. *)
-and remove_class_elements_after_stop_in_class_type_kind tk =
- match tk with
- Odoc_class.Class_signature (inher, l) ->
- Odoc_class.Class_signature (inher, remove_class_elements_after_stop l)
- | Odoc_class.Class_type _ -> tk
-
-
-(** Remove the module elements after the stop special comment. *)
-let rec remove_module_elements_after_stop eles =
- let f = remove_module_elements_after_stop in
- match eles with
- [] -> []
- | ele :: q ->
- match ele with
- Odoc_module.Element_module_comment [ Odoc_types.Raw "/*" ] -> []
- | Odoc_module.Element_module_comment _ ->
- ele :: (f q)
- | Odoc_module.Element_module m ->
- m.Odoc_module.m_kind <- remove_module_elements_after_stop_in_module_kind m.Odoc_module.m_kind ;
- (Odoc_module.Element_module m) :: (f q)
- | Odoc_module.Element_module_type mt ->
- mt.Odoc_module.mt_kind <- Odoc_misc.apply_opt
- remove_module_elements_after_stop_in_module_type_kind mt.Odoc_module.mt_kind ;
- (Odoc_module.Element_module_type mt) :: (f q)
- | Odoc_module.Element_included_module _ ->
- ele :: (f q)
- | Odoc_module.Element_class c ->
- c.Odoc_class.cl_kind <- remove_class_elements_after_stop_in_class_kind c.Odoc_class.cl_kind ;
- (Odoc_module.Element_class c) :: (f q)
- | Odoc_module.Element_class_type ct ->
- ct.Odoc_class.clt_kind <- remove_class_elements_after_stop_in_class_type_kind ct.Odoc_class.clt_kind ;
- (Odoc_module.Element_class_type ct) :: (f q)
- | Odoc_module.Element_value _
- | Odoc_module.Element_exception _
- | Odoc_module.Element_type _ ->
- ele :: (f q)
-
-
-(** Remove the module elements after the stop special comment, in the given module kind. *)
-and remove_module_elements_after_stop_in_module_kind k =
- match k with
- | Odoc_module.Module_struct l -> Odoc_module.Module_struct (remove_module_elements_after_stop l)
- | Odoc_module.Module_alias _ -> k
- | Odoc_module.Module_functor (params, k2) ->
- Odoc_module.Module_functor (params, remove_module_elements_after_stop_in_module_kind k2)
- | Odoc_module.Module_apply (k1, k2) ->
- Odoc_module.Module_apply (remove_module_elements_after_stop_in_module_kind k1,
- remove_module_elements_after_stop_in_module_kind k2)
- | Odoc_module.Module_with (mtkind, s) ->
- Odoc_module.Module_with (remove_module_elements_after_stop_in_module_type_kind mtkind, s)
- | Odoc_module.Module_constraint (k2, mtkind) ->
- Odoc_module.Module_constraint (remove_module_elements_after_stop_in_module_kind k2,
- remove_module_elements_after_stop_in_module_type_kind mtkind)
-
-(** Remove the module elements after the stop special comment, in the given module type kind. *)
-and remove_module_elements_after_stop_in_module_type_kind tk =
- match tk with
- | Odoc_module.Module_type_struct l -> Odoc_module.Module_type_struct (remove_module_elements_after_stop l)
- | Odoc_module.Module_type_functor (params, tk2) ->
- Odoc_module.Module_type_functor (params, remove_module_elements_after_stop_in_module_type_kind tk2)
- | Odoc_module.Module_type_alias _ -> tk
- | Odoc_module.Module_type_with (tk2, s) ->
- Odoc_module.Module_type_with (remove_module_elements_after_stop_in_module_type_kind tk2, s)
-
-
-(** Remove elements after the stop special comment. *)
-let remove_elements_after_stop module_list =
- List.map
- (fun m ->
- m.Odoc_module.m_kind <- remove_module_elements_after_stop_in_module_kind m.Odoc_module.m_kind;
- m
- )
- module_list
-
-(** This function builds the modules from the given list of source files. *)
-let analyse_files ?(init=[]) files =
- let modules_pre =
- init @
- (List.fold_left
- (fun acc -> fun file ->
- try
- match process_file Format.err_formatter file with
- None ->
- acc
- | Some m ->
- acc @ [ m ]
- with
- Failure s ->
- prerr_endline s ;
- incr Odoc_global.errors ;
- acc
- )
- []
- files
- )
- in
- (* Remove elements after the stop special comments, if needed. *)
- let modules =
- if !Odoc_args.no_stop then
- modules_pre
- else
- remove_elements_after_stop modules_pre
- in
-
-
- if !Odoc_args.verbose then
- (
- print_string Odoc_messages.merging;
- print_newline ()
- );
- let merged_modules = Odoc_merge.merge !Odoc_args.merge_options modules in
- if !Odoc_args.verbose then
- (
- print_string Odoc_messages.ok;
- print_newline ();
- );
- let modules_list =
- (List.fold_left
- (fun acc -> fun m -> acc @ (Odoc_module.module_all_submodules ~trans: false m))
- merged_modules
- merged_modules
- )
- in
- if !Odoc_args.verbose then
- (
- print_string Odoc_messages.cross_referencing;
- print_newline ()
- );
- let _ = Odoc_cross.associate modules_list in
-
- if !Odoc_args.verbose then
- (
- print_string Odoc_messages.ok;
- print_newline ();
- );
-
- if !Odoc_args.sort_modules then
- Sort.list (fun m1 -> fun m2 -> m1.Odoc_module.m_name < m2.Odoc_module.m_name) merged_modules
- else
- merged_modules
-
-let dump_modules file (modules : Odoc_module.t_module list) =
- try
- let chanout = open_out_bin file in
- let dump = Odoc_types.make_dump modules in
- output_value chanout dump;
- close_out chanout
- with
- Sys_error s ->
- raise (Failure s)
-
-let load_modules file =
- try
- let chanin = open_in_bin file in
- let dump = input_value chanin in
- close_in chanin ;
- let (l : Odoc_module.t_module list) = Odoc_types.open_dump dump in
- l
- with
- Sys_error s ->
- raise (Failure s)
-
-
-(* eof $Id$ *)
diff --git a/ocamldoc/odoc_analyse.mli b/ocamldoc/odoc_analyse.mli
deleted file mode 100644
index b1da2aeb10..0000000000
--- a/ocamldoc/odoc_analyse.mli
+++ /dev/null
@@ -1,32 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Analysis of source files. *)
-
-(** This function builds the top modules from the analysis of the
- given list of source files.
- @param init is the list of modules already known from a previous analysis.
-*)
-val analyse_files :
- ?init: Odoc_module.t_module list ->
- string list ->
- Odoc_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_args.ml b/ocamldoc/odoc_args.ml
deleted file mode 100644
index bdd692bc4c..0000000000
--- a/ocamldoc/odoc_args.ml
+++ /dev/null
@@ -1,306 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* cvsid $Id$ *)
-
-(** Command-line arguments. *)
-open Clflags
-
-module M = Odoc_messages
-
-let include_dirs = Clflags.include_dirs
-
-let bytecode_mode = ref true
-
-class type doc_generator =
- object
- method generate : Odoc_module.t_module list -> unit
- end
-
-let doc_generator = ref (None : doc_generator option)
-
-let merge_options = ref ([] : Odoc_types.merge_option list)
-
-let out_file = ref M.default_out_file
-
-let dot_include_all = ref false
-
-let dot_types = ref false
-
-let dot_reduce = ref false
-
-let dot_colors = ref M.default_dot_colors
-
-let man_suffix = ref M.default_man_suffix
-
-let man_mini = ref false
-
-(** Analysis of a string defining options. Return the list of
- options according to the list giving associations between
- [(character, _)] and a list of options. *)
-let analyse_option_string l s =
- List.fold_left
- (fun acc -> fun ((c,_), v) ->
- if String.contains s c then
- acc @ v
- else
- acc)
- []
- l
-
-(** Analysis of a string defining the merge options to be used.
- Returns the list of options specified.*)
-let analyse_merge_options s =
- let l = [
- (M.merge_description, [Odoc_types.Merge_description]) ;
- (M.merge_author, [Odoc_types.Merge_author]) ;
- (M.merge_version, [Odoc_types.Merge_version]) ;
- (M.merge_see, [Odoc_types.Merge_see]) ;
- (M.merge_since, [Odoc_types.Merge_since]) ;
- (M.merge_deprecated, [Odoc_types.Merge_deprecated]) ;
- (M.merge_param, [Odoc_types.Merge_param]) ;
- (M.merge_raised_exception, [Odoc_types.Merge_raised_exception]) ;
- (M.merge_return_value, [Odoc_types.Merge_return_value]) ;
- (M.merge_custom, [Odoc_types.Merge_custom]) ;
- (M.merge_all, Odoc_types.all_merge_options)
- ]
- in
- analyse_option_string l s
-
-let classic = Clflags.classic
-
-let dump = ref (None : string option)
-
-let load = ref ([] : string list)
-
-(** Allow arbitrary recursive types. *)
-let recursive_types = Clflags.recursive_types
-
-let verbose = ref false
-
-(** Optional preprocessor command. *)
-let preprocessor = Clflags.preprocessor
-
-let sort_modules = ref false
-
-let no_custom_tags = ref false
-
-let no_stop = ref false
-
-let remove_stars = ref false
-
-let keep_code = ref false
-
-let inverse_merge_ml_mli = ref false
-
-let title = ref (None : string option)
-
-let intro_file = ref (None : string option)
-
-let with_parameter_list = ref false
-
-let hidden_modules = ref ([] : string list)
-
-let target_dir = ref Filename.current_dir_name
-
-let css_style = ref None
-
-let index_only = ref false
-
-let colorize_code = ref false
-
-let with_header = ref true
-
-let with_trailer = ref true
-
-let separate_files = ref false
-
-let latex_titles = ref [
- 1, "section" ;
- 2, "subsection" ;
- 3, "subsubsection" ;
- 4, "paragraph" ;
- 5, "subparagraph" ;
-]
-
-let with_toc = ref true
-
-let with_index = ref true
-
-let esc_8bits = ref false
-
-let info_section = ref "Objective Caml"
-
-let info_entry = ref []
-
-let files = ref []
-
-let f_latex_title s =
- try
- let pos = String.index s ',' in
- let n = int_of_string (String.sub s 0 pos) in
- let len = String.length s in
- let command = String.sub s (pos + 1) (len - pos - 1) in
- latex_titles := List.remove_assoc n !latex_titles ;
- latex_titles := (n, command) :: !latex_titles
- with
- Not_found
- | Invalid_argument _ ->
- incr Odoc_global.errors ;
- prerr_endline (M.wrong_format s)
-
-let add_hidden_modules s =
- let l = Str.split (Str.regexp ",") s in
- List.iter
- (fun n ->
- let name = Str.global_replace (Str.regexp "[ \n\r\t]+") "" n in
- match name with
- "" -> ()
- | _ ->
- match name.[0] with
- 'A'..'Z' -> hidden_modules := name :: !hidden_modules
- | _ ->
- incr Odoc_global.errors;
- prerr_endline (M.not_a_module_name name)
- )
- l
-
-let latex_value_prefix = ref M.default_latex_value_prefix
-let latex_type_prefix = ref M.default_latex_type_prefix
-let latex_exception_prefix = ref M.default_latex_exception_prefix
-let latex_module_prefix = ref M.default_latex_module_prefix
-let latex_module_type_prefix = ref M.default_latex_module_type_prefix
-let latex_class_prefix = ref M.default_latex_class_prefix
-let latex_class_type_prefix = ref M.default_latex_class_type_prefix
-let latex_attribute_prefix = ref M.default_latex_attribute_prefix
-let latex_method_prefix = ref M.default_latex_method_prefix
-
-let set_doc_generator (dg_opt : doc_generator option) = doc_generator := dg_opt
-
-(** The default html generator. Initialized in the parse function, to be used during the command line analysis.*)
-let default_html_generator = ref (None : doc_generator option)
-
-(** The default latex generator. Initialized in the parse function, to be used during the command line analysis.*)
-let default_latex_generator = ref (None : doc_generator option)
-
-(** The default texinfo generator. Initialized in the parse function, to be used during the command line analysis.*)
-let default_texi_generator = ref (None : doc_generator option)
-
-(** The default man pages generator. Initialized in the parse function, to be used during the command line analysis.*)
-let default_man_generator = ref (None : doc_generator option)
-
-(** The default dot generator. Initialized in the parse function, to be used during the command line analysis.*)
-let default_dot_generator = ref (None : doc_generator option)
-
-(** The default option list *)
-let options = ref [
- "-version", Arg.Unit (fun () -> print_string M.message_version ; print_newline () ; exit 0) , M.option_version ;
- "-v", Arg.Unit (fun () -> verbose := true), M.verbose_mode ;
- "-I", Arg.String (fun s -> include_dirs := (Misc.expand_directory Config.standard_library s) :: !include_dirs), M.include_dirs ;
- "-pp", Arg.String (fun s -> preprocessor := Some s), M.preprocess ;
- "-rectypes", Arg.Set recursive_types, M.rectypes ;
- "-nolabels", Arg.Unit (fun () -> classic := true), M.nolabels ;
- "-warn-error", Arg.Set Odoc_global.warn_error, M.werr ;
- "-o", Arg.String (fun s -> out_file := s), M.out_file ;
- "-d", Arg.String (fun s -> target_dir := s), M.target_dir ;
- "-sort", Arg.Unit (fun () -> sort_modules := true), M.sort_modules ;
- "-no-stop", Arg.Set no_stop, M.no_stop ;
- "-no-custom-tags", Arg.Set no_custom_tags, M.no_custom_tags ;
- "-stars", Arg.Set remove_stars, M.remove_stars ;
- "-inv-merge-ml-mli", Arg.Set inverse_merge_ml_mli, M.inverse_merge_ml_mli ;
- "-keep-code", Arg.Set keep_code, M.keep_code^"\n" ;
-
- "-dump", Arg.String (fun s -> dump := Some s), M.dump ;
- "-load", Arg.String (fun s -> load := !load @ [s]), M.load^"\n" ;
-
- "-t", Arg.String (fun s -> title := Some s), M.option_title ;
- "-intro", Arg.String (fun s -> intro_file := Some s), M.option_intro ;
- "-hide", Arg.String add_hidden_modules, M.hide_modules ;
- "-m", Arg.String (fun s -> merge_options := !merge_options @ (analyse_merge_options s)), M.merge_options^"\n" ;
-
-(* generators *)
- "-html", Arg.Unit (fun () -> set_doc_generator !default_html_generator), M.generate_html ;
- "-latex", Arg.Unit (fun () -> set_doc_generator !default_latex_generator), M.generate_latex ;
- "-texi", Arg.Unit (fun () -> set_doc_generator !default_texi_generator), M.generate_texinfo ;
- "-man", Arg.Unit (fun () -> set_doc_generator !default_man_generator), M.generate_man ;
- "-dot", Arg.Unit (fun () -> set_doc_generator !default_dot_generator), M.generate_dot ;
- "-g", Arg.String (fun s -> if !bytecode_mode then () else (prerr_endline (M.option_not_in_native_code "-g"); exit 1)),
- M.load_file^"\n" ;
-
-(* html only options *)
- "-all-params", Arg.Set with_parameter_list, M.with_parameter_list ;
- "-css-style", Arg.String (fun s -> css_style := Some s), M.css_style ;
- "-index-only", Arg.Set index_only, M.index_only ;
- "-colorize-code", Arg.Set colorize_code, M.colorize_code^"\n" ;
-
-(* latex only options *)
- "-noheader", Arg.Unit (fun () -> with_header := false), M.no_header ;
- "-notrailer", Arg.Unit (fun () -> with_trailer := false), M.no_trailer ;
- "-sepfiles", Arg.Set separate_files, M.separate_files ;
- "-latextitle", Arg.String f_latex_title, M.latex_title latex_titles ;
- "-latex-value-prefix", Arg.String (fun s -> latex_value_prefix := s), M.latex_value_prefix ;
- "-latex-type-prefix", Arg.String (fun s -> latex_type_prefix := s), M.latex_type_prefix ;
- "-latex-exception-prefix", Arg.String (fun s -> latex_exception_prefix := s), M.latex_exception_prefix ;
- "-latex-attribute-prefix", Arg.String (fun s -> latex_attribute_prefix := s), M.latex_attribute_prefix ;
- "-latex-method-prefix", Arg.String (fun s -> latex_method_prefix := s), M.latex_method_prefix ;
- "-latex-module-prefix", Arg.String (fun s -> latex_module_prefix := s), M.latex_module_prefix ;
- "-latex-module-type-prefix", Arg.String (fun s -> latex_module_type_prefix := s), M.latex_module_type_prefix ;
- "-latex-class-prefix", Arg.String (fun s -> latex_class_prefix := s), M.latex_class_prefix ;
- "-latex-class-type-prefix", Arg.String (fun s -> latex_class_type_prefix := s), M.latex_class_type_prefix ;
- "-notoc", Arg.Unit (fun () -> with_toc := false), M.no_toc^"\n" ;
-
-(* tex only options *)
- "-noindex", Arg.Clear with_index, M.no_index ;
- "-esc8", Arg.Set esc_8bits, M.esc_8bits ;
- "-info-section", Arg.String ((:=) info_section), M.info_section ;
- "-info-entry", Arg.String (fun s -> info_entry := !info_entry @ [ s ]), M.info_entry ;
-
-(* dot only options *)
- "-dot-colors", Arg.String (fun s -> dot_colors := Str.split (Str.regexp_string ",") s), M.dot_colors ;
- "-dot-include-all", Arg.Set dot_include_all, M.dot_include_all ;
- "-dot-types", Arg.Set dot_types, M.dot_types ;
- "-dot-reduce", Arg.Set dot_reduce, M.dot_reduce ;
-
-(* man only options *)
- "-man-mini", Arg.Set man_mini, M.man_mini ;
- "-man-suffix", Arg.String (fun s -> man_suffix := s), M.man_suffix ;
-
-]
-
-let add_option o =
- let (s,_,_) = o in
- let rec iter = function
- [] -> [o]
- | (s2,f,m) :: q ->
- if s = s2 then
- o :: q
- else
- (s2,f,m) :: (iter q)
- in
- options := iter !options
-
-let parse ~html_generator ~latex_generator ~texi_generator ~man_generator ~dot_generator =
- default_html_generator := Some html_generator ;
- default_latex_generator := Some latex_generator ;
- default_texi_generator := Some texi_generator ;
- default_man_generator := Some man_generator ;
- default_dot_generator := Some dot_generator ;
- let _ = Arg.parse !options
- (fun s -> files := !files @ [s])
- (M.usage^M.options_are)
- in
- (* we sort the hidden modules by name, to be sure that for example,
- A.B is before A, so we will match against A.B before A in
- Odoc_name.hide_modules.*)
- hidden_modules := List.sort (fun a -> fun b -> - (compare a b)) !hidden_modules
-
-
-(* eof $Id$ *)
diff --git a/ocamldoc/odoc_args.mli b/ocamldoc/odoc_args.mli
deleted file mode 100644
index 889f09ce58..0000000000
--- a/ocamldoc/odoc_args.mli
+++ /dev/null
@@ -1,181 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Analysis of the command line arguments. *)
-
-(** The include_dirs in the OCaml compiler. *)
-val include_dirs : string list ref
-
-(** Indicate if we are in bytecode mode or not.
- (For the [ocamldoc] command).*)
-val bytecode_mode : bool ref
-
-(** The class type of documentation generators. *)
-class type doc_generator =
- object method generate : Odoc_module.t_module list -> unit end
-
-(** The function to be used to create a generator. *)
-val doc_generator : doc_generator option ref
-
-(** The merge options to be used. *)
-val merge_options : Odoc_types.merge_option list ref
-
-(** Classic mode or not. *)
-val classic : bool ref
-
-(** The file used by the generators outputting only one file. *)
-val out_file : string ref
-
-(** The optional file name to dump the collected information into.*)
-val dump : string option ref
-
-(** The list of information files to load. *)
-val load : string list ref
-
-(** Verbose mode or not. *)
-val verbose : bool ref
-
-(** We must sort the list of top modules or not.*)
-val sort_modules : bool ref
-
-(** We must not stop at the stop special comments. Default is false (we stop).*)
-val no_stop : bool ref
-
-(** We must raise an exception when we find an unknown @-tag. *)
-val no_custom_tags : bool ref
-
-(** We must remove the the first characters of each comment line, until the first asterisk '*'. *)
-val remove_stars : bool ref
-
-(** To keep the code while merging, when we have both .ml and .mli files for a module. *)
-val keep_code : bool ref
-
-(** To inverse implementation and interface files when merging. *)
-val inverse_merge_ml_mli : bool ref
-
-(** The optional title to use in the generated documentation. *)
-val title : string option ref
-
-(** The optional file whose content can be used as intro text. *)
-val intro_file : string option ref
-
-(** Flag to indicate whether we must display the complete list of parameters
- for functions and methods. *)
-val with_parameter_list : bool ref
-
-(** The list of module names to hide. *)
-val hidden_modules : string list ref
-
-(** The directory where files have to be generated. *)
-val target_dir : string ref
-
-(** An optional file to use where a CSS style is defined (for HTML). *)
-val css_style : string option ref
-
-(** Generate only index files. (for HTML). *)
-val index_only : bool ref
-
-(** To colorize code in HTML generated documentation pages, not code pages. *)
-val colorize_code : bool ref
-
-(** The flag which indicates if we must generate a header (for LaTeX). *)
-val with_header : bool ref
-
-(** The flag which indicates if we must generate a trailer (for LaTeX). *)
-val with_trailer : bool ref
-
-(** The flag to indicate if we must generate one file per module (for LaTeX). *)
-val separate_files : bool ref
-
-(** The list of pairs (title level, sectionning style). *)
-val latex_titles : (int * string) list ref
-
-(** The prefix to use for value labels in LaTeX. *)
-val latex_value_prefix : string ref
-
-(** The prefix to use for type labels in LaTeX. *)
-val latex_type_prefix : string ref
-
-(** The prefix to use for exception labels in LaTeX. *)
-val latex_exception_prefix : string ref
-
-(** The prefix to use for module labels in LaTeX. *)
-val latex_module_prefix : string ref
-
-(** The prefix to use for module type labels in LaTeX. *)
-val latex_module_type_prefix : string ref
-
-(** The prefix to use for class labels in LaTeX. *)
-val latex_class_prefix : string ref
-
-(** The prefix to use for class type labels in LaTeX. *)
-val latex_class_type_prefix : string ref
-
-(** The prefix to use for attribute labels in LaTeX. *)
-val latex_attribute_prefix : string ref
-
-(** The prefix to use for method labels in LaTeX. *)
-val latex_method_prefix : string ref
-
-(** The flag which indicates if we must generate a table of contents (for LaTeX). *)
-val with_toc : bool ref
-
-(** The flag which indicates if we must generate an index (for TeXinfo). *)
-val with_index : bool ref
-
-(** The flag which indicates if we must escape accentuated characters (for TeXinfo).*)
-val esc_8bits : bool ref
-
-(** The Info directory section *)
-val info_section : string ref
-
-(** The Info directory entries to insert *)
-val info_entry : string list ref
-
-(** Include all modules or only the ones on the command line, for the dot ouput. *)
-val dot_include_all : bool ref
-
-(** Generate dependency graph for types. *)
-val dot_types : bool ref
-
-(** Perform transitive reduction before dot output. *)
-val dot_reduce : bool ref
-
-(** The colors used in the dot output. *)
-val dot_colors : string list ref
-
-(** The suffix for man pages. *)
-val man_suffix : string ref
-
-(** The flag to generate all man pages or only for modules and classes.*)
-val man_mini : bool ref
-
-(** The files to be analysed. *)
-val files : string list ref
-
-(** To set the documentation generator. *)
-val set_doc_generator : doc_generator option -> unit
-
-(** Add an option specification. *)
-val add_option : string * Arg.spec * string -> unit
-
-(** Parse the args.
- [byte] indicate if we are in bytecode mode (default is [true]).*)
-val parse :
- html_generator:doc_generator ->
- latex_generator:doc_generator ->
- texi_generator:doc_generator ->
- man_generator:doc_generator ->
- dot_generator:doc_generator ->
- unit
-
diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml
deleted file mode 100644
index 8085ca1cb4..0000000000
--- a/ocamldoc/odoc_ast.ml
+++ /dev/null
@@ -1,1536 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Analysis of implementation files. *)
-open Misc
-open Asttypes
-open Types
-open Typedtree
-
-let print_DEBUG3 s = print_string s ; print_newline ();;
-let print_DEBUG s = print_string s ; print_newline ();;
-
-type typedtree = (Typedtree.structure * Typedtree.module_coercion)
-
-module Name = Odoc_name
-open Odoc_parameter
-open Odoc_value
-open Odoc_type
-open Odoc_exception
-open Odoc_class
-open Odoc_module
-open Odoc_types
-
-(** This variable contains the regular expression representing a blank.*)
-let blank = "[ \010\013\009\012']"
-(** This variable contains the regular expression representing a blank but not a '\n'.*)
-let simple_blank = "[ \013\009\012]"
-
-
-(** This module is used to search for structure items by name in a Typedtree.structure.
- One function creates two hash tables, which can then be used to search for elements.
- Class elements do not use tables.
-*)
-module Typedtree_search =
- struct
- type ele =
- | M of string
- | MT of string
- | T of string
- | C of string
- | CT of string
- | E of string
- | ER of string
- | P of string
- | IM of string
-
- type tab = (ele, Typedtree.structure_item) Hashtbl.t
- type tab_values = (Odoc_module.Name.t, Typedtree.pattern * Typedtree.expression) Hashtbl.t
-
- let iter_val_pattern = function
- | Typedtree.Tpat_any -> None
- | Typedtree.Tpat_var name -> Some (Name.from_ident name)
- | Typedtree.Tpat_tuple _ -> None (* A VOIR quand on traitera les tuples *)
- | _ -> None
-
- let add_to_hashes table table_values tt =
- match tt with
- | Typedtree.Tstr_module (ident, _) ->
- Hashtbl.add table (M (Name.from_ident ident)) tt
- | Typedtree.Tstr_recmodule mods ->
- List.iter
- (fun (ident,mod_expr) ->
- Hashtbl.add table (M (Name.from_ident ident))
- (Typedtree.Tstr_module (ident,mod_expr))
- )
- mods
- | Typedtree.Tstr_modtype (ident, _) ->
- Hashtbl.add table (MT (Name.from_ident ident)) tt
- | Typedtree.Tstr_exception (ident, _) ->
- Hashtbl.add table (E (Name.from_ident ident)) tt
- | Typedtree.Tstr_exn_rebind (ident, _) ->
- Hashtbl.add table (ER (Name.from_ident ident)) tt
- | Typedtree.Tstr_type ident_type_decl_list ->
- List.iter
- (fun (id, e) ->
- Hashtbl.add table (T (Name.from_ident id))
- (Typedtree.Tstr_type [(id,e)]))
- ident_type_decl_list
- | Typedtree.Tstr_class info_list ->
- List.iter
- (fun ((id,_,_,_) as ci) ->
- Hashtbl.add table (C (Name.from_ident id))
- (Typedtree.Tstr_class [ci]))
- info_list
- | Typedtree.Tstr_cltype info_list ->
- List.iter
- (fun ((id,_) as ci) ->
- Hashtbl.add table
- (CT (Name.from_ident id))
- (Typedtree.Tstr_cltype [ci]))
- info_list
- | Typedtree.Tstr_value (_, pat_exp_list) ->
- List.iter
- (fun (pat,exp) ->
- match iter_val_pattern pat.Typedtree.pat_desc with
- None -> ()
- | Some n -> Hashtbl.add table_values n (pat,exp)
- )
- pat_exp_list
- | Typedtree.Tstr_primitive (ident, _) ->
- Hashtbl.add table (P (Name.from_ident ident)) tt
- | Typedtree.Tstr_open _ -> ()
- | Typedtree.Tstr_include _ -> ()
- | Typedtree.Tstr_eval _ -> ()
-
- let tables typedtree =
- let t = Hashtbl.create 13 in
- let t_values = Hashtbl.create 13 in
- List.iter (add_to_hashes t t_values) typedtree;
- (t, t_values)
-
- let search_module table name =
- match Hashtbl.find table (M name) with
- (Typedtree.Tstr_module (_, module_expr)) -> module_expr
- | _ -> assert false
-
- let search_module_type table name =
- match Hashtbl.find table (MT name) with
- | (Typedtree.Tstr_modtype (_, module_type)) -> module_type
- | _ -> assert false
-
- let search_exception table name =
- match Hashtbl.find table (E name) with
- | (Typedtree.Tstr_exception (_, excep_decl)) -> excep_decl
- | _ -> assert false
-
- let search_exception_rebind table name =
- match Hashtbl.find table (ER name) with
- | (Typedtree.Tstr_exn_rebind (_, p)) -> p
- | _ -> assert false
-
- let search_type_declaration table name =
- match Hashtbl.find table (T name) with
- | (Typedtree.Tstr_type [(_,decl)]) -> decl
- | _ -> assert false
-
- let search_class_exp table name =
- match Hashtbl.find table (C name) with
- | (Typedtree.Tstr_class [(_,_,_,ce)]) ->
- (
- try
- let type_decl = search_type_declaration table name in
- (ce, type_decl.Types.type_params)
- with
- Not_found ->
- (ce, [])
- )
- | _ -> assert false
-
- let search_class_type_declaration table name =
- match Hashtbl.find table (CT name) with
- | (Typedtree.Tstr_cltype [(_,cltype_decl)]) -> cltype_decl
- | _ -> assert false
-
- let search_value table name = Hashtbl.find table name
-
- let search_primitive table name =
- match Hashtbl.find table (P name) with
- Tstr_primitive (ident, val_desc) -> val_desc.Types.val_type
- | _ -> assert false
-
- let get_nth_inherit_class_expr cls n =
- let rec iter cpt = function
- | [] ->
- raise Not_found
- | Typedtree.Cf_inher (clexp, _, _) :: q ->
- if n = cpt then clexp else iter (cpt+1) q
- | _ :: q ->
- iter cpt q
- in
- iter 0 cls.Typedtree.cl_field
-
- let search_attribute_type cls name =
- let rec iter = function
- | [] ->
- raise Not_found
- | Typedtree.Cf_val (_, ident, exp) :: q
- when Name.from_ident ident = name ->
- exp.Typedtree.exp_type
- | _ :: q ->
- iter q
- in
- iter cls.Typedtree.cl_field
-
- let search_method_expression cls name =
- let rec iter = function
- | [] ->
- raise Not_found
- | Typedtree.Cf_meth (label, exp) :: q when label = name ->
- exp
- | _ :: q ->
- iter q
- in
- iter cls.Typedtree.cl_field
- end
-
-module Analyser =
- functor (My_ir : Odoc_sig.Info_retriever) ->
-
- struct
- module Sig = Odoc_sig.Analyser (My_ir)
-
- (** This variable is used to load a file as a string and retrieve characters from it.*)
- let file = Sig.file
-
- (** The name of the analysed file. *)
- let file_name = Sig.file_name
-
- (** 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 = Sig.get_string_of_file
-
- (** This function loads the given file in the file global variable.
- and sets file_name.*)
- let prepare_file = Sig.prepare_file
-
- (** The function used to get the comments in a class. *)
- let get_comments_in_class = Sig.get_comments_in_class
-
- (** The function used to get the comments in a module. *)
- let get_comments_in_module = Sig.get_comments_in_module
-
- (** This function takes a parameter pattern and builds the
- corresponding [parameter] structure. The f_desc function
- is used to retrieve a parameter description, if any, from
- a parameter name.
- *)
- let tt_param_info_from_pattern env f_desc pat =
- let rec iter_pattern pat =
- match pat.pat_desc with
- Typedtree.Tpat_var ident ->
- let name = Name.from_ident ident in
- Simple_name { sn_name = name ;
- sn_text = f_desc name ;
- sn_type = Odoc_env.subst_type env pat.pat_type
- }
-
- | Typedtree.Tpat_alias (pat, _) ->
- iter_pattern pat
-
- | Typedtree.Tpat_tuple patlist ->
- Tuple
- (List.map iter_pattern patlist,
- Odoc_env.subst_type env pat.pat_type)
-
- | Typedtree.Tpat_construct (cons_desc, _) when
- (* we give a name to the parameter only if it unit *)
- (match cons_desc.cstr_res.desc with
- Tconstr (p, _, _) ->
- Path.same p Predef.path_unit
- | _ ->
- false)
- ->
- (* a () argument, it never has description *)
- Simple_name { sn_name = "()" ;
- sn_text = None ;
- sn_type = Odoc_env.subst_type env pat.pat_type
- }
-
- | _ ->
- (* implicit pattern matching -> anonymous parameter *)
- Simple_name { sn_name = "()" ;
- sn_text = None ;
- sn_type = Odoc_env.subst_type env pat.pat_type
- }
- in
- iter_pattern pat
-
- (** Analysis of the parameter of a function. Return a list of t_parameter created from
- the (pattern, expression) structures encountered. *)
- let rec tt_analyse_function_parameters env current_comment_opt pat_exp_list =
- match pat_exp_list with
- [] ->
- (* This case means we have a 'function' without pattern, that's impossible *)
- raise (Failure "tt_analyse_function_parameters: 'function' without pattern")
-
- | (pattern_param, exp) :: second_ele :: q ->
- (* implicit pattern matching -> anonymous parameter and no more parameter *)
- (* A VOIR : le label ? *)
- let parameter = Odoc_parameter.Tuple ([], Odoc_env.subst_type env pattern_param.pat_type) in
- [ parameter ]
-
- | (pattern_param, func_body) :: [] ->
- let parameter =
- tt_param_info_from_pattern
- env
- (Odoc_parameter.desc_from_info_opt current_comment_opt)
- pattern_param
-
- in
- (* For optional parameters with a default value, a special treatment is required *)
- (* we look if the name of the parameter we just add is "*opt*", which means
- that there is a let param_name = ... in ... just right now *)
- let (p, next_exp) =
- match parameter with
- Simple_name { sn_name = "*opt*" } ->
- (
- (
- match func_body.exp_desc with
- Typedtree.Texp_let (_, ({pat_desc = Typedtree.Tpat_var id } , exp) :: _, func_body2) ->
- let name = Name.from_ident id in
- let new_param = Simple_name
- { sn_name = name ;
- sn_text = Odoc_parameter.desc_from_info_opt current_comment_opt name ;
- sn_type = Odoc_env.subst_type env exp.exp_type
- }
- in
- (new_param, func_body2)
- | _ ->
- print_DEBUG3 "Pas le bon filtre pour le paramètre optionnel avec valeur par défaut.";
- (parameter, func_body)
- )
- )
- | _ ->
- (parameter, func_body)
- in
- (* continue if the body is still a function *)
- match next_exp.exp_desc with
- Texp_function (pat_exp_list, _) ->
- p :: (tt_analyse_function_parameters env current_comment_opt pat_exp_list)
- | _ ->
- (* something else ; no more parameter *)
- [ p ]
-
- (** Analysis of a Tstr_value from the typedtree. Create and return a list of [t_value].
- @raise Failure if an error occurs.*)
- let tt_analyse_value env current_module_name comment_opt loc pat_exp rec_flag =
- let (pat, exp) = pat_exp in
- match (pat.pat_desc, exp.exp_desc) with
- (Typedtree.Tpat_var ident, Typedtree.Texp_function (pat_exp_list2, partial)) ->
- (* a new function is defined *)
- let name_pre = Name.from_ident ident in
- let name = Name.parens_if_infix name_pre in
- let complete_name = Name.concat current_module_name name in
- (* create the value *)
- let new_value = {
- val_name = complete_name ;
- val_info = comment_opt ;
- val_type = Odoc_env.subst_type env pat.Typedtree.pat_type ;
- val_recursive = rec_flag = Asttypes.Recursive ;
- val_parameters = tt_analyse_function_parameters env comment_opt pat_exp_list2 ;
- val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ;
- val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
- }
- in
- [ new_value ]
-
- | (Typedtree.Tpat_var ident, _) ->
- (* a new value is defined *)
- let name_pre = Name.from_ident ident in
- let name = Name.parens_if_infix name_pre in
- let complete_name = Name.concat current_module_name name in
- let new_value = {
- val_name = complete_name ;
- val_info = comment_opt ;
- val_type = Odoc_env.subst_type env pat.Typedtree.pat_type ;
- val_recursive = rec_flag = Asttypes.Recursive ;
- val_parameters = [] ;
- val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ;
- val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
- }
- in
- [ new_value ]
-
- | (Typedtree.Tpat_tuple lpat, _) ->
- (* new identifiers are defined *)
- (* A VOIR : by now we don't accept to have global variables defined in tuples *)
- []
-
- | _ ->
- (* something else, we don't care ? A VOIR *)
- []
-
- (** This function takes a Typedtree.class_expr and returns a string which can stand for the class name.
- The name can be "object ... end" if the class expression is not an ident or a class constraint or a class apply. *)
- let rec tt_name_of_class_expr clexp =
-(*
- (
- match clexp.Typedtree.cl_desc with
- Tclass_ident _ -> prerr_endline "Tclass_ident"
- | Tclass_structure _ -> prerr_endline "Tclass_structure"
- | Tclass_fun _ -> prerr_endline "Tclass_fun"
- | Tclass_apply _ -> prerr_endline "Tclass_apply"
- | Tclass_let _ -> prerr_endline "Tclass_let"
- | Tclass_constraint _ -> prerr_endline "Tclass_constraint"
- );
-*)
- match clexp.Typedtree.cl_desc with
- Typedtree.Tclass_ident p -> Name.from_path p
- | Typedtree.Tclass_constraint (class_expr, _, _, _)
- | Typedtree.Tclass_apply (class_expr, _) -> tt_name_of_class_expr class_expr
-(*
- | Typedtree.Tclass_fun (_, _, class_expr, _) -> tt_name_of_class_expr class_expr
- | Typedtree.Tclass_let (_,_,_, class_expr) -> tt_name_of_class_expr class_expr
-*)
- | _ -> Odoc_messages.object_end
-
- (** Analysis of a method expression to get the method parameters.
- @param first indicates if we're analysing the method for
- the first time ; in that case we must not keep the first parameter,
- which is "self-*", the object itself.
- *)
- let rec tt_analyse_method_expression env current_method_name comment_opt ?(first=true) exp =
- match exp.Typedtree.exp_desc with
- Typedtree.Texp_function (pat_exp_list, _) ->
- (
- match pat_exp_list with
- [] ->
- (* it is not a function since there are no parameters *)
- (* we can't get here normally *)
- raise (Failure (Odoc_messages.bad_tree^" "^(Odoc_messages.method_without_param current_method_name)))
- | l ->
- match l with
- [] ->
- (* cas impossible, on l'a filtré avant *)
- assert false
- | (pattern_param, exp) :: second_ele :: q ->
- (* implicit pattern matching -> anonymous parameter *)
- (* Note : We can't match this pattern if it is the first call to the function. *)
- let new_param = Simple_name
- { sn_name = "??" ; sn_text = None;
- sn_type = Odoc_env.subst_type env pattern_param.Typedtree.pat_type }
- in
- [ new_param ]
-
- | (pattern_param, body) :: [] ->
- (* if this is the first call to the function, this is the first parameter and we skip it *)
- if not first then
- (
- let parameter =
- tt_param_info_from_pattern
- env
- (Odoc_parameter.desc_from_info_opt comment_opt)
- pattern_param
- in
- (* For optional parameters with a default value, a special treatment is required. *)
- (* We look if the name of the parameter we just add is "*opt*", which means
- that there is a let param_name = ... in ... just right now. *)
- let (current_param, next_exp) =
- match parameter with
- Simple_name { sn_name = "*opt*"} ->
- (
- (
- match body.exp_desc with
- Typedtree.Texp_let (_, ({pat_desc = Typedtree.Tpat_var id } , exp) :: _, body2) ->
- let name = Name.from_ident id in
- let new_param = Simple_name
- { sn_name = name ;
- sn_text = Odoc_parameter.desc_from_info_opt comment_opt name ;
- sn_type = Odoc_env.subst_type env exp.Typedtree.exp_type ;
- }
- in
- (new_param, body2)
- | _ ->
- print_DEBUG3 "Pas le bon filtre pour le paramètre optionnel avec valeur par défaut.";
- (parameter, body)
- )
- )
- | _ ->
- (* no *opt* parameter, we add the parameter then continue *)
- (parameter, body)
- in
- current_param :: (tt_analyse_method_expression env current_method_name comment_opt ~first: false next_exp)
- )
- else
- tt_analyse_method_expression env current_method_name comment_opt ~first: false body
- )
- | _ ->
- (* no more parameter *)
- []
-
- (** Analysis of a [Parsetree.class_struture] and a [Typedtree.class_structure] to get a couple
- (inherited classes, class elements). *)
- let analyse_class_structure env current_class_name tt_class_sig last_pos pos_limit p_cls tt_cls =
- let rec iter acc_inher acc_fields 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 @ [Class_comment t])
- []
- ele_coms
- in
- (acc_inher, acc_fields @ ele_comments)
-
- | (Parsetree.Pcf_inher (p_clexp, _)) :: q ->
- let tt_clexp =
- let n = List.length acc_inher in
- try Typedtree_search.get_nth_inherit_class_expr tt_cls n
- with Not_found -> raise (Failure (Odoc_messages.inherit_classexp_not_found_in_typedtree n))
- in
- let (info_opt, ele_comments) =
- get_comments_in_class last_pos
- p_clexp.Parsetree.pcl_loc.Location.loc_start.Lexing.pos_cnum
- in
- let text_opt = match info_opt with None -> None | Some i -> i.Odoc_types.i_desc in
- let name = tt_name_of_class_expr tt_clexp in
- let inher =
- {
- ic_name = Odoc_env.full_class_or_class_type_name env name ;
- ic_class = None ;
- ic_text = text_opt ;
- }
- in
- iter (acc_inher @ [ inher ]) (acc_fields @ ele_comments)
- p_clexp.Parsetree.pcl_loc.Location.loc_end.Lexing.pos_cnum
- q
-
- | (Parsetree.Pcf_val (label, mutable_flag, expression, loc)) :: q ->
- let complete_name = Name.concat current_class_name label in
- let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
- let type_exp =
- try Typedtree_search.search_attribute_type tt_cls label
- with Not_found -> raise (Failure (Odoc_messages.attribute_not_found_in_typedtree complete_name))
- in
- let att =
- {
- att_value = { val_name = complete_name ;
- val_info = info_opt ;
- val_type = Odoc_env.subst_type env type_exp ;
- val_recursive = false ;
- val_parameters = [] ;
- val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ;
- val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
- } ;
- att_mutable = mutable_flag = Asttypes.Mutable ;
- }
- in
- iter acc_inher (acc_fields @ ele_comments @ [ Class_attribute att ]) loc.Location.loc_end.Lexing.pos_cnum q
-
- | (Parsetree.Pcf_virt (label, private_flag, _, loc)) :: q ->
- let complete_name = Name.concat current_class_name label in
- let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
- let met_type =
- try Odoc_sig.Signature_search.search_method_type label tt_class_sig
- with Not_found -> raise (Failure (Odoc_messages.method_type_not_found current_class_name label))
- in
- let real_type =
- match met_type.Types.desc with
- Tarrow (_, _, t, _) ->
- t
- | _ ->
- (* ?!? : not an arrow type ! return the original type *)
- met_type
- in
- let met =
- {
- met_value = { val_name = complete_name ;
- val_info = info_opt ;
- val_type = Odoc_env.subst_type env real_type ;
- val_recursive = false ;
- val_parameters = [] ;
- val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ;
- val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
- } ;
- met_private = private_flag = Asttypes.Private ;
- met_virtual = true ;
- }
- in
- (* update the parameter description *)
- Odoc_value.update_value_parameters_text met.met_value;
-
- iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end.Lexing.pos_cnum q
-
- | (Parsetree.Pcf_meth (label, private_flag, _, loc)) :: q ->
- let complete_name = Name.concat current_class_name label in
- let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
- let exp =
- try Typedtree_search.search_method_expression tt_cls label
- with Not_found -> raise (Failure (Odoc_messages.method_not_found_in_typedtree complete_name))
- in
- let real_type =
- match exp.exp_type.desc with
- Tarrow (_, _, t,_) ->
- t
- | _ ->
- (* ?!? : not an arrow type ! return the original type *)
- exp.Typedtree.exp_type
- in
- let met =
- {
- met_value = { val_name = complete_name ;
- val_info = info_opt ;
- val_type = Odoc_env.subst_type env real_type ;
- val_recursive = false ;
- val_parameters = tt_analyse_method_expression env complete_name info_opt exp ;
- val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ;
- val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
- } ;
- met_private = private_flag = Asttypes.Private ;
- met_virtual = false ;
- }
- in
- (* update the parameter description *)
- Odoc_value.update_value_parameters_text met.met_value;
-
- iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end.Lexing.pos_cnum q
-
- | Parsetree.Pcf_cstr (_, _, loc) :: q ->
- (* don't give a $*%@ ! *)
- iter acc_inher acc_fields loc.Location.loc_end.Lexing.pos_cnum q
-
- | Parsetree.Pcf_let (_, _, loc) :: q ->
- (* don't give a $*%@ ! *)
- iter acc_inher acc_fields loc.Location.loc_end.Lexing.pos_cnum q
-
- | (Parsetree.Pcf_init exp) :: q ->
- iter acc_inher acc_fields exp.Parsetree.pexp_loc.Location.loc_end.Lexing.pos_cnum q
- in
- iter [] [] last_pos (snd p_cls)
-
- (** Analysis of a [Parsetree.class_expr] and a [Typedtree.class_expr] to get a a couple (class parameters, class kind). *)
- let rec analyse_class_kind env current_class_name comment_opt last_pos p_class_expr tt_class_exp =
- match (p_class_expr.Parsetree.pcl_desc, tt_class_exp.Typedtree.cl_desc) with
- (Parsetree.Pcl_constr (lid, _), tt_class_exp_desc ) ->
- let name =
- match tt_class_exp_desc with
- Typedtree.Tclass_ident p -> Name.from_path p
- | _ ->
- (* we try to get the name from the environment. *)
- (* A VOIR : dommage qu'on n'ait pas un Tclass_ident :-( même quand on a class tutu = toto *)
- Name.from_longident lid
- in
- (* On n'a pas ici les paramètres de type sous forme de Types.type_expr,
- par contre on peut les trouver dans le class_type *)
- let params =
- match tt_class_exp.Typedtree.cl_type with
- Types.Tcty_constr (p2, type_exp_list, cltyp) ->
- (* cltyp is the class type for [type_exp_list] p *)
- type_exp_list
- | _ ->
- []
- in
- ([],
- Class_constr
- {
- cco_name = Odoc_env.full_class_name env name ;
- cco_class = None ;
- cco_type_parameters = List.map (Odoc_env.subst_type env) params ;
- } )
-
- | (Parsetree.Pcl_structure p_class_structure, Typedtree.Tclass_structure tt_class_structure) ->
- (* we need the class signature to get the type of methods in analyse_class_structure *)
- let tt_class_sig =
- match tt_class_exp.Typedtree.cl_type with
- Types.Tcty_signature class_sig -> class_sig
- | _ -> raise (Failure "analyse_class_kind: no class signature for a class structure.")
- in
- let (inherited_classes, class_elements) = analyse_class_structure
- env
- current_class_name
- tt_class_sig
- last_pos
- p_class_expr.Parsetree.pcl_loc.Location.loc_end.Lexing.pos_cnum
- p_class_structure
- tt_class_structure
- in
- ([],
- Class_structure (inherited_classes, class_elements) )
-
- | (Parsetree.Pcl_fun (label, expression_opt, pattern, p_class_expr2),
- Typedtree.Tclass_fun (pat, ident_exp_list, tt_class_expr2, partial)) ->
- (* we check that this is not an optional parameter with
- a default value. In this case, we look for the good parameter pattern *)
- let (parameter, next_tt_class_exp) =
- match pat.Typedtree.pat_desc with
- Typedtree.Tpat_var ident when Name.from_ident ident = "*opt*" ->
- (
- (* there must be a Tclass_let just after *)
- match tt_class_expr2.Typedtree.cl_desc with
- Typedtree.Tclass_let (_, ({pat_desc = Typedtree.Tpat_var id } , exp) :: _, _, tt_class_expr3) ->
- let name = Name.from_ident id in
- let new_param = Simple_name
- { sn_name = name ;
- sn_text = Odoc_parameter.desc_from_info_opt comment_opt name ;
- sn_type = Odoc_env.subst_type env exp.exp_type
- }
- in
- (new_param, tt_class_expr3)
- | _ ->
- (* strange case *)
- (* we create the parameter and add it to the class *)
- raise (Failure "analyse_class_kind: strange case")
- )
- | _ ->
- (* no optional parameter with default value, we create the parameter *)
- let new_param =
- tt_param_info_from_pattern
- env
- (Odoc_parameter.desc_from_info_opt comment_opt)
- pat
- in
- (new_param, tt_class_expr2)
- in
- let (params, k) = analyse_class_kind env current_class_name comment_opt last_pos p_class_expr2 next_tt_class_exp in
- (parameter :: params, k)
-
- | (Parsetree.Pcl_apply (p_class_expr2, _), Tclass_apply (tt_class_expr2, exp_opt_optional_list)) ->
- let applied_name =
- (* we want an ident, or else the class applied will appear in the form object ... end,
- because if the class applied has no name, the code is kinda ugly, isn't it ? *)
- match tt_class_expr2.Typedtree.cl_desc with
- Typedtree.Tclass_ident p -> Name.from_path p (* A VOIR : obtenir le nom complet *)
- | _ ->
- (* A VOIR : dommage qu'on n'ait pas un Tclass_ident :-( même quand on a class tutu = toto *)
- match p_class_expr2.Parsetree.pcl_desc with
- Parsetree.Pcl_constr (lid, _) ->
- (* we try to get the name from the environment. *)
- Name.from_longident lid
- | _ ->
- Odoc_messages.object_end
- in
- let param_exps = List.fold_left
- (fun acc -> fun (exp_opt, _) ->
- match exp_opt with
- None -> acc
- | Some e -> acc @ [e])
- []
- exp_opt_optional_list
- in
- let param_types = List.map (fun e -> e.Typedtree.exp_type) param_exps in
- let params_code =
- List.map
- (fun e -> get_string_of_file
- e.exp_loc.Location.loc_start.Lexing.pos_cnum
- e.exp_loc.Location.loc_end.Lexing.pos_cnum)
- param_exps
- in
- ([],
- Class_apply
- { capp_name = Odoc_env.full_class_name env applied_name ;
- capp_class = None ;
- capp_params = param_types ;
- capp_params_code = params_code ;
- } )
-
- | (Parsetree.Pcl_let (_, _, p_class_expr2), Typedtree.Tclass_let (_, _, _, tt_class_expr2)) ->
- (* we don't care about these lets *)
- analyse_class_kind env current_class_name comment_opt last_pos p_class_expr2 tt_class_expr2
-
- | (Parsetree.Pcl_constraint (p_class_expr2, p_class_type2),
- Typedtree.Tclass_constraint (tt_class_expr2, _, _, _)) ->
- let (l, class_kind) = analyse_class_kind env current_class_name comment_opt last_pos p_class_expr2 tt_class_expr2 in
- (* A VOIR : analyse du class type ? on n'a pas toutes les infos. cf. Odoc_sig.analyse_class_type_kind *)
- let class_type_kind =
- (*Sig.analyse_class_type_kind
- env
- ""
- p_class_type2.Parsetree.pcty_loc.Location.loc_start.Lexing.pos_cnum
- p_class_type2
- tt_class_expr2.Typedtree.cl_type
- *)
- Class_type { cta_name = Odoc_messages.object_end ;
- cta_class = None ; cta_type_parameters = [] }
- in
- (l, Class_constraint (class_kind, class_type_kind))
-
- | _ ->
- raise (Failure "analyse_class_kind: Parsetree and typedtree don't match.")
-
- (** Analysis of a [Parsetree.class_declaration] and a [Typedtree.class_expr] to return a [t_class].*)
- let analyse_class env current_module_name comment_opt p_class_decl tt_type_params tt_class_exp =
- let name = p_class_decl.Parsetree.pci_name in
- let complete_name = Name.concat current_module_name name in
- let pos_start = p_class_decl.Parsetree.pci_expr.Parsetree.pcl_loc.Location.loc_start.Lexing.pos_cnum in
- let type_parameters = tt_type_params in
- let virt = p_class_decl.Parsetree.pci_virt = Asttypes.Virtual in
- let cltype = Odoc_env.subst_class_type env tt_class_exp.Typedtree.cl_type in
- let (parameters, kind) = analyse_class_kind
- env
- complete_name
- comment_opt
- pos_start
- p_class_decl.Parsetree.pci_expr
- tt_class_exp
- in
- let cl =
- {
- cl_name = complete_name ;
- cl_info = comment_opt ;
- cl_type = cltype ;
- cl_virtual = virt ;
- cl_type_parameters = type_parameters ;
- cl_kind = kind ;
- cl_parameters = parameters ;
- cl_loc = { loc_impl = Some (!file_name, pos_start) ; loc_inter = None } ;
- }
- in
- cl
-
- (** Get a name from a module expression, or "struct ... end" if the module expression
- is not an ident of a constraint on an ident. *)
- let rec tt_name_from_module_expr mod_expr =
- match mod_expr.Typedtree.mod_desc with
- Typedtree.Tmod_ident p -> Name.from_path p
- | Typedtree.Tmod_constraint (m_exp, _, _) -> tt_name_from_module_expr m_exp
- | Typedtree.Tmod_structure _
- | Typedtree.Tmod_functor _
- | Typedtree.Tmod_apply _ ->
- Odoc_messages.struct_end
-
- (** Get the list of included modules in a module structure of a typed tree. *)
- let tt_get_included_module_list tt_structure =
- let f acc item =
- match item with
- Typedtree.Tstr_include (mod_expr, _) ->
- acc @ [
- { (* A VOIR : chercher dans les modules et les module types, avec quel env ? *)
- im_name = tt_name_from_module_expr mod_expr ;
- im_module = None ;
- im_info = None ;
- }
- ]
- | _ ->
- acc
- in
- List.fold_left f [] tt_structure
-
- (** This function takes a [module element list] of a module and replaces the "dummy" included modules with
- the ones found in typed tree structure of the module. *)
- let replace_dummy_included_modules module_elements included_modules =
- let rec f = function
- | ([], _) ->
- []
- | ((Element_included_module im) :: q, (im_repl :: im_q)) ->
- (Element_included_module { im_repl with im_info = im.im_info })
- :: (f (q, im_q))
- | ((Element_included_module im) :: q, []) ->
- (Element_included_module im) :: q
- | (ele :: q, l) ->
- ele :: (f (q, l))
- in
- f (module_elements, included_modules)
-
- (** Analysis of a parse tree structure with a typed tree, to return module elements.*)
- let rec analyse_structure env current_module_name last_pos pos_limit parsetree typedtree =
- print_DEBUG "Odoc_ast:analyse_struture";
- let (table, table_values) = Typedtree_search.tables typedtree in
- let rec iter 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
- ele_comments
- | item :: q ->
- let (comment_opt, ele_comments) =
- get_comments_in_module last_pos item.Parsetree.pstr_loc.Location.loc_start.Lexing.pos_cnum
- in
- let pos_limit2 =
- match q with
- [] -> pos_limit
- | item2 :: _ -> item2.Parsetree.pstr_loc.Location.loc_start.Lexing.pos_cnum
- in
- let (maybe_more, new_env, elements) = analyse_structure_item
- env
- current_module_name
- item.Parsetree.pstr_loc
- pos_limit2
- comment_opt
- item.Parsetree.pstr_desc
- typedtree
- table
- table_values
- in
- ele_comments @ elements @ (iter new_env (item.Parsetree.pstr_loc.Location.loc_end.Lexing.pos_cnum + maybe_more) q)
- in
- iter env last_pos parsetree
-
- (** Analysis of a parse tree structure item to obtain a new environment and a list of elements.*)
- and analyse_structure_item env current_module_name loc pos_limit comment_opt parsetree_item_desc typedtree
- table table_values =
- print_DEBUG "Odoc_ast:analyse_struture_item";
- match parsetree_item_desc with
- Parsetree.Pstr_eval _ ->
- (* don't care *)
- (0, env, [])
- | Parsetree.Pstr_value (rec_flag, pat_exp_list) ->
- (* of rec_flag * (pattern * expression) list *)
- (* For each value, look for the value name, then look in the
- typedtree for the corresponding information,
- at last analyse this information to build the value *)
- let rec iter_pat = function
- | Parsetree.Ppat_any -> None
- | Parsetree.Ppat_var name -> Some name
- | Parsetree.Ppat_tuple _ -> None (* A VOIR quand on traitera les tuples *)
- | Parsetree.Ppat_constraint (pat, _) -> iter_pat pat.Parsetree.ppat_desc
- | _ -> None
- in
- let rec iter ?(first=false) last_pos acc_env acc p_e_list =
- match p_e_list with
- [] ->
- (acc_env, acc)
- | (pat, exp) :: q ->
- let value_name_opt = iter_pat pat.Parsetree.ppat_desc in
- let new_last_pos = exp.Parsetree.pexp_loc.Location.loc_end.Lexing.pos_cnum in
- match value_name_opt with
- None ->
- iter new_last_pos acc_env acc q
- | Some name ->
- try
- let pat_exp = Typedtree_search.search_value table_values name in
- let (info_opt, ele_comments) =
- (* we already have the optional comment for the first value. *)
- if first then
- (comment_opt, [])
- else
- get_comments_in_module
- last_pos
- pat.Parsetree.ppat_loc.Location.loc_start.Lexing.pos_cnum
- in
- let l_values = tt_analyse_value
- env
- current_module_name
- info_opt
- loc
- pat_exp
- rec_flag
- in
- let new_env = List.fold_left
- (fun e -> fun v ->
- Odoc_env.add_value e v.val_name
- )
- acc_env
- l_values
- in
- let l_ele = List.map (fun v -> Element_value v) l_values in
- iter
- new_last_pos
- new_env
- (acc @ ele_comments @ l_ele)
- q
- with
- Not_found ->
- iter new_last_pos acc_env acc q
- in
- let (new_env, l_ele) = iter ~first: true loc.Location.loc_start.Lexing.pos_cnum env [] pat_exp_list in
- (0, new_env, l_ele)
-
- | Parsetree.Pstr_primitive (name_pre, val_desc) ->
- (* of string * value_description *)
- print_DEBUG ("Parsetree.Pstr_primitive ("^name_pre^", ["^(String.concat ", " val_desc.Parsetree.pval_prim)^"]");
- let typ = Typedtree_search.search_primitive table name_pre in
- let name = Name.parens_if_infix name_pre in
- let complete_name = Name.concat current_module_name name in
- let new_value = {
- val_name = complete_name ;
- val_info = comment_opt ;
- val_type = Odoc_env.subst_type env typ ;
- val_recursive = false ;
- val_parameters = [] ;
- val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ;
- val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
- }
- in
- let new_env = Odoc_env.add_value env new_value.val_name in
- (0, new_env, [Element_value new_value])
-
- | Parsetree.Pstr_type name_typedecl_list ->
- (* of (string * type_declaration) list *)
- (* we start by extending the environment *)
- let new_env =
- List.fold_left
- (fun acc_env -> fun (name, _) ->
- let complete_name = Name.concat current_module_name name in
- Odoc_env.add_type acc_env complete_name
- )
- env
- name_typedecl_list
- in
- let rec f ?(first=false) maybe_more_acc last_pos name_type_decl_list =
- match name_type_decl_list with
- [] -> (maybe_more_acc, [])
- | (name, type_decl) :: q ->
- let complete_name = Name.concat current_module_name name in
- let loc_start = type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum in
- let loc_end = type_decl.Parsetree.ptype_loc.Location.loc_end.Lexing.pos_cnum in
- let pos_limit2 =
- match q with
- [] -> pos_limit
- | (_, td) :: _ -> td.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum
- in
- let (maybe_more, name_comment_list) =
- Sig.name_comment_from_type_kind
- loc_start loc_end
- pos_limit2
- type_decl.Parsetree.ptype_kind
- in
- let tt_type_decl =
- try Typedtree_search.search_type_declaration table name
- with Not_found -> raise (Failure (Odoc_messages.type_not_found_in_typedtree complete_name))
- in
- let (com_opt, ele_comments) = (* the comment for the first type was already retrieved *)
- if first then
- (comment_opt , [])
- else
- get_comments_in_module last_pos loc_start
- in
- let kind = Sig.get_type_kind
- new_env name_comment_list
- tt_type_decl.Types.type_kind
- in
- let new_end = loc_end + maybe_more in
- let t =
- {
- ty_name = complete_name ;
- ty_info = com_opt ;
- ty_parameters =
- List.map2
- (fun p (co,cn,_) ->
- (Odoc_env.subst_type new_env p,
- co, cn)
- )
- tt_type_decl.Types.type_params
- tt_type_decl.Types.type_variance ;
- ty_kind = kind ;
- ty_manifest =
- (match tt_type_decl.Types.type_manifest with
- None -> None
- | Some t -> Some (Odoc_env.subst_type new_env t));
- ty_loc = { loc_impl = Some (!file_name, loc_start) ; loc_inter = None } ;
- ty_code =
- (
- if !Odoc_args.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
- t.ty_info <- Sig.merge_infos t.ty_info info_after_opt ;
- let (maybe_more3, eles) = f (maybe_more + maybe_more2) (new_end + maybe_more2) q in
- (maybe_more3, ele_comments @ ((Element_type t) :: eles))
- in
- let (maybe_more, eles) = f ~first: true 0 loc.Location.loc_start.Lexing.pos_cnum name_typedecl_list in
- (maybe_more, new_env, eles)
-
- | Parsetree.Pstr_exception (name, excep_decl) ->
- (* a new exception is defined *)
- let complete_name = Name.concat current_module_name name in
- (* we get the exception declaration in the typed tree *)
- let tt_excep_decl =
- try Typedtree_search.search_exception table name
- with Not_found ->
- raise (Failure (Odoc_messages.exception_not_found_in_typedtree complete_name))
- in
- let new_env = Odoc_env.add_exception env complete_name in
- let loc_start = loc.Location.loc_start.Lexing.pos_cnum in
- let loc_end = loc.Location.loc_end.Lexing.pos_cnum in
- let new_ex =
- {
- ex_name = complete_name ;
- ex_info = comment_opt ;
- ex_args = List.map (Odoc_env.subst_type new_env) tt_excep_decl ;
- ex_alias = None ;
- ex_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
- ex_code =
- (
- if !Odoc_args.keep_code then
- Some (get_string_of_file loc_start loc_end)
- else
- None
- ) ;
- }
- in
- (0, new_env, [ Element_exception new_ex ])
-
- | Parsetree.Pstr_exn_rebind (name, _) ->
- (* a new exception is defined *)
- let complete_name = Name.concat current_module_name name in
- (* we get the exception rebind in the typed tree *)
- let tt_path =
- try Typedtree_search.search_exception_rebind table name
- with Not_found ->
- raise (Failure (Odoc_messages.exception_not_found_in_typedtree complete_name))
- in
- let new_env = Odoc_env.add_exception env complete_name in
- let new_ex =
- {
- ex_name = complete_name ;
- ex_info = comment_opt ;
- ex_args = [] ;
- ex_alias = Some { ea_name = (Odoc_env.full_exception_name env (Name.from_path tt_path)) ;
- ea_ex = None ; } ;
- ex_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
- ex_code = None ;
- }
- in
- (0, new_env, [ Element_exception new_ex ])
-
- | Parsetree.Pstr_module (name, module_expr) ->
- (
- (* of string * module_expr *)
- try
- let tt_module_expr = Typedtree_search.search_module table name in
- let new_module = analyse_module
- env
- current_module_name
- name
- comment_opt
- module_expr
- tt_module_expr
- in
- let new_env = Odoc_env.add_module env new_module.m_name in
- let new_env2 =
- match new_module.m_type with
- (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *)
- Types.Tmty_signature s ->
- Odoc_env.add_signature new_env new_module.m_name
- ~rel: (Name.simple new_module.m_name) s
- | _ ->
- new_env
- in
- (0, new_env2, [ Element_module new_module ])
- with
- Not_found ->
- let complete_name = Name.concat current_module_name name in
- raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name))
- )
-
- | Parsetree.Pstr_recmodule mods ->
- let new_env =
- List.fold_left
- (fun acc_env (name, _, mod_exp) ->
- let complete_name = Name.concat current_module_name name in
- let e = Odoc_env.add_module acc_env complete_name in
- let tt_mod_exp =
- try Typedtree_search.search_module table name
- with Not_found -> raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name))
- in
- let new_module = analyse_module
- e
- current_module_name
- name
- None
- mod_exp
- tt_mod_exp
- in
- match new_module.m_type with
- Types.Tmty_signature s ->
- Odoc_env.add_signature e new_module.m_name
- ~rel: (Name.simple new_module.m_name) s
- | _ ->
- e
- )
- env
- mods
- in
- let rec f ?(first=false) last_pos name_mod_exp_list =
- match name_mod_exp_list with
- [] -> []
- | (name, _, mod_exp) :: q ->
- let complete_name = Name.concat current_module_name name in
- let loc_start = mod_exp.Parsetree.pmod_loc.Location.loc_start.Lexing.pos_cnum in
- let loc_end = mod_exp.Parsetree.pmod_loc.Location.loc_end.Lexing.pos_cnum in
- let pos_limit2 =
- match q with
- [] -> pos_limit
- | (_, _, me) :: _ -> me.Parsetree.pmod_loc.Location.loc_start.Lexing.pos_cnum
- in
- let tt_mod_exp =
- try Typedtree_search.search_module table name
- with Not_found -> raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name))
- in
- let (com_opt, ele_comments) = (* the comment for the first type was already retrieved *)
- if first then
- (comment_opt, [])
- else
- get_comments_in_module last_pos loc_start
- in
- let new_module = analyse_module
- new_env
- current_module_name
- name
- com_opt
- mod_exp
- tt_mod_exp
- in
- let eles = f loc_end q in
- ele_comments @ ((Element_module new_module) :: eles)
- in
- let eles = f ~first: true loc.Location.loc_start.Lexing.pos_cnum mods in
- (0, new_env, eles)
-
- | Parsetree.Pstr_modtype (name, modtype) ->
- let complete_name = Name.concat current_module_name name in
- let tt_module_type =
- try Typedtree_search.search_module_type table name
- with Not_found ->
- raise (Failure (Odoc_messages.module_type_not_found_in_typedtree complete_name))
- in
- let kind = Sig.analyse_module_type_kind env complete_name
- modtype tt_module_type
- in
- let mt =
- {
- mt_name = complete_name ;
- mt_info = comment_opt ;
- mt_type = Some tt_module_type ;
- mt_is_interface = false ;
- mt_file = !file_name ;
- mt_kind = Some kind ;
- mt_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
- }
- in
- let new_env = Odoc_env.add_module_type env mt.mt_name in
- let new_env2 =
- match tt_module_type with
- (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on n'aurait pas la signature *)
- Types.Tmty_signature s ->
- Odoc_env.add_signature new_env mt.mt_name ~rel: (Name.simple mt.mt_name) s
- | _ ->
- new_env
- in
- (0, new_env2, [ Element_module_type mt ])
-
- | Parsetree.Pstr_open longident ->
- (* A VOIR : enrichir l'environnement quand open ? *)
- 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.Pstr_class class_decl_list ->
- (* we start by extending the environment *)
- let new_env =
- List.fold_left
- (fun acc_env -> fun class_decl ->
- let complete_name = Name.concat current_module_name class_decl.Parsetree.pci_name in
- Odoc_env.add_class acc_env complete_name
- )
- env
- class_decl_list
- in
- let rec f ?(first=false) last_pos class_decl_list =
- match class_decl_list with
- [] ->
- []
- | class_decl :: q ->
- let (tt_class_exp, tt_type_params) =
- try Typedtree_search.search_class_exp table class_decl.Parsetree.pci_name
- with Not_found ->
- let complete_name = Name.concat current_module_name class_decl.Parsetree.pci_name in
- raise (Failure (Odoc_messages.class_not_found_in_typedtree complete_name))
- in
- let (com_opt, ele_comments) =
- if first then
- (comment_opt, [])
- else
- get_comments_in_module last_pos class_decl.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
- in
- let last_pos2 = class_decl.Parsetree.pci_loc.Location.loc_end.Lexing.pos_cnum in
- let new_class = analyse_class
- new_env
- current_module_name
- com_opt
- class_decl
- tt_type_params
- tt_class_exp
- in
- ele_comments @ ((Element_class new_class) :: (f last_pos2 q))
- in
- (0, new_env, f ~first: true loc.Location.loc_start.Lexing.pos_cnum class_decl_list)
-
- | Parsetree.Pstr_class_type class_type_decl_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 in
- Odoc_env.add_class_type acc_env complete_name
- )
- env
- class_type_decl_list
- in
- let rec f ?(first=false) last_pos class_type_decl_list =
- match class_type_decl_list with
- [] ->
- []
- | class_type_decl :: q ->
- let name = class_type_decl.Parsetree.pci_name in
- let complete_name = Name.concat current_module_name name in
- let virt = class_type_decl.Parsetree.pci_virt = Asttypes.Virtual in
- let tt_cltype_declaration =
- try Typedtree_search.search_class_type_declaration table name
- with Not_found ->
- raise (Failure (Odoc_messages.class_type_not_found_in_typedtree complete_name))
- in
- let type_params = tt_cltype_declaration.Types.clty_params in
- let kind = Sig.analyse_class_type_kind
- new_env
- complete_name
- class_type_decl.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
- class_type_decl.Parsetree.pci_expr
- tt_cltype_declaration.Types.clty_type
- in
- let (com_opt, ele_comments) =
- if first then
- (comment_opt, [])
- else
- get_comments_in_module last_pos class_type_decl.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
- in
- let last_pos2 = class_type_decl.Parsetree.pci_loc.Location.loc_end.Lexing.pos_cnum in
- let new_ele =
- Element_class_type
- {
- clt_name = complete_name ;
- clt_info = com_opt ;
- clt_type = Odoc_env.subst_class_type env tt_cltype_declaration.Types.clty_type ;
- clt_type_parameters = List.map (Odoc_env.subst_type new_env) type_params ;
- clt_virtual = virt ;
- clt_kind = kind ;
- clt_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ;
- loc_inter = None } ;
- }
- in
- ele_comments @ (new_ele :: (f last_pos2 q))
- in
- (0, new_env, f ~first: true loc.Location.loc_start.Lexing.pos_cnum class_type_decl_list)
-
- | Parsetree.Pstr_include module_expr ->
- (* we add a dummy included module which will be replaced by a correct
- one at the end of the module analysis,
- to use the Path.t of the included modules in the typdtree. *)
- let im =
- {
- im_name = "dummy" ;
- im_module = None ;
- im_info = comment_opt ;
- }
- in
- (0, env, [ Element_included_module im ]) (* A VOIR : étendre l'environnement ? avec quoi ? *)
-
- (** Analysis of a [Parsetree.module_expr] and a name to return a [t_module].*)
- and analyse_module env current_module_name module_name comment_opt p_module_expr tt_module_expr =
- let complete_name = Name.concat current_module_name module_name in
- let pos_start = p_module_expr.Parsetree.pmod_loc.Location.loc_start.Lexing.pos_cnum in
- let pos_end = p_module_expr.Parsetree.pmod_loc.Location.loc_end.Lexing.pos_cnum in
- let modtype = tt_module_expr.Typedtree.mod_type in
- let m_base =
- {
- m_name = complete_name ;
- m_type = tt_module_expr.Typedtree.mod_type ;
- m_info = comment_opt ;
- m_is_interface = false ;
- m_file = !file_name ;
- m_kind = Module_struct [] ;
- m_loc = { loc_impl = Some (!file_name, pos_start) ; loc_inter = None } ;
- m_top_deps = [] ;
- m_code = None ;
- }
- in
- match (p_module_expr.Parsetree.pmod_desc, tt_module_expr.Typedtree.mod_desc) with
- (Parsetree.Pmod_ident longident, Typedtree.Tmod_ident path) ->
- let alias_name = Odoc_env.full_module_name env (Name.from_path path) in
- { m_base with m_kind = Module_alias { ma_name = alias_name ;
- ma_module = None ; } }
-
- | (Parsetree.Pmod_structure p_structure, Typedtree.Tmod_structure tt_structure) ->
- let elements = analyse_structure env complete_name pos_start pos_end p_structure tt_structure in
- (* we must complete the included modules *)
- let included_modules_from_tt = tt_get_included_module_list tt_structure in
- let elements2 = replace_dummy_included_modules elements included_modules_from_tt in
- { m_base with m_kind = Module_struct elements2 }
-
- | (Parsetree.Pmod_functor (_, _, p_module_expr2),
- Typedtree.Tmod_functor (ident, mtyp, tt_module_expr2)) ->
- let param =
- {
- mp_name = Name.from_ident ident ;
- mp_type = Odoc_env.subst_module_type env mtyp ;
- }
- in
- let dummy_complete_name = Name.concat "__" param.mp_name in
- let new_env = Odoc_env.add_module env dummy_complete_name in
- let m_base2 = analyse_module
- new_env
- current_module_name
- module_name
- None
- p_module_expr2
- tt_module_expr2
- in
- let kind =
- match m_base2.m_kind with
- Module_functor (params, k) -> Module_functor (param :: params, m_base2.m_kind)
- | k -> Module_functor ([param], k)
- in
- { m_base with m_kind = kind }
-
- | (Parsetree.Pmod_apply (p_module_expr1, p_module_expr2),
- Typedtree.Tmod_apply (tt_module_expr1, tt_module_expr2, _)) ->
- let m1 = analyse_module
- env
- current_module_name
- module_name
- None
- p_module_expr1
- tt_module_expr1
- in
- let m2 = analyse_module
- env
- current_module_name
- module_name
- None
- p_module_expr2
- tt_module_expr2
- in
- { m_base with m_kind = Module_apply (m1.m_kind, m2.m_kind) }
-
- | (Parsetree.Pmod_constraint (p_module_expr2, p_modtype),
- Typedtree.Tmod_constraint (tt_module_expr2, tt_modtype, _)) ->
- (* we create the module with p_module_expr2 and tt_module_expr2
- but we change its type according to the constraint.
- A VOIR : est-ce que c'est bien ?
- *)
- let m_base2 = analyse_module
- env
- current_module_name
- module_name
- None
- p_module_expr2
- tt_module_expr2
- in
- let mtkind = Sig.analyse_module_type_kind
- env
- (Name.concat current_module_name "??")
- p_modtype tt_modtype
- in
- {
- m_base with
- m_type = tt_modtype ;
- m_kind = Module_constraint (m_base2.m_kind,
- mtkind)
-
-(* Module_type_alias { mta_name = "Not analyzed" ;
- mta_module = None })
-*)
- }
-
- | (Parsetree.Pmod_structure p_structure,
- Typedtree.Tmod_constraint
- ({ Typedtree.mod_desc = Typedtree.Tmod_structure tt_structure},
- tt_modtype, _)
- ) ->
- (* needed for recursive modules *)
- let elements = analyse_structure env complete_name pos_start pos_end p_structure tt_structure in
- (* we must complete the included modules *)
- let included_modules_from_tt = tt_get_included_module_list tt_structure in
- let elements2 = replace_dummy_included_modules elements included_modules_from_tt in
- { m_base with m_kind = Module_struct elements2 }
-
- | _ ->
- raise (Failure "analyse_module: parsetree and typedtree don't match.")
-
- let analyse_typed_tree source_file input_file
- (parsetree : Parsetree.structure) (typedtree : typedtree) =
- let (tree_structure, _) = typedtree in
- let complete_source_file =
- try
- let curdir = Sys.getcwd () in
- let (dirname, basename) = (Filename.dirname source_file, Filename.basename source_file) in
- Sys.chdir dirname ;
- let complete = Filename.concat (Sys.getcwd ()) basename in
- Sys.chdir curdir ;
- complete
- with
- Sys_error s ->
- prerr_endline s ;
- incr Odoc_global.errors ;
- source_file
- in
- prepare_file complete_source_file input_file;
- (* We create the t_module for this file. *)
- let mod_name = String.capitalize (Filename.basename (Filename.chop_extension source_file)) in
- let (len,info_opt) = My_ir.first_special !file_name !file in
-
- (* we must complete the included modules *)
- let elements = analyse_structure Odoc_env.empty mod_name len (String.length !file) parsetree tree_structure in
- let included_modules_from_tt = tt_get_included_module_list tree_structure in
- let elements2 = replace_dummy_included_modules elements included_modules_from_tt in
- let kind = Module_struct elements2 in
- let m =
- {
- m_name = mod_name ;
- m_type = Types.Tmty_signature [] ;
- m_info = info_opt ;
- m_is_interface = false ;
- m_file = !file_name ;
- m_kind = kind ;
- m_loc = { loc_impl = Some (!file_name, 0) ; loc_inter = None } ;
- m_top_deps = [] ;
- m_code = Some !file ;
- }
- in
- m
- end
-
-
-
-(* eof $Id$ *)
diff --git a/ocamldoc/odoc_ast.mli b/ocamldoc/odoc_ast.mli
deleted file mode 100644
index 666fa1973e..0000000000
--- a/ocamldoc/odoc_ast.mli
+++ /dev/null
@@ -1,104 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** The module for analysing the typed abstract syntax tree and source code and creating modules, classes, ..., elements.*)
-
-type typedtree = Typedtree.structure * Typedtree.module_coercion
-
-(** This module is used to search for structure items by name in a [Typedtree.structure]. *)
-module Typedtree_search :
- sig
- type ele
-
- type tab = (ele, Typedtree.structure_item) Hashtbl.t
- type tab_values = (Odoc_name.t, Typedtree.pattern * Typedtree.expression) Hashtbl.t
-
- (** Create hash tables used to search by some of the functions below. *)
- val tables : Typedtree.structure_item list -> tab * tab_values
-
- (** This function returns the [Typedtree.module_expr] associated to the given module name,
- in the given table.
- @raise Not_found if the module was not found.*)
- val search_module : tab -> string -> Typedtree.module_expr
-
- (** This function returns the [Types.module_type] associated to the given module type name,
- in the given table.
- @raise Not_found if the module type was not found.*)
- val search_module_type : tab -> string -> Types.module_type
-
- (** This function returns the [Types.exception_declaration] associated to the given exception name,
- in the given table.
- @raise Not_found if the exception was not found.*)
- val search_exception : tab -> string -> Types.exception_declaration
-
- (** This function returns the [Path.t] associated to the given exception rebind name,
- in the table.
- @raise Not_found if the exception rebind was not found.*)
- val search_exception_rebind : tab -> string -> Path.t
-
- (** This function returns the [Typedtree.type_declaration] associated to the given type name,
- in the given table.
- @raise Not_found if the type was not found. *)
- val search_type_declaration : tab -> string -> Types.type_declaration
-
- (** This function returns the [Typedtree.class_expr] and type parameters
- associated to the given class name, in the given table.
- @raise Not_found if the class was not found. *)
- val search_class_exp : tab -> string -> (Typedtree.class_expr * (Types.type_expr list))
-
- (** This function returns the [Types.cltype_declaration] associated to the given class type name,
- in the given table.
- @raise Not_found if the class type was not found. *)
- val search_class_type_declaration : tab -> string -> Types.cltype_declaration
-
- (** This function returns the couple (pat, exp) for the given value name, in the
- given table of values.
- @raise Not found if no value matches the name.*)
- val search_value : tab_values -> string -> Typedtree.pattern * Typedtree.expression
-
- (** This function returns the [type_expr] for the given primitive name, in the
- given table.
- @raise Not found if no value matches the name.*)
- val search_primitive : tab -> string -> Types.type_expr
-
- (** This function returns the [Typedtree.class_expr] associated to
- the n'th inherit in the given class structure of typed tree.
- @raise Not_found if the class expression could not be found.*)
- val get_nth_inherit_class_expr :
- Typedtree.class_structure -> int -> Typedtree.class_expr
-
- (** This function returns the [Types.type_expr] of the attribute
- whose name is given, in a given class structure.
- @raise Not_found if the class attribute could not be found.*)
- val search_attribute_type :
- Typedtree.class_structure -> string -> Types.type_expr
-
- (** This function returns the [Types.expression] of the method whose name is given, in a given class structure.
- @raise Not_found if the class method could not be found.*)
- val search_method_expression :
- Typedtree.class_structure -> string -> Typedtree.expression
- end
-
-(** The module which performs the analysis of a typed tree.
- The module uses the module {!Odoc_sig.Analyser}.
- @param My_ir The module used to retrieve comments and special comments.*)
-module Analyser :
- functor (My_ir : Odoc_sig.Info_retriever) ->
- sig
- (** This function takes a file name, a file containg the code and
- the typed tree obtained from the compiler.
- It goes through the tree, creating values for encountered
- functions, modules, ..., and looking in the source file for comments.*)
- val analyse_typed_tree :
- string -> string -> Parsetree.structure -> typedtree -> Odoc_module.t_module
- end
diff --git a/ocamldoc/odoc_class.ml b/ocamldoc/odoc_class.ml
deleted file mode 100644
index aea0748bfb..0000000000
--- a/ocamldoc/odoc_class.ml
+++ /dev/null
@@ -1,253 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Representation and manipulation of classes and class types.*)
-
-module Name = Odoc_name
-
-(** To keep the order of elements in a class *)
-type class_element =
- Class_attribute of Odoc_value.t_attribute
- | Class_method of Odoc_value.t_method
- | Class_comment of Odoc_types.text
-
-(** Used when we can reference t_class or t_class_type. *)
-type cct =
- Cl of t_class
- | Cltype of t_class_type * Types.type_expr list (** class type and type parameters *)
-
-and 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 : Odoc_types.text option ; (** The inheritance comment, if any *)
- }
-
-and class_apply = {
- capp_name : Name.t ; (** The complete name of the applied class *)
- mutable capp_class : t_class option; (** The associated t_class if we found it *)
- capp_params : Types.type_expr list; (** The type of expressions the class is applied to *)
- capp_params_code : string list ; (** The code of these exprssions *)
- }
-
-and class_constr = {
- cco_name : Name.t ; (** The complete name of the applied class *)
- mutable cco_class : cct option; (** The associated class ot class type if we found it *)
- cco_type_parameters : Types.type_expr list; (** The type parameters of the class, if needed *)
- }
-
-
-and 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....tutu"
- when the class to is defined like this :
- class toto : int -> tutu *)
- | Class_constraint of class_kind * class_type_kind
- (** A class definition with a constraint. *)
-
-(** Representation of a class. *)
-and t_class = {
- cl_name : Name.t ; (** Name of the class *)
- mutable cl_info : Odoc_types.info option ; (** The optional associated user information *)
- cl_type : Types.class_type ;
- cl_type_parameters : Types.type_expr list ; (** Type parameters *)
- cl_virtual : bool ; (** true = virtual *)
- mutable cl_kind : class_kind ;
- mutable cl_parameters : Odoc_parameter.parameter list ;
- mutable cl_loc : Odoc_types.location ;
- }
-
-and class_type_alias = {
- cta_name : Name.t ;
- mutable cta_class : cct option ; (** we can have a t_class or a t_class_type *)
- cta_type_parameters : Types.type_expr list ; (** the type parameters *)
- }
-
-and 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 = {
- clt_name : Name.t ;
- mutable clt_info : Odoc_types.info option ; (** The optional associated user information *)
- clt_type : Types.class_type ;
- clt_type_parameters : Types.type_expr list ; (** type parameters *)
- clt_virtual : bool ; (** true = virtual *)
- mutable clt_kind : class_type_kind ;
- mutable clt_loc : Odoc_types.location ;
- }
-
-
-(** {2 Functions} *)
-
-(** Returns the text associated to the given parameter label
- in the given class, or None. *)
-let class_parameter_text_by_name cl label =
- match cl.cl_info with
- None -> None
- | Some i ->
- try
- let t = List.assoc label i.Odoc_types.i_params in
- Some t
- with
- Not_found ->
- None
-
-(** Returns the list of elements of a t_class. *)
-let rec class_elements ?(trans=true) cl =
- let rec iter_kind k =
- match k with
- Class_structure (_, elements) -> elements
- | Class_constraint (c_kind, ct_kind) ->
- iter_kind c_kind
- (* A VOIR : utiliser le c_kind ou le ct_kind ?
- Pour l'instant, comme le ct_kind n'est pas analysé,
- on cherche dans le c_kind
- class_type_elements ~trans: trans
- { clt_name = "" ; clt_info = None ;
- clt_type_parameters = [] ;
- clt_virtual = false ;
- clt_kind = ct_kind }
- *)
- | Class_apply capp ->
- (
- match capp.capp_class with
- Some c when trans -> class_elements ~trans: trans c
- | _ -> []
- )
- | Class_constr cco ->
- (
- match cco.cco_class with
- Some (Cl c) when trans -> class_elements ~trans: trans c
- | Some (Cltype (ct,_)) when trans -> class_type_elements ~trans: trans ct
- | _ -> []
- )
- in
- iter_kind cl.cl_kind
-
-(** Returns the list of elements of a t_class_type. *)
-and class_type_elements ?(trans=true) clt =
- match clt.clt_kind with
- Class_signature (_, elements) -> elements
- | Class_type { cta_class = Some (Cltype (ct, _)) } when trans ->
- class_type_elements ~trans ct
- | Class_type { cta_class = Some (Cl c) } when trans ->
- class_elements ~trans c
- | Class_type _ ->
- []
-
-(** Returns the attributes of a t_class. *)
-let class_attributes ?(trans=true) cl =
- List.fold_left
- (fun acc -> fun ele ->
- match ele with
- Class_attribute a ->
- acc @ [ a ]
- | _ ->
- acc
- )
- []
- (class_elements ~trans cl)
-
-(** Returns the methods of a t_class. *)
-let class_methods ?(trans=true) cl =
- List.fold_left
- (fun acc -> fun ele ->
- match ele with
- Class_method m ->
- acc @ [ m ]
- | _ ->
- acc
- )
- []
- (class_elements ~trans cl)
-
-(** Returns the comments in a t_class. *)
-let class_comments ?(trans=true) cl =
- List.fold_left
- (fun acc -> fun ele ->
- match ele with
- Class_comment t ->
- acc @ [ t ]
- | _ ->
- acc
- )
- []
- (class_elements ~trans cl)
-
-
-(** Update the parameters text of a t_class, according to the cl_info field. *)
-let class_update_parameters_text cl =
- let f p =
- Odoc_parameter.update_parameter_text (class_parameter_text_by_name cl) p
- in
- List.iter f cl.cl_parameters
-
-(** Returns the attributes of a t_class_type. *)
-let class_type_attributes ?(trans=true) clt =
- List.fold_left
- (fun acc -> fun ele ->
- match ele with
- Class_attribute a ->
- acc @ [ a ]
- | _ ->
- acc
- )
- []
- (class_type_elements ~trans clt)
-
-(** Returns the methods of a t_class_type. *)
-let class_type_methods ?(trans=true) clt =
- List.fold_left
- (fun acc -> fun ele ->
- match ele with
- Class_method m ->
- acc @ [ m ]
- | _ ->
- acc
- )
- []
- (class_type_elements ~trans clt)
-
-(** Returns the comments in a t_class_type. *)
-let class_type_comments ?(trans=true) clt =
- List.fold_left
- (fun acc -> fun ele ->
- match ele with
- Class_comment m ->
- acc @ [ m ]
- | _ ->
- acc
- )
- []
- (class_type_elements ~trans clt)
-
-(** Returns the text associated to the given parameter label
- in the given class type, or None. *)
-let class_type_parameter_text_by_name clt label =
- match clt.clt_info with
- None -> None
- | Some i ->
- try
- let t = List.assoc label i.Odoc_types.i_params in
- Some t
- with
- Not_found ->
- None
-
-
-(* eof $Id$ *)
diff --git a/ocamldoc/odoc_comments.ml b/ocamldoc/odoc_comments.ml
deleted file mode 100644
index 765207ddc8..0000000000
--- a/ocamldoc/odoc_comments.ml
+++ /dev/null
@@ -1,315 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Analysis of comments. *)
-
-open Odoc_types
-
-let print_DEBUG s = print_string s ; print_newline ();;
-
-(** This variable contains the regular expression representing a blank but not a '\n'.*)
-let simple_blank = "[ \013\009\012]"
-
-module type Texter =
- sig
- (** Return a text structure from a string. *)
- val text_of_string : string -> text
- end
-
-module Info_retriever =
- functor (MyTexter : Texter) ->
- struct
- let create_see s =
- try
- let lexbuf = Lexing.from_string s in
- let (see_ref, s) = Odoc_parser.see_info Odoc_see_lexer.main lexbuf in
- (see_ref, MyTexter.text_of_string s)
- with
- | Odoc_text.Text_syntax (l, c, s) ->
- raise (Failure (Odoc_messages.text_parse_error l c s))
- | _ ->
- raise (Failure ("Erreur inconnue lors du parse de see : "^s))
-
- let retrieve_info fun_lex file (s : string) =
- try
- let _ = Odoc_comments_global.init () in
- Odoc_lexer.comments_level := 0;
- let lexbuf = Lexing.from_string s in
- match Odoc_parser.main fun_lex lexbuf with
- None ->
- (0, None)
- | Some (desc, remain_opt) ->
- let mem_nb_chars = !Odoc_comments_global.nb_chars in
- let _ =
- match remain_opt with
- None ->
- ()
- | Some s ->
- (*DEBUG*)print_string ("remain: "^s); print_newline();
- let lexbuf2 = Lexing.from_string s in
- Odoc_parser.info_part2 Odoc_lexer.elements lexbuf2
- in
- (mem_nb_chars,
- Some
- {
- i_desc = (match desc with "" -> None | _ -> Some (MyTexter.text_of_string desc));
- i_authors = !Odoc_comments_global.authors;
- i_version = !Odoc_comments_global.version;
- i_sees = (List.map create_see !Odoc_comments_global.sees) ;
- i_since = !Odoc_comments_global.since;
- i_deprecated =
- (match !Odoc_comments_global.deprecated with
- None -> None | Some s -> Some (MyTexter.text_of_string s));
- i_params =
- (List.map (fun (n, s) ->
- (n, MyTexter.text_of_string s)) !Odoc_comments_global.params);
- i_raised_exceptions =
- (List.map (fun (n, s) ->
- (n, MyTexter.text_of_string s)) !Odoc_comments_global.raised_exceptions);
- i_return_value =
- (match !Odoc_comments_global.return_value with
- None -> None | Some s -> Some (MyTexter.text_of_string s)) ;
- i_custom = (List.map
- (fun (tag, s) -> (tag, MyTexter.text_of_string s))
- !Odoc_comments_global.customs)
- }
- )
- with
- Failure s ->
- incr Odoc_global.errors ;
- prerr_endline (file^" : "^s^"\n");
- (0, None)
- | Odoc_text.Text_syntax (l, c, s) ->
- incr Odoc_global.errors ;
- prerr_endline (file^" : "^(Odoc_messages.text_parse_error l c s));
- (0, None)
- | _ ->
- incr Odoc_global.errors ;
- prerr_endline (file^" : "^Odoc_messages.parse_error^"\n");
- (0, None)
-
- (** This function takes a string where a simple comment may has been found. It returns
- false if there is a blank line or the first comment is a special one, or if there is
- no comment if the string.*)
- let nothing_before_simple_comment s =
- (* get the position of the first "(*" *)
- try
- print_DEBUG ("comment_is_attached: "^s);
- let pos = Str.search_forward (Str.regexp "(\\*") s 0 in
- let next_char = if (String.length s) >= (pos + 1) then s.[pos + 2] else '_' in
- (next_char <> '*') &&
- (
- (* there is no special comment between the constructor and the coment we got *)
- let s2 = String.sub s 0 pos in
- print_DEBUG ("s2="^s2);
- try
- let _ = Str.search_forward (Str.regexp ("['\n']"^simple_blank^"*['\n']")) s2 0 in
- (* a blank line was before the comment *)
- false
- with
- Not_found ->
- true
- )
- with
- Not_found ->
- false
-
- (** Return true if the given string contains a blank line. *)
- let blank_line s =
- try
- let _ = Str.search_forward (Str.regexp ("['\n']"^simple_blank^"*['\n']")) s 0 in
- (* a blank line was before the comment *)
- true
- with
- Not_found ->
- false
-
- let retrieve_info_special file (s : string) =
- retrieve_info Odoc_lexer.main file s
-
- let retrieve_info_simple file (s : string) =
- let _ = Odoc_comments_global.init () in
- Odoc_lexer.comments_level := 0;
- let lexbuf = Lexing.from_string s in
- match Odoc_parser.main Odoc_lexer.simple lexbuf with
- None ->
- (0, None)
- | Some (desc, remain_opt) ->
- (!Odoc_comments_global.nb_chars, Some Odoc_types.dummy_info)
-
- (** Return true if the given string contains a blank line outside a simple comment. *)
- let blank_line_outside_simple file s =
- let rec iter s2 =
- match retrieve_info_simple file s2 with
- (_, None) ->
- blank_line s2
- | (len, Some _) ->
- try
- let pos = Str.search_forward (Str.regexp_string "(*") s2 0 in
- let s_before = String.sub s2 0 pos in
- let s_after = String.sub s2 len ((String.length s2) - len) in
- (blank_line s_before) || (iter s_after)
- with
- Not_found ->
- (* we shouldn't get here *)
- false
- in
- iter s
-
- (** This function returns the first simple comment in
- the given string. If strict is [true] then no
- comment is returned if a blank line or a special
- comment is found before the simple comment. *)
- let retrieve_first_info_simple ?(strict=true) file (s : string) =
- match retrieve_info_simple file s with
- (_, None) ->
- (0, None)
- | (len, Some d) ->
- (* we check if the comment we got was really attached to the constructor,
- i.e. that there was no blank line or any special comment "(**" before *)
- if (not strict) or (nothing_before_simple_comment s) then
- (* ok, we attach the comment to the constructor *)
- (len, Some d)
- else
- (* a blank line or special comment was before the comment,
- so we must not attach this comment to the constructor. *)
- (0, None)
-
- let retrieve_last_info_simple file (s : string) =
- print_DEBUG ("retrieve_last_info_simple:"^s);
- let rec f cur_len cur_d =
- try
- let s2 = String.sub s cur_len ((String.length s) - cur_len) in
- print_DEBUG ("retrieve_last_info_simple.f:"^s2);
- match retrieve_info_simple file s2 with
- (len, None) ->
- print_DEBUG "retrieve_last_info_simple: None";
- (cur_len + len, cur_d)
- | (len, Some d) ->
- print_DEBUG "retrieve_last_info_simple: Some";
- f (len + cur_len) (Some d)
- with
- _ ->
- print_DEBUG "retrieve_last_info_simple : Erreur String.sub";
- (cur_len, cur_d)
- in
- f 0 None
-
- let retrieve_last_special_no_blank_after file (s : string) =
- print_DEBUG ("retrieve_last_special_no_blank_after:"^s);
- let rec f cur_len cur_d =
- try
- let s2 = String.sub s cur_len ((String.length s) - cur_len) in
- print_DEBUG ("retrieve_last_special_no_blank_after.f:"^s2);
- match retrieve_info_special file s2 with
- (len, None) ->
- print_DEBUG "retrieve_last_special_no_blank_after: None";
- (cur_len + len, cur_d)
- | (len, Some d) ->
- print_DEBUG "retrieve_last_special_no_blank_after: Some";
- f (len + cur_len) (Some d)
- with
- _ ->
- print_DEBUG "retrieve_last_special_no_blank_after : Erreur String.sub";
- (cur_len, cur_d)
- in
- f 0 None
-
- let all_special file s =
- print_DEBUG ("all_special: "^s);
- let rec iter acc n s2 =
- match retrieve_info_special file s2 with
- (_, None) ->
- (n, acc)
- | (n2, Some i) ->
- print_DEBUG ("all_special: avant String.sub new_s="^s2);
- print_DEBUG ("n2="^(string_of_int n2)) ;
- print_DEBUG ("len(s2)="^(string_of_int (String.length s2))) ;
- let new_s = String.sub s2 n2 ((String.length s2) - n2) in
- print_DEBUG ("all_special: apres String.sub new_s="^new_s);
- iter (acc @ [i]) (n + n2) new_s
- in
- let res = iter [] 0 s in
- print_DEBUG ("all_special: end");
- res
-
- let just_after_special file s =
- print_DEBUG ("just_after_special: "^s);
- let res = match retrieve_info_special file s with
- (_, None) ->
- (0, None)
- | (len, Some d) ->
- (* we must not have a simple comment or a blank line before. *)
- match retrieve_info_simple file (String.sub s 0 len) with
- (_, None) ->
- (
- try
- (* if the special comment is the stop comment (**/**),
- then we must not associate it. *)
- let pos = Str.search_forward (Str.regexp_string "(**") s 0 in
- if blank_line (String.sub s 0 pos) or
- d.Odoc_types.i_desc = Some [Odoc_types.Raw "/*"]
- then
- (0, None)
- else
- (len, Some d)
- with
- Not_found ->
- (* should not occur *)
- (0, None)
- )
- | (len2, Some d2) ->
- (0, None)
- in
- print_DEBUG ("just_after_special:end");
- res
-
- let first_special file s =
- retrieve_info_special file s
-
- let get_comments f_create_ele file s =
- let (assoc_com, ele_coms) =
- (* get the comments *)
- let (len, special_coms) = all_special file s in
- (* if there is no blank line after the special comments, and
- if the last special comment is not the stop special comment, then the
- last special comments must be associated to the element. *)
- match List.rev special_coms with
- [] ->
- (None, [])
- | h :: q ->
- if (blank_line_outside_simple file
- (String.sub s len ((String.length s) - len)) )
- or h.Odoc_types.i_desc = Some [Odoc_types.Raw "/*"]
- then
- (None, special_coms)
- else
- (Some h, List.rev q)
- in
- let ele_comments =
- List.fold_left
- (fun acc -> fun sc ->
- match sc.Odoc_types.i_desc with
- None ->
- acc
- | Some t ->
- acc @ [f_create_ele t])
- []
- ele_coms
- in
- (assoc_com, ele_comments)
- end
-
-module Basic_info_retriever = Info_retriever (Odoc_text.Texter)
-
-(* eof $Id$ *)
diff --git a/ocamldoc/odoc_comments.mli b/ocamldoc/odoc_comments.mli
deleted file mode 100644
index 0579926a90..0000000000
--- a/ocamldoc/odoc_comments.mli
+++ /dev/null
@@ -1,57 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Analysis of comments. *)
-
-val simple_blank : string
-
-(** The type of modules in argument to Info_retriever *)
-module type Texter =
- sig
- (** Return a text structure from a string. *)
- val text_of_string : string -> Odoc_types.text
- end
-
-(** The basic module for special comments analysis.*)
-module Basic_info_retriever :
- sig
- (** Return true if the given string contains a blank line. *)
- val blank_line_outside_simple :
- string -> string -> bool
-
- (** This function retrieves all the special comments in the given string. *)
- val all_special : string -> string -> int * Odoc_types.info list
-
- (** [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
diff --git a/ocamldoc/odoc_comments_global.ml b/ocamldoc/odoc_comments_global.ml
deleted file mode 100644
index 6e18fd295d..0000000000
--- a/ocamldoc/odoc_comments_global.ml
+++ /dev/null
@@ -1,48 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** The global variables used by the special comment parser.*)
-
-let nb_chars = ref 0
-
-let authors = ref ([] : string list)
-
-let version = ref (None : string option)
-
-let sees = ref ([] : string list)
-
-let since = ref (None : string option)
-
-let deprecated = ref (None : string option)
-
-let params = ref ([] : (string * string) list)
-
-let raised_exceptions = ref ([] : (string * string) list)
-
-let return_value = ref (None : string option)
-
-let customs = ref []
-
-let init () =
- nb_chars := 0;
- authors := [];
- version := None;
- sees := [];
- since := None;
- deprecated := None;
- params := [];
- raised_exceptions := [];
- return_value := None ;
- customs := []
-
-(* eof $Id$ *)
diff --git a/ocamldoc/odoc_comments_global.mli b/ocamldoc/odoc_comments_global.mli
deleted file mode 100644
index 9e0474676e..0000000000
--- a/ocamldoc/odoc_comments_global.mli
+++ /dev/null
@@ -1,47 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** The global variables used by the special comment parser.*)
-
-(** the number of chars used in the lexer. *)
-val nb_chars : int ref
-
-(** the authors list *)
-val authors : string list ref
-
-(** the version string *)
-val version : string option ref
-
-(** the see references *)
-val sees : string list ref
-
-(** the since string *)
-val since : string option ref
-
-(** the deprecated flag *)
-val deprecated : string option ref
-
-(** parameters, with name and description *)
-val params : (string * string) list ref
-
-(** the raised exceptions, with name and description *)
-val raised_exceptions : (string * string) list ref
-
-(** the description of the return value *)
-val return_value : string option ref
-
-(** the strings associated to custom tags. *)
-val customs : (string * string) list ref
-
-(** this function inits the variables filled by the parser. *)
-val init : unit -> unit
diff --git a/ocamldoc/odoc_control.ml b/ocamldoc/odoc_control.ml
deleted file mode 100644
index 705bf4ad3c..0000000000
--- a/ocamldoc/odoc_control.ml
+++ /dev/null
@@ -1,13 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
diff --git a/ocamldoc/odoc_cross.ml b/ocamldoc/odoc_cross.ml
deleted file mode 100644
index 4134ea84b8..0000000000
--- a/ocamldoc/odoc_cross.ml
+++ /dev/null
@@ -1,815 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Cross referencing. *)
-
-module Name = Odoc_name
-open Odoc_module
-open Odoc_class
-open Odoc_exception
-open Odoc_types
-open Odoc_value
-open Odoc_type
-open Odoc_parameter
-
-(*** Replacements of aliases : if e1 = e2 and e2 = e3, then replace e2 by e3 to have e1 = e3,
- in order to associate the element with complete information. *)
-
-(** The module used to keep what refs were modified. *)
-module S = Set.Make
- (
- struct type t = string * ref_kind option
- let compare = Pervasives.compare
- end
- )
-
-let verified_refs = ref S.empty
-
-let add_verified v = verified_refs := S.add v !verified_refs
-let was_verified v = S.mem v !verified_refs
-
-(** The module with the predicates used to get the aliased modules, classes and exceptions. *)
-module P_alias =
- struct
- type t = int
-
- let p_module m _ =
- (true,
- match m.m_kind with
- Module_alias _ -> true
- | _ -> false
- )
- let p_module_type mt _ =
- (true,
- match mt.mt_kind with
- Some (Module_type_alias _) -> true
- | _ -> false
- )
- let p_class c _ = (false, false)
- let p_class_type ct _ = (false, false)
- let p_value v _ = false
- let p_type t _ = false
- let p_exception e _ = e.ex_alias <> None
- let p_attribute a _ = false
- let p_method m _ = false
- let p_section s _ = false
- end
-
-(** The module used to get the aliased elements. *)
-module Search_alias = Odoc_search.Search (P_alias)
-
-let rec build_alias_list (acc_m, acc_mt, acc_ex) = function
- [] ->
- (acc_m, acc_mt, acc_ex)
- | (Odoc_search.Res_module m) :: q ->
- let new_acc_m =
- match m.m_kind with
- Module_alias ma -> (m.m_name, ma.ma_name) :: acc_m
- | _ -> acc_m
- in
- build_alias_list (new_acc_m, acc_mt, acc_ex) q
- | (Odoc_search.Res_module_type mt) :: q ->
- let new_acc_mt =
- match mt.mt_kind with
- Some (Module_type_alias mta) -> (mt.mt_name, mta.mta_name) :: acc_mt
- | _ -> acc_mt
- in
- build_alias_list (acc_m, new_acc_mt, acc_ex) q
- | (Odoc_search.Res_exception e) :: q ->
- let new_acc_ex =
- match e.ex_alias with
- None -> acc_ex
- | Some ea -> (e.ex_name, ea.ea_name) :: acc_ex
- in
- build_alias_list (acc_m, acc_mt, new_acc_ex) q
- | _ :: q ->
- build_alias_list (acc_m, acc_mt, acc_ex) q
-
-
-
-(** Couples of module name aliases. *)
-let module_aliases = ref [] ;;
-
-(** Couples of module type name aliases. *)
-let module_type_aliases = ref [] ;;
-
-(** Couples of exception name aliases. *)
-let exception_aliases = ref [] ;;
-
-(** Retrieve the aliases for modules, module types and exceptions and put them in global variables. *)
-let get_alias_names module_list =
- let (alias_m, alias_mt, alias_ex) =
- build_alias_list
- ([], [], [])
- (Search_alias.search module_list 0)
- in
- module_aliases := alias_m ;
- module_type_aliases := alias_mt ;
- exception_aliases := alias_ex
-
-
-(** The module with lookup predicates. *)
-module P_lookup =
- struct
- type t = Name.t
- let p_module m name = (Name.prefix m.m_name name, m.m_name = (Name.name_alias name !module_aliases))
- let p_module_type mt name = (Name.prefix mt.mt_name name, mt.mt_name = (Name.name_alias name (!module_aliases @ !module_type_aliases)))
- let p_class c name = (false, c.cl_name = (Name.name_alias name (!module_aliases @ !module_type_aliases)))
- let p_class_type ct name = (false, ct.clt_name = (Name.name_alias name (!module_aliases @ !module_type_aliases)))
- let p_value v name = false
- let p_type t name = false
- let p_exception e name = e.ex_name = (Name.name_alias name !exception_aliases)
- let p_attribute a name = false
- let p_method m name = false
- let p_section s name = false
- end
-
-(** The module used to search by a complete name.*)
-module Search_by_complete_name = Odoc_search.Search (P_lookup)
-
-let rec lookup_module module_list name =
- let l = List.filter
- (fun res ->
- match res with
- Odoc_search.Res_module _ -> true
- | _ -> false
- )
- (Search_by_complete_name.search module_list name)
- in
- match l with
- (Odoc_search.Res_module m) :: _ -> m
- | _ -> raise Not_found
-
-let rec lookup_module_type module_list name =
- let l = List.filter
- (fun res ->
- match res with
- Odoc_search.Res_module_type _ -> true
- | _ -> false
- )
- (Search_by_complete_name.search module_list name)
- in
- match l with
- (Odoc_search.Res_module_type mt) :: _ -> mt
- | _ -> raise Not_found
-
-let rec lookup_class module_list name =
- let l = List.filter
- (fun res ->
- match res with
- Odoc_search.Res_class _ -> true
- | _ -> false
- )
- (Search_by_complete_name.search module_list name)
- in
- match l with
- (Odoc_search.Res_class c) :: _ -> c
- | _ -> raise Not_found
-
-let rec lookup_class_type module_list name =
- let l = List.filter
- (fun res ->
- match res with
- Odoc_search.Res_class_type _ -> true
- | _ -> false
- )
- (Search_by_complete_name.search module_list name)
- in
- match l with
- (Odoc_search.Res_class_type ct) :: _ -> ct
- | _ -> raise Not_found
-
-let rec lookup_exception module_list name =
- let l = List.filter
- (fun res ->
- match res with
- Odoc_search.Res_exception _ -> true
- | _ -> false
- )
- (Search_by_complete_name.search module_list name)
- in
- match l with
- (Odoc_search.Res_exception e) :: _ -> e
- | _ -> raise Not_found
-
-(** The type to describe the names not found. *)
-type not_found_name =
- NF_m of Name.t
- | NF_mt of Name.t
- | NF_mmt of Name.t
- | NF_c of Name.t
- | NF_ct of Name.t
- | NF_cct of Name.t
- | NF_ex of Name.t
-
-(** Functions to find and associate aliases elements. *)
-
-let rec associate_in_module module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) m =
- let rec iter_kind (acc_b, acc_inc, acc_names) k =
- match k with
- Module_struct elements ->
- List.fold_left
- (associate_in_module_element module_list m.m_name)
- (acc_b, acc_inc, acc_names)
- elements
-
- | Module_alias ma ->
- (
- match ma.ma_module with
- Some _ ->
- (acc_b, acc_inc, acc_names)
- | None ->
- let mmt_opt =
- try Some (Mod (lookup_module module_list ma.ma_name))
- with Not_found ->
- try Some (Modtype (lookup_module_type module_list ma.ma_name))
- with Not_found -> None
- in
- match mmt_opt with
- None -> (acc_b, (Name.head m.m_name) :: acc_inc,
- (* we don't want to output warning messages for
- "sig ... end" or "struct ... end" modules not found *)
- (if ma.ma_name = Odoc_messages.struct_end or
- ma.ma_name = Odoc_messages.sig_end then
- acc_names
- else
- (NF_mmt ma.ma_name) :: acc_names)
- )
- | Some mmt ->
- ma.ma_module <- Some mmt ;
- (true, acc_inc, acc_names)
- )
-
- | Module_functor (_, k) ->
- iter_kind (acc_b, acc_inc, acc_names) k
-
- | Module_with (tk, _) ->
- associate_in_module_type module_list (acc_b, acc_inc, acc_names)
- { 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_apply (k1, k2) ->
- let (acc_b2, acc_inc2, acc_names2) = iter_kind (acc_b, acc_inc, acc_names) k1 in
- iter_kind (acc_b2, acc_inc2, acc_names2) k2
-
- | Module_constraint (k, tk) ->
- let (acc_b2, acc_inc2, acc_names2) = iter_kind (acc_b, acc_inc, acc_names) k in
- associate_in_module_type module_list (acc_b2, acc_inc2, acc_names2)
- { 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 (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) m.m_kind
-
-and associate_in_module_type module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) mt =
- let rec iter_kind (acc_b, acc_inc, acc_names) k =
- match k with
- Module_type_struct elements ->
- List.fold_left
- (associate_in_module_element module_list mt.mt_name)
- (acc_b, acc_inc, acc_names)
- elements
-
- | Module_type_functor (_, k) ->
- iter_kind (acc_b, acc_inc, acc_names) k
-
- | Module_type_with (k, _) ->
- iter_kind (acc_b, acc_inc, acc_names) k
-
- | Module_type_alias mta ->
- match mta.mta_module with
- Some _ ->
- (acc_b, acc_inc, acc_names)
- | None ->
- let mt_opt =
- try Some (lookup_module_type module_list mta.mta_name)
- with Not_found -> None
- in
- match mt_opt with
- None -> (acc_b, (Name.head mt.mt_name) :: acc_inc,
- (* we don't want to output warning messages for
- "sig ... end" or "struct ... end" modules not found *)
- (if mta.mta_name = Odoc_messages.struct_end or
- mta.mta_name = Odoc_messages.sig_end then
- acc_names
- else
- (NF_mt mta.mta_name) :: acc_names)
- )
- | Some mt ->
- mta.mta_module <- Some mt ;
- (true, acc_inc, acc_names)
- in
- match mt.mt_kind with
- None -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found)
- | Some k -> iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) k
-
-and associate_in_module_element module_list m_name (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) element =
- match element with
- Element_module m -> associate_in_module module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) m
- | Element_module_type mt -> associate_in_module_type module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) mt
- | Element_included_module im ->
- (
- match im.im_module with
- Some _ -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found)
- | None ->
- let mmt_opt =
- try Some (Mod (lookup_module module_list im.im_name))
- with Not_found ->
- try Some (Modtype (lookup_module_type module_list im.im_name))
- with Not_found -> None
- in
- match mmt_opt with
- None -> (acc_b_modif, (Name.head m_name) :: acc_incomplete_top_module_names,
- (* we don't want to output warning messages for
- "sig ... end" or "struct ... end" modules not found *)
- (if im.im_name = Odoc_messages.struct_end or
- im.im_name = Odoc_messages.sig_end then
- acc_names_not_found
- else
- (NF_mmt im.im_name) :: acc_names_not_found)
- )
- | Some mmt ->
- im.im_module <- Some mmt ;
- (true, acc_incomplete_top_module_names, acc_names_not_found)
- )
- | Element_class cl -> associate_in_class module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) cl
- | Element_class_type ct -> associate_in_class_type module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) ct
- | Element_value _ -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found)
- | Element_exception ex ->
- (
- match ex.ex_alias with
- None -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found)
- | Some ea ->
- match ea.ea_ex with
- Some _ ->
- (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found)
- | None ->
- let ex_opt =
- try Some (lookup_exception module_list ea.ea_name)
- with Not_found -> None
- in
- match ex_opt with
- None -> (acc_b_modif, (Name.head m_name) :: acc_incomplete_top_module_names, (NF_ex ea.ea_name) :: acc_names_not_found)
- | Some e ->
- ea.ea_ex <- Some e ;
- (true, acc_incomplete_top_module_names, acc_names_not_found)
- )
- | Element_type _ -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found)
- | Element_module_comment _ -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found)
-
-and associate_in_class module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) c =
- let rec iter_kind (acc_b, acc_inc, acc_names) k =
- match k with
- Class_structure (inher_l, _) ->
- let f (acc_b2, acc_inc2, acc_names2) ic =
- match ic.ic_class with
- Some _ -> (acc_b2, acc_inc2, acc_names2)
- | None ->
- let cct_opt =
- try Some (Cl (lookup_class module_list ic.ic_name))
- with Not_found ->
- try Some (Cltype (lookup_class_type module_list ic.ic_name, []))
- with Not_found -> None
- in
- match cct_opt with
- None -> (acc_b2, (Name.head c.cl_name) :: acc_inc2,
- (* we don't want to output warning messages for "object ... end" classes not found *)
- (if ic.ic_name = Odoc_messages.object_end then acc_names2 else (NF_cct ic.ic_name) :: acc_names2))
- | Some cct ->
- ic.ic_class <- Some cct ;
- (true, acc_inc2, acc_names2)
- in
- List.fold_left f (acc_b, acc_inc, acc_names) inher_l
-
- | Class_apply capp ->
- (
- match capp.capp_class with
- Some _ -> (acc_b, acc_inc, acc_names)
- | None ->
- let cl_opt =
- try Some (lookup_class module_list capp.capp_name)
- with Not_found -> None
- in
- match cl_opt with
- None -> (acc_b, (Name.head c.cl_name) :: acc_inc,
- (* we don't want to output warning messages for "object ... end" classes not found *)
- (if capp.capp_name = Odoc_messages.object_end then acc_names else (NF_c capp.capp_name) :: acc_names))
- | Some c ->
- capp.capp_class <- Some c ;
- (true, acc_inc, acc_names)
- )
-
- | Class_constr cco ->
- (
- match cco.cco_class with
- Some _ -> (acc_b, acc_inc, acc_names)
- | None ->
- let cl_opt =
- try Some (lookup_class module_list cco.cco_name)
- with Not_found -> None
- in
- match cl_opt with
- None ->
- (
- let clt_opt =
- try Some (lookup_class_type module_list cco.cco_name)
- with Not_found -> None
- in
- match clt_opt with
- None ->
- (acc_b, (Name.head c.cl_name) :: acc_inc,
- (* we don't want to output warning messages for "object ... end" classes not found *)
- (if cco.cco_name = Odoc_messages.object_end then acc_names else (NF_cct cco.cco_name) :: acc_names))
- | Some ct ->
- cco.cco_class <- Some (Cltype (ct, [])) ;
- (true, acc_inc, acc_names)
- )
- | Some c ->
- cco.cco_class <- Some (Cl c) ;
- (true, acc_inc, acc_names)
- )
- | Class_constraint (ckind, ctkind) ->
- let (acc_b2, acc_inc2, acc_names2) = iter_kind (acc_b, acc_inc, acc_names) ckind in
- associate_in_class_type module_list (acc_b2, acc_inc2, acc_names2)
- { clt_name = "" ; clt_info = None ;
- clt_type = c.cl_type ; (* should be ok *)
- clt_type_parameters = [] ;
- clt_virtual = false ;
- clt_kind = ctkind ;
- clt_loc = Odoc_types.dummy_loc }
- in
- iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) c.cl_kind
-
-and associate_in_class_type module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) ct =
- let rec iter_kind (acc_b, acc_inc, acc_names) k =
- match k with
- Class_signature (inher_l, _) ->
- let f (acc_b2, acc_inc2, acc_names2) ic =
- match ic.ic_class with
- Some _ -> (acc_b2, acc_inc2, acc_names2)
- | None ->
- let cct_opt =
- try Some (Cltype (lookup_class_type module_list ic.ic_name, []))
- with Not_found ->
- try Some (Cl (lookup_class module_list ic.ic_name))
- with Not_found -> None
- in
- match cct_opt with
- None -> (acc_b2, (Name.head ct.clt_name) :: acc_inc2,
- (* we don't want to output warning messages for "object ... end" class types not found *)
- (if ic.ic_name = Odoc_messages.object_end then acc_names2 else (NF_cct ic.ic_name) :: acc_names2))
- | Some cct ->
- ic.ic_class <- Some cct ;
- (true, acc_inc2, acc_names2)
- in
- List.fold_left f (acc_b, acc_inc, acc_names) inher_l
-
- | Class_type cta ->
- (
- match cta.cta_class with
- Some _ -> (acc_b, acc_inc, acc_names)
- | None ->
- let cct_opt =
- try Some (Cltype (lookup_class_type module_list cta.cta_name, []))
- with Not_found ->
- try Some (Cl (lookup_class module_list cta.cta_name))
- with Not_found -> None
- in
- match cct_opt with
- None -> (acc_b, (Name.head ct.clt_name) :: acc_inc,
- (* we don't want to output warning messages for "object ... end" class types not found *)
- (if cta.cta_name = Odoc_messages.object_end then acc_names else (NF_cct cta.cta_name) :: acc_names))
- | Some c ->
- cta.cta_class <- Some c ;
- (true, acc_inc, acc_names)
- )
- in
- iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) ct.clt_kind
-
-(*************************************************************)
-(** Association of types to elements referenced in comments .*)
-
-let ao = Odoc_misc.apply_opt
-
-let rec assoc_comments_text_elements module_list t_ele =
- match t_ele with
- | Raw _
- | Code _
- | CodePre _
- | Latex _
- | Verbatim _ -> t_ele
- | Bold t -> Bold (assoc_comments_text module_list t)
- | Italic t -> Italic (assoc_comments_text module_list t)
- | Center t -> Center (assoc_comments_text module_list t)
- | Left t -> Left (assoc_comments_text module_list t)
- | Right t -> Right (assoc_comments_text module_list t)
- | Emphasize t -> Emphasize (assoc_comments_text module_list t)
- | List l -> List (List.map (assoc_comments_text module_list) l)
- | Enum l -> Enum (List.map (assoc_comments_text module_list) l)
- | Newline -> Newline
- | Block t -> Block (assoc_comments_text module_list t)
- | Superscript t -> Superscript (assoc_comments_text module_list t)
- | Subscript t -> Subscript (assoc_comments_text module_list t)
- | Title (n, l_opt, t) -> Title (n, l_opt, (assoc_comments_text module_list t))
- | Link (s, t) -> Link (s, (assoc_comments_text module_list t))
- | Ref (name, None) ->
- (
- (* we look for the first element with this name *)
- let re = Str.regexp ("^"^(Str.quote name)^"$") in
- let res = Odoc_search.Search_by_name.search module_list re in
- match res with
- [] ->
- Odoc_messages.pwarning (Odoc_messages.cross_element_not_found name);
- t_ele
- | ele :: _ ->
- let kind =
- match ele with
- Odoc_search.Res_module _ -> RK_module
- | Odoc_search.Res_module_type _ -> RK_module_type
- | Odoc_search.Res_class _ -> RK_class
- | Odoc_search.Res_class_type _ -> RK_class_type
- | Odoc_search.Res_value _ -> RK_value
- | Odoc_search.Res_type _ -> RK_type
- | Odoc_search.Res_exception _ -> RK_exception
- | Odoc_search.Res_attribute _ -> RK_attribute
- | Odoc_search.Res_method _ -> RK_method
- | Odoc_search.Res_section (_ ,t)-> RK_section t
- in
- add_verified (name, Some kind) ;
- Ref (name, Some kind)
- )
- | Ref (name, Some kind) ->
- let v = (name, Some kind) in
- (** we just verify that we find an element of this kind with this name *)
- let re = Str.regexp ("^"^(Str.quote name)^"$") in
- let res = Odoc_search.Search_by_name.search module_list re in
- if was_verified v then
- Ref (name, Some kind)
- else
- match kind with
- | RK_section _ ->
- (
- try
- let t = Odoc_search.find_section module_list re in
- let v2 = (name, Some (RK_section t)) in
- add_verified v2 ;
- Ref (name, Some (RK_section t))
- with
- Not_found ->
- Odoc_messages.pwarning (Odoc_messages.cross_section_not_found name);
- Ref (name, None)
- )
- | _ ->
- let (f,f_mes) =
- match kind with
- RK_module -> Odoc_search.module_exists, Odoc_messages.cross_module_not_found
- | RK_module_type -> Odoc_search.module_type_exists, Odoc_messages.cross_module_type_not_found
- | RK_class -> Odoc_search.class_exists, Odoc_messages.cross_class_not_found
- | RK_class_type -> Odoc_search.class_type_exists, Odoc_messages.cross_class_type_not_found
- | RK_value -> Odoc_search.value_exists, Odoc_messages.cross_value_not_found
- | RK_type -> Odoc_search.type_exists, Odoc_messages.cross_type_not_found
- | RK_exception -> Odoc_search.exception_exists, Odoc_messages.cross_exception_not_found
- | RK_attribute -> Odoc_search.attribute_exists, Odoc_messages.cross_attribute_not_found
- | RK_method -> Odoc_search.method_exists, Odoc_messages.cross_method_not_found
- | RK_section _ -> assert false
- in
- if f module_list re then
- (
- add_verified v ;
- Ref (name, Some kind)
- )
- else
- (
- Odoc_messages.pwarning (f_mes name);
- Ref (name, None)
- )
-
-
-and assoc_comments_text module_list text =
- List.map (assoc_comments_text_elements module_list) text
-
-and assoc_comments_info module_list i =
- let ft = assoc_comments_text module_list in
- {
- i with
- i_desc = ao ft i.i_desc ;
- i_sees = List.map (fun (sr, t) -> (sr, ft t)) i.i_sees;
- i_deprecated = ao ft i.i_deprecated ;
- i_params = List.map (fun (name, t) -> (name, ft t)) i.i_params;
- i_raised_exceptions = List.map (fun (name, t) -> (name, ft t)) i.i_raised_exceptions;
- i_return_value = ao ft i.i_return_value ;
- i_custom = List.map (fun (tag, t) -> (tag, ft t)) i.i_custom ;
- }
-
-
-let rec assoc_comments_module_element module_list m_ele =
- match m_ele with
- Element_module m -> Element_module (assoc_comments_module module_list m)
- | Element_module_type mt -> Element_module_type (assoc_comments_module_type module_list mt)
- | Element_included_module _ -> m_ele (* don't go down into the aliases *)
- | Element_class c -> Element_class (assoc_comments_class module_list c)
- | Element_class_type ct -> Element_class_type (assoc_comments_class_type module_list ct)
- | Element_value v -> Element_value (assoc_comments_value module_list v)
- | Element_exception e -> Element_exception (assoc_comments_exception module_list e)
- | Element_type t -> Element_type (assoc_comments_type module_list t)
- | Element_module_comment t -> Element_module_comment (assoc_comments_text module_list t)
-
-and assoc_comments_class_element module_list c_ele =
- match c_ele with
- Class_attribute a -> Class_attribute (assoc_comments_attribute module_list a)
- | Class_method m -> Class_method (assoc_comments_method module_list m)
- | Class_comment t -> Class_comment (assoc_comments_text module_list t)
-
-and assoc_comments_module_kind module_list mk =
- match mk with
- | Module_struct eles ->
- Module_struct (List.map (assoc_comments_module_element module_list) eles)
- | Module_alias _
- | Module_functor _ ->
- mk
- | Module_apply (mk1, mk2) ->
- Module_apply (assoc_comments_module_kind module_list mk1,
- assoc_comments_module_kind module_list mk2)
- | Module_with (mtk, s) ->
- Module_with (assoc_comments_module_type_kind module_list mtk, s)
- | Module_constraint (mk1, mtk) ->
- Module_constraint (assoc_comments_module_kind module_list mk1,
- assoc_comments_module_type_kind module_list mtk)
-
-and assoc_comments_module_type_kind module_list mtk =
- match mtk with
- | Module_type_struct eles ->
- Module_type_struct (List.map (assoc_comments_module_element module_list) eles)
- | Module_type_functor (params, mtk1) ->
- Module_type_functor (params, assoc_comments_module_type_kind module_list mtk1)
- | Module_type_alias _ ->
- mtk
- | Module_type_with (mtk1, s) ->
- Module_type_with (assoc_comments_module_type_kind module_list mtk1, s)
-
-and assoc_comments_class_kind module_list ck =
- match ck with
- Class_structure (inher, eles) ->
- let inher2 =
- List.map
- (fun ic -> { ic with
- ic_text = ao (assoc_comments_text module_list) ic.ic_text })
- inher
- in
- Class_structure (inher2, List.map (assoc_comments_class_element module_list) eles)
-
- | Class_apply _
- | Class_constr _ -> ck
- | Class_constraint (ck1, ctk) ->
- Class_constraint (assoc_comments_class_kind module_list ck1,
- assoc_comments_class_type_kind module_list ctk)
-
-and assoc_comments_class_type_kind module_list ctk =
- match ctk with
- Class_signature (inher, eles) ->
- let inher2 =
- List.map
- (fun ic -> { ic with
- ic_text = ao (assoc_comments_text module_list) ic.ic_text })
- inher
- in
- Class_signature (inher2, List.map (assoc_comments_class_element module_list) eles)
-
- | Class_type _ -> ctk
-
-
-and assoc_comments_module module_list m =
- m.m_info <- ao (assoc_comments_info module_list) m.m_info ;
- m.m_kind <- assoc_comments_module_kind module_list m.m_kind ;
- m
-
-and assoc_comments_module_type module_list mt =
- mt.mt_info <- ao (assoc_comments_info module_list) mt.mt_info ;
- mt.mt_kind <- ao (assoc_comments_module_type_kind module_list) mt.mt_kind ;
- mt
-
-and assoc_comments_class module_list c =
- c.cl_info <- ao (assoc_comments_info module_list) c.cl_info ;
- c.cl_kind <- assoc_comments_class_kind module_list c.cl_kind ;
- assoc_comments_parameter_list module_list c.cl_parameters;
- c
-
-and assoc_comments_class_type module_list ct =
- ct.clt_info <- ao (assoc_comments_info module_list) ct.clt_info ;
- ct.clt_kind <- assoc_comments_class_type_kind module_list ct.clt_kind ;
- ct
-
-and assoc_comments_parameter module_list p =
- match p with
- Simple_name sn ->
- sn.sn_text <- ao (assoc_comments_text module_list) sn.sn_text
- | Tuple (l, t) ->
- List.iter (assoc_comments_parameter module_list) l
-
-and assoc_comments_parameter_list module_list pl =
- List.iter (assoc_comments_parameter module_list) pl
-
-and assoc_comments_value module_list v =
- v.val_info <- ao (assoc_comments_info module_list) v.val_info ;
- assoc_comments_parameter_list module_list v.val_parameters;
- v
-
-and assoc_comments_exception module_list e =
- e.ex_info <- ao (assoc_comments_info module_list) e.ex_info ;
- e
-
-and assoc_comments_type module_list t =
- t.ty_info <- ao (assoc_comments_info module_list) t.ty_info ;
- (match t.ty_kind with
- Type_abstract -> ()
- | Type_variant (vl, _) ->
- List.iter
- (fun vc -> vc.vc_text <- ao (assoc_comments_text module_list) vc.vc_text)
- vl
- | Type_record (fl, _) ->
- List.iter
- (fun rf -> rf.rf_text <- ao (assoc_comments_text module_list) rf.rf_text)
- fl
- );
- t
-
-and assoc_comments_attribute module_list a =
- let _ = assoc_comments_value module_list a.att_value in
- a
-
-and assoc_comments_method module_list m =
- let _ = assoc_comments_value module_list m.met_value in
- assoc_comments_parameter_list module_list m.met_value.val_parameters;
- m
-
-
-let associate_type_of_elements_in_comments module_list =
- List.map (assoc_comments_module module_list) module_list
-
-
-(***********************************************************)
-(** The function which performs all the cross referencing. *)
-let associate module_list =
- get_alias_names module_list ;
- 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
- let rec iter incomplete_modules =
- let (b_modif, remaining_inc_modules, acc_names_not_found) =
- List.fold_left (associate_in_module module_list) (false, [], []) incomplete_modules
- in
- let remaining_no_doubles = remove_doubles [] remaining_inc_modules in
- let remaining_modules = List.filter
- (fun m -> List.mem m.m_name remaining_no_doubles)
- incomplete_modules
- in
- if b_modif then
- (* we may be able to associate something else *)
- iter remaining_modules
- else
- (* nothing changed, we won' be able to associate any more *)
- acc_names_not_found
- in
- let names_not_found = iter module_list in
- (
- match names_not_found with
- [] ->
- ()
- | l ->
- List.iter
- (fun nf ->
- Odoc_messages.pwarning
- (
- match nf with
- NF_m n -> Odoc_messages.cross_module_not_found n
- | NF_mt n -> Odoc_messages.cross_module_type_not_found n
- | NF_mmt n -> Odoc_messages.cross_module_or_module_type_not_found n
- | NF_c n -> Odoc_messages.cross_class_not_found n
- | NF_ct n -> Odoc_messages.cross_class_type_not_found n
- | NF_cct n -> Odoc_messages.cross_class_or_class_type_not_found n
- | NF_ex n -> Odoc_messages.cross_exception_not_found n
- );
- )
- l
- ) ;
-
- (* Find a type for each name of element which is referenced in comments. *)
- let _ = associate_type_of_elements_in_comments module_list in
- ()
-
-
-(* eof $Id$ *)
diff --git a/ocamldoc/odoc_cross.mli b/ocamldoc/odoc_cross.mli
deleted file mode 100644
index 1c6a357027..0000000000
--- a/ocamldoc/odoc_cross.mli
+++ /dev/null
@@ -1,17 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Cross-referencing. *)
-
-val associate : Odoc_module.t_module list -> unit
-
diff --git a/ocamldoc/odoc_dag2html.ml b/ocamldoc/odoc_dag2html.ml
deleted file mode 100644
index 805cdc1efe..0000000000
--- a/ocamldoc/odoc_dag2html.ml
+++ /dev/null
@@ -1,1756 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** The types and functions to create a html table representing a dag. Thanks to Daniel De Rauglaudre. *)
-
-type 'a dag = { mutable dag : 'a node array }
-and 'a node =
- { mutable pare : idag list; valu : 'a; mutable chil : idag list }
-and idag = int
-;;
-
-external int_of_idag : idag -> int = "%identity";;
-external idag_of_int : int -> idag = "%identity";;
-
-type 'a table = { mutable table : 'a data array array }
-and 'a data = { mutable elem : 'a elem; mutable span : span_id }
-and 'a elem = Elem of 'a | Ghost of ghost_id | Nothing
-and span_id
-and ghost_id
-;;
-
-external span_id_of_int : int -> span_id = "%identity";;
-external int_of_span_id : span_id -> int = "%identity";;
-external ghost_id_of_int : int -> ghost_id = "%identity";;
-external int_of_ghost_id : ghost_id -> int = "%identity";;
-
-let new_span_id = let i = ref 0 in fun () -> incr i; span_id_of_int !i;;
-
-let new_ghost_id = let i = ref 0 in fun () -> incr i; ghost_id_of_int !i;;
-
-(** creating the html table structure *)
-
-type align = LeftA | CenterA | RightA;;
-type table_data = TDstring of string | TDhr of align;;
-type html_table = (int * align * table_data) array array;;
-
-let html_table_struct indi_txt phony d t =
- let phony =
- function
- Elem e -> phony d.dag.(int_of_idag e)
- | Ghost _ -> false
- | Nothing -> true
- in
- let jlast = Array.length t.table.(0) - 1 in
- let elem_txt =
- function
- Elem e -> indi_txt d.dag.(int_of_idag e)
- | Ghost _ -> "|"
- | Nothing -> "&nbsp;"
- in
- let bar_txt =
- function
- Elem _ | Ghost _ -> "|"
- | Nothing -> "&nbsp;"
- in
- let all_empty i =
- let rec loop j =
- if j = Array.length t.table.(i) then true
- else
- match t.table.(i).(j).elem with
- Nothing -> loop (j + 1)
- | e -> if phony e then loop (j + 1) else false
- in
- loop 0
- in
- let line_elem_txt i =
- let les =
- let rec loop les j =
- if j = Array.length t.table.(i) then les
- else
- let x = t.table.(i).(j) in
- let next_j =
- let rec loop j =
- if j = Array.length t.table.(i) then j
- else if t.table.(i).(j) = x then loop (j + 1)
- else j
- in
- loop (j + 1)
- in
- let colspan = 3 * (next_j - j) in
- let les = (1, LeftA, TDstring "&nbsp;") :: les in
- let les =
- let s =
- if t.table.(i).(j).elem = Nothing then "&nbsp;"
- else elem_txt t.table.(i).(j).elem
- in
- (colspan - 2, CenterA, TDstring s) :: les
- in
- let les = (1, LeftA, TDstring "&nbsp;") :: les in loop les next_j
- in
- loop [] 0
- in
- Array.of_list (List.rev les)
- in
- let vbars_txt k i =
- let les =
- let rec loop les j =
- if j = Array.length t.table.(i) then les
- else
- let x = t.table.(i).(j) in
- let next_j =
- let rec loop j =
- if j = Array.length t.table.(i) then j
- else if t.table.(i).(j) = x then loop (j + 1)
- else j
- in
- loop (j + 1)
- in
- let colspan = 3 * (next_j - j) in
- let les = (1, LeftA, TDstring "&nbsp;") :: les in
- let les =
- let s =
- if k > 0 && t.table.(k - 1).(j).elem = Nothing ||
- t.table.(k).(j).elem = Nothing then
- "&nbsp;"
- else if phony t.table.(i).(j).elem then "&nbsp;"
- else bar_txt t.table.(i).(j).elem
- in
- (colspan - 2, CenterA, TDstring s) :: les
- in
- let les = (1, LeftA, TDstring "&nbsp;") :: les in loop les next_j
- in
- loop [] 0
- in
- Array.of_list (List.rev les)
- in
- let alone_bar_txt i =
- let les =
- let rec loop les j =
- if j = Array.length t.table.(i) then les
- else
- let next_j =
- let x = t.table.(i).(j).span in
- let rec loop j =
- if j = Array.length t.table.(i) then j
- else if t.table.(i).(j).span = x then loop (j + 1)
- else j
- in
- loop (j + 1)
- in
- let colspan = 3 * (next_j - j) - 2 in
- let les = (1, LeftA, TDstring "&nbsp;") :: les in
- let les =
- if t.table.(i).(j).elem = Nothing ||
- t.table.(i + 1).(j).elem = Nothing then
- (colspan, LeftA, TDstring "&nbsp;") :: les
- else
- let s =
- let all_ph =
- let rec loop j =
- if j = next_j then true
- else if phony t.table.(i + 1).(j).elem then loop (j + 1)
- else false
- in
- loop j
- in
- if all_ph then "&nbsp;" else "|"
- in
- (colspan, CenterA, TDstring s) :: les
- in
- let les = (1, LeftA, TDstring "&nbsp;") :: les in loop les next_j
- in
- loop [] 0
- in
- Array.of_list (List.rev les)
- in
- let exist_several_branches i k =
- let rec loop j =
- if j = Array.length t.table.(i) then false
- else
- let x = t.table.(i).(j).span in
- let e = t.table.(k).(j).elem in
- let rec loop1 j =
- if j = Array.length t.table.(i) then false
- else if t.table.(i).(j).elem = Nothing then loop j
- else if t.table.(i).(j).span <> x then loop j
- else if t.table.(k).(j).elem <> e then true
- else loop1 (j + 1)
- in
- loop1 (j + 1)
- in
- loop 0
- in
- let hbars_txt i k =
- let les =
- let rec loop les j =
- if j = Array.length t.table.(i) then les
- else
- let next_j =
- let e = t.table.(i).(j).elem in
- let x = t.table.(i).(j).span in
- let rec loop j =
- if j = Array.length t.table.(i) then j
- else if e = Nothing && t.table.(i).(j).elem = Nothing then
- loop (j + 1)
- else if t.table.(i).(j).span = x then loop (j + 1)
- else j
- in
- loop (j + 1)
- in
- let rec loop1 les l =
- if l = next_j then loop les next_j
- else
- let next_l =
- let y = t.table.(k).(l) in
- match y.elem with
- Elem _ | Ghost _ ->
- let rec loop l =
- if l = Array.length t.table.(i) then l
- else if t.table.(k).(l) = y then loop (l + 1)
- else l
- in
- loop (l + 1)
- | _ -> l + 1
- in
- if next_l > next_j then
- begin
- Printf.eprintf
- "assert false i %d k %d l %d next_l %d next_j %d\n" i k l
- next_l next_j;
- flush stderr
- end;
- let next_l = min next_l next_j in
- let colspan = 3 * (next_l - l) - 2 in
- let les =
- match t.table.(i).(l).elem, t.table.(i + 1).(l).elem with
- Nothing, _ | _, Nothing ->
- (colspan + 2, LeftA, TDstring "&nbsp;") :: les
- | _ ->
- let ph s =
- if phony t.table.(k).(l).elem then TDstring "&nbsp;"
- else s
- in
- if l = j && next_l = next_j then
- let les = (1, LeftA, TDstring "&nbsp;") :: les in
- let s = ph (TDstring "|") in
- let les = (colspan, CenterA, s) :: les in
- let les = (1, LeftA, TDstring "&nbsp;") :: les in les
- else if l = j then
- let les = (1, LeftA, TDstring "&nbsp;") :: les in
- let s = ph (TDhr RightA) in
- let les = (colspan, RightA, s) :: les in
- let s = ph (TDhr CenterA) in
- let les = (1, LeftA, s) :: les in les
- else if next_l = next_j then
- let s = ph (TDhr CenterA) in
- let les = (1, LeftA, s) :: les in
- let s = ph (TDhr LeftA) in
- let les = (colspan, LeftA, s) :: les in
- let les = (1, LeftA, TDstring "&nbsp;") :: les in les
- else
- let s = ph (TDhr CenterA) in
- (colspan + 2, LeftA, s) :: les
- in
- loop1 les next_l
- in
- loop1 les j
- in
- loop [] 0
- in
- Array.of_list (List.rev les)
- in
- let hts =
- let rec loop hts i =
- if i = Array.length t.table then hts
- else if i = Array.length t.table - 1 && all_empty i then hts
- else
- let hts = line_elem_txt i :: hts in
- let hts =
- if i < Array.length t.table - 1 then
- let hts = vbars_txt (i + 1) i :: hts in
- let hts =
- if exist_several_branches i i then
- alone_bar_txt i :: hbars_txt i i :: hts
- else hts
- in
- let hts =
- if exist_several_branches i (i + 1) &&
- (i < Array.length t.table - 2 ||
- not (all_empty (i + 1))) then
- vbars_txt (i + 1) (i + 1) :: hbars_txt i (i + 1) :: hts
- else hts
- in
- hts
- else hts
- in
- loop hts (i + 1)
- in
- loop [] 0
- in
- Array.of_list (List.rev hts)
-;;
-
-(** transforming dag into table *)
-
-let ancestors d =
- let rec loop i =
- if i = Array.length d.dag then []
- else
- let n = d.dag.(i) in
- if n.pare = [] then idag_of_int i :: loop (i + 1) else loop (i + 1)
- in
- loop 0
-;;
-
-let get_children d parents =
- let rec merge_children children el =
- List.fold_right
- (fun (x, _) children ->
- match x with
- Elem e ->
- let e = d.dag.(int_of_idag e) in
- List.fold_right
- (fun c children ->
- if List.mem c children then children else c :: children)
- e.chil children
- | _ -> [])
- el children
- in
- merge_children [] parents
-;;
-
-let rec get_block t i j =
- if j = Array.length t.table.(i) then None
- else if j = Array.length t.table.(i) - 1 then
- let x = t.table.(i).(j) in Some ([x.elem, 1], 1, x.span)
- else
- let x = t.table.(i).(j) in
- let y = t.table.(i).(j + 1) in
- if y.span = x.span then
- match get_block t i (j + 1) with
- Some ((x1, c1) :: list, mpc, span) ->
- let (list, mpc) =
- if x1 = x.elem then (x1, c1 + 1) :: list, max mpc (c1 + 1)
- else (x.elem, 1) :: (x1, c1) :: list, max mpc c1
- in
- Some (list, mpc, span)
- | _ -> assert false
- else Some ([x.elem, 1], 1, x.span)
-;;
-
-let group_by_common_children d list =
- let module O = struct type t = idag;; let compare = compare;; end
- in
- let module S = Set.Make (O)
- in
- let nlcsl =
- List.map
- (fun id ->
- let n = d.dag.(int_of_idag id) in
- let cs = List.fold_right S.add n.chil S.empty in [id], cs)
- list
- in
- let nlcsl =
- let rec loop =
- function
- [] -> []
- | (nl, cs) :: rest ->
- let rec loop1 beg =
- function
- (nl1, cs1) :: rest1 ->
- if S.is_empty (S.inter cs cs1) then
- loop1 ((nl1, cs1) :: beg) rest1
- else
- loop ((nl @ nl1, S.union cs cs1) :: (List.rev beg @ rest1))
- | [] -> (nl, cs) :: loop rest
- in
- loop1 [] rest
- in
- loop nlcsl
- in
- List.fold_right
- (fun (nl, _) a ->
- let span = new_span_id () in
- List.fold_right (fun n a -> {elem = Elem n; span = span} :: a) nl a)
- nlcsl []
-;;
-
-let copy_data d = {elem = d.elem; span = d.span};;
-
-let insert_columns t nb j =
- let t1 = Array.create (Array.length t.table) [| |] in
- for i = 0 to Array.length t.table - 1 do
- let line = t.table.(i) in
- let line1 = Array.create (Array.length line + nb) line.(0) in
- t1.(i) <- line1;
- let rec loop k =
- if k = Array.length line then ()
- else
- begin
- if k < j then line1.(k) <- copy_data line.(k)
- else if k = j then
- for r = 0 to nb do line1.(k + r) <- copy_data line.(k) done
- else line1.(k + nb) <- copy_data line.(k);
- loop (k + 1)
- end
- in
- loop 0
- done;
- {table = t1}
-;;
-
-let rec gcd a b =
- if a < b then gcd b a else if b = 0 then a else gcd b (a mod b)
-;;
-
-let treat_new_row d t =
- let i = Array.length t.table - 1 in
- let rec loop t i j =
- match get_block t i j with
- Some (parents, max_parent_colspan, span) ->
- let children = get_children d parents in
- let children =
- if children = [] then [{elem = Nothing; span = new_span_id ()}]
- else
- List.map (fun n -> {elem = Elem n; span = new_span_id ()})
- children
- in
- let simple_parents_colspan =
- List.fold_left (fun x (_, c) -> x + c) 0 parents
- in
- if simple_parents_colspan mod List.length children = 0 then
- let j = j + simple_parents_colspan in
- let children =
- let cnt = simple_parents_colspan / List.length children in
- List.fold_right
- (fun d list ->
- let rec loop cnt list =
- if cnt = 1 then d :: list
- else copy_data d :: loop (cnt - 1) list
- in
- loop cnt list)
- children []
- in
- let (t, children_rest) = loop t i j in t, children @ children_rest
- else
- let parent_colspan =
- List.fold_left
- (fun scm (_, c) -> let g = gcd scm c in scm / g * c)
- max_parent_colspan parents
- in
- let (t, parents, _) =
- List.fold_left
- (fun (t, parents, j) (x, c) ->
- let to_add = parent_colspan / c - 1 in
- let t =
- let rec loop cc t j =
- if cc = 0 then t
- else
- let t = insert_columns t to_add j in
- loop (cc - 1) t (j + to_add + 1)
- in
- loop c t j
- in
- t, (x, parent_colspan) :: parents, j + parent_colspan)
- (t, [], j) parents
- in
- let parents = List.rev parents in
- let parents_colspan = parent_colspan * List.length parents in
- let children_colspan = List.length children in
- let g = gcd parents_colspan children_colspan in
- let (t, j) =
- let cnt = children_colspan / g in
- List.fold_left
- (fun (t, j) (_, c) ->
- let rec loop cc t j =
- if cc = 0 then t, j
- else
- let t = insert_columns t (cnt - 1) j in
- let j = j + cnt in loop (cc - 1) t j
- in
- loop c t j)
- (t, j) parents
- in
- let children =
- let cnt = parents_colspan / g in
- List.fold_right
- (fun d list ->
- let rec loop cnt list =
- if cnt = 0 then list else d :: loop (cnt - 1) list
- in
- loop cnt list)
- children []
- in
- let (t, children_rest) = loop t i j in t, children @ children_rest
- | None -> t, []
- in
- loop t i 0
-;;
-
-let down_it t i k y =
- t.table.(Array.length t.table - 1).(k) <- t.table.(i).(k);
- for r = i to Array.length t.table - 2 do
- t.table.(r).(k) <- {elem = Ghost (new_ghost_id ()); span = new_span_id ()}
- done
-;;
-
-(* equilibrate:
- in the last line, for all elem A, make fall all As, which are located at
- its right side above, to its line,
- A |
- i.e. transform all . into |
- A....... A......A
-*)
-
-let equilibrate t =
- let ilast = Array.length t.table - 1 in
- let last = t.table.(ilast) in
- let len = Array.length last in
- let rec loop j =
- if j = len then ()
- else
- match last.(j).elem with
- Elem x ->
- let rec loop1 i =
- if i = ilast then loop (j + 1)
- else
- let rec loop2 k =
- if k = len then loop1 (i + 1)
- else
- match t.table.(i).(k).elem with
- Elem y when x = y -> down_it t i k y; loop 0
- | _ -> loop2 (k + 1)
- in
- loop2 0
- in
- loop1 0
- | _ -> loop (j + 1)
- in
- loop 0
-;;
-
-(* group_elem:
- transform all x y into x x
- A A A A *)
-
-let group_elem t =
- for i = 0 to Array.length t.table - 2 do
- for j = 1 to Array.length t.table.(0) - 1 do
- match t.table.(i + 1).(j - 1).elem, t.table.(i + 1).(j).elem with
- Elem x, Elem y when x = y ->
- t.table.(i).(j).span <- t.table.(i).(j - 1).span
- | _ -> ()
- done
- done
-;;
-
-(* group_ghost:
- x x x x |a |a |a |a
- transform all |a |b into |a |a and all x y into x x
- y z y y A A A A *)
-
-let group_ghost t =
- for i = 0 to Array.length t.table - 2 do
- for j = 1 to Array.length t.table.(0) - 1 do
- begin match t.table.(i + 1).(j - 1).elem, t.table.(i + 1).(j).elem with
- Ghost x, Ghost _ ->
- if t.table.(i).(j - 1).span = t.table.(i).(j).span then
- t.table.(i + 1).(j) <-
- {elem = Ghost x; span = t.table.(i + 1).(j - 1).span}
- | _ -> ()
- end;
- match t.table.(i).(j - 1).elem, t.table.(i).(j).elem with
- Ghost x, Ghost _ ->
- if t.table.(i + 1).(j - 1).elem = t.table.(i + 1).(j).elem then
- begin
- t.table.(i).(j) <-
- {elem = Ghost x; span = t.table.(i).(j - 1).span};
- if i > 0 then
- t.table.(i - 1).(j).span <- t.table.(i - 1).(j - 1).span
- end
- | _ -> ()
- done
- done
-;;
-
-(* group_children:
- transform all A A into A A
- x y x x *)
-
-let group_children t =
- for i = 0 to Array.length t.table - 1 do
- let line = t.table.(i) in
- let len = Array.length line in
- for j = 1 to len - 1 do
- if line.(j).elem = line.(j - 1).elem && line.(j).elem <> Nothing then
- line.(j).span <- line.(j - 1).span
- done
- done
-;;
-
-(* group_span_by_common_children:
- in the last line, transform all
- A B into A B
- x y x x
- if A and B have common children *)
-
-let group_span_by_common_children d t =
- let module O = struct type t = idag;; let compare = compare;; end
- in
- let module S = Set.Make (O)
- in
- let i = Array.length t.table - 1 in
- let line = t.table.(i) in
- let rec loop j cs =
- if j = Array.length line then ()
- else
- match line.(j).elem with
- Elem id ->
- let n = d.dag.(int_of_idag id) in
- let curr_cs = List.fold_right S.add n.chil S.empty in
- if S.is_empty (S.inter cs curr_cs) then loop (j + 1) curr_cs
- else
- begin
- line.(j).span <- line.(j - 1).span;
- loop (j + 1) (S.union cs curr_cs)
- end
- | _ -> loop (j + 1) S.empty
- in
- loop 0 S.empty
-;;
-
-let find_same_parents t i j1 j2 j3 j4 =
- let rec loop i j1 j2 j3 j4 =
- if i = 0 then i, j1, j2, j3, j4
- else
- let x1 = t.(i - 1).(j1) in
- let x2 = t.(i - 1).(j2) in
- let x3 = t.(i - 1).(j3) in
- let x4 = t.(i - 1).(j4) in
- if x1.span = x4.span then i, j1, j2, j3, j4
- else
- let j1 =
- let rec loop j =
- if j < 0 then 0
- else if t.(i - 1).(j).span = x1.span then loop (j - 1)
- else j + 1
- in
- loop (j1 - 1)
- in
- let j2 =
- let rec loop j =
- if j >= Array.length t.(i) then j - 1
- else if t.(i - 1).(j).span = x2.span then loop (j + 1)
- else j - 1
- in
- loop (j2 + 1)
- in
- let j3 =
- let rec loop j =
- if j < 0 then 0
- else if t.(i - 1).(j).span = x3.span then loop (j - 1)
- else j + 1
- in
- loop (j3 - 1)
- in
- let j4 =
- let rec loop j =
- if j >= Array.length t.(i) then j - 1
- else if t.(i - 1).(j).span = x4.span then loop (j + 1)
- else j - 1
- in
- loop (j4 + 1)
- in
- loop (i - 1) j1 j2 j3 j4
- in
- loop i j1 j2 j3 j4
-;;
-
-let find_linked_children t i j1 j2 j3 j4 =
- let rec loop i j1 j2 j3 j4 =
- if i = Array.length t - 1 then j1, j2, j3, j4
- else
- let x1 = t.(i).(j1) in
- let x2 = t.(i).(j2) in
- let x3 = t.(i).(j3) in
- let x4 = t.(i).(j4) in
- let j1 =
- let rec loop j =
- if j < 0 then 0
- else if t.(i).(j).span = x1.span then loop (j - 1)
- else j + 1
- in
- loop (j1 - 1)
- in
- let j2 =
- let rec loop j =
- if j >= Array.length t.(i) then j - 1
- else if t.(i).(j).span = x2.span then loop (j + 1)
- else j - 1
- in
- loop (j2 + 1)
- in
- let j3 =
- let rec loop j =
- if j < 0 then 0
- else if t.(i).(j).span = x3.span then loop (j - 1)
- else j + 1
- in
- loop (j3 - 1)
- in
- let j4 =
- let rec loop j =
- if j >= Array.length t.(i) then j - 1
- else if t.(i).(j).span = x4.span then loop (j + 1)
- else j - 1
- in
- loop (j4 + 1)
- in
- loop (i + 1) j1 j2 j3 j4
- in
- loop i j1 j2 j3 j4
-;;
-
-let mirror_block t i1 i2 j1 j2 =
- for i = i1 to i2 do
- let line = t.(i) in
- let rec loop j1 j2 =
- if j1 >= j2 then ()
- else
- let v = line.(j1) in
- line.(j1) <- line.(j2); line.(j2) <- v; loop (j1 + 1) (j2 - 1)
- in
- loop j1 j2
- done
-;;
-
-let exch_blocks t i1 i2 j1 j2 j3 j4 =
- for i = i1 to i2 do
- let line = t.(i) in
- let saved = Array.copy line in
- for j = j1 to j2 do line.(j4 - j2 + j) <- saved.(j) done;
- for j = j3 to j4 do line.(j1 - j3 + j) <- saved.(j) done
- done
-;;
-
-let find_block_with_parents t i jj1 jj2 jj3 jj4 =
- let rec loop ii jj1 jj2 jj3 jj4 =
- let (nii, njj1, njj2, njj3, njj4) =
- find_same_parents t i jj1 jj2 jj3 jj4
- in
- if nii <> ii || njj1 <> jj1 || njj2 <> jj2 || njj3 <> jj3 ||
- njj4 <> jj4 then
- let nii = min ii nii in
- let (jj1, jj2, jj3, jj4) =
- find_linked_children t nii njj1 njj2 njj3 njj4
- in
- if njj1 <> jj1 || njj2 <> jj2 || njj3 <> jj3 || njj4 <> jj4 then
- loop nii jj1 jj2 jj3 jj4
- else nii, jj1, jj2, jj3, jj4
- else ii, jj1, jj2, jj3, jj4
- in
- loop i jj1 jj2 jj3 jj4
-;;
-
-let push_to_right d t i j1 j2 =
- let line = t.(i) in
- let rec loop j =
- if j = j2 then j - 1
- else
- let ini_jj1 =
- match line.(j - 1).elem with
- Nothing -> j - 1
- | x ->
- let rec same_value j =
- if j < 0 then 0
- else if line.(j).elem = x then same_value (j - 1)
- else j + 1
- in
- same_value (j - 2)
- in
- let jj1 = ini_jj1 in
- let jj2 = j - 1 in
- let jj3 = j in
- let jj4 =
- match line.(j).elem with
- Nothing -> j
- | x ->
- let rec same_value j =
- if j >= Array.length line then j - 1
- else if line.(j).elem = x then same_value (j + 1)
- else j - 1
- in
- same_value (j + 1)
- in
- let (ii, jj1, jj2, jj3, jj4) =
- find_block_with_parents t i jj1 jj2 jj3 jj4
- in
- if jj4 < j2 && jj2 < jj3 then
- begin exch_blocks t ii i jj1 jj2 jj3 jj4; loop (jj4 + 1) end
- else if jj4 < j2 && jj1 = ini_jj1 && jj2 <= jj4 then
- begin mirror_block t ii i jj1 jj4; loop (jj4 + 1) end
- else j - 1
- in
- loop (j1 + 1)
-;;
-
-let push_to_left d t i j1 j2 =
- let line = t.(i) in
- let rec loop j =
- if j = j1 then j + 1
- else
- let jj1 =
- match line.(j).elem with
- Nothing -> j
- | x ->
- let rec same_value j =
- if j < 0 then 0
- else if line.(j).elem = x then same_value (j - 1)
- else j + 1
- in
- same_value (j - 1)
- in
- let jj2 = j in
- let jj3 = j + 1 in
- let ini_jj4 =
- match line.(j + 1).elem with
- Nothing -> j + 1
- | x ->
- let rec same_value j =
- if j >= Array.length line then j - 1
- else if line.(j).elem = x then same_value (j + 1)
- else j - 1
- in
- same_value (j + 2)
- in
- let jj4 = ini_jj4 in
- let (ii, jj1, jj2, jj3, jj4) =
- find_block_with_parents t i jj1 jj2 jj3 jj4
- in
- if jj1 > j1 && jj2 < jj3 then
- begin exch_blocks t ii i jj1 jj2 jj3 jj4; loop (jj1 - 1) end
- else if jj1 > j1 && jj4 = ini_jj4 && jj3 >= jj1 then
- begin mirror_block t ii i jj1 jj4; loop (jj1 - 1) end
- else j + 1
- in
- loop (j2 - 1)
-;;
-
-let fill_gap d t i j1 j2 =
- let t1 =
- let t1 = Array.copy t.table in
- for i = 0 to Array.length t.table - 1 do
- t1.(i) <- Array.copy t.table.(i);
- for j = 0 to Array.length t1.(i) - 1 do
- t1.(i).(j) <- copy_data t.table.(i).(j)
- done
- done;
- t1
- in
- let j2 = push_to_left d t1 i j1 j2 in
- let j1 = push_to_right d t1 i j1 j2 in
- if j1 = j2 - 1 then
- let line = t1.(i - 1) in
- let x = line.(j1).span in
- let y = line.(j2).span in
- let rec loop y j =
- if j >= Array.length line then ()
- else if line.(j).span = y || t1.(i).(j).elem = t1.(i).(j - 1).elem then
- let y = line.(j).span in
- line.(j).span <- x;
- if i > 0 then t1.(i - 1).(j).span <- t1.(i - 1).(j - 1).span;
- loop y (j + 1)
- in
- loop y j2; Some ({table = t1}, true)
- else None
-;;
-
-let treat_gaps d t =
- let i = Array.length t.table - 1 in
- let rec loop t j =
- let line = t.table.(i) in
- if j = Array.length line then t
- else
- match line.(j).elem with
- Elem _ as y ->
- if y = line.(j - 1).elem then loop t (j + 1)
- else
- let rec loop1 t j1 =
- if j1 < 0 then loop t (j + 1)
- else if y = line.(j1).elem then
- match fill_gap d t i j1 j with
- Some (t, ok) -> if ok then loop t 2 else loop t (j + 1)
- | None -> loop t (j + 1)
- else loop1 t (j1 - 1)
- in
- loop1 t (j - 2)
- | _ -> loop t (j + 1)
- in
- if Array.length t.table.(i) = 1 then t else loop t 2
-;;
-
-let group_span_last_row t =
- let row = t.table.(Array.length t.table - 1) in
- let rec loop i =
- if i >= Array.length row then ()
- else
- begin
- begin match row.(i).elem with
- Elem _ | Ghost _ as x ->
- if x = row.(i - 1).elem then row.(i).span <- row.(i - 1).span
- | _ -> ()
- end;
- loop (i + 1)
- end
- in
- loop 1
-;;
-
-let has_phony_children phony d t =
- let line = t.table.(Array.length t.table - 1) in
- let rec loop j =
- if j = Array.length line then false
- else
- match line.(j).elem with
- Elem x -> if phony d.dag.(int_of_idag x) then true else loop (j + 1)
- | _ -> loop (j + 1)
- in
- loop 0
-;;
-
-let tablify phony no_optim no_group d =
- let a = ancestors d in
- let r = group_by_common_children d a in
- let t = {table = [| Array.of_list r |]} in
- let rec loop t =
- let (t, new_row) = treat_new_row d t in
- if List.for_all (fun x -> x.elem = Nothing) new_row then t
- else
- let t = {table = Array.append t.table [| Array.of_list new_row |]} in
- let t =
- if no_group && not (has_phony_children phony d t) then t
- else
- let _ = if no_optim then () else equilibrate t in
- let _ = group_elem t in
- let _ = group_ghost t in
- let _ = group_children t in
- let _ = group_span_by_common_children d t in
- let t = if no_optim then t else treat_gaps d t in
- let _ = group_span_last_row t in t
- in
- loop t
- in
- loop t
-;;
-
-let fall d t =
- for i = 1 to Array.length t.table - 1 do
- let line = t.table.(i) in
- let rec loop j =
- if j = Array.length line then ()
- else
- match line.(j).elem with
- Ghost x ->
- let j2 =
- let rec loop j =
- if j = Array.length line then j - 1
- else
- match line.(j).elem with
- Ghost y when y = x -> loop (j + 1)
- | _ -> j - 1
- in
- loop (j + 1)
- in
- let i1 =
- let rec loop i =
- if i < 0 then i + 1
- else
- let line = t.table.(i) in
- if (j = 0 || line.(j - 1).span <> line.(j).span) &&
- (j2 = Array.length line - 1 ||
- line.(j2 + 1).span <> line.(j2).span) then
- loop (i - 1)
- else i + 1
- in
- loop (i - 1)
- in
- let i1 =
- if i1 = i then i1
- else if i1 = 0 then i1
- else if t.table.(i1).(j).elem = Nothing then i1
- else i
- in
- if i1 < i then
- begin
- for k = i downto i1 + 1 do
- for j = j to j2 do
- t.table.(k).(j).elem <- t.table.(k - 1).(j).elem;
- if k < i then
- t.table.(k).(j).span <- t.table.(k - 1).(j).span
- done
- done;
- for l = j to j2 do
- if i1 = 0 || t.table.(i1 - 1).(l).elem = Nothing then
- t.table.(i1).(l).elem <- Nothing
- else
- t.table.(i1).(l) <-
- if l = j ||
- t.table.(i1 - 1).(l - 1).span <>
- t.table.(i1 - 1).(l).span then
- {elem = Ghost (new_ghost_id ());
- span = new_span_id ()}
- else copy_data t.table.(i1).(l - 1)
- done
- end;
- loop (j2 + 1)
- | _ -> loop (j + 1)
- in
- loop 0
- done
-;;
-
-let fall2_cool_right t i1 i2 i3 j1 j2 =
- let span = t.table.(i2 - 1).(j1).span in
- for i = i2 - 1 downto 0 do
- for j = j1 to j2 - 1 do
- t.table.(i).(j) <-
- if i - i2 + i1 >= 0 then t.table.(i - i2 + i1).(j)
- else {elem = Nothing; span = new_span_id ()}
- done
- done;
- for i = Array.length t.table - 1 downto 0 do
- for j = j2 to Array.length t.table.(i) - 1 do
- t.table.(i).(j) <-
- if i - i2 + i1 >= 0 then t.table.(i - i2 + i1).(j)
- else {elem = Nothing; span = new_span_id ()}
- done
- done;
- let old_span = t.table.(i2 - 1).(j1).span in
- let rec loop j =
- if j = Array.length t.table.(i2 - 1) then ()
- else if t.table.(i2 - 1).(j).span = old_span then
- begin t.table.(i2 - 1).(j).span <- span; loop (j + 1) end
- in
- loop j1
-;;
-
-let fall2_cool_left t i1 i2 i3 j1 j2 =
- let span = t.table.(i2 - 1).(j2).span in
- for i = i2 - 1 downto 0 do
- for j = j1 + 1 to j2 do
- t.table.(i).(j) <-
- if i - i2 + i1 >= 0 then t.table.(i - i2 + i1).(j)
- else {elem = Nothing; span = new_span_id ()}
- done
- done;
- for i = Array.length t.table - 1 downto 0 do
- for j = j1 downto 0 do
- t.table.(i).(j) <-
- if i - i2 + i1 >= 0 then t.table.(i - i2 + i1).(j)
- else {elem = Nothing; span = new_span_id ()}
- done
- done;
- let old_span = t.table.(i2 - 1).(j2).span in
- let rec loop j =
- if j < 0 then ()
- else if t.table.(i2 - 1).(j).span = old_span then
- begin t.table.(i2 - 1).(j).span <- span; loop (j - 1) end
- in
- loop j2
-;;
-
-let do_fall2_right t i1 i2 j1 j2 =
- let i3 =
- let rec loop_i i =
- if i < 0 then 0
- else
- let rec loop_j j =
- if j = Array.length t.table.(i) then loop_i (i - 1)
- else
- match t.table.(i).(j).elem with
- Nothing -> loop_j (j + 1)
- | _ -> i + 1
- in
- loop_j j2
- in
- loop_i (Array.length t.table - 1)
- in
- let new_height = i3 + i2 - i1 in
- let t =
- if new_height > Array.length t.table then
- let rec loop cnt t =
- if cnt = 0 then t
- else
- let new_line =
- Array.init (Array.length t.table.(0))
- (fun i -> {elem = Nothing; span = new_span_id ()})
- in
- let t = {table = Array.append t.table [| new_line |]} in
- loop (cnt - 1) t
- in
- loop (new_height - Array.length t.table) t
- else t
- in
- fall2_cool_right t i1 i2 i3 j1 j2; t
-;;
-
-let do_fall2_left t i1 i2 j1 j2 =
- let i3 =
- let rec loop_i i =
- if i < 0 then 0
- else
- let rec loop_j j =
- if j < 0 then loop_i (i - 1)
- else
- match t.table.(i).(j).elem with
- Nothing -> loop_j (j - 1)
- | _ -> i + 1
- in
- loop_j j1
- in
- loop_i (Array.length t.table - 1)
- in
- let new_height = i3 + i2 - i1 in
- let t =
- if new_height > Array.length t.table then
- let rec loop cnt t =
- if cnt = 0 then t
- else
- let new_line =
- Array.init (Array.length t.table.(0))
- (fun i -> {elem = Nothing; span = new_span_id ()})
- in
- let t = {table = Array.append t.table [| new_line |]} in
- loop (cnt - 1) t
- in
- loop (new_height - Array.length t.table) t
- else t
- in
- fall2_cool_left t i1 i2 i3 j1 j2; t
-;;
-
-let do_shorten_too_long t i1 j1 j2 =
- for i = i1 to Array.length t.table - 2 do
- for j = j1 to j2 - 1 do t.table.(i).(j) <- t.table.(i + 1).(j) done
- done;
- let i = Array.length t.table - 1 in
- for j = j1 to j2 - 1 do
- t.table.(i).(j) <- {elem = Nothing; span = new_span_id ()}
- done;
- t
-;;
-
-let try_fall2_right t i j =
- match t.table.(i).(j).elem with
- Ghost _ ->
- let i1 =
- let rec loop i =
- if i < 0 then 0
- else
- match t.table.(i).(j).elem with
- Ghost _ -> loop (i - 1)
- | _ -> i + 1
- in
- loop (i - 1)
- in
- let separated1 =
- let rec loop i =
- if i < 0 then true
- else if
- j > 0 && t.table.(i).(j - 1).span = t.table.(i).(j).span then
- false
- else loop (i - 1)
- in
- loop (i1 - 1)
- in
- let j2 =
- let x = t.table.(i).(j).span in
- let rec loop j2 =
- if j2 = Array.length t.table.(i) then j2
- else
- match t.table.(i).(j2) with
- {elem = Ghost _; span = y} when y = x -> loop (j2 + 1)
- | _ -> j2
- in
- loop (j + 1)
- in
- let separated2 =
- let rec loop i =
- if i = Array.length t.table then true
- else if j2 = Array.length t.table.(i) then false
- else if t.table.(i).(j2 - 1).span = t.table.(i).(j2).span then false
- else loop (i + 1)
- in
- loop (i + 1)
- in
- if not separated1 || not separated2 then None
- else Some (do_fall2_right t i1 (i + 1) j j2)
- | _ -> None
-;;
-
-let try_fall2_left t i j =
- match t.table.(i).(j).elem with
- Ghost _ ->
- let i1 =
- let rec loop i =
- if i < 0 then 0
- else
- match t.table.(i).(j).elem with
- Ghost _ -> loop (i - 1)
- | _ -> i + 1
- in
- loop (i - 1)
- in
- let separated1 =
- let rec loop i =
- if i < 0 then true
- else if
- j < Array.length t.table.(i) - 1 &&
- t.table.(i).(j).span = t.table.(i).(j + 1).span then
- false
- else loop (i - 1)
- in
- loop (i1 - 1)
- in
- let j1 =
- let x = t.table.(i).(j).span in
- let rec loop j1 =
- if j1 < 0 then j1
- else
- match t.table.(i).(j1) with
- {elem = Ghost _; span = y} when y = x -> loop (j1 - 1)
- | _ -> j1
- in
- loop (j - 1)
- in
- let separated2 =
- let rec loop i =
- if i = Array.length t.table then true
- else if j1 < 0 then false
- else if t.table.(i).(j1).span = t.table.(i).(j1 + 1).span then false
- else loop (i + 1)
- in
- loop (i + 1)
- in
- if not separated1 || not separated2 then None
- else Some (do_fall2_left t i1 (i + 1) j1 j)
- | _ -> None
-;;
-
-let try_shorten_too_long t i j =
- match t.table.(i).(j).elem with
- Ghost _ ->
- let j2 =
- let x = t.table.(i).(j).span in
- let rec loop j2 =
- if j2 = Array.length t.table.(i) then j2
- else
- match t.table.(i).(j2) with
- {elem = Ghost _; span = y} when y = x -> loop (j2 + 1)
- | _ -> j2
- in
- loop (j + 1)
- in
- let i1 =
- let rec loop i =
- if i = Array.length t.table then i
- else
- match t.table.(i).(j).elem with
- Elem _ -> loop (i + 1)
- | _ -> i
- in
- loop (i + 1)
- in
- let i2 =
- let rec loop i =
- if i = Array.length t.table then i
- else
- match t.table.(i).(j).elem with
- Nothing -> loop (i + 1)
- | _ -> i
- in
- loop i1
- in
- let separated_left =
- let rec loop i =
- if i = i2 then true
- else if
- j > 0 && t.table.(i).(j).span = t.table.(i).(j - 1).span then
- false
- else loop (i + 1)
- in
- loop i
- in
- let separated_right =
- let rec loop i =
- if i = i2 then true
- else if
- j2 < Array.length t.table.(i) &&
- t.table.(i).(j2 - 1).span = t.table.(i).(j2).span then
- false
- else loop (i + 1)
- in
- loop i
- in
- if not separated_left || not separated_right then None
- else if i2 < Array.length t.table then None
- else Some (do_shorten_too_long t i j j2)
- | _ -> None
-;;
-
-let fall2_right t =
- let rec loop_i i t =
- if i <= 0 then t
- else
- let rec loop_j j t =
- if j < 0 then loop_i (i - 1) t
- else
- match try_fall2_right t i j with
- Some t -> loop_i (Array.length t.table - 1) t
- | None -> loop_j (j - 1) t
- in
- loop_j (Array.length t.table.(i) - 2) t
- in
- loop_i (Array.length t.table - 1) t
-;;
-
-let fall2_left t =
- let rec loop_i i t =
- if i <= 0 then t
- else
- let rec loop_j j t =
- if j >= Array.length t.table.(i) then loop_i (i - 1) t
- else
- match try_fall2_left t i j with
- Some t -> loop_i (Array.length t.table - 1) t
- | None -> loop_j (j + 1) t
- in
- loop_j 1 t
- in
- loop_i (Array.length t.table - 1) t
-;;
-
-let shorten_too_long t =
- let rec loop_i i t =
- if i <= 0 then t
- else
- let rec loop_j j t =
- if j >= Array.length t.table.(i) then loop_i (i - 1) t
- else
- match try_shorten_too_long t i j with
- Some t -> loop_i (Array.length t.table - 1) t
- | None -> loop_j (j + 1) t
- in
- loop_j 1 t
- in
- loop_i (Array.length t.table - 1) t
-;;
-
-(* top_adjust:
- deletes all empty rows that might have appeared on top of the table
- after the falls *)
-
-let top_adjust t =
- let di =
- let rec loop i =
- if i = Array.length t.table then i
- else
- let rec loop_j j =
- if j = Array.length t.table.(i) then loop (i + 1)
- else if t.table.(i).(j).elem <> Nothing then i
- else loop_j (j + 1)
- in
- loop_j 0
- in
- loop 0
- in
- if di > 0 then
- begin
- for i = 0 to Array.length t.table - 1 - di do
- t.table.(i) <- t.table.(i + di)
- done;
- {table = Array.sub t.table 0 (Array.length t.table - di)}
- end
- else t
-;;
-
-(* bottom_adjust:
- deletes all empty rows that might have appeared on bottom of the table
- after the falls *)
-
-let bottom_adjust t =
- let last_i =
- let rec loop i =
- if i < 0 then i
- else
- let rec loop_j j =
- if j = Array.length t.table.(i) then loop (i - 1)
- else if t.table.(i).(j).elem <> Nothing then i
- else loop_j (j + 1)
- in
- loop_j 0
- in
- loop (Array.length t.table - 1)
- in
- if last_i < Array.length t.table - 1 then
- {table = Array.sub t.table 0 (last_i + 1)}
- else t
-;;
-
-(* invert *)
-
-let invert_dag d =
- let d = {dag = Array.copy d.dag} in
- for i = 0 to Array.length d.dag - 1 do
- let n = d.dag.(i) in
- d.dag.(i) <-
- {pare = List.map (fun x -> x) n.chil; valu = n.valu;
- chil = List.map (fun x -> x) n.pare}
- done;
- d
-;;
-
-let invert_table t =
- let t' = {table = Array.copy t.table} in
- let len = Array.length t.table in
- for i = 0 to len - 1 do
- t'.table.(i) <-
- Array.init (Array.length t.table.(0))
- (fun j ->
- let d = t.table.(len - 1 - i).(j) in
- {elem = d.elem; span = d.span});
- if i < len - 1 then
- for j = 0 to Array.length t'.table.(i) - 1 do
- t'.table.(i).(j).span <- t.table.(len - 2 - i).(j).span
- done
- done;
- t'
-;;
-
-(* main *)
-
-let table_of_dag phony no_optim invert no_group d =
- let d = if invert then invert_dag d else d in
- let t = tablify phony no_optim no_group d in
- let t = if invert then invert_table t else t in
- let _ = fall () t in
- let t = fall2_right t in
- let t = fall2_left t in
- let t = shorten_too_long t in
- let t = top_adjust t in let t = bottom_adjust t in t
-;;
-
-
-let version = "1.01";;
-
-(* input dag *)
-
-let strip_spaces str =
- let start =
- let rec loop i =
- if i == String.length str then i
- else
- match str.[i] with
- ' ' | '\013' | '\n' | '\t' -> loop (i + 1)
- | _ -> i
- in
- loop 0
- in
- let stop =
- let rec loop i =
- if i == -1 then i + 1
- else
- match str.[i] with
- ' ' | '\013' | '\n' | '\t' -> loop (i - 1)
- | _ -> i + 1
- in
- loop (String.length str - 1)
- in
- if start == 0 && stop == String.length str then str
- else if start > stop then ""
- else String.sub str start (stop - start)
-;;
-
-let rec get_line ic =
- try
- let line = input_line ic in
- if String.length line > 0 && line.[0] = '#' then get_line ic
- else Some (strip_spaces line)
- with
- End_of_file -> None
-;;
-
-let input_dag ic =
- let rec find cnt s =
- function
- n :: nl ->
- if n.valu = s then n, idag_of_int cnt else find (cnt - 1) s nl
- | [] -> raise Not_found
- in
- let add_node pl cl nl cnt =
- let cl = List.rev cl in
- let pl = List.rev pl in
- let (pl, pnl, nl, cnt) =
- List.fold_left
- (fun (pl, pnl, nl, cnt) p ->
- try
- let (n, p) = find (cnt - 1) p nl in p :: pl, n :: pnl, nl, cnt
- with
- Not_found ->
- let n = {pare = []; valu = p; chil = []} in
- let p = idag_of_int cnt in p :: pl, n :: pnl, n :: nl, cnt + 1)
- ([], [], nl, cnt) pl
- in
- let pl = List.rev pl in
- let (cl, nl, cnt) =
- List.fold_left
- (fun (cl, nl, cnt) c ->
- try
- let (n, c) = find (cnt - 1) c nl in
- n.pare <- n.pare @ pl; c :: cl, nl, cnt
- with
- Not_found ->
- let n = {pare = pl; valu = c; chil = []} in
- let c = idag_of_int cnt in c :: cl, n :: nl, cnt + 1)
- ([], nl, cnt) cl
- in
- let cl = List.rev cl in
- List.iter (fun p -> p.chil <- p.chil @ cl) pnl; nl, cnt
- in
- let rec input_parents nl pl cnt =
- function
- Some "" -> input_parents nl pl cnt (get_line ic)
- | Some line ->
- begin match line.[0] with
- 'o' ->
- let p =
- strip_spaces (String.sub line 1 (String.length line - 1))
- in
- if p = "" then failwith line
- else input_parents nl (p :: pl) cnt (get_line ic)
- | '-' ->
- if pl = [] then failwith line
- else input_children nl pl [] cnt (Some line)
- | _ -> failwith line
- end
- | None -> if pl = [] then nl, cnt else failwith "end of file 1"
- and input_children nl pl cl cnt =
- function
- Some "" -> input_children nl pl cl cnt (get_line ic)
- | Some line ->
- begin match line.[0] with
- 'o' ->
- if cl = [] then failwith line
- else
- let (nl, cnt) = add_node pl cl nl cnt in
- input_parents nl [] cnt (Some line)
- | '-' ->
- let c =
- strip_spaces (String.sub line 1 (String.length line - 1))
- in
- if c = "" then failwith line
- else input_children nl pl (c :: cl) cnt (get_line ic)
- | _ -> failwith line
- end
- | None ->
- if cl = [] then failwith "end of file 2" else add_node pl cl nl cnt
- in
- let (nl, _) = input_parents [] [] 0 (get_line ic) in
- {dag = Array.of_list (List.rev nl)}
-;;
-
-(* testing *)
-
-let map_dag f d =
- let a =
- Array.map (fun d -> {pare = d.pare; valu = f d.valu; chil = d.chil}) d.dag
- in
- {dag = a}
-;;
-
-let tag_dag d =
- let c = ref 'A' in
- map_dag
- (fun v ->
- let v = !c in
- c :=
- if !c = 'Z' then 'a'
- else if !c = 'z' then '1'
- else Char.chr (Char.code !c + 1);
- String.make 1 v)
- d
-;;
-
-(* *)
-
-let phony _ = false;;
-let indi_txt n = n.valu;;
-
-let string_table border hts =
- let buf = Buffer.create 30 in
- Printf.bprintf buf "<center><table border=%d" border;
- Printf.bprintf buf " cellspacing=0 cellpadding=0>\n";
- for i = 0 to Array.length hts - 1 do
- Printf.bprintf buf "<tr>\n";
- for j = 0 to Array.length hts.(i) - 1 do
- let (colspan, align, td) = hts.(i).(j) in
- Printf.bprintf buf "<td";
- if colspan = 1 && (td = TDstring "&nbsp;" || td = TDhr CenterA) then ()
- else Printf.bprintf buf " colspan=%d" colspan;
- begin match align, td with
- LeftA, TDhr LeftA -> Printf.bprintf buf " align=left"
- | LeftA, _ -> ()
- | CenterA, _ -> Printf.bprintf buf " align=center"
- | RightA, _ -> Printf.bprintf buf " align=right"
- end;
- Printf.bprintf buf ">";
- begin match td with
- TDstring s -> Printf.bprintf buf "%s" s
- | TDhr align ->
- Printf.bprintf buf "<hr noshade size=1";
- begin match align with
- LeftA -> Printf.bprintf buf " width=\"50%%\" align=left"
- | RightA -> Printf.bprintf buf " width=\"50%%\" align=right"
- | _ -> ()
- end;
- Printf.bprintf buf ">";
- ()
- end;
- Printf.bprintf buf "</td>\n";
- ()
- done
- done;
- Printf.bprintf buf "</table></center>\n";
- Buffer.contents buf
-;;
-
-let fname = ref "";;
-let invert = ref false;;
-let char = ref false;;
-let border = ref 0;;
-let no_optim = ref false;;
-let no_group = ref false;;
-
-let html_of_dag d =
- let print_indi n = print_string n.valu in
- let t = table_of_dag phony !no_optim !invert !no_group d in
- let hts = html_table_struct indi_txt phony d t in
- string_table !border hts
-;;
-
-
-(********************************* Max's code **********************************)
-(** This function takes a list of classes and a list of class types
- and create the associate dag. *)
-let create_class_dag cl_list clt_list =
- let module M = Odoc_info.Class in
- (* the list of all the classes concerned *)
- let cl_list2 = List.map (fun c -> (c.M.cl_name, Some (M.Cl c))) cl_list in
- let clt_list2 = List.map (fun ct -> (ct.M.clt_name, Some (M.Cltype (ct, [])))) clt_list in
- let list = cl_list2 @ clt_list2 in
- let all_classes =
- let rec iter list2 =
- List.fold_left
- (fun acc -> fun (name, cct_opt) ->
- let l =
- match cct_opt with
- None -> []
- | Some (M.Cl c) ->
- iter
- (List.map
- (fun inh ->(inh.M.ic_name, inh.M.ic_class))
- (match c.M.cl_kind with
- M.Class_structure (inher_l, _) ->
- inher_l
- | _ ->
- []
- )
- )
- | Some (M.Cltype (ct, _)) ->
- iter
- (List.map
- (fun inh ->(inh.M.ic_name, inh.M.ic_class))
- (match ct.M.clt_kind with
- M.Class_signature (inher_l, _) ->
- inher_l
- | _ ->
- []
- )
- )
- in
- (name, cct_opt) :: (acc @ l)
- )
- []
- list2
- in
- iter list
- in
- let rec distinct acc = function
- [] ->
- acc
- | (name, cct_opt) :: q ->
- if List.exists (fun (name2, _) -> name = name2) acc then
- distinct acc q
- else
- distinct ((name, cct_opt) :: acc) q
- in
- let distinct_classes = distinct [] all_classes in
- let liste_index =
- let rec f n = function
- [] -> []
- | (name, _) :: q -> (name, n) :: (f (n+1) q)
- in
- f 0 distinct_classes
- in
- let array1 = Array.of_list distinct_classes in
- (* create the dag array, filling parents and values *)
- let fmap (name, cct_opt) =
- { pare = List.map
- (fun inh -> List.assoc inh.M.ic_name liste_index )
- (match cct_opt with
- None -> []
- | Some (M.Cl c) ->
- (match c.M.cl_kind with
- M.Class_structure (inher_l, _) ->
- inher_l
- | _ ->
- []
- )
- | Some (M.Cltype (ct, _)) ->
- (match ct.M.clt_kind with
- M.Class_signature (inher_l, _) ->
- inher_l
- | _ ->
- []
- )
- );
- valu = (name, cct_opt) ;
- chil = []
- }
- in
- let dag = { dag = Array.map fmap array1 } in
- (* fill the children *)
- let fiter i node =
- let l = Array.to_list dag.dag in
- let l2 = List.map (fun n -> n.valu)
- (List.filter (fun n -> List.mem i n.pare) l)
- in
- node.chil <- List.map (fun (name,_) -> List.assoc name liste_index) l2
- in
- Array.iteri fiter dag.dag;
- dag
-
-
-
-
diff --git a/ocamldoc/odoc_dag2html.mli b/ocamldoc/odoc_dag2html.mli
deleted file mode 100644
index 0f21e745d2..0000000000
--- a/ocamldoc/odoc_dag2html.mli
+++ /dev/null
@@ -1,31 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** The types and functions to create a html table representing a dag.
- Thanks to Daniel de Rauglaudre. *)
-
-type 'a dag = { mutable dag : 'a node array }
-and 'a node =
- { mutable pare : idag list; valu : 'a; mutable chil : idag list }
-and idag = int
-
-(** This function returns the html code to represent the given dag. *)
-val html_of_dag : string dag -> string
-
-(** This function takes a list of classes and a list of class types and creates the associate dag. *)
-val create_class_dag :
- Odoc_info.Class.t_class list ->
- Odoc_info.Class.t_class_type list ->
- (Odoc_info.Name.t * Odoc_info.Class.cct option) dag
-
-
diff --git a/ocamldoc/odoc_dep.ml b/ocamldoc/odoc_dep.ml
deleted file mode 100644
index c02d66066f..0000000000
--- a/ocamldoc/odoc_dep.ml
+++ /dev/null
@@ -1,219 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Top modules dependencies. *)
-
-module StrS = Depend.StringSet
-module Module = Odoc_module
-module Type = Odoc_type
-
-let set_to_list s =
- let l = ref [] in
- StrS.iter (fun e -> l := e :: !l) s;
- !l
-
-let impl_dependencies ast =
- Depend.free_structure_names := StrS.empty;
- Depend.add_use_file StrS.empty [Parsetree.Ptop_def ast];
- set_to_list !Depend.free_structure_names
-
-let intf_dependencies ast =
- Depend.free_structure_names := StrS.empty;
- Depend.add_signature StrS.empty ast;
- set_to_list !Depend.free_structure_names
-
-
-module Dep =
- struct
- type id = string
-
- module S = Set.Make (struct type t = string let compare = compare end)
-
- let set_to_list s =
- let l = ref [] in
- S.iter (fun e -> l := e :: !l) s;
- !l
-
- type node = {
- id : id ;
- mutable near : S.t ; (** fils directs *)
- mutable far : (id * S.t) list ; (** fils indirects, par quel fils *)
- reflex : bool ; (** reflexive or not, we keep
- information here to remove the node itself from its direct children *)
- }
-
- type graph = node list
-
- let make_node s children =
- let set = List.fold_right
- S.add
- children
- S.empty
- in
- { id = s;
- near = S.remove s set ;
- far = [] ;
- reflex = List.mem s children ;
- }
-
- let get_node graph s =
- try List.find (fun n -> n.id = s) graph
- with Not_found ->
- make_node s []
-
- let rec trans_closure graph acc n =
- if S.mem n.id acc then
- acc
- else
- (* optimisation plus tard : utiliser le champ far si non vide ? *)
- S.fold
- (fun child -> fun acc2 ->
- trans_closure graph acc2 (get_node graph child))
- n.near
- (S.add n.id acc)
-
- let node_trans_closure graph n =
- let far = List.map
- (fun child ->
- let set = trans_closure graph S.empty (get_node graph child) in
- (child, set)
- )
- (set_to_list n.near)
- in
- n.far <- far
-
- let compute_trans_closure graph =
- List.iter (node_trans_closure graph) graph
-
- let prune_node graph node =
- S.iter
- (fun child ->
- let set_reachables = List.fold_left
- (fun acc -> fun (ch, reachables) ->
- if child = ch then
- acc
- else
- S.union acc reachables
- )
- S.empty
- node.far
- in
- let set = S.remove node.id set_reachables in
- if S.exists (fun n2 -> S.mem child (get_node graph n2).near) set then
- (
- node.near <- S.remove child node.near ;
- node.far <- List.filter (fun (ch,_) -> ch <> child) node.far
- )
- else
- ()
- )
- node.near;
- if node.reflex then
- node.near <- S.add node.id node.near
- else
- ()
-
- let kernel graph =
- (* compute transitive closure *)
- compute_trans_closure graph ;
-
- (* remove edges to keep a transitive kernel *)
- List.iter (prune_node graph) graph;
-
- graph
-
- end
-
-(** [type_deps t] returns the list of fully qualified type names
- [t] depends on. *)
-let type_deps t =
- let module T = Odoc_type in
- let l = ref [] in
- let re = Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)" in
- let f s =
- let s2 = Str.matched_string s in
- l := s2 :: !l ;
- s2
- in
- (match t.T.ty_kind with
- T.Type_abstract -> ()
- | T.Type_variant (cl, _) ->
- List.iter
- (fun c ->
- List.iter
- (fun e ->
- let s = Odoc_misc.string_of_type_expr e in
- ignore (Str.global_substitute re f s)
- )
- c.T.vc_args
- )
- cl
- | T.Type_record (rl, _) ->
- List.iter
- (fun r ->
- let s = Odoc_misc.string_of_type_expr r.T.rf_type in
- ignore (Str.global_substitute re f s)
- )
- rl
- );
-
- (match t.T.ty_manifest with
- None -> ()
- | Some e ->
- let s = Odoc_misc.string_of_type_expr e in
- ignore (Str.global_substitute re f s)
- );
-
- !l
-
-(** Modify the modules depencies of the given list of modules,
- to get the minimum transitivity kernel. *)
-let kernel_deps_of_modules modules =
- let graph = List.map
- (fun m -> Dep.make_node m.Module.m_name m.Module.m_top_deps)
- modules
- in
- let k = Dep.kernel graph in
- List.iter
- (fun m ->
- let node = Dep.get_node k m.Module.m_name in
- m.Module.m_top_deps <-
- List.filter (fun m2 -> Dep.S.mem m2 node.Dep.near) m.Module.m_top_deps)
- modules
-
-(** Return the list of dependencies between the given types,
- in the form of a list [(type, names of types it depends on)].
- @param kernel indicates if we must keep only the transitivity kernel
- of the dependencies. Default is [false].
-*)
-let deps_of_types ?(kernel=false) types =
- let deps_pre = List.map (fun t -> (t, type_deps t)) types in
- let deps =
- if kernel then
- (
- let graph = List.map
- (fun (t, names) -> Dep.make_node t.Type.ty_name names)
- deps_pre
- in
- let k = Dep.kernel graph in
- List.map
- (fun t ->
- let node = Dep.get_node k t.Type.ty_name in
- (t, Dep.set_to_list node.Dep.near)
- )
- types
- )
- else
- deps_pre
- in
- deps
diff --git a/ocamldoc/odoc_dot.ml b/ocamldoc/odoc_dot.ml
deleted file mode 100644
index 877a84b913..0000000000
--- a/ocamldoc/odoc_dot.ml
+++ /dev/null
@@ -1,130 +0,0 @@
-(***********************************************************************)
-(* Ocamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Definition of a class which outputs a dot file showing
- top modules dependencies.*)
-
-open Odoc_info
-
-module F = Format
-
-(** This class generates a dot file showing the top modules dependencies. *)
-class dot =
- object (self)
-
- (** To store the colors associated to locations of modules. *)
- val mutable loc_colors = []
-
- (** the list of modules we know. *)
- val mutable modules = []
-
- (** Colors to use when finding new locations of modules. *)
- val mutable colors = !Args.dot_colors
-
- (** Graph header. *)
- method header =
- "digraph G {\n"^
- " size=\"10,7.5\";\n"^
- " ratio=\"fill\";\n"^
- " rotate=90;\n"^
- " fontsize=\"12pt\";\n"^
- " rankdir = TB ;\n"
-
- method get_one_color =
- match colors with
- [] -> None
- | h :: q ->
- colors <- q ;
- Some h
-
- method node_color s =
- try Some (List.assoc s loc_colors)
- with
- Not_found ->
- match self#get_one_color with
- None -> None
- | Some c ->
- loc_colors <- (s, c) :: loc_colors ;
- Some c
-
- method print_module_atts fmt m =
- match self#node_color (Filename.dirname m.Module.m_file) with
- None -> ()
- | Some col -> F.fprintf fmt "\"%s\" [style=filled, color=%s];\n" m.Module.m_name col
-
- method print_type_atts fmt t =
- match self#node_color (Name.father t.Type.ty_name) with
- None -> ()
- | Some col -> F.fprintf fmt "\"%s\" [style=filled, color=%s];\n" t.Type.ty_name col
-
- method print_one_dep fmt src dest =
- F.fprintf fmt "\"%s\" -> \"%s\";\n" src dest
-
- method generate_for_module fmt m =
- let l = List.filter
- (fun n ->
- !Args.dot_include_all or
- (List.exists (fun m -> m.Module.m_name = n) modules))
- m.Module.m_top_deps
- in
- self#print_module_atts fmt m;
- List.iter (self#print_one_dep fmt m.Module.m_name) l
-
- method generate_for_type fmt (t, l) =
- self#print_type_atts fmt t;
- List.iter
- (self#print_one_dep fmt t.Type.ty_name)
- l
-
- method generate_types types =
- try
- let oc = open_out !Args.out_file in
- let fmt = F.formatter_of_out_channel oc in
- F.fprintf fmt "%s" self#header;
- let graph = Odoc_info.Dep.deps_of_types
- ~kernel: !Args.dot_reduce
- types
- in
- List.iter (self#generate_for_type fmt) graph;
- F.fprintf fmt "}\n" ;
- F.pp_print_flush fmt ();
- close_out oc
- with
- Sys_error s ->
- raise (Failure s)
-
- method generate_modules modules_list =
- try
- modules <- modules_list ;
- let oc = open_out !Args.out_file in
- let fmt = F.formatter_of_out_channel oc in
- F.fprintf fmt "%s" self#header;
-
- if !Args.dot_reduce then
- Odoc_info.Dep.kernel_deps_of_modules modules_list;
-
- List.iter (self#generate_for_module fmt) modules_list;
- F.fprintf fmt "}\n" ;
- F.pp_print_flush fmt ();
- close_out oc
- with
- Sys_error s ->
- raise (Failure s)
-
- (** Generate the dot code in the file {!Odoc_info.Args.out_file}. *)
- method generate (modules_list : Odoc_info.Module.t_module list) =
- if !Args.dot_types then
- self#generate_types (Odoc_info.Search.types modules_list)
- else
- self#generate_modules modules_list
- end
diff --git a/ocamldoc/odoc_env.ml b/ocamldoc/odoc_env.ml
deleted file mode 100644
index ab0fff272b..0000000000
--- a/ocamldoc/odoc_env.ml
+++ /dev/null
@@ -1,245 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Environment for finding complete names from relative names. *)
-
-let print_DEBUG s = print_string s ; print_newline ();;
-
-module Name = Odoc_name
-
-(** relative name * complete name *)
-type env_element = Name.t * Name.t
-
-type env = {
- env_values : env_element list ;
- env_types : env_element list ;
- env_class_types : env_element list ;
- env_classes : env_element list ;
- env_modules : env_element list ;
- env_module_types : env_element list ;
- env_exceptions : env_element list ;
- }
-
-let empty = {
- env_values = [] ;
- env_types = [] ;
- env_class_types = [] ;
- env_classes = [] ;
- env_modules = [] ;
- env_module_types = [] ;
- env_exceptions = [] ;
- }
-
-(** Add a signature to an environment. *)
-let rec add_signature env root ?rel signat =
- let qualify id = Name.concat root (Name.from_ident id) in
- let rel_name id =
- let n = Name.from_ident id in
- match rel with
- None -> n
- | Some r -> Name.concat r n
- in
- let f env item =
- match item with
- Types.Tsig_value (ident, _) -> { env with env_values = (rel_name ident, qualify ident) :: env.env_values }
- | Types.Tsig_type (ident,_ ) -> { env with env_types = (rel_name ident, qualify ident) :: env.env_types }
- | Types.Tsig_exception (ident, _) -> { env with env_exceptions = (rel_name ident, qualify ident) :: env.env_exceptions }
- | Types.Tsig_module (ident, modtype) ->
- let env2 =
- match modtype with (* A VOIR : le cas où c'est un identificateur, dans ce cas on n'a pas de signature *)
- Types.Tmty_signature s -> add_signature env (qualify ident) ~rel: (rel_name ident) s
- | _ -> env
- in
- { env2 with env_modules = (rel_name ident, qualify ident) :: env2.env_modules }
- | Types.Tsig_modtype (ident, modtype_decl) ->
- let env2 =
- match modtype_decl with
- Types.Tmodtype_abstract ->
- env
- | Types.Tmodtype_manifest modtype ->
- match modtype with
- (* A VOIR : le cas où c'est un identificateur, dans ce cas on n'a pas de signature *)
- Types.Tmty_signature s -> add_signature env (qualify ident) ~rel: (rel_name ident) s
- | _ -> env
- in
- { env2 with env_module_types = (rel_name ident, qualify ident) :: env2.env_module_types }
- | Types.Tsig_class (ident, _) -> { env with env_classes = (rel_name ident, qualify ident) :: env.env_classes }
- | Types.Tsig_cltype (ident, _) -> { env with env_class_types = (rel_name ident, qualify ident) :: env.env_class_types }
- in
- List.fold_left f env signat
-
-let add_exception env full_name =
- let simple_name = Name.simple full_name in
- { env with env_exceptions = (simple_name, full_name) :: env.env_exceptions }
-
-let add_type env full_name =
- let simple_name = Name.simple full_name in
- { env with env_types = (simple_name, full_name) :: env.env_types }
-
-let add_value env full_name =
- let simple_name = Name.simple full_name in
- { env with env_values = (simple_name, full_name) :: env.env_values }
-
-let add_module env full_name =
- let simple_name = Name.simple full_name in
- { env with env_modules = (simple_name, full_name) :: env.env_modules }
-
-let add_module_type env full_name =
- let simple_name = Name.simple full_name in
- { env with env_module_types = (simple_name, full_name) :: env.env_module_types }
-
-let add_class env full_name =
- let simple_name = Name.simple full_name in
- { env with
- env_classes = (simple_name, full_name) :: env.env_classes ;
- (* we also add a type 'cause the class name may appear as a type *)
- env_types = (simple_name, full_name) :: env.env_types
- }
-
-let add_class_type env full_name =
- let simple_name = Name.simple full_name in
- { env with
- env_class_types = (simple_name, full_name) :: env.env_class_types ;
- (* we also add a type 'cause the class type name may appear as a type *)
- env_types = (simple_name, full_name) :: env.env_types
- }
-
-let full_module_name env n =
- try List.assoc n env.env_modules
- with Not_found ->
- print_DEBUG ("Module "^n^" not found with env=");
- List.iter (fun (sn, fn) -> print_DEBUG ("("^sn^", "^fn^")")) env.env_modules;
- n
-
-let full_module_type_name env n =
- try List.assoc n env.env_module_types
- with Not_found ->
- print_DEBUG ("Module "^n^" not found with env=");
- List.iter (fun (sn, fn) -> print_DEBUG ("("^sn^", "^fn^")")) env.env_modules;
- n
-
-let full_module_or_module_type_name env n =
- try List.assoc n env.env_modules
- with Not_found -> full_module_type_name env n
-
-let full_type_name env n =
- try
- let full = List.assoc n env.env_types in
-(** print_string ("type "^n^" is "^full);
- print_newline ();*)
- full
- with Not_found ->
-(** print_string ("type "^n^" not found");
- print_newline ();*)
- n
-
-let full_value_name env n =
- try List.assoc n env.env_values
- with Not_found -> n
-
-let full_exception_name env n =
- try List.assoc n env.env_exceptions
- with Not_found ->
- print_DEBUG ("Exception "^n^" not found with env=");
- List.iter (fun (sn, fn) -> print_DEBUG ("("^sn^", "^fn^")")) env.env_exceptions;
- n
-
-let full_class_name env n =
- try List.assoc n env.env_classes
- with Not_found ->
- print_DEBUG ("Class "^n^" not found with env=");
- List.iter (fun (sn, fn) -> print_DEBUG ("("^sn^", "^fn^")")) env.env_classes;
- n
-
-let full_class_type_name env n =
- try List.assoc n env.env_class_types
- with Not_found ->
- print_DEBUG ("Class type "^n^" not found with env=");
- List.iter (fun (sn, fn) -> print_DEBUG ("("^sn^", "^fn^")")) env.env_class_types;
- n
-
-let full_class_or_class_type_name env n =
- try List.assoc n env.env_classes
- with Not_found -> full_class_type_name env n
-
-let print_env_types env =
- List.iter (fun (s1,s2) -> Printf.printf "%s = %s\n" s1 s2) env.env_types
-
-let subst_type env t =
-(*
- print_string "Odoc_env.subst_type\n";
- print_env_types env ;
- print_newline ();
-*)
- Printtyp.mark_loops t;
- let deja_vu = ref [] in
- let rec iter t =
- if List.memq t !deja_vu then () else begin
- deja_vu := t :: !deja_vu;
- Btype.iter_type_expr iter t;
- match t.Types.desc with
- | Types.Tconstr (p, [ty], a) when Path.same p Predef.path_option ->
- ()
- | Types.Tconstr (p, l, a) ->
- let new_p =
- Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in
- t.Types.desc <- Types.Tconstr (new_p, l, a)
- | Types.Tobject (_, ({contents=Some(p,tyl)} as r)) ->
- let new_p =
- Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in
- r := Some (new_p, tyl)
- | Types.Tvariant ({Types.row_name=Some(p, tyl)} as row) ->
- let new_p =
- Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in
- t.Types.desc <-
- Types.Tvariant {row with Types.row_name=Some(new_p, tyl)}
- | _ ->
- ()
- end
- in
- iter t;
- t
-
-
-let subst_module_type env t =
- let rec iter t =
- match t with
- Types.Tmty_ident p ->
- let new_p = Odoc_name.to_path (full_module_type_name env (Odoc_name.from_path p)) in
- Types.Tmty_ident new_p
- | Types.Tmty_signature _ ->
- t
- | Types.Tmty_functor (id, mt1, mt2) ->
- Types.Tmty_functor (id, iter mt1, iter mt2)
- in
- iter t
-
-let subst_class_type env t =
- let rec iter t =
- match t with
- Types.Tcty_constr (p,texp_list,ct) ->
- let new_p = Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in
- let new_texp_list = List.map (subst_type env) texp_list in
- let new_ct = iter ct in
- Types.Tcty_constr (new_p, new_texp_list, new_ct)
- | Types.Tcty_signature cs ->
- (* on ne s'occupe pas des vals et methods *)
- t
- | Types.Tcty_fun (l, texp, ct) ->
- let new_texp = subst_type env texp in
- let new_ct = iter ct in
- Types.Tcty_fun (l, new_texp, new_ct)
- in
- iter t
-
-(* eof $Id$ *)
diff --git a/ocamldoc/odoc_env.mli b/ocamldoc/odoc_env.mli
deleted file mode 100644
index 6532a58d5c..0000000000
--- a/ocamldoc/odoc_env.mli
+++ /dev/null
@@ -1,76 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Environment for finding complete names from relative names. *)
-
-(** An environment of known names,
- from simple name to complete name. *)
-type env
-
-(** The empty environment. *)
-val empty : env
-
-(** Extending an environment *)
-
-val add_signature : env -> string -> ?rel:string -> Types.signature -> env
-val add_exception : env -> Odoc_name.t -> env
-val add_type : env -> Odoc_name.t -> env
-val add_value : env -> Odoc_name.t -> env
-val add_module : env -> Odoc_name.t -> env
-val add_module_type : env -> Odoc_name.t -> env
-val add_class : env -> Odoc_name.t -> env
-val add_class_type : env -> Odoc_name.t -> env
-
-(** Retrieving fully qualified names from an environment *)
-
-(** Get the fully qualified module name from a name.*)
-val full_module_name : env -> Odoc_name.t -> Odoc_name.t
-
-(** Get the fully qualified module type name from a name.*)
-val full_module_type_name : env -> Odoc_name.t -> Odoc_name.t
-
-(** Get the fully qualified module or module type name from a name.
- We look for a module type if we don't find a module.*)
-val full_module_or_module_type_name : env -> Odoc_name.t -> Odoc_name.t
-
-(** Get the fully qualified type name from a name.*)
-val full_type_name : env -> Odoc_name.t -> Odoc_name.t
-
-(** Get the fully qualified value name from a name.*)
-val full_value_name : env -> Odoc_name.t -> Odoc_name.t
-
-(** Get the fully qualified exception name from a name.*)
-val full_exception_name : env -> Odoc_name.t -> Odoc_name.t
-
-(** Get the fully qualified class name from a name.*)
-val full_class_name : env -> Odoc_name.t -> Odoc_name.t
-
-(** Get the fully qualified class type name from a name.*)
-val full_class_type_name : env -> Odoc_name.t -> Odoc_name.t
-
-(** Get the fully qualified class or class type name from a name.*)
-val full_class_or_class_type_name : env -> Odoc_name.t -> Odoc_name.t
-
-(** Substitutions *)
-
-(** Replace the [Path.t] by a complete [Path.t] in a [Types.type_expr].*)
-val subst_type : env -> Types.type_expr -> Types.type_expr
-
-(** Replace the [Path.t] by a complete [Path.t] in a [Types.module_type].*)
-val subst_module_type : env -> Types.module_type -> Types.module_type
-
-(** Replace the [Path.t] by a complete [Path.t] in a [Types.class_type].
- Also empty the structures to get only [object end] when the type
- is printed.
-*)
-val subst_class_type : env -> Types.class_type -> Types.class_type
diff --git a/ocamldoc/odoc_exception.ml b/ocamldoc/odoc_exception.ml
deleted file mode 100644
index 4d81f81202..0000000000
--- a/ocamldoc/odoc_exception.ml
+++ /dev/null
@@ -1,32 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Representation and manipulation of exceptions. *)
-
-module Name = Odoc_name
-
-type exception_alias = {
- ea_name : Name.t ;
- mutable ea_ex : t_exception option ;
- }
-
-and t_exception = {
- ex_name : Name.t ;
- mutable ex_info : Odoc_types.info option ; (** optional user information *)
- ex_args : Types.type_expr list ; (** the types of the parameters *)
- ex_alias : exception_alias option ;
- mutable ex_loc : Odoc_types.location ;
- mutable ex_code : string option ;
- }
-
-
diff --git a/ocamldoc/odoc_global.ml b/ocamldoc/odoc_global.ml
deleted file mode 100644
index 4e08456617..0000000000
--- a/ocamldoc/odoc_global.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Global variables. *)
-
-let errors = ref 0
-
-let warn_error = ref false
-
-
-(* Tell ocaml compiler not to generate files. *)
-let _ = Clflags.dont_write_files := true
diff --git a/ocamldoc/odoc_global.mli b/ocamldoc/odoc_global.mli
deleted file mode 100644
index 3a9eab6514..0000000000
--- a/ocamldoc/odoc_global.mli
+++ /dev/null
@@ -1,20 +0,0 @@
-(***********************************************************************)
-(* Ocamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Global variables. *)
-
-(** A counter for errors. *)
-val errors : int ref
-
-(** Indicate if a warning is an error. *)
-val warn_error : bool ref
diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml
deleted file mode 100644
index 2db74bf6b0..0000000000
--- a/ocamldoc/odoc_html.ml
+++ /dev/null
@@ -1,2018 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Generation of html documentation. *)
-
-let print_DEBUG s = print_string s ; print_newline ()
-
-open Odoc_info
-open Parameter
-open Value
-open Type
-open Exception
-open Class
-open Module
-
-
-(** The functions used for naming files and html marks.*)
-module Naming =
- struct
- (** The prefix for types marks. *)
- let mark_type = "TYPE"
-
- (** The prefix for functions marks. *)
- let mark_function = "FUN"
-
- (** The prefix for exceptions marks. *)
- let mark_exception = "EXCEPTION"
-
- (** The prefix for values marks. *)
- let mark_value = "VAL"
-
- (** The prefix for attributes marks. *)
- let mark_attribute = "ATT"
-
- (** The prefix for methods marks. *)
- let mark_method = "METHOD"
-
- (** The prefix for code files.. *)
- let code_prefix = "code_"
-
- (** The prefix for type files.. *)
- let type_prefix = "type_"
-
- (** Return the two html files names for the given module or class name.*)
- let html_files name =
- let html_file = name^".html" in
- let html_frame_file = name^"-frame.html" in
- (html_file, html_frame_file)
-
- (** Return the target for the given prefix and simple name. *)
- let target pref simple_name = pref^simple_name
-
- (** Return the complete link target (file#target) for the given prefix string and complete name.*)
- let complete_target pref complete_name =
- let simple_name = Name.simple complete_name in
- let module_name =
- let s = Name.father complete_name in
- if s = "" then simple_name else s
- in
- let (html_file, _) = html_files module_name in
- html_file^"#"^(target pref simple_name)
-
- (** Return the link target for the given type. *)
- let type_target t = target mark_type (Name.simple t.ty_name)
-
- (** Return the complete link target for the given type. *)
- let complete_type_target t = complete_target mark_type t.ty_name
-
- (** Return the link target for the given exception. *)
- let exception_target e = target mark_exception (Name.simple e.ex_name)
-
- (** Return the complete link target for the given exception. *)
- let complete_exception_target e = complete_target mark_exception e.ex_name
-
-
-
- (** Return the link target for the given value. *)
- let value_target v = target mark_value (Name.simple v.val_name)
-
- (** Return the given value name where symbols accepted in infix values
- are replaced by strings, to avoid clashes with the filesystem.*)
- let subst_infix_symbols name =
- let len = String.length name in
- let buf = Buffer.create len in
- let ch c = Buffer.add_char buf c in
- let st s = Buffer.add_string buf s in
- for i = 0 to len - 1 do
- match name.[i] with
- | '|' -> st "_pipe_"
- | '<' -> st "_lt_"
- | '>' -> st "_gt_"
- | '@' -> st "_at_"
- | '^' -> st "_exp_"
- | '&' -> st "_amp_"
- | '+' -> st "_plus_"
- | '-' -> st "_minus_"
- | '*' -> st "_star_"
- | '/' -> st "_slash_"
- | '$' -> st "_dollar_"
- | '%' -> st "_percent_"
- | '=' -> st "_equal_"
- | ':' -> st "_column_"
- | '~' -> st "_tilde_"
- | '!' -> st "_bang_"
- | c -> ch c
- done;
- Buffer.contents buf
-
- (** Return the complete link target for the given value. *)
- let complete_value_target v = complete_target mark_value v.val_name
-
- (** Return the complete filename for the code of the given value. *)
- let file_code_value_complete_target v =
- let f = code_prefix^mark_value^(subst_infix_symbols v.val_name)^".html" in
- f
-
- (** Return the link target for the given attribute. *)
- let attribute_target a = target mark_attribute (Name.simple a.att_value.val_name)
-
- (** Return the complete link target for the given attribute. *)
- let complete_attribute_target a = complete_target mark_attribute a.att_value.val_name
-
- (** Return the complete filename for the code of the given attribute. *)
- let file_code_attribute_complete_target a =
- let f = code_prefix^mark_attribute^a.att_value.val_name^".html" in
- f
-
- (** Return the link target for the given method. *)
- let method_target m = target mark_method (Name.simple m.met_value.val_name)
-
- (** Return the complete link target for the given method. *)
- let complete_method_target m = complete_target mark_method m.met_value.val_name
-
- (** Return the complete filename for the code of the given method. *)
- let file_code_method_complete_target m =
- let f = code_prefix^mark_method^m.met_value.val_name^".html" in
- f
-
- (** Return the link target for the given label section. *)
- let label_target l = target "" l
-
- (** Return the complete link target for the given section label. *)
- let complete_label_target l = complete_target "" l
-
- (** Return the complete filename for the code of the type of the
- given module or module type name. *)
- let file_type_module_complete_target name =
- let f = type_prefix^name^".html" in
- f
-
- (** Return the complete filename for the code of the
- given module name. *)
- let file_code_module_complete_target name =
- let f = code_prefix^name^".html" in
- f
-
- (** Return the complete filename for the code of the type of the
- given class or class type name. *)
- let file_type_class_complete_target name =
- let f = type_prefix^name^".html" in
- f
- end
-
-(** A class with a method to colorize a string which represents OCaml code. *)
-class ocaml_code =
- object(self)
- method html_of_code ?(with_pre=true) code =
- let html_code = Odoc_ocamlhtml.html_of_code ~with_pre: with_pre code in
- html_code
- end
-
-(** Generation of html code from text structures. *)
-class text =
- object (self)
- (** We want to display colorized code. *)
- inherit ocaml_code
-
- (** Escape the strings which would clash with html syntax, and
- make some replacements (double newlines replaced by <br>). *)
- method escape s = Odoc_ocamlhtml.escape_base s
-
-
- method keep_alpha_num s =
- let len = String.length s in
- let buf = Buffer.create len in
- for i = 0 to len - 1 do
- match s.[i] with
- 'a'..'z' | 'A'..'Z' | '0'..'9' -> Buffer.add_char buf s.[i]
- | _ -> ()
- done;
- Buffer.contents buf
-
- (** Return a label created from the first sentence of a text. *)
- method label_of_text t=
- let t2 = Odoc_info.first_sentence_of_text t in
- let s = Odoc_info.string_of_text t2 in
- let s2 = self#keep_alpha_num s in
- s2
-
- (** Create a label for the associated title.
- Return the label specified by the user or a label created
- from the title level and the first sentence of the title. *)
- method create_title_label (n,label_opt,t) =
- match label_opt with
- Some s -> s
- | None -> Printf.sprintf "%d_%s" n (self#label_of_text t)
-
- (** Return the html code corresponding to the [text] parameter. *)
- method html_of_text t = String.concat "" (List.map self#html_of_text_element t)
-
- (** Return the html code for the [text_element] in parameter. *)
- method html_of_text_element te =
- print_DEBUG "text::html_of_text_element";
- match te with
- | Odoc_info.Raw s -> self#html_of_Raw s
- | Odoc_info.Code s -> self#html_of_Code s
- | Odoc_info.CodePre s -> self#html_of_CodePre s
- | Odoc_info.Verbatim s -> self#html_of_Verbatim s
- | Odoc_info.Bold t -> self#html_of_Bold t
- | Odoc_info.Italic t -> self#html_of_Italic t
- | Odoc_info.Emphasize t -> self#html_of_Emphasize t
- | Odoc_info.Center t -> self#html_of_Center t
- | Odoc_info.Left t -> self#html_of_Left t
- | Odoc_info.Right t -> self#html_of_Right t
- | Odoc_info.List tl -> self#html_of_List tl
- | Odoc_info.Enum tl -> self#html_of_Enum tl
- | Odoc_info.Newline -> self#html_of_Newline
- | Odoc_info.Block t -> self#html_of_Block t
- | Odoc_info.Title (n, l_opt, t) -> self#html_of_Title n l_opt t
- | Odoc_info.Latex s -> self#html_of_Latex s
- | Odoc_info.Link (s, t) -> self#html_of_Link s t
- | Odoc_info.Ref (name, ref_opt) -> self#html_of_Ref name ref_opt
- | Odoc_info.Superscript t -> self#html_of_Superscript t
- | Odoc_info.Subscript t -> self#html_of_Subscript t
-
- method html_of_Raw s = self#escape s
-
- method html_of_Code s =
- if !Args.colorize_code then
- self#html_of_code ~with_pre: false s
- else
- "<code class=\""^Odoc_ocamlhtml.code_class^"\">"^(self#escape s)^"</code>"
-
- method html_of_CodePre s =
- if !Args.colorize_code then
- "<pre></pre>"^(self#html_of_code s)^"<pre></pre>"
- else
- "<pre><code class=\""^Odoc_ocamlhtml.code_class^"\">"^(self#escape s)^"</code></pre>"
-
- method html_of_Verbatim s = "<pre>"^(self#escape s)^"</pre>"
- method html_of_Bold t = "<b>"^(self#html_of_text t)^"</b>"
- method html_of_Italic t = "<i>"^(self#html_of_text t)^"</i>"
- method html_of_Emphasize t = "<em>"^(self#html_of_text t)^"</em>"
- method html_of_Center t = "<center>"^(self#html_of_text t)^"</center>"
- method html_of_Left t = "<div align=left>"^(self#html_of_text t)^"</div>"
- method html_of_Right t = "<div align=right>"^(self#html_of_text t)^"</div>"
-
- method html_of_List tl =
- "<ul>\n"^
- (String.concat ""
- (List.map (fun t -> "<li>"^(self#html_of_text t)^"</li>\n") tl))^
- "</ul>\n"
-
- method html_of_Enum tl =
- "<OL>\n"^
- (String.concat ""
- (List.map (fun t -> "<li>"^(self#html_of_text t)^"</li>\n") tl))^
- "</OL>\n"
-
- method html_of_Newline = "\n<p>\n"
-
- method html_of_Block t =
- "<blockquote>\n"^(self#html_of_text t)^"</blockquote>\n"
-
- method html_of_Title n label_opt t =
- let label1 = self#create_title_label (n, label_opt, t) in
- "<a name=\""^(Naming.label_target label1)^"\"></a>\n"^
- let (tag_o, tag_c) =
- if n > 6 then
- (Printf.sprintf "div class=\"h%d\"" n, "div")
- else
- let t = Printf.sprintf "h%d" n in (t, t)
- in
- (Printf.sprintf "<%s>%s</%s>\n" tag_o (self#html_of_text t) tag_c)
-
- method html_of_Latex _ = ""
- (* don't care about LaTeX stuff in HTML. *)
-
- method html_of_Link s t =
- "<a href=\""^s^"\">"^(self#html_of_text t)^"</a>"
-
- method html_of_Ref name ref_opt =
- match ref_opt with
- None ->
- self#html_of_text_element (Odoc_info.Code name)
- | Some kind ->
- let h name = Odoc_info.Code (Odoc_info.use_hidden_modules name) in
- let (target, text) =
- match kind with
- Odoc_info.RK_module
- | Odoc_info.RK_module_type
- | Odoc_info.RK_class
- | Odoc_info.RK_class_type ->
- let (html_file, _) = Naming.html_files name in
- (html_file, h name)
- | Odoc_info.RK_value -> (Naming.complete_target Naming.mark_value name, h name)
- | Odoc_info.RK_type -> (Naming.complete_target Naming.mark_type name, h name)
- | Odoc_info.RK_exception -> (Naming.complete_target Naming.mark_exception name, h name)
- | Odoc_info.RK_attribute -> (Naming.complete_target Naming.mark_attribute name, h name)
- | Odoc_info.RK_method -> (Naming.complete_target Naming.mark_method name, h name)
- | Odoc_info.RK_section t -> (Naming.complete_label_target name,
- Odoc_info.Italic [Raw (Odoc_info.string_of_text t)])
- in
- "<a href=\""^target^"\">"^
- (self#html_of_text_element text)^
- "</a>"
-
- method html_of_Superscript t =
- "<sup class=\"superscript\">"^(self#html_of_text t)^"</sup>"
-
- method html_of_Subscript t =
- "<sub class=\"subscript\">"^(self#html_of_text t)^"</sub>"
-
- end
-
-(** A class used to generate html code 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 html code.
- Add a pair here to handle a tag.*)
- val mutable tag_functions = ([] : (string * (Odoc_info.text -> string)) list)
-
- (** The method used to get html code from a [text]. *)
- method virtual html_of_text : Odoc_info.text -> string
-
- (** Return html for an author list. *)
- method html_of_author_list l =
- match l with
- [] ->
- ""
- | _ ->
- "<b>"^Odoc_messages.authors^": </b>"^
- (String.concat ", " l)^
- "<br>\n"
-
- (** Return html code for the given optional version information.*)
- method html_of_version_opt v_opt =
- match v_opt with
- None -> ""
- | Some v -> "<b>"^Odoc_messages.version^": </b>"^v^"<br>\n"
-
- (** Return html code for the given optional since information.*)
- method html_of_since_opt s_opt =
- match s_opt with
- None -> ""
- | Some s -> "<b>"^Odoc_messages.since^"</b> "^s^"<br>\n"
-
- (** Return html code for the given list of raised exceptions.*)
- method html_of_raised_exceptions l =
- match l with
- [] -> ""
- | (s, t) :: [] -> "<b>"^Odoc_messages.raises^"</b> <code>"^s^"</code> "^(self#html_of_text t)^"<br>\n"
- | _ ->
- "<b>"^Odoc_messages.raises^"</b><ul>"^
- (String.concat ""
- (List.map
- (fun (ex, desc) -> "<li><code>"^ex^"</code> "^(self#html_of_text desc)^"</li>\n")
- l
- )
- )^"</ul>\n"
-
- (** Return html code for the given "see also" reference. *)
- method html_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#html_of_text t_ref
-
- (** Return html code for the given list of "see also" references.*)
- method html_of_sees l =
- match l with
- [] -> ""
- | see :: [] -> "<b>"^Odoc_messages.see_also^"</b> "^(self#html_of_see see)^"<br>\n"
- | _ ->
- "<b>"^Odoc_messages.see_also^"</b><ul>"^
- (String.concat ""
- (List.map
- (fun see -> "<li>"^(self#html_of_see see)^"</li>\n")
- l
- )
- )^"</ul>\n"
-
- (** Return html code for the given optional return information.*)
- method html_of_return_opt return_opt =
- match return_opt with
- None -> ""
- | Some s -> "<b>"^Odoc_messages.returns^"</b> "^(self#html_of_text s)^"<br>\n"
-
- (** Return html code for the given list of custom tagged texts. *)
- method html_of_custom l =
- let buf = Buffer.create 50 in
- List.iter
- (fun (tag, text) ->
- try
- let f = List.assoc tag tag_functions in
- Buffer.add_string buf (f text)
- with
- Not_found ->
- Odoc_info.warning (Odoc_messages.tag_not_handled tag)
- )
- l;
- Buffer.contents buf
-
- (** Return html code for a description, except for the [i_params] field. *)
- method html_of_info info_opt =
- match info_opt with
- None ->
- ""
- | Some info ->
- let module M = Odoc_info in
- "<div class=\"info\">\n"^
- (match info.M.i_deprecated with
- None -> ""
- | Some d ->
- "<span class=\"warning\">"^Odoc_messages.deprecated^"</span> "^
- (self#html_of_text d)^
- "<br>\n"
- )^
- (match info.M.i_desc with
- None -> ""
- | Some d when d = [Odoc_info.Raw ""] -> ""
- | Some d -> (self#html_of_text d)^"<br>\n"
- )^
- (self#html_of_author_list info.M.i_authors)^
- (self#html_of_version_opt info.M.i_version)^
- (self#html_of_since_opt info.M.i_since)^
- (self#html_of_raised_exceptions info.M.i_raised_exceptions)^
- (self#html_of_return_opt info.M.i_return_value)^
- (self#html_of_sees info.M.i_sees)^
- (self#html_of_custom info.M.i_custom)^
- "</div>\n"
-
- (** Return html code for the first sentence of a description.
- The titles and lists in this first sentence has been removed.*)
- method html_of_info_first_sentence info_opt =
- match info_opt with
- None -> ""
- | Some info ->
- let module M = Odoc_info in
- let dep = info.M.i_deprecated <> None in
- "<div class=\"info\">\n"^
- (if dep then "<font color=\"#CCCCCC\">" else "") ^
- (match info.M.i_desc with
- None -> ""
- | Some d when d = [Odoc_info.Raw ""] -> ""
- | Some d -> (self#html_of_text
- (Odoc_info.text_no_title_no_list
- (Odoc_info.first_sentence_of_text d)))^"\n"
- )^
- (if dep then "</font>" else "") ^
- "</div>\n"
-
- end
-
-
-
-let opt = Odoc_info.apply_opt
-
-(** This class is used to create objects which can generate a simple html documentation. *)
-class html =
- object (self)
- inherit text
- inherit info
-
- (** The default style options. *)
- val mutable default_style_options =
- ["a:visited {color : #416DFF; text-decoration : none; }" ;
- "a:link {color : #416DFF; text-decoration : none;}" ;
- "a:hover {color : Red; text-decoration : none; background-color: #5FFF88}" ;
- "a:active {color : Red; text-decoration : underline; }" ;
- ".keyword { font-weight : bold ; color : Red }" ;
- ".keywordsign { color : #C04600 }" ;
- ".superscript { font-size : 4 }" ;
- ".subscript { font-size : 4 }" ;
- ".comment { color : Green }" ;
- ".constructor { color : Blue }" ;
- ".type { color : #5C6585 }" ;
- ".string { color : Maroon }" ;
- ".warning { color : Red ; font-weight : bold }" ;
- ".info { margin-left : 3em; margin-right : 3em }" ;
- ".code { color : #465F91 ; }" ;
- "h1 { font-size : 20pt ; text-align: center; }" ;
-
- "h2 { font-size : 20pt ; border: 1px solid #000000; "^
- "margin-top: 5px; margin-bottom: 2px;"^
- "text-align: center; background-color: #90BDFF ;"^
- "padding: 2px; }" ;
-
- "h3 { font-size : 20pt ; border: 1px solid #000000; "^
- "margin-top: 5px; margin-bottom: 2px;"^
- "text-align: center; background-color: #90DDFF ;"^
- "padding: 2px; }" ;
-
- "h4 { font-size : 20pt ; border: 1px solid #000000; "^
- "margin-top: 5px; margin-bottom: 2px;"^
- "text-align: center; background-color: #90EDFF ;"^
- "padding: 2px; }" ;
-
- "h5 { font-size : 20pt ; border: 1px solid #000000; "^
- "margin-top: 5px; margin-bottom: 2px;"^
- "text-align: center; background-color: #90FDFF ;"^
- "padding: 2px; }" ;
-
- "h6 { font-size : 20pt ; border: 1px solid #000000; "^
- "margin-top: 5px; margin-bottom: 2px;"^
- "text-align: center; background-color: #C0FFFF ; "^
- "padding: 2px; }" ;
-
- "div.h7 { font-size : 20pt ; border: 1px solid #000000; "^
- "margin-top: 5px; margin-bottom: 2px;"^
- "text-align: center; background-color: #E0FFFF ; "^
- "padding: 2px; }" ;
-
- "div.h8 { font-size : 20pt ; border: 1px solid #000000; "^
- "margin-top: 5px; margin-bottom: 2px;"^
- "text-align: center; background-color: #F0FFFF ; "^
- "padding: 2px; }" ;
-
- "div.h9 { font-size : 20pt ; border: 1px solid #000000; "^
- "margin-top: 5px; margin-bottom: 2px;"^
- "text-align: center; background-color: #FFFFFF ; "^
- "padding: 2px; }" ;
-
- ".typetable { border-style : hidden }" ;
- ".indextable { border-style : hidden }" ;
- ".paramstable { border-style : hidden ; padding: 5pt 5pt}" ;
- "body { background-color : White }" ;
- "tr { background-color : White }" ;
- "td.typefieldcomment { background-color : #FFFFFF }" ;
- "pre { margin-bottom: 4px }" ;
- ]
-
- (** The style file for all pages. *)
- val mutable style_file = "style.css"
-
- (** The code to import the style. Initialized in [init_style]. *)
- val mutable style = ""
-
- (** The known types names.
- Used to know if we must create a link to a type
- when printing a type. *)
- val mutable known_types_names = []
-
- (** The known class and class type names.
- Used to know if we must create a link to a class
- or class type or not when printing a type. *)
- val mutable known_classes_names = []
-
- (** The known modules and module types names.
- Used to know if we must create a link to a type or not
- when printing a module type. *)
- val mutable known_modules_names = []
-
- (** The main file. *)
- val mutable index = "index.html"
- (** The file for the index of values. *)
- val mutable index_values = "index_values.html"
- (** The file for the index of types. *)
- val mutable index_types = "index_types.html"
- (** The file for the index of exceptions. *)
- val mutable index_exceptions = "index_exceptions.html"
- (** The file for the index of attributes. *)
- val mutable index_attributes = "index_attributes.html"
- (** The file for the index of methods. *)
- val mutable index_methods = "index_methods.html"
- (** The file for the index of classes. *)
- val mutable index_classes = "index_classes.html"
- (** The file for the index of class types. *)
- val mutable index_class_types = "index_class_types.html"
- (** The file for the index of modules. *)
- val mutable index_modules = "index_modules.html"
- (** The file for the index of module types. *)
- val mutable index_module_types = "index_module_types.html"
-
-
- (** The list of attributes. Filled in the [generate] method. *)
- val mutable list_attributes = []
- (** The list of methods. Filled in the [generate] method. *)
- val mutable list_methods = []
- (** The list of values. Filled in the [generate] method. *)
- val mutable list_values = []
- (** The list of exceptions. Filled in the [generate] method. *)
- val mutable list_exceptions = []
- (** The list of types. Filled in the [generate] method. *)
- val mutable list_types = []
- (** The list of modules. Filled in the [generate] method. *)
- val mutable list_modules = []
- (** The list of module types. Filled in the [generate] method. *)
- val mutable list_module_types = []
- (** The list of classes. Filled in the [generate] method. *)
- val mutable list_classes = []
- (** The list of class types. Filled in the [generate] method. *)
- val mutable list_class_types = []
-
- (** The header of pages. Must be prepared by the [prepare_header] method.*)
- val mutable header = fun ?(nav=None) -> fun ?(comments=[]) -> fun _ -> ""
-
- (** Init the style. *)
- method init_style =
- (match !Args.css_style with
- None ->
- let default_style = String.concat "\n" default_style_options in
- (
- try
- let file = Filename.concat !Args.target_dir style_file 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 default_style ;
- flush chanout ;
- close_out chanout;
- Odoc_info.verbose (Odoc_messages.file_generated file)
- )
- with
- Sys_error s ->
- prerr_endline s ;
- incr Odoc_info.errors ;
- )
- | Some f ->
- style_file <- f
- );
- style <- "<link rel=\"stylesheet\" href=\""^style_file^"\" type=\"text/css\">\n"
-
- (** Get the title given by the user *)
- method title = match !Args.title with None -> "" | Some t -> self#escape t
-
- (** Get the title given by the user completed with the given subtitle. *)
- method inner_title s =
- (match self#title with "" -> "" | t -> t^" : ")^
- (self#escape s)
-
- (** Get the page header. *)
- method header ?nav ?comments title = header ?nav ?comments title
-
- (** A function to build the header of pages. *)
- method prepare_header module_list =
- let f ?(nav=None) ?(comments=[]) t =
- let link_if_not_empty l m url =
- match l with
- [] -> ""
- | _ -> "<link title=\""^m^"\" rel=Appendix href=\""^url^"\">\n"
- in
- "<head>\n"^
- style^
- "<link rel=\"Start\" href=\""^index^"\">\n"^
- (
- match nav with
- None -> ""
- | Some (pre_opt, post_opt, name) ->
- (match pre_opt with
- None -> ""
- | Some name ->
- "<link rel=\"previous\" href=\""^(fst (Naming.html_files name))^"\">\n"
- )^
- (match post_opt with
- None -> ""
- | Some name ->
- "<link rel=\"next\" href=\""^(fst (Naming.html_files name))^"\">\n"
- )^
- (
- let father = Name.father name in
- let href = if father = "" then index else fst (Naming.html_files father) in
- "<link rel=\"Up\" href=\""^href^"\">\n"
- )
- )^
- (link_if_not_empty list_types Odoc_messages.index_of_types index_types)^
- (link_if_not_empty list_exceptions Odoc_messages.index_of_exceptions index_exceptions)^
- (link_if_not_empty list_values Odoc_messages.index_of_values index_values)^
- (link_if_not_empty list_attributes Odoc_messages.index_of_attributes index_attributes)^
- (link_if_not_empty list_methods Odoc_messages.index_of_methods index_methods)^
- (link_if_not_empty list_classes Odoc_messages.index_of_classes index_classes)^
- (link_if_not_empty list_class_types Odoc_messages.index_of_class_types index_class_types)^
- (link_if_not_empty list_modules Odoc_messages.index_of_modules index_modules)^
- (link_if_not_empty list_module_types Odoc_messages.index_of_module_types index_module_types)^
- (String.concat "\n"
- (List.map
- (fun m ->
- let html_file = fst (Naming.html_files m.m_name) in
- "<link title=\""^m.m_name^"\" rel=\"Chapter\" href=\""^html_file^"\">"
- )
- module_list
- )
- )^
- (self#html_sections_links comments)^
- "<title>"^
- t^
- "</title>\n</head>\n"
- in
- header <- f
-
- (** Build the html code for the link tags in the header, defining section and
- subsections for the titles found in the given comments.*)
- method html_sections_links comments =
- let titles = List.flatten (List.map Odoc_info.get_titles_in_text comments) in
- let levels =
- let rec iter acc l =
- match l with
- [] -> acc
- | (n,_,_) :: q ->
- if List.mem n acc
- then iter acc q
- else iter (n::acc) q
- in
- iter [] titles
- in
- let sorted_levels = List.sort compare levels in
- let (section_level, subsection_level) =
- match sorted_levels with
- [] -> (None, None)
- | [n] -> (Some n, None)
- | n :: m :: _ -> (Some n, Some m)
- in
- let titles_per_level level_opt =
- match level_opt with
- None -> []
- | Some n -> List.filter (fun (m,_,_) -> m = n) titles
- in
- let section_titles = titles_per_level section_level in
- let subsection_titles = titles_per_level subsection_level in
- let create_lines s_rel titles =
- List.map
- (fun (n,lopt,t) ->
- let s = Odoc_info.string_of_text t in
- let label = self#create_title_label (n,lopt,t) in
- Printf.sprintf "<link title=\"%s\" rel=\"%s\" href=\"#%s\">\n" s s_rel label)
- titles
- in
- let section_lines = create_lines "Section" section_titles in
- let subsection_lines = create_lines "Subsection" subsection_titles in
- String.concat "" (section_lines @ subsection_lines)
-
- (** Html code for navigation bar.
- @param pre optional name for optional previous module/class
- @param post optional name for optional next module/class
- @param name name of current module/class *)
- method navbar pre post name =
- "<div class=\"navbar\">"^
- (match pre with
- None -> ""
- | Some name ->
- "<a href=\""^(fst (Naming.html_files name))^"\">"^Odoc_messages.previous^"</a>\n"
- )^
- "&nbsp;"^
- (
- let father = Name.father name in
- let href = if father = "" then index else fst (Naming.html_files father) in
- "<a href=\""^href^"\">"^Odoc_messages.up^"</a>\n"
- )^
- "&nbsp;"^
- (match post with
- None -> ""
- | Some name ->
- "<a href=\""^(fst (Naming.html_files name))^"\">"^Odoc_messages.next^"</a>\n"
- )^
- "</div>\n"
-
- (** Return html code with the given string in the keyword style.*)
- method keyword s =
- "<span class=\"keyword\">"^s^"</span>"
-
- (** Return html code with the given string in the constructor style. *)
- method constructor s = "<span class=\"constructor\">"^s^"</span>"
-
- (** Output the given ocaml code to the given file name. *)
- method private output_code in_title file code =
- try
- let chanout = open_out file in
- let html_code = self#html_of_code code in
- output_string chanout ("<html>"^(self#header (self#inner_title in_title))^"<body>\n");
- output_string chanout html_code;
- output_string chanout "</body></html>";
- close_out chanout
- with
- Sys_error s ->
- incr Odoc_info.errors ;
- prerr_endline s
-
- (** Take a string and return the string where fully qualified
- type (or class or class type) idents
- have been replaced by links to the type referenced by the ident.*)
- method create_fully_qualified_idents_links 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
- let s_final = Odoc_info.apply_if_equal
- Odoc_info.use_hidden_modules
- match_s
- rel
- in
- if List.mem match_s known_types_names then
- "<a href=\""^(Naming.complete_target Naming.mark_type match_s)^"\">"^
- s_final^
- "</a>"
- else
- if List.mem match_s known_classes_names then
- let (html_file, _) = Naming.html_files match_s in
- "<a href=\""^html_file^"\">"^s_final^"</a>"
- else
- s_final
- in
- let s2 = Str.global_substitute
- (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)")
- f
- s
- in
- s2
-
- (** Take a string and return the string where fully qualified module idents
- have been replaced by links to the module referenced by the ident.*)
- method create_fully_qualified_module_idents_links m_name s =
- let f str_t =
- let match_s = Str.matched_string str_t in
- if List.mem match_s known_modules_names then
- let (html_file, _) = Naming.html_files match_s in
- "<a href=\""^html_file^"\">"^(Name.get_relative m_name match_s)^"</a>"
- else
- match_s
- in
- let s2 = Str.global_substitute
- (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([A-Z][a-zA-Z_'0-9]*\\)")
- f
- s
- in
- s2
-
- (** Return html code to display a [Types.type_expr]. *)
- method html_of_type_expr m_name t =
- let s = String.concat "\n"
- (Str.split (Str.regexp "\n") (Odoc_info.string_of_type_expr t))
- in
- let s2 = Str.global_replace (Str.regexp "\n") "<br> " s in
- Printf.sprintf
- "<code class=\"type\">%s</code>"
- (self#create_fully_qualified_idents_links m_name s2)
-
- (** Return html code to display a [Types.class_type].*)
- method html_of_class_type_expr m_name t =
- let s = String.concat "\n"
- (Str.split (Str.regexp "\n") (Odoc_info.string_of_class_type t))
- in
- let s2 = Str.global_replace (Str.regexp "\n") "<br> " s in
- "<code class=\"type\">"^(self#create_fully_qualified_idents_links m_name s2)^"</code>"
-
- (** Return html code to display a [Types.type_expr list]. *)
- method html_of_type_expr_list m_name sep l =
- print_DEBUG "html#html_of_type_expr_list";
- let s = Odoc_info.string_of_type_list sep l in
- print_DEBUG "html#html_of_type_expr_list: 1";
- let s2 = Str.global_replace (Str.regexp "\n") "<br> " s in
- print_DEBUG "html#html_of_type_expr_list: 2";
- "<code class=\"type\">"^(self#create_fully_qualified_idents_links m_name s2)^"</code>"
-
- (** Return html code to display a [Types.type_expr list] as type parameters
- of a class of class type. *)
- method html_of_class_type_param_expr_list m_name l =
- let s = Odoc_info.string_of_class_type_param_list l in
- let s2 = Str.global_replace (Str.regexp "\n") "<br> " s in
- "<code class=\"type\">"^(self#create_fully_qualified_idents_links m_name s2)^"</code>"
-
- (** Return html code to display a list of type parameters for the given type.*)
- method html_of_type_expr_param_list m_name t =
- let s = Odoc_info.string_of_type_param_list t in
- let s2 = Str.global_replace (Str.regexp "\n") "<br> " s in
- "<code class=\"type\">"^(self#create_fully_qualified_idents_links m_name s2)^"</code>"
-
- (** Return html code to display a [Types.module_type]. *)
- method html_of_module_type m_name t =
- let s = String.concat "\n"
- (Str.split (Str.regexp "\n") (Odoc_info.string_of_module_type t))
- in
- let s2 = Str.global_replace (Str.regexp "\n") "<br> " s in
- "<code class=\"type\">"^(self#create_fully_qualified_module_idents_links m_name s2)^"</code>"
-
- (** Generate a file containing the module type in the given file name. *)
- method output_module_type in_title file mtyp =
- let s = String.concat "\n"
- (Str.split (Str.regexp "\n") (Odoc_info.string_of_module_type ~complete: true mtyp))
- in
- self#output_code in_title file s
-
- (** Generate a file containing the class type in the given file name. *)
- method output_class_type in_title file ctyp =
- let s = String.concat "\n"
- (Str.split (Str.regexp "\n") (Odoc_info.string_of_class_type ~complete: true ctyp))
- in
- self#output_code in_title file s
-
-
- (** Return html code for a value. *)
- method html_of_value v =
- Odoc_info.reset_type_names ();
- "<pre>"^(self#keyword "val")^" "^
- (* html mark *)
- "<a name=\""^(Naming.value_target v)^"\"></a>"^
- (match v.val_code with
- None -> Name.simple v.val_name
- | Some c ->
- let file = Naming.file_code_value_complete_target v in
- self#output_code v.val_name (Filename.concat !Args.target_dir file) c;
- "<a href=\""^file^"\">"^(Name.simple v.val_name)^"</a>"
- )^" : "^
- (self#html_of_type_expr (Name.father v.val_name) v.val_type)^"</pre>"^
- (self#html_of_info v.val_info)^
- (if !Args.with_parameter_list then
- self#html_of_parameter_list (Name.father v.val_name) v.val_parameters
- else
- self#html_of_described_parameter_list (Name.father v.val_name) v.val_parameters
- )
-
- (** Return html code for an exception. *)
- method html_of_exception e =
- Odoc_info.reset_type_names ();
- "<pre>"^(self#keyword "exception")^" "^
- (* html mark *)
- "<a name=\""^(Naming.exception_target e)^"\"></a>"^
- (Name.simple e.ex_name)^
- (match e.ex_args with
- [] -> ""
- | _ ->
- " "^(self#keyword "of")^" "^
- (self#html_of_type_expr_list (Name.father e.ex_name) " * " e.ex_args)
- )^
- (match e.ex_alias with
- None -> ""
- | Some ea -> " = "^
- (
- match ea.ea_ex with
- None -> ea.ea_name
- | Some e -> "<a href=\""^(Naming.complete_exception_target e)^"\">"^e.ex_name^"</a>"
- )
- )^
- "</pre>\n"^
- (self#html_of_info e.ex_info)
-
- (** Return html code for a type. *)
- method html_of_type t =
- Odoc_info.reset_type_names ();
- let father = Name.father t.ty_name in
- (match t.ty_manifest, t.ty_kind with
- None, Type_abstract -> "<pre>"
- | None, Type_variant _
- | None, Type_record _ -> "<br><code>"
- | Some _, Type_abstract -> "<pre>"
- | Some _, Type_variant _
- | Some _, Type_record _ -> "<pre>"
- )^
- (self#keyword "type")^" "^
- (* html mark *)
- "<a name=\""^(Naming.type_target t)^"\"></a>"^
- (self#html_of_type_expr_param_list father t)^
- (match t.ty_parameters with [] -> "" | _ -> " ")^
- (Name.simple t.ty_name)^" "^
- (match t.ty_manifest with None -> "" | Some typ -> "= "^(self#html_of_type_expr father typ)^" ")^
- (match t.ty_kind with
- Type_abstract -> "</pre>"
- | Type_variant (l, priv) ->
- "= "^(if priv then "private" else "")^
- (match t.ty_manifest with None -> "</code>" | Some _ -> "</pre>")^
- "<table class=\"typetable\">\n"^
- (String.concat "\n"
- (List.map
- (fun constr ->
- "<tr>\n"^
- "<td align=\"left\" valign=\"top\" >\n"^
- "<code>"^
- (self#keyword "|")^
- "</code></td>\n"^
- "<td align=\"left\" valign=\"top\" >\n"^
- "<code>"^
- (self#constructor constr.vc_name)^
- (match constr.vc_args with
- [] -> ""
- | l ->
- " "^(self#keyword "of")^" "^
- (self#html_of_type_expr_list father " * " l)
- )^
- "</code></td>\n"^
- (match constr.vc_text with
- None -> ""
- | Some t ->
- "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >"^
- "<code>"^
- "(*"^
- "</code></td>"^
- "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >"^
- "<code>"^
- (self#html_of_text t)^
- "</code></td>"^
- "<td class=\"typefieldcomment\" align=\"left\" valign=\"bottom\" >"^
- "<code>"^
- "*)"^
- "</code></td>"
- )^
- "\n</tr>"
- )
- l
- )
- )^
- "</table>\n"
-
- | Type_record (l, priv) ->
- "= "^(if priv then "private " else "")^"{"^
- (match t.ty_manifest with None -> "</code>" | Some _ -> "</pre>")^
- "<table class=\"typetable\">\n"^
- (String.concat "\n"
- (List.map
- (fun r ->
- "<tr>\n"^
- "<td align=\"left\" valign=\"top\" >\n"^
- "<code>&nbsp;&nbsp;</code>"^
- "</td>\n"^
- "<td align=\"left\" valign=\"top\" >\n"^
- "<code>"^(if r.rf_mutable then self#keyword "mutable&nbsp;" else "")^
- r.rf_name^"&nbsp;: "^(self#html_of_type_expr father r.rf_type)^";"^
- "</code></td>\n"^
- (match r.rf_text with
- None -> ""
- | Some t ->
- "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >"^
- "<code>"^
- "(*"^
- "</code></td>"^
- "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >"^
- "<code>"^
- (self#html_of_text t)^
- "</code></td>"^
- "<td class=\"typefieldcomment\" align=\"left\" valign=\"bottom\" >"^
- "<code>"^
- "*)"^
- "</code></td>"
- )^
- "\n</tr>"
- )
- l
- )
- )^
- "</table>\n"^
- "}\n"
- )^"\n"^
- (self#html_of_info t.ty_info)^
- "\n"
-
- (** Return html code for a class attribute. *)
- method html_of_attribute a =
- let module_name = Name.father (Name.father a.att_value.val_name) in
- "<pre>"^(self#keyword "val")^" "^
- (* html mark *)
- "<a name=\""^(Naming.attribute_target a)^"\"></a>"^
- (if a.att_mutable then (self#keyword Odoc_messages.mutab)^" " else "")^
- (match a.att_value.val_code with
- None -> Name.simple a.att_value.val_name
- | Some c ->
- let file = Naming.file_code_attribute_complete_target a in
- self#output_code a.att_value.val_name (Filename.concat !Args.target_dir file) c;
- "<a href=\""^file^"\">"^(Name.simple a.att_value.val_name)^"</a>"
- )^" : "^
- (self#html_of_type_expr module_name a.att_value.val_type)^"</pre>"^
- (self#html_of_info a.att_value.val_info)
-
- (** Return html code for a class method. *)
- method html_of_method m =
- let module_name = Name.father (Name.father m.met_value.val_name) in
- "<pre>"^(self#keyword "method")^" "^
- (* html mark *)
- "<a name=\""^(Naming.method_target m)^"\"></a>"^
- (if m.met_private then (self#keyword "private")^" " else "")^
- (if m.met_virtual then (self#keyword "virtual")^" " else "")^
- (match m.met_value.val_code with
- None -> Name.simple m.met_value.val_name
- | Some c ->
- let file = Naming.file_code_method_complete_target m in
- self#output_code m.met_value.val_name (Filename.concat !Args.target_dir file) c;
- "<a href=\""^file^"\">"^(Name.simple m.met_value.val_name)^"</a>"
- )^" : "^
- (self#html_of_type_expr module_name m.met_value.val_type)^"</pre>"^
- (self#html_of_info m.met_value.val_info)^
- (if !Args.with_parameter_list then
- self#html_of_parameter_list module_name m.met_value.val_parameters
- else
- self#html_of_described_parameter_list module_name m.met_value.val_parameters
- )
-
- (** Return html code for the description of a function parameter. *)
- method html_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 -> self#html_of_text t
- )
- | l ->
- (* A list of names, we display those with a description. *)
- let l2 = List.filter (fun n -> (Parameter.desc_by_name p n) <> None) l in
- String.concat "<br>\n"
- (List.map
- (fun n ->
- match Parameter.desc_by_name p n with
- None -> ""
- | Some t -> "<code>"^n^"</code> : "^(self#html_of_text t)
- )
- l2
- )
-
- (** Return html code for a list of parameters. *)
- method html_of_parameter_list m_name l =
- match l with
- [] ->
- ""
- | _ ->
- "<div class=\"info\">"^
- "<table border=\"0\" cellpadding=\"3\" width=\"100%\">\n"^
- "<tr>\n"^
- "<td align=\"left\" valign=\"top\" width=\"1%\"><b>"^Odoc_messages.parameters^": </b></td>\n"^
- "<td>\n"^
- "<table class=\"paramstable\">\n"^
- (*border=\"0\" cellpadding=\"5\" cellspacing=\"0\">\n"^*)
- (String.concat ""
- (List.map
- (fun p ->
- "<tr>\n"^
- "<td align=\"center\" valign=\"top\" width=\"15%\" class=\"code\">\n"^
- (match Parameter.complete_name p with
- "" -> "?"
- | s -> s
- )^"</td>\n"^
- "<td align=\"center\" valign=\"top\">:</td>\n"^
- "<td>"^(self#html_of_type_expr m_name (Parameter.typ p))^"<br>\n"^
- (self#html_of_parameter_description p)^"\n"^
- "</tr>\n"
- )
- l
- )
- )^"</table>\n"^
- "</td>\n"^
- "</tr>\n"^
- "</table></div>\n"
-
- (** Return html code for the parameters which have a name and description. *)
- method html_of_described_parameter_list 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 =
- "<div class=\"info\"><code class=\"code\">"^(Parameter.complete_name p)^"</code> : "^
- (self#html_of_parameter_description p)^"</div>\n"
- in
- match l2 with
- [] -> ""
- | _ -> "<br>"^(String.concat "" (List.map f l2))
-
- (** Return html code for a list of module parameters. *)
- method html_of_module_parameter_list m_name l =
- match l with
- [] ->
- ""
- | _ ->
- "<table border=\"0\" cellpadding=\"3\" width=\"100%\">\n"^
- "<tr>\n"^
- "<td align=\"left\" valign=\"top\" width=\"1%\"><b>"^Odoc_messages.parameters^": </b></td>\n"^
- "<td>\n"^
- "<table class=\"paramstable\">\n"^
- (*border=\"0\" cellpadding=\"5\" cellspacing=\"0\">\n"^*)
- (String.concat ""
- (List.map
- (fun (p, desc_opt) ->
- "<tr>\n"^
- "<td align=\"center\" valign=\"top\" width=\"15%\">\n"^
- "<code>"^p.mp_name^"</code></td>\n"^
- "<td align=\"center\" valign=\"top\">:</td>\n"^
- "<td>"^(self#html_of_module_type m_name p.mp_type)^"\n"^
- (match desc_opt with
- None -> ""
- | Some t -> "<br>"^(self#html_of_text t))^
- "\n"^
- "</tr>\n"
- )
- l
- )
- )^"</table>\n"^
- "</td>\n"^
- "</tr>\n"^
- "</table>\n"
-
- (** Return html code for a module. *)
- method html_of_module ?(info=true) ?(complete=true) ?(with_link=true) m =
- let (html_file, _) = Naming.html_files m.m_name in
- let father = Name.father m.m_name in
- let buf = Buffer.create 32 in
- let p = Printf.bprintf in
- p buf "<pre>%s " (self#keyword "module");
- (
- if with_link then
- p buf "<a href=\"%s\">%s</a>" html_file (Name.simple m.m_name)
- else
- p buf "%s" (Name.simple m.m_name)
- );
- p buf ": %s</pre>" (self#html_of_module_type father m.m_type);
- if info then
- p buf "%s" ((if complete then self#html_of_info else self#html_of_info_first_sentence) m.m_info)
- else
- ();
- Buffer.contents buf
-
- (** Return html code for a module type. *)
- method html_of_modtype ?(info=true) ?(complete=true) ?(with_link=true) mt =
- let (html_file, _) = Naming.html_files mt.mt_name in
- let father = Name.father mt.mt_name in
- let buf = Buffer.create 32 in
- let p = Printf.bprintf in
- p buf "<pre>%s " (self#keyword "module type");
- (
- if with_link then
- p buf "<a href=\"%s\">%s</a>" html_file (Name.simple mt.mt_name)
- else
- p buf "%s" (Name.simple mt.mt_name)
- );
- (match mt.mt_type with
- None -> ()
- | Some mtyp -> p buf " = %s" (self#html_of_module_type father mtyp)
- );
- Buffer.add_string buf "</pre>";
- if info then
- p buf "%s" ((if complete then self#html_of_info else self#html_of_info_first_sentence) mt.mt_info)
- else
- ();
- Buffer.contents buf
-
- (** Return html code for an included module. *)
- method html_of_included_module im =
- "<pre>"^(self#keyword "include")^" "^
- (
- match im.im_module with
- None ->
- 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
- "<a href=\""^file^"\">"^(Name.simple name)^"</a>"
- )^
- "</pre>\n"^
- (self#html_of_info im.im_info)
-
- (** Return html code for a class. *)
- method html_of_class ?(complete=true) ?(with_link=true) c =
- let father = Name.father c.cl_name in
- Odoc_info.reset_type_names ();
- let buf = Buffer.create 32 in
- let (html_file, _) = Naming.html_files c.cl_name in
- let p = Printf.bprintf in
- p buf "<pre>%s " (self#keyword "class");
- (* we add a html tag, the same as for a type so we can
- go directly here when the class name is used as a type name *)
- p buf "<a name=\"%s\"></a>"
- (Naming.type_target
- { ty_name = c.cl_name ;
- ty_info = None ; ty_parameters = [] ;
- ty_kind = Type_abstract ; ty_manifest = None ;
- ty_loc = Odoc_info.dummy_loc ;
- ty_code = None ;
- }
- );
- print_DEBUG "html#html_of_class : virtual or not" ;
- if c.cl_virtual then p buf "%s " (self#keyword "virtual") else ();
- (
- match c.cl_type_parameters with
- [] -> ()
- | l ->
- p buf "%s "
- (self#html_of_class_type_param_expr_list father l)
- );
- print_DEBUG "html#html_of_class : with link or not" ;
- (
- if with_link then
- p buf "<a href=\"%s\">%s</a>" html_file (Name.simple c.cl_name)
- else
- p buf "%s" (Name.simple c.cl_name)
- );
-
- Buffer.add_string buf " : " ;
- Buffer.add_string buf (self#html_of_class_type_expr father c.cl_type);
- Buffer.add_string buf "</pre>" ;
- print_DEBUG "html#html_of_class : info" ;
- Buffer.add_string buf
- ((if complete then self#html_of_info else self#html_of_info_first_sentence) c.cl_info);
- Buffer.contents buf
-
- (** Return html code for a class type. *)
- method html_of_class_type ?(complete=true) ?(with_link=true) ct =
- Odoc_info.reset_type_names ();
- let father = Name.father ct.clt_name in
- let buf = Buffer.create 32 in
- let p = Printf.bprintf in
- let (html_file, _) = Naming.html_files ct.clt_name in
- p buf "<pre>%s " (self#keyword "class type");
- (* we add a html tag, the same as for a type so we can
- go directly here when the class type name is used as a type name *)
- p buf "<a name=\"%s\"></a>"
- (Naming.type_target
- { ty_name = ct.clt_name ;
- ty_info = None ; ty_parameters = [] ;
- ty_kind = Type_abstract ; ty_manifest = None ;
- ty_loc = Odoc_info.dummy_loc ;
- ty_code = None ;
- }
- );
- if ct.clt_virtual then p buf "%s "(self#keyword "virtual") else ();
- (
- match ct.clt_type_parameters with
- [] -> ()
- | l -> p buf "%s " (self#html_of_class_type_param_expr_list father l)
- );
-
- if with_link then
- p buf "<a href=\"%s\">%s</a>" html_file (Name.simple ct.clt_name)
- else
- p buf "%s" (Name.simple ct.clt_name);
-
- Buffer.add_string buf " = ";
- Buffer.add_string buf (self#html_of_class_type_expr father ct.clt_type);
- Buffer.add_string buf "</pre>";
- Buffer.add_string buf ((if complete then self#html_of_info else self#html_of_info_first_sentence) ct.clt_info);
-
- Buffer.contents buf
-
- (** 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 =
- "<table border=1>\n<tr><td>"^
- "<a href=\""^html_file^"\">"^name2^"</a>"^
- "</td></tr>\n</table>\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 }
-
- (** Return html code for a module comment.*)
- method html_of_module_comment text =
- "<br>\n"^(self#html_of_text text)^"<br>\n"
-
- (** Return html code for a class comment.*)
- method html_of_class_comment 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 text2
-
- (** Generate html 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 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
- let html = self#html_of_text text in
- output_string chanout html
-
- (** Generate html code for the inherited classes of the given class. *)
- method generate_class_inheritance_info chanout cl =
- let rec iter_kind k =
- match k with
- Class_structure ([], _) ->
- ()
- | Class_structure (l, _) ->
- self#generate_inheritance_info chanout l
- | Class_constraint (k, ct) ->
- 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 chanout clt =
- match clt.clt_kind with
- Class_signature ([], _) ->
- ()
- | Class_signature (l, _) ->
- self#generate_inheritance_info chanout 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 !Args.target_dir simple_file) in
- output_string chanout
- (
- "<html>\n"^
- (self#header (self#inner_title title)) ^
- "<body>\n"^
- "<center><h1>"^title^"</h1></center>\n");
-
- let sorted_elements = List.sort
- (fun e1 -> fun e2 -> compare (Name.simple (name e1)) (Name.simple (name e2)))
- elements
- in
- let groups = Odoc_info.create_index_lists sorted_elements (fun e -> Name.simple (name e)) in
- let f_ele e =
- let simple_name = Name.simple (name e) in
- let father_name = Name.father (name e) in
- output_string chanout
- ("<tr><td><a href=\""^(target e)^"\">"^simple_name^"</a> "^
- (if simple_name <> father_name && father_name <> "" then
- "["^"<a href=\""^(fst (Naming.html_files father_name))^"\">"^father_name^"</a>]"
- else
- ""
- )^
- "</td>\n"^
- "<td>"^(self#html_of_info_first_sentence (info e))^"</td></tr>\n"
- )
- in
- let f_group l =
- match l with
- [] -> ()
- | e :: _ ->
- let s =
- match (Char.uppercase (Name.simple (name e)).[0]) with
- 'A'..'Z' as c -> String.make 1 c
- | _ -> ""
- in
- output_string chanout ("<tr><td align=\"left\"><br>"^s^"</td></tr>\n");
- List.iter f_ele l
- in
- output_string chanout "<table>\n";
- List.iter f_group groups ;
- output_string chanout "</table><br>\n" ;
- output_string chanout "</body>\n</html>";
- 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 !Args.target_dir html_file) in
- let pre_name = opt (fun c -> c.cl_name) pre in
- let post_name = opt (fun c -> c.cl_name) post in
- output_string chanout
- ("<html>\n"^
- (self#header
- ~nav: (Some (pre_name, post_name, cl.cl_name))
- ~comments: (Class.class_comments cl)
- (self#inner_title cl.cl_name)
- )^
- "<body>\n"^
- (self#navbar pre_name post_name cl.cl_name)^
- "<center><h1>"^Odoc_messages.clas^" "^
- (if cl.cl_virtual then "virtual " else "")^
- "<a href=\""^type_file^"\">"^cl.cl_name^"</a>"^
- "</h1></center>\n"^
- "<br>\n"^
- (self#html_of_class ~with_link: false cl)
- );
- (* parameters *)
- output_string chanout
- (self#html_of_described_parameter_list (Name.father cl.cl_name) cl.cl_parameters);
- (* class inheritance *)
- self#generate_class_inheritance_info chanout cl;
- (* a horizontal line *)
- output_string chanout "<hr width=\"100%\">\n";
- (* the various elements *)
- List.iter
- (fun element ->
- match element with
- Class_attribute a ->
- output_string chanout (self#html_of_attribute a)
- | Class_method m ->
- output_string chanout (self#html_of_method m)
- | Class_comment t ->
- output_string chanout (self#html_of_class_comment t)
- )
- (Class.class_elements ~trans:false cl);
- output_string chanout "</body></html>";
- close_out chanout;
-
- (* generate the file with the complete class type *)
- self#output_class_type
- cl.cl_name
- (Filename.concat !Args.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 !Args.target_dir html_file) in
- let pre_name = opt (fun ct -> ct.clt_name) pre in
- let post_name = opt (fun ct -> ct.clt_name) post in
- output_string chanout
- ("<html>\n"^
- (self#header
- ~nav: (Some (pre_name, post_name, clt.clt_name))
- ~comments: (Class.class_type_comments clt)
- (self#inner_title clt.clt_name)
- )^
- "<body>\n"^
- (self#navbar pre_name post_name clt.clt_name)^
- "<center><h1>"^Odoc_messages.class_type^" "^
- (if clt.clt_virtual then "virtual " else "")^
- "<a href=\""^type_file^"\">"^clt.clt_name^"</a>"^
- "</h1></center>\n"^
- "<br>\n"^
- (self#html_of_class_type ~with_link: false clt)
- );
- (* class inheritance *)
- self#generate_class_type_inheritance_info chanout clt;
- (* a horizontal line *)
- output_string chanout "<hr width=\"100%\">\n";
- (* the various elements *)
- List.iter
- (fun element ->
- match element with
- Class_attribute a ->
- output_string chanout (self#html_of_attribute a)
- | Class_method m ->
- output_string chanout (self#html_of_method m)
- | Class_comment t ->
- output_string chanout (self#html_of_class_comment t)
- )
- (Class.class_type_elements ~trans: false clt);
- output_string chanout "</body></html>";
- close_out chanout;
-
- (* generate the file with the complete class type *)
- self#output_class_type
- clt.clt_name
- (Filename.concat !Args.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 !Args.target_dir html_file) in
- let pre_name = opt (fun mt -> mt.mt_name) pre in
- let post_name = opt (fun mt -> mt.mt_name) post in
- output_string chanout
- ("<html>\n"^
- (self#header
- ~nav: (Some (pre_name, post_name, mt.mt_name))
- ~comments: (Module.module_type_comments mt)
- (self#inner_title mt.mt_name)
- )^
- "<body>\n"^
- (self#navbar pre_name post_name mt.mt_name)^
- "<center><h1>"^Odoc_messages.module_type^
- " "^
- (match mt.mt_type with
- Some _ -> "<a href=\""^type_file^"\">"^mt.mt_name^"</a>"
- | None-> mt.mt_name
- )^
- "</h1></center>\n"^
- "<br>\n"^
- (self#html_of_modtype ~with_link: false mt)
- );
- (* parameters for functors *)
- output_string chanout (self#html_of_module_parameter_list "" (Module.module_type_parameters mt));
- (* a horizontal line *)
- output_string chanout "<hr width=\"100%\">\n";
- (* module elements *)
- List.iter
- (fun ele ->
- match ele with
- Element_module m ->
- output_string chanout (self#html_of_module ~complete: false m)
- | Element_module_type mt ->
- output_string chanout (self#html_of_modtype ~complete: false mt)
- | Element_included_module im ->
- output_string chanout (self#html_of_included_module im)
- | Element_class c ->
- output_string chanout (self#html_of_class ~complete: false c)
- | Element_class_type ct ->
- output_string chanout (self#html_of_class_type ~complete: false ct)
- | Element_value v ->
- output_string chanout (self#html_of_value v)
- | Element_exception e ->
- output_string chanout (self#html_of_exception e)
- | Element_type t ->
- output_string chanout (self#html_of_type t)
- | Element_module_comment text ->
- output_string chanout (self#html_of_module_comment text)
- )
- (Module.module_type_elements mt);
-
- output_string chanout "</body></html>";
- 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 !Args.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 !Args.target_dir html_file) in
- let pre_name = opt (fun m -> m.m_name) pre in
- let post_name = opt (fun m -> m.m_name) post in
- output_string chanout
- ("<html>\n"^
- (self#header
- ~nav: (Some (pre_name, post_name, modu.m_name))
- ~comments: (Module.module_comments modu)
- (self#inner_title modu.m_name)
- ) ^
- "<body>\n"^
- (self#navbar pre_name post_name modu.m_name)^
- "<center><h1>"^(if Module.module_is_functor modu then Odoc_messages.functo else Odoc_messages.modul)^
- " "^
- "<a href=\""^type_file^"\">"^modu.m_name^"</a>"^
- (
- match modu.m_code with
- None -> ""
- | Some _ -> Printf.sprintf " (<a href=\"%s\">.ml</a>)" code_file
- )^
- "</h1></center>\n"^
- "<br>\n"^
- (self#html_of_module ~with_link: false modu)
- );
- (* parameters for functors *)
- output_string chanout (self#html_of_module_parameter_list "" (Module.module_parameters modu));
- (* a horizontal line *)
- output_string chanout "<hr width=\"100%\">\n";
- (* module elements *)
- List.iter
- (fun ele ->
- print_DEBUG "html#generate_for_module : ele ->";
- match ele with
- Element_module m ->
- output_string chanout (self#html_of_module ~complete: false m)
- | Element_module_type mt ->
- output_string chanout (self#html_of_modtype ~complete: false mt)
- | Element_included_module im ->
- output_string chanout (self#html_of_included_module im)
- | Element_class c ->
- output_string chanout (self#html_of_class ~complete: false c)
- | Element_class_type ct ->
- output_string chanout (self#html_of_class_type ~complete: false ct)
- | Element_value v ->
- output_string chanout (self#html_of_value v)
- | Element_exception e ->
- output_string chanout (self#html_of_exception e)
- | Element_type t ->
- output_string chanout (self#html_of_type t)
- | Element_module_comment text ->
- output_string chanout (self#html_of_module_comment text)
- )
- (Module.module_elements modu);
-
- output_string chanout "</body></html>";
- 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 !Args.target_dir type_file)
- modu.m_type;
-
- match modu.m_code with
- None -> ()
- | Some code ->
- self#output_code
- modu.m_name
- (Filename.concat !Args.target_dir code_file)
- code
- with
- Sys_error s ->
- raise (Failure s)
-
- (** Generate the [index.html] file corresponding to the given module list.
- @raise Failure if an error occurs.*)
- method generate_index module_list =
- try
- let title = match !Args.title with None -> "" | Some t -> self#escape t in
- let index_if_not_empty l url m =
- match l with
- [] -> ""
- | _ -> "<a href=\""^url^"\">"^m^"</a><br>\n"
- in
- let chanout = open_out (Filename.concat !Args.target_dir index) in
- output_string chanout
- (
- "<html>\n"^
- (self#header self#title) ^
- "<body>\n"^
- "<center><h1>"^title^"</h1></center>\n"^
- (
- let info = Odoc_info.apply_opt
- Odoc_info.info_of_comment_file !Odoc_info.Args.intro_file
- in
- Printf.sprintf "%s%s"
- (self#html_of_info info)
- (match info with None -> "" | Some _ -> "<br/>")
- )^
- (index_if_not_empty list_types index_types Odoc_messages.index_of_types)^
- (index_if_not_empty list_exceptions index_exceptions Odoc_messages.index_of_exceptions)^
- (index_if_not_empty list_values index_values Odoc_messages.index_of_values)^
- (index_if_not_empty list_attributes index_attributes Odoc_messages.index_of_attributes)^
- (index_if_not_empty list_methods index_methods Odoc_messages.index_of_methods)^
- (index_if_not_empty list_classes index_classes Odoc_messages.index_of_classes)^
- (index_if_not_empty list_class_types index_class_types Odoc_messages.index_of_class_types)^
- (index_if_not_empty list_modules index_modules Odoc_messages.index_of_modules)^
- (index_if_not_empty list_module_types index_module_types Odoc_messages.index_of_module_types)^
- "<br>\n"^
- "<table class=\"indextable\">\n"^
- (String.concat ""
- (List.map
- (fun m ->
- let (html, _) = Naming.html_files m.m_name in
- "<tr><td><a href=\""^html^"\">"^m.m_name^"</a></td>"^
- "<td>"^(self#html_of_info_first_sentence m.m_info)^"</td></tr>\n")
- module_list
- )
- )^
- "</table>\n"^
- "</body>\n"^
- "</html>"
- );
- 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
- list_values
- (fun v -> v.val_name)
- (fun v -> v.val_info)
- Naming.complete_value_target
- Odoc_messages.index_of_values
- index_values
-
- (** Generate the exceptions index in the file [index_exceptions.html]. *)
- method generate_exceptions_index module_list =
- self#generate_elements_index
- list_exceptions
- (fun e -> e.ex_name)
- (fun e -> e.ex_info)
- Naming.complete_exception_target
- Odoc_messages.index_of_exceptions
- index_exceptions
-
- (** Generate the types index in the file [index_types.html]. *)
- method generate_types_index module_list =
- self#generate_elements_index
- list_types
- (fun t -> t.ty_name)
- (fun t -> t.ty_info)
- Naming.complete_type_target
- Odoc_messages.index_of_types
- index_types
-
- (** Generate the attributes index in the file [index_attributes.html]. *)
- method generate_attributes_index module_list =
- self#generate_elements_index
- list_attributes
- (fun a -> a.att_value.val_name)
- (fun a -> a.att_value.val_info)
- Naming.complete_attribute_target
- Odoc_messages.index_of_attributes
- index_attributes
-
- (** Generate the methods index in the file [index_methods.html]. *)
- method generate_methods_index module_list =
- self#generate_elements_index
- list_methods
- (fun m -> m.met_value.val_name)
- (fun m -> m.met_value.val_info)
- Naming.complete_method_target
- Odoc_messages.index_of_methods
- index_methods
-
- (** Generate the classes index in the file [index_classes.html]. *)
- method generate_classes_index module_list =
- self#generate_elements_index
- list_classes
- (fun c -> c.cl_name)
- (fun c -> c.cl_info)
- (fun c -> fst (Naming.html_files c.cl_name))
- Odoc_messages.index_of_classes
- index_classes
-
- (** Generate the class types index in the file [index_class_types.html]. *)
- method generate_class_types_index module_list =
- self#generate_elements_index
- list_class_types
- (fun ct -> ct.clt_name)
- (fun ct -> ct.clt_info)
- (fun ct -> fst (Naming.html_files ct.clt_name))
- Odoc_messages.index_of_class_types
- index_class_types
-
- (** Generate the modules index in the file [index_modules.html]. *)
- method generate_modules_index module_list =
- self#generate_elements_index
- list_modules
- (fun m -> m.m_name)
- (fun m -> m.m_info)
- (fun m -> fst (Naming.html_files m.m_name))
- Odoc_messages.index_of_modules
- index_modules
-
- (** Generate the module types index in the file [index_module_types.html]. *)
- method generate_module_types_index module_list =
- let module_types = Odoc_info.Search.module_types module_list in
- self#generate_elements_index
- list_module_types
- (fun mt -> mt.mt_name)
- (fun mt -> mt.mt_info)
- (fun mt -> fst (Naming.html_files mt.mt_name))
- Odoc_messages.index_of_module_types
- index_module_types
-
- (** Generate all the html files from a module list. The main
- file is [index.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_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
- let type_names = List.map (fun t -> t.ty_name) types in
- known_types_names <- type_names ;
- (* Get the names of all class and class types. *)
- let classes = Odoc_info.Search.classes module_list in
- let class_types = Odoc_info.Search.class_types module_list in
- let class_names = List.map (fun c -> c.cl_name) classes in
- let class_type_names = List.map (fun ct -> ct.clt_name) class_types in
- known_classes_names <- class_names @ class_type_names ;
- (* Get the names of all known modules and module types. *)
- let module_types = Odoc_info.Search.module_types module_list in
- let modules = Odoc_info.Search.modules module_list in
- let module_type_names = List.map (fun mt -> mt.mt_name) module_types in
- let module_names = List.map (fun m -> m.m_name) modules in
- known_modules_names <- module_type_names @ module_names ;
- (* generate html for each module *)
- if not !Args.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_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 -> self#html_of_text (Odoc_text.Texter.text_of_string s))
- end
-
-
-
-(* eof $Id$ *)
diff --git a/ocamldoc/odoc_info.ml b/ocamldoc/odoc_info.ml
deleted file mode 100644
index 4e11dfe2ed..0000000000
--- a/ocamldoc/odoc_info.ml
+++ /dev/null
@@ -1,254 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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_exception
- | RK_attribute
- | RK_method
- | RK_section of text
-
-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
- | Superscript of text
- | Subscript of text
-
-
-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_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 : (string * int) option ;
- loc_inter : (string * int) option ;
- }
-
-let dummy_loc = { loc_impl = None ; loc_inter = None }
-
-module Name = Odoc_name
-module Parameter = Odoc_parameter
-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_args.merge_options := merge_options;
- Odoc_args.include_dirs := include_dirs;
- Odoc_args.classic := not labels;
- Odoc_args.sort_modules := sort_modules;
- Odoc_args.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_misc.string_of_type_expr t
-
-let string_of_type_list sep type_list = Odoc_str.string_of_type_list sep type_list
-
-let string_of_type_param_list t = Odoc_str.string_of_type_param_list t
-
-let string_of_class_type_param_list l = Odoc_str.string_of_class_type_param_list l
-
-let string_of_module_type = Odoc_misc.string_of_module_type
-
-let string_of_class_type = Odoc_misc.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_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 get_titles_in_text = Odoc_misc.get_titles_in_text
-
-let create_index_lists = Odoc_misc.create_index_lists
-
-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_args.hidden_modules n
-
-let verbose s =
- if !Odoc_args.verbose then
- (print_string s ; print_newline ())
- else
- ()
-
-let warning s = Odoc_messages.pwarning s
-
-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 info_of_string s =
- let dummy =
- {
- i_desc = None ;
- i_authors = [] ;
- i_version = None ;
- i_sees = [] ;
- i_since = None ;
- i_deprecated = None ;
- i_params = [] ;
- i_raised_exceptions = [] ;
- i_return_value = None ;
- i_custom = [] ;
- }
- in
- let s2 = Printf.sprintf "(** %s *)" s in
- let (_, i_opt) = Odoc_comments.Basic_info_retriever.first_special "-" s2 in
- match i_opt with
- None -> dummy
- | Some i -> i
-
-let info_of_comment_file f =
- try
- let s = Odoc_misc.input_file_as_string f in
- info_of_string s
- with
- Sys_error s ->
- failwith s
-
-module Search =
- struct
- type result_element = Odoc_search.result_element =
- 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_exception of Exception.t_exception
- | Res_attribute of Value.t_attribute
- | Res_method of Value.t_method
- | Res_section of string * text
-
- type search_result = result_element list
-
- let search_by_name = Odoc_search.Search_by_name.search
-
- let values = Odoc_search.values
- 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 Args = Odoc_args
diff --git a/ocamldoc/odoc_info.mli b/ocamldoc/odoc_info.mli
deleted file mode 100644
index e4b97cdb95..0000000000
--- a/ocamldoc/odoc_info.mli
+++ /dev/null
@@ -1,1032 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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_exception
- | RK_attribute
- | RK_method
- | RK_section of text
-
-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
- (** A reference to an element. Complete name and kind. *)
- | Superscript of text (** Superscripts. *)
- | Subscript of text (** Subscripts. *)
-
-(** 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 *)
-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_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 : (string * int) option ; (** implementation file name and position *)
- loc_inter : (string * int) option ; (** interface file name and position *)
- }
-
-(** 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
-
- (** A module parameter is just a name and a module type.*)
- type module_parameter = Odoc_parameter.module_parameter =
- {
- mp_name : string ;
- mp_type : Types.module_type ;
- }
-
- (** {3 Functions} *)
- (** Acces to the name as a string. For tuples, parenthesis and commas are added. *)
- val complete_name : parameter -> string
-
- (** 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 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 : Types.type_expr list ; (** The types of the parameters. *)
- 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
- (** Description of a variant type constructor. *)
- type variant_constructor = Odoc_type.variant_constructor =
- {
- vc_name : string ; (** Name of the constructor. *)
- vc_args : Types.type_expr list ; (** Arguments of the constructor. *)
- mutable vc_text : text option ; (** Optional description in the associated comment. *)
- }
-
- (** 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 : text 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 * bool
- (** constructors * bool *)
- | Type_record of record_field list * bool
- (** fields * bool *)
-
- (** 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_manifest : Types.type_expr option; (** Type manifest. *)
- 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. *)
- }
-
- (** 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. A VOIR : mettre des string ? *)
- }
-
- 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_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. *)
- }
-
- (** Different kinds of a module. *)
- and module_kind = Odoc_module.module_kind =
- | Module_struct of module_element list (** A complete module structure. *)
- | Module_alias of module_alias (** Complete name and corresponding module if we found it *)
- | Module_functor of (Parameter.module_parameter list) * module_kind
- (** A functor, with {e all} its parameters and the rest of its definition *)
- | Module_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. *)
-
- (** Representation of a module. *)
- and t_module = Odoc_module.t_module =
- {
- m_name : Name.t ; (** Complete name of the module. *)
- 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 *)
- }
-
- 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 (Odoc_parameter.module_parameter list) * module_type_kind
- (** A functor, with {e all} its parameters 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. *)
-
- (** 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. *)
- 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 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 -> (Parameter.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 -> (Parameter.module_parameter * text option) list
-
- (** The list of module comments. *)
- val module_type_comments : ?trans:bool-> t_module_type -> text list
- 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 ->
- string 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
-
-(** {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
-
-(** This function returns a string to represent the given list of types,
- with a given separator. *)
-val string_of_type_list : string -> Types.type_expr list -> string
-
-(** This function returns a string to represent the list of type parameters
- for the given type. *)
-val string_of_type_param_list : Type.t_type -> string
-
-(** This function returns a string to represent the given list of
- type parameters of a class or class type,
- with a given separator. It writes in and flushes [Format.str_formatter].*)
-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].
-*)
-val string_of_module_type : ?complete: bool -> Types.module_type -> string
-
-(** This function returns a string representing a [Types.class_type].
- @param complete indicates if we must print complete signatures
- or just [object end]. Default if [false].
-*)
-val string_of_class_type : ?complete: bool -> Types.class_type -> string
-
-
-(** 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
-
-(** @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
-
-(** 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 : string -> bool
-
-(** Return the label name for the given label,
- i.e. removes the beginning '?' if present.*)
-val label_name : string -> 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
-
-(** 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
-
-(** [string_text_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_of_comment_file file] parses the given file
- and return an {!Odoc_info.info} structure. The content of the
- file must have the same syntax as the content of a special comment.
- @raise Failure is the file could not be opened or there is a
- syntax error.
-*)
-val info_of_comment_file : string -> info
-
-
-(** Research in elements *)
-module Search :
- sig
- 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_exception of Exception.t_exception
- | Res_attribute of Value.t_attribute
- | Res_method of Value.t_method
- | Res_section of string * text
-
- (** 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 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
- (** Scan of 'leaf elements'. *)
-
- method scan_value : Value.t_value -> unit
- method scan_type : Type.t_type -> 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 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 overriden. 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 overriden. 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 overriden. 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 overriden. 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 Command line arguments} *)
-
-(** You can use this module to create custom generators.*)
-module Args :
- sig
- (** The class type of documentation generators. *)
- class type doc_generator =
- object method generate : Module.t_module list -> unit end
-
- (** The file used by the generators outputting only one file. *)
- val out_file : string ref
-
- (** Verbose mode or not. *)
- val verbose : bool ref
-
- (** The optional title to use in the generated documentation. *)
- val title : string option ref
-
- (** The optional file whose content can be used as intro text. *)
- val intro_file : string option ref
-
- (** Flag to indicate whether we must display the complete list of parameters
- for functions and methods. *)
- val with_parameter_list : bool ref
-
- (** The list of module names to hide. *)
- val hidden_modules : string list ref
-
- (** The directory where files have to be generated. *)
- val target_dir : string ref
-
- (** An optional file to use where a CSS style is defined (for HTML). *)
- val css_style : string option ref
-
- (** Generate only index files. (for HTML). *)
- val index_only : bool ref
-
- (** To colorize code in HTML generated documentation pages, not code pages. *)
- val colorize_code : bool ref
-
- (** The flag which indicates if we must generate a header (for LaTeX). *)
- val with_header : bool ref
-
- (** The flag which indicates if we must generate a trailer (for LaTeX). *)
- val with_trailer : bool ref
-
- (** The flag to indicate if we must generate one file per module (for LaTeX). *)
- val separate_files : bool ref
-
- (** The list of pairs (title level, sectionning style). *)
- val latex_titles : (int * string) list ref
-
- (** The prefix to use for value labels in LaTeX. *)
- val latex_value_prefix : string ref
-
- (** The prefix to use for type labels in LaTeX. *)
- val latex_type_prefix : string ref
-
- (** The prefix to use for exception labels in LaTeX. *)
- val latex_exception_prefix : string ref
-
- (** The prefix to use for module labels in LaTeX. *)
- val latex_module_prefix : string ref
-
- (** The prefix to use for module type labels in LaTeX. *)
- val latex_module_type_prefix : string ref
-
- (** The prefix to use for class labels in LaTeX. *)
- val latex_class_prefix : string ref
-
- (** The prefix to use for class type labels in LaTeX. *)
- val latex_class_type_prefix : string ref
-
- (** The prefix to use for attribute labels in LaTeX. *)
- val latex_attribute_prefix : string ref
-
- (** The prefix to use for method labels in LaTeX. *)
- val latex_method_prefix : string ref
-
- (** The flag which indicates if we must generate a table of contents (for LaTeX). *)
- val with_toc : bool ref
-
- (** The flag which indicates if we must generate an index (for TeXinfo). *)
- val with_index : bool ref
-
- (** The flag which indicates if we must escape accentuated characters (for TeXinfo).*)
- val esc_8bits : bool ref
-
- (** The Info directory section *)
- val info_section : string ref
-
- (** The Info directory entries to insert *)
- val info_entry : string list ref
-
- (** Include all modules or only the ones on the command line, for the dot ouput. *)
- val dot_include_all : bool ref
-
- (** Generate dependency graph for types. *)
- val dot_types : bool ref
-
- (** Perform transitive reduction before dot output. *)
- val dot_reduce : bool ref
-
- (** The colors used in the dot output. *)
- val dot_colors : string list ref
-
- (** The suffix for man pages. *)
- val man_suffix : string ref
-
- (** The flag to generate all man pages or only for modules and classes.*)
- val man_mini : bool ref
-
- (** The files to be analysed. *)
- val files : string list ref
-
- (** To set the documentation generator. *)
- val set_doc_generator : doc_generator option -> unit
-
- (** Add an option specification. *)
- val add_option : string * Arg.spec * string -> unit
- end
diff --git a/ocamldoc/odoc_inherit.ml b/ocamldoc/odoc_inherit.ml
deleted file mode 100644
index 705bf4ad3c..0000000000
--- a/ocamldoc/odoc_inherit.ml
+++ /dev/null
@@ -1,13 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
diff --git a/ocamldoc/odoc_latex.ml b/ocamldoc/odoc_latex.ml
deleted file mode 100644
index 7da4d23891..0000000000
--- a/ocamldoc/odoc_latex.ml
+++ /dev/null
@@ -1,986 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Generation of LaTeX documentation. *)
-
-let print_DEBUG s = print_string s ; print_newline ()
-
-open Odoc_info
-open Parameter
-open Value
-open Type
-open Exception
-open Class
-open Module
-
-
-(** 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 !Args.latex_titles in
- "\\"^sec^"{"^s^"}\n"
- with Not_found -> s
-
- (** Associations of strings to subsitute in latex code. *)
- val mutable subst_strings = [
- ("MAXENCE"^"ZZZ", "\\$");
- ("MAXENCE"^"YYY", "\\&");
- ("MAXENCE"^"XXX", "{\\textbackslash}") ;
- ("à", "\\`a") ;
- ("â", "\\^a") ;
- ("é", "\\'e") ;
- ("è", "\\`e") ;
- ("ê", "\\^e") ;
- ("ë", "\\\"e") ;
- ("ç", "\\c{c}") ;
- ("ô", "\\^o") ;
- ("ö", "\\\"o") ;
- ("î", "\\^i") ;
- ("ï", "\\\"i") ;
- ("ù", "\\`u") ;
- ("û", "\\^u") ;
- ("%", "\\%") ;
- ("_", "\\_");
- ("\\.\\.\\.", "$\\ldots$");
- ("~", "\\~{}");
- ("#", "\\verb`#`");
- ("}", "\\}");
- ("{", "\\{");
- ("&", "\\&");
- (">", "$>$");
- ("<", "$<$");
- ("=", "$=$");
- (">=", "$\\geq$");
- ("<=", "$\\leq$");
- ("->", "$\\rightarrow$") ;
- ("<-", "$\\leftarrow$");
- ("|", "\\textbar ");
- ("\\^", "\\textasciicircum ") ;
- ("\\.\\.\\.", "$\\ldots$");
- ("\\\\", "MAXENCE"^"XXX") ;
- ("&", "MAXENCE"^"YYY") ;
- ("\\$", "MAXENCE"^"ZZZ")
- ]
-
- val mutable subst_strings_simple =
- [
- ("MAXENCE"^"XXX", "{\\textbackslash}") ;
- "}", "\\}" ;
- "{", "\\{" ;
- ("\\\\", "MAXENCE"^"XXX") ;
- ]
-
- val mutable subst_strings_code = [
- ("MAXENCE"^"ZZZ", "\\$");
- ("MAXENCE"^"YYY", "\\&");
- ("MAXENCE"^"XXX", "{\\textbackslash}") ;
- ("%", "\\%") ;
- ("_", "\\_");
- ("~", "\\~{}");
- ("#", "\\verb`#`");
- ("}", "\\}");
- ("{", "\\{");
- ("&", "\\&");
- ("\\^", "\\textasciicircum ") ;
- ("&", "MAXENCE"^"YYY") ;
- ("\\$", "MAXENCE"^"ZZZ") ;
- ("\\\\", "MAXENCE"^"XXX") ;
- ]
-
- method subst l s =
- List.fold_right
- (fun (s, s2) -> fun acc -> Str.global_replace (Str.regexp s) s2 acc)
- l
- s
-
- (** 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 = !Args.latex_value_prefix^(self#label ?no_ name)
-
- (** Make a correct label from an attribute name. *)
- method attribute_label ?no_ name = !Args.latex_attribute_prefix^(self#label ?no_ name)
-
- (** Make a correct label from a method name. *)
- method method_label ?no_ name = !Args.latex_method_prefix^(self#label ?no_ name)
-
- (** Make a correct label from a class name. *)
- method class_label ?no_ name = !Args.latex_class_prefix^(self#label ?no_ name)
-
- (** Make a correct label from a class type name. *)
- method class_type_label ?no_ name = !Args.latex_class_type_prefix^(self#label ?no_ name)
-
- (** Make a correct label from a module name. *)
- method module_label ?no_ name = !Args.latex_module_prefix^(self#label ?no_ name)
-
- (** Make a correct label from a module type name. *)
- method module_type_label ?no_ name = !Args.latex_module_type_prefix^(self#label ?no_ name)
-
- (** Make a correct label from an exception name. *)
- method exception_label ?no_ name = !Args.latex_exception_prefix^(self#label ?no_ name)
-
- (** Make a correct label from a type name. *)
- method type_label ?no_ name = !Args.latex_type_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^"}"
-
- (** Return the LaTeX code corresponding to the [text] parameter.*)
- method latex_of_text t = String.concat "" (List.map self#latex_of_text_element t)
-
- (** Return the LaTeX code for the [text_element] in parameter. *)
- method latex_of_text_element te =
- match te with
- | Odoc_info.Raw s -> self#latex_of_Raw s
- | Odoc_info.Code s -> self#latex_of_Code s
- | Odoc_info.CodePre s -> self#latex_of_CodePre s
- | Odoc_info.Verbatim s -> self#latex_of_Verbatim s
- | Odoc_info.Bold t -> self#latex_of_Bold t
- | Odoc_info.Italic t -> self#latex_of_Italic t
- | Odoc_info.Emphasize t -> self#latex_of_Emphasize t
- | Odoc_info.Center t -> self#latex_of_Center t
- | Odoc_info.Left t -> self#latex_of_Left t
- | Odoc_info.Right t -> self#latex_of_Right t
- | Odoc_info.List tl -> self#latex_of_List tl
- | Odoc_info.Enum tl -> self#latex_of_Enum tl
- | Odoc_info.Newline -> self#latex_of_Newline
- | Odoc_info.Block t -> self#latex_of_Block t
- | Odoc_info.Title (n, l_opt, t) -> self#latex_of_Title n l_opt t
- | Odoc_info.Latex s -> self#latex_of_Latex s
- | Odoc_info.Link (s, t) -> self#latex_of_Link s t
- | Odoc_info.Ref (name, ref_opt) -> self#latex_of_Ref name ref_opt
- | Odoc_info.Superscript t -> self#latex_of_Superscript t
- | Odoc_info.Subscript t -> self#latex_of_Subscript t
-
- method latex_of_Raw s = self#escape s
-
- method latex_of_Code s =
- let s2 = self#escape_code s in
- let s3 = Str.global_replace (Str.regexp "\n") ("\\\\\n") s2 in
- "{\\tt{"^s3^"}}"
-
- method latex_of_CodePre s =
- "\\begin{ocamldoccode}\n"^(self#escape_simple s)^"\n\\end{ocamldoccode}\n"
-
- method latex_of_Verbatim s = "\\begin{verbatim}"^s^"\\end{verbatim}"
-
- method latex_of_Bold t =
- let s = self#latex_of_text t in
- "{\\bf "^s^"}"
-
- method latex_of_Italic t =
- let s = self#latex_of_text t in
- "{\\it "^s^"}"
-
- method latex_of_Emphasize t =
- let s = self#latex_of_text t in
- "{\\em "^s^"}"
-
- method latex_of_Center t =
- let s = self#latex_of_text t in
- "\\begin{center}\n"^s^"\\end{center}\n"
-
- method latex_of_Left t =
- let s = self#latex_of_text t in
- "\\begin{flushleft}\n"^s^"\\end{flushleft}\n"
-
- method latex_of_Right t =
- let s = self#latex_of_text t in
- "\\begin{flushright}\n"^s^"\\end{flushright}\n"
-
- method latex_of_List tl =
- "\\begin{itemize}"^
- (String.concat ""
- (List.map (fun t -> "\\item "^(self#latex_of_text t)^"\n") tl))^
- "\\end{itemize}\n"
-
- method latex_of_Enum tl =
- "\\begin{enumerate}"^
- (String.concat ""
- (List.map (fun t -> "\\item "^(self#latex_of_text t)^"\n") tl))^
- "\\end{enumerate}\n"
-
- method latex_of_Newline = "\n\n"
-
- method latex_of_Block t =
- let s = self#latex_of_text t in
- "\\begin{ocamldocdescription}\n"^s^"\n\\end{ocamldocdescription}\n"
-
- method latex_of_Title n label_opt t =
- let s_title = self#latex_of_text t in
- let s_title2 = self#section_style n s_title in
- s_title2^
- (match label_opt with
- None -> ""
- | Some l -> self#make_label (self#label ~no_: false l))
-
- method latex_of_Latex s = s
-
- method latex_of_Link s t =
- let s1 = self#latex_of_text t in
- let s2 = "[\\url{"^s^"}]" in
- s1^s2
-
- method latex_of_Ref name ref_opt =
- match ref_opt with
- None ->
- self#latex_of_text_element
- (Odoc_info.Code (Odoc_info.use_hidden_modules name))
- | Some (RK_section _) ->
- self#latex_of_text_element
- (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_exception -> self#exception_label
- | Odoc_info.RK_attribute -> self#attribute_label
- | Odoc_info.RK_method -> self#method_label
- | Odoc_info.RK_section _ -> assert false
- in
- (self#latex_of_text
- [
- Odoc_info.Code (Odoc_info.use_hidden_modules name) ;
- Latex ("["^(self#make_ref (f_label name))^"]")
- ]
- )
-
- method latex_of_Superscript t = "$^{"^(self#latex_of_text t)^"}$"
-
- method latex_of_Subscript t = "$_{"^(self#latex_of_text t)^"}$"
-
- 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 : Odoc_info.text -> string
-
- (** The method used to get a [text] from an optionel info structure. *)
- method virtual text_of_info : ?block: bool -> Odoc_info.info option -> Odoc_info.text
-
- (** Return LaTeX code for a description, except for the [i_params] field. *)
- method latex_of_info info_opt =
- self#latex_of_text
- (self#text_of_info ~block: false info_opt)
- end
-
-(** 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)
-
- (** Return LaTeX code for a value. *)
- method latex_of_value v =
- Odoc_info.reset_type_names () ;
- self#latex_of_text
- ((Latex (self#make_label (self#value_label v.val_name))) ::
- (to_text#text_of_value v))
-
- (** Return LaTeX code for a class attribute. *)
- method latex_of_attribute a =
- self#latex_of_text
- ((Latex (self#make_label (self#attribute_label a.att_value.val_name))) ::
- (to_text#text_of_attribute a))
-
- (** Return LaTeX code for a class method. *)
- method latex_of_method m =
- self#latex_of_text
- ((Latex (self#make_label (self#method_label m.met_value.val_name))) ::
- (to_text#text_of_method m))
-
- (** Return LaTeX code for the parameters of a type. *)
- method latex_of_type_params m_name t =
- let f (p, co, cn) =
- Printf.sprintf "%s%s"
- (Odoc_info.string_of_variance t (co,cn))
- (self#normal_type m_name p)
- in
- match t.ty_parameters with
- [] -> ""
- | [(p,co,cn)] -> f (p, co, cn)
- | l ->
- Printf.sprintf "(%s)"
- (String.concat ", " (List.map f t.ty_parameters))
-
- (** Return LaTeX code for a type. *)
- method latex_of_type t =
- let s_name = Name.simple t.ty_name in
- let text =
- Odoc_info.reset_type_names () ;
- let mod_name = Name.father t.ty_name in
- let s_type1 =
- Format.fprintf Format.str_formatter "@[<hov 2>type ";
- Format.fprintf Format.str_formatter "%s%s"
- (self#latex_of_type_params mod_name t)
- (match t.ty_parameters with [] -> "" | _ -> " ");
- Format.flush_str_formatter ()
- in
- Format.fprintf Format.str_formatter
- ("@[<hov 2>%s %s")
- s_type1
- s_name;
- let s_type2 =
- (
- match t.ty_manifest with
- None -> ()
- | Some typ ->
- Format.fprintf Format.str_formatter
- " = %s"
- (self#normal_type mod_name typ)
- );
- Format.flush_str_formatter ()
- in
- let s_type3 =
- Format.fprintf Format.str_formatter
- ("%s %s")
- s_type2
- (
- match t.ty_kind with
- Type_abstract -> ""
- | Type_variant (_, priv) -> "="^(if priv then " private" else "")
- | Type_record (_, priv) -> "= "^(if priv then "private " else "")^"{"
- ) ;
- Format.flush_str_formatter ()
- in
-
- let defs =
- match t.ty_kind with
- Type_abstract -> []
- | Type_variant (l, _) ->
- (List.flatten
- (List.map
- (fun constr ->
- let s_cons =
- Format.fprintf Format.str_formatter
- "@[<hov 6> | %s"
- constr.vc_name;
- (
- match constr.vc_args with
- [] -> ()
- | l ->
- Format.fprintf Format.str_formatter " %s@ %s"
- "of"
- (self#normal_type_list mod_name " * " l)
- );
- Format.flush_str_formatter ()
- in
- [ CodePre s_cons ] @
- (match constr.vc_text with
- None -> []
- | Some t ->
- [ Latex
- ("\\begin{ocamldoccomment}\n"^
- (self#latex_of_text t)^
- "\n\\end{ocamldoccomment}\n")
- ]
- )
- )
- l
- )
- )
- | Type_record (l, _) ->
- (List.flatten
- (List.map
- (fun r ->
- let s_field =
- Format.fprintf Format.str_formatter
- "@[<hov 6> %s%s :@ %s ;"
- (if r.rf_mutable then "mutable " else "")
- r.rf_name
- (self#normal_type mod_name r.rf_type);
- Format.flush_str_formatter ()
- in
- [ CodePre s_field ] @
- (match r.rf_text with
- None -> []
- | Some t ->
- [ Latex
- ("\\begin{ocamldoccomment}\n"^
- (self#latex_of_text t)^
- "\n\\end{ocamldoccomment}\n")
- ]
- )
- )
- l
- )
- ) @
- [ CodePre "}" ]
- in
- let defs2 = (CodePre s_type3) :: defs in
- let rec iter = function
- [] -> []
- | [e] -> [e]
- | (CodePre s1) :: (CodePre s2) :: q ->
- iter ((CodePre (s1^"\n"^s2)) :: q)
- | e :: q ->
- e :: (iter q)
- in
- (iter defs2) @
- [Latex ("\\index{"^(self#type_label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @
- (self#text_of_info t.ty_info)
- in
- self#latex_of_text
- ((Latex (self#make_label (self#type_label t.ty_name))) :: text)
-
- (** Return LaTeX code for an exception. *)
- method latex_of_exception e =
- Odoc_info.reset_type_names () ;
- self#latex_of_text
- ((Latex (self#make_label (self#exception_label e.ex_name))) ::
- (to_text#text_of_exception e))
-
- (** Return the LaTeX code for the given module.
- @param for_detail indicate if we must print the type ([false]) or just ["sig"] ([true]).*)
- method latex_of_module ?(for_detail=false) ?(with_link=true) m =
- let buf = Buffer.create 32 in
- let f = Format.formatter_of_buffer buf in
- let father = Name.father m.m_name in
- let t =
- Format.fprintf f "module %s" (Name.simple m.m_name);
- Format.fprintf f " : %s"
- (
- if for_detail
- then "sig"
- else (self#normal_module_type father m.m_type)
- );
-
- Format.pp_print_flush f ();
-
- (CodePre (Buffer.contents buf)) ::
- (
- if with_link
- then [Odoc_info.Latex ("\\\n["^(self#make_ref (self#module_label m.m_name))^"]")]
- else []
- )
- in
- self#latex_of_text t
-
- (** Return the LaTeX code for the given module type.
- @param for_detail indicate if we must print the type ([false]) or just ["sig"] ([true]).*)
- method latex_of_module_type ?(for_detail=false) ?(with_link=true) mt =
- let buf = Buffer.create 32 in
- let f = Format.formatter_of_buffer buf in
- let father = Name.father mt.mt_name in
- let t =
- Format.fprintf f "module type %s" (Name.simple mt.mt_name);
- (match mt.mt_type with
- None -> ()
- | Some mtyp ->
- Format.fprintf f " = %s"
- (
- if for_detail
- then "sig"
- else (self#normal_module_type father mtyp)
- )
- );
-
- Format.pp_print_flush f ();
-
- (CodePre (Buffer.contents buf)) ::
- (
- if with_link
- then [Odoc_info.Latex ("\\\n["^(self#make_ref (self#module_type_label mt.mt_name))^"]")]
- else []
- )
- in
- self#latex_of_text t
-
- (** Return the LaTeX code for the given included module. *)
- method latex_of_included_module im =
- (self#latex_of_text ((Code "include ") ::
- (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)
- )
- )
-
- (** Return the LaTeX code for the given class.
- @param for_detail indicate if we must print the type ([false]) or just ["object"] ([true]).*)
- method latex_of_class ?(for_detail=false) ?(with_link=true) c =
- Odoc_info.reset_type_names () ;
- let buf = Buffer.create 32 in
- let f = Format.formatter_of_buffer buf in
- let father = Name.father c.cl_name in
- let t =
- Format.fprintf f "class %s"
- (if c.cl_virtual then "virtual " else "");
- (
- match c.cl_type_parameters with
- [] -> ()
- | l ->
- let s1 = self#normal_class_type_param_list father l in
- Format.fprintf f "%s " s1
- );
- Format.fprintf f "%s : %s"
- (Name.simple c.cl_name)
- (
- if for_detail then
- "object"
- else
- self#normal_class_type father c.cl_type
- );
-
- Format.pp_print_flush f ();
-
- (CodePre (Buffer.contents buf)) ::
- (
- if with_link
- then [Odoc_info.Latex (" ["^(self#make_ref (self#class_label c.cl_name))^"]")]
- else []
- )
- in
- self#latex_of_text t
-
- (** Return the LaTeX code for the given class type.
- @param for_detail indicate if we must print the type ([false]) or just ["object"] ([true]).*)
- method latex_of_class_type ?(for_detail=false) ?(with_link=true) ct =
- Odoc_info.reset_type_names () ;
- let buf = Buffer.create 32 in
- let f = Format.formatter_of_buffer buf in
- let father = Name.father ct.clt_name in
- let t =
- Format.fprintf f "class type %s"
- (if ct.clt_virtual then "virtual " else "");
- (
- match ct.clt_type_parameters with
- [] -> ()
- | l ->
- let s1 = self#normal_class_type_param_list father l in
- Format.fprintf f "%s " s1
- );
- Format.fprintf f "%s = %s"
- (Name.simple ct.clt_name)
- (if for_detail then
- "object"
- else
- self#normal_class_type father ct.clt_type
- );
-
- Format.pp_print_flush f ();
- (CodePre (Buffer.contents buf)) ::
- (
- if with_link
- then [Odoc_info.Latex (" ["^(self#make_ref (self#class_type_label ct.clt_name))^"]")]
- else []
- )
- in
- self#latex_of_text t
-
- (** Return the LaTeX code for the given class element. *)
- method latex_of_class_element class_name class_ele =
- (self#latex_of_text [Newline])^
- (
- match class_ele with
- Class_attribute att -> self#latex_of_attribute att
- | Class_method met -> self#latex_of_method met
- | Class_comment t ->
- match t with
- | [] -> ""
- | (Title (_,_,_)) :: _ -> self#latex_of_text t
- | _ -> self#latex_of_text [ Title ((Name.depth class_name) + 2, None, t) ]
- )
-
- (** Return the LaTeX code for the given module element. *)
- method latex_of_module_element module_name module_ele =
- (self#latex_of_text [Newline])^
- (
- match module_ele with
- Element_module m -> self#latex_of_module m
- | Element_module_type mt -> self#latex_of_module_type mt
- | Element_included_module im -> self#latex_of_included_module im
- | Element_class c -> self#latex_of_class c
- | Element_class_type ct -> self#latex_of_class_type ct
- | Element_value v -> self#latex_of_value v
- | Element_exception e -> self#latex_of_exception e
- | Element_type t -> self#latex_of_type t
- | Element_module_comment t -> self#latex_of_text t
- )
-
- (** Generate the LaTeX 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 *)
- (Odoc_info.Code 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 *)
- (Odoc_info.Code inh.ic_name) ::
- (Odoc_info.Latex (" ["^(self#make_ref label)^"]")) ::
- (match inh.ic_text with
- None -> []
- | Some t -> Newline :: t
- )
- in
- let text = [
- Odoc_info.Bold [Odoc_info.Raw Odoc_messages.inherits ];
- Odoc_info.List (List.map f inher_l)
- ]
- in
- let s = self#latex_of_text text in
- output_string chanout s
-
- (** Generate the LaTeX code for the inherited classes of the given class. *)
- method generate_class_inheritance_info chanout cl =
- let rec iter_kind k =
- match k with
- 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 LaTeX 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 LaTeX code for the given class, in the given out channel. *)
- method generate_for_class chanout c =
- Odoc_info.reset_type_names () ;
- let depth = Name.depth c.cl_name in
- let (first_t, rest_t) = self#first_and_rest_of_info c.cl_info in
- let text = [ Title (depth, None, [ Raw (Odoc_messages.clas^" ") ; Code c.cl_name ] @
- (match first_t with
- [] -> []
- | t -> (Raw " : ") :: t)) ;
- Latex (self#make_label (self#class_label c.cl_name)) ;
- ]
- in
- output_string chanout (self#latex_of_text text);
- output_string chanout ((self#latex_of_class ~for_detail: true ~with_link: false c)^"\n\n") ;
- let s_name = Name.simple c.cl_name in
- output_string chanout
- (self#latex_of_text [Latex ("\\index{"^(self#class_label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")]);
- output_string chanout (self#latex_of_text rest_t) ;
- (* parameters *)
- output_string chanout
- (self#latex_of_text (self#text_of_parameter_list (Name.father c.cl_name) c.cl_parameters));
-
- output_string chanout (self#latex_of_text [ Newline ] );
- output_string chanout ("\\ocamldocvspace{0.5cm}\n\n");
- self#generate_class_inheritance_info chanout c;
-
- List.iter
- (fun ele -> output_string chanout ((self#latex_of_class_element c.cl_name ele)^"\n\n"))
- (Class.class_elements ~trans: false c);
-
- output_string chanout (self#latex_of_text [ CodePre "end"])
-
- (** Generate the LaTeX code for the given class type, in the given out channel. *)
- method generate_for_class_type chanout ct =
- Odoc_info.reset_type_names () ;
- let depth = Name.depth ct.clt_name in
- let (first_t, rest_t) = self#first_and_rest_of_info ct.clt_info in
- let text = [ Title (depth, None, [ Raw (Odoc_messages.class_type^" ") ; Code ct.clt_name ] @
- (match first_t with
- [] -> []
- | t -> (Raw " : ") :: t)) ;
- Latex (self#make_label (self#class_type_label ct.clt_name)) ;
- ]
- in
-
- output_string chanout (self#latex_of_text text);
- output_string chanout ((self#latex_of_class_type ~for_detail: true ~with_link: false ct)^"\n\n") ;
- let s_name = Name.simple ct.clt_name in
- output_string chanout
- (self#latex_of_text [Latex ("\\index{"^(self#class_type_label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")]);
- output_string chanout ((self#latex_of_text rest_t)) ;
- output_string chanout (self#latex_of_text [ Newline]) ;
- output_string chanout ("\\ocamldocvspace{0.5cm}\n\n");
- self#generate_class_type_inheritance_info chanout ct;
-
- List.iter
- (fun ele -> output_string chanout ((self#latex_of_class_element ct.clt_name ele)^"\n\n"))
- (Class.class_type_elements ~trans: false ct);
-
- output_string chanout (self#latex_of_text [ CodePre "end"])
-
- (** Generate the LaTeX code for the given module type, in the given out channel. *)
- method generate_for_module_type chanout mt =
- let depth = Name.depth mt.mt_name in
- let (first_t, rest_t) = self#first_and_rest_of_info mt.mt_info in
- let text = [ Title (depth, None,
- [ Raw (Odoc_messages.module_type^" ") ; Code mt.mt_name ] @
- (match first_t with
- [] -> []
- | t -> (Raw " : ") :: t)) ;
- Latex (self#make_label (self#module_type_label mt.mt_name)) ;
- ]
- in
- output_string chanout (self#latex_of_text text);
- if depth > 1 then
- output_string chanout ((self#latex_of_module_type ~for_detail: true ~with_link: false mt)^"\n\n");
- let s_name = Name.simple mt.mt_name in
- output_string chanout
- (self#latex_of_text [Latex ("\\index{"^(self#module_type_label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")]);
- output_string chanout (self#latex_of_text rest_t) ;
- (* parameters *)
- output_string chanout
- (self#latex_of_text
- (self#text_of_module_parameter_list
- (Module.module_type_parameters mt)));
-
- output_string chanout (self#latex_of_text [ Newline ] );
- output_string chanout ("\\ocamldocvspace{0.5cm}\n\n");
- List.iter
- (fun ele -> output_string chanout ((self#latex_of_module_element mt.mt_name ele)^"\n\n"))
- (Module.module_type_elements ~trans: false mt);
-
- if depth > 1 then
- output_string chanout (self#latex_of_text [ CodePre "end"]);
-
- (* create sub parts for modules, module types, classes and class types *)
- let rec iter ele =
- match ele with
- Element_module m -> self#generate_for_module chanout m
- | Element_module_type mt -> self#generate_for_module_type chanout mt
- | Element_class c -> self#generate_for_class chanout c
- | Element_class_type ct -> self#generate_for_class_type chanout ct
- | _ -> ()
- in
- List.iter iter (Module.module_type_elements ~trans: false mt)
-
- (** Generate the LaTeX code for the given module, in the given out channel. *)
- method generate_for_module chanout m =
- let depth = Name.depth m.m_name in
- let (first_t, rest_t) = self#first_and_rest_of_info m.m_info in
- let text = [ Title (depth, None,
- [ Raw (Odoc_messages.modul^" ") ; Code m.m_name ] @
- (match first_t with
- [] -> []
- | t -> (Raw " : ") :: t)) ;
- Latex (self#make_label (self#module_label m.m_name)) ;
- ]
- in
- output_string chanout (self#latex_of_text text);
- if depth > 1 then
- output_string chanout ((self#latex_of_module ~for_detail:true ~with_link: false m)^"\n\n");
- let s_name = Name.simple m.m_name in
- output_string chanout
- (self#latex_of_text [Latex ("\\index{"^(self#module_label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")]);
- output_string chanout (self#latex_of_text rest_t) ;
- (* parameters *)
- output_string chanout
- (self#latex_of_text
- (self#text_of_module_parameter_list
- (Module.module_parameters m)));
-
- output_string chanout (self#latex_of_text [ Newline ]) ;
- output_string chanout ("\\ocamldocvspace{0.5cm}\n\n");
- List.iter
- (fun ele -> output_string chanout ((self#latex_of_module_element m.m_name ele)^"\n\n"))
- (Module.module_elements ~trans: false m);
-
- if depth > 1 then
- output_string chanout (self#latex_of_text [ CodePre "end"]);
-
- (* create sub parts for modules, module types, classes and class types *)
- let rec iter ele =
- match ele with
- Element_module m -> self#generate_for_module chanout m
- | Element_module_type mt -> self#generate_for_module_type chanout mt
- | Element_class c -> self#generate_for_class chanout c
- | Element_class_type ct -> self#generate_for_class_type chanout ct
- | _ -> ()
- in
- List.iter iter (Module.module_elements ~trans: false m)
-
- (** Return the header of the TeX document. *)
- method latex_header =
- "\\documentclass[11pt]{article} \n"^
- "\\usepackage[latin1]{inputenc} \n"^
- "\\usepackage[T1]{fontenc} \n"^
- "\\usepackage{fullpage} \n"^
- "\\usepackage{url} \n"^
- "\\usepackage{ocamldoc}\n"^
- (
- match !Args.title with
- None -> ""
- | Some s -> "\\title{"^(self#escape s)^"}\n"
- )^
- "\\begin{document}\n"^
- (match !Args.title with None -> "" | Some _ -> "\\maketitle\n")^
- (if !Args.with_toc then "\\tableofcontents\n" else "")^
- (
- let info = Odoc_info.apply_opt
- Odoc_info.info_of_comment_file !Odoc_info.Args.intro_file
- in
- Printf.sprintf "%s%s%s"
- (match info with None -> "" | Some _ -> "\\vspace{0.2cm}")
- (self#latex_of_info info)
- (match info with None -> "" | Some _ -> "\n\n")
- )
-
-
- (** Generate the LaTeX style file, if it does not exists. *)
- method generate_style_file =
- try
- let dir = Filename.dirname !Args.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.Args.out_file} file. *)
- method generate module_list =
- self#generate_style_file ;
- if !Args.separate_files then
- (
- let f m =
- try
- let chanout =
- open_out ((Filename.concat !Args.target_dir (Name.simple m.m_name))^".tex")
- in
- self#generate_for_module chanout m ;
- 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 !Args.out_file in
- let _ = if !Args.with_header then output_string chanout self#latex_header else () in
- List.iter
- (fun m -> if !Args.separate_files then
- output_string chanout ("\\input{"^((Name.simple m.m_name))^".tex}\n")
- else
- self#generate_for_module chanout m
- )
- module_list ;
- let _ = if !Args.with_trailer then output_string chanout "\\end{document}" else () in
- close_out chanout
- with
- Failure s
- | Sys_error s ->
- prerr_endline s ;
- incr Odoc_info.errors
- end
-
-(* eof $Id$ *)
diff --git a/ocamldoc/odoc_latex_style.ml b/ocamldoc/odoc_latex_style.ml
deleted file mode 100644
index 1e557f55f0..0000000000
--- a/ocamldoc/odoc_latex_style.ml
+++ /dev/null
@@ -1,76 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(** The content of the LaTeX style to generate when generating LaTeX code. *)
-
-(* $Id$ *)
-
-let content ="
-%% Support macros for LaTeX documentation generated by ocamldoc.
-%% This file is in the public domain; do what you want with it.
-
-\\NeedsTeXFormat{LaTeX2e}
-\\ProvidesPackage{ocamldoc}
- [2001/12/04 v1.0 ocamldoc support]
-
-\\newenvironment{ocamldoccode}{%
- \\bgroup
- \\leftskip\\@totalleftmargin
- \\rightskip\\z@skip
- \\parindent\\z@
- \\parfillskip\\@flushglue
- \\parskip\\z@skip
- %\\noindent
- \\@@par\\smallskip
- \\@tempswafalse
- \\def\\par{%
- \\if@tempswa
- \\leavevmode\\null\\@@par\\penalty\\interlinepenalty
- \\else
- \\@tempswatrue
- \\ifhmode\\@@par\\penalty\\interlinepenalty\\fi
- \\fi}
- \\obeylines
- \\verbatim@font
- \\let\\org@prime~%
- \\@noligs
- \\let\\org@dospecials\\dospecials
- \\g@remfrom@specials{\\\\}
- \\g@remfrom@specials{\\{}
- \\g@remfrom@specials{\\}}
- \\let\\do\\@makeother
- \\dospecials
- \\let\\dospecials\\org@dospecials
- \\frenchspacing\\@vobeyspaces
- \\everypar \\expandafter{\\the\\everypar \\unpenalty}}
-{\\egroup\\par}
-
-\\def\\g@remfrom@specials#1{%
- \\def\\@new@specials{}
- \\def\\@remove##1{%
- \\ifx##1#1\\else
- \\g@addto@macro\\@new@specials{\\do ##1}\\fi}
- \\let\\do\\@remove\\dospecials
- \\let\\dospecials\\@new@specials
- }
-
-\\newenvironment{ocamldocdescription}
-{\\list{}{\\rightmargin0pt \\topsep0pt}\\raggedright\\item\\relax}
-{\\endlist\\medskip}
-
-\\newenvironment{ocamldoccomment}
-{\\list{}{\\leftmargin 2\\leftmargini \\rightmargin0pt \\topsep0pt}\\raggedright\\item\\relax}
-{\\endlist}
-
-\\let\\ocamldocvspace\\vspace
-\\endinput
-"
-
diff --git a/ocamldoc/odoc_lexer.mll b/ocamldoc/odoc_lexer.mll
deleted file mode 100644
index 353ddfbe13..0000000000
--- a/ocamldoc/odoc_lexer.mll
+++ /dev/null
@@ -1,411 +0,0 @@
-{
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** The lexer for special comments. *)
-
-open Lexing
-open Odoc_parser
-
-let line_number = ref 0
-
-
-let string_buffer = Buffer.create 32
-
-(** Fonction de remise à zéro de la chaine de caractères tampon *)
-let reset_string_buffer () = Buffer.reset string_buffer
-
-(** Fonction d'ajout d'un caractère dans la chaine de caractères tampon *)
-let ajout_char_string = Buffer.add_char string_buffer
-
-(** Add a string to the buffer. *)
-let ajout_string = Buffer.add_string string_buffer
-
-let lecture_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 =
- let s2 = Str.global_replace (Str.regexp ("^"^blank^"*\\*")) "" s in
- s2
-}
-
-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 = lecture_string () in
- let s3 = remove_blanks s2 in
- let s4 =
- if !Odoc_args.remove_stars then
- remove_stars s3
- else
- s3
- in
- Description (s4, None)
- )
- else
- (
- ajout_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 ;
- ajout_string s;
- special_comment lexbuf
- }
-
- | "\\@"
- {
- let s = Lexing.lexeme lexbuf in
- let c = (Lexing.lexeme_char lexbuf 1) in
- ajout_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 = lecture_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
- ajout_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_args.remove_stars then
- remove_stars !description
- else
- !description
- in
- let remain = lecture_string () in
- let remain2 =
- if !Odoc_args.remove_stars then
- remove_stars remain
- else
- remain
- in
- Description (desc, Some remain2)
- else
- (
- ajout_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);
- ajout_string s;
- incr comments_level ;
- special_comment_part2 lexbuf
- }
-
- | _
- {
- let c = (Lexing.lexeme_char lexbuf 0) in
- ajout_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 }
-
- | "@"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
- | "deprecated" ->
- T_DEPRECATED
- | "raise" ->
- T_RAISES
- | "return" ->
- T_RETURN
- | s ->
- if !Odoc_args.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 s2 = remove_blanks s in
- print_DEBUG2 ("Desc "^s2);
- Desc s2
- }
- | eof
- {
- EOF
- }
-
-
-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
- (
- ajout_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
deleted file mode 100644
index 23af3d8e8a..0000000000
--- a/ocamldoc/odoc_man.ml
+++ /dev/null
@@ -1,941 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** The man pages generator. *)
-open Odoc_info
-open Parameter
-open Value
-open Type
-open Exception
-open Class
-open Module
-open Search
-
-
-(** 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 : Odoc_info.text -> string
-
- (** Groff string for an author list. *)
- method man_of_author_list l =
- match l with
- [] ->
- ""
- | _ ->
- ".B \""^Odoc_messages.authors^"\"\n:\n"^
- (String.concat ", " l)^
- "\n.sp\n"
-
- (** Groff string for the given optional version information.*)
- method man_of_version_opt v_opt =
- match v_opt with
- None -> ""
- | Some v -> ".B \""^Odoc_messages.version^"\"\n:\n"^v^"\n.sp\n"
-
- (** Groff string for the given optional since information.*)
- method man_of_since_opt s_opt =
- match s_opt with
- None -> ""
- | Some s -> ".B \""^Odoc_messages.since^"\"\n"^s^"\n.sp\n"
-
- (** Groff string for the given list of raised exceptions.*)
- method man_of_raised_exceptions l =
- match l with
- [] -> ""
- | (s, t) :: [] -> ".B \""^Odoc_messages.raises^" "^s^"\"\n"^(self#man_of_text t)^"\n.sp\n"
- | _ ->
- ".B \""^Odoc_messages.raises^"\"\n"^
- (String.concat ""
- (List.map
- (fun (ex, desc) -> ".TP\n.B \""^ex^"\"\n"^(self#man_of_text desc)^"\n")
- l
- )
- )^"\n.sp\n"
-
- (** Groff string for the given "see also" reference. *)
- method man_of_see (see_ref, t) =
- let t_ref =
- match see_ref with
- Odoc_info.See_url s -> [ Odoc_info.Link (s, t) ]
- | Odoc_info.See_file s -> (Odoc_info.Code s) :: (Odoc_info.Raw " ") :: t
- | Odoc_info.See_doc s -> (Odoc_info.Italic [Odoc_info.Raw s]) :: (Odoc_info.Raw " ") :: t
- in
- self#man_of_text t_ref
-
- (** Groff string for the given list of "see also" references.*)
- method man_of_sees l =
- match l with
- [] -> ""
- | see :: [] -> ".B \""^Odoc_messages.see_also^"\"\n"^(self#man_of_see see)^"\n.sp\n"
- | _ ->
- ".B \""^Odoc_messages.see_also^"\"\n"^
- (String.concat ""
- (List.map
- (fun see -> ".TP\n \"\"\n"^(self#man_of_see see)^"\n")
- l
- )
- )^"\n.sp\n"
-
- (** Groff string for the given optional return information.*)
- method man_of_return_opt return_opt =
- match return_opt with
- None -> ""
- | Some s -> ".B "^Odoc_messages.returns^"\n"^(self#man_of_text s)^"\n.sp\n"
-
- (** Return man code for the given list of custom tagged texts. *)
- method man_of_custom l =
- let buf = Buffer.create 50 in
- List.iter
- (fun (tag, text) ->
- try
- let f = List.assoc tag tag_functions in
- Buffer.add_string buf (f text)
- with
- Not_found ->
- Odoc_info.warning (Odoc_messages.tag_not_handled tag)
- )
- l;
- Buffer.contents buf
-
- (** Return the groff string to display an optional info structure. *)
- method man_of_info info_opt =
- match info_opt with
- None ->
- ""
- | Some info ->
- let module M = Odoc_info in
- (match info.M.i_deprecated with
- None -> ""
- | Some d -> ".B \""^Odoc_messages.deprecated^"\"\n"^(self#man_of_text d)^"\n.sp\n")^
- (match info.M.i_desc with
- None -> ""
- | Some d when d = [Odoc_info.Raw ""] -> ""
- | Some d -> (self#man_of_text d)^"\n.sp\n"
- )^
- (self#man_of_author_list info.M.i_authors)^
- (self#man_of_version_opt info.M.i_version)^
- (self#man_of_since_opt info.M.i_since)^
- (self#man_of_raised_exceptions info.M.i_raised_exceptions)^
- (self#man_of_return_opt info.M.i_return_value)^
- (self#man_of_sees info.M.i_sees)^
- (self#man_of_custom info.M.i_custom)
- end
-
-(** 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 !Args.man_suffix in
- Str.global_replace re_slash "slash" s
-
- (** Escape special sequences of characters in a string. *)
- method escape (s : string) = s
-
- (** Open a file for output. Add the target directory.*)
- method open_out file =
- let f = Filename.concat !Args.target_dir file in
- open_out f
-
- (** Return the groff string for a text, without correction of blanks. *)
- method private man_of_text2 t = String.concat "" (List.map self#man_of_text_element t)
-
- (** Return the groff string for a text, with blanks corrected. *)
- method man_of_text t =
- let s = self#man_of_text2 t in
- let s2 = Str.global_replace (Str.regexp "\n[ ]*") "\n" s in
- Str.global_replace (Str.regexp "\n\n") "\n" s2
-
- (** Return the given string without no newlines. *)
- method remove_newlines s =
- Str.global_replace (Str.regexp "[ ]*\n[ ]*") " " s
-
- (** Return the groff string for a text element. *)
- method man_of_text_element te =
- match te with
- | Odoc_info.Raw s -> s
- | Odoc_info.Code s ->
- let s2 = "\n.B "^(Str.global_replace (Str.regexp "\n") "\n.B " (self#escape s))^"\n" in
- s2
- | Odoc_info.CodePre s ->
- let s2 = "\n.B "^(Str.global_replace (Str.regexp "\n") "\n.B " (self#escape s))^"\n" in
- s2
- | Odoc_info.Verbatim s -> self#escape s
- | Odoc_info.Bold t
- | Odoc_info.Italic t
- | Odoc_info.Emphasize t
- | Odoc_info.Center t
- | Odoc_info.Left t
- | Odoc_info.Right t -> self#man_of_text2 t
- | Odoc_info.List tl ->
- (String.concat ""
- (List.map
- (fun t -> ".TP\n \"\"\n"^(self#man_of_text2 t)^"\n")
- tl
- )
- )^"\n"
- | Odoc_info.Enum tl ->
- (String.concat ""
- (List.map
- (fun t -> ".TP\n \"\"\n"^(self#man_of_text2 t)^"\n")
- tl
- )
- )^"\n"
- | Odoc_info.Newline ->
- "\n.sp\n"
- | Odoc_info.Block t ->
- "\n.sp\n"^(self#man_of_text2 t)^"\n.sp\n"
- | Odoc_info.Title (n, l_opt, t) ->
- self#man_of_text2 [Odoc_info.Code (Odoc_info.string_of_text t)]
- | Odoc_info.Latex _ ->
- (* don't care about LaTeX stuff in HTML. *)
- ""
- | Odoc_info.Link (s, t) ->
- self#man_of_text2 t
- | Odoc_info.Ref (name, _) ->
- self#man_of_text_element
- (Odoc_info.Code (Odoc_info.use_hidden_modules name))
- | Odoc_info.Superscript t ->
- "^{"^(self#man_of_text2 t)
- | Odoc_info.Subscript t ->
- "_{"^(self#man_of_text2 t)
-
- (** Groff string to display code. *)
- method man_of_code s = self#man_of_text [ 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
- let s2 = Str.global_substitute
- (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)")
- f
- s
- in
- s2
-
- (** Groff string to display a [Types.type_expr].*)
- method man_of_type_expr m_name t =
- let s = String.concat "\n"
- (Str.split (Str.regexp "\n") (Odoc_misc.string_of_type_expr t))
- in
- let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in
- "\n.B "^(self#relative_idents m_name s2)^"\n"
-
- (** Groff string to display a [Types.class_type].*)
- method man_of_class_type_expr m_name t =
- let s = String.concat "\n"
- (Str.split (Str.regexp "\n") (Odoc_misc.string_of_class_type t))
- in
- let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in
- "\n.B "^(self#relative_idents m_name s2)^"\n"
-
- (** Groff string to display a [Types.type_expr list].*)
- method man_of_type_expr_list m_name sep l =
- let s = Odoc_str.string_of_type_list sep l in
- let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in
- "\n.B "^(self#relative_idents m_name s2)^"\n"
-
- (** Groff string to display the parameters of a type.*)
- method man_of_type_expr_param_list m_name t =
- match t.ty_parameters with
- [] -> ""
- | l ->
- let s = Odoc_str.string_of_type_param_list t in
- let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in
- "\n.B "^(self#relative_idents m_name s2)^"\n"
-
- (** Groff string to display a [Types.module_type]. *)
- method man_of_module_type m_name t =
- let s = String.concat "\n"
- (Str.split (Str.regexp "\n") (Odoc_misc.string_of_module_type t))
- in
- let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in
- "\n.B "^(self#relative_idents m_name s2)^"\n"
-
- (** Groff string code for a value. *)
- method man_of_value v =
- Odoc_info.reset_type_names () ;
- "\n.I val "^(Name.simple v.val_name)^" \n: "^
- (self#man_of_type_expr (Name.father v.val_name) v.val_type)^
- ".sp\n"^
- (self#man_of_info v.val_info)^
- "\n.sp\n"
-
- (** Groff string code for an exception. *)
- method man_of_exception e =
- Odoc_info.reset_type_names () ;
- "\n.I exception "^(Name.simple e.ex_name)^" \n"^
- (match e.ex_args with
- [] -> ""
- | _ ->
- ".B of "^
- (self#man_of_type_expr_list (Name.father e.ex_name) " * " e.ex_args)
- )^
- (match e.ex_alias with
- None -> ""
- | Some ea -> " = "^
- (
- match ea.ea_ex with
- None -> ea.ea_name
- | Some e -> e.ex_name
- )
- )^
- "\n.sp\n"^
- (self#man_of_info e.ex_info)^
- "\n.sp\n"
-
- (** Groff string for a type. *)
- method man_of_type t =
- Odoc_info.reset_type_names () ;
- let father = Name.father t.ty_name in
- ".I type "^
- (self#man_of_type_expr_param_list father t)^
- (match t.ty_parameters with [] -> "" | _ -> ".I ")^(Name.simple t.ty_name)^" \n"^
- (match t.ty_manifest with None -> "" | Some typ -> "= "^(self#man_of_type_expr father typ))^
- (
- match t.ty_kind with
- Type_abstract ->
- ""
- | Type_variant (l, priv) ->
- "="^(if priv then " private" else "")^"\n "^
- (String.concat ""
- (List.map
- (fun constr ->
- "| "^constr.vc_name^
- (match constr.vc_args, constr.vc_text with
- [], None -> "\n "
- | [], (Some t) -> " (* "^(self#man_of_text t)^" *)\n "
- | l, None ->
- "\n.B of "^(self#man_of_type_expr_list father " * " l)^" "
- | l, (Some t) ->
- "\n.B of "^(self#man_of_type_expr_list father " * " l)^
- ".I \" \"\n"^
- "(* "^(self#man_of_text t)^" *)\n "
- )
- )
- l
- )
- )
- | Type_record (l, priv) ->
- "= "^(if priv then "private " else "")^"{"^
- (String.concat ""
- (List.map
- (fun r ->
- (if r.rf_mutable then "\n\n.B mutable \n" else "\n ")^
- r.rf_name^" : "^(self#man_of_type_expr father r.rf_type)^";"^
- (match r.rf_text with
- None ->
- ""
- | Some t ->
- " (* "^(self#man_of_text t)^" *) "
- )^""
- )
- l
- )
- )^
- "\n }\n"
- )^
- "\n.sp\n"^(self#man_of_info t.ty_info)^
- "\n.sp\n"
-
- (** Groff string for a class attribute. *)
- method man_of_attribute a =
- ".I val "^
- (if a.att_mutable then Odoc_messages.mutab^" " else "")^
- (Name.simple a.att_value.val_name)^" : "^
- (self#man_of_type_expr (Name.father a.att_value.val_name) a.att_value.val_type)^
- "\n.sp\n"^(self#man_of_info a.att_value.val_info)^
- "\n.sp\n"
-
- (** Groff string for a class method. *)
- method man_of_method m =
- ".I method "^
- (if m.met_private then "private " else "")^
- (if m.met_virtual then "virtual " else "")^
- (Name.simple m.met_value.val_name)^" : "^
- (self#man_of_type_expr (Name.father m.met_value.val_name) m.met_value.val_type)^
- "\n.sp\n"^(self#man_of_info m.met_value.val_info)^
- "\n.sp\n"
-
- (** Groff for a list of parameters. *)
- method man_of_parameter_list m_name l =
- match l with
- [] ->
- ""
- | _ ->
- "\n.B "^Odoc_messages.parameters^": \n"^
- (String.concat ""
- (List.map
- (fun p ->
- ".TP\n"^
- "\""^(Parameter.complete_name p)^"\"\n"^
- (self#man_of_type_expr m_name (Parameter.typ p))^"\n"^
- (self#man_of_parameter_description p)^"\n"
- )
- l
- )
- )^"\n"
-
- (** Groff for the description of a function parameter. *)
- method man_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 -> "\n "^(self#man_of_text t)
- )
- | l ->
- (* A list of names, we display those with a description. *)
- String.concat ""
- (List.map
- (fun n ->
- match Parameter.desc_by_name p n with
- None -> ""
- | Some t -> (self#man_of_code (n^" : "))^(self#man_of_text t)
- )
- l
- )
-
- (** Groff string for a list of module parameters. *)
- method man_of_module_parameter_list m_name l =
- match l with
- [] ->
- ""
- | _ ->
- ".B \""^Odoc_messages.parameters^":\"\n"^
- (String.concat ""
- (List.map
- (fun (p, desc_opt) ->
- ".TP\n"^
- "\""^p.mp_name^"\"\n"^
- (self#man_of_module_type m_name p.mp_type)^"\n"^
- (match desc_opt with
- None -> ""
- | Some t -> self#man_of_text t)^
- "\n"
- )
- l
- )
- )^"\n\n"
-
- (** Groff string for a class. *)
- method man_of_class c =
- let buf = Buffer.create 32 in
- let p = Printf.bprintf in
- Odoc_info.reset_type_names () ;
- let father = Name.father c.cl_name in
- p buf ".I class %s"
- (if c.cl_virtual then "virtual " else "");
- (
- match c.cl_type_parameters with
- [] -> ()
- | l -> p buf "%s " (Odoc_str.string_of_class_type_param_list l)
- );
- p buf "%s : %s"
- (Name.simple c.cl_name)
- (self#man_of_class_type_expr (Name.father c.cl_name) c.cl_type);
- p buf "\n.sp\n%s\n.sp\n" (self#man_of_info c.cl_info);
- Buffer.contents buf
-
- (** Groff string for a class type. *)
- method man_of_class_type ct =
- let buf = Buffer.create 32 in
- let p = Printf.bprintf in
- Odoc_info.reset_type_names () ;
- p buf ".I class type %s"
- (if ct.clt_virtual then "virtual " else "");
- (
- match ct.clt_type_parameters with
- [] -> ()
- | l -> p buf "%s " (Odoc_str.string_of_class_type_param_list l)
- );
- p buf "%s = %s"
- (Name.simple ct.clt_name)
- (self#man_of_class_type_expr (Name.father ct.clt_name) ct.clt_type);
- p buf "\n.sp\n%s\n.sp\n" (self#man_of_info ct.clt_info);
- Buffer.contents buf
-
- (** Groff string for a module. *)
- method man_of_module m =
- ".I module "^(Name.simple m.m_name)^
- " : "^(self#man_of_module_type (Name.father m.m_name) m.m_type)^
- "\n.sp\n"^(self#man_of_info m.m_info)^"\n.sp\n"
-
- (** Groff string for a module type. *)
- method man_of_modtype mt =
- ".I module type "^(Name.simple mt.mt_name)^
- " = "^
- (match mt.mt_type with
- None -> ""
- | Some t -> self#man_of_module_type (Name.father mt.mt_name) t
- )^
- "\n.sp\n"^(self#man_of_info mt.mt_info)^"\n.sp\n"
-
- (** Groff string for a module comment.*)
- method man_of_module_comment text =
- "\n.pp\n"^
- (self#man_of_text [Code ("=== "^(Odoc_misc.string_of_text text)^" ===")])^
- "\n.pp\n"
-
- (** Groff string for a class comment.*)
- method man_of_class_comment text =
- "\n.pp\n"^
- (self#man_of_text [Code ("=== "^(Odoc_misc.string_of_text text)^" ===")])^
- "\n.pp\n"
-
- (** Groff string for an included module. *)
- method man_of_included_module m_name im =
- ".I include "^
- (
- match im.im_module with
- None -> im.im_name
- | Some mmt ->
- let name =
- match mmt with
- Mod m -> m.m_name
- | Modtype mt -> mt.mt_name
- in
- self#relative_idents m_name name
- )^
- "\n.sp\n"^
- (self#man_of_info im.im_info)^
- "\n.sp\n"
-
- (** Generate the man page for the given class.*)
- method generate_for_class cl =
- Odoc_info.reset_type_names () ;
- let date = Unix.time () in
- let file = self#file_name cl.cl_name in
- try
- let chanout = self#open_out file in
- output_string chanout
- (".TH \""^Odoc_messages.clas^"\" "^
- cl.cl_name^" "^
- "\""^(Odoc_misc.string_of_date ~hour: false date)^"\" "^
- "OCamldoc "^
- "\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
-
- let 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
-
- output_string chanout
- (
- ".SH NAME\n"^
- cl.cl_name^" \\- "^abstract^"\n"^
- ".SH "^Odoc_messages.clas^"\n"^
- Odoc_messages.clas^" "^cl.cl_name^"\n"^
- ".SH "^Odoc_messages.documentation^"\n"^
- ".sp\n"
- );
- output_string chanout (self#man_of_class cl);
-
- (* parameters *)
- output_string chanout
- (self#man_of_parameter_list "" cl.cl_parameters);
- (* a large blank *)
- output_string chanout "\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 ->
- output_string chanout (self#man_of_attribute a)
- | Class_method m ->
- output_string chanout (self#man_of_method m)
- | Class_comment t ->
- output_string chanout (self#man_of_class_comment t)
- )
- (Class.class_elements cl);
-
- 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 date = Unix.time () in
- let file = self#file_name ct.clt_name in
- try
- let chanout = self#open_out file in
- output_string chanout
- (".TH \""^Odoc_messages.class_type^"\" "^
- ct.clt_name^" "^
- "\""^(Odoc_misc.string_of_date ~hour: false date)^"\" "^
- "OCamldoc "^
- "\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
-
- let 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
-
- output_string chanout
- (
- ".SH NAME\n"^
- ct.clt_name^" \\- "^abstract^"\n"^
- ".SH "^Odoc_messages.class_type^"\n"^
- Odoc_messages.class_type^" "^ct.clt_name^"\n"^
- ".SH "^Odoc_messages.documentation^"\n"^
- ".sp\n"
- );
- output_string chanout (self#man_of_class_type ct);
-
- (* a large blank *)
- output_string chanout "\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 ->
- output_string chanout (self#man_of_attribute a)
- | Class_method m ->
- output_string chanout (self#man_of_method m)
- | Class_comment t ->
- output_string chanout (self#man_of_class_comment t)
- )
- (Class.class_type_elements ct);
-
- close_out chanout
- with
- Sys_error s ->
- incr Odoc_info.errors ;
- prerr_endline s
-
- (** Generate the man file for the given module type.
- @raise Failure if an error occurs.*)
- method generate_for_module_type mt =
- let date = Unix.time () in
- let file = self#file_name mt.mt_name in
- try
- let chanout = self#open_out file in
- output_string chanout
- (".TH \""^Odoc_messages.module_type^"\" "^
- mt.mt_name^" "^
- "\""^(Odoc_misc.string_of_date ~hour: false date)^"\" "^
- "OCamldoc "^
- "\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
-
- let 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
- output_string chanout
- (
- ".SH NAME\n"^
- mt.mt_name^" \\- "^abstract^"\n"^
- ".SH "^Odoc_messages.module_type^"\n"^
- Odoc_messages.module_type^" "^mt.mt_name^"\n"^
- ".SH "^Odoc_messages.documentation^"\n"^
- ".sp\n"^
- Odoc_messages.module_type^"\n"^
- ".BI \""^(Name.simple mt.mt_name)^"\"\n"^
- " = "^
- (match mt.mt_type with
- None -> ""
- | Some t -> self#man_of_module_type (Name.father mt.mt_name) t
- )^
- "\n.sp\n"^
- (self#man_of_info mt.mt_info)^"\n"^
- ".sp\n"
- );
-
- (* parameters for functors *)
- output_string chanout
- (self#man_of_module_parameter_list "" (Module.module_type_parameters mt));
- (* a large blank *)
- output_string chanout "\n.sp\n.sp\n";
-
- (* module elements *)
- List.iter
- (fun ele ->
- match ele with
- Element_module m ->
- output_string chanout (self#man_of_module m)
- | Element_module_type mt ->
- output_string chanout (self#man_of_modtype mt)
- | Element_included_module im ->
- output_string chanout (self#man_of_included_module mt.mt_name im)
- | Element_class c ->
- output_string chanout (self#man_of_class c)
- | Element_class_type ct ->
- output_string chanout (self#man_of_class_type ct)
- | Element_value v ->
- output_string chanout (self#man_of_value v)
- | Element_exception e ->
- output_string chanout (self#man_of_exception e)
- | Element_type t ->
- output_string chanout (self#man_of_type t)
- | Element_module_comment text ->
- output_string chanout (self#man_of_module_comment text)
- )
- (Module.module_type_elements mt);
-
- close_out chanout
-
- with
- Sys_error s ->
- incr Odoc_info.errors ;
- prerr_endline s
-
- (** Generate the man file for the given module.
- @raise Failure if an error occurs.*)
- method generate_for_module m =
- let date = Unix.time () in
- let file = self#file_name m.m_name in
- try
- let chanout = self#open_out file in
- output_string chanout
- (".TH \""^Odoc_messages.modul^"\" "^
- m.m_name^" "^
- "\""^(Odoc_misc.string_of_date ~hour: false date)^"\" "^
- "OCamldoc "^
- "\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
-
- let 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
-
- output_string chanout
- (
- ".SH NAME\n"^
- m.m_name^" \\- "^abstract^"\n"^
- ".SH "^Odoc_messages.modul^"\n"^
- Odoc_messages.modul^" "^m.m_name^"\n"^
- ".SH "^Odoc_messages.documentation^"\n"^
- ".sp\n"^
- Odoc_messages.modul^"\n"^
- ".BI \""^(Name.simple m.m_name)^"\"\n"^
- " : "^(self#man_of_module_type (Name.father m.m_name) m.m_type)^
- "\n.sp\n"^
- (self#man_of_info m.m_info)^"\n"^
- ".sp\n"
- );
-
- (* parameters for functors *)
- output_string chanout
- (self#man_of_module_parameter_list "" (Module.module_parameters m));
- (* a large blank *)
- output_string chanout "\n.sp\n.sp\n";
-
- (* module elements *)
- List.iter
- (fun ele ->
- match ele with
- Element_module m ->
- output_string chanout (self#man_of_module m)
- | Element_module_type mt ->
- output_string chanout (self#man_of_modtype mt)
- | Element_included_module im ->
- output_string chanout (self#man_of_included_module m.m_name im)
- | Element_class c ->
- output_string chanout (self#man_of_class c)
- | Element_class_type ct ->
- output_string chanout (self#man_of_class_type ct)
- | Element_value v ->
- output_string chanout (self#man_of_value v)
- | Element_exception e ->
- output_string chanout (self#man_of_exception e)
- | Element_type t ->
- output_string chanout (self#man_of_type t)
- | Element_module_comment text ->
- output_string chanout (self#man_of_module_comment text)
- )
- (Module.module_elements m);
-
- close_out chanout
-
- with
- Sys_error s ->
- raise (Failure s)
-
- (** Create the groups of elements to generate pages for. *)
- method create_groups 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_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
- 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 | _ -> true)
- 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 :: q2 ->
- 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_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
- )
- in
- let date = Unix.time () in
- let file = self#file_name name in
- try
- let chanout = self#open_out file in
- output_string chanout
- (
- ".TH \""^name^"\" "^
- "man "^
- "\""^(Odoc_misc.string_of_date ~hour: false date)^"\" "^
- "OCamldoc "^
- "\""^(match !Args.title with Some t -> t | None -> "")^"\"\n"^
- ".SH NAME\n"^
- name^" \\- all "^name^" elements\n\n"
- );
-
- let f ele =
- match ele with
- Res_value v ->
- output_string chanout
- ("\n.SH "^Odoc_messages.modul^" "^(Name.father v.val_name)^"\n"^
- (self#man_of_value v))
- | Res_type t ->
- output_string chanout
- ("\n.SH "^Odoc_messages.modul^" "^(Name.father t.ty_name)^"\n"^
- (self#man_of_type t))
- | Res_exception e ->
- output_string chanout
- ("\n.SH "^Odoc_messages.modul^" "^(Name.father e.ex_name)^"\n"^
- (self#man_of_exception e))
- | Res_attribute a ->
- output_string chanout
- ("\n.SH "^Odoc_messages.clas^" "^(Name.father a.att_value.val_name)^"\n"^
- (self#man_of_attribute a))
- | Res_method m ->
- output_string chanout
- ("\n.SH "^Odoc_messages.clas^" "^(Name.father m.met_value.val_name)^"\n"^
- (self#man_of_method m))
- | Res_class c ->
- output_string chanout
- ("\n.SH "^Odoc_messages.modul^" "^(Name.father c.cl_name)^"\n"^
- (self#man_of_class c))
- | Res_class_type ct ->
- output_string chanout
- ("\n.SH "^Odoc_messages.modul^" "^(Name.father ct.clt_name)^"\n"^
- (self#man_of_class_type ct))
- | _ ->
- (* normalement on ne peut pas avoir de module ici. *)
- ()
- in
- List.iter f l;
- 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 = Sort.list (fun m1 -> fun m2 -> m1.m_name < m2.m_name) module_list in
- let groups = self#create_groups 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 ->
- if !Args.man_mini then
- ()
- else
- self#generate_for_group l
- in
- List.iter f groups
- end
diff --git a/ocamldoc/odoc_merge.ml b/ocamldoc/odoc_merge.ml
deleted file mode 100644
index ae1d6dcf43..0000000000
--- a/ocamldoc/odoc_merge.ml
+++ /dev/null
@@ -1,953 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Merge of information from [.ml] and [.mli] for a module.*)
-
-open Odoc_types
-
-module Name = Odoc_name
-open Odoc_parameter
-open Odoc_value
-open Odoc_type
-open Odoc_exception
-open Odoc_class
-open Odoc_module
-
-(** 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_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_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 (d1 @ d2)
- else
- Some d1
- in
- cons.vc_text <- new_desc
- with
- Not_found ->
- if !Odoc_args.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 (d1 @ d2)
- else
- Some d1
- in
- record.rf_text <- new_desc
- with
- Not_found ->
- if !Odoc_args.inverse_merge_ml_mli then
- ()
- else
- raise (Failure (Odoc_messages.different_types mli.ty_name))
- in
- List.iter f l1
-
- | _ ->
- if !Odoc_args.inverse_merge_ml_mli then
- ()
- else
- raise (Failure (Odoc_messages.different_types mli.ty_name))
-
-(** 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_args.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_args.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_args.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_args.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 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
- (
- 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_args.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 } ;
- (* More dependencies in the .ml file. *)
- mli.m_top_deps <- ml.m_top_deps ;
-
- let code =
- if !Odoc_args.keep_code then
- match mli.m_code, ml.m_code with
- Some s, _ -> Some s
- | _, Some s -> Some s
- | _ -> None
- else
- None
- in
- mli.m_code <- code;
-
- (* 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
- (
- 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_args.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_args.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_args.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_args.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))
- )
- | _ ->
- (* two many Module.t ! *)
- raise (Failure (Odoc_messages.too_many_module_objects m.m_name))
-
- in
- iter modules_list
-
-(* eof $Id$ *)
diff --git a/ocamldoc/odoc_merge.mli b/ocamldoc/odoc_merge.mli
deleted file mode 100644
index cae4d230b3..0000000000
--- a/ocamldoc/odoc_merge.mli
+++ /dev/null
@@ -1,32 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Merge of information from [.ml] and [.mli] for a module.*)
-
-(** 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
deleted file mode 100644
index 26cb295961..0000000000
--- a/ocamldoc/odoc_messages.ml
+++ /dev/null
@@ -1,309 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** The messages of the application. *)
-
-let ok = "Ok"
-let software = "OCamldoc"
-let version = Config.version
-let magic = version^""
-let message_version = software^" "^version
-
-(** Messages for command line *)
-
-let usage = "Usage : "^(Sys.argv.(0))^" [options] <files>\n"
-let options_are = "Options are :"
-let option_version = " Print version and exit"
-let latex_only = "(LaTeX only)"
-let texi_only = "(TeXinfo only)"
-let latex_texi_only = "(LaTeX and TeXinfo only)"
-let html_only = "(HTML only)"
-let html_latex_only = "(HTML and LaTeX only)"
-let html_latex_texi_only = "(HTML, LaTeX and TeXinfo only)"
-let man_only = "(man only)"
-let verbose_mode = " verbose mode"
-let include_dirs = "<dir> Add <dir> to the list of include directories"
-let rectypes = " Allow arbitrary recursive types"
-let preprocess = "<command> Pipe sources through preprocessor <command>"
-let load_file = "<file.cm[o|a]> Load file defining a new documentation generator (bytecode version only)"
-let nolabels = " Ignore non-optional labels in types"
-let werr = "Treat ocamldoc warnings as errors"
-let target_dir = "<dir> Generate files in directory <dir>, rather than in current directory (for man and HTML generators)"
-let dump = "<file> Dump collected information into <file>"
-let load = "<file> Load information from <file> ; may be used several times"
-let css_style = "<file> Use content of <file> as CSS style definition "^html_only
-let index_only = " Generate index files only "^html_only
-let colorize_code = "Colorize code even in documentation pages "^html_only
-let generate_html = " Generate HTML documentation"
-let generate_latex = " Generate LaTeX documentation"
-let generate_texinfo = " Generate TeXinfo documentation"
-let generate_man = " Generate man pages"
-let generate_dot = " Generate dot code of top modules dependencies"
-
-let option_not_in_native_code op = "Option "^op^" not available in native code version."
-
-let default_out_file = "ocamldoc.out"
-let out_file = "<file> Set the ouput file name, used by texi, latex and dot generators "^
- "(default is "^default_out_file^")"
-
-let dot_include_all = " include all modules in the dot output,\n"^
- " not only the modules given on the command line"
-let dot_types = " generate dependency graph for types instead of modules"
-let default_dot_colors = [ "darkturquoise" ; "darkgoldenrod2" ; "cyan" ; "green" ; "magenta" ; "yellow" ;
- "burlywood1" ; "aquamarine" ; "floralwhite" ; "lightpink" ;
- "lightblue" ; "mediumturquoise" ; "salmon" ; "slategray3" ;
- ]
-let dot_colors = "<c1,c2,...,cn> use colors c1,c1,...,cn in the dot output\n"^
- " (default list is "^(String.concat "," default_dot_colors)^")"
-let dot_reduce = " perform a transitive reduction on the selected dependency graph before the dot output\n"
-
-let man_mini = " Generate man pages only for modules, module types,\n"^
- " classes and class types "^man_only
-let default_man_suffix = "o"
-let man_suffix = "<suffix> use <suffix> for man page files "^
- "(default is "^default_man_suffix^") "^man_only^"\n"
-
-let option_title = "<title> use <title> as title for the generated documentation"
-let option_intro =
- "<file> use content of <file> as ocamldoc text to use as introduction "^(html_latex_texi_only)
-let with_parameter_list = " display the complete list of parameters for functions and methods "^html_only
-let hide_modules = " <M1,M2.M3,...> Hide the given complete module names in generated doc"
-let no_header = " Suppress header in generated documentation "^latex_texi_only
-let no_trailer = " Suppress trailer in generated documentation "^latex_texi_only
-let separate_files = " Generate one file per toplevel module "^latex_only
-let latex_title ref_titles =
- "n,style associate {n } to the given sectionning style\n"^
- " (e.g. 'section') in the latex output "^latex_only^"\n"^
- " Default sectionning is:\n"^
- (String.concat "\n"
- (List.map (fun (n,t) -> Printf.sprintf " %d -> %s" n t) !ref_titles))
-
-let default_latex_value_prefix = "val:"
-let latex_value_prefix = "<string> use <string> as prefix for the LaTeX labels of values. "^
- "(default is \""^default_latex_value_prefix^"\")"
-let default_latex_type_prefix = "type:"
-let latex_type_prefix = "<string> use <string> as prefix for the LaTeX labels of types. "^
- "(default is \""^default_latex_type_prefix^"\")"
-let default_latex_exception_prefix = "exception:"
-let latex_exception_prefix = "<string> use <string> as prefix for the LaTeX labels of exceptions. "^
- "(default is \""^default_latex_exception_prefix^"\")"
-let default_latex_module_prefix = "module:"
-let latex_module_prefix = "<string> use <string> as prefix for the LaTeX labels of modules. "^
- "(default is \""^default_latex_module_prefix^"\")"
-let default_latex_module_type_prefix = "moduletype:"
-let latex_module_type_prefix = "<string> use <string> as prefix for the LaTeX labels of module types. "^
- "(default is \""^default_latex_module_type_prefix^"\")"
-let default_latex_class_prefix = "class:"
-let latex_class_prefix = "<string> use <string> as prefix for the LaTeX labels of classes. "^
- "(default is \""^default_latex_class_prefix^"\")"
-let default_latex_class_type_prefix = "classtype:"
-let latex_class_type_prefix = "<string> use <string> as prefix for the LaTeX labels of class types. "^
- "(default is \""^default_latex_class_type_prefix^"\")"
-let default_latex_attribute_prefix = "val:"
-let latex_attribute_prefix = "<string> use <string> as prefix for the LaTeX labels of attributes. "^
- "(default is \""^default_latex_attribute_prefix^"\")"
-let default_latex_method_prefix = "method:"
-let latex_method_prefix = "<string> use <string> as prefix for the LaTeX labels of methods. "^
- "(default is \""^default_latex_method_prefix^"\")"
-
-let no_toc = " Do not generate table of contents "^latex_only
-let sort_modules = " Sort the list of top modules before generating the documentation"
-let no_stop = " Do not stop at (**/**) comments"
-let no_custom_tags = " Do not allow custom @-tags"
-let remove_stars = " Remove beginning blanks of comment lines, until the first '*'"
-let keep_code = " Always keep code when available"
-let inverse_merge_ml_mli = "Inverse implementations and interfaces when merging"
-let 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_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^"\n"
-
-let options_can_be = " <options> can be one or more of the following characters:"
-let string_of_options_list l =
- List.fold_left (fun acc -> fun (c, m) -> acc^"\n "^(String.make 1 c)^" "^m)
- ""
- l
-
-let merge_options =
- "<options> specify merge options between .mli and .ml\n"^
- options_can_be^
- (string_of_options_list
- [ merge_description ;
- merge_author ;
- merge_version ;
- merge_see ;
- merge_since ;
- merge_deprecated ;
- merge_param ;
- merge_raised_exception ;
- merge_return_value ;
- merge_custom ;
- merge_all ]
- )
-
-
-(** Error and warning messages *)
-
-let warning = "Warning"
-let pwarning s =
- prerr_endline (warning^": "^s);
- if !Odoc_global.warn_error then incr Odoc_global.errors
-
-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^"\n"
-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
- "Syntax error in text:\n"^s^"\n"^
- "line "^(string_of_int l)^", character "^(string_of_int c)^":\n"^
- (List.nth lines l)^"\n"^
- (String.make c ' ')^"^"
-
-let tag_not_handled tag = "Tag @"^tag^" not handled by this generator"
-let bad_tree = "Incorrect tree structure."
-let not_a_valid_tag s = s^" is not a valid tag."
-let fun_without_param f = "Function "^f^" has no parameter.";;
-let method_without_param f = "Méthode "^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 two many interfaces/implementation of module "^name^"."
-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 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 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 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_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 = "Attribute "^n^" not found"
-let cross_type_not_found n = "Type "^n^" not found"
-
-let object_end = "object ... end"
-let struct_end = "struct ... end"
-let sig_end = "sig ... end"
-
-(** 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 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 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_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
deleted file mode 100644
index b1da6973e4..0000000000
--- a/ocamldoc/odoc_misc.ml
+++ /dev/null
@@ -1,454 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-let input_file_as_string nom =
- let chanin = open_in_bin nom in
- let len = 1024 in
- let s = String.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_substring buf s 0 n;
- iter ()
- )
- with
- End_of_file -> ()
- in
- iter ();
- close_in chanin;
- Buffer.contents buf
-
-let string_of_longident li = String.concat "." (Longident.flatten li)
-
-let string_of_type_expr t =
- let b = Buffer.create 256 in
- let fmt = Format.formatter_of_buffer b in
- Printtyp.mark_loops t;
- Printtyp.type_scheme_max ~b_reset_names: false fmt t;
- Format.pp_print_flush fmt () ;
- Buffer.contents b
-
-(** Return the given module type where methods and vals have been removed
- from the signatures. Used when we don't want to print a too long module type.*)
-let simpl_module_type t =
- let rec iter t =
- match t with
- Types.Tmty_ident p -> t
- | Types.Tmty_signature _ -> Types.Tmty_signature []
- | Types.Tmty_functor (id, mt1, mt2) ->
- Types.Tmty_functor (id, iter mt1, iter mt2)
- in
- iter t
-
-let string_of_module_type ?(complete=false) t =
- let t2 = if complete then t else simpl_module_type t in
- Printtyp.modtype Format.str_formatter t2;
- let s = Format.flush_str_formatter () in
- s
-
-
-(** Return the given class type where methods and vals have been removed
- from the signatures. Used when we don't want to print a too long class type.*)
-let simpl_class_type t =
- let rec iter t =
- match t with
- Types.Tcty_constr (p,texp_list,ct) -> t
- | Types.Tcty_signature cs ->
- (* on vire les vals et methods pour ne pas qu'elles soient imprimées
- quand on affichera le type *)
- let tnil = { Types.desc = Types.Tnil ; Types.level = 0; Types.id = 0 } in
- Types.Tcty_signature { Types.cty_self = { cs.Types.cty_self with
- Types.desc = Types.Tobject (tnil, ref None) };
- Types.cty_vars = Types.Vars.empty ;
- Types.cty_concr = Types.Concr.empty ;
- }
- | Types.Tcty_fun (l, texp, ct) ->
- let new_ct = iter ct in
- Types.Tcty_fun (l, texp, new_ct)
- in
- iter t
-
-let string_of_class_type ?(complete=false) t =
- let t2 = if complete then t else simpl_class_type t in
- (* A VOIR : ma propre version de Printtyp.class_type pour ne pas faire reset_names *)
- Printtyp.class_type Format.str_formatter t2;
- let s = Format.flush_str_formatter () in
- s
-
-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, _) ->
- iter (Odoc_types.Code name)
- | Odoc_types.Superscript t ->
- "^{"^(string_of_text t)^"}"
- | Odoc_types.Subscript t ->
- "^{"^(string_of_text t)^"}"
- 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 ?(hour=true) d =
- let add_0 s = if String.length s < 2 then "0"^s else s in
- let t = 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 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 rec 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 _ -> [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)]
- 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 s -> ()
- | Odoc_types.Link (_, t)
- | Odoc_types.Superscript t
- | Odoc_types.Subscript t -> iter_text t
- and iter_text te =
- List.iter iter_ele te
- in
- iter_text t;
- List.rev !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
- (* le point est le dernier caractère *)
- (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 _ -> (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 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 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 (p,tlist,_) ->
- (
- match p with
- Path.Pident id when Ident.name id = "option" ->
- (
- match tlist with
- [t2] -> t2.Types.desc
- | _ -> t
- )
- | _ -> t
- )
- | Types.Tvar
- | Types.Tunivar
- | Types.Tpoly _
- | Types.Tarrow _
- | Types.Ttuple _
- | Types.Tobject _
- | Types.Tfield _
- | Types.Tnil
- | Types.Tvariant _ -> t
- | Types.Tlink t2
- | Types.Tsubst t2 -> iter t2.Types.desc
- in
- { typ with Types.desc = iter typ.Types.desc }
-
-(* eof $Id$ *)
diff --git a/ocamldoc/odoc_misc.mli b/ocamldoc/odoc_misc.mli
deleted file mode 100644
index 59200c2440..0000000000
--- a/ocamldoc/odoc_misc.mli
+++ /dev/null
@@ -1,112 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Miscelaneous functions *)
-
-(** This function returns a file in the form of one string.*)
-val input_file_as_string : string -> string
-
-(** This function creates a string from a Longident.t .*)
-val string_of_longident : Longident.t -> string
-
-(** This function takes a Types.type_expr and returns a string.
- It writes in and flushes [Format.str_formatter].*)
-val string_of_type_expr : Types.type_expr -> string
-
-(** This function returns a string representing a [Types.module_type].
- @param complete indicates if we must print complete signatures
- or just [sig end]. Default if [false].
-*)
-val string_of_module_type : ?complete: bool -> Types.module_type -> string
-
-(** This function returns a string representing a [Types.class_type].
- @param complete indicates if we must print complete signatures
- or just [object end]. Default if [false].
-*)
-val string_of_class_type : ?complete: bool -> Types.class_type -> string
-
-(** This function returns the list of (label, type_expr) describing
- the methods of a type_expr in a Tobject.*)
-val get_fields : Types.type_expr -> (string * Types.type_expr) list
-
-(** 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 : ?hour:bool -> float -> 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
-
-(** 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
-
-(** 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 : string -> bool
-
-(** Return the label name for the given label,
- i.e. removes the beginning '?' if present.*)
-val label_name : string -> string
diff --git a/ocamldoc/odoc_module.ml b/ocamldoc/odoc_module.ml
deleted file mode 100644
index e9df5cbe50..0000000000
--- a/ocamldoc/odoc_module.ml
+++ /dev/null
@@ -1,510 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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_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 *)
- }
-
-(** Different kinds of module. *)
-and module_kind =
- | Module_struct of module_element list
- | Module_alias of module_alias (** complete name and corresponding module if we found it *)
- | Module_functor of (Odoc_parameter.module_parameter list) * module_kind
- | Module_apply of module_kind * module_kind
- | Module_with of module_type_kind * string
- | Module_constraint of module_kind * module_type_kind
-
-(** Representation of a module. *)
-and t_module = {
- m_name : Name.t ;
- 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 *)
- }
-
-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 (Odoc_parameter.module_parameter list) * 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 *)
-
-(** Representation of a module type. *)
-and t_module_type = {
- mt_name : Name.t ;
- mutable mt_info : Odoc_types.info option ;
- 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 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
-
-(** Returns the list of elements of a module.
- @param trans indicates if, for aliased modules, we must perform a transitive search.*)
-let rec module_elements ?(trans=true) m =
- let rec iter_kind = function
- Module_struct l -> l
- | Module_alias ma ->
- if trans then
- match ma.ma_module with
- None -> []
- | Some (Mod m) -> module_elements m
- | Some (Modtype mt) -> module_type_elements mt
- else
- []
- | Module_functor (_, k)
- | Module_apply (k, _) -> iter_kind k
- | Module_with (tk,_) ->
- module_type_elements ~trans: trans
- { mt_name = "" ; mt_info = None ; mt_type = None ;
- mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ;
- mt_loc = Odoc_types.dummy_loc ;
- }
- | Module_constraint (k, tk) ->
- (* A VOIR : utiliser k ou tk ? *)
- module_elements ~trans: trans
- { m_name = "" ;
- m_info = None ;
- m_type = Types.Tmty_signature [] ;
- m_is_interface = false ; m_file = "" ; m_kind = k ;
- m_loc = Odoc_types.dummy_loc ;
- m_top_deps = [] ;
- m_code = None ;
- }
-(*
- module_type_elements ~trans: trans
- { mt_name = "" ; mt_info = None ; mt_type = None ;
- mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ;
- mt_loc = Odoc_types.dummy_loc }
-*)
- in
- iter_kind m.m_kind
-
-(** Returns the list of elements of a module type.
- @param trans indicates if, for aliased modules, we must perform a transitive search.*)
-and 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
- []
- in
- iter_kind mt.mt_kind
-
-(** 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 excptions 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 (params, _)) ->
- (
- (* we create the couple (parameter, description opt), using
- the description of the parameter if we can find it in the comment.*)
- match mt.mt_info with
- None ->
- List.map (fun p -> (p, None)) params
- | Some i ->
- List.map
- (fun p ->
- try
- let d = List.assoc p.Odoc_parameter.mp_name i.Odoc_types.i_params in
- (p, Some d)
- with
- Not_found ->
- (p, None)
- )
- params
- )
- | Some (Module_type_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 _) ->
- []
- | 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 =
- match m.m_kind with
- Module_functor (params, _) ->
- (
- (* we create the couple (parameter, description opt), using
- the description of the parameter if we can find it in the comment.*)
- match m.m_info with
- None ->
- List.map (fun p -> (p, None)) params
- | Some i ->
- List.map
- (fun p ->
- try
- let d = List.assoc p.Odoc_parameter.mp_name i.Odoc_types.i_params in
- (p, Some d)
- with
- Not_found ->
- (p, None)
- )
- params
- )
- | Module_alias ma ->
- if trans then
- match ma.ma_module with
- None -> []
- | Some (Mod m) -> module_parameters ~trans m
- | Some (Modtype mt) -> module_type_parameters ~trans mt
- else
- []
- | Module_constraint (k, tk) ->
- module_type_parameters ~trans: trans
- { mt_name = "" ; mt_info = None ; mt_type = None ;
- mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ;
- mt_loc = Odoc_types.dummy_loc }
- | Module_struct _
- | Module_apply _
- | Module_with _ ->
- []
-
-(** 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 _)
- | 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 rec module_is_functor m =
- match m.m_kind with
- Module_functor _ -> true
- | Module_alias ma ->
- (
- match ma.ma_module with
- None -> false
- | Some (Mod mo) -> module_is_functor mo
- | Some (Modtype mt) -> module_type_is_functor mt
- )
- | _ -> false
-
-
-(** 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 excptions 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
deleted file mode 100644
index ef01ec4a3f..0000000000
--- a/ocamldoc/odoc_name.ml
+++ /dev/null
@@ -1,162 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Representation of element names. *)
-
-let infix_chars = [ '|' ;
- '<' ;
- '>' ;
- '@' ;
- '^' ;
- '&' ;
- '+' ;
- '-' ;
- '*' ;
- '/' ;
- '$' ;
- '%' ;
- '=' ;
- ':' ;
- '~' ;
- '!' ;
- ]
-
-type t = string
-
-let parens_if_infix name =
- match name with
- "" -> ""
- | s ->
- if List.mem s.[0] infix_chars then
- "("^s^")"
- else
- s
-
-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 head n =
- match Str.split (Str.regexp "\\.") n with
- [] -> n
- | h :: _ -> h
-
-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 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 longident = String.concat "." (Longident.flatten longident)
-
-let name_alias name cpl_aliases =
- let rec f n1 = function
- [] -> raise Not_found
- | (n2, n3) :: q ->
- if n2 = n1 then
- n3
- else
- if prefix n2 n1 then
- let ln2 = String.length n2 in
- n3^(String.sub n1 ln2 ((String.length n1) - ln2))
- else
- f n1 q
- in
- let rec iter n =
- try iter (f n cpl_aliases)
- with Not_found -> n
- in
- iter name
diff --git a/ocamldoc/odoc_name.mli b/ocamldoc/odoc_name.mli
deleted file mode 100644
index b0a5d55440..0000000000
--- a/ocamldoc/odoc_name.mli
+++ /dev/null
@@ -1,66 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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
-
-(** 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 a list of module names to hide and a name,
- and return the name when the module name (or part of it)
- was removedn, according to the list of module names to hide.*)
-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
-
-(** This function takes a name and a list of name aliases and returns the name
- after substitution using the aliases. *)
-val name_alias : t -> (t * t) list -> t
diff --git a/ocamldoc/odoc_ocamlhtml.mll b/ocamldoc/odoc_ocamlhtml.mll
deleted file mode 100644
index ba4c0c8f31..0000000000
--- a/ocamldoc/odoc_ocamlhtml.mll
+++ /dev/null
@@ -1,544 +0,0 @@
-
-{
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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 = [
- ("&", "&amp;") ;
- ("<", "&lt;") ;
- (">", "&gt;") ;
-]
-
-let pre_escape_strings = [
- (" ", "&nbsp;") ;
- ("\n", "<br>\n") ;
- ("\t", "&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;") ;
- ]
-
-
-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.*)
-let escape s =
- List.fold_left
- (fun acc -> fun (s, s2) -> Str.global_replace (Str.regexp s) s2 acc)
- s
- (if !pre then base_escape_strings @ pre_escape_strings else base_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 (s : 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 make_margin () =
- let rec iter n =
- if n <= 0 then ""
- else "&nbsp;"^(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 () =
- let s = Buffer.contents string_buffer in
- String.escaped s
-
-(** To translate escape sequences *)
-
-let char_for_backslash =
- match Sys.os_type with
- | "Unix" | "Win32" | "Cygwin" ->
- begin function
- | 'n' -> '\010'
- | 'r' -> '\013'
- | 'b' -> '\008'
- | 't' -> '\009'
- | c -> c
- end
- | "MacOS" ->
- begin function
- | 'n' -> '\013'
- | 'r' -> '\010'
- | 'b' -> '\008'
- | 't' -> '\009'
- | c -> c
- end
- | x -> fatal_error "Lexer: unknown system type"
-
-let char_for_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
- {
- 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
- | [x] -> comment_start_pos := []
- | _ :: l ->
- store_comment_char '*';
- store_comment_char ')';
- comment_start_pos := l;
- comment lexbuf;
- }
- | "\""
- { reset_string_buffer();
- string_start_pos := Lexing.lexeme_start lexbuf;
- store_comment_char '"';
- 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;
- comment lexbuf }
- | "''"
- {
- store_comment_char '\'';
- store_comment_char '\'';
- 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 '\'';
- store_comment_char '\\';
- store_comment_char(char_for_decimal_code lexbuf 1);
- 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']
- { 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 }
-{
-
-let html_of_code ?(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
- let _ = token lexbuf in
- 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 ;
-
- html
-
-}
diff --git a/ocamldoc/odoc_opt.ml b/ocamldoc/odoc_opt.ml
deleted file mode 100644
index 8eb7e6fa38..0000000000
--- a/ocamldoc/odoc_opt.ml
+++ /dev/null
@@ -1,82 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Main module for native version.*)
-
-open Config
-open Clflags
-open Misc
-open Format
-open Typedtree
-
-let _ = Odoc_args.bytecode_mode := false
-
-
-let html_generator = new Odoc_html.html
-let default_latex_generator = new Odoc_latex.latex
-let default_texi_generator = new Odoc_texi.texi
-let default_man_generator = new Odoc_man.man
-let default_dot_generator = new Odoc_dot.dot
-let _ = Odoc_args.parse
- (html_generator :> Odoc_args.doc_generator)
- (default_latex_generator :> Odoc_args.doc_generator)
- (default_texi_generator :> Odoc_args.doc_generator)
- (default_man_generator :> Odoc_args.doc_generator)
- (default_dot_generator :> Odoc_args.doc_generator)
-
-let loaded_modules =
- List.flatten
- (List.map
- (fun f ->
- Odoc_info.verbose (Odoc_messages.loading f);
- try
- let l = Odoc_analyse.load_modules f in
- Odoc_info.verbose Odoc_messages.ok;
- l
- with Failure s ->
- prerr_endline s ;
- incr Odoc_global.errors ;
- []
- )
- !Odoc_args.load
- )
-
-let modules = Odoc_analyse.analyse_files ~init: loaded_modules !Odoc_args.files
-
-let _ =
- match !Odoc_args.dump with
- None -> ()
- | Some f ->
- try Odoc_analyse.dump_modules f modules
- with Failure s ->
- prerr_endline s ;
- incr Odoc_global.errors
-
-let _ =
- match !Odoc_args.doc_generator with
- None ->
- ()
- | Some gen ->
- Odoc_info.verbose Odoc_messages.generating_doc;
- gen#generate modules;
- Odoc_info.verbose Odoc_messages.ok
-
-let _ =
- if !Odoc_global.errors > 0 then
- (
- prerr_endline (Odoc_messages.errors_occured !Odoc_global.errors) ;
- exit 1
- )
- else
- exit 0
-
diff --git a/ocamldoc/odoc_parameter.ml b/ocamldoc/odoc_parameter.ml
deleted file mode 100644
index 790250fc82..0000000000
--- a/ocamldoc/odoc_parameter.ml
+++ /dev/null
@@ -1,131 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Representation and manipulation of method / function / class parameters,
- and module 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
-
-(** A module parameter is just a name and a module type.*)
-type module_parameter = {
- mp_name : string ;
- mp_type : Types.module_type ;
- }
-
-
-(** Functions *)
-
-(** acces to the name as a string. For tuples, parenthesis and commas are added. *)
-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
deleted file mode 100644
index 9b99e24f02..0000000000
--- a/ocamldoc/odoc_parser.mly
+++ /dev/null
@@ -1,158 +0,0 @@
-%{
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Odoc_types
-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_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 { () }
-| 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 }
-;
-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_scan.ml b/ocamldoc/odoc_scan.ml
deleted file mode 100644
index 2618d064ba..0000000000
--- a/ocamldoc/odoc_scan.ml
+++ /dev/null
@@ -1,156 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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)
- (** Scan of 'leaf elements'. *)
-
- method scan_value (v : Odoc_value.t_value) = ()
- method scan_type (t : Odoc_type.t_type) = ()
- method scan_exception (e : Odoc_exception.t_exception) = ()
- method scan_attribute (a : Odoc_value.t_attribute) = ()
- method scan_method (m : Odoc_value.t_method) = ()
- method scan_included_module (im : Odoc_module.included_module) = ()
-
- (** Scan of a class. *)
-
- (** Scan of a comment inside a class. *)
- method scan_class_comment (t : 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 (c : Odoc_class.t_class) = true
-
- (** This method scan the elements of the given class.
- A VOIR : scan des classes héritées.*)
- 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 overriden. 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 (t : 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 (ct : Odoc_class.t_class_type) = true
-
- (** This method scan the elements of the given class type.
- A VOIR : scan des classes héritées.*)
- 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 overriden. 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 (t : 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 (m : 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_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 overriden. 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 (t : 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 (mt : 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_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 overriden. 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
deleted file mode 100644
index 990930d695..0000000000
--- a/ocamldoc/odoc_search.ml
+++ /dev/null
@@ -1,632 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Research of elements through modules. *)
-
-module Name = Odoc_name
-open Odoc_parameter
-open Odoc_value
-open Odoc_type
-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_exception of t_exception
- | Res_attribute of t_attribute
- | Res_method of t_method
- | Res_section of string * Odoc_types.text
-
-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_type : t_type -> 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.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.Title (n, 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_type t v = if P.p_type t v then [Res_type t] else []
-
- 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
- let l = res_att @ res_met @ res_sec in
- l
- 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
- let l = res_att @ res_met @ res_sec in
- l
- 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_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
- let l = res_val @ res_typ @ res_exc @ res_mod @
- res_modtyp @ res_cl @ res_cltyp @ res_sec
- in
- l
- 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_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
- let l = res_val @ res_typ @ res_exc @ res_mod @
- res_modtyp @ res_cl @ res_cltyp @ res_sec
- in
- l
- 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_type t r = t.ty_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_type _ _ = 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_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_type _ _ = 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_type _ _ = true
- 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_type _ _ = 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_type _ _ = 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_type _ _ = 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_type _ _ = 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_type _ _ = 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_type _ _ = 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 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
-
-(* eof $Id$ *)
diff --git a/ocamldoc/odoc_search.mli b/ocamldoc/odoc_search.mli
deleted file mode 100644
index affd315fb4..0000000000
--- a/ocamldoc/odoc_search.mli
+++ /dev/null
@@ -1,199 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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_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
-
-(** 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_type : Odoc_type.t_type -> 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 type *)
- val search_type : Odoc_type.t_type -> 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_type : Odoc_type.t_type -> 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_type : Odoc_type.t_type -> 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 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 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
deleted file mode 100644
index a556679bd2..0000000000
--- a/ocamldoc/odoc_see_lexer.mll
+++ /dev/null
@@ -1,102 +0,0 @@
-{
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-let print_DEBUG2 s = print_string s ; print_newline ()
-
-(** the lexer for special comments. *)
-
-open Lexing
-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
deleted file mode 100644
index 70f55f3675..0000000000
--- a/ocamldoc/odoc_sig.ml
+++ /dev/null
@@ -1,1330 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Analysis of interface files. *)
-
-open Misc
-open Asttypes
-open Types
-open Typedtree
-open Path
-
-let print_DEBUG s = print_string s ; print_newline ();;
-
-module Name = Odoc_name
-open Odoc_parameter
-open Odoc_value
-open Odoc_type
-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
- | E of string
- | ER of string
- | P of string
-
- type tab = (ele, Types.signature_item) Hashtbl.t
-
- let add_to_hash table signat =
- match signat with
- Types.Tsig_value (ident, _) ->
- Hashtbl.add table (V (Name.from_ident ident)) signat
- | Types.Tsig_exception (ident, _) ->
- Hashtbl.add table (E (Name.from_ident ident)) signat
- | Types.Tsig_type (ident, _) ->
- Hashtbl.add table (T (Name.from_ident ident)) signat
- | Types.Tsig_class (ident,_) ->
- Hashtbl.add table (C (Name.from_ident ident)) signat
- | Types.Tsig_cltype (ident, _) ->
- Hashtbl.add table (CT (Name.from_ident ident)) signat
- | Types.Tsig_module (ident, _) ->
- Hashtbl.add table (M (Name.from_ident ident)) signat
- | Types.Tsig_modtype (ident,_) ->
- Hashtbl.add table (MT (Name.from_ident ident)) signat
-
- 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.Tsig_value (_, val_desc)) -> val_desc.Types.val_type
- | _ -> assert false
-
- let search_exception table name =
- match Hashtbl.find table (E name) with
- | (Types.Tsig_exception (_, type_expr_list)) ->
- type_expr_list
- | _ -> assert false
-
- let search_type table name =
- match Hashtbl.find table (T name) with
- | (Types.Tsig_type (_, type_decl)) -> type_decl
- | _ -> assert false
-
- let search_class table name =
- match Hashtbl.find table (C name) with
- | (Types.Tsig_class (_, class_decl)) -> class_decl
- | _ -> assert false
-
- let search_class_type table name =
- match Hashtbl.find table (CT name) with
- | (Types.Tsig_cltype (_, cltype_decl)) -> cltype_decl
- | _ -> assert false
-
- let search_module table name =
- match Hashtbl.find table (M name) with
- | (Types.Tsig_module (ident, module_type)) -> module_type
- | _ -> assert false
-
- let search_module_type table name =
- match Hashtbl.find table (MT name) with
- | (Types.Tsig_modtype (_, Types.Tmodtype_manifest module_type)) ->
- Some module_type
- | (Types.Tsig_modtype (_, Types.Tmodtype_abstract)) ->
- None
- | _ -> assert false
-
- let search_attribute_type name class_sig =
- let (_, type_expr) = Types.Vars.find name class_sig.Types.cty_vars in
- type_expr
-
- let search_method_type name class_sig =
- let fields = Odoc_misc.get_fields class_sig.Types.cty_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
- let s = String.sub !file the_start (the_end-the_start) in
- s
- with
- Invalid_argument _ ->
- ""
-
- (** 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
-
- let name_comment_from_type_kind pos_start pos_end pos_limit tk =
- match tk with
- Parsetree.Ptype_abstract ->
- (0, [])
- | Parsetree.Ptype_variant (cons_core_type_list_list, _) ->
- (*of (string * core_type list) list *)
- let rec f acc last_pos cons_core_type_list_list =
- match cons_core_type_list_list with
- [] ->
- (0, acc)
- | (name, core_type_list) :: [] ->
- let pos = Str.search_forward (Str.regexp_string name) !file last_pos in
- let s = get_string_of_file pos_end pos_limit in
- let (len, comment_opt) = My_ir.just_after_special !file_name s in
- (len, acc @ [ (name, comment_opt) ])
-
- | (name, core_type_list) :: (name2, core_type_list2) :: q ->
- match (List.rev core_type_list, core_type_list2) with
- ([], []) ->
- let pos = Str.search_forward (Str.regexp_string name) !file last_pos in
- let pos' = pos + (String.length name) in
- let pos2 = Str.search_forward (Str.regexp_string name2) !file pos' in
- let s = get_string_of_file pos' pos2 in
- let (_,comment_opt) = My_ir.just_after_special !file_name s in
- f (acc @ [name, comment_opt]) pos2 ((name2, core_type_list2) :: q)
-
- | ([], (ct2 :: _)) ->
- let pos = Str.search_forward (Str.regexp_string name) !file last_pos in
- let pos' = pos + (String.length name) in
- let pos2 = ct2.Parsetree.ptyp_loc.Location.loc_start.Lexing.pos_cnum in
- let pos2' = Str.search_backward (Str.regexp_string name2) !file pos2 in
- let s = get_string_of_file pos' pos2' in
- let (_,comment_opt) = My_ir.just_after_special !file_name s in
- f (acc @ [name, comment_opt]) pos2' ((name2, core_type_list2) :: q)
-
- | ((ct :: _), _) ->
- let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in
- let pos2 = Str.search_forward (Str.regexp_string name2) !file pos in
- let s = get_string_of_file pos pos2 in
- let (_,comment_opt) = My_ir.just_after_special !file_name s in
- let new_pos_end =
- match comment_opt with
- None -> ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum
- | Some _ -> Str.search_forward (Str.regexp "*)") !file pos
- in
- f (acc @ [name, comment_opt]) new_pos_end ((name2, core_type_list2) :: q)
- in
- f [] pos_start cons_core_type_list_list
-
- | Parsetree.Ptype_record (name_mutable_type_list, _) (* of (string * mutable_flag * core_type) list*) ->
- let rec f = function
- [] ->
- []
- | (name, _, ct) :: [] ->
- let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in
- let s = get_string_of_file pos pos_end in
- let (_,comment_opt) = My_ir.just_after_special !file_name s in
- [name, comment_opt]
- | (name,_,ct) :: ((name2,_,ct2) as ele2) :: q ->
- let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in
- let pos2 = ct2.Parsetree.ptyp_loc.Location.loc_start.Lexing.pos_cnum in
- let s = get_string_of_file pos pos2 in
- let (_,comment_opt) = My_ir.just_after_special !file_name s in
- (name, comment_opt) :: (f (ele2 :: q))
- in
- (0, f name_mutable_type_list)
-
- 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, priv) ->
- let f (constructor_name, type_expr_list) =
- let comment_opt =
- try
- match List.assoc constructor_name name_comment_list with
- None -> None
- | Some d -> d.Odoc_types.i_desc
- with Not_found -> None
- in
- {
- vc_name = constructor_name ;
- vc_args = List.map (Odoc_env.subst_type env) type_expr_list ;
- vc_text = comment_opt
- }
- in
- Odoc_type.Type_variant (List.map f l, priv = Asttypes.Private)
-
- | Types.Type_record (l, _, priv) ->
- let f (field_name, mutable_flag, type_expr) =
- let comment_opt =
- try
- match List.assoc field_name name_comment_list with
- None -> None
- | Some d -> d.Odoc_types.i_desc
- 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
- }
- in
- Odoc_type.Type_record (List.map f l, priv = Asttypes.Private)
-
- (** 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 =
- print_DEBUG "Types.Tcty_signature class_signature";
- let f_DEBUG var (mutable_flag, type_exp) = print_DEBUG var in
- Types.Vars.iter f_DEBUG class_signature.Types.cty_vars;
- print_DEBUG ("Type de la classe "^current_class_name^" : ");
- print_DEBUG (Odoc_misc.string_of_type_expr class_signature.Types.cty_self);
- let get_pos_limit2 q =
- match q with
- [] -> pos_limit
- | ele2 :: _ ->
- match ele2 with
- Parsetree.Pctf_val (_, _, _, loc)
- | Parsetree.Pctf_virt (_, _, _, loc)
- | Parsetree.Pctf_meth (_, _, _, loc)
- | Parsetree.Pctf_cstr (_, _, loc) -> loc.Location.loc_start.Lexing.pos_cnum
- | Parsetree.Pctf_inher class_type ->
- class_type.Parsetree.pcty_loc.Location.loc_start.Lexing.pos_cnum
- 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 (!file_name, loc.Location.loc_start.Lexing.pos_cnum) };
- } ;
- met_private = private_flag = Asttypes.Private ;
- met_virtual = false ;
- }
- in
- let pos_limit2 = get_pos_limit2 q in
- let pos_end = loc.Location.loc_end.Lexing.pos_cnum 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)
-
- | Parsetree.Pctf_val (name, mutable_flag, _, loc) :: q ->
- (* of (string * mutable_flag * core_type option * Location.t)*)
- let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum 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 (!file_name, loc.Location.loc_start.Lexing.pos_cnum)} ;
- } ;
- att_mutable = mutable_flag = Asttypes.Mutable ;
- }
- in
- let pos_limit2 = get_pos_limit2 q in
- let pos_end = loc.Location.loc_end.Lexing.pos_cnum 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_virt (name, private_flag, _, loc) :: q ->
- (* of (string * private_flag * core_type * Location.t) *)
- let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
- let (met, maybe_more) = get_method name comment_opt private_flag loc q in
- let met2 = { met with met_virtual = true } in
- let (inher_l, eles) = f (loc.Location.loc_end.Lexing.pos_cnum + maybe_more) q in
- (inher_l, eles_comments @ ((Class_method met2) :: eles))
-
- | Parsetree.Pctf_meth (name, private_flag, _, loc) :: q ->
- (* of (string * private_flag * core_type * Location.t) *)
- let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
- let (met, maybe_more) = get_method name comment_opt private_flag loc q in
- let (inher_l, eles) = f (loc.Location.loc_end.Lexing.pos_cnum + maybe_more) q in
- (inher_l, eles_comments @ ((Class_method met) :: eles))
-
- | (Parsetree.Pctf_cstr (_, _, loc)) :: q ->
- (* of (core_type * core_type * Location.t) *)
- (* A VOIR : cela correspond aux contraintes, non ? on ne les garde pas pour l'instant *)
- let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
- let (inher_l, eles) = f loc.Location.loc_end.Lexing.pos_cnum q in
- (inher_l, eles_comments @ eles)
-
- | Parsetree.Pctf_inher class_type :: q ->
- let loc = class_type.Parsetree.pcty_loc in
- let (comment_opt, eles_comments) =
- get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum
- in
- let pos_limit2 = get_pos_limit2 q in
- let pos_end = loc.Location.loc_end.Lexing.pos_cnum in
- let (maybe_more, info_after_opt) =
- My_ir.just_after_special
- !file_name
- (get_string_of_file 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 in
- let ic =
- {
- ic_name = Odoc_env.full_class_or_class_type_name env name ;
- ic_class = None ;
- ic_text = text_opt ;
- }
- in
- ic
-
- | Parsetree.Pcty_signature _
- | Parsetree.Pcty_fun _ ->
- (* 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 ;
- }
- in
- let (inher_l, eles) = f (pos_end + maybe_more) q in
- (inh :: inher_l , eles_comments @ eles)
- 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
- ele.Parsetree.psig_loc.Location.loc_start.Lexing.pos_cnum
- in
- let (maybe_more, new_env, elements) = analyse_signature_item_desc
- acc_env
- signat
- table
- current_module_name
- ele.Parsetree.psig_loc.Location.loc_start.Lexing.pos_cnum
- ele.Parsetree.psig_loc.Location.loc_end.Lexing.pos_cnum
- (match q with
- [] -> pos_limit
- | ele2 :: _ -> ele2.Parsetree.psig_loc.Location.loc_start.Lexing.pos_cnum
- )
- assoc_com
- ele.Parsetree.psig_desc
- in
- f (acc_eles @ (ele_comments @ elements))
- new_env
- (ele.Parsetree.psig_loc.Location.loc_end.Lexing.pos_cnum + 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 *)
- 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
- pos_start_ele pos_end_ele pos_limit comment_opt sig_item_desc =
- match sig_item_desc with
- Parsetree.Psig_value (name_pre, value_desc) ->
- let type_expr =
- try Signature_search.search_value table name_pre
- with Not_found ->
- raise (Failure (Odoc_messages.value_not_found current_module_name name_pre))
- in
- let name = Name.parens_if_infix name_pre 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 (!file_name, pos_start_ele)}
- }
- 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_exception (name, exception_decl) ->
- let types_excep_decl =
- try Signature_search.search_exception table name
- with Not_found ->
- raise (Failure (Odoc_messages.exception_not_found current_module_name name))
- in
- let e =
- {
- ex_name = Name.concat current_module_name name ;
- ex_info = comment_opt ;
- ex_args = List.map (Odoc_env.subst_type env) types_excep_decl ;
- ex_alias = None ;
- ex_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ;
- ex_code =
- (
- if !Odoc_args.keep_code then
- Some (get_string_of_file pos_start_ele (pos_end_ele + pos_limit))
- 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_exception env e.ex_name in
- (maybe_more, new_env, [ Element_exception e ])
-
- | Parsetree.Psig_type name_type_decl_list ->
- (* we start by extending the environment *)
- let new_env =
- List.fold_left
- (fun acc_env -> fun (name, _) ->
- let complete_name = Name.concat current_module_name name in
- Odoc_env.add_type acc_env complete_name
- )
- env
- name_type_decl_list
- in
- let rec f ?(first=false) acc_maybe_more last_pos name_type_decl_list =
- match name_type_decl_list with
- [] ->
- (acc_maybe_more, [])
- | (name, type_decl) :: q ->
- let (assoc_com, ele_comments) =
- if first then
- (comment_opt, [])
- else
- get_comments_in_module
- last_pos
- type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum
- in
- let pos_limit2 =
- match q with
- [] -> pos_limit
- | (_, td) :: _ -> td.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum
- in
- let (maybe_more, name_comment_list) =
- name_comment_from_type_kind
- type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum
- type_decl.Parsetree.ptype_loc.Location.loc_end.Lexing.pos_cnum
- pos_limit2
- type_decl.Parsetree.ptype_kind
- in
- print_DEBUG ("Type "^name^" : "^(match assoc_com with None -> "sans commentaire" | Some c -> Odoc_misc.string_of_info c));
- let f_DEBUG (name, c_opt) = print_DEBUG ("constructor/field "^name^": "^(match c_opt with None -> "sans commentaire" | Some c -> Odoc_misc.string_of_info c)) in
- List.iter f_DEBUG name_comment_list;
- (* get the information for the type in the signature *)
- let sig_type_decl =
- try Signature_search.search_type table name
- with Not_found ->
- raise (Failure (Odoc_messages.type_not_found current_module_name name))
- in
- (* get the type kind with the associated comments *)
- let type_kind = get_type_kind new_env name_comment_list sig_type_decl.Types.type_kind in
- let loc_start = type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum in
- let new_end = type_decl.Parsetree.ptype_loc.Location.loc_end.Lexing.pos_cnum + 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 ;
- ty_info = assoc_com ;
- ty_parameters =
- List.map2 (fun p (co,cn,_) ->
- (Odoc_env.subst_type new_env p,
- co, cn)
- )
- sig_type_decl.Types.type_params
- sig_type_decl.Types.type_variance;
- ty_kind = type_kind ;
- ty_manifest =
- (match sig_type_decl.Types.type_manifest with
- None -> None
- | Some t -> Some (Odoc_env.subst_type new_env t));
- ty_loc =
- { loc_impl = None ;
- loc_inter = Some (!file_name,loc_start) ;
- };
- ty_code =
- (
- if !Odoc_args.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, new_env, types)
-
- | Parsetree.Psig_open _ -> (* A VOIR *)
- 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 (name, module_type) ->
- let complete_name = Name.concat current_module_name name in
- (* get the the module type in the signature by the module name *)
- 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
- let module_kind = analyse_module_kind env complete_name module_type sig_module_type 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 (!file_name, pos_start_ele) } ;
- m_top_deps = [] ;
- m_code = 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
- 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 (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *)
- Types.Tmty_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 -> fun (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
- (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *)
- Types.Tmty_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, [])
- | (name, modtype) :: q ->
- let complete_name = Name.concat current_module_name name in
- let loc_start = modtype.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in
- let loc_end = modtype.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum 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
- | (_, mty) :: _ -> mty.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum
- 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
- (* 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 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 (!file_name, pos_start_ele) } ;
- m_top_deps = [] ;
- m_code = None ;
- }
- 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 (name, Parsetree.Pmodtype_abstract) ->
- let sig_mtype =
- try Signature_search.search_module_type table name
- with Not_found ->
- raise (Failure (Odoc_messages.module_type_not_found current_module_name name))
- in
- let complete_name = Name.concat current_module_name name 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 = None ;
- mt_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ;
- }
- 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
- (maybe_more, new_env, [ Element_module_type mt ])
-
- | Parsetree.Psig_modtype (name, Parsetree.Pmodtype_manifest module_type) ->
- let complete_name = Name.concat current_module_name name in
- let sig_mtype_opt =
- try Signature_search.search_module_type table name
- with Not_found ->
- raise (Failure (Odoc_messages.module_type_not_found current_module_name name))
- in
- let module_type_kind =
- match sig_mtype_opt 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_opt ;
- mt_is_interface = true ;
- mt_file = !file_name ;
- mt_kind = module_type_kind ;
- mt_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ;
- }
- 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_opt with (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *)
- Some (Types.Tmty_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 module_type ->
- let rec f = function
- Parsetree.Pmty_ident longident ->
- Name.from_longident longident
- | Parsetree.Pmty_signature _ ->
- "??"
- | Parsetree.Pmty_functor _ ->
- "??"
- | Parsetree.Pmty_with (mt, _) ->
- f mt.Parsetree.pmty_desc
- in
- let im =
- {
- im_name = Odoc_env.full_module_or_module_type_name env (f module_type.Parsetree.pmty_desc) ;
- im_module = None ;
- im_info = comment_opt;
- }
- in
- (0, env, [ Element_included_module im ]) (* A VOIR : étendre l'environnement ? avec quoi ? *)
-
- | 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 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
- class_desc.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
- in
- let pos_end = class_desc.Parsetree.pci_loc.Location.loc_end.Lexing.pos_cnum in
- let pos_limit2 =
- match q with
- [] -> pos_limit
- | cd :: _ -> cd.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
- in
- let name = class_desc.Parsetree.pci_name in
- let complete_name = Name.concat current_module_name name in
- let sig_class_decl =
- try Signature_search.search_class table name
- with Not_found ->
- raise (Failure (Odoc_messages.class_not_found current_module_name name))
- in
- let sig_class_type = sig_class_decl.Types.cty_type in
- let (parameters, class_kind) =
- analyse_class_kind
- new_env
- complete_name
- class_desc.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
- 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 (!file_name, pos_start_ele) } ;
- }
- in
- let (maybe_more, info_after_opt) =
- My_ir.just_after_special
- !file_name
- (get_string_of_file 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 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
- ct_decl.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
- in
- let pos_end = ct_decl.Parsetree.pci_loc.Location.loc_end.Lexing.pos_cnum in
- let pos_limit2 =
- match q with
- [] -> pos_limit
- | ct_decl2 :: _ -> ct_decl2.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
- in
- let name = ct_decl.Parsetree.pci_name in
- let complete_name = Name.concat current_module_name name in
- let sig_cltype_decl =
- try Signature_search.search_class_type table name
- with Not_found ->
- raise (Failure (Odoc_messages.class_type_not_found current_module_name name))
- in
- let sig_class_type = sig_cltype_decl.Types.clty_type in
- let kind = analyse_class_type_kind
- new_env
- complete_name
- ct_decl.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
- 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 (!file_name, pos_start_ele) } ;
- }
- in
- let (maybe_more, info_after_opt) =
- My_ir.just_after_special
- !file_name
- (get_string_of_file 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)
-
- (** Return a module_type_kind from a Parsetree.module_type and a Types.module_type *)
- and analyse_module_type_kind 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.Tmty_ident path -> Name.from_path path
- | _ -> Name.from_longident longident
- (* A VOIR cela arrive quand on fait module type F : functor ... -> Toto, Toto n'est pas un ident mais une structure *)
- in
- Module_type_alias { mta_name = Odoc_env.full_module_type_name env name ;
- mta_module = None }
-
- | Parsetree.Pmty_signature ast ->
- (
- (* we must have a signature in the module type *)
- match sig_module_type with
- Types.Tmty_signature signat ->
- let pos_start = module_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in
- let pos_end = module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum 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.Tmty_signature signat")
- )
-
- | Parsetree.Pmty_functor (_,_, module_type2) ->
- (
- match sig_module_type with
- Types.Tmty_functor (ident, param_module_type, body_module_type) ->
- let param =
- {
- mp_name = Name.from_ident ident ;
- mp_type = Odoc_env.subst_module_type env param_module_type ;
- }
- in
- (
- match analyse_module_type_kind env current_module_name module_type2 body_module_type with
- Module_type_functor (params, k) ->
- Module_type_functor (param :: params, k)
- | k ->
- Module_type_functor ([param], k)
- )
-
- | _ ->
- (* if we're here something's wrong *)
- raise (Failure "Parsetree.Pmty_functor _ but not Types.Tmty_functor _")
- )
-
- | Parsetree.Pmty_with (module_type2, _) ->
- (* of module_type * (Longident.t * with_constraint) list *)
- (
- let loc_start = module_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
- let loc_end = module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
- let s = get_string_of_file loc_start loc_end in
- let k = analyse_module_type_kind env current_module_name module_type2 sig_module_type in
- Module_type_with (k, s)
- )
-
- (** Analyse of a Parsetree.module_type and a Types.module_type.*)
- and analyse_module_kind env current_module_name module_type sig_module_type =
- match module_type.Parsetree.pmty_desc with
- Parsetree.Pmty_ident longident (*of Longident.t*) ->
- let name =
- match sig_module_type with
- Types.Tmty_ident path -> Name.from_path path
- | _ ->
- Name.from_longident longident
- in
- Module_alias { ma_name = Odoc_env.full_module_or_module_type_name env name ;
- ma_module = None }
-
- | Parsetree.Pmty_signature signature ->
- (
- match sig_module_type with
- Types.Tmty_signature signat ->
- Module_struct
- (analyse_parsetree
- env
- signat
- current_module_name
- module_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum
- module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum
- signature
- )
- | _ ->
- (* if we're here something's wrong *)
- raise (Failure "Parsetree.Pmty_signature signature but not Types.Tmty_signature signat")
- )
- | Parsetree.Pmty_functor (_,_,module_type2) (* of string * module_type * module_type *) ->
- (
- match sig_module_type with
- Types.Tmty_functor (ident, param_module_type, body_module_type) ->
- let param =
- {
- mp_name = Name.from_ident ident ;
- mp_type = Odoc_env.subst_module_type env param_module_type ;
- }
- in
- (
- match analyse_module_kind env current_module_name module_type2 body_module_type with
- Module_functor (params, k) ->
- Module_functor (param :: params, k)
- | k ->
- Module_functor ([param], k)
- )
-
- | _ ->
- (* if we're here something's wrong *)
- raise (Failure "Parsetree.Pmty_functor _ but not Types.Tmty_functor _")
- )
- | Parsetree.Pmty_with (module_type2, _) ->
- (*of module_type * (Longident.t * with_constraint) list*)
- (
- let loc_start = module_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
- let loc_end = module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
- let s = get_string_of_file loc_start loc_end in
- let k = analyse_module_type_kind env current_module_name module_type2 sig_module_type in
- Module_with (k, s)
- )
-
- (** 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.Tcty_constr (p, typ_list, _) (*of Path.t * type_expr list * class_type*)) ->
- print_DEBUG "Tcty_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 (_, class_type_field_list), Types.Tcty_signature class_signature) ->
- print_DEBUG "Types.Tcty_signature class_signature";
- let f_DEBUG var (mutable_flag, type_exp) = print_DEBUG var in
- Types.Vars.iter f_DEBUG class_signature.Types.cty_vars;
- print_DEBUG ("Type de la classe "^current_class_name^" : ");
- print_DEBUG (Odoc_misc.string_of_type_expr class_signature.Types.cty_self);
- (* 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
- parse_class_type.Parsetree.pcty_loc.Location.loc_end.Lexing.pos_cnum
- class_type_field_list
- class_signature
- in
- ([], Class_structure (inher_l, ele))
-
- | (Parsetree.Pcty_fun (parse_label, _, pclass_type), Types.Tcty_fun (label, type_expr, class_type)) ->
- (* label = string. Dans les signatures, pas de nom de paramètres à l'intérieur des tuples *)
- (* si label = "", pas de label. ici on a l'information pour savoir si on a un label explicite. *)
- 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_fun (parse_label, _, pclass_type), labels différents")
- )
-
- | _ ->
- 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.Tcty_constr (p, typ_list, _) (*of Path.t * type_expr list * class_type*)) ->
- print_DEBUG "Tcty_constr _";
- let k =
- 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
- }
- in
- k
-
- | (Parsetree.Pcty_signature (_, class_type_field_list), Types.Tcty_signature class_signature) ->
- print_DEBUG "Types.Tcty_signature class_signature";
- let f_DEBUG var (mutable_flag, type_exp) = print_DEBUG var in
- Types.Vars.iter f_DEBUG class_signature.Types.cty_vars;
- print_DEBUG ("Type de la classe "^current_class_name^" : ");
- print_DEBUG (Odoc_misc.string_of_type_expr class_signature.Types.cty_self);
- (* 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
- parse_class_type.Parsetree.pcty_loc.Location.loc_end.Lexing.pos_cnum
- class_type_field_list
- class_signature
- in
- Class_signature (inher_l, ele)
-
- | (Parsetree.Pcty_fun (parse_label, _, pclass_type), Types.Tcty_fun (label, type_expr, class_type)) ->
- raise (Failure "analyse_class_type_kind : Parsetree.Pcty_fun (...) with Types.Tcty_fun (...)")
-(*
- | (Parsetree.Pcty_constr (longident, _) (*of Longident.t * core_type list *),
- Types.Tcty_signature class_signature) ->
- (* A VOIR : c'est pour le cas des contraintes de classes :
- 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) =
- let complete_source_file =
- try
- let curdir = Sys.getcwd () in
- let (dirname, basename) = (Filename.dirname source_file, Filename.basename source_file) in
- Sys.chdir dirname ;
- let complete = Filename.concat (Sys.getcwd ()) basename in
- Sys.chdir curdir ;
- complete
- with
- Sys_error s ->
- prerr_endline s ;
- incr Odoc_global.errors ;
- source_file
- in
- prepare_file complete_source_file input_file;
- (* We create the t_module for this file. *)
- let mod_name = String.capitalize
- (Filename.basename (try Filename.chop_extension source_file with _ -> source_file))
- in
- let (len,info_opt) = My_ir.first_special !file_name !file in
- let elements = analyse_parsetree Odoc_env.empty signat mod_name len (String.length !file) ast in
- let m =
- {
- m_name = mod_name ;
- m_type = Types.Tmty_signature signat ;
- m_info = info_opt ;
- m_is_interface = true ;
- m_file = !file_name ;
- m_kind = Module_struct elements ;
- m_loc = { loc_impl = None ; loc_inter = Some (!file_name, 0) } ;
- m_top_deps = [] ;
- m_code = None ;
- }
- in
-
- print_DEBUG "Eléments du module:";
- let f e =
- let s =
- match e with
- Element_module m -> "module "^m.m_name
- | Element_module_type mt -> "module type "^mt.mt_name
- | Element_included_module im -> "included module "^im.im_name
- | Element_class c -> "class "^c.cl_name
- | Element_class_type ct -> "class type "^ct.clt_name
- | Element_value v -> "value "^v.val_name
- | Element_exception e -> "exception "^e.ex_name
- | Element_type t -> "type "^t.ty_name
- | Element_module_comment t -> Odoc_misc.string_of_text t
- in
- print_DEBUG s;
- ()
- in
- List.iter f elements;
-
- m
-
- end
-
-(* eof $Id$ *)
diff --git a/ocamldoc/odoc_sig.mli b/ocamldoc/odoc_sig.mli
deleted file mode 100644
index bbd946420d..0000000000
--- a/ocamldoc/odoc_sig.mli
+++ /dev/null
@@ -1,176 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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 type expression list for the exception whose name is given,
- in the given table.
- @raise Not_found if error.*)
- val search_exception : tab -> string -> Types.exception_declaration
-
- (** 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.cltype_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.cltype_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)
-
- (** 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_start] and [pos_end] are the first and 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_kind :
- int -> int -> int -> Parsetree.type_kind -> int * (string * Odoc_types.info option) list
-
- (** 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 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 :
- 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
deleted file mode 100644
index f5d92e73ae..0000000000
--- a/ocamldoc/odoc_str.ml
+++ /dev/null
@@ -1,231 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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_manifest = None
- then
- match (co, cn) with
- (true, false) -> "+"
- | (false, true) -> "-"
- | _ -> ""
- else
- ""
-
-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 _ -> 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 sep type_list =
- let par =
- 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_class_type_param_list l =
- let par =
- match l with
- [] | [_] -> false
- | _ -> true
- in
- Printf.sprintf "%s%s%s"
- (if par then "[" else "")
- (raw_string_of_type_list ", "
- (List.map
- (fun typ -> ("", typ))
- l
- )
- )
- (if par then "]" else "")
-
-let string_of_type t =
- let module M = Odoc_type in
- "type "^
- (String.concat ""
- (List.map
- (fun (p, co, cn) ->
- (string_of_variance t (co, cn))^
- (Odoc_misc.string_of_type_expr p)^" "
- )
- t.M.ty_parameters
- )
- )^
- (Name.simple t.M.ty_name)^" "^
- (match t.M.ty_manifest with
- None -> ""
- | Some typ -> "= "^(Odoc_misc.string_of_type_expr typ)^" "
- )^
- (match t.M.ty_kind with
- M.Type_abstract ->
- ""
- | M.Type_variant (l, priv) ->
- "="^(if priv then " private" else "")^"\n"^
- (String.concat ""
- (List.map
- (fun cons ->
- " | "^cons.M.vc_name^
- (match cons.M.vc_args with
- [] -> ""
- | l ->
- " of "^(String.concat " * "
- (List.map (fun t -> "("^(Odoc_misc.string_of_type_expr t)^")") l))
- )^
- (match cons.M.vc_text with
- None ->
- ""
- | Some t ->
- "(* "^(Odoc_misc.string_of_text t)^" *)"
- )^"\n"
- )
- l
- )
- )
- | M.Type_record (l, priv) ->
- "= "^(if priv then "private " else "")^"{\n"^
- (String.concat ""
- (List.map
- (fun record ->
- " "^(if record.M.rf_mutable then "mutable " else "")^
- record.M.rf_name^" : "^(Odoc_misc.string_of_type_expr record.M.rf_type)^";"^
- (match record.M.rf_text with
- None ->
- ""
- | Some t ->
- "(* "^(Odoc_misc.string_of_text t)^" *)"
- )^"\n"
- )
- l
- )
- )^
- "}\n"
- )^
- (match t.M.ty_info with
- None -> ""
- | Some info -> Odoc_misc.string_of_info info)
-
-let string_of_exception e =
- let module M = Odoc_exception in
- "exception "^(Name.simple e.M.ex_name)^
- (match e.M.ex_args with
- [] -> ""
- | _ ->" : "^
- (String.concat " -> "
- (List.map (fun t -> "("^(Odoc_misc.string_of_type_expr t)^")") e.M.ex_args)
- )
- )^
- (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_misc.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_mutable then Odoc_messages.mutab^" " else "")^
- (Name.simple a.M.att_value.M.val_name)^" : "^
- (Odoc_misc.string_of_type_expr a.M.att_value.M.val_type)^"\n"^
- (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_misc.string_of_type_expr m.M.met_value.M.val_type)^"\n"^
- (match m.M.met_value.M.val_info with
- None -> ""
- | Some i -> Odoc_misc.string_of_info i)
-
-(* eof $Id$ *)
diff --git a/ocamldoc/odoc_str.mli b/ocamldoc/odoc_str.mli
deleted file mode 100644
index a06852ebe3..0000000000
--- a/ocamldoc/odoc_str.mli
+++ /dev/null
@@ -1,45 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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. It writes in and flushes [Format.str_formatter].*)
-val string_of_type_list : string -> Types.type_expr list -> string
-
-(** This function returns a string to represent the list of type parameters
- for the given type. It writes in and flushes [Format.str_formatter].*)
-val string_of_type_param_list : Odoc_type.t_type -> string
-
-(** This function returns a string to represent the given list of
- type parameters of a class or class type,
- with a given separator. It writes in and flushes [Format.str_formatter].*)
-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
-
-(** @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_texi.ml b/ocamldoc/odoc_texi.ml
deleted file mode 100644
index 8090a2b3c4..0000000000
--- a/ocamldoc/odoc_texi.ml
+++ /dev/null
@@ -1,1193 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Olivier Andrieu, basé sur du code de Maxence Guesdon *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Generation of Texinfo documentation. *)
-
-open Odoc_info
-open Parameter
-open Value
-open Type
-open Exception
-open Class
-open Module
-
-(** {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
- let s' = String.make n ' ' in
- String.blit s 0 s' 0 len ; s'
- 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' = String.make (succ len + (succ !c) * nb_sp ) ' ' in
- c := nb_sp ;
- for i = 0 to len do
- s'.[!c] <- s.[i] ;
- if s.[i] = '\n' then c := !c + nb_sp ;
- incr c
- done ;
- 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
- | `Exception
- | `Value
- | `Class_att
- | `Method
- | `Class
- | `Class_type
- | `Module
- | `Module_type
-]
-
-let indices = function
- | `Type -> "ty"
- | `Exception -> "ex"
- | `Value -> "va"
- | `Class_att -> "ca"
- | `Method -> "me"
- | `Class -> "cl"
- | `Class_type -> "ct"
- | `Module -> "mo"
- | `Module_type -> "mt"
-
-let indices_names = [
- "Types" , "ty" ;
- "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 !Args.esc_8bits
- then [
- (Str.regexp "à", "@`a") ;
- (Str.regexp "â", "@^a") ;
- (Str.regexp "é", "@'e") ;
- (Str.regexp "è", "@`e") ;
- (Str.regexp "ê", "@^e") ;
- (Str.regexp "ë", "@\"e") ;
- (Str.regexp "ç", "@,{c}") ;
- (Str.regexp "ô", "@^o") ;
- (Str.regexp "ö", "@\"o") ;
- (Str.regexp "î", "@^i") ;
- (Str.regexp "ï", "@\"i") ;
- (Str.regexp "ù", "@`u") ;
- (Str.regexp "û", "@^u") ;
- (Str.regexp "æ", "@ae{}" ) ;
- (Str.regexp "Æ", "@AE{}" ) ;
- (Str.regexp "ß", "@ss{}" ) ;
- (Str.regexp "©", "@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] informations *)
- 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) =
- 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
-
- 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
-
-
-
-(** This class is used to create objects which can generate a simple
- Texinfo documentation. *)
-class texi =
- object (self)
- inherit text as to_texi
- 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 ]
-
- method node depth name =
- if depth <= maxdepth
- then Verbatim ("@node " ^ (Texi.fix_nodename name) ^ ",\n")
- else nothing
-
- method index (ind : indices) ent =
- Verbatim
- (if !Args.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 | Enum tel -> List (List.map self#fix_linebreaks tel)
- | te -> te) t
-
- method private soft_fix_linebreaks =
- let re = Str.regexp "\n[ \t]*" in
- fun ind t ->
- let rep = String.make (succ ind) ' ' in
- rep.[0] <- '\n' ;
- List.map
- (function
- | Raw s -> Raw (Str.global_replace re rep s)
- | te -> te) 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_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 ;
- 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_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 = function
- | [] -> ""
- | args -> " of " ^ (Odoc_info.string_of_type_list " * " args)
-
- (** Return Texinfo code for a type. *)
- method texi_of_type ty =
- Odoc_info.reset_type_names () ;
- let t =
- [ self#fixedblock (
- [ Newline ; minus ; Raw "type " ;
- Raw (self#string_of_type_parameters ty) ;
- Raw (Name.simple ty.ty_name) ] @
- ( match ty.ty_manifest with
- | None -> []
- | Some typ ->
- (Raw " = ") :: (self#text_of_short_type_expr
- (Name.father ty.ty_name) typ) ) @
- (
- match ty.ty_kind with
- | Type_abstract -> [ Newline ]
- | Type_variant (l, priv) ->
- (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)) ::
- (match constr.vc_text with
- | None -> [ Newline ]
- | Some t ->
- ((Raw (indent 5 "\n(* ")) :: (self#soft_fix_linebreaks 8 t)) @
- [ Raw " *)" ; Newline ]
- ) ) l ) )
- | Type_record (l, priv) ->
- (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 " ;" ] @
- (match r.rf_text with
- | None -> [ Newline ]
- | Some t ->
- ((Raw (indent 5 "\n(* ")) :: (self#soft_fix_linebreaks 8 t)) @
- [ Raw " *)" ; Newline ] ) )
- l ) )
- @ [ Raw " }" ]
- ) ) ;
- self#index `Type ty.ty_name ; Newline ] @
- (self#text_of_info ty.ty_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) ] @
- (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) ;
- 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) ;
- 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) ]
- | Some (Modtype { mt_name = name }) ->
- [ Raw name ; Raw "\n " ;
- Ref (name, Some RK_module_type) ]
- ) @
- [ 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) ; 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) ; 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_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)) ::
- ( 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 =
- 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)
-
-
- (** Generate the Texinfo code for the given class type,
- in the given out channel. *)
- method generate_for_class_type chanout ct =
- Odoc_info.reset_type_names () ;
- let depth = Name.depth ct.clt_name in
- let 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)
-
-
-
- (** Generate the Texinfo code for the given module type,
- in the given out channel. *)
- method generate_for_module_type chanout mt =
- let depth = Name.depth mt.mt_name in
- let 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
-
-
- (** Generate the Texinfo code for the given module,
- in the given out channel. *)
- method generate_for_module chanout m =
- 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, [ 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
-
-
-
- (** Writes the header of the TeXinfo document. *)
- method generate_texi_header chan texi_filename m_list =
- let title = match !Args.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 !Args.with_index then
- List.map
- (fun ind ->
- "@defcodeindex " ^ (indices ind))
- indices_to_build
- else []) ;
-
- [ Texi.dirsection !Args.info_section ] ;
-
- Texi.direntry
- (if !Args.info_entry <> []
- then !Args.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.Args.intro_file with
- | None when title <> "" ->
- puts_nl chan "@ifinfo" ;
- puts_nl chan ("Documentation for " ^ title) ;
- puts_nl chan "@end ifinfo"
- | None ->
- puts_nl chan "@c no title given"
- | Some f ->
- nl chan ;
- puts_nl chan
- (self#texi_of_info (Some (Odoc_info.info_of_comment_file f)))
- end ;
-
- (* write a top menu *)
- Texi.generate_menu chan
- ((List.map (fun m -> `Module m) m_list) @
- (if !Args.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 !Args.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 !Args.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_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.Args.out_file} file. *)
- method generate module_list =
- let filename =
- if !Args.out_file = Odoc_messages.default_out_file
- then "ocamldoc.texi"
- else !Args.out_file in
- if !Args.with_index
- then List.iter self#scan_for_index
- (List.map (fun m -> `Module m) module_list) ;
- try
- let chanout = open_out
- (Filename.concat !Args.target_dir filename) in
- if !Args.with_header
- then self#generate_texi_header chanout filename module_list ;
- List.iter
- (self#generate_for_module chanout)
- module_list ;
- if !Args.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
diff --git a/ocamldoc/odoc_text.ml b/ocamldoc/odoc_text.ml
deleted file mode 100644
index b83c88a19f..0000000000
--- a/ocamldoc/odoc_text.ml
+++ /dev/null
@@ -1,144 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-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 (s,None) ->
- p b "{!%s}" s
- | Ref (s, Some k) ->
- (
- let sk = match k with
- RK_module -> "module"
- | RK_module_type -> "modtype"
- | RK_class -> "class"
- | RK_class_type -> "classtype"
- | RK_value -> "val"
- | RK_type -> "type"
- | RK_exception -> "exception"
- | RK_attribute -> "attribute"
- | RK_method -> "method"
- | RK_section _ -> "section"
- in
- p b "{!%s:%s}" sk s
- )
- | Superscript t -> p b "{^" ; p_text b t ; p b "}"
- | Subscript t -> p b "{_" ; p_text b t ; p b "}"
-
- 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
deleted file mode 100644
index bc121791dd..0000000000
--- a/ocamldoc/odoc_text.mli
+++ /dev/null
@@ -1,24 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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
deleted file mode 100644
index f21ec9ae39..0000000000
--- a/ocamldoc/odoc_text_lexer.mll
+++ /dev/null
@@ -1,730 +0,0 @@
-{
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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
-
-(** Fonction de remise à zéro de la chaine de caractères tampon *)
-let reset_string_buffer () = Buffer.reset string_buffer
-
-(** Fonction d'ajout d'un caractère dans la chaine de caractères tampon *)
-let ajout_char_string = Buffer.add_char string_buffer
-
-(** Add a string to the buffer. *)
-let ajout_string = Buffer.add_string string_buffer
-
-let lecture_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 latex mode or not, to handle any special expression
- like a string when we're in latex mode.*)
-let latex_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;
- latex_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" | html_list
-let begin_enum = "{ol" | html_enum
-let begin_item = "{li"blank_nl | "{- " | html_item
-let begin_link = "{{:"
-let begin_latex = "{%"blank_nl
-let end_latex = "%}"
-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_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_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
- {
- incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or
- (!open_brackets >= 1) then
- Char (Lexing.lexeme lexbuf)
- else
- let _ =
- if !ele_ref_mode then
- ele_ref_mode := false
- in
- END
- }
-| begin_title
- {
- incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or
- (!open_brackets >= 1) or !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 or !latex_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
- Char (Lexing.lexeme lexbuf)
- else
- BOLD
- }
-| begin_italic
- {
- incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
- Char (Lexing.lexeme lexbuf)
- else
- ITALIC
- }
-| begin_link
- {
- incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
- Char (Lexing.lexeme lexbuf)
- else
- LINK
- }
-| begin_emp
- {
- incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
- Char (Lexing.lexeme lexbuf)
- else
- EMP
- }
-| begin_superscript
- {
- incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
- Char (Lexing.lexeme lexbuf)
- else
- SUPERSCRIPT
- }
-| begin_subscript
- {
- incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
- Char (Lexing.lexeme lexbuf)
- else
- SUBSCRIPT
- }
-| begin_center
- {
- incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
- Char (Lexing.lexeme lexbuf)
- else
- CENTER
- }
-| begin_left
- {
- incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
- Char (Lexing.lexeme lexbuf)
- else
- LEFT
- }
-| begin_right
- {
- incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode
- or (!open_brackets >= 1) or !ele_ref_mode then
- Char (Lexing.lexeme lexbuf)
- else
- RIGHT
- }
-| begin_list
- {
- incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
- Char (Lexing.lexeme lexbuf)
- else
- LIST
- }
-| begin_enum
- {
- incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
- Char (Lexing.lexeme lexbuf)
- else
- ENUM
- }
-| begin_item
- {
- incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
- Char (Lexing.lexeme lexbuf)
- else
- ITEM
- }
-| begin_latex
- {
- incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or
- (!open_brackets >= 1) or !ele_ref_mode then
- Char (Lexing.lexeme lexbuf)
- else
- (
- latex_mode := true;
- LATEX
- )
- }
-| end_latex
- {
- incr_cpts lexbuf ;
- if !verb_mode or (!open_brackets >= 1) or !code_pre_mode or
- !ele_ref_mode then
- Char (Lexing.lexeme lexbuf)
- else
- (
- latex_mode := false;
- END_LATEX
- )
- }
-| begin_code end_code
- {
- incr_cpts lexbuf ;
- Char (Lexing.lexeme lexbuf)
- }
-
-| begin_code
- {
- incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or !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 or !latex_mode or !code_pre_mode or !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 or !latex_mode or !code_pre_mode or !ele_ref_mode then
- Char (Lexing.lexeme lexbuf)
- else
- (
- code_pre_mode := true;
- CODE_PRE
- )
- }
-| end_code_pre
- {
- incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !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 or !latex_mode or !code_pre_mode or !open_brackets >= 1 then
- Char (Lexing.lexeme lexbuf)
- else
- if not !ele_ref_mode then
- (
- ele_ref_mode := true;
- ELE_REF
- )
- else
- (
- Char (Lexing.lexeme lexbuf)
- )
- }
-
-
-| begin_val_ref
- {
- incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or !open_brackets >= 1 then
- Char (Lexing.lexeme lexbuf)
- else
- if not !ele_ref_mode then
- (
- ele_ref_mode := true;
- VAL_REF
- )
- else
- (
- Char (Lexing.lexeme lexbuf)
- )
- }
-
-| begin_typ_ref
- {
- incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or !open_brackets >= 1 then
- Char (Lexing.lexeme lexbuf)
- else
- if not !ele_ref_mode then
- (
- ele_ref_mode := true;
- TYP_REF
- )
- else
- (
- Char (Lexing.lexeme lexbuf)
- )
- }
-
-| begin_exc_ref
- {
- incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or !open_brackets >= 1 then
- Char (Lexing.lexeme lexbuf)
- else
- if not !ele_ref_mode then
- (
- ele_ref_mode := true;
- EXC_REF
- )
- else
- (
- Char (Lexing.lexeme lexbuf)
- )
- }
-
-| begin_mod_ref
- {
- incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or !open_brackets >= 1 then
- Char (Lexing.lexeme lexbuf)
- else
- if not !ele_ref_mode then
- (
- ele_ref_mode := true;
- MOD_REF
- )
- else
- (
- Char (Lexing.lexeme lexbuf)
- )
- }
-
-| begin_modt_ref
- {
- incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or !open_brackets >= 1 then
- Char (Lexing.lexeme lexbuf)
- else
- if not !ele_ref_mode then
- (
- ele_ref_mode := true;
- MODT_REF
- )
- else
- (
- Char (Lexing.lexeme lexbuf)
- )
- }
-
-| begin_cla_ref
- {
- incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or !open_brackets >= 1 then
- Char (Lexing.lexeme lexbuf)
- else
- if not !ele_ref_mode then
- (
- ele_ref_mode := true;
- CLA_REF
- )
- else
- (
- Char (Lexing.lexeme lexbuf)
- )
- }
-
-| begin_clt_ref
- {
- incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or !open_brackets >= 1 then
- Char (Lexing.lexeme lexbuf)
- else
- if not !ele_ref_mode then
- (
- ele_ref_mode := true;
- CLT_REF
- )
- else
- (
- Char (Lexing.lexeme lexbuf)
- )
- }
-
-| begin_att_ref
- {
- incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or !open_brackets >= 1 then
- Char (Lexing.lexeme lexbuf)
- else
- if not !ele_ref_mode then
- (
- ele_ref_mode := true;
- ATT_REF
- )
- else
- (
- Char (Lexing.lexeme lexbuf)
- )
- }
-
-| begin_met_ref
- {
- incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or !open_brackets >= 1 then
- Char (Lexing.lexeme lexbuf)
- else
- if not !ele_ref_mode then
- (
- ele_ref_mode := true;
- MET_REF
- )
- else
- (
- Char (Lexing.lexeme lexbuf)
- )
- }
-
-| begin_sec_ref
- {
- incr_cpts lexbuf ;
- if !verb_mode or !latex_mode or !code_pre_mode or !open_brackets >= 1 then
- Char (Lexing.lexeme lexbuf)
- else
- if not !ele_ref_mode then
- (
- ele_ref_mode := true;
- SEC_REF
- )
- else
- (
- Char (Lexing.lexeme lexbuf)
- )
- }
-
-
-| begin_verb
- {
- incr_cpts lexbuf ;
- if !latex_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode then
- Char (Lexing.lexeme lexbuf)
- else
- (
- verb_mode := true;
- VERB
- )
- }
-| end_verb
- {
- incr_cpts lexbuf ;
- if !latex_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode then
- Char (Lexing.lexeme lexbuf)
- else
- (
- verb_mode := false;
- END_VERB
- )
- }
-
-| shortcut_list_item
- {
- incr_cpts lexbuf ;
- if !shortcut_list_mode then
- (
- SHORTCUT_LIST_ITEM
- )
- else
- (
- shortcut_list_mode := true;
- BEGIN_SHORTCUT_LIST_ITEM
- )
- }
-
-| shortcut_enum_item
- {
- incr_cpts lexbuf ;
- 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
- BLANK_LINE
- }
-
-| eof { EOF }
-
-| "{"
- {
- incr_cpts lexbuf ;
- if !latex_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode then
- Char (Lexing.lexeme lexbuf)
- else
- ERROR
- }
-| _
- {
- incr_cpts lexbuf ;
- Char (Lexing.lexeme lexbuf)
- }
-
-
diff --git a/ocamldoc/odoc_text_parser.mly b/ocamldoc/odoc_text_parser.mly
deleted file mode 100644
index 2abd562f74..0000000000
--- a/ocamldoc/odoc_text_parser.mly
+++ /dev/null
@@ -1,215 +0,0 @@
-%{
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Odoc_types
-
-let identchar =
- "[A-Z a-z_\192-\214\216-\246\248-\255'0-9]"
-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 ERROR
-%token END
-%token <int * string option> Title
-%token BOLD
-%token EMP
-%token CENTER
-%token LEFT
-%token RIGHT
-%token ITALIC
-%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 END_LATEX
-
-%token ELE_REF
-%token VAL_REF
-%token TYP_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 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
-%type <Odoc_types.text> main
-
-%%
-main:
- text EOF { $1 }
-| EOF { [Raw ""] }
-;
-
-text:
- text_element_list { $1 }
-;
-
-text_element_list:
- text_element { [ $1 ] }
-| text_element text_element_list { $1 :: $2 }
-;
-
-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 }
-| 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 string END {
- let s2 = remove_beginning_blanks $2 in
- let s3 = remove_trailing_blanks s2 in
- Ref (s3, None)
- }
-| VAL_REF string END {
- let s2 = remove_beginning_blanks $2 in
- let s3 = remove_trailing_blanks s2 in
- Ref (s3, Some RK_value)
- }
-| TYP_REF string END {
- let s2 = remove_beginning_blanks $2 in
- let s3 = remove_trailing_blanks s2 in
- Ref (s3, Some RK_type)
- }
-| EXC_REF string END {
- let s2 = remove_beginning_blanks $2 in
- let s3 = remove_trailing_blanks s2 in
- Ref (s3, Some RK_exception)
- }
-| MOD_REF string END {
- let s2 = remove_beginning_blanks $2 in
- let s3 = remove_trailing_blanks s2 in
- Ref (s3, Some RK_module)
- }
-| MODT_REF string END {
- let s2 = remove_beginning_blanks $2 in
- let s3 = remove_trailing_blanks s2 in
- Ref (s3, Some RK_module_type)
- }
-| CLA_REF string END {
- let s2 = remove_beginning_blanks $2 in
- let s3 = remove_trailing_blanks s2 in
- Ref (s3, Some RK_class)
- }
-| CLT_REF string END {
- let s2 = remove_beginning_blanks $2 in
- let s3 = remove_trailing_blanks s2 in
- Ref (s3, Some RK_class_type)
- }
-| ATT_REF string END {
- let s2 = remove_beginning_blanks $2 in
- let s3 = remove_trailing_blanks s2 in
- Ref (s3, Some RK_attribute)
- }
-| MET_REF string END {
- let s2 = remove_beginning_blanks $2 in
- let s3 = remove_trailing_blanks s2 in
- Ref (s3, Some RK_method)
- }
-| SEC_REF string END {
- let s2 = remove_beginning_blanks $2 in
- let s3 = remove_trailing_blanks s2 in
- Ref (s3, Some (RK_section []))
- }
-| VERB string END_VERB { Verbatim $2 }
-| LATEX string END_LATEX { Latex $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 { [] (* A VOIR : un test pour voir qu'il n'y a que des blancs *) }
-| 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
deleted file mode 100644
index a80eb3889a..0000000000
--- a/ocamldoc/odoc_to_text.ml
+++ /dev/null
@@ -1,537 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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
-open Parameter
-
-(** 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 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) =
- 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
- t_ref
-
- (** 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_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
- let s2 = Str.global_substitute
- (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)")
- f
- s
- in
- s2
-
- (** Get a string for a [Types.class_type] where all idents are relative. *)
- method normal_class_type m_name t =
- (self#relative_idents m_name (Odoc_info.string_of_class_type t))
-
- (** Get a string for a [Types.module_type] where all idents are relative. *)
- method normal_module_type m_name t =
- (self#relative_idents m_name (Odoc_info.string_of_module_type t))
-
- (** Get a string for a type where all idents are relative. *)
- method normal_type m_name t =
- (self#relative_idents m_name (Odoc_info.string_of_type_expr t))
-
- (** Get a string for a list of types where all idents are relative. *)
- method normal_type_list m_name sep t =
- (self#relative_idents m_name (Odoc_info.string_of_type_list sep t))
-
- (** Get a string for a list of class or class type type parameters
- where all idents are relative. *)
- method normal_class_type_param_list m_name t =
- (self#relative_idents m_name (Odoc_info.string_of_class_type_param_list t))
-
- (** @return [text] value to represent a [Types.type_expr].*)
- method text_of_type_expr module_name t =
- let t = List.flatten
- (List.map
- (fun s -> [Code s ; Newline ])
- (Str.split (Str.regexp "\n")
- (self#normal_type module_name t))
- )
- in
- 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 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 s_name = Name.simple v.val_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"
- (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
- Format.fprintf Format.str_formatter "@[<hov 2>exception %s" s_name ;
- (match e.ex_args with
- [] -> ()
- | _ ->
- Format.fprintf Format.str_formatter "@ of "
- );
- let s = self#normal_type_list (Name.father e.ex_name) " * " e.ex_args in
- let s2 =
- Format.fprintf Format.str_formatter "%s" s ;
- (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
- )
- );
- 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) ->
- [Code (p.mp_name^" : ")] @
- (self#text_of_module_type p.mp_type) @
- (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)
-
- (** Return html code for a [module_type_kind]. *)
- method text_of_module_type_kind ?(with_def_syntax=true) tk =
- match tk with
- | Module_type_struct _ ->
- [Code ((if with_def_syntax then " = " else "")^Odoc_messages.sig_end)]
-
- | Module_type_functor (params, k) ->
- let f p =
- [Code ("("^p.mp_name^" : ")] @
- (self#text_of_module_type p.mp_type) @
- [Code ") -> "]
- in
- let t1 = List.flatten (List.map f params) in
- let t2 = self#text_of_module_type_kind ~with_def_syntax: false k in
- (if with_def_syntax then [Code " = "] else []) @ t1 @ t2
-
- | 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))
- ]
-
- end
diff --git a/ocamldoc/odoc_type.ml b/ocamldoc/odoc_type.ml
deleted file mode 100644
index bcf194d143..0000000000
--- a/ocamldoc/odoc_type.ml
+++ /dev/null
@@ -1,52 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Representation and manipulation of a type, but not class nor module type.*)
-
-module Name = Odoc_name
-
-(** Description of a variant type constructor. *)
-type variant_constructor = {
- vc_name : string ;
- vc_args : Types.type_expr list ; (** arguments of the constructor *)
- mutable vc_text : Odoc_types.text option ; (** optional user description *)
- }
-
-(** 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.text option ; (** optional user description *)
- }
-
-(** The various kinds of type. *)
-type type_kind =
- Type_abstract
- | Type_variant of variant_constructor list * bool
- (** constructors * bool *)
- | Type_record of record_field list * bool
- (** fields * bool *)
-
-(** 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_manifest : Types.type_expr option; (** type manifest *)
- mutable ty_loc : Odoc_types.location ;
- mutable ty_code : string option;
- }
-
diff --git a/ocamldoc/odoc_types.ml b/ocamldoc/odoc_types.ml
deleted file mode 100644
index fd8938ed69..0000000000
--- a/ocamldoc/odoc_types.ml
+++ /dev/null
@@ -1,130 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-type ref_kind =
- RK_module
- | RK_module_type
- | RK_class
- | RK_class_type
- | RK_value
- | RK_type
- | RK_exception
- | RK_attribute
- | RK_method
- | RK_section of text
-
-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
- | Superscript of text
- | Subscript of text
-
-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_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_deprecated = None ;
- i_params = [] ;
- i_raised_exceptions = [] ;
- i_return_value = None ;
- i_custom = [] ;
-}
-
-type location = {
- loc_impl : (string * int) option ;
- loc_inter : (string * int) option ;
- }
-
-let dummy_loc = { loc_impl = None ; loc_inter = None }
-
-type merge_option =
- | Merge_description
- | Merge_author
- | Merge_version
- | Merge_see
- | Merge_since
- | 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_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
deleted file mode 100644
index 61e8db7b26..0000000000
--- a/ocamldoc/odoc_types.mli
+++ /dev/null
@@ -1,130 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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_exception
- | RK_attribute
- | RK_method
- | RK_section of text
-
-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
- (** A reference to an element. Complete name and kind. *)
- | Superscript of text (** Superscripts. *)
- | Subscript of text (** Subscripts. *)
-
-(** [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_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 : (string * int) option ; (** implementation file name and position *)
- loc_inter : (string * int) option ; (** interface file name and position *)
- }
-
-(** 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_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
deleted file mode 100644
index b001f1464f..0000000000
--- a/ocamldoc/odoc_value.ml
+++ /dev/null
@@ -1,133 +0,0 @@
-(***********************************************************************)
-(* OCamldoc *)
-(* *)
-(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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 ;
- }
-
-(** 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)
- | _ ->
- []
- 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 s =
- match s with
- "" -> s
- | _ ->
- match s.[0] with
- '?' -> String.sub s 1 ((String.length s) - 1)
- | _ -> s
- 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 ->
- if label = "" then
- Odoc_parameter.Tuple
- (List.map (fun t2 -> iter ("", 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
deleted file mode 100755
index 99ab8972f4..0000000000
--- a/ocamldoc/remove_DEBUG
+++ /dev/null
@@ -1,8 +0,0 @@
-#!/bin/sh
-
-# usage: remove_DEBUG <file>
-# remove from <file> every line that contains the string "DEBUG",
-# respecting the cpp # line annotation conventions
-
-echo "# 1 \"$1\""
-sed -e '/DEBUG/s/.*//' "$1"
diff --git a/ocamldoc/runocamldoc b/ocamldoc/runocamldoc
deleted file mode 100644
index a71d705ccd..0000000000
--- a/ocamldoc/runocamldoc
+++ /dev/null
@@ -1,12 +0,0 @@
-#!/bin/sh
-# $Id$
-
-case "$1" in
- true) shift
- exec ../boot/ocamlrun -I ../otherlibs/unix -I ../otherlibs/str \
- ./ocamldoc "$@"
- ;;
- *) shift
- exec ./ocamldoc "$@"
- ;;
-esac
diff --git a/otherlibs/bigarray/.cvsignore b/otherlibs/bigarray/.cvsignore
deleted file mode 100644
index c54b3a3580..0000000000
--- a/otherlibs/bigarray/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-*.o
-*.x
-so_locations
diff --git a/otherlibs/bigarray/.depend b/otherlibs/bigarray/.depend
deleted file mode 100644
index 7c4e124ea6..0000000000
--- a/otherlibs/bigarray/.depend
+++ /dev/null
@@ -1,17 +0,0 @@
-bigarray_stubs.o: bigarray_stubs.c ../../byterun/alloc.h \
- ../../byterun/misc.h ../../byterun/config.h ../../config/m.h \
- ../../config/s.h ../../byterun/mlvalues.h bigarray.h \
- ../../byterun/custom.h ../../byterun/fail.h ../../byterun/intext.h \
- ../../byterun/io.h ../../byterun/fix_code.h ../../byterun/memory.h \
- ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
- ../../byterun/minor_gc.h
-mmap_unix.o: mmap_unix.c bigarray.h ../../byterun/mlvalues.h \
- ../../byterun/config.h ../../config/m.h ../../config/s.h \
- ../../byterun/misc.h ../../byterun/custom.h ../../byterun/fail.h \
- ../../byterun/sys.h
-mmap_win32.o: mmap_win32.c bigarray.h ../../byterun/mlvalues.h \
- ../../byterun/config.h ../../config/m.h ../../config/s.h \
- ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/custom.h \
- ../../byterun/fail.h ../../byterun/sys.h ../unix/unixsupport.h
-bigarray.cmo: bigarray.cmi
-bigarray.cmx: bigarray.cmi
diff --git a/otherlibs/bigarray/Makefile b/otherlibs/bigarray/Makefile
deleted file mode 100644
index 715428fca6..0000000000
--- a/otherlibs/bigarray/Makefile
+++ /dev/null
@@ -1,74 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-include ../../config/Makefile
-
-CC=$(BYTECC)
-CFLAGS=-I../../byterun -g -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS)
-CAMLC=../../ocamlcomp.sh -I ../unix
-CAMLOPT=../../ocamlcompopt.sh -I ../unix
-MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib
-COMPFLAGS=-warn-error A
-
-C_OBJS=bigarray_stubs.o mmap_unix.o
-
-CAML_OBJS=bigarray.cmo
-
-all: libbigarray.a bigarray.cma
-
-allopt: libbigarray.a bigarray.cmxa
-
-libbigarray.a: $(C_OBJS)
- $(MKLIB) -o bigarray $(C_OBJS)
-
-bigarray.cma: $(CAML_OBJS)
- $(MKLIB) -ocamlc '$(CAMLC)' -linkall -o bigarray $(CAML_OBJS)
-
-bigarray.cmxa: $(CAML_OBJS:.cmo=.cmx)
- $(MKLIB) -ocamlopt '$(CAMLOPT)' -linkall -o bigarray \
- $(CAML_OBJS:.cmo=.cmx)
-
-install:
- if test -f dllbigarray.so; then cp dllbigarray.so $(STUBLIBDIR)/dllbigarray.so; fi
- cp bigarray.cmi bigarray.mli libbigarray.a bigarray.cma $(LIBDIR)
- cd $(LIBDIR); $(RANLIB) libbigarray.a
- cp bigarray.h $(LIBDIR)/caml/bigarray.h
-
-installopt:
- cp bigarray.a $(CAML_OBJS:.cmo=.cmx) bigarray.cmxa $(LIBDIR)
- cd $(LIBDIR); $(RANLIB) bigarray.a
-
-partialclean:
- rm -f *.cm*
-
-clean: partialclean
- rm -f libbigarray.* *.o bigarray.a *.so
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.mli.cmi:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-depend:
- gcc -MM -I../../byterun -I../unix *.c > .depend
- ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend
-
-include .depend
diff --git a/otherlibs/bigarray/Makefile.Mac b/otherlibs/bigarray/Makefile.Mac
deleted file mode 100644
index 7f449f9974..0000000000
--- a/otherlibs/bigarray/Makefile.Mac
+++ /dev/null
@@ -1,53 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Damien Doligez, projet Moscova, INRIA Rocquencourt #
-# #
-# Copyright 2000 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-PPCC = mrc
-PPCCOptions = -i :::byterun:,:::config: -w 35 {cdbgflag}
-
-CAMLC = :::boot:ocamlrun :::ocamlc -I :::stdlib: -I ::unix:
-
-PPCC_OBJS = bigarray_stubs.c.x mmap_unix.c.x
-
-CAML_OBJS = bigarray.cmo
-
-all Ä libbigarray.x bigarray.cma
-
-libbigarray.x Ä {PPCC_OBJS}
- ppclink {ldbgflag} -xm library -o libbigarray.x {PPCC_OBJS}
-
-bigarray.cma Ä {CAML_OBJS}
- {CAMLC} -a -linkall -o bigarray.cma {CAML_OBJS}
-
-install Ä
- duplicate -y bigarray.cmi bigarray.mli libbigarray.x ¶
- bigarray.cma "{LIBDIR}"
-
-partialclean Ä
- delete -y Å.cmÅ || set status 0
-
-clean Ä partialclean
- delete -i Å.x || set status 0
-
-.cmi Ä .mli
- {CAMLC} -c {COMPFLAGS} {depdir}{default}.mli
-
-.cmo Ä .ml
- {CAMLC} -c {COMPFLAGS} {depdir}{default}.ml
-
-depend Ä
- begin
- MakeDepend -w -objext .x Å.c
- :::boot:ocamlrun :::tools:ocamldep -I :::stdlib: -I ::unix: Å.mli Å.ml
- end | streamedit -e "/¶t/ replace // ' ' -c °" > Makefile.Mac.depend
diff --git a/otherlibs/bigarray/Makefile.Mac.depend b/otherlibs/bigarray/Makefile.Mac.depend
deleted file mode 100644
index b2608cbede..0000000000
--- a/otherlibs/bigarray/Makefile.Mac.depend
+++ /dev/null
@@ -1,42 +0,0 @@
-#*** Dependencies: Cut here ***
-# These dependencies were produced at 20:33:17 on Tue, Aug 21, 2001 by MakeDepend
-
-:bigarray_stubs.c.x Ä ¶
- :bigarray_stubs.c ¶
- "{CIncludes}"stddef.h ¶
- "{CIncludes}"stdarg.h ¶
- "{CIncludes}"string.h ¶
- :bigarray.h ¶
- "{CIncludes}"memory.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"WCharTDef.h ¶
- "{CIncludes}"VaListTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:mmap_unix.c.x Ä ¶
- :mmap_unix.c ¶
- "{CIncludes}"stddef.h ¶
- "{CIncludes}"string.h ¶
- :bigarray.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"WCharTDef.h
-
-:mmap_win32.c.x Ä ¶
- :mmap_win32.c ¶
- "{CIncludes}"stddef.h ¶
- "{CIncludes}"string.h ¶
- :bigarray.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"WCharTDef.h
-
-bigarray.cmiÄ ::unix:unix.cmi
-bigarray.cmoÄ :::stdlib:array.cmi :::stdlib:obj.cmi ::unix:unix.cmi ¶
- bigarray.cmi
-bigarray.cmxÄ :::stdlib:array.cmx :::stdlib:obj.cmx ::unix:unix.cmx ¶
- bigarray.cmi
diff --git a/otherlibs/bigarray/Makefile.nt b/otherlibs/bigarray/Makefile.nt
deleted file mode 100644
index b4a8dc3058..0000000000
--- a/otherlibs/bigarray/Makefile.nt
+++ /dev/null
@@ -1,84 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-include ../../config/Makefile
-
-CC=$(BYTECC)
-CFLAGS=-I../../byterun -I../win32unix -DIN_OCAML_BIGARRAY
-CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib -I ../win32unix
-CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -I ../win32unix
-
-C_OBJS=bigarray_stubs.obj mmap_win32.obj
-
-CAML_OBJS=bigarray.cmo
-
-all: dllbigarray.dll libbigarray.$(A) bigarray.cma
-
-allopt: libbigarray.$(A) bigarray.cmxa
-
-dllbigarray.dll: $(C_OBJS:.obj=.$(DO))
- $(call MKDLL,dllbigarray.dll,dllbigarray.$(A),\
- $(C_OBJS:.obj=.$(DO)) ../../byterun/ocamlrun.$(A))
-
-libbigarray.$(A): $(C_OBJS:.obj=.$(SO))
- $(call MKLIB,libbigarray.$(A),$(C_OBJS:.obj=.$(SO)))
-
-bigarray.cma: $(CAML_OBJS)
- $(CAMLC) -a -linkall -o bigarray.cma $(CAML_OBJS) \
- -dllib -lbigarray -cclib -lbigarray
-
-bigarray.cmxa: $(CAML_OBJS:.cmo=.cmx)
- $(CAMLOPT) -a -linkall -o bigarray.cmxa \
- $(CAML_OBJS:.cmo=.cmx) -cclib -lbigarray
-
-install:
- cp dllbigarray.dll $(STUBLIBDIR)
- cp libbigarray.$(A) dllbigarray.$(A) $(LIBDIR)
- cp bigarray.cmi bigarray.mli bigarray.cma $(LIBDIR)
- cp bigarray.h $(LIBDIR)/caml/bigarray.h
-
-installopt:
- cp bigarray.$(A) $(CAML_OBJS:.cmo=.cmx) bigarray.cmxa $(LIBDIR)
-
-partialclean:
- rm -f *.cm*
-
-clean: partialclean
- rm -f *.dll *.$(A) *.$(O)
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx .$(DO) .$(SO)
-
-.mli.cmi:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-.c.$(DO):
- $(BYTECC) $(DLLCCCOMPOPTS) $(CFLAGS) -c $<
- mv $*.$(O) $*.$(DO)
-
-.c.$(SO):
- $(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c $<
- mv $*.$(O) $*.$(SO)
-
-depend:
- gcc -MM $(CFLAGS) *.c > .depend
- ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend
-
-include .depend
diff --git a/otherlibs/bigarray/bigarray.h b/otherlibs/bigarray/bigarray.h
deleted file mode 100644
index 17b2dfe430..0000000000
--- a/otherlibs/bigarray/bigarray.h
+++ /dev/null
@@ -1,81 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */
-/* */
-/* Copyright 2000 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#ifndef _bigarray_
-#define _bigarray_
-
-
-#include "mlvalues.h"
-
-#define MAX_NUM_DIMS 16
-
-enum caml_bigarray_kind {
- BIGARRAY_FLOAT32, /* Single-precision floats */
- BIGARRAY_FLOAT64, /* Double-precision floats */
- BIGARRAY_SINT8, /* Signed 8-bit integers */
- BIGARRAY_UINT8, /* Unsigned 8-bit integers */
- BIGARRAY_SINT16, /* Signed 16-bit integers */
- BIGARRAY_UINT16, /* Unsigned 16-bit integers */
- BIGARRAY_INT32, /* Signed 32-bit integers */
- BIGARRAY_INT64, /* Signed 64-bit integers */
- BIGARRAY_CAML_INT, /* Caml-style integers (signed 31 or 63 bits) */
- BIGARRAY_NATIVE_INT, /* Platform-native long integers (32 or 64 bits) */
- BIGARRAY_COMPLEX32, /* Single-precision complex */
- BIGARRAY_COMPLEX64, /* Double-precision complex */
- BIGARRAY_KIND_MASK = 0xFF /* Mask for kind in flags field */
-};
-
-enum caml_bigarray_layout {
- BIGARRAY_C_LAYOUT = 0, /* Row major, indices start at 0 */
- BIGARRAY_FORTRAN_LAYOUT = 0x100, /* Column major, indices start at 1 */
- BIGARRAY_LAYOUT_MASK = 0x100 /* Mask for layout in flags field */
-};
-
-enum caml_bigarray_managed {
- BIGARRAY_EXTERNAL = 0, /* Data is not allocated by Caml */
- BIGARRAY_MANAGED = 0x200, /* Data is allocated by Caml */
- BIGARRAY_MAPPED_FILE = 0x400, /* Data is a memory mapped file */
- BIGARRAY_MANAGED_MASK = 0x600 /* Mask for "managed" bits in flags field */
-};
-
-struct caml_bigarray_proxy {
- long refcount; /* Reference count */
- void * data; /* Pointer to base of actual data */
- unsigned long size; /* Size of data in bytes (if mapped file) */
-};
-
-struct caml_bigarray {
- void * data; /* Pointer to raw data */
- long num_dims; /* Number of dimensions */
- long flags; /* Kind of element array + memory layout + allocation status */
- struct caml_bigarray_proxy * proxy; /* The proxy for sub-arrays, or NULL */
- long dim[1] /*[num_dims]*/; /* Size in each dimension */
-};
-
-#define Bigarray_val(v) ((struct caml_bigarray *) Data_custom_val(v))
-
-#define Data_bigarray_val(v) (Bigarray_val(v)->data)
-
-#if defined(IN_OCAML_BIGARRAY)
-#define CAMLBAextern CAMLexport
-#else
-#define CAMLBAextern CAMLextern
-#endif
-
-CAMLBAextern value alloc_bigarray(int flags, int num_dims, void * data, long * dim);
-CAMLBAextern value alloc_bigarray_dims(int flags, int num_dims, void * data,
- ... /*dimensions, with type long */);
-
-#endif
diff --git a/otherlibs/bigarray/bigarray.ml b/otherlibs/bigarray/bigarray.ml
deleted file mode 100644
index adfb5847b2..0000000000
--- a/otherlibs/bigarray/bigarray.ml
+++ /dev/null
@@ -1,226 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* 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 Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Module [Bigarray]: large, multi-dimensional, numerical arrays *)
-
-external init : unit -> unit = "bigarray_init"
-
-let _ = init()
-
-type ('a, 'b) kind = int
-
-type int8_signed_elt
-type int8_unsigned_elt
-type int16_signed_elt
-type int16_unsigned_elt
-type int_elt
-type int32_elt
-type int64_elt
-type nativeint_elt
-type float32_elt
-type float64_elt
-type complex32_elt
-type complex64_elt
-
-(* Keep those constants in sync with the caml_bigarray_kind enumeration
- in bigarray.h *)
-
-let float32 = 0
-let float64 = 1
-let int8_signed = 2
-let int8_unsigned = 3
-let int16_signed = 4
-let int16_unsigned = 5
-let int32 = 6
-let int64 = 7
-let int = 8
-let nativeint = 9
-let char = int8_unsigned
-let complex32 = 10
-let complex64 = 11
-
-type 'a layout = int
-
-type c_layout
-type fortran_layout
-
-(* Keep those constants in sync with the caml_bigarray_layout enumeration
- in bigarray.h *)
-
-let c_layout = 0
-let fortran_layout = 0x100
-
-module Genarray = struct
- type ('a, 'b, 'c) t
- external create: ('a, 'b) kind -> 'c layout -> int array -> ('a, 'b, 'c) t
- = "bigarray_create"
- external get: ('a, 'b, 'c) t -> int array -> 'a
- = "bigarray_get_generic"
- external set: ('a, 'b, 'c) t -> int array -> 'a -> unit
- = "bigarray_set_generic"
- external num_dims: ('a, 'b, 'c) t -> int = "bigarray_num_dims"
- external nth_dim: ('a, 'b, 'c) t -> int -> int = "bigarray_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 = "bigarray_kind"
- external layout: ('a, 'b, 'c) t -> 'c layout = "bigarray_layout"
-
- external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
- = "bigarray_sub"
- external sub_right: ('a, 'b, fortran_layout) t -> int -> int ->
- ('a, 'b, fortran_layout) t
- = "bigarray_sub"
- external slice_left: ('a, 'b, c_layout) t -> int array ->
- ('a, 'b, c_layout) t
- = "bigarray_slice"
- external slice_right: ('a, 'b, fortran_layout) t -> int array ->
- ('a, 'b, fortran_layout) t
- = "bigarray_slice"
- external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit
- = "bigarray_blit"
- external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill"
- external map_file: Unix.file_descr -> ('a, 'b) kind -> 'c layout ->
- bool -> int array -> ('a, 'b, 'c) t
- = "bigarray_map_file"
-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 = "%bigarray_ref_1"
- external set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%bigarray_set_1"
- let dim a = Genarray.nth_dim a 0
- external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "bigarray_kind"
- external layout: ('a, 'b, 'c) t -> 'c layout = "bigarray_layout"
- external sub: ('a, 'b, 'c) t -> int -> int -> ('a, 'b, 'c) t = "bigarray_sub"
- external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "bigarray_blit"
- external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill"
- let of_array kind layout data =
- let ba = create kind layout (Array.length data) in
- let ofs = if (Obj.magic layout : 'a layout) = c_layout then 0 else 1 in
- for i = 0 to Array.length data - 1 do set ba (i + ofs) data.(i) done;
- ba
- let map_file fd kind layout shared dim =
- Genarray.map_file fd 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 = "%bigarray_ref_2"
- external set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%bigarray_set_2"
- let dim1 a = Genarray.nth_dim a 0
- let dim2 a = Genarray.nth_dim a 1
- external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "bigarray_kind"
- external layout: ('a, 'b, 'c) t -> 'c layout = "bigarray_layout"
- external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "bigarray_sub"
- external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t = "bigarray_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 = "bigarray_blit"
- external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill"
- let of_array kind 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 = if (Obj.magic layout : 'a layout) = c_layout then 0 else 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
- set ba (i + ofs) (j + ofs) row.(j)
- done
- done;
- ba
- let map_file fd kind layout shared dim1 dim2 =
- Genarray.map_file fd 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 = "%bigarray_ref_3"
- external set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit = "%bigarray_set_3"
- let dim1 a = Genarray.nth_dim a 0
- let dim2 a = Genarray.nth_dim a 1
- let dim3 a = Genarray.nth_dim a 2
- external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "bigarray_kind"
- external layout: ('a, 'b, 'c) t -> 'c layout = "bigarray_layout"
- external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "bigarray_sub"
- external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t = "bigarray_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 = "bigarray_blit"
- external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill"
- let of_array kind 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 = if (Obj.magic layout : 'a layout) = c_layout then 0 else 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
- set ba (i + ofs) (j + ofs) (k + ofs) col.(j)
- done
- done
- done;
- ba
- let map_file fd kind layout shared dim1 dim2 dim3 =
- Genarray.map_file fd kind layout shared [|dim1;dim2;dim3|]
-end
-
-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 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
- = "bigarray_reshape"
-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 bigarray_get_{1,2,3,N} to be linked in, since we don't refer
- to those primitives directly in this file *)
-
-let _ =
- let getN = Genarray.get in
- let get1 = Array1.get in
- let get2 = Array2.get in
- let get3 = Array3.get in
- ()
-
diff --git a/otherlibs/bigarray/bigarray.mli b/otherlibs/bigarray/bigarray.mli
deleted file mode 100644
index e2ce03de67..0000000000
--- a/otherlibs/bigarray/bigarray.mli
+++ /dev/null
@@ -1,756 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2000 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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 Caml 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 Caml ad-hoc polymorphic operations:
- - comparisons ([=], [<>], [<=], etc, as well as {!Pervasives.compare});
- - hashing (module [Hash]);
- - and structured input-output ({!Pervasives.output_value}
- and {!Pervasives.input_value}, as well as the functions from the
- {!Marshal} module).
-*)
-
-(** {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}),
-- Caml integers (signed, 31 bits on 32-bit architectures,
- 63 bits on 64-bit architectures) ({!Bigarray.int_elt}),
-- 32-bit signed integer ({!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 abstract types defined below.
-*)
-
-type float32_elt
-type float64_elt
-type complex32_elt
-type complex64_elt
-type int8_signed_elt
-type int8_unsigned_elt
-type int16_signed_elt
-type int16_unsigned_elt
-type int_elt
-type int32_elt
-type int64_elt
-type nativeint_elt
-
-type ('a, 'b) kind
-(** To each element kind is associated a Caml type, which is
- the type of Caml 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 Caml uses the Caml type [float], which is
- 64-bit double precision floats.
-
- The abstract type [('a, 'b) kind] captures this association
- of a Caml 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. The following predefined values of type
- [kind] list all possible associations of Caml types with
- element kinds: *)
-
-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 Caml type [float]. Big arrays of complex kinds
- [complex32_elt], [complex64_elt] are accessed with the Caml type
- {!Complex.t}. Big arrays of
- integer kinds are accessed using the smallest Caml integer
- type large enough to represent the array elements:
- [int] for 8- and 16-bit integer bigarrays, as well as Caml-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]. *)
-
-(** {6 Array layouts} *)
-
-type c_layout
-(** See {!Bigarray.fortran_layout}.*)
-
-type fortran_layout
-(** 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
- abstract types {!Bigarray.c_layout} and [fortran_layout] respectively. *)
-
-type 'a layout
-(** The type ['a layout] represents one of the two supported
- memory layouts: C-style if ['a] is {!Bigarray.c_layout}, Fortran-style
- if ['a] is {!Bigarray.fortran_layout}. *)
-
-
-(** {7 Supported layouts}
-
- The abstract values [c_layout] and [fortran_layout] represent
- the two supported layouts at the level of values.
-*)
-
-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 1 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 Caml 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
- Caml type [float]. *)
-
- external create: ('a, 'b) kind -> 'c layout -> int array -> ('a, 'b, 'c) t
- = "bigarray_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_arg] if the number of dimensions
- is not in the range 1 to 16 inclusive, or if one of the dimensions
- is negative. *)
-
- external num_dims: ('a, 'b, 'c) t -> int = "bigarray_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 = "bigarray_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_arg] if [n] is less than 0 or greater or equal than
- [Genarray.num_dims a]. *)
-
- external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "bigarray_kind"
- (** Return the kind of the given big array. *)
-
- external layout: ('a, 'b, 'c) t -> 'c layout = "bigarray_layout"
- (** Return the layout of the given big array. *)
-
- external get: ('a, 'b, 'c) t -> int array -> 'a = "bigarray_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_arg] 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
- = "bigarray_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_arg] 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
- = "bigarray_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_arg] 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
- = "bigarray_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_arg] 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
- = "bigarray_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_arg] 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
- = "bigarray_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_arg] if [M >= N], or if [[|i1; ... ; iM|]]
- is outside the bounds of [a]. *)
-
- external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit
- = "bigarray_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 = "bigarray_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]. *)
-
- external map_file:
- Unix.file_descr -> ('a, 'b) kind -> 'c layout ->
- bool -> int array -> ('a, 'b, 'c) t = "bigarray_map_file"
- (** 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). 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]. *)
-
- 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
- Caml 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]. *)
-
- val dim: ('a, 'b, 'c) t -> int
- (** Return the size (dimension) of the given one-dimensional
- big array. *)
-
- external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "bigarray_kind"
- (** Return the kind of the given big array. *)
-
- external layout: ('a, 'b, 'c) t -> 'c layout = "bigarray_layout"
- (** Return the layout of the given big array. *)
-
- external get: ('a, 'b, 'c) t -> int -> 'a = "%bigarray_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_arg] is raised. *)
-
- external set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%bigarray_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_arg] is raised. *)
-
- external sub: ('a, 'b, 'c) t -> int -> int -> ('a, 'b, 'c) t
- = "bigarray_sub"
- (** Extract a sub-array of the given one-dimensional big array.
- See [Genarray.sub_left] for more details. *)
-
- external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit
- = "bigarray_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 = "bigarray_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 -> ('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. *)
-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
- Caml 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}. *)
-
- val dim1: ('a, 'b, 'c) t -> int
- (** Return the first dimension of the given two-dimensional big array. *)
-
- val dim2: ('a, 'b, 'c) t -> int
- (** Return the second dimension of the given two-dimensional big array. *)
-
- external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "bigarray_kind"
- (** Return the kind of the given big array. *)
-
- external layout: ('a, 'b, 'c) t -> 'c layout = "bigarray_layout"
- (** Return the layout of the given big array. *)
-
- external get: ('a, 'b, 'c) t -> int -> int -> 'a = "%bigarray_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_arg] is raised. *)
-
- external set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%bigarray_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_arg] is raised. *)
-
- external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
- = "bigarray_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
- = "bigarray_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
- = "bigarray_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 = "bigarray_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 -> ('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. *)
-
- 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
- Caml 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}. *)
-
- val dim1: ('a, 'b, 'c) t -> int
- (** Return the first dimension of the given three-dimensional big array. *)
-
- val dim2: ('a, 'b, 'c) t -> int
- (** Return the second dimension of the given three-dimensional big array. *)
-
- val dim3: ('a, 'b, 'c) t -> int
- (** Return the third dimension of the given three-dimensional big array. *)
-
- external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "bigarray_kind"
- (** Return the kind of the given big array. *)
-
- external layout: ('a, 'b, 'c) t -> 'c layout = "bigarray_layout"
- (** Return the layout of the given big array. *)
-
- external get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%bigarray_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_arg] is raised. *)
-
- external set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit
- = "%bigarray_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_arg] is raised. *)
-
- external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
- = "bigarray_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
- = "bigarray_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
- = "bigarray_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 = "bigarray_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 -> ('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. *)
-
- end
-
-(** {6 Coercions between generic big arrays and fixed-dimension big arrays} *)
-
-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 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_arg] 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_arg] 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_arg] 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_arg] is raised. *)
-
-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
deleted file mode 100644
index 969c111b12..0000000000
--- a/otherlibs/bigarray/bigarray_stubs.c
+++ /dev/null
@@ -1,1073 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */
-/* */
-/* Copyright 2000 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <stddef.h>
-#include <stdarg.h>
-#include <string.h>
-#include "alloc.h"
-#include "bigarray.h"
-#include "custom.h"
-#include "fail.h"
-#include "intext.h"
-#include "memory.h"
-#include "mlvalues.h"
-
-CAMLextern int compare_unordered; /* from byterun/compare.c */
-
-extern void bigarray_unmap_file(void * addr, unsigned long len);
- /* from mmap_xxx.c */
-
-/* Compute the number of elements of a big array */
-
-static unsigned long bigarray_num_elts(struct caml_bigarray * b)
-{
- unsigned long 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 bigarray_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*/
-};
-
-/* Compute the number of bytes for the elements of a big array */
-
-unsigned long bigarray_byte_size(struct caml_bigarray * b)
-{
- return bigarray_num_elts(b)
- * bigarray_element_size[b->flags & BIGARRAY_KIND_MASK];
-}
-
-/* Operation table for bigarrays */
-
-static void bigarray_finalize(value v);
-static int bigarray_compare(value v1, value v2);
-static long bigarray_hash(value v);
-static void bigarray_serialize(value, unsigned long *, unsigned long *);
-unsigned long bigarray_deserialize(void * dst);
-static struct custom_operations bigarray_ops = {
- "_bigarray",
- bigarray_finalize,
- bigarray_compare,
- bigarray_hash,
- bigarray_serialize,
- bigarray_deserialize
-};
-
-/* Multiplication of unsigned longs with overflow detection */
-
-static unsigned long
-bigarray_multov(unsigned long a, unsigned long b, int * overflow)
-{
-#define HALF_SIZE (sizeof(unsigned long) * 4)
-#define LOW_HALF(x) ((x) & ((1UL << HALF_SIZE) - 1))
-#define HIGH_HALF(x) ((x) >> HALF_SIZE)
- /* Cut in half words */
- unsigned long al = LOW_HALF(a);
- unsigned long ah = HIGH_HALF(a);
- unsigned long bl = LOW_HALF(b);
- unsigned long bh = HIGH_HALF(b);
- /* Exact product is:
- al * bl
- + ah * bl << HALF_SIZE
- + al * bh << HALF_SIZE
- + ah * bh << 2*HALF_SIZE
- Overflow occurs if:
- ah * bh is not 0, i.e. ah != 0 and bh != 0
- OR ah * bl has high half != 0
- OR ah * bl has high half != 0
- OR the sum al * bl + LOW_HALF(ah * bl) << HALF_SIZE
- + LOW_HALF(al * bh) << HALF_SIZE overflows.
- This sum is equal to p = (a * b) modulo word size. */
- unsigned long p1 = al * bh;
- unsigned long p2 = ah * bl;
- unsigned long p = a * b;
- if (ah != 0 && bh != 0) *overflow = 1;
- if (p1 >= (1UL << HALF_SIZE) || p2 >= (1UL << HALF_SIZE)) *overflow = 1;
- p1 <<= HALF_SIZE;
- p2 <<= HALF_SIZE;
- p1 += p2;
- if (p < p1 || p1 < p2) *overflow = 1; /* overflow in sums */
- return p;
-#undef HALF_SIZE
-#undef LOW_HALF
-#undef HIGH_HALF
-}
-
-/* Allocation of a big array */
-
-#define MAX_BIGARRAY_MEMORY 256*1024*1024
-/* 256 Mb -- after allocating that much, it's probably worth speeding
- up the major GC */
-
-/* [alloc_bigarray] will allocate a new bigarray object in the heap.
- If [data] is NULL, the memory for the contents is also allocated
- (with [malloc]) by [alloc_bigarray].
- [data] cannot point into the Caml heap.
- [dim] may point into an object in the Caml heap.
-*/
-CAMLexport value
-alloc_bigarray(int flags, int num_dims, void * data, long * dim)
-{
- unsigned long num_elts, size;
- int overflow, i;
- value res;
- struct caml_bigarray * b;
- long dimcopy[MAX_NUM_DIMS];
-
- Assert(num_dims >= 1 && num_dims <= MAX_NUM_DIMS);
- Assert((flags & BIGARRAY_KIND_MASK) <= BIGARRAY_COMPLEX64);
- 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 = bigarray_multov(num_elts, dimcopy[i], &overflow);
- }
- size = bigarray_multov(num_elts,
- bigarray_element_size[flags & BIGARRAY_KIND_MASK],
- &overflow);
- if (overflow) raise_out_of_memory();
- data = malloc(size);
- if (data == NULL && size != 0) raise_out_of_memory();
- flags |= BIGARRAY_MANAGED;
- }
- res = alloc_custom(&bigarray_ops,
- sizeof(struct caml_bigarray)
- + (num_dims - 1) * sizeof(long),
- size, MAX_BIGARRAY_MEMORY);
- b = Bigarray_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 alloc_bigarray, but dimensions are passed as a list of
- arguments */
-
-CAMLexport value alloc_bigarray_dims(int flags, int num_dims, void * data, ...)
-{
- va_list ap;
- long dim[MAX_NUM_DIMS];
- int i;
- value res;
-
- va_start(ap, data);
- for (i = 0; i < num_dims; i++) dim[i] = va_arg(ap, long);
- va_end(ap);
- res = alloc_bigarray(flags, num_dims, data, dim);
- return res;
-}
-
-/* Allocate a bigarray from Caml */
-
-CAMLprim value bigarray_create(value vkind, value vlayout, value vdim)
-{
- long dim[MAX_NUM_DIMS];
- mlsize_t num_dims;
- int i, flags;
-
- num_dims = Wosize_val(vdim);
- if (num_dims < 1 || num_dims > MAX_NUM_DIMS)
- 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 || dim[i] > 0x7FFFFFFFL)
- invalid_argument("Bigarray.create: negative dimension");
- }
- flags = Int_val(vkind) | Int_val(vlayout);
- return alloc_bigarray(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 bigarray_offset(struct caml_bigarray * b, long * index)
-{
- long offset;
- int i;
-
- offset = 0;
- if ((b->flags & BIGARRAY_LAYOUT_MASK) == BIGARRAY_C_LAYOUT) {
- /* C-style layout: row major, indices start at 0 */
- for (i = 0; i < b->num_dims; i++) {
- if ((unsigned long) index[i] >= (unsigned long) b->dim[i])
- array_bound_error();
- offset = offset * b->dim[i] + index[i];
- }
- } else {
- /* Fortran-style layout: column major, indices start at 1 */
- for (i = b->num_dims - 1; i >= 0; i--) {
- if ((unsigned long) (index[i] - 1) >= (unsigned long) b->dim[i])
- 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 = 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 bigarray_get_N(value vb, value * vind, int nind)
-{
- struct caml_bigarray * b = Bigarray_val(vb);
- long index[MAX_NUM_DIMS];
- int i;
- long offset;
-
- /* Check number of indices = number of dimensions of array
- (maybe not necessary if ML typing guarantees this) */
- if (nind != b->num_dims)
- 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 = bigarray_offset(b, index);
- /* Perform read */
- switch ((b->flags) & BIGARRAY_KIND_MASK) {
- default:
- Assert(0);
- case BIGARRAY_FLOAT32:
- return copy_double(((float *) b->data)[offset]);
- case BIGARRAY_FLOAT64:
- return copy_double(((double *) b->data)[offset]);
- case BIGARRAY_SINT8:
- return Val_int(((schar *) b->data)[offset]);
- case BIGARRAY_UINT8:
- return Val_int(((unsigned char *) b->data)[offset]);
- case BIGARRAY_SINT16:
- return Val_int(((int16 *) b->data)[offset]);
- case BIGARRAY_UINT16:
- return Val_int(((uint16 *) b->data)[offset]);
- case BIGARRAY_INT32:
- return copy_int32(((int32 *) b->data)[offset]);
- case BIGARRAY_INT64:
- return copy_int64(((int64 *) b->data)[offset]);
- case BIGARRAY_NATIVE_INT:
- return copy_nativeint(((long *) b->data)[offset]);
- case BIGARRAY_CAML_INT:
- return Val_long(((long *) b->data)[offset]);
- case BIGARRAY_COMPLEX32:
- { float * p = ((float *) b->data) + offset * 2;
- return copy_two_doubles(p[0], p[1]); }
- case BIGARRAY_COMPLEX64:
- { double * p = ((double *) b->data) + offset * 2;
- return copy_two_doubles(p[0], p[1]); }
- }
-}
-
-CAMLprim value bigarray_get_1(value vb, value vind1)
-{
- return bigarray_get_N(vb, &vind1, 1);
-}
-
-CAMLprim value bigarray_get_2(value vb, value vind1, value vind2)
-{
- value vind[2];
- vind[0] = vind1; vind[1] = vind2;
- return bigarray_get_N(vb, vind, 2);
-}
-
-CAMLprim value bigarray_get_3(value vb, value vind1, value vind2, value vind3)
-{
- value vind[3];
- vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
- return bigarray_get_N(vb, vind, 3);
-}
-
-#if 0
-CAMLprim value bigarray_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 bigarray_get_N(vb, vind, 4);
-}
-
-CAMLprim value bigarray_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 bigarray_get_N(vb, vind, 5);
-}
-
-CAMLprim value bigarray_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 bigarray_get_N(vb, vind, 6);
-}
-#endif
-
-CAMLprim value bigarray_get_generic(value vb, value vind)
-{
- return bigarray_get_N(vb, &Field(vind, 0), Wosize_val(vind));
-}
-
-/* Generic write to a big array */
-
-static value bigarray_set_aux(value vb, value * vind, long nind, value newval)
-{
- struct caml_bigarray * b = Bigarray_val(vb);
- long index[MAX_NUM_DIMS];
- int i;
- long offset;
-
- /* Check number of indices = number of dimensions of array
- (maybe not necessary if ML typing guarantees this) */
- if (nind != b->num_dims)
- 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 = bigarray_offset(b, index);
- /* Perform write */
- switch (b->flags & BIGARRAY_KIND_MASK) {
- default:
- Assert(0);
- case BIGARRAY_FLOAT32:
- ((float *) b->data)[offset] = Double_val(newval); break;
- case BIGARRAY_FLOAT64:
- ((double *) b->data)[offset] = Double_val(newval); break;
- case BIGARRAY_SINT8:
- case BIGARRAY_UINT8:
- ((schar *) b->data)[offset] = Int_val(newval); break;
- case BIGARRAY_SINT16:
- case BIGARRAY_UINT16:
- ((int16 *) b->data)[offset] = Int_val(newval); break;
- case BIGARRAY_INT32:
- ((int32 *) b->data)[offset] = Int32_val(newval); break;
- case BIGARRAY_INT64:
- ((int64 *) b->data)[offset] = Int64_val(newval); break;
- case BIGARRAY_NATIVE_INT:
- ((long *) b->data)[offset] = Nativeint_val(newval); break;
- case BIGARRAY_CAML_INT:
- ((long *) b->data)[offset] = Long_val(newval); break;
- case BIGARRAY_COMPLEX32:
- { float * p = ((float *) b->data) + offset * 2;
- p[0] = Double_field(newval, 0);
- p[1] = Double_field(newval, 1);
- break; }
- case BIGARRAY_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 bigarray_set_1(value vb, value vind1, value newval)
-{
- return bigarray_set_aux(vb, &vind1, 1, newval);
-}
-
-CAMLprim value bigarray_set_2(value vb, value vind1, value vind2, value newval)
-{
- value vind[2];
- vind[0] = vind1; vind[1] = vind2;
- return bigarray_set_aux(vb, vind, 2, newval);
-}
-
-CAMLprim value bigarray_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 bigarray_set_aux(vb, vind, 3, newval);
-}
-
-#if 0
-CAMLprim value bigarray_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 bigarray_set_aux(vb, vind, 4, newval);
-}
-
-CAMLprim value bigarray_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 bigarray_set_aux(vb, vind, 5, newval);
-}
-
-CAMLprim value bigarray_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 bigarray_set_aux(vb, vind, 6, newval);
-}
-
-value bigarray_set_N(value vb, value * vind, int nargs)
-{
- return bigarray_set_aux(vb, vind, nargs - 1, vind[nargs - 1]);
-}
-#endif
-
-CAMLprim value bigarray_set_generic(value vb, value vind, value newval)
-{
- return bigarray_set_aux(vb, &Field(vind, 0), Wosize_val(vind), newval);
-}
-
-/* Return the number of dimensions of a big array */
-
-CAMLprim value bigarray_num_dims(value vb)
-{
- struct caml_bigarray * b = Bigarray_val(vb);
- return Val_long(b->num_dims);
-}
-
-/* Return the n-th dimension of a big array */
-
-CAMLprim value bigarray_dim(value vb, value vn)
-{
- struct caml_bigarray * b = Bigarray_val(vb);
- long n = Long_val(vn);
- if (n >= b->num_dims) invalid_argument("Bigarray.dim");
- return Val_long(b->dim[n]);
-}
-
-/* Return the kind of a big array */
-
-CAMLprim value bigarray_kind(value vb)
-{
- return Val_int(Bigarray_val(vb)->flags & BIGARRAY_KIND_MASK);
-}
-
-/* Return the layout of a big array */
-
-CAMLprim value bigarray_layout(value vb)
-{
- return Val_int(Bigarray_val(vb)->flags & BIGARRAY_LAYOUT_MASK);
-}
-
-/* Finalization of a big array */
-
-static void bigarray_finalize(value v)
-{
- struct caml_bigarray * b = Bigarray_val(v);
-
- switch (b->flags & BIGARRAY_MANAGED_MASK) {
- case BIGARRAY_EXTERNAL:
- break;
- case BIGARRAY_MANAGED:
- if (b->proxy == NULL) {
- free(b->data);
- } else {
- if (-- b->proxy->refcount == 0) {
- free(b->proxy->data);
- stat_free(b->proxy);
- }
- }
- break;
- case BIGARRAY_MAPPED_FILE:
- if (b->proxy == NULL) {
- bigarray_unmap_file(b->data, bigarray_byte_size(b));
- } else {
- if (-- b->proxy->refcount == 0) {
- bigarray_unmap_file(b->proxy->data, b->proxy->size);
- stat_free(b->proxy);
- }
- }
- break;
- }
-}
-
-/* Comparison of two big arrays */
-
-static int bigarray_compare(value v1, value v2)
-{
- struct caml_bigarray * b1 = Bigarray_val(v1);
- struct caml_bigarray * b2 = Bigarray_val(v2);
- unsigned long n, num_elts;
- int i;
-
- /* 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++) {
- long d1 = b1->dim[i];
- long d2 = b2->dim[i];
- if (d1 != d2) return d1 < d2 ? -1 : 1;
- }
- /* Same dimensions: compare contents lexicographically */
- num_elts = bigarray_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) { \
- compare_unordered = 1; \
- if (e1 == e1) return 1; \
- if (e2 == e2) return -1; \
- } \
- } \
- return 0; \
- }
-
- switch (b1->flags & BIGARRAY_KIND_MASK) {
- case BIGARRAY_COMPLEX32:
- num_elts *= 2; /*fallthrough*/
- case BIGARRAY_FLOAT32:
- DO_FLOAT_COMPARISON(float);
- case BIGARRAY_COMPLEX64:
- num_elts *= 2; /*fallthrough*/
- case BIGARRAY_FLOAT64:
- DO_FLOAT_COMPARISON(double);
- case BIGARRAY_SINT8:
- DO_INTEGER_COMPARISON(schar);
- case BIGARRAY_UINT8:
- DO_INTEGER_COMPARISON(unsigned char);
- case BIGARRAY_SINT16:
- DO_INTEGER_COMPARISON(int16);
- case BIGARRAY_UINT16:
- DO_INTEGER_COMPARISON(uint16);
- case BIGARRAY_INT32:
- DO_INTEGER_COMPARISON(int32);
- case BIGARRAY_INT64:
-#ifdef ARCH_INT64_TYPE
- DO_INTEGER_COMPARISON(int64);
-#else
- { int64 * p1 = b1->data; int64 * p2 = b2->data;
- for (n = 0; n < num_elts; n++) {
- int64 e1 = *p1++; int64 e2 = *p2++;
- if ((int32)e1.h > (int32)e2.h) return 1;
- if ((int32)e1.h < (int32)e2.h) return -1;
- if (e1.l > e2.l) return 1;
- if (e1.l < e2.l) return -1;
- }
- return 0;
- }
-#endif
- case BIGARRAY_CAML_INT:
- case BIGARRAY_NATIVE_INT:
- DO_INTEGER_COMPARISON(long);
- default:
- Assert(0);
- return 0; /* should not happen */
- }
-#undef DO_INTEGER_COMPARISON
-#undef DO_FLOAT_COMPARISON
-}
-
-/* Hashing of a bigarray */
-
-static long bigarray_hash(value v)
-{
- struct caml_bigarray * b = Bigarray_val(v);
- long num_elts, n, h;
- int i;
-
- num_elts = 1;
- for (i = 0; i < b->num_dims; i++) num_elts = num_elts * b->dim[i];
- if (num_elts >= 50) num_elts = 50;
- h = 0;
-
-#define COMBINE(h,v) ((h << 4) + h + (v))
-
- switch (b->flags & BIGARRAY_KIND_MASK) {
- case BIGARRAY_SINT8:
- case BIGARRAY_UINT8: {
- unsigned char * p = b->data;
- for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++);
- break;
- }
- case BIGARRAY_SINT16:
- case BIGARRAY_UINT16: {
- unsigned short * p = b->data;
- for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++);
- break;
- }
- case BIGARRAY_FLOAT32:
- case BIGARRAY_COMPLEX32:
- case BIGARRAY_INT32:
-#ifndef ARCH_SIXTYFOUR
- case BIGARRAY_CAML_INT:
- case BIGARRAY_NATIVE_INT:
-#endif
- {
- uint32 * p = b->data;
- for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++);
- break;
- }
- case BIGARRAY_FLOAT64:
- case BIGARRAY_COMPLEX64:
- case BIGARRAY_INT64:
-#ifdef ARCH_SIXTYFOUR
- case BIGARRAY_CAML_INT:
- case BIGARRAY_NATIVE_INT:
-#endif
-#ifdef ARCH_SIXTYFOUR
- {
- unsigned long * p = b->data;
- for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++);
- break;
- }
-#else
- {
- uint32 * p = b->data;
- for (n = 0; n < num_elts; n++) {
-#ifdef ARCH_BIG_ENDIAN
- h = COMBINE(h, p[1]); h = COMBINE(h, p[0]); p += 2;
-#else
- h = COMBINE(h, p[0]); h = COMBINE(h, p[1]); p += 2;
-#endif
- }
- break;
- }
-#endif
- }
-#undef COMBINE
- return h;
-}
-
-static void bigarray_serialize_longarray(void * data,
- long num_elts,
- long min_val, long max_val)
-{
-#ifdef ARCH_SIXTYFOUR
- int overflow_32 = 0;
- long * 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) {
- serialize_int_1(1);
- serialize_block_8(data, num_elts);
- } else {
- serialize_int_1(0);
- for (n = 0, p = data; n < num_elts; n++, p++) serialize_int_4((int32) *p);
- }
-#else
- serialize_int_1(0);
- serialize_block_4(data, num_elts);
-#endif
-}
-
-static void bigarray_serialize(value v,
- unsigned long * wsize_32,
- unsigned long * wsize_64)
-{
- struct caml_bigarray * b = Bigarray_val(v);
- long num_elts;
- int i;
-
- /* Serialize header information */
- serialize_int_4(b->num_dims);
- serialize_int_4(b->flags & (BIGARRAY_KIND_MASK | BIGARRAY_LAYOUT_MASK));
- for (i = 0; i < b->num_dims; i++) 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 & BIGARRAY_KIND_MASK) {
- case BIGARRAY_SINT8:
- case BIGARRAY_UINT8:
- serialize_block_1(b->data, num_elts); break;
- case BIGARRAY_SINT16:
- case BIGARRAY_UINT16:
- serialize_block_2(b->data, num_elts); break;
- case BIGARRAY_FLOAT32:
- case BIGARRAY_INT32:
- serialize_block_4(b->data, num_elts); break;
- case BIGARRAY_COMPLEX32:
- serialize_block_4(b->data, num_elts * 2); break;
- case BIGARRAY_FLOAT64:
- case BIGARRAY_INT64:
- serialize_block_8(b->data, num_elts); break;
- case BIGARRAY_COMPLEX64:
- serialize_block_8(b->data, num_elts * 2); break;
- case BIGARRAY_CAML_INT:
- bigarray_serialize_longarray(b->data, num_elts, -0x40000000, 0x3FFFFFFF);
- break;
- case BIGARRAY_NATIVE_INT:
- bigarray_serialize_longarray(b->data, num_elts, -0x80000000, 0x7FFFFFFF);
- break;
- }
- /* Compute required size in Caml heap. Assumes struct caml_bigarray
- is exactly 4 + num_dims words */
- Assert(sizeof(struct caml_bigarray) == 5 * sizeof(value));
- *wsize_32 = (4 + b->num_dims) * 4;
- *wsize_64 = (4 + b->num_dims) * 8;
-}
-
-static void bigarray_deserialize_longarray(void * dest, long num_elts)
-{
- int sixty = deserialize_uint_1();
-#ifdef ARCH_SIXTYFOUR
- if (sixty) {
- deserialize_block_8(dest, num_elts);
- } else {
- long * p, n;
- for (n = 0, p = dest; n < num_elts; n++, p++) *p = deserialize_sint_4();
- }
-#else
- if (sixty)
- deserialize_error("input_value: cannot read bigarray "
- "with 64-bit Caml ints");
- deserialize_block_4(dest, num_elts);
-#endif
-}
-
-unsigned long bigarray_deserialize(void * dst)
-{
- struct caml_bigarray * b = dst;
- int i, elt_size;
- unsigned long num_elts;
-
- /* Read back header information */
- b->num_dims = deserialize_uint_4();
- b->flags = deserialize_uint_4() | BIGARRAY_MANAGED;
- b->proxy = NULL;
- for (i = 0; i < b->num_dims; i++) b->dim[i] = deserialize_uint_4();
- /* Compute total number of elements */
- num_elts = bigarray_num_elts(b);
- /* Determine element size in bytes */
- if ((b->flags & BIGARRAY_KIND_MASK) > BIGARRAY_COMPLEX64)
- deserialize_error("input_value: bad bigarray kind");
- elt_size = bigarray_element_size[b->flags & BIGARRAY_KIND_MASK];
- /* Allocate room for data */
- b->data = malloc(elt_size * num_elts);
- if (b->data == NULL)
- deserialize_error("input_value: out of memory for bigarray");
- /* Read data */
- switch (b->flags & BIGARRAY_KIND_MASK) {
- case BIGARRAY_SINT8:
- case BIGARRAY_UINT8:
- deserialize_block_1(b->data, num_elts); break;
- case BIGARRAY_SINT16:
- case BIGARRAY_UINT16:
- deserialize_block_2(b->data, num_elts); break;
- case BIGARRAY_FLOAT32:
- case BIGARRAY_INT32:
- deserialize_block_4(b->data, num_elts); break;
- case BIGARRAY_COMPLEX32:
- deserialize_block_4(b->data, num_elts * 2); break;
- case BIGARRAY_FLOAT64:
- case BIGARRAY_INT64:
- deserialize_block_8(b->data, num_elts); break;
- case BIGARRAY_COMPLEX64:
- deserialize_block_8(b->data, num_elts * 2); break;
- case BIGARRAY_CAML_INT:
- case BIGARRAY_NATIVE_INT:
- bigarray_deserialize_longarray(b->data, num_elts); break;
- }
- return sizeof(struct caml_bigarray) + (b->num_dims - 1) * sizeof(long);
-}
-
-/* Create / update proxy to indicate that b2 is a sub-array of b1 */
-
-static void bigarray_update_proxy(struct caml_bigarray * b1,
- struct caml_bigarray * b2)
-{
- struct caml_bigarray_proxy * proxy;
- /* Nothing to do for un-managed arrays */
- if ((b1->flags & BIGARRAY_MANAGED_MASK) == BIGARRAY_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 = stat_alloc(sizeof(struct caml_bigarray_proxy));
- proxy->refcount = 2; /* original array + sub array */
- proxy->data = b1->data;
- proxy->size =
- b1->flags & BIGARRAY_MAPPED_FILE ? bigarray_byte_size(b1) : 0;
- b1->proxy = proxy;
- b2->proxy = proxy;
- }
-}
-
-/* Slicing */
-
-CAMLprim value bigarray_slice(value vb, value vind)
-{
- CAMLparam2 (vb, vind);
- #define b ((struct caml_bigarray *) Bigarray_val(vb))
- CAMLlocal1 (res);
- long index[MAX_NUM_DIMS];
- int num_inds, i;
- long offset;
- long * 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)
- invalid_argument("Bigarray.slice: too many indices");
- /* Compute offset and check bounds */
- if ((b->flags & BIGARRAY_LAYOUT_MASK) == BIGARRAY_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 = bigarray_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 = bigarray_offset(b, index);
- sub_dims = b->dim;
- }
- sub_data =
- (char *) b->data +
- offset * bigarray_element_size[b->flags & BIGARRAY_KIND_MASK];
- /* Allocate a Caml bigarray to hold the result */
- res = alloc_bigarray(b->flags, b->num_dims - num_inds, sub_data, sub_dims);
- /* Create or update proxy in case of managed bigarray */
- bigarray_update_proxy(b, Bigarray_val(res));
- /* Return result */
- CAMLreturn (res);
-
- #undef b
-}
-
-/* Extracting a sub-array of same number of dimensions */
-
-CAMLprim value bigarray_sub(value vb, value vofs, value vlen)
-{
- CAMLparam3 (vb, vofs, vlen);
- CAMLlocal1 (res);
- #define b ((struct caml_bigarray *) Bigarray_val(vb))
- long ofs = Long_val(vofs);
- long len = Long_val(vlen);
- int i, changed_dim;
- long mul;
- char * sub_data;
-
- /* Compute offset and check bounds */
- if ((b->flags & BIGARRAY_LAYOUT_MASK) == BIGARRAY_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])
- invalid_argument("Bigarray.sub: bad sub-array");
- sub_data =
- (char *) b->data +
- ofs * mul * bigarray_element_size[b->flags & BIGARRAY_KIND_MASK];
- /* Allocate a Caml bigarray to hold the result */
- res = alloc_bigarray(b->flags, b->num_dims, sub_data, b->dim);
- /* Doctor the changed dimension */
- Bigarray_val(res)->dim[changed_dim] = len;
- /* Create or update proxy in case of managed bigarray */
- bigarray_update_proxy(b, Bigarray_val(res));
- /* Return result */
- CAMLreturn (res);
-
- #undef b
-}
-
-/* Copying a big array into another one */
-
-CAMLprim value bigarray_blit(value vsrc, value vdst)
-{
- struct caml_bigarray * src = Bigarray_val(vsrc);
- struct caml_bigarray * dst = Bigarray_val(vdst);
- int i;
- long num_bytes;
-
- /* 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 =
- bigarray_num_elts(src)
- * bigarray_element_size[src->flags & BIGARRAY_KIND_MASK];
- /* Do the copying */
- memmove (dst->data, src->data, num_bytes);
- return Val_unit;
- blit_error:
- invalid_argument("Bigarray.blit: dimension mismatch");
- return Val_unit; /* not reached */
-}
-
-/* Filling a big array with a given value */
-
-CAMLprim value bigarray_fill(value vb, value vinit)
-{
- struct caml_bigarray * b = Bigarray_val(vb);
- long num_elts = bigarray_num_elts(b);
-
- switch (b->flags & BIGARRAY_KIND_MASK) {
- default:
- Assert(0);
- case BIGARRAY_FLOAT32: {
- float init = Double_val(vinit);
- float * p;
- for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
- break;
- }
- case BIGARRAY_FLOAT64: {
- double init = Double_val(vinit);
- double * p;
- for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
- break;
- }
- case BIGARRAY_SINT8:
- case BIGARRAY_UINT8: {
- int init = Int_val(vinit);
- char * p;
- for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
- break;
- }
- case BIGARRAY_SINT16:
- case BIGARRAY_UINT16: {
- int init = Int_val(vinit);
- short * p;
- for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
- break;
- }
- case BIGARRAY_INT32: {
- int32 init = Int32_val(vinit);
- int32 * p;
- for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
- break;
- }
- case BIGARRAY_INT64: {
- int64 init = Int64_val(vinit);
- int64 * p;
- for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
- break;
- }
- case BIGARRAY_NATIVE_INT: {
- long init = Nativeint_val(vinit);
- long * p;
- for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
- break;
- }
- case BIGARRAY_CAML_INT: {
- long init = Long_val(vinit);
- long * p;
- for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
- break;
- }
- case BIGARRAY_COMPLEX32: {
- float init0 = Double_field(vinit, 0);
- float init1 = Double_field(vinit, 1);
- float * p;
- for (p = b->data; num_elts > 0; num_elts--) { *p++ = init0; *p++ = init1; }
- break;
- }
- case BIGARRAY_COMPLEX64: {
- double init0 = Double_field(vinit, 0);
- double init1 = Double_field(vinit, 1);
- double * p;
- for (p = b->data; num_elts > 0; num_elts--) { *p++ = init0; *p++ = init1; }
- break;
- }
- }
- return Val_unit;
-}
-
-/* Reshape an array: change dimensions and number of dimensions, preserving
- array contents */
-
-CAMLprim value bigarray_reshape(value vb, value vdim)
-{
- CAMLparam2 (vb, vdim);
- CAMLlocal1 (res);
- #define b ((struct caml_bigarray *) Bigarray_val(vb))
- long dim[MAX_NUM_DIMS];
- mlsize_t num_dims;
- unsigned long num_elts;
- int i;
-
- num_dims = Wosize_val(vdim);
- if (num_dims < 1 || num_dims > MAX_NUM_DIMS)
- 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 || dim[i] > 0x7FFFFFFFL)
- invalid_argument("Bigarray.reshape: negative dimension");
- num_elts *= dim[i];
- }
- /* Check that sizes agree */
- if (num_elts != bigarray_num_elts(b))
- invalid_argument("Bigarray.reshape: size mismatch");
- /* Create bigarray with same data and new dimensions */
- res = alloc_bigarray(b->flags, num_dims, b->data, dim);
- /* Create or update proxy in case of managed bigarray */
- bigarray_update_proxy(b, Bigarray_val(res));
- /* Return result */
- CAMLreturn (res);
-
- #undef b
-}
-
-/* Initialization */
-
-CAMLprim value bigarray_init(value unit)
-{
- register_custom_operations(&bigarray_ops);
- return Val_unit;
-}
diff --git a/otherlibs/bigarray/mmap_unix.c b/otherlibs/bigarray/mmap_unix.c
deleted file mode 100644
index e0f649f920..0000000000
--- a/otherlibs/bigarray/mmap_unix.c
+++ /dev/null
@@ -1,117 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */
-/* */
-/* Copyright 2000 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <stddef.h>
-#include <string.h>
-#include "bigarray.h"
-#include "custom.h"
-#include "fail.h"
-#include "mlvalues.h"
-#include "sys.h"
-
-extern int bigarray_element_size[]; /* from bigarray_stubs.c */
-
-#ifdef HAS_UNISTD
-#include <unistd.h>
-#endif
-#ifdef HAS_MMAP
-#include <sys/types.h>
-#include <sys/mman.h>
-#endif
-
-#if defined(HAS_MMAP)
-
-#ifndef MAP_FAILED
-#define MAP_FAILED ((void *) -1)
-#endif
-
-CAMLprim value bigarray_map_file(value vfd, value vkind, value vlayout,
- value vshared, value vdim)
-{
- int fd, flags, major_dim, shared;
- long num_dims, i;
- long dim[MAX_NUM_DIMS];
- long currpos, file_size;
- unsigned long array_size;
- char c;
- void * addr;
-
- fd = Int_val(vfd);
- flags = Int_val(vkind) | Int_val(vlayout);
- num_dims = Wosize_val(vdim);
- major_dim = flags & BIGARRAY_FORTRAN_LAYOUT ? num_dims - 1 : 0;
- /* Extract dimensions from Caml array */
- num_dims = Wosize_val(vdim);
- if (num_dims < 1 || num_dims > MAX_NUM_DIMS)
- 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 || dim[i] > 0x7FFFFFFFL)
- invalid_argument("Bigarray.create: negative dimension");
- }
- /* Determine file size */
- currpos = lseek(fd, 0, SEEK_CUR);
- if (currpos == -1) sys_error(NO_ARG);
- file_size = lseek(fd, 0, SEEK_END);
- if (file_size == -1) sys_error(NO_ARG);
- /* Determine array size in bytes (or size of array without the major
- dimension if that dimension wasn't specified) */
- array_size = bigarray_element_size[flags & BIGARRAY_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 ((unsigned long) file_size % array_size != 0)
- failwith("Bigarray.mmap: file size doesn't match array dimensions");
- dim[major_dim] = (unsigned long) file_size / array_size;
- array_size = file_size;
- } else {
- /* Check that file is large enough, and grow it otherwise */
- if (file_size < array_size) {
- if (lseek(fd, array_size - 1, SEEK_SET) == -1) sys_error(NO_ARG);
- c = 0;
- if (write(fd, &c, 1) != 1) sys_error(NO_ARG);
- }
- }
- /* Restore original file position */
- lseek(fd, currpos, SEEK_SET);
- /* Do the mmap */
- shared = Bool_val(vshared) ? MAP_SHARED : MAP_PRIVATE;
- addr = mmap(NULL, array_size, PROT_READ | PROT_WRITE, shared, fd, 0);
- if (addr == (void *) MAP_FAILED) sys_error(NO_ARG);
- /* Build and return the Caml bigarray */
- return alloc_bigarray(flags | BIGARRAY_MAPPED_FILE, num_dims, addr, dim);
-}
-
-#else
-
-value bigarray_map_file(value vfd, value vkind, value vlayout,
- value vshared, value vdim)
-{
- invalid_argument("Bigarray.map_file: not supported");
- return Val_unit;
-}
-
-#endif
-
-
-void bigarray_unmap_file(void * addr, unsigned long len)
-{
-#if defined(HAS_MMAP)
- munmap(addr, len);
-#endif
-}
diff --git a/otherlibs/bigarray/mmap_win32.c b/otherlibs/bigarray/mmap_win32.c
deleted file mode 100644
index a3701611d7..0000000000
--- a/otherlibs/bigarray/mmap_win32.c
+++ /dev/null
@@ -1,116 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */
-/* */
-/* Copyright 2000 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <stddef.h>
-#include <stdio.h>
-#include <string.h>
-#include "bigarray.h"
-#include "alloc.h"
-#include "custom.h"
-#include "fail.h"
-#include "mlvalues.h"
-#include "sys.h"
-#include "unixsupport.h"
-
-extern int bigarray_element_size[]; /* from bigarray_stubs.c */
-
-static void bigarray_sys_error(void);
-
-CAMLprim value bigarray_map_file(value vfd, value vkind, value vlayout,
- value vshared, value vdim)
-{
- HANDLE fd, fmap;
- int flags, major_dim, mode, perm;
- long num_dims, i;
- long dim[MAX_NUM_DIMS];
- long currpos, file_size;
- unsigned long array_size;
- char c;
- void * addr;
-
- fd = Handle_val(vfd);
- flags = Int_val(vkind) | Int_val(vlayout);
- num_dims = Wosize_val(vdim);
- major_dim = flags & BIGARRAY_FORTRAN_LAYOUT ? num_dims - 1 : 0;
- /* Extract dimensions from Caml array */
- num_dims = Wosize_val(vdim);
- if (num_dims < 1 || num_dims > MAX_NUM_DIMS)
- 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 || dim[i] > 0x7FFFFFFFL)
- invalid_argument("Bigarray.create: negative dimension");
- }
- /* Determine file size */
- currpos = SetFilePointer(fd, 0, NULL, FILE_CURRENT);
- if (currpos == -1) bigarray_sys_error();
- file_size = SetFilePointer(fd, 0, NULL, FILE_END);
- if (file_size == -1) bigarray_sys_error();
- /* Determine array size in bytes (or size of array without the major
- dimension if that dimension wasn't specified) */
- array_size = bigarray_element_size[flags & BIGARRAY_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 ((unsigned long) file_size % array_size != 0)
- failwith("Bigarray.mmap: file size doesn't match array dimensions");
- dim[major_dim] = (unsigned long) file_size / array_size;
- array_size = file_size;
- }
- /* Restore original file position */
- SetFilePointer(fd, currpos, NULL, 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;
- }
- fmap = CreateFileMapping(fd, NULL, perm, 0, array_size, NULL);
- if (fmap == NULL) bigarray_sys_error();
- /* Map the mapping in memory */
- addr = MapViewOfFile(fmap, mode, 0, 0, array_size);
- if (addr == NULL) bigarray_sys_error();
- /* Close the file mapping */
- CloseHandle(fmap);
- /* Build and return the Caml bigarray */
- return alloc_bigarray(flags | BIGARRAY_MAPPED_FILE, num_dims, addr, dim);
-}
-
-void bigarray_unmap_file(void * addr, unsigned long len)
-{
- UnmapViewOfFile(addr);
-}
-
-static void bigarray_sys_error(void)
-{
- char buffer[512];
- unsigned long 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);
- raise_sys_error(copy_string(buffer));
-}
diff --git a/otherlibs/db/.depend b/otherlibs/db/.depend
deleted file mode 100644
index 5d94dce520..0000000000
--- a/otherlibs/db/.depend
+++ /dev/null
@@ -1,2 +0,0 @@
-db.cmo: db.cmi
-db.cmx: db.cmi
diff --git a/otherlibs/dbm/.cvsignore b/otherlibs/dbm/.cvsignore
deleted file mode 100644
index 074dd28a45..0000000000
--- a/otherlibs/dbm/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-so_locations
diff --git a/otherlibs/dbm/.depend b/otherlibs/dbm/.depend
deleted file mode 100644
index 6fa318eed6..0000000000
--- a/otherlibs/dbm/.depend
+++ /dev/null
@@ -1,2 +0,0 @@
-dbm.cmo: dbm.cmi
-dbm.cmx: dbm.cmi
diff --git a/otherlibs/dbm/Makefile b/otherlibs/dbm/Makefile
deleted file mode 100644
index 394586416c..0000000000
--- a/otherlibs/dbm/Makefile
+++ /dev/null
@@ -1,73 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-# Makefile for the ndbm library
-
-include ../../config/Makefile
-
-# Compilation optiosn
-CC=$(BYTECC) -g
-CAMLC=../../ocamlcomp.sh
-CAMLOPT=../../ocamlcompopt.sh
-MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib
-COMPFLAGS=-warn-error A
-
-CFLAGS=$(DBM_INCLUDES) -I../../byterun -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS)
-COBJS=cldbm.o
-
-all: libmldbm.a dbm.cmi dbm.cma
-
-allopt: libmldbm.a dbm.cmi dbm.cmxa
-
-libmldbm.a: $(COBJS)
- $(MKLIB) -oc mldbm $(COBJS) $(DBM_LINK)
-
-dbm.cma: dbm.cmo
- $(MKLIB) -ocamlc '$(CAMLC)' -o dbm -oc mldbm dbm.cmo $(DBM_LINK)
-
-dbm.cmxa: dbm.cmx
- $(MKLIB) -ocamlopt '$(CAMLOPT)' -o dbm -oc mldbm dbm.cmx $(DBM_LINK)
-
-partialclean:
- rm -f *.cm*
-
-clean: partialclean
- rm -f *.a *.o *.so
-
-install:
- if test -f dllmldbm.so; then cp dllmldbm.so $(STUBLIBDIR)/dllmldbm.so; fi
- cp libmldbm.a $(LIBDIR)/libmldbm.a
- cd $(LIBDIR); $(RANLIB) libmldbm.a
- cp dbm.cma dbm.cmi dbm.mli $(LIBDIR)
-
-installopt:
- cp dbm.cmx dbm.cmxa dbm.a $(LIBDIR)
- cd $(LIBDIR); $(RANLIB) dbm.a
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.mli.cmi:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-depend:
- ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml > .depend
-
-include .depend
diff --git a/otherlibs/dbm/cldbm.c b/otherlibs/dbm/cldbm.c
deleted file mode 100644
index a9da59b3db..0000000000
--- a/otherlibs/dbm/cldbm.c
+++ /dev/null
@@ -1,166 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Francois Rouaix, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <string.h>
-#include <fcntl.h>
-#include <mlvalues.h>
-#include <alloc.h>
-#include <memory.h>
-#include <fail.h>
-#include <callback.h>
-
-#ifdef DBM_USES_GDBM_NDBM
-#include <gdbm-ndbm.h>
-#else
-#include <ndbm.h>
-#endif
-
-/* Quite close to sys_open_flags, but we need RDWR */
-static int dbm_open_flags[] = {
- O_RDONLY, O_WRONLY, O_RDWR, O_CREAT
-};
-
-static void raise_dbm (char *errmsg) Noreturn;
-
-static void raise_dbm(char *errmsg)
-{
- static value * dbm_exn = NULL;
- if (dbm_exn == NULL)
- dbm_exn = caml_named_value("dbmerror");
- raise_with_string(*dbm_exn, errmsg);
-}
-
-#define DBM_val(v) *((DBM **) &Field(v, 0))
-
-static value alloc_dbm(DBM * db)
-{
- value res = alloc_small(1, Abstract_tag);
- DBM_val(res) = db;
- return res;
-}
-
-static DBM * extract_dbm(value vdb)
-{
- if (DBM_val(vdb) == NULL) raise_dbm("DBM has been closed");
- return DBM_val(vdb);
-}
-
-/* Dbm.open : string -> Sys.open_flag list -> int -> t */
-value caml_dbm_open(value vfile, value vflags, value vmode) /* ML */
-{
- char *file = String_val(vfile);
- int flags = convert_flag_list(vflags, dbm_open_flags);
- int mode = Int_val(vmode);
- DBM *db = dbm_open(file,flags,mode);
-
- if (db == NULL)
- raise_dbm("Can't open file");
- else
- return (alloc_dbm(db));
-}
-
-/* Dbm.close: t -> unit */
-value caml_dbm_close(value vdb) /* ML */
-{
- dbm_close(extract_dbm(vdb));
- DBM_val(vdb) = NULL;
- return Val_unit;
-}
-
-/* Dbm.fetch: t -> string -> string */
-value caml_dbm_fetch(value vdb, value vkey) /* ML */
-{
- datum key,answer;
- key.dptr = String_val(vkey);
- key.dsize = string_length(vkey);
- answer = dbm_fetch(extract_dbm(vdb), key);
- if (answer.dptr) {
- value res = alloc_string(answer.dsize);
- memmove (String_val (res), answer.dptr, answer.dsize);
- return res;
- }
- else raise_not_found();
-}
-
-value caml_dbm_insert(value vdb, value vkey, value vcontent) /* ML */
-{
- datum key, content;
-
- key.dptr = String_val(vkey);
- key.dsize = string_length(vkey);
- content.dptr = String_val(vcontent);
- content.dsize = string_length(vcontent);
-
- switch(dbm_store(extract_dbm(vdb), key, content, DBM_INSERT)) {
- case 0:
- return Val_unit;
- case 1: /* DBM_INSERT and already existing */
- raise_dbm("Entry already exists");
- default:
- raise_dbm("dbm_store failed");
- }
-}
-
-value caml_dbm_replace(value vdb, value vkey, value vcontent) /* ML */
-{
- datum key, content;
-
- key.dptr = String_val(vkey);
- key.dsize = string_length(vkey);
- content.dptr = String_val(vcontent);
- content.dsize = string_length(vcontent);
-
- switch(dbm_store(extract_dbm(vdb), key, content, DBM_REPLACE)) {
- case 0:
- return Val_unit;
- default:
- raise_dbm("dbm_store failed");
- }
-}
-
-value caml_dbm_delete(value vdb, value vkey) /* ML */
-{
- datum key;
- key.dptr = String_val(vkey);
- key.dsize = string_length(vkey);
-
- if (dbm_delete(extract_dbm(vdb), key) < 0)
- raise_dbm("dbm_delete");
- else return Val_unit;
-}
-
-value caml_dbm_firstkey(value vdb) /* ML */
-{
- datum key = dbm_firstkey(extract_dbm(vdb));
-
- if (key.dptr) {
- value res = alloc_string(key.dsize);
- memmove (String_val (res), key.dptr, key.dsize);
- return res;
- }
- else raise_not_found();
-}
-
-value caml_dbm_nextkey(value vdb) /* ML */
-{
- datum key = dbm_nextkey(extract_dbm(vdb));
-
- if (key.dptr) {
- value res = alloc_string(key.dsize);
- memmove (String_val (res), key.dptr, key.dsize);
- return res;
- }
- else raise_not_found();
-}
diff --git a/otherlibs/dbm/dbm.ml b/otherlibs/dbm/dbm.ml
deleted file mode 100644
index c98f7fe24d..0000000000
--- a/otherlibs/dbm/dbm.ml
+++ /dev/null
@@ -1,58 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Francois Rouaix, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-type t
-
-type open_flag =
- Dbm_rdonly | Dbm_wronly | Dbm_rdwr | Dbm_create
-
-type dbm_flag =
- DBM_INSERT
- | DBM_REPLACE
-
-exception Dbm_error of string
-
-external raw_opendbm : string -> open_flag list -> int -> t
- = "caml_dbm_open"
-
-let opendbm file flags mode =
- try
- raw_opendbm file flags mode
- with Dbm_error msg ->
- raise(Dbm_error("Can't open file " ^ file))
-
- (* By exporting opendbm as val, we are sure to link in this
- file (we must register the exception). Since t is abstract, programs
- have to call it in order to do anything *)
-
-external close : t -> unit = "caml_dbm_close"
-external find : t -> string -> string = "caml_dbm_fetch"
-external add : t -> string -> string -> unit = "caml_dbm_insert"
-external replace : t -> string -> string -> unit = "caml_dbm_replace"
-external remove : t -> string -> unit = "caml_dbm_delete"
-external firstkey : t -> string = "caml_dbm_firstkey"
-external nextkey : t -> string = "caml_dbm_nextkey"
-
-let _ = Callback.register_exception "dbmerror" (Dbm_error "")
-
-(* Usual iterator *)
-let iter f t =
- let rec walk = function
- None -> ()
- | Some k ->
- f k (find t k);
- walk (try Some(nextkey t) with Not_found -> None)
- in
- walk (try Some(firstkey t) with Not_found -> None)
diff --git a/otherlibs/dbm/dbm.mli b/otherlibs/dbm/dbm.mli
deleted file mode 100644
index d451745f9e..0000000000
--- a/otherlibs/dbm/dbm.mli
+++ /dev/null
@@ -1,80 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Francois Rouaix, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Interface to the NDBM database. *)
-
-type t
-(** The type of file descriptors opened on NDBM databases. *)
-
-
-type open_flag =
- Dbm_rdonly
- | Dbm_wronly
- | Dbm_rdwr
- | Dbm_create
-(** Flags for opening a database (see {!Dbm.opendbm}). *)
-
-
-exception Dbm_error of string
-(** Raised by the following functions when an error is encountered. *)
-
-val opendbm : string -> open_flag list -> int -> t
-(** Open a descriptor on an NDBM database. The first argument is
- the name of the database (without the [.dir] and [.pag] suffixes).
- The second argument is a list of flags: [Dbm_rdonly] opens
- the database for reading only, [Dbm_wronly] for writing only,
- [Dbm_rdwr] for reading and writing; [Dbm_create] causes the
- database to be created if it does not already exist.
- The third argument is the permissions to give to the database
- files, if the database is created. *)
-
-external close : t -> unit = "caml_dbm_close"
-(** Close the given descriptor. *)
-
-external find : t -> string -> string = "caml_dbm_fetch"
-(** [find db key] returns the data associated with the given
- [key] in the database opened for the descriptor [db].
- Raise [Not_found] if the [key] has no associated data. *)
-
-external add : t -> string -> string -> unit = "caml_dbm_insert"
-(** [add db key data] inserts the pair ([key], [data]) in
- the database [db]. If the database already contains data
- associated with [key], raise [Dbm_error "Entry already exists"]. *)
-
-external replace : t -> string -> string -> unit = "caml_dbm_replace"
-(** [replace db key data] inserts the pair ([key], [data]) in
- the database [db]. If the database already contains data
- associated with [key], that data is discarded and silently
- replaced by the new [data]. *)
-
-external remove : t -> string -> unit = "caml_dbm_delete"
-(** [remove db key data] removes the data associated with [key]
- in [db]. If [key] has no associated data, raise
- [Dbm_error "dbm_delete"]. *)
-
-external firstkey : t -> string = "caml_dbm_firstkey"
-(** See {!Dbm.nextkey}.*)
-
-external nextkey : t -> string = "caml_dbm_nextkey"
-(** Enumerate all keys in the given database, in an unspecified order.
- [firstkey db] returns the first key, and repeated calls
- to [nextkey db] return the remaining keys. [Not_found] is raised
- when all keys have been enumerated. *)
-
-val iter : (string -> string -> 'a) -> t -> unit
-(** [iter f db] applies [f] to each ([key], [data]) pair in
- the database [db]. [f] receives [key] as first argument
- and [data] as second argument. *)
-
diff --git a/otherlibs/dynlink/.cvsignore b/otherlibs/dynlink/.cvsignore
deleted file mode 100644
index 5ea9775e1d..0000000000
--- a/otherlibs/dynlink/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-extract_crc
diff --git a/otherlibs/dynlink/.depend b/otherlibs/dynlink/.depend
deleted file mode 100644
index 251aef84c3..0000000000
--- a/otherlibs/dynlink/.depend
+++ /dev/null
@@ -1,10 +0,0 @@
-dynlink.cmo: ../../utils/config.cmi ../../utils/consistbl.cmi \
- ../../bytecomp/dll.cmi ../../bytecomp/emitcode.cmi \
- ../../bytecomp/meta.cmi ../../utils/misc.cmi ../../bytecomp/opcodes.cmo \
- ../../bytecomp/symtable.cmi dynlink.cmi
-dynlink.cmx: ../../utils/config.cmx ../../utils/consistbl.cmx \
- ../../bytecomp/dll.cmx ../../bytecomp/emitcode.cmx \
- ../../bytecomp/meta.cmx ../../utils/misc.cmx ../../bytecomp/opcodes.cmx \
- ../../bytecomp/symtable.cmx dynlink.cmi
-extract_crc.cmo: dynlink.cmi
-extract_crc.cmx: dynlink.cmx
diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile
deleted file mode 100644
index 43b9599ca8..0000000000
--- a/otherlibs/dynlink/Makefile
+++ /dev/null
@@ -1,61 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-# Makefile for the dynamic link library
-
-include ../../config/Makefile
-
-CAMLC=../../boot/ocamlrun ../../ocamlc
-INCLUDES=-I ../../utils -I ../../typing -I ../../bytecomp
-COMPFLAGS=-warn-error A -I ../../stdlib $(INCLUDES)
-
-OBJS=dynlink.cmo
-COMPILEROBJS=misc.cmo config.cmo tbl.cmo clflags.cmo consistbl.cmo \
- ident.cmo path.cmo \
- types.cmo btype.cmo predef.cmo runtimedef.cmo \
- bytesections.cmo dll.cmo symtable.cmo opcodes.cmo meta.cmo
-
-all: dynlink.cma extract_crc
-
-allopt:
-
-dynlink.cma: $(OBJS)
- $(CAMLC) $(COMPFLAGS) -a -o dynlink.cma $(COMPILEROBJS) $(OBJS)
-
-extract_crc: dynlink.cma extract_crc.cmo
- $(CAMLC) $(COMPFLAGS) -o extract_crc dynlink.cma extract_crc.cmo
-
-install:
- cp dynlink.cmi dynlink.cma dynlink.mli extract_crc $(LIBDIR)
-
-installopt:
-
-partialclean:
- rm -f extract_crc *.cm[ioa]
-
-clean: partialclean
-
-.SUFFIXES: .ml .mli .cmo .cmi
-
-.mli.cmi:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-depend:
- ../../boot/ocamlrun ../../tools/ocamldep $(INCLUDES) *.mli *.ml >.depend
-
-include .depend
diff --git a/otherlibs/dynlink/Makefile.Mac b/otherlibs/dynlink/Makefile.Mac
deleted file mode 100644
index 3b7fca1cb5..0000000000
--- a/otherlibs/dynlink/Makefile.Mac
+++ /dev/null
@@ -1,56 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-# Makefile for the dynamic link library
-
-CAMLC = :::boot:ocamlrun :::ocamlc
-INCLUDES = -I :::utils: -I :::typing: -I :::bytecomp:
-COMPFLAGS = -I :::stdlib: {INCLUDES}
-
-OBJS = dynlink.cmo
-COMPILEROBJS = misc.cmo config.cmo tbl.cmo ¶
- clflags.cmo ident.cmo path.cmo ¶
- types.cmo btype.cmo predef.cmo runtimedef.cmo ¶
- bytesections.cmo dll.cmo symtable.cmo opcodes.cmo meta.cmo
-
-all Ä dynlink.cma extract_crc
-
-allopt Ä
-
-dynlink.cma Ä {OBJS}
- {CAMLC} {COMPFLAGS} -a -o dynlink.cma {COMPILEROBJS} {OBJS}
-
-extract_crc Ä dynlink.cma extract_crc.cmo
- {CAMLC} {COMPFLAGS} -o extract_crc dynlink.cma extract_crc.cmo
-
-install Ä
- duplicate -y dynlink.cmi dynlink.cma extract_crc "{LIBDIR}"
-
-installopt Ä
-
-partialclean Ä
- delete -i extract_crc
- delete -i Å.cm[aio] || set status 0
-
-clean Ä partialclean
-
-.cmi Ä .mli
- {CAMLC} -c {COMPFLAGS} {default}.mli
-
-.cmo Ä .ml
- {CAMLC} -c {COMPFLAGS} {default}.ml
-
-depend Ä
- :::boot:ocamlrun :::tools:ocamldep Å.mli Å.ml > Makefile.Mac.depend
diff --git a/otherlibs/dynlink/Makefile.Mac.depend b/otherlibs/dynlink/Makefile.Mac.depend
deleted file mode 100644
index 6a7522b5be..0000000000
--- a/otherlibs/dynlink/Makefile.Mac.depend
+++ /dev/null
@@ -1,4 +0,0 @@
-dynlink.cmoÄ dynlink.cmi
-dynlink.cmxÄ dynlink.cmi
-extract_crc.cmoÄ dynlink.cmi
-extract_crc.cmxÄ dynlink.cmx
diff --git a/otherlibs/dynlink/Makefile.nt b/otherlibs/dynlink/Makefile.nt
deleted file mode 100644
index 6718083d93..0000000000
--- a/otherlibs/dynlink/Makefile.nt
+++ /dev/null
@@ -1,62 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-# Makefile for the dynamic link library
-
-include ../../config/Makefile
-
-CAMLC=../../boot/ocamlrun ../../ocamlc
-INCLUDES=-I ../../utils -I ../../typing -I ../../bytecomp
-COMPFLAGS=-warn-error A -I ../../stdlib $(INCLUDES)
-
-OBJS=dynlink.cmo
-COMPILEROBJS=misc.cmo config.cmo tbl.cmo clflags.cmo consistbl.cmo \
- ident.cmo path.cmo \
- types.cmo btype.cmo predef.cmo runtimedef.cmo \
- bytesections.cmo dll.cmo symtable.cmo opcodes.cmo meta.cmo
-
-all: dynlink.cma extract_crc
-
-allopt:
-
-dynlink.cma: $(OBJS)
- $(CAMLC) $(COMPFLAGS) -a -o dynlink.cma $(COMPILEROBJS) $(OBJS)
-
-extract_crc: dynlink.cma extract_crc.cmo
- $(CAMLC) $(COMPFLAGS) -o extract_crc dynlink.cma extract_crc.cmo
-
-install:
- cp dynlink.cmi dynlink.cma dynlink.mli $(LIBDIR)
- cp extract_crc $(LIBDIR)/extract_crc.exe
-
-installopt:
-
-partialclean:
- rm -f extract_crc *.cm[ioa]
-
-clean: partialclean
-
-.SUFFIXES: .ml .mli .cmo .cmi
-
-.mli.cmi:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-depend:
- ../../boot/ocamlrun ../../tools/ocamldep $(INCLUDES) *.mli *.ml >.depend
-
-include .depend
diff --git a/otherlibs/dynlink/dynlink.ml b/otherlibs/dynlink/dynlink.ml
deleted file mode 100644
index 2d4047a615..0000000000
--- a/otherlibs/dynlink/dynlink.ml
+++ /dev/null
@@ -1,248 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Dynamic loading of .cmo files *)
-
-open Emitcode
-
-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
-
-exception Error of error
-
-(* 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, 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();
- add_available_units !default_crcs;
- allow_extension := true
-
-(* Initialize the linker tables and everything *)
-
-let init () =
- default_crcs := Symtable.init_toplevel();
- 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 = String.create (String.length Config.cmi_magic_number) in
- really_input ic buffer 0 (String.length Config.cmi_magic_number);
- if buffer <> Config.cmi_magic_number then begin
- close_in ic;
- raise(Error(Corrupted_interface filename))
- end;
- input_value ic;
- let crc =
- match input_value ic with
- (_, crc) :: _ -> crc
- | _ -> raise(Error(Corrupted_interface filename))
- in
- close_in ic;
- 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 *)
-
-let load_compunit ic file_name 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;
- String.unsafe_set code compunit.cu_codesize (Char.chr Opcodes.opRETURN);
- String.unsafe_set code (compunit.cu_codesize + 1) '\000';
- String.unsafe_set code (compunit.cu_codesize + 2) '\000';
- String.unsafe_set code (compunit.cu_codesize + 3) '\000';
- String.unsafe_set code (compunit.cu_codesize + 4) '\001';
- String.unsafe_set code (compunit.cu_codesize + 5) '\000';
- String.unsafe_set code (compunit.cu_codesize + 6) '\000';
- String.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;
- begin try
- ignore((Meta.reify_bytecode code code_size) ())
- with exn ->
- Symtable.restore_state initial_symtable;
- raise exn
- end
-
-let loadfile file_name =
- let ic = open_in_bin file_name in
- try
- let buffer = String.create (String.length Config.cmo_magic_number) in
- really_input ic buffer 0 (String.length Config.cmo_magic_number);
- if buffer = Config.cmo_magic_number then begin
- let compunit_pos = input_binary_int ic in (* Go to descriptor *)
- seek_in ic compunit_pos;
- load_compunit ic file_name (input_value ic : compilation_unit)
- 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 (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) 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 =
- 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
diff --git a/otherlibs/dynlink/dynlink.mli b/otherlibs/dynlink/dynlink.mli
deleted file mode 100644
index ac5c1a2113..0000000000
--- a/otherlibs/dynlink/dynlink.mli
+++ /dev/null
@@ -1,129 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Dynamic loading of bytecode object files. *)
-
-(** {6 Initialization} *)
-
-val init : unit -> unit
-(** Initialize the [Dynlink] library.
- Must be called before any other function in this module. *)
-
-(** {6 Dynamic loading of compiled bytecode files} *)
-
-val loadfile : string -> unit
-(** Load the given bytecode object file ([.cmo] file) or
- bytecode library file ([.cma] file), 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. *)
-
-(** {6 Access control} *)
-
-val allow_only: string list -> unit
-(** [allow_only units] restricts the compilation units that dynamically-linked
- units can reference: it only allows references to the units named in
- list [units]. References to any other compilation unit will cause
- a [Unavailable_unit] error during [loadfile] or [loadfile_private].
-
- Initially (just after calling [init]), all compilation units composing
- the program currently running are available for reference from
- dynamically-linked units. [allow_only] can be used to grant access
- to some of them only, 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. *)
-
-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. *)
-
-(** {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. *)
-
-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
- Objective Caml standard library directory. *)
-
-val clear_available_units : unit -> unit
-(** Empty the list of compilation units accessible to dynamically-linked
- programs. *)
-
-(** {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
-
-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
deleted file mode 100644
index 80a1568374..0000000000
--- a/otherlibs/dynlink/extract_crc.ml
+++ /dev/null
@@ -1,53 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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 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 _ -> 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/graph/.cvsignore b/otherlibs/graph/.cvsignore
deleted file mode 100644
index 074dd28a45..0000000000
--- a/otherlibs/graph/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-so_locations
diff --git a/otherlibs/graph/.depend b/otherlibs/graph/.depend
deleted file mode 100644
index 1bc2b88109..0000000000
--- a/otherlibs/graph/.depend
+++ /dev/null
@@ -1,48 +0,0 @@
-color.o: color.c libgraph.h ../../byterun/mlvalues.h \
- ../../byterun/config.h ../../config/m.h ../../config/s.h \
- ../../byterun/misc.h
-draw.o: draw.c libgraph.h ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h
-dump_img.o: dump_img.c libgraph.h ../../byterun/mlvalues.h \
- ../../byterun/config.h ../../config/m.h ../../config/s.h \
- ../../byterun/misc.h image.h ../../byterun/alloc.h \
- ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
- ../../byterun/freelist.h ../../byterun/minor_gc.h
-events.o: events.c libgraph.h ../../byterun/mlvalues.h \
- ../../byterun/config.h ../../config/m.h ../../config/s.h \
- ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/signals.h
-fill.o: fill.c libgraph.h ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
- ../../byterun/freelist.h ../../byterun/minor_gc.h
-image.o: image.c libgraph.h ../../byterun/mlvalues.h \
- ../../byterun/config.h ../../config/m.h ../../config/s.h \
- ../../byterun/misc.h image.h ../../byterun/alloc.h \
- ../../byterun/custom.h
-make_img.o: make_img.c libgraph.h ../../byterun/mlvalues.h \
- ../../byterun/config.h ../../config/m.h ../../config/s.h \
- ../../byterun/misc.h image.h ../../byterun/memory.h ../../byterun/gc.h \
- ../../byterun/major_gc.h ../../byterun/freelist.h \
- ../../byterun/minor_gc.h
-open.o: open.c libgraph.h ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h ../../byterun/callback.h ../../byterun/fail.h \
- ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
- ../../byterun/freelist.h ../../byterun/minor_gc.h
-point_col.o: point_col.c libgraph.h ../../byterun/mlvalues.h \
- ../../byterun/config.h ../../config/m.h ../../config/s.h \
- ../../byterun/misc.h
-sound.o: sound.c libgraph.h ../../byterun/mlvalues.h \
- ../../byterun/config.h ../../config/m.h ../../config/s.h \
- ../../byterun/misc.h
-subwindow.o: subwindow.c libgraph.h ../../byterun/mlvalues.h \
- ../../byterun/config.h ../../config/m.h ../../config/s.h \
- ../../byterun/misc.h
-text.o: text.c libgraph.h ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h
-graphics.cmo: graphics.cmi
-graphics.cmx: graphics.cmi
-graphicsX11.cmo: graphics.cmi graphicsX11.cmi
-graphicsX11.cmx: graphics.cmx graphicsX11.cmi
diff --git a/otherlibs/graph/Makefile b/otherlibs/graph/Makefile
deleted file mode 100644
index a35e1d3bae..0000000000
--- a/otherlibs/graph/Makefile
+++ /dev/null
@@ -1,75 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-# Makefile for the portable graphics library
-
-include ../../config/Makefile
-
-CC=$(BYTECC)
-CFLAGS=-I../../byterun $(X11_INCLUDES) -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS)
-CAMLC=../../ocamlcomp.sh
-CAMLOPT=../../ocamlcompopt.sh
-MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib
-COMPFLAGS=-warn-error A
-
-OBJS=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
-
-all: libgraphics.a graphics.cmi graphics.cma
-
-allopt: libgraphics.a graphics.cmi graphics.cmxa
-
-libgraphics.a: $(OBJS)
- $(MKLIB) -o graphics $(OBJS) $(X11_LINK)
-
-graphics.cma: $(CAMLOBJS)
- $(MKLIB) -ocamlc '$(CAMLC)' -o graphics $(CAMLOBJS) $(X11_LINK)
-
-graphics.cmxa: $(CAMLOBJS:.cmo=.cmx)
- $(MKLIB) -ocamlopt '$(CAMLOPT)' -o graphics $(CAMLOBJS:.cmo=.cmx) $(X11_LINK)
-
-partialclean:
- rm -f *.cm*
-
-clean: partialclean
- rm -f *.a *.so *.o
-
-install:
- if test -f dllgraphics.so; then cp dllgraphics.so $(STUBLIBDIR)/dllgraphics.so; fi
- cp libgraphics.a $(LIBDIR)/libgraphics.a
- cd $(LIBDIR); $(RANLIB) libgraphics.a
- cp graphics.cm[ia] graphicsX11.cmi graphics.mli graphicsX11.mli $(LIBDIR)
-
-installopt:
- cp graphics.cmx graphics.cmxa graphics.a $(LIBDIR)
- cd $(LIBDIR); $(RANLIB) graphics.a
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.mli.cmi:
- $(CAMLC) -c $(COMPFLAGS) $<
-.ml.cmo:
- $(CAMLC) -c $(COMPFLAGS) $<
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-depend:
- gcc -MM $(CFLAGS) *.c > .depend
- ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend
-
-include .depend
diff --git a/otherlibs/graph/Makefile.Mac b/otherlibs/graph/Makefile.Mac
deleted file mode 100644
index 7269595e68..0000000000
--- a/otherlibs/graph/Makefile.Mac
+++ /dev/null
@@ -1,40 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-CAMLC = :::boot:ocamlrun :::ocamlc -I :::stdlib:
-
-all Ä graphics.cmi graphics.cma
- set status 0
-
-graphics.cma Ä graphics.cmo
- {CAMLC} -a -o graphics.cma graphics.cmo
-
-partialclean Ä
- delete -i Å.cm[aio] || set status 0
-
-clean Ä partialclean
- set status 0
-
-install Ä
- duplicate -y graphics.cm[ia] graphics.mli "{LIBDIR}"
-
-.cmi Ä .mli
- {CAMLC} -c {default}.mli
-
-.cmo Ä .ml
- {CAMLC} -c {default}.ml
-
-depend Ä
- :::boot:ocamlrun :::tools:ocamldep Å.mli Å.ml > Makefile.Mac.depend
diff --git a/otherlibs/graph/Makefile.Mac.depend b/otherlibs/graph/Makefile.Mac.depend
deleted file mode 100644
index 2877a11eb5..0000000000
--- a/otherlibs/graph/Makefile.Mac.depend
+++ /dev/null
@@ -1,4 +0,0 @@
-graphics.cmoÄ graphics.cmi
-graphics.cmxÄ graphics.cmi
-graphicsX11.cmoÄ graphics.cmi graphicsX11.cmi
-graphicsX11.cmxÄ graphics.cmx graphicsX11.cmi
diff --git a/otherlibs/graph/color.c b/otherlibs/graph/color.c
deleted file mode 100644
index f47fa58147..0000000000
--- a/otherlibs/graph/color.c
+++ /dev/null
@@ -1,230 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "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 direct_rgb = False;
-int red_l, red_r;
-int green_l, green_r;
-int blue_l, blue_r;
-unsigned long red_mask, green_mask, blue_mask;
-
-/* rgb -> pixel table */
-unsigned long red_vals[256];
-unsigned long green_vals[256];
-unsigned long blue_vals[256];
-
-void 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 gr_init_direct_rgb_to_pixel(void)
-{
- Visual *visual;
- int i;
-
- visual = DefaultVisual(grdisplay,grscreen);
-
- if ( visual->class == TrueColor || visual->class == DirectColor ){
- int lsl, lsr;
-
- red_mask = visual->red_mask;
- green_mask = visual->green_mask;
- blue_mask = visual->blue_mask;
-
-#ifdef QUICKCOLORDEBUG
- fprintf(stderr, "visual %lx %lx %lx\n",
- red_mask,
- green_mask,
- blue_mask);
-#endif
-
- get_shifts(red_mask, &red_l, &red_r);
-#ifdef QUICKCOLORDEBUG
- fprintf(stderr, "red %d %d\n", red_l, red_r);
-#endif
- for(i=0; i<256; i++){
- red_vals[i] = (((i << 8) + i) >> red_r) << red_l;
- }
-
- get_shifts(green_mask, &green_l, &green_r);
-#ifdef QUICKCOLORDEBUG
- fprintf(stderr, "green %d %d\n", green_l, green_r);
-#endif
- for(i=0; i<256; i++){
- green_vals[i] = (((i << 8) + i) >> green_r) << green_l;
- }
-
- get_shifts(blue_mask, &blue_l, &blue_r);
-#ifdef QUICKCOLORDEBUG
- fprintf(stderr, "blue %d %d\n", blue_l, blue_r);
-#endif
- for(i=0; i<256; i++){
- blue_vals[i] = (((i << 8) + i) >> blue_r) << blue_l;
- }
-
- if( red_l < 0 || red_r < 0 ||
- green_l < 0 || green_r < 0 ||
- blue_l < 0 || blue_r < 0 ){
-#ifdef QUICKCOLORDEBUG
- fprintf(stderr, "Damn, boost failed\n");
-#endif
- direct_rgb = False;
- } else {
-#ifdef QUICKCOLORDEBUG
- fprintf(stderr, "Boost ok\n");
-#endif
- direct_rgb = True;
- }
- } else {
- /* we cannot use direct_rgb_to_pixel */
-#ifdef QUICKCOLORDEBUG
- fprintf(stderr, "No boost!\n");
-#endif
- direct_rgb = False;
- }
-}
-
-void gr_init_color_cache(void)
-{
- int i;
- for (i = 0; i < Color_cache_size; i++) color_cache[i].rgb = Empty;
- i = Hash_rgb(0, 0, 0);
- color_cache[i].rgb = 0;
- color_cache[i].pixel = grblack;
- i = Hash_rgb(0xFF, 0xFF, 0xFF);
- color_cache[i].rgb = 0xFFFFFF;
- color_cache[i].pixel = grwhite;
-}
-
-unsigned long gr_pixel_rgb(int rgb)
-{
- unsigned int r, g, b;
- int h, i;
- XColor color;
- unsigned short tmp;
-
- r = (rgb >> 16) & 0xFF;
- g = (rgb >> 8) & 0xFF;
- b = rgb & 0xFF;
-
- if (direct_rgb){
- return red_vals[r] | green_vals[g] | blue_vals[b];
- }
-
- 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(grdisplay, grcolormap, &color);
- color_cache[i].rgb = rgb;
- color_cache[i].pixel = color.pixel;
- return color.pixel;
-}
-
-int gr_rgb_pixel(long unsigned int pixel)
-{
- register int r,g,b;
-
- XColor color;
- int i;
-
- if (direct_rgb) {
- r = (((pixel & red_mask) >> red_l) << 8) >> (16 - red_r);
- g = (((pixel & green_mask) >> green_l) << 8) >> (16 - green_r);
- b = (((pixel & blue_mask) >> blue_l) << 8) >> (16 - blue_r);
- return (r << 16) + (g << 8) + b;
- }
-
- if (pixel == grblack) return 0;
- if (pixel == grwhite) 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(grdisplay, grcolormap, &color);
- return
- ((color.red >> 8) << 16) + ((color.green >> 8) << 8) + (color.blue >> 8);
-}
-
-value gr_set_color(value vrgb)
-{
- int xcolor;
- gr_check_open();
- grcolor = Int_val(vrgb);
- if (grcolor >= 0 ){
- xcolor = gr_pixel_rgb(Int_val(vrgb));
- XSetForeground(grdisplay, grwindow.gc, xcolor);
- XSetForeground(grdisplay, grbstore.gc, xcolor);
- } else {
- XSetForeground(grdisplay, grwindow.gc, grbackground);
- XSetForeground(grdisplay, grbstore.gc, grbackground);
- }
- return Val_unit;
-}
diff --git a/otherlibs/graph/draw.c b/otherlibs/graph/draw.c
deleted file mode 100644
index 18166168bf..0000000000
--- a/otherlibs/graph/draw.c
+++ /dev/null
@@ -1,131 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "libgraph.h"
-#include <alloc.h>
-
-value gr_plot(value vx, value vy)
-{
- int x = Int_val(vx);
- int y = Int_val(vy);
- gr_check_open();
- if(grremember_mode)
- XDrawPoint(grdisplay, grbstore.win, grbstore.gc, x, Bcvt(y));
- if(grdisplay_mode) {
- XDrawPoint(grdisplay, grwindow.win, grwindow.gc, x, Wcvt(y));
- XFlush(grdisplay);
- }
- return Val_unit;
-}
-
-value gr_moveto(value vx, value vy)
-{
- grx = Int_val(vx);
- gry = Int_val(vy);
- return Val_unit;
-}
-
-value gr_current_x(void)
-{
- return Val_int(grx);
-}
-
-value gr_current_y(void)
-{
- return Val_int(gry);
-}
-
-value gr_lineto(value vx, value vy)
-{
- int x = Int_val(vx);
- int y = Int_val(vy);
- gr_check_open();
- if(grremember_mode)
- XDrawLine(grdisplay, grbstore.win, grbstore.gc,
- grx, Bcvt(gry), x, Bcvt(y));
- if(grdisplay_mode) {
- XDrawLine(grdisplay, grwindow.win, grwindow.gc,
- grx, Wcvt(gry), x, Wcvt(y));
- XFlush(grdisplay);
- }
- grx = x;
- gry = y;
- return Val_unit;
-}
-
-value gr_draw_rect(value vx, value vy, value vw, value vh)
-{
- int x = Int_val(vx);
- int y = Int_val(vy);
- int w = Int_val(vw);
- int h = Int_val(vh);
-
- gr_check_open();
- y = Bcvt(y) - h + 1;
- /* Correct for XDrawRectangle irritating habit of drawing a larger
- rectangle hanging out one pixel below and to the right of the
- expected rectangle */
- if (w == 0 || h == 0) return Val_unit;
- y += 1;
- w -= 1;
- h -= 1;
- if(grremember_mode)
- XDrawRectangle(grdisplay, grbstore.win, grbstore.gc,
- x, y, w, h);
- if(grdisplay_mode) {
- XDrawRectangle(grdisplay, grwindow.win, grwindow.gc,
- x, y, w, h);
- XFlush(grdisplay);
- }
- return Val_unit;
-}
-
-value 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);
-
- gr_check_open();
- if(grremember_mode)
- XDrawArc(grdisplay, grbstore.win, grbstore.gc,
- x - rx, Bcvt(y) - ry, rx * 2, ry * 2, a1 * 64, (a2 - a1) * 64);
- if(grdisplay_mode) {
- XDrawArc(grdisplay, grwindow.win, grwindow.gc,
- x - rx, Wcvt(y) - ry, rx * 2, ry * 2, a1 * 64, (a2 - a1) * 64);
- XFlush(grdisplay);
- }
- return Val_unit;
-}
-
-value gr_draw_arc(value *argv, int argc)
-{
- return gr_draw_arc_nat(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
-}
-
-value gr_set_line_width(value vwidth)
-{
- int width = Int_val(vwidth);
-
- gr_check_open();
- XSetLineAttributes(grdisplay, grwindow.gc,
- width, LineSolid, CapRound, JoinRound);
- XSetLineAttributes(grdisplay, grbstore.gc,
- width, LineSolid, CapRound, JoinRound);
- return Val_unit;
-}
diff --git a/otherlibs/graph/dump_img.c b/otherlibs/graph/dump_img.c
deleted file mode 100644
index 75a9dce43e..0000000000
--- a/otherlibs/graph/dump_img.c
+++ /dev/null
@@ -1,55 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "libgraph.h"
-#include "image.h"
-#include <alloc.h>
-#include <memory.h>
-
-value gr_dump_image(value image)
-{
- int width, height, i, j;
- XImage * idata, * imask;
- value m = Val_unit;
-
- Begin_roots2(image, m);
- gr_check_open();
- width = Width_im(image);
- height = Height_im(image);
- m = alloc(height, 0);
- for (i = 0; i < height; i++) {
- value v = alloc(width, 0);
- modify(&Field(m, i), v);
- }
-
- idata =
- XGetImage(grdisplay, Data_im(image), 0, 0, width, height, (-1), ZPixmap);
- for (i = 0; i < height; i++)
- for (j = 0; j < width; j++)
- Field(Field(m, i), j) = Val_int(gr_rgb_pixel(XGetPixel(idata, j, i)));
- XDestroyImage(idata);
-
- if (Mask_im(image) != None) {
- imask =
- XGetImage(grdisplay, 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
deleted file mode 100644
index 1f0029d25f..0000000000
--- a/otherlibs/graph/events.c
+++ /dev/null
@@ -1,287 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <signal.h>
-#include "libgraph.h"
-#include <alloc.h>
-#include <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 gr_queue[SIZE_QUEUE];
-static unsigned int gr_head = 0; /* position of next read */
-static unsigned int gr_tail = 0; /* position of next write */
-
-#define QueueIsEmpty (gr_tail == gr_head)
-
-static void gr_enqueue_event(int kind, int mouse_x, int mouse_y,
- int button, int key)
-{
- struct event_data * ev;
-
- ev = &(gr_queue[gr_tail]);
- ev->kind = kind;
- ev->mouse_x = mouse_x;
- ev->mouse_y = mouse_y;
- ev->button = (button != 0);
- ev->key = key;
- gr_tail = (gr_tail + 1) % SIZE_QUEUE;
- /* If queue was full, it now appears empty; drop oldest entry from queue. */
- if (QueueIsEmpty) gr_head = (gr_head + 1) % SIZE_QUEUE;
-}
-
-#define BUTTON_STATE(state) \
- ((state) & (Button1Mask|Button2Mask|Button3Mask|Button4Mask|Button5Mask))
-
-void gr_handle_event(XEvent * event)
-{
- switch (event->type) {
-
- case Expose:
- XCopyArea(grdisplay, grbstore.win, grwindow.win, grwindow.gc,
- event->xexpose.x, event->xexpose.y + grbstore.h - grwindow.h,
- event->xexpose.width, event->xexpose.height,
- event->xexpose.x, event->xexpose.y);
- XFlush(grdisplay);
- break;
-
- case ConfigureNotify:
- grwindow.w = event->xconfigure.width;
- grwindow.h = event->xconfigure.height;
- if (grwindow.w > grbstore.w || grwindow.h > grbstore.h) {
-
- /* Allocate a new backing store large enough to accomodate
- both the old backing store and the current window. */
- struct canvas newbstore;
- newbstore.w = max(grwindow.w, grbstore.w);
- newbstore.h = max(grwindow.h, grbstore.h);
- newbstore.win =
- XCreatePixmap(grdisplay, grwindow.win, newbstore.w, newbstore.h,
- XDefaultDepth(grdisplay, grscreen));
- newbstore.gc = XCreateGC(grdisplay, newbstore.win, 0, NULL);
- XSetBackground(grdisplay, newbstore.gc, grwhite);
- XSetForeground(grdisplay, newbstore.gc, grwhite);
- XFillRectangle(grdisplay, newbstore.win, newbstore.gc,
- 0, 0, newbstore.w, newbstore.h);
- XSetForeground(grdisplay, newbstore.gc, grcolor);
- if (grfont != NULL)
- XSetFont(grdisplay, newbstore.gc, grfont->fid);
-
- /* Copy the old backing store into the new one */
- XCopyArea(grdisplay, grbstore.win, newbstore.win, newbstore.gc,
- 0, 0, grbstore.w, grbstore.h, 0, newbstore.h - grbstore.h);
-
- /* Free the old backing store */
- XFreeGC(grdisplay, grbstore.gc);
- XFreePixmap(grdisplay, grbstore.win);
-
- /* Use the new backing store */
- grbstore = newbstore;
- XFlush(grdisplay);
- }
- 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--)
- gr_enqueue_event(event->type, event->xkey.x, event->xkey.y,
- BUTTON_STATE(event->xkey.state), *p);
- break;
- }
-
- case ButtonPress:
- case ButtonRelease:
- gr_enqueue_event(event->type, event->xbutton.x, event->xbutton.y,
- event->type == ButtonPress, 0);
- break;
-
- case MotionNotify:
- gr_enqueue_event(event->type, event->xmotion.x, event->xmotion.y,
- BUTTON_STATE(event->xmotion.state), 0);
- break;
- }
-}
-
-static value gr_wait_allocate_result(int mouse_x, int mouse_y, int button,
- int keypressed, int key)
-{
- value res = 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 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;
-
- if (XQueryPointer(grdisplay, grwindow.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 = gr_head; i != gr_tail; i = (i + 1) % SIZE_QUEUE) {
- if (gr_queue[i].kind == KeyPress) {
- keypressed = True;
- key = gr_queue[i].key;
- break;
- }
- }
- return gr_wait_allocate_result(mouse_x, mouse_y, button, keypressed, key);
-}
-
-static value gr_wait_event_in_queue(long mask)
-{
- struct event_data * ev;
- /* Pop events in queue until one matches mask. */
- while (gr_head != gr_tail) {
- ev = &(gr_queue[gr_head]);
- gr_head = (gr_head + 1) % SIZE_QUEUE;
- if ((ev->kind == KeyPress && (mask & KeyPressMask))
- || (ev->kind == ButtonPress && (mask & ButtonPressMask))
- || (ev->kind == ButtonRelease && (mask & ButtonReleaseMask))
- || (ev->kind == MotionNotify && (mask & PointerMotionMask)))
- return gr_wait_allocate_result(ev->mouse_x, ev->mouse_y,
- ev->button, ev->kind == KeyPress,
- ev->key);
- }
- return Val_false;
-}
-
-static value gr_wait_event_blocking(long mask)
-{
-#ifdef POSIX_SIGNALS
- sigset_t sigset;
-#else
- void (*oldsig)();
-#endif
- XEvent event;
- fd_set readfds;
- value res;
-
- /* First see if we have a matching event in the queue */
- res = gr_wait_event_in_queue(mask);
- if (res != Val_false) return res;
-
- /* Increase the selected events if required */
- if ((mask & ~grselected_events) != 0) {
- grselected_events |= mask;
- XSelectInput(grdisplay, grwindow.win, grselected_events);
- }
-
- /* Block or deactivate the EVENT signal */
-#ifdef POSIX_SIGNALS
- sigemptyset(&sigset);
- sigaddset(&sigset, EVENT_SIGNAL);
- sigprocmask(SIG_BLOCK, &sigset, NULL);
-#else
- oldsig = signal(EVENT_SIGNAL, SIG_IGN);
-#endif
-
- /* Replenish our event queue from that of X11 */
- while (1) {
- if (XCheckMaskEvent(grdisplay, -1 /*all events*/, &event)) {
- /* One event available: add it to our queue */
- gr_handle_event(&event);
- /* See if we now have a matching event */
- res = gr_wait_event_in_queue(mask);
- if (res != Val_false) break;
- } else {
- /* No event available: block on input socket until one is */
- FD_ZERO(&readfds);
- FD_SET(ConnectionNumber(grdisplay), &readfds);
- enter_blocking_section();
- select(FD_SETSIZE, &readfds, NULL, NULL, NULL);
- leave_blocking_section();
- }
- }
-
- /* Restore the EVENT signal to its initial state */
-#ifdef POSIX_SIGNALS
- sigprocmask(SIG_UNBLOCK, &sigset, NULL);
-#else
- signal(EVENT_SIGNAL, oldsig);
-#endif
-
- /* Return result */
- return res;
-}
-
-value gr_wait_event(value eventlist) /* ML */
-{
- int mask;
- Bool poll;
-
- 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 gr_wait_event_poll();
- else
- return gr_wait_event_blocking(mask);
-}
diff --git a/otherlibs/graph/fill.c b/otherlibs/graph/fill.c
deleted file mode 100644
index faaa3c4cf3..0000000000
--- a/otherlibs/graph/fill.c
+++ /dev/null
@@ -1,88 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "libgraph.h"
-#include <memory.h>
-
-value gr_fill_rect(value vx, value vy, value vw, value vh)
-{
- int x = Int_val(vx);
- int y = Int_val(vy);
- int w = Int_val(vw);
- int h = Int_val(vh);
-
- gr_check_open();
- if(grremember_mode)
- XFillRectangle(grdisplay, grbstore.win, grbstore.gc,
- x, Bcvt(y) - h + 1, w, h);
- if(grdisplay_mode) {
- XFillRectangle(grdisplay, grwindow.win, grwindow.gc,
- x, Wcvt(y) - h + 1, w, h);
- XFlush(grdisplay);
- }
- return Val_unit;
-}
-
-value gr_fill_poly(value array)
-{
- XPoint * points;
- int npoints, i;
-
- gr_check_open();
- npoints = Wosize_val(array);
- points = (XPoint *) stat_alloc(npoints * sizeof(XPoint));
- for (i = 0; i < npoints; i++) {
- points[i].x = Int_val(Field(Field(array, i), 0));
- points[i].y = Bcvt(Int_val(Field(Field(array, i), 1)));
- }
- if(grremember_mode)
- XFillPolygon(grdisplay, grbstore.win, grbstore.gc, points,
- npoints, Complex, CoordModeOrigin);
- if(grdisplay_mode) {
- for (i = 0; i < npoints; i++)
- points[i].y = BtoW(points[i].y);
- XFillPolygon(grdisplay, grwindow.win, grwindow.gc, points,
- npoints, Complex, CoordModeOrigin);
- XFlush(grdisplay);
- }
- stat_free((char *) points);
- return Val_unit;
-}
-
-value 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);
-
- gr_check_open();
- if(grremember_mode)
- XFillArc(grdisplay, grbstore.win, grbstore.gc,
- x - rx, Bcvt(y) - ry, rx * 2, ry * 2, a1 * 64, (a2 - a1) * 64);
- if(grdisplay_mode) {
- XFillArc(grdisplay, grwindow.win, grwindow.gc,
- x - rx, Wcvt(y) - ry, rx * 2, ry * 2, a1 * 64, (a2 - a1) * 64);
- XFlush(grdisplay);
- }
- return Val_unit;
-}
-
-value gr_fill_arc(value *argv, int argc)
-{
- return 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
deleted file mode 100644
index 88e7450e0a..0000000000
--- a/otherlibs/graph/graphics.ml
+++ /dev/null
@@ -1,228 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-exception Graphic_failure of string
-
-(* Initializations *)
-
-let _ =
- Callback.register_exception "Graphics.Graphic_failure" (Graphic_failure "")
-
-external raw_open_graph: string -> unit = "gr_open_graph"
-external raw_close_graph: unit -> unit = "gr_close_graph"
-external sigio_signal: unit -> int = "gr_sigio_signal"
-external sigio_handler: int -> unit = "gr_sigio_handler"
-
-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 = "gr_set_window_title"
-external clear_graph : unit -> unit = "gr_clear_graph"
-external size_x : unit -> int = "gr_size_x"
-external size_y : unit -> int = "gr_size_y"
-
-(* Double-buffering *)
-
-external display_mode : bool -> unit = "gr_display_mode"
-external remember_mode : bool -> unit = "gr_remember_mode"
-external synchronize : unit -> unit = "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 = "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 = "gr_plot"
-let plots points =
- for i = 0 to Array.length points - 1 do
- let (x, y) = points.(i) in
- plot x y;
- done
-;;
-external point_color : int -> int -> color = "gr_point_color"
-external moveto : int -> int -> unit = "gr_moveto"
-external current_x : unit -> int = "gr_current_x"
-external current_y : unit -> int = "gr_current_y"
-let current_point () = current_x (), current_y ()
-external lineto : int -> int -> unit = "gr_lineto"
-let rlineto x y = lineto (current_x () + x) (current_y () + y)
-let rmoveto x y = moveto (current_x () + x) (current_y () + y)
-external draw_rect : int -> int -> int -> int -> unit = "gr_draw_rect"
-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 draw_arc : int -> int -> int -> int -> int -> int -> unit
- = "gr_draw_arc" "gr_draw_arc_nat"
-let draw_ellipse x y rx ry = draw_arc x y rx ry 0 360
-let draw_circle x y r = draw_arc x y r r 0 360
-external set_line_width : int -> unit = "gr_set_line_width"
-
-external fill_rect : int -> int -> int -> int -> unit = "gr_fill_rect"
-external fill_poly : (int * int) array -> unit = "gr_fill_poly"
-external fill_arc : int -> int -> int -> int -> int -> int -> unit
- = "gr_fill_arc" "gr_fill_arc_nat"
-let fill_ellipse x y rx ry = fill_arc x y rx ry 0 360
-let fill_circle x y r = fill_arc x y r r 0 360
-
-(* Text *)
-
-external draw_char : char -> unit = "gr_draw_char"
-external draw_string : string -> unit = "gr_draw_string"
-external set_font : string -> unit = "gr_set_font"
-external set_text_size : int -> unit = "gr_set_text_size"
-external text_size : string -> int * int = "gr_text_size"
-
-(* Images *)
-
-type image
-
-let transp = -1
-
-external make_image : color array array -> image = "gr_make_image"
-external dump_image : image -> color array array = "gr_dump_image"
-external draw_image : image -> int -> int -> unit = "gr_draw_image"
-external create_image : int -> int -> image = "gr_create_image"
-external blit_image : image -> int -> int -> unit = "gr_blit_image"
-
-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 = "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
-
-(*** Sound *)
-
-external sound : int -> int -> unit = "gr_sound"
-
-(* Splines *)
-let add (x1, y1) (x2, y2) = (x1 +. x2, y1 +. y2)
-and 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
deleted file mode 100644
index ff271ce556..0000000000
--- a/otherlibs/graph/graphics.mli
+++ /dev/null
@@ -1,374 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Machine-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. *)
-
-external clear_graph : unit -> unit = "gr_clear_graph"
-(** Erase the graphics window. *)
-
-external size_x : unit -> int = "gr_size_x"
-(** See {!Graphics.size_y}. *)
-
-external size_y : unit -> int = "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. *)
-
-(** {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 = "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 = "gr_plot"
-(** Plot the given point with the current drawing color. *)
-
-val plots : (int * int) array -> unit
-(** Plot the given points with the current drawing color. *)
-
-external point_color : int -> int -> color = "gr_point_color"
-(** Return the color of the given point in the backing store
- (see "Double buffering" below). *)
-
-external moveto : int -> int -> unit = "gr_moveto"
-(** Position the current point. *)
-
-val rmoveto : int -> int -> unit
-(** [rmoveto dx dy] translates the current point by the given vector. *)
-
-external current_x : unit -> int = "gr_current_x"
-(** Return the abscissa of the current point. *)
-
-external current_y : unit -> int = "gr_current_y"
-(** Return the ordinate of the current point. *)
-
-val current_point : unit -> int * int
-(** Return the position of the current point. *)
-
-external lineto : int -> int -> unit = "gr_lineto"
-(** 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]. *)
-
-external draw_rect : int -> int -> int -> int -> unit = "gr_draw_rect"
-(** [draw_rect x y w h] draws the rectangle with lower left corner
- at [x,y], width [w] and height [h].
- The current point is unchanged. *)
-
-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. *)
-
-external draw_arc :
- int -> int -> int -> int -> int -> int ->
- unit = "gr_draw_arc" "gr_draw_arc_nat"
-(** [draw_arc x y rx ry a1 a2] draws an elliptical arc with center
- [x,y], horizontal radius [rx], vertical radius [ry], from angle
- [a1] to angle [a2] (in degrees). The current point is unchanged. *)
-
-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. *)
-
-val draw_circle : int -> int -> int -> unit
-(** [draw_circle x y r] draws a circle with center [x,y] and
- radius [r]. The current point is unchanged. *)
-
-external set_line_width : int -> unit = "gr_set_line_width"
-(** 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. *)
-
-(** {6 Text drawing} *)
-
-external draw_char : char -> unit = "gr_draw_char"
-(** See {!Graphics.draw_string}.*)
-
-external draw_string : string -> unit = "gr_draw_string"
-(** Draw a character or a character string with lower left corner
- at current position. After drawing, the current position is set
- to the lower right corner of the text drawn. *)
-
-external set_font : string -> unit = "gr_set_font"
-(** Set the font used for drawing text.
- The interpretation of the arguments to [set_font]
- is implementation-dependent. *)
-
-val set_text_size : int -> unit
-(** Set the character size used for drawing text.
- The interpretation of the arguments to [set_text_size]
- is implementation-dependent. *)
-
-external text_size : string -> int * int = "gr_text_size"
-(** Return the dimensions of the given text, if it were drawn with
- the current font and size. *)
-
-
-(** {6 Filling} *)
-
-external fill_rect : int -> int -> int -> int -> unit = "gr_fill_rect"
-(** [fill_rect x y w h] fills the rectangle with lower left corner
- at [x,y], width [w] and height [h], with the current color. *)
-
-external fill_poly : (int * int) array -> unit = "gr_fill_poly"
-(** Fill the given polygon with the current color. The array
- contains the coordinates of the vertices of the polygon. *)
-
-external fill_arc :
- int -> int -> int -> int -> int -> int ->
- unit = "gr_fill_arc" "gr_fill_arc_nat"
-(** 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 = "gr_make_image"
-(** Convert the given color matrix to an image.
- Each sub-array represents one horizontal line. All sub-arrays
- must have the same length; otherwise, exception [Graphic_failure]
- is raised. *)
-
-external dump_image : image -> color array array = "gr_dump_image"
-(** Convert an image to a color matrix. *)
-
-external draw_image : image -> int -> int -> unit = "gr_draw_image"
-(** Draw the given image with lower left corner at the given point. *)
-
-val get_image : int -> int -> int -> int -> image
-(** Capture the contents of a rectangle on the screen as an image.
- The parameters are the same as for {!Graphics.fill_rect}. *)
-
-external create_image : int -> int -> image = "gr_create_image"
-(** [create_image w h] returns a new image [w] pixels wide and [h]
- pixels tall, to be used in conjunction with [blit_image].
- The initial image contents are random, except that no point
- is transparent. *)
-
-external blit_image : image -> int -> int -> unit = "gr_blit_image"
-(** [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 = "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. *)
-
-(** {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 = "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 = "gr_synchronize"
-(** Synchronize the backing store and the on-screen window, by
- copying the contents of the backing store onto the graphics
- window. *)
-
-
-external display_mode : bool -> unit = "gr_display_mode"
-(** 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 = "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
deleted file mode 100644
index 69f7b718d6..0000000000
--- a/otherlibs/graph/graphicsX11.ml
+++ /dev/null
@@ -1,42 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* 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 Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Module [GraphicsX11]: additional graphics primitives for the X Windows system *)
-
-type window_id = string
-
-external window_id : unit -> window_id = "gr_window_id"
-
-let subwindows = Hashtbl.create 13
-
-external open_subwindow : int -> int -> int -> int -> window_id
- = "gr_open_subwindow"
-external close_subwindow : window_id -> unit
- = "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
deleted file mode 100644
index ff55adf668..0000000000
--- a/otherlibs/graph/graphicsX11.mli
+++ /dev/null
@@ -1,31 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* 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 Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Additional graphics primitives for the X Windows system. *)
-
-type window_id = string
-
-val window_id : unit -> window_id
-(** Return the unique identifier of the Caml 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 Caml 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
deleted file mode 100644
index 8d47fc4e58..0000000000
--- a/otherlibs/graph/image.c
+++ /dev/null
@@ -1,105 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "libgraph.h"
-#include "image.h"
-#include <alloc.h>
-#include <custom.h>
-
-static void gr_free_image(value im)
-{
- XFreePixmap(grdisplay, Data_im(im));
- if (Mask_im(im) != None) XFreePixmap(grdisplay, Mask_im(im));
-}
-
-static struct custom_operations image_ops = {
- "_image",
- gr_free_image,
- custom_compare_default,
- custom_hash_default,
- custom_serialize_default,
- custom_deserialize_default
-};
-
-#define Max_image_mem 2000000
-
-value gr_new_image(int w, int h)
-{
- value res = alloc_custom(&image_ops, sizeof(struct grimage),
- w * h, Max_image_mem);
- Width_im(res) = w;
- Height_im(res) = h;
- Data_im(res) = XCreatePixmap(grdisplay, grwindow.win, w, h,
- XDefaultDepth(grdisplay, grscreen));
- Mask_im(res) = None;
- return res;
-}
-
-value gr_create_image(value vw, value vh)
-{
- gr_check_open();
- return gr_new_image(Int_val(vw), Int_val(vh));
-}
-
-value gr_blit_image(value im, value vx, value vy)
-{
- int x = Int_val(vx);
- int y = Int_val(vy);
- gr_check_open();
- XCopyArea(grdisplay, grbstore.win, Data_im(im), grbstore.gc,
- x, Bcvt(y) + 1 - Height_im(im),
- Width_im(im), Height_im(im),
- 0, 0);
- return Val_unit;
-}
-
-value gr_draw_image(value im, value vx, value vy)
-{
- int x = Int_val(vx);
- int y = Int_val(vy);
- int wy = Wcvt(y) + 1 - Height_im(im);
- int by = Bcvt(y) + 1 - Height_im(im);
-
- gr_check_open();
- if (Mask_im(im) != None) {
- if(grremember_mode) {
- XSetClipOrigin(grdisplay, grbstore.gc, x, by);
- XSetClipMask(grdisplay, grbstore.gc, Mask_im(im));
- }
- if(grdisplay_mode) {
- XSetClipOrigin(grdisplay, grwindow.gc, x, wy);
- XSetClipMask(grdisplay, grwindow.gc, Mask_im(im));
- }
- }
- if(grremember_mode)
- XCopyArea(grdisplay, Data_im(im), grbstore.win, grbstore.gc,
- 0, 0,
- Width_im(im), Height_im(im),
- x, by);
- if(grdisplay_mode)
- XCopyArea(grdisplay, Data_im(im), grwindow.win, grwindow.gc,
- 0, 0,
- Width_im(im), Height_im(im),
- x, wy);
- if (Mask_im(im) != None) {
- if(grremember_mode)
- XSetClipMask(grdisplay, grbstore.gc, None);
- if(grdisplay_mode)
- XSetClipMask(grdisplay, grwindow.gc, None);
- }
- if(grdisplay_mode)
- XFlush(grdisplay);
- return Val_unit;
-}
diff --git a/otherlibs/graph/image.h b/otherlibs/graph/image.h
deleted file mode 100644
index 441da97fbc..0000000000
--- a/otherlibs/graph/image.h
+++ /dev/null
@@ -1,29 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-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 gr_new_image(int w, int h);
diff --git a/otherlibs/graph/libgraph.h b/otherlibs/graph/libgraph.h
deleted file mode 100644
index 605c5a463f..0000000000
--- a/otherlibs/graph/libgraph.h
+++ /dev/null
@@ -1,84 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <stdio.h>
-#include <X11/Xlib.h>
-#include <X11/Xutil.h>
-#include <mlvalues.h>
-
-struct canvas {
- int w, h; /* Dimensions of the drawable */
- Drawable win; /* The drawable itself */
- GC gc; /* The associated graphics context */
-};
-
-extern Display * grdisplay; /* The display connection */
-extern int grscreen; /* The screen number */
-extern Colormap grcolormap; /* The color map */
-extern struct canvas grwindow; /* The graphics window */
-extern struct canvas grbstore; /* The pixmap used for backing store */
-extern int grwhite, grblack; /* Black and white pixels for X */
-extern int grbackground; /* Background color for X
- (used for CAML color -1) */
-extern Bool grdisplay_mode; /* Display-mode flag */
-extern Bool grremember_mode; /* Remember-mode flag */
-extern int grx, gry; /* Coordinates of the current point */
-extern int grcolor; /* Current *CAML* drawing color (can be -1) */
-extern XFontStruct * grfont; /* Current font */
-extern long grselected_events; /* Events we are interested in */
-
-extern Bool direct_rgb;
-extern int byte_order;
-extern int bitmap_unit;
-extern int bits_per_pixel;
-
-#define Wcvt(y) (grwindow.h - 1 - (y))
-#define Bcvt(y) (grbstore.h - 1 - (y))
-#define WtoB(y) ((y) + grbstore.h - grwindow.h)
-#define BtoW(y) ((y) + grwindow.h - grbstore.h)
-#define 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 "Caml 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
-
-extern void gr_fail(char *fmt, char *arg);
-extern void gr_check_open(void);
-extern unsigned long gr_pixel_rgb(int rgb);
-extern int gr_rgb_pixel(long unsigned int pixel);
-extern void gr_handle_event(XEvent *e);
-extern void gr_init_color_cache(void);
-extern void gr_init_direct_rgb_to_pixel(void);
-extern value id_of_window( Window w );
diff --git a/otherlibs/graph/make_img.c b/otherlibs/graph/make_img.c
deleted file mode 100644
index a0d15a824f..0000000000
--- a/otherlibs/graph/make_img.c
+++ /dev/null
@@ -1,95 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "libgraph.h"
-#include "image.h"
-#include <memory.h>
-
-value 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;
-
- gr_check_open();
- height = Wosize_val(m);
- if (height == 0) return gr_new_image(0, 0);
- width = Wosize_val(Field(m, 0));
- for (i = 1; i < height; i++)
- if (Wosize_val(Field(m, i)) != width)
- gr_fail("make_image: lines of different lengths", NULL);
-
- /* Build an XImage for the data part of the image */
- idata =
- XCreateImage(grdisplay, DefaultVisual(grdisplay, grscreen),
- XDefaultDepth(grdisplay, grscreen),
- ZPixmap, 0, NULL, width, height,
- BitmapPad(grdisplay), 0);
-
- bdata = (char *) 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, 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(grdisplay, DefaultVisual(grdisplay, grscreen),
- 1, ZPixmap, 0, NULL, width, height,
- BitmapPad(grdisplay), 0);
- bmask = (char *) 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 = gr_new_image(width, height);
- gc = XCreateGC(grdisplay, Data_im(im), 0, NULL);
- XPutImage(grdisplay, Data_im(im), gc, idata, 0, 0, 0, 0, width, height);
- XDestroyImage(idata);
- XFreeGC(grdisplay, gc);
- if (has_transp) {
- Mask_im(im) = XCreatePixmap(grdisplay, grwindow.win, width, height, 1);
- gc = XCreateGC(grdisplay, Mask_im(im), 0, NULL);
- XPutImage(grdisplay, Mask_im(im), gc, imask, 0, 0, 0, 0, width, height);
- XDestroyImage(imask);
- XFreeGC(grdisplay, gc);
- }
- XFlush(grdisplay);
- return im;
-}
diff --git a/otherlibs/graph/open.c b/otherlibs/graph/open.c
deleted file mode 100644
index 3bc034ec36..0000000000
--- a/otherlibs/graph/open.c
+++ /dev/null
@@ -1,366 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <string.h>
-#include <fcntl.h>
-#include <signal.h>
-#include "libgraph.h"
-#include <alloc.h>
-#include <callback.h>
-#include <fail.h>
-#include <memory.h>
-#ifdef HAS_UNISTD
-#include <unistd.h>
-#endif
-#ifdef HAS_SETITIMER
-#include <sys/time.h>
-#endif
-
-Display * grdisplay = NULL;
-int grscreen;
-Colormap grcolormap;
-int grwhite, grblack, grbackground;
-struct canvas grwindow;
-struct canvas grbstore;
-Bool grdisplay_mode;
-Bool grremember_mode;
-int grx, gry;
-int grcolor;
-extern XFontStruct * grfont;
-long grselected_events;
-static Bool gr_initialized = False;
-static char * window_name = NULL;
-
-static int gr_error_handler(Display *display, XErrorEvent *error);
-static int gr_ioerror_handler(Display *display);
-value gr_clear_graph(void);
-
-value 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 (gr_initialized) {
- 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 (grdisplay == NULL) {
- grdisplay = XOpenDisplay(display_name);
- if (grdisplay == NULL)
- gr_fail("Cannot open display %s", XDisplayName(display_name));
- grscreen = DefaultScreen(grdisplay);
- grblack = BlackPixel(grdisplay, grscreen);
- grwhite = WhitePixel(grdisplay, grscreen);
- grbackground = grwhite;
- grcolormap = DefaultColormap(grdisplay, grscreen);
- }
-
- /* Set up the error handlers */
- XSetErrorHandler(gr_error_handler);
- XSetIOErrorHandler(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(grdisplay, grscreen, 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 */
- grcolor = 0; /* CAML COLOR */
-
- /* Create the on-screen window */
- grwindow.w = hints.width;
- grwindow.h = hints.height;
- grwindow.win =
- XCreateSimpleWindow(grdisplay, DefaultRootWindow(grdisplay),
- hints.x, hints.y, hints.width, hints.height,
- BORDER_WIDTH, grblack, grbackground);
- p = window_name;
- if (p == NULL) p = DEFAULT_WINDOW_NAME;
- XSetStandardProperties(grdisplay, grwindow.win, p, p,
- None, NULL, 0, &hints);
- grwindow.gc = XCreateGC(grdisplay, grwindow.win, 0, NULL);
- XSetBackground(grdisplay, grwindow.gc, grbackground);
- XSetForeground(grdisplay, grwindow.gc, grblack);
-
- /* Require exposure, resize and keyboard events */
- grselected_events = DEFAULT_SELECTED_EVENTS;
- XSelectInput(grdisplay, grwindow.win, grselected_events);
-
- /* Map the window on the screen and wait for the first Expose event */
- XMapWindow(grdisplay, grwindow.win);
- do { XNextEvent(grdisplay, &event); } while (event.type != Expose);
-
- /* Get the actual window dimensions */
- XGetWindowAttributes(grdisplay, grwindow.win, &attributes);
- grwindow.w = attributes.width;
- grwindow.h = attributes.height;
-
- /* Create the pixmap used for backing store */
- grbstore.w = grwindow.w;
- grbstore.h = grwindow.h;
- grbstore.win =
- XCreatePixmap(grdisplay, grwindow.win, grbstore.w, grbstore.h,
- XDefaultDepth(grdisplay, grscreen));
- grbstore.gc = XCreateGC(grdisplay, grbstore.win, 0, NULL);
- XSetBackground(grdisplay, grbstore.gc, grbackground);
-
- /* Clear the pixmap */
- XSetForeground(grdisplay, grbstore.gc, grbackground);
- XFillRectangle(grdisplay, grbstore.win, grbstore.gc,
- 0, 0, grbstore.w, grbstore.h);
- XSetForeground(grdisplay, grbstore.gc, grblack);
-
- /* Set the display and remember modes on */
- grdisplay_mode = True ;
- grremember_mode = True ;
-
- /* The global data structures are now correctly initialized.
- In particular, gr_sigio_handler can now handle events safely. */
- 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(grdisplay), F_GETFL, 0);
- fcntl(ConnectionNumber(grdisplay), F_SETFL, ret | FASYNC);
- fcntl(ConnectionNumber(grdisplay), 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 */
- grx = 0;
- gry = 0;
- /* Reset the color cache */
- gr_init_color_cache();
- gr_init_direct_rgb_to_pixel();
- return Val_unit;
-}
-
-value gr_close_graph(void)
-{
- if (gr_initialized) {
-#ifdef USE_INTERVAL_TIMER
- struct itimerval it;
- it.it_value.tv_sec = 0;
- it.it_value.tv_usec = 0;
- setitimer(ITIMER_REAL, &it, NULL);
-#endif
- gr_initialized = False;
- if (grfont != NULL) { XFreeFont(grdisplay, grfont); grfont = NULL; }
- XFreeGC(grdisplay, grwindow.gc);
- XDestroyWindow(grdisplay, grwindow.win);
- XFreeGC(grdisplay, grbstore.gc);
- XFreePixmap(grdisplay, grbstore.win);
- XFlush(grdisplay);
- }
- return Val_unit;
-}
-
-value id_of_window(Window win)
-{
- char tmp[256];
-
- sprintf(tmp, "%lu", (unsigned long)win);
- return copy_string( tmp );
-}
-
-value gr_window_id(void)
-{
- gr_check_open();
- return id_of_window(grwindow.win);
-}
-
-value gr_set_window_title(value n)
-{
- if (window_name != NULL) stat_free(window_name);
- window_name = stat_alloc(strlen(String_val(n)));
- strcpy(window_name, String_val(n));
- if (gr_initialized) {
- XStoreName(grdisplay, grwindow.win, window_name);
- XSetIconName(grdisplay, grwindow.win, window_name);
- XFlush(grdisplay);
- }
- return Val_unit;
-}
-
-value gr_clear_graph(void)
-{
- gr_check_open();
- if(grremember_mode) {
- XSetForeground(grdisplay, grbstore.gc, grwhite);
- XFillRectangle(grdisplay, grbstore.win, grbstore.gc,
- 0, 0, grbstore.w, grbstore.h);
- XSetForeground(grdisplay, grbstore.gc, grcolor);
- }
- if(grdisplay_mode) {
- XSetForeground(grdisplay, grwindow.gc, grwhite);
- XFillRectangle(grdisplay, grwindow.win, grwindow.gc,
- 0, 0, grwindow.w, grwindow.h);
- XSetForeground(grdisplay, grwindow.gc, grcolor);
- XFlush(grdisplay);
- }
- gr_init_color_cache();
- gr_init_direct_rgb_to_pixel();
- return Val_unit;
-}
-
-value gr_size_x(void)
-{
- gr_check_open();
- return Val_int(grwindow.w);
-}
-
-value gr_size_y(void)
-{
- gr_check_open();
- return Val_int(grwindow.h);
-}
-
-value gr_synchronize(void)
-{
- gr_check_open();
- XCopyArea(grdisplay, grbstore.win, grwindow.win, grwindow.gc,
- 0, grbstore.h - grwindow.h,
- grwindow.w, grwindow.h,
- 0, 0);
- XFlush(grdisplay);
- return Val_unit ;
-}
-
-value gr_display_mode(value flag)
-{
- grdisplay_mode = Bool_val (flag);
- return Val_unit ;
-}
-
-value gr_remember_mode(value flag)
-{
- grremember_mode = Bool_val(flag);
- return Val_unit ;
-}
-
-/* The gr_sigio_handler is called via the signal machinery in the bytecode
- interpreter. The signal system ensures that this function will be
- called either between two bytecode instructions, or during a blocking
- primitive. In either case, not in the middle of an Xlib call. */
-
-value gr_sigio_signal(value unit)
-{
- return Val_int(EVENT_SIGNAL);
-}
-
-value gr_sigio_handler(void)
-{
- XEvent grevent;
-
- if (gr_initialized) {
- while (XCheckMaskEvent(grdisplay, -1 /*all events*/, &grevent)) {
- gr_handle_event(&grevent);
- }
- }
-#ifdef USE_ALARM
- alarm(1);
-#endif
- 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)
- invalid_argument("Exception Graphics.Graphic_failure not initialized, must link graphics.cma");
- }
- sprintf(buffer, fmt, arg);
- raise_with_string(*graphic_failure_exn, buffer);
-}
-
-void gr_check_open(void)
-{
- if (!gr_initialized) gr_fail("graphic screen not opened", NULL);
-}
-
-static int gr_error_handler(Display *display, XErrorEvent *error)
-{
- char errmsg[512];
- XGetErrorText(error->display, error->error_code, errmsg, sizeof(errmsg));
- gr_fail("Xlib error: %s", errmsg);
- return 0;
-}
-
-static int gr_ioerror_handler(Display *display)
-{
- gr_fail("fatal I/O error", NULL);
- return 0;
-}
diff --git a/otherlibs/graph/point_col.c b/otherlibs/graph/point_col.c
deleted file mode 100644
index 8df0dfaf01..0000000000
--- a/otherlibs/graph/point_col.c
+++ /dev/null
@@ -1,32 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "libgraph.h"
-
-value gr_point_color(value vx, value vy)
-{
- int x = Int_val(vx);
- int y = Int_val(vy);
- XImage * im;
- int rgb;
-
- gr_check_open();
- im = XGetImage(grdisplay, grbstore.win, x, Bcvt(y), 1, 1, (-1), ZPixmap);
- rgb = gr_rgb_pixel(XGetPixel(im, 0, 0));
- XDestroyImage(im);
- return Val_int(rgb);
-}
-
-
diff --git a/otherlibs/graph/sound.c b/otherlibs/graph/sound.c
deleted file mode 100644
index 4b30622068..0000000000
--- a/otherlibs/graph/sound.c
+++ /dev/null
@@ -1,34 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "libgraph.h"
-
-value gr_sound(value vfreq, value vdur)
-{
- XKeyboardControl kbdcontrol;
-
- gr_check_open();
- kbdcontrol.bell_pitch = Int_val(vfreq);
- kbdcontrol.bell_duration = Int_val(vdur);
- XChangeKeyboardControl(grdisplay, KBBellPitch | KBBellDuration,
- &kbdcontrol);
- XBell(grdisplay, 0);
- kbdcontrol.bell_pitch = -1; /* restore default value */
- kbdcontrol.bell_duration = -1; /* restore default value */
- XChangeKeyboardControl(grdisplay, KBBellPitch | KBBellDuration,
- &kbdcontrol);
- XFlush(grdisplay);
- return Val_unit;
-}
diff --git a/otherlibs/graph/subwindow.c b/otherlibs/graph/subwindow.c
deleted file mode 100644
index a97242de0b..0000000000
--- a/otherlibs/graph/subwindow.c
+++ /dev/null
@@ -1,45 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "libgraph.h"
-
-value 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);
-
- gr_check_open();
- win = XCreateSimpleWindow(grdisplay, grwindow.win,
- x, Wcvt(y + h), w, h,
- 0, grblack, grbackground);
- XMapWindow(grdisplay, win);
- XFlush(grdisplay);
- return (id_of_window (win));
-}
-
-value gr_close_subwindow(value wid)
-{
- Window win;
-
- gr_check_open();
- sscanf( String_val(wid), "%lu", (unsigned long *)(&win) );
- XDestroyWindow(grdisplay, win);
- XFlush(grdisplay);
- return Val_unit;
-}
diff --git a/otherlibs/graph/text.c b/otherlibs/graph/text.c
deleted file mode 100644
index ad41f2ff2a..0000000000
--- a/otherlibs/graph/text.c
+++ /dev/null
@@ -1,84 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "libgraph.h"
-#include <alloc.h>
-
-XFontStruct * grfont = NULL;
-
-static void gr_font(char *fontname)
-{
- XFontStruct * font = XLoadQueryFont(grdisplay, fontname);
- if (font == NULL) gr_fail("cannot find font %s", fontname);
- if (grfont != NULL) XFreeFont(grdisplay, grfont);
- grfont = font;
- XSetFont(grdisplay, grwindow.gc, grfont->fid);
- XSetFont(grdisplay, grbstore.gc, grfont->fid);
-}
-
-value gr_set_font(value fontname)
-{
- gr_check_open();
- gr_font(String_val(fontname));
- return Val_unit;
-}
-
-value gr_set_text_size (value sz)
-{
- return Val_unit;
-}
-
-static void gr_draw_text(char *txt, int len)
-{
- if (grfont == NULL) gr_font(DEFAULT_FONT);
- if (grremember_mode)
- XDrawString(grdisplay, grbstore.win, grbstore.gc,
- grx, Bcvt(gry) - grfont->descent + 1, txt, len);
- if (grdisplay_mode) {
- XDrawString(grdisplay, grwindow.win, grwindow.gc,
- grx, Wcvt(gry) - grfont->descent + 1, txt, len);
- XFlush(grdisplay);
- }
- grx += XTextWidth(grfont, txt, len);
-}
-
-value gr_draw_char(value chr)
-{
- char str[1];
- gr_check_open();
- str[0] = Int_val(chr);
- gr_draw_text(str, 1);
- return Val_unit;
-}
-
-value gr_draw_string(value str)
-{
- gr_check_open();
- gr_draw_text(String_val(str), string_length(str));
- return Val_unit;
-}
-
-value gr_text_size(value str)
-{
- int width;
- value res;
- gr_check_open();
- if (grfont == NULL) gr_font(DEFAULT_FONT);
- width = XTextWidth(grfont, String_val(str), string_length(str));
- res = alloc_small(2, 0);
- Field(res, 0) = Val_int(width);
- Field(res, 1) = Val_int(grfont->ascent + grfont->descent);
- return res;
-}
diff --git a/otherlibs/labltk/.cvsignore b/otherlibs/labltk/.cvsignore
deleted file mode 100644
index f58b0734b6..0000000000
--- a/otherlibs/labltk/.cvsignore
+++ /dev/null
@@ -1,4 +0,0 @@
-labltklink
-labltkopt
-Makefile.config
-config.status
diff --git a/otherlibs/labltk/Changes b/otherlibs/labltk/Changes
deleted file mode 100644
index bd671fdb67..0000000000
--- a/otherlibs/labltk/Changes
+++ /dev/null
@@ -1,13 +0,0 @@
-version 1.0a1
-
-General Changes
-* Merging CamlTk and LablTk API interfaces
-* Activate and Deactivate Events are added
-* Virtual events support
-* Added UTF conversion
-
-Incompatibilities between the previous camltk/labltk versions
-* CamlTk's bind_tag and bind_class superseded tag_bind and class_bind.
-* added optional arguments to some functions of CamlTk.
-* The library name libfrx and libjpf are changed to frxlib and jpflib
- respectively, to avoid the library name confusion.
diff --git a/otherlibs/labltk/Makefile b/otherlibs/labltk/Makefile
deleted file mode 100644
index 4e4fbd159c..0000000000
--- a/otherlibs/labltk/Makefile
+++ /dev/null
@@ -1,80 +0,0 @@
-# Top Makefile for mlTk
-
-SUBDIRS=compiler support lib jpf frx tkanim examples_labltk \
- examples_camltk browser
-SUBDIRS_GENERATED=camltk labltk
-
-
-all:
- cd support; $(MAKE)
- cd compiler; $(MAKE)
- cd labltk; $(MAKE) -f Makefile.gen
- cd labltk; $(MAKE)
- cd camltk; $(MAKE) -f Makefile.gen
- cd camltk; $(MAKE)
- cd lib; $(MAKE)
- cd jpf; $(MAKE)
- cd frx; $(MAKE)
- cd tkanim; $(MAKE)
- cd browser; $(MAKE)
-
-allopt:
- cd support; $(MAKE) opt
- cd labltk; $(MAKE) -f Makefile.gen
- cd labltk; $(MAKE) opt
- cd camltk; $(MAKE) -f Makefile.gen
- cd camltk; $(MAKE) opt
- cd lib; $(MAKE) opt
- cd jpf; $(MAKE) opt
- cd frx; $(MAKE) opt
- cd tkanim; $(MAKE) opt
-
-byte: all
-opt: allopt
-
-.PHONY: labltk camltk examples_labltk examples_camltk
-
-labltk: Widgets.src
- compiler/tkcompiler -outdir labltk
- cd labltk; $(MAKE)
-
-camltk: Widgets.src
- compiler/tkcompiler -camltk -outdir camltk
- cd camltk; $(MAKE)
-
-examples: examples_labltk examples_camltk
-
-examples_labltk:
- cd examples_labltk; $(MAKE) all
-
-examples_camltk:
- cd examples_camltk; $(MAKE) all
-
-install:
- cd labltk; $(MAKE) install
- cd camltk; $(MAKE) install
- cd lib; $(MAKE) install
- cd support; $(MAKE) install
- cd compiler; $(MAKE) install
- cd jpf; $(MAKE) install
- cd frx; $(MAKE) install
- cd tkanim; $(MAKE) install
- cd browser; $(MAKE) install
-
-installopt:
- cd labltk; $(MAKE) installopt
- cd camltk; $(MAKE) installopt
- cd lib; $(MAKE) installopt
- cd jpf; $(MAKE) installopt
- cd frx; $(MAKE) installopt
- cd tkanim; $(MAKE) installopt
-
-partialclean clean:
- for d in $(SUBDIRS); do \
- cd $$d; $(MAKE) -f Makefile clean; cd ..; \
- done
- for d in $(SUBDIRS_GENERATED); do \
- cd $$d; $(MAKE) -f Makefile.gen clean; cd ..; \
- done
-
-depend:
diff --git a/otherlibs/labltk/Makefile.nt b/otherlibs/labltk/Makefile.nt
deleted file mode 100644
index 0f91c1ace7..0000000000
--- a/otherlibs/labltk/Makefile.nt
+++ /dev/null
@@ -1,59 +0,0 @@
-# Top Makefile for LablTk
-
-include ../../config/Makefile
-
-SUBDIRS=compiler support lib labltk camltk jpf frx tkanim examples_labltk examples_camltk browser
-
-all:
- cd support ; $(MAKEREC)
- cd compiler ; $(MAKEREC)
- cd labltk ; $(MAKECMD) -f Makefile.gen.nt
- cd labltk ; $(MAKEREC)
- cd camltk ; $(MAKECMD) -f Makefile.gen.nt
- cd camltk ; $(MAKEREC)
- cd lib ; $(MAKEREC)
- cd jpf ; $(MAKEREC)
- cd frx ; $(MAKEREC)
- cd tkanim ; $(MAKEREC)
- cd browser ; $(MAKEREC)
-
-allopt:
- cd support ; $(MAKEREC) opt
- cd labltk ; $(MAKECMD) -f Makefile.gen.nt
- cd labltk ; $(MAKEREC) opt
- cd camltk ; $(MAKECMD) -f Makefile.gen.nt
- cd camltk ; $(MAKEREC) opt
- cd lib ; $(MAKEREC) opt
- cd jpf ; $(MAKEREC) opt
- cd frx ; $(MAKEREC) opt
- cd tkanim ; $(MAKEREC) opt
-
-example: examples_labltk/all examples_camltk/all
-
-examples_labltk/all:
- cd examples_labltk ; $(MAKEREC) all
-
-examples_camltk/all:
- cd examples_camltk ; $(MAKEREC) all
-
-install:
- cd labltk ; $(MAKEREC) install
- cd camltk ; $(MAKEREC) install
- cd lib ; $(MAKEREC) install
- cd support ; $(MAKEREC) install
- cd compiler ; $(MAKEREC) install
- cd jpf ; $(MAKEREC) install
- cd frx ; $(MAKEREC) install
- cd tkanim ; $(MAKEREC) install
- cd browser ; $(MAKEREC) install
-
-installopt:
- cd labltk ; $(MAKEREC) installopt
- cd camltk ; $(MAKEREC) installopt
- cd lib ; $(MAKEREC) installopt
- cd jpf ; $(MAKEREC) installopt
- cd frx ; $(MAKEREC) installopt
- cd tkanim ; $(MAKEREC) installopt
-
-partialclean clean:
- for d in $(SUBDIRS); do $(MAKEREC) -C $$d clean; done
diff --git a/otherlibs/labltk/README b/otherlibs/labltk/README
deleted file mode 100644
index 6f63b4a4dd..0000000000
--- a/otherlibs/labltk/README
+++ /dev/null
@@ -1,152 +0,0 @@
-INTRODUCTION
-============
-mlTk is a library for interfacing Objective Caml with the scripting
-language Tcl/Tk (all versions since 8.0.3, but no betas).
-
-In addition to the basic interface with Tcl/Tk, this package contains
- * the OCamlBrowser code editor / library browser written by Jacques
- Garrigue.
- * the "jpf" library, written by Jun P. Furuse; it contains a "file
- selector" and "balloon help" support
- * the "frx" library, written by Francois Rouaix
- * the "tkanim" library, which supports animated gif loading/display
-
-mlTk = CamlTk + LablTk
-======================
-There existed two parallel Tcl/Tk interfaces for O'Caml, CamlTk and LablTk.
-
-CamlTk uses classical features only, therefore it is easy to understand for
-the beginners of ML. It makes many conservative O'Caml gurus also happy.
-LablTk, on the other hand, uses rather newer features of O'Caml, the labeled
-optional arguments and polymorphic variants. Its syntax has much more Tcl/Tk
-script flavor, but provides more powerful typing than CamlTk at the same time
-(i.e. less run time type checking of widgets).
-Until now, these two interfaces have been distributed and maintained
-independently.
-
-mlTk unifies these libraries into one. Since mlTk provides the both API's,
-both CamlTk and LablTk users can compile their applications with mlTk,
-just with little fixes.
-
-REQUIREMENTS
-============
-You must have already installed
- * Objective Caml source, version 3.04+8 or later
-
- * Tcl/Tk 8.0.3 or later
- http://www.scriptics.com/ or various mirrors
-
-PLATFORMS:
-Essentially any Unix/X Window System platform. We have tested
-releases on Linux (ELF x86), FreeBSD (x86), SunOS4.1.x (sparc), DEC
-OSF/1 V4.0 (alpha), DGUX SVR4 (m88k) and Windows (VC++ and Cygwin).
-
-INSTALLATION
-============
-
-0. Check-out the O'Caml CVS source code tree.
-
-1. Compile O'Caml (= make world). If you want, also make opt.
-
-2. Untar this mlTk distribution in the otherlibs directory, just like
- the labltk source tree.
-
-3. change directory to otherlibs/mltk, and make (and make opt)
-
-4. To install the library, make install (and make installopt)
-
-To compile mlTk, you need the O'Caml source tree, since mltk/camlbrowser
-requires some modules of O'Caml. If you are not interested in camlbrowser,
-you can compile mlTk without the O'Caml source tree, but you have to modify
-support/Makefile.common.
-
-
-Compile your CamlTk/LablTk applications with mlTk
-=================================================
-
-* General
-
-The names of the additional libraries libjpf and libfrx are changed
-to jpflib and frxlib respectively, to avoid the library name space confusion.
-
-* LablTk users
-
-Just change the occurrences of labltk in your Makefiles to mltk
-(i.e. -I +labltk => -I +mltk, labltk.cma => mltk.cma, and so on)
-Since the API functions are 100% compatible, you need not to change
-your .ml files.
-
-* CamlTk users
-
- - Makefiles : apply the same modification explained above for LablTk users.
-
- - open Camltk : The API modules and functions are stored in the modules
- Camltk. Therefore you need to replace the module name Tk to Camltk.
- For example, open Tk => open Camltk.
-
- open Camltk (* instead of open Tk *)
-
- let t = openTk ();;
- let b = Button.create t [];;
-
- - You may also need to open the Camltk module explicitly, when your
- original module source contain no open Tk phrase. Widget and the other
- Tcl/Tk related types are now under Camltk. (e.g. Widget.widget is now
- Camltk.Widget.widget) Add open Camltk at the beginning of .mli files,
- if these types are used:
-
- open Camltk (* added for compiling under mlTk *)
-
- val create_progress_bar : Widget.widget -> Widget.widget
-
- - Eta expansion to flush optional arguments at registering callbacks.
- Functions with the _displayof suffix are unified with their non-displayof
- versions, using optional labeled arguments. For example, Bell.ring
- had/have the following types:
-
- before: Bell.ring : unit -> unit
- now: Bell.ring : ?displayof:Camltk.widget -> unit -> unit
-
- If you use these functions as callbacks directly like Command Bell.ring,
- you need eta-expansions to flush these new optional arguments:
-
- Button.create w [Command Bell.ring]
-
- => Button.create w [Command (fun () -> Bell.ring ())]
-
-Use the both API's at the same time
-===================================
-It is possible to use the both API's in one program. If you want to use
-a widget library written in the different API from you use, you need to
-do it. (It will be confusing, but easier than porting the library itself
-from one to the other API.)
-
-For the users who mainly use LablTk API, CamlTk API is available
-in the modules start with 'C'. For example, the source file of
-the CamlTk button widget functions is CButton (and exported also as
-Camltk.Button).
-
-For the users who mainly use CamlTk API, LablTk API modules are exported
-inside Labltk module. For example, LablTk's Button module can be also
-accessible as Labltk.Button.
-
-In CamlTk, we have only one widget type, [widget]. This type is equivalent
-to the LablTk's type [any widget]. Therefore, if you want to apply CamlTk
-functions to LablTk widget, you can use [coe] function to coerce it to
-[any widget].
-
-To do the converse, the "widget-typers" are available inside the module Labltk.
-For example, to recover the type of a button widget, use Labltk.button.
-These widget-typers checks the types of widgets at run-time. If the widget
-type is different from the context type, a run-time exception is raised.
-
- open Tk (* open LablTk API *)
-
- let t = openTk ();; (* t is LablTk widget, toplevel widget *)
- (* CButton.create takes [any widget]; [t] must be coerced to the type. *)
- let caml_b = CButton.create (coe t) [];;
- (* caml_b is [any widget], must be explicitly typed as [button widget],
- when it is used with LablTk API functions *)
- let b = Labltk.button caml_b in (* recover the type [button widget] *)
- ...
-
diff --git a/otherlibs/labltk/Widgets.src b/otherlibs/labltk/Widgets.src
deleted file mode 100644
index e011bbe30f..0000000000
--- a/otherlibs/labltk/Widgets.src
+++ /dev/null
@@ -1,2271 +0,0 @@
-%%%%%%%%%%%%%% Standard Tk8.0.3 Widgets and functions %%%%%%%%%%%%%%
-type Widget external
-
-% cget will probably never be implemented with verifications
-function (string) cgets [widget; "cget"; string]
-% another version with some hack is
-type options_constrs external
-function (string) cget [widget; "cget"; options_constrs]
-% constructors of type options_constrs are of the form C<c>
-% where <c> is an option constructor (e.g. CBackground)
-
-%%%%% Some types for standard options of widgets
-type Anchor {
- NW ["nw"] N ["n"] NE ["ne"]
- W ["w"] Center ["center"] E ["e"]
- SW ["sw"] S ["s"] SE ["se"]
-}
-
-type Bitmap external % builtin_GetBitmap.ml
-type Cursor external % builtin_GetCursor.ml
-type Color external % builtin_GetCursor.ml
-
-##ifdef CAMLTK
-
-type ImageBitmap {
- BitmapImage [string]
- }
-type ImagePhoto {
- PhotoImage [string]
- }
-
-##else
-
-variant type ImageBitmap {
- Bitmap [string]
- }
-variant type ImagePhoto {
- Photo [string]
- }
-variant type Image {
- Bitmap [string]
- Photo [string]
-}
-
-##endif
-
-type Justification {
- Justify_Left ["left"]
- Justify_Center ["center"]
- Justify_Right ["right"]
-}
-
-type Orientation {
- Vertical ["vertical"]
- Horizontal ["horizontal"]
-}
-
-type Relief {
- Raised ["raised"]
- Sunken ["sunken"]
- Flat ["flat"]
- Ridge ["ridge"]
- Groove ["groove"]
-}
-
-type TextVariable external % textvariable.ml
-type Units external % builtin_GetPixel.ml
-
-%%%%% The standard options, as defined in man page options(n)
-%%%%% The subtype is never used
-subtype option(standard) {
- ActiveBackground ["-activebackground"; Color]
- ActiveBorderWidth ["-activeborderwidth"; Units/int]
- ActiveForeground ["-activeforeground"; Color]
- Anchor ["-anchor"; Anchor]
- Background ["-background"; Color]
- Bitmap ["-bitmap"; Bitmap]
- BorderWidth ["-borderwidth"; Units/int]
- Cursor ["-cursor"; Cursor]
- DisabledForeground ["-disabledforeground"; Color]
- ExportSelection ["-exportselection"; bool]
- Font ["-font"; string]
- Foreground ["-foreground"; Color]
-% Geometry is not one of standard options...
- Geometry ["-geometry"; string] % Too variable to encode
- HighlightBackground ["-highlightbackground"; Color]
- HighlightColor ["-highlightcolor"; Color]
- HighlightThickness ["-highlightthickness"; Units/int]
-##ifdef CAMLTK
- % images are split, to do additionnal static typing
- ImageBitmap (ImageBitmap) ["-image"; ImageBitmap]
- ImagePhoto (ImagePhoto) ["-image"; ImagePhoto]
-##else
- Image ["-image"; Image]
-##endif
- InsertBackground ["-insertbackground"; Color]
- InsertBorderWidth ["-insertborderwidth"; Units/int]
- InsertOffTime ["-insertofftime"; int] % Positive only
- InsertOnTime ["-insertontime"; int] % Idem
- InsertWidth ["-insertwidth"; Units/int]
- Jump ["-jump"; bool]
- Justify ["-justify"; Justification]
- Orient ["-orient"; Orientation]
- PadX ["-padx"; Units/int]
- PadY ["-pady"; Units/int]
- Relief ["-relief"; Relief]
- RepeatDelay ["-repeatdelay"; int]
- RepeatInterval ["-repeatinterval"; int]
- SelectBackground ["-selectbackground"; Color]
- SelectBorderWidth ["-selectborderwidth"; Units/int]
- SelectForeground ["-selectforeground"; Color]
- SetGrid ["-setgrid"; bool]
- % incomplete description of TakeFocus
- TakeFocus ["-takefocus"; bool]
- Text ["-text"; string]
- TextVariable ["-textvariable"; TextVariable]
- TroughColor ["-troughcolor"; Color]
- UnderlinedChar ["-underline"; int]
- WrapLength ["-wraplength"; Units/int]
- XScrollCommand ["-xscrollcommand"; function(first:float, last:float)]
- YScrollCommand ["-yscrollcommand"; function(first:float, last:float)]
-}
-
-%%%% Some other common types
-type Index external % builtin_index.ml
-type sequence ScrollValue external % builtin_ScrollValue.ml
-% type sequence ScrollValue {
-% MoveTo ["moveto"; float]
-% ScrollUnit ["scroll"; int; "unit"]
-% ScrollPage ["scroll"; int; "page"]
-% }
-
-
-
-%%%%% bell(n)
-module Bell {
-##ifdef CAMLTK
- function () ring ["bell"; ?displayof:["-displayof"; widget]]
- function () ring_displayof ["bell"; "-displayof" ; displayof: widget]
-##else
- function () ring ["bell"; ?displayof:["-displayof"; widget]]
-##endif
- }
-
-%%%%% bind(n)
-% builtin_bind.ml
-
-
-%%%%% bindtags(n)
-%type Bindings {
-% TagBindings [string]
-% WidgetBindings [widget]
-% }
-
-type Bindings external
-
-function () bindtags ["bindtags"; widget; [bindings: Bindings list]]
-function (Bindings list) bindtags_get ["bindtags"; widget]
-
-%%%%% bitmap(n)
-subtype option(bitmapimage) {
- Background
- Data ["-data"; string]
- File ["-file"; string]
- Foreground
- Maskdata ["-maskdata"; string]
- Maskfile ["-maskfile"; string]
- }
-
-module Imagebitmap {
- function (ImageBitmap) create ["image"; "create"; "bitmap"; ?name:[ImageBitmap]; option(bitmapimage) list]
-##ifdef CAMLTK
- function (ImageBitmap) create_named ["image"; "create"; "bitmap"; ImageBitmap; option(bitmapimage) list]
-##endif
- function () delete ["image"; "delete"; ImageBitmap]
- function (int) height ["image"; "height"; ImageBitmap]
- function (int) width ["image"; "width"; ImageBitmap]
- function () configure [ImageBitmap; "configure"; option(bitmapimage) list]
- function (string) configure_get [ImageBitmap; "configure"]
- % Functions inherited from the "image" TK class
- }
-
-%%%%% button(n)
-
-type State {
- Normal ["normal"]
- Active ["active"]
- Disabled ["disabled"]
-}
-
-widget button {
- % Standard options
- option ActiveBackground
- option ActiveForeground
- option Anchor
- option Background
- option Bitmap
- option BorderWidth
- option Cursor
- option DisabledForeground
- option Font
- option Foreground
- option HighlightBackground
- option HighlightColor
- option HighlightThickness
-##ifdef CAMLTK
- option ImageBitmap
- option ImagePhoto
-##else
- option Image
-##endif
- option Justify
- option PadX
- option PadY
- option Relief
- option TakeFocus
- option Text
- option TextVariable
- option UnderlinedChar
- option WrapLength
- % Widget specific options
- option Command ["-command"; function ()]
- option Default ["-default"; State]
- option Height ["-height"; Units/int]
- option State ["-state"; State]
- option Width ["-width"; Units/int]
-
- function () configure [widget(button); "configure"; option(button) list]
- function (string) configure_get [widget(button); "configure"]
- function () flash [widget(button); "flash"]
- function () invoke [widget(button); "invoke"]
- }
-
-
-%%%%%% canvas(n)
-% Item ids and tags
-type TagOrId {
- Tag [string]
- Id [int]
-}
-
-% Indices: defined internally
-% subtype Index(canvas) {
-% Number End Insert SelFirst SelLast AtXY
-% }
-
-type SearchSpec {
- Above ["above"; TagOrId]
- All ["all"]
- Below ["below"; TagOrId]
- Closest ["closest"; Units/int; Units/int]
- ClosestHalo (Closesthalo) ["closest"; Units/int; Units/int; Units/int]
- ClosestHaloStart (Closesthalostart) ["closest"; Units/int; Units/int; Units/int; TagOrId]
- Enclosed ["enclosed"; Units/int;Units/int;Units/int;Units/int]
- Overlapping ["overlapping"; int;int;int;int]
- Withtag ["withtag"; TagOrId]
-}
-
-type ColorMode {
- Color ["color"]
- Gray ["gray"]
- Mono ["mono"]
-}
-
-subtype option(postscript) {
- % Cannot support this without array variables
- % Colormap ["-colormap"; TextVariable]
- Colormode ["-colormode"; ColorMode]
- File ["-file"; string]
- % Fontmap ["-fontmap"; TextVariable]
- Height
- PageAnchor ["-pageanchor"; Anchor]
- PageHeight ["-pageheight"; Units/int]
- PageWidth ["-pagewidth"; Units/int]
- PageX ["-pagex"; Units/int]
- PageY ["-pagey"; Units/int]
- Rotate ["-rotate"; bool]
- Width
- X ["-x"; Units/int]
- Y ["-y"; Units/int]
- }
-
-
-% Arc item configuration
-type ArcStyle {
- Arc ["arc"]
- Chord ["chord"]
- PieSlice ["pieslice"]
-}
-
-subtype option(arc) {
- Extent ["-extent"; float]
- Dash ["-dash"; string]
- % Fill is used by packer
- FillColor ["-fill"; Color]
- Outline ["-outline"; Color]
- OutlineStipple ["-outlinestipple"; Bitmap]
- Start ["-start"; float]
- Stipple ["-stipple"; Bitmap]
- ArcStyle ["-style"; ArcStyle]
- Tags ["-tags"; [TagOrId/string list]]
- Width
- }
-
-% Bitmap item configuration
-subtype option(bitmap) {
- Anchor
- Background
- Bitmap
- Foreground
- Tags
-}
-
-% Image item configuration
-subtype option(image) {
- Anchor
-##ifdef CAMLTK
- ImagePhoto
- ImageBitmap
-##else
- Image
-##endif
- Tags
-}
-
-% Line item configuration
-type ArrowStyle {
- Arrow_None ["none"]
- Arrow_First ["first"]
- Arrow_Last ["last"]
- Arrow_Both ["both"]
-}
-
-type CapStyle {
- Cap_Butt ["butt"]
- Cap_Projecting ["projecting"]
- Cap_Round ["round"]
-}
-
-type JoinStyle {
- Join_Bevel ["bevel"]
- Join_Miter ["miter"]
- Join_Round ["round"]
-}
-
-subtype option(line) {
- ArrowStyle ["-arrow"; ArrowStyle]
- ArrowShape ["-arrowshape"; [Units/int; Units/int; Units/int]]
- CapStyle ["-capstyle"; CapStyle]
- Dash
- FillColor
- JoinStyle ["-joinstyle"; JoinStyle]
- Smooth ["-smooth"; bool]
- SplineSteps ["-splinesteps"; int]
- Stipple
- Tags
- Width
- }
-
-% Oval item configuration
-subtype option(oval) {
- Dash FillColor Outline Stipple Tags Width
- }
-
-% Polygon item configuration
-subtype option(polygon) {
- Dash FillColor Outline Smooth SplineSteps
- Stipple Tags Width
- }
-
-% Rectangle item configuration
-subtype option(rectangle) {
- Dash FillColor Outline Stipple Tags Width
- }
-
-% Text item configuration
-subtype option(canvastext) {
- Anchor FillColor Font Justify
- Stipple Tags Text Width
- }
-
-% Window item configuration
-subtype option(window) {
- Anchor Height Tags Width
- Window ["-window"; widget]
- Dash
- }
-
-% Types of items
-type CanvasItem {
- Arc_item ["arc"]
- Bitmap_item ["bitmap"]
- Image_item ["image"]
- Line_item ["line"]
- Oval_item ["oval"]
- Polygon_item ["polygon"]
- Rectangle_item ["rectangle"]
- Text_item ["text"]
- Window_item ["window"]
- User_item [string]
-}
-
-widget canvas {
- % Standard options
- option Background
- option BorderWidth
- option Cursor
- option HighlightBackground
- option HighlightColor
- option HighlightThickness
- option InsertBackground
- option InsertBorderWidth
- option InsertOffTime
- option InsertOnTime
- option InsertWidth
- option Relief
- option SelectBackground
- option SelectBorderWidth
- option SelectForeground
- option TakeFocus
- option XScrollCommand
- option YScrollCommand
- % Widget specific options
- option CloseEnough ["-closeenough"; float]
- option Confine ["-confine"; bool]
- option Height ["-height"; Units/int]
- option ScrollRegion ["-scrollregion"; [Units/int;Units/int;Units/int;Units/int]]
- option Width ["-width"; Units/int]
- option XScrollIncrement ["-xscrollincrement"; Units/int]
- option YScrollIncrement ["-yscrollincrement"; Units/int]
-
-
- function () addtag [widget(canvas); "addtag"; tag: TagOrId/string; specs: SearchSpec list] % Tag only
- % bbox not fully supported. should be builtin because of ambiguous result
- % will raise Protocol.TkError if no items match TagOrId
- function (int,int,int,int) bbox [widget(canvas); "bbox"; TagOrId list]
- external bind "builtin/canvas_bind"
-##ifdef CAMLTK
- function (float) canvasx [widget(canvas); "canvasx"; ?spacing:[Units]; Units]
- function (float) canvasy [widget(canvas); "canvasy"; ?spacing:[Units]; Units]
- function (float) canvasx_grid [widget(canvas); "canvasx"; Units; Units]
- function (float) canvasy_grid [widget(canvas); "canvasy"; Units; Units]
-##else
- function (float) canvasx [widget(canvas); "canvasx"; x:int; ?spacing:[int]]
- function (float) canvasy [widget(canvas); "canvasy"; y:int; ?spacing:[int]]
-##endif
- function () configure [widget(canvas); "configure"; option(canvas) list]
- function (string) configure_get [widget(canvas); "configure"]
- % TODO: check result
- function (float list) coords_get [widget(canvas); "coords"; TagOrId]
-##ifdef CAMLTK
- function () coords_set [widget(canvas); "coords"; TagOrId; xys: Units list]
-##else
- function () coords_set [widget(canvas); "coords"; TagOrId; xys: {int, int} list]
-##endif
- % create variations (see below)
- function () dchars [widget(canvas); "dchars"; TagOrId; first: Index(canvas); last: Index(canvas)]
- function () delete [widget(canvas); "delete"; TagOrId list]
- function () dtag [widget(canvas); "dtag"; TagOrId; tag: TagOrId/string]
- function (TagOrId list) find [widget(canvas); "find"; specs: SearchSpec list]
- % focus variations
- function () focus_reset [widget(canvas); "focus"; ""]
- function (TagOrId) focus_get [widget(canvas); "focus"]
- function () focus [widget(canvas); "focus"; TagOrId]
- function (TagOrId/string list) gettags [widget(canvas); "gettags"; TagOrId]
- function () icursor [widget(canvas); "icursor"; TagOrId; index: Index(canvas)]
- function (int) index [widget(canvas); "index"; TagOrId; index: Index(canvas)]
- function () insert [widget(canvas); "insert"; TagOrId; before: Index(canvas); text: string]
- % itemcget, itemconfigure are defined later
- function () lower [widget(canvas); "lower"; TagOrId; ?below: [TagOrId]]
-##ifdef CAMLTK
- function () lower_below [widget(canvas); "lower"; TagOrId; TagOrId]
- function () lower_bot [widget(canvas); "lower"; TagOrId]
-##endif
- function () move [widget(canvas); "move"; TagOrId; x: Units/int; y: Units/int]
- unsafe function (string) postscript [widget(canvas); "postscript"; option(postscript) list]
- % We use raise with Module name
- function () raise [widget(canvas); "raise"; TagOrId; ?above:[TagOrId]]
-##ifdef CAMLTK
- function () raise_above [widget(canvas); "raise"; TagOrId; TagOrId]
- function () raise_top [widget(canvas); "raise"; TagOrId]
-##endif
- function () scale [widget(canvas); "scale"; TagOrId; xorigin: Units/int; yorigin: Units/int; xscale: float; yscale: float]
- % For scan, use x:int and y:int since common usage is with mouse coordinates
- function () scan_mark [widget(canvas); "scan"; "mark"; x: int; y: int]
- function () scan_dragto [widget(canvas); "scan"; "dragto"; x: int; y: int]
- % select variations
- function () select_adjust [widget(canvas); "select"; "adjust"; TagOrId; index: Index(canvas)]
- function () select_clear [widget(canvas); "select"; "clear"]
- function () select_from [widget(canvas); "select"; "from"; TagOrId; index: Index(canvas)]
- function (TagOrId) select_item [widget(canvas); "select"; "item"]
- function () select_to [widget(canvas); "select"; "to"; TagOrId; index: Index(canvas)]
-
- function (CanvasItem) typeof [widget(canvas); "type"; TagOrId]
- function (float,float) xview_get [widget(canvas); "xview"]
- function (float,float) yview_get [widget(canvas); "yview"]
- function () xview [widget(canvas); "xview"; scroll: ScrollValue]
- function () yview [widget(canvas); "yview"; scroll: ScrollValue]
-
- % create and configure variations
- function (TagOrId) create_arc [widget(canvas); "create"; "arc"; x1: Units/int; y1: Units/int; x2: Units/int; y2: Units/int; option(arc) list]
- function (TagOrId) create_bitmap [widget(canvas); "create"; "bitmap"; x: Units/int; y: Units/int; option(bitmap) list]
- function (TagOrId) create_image [widget(canvas); "create"; "image"; x: Units/int; y: Units/int; option(image) list]
-##ifdef CAMLTK
- function (TagOrId) create_line [widget(canvas); "create"; "line"; Units list; option(line) list]
- function (TagOrId) create_polygon [widget(canvas); "create"; "polygon"; Units list; option(polygon) list]
-##else
- function (TagOrId) create_line [widget(canvas); "create"; "line"; xys: {int, int} list; option(line) list]
- function (TagOrId) create_polygon [widget(canvas); "create"; "polygon"; xys: {int, int} list; option(polygon) list]
-##endif
- function (TagOrId) create_oval [widget(canvas); "create"; "oval"; x1: Units/int; y1: Units/int; x2: Units/int; y2: Units/int; option(oval) list]
- function (TagOrId) create_rectangle [widget(canvas); "create"; "rectangle"; x1: Units/int; y1: Units/int; x2: Units/int; y2: Units/int; option(rectangle) list]
- function (TagOrId) create_text [widget(canvas); "create"; "text"; x: Units/int; y: Units/int; option(canvastext) list]
- function (TagOrId) create_window [widget(canvas); "create"; "window"; x: Units/int; y: Units/int; option(window) list]
-
- function (string) itemconfigure_get [widget(canvas); "itemconfigure"; TagOrId]
-
- function () configure_arc [widget(canvas); "itemconfigure"; TagOrId; option(arc) list]
- function () configure_bitmap [widget(canvas); "itemconfigure"; TagOrId; option(bitmap) list]
- function () configure_image [widget(canvas); "itemconfigure"; TagOrId; option(image) list]
- function () configure_line [widget(canvas); "itemconfigure"; TagOrId; option(line) list]
- function () configure_oval [widget(canvas); "itemconfigure"; TagOrId; option(oval) list]
- function () configure_polygon [widget(canvas); "itemconfigure"; TagOrId; option(polygon) list]
- function () configure_rectangle [widget(canvas); "itemconfigure"; TagOrId; option(rectangle) list]
- function () configure_text [widget(canvas); "itemconfigure"; TagOrId; option(canvastext) list]
- function () configure_window [widget(canvas); "itemconfigure"; TagOrId; option(window) list]
- }
-
-
-%%%%% checkbutton(n)
-widget checkbutton {
- % Standard options
- option ActiveBackground
- option ActiveForeground
- option Anchor
- option Background
- option Bitmap
- option BorderWidth
- option Cursor
- option DisabledForeground
- option Font
- option Foreground
- option HighlightBackground
- option HighlightColor
- option HighlightThickness
-##ifdef CAMLTK
- option ImageBitmap
- option ImagePhoto
-##else
- option Image
-##endif
- option Justify
- option PadX
- option PadY
- option Relief
- option TakeFocus
- option Text
- option TextVariable
- option UnderlinedChar
- option WrapLength
- % Widget specific options
- option Command
- option Height
- option IndicatorOn ["-indicatoron"; bool]
- option OffValue ["-offvalue"; string]
- option OnValue ["-onvalue"; string]
- option SelectColor ["-selectcolor"; Color]
-##ifdef CAMLTK
- option SelectImageBitmap (SelectImageBitmap) ["-selectimage"; ImageBitmap]
- option SelectImagePhoto (SelectImagePhoto) ["-selectimage"; ImagePhoto]
-##else
- option SelectImage ["-selectimage"; Image]
-##endif
- option State
- option Variable ["-variable"; TextVariable]
- option Width
-
- function () configure [widget(checkbutton); "configure"; option(checkbutton) list]
- function (string) configure_get [widget(checkbutton); "configure"]
- function () deselect [widget(checkbutton); "deselect"]
- function () flash [widget(checkbutton); "flash"]
- function () invoke [widget(checkbutton); "invoke"]
- function () select [widget(checkbutton); "select"]
- function () toggle [widget(checkbutton); "toggle"]
- }
-
-%%%%% clipboard(n)
-subtype icccm(clipboard_append) {
- ICCCMFormat ["-format"; string]
- ICCCMType ["-type"; string]
- }
-
-module Clipboard {
- function () clear ["clipboard"; "clear"; ?displayof:["-displayof"; widget]]
- function () append ["clipboard"; "append"; ?displayof:["-displayof"; widget]; icccm(clipboard_append) list; "--"; data: string]
- }
-
-%%%%% destroy(n)
-function () destroy ["destroy"; widget]
-
-%%%%% tk_dialog(n)
-module Dialog {
- external create "builtin/dialog"
- }
-
-%%%%% entry(n)
-% Defined internally
-% subtype Index(entry) {
-% Number End Insert SelFirst SelLast At AnchorPoint
-% }
-
-##ifndef CAMLTK
-% Only for Labltk. InputState is unified as State in Camltk
-type InputState {
- Normal ["normal"]
- Disabled ["disabled"]
-}
-##endif
-
-widget entry {
- % Standard options
- option Background
- option BorderWidth
- option Cursor
- option ExportSelection
- option Font
- option Foreground
- option HighlightBackground
- option HighlightColor
- option HighlightThickness
- option InsertBackground
- option InsertBorderWidth
- option InsertOffTime
- option InsertOnTime
- option InsertWidth
- option Justify
- option Relief
- option SelectBackground
- option SelectBorderWidth
- option SelectForeground
- option TakeFocus
- option TextVariable
- option XScrollCommand
-
- % Widget specific options
- option Show ["-show"; char]
-##ifdef CAMLTK
- option State
-##else
- option EntryState ["-state"; InputState]
-##endif
- option TextWidth (Textwidth) ["-width"; int]
-
- function (int,int,int,int) bbox [widget(entry); "bbox"; Index(entry)]
- function () configure [widget(entry); "configure"; option(entry) list]
- function (string) configure_get [widget(entry); "configure"]
- function () delete_single [widget(entry); "delete"; index: Index(entry)]
- function () delete_range [widget(entry); "delete"; start: Index(entry); stop: Index(entry)]
- function (string) get [widget(entry); "get"]
- function () icursor [widget(entry); "icursor"; index: Index(entry)]
- function (int) index [widget(entry); "index"; index: Index(entry)]
- function () insert [widget(entry); "insert"; index: Index(entry); text: string]
- function () scan_mark [widget(entry); "scan"; "mark"; x: int]
- function () scan_dragto [widget(entry); "scan"; "dragto"; x: int]
- % selection variation
- function () selection_adjust [widget(entry); "selection"; "adjust"; index: Index(entry)]
- function () selection_clear [widget(entry); "selection"; "clear"]
- function () selection_from [widget(entry); "selection"; "from"; index: Index(entry)]
- function (bool) selection_present [widget(entry); "selection"; "present"]
- function () selection_range [widget(entry); "selection"; "range"; start: Index(entry) ; stop: Index(entry)]
- function () selection_to [widget(entry); "selection"; "to"; index: Index(entry)]
-
- function (float,float) xview_get [widget(entry); "xview"]
- function () xview [widget(entry); "xview"; scroll: ScrollValue]
- function () xview_index [widget(entry); "xview"; index: Index(entry)]
- function (float, float) xview_get [widget(entry); "xview"]
- }
-
-
-%%%%% focus(n)
-%%%%% tk_focusNext(n)
-module Focus {
- unsafe function (widget) get ["focus"; ?displayof:["-displayof"; widget]]
- unsafe function (widget) displayof ["focus"; "-displayof"; widget]
- function () set ["focus"; widget]
- function () force ["focus"; "-force"; widget]
- unsafe function (widget) lastfor ["focus"; "-lastfor"; widget]
- unsafe function (widget) next ["tk_focusNext"; widget]
- unsafe function (widget) prev ["tk_focusPrev"; widget]
- function () follows_mouse ["tk_focusFollowsMouse"]
-}
-
-type font external % builtin/builtin_font.ml
-
-type weight {
- Weight_Normal(Normal) ["normal"]
- Weight_Bold(Bold) ["bold"]
-}
-
-type slant {
- Slant_Roman(Roman) ["roman"]
- Slant_Italic(Italic) ["italic"]
-}
-
-type fontMetrics {
- Ascent ["-ascent"]
- Descent ["-descent"]
- Linespace ["-linespace"]
- Fixed ["-fixed"]
-}
-
-subtype options(font) {
- Font_Family ["-family"; string]
- Font_Size ["-size"; int]
- Font_Weight ["-weight"; weight]
- Font_Slant ["-slant"; slant]
- Font_Underline ["-underline"; bool]
- Font_Overstrike ["-overstrike"; bool]
-% later, JP only
-% Charset ["-charset"; string]
-%% Beware of the order of Compound ! Put it as the first option
-% Compound ["-compound"; [font list]]
-% Copy ["-copy"; string]
-}
-
-module Font {
- function (string) actual_family ["font"; "actual"; font;
- ?displayof:["-displayof"; widget];
- "-family"]
- function (int) actual_size ["font"; "actual"; font;
- ?displayof:["-displayof"; widget];
- "-size"]
- function (string) actual_weight ["font"; "actual"; font;
- ?displayof:["-displayof"; widget];
- "-weight"]
- function (string) actual_slant ["font"; "actual"; font;
- ?displayof:["-displayof"; widget];
- "-slant"]
- function (bool) actual_underline ["font"; "actual"; font;
- ?displayof:["-displayof"; widget];
- "-underline"]
- function (bool) actual_overstrike ["font"; "actual"; font;
- ?displayof:["-displayof"; widget];
- "-overstrike"]
-
- function () configure ["font"; "configure"; font; options(font) list]
- function (font) create ["font"; "create"; ?name:[string]; options(font) list]
-##ifdef CAMLTK
- function (font) create_named ["font"; "create"; string; options(font) list]
-##endif
- function () delete ["font"; "delete"; font]
- function (string list) families ["font"; "families";
- ?displayof:["-displayof"; widget]]
-##ifdef CAMLTK
- function (string list) families_displayof ["font"; "families";
- "-displayof"; widget]
-##endif
- function (int) measure ["font"; "measure"; font; string;
- ?displayof:["-displayof"; widget]]
-##ifdef CAMLTK
- function (int) measure_displayof ["font"; "measure"; font;
- "-displayof"; widget; string ]
-##endif
- function (int) metrics ["font"; "metrics"; font;
- ?displayof:["-displayof"; widget];
- fontMetrics ]
-##ifdef CAMLTK
- function (int) metrics_displayof ["font"; "metrics"; font;
- "-displayof"; widget;
- fontMetrics ]
-##endif
- function (string list) names ["font"; "names"]
-% JP
-% function () failsafe ["font"; "failsafe"; string]
-}
-
-%%%%% frame(n)
-type Colormap {
- NewColormap (New) ["new"]
- WidgetColormap (Widget) [widget]
- }
-
-% Visual classes are: directcolor, grayscale, greyscale, pseudocolor,
-% staticcolor, staticgray, staticgrey, truecolor
-type Visual {
- ClassVisual (Clas) [[string; int]]
- DefaultVisual ["default"]
- WidgetVisual (Widget) [widget]
- BestDepth (Bestdepth) [["best"; int]]
- Best ["best"]
- }
-
-widget frame {
- % Standard options
- option BorderWidth
- option Cursor
- option HighlightBackground
- option HighlightColor
- option HighlightThickness
- option Relief
- option TakeFocus
-
- % Widget specific options
- option Background
-##ifdef CAMLTK
- option Class ["-class"; string]
-##else
- option Clas ["-class"; string]
-##endif
- option Colormap ["-colormap"; Colormap]
- option Container ["-container"; bool]
- option Height
- option Visual ["-visual"; Visual]
- option Width
-
- % Class and Colormap and Visual cannot be changed
- function () configure [widget(frame); "configure"; option(frame) list]
- function (string) configure_get [widget(frame); "configure"]
- }
-
-
-
-%%%%% grab(n)
-type GrabStatus {
- GrabNone ["none"]
- GrabLocal ["local"]
- GrabGlobal ["global"]
-}
-type GrabGlobal external
-module Grab {
- function () set ["grab"; "set"; ?global:[GrabGlobal]; widget]
-##ifdef CAMLTK
- function () set_global ["grab"; "set"; "-global"; widget]
-##endif
- unsafe function (widget list) current ["grab"; "current"; ?displayof:[widget]]
-##ifdef CAMLTK
- % all_current is now current.
- % The old current is now current_of
- unsafe function (widget list) current_of ["grab"; "current"; widget]
-##endif
- function () release ["grab"; "release"; widget]
- function (GrabStatus) status ["grab"; "status"; widget]
-}
-
-subtype option(rowcolumnconfigure) {
- Minsize ["-minsize"; Units/int]
- Weight ["-weight"; int]
- Pad ["-pad"; Units/int]
-}
-
-subtype option(grid) {
- Column ["-column"; int]
- ColumnSpan ["-columnspan"; int]
- In(Inside) ["-in"; widget]
- IPadX ["-ipadx"; Units/int]
- IPadY ["-ipady"; Units/int]
- PadX
- PadY
- Row ["-row"; int]
- RowSpan ["-rowspan"; int]
- Sticky ["-sticky"; string]
- }
-
-% Same as pack
-function () grid ["grid"; widget list; option(grid) list]
-
-module Grid {
- function (int,int,int,int) bbox ["grid"; "bbox"; widget]
- function (int,int,int,int) bbox_cell ["grid"; "bbox"; widget; column: int; row: int]
- function (int,int,int,int) bbox_span ["grid"; "bbox"; widget; column1: int; row1: int; column2: int; row2: int]
- function () column_configure
- ["grid"; "columnconfigure"; widget; int;
- option(rowcolumnconfigure) list]
- function () configure ["grid"; "configure"; widget list; option(grid) list]
- function (string) column_configure_get ["grid"; "columnconfigure"; widget;
- int]
- function () forget ["grid"; "forget"; widget list]
- %% info returns only a string
- function (string) info ["grid"; "info"; widget]
- %% TODO: check result values
- function (int,int) location ["grid"; "location"; widget; x:Units/int; y:Units/int]
- function (bool) propagate_get ["grid"; "propagate"; widget]
- function () propagate_set ["grid"; "propagate"; widget; bool]
- function () row_configure
- ["grid"; "rowconfigure"; widget; int; option(rowcolumnconfigure) list]
- function (string) row_configure_get ["grid"; "rowconfigure"; widget; int]
- function (int,int) size ["grid"; "size"; widget]
-
-##ifdef CAMLTK
- function (widget list) slaves ["grid"; "slaves"; widget; ?column:["-column"; int]; ?row:["-row"; int]]
- function (widget list) row_slaves ["grid"; "slaves"; widget; "-row"; int]
- function (widget list) column_slaves ["grid"; "slaves"; widget; "-column"; int]
-##else
- function (widget list) slaves ["grid"; "slaves"; widget; ?column:["-column"; int]; ?row:["-row"; int]]
-##endif
- }
-
-%%%%% image(n)
-%%%%% cf Imagephoto and Imagebitmap
-% Some functions on images are implemented in Imagephoto or Imagebitmap.
-module Image {
- external names "builtin/image"
-}
-
-%%%%% label(n)
-widget label {
- % Standard options
- option Anchor
- option Background
- option Bitmap
- option BorderWidth
- option Cursor
- option Font
- option Foreground
- option HighlightBackground
- option HighlightColor
- option HighlightThickness
-##ifdef CAMLTK
- option ImageBitmap
- option ImagePhoto
-##else
- option Image
-##endif
- option Justify
- option PadX
- option PadY
- option Relief
- option TakeFocus
- option Text
- option TextVariable
- option UnderlinedChar
- option WrapLength
-
- % Widget specific options
- option Height
- % use according to label contents
- option Width
- option TextWidth
-
- function () configure [widget(label); "configure"; option(label) list]
- function (string) configure_get [widget(label); "configure"]
- }
-
-
-%%%%% listbox(n)
-
-% Defined internally
-% subtype Index(listbox) {
-% Number Active AnchorPoint End AtXY
-%}
-
-type SelectModeType {
- Single ["single"]
- Browse ["browse"]
- Multiple ["multiple"]
- Extended ["extended"]
- }
-
-
-widget listbox {
- % Standard options
- option Background
- option BorderWidth
- option Cursor
- option ExportSelection
- option Font
- option Foreground
- % Height is TextHeight
- option HighlightBackground
- option HighlightColor
- option HighlightThickness
- option Relief
- option SelectBackground
- option SelectBorderWidth
- option SelectForeground
- option SetGrid
- option TakeFocus
- % Width is TextWidth
- option XScrollCommand
- option YScrollCommand
- % Widget specific options
- option TextHeight ["-height"; int]
- option TextWidth
- option SelectMode ["-selectmode"; SelectModeType]
-
- function () activate [widget(listbox); "activate"; index: Index(listbox)]
- function (int,int,int,int) bbox [widget(listbox); "bbox"; index: Index(listbox)]
- function () configure [widget(listbox); "configure"; option(listbox) list]
- function (string) configure_get [widget(listbox); "configure"]
- function (Index(listbox) as "[>`Num of int]" list) curselection [widget(listbox); "curselection"]
- function () delete [widget(listbox); "delete"; first: Index(listbox); last: Index(listbox)]
- function (string) get [widget(listbox); "get"; index: Index(listbox)]
- function (string list) get_range [widget(listbox); "get"; first: Index(listbox); last: Index(listbox)]
- function (Index(listbox) as "[>`Num of int]") index [widget(listbox); "index"; index: Index(listbox)]
- function () insert [widget(listbox); "insert"; index: Index(listbox); texts: string list]
- function (Index(listbox) as "[>`Num of int]") nearest [widget(listbox); "nearest"; y: int]
- function () scan_mark [widget(listbox); "scan"; "mark"; x: int; y: int]
- function () scan_dragto [widget(listbox); "scan"; "dragto"; x: int; y: int]
- function () see [widget(listbox); "see"; index: Index(listbox)]
- function () selection_anchor [widget(listbox); "selection"; "anchor"; index: Index(listbox)]
- function () selection_clear [widget(listbox); "selection"; "clear"; first: Index(listbox); last: Index(listbox)]
- function (bool) selection_includes [widget(listbox); "selection"; "includes"; index: Index(listbox)]
- function () selection_set [widget(listbox); "selection"; "set"; first: Index(listbox); last: Index(listbox)]
- function (int) size [widget(listbox); "size"]
-
- function (float,float) xview_get [widget(listbox); "xview"]
- function (float,float) yview_get [widget(listbox); "yview"]
- function () xview_index [widget(listbox); "xview"; index: Index(listbox)]
- function () yview_index [widget(listbox); "yview"; index: Index(listbox)]
- function () xview [widget(listbox); "xview"; scroll: ScrollValue]
- function () yview [widget(listbox); "yview"; scroll: ScrollValue]
- }
-
-%%%%% lower(n)
-function () lower_window ["lower"; widget; ?below:[widget]]
-##ifdef CAMLTK
-function () lower_window_below ["lower"; widget; below: widget]
-##endif
-
-
-%%%%% menu(n)
-%%%%% tk_popup(n)
-% defined internally
-% subtype Index(menu) {
-% Number Active End Last None At Pattern
-% }
-
-type MenuItem {
- Cascade_Item ["cascade"]
- Checkbutton_Item ["checkbutton"]
- Command_Item ["command"]
- Radiobutton_Item ["radiobutton"]
- Separator_Item ["separator"]
- TearOff_Item ["tearoff"]
-}
-
-% notused as a subtype. just for cleaning up the rest.
-subtype option(menuentry) {
- ActiveBackground
- ActiveForeground
- Accelerator ["-accelerator"; string]
- Background
- Bitmap
- ColumnBreak ["-columnbreak"; bool]
- Command
- Font
- Foreground
- HideMargin ["-hidemargin"; bool]
-##ifdef CAMLTK
- ImageBitmap
- ImagePhoto
-##else
- Image
-##endif
- IndicatorOn
- Label ["-label"; string]
- Menu ["-menu"; widget(menu)]
- OffValue
- OnValue
- SelectColor
-##ifdef CAMLTK
- SelectImageBitmap
- SelectImagePhoto
-##else
- SelectImage
-##endif
- State
- UnderlinedChar
- Value ["-value"; string]
- Variable
- }
-
-% Options for cascade entry
-subtype option(menucascade) {
- ActiveBackground ActiveForeground Accelerator
- Background Bitmap ColumnBreak Command Font Foreground
- HideMargin
-##ifdef CAMLTK
- ImageBitmap ImagePhoto
-##else
- Image
-##endif
- IndicatorOn Label Menu State UnderlinedChar
- }
-
-% Options for radiobutton entry
-subtype option(menuradio) {
- ActiveBackground ActiveForeground Accelerator
- Background Bitmap ColumnBreak Command Font Foreground
-##ifdef CAMLTK
- ImageBitmap ImagePhoto SelectImageBitmap SelectImagePhoto
-##else
- Image SelectImage
-##endif
- IndicatorOn Label SelectColor
- State UnderlinedChar Value Variable
- }
-
-% Options for checkbutton entry
-subtype option(menucheck) {
- ActiveBackground ActiveForeground Accelerator
- Background Bitmap ColumnBreak Command Font Foreground
-##ifdef CAMLTK
- ImageBitmap SelectImageBitmap ImagePhoto SelectImagePhoto
-##else
- Image SelectImage
-##endif
- IndicatorOn Label
- OffValue OnValue SelectColor
- State UnderlinedChar Variable
- }
-
-% Options for command entry
-subtype option(menucommand) {
- ActiveBackground ActiveForeground Accelerator
- Background Bitmap ColumnBreak Command Font Foreground
-##ifdef CAMLTK
- ImageBitmap ImagePhoto
-##else
- Image
-##endif
- Label State UnderlinedChar
- }
-
-type menuType {
- Menu_Menubar ["menubar"]
- Menu_Tearoff ["tearoff"]
- Menu_Normal ["normal"]
-}
-
-% Separators and tearoffs don't have options
-
-widget menu {
- % Standard options
- option ActiveBackground
- option ActiveBorderWidth
- option ActiveForeground
- option Background
- option BorderWidth
- option Cursor
- option DisabledForeground
- option Font
- option Foreground
- option Relief
- option TakeFocus
- % Widget specific options
- option PostCommand ["-postcommand"; function()]
- option SelectColor
- option TearOff ["-tearoff"; bool]
- option TearOffCommand ["-tearoffcommand"; function(menu: widget(any), tornoff: widget(any)) ]
- option MenuTitle ["-title"; string]
- option MenuType ["-type"; menuType]
-
- function () activate [widget(menu); "activate"; index: Index(menu)]
- % add variations
- function () add_cascade [widget(menu); "add"; "cascade"; option(menucascade) list]
- function () add_checkbutton [widget(menu); "add"; "checkbutton"; option(menucheck) list]
- function () add_command [widget(menu); "add"; "command"; option(menucommand) list]
- function () add_radiobutton [widget(menu); "add"; "radiobutton"; option(menuradio) list]
- function () add_separator [widget(menu); "add"; "separator"]
- % not for user: function clone [widget(menu); "clone"; ???; menuType]
- function () configure [widget(menu); "configure"; option(menu) list]
- function (string) configure_get [widget(menu); "configure"]
- % beware of possible callback leak when deleting menu entries
- function () delete [widget(menu); "delete"; first: Index(menu); last: Index(menu)]
- function () configure_cascade [widget(menu); "entryconfigure"; Index(menu); option(menucascade) list]
- function () configure_checkbutton [widget(menu); "entryconfigure"; Index(menu); option(menucheck) list]
- function () configure_command [widget(menu); "entryconfigure"; Index(menu); option(menucommand) list]
- function () configure_radiobutton [widget(menu); "entryconfigure"; Index(menu); option(menuradio) list]
- function (string) entryconfigure_get [widget(menu); "entryconfigure"; Index(menu)]
- function (int) index [widget(menu); "index"; Index(menu)]
- function () insert_cascade [widget(menu); "insert"; index: Index(menu); "cascade"; option(menucascade) list]
- function () insert_checkbutton [widget(menu); "insert"; index: Index(menu); "checkbutton"; option(menucheck) list]
- function () insert_command [widget(menu); "insert"; index: Index(menu); "command"; option(menucommand) list]
- function () insert_radiobutton [widget(menu); "insert"; index: Index(menu); "radiobutton"; option(menuradio) list]
- function () insert_separator [widget(menu); "insert"; index: Index(menu); "separator"]
- function (string) invoke [widget(menu); "invoke"; index: Index(menu)]
- function () post [widget(menu); "post"; x: int; y: int]
- function () postcascade [widget(menu); "postcascade"; index: Index(menu)]
- % can't use type of course
- function (MenuItem) typeof [widget(menu); "type"; index: Index(menu)]
- function () unpost [widget(menu); "unpost"]
- function (int) yposition [widget(menu); "yposition"; index: Index(menu)]
-
- function () popup ["tk_popup"; widget(menu); x: int; y: int; ?entry:[Index(menu)]]
-##ifdef CAMLTK
- function () popup_entry ["tk_popup"; widget(menu); x: int; y: int; index: Index(menu)]
-##endif
- }
-
-
-%%%%% menubutton(n)
-
-type menubuttonDirection {
- Dir_Above ["above"]
- Dir_Below ["below"]
- Dir_Left ["left"]
- Dir_Right ["right"]
-}
-
-widget menubutton {
- % Standard options
- option ActiveBackground
- option ActiveForeground
- option Anchor
- option Background
- option Bitmap
- option BorderWidth
- option Cursor
- option DisabledForeground
- option Font
- option Foreground
- option HighlightBackground
- option HighlightColor
- option HighlightThickness
-##ifdef CAMLTK
- option ImageBitmap
- option ImagePhoto
-##else
- option Image
-##endif
- option Justify
- option PadX
- option PadY
- option Relief
- option TakeFocus
- option Text
- option TextVariable
- option UnderlinedChar
- option WrapLength
- % Widget specific options
- option Direction ["-direction"; menubuttonDirection ]
- option Height
- option IndicatorOn
- option Menu ["-menu"; widget(menu)]
- option State
- option Width
- option TextWidth
-
- function () configure [widget(menubutton); "configure"; option(menubutton) list]
- function (string) configure_get [widget(menubutton); "configure"]
- }
-
-
-
-%%%%% message(n)
-widget message {
- % Standard options
- option Anchor
- option Background
- option BorderWidth
- option Cursor
- option Font
- option Foreground
- option HighlightBackground
- option HighlightColor
- option HighlightThickness
- option PadX
- option PadY
- option Relief
- option TakeFocus
- option Text
- option TextVariable
- % Widget specific options
- option Aspect ["-aspect"; int]
- option Justify
- option Width
-
- function () configure [widget(message); "configure"; option(message) list]
- function (string) configure_get [widget(message); "configure"]
- }
-
-
-%%%%% option(n)
-type OptionPriority {
- WidgetDefault ["widgetDefault"]
- StartupFile ["startupFile"]
- UserDefault ["userDefault"]
- Interactive ["interactive"]
- Priority [int]
- }
-
-##ifdef CAMLTK
-
-module Option {
- unsafe function () add ["option"; "add"; string; string; OptionPriority]
- function () clear ["option"; "clear"]
- function (string) get ["option"; "get"; widget; string; string]
- unsafe function () readfile ["option"; "readfile"; string; OptionPriority]
- }
-%% Resource is now superseded by Option
-module Resource {
- unsafe function () add ["option"; "add"; string; string; OptionPriority]
- function () clear ["option"; "clear"]
- function (string) get ["option"; "get"; widget; string; string]
- unsafe function () readfile ["option"; "readfile"; string; OptionPriority]
- }
-##else
-module Option {
- unsafe function () add
- ["option"; "add"; path: string; string; ?priority:[OptionPriority]]
- function () clear ["option"; "clear"]
- function (string) get ["option"; "get"; widget; name: string; clas: string]
- unsafe function () readfile
- ["option"; "readfile"; string; ?priority:[OptionPriority]]
- }
-##endif
-
-%%%%% tk_optionMenu(n)
-module Optionmenu {
- external create "builtin/optionmenu"
- }
-
-
-%%%%% pack(n)
-type Side {
- Side_Left ["left"]
- Side_Right ["right"]
- Side_Top ["top"]
- Side_Bottom ["bottom"]
-}
-
-type FillMode {
- Fill_None ["none"]
- Fill_X ["x"]
- Fill_Y ["y"]
- Fill_Both ["both"]
-}
-
-subtype option(pack) {
- After ["-after"; widget]
- Anchor
- Before ["-before"; widget]
- Expand ["-expand"; bool]
- Fill ["-fill"; FillMode]
- In(Inside) ["-in"; widget]
- IPadX ["-ipadx"; Units/int]
- IPadY ["-ipady"; Units/int]
- PadX
- PadY
- Side ["-side"; Side]
-}
-
-function () pack ["pack"; widget list; option(pack) list]
-
-module Pack {
- function () configure ["pack"; "configure"; widget list; option(pack) list]
- function () forget ["pack"; "forget"; widget list]
- function (string) info ["pack"; "info"; widget]
- function (bool) propagate_get ["pack"; "propagate"; widget]
- function () propagate_set ["pack"; "propagate"; widget; bool]
- function (widget list) slaves ["pack"; "slaves"; widget]
- }
-
-subtype TkPalette(any) { % Not sophisticated...
- PaletteActiveBackground ["activeBackground"; Color]
- PaletteActiveForeground ["activeForeground"; Color]
- PaletteBackground ["background"; Color]
- PaletteDisabledForeground ["disabledForeground"; Color]
- PaletteForeground ["foreground"; Color]
- PaletteHighlightBackground ["hilightBackground"; Color]
- PaletteHighlightColor ["highlightColor"; Color]
- PaletteInsertBackground ["insertBackground"; Color]
- PaletteSelectColor ["selectColor"; Color]
- PaletteSelectBackground ["selectBackground"; Color]
- PaletteForegroundselectColor ["selectForeground"; Color]
- PaletteTroughColor ["troughColor"; Color]
-}
-
-%%%%% tk_setPalette(n)
-%%%% can't simply encode general form of tk_setPalette
-module Palette {
- function () set_background ["tk_setPalette"; Color]
- function () set ["tk_setPalette"; TkPalette(any) list]
- function () bisque ["tk_bisque"]
- }
-
-%%%%% photo(n)
-type PaletteType external % builtin_palette.ml
-
-subtype option(photoimage) {
- % Channel ["-channel"; file_descr] % removed in 8.3 ?
- Data
- Format ["-format"; string]
- File
- Gamma ["-gamma"; float]
- Height
- Palette ["-palette"; PaletteType]
- Width
- }
-
-subtype photo(copy) {
- ImgFrom(Src_area) ["-from"; int; int; int; int]
- ImgTo(Dst_area) ["-to"; int; int; int; int]
- Shrink ["-shrink"]
- Zoom ["-zoom"; int; int]
- Subsample ["-subsample"; int; int]
- }
-
-subtype photo(put) {
- ImgTo
- }
-
-subtype photo(read) {
- ImgFormat ["-format"; string]
- ImgFrom
- Shrink
- TopLeft(Dst_pos) ["-to"; int; int]
- }
-
-subtype photo(write) {
- ImgFormat ImgFrom
- }
-
-module Imagephoto {
- function (ImagePhoto) create ["image"; "create"; "photo"; ?name:[ImagePhoto]; option(photoimage) list]
-##ifdef CAMLTK
- function (ImagePhoto) create_named ["image"; "create"; "photo"; ImagePhoto; option(photoimage) list]
-##endif
- function () delete ["image"; "delete"; ImagePhoto]
- function (int) height ["image"; "height"; ImagePhoto]
- function (int) width ["image"; "width"; ImagePhoto]
-
-%name
-%type
-
- function () blank [ImagePhoto; "blank"]
- function () configure [ImagePhoto; "configure"; option(photoimage) list]
- function (string) configure_get [ImagePhoto; "configure"]
- function () copy [ImagePhoto; "copy"; src: ImagePhoto; photo(copy) list]
- function (int, int, int) get [ImagePhoto; "get"; x: int; y: int]
-% it is buggy ? can't express nested lists ?
- function () put [ImagePhoto; "put"; [Color list list]; photo(put) list]
-% external put "builtin/imagephoto_put"
- function () read [ImagePhoto; "read"; file: string; photo(read) list]
- function () redither [ImagePhoto; "redither"]
- function () write [ImagePhoto; "write"; file: string; photo(write) list]
- % Functions inherited from the "image" TK class
- }
-
-
-%%%%% place(n)
-type BorderMode {
- Inside ["inside"]
- Outside ["outside"]
- Ignore ["ignore"]
-}
-
-subtype option(place) {
- In
- X
- RelX ["-relx"; float]
- Y
- RelY ["-rely"; float]
- Anchor
- Width
- RelWidth ["-relwidth"; float]
- Height
- RelHeight ["-relheight"; float]
- BorderMode ["-bordermode"; BorderMode]
-}
-
-function () place ["place"; widget; option(place) list]
-
-module Place {
- function () configure ["place"; "configure"; widget; option(place) list]
- function () forget ["place"; "forget"; widget]
- function (string) info ["place"; "info"; widget]
- function (widget list) slaves ["place"; "slaves"; widget]
-}
-
-
-%%%%% radiobutton(n)
-
-widget radiobutton {
- % Standard options
- option ActiveBackground
- option ActiveForeground
- option Anchor
- option Background
- option Bitmap
- option BorderWidth
- option Cursor
- option DisabledForeground
- option Font
- option Foreground
- option HighlightBackground
- option HighlightColor
- option HighlightThickness
-##ifdef CAMLTK
- option ImageBitmap
- option ImagePhoto
-##else
- option Image
-##endif
- option Justify
- option PadX
- option PadY
- option Relief
- option TakeFocus
- option Text
- option TextVariable
- option UnderlinedChar
- option WrapLength
-
- % Widget specific options
- option Command
- option Height
- option IndicatorOn
- option SelectColor
-##ifdef CAMLTK
- option SelectImageBitmap
- option SelectImagePhoto
-##else
- option SelectImage
-##endif
- option State
- option Value
- option Variable
- option Width
-
- function () configure [widget(radiobutton); "configure"; option(radiobutton) list]
- function (string) configure_get [widget(radiobutton); "configure"]
- function () deselect [widget(radiobutton); "deselect"]
- function () flash [widget(radiobutton); "flash"]
- function () invoke [widget(radiobutton); "invoke"]
- function () select [widget(radiobutton); "select"]
- }
-
-
-%%%%% raise(n)
-% We cannot use raise !!
-function () raise_window ["raise"; widget; ?above:[widget]]
-##ifdef CAMLTK
-function () raise_window_above ["raise"; widget; widget]
-##endif
-
-%%%%% scale(n)
-%% shared with scrollbars
-##ifdef CAMLTK
-subtype WidgetElement(scale) {
- Slider ["slider"]
- Trough1 ["trough1"]
- Trough2 ["trough2"]
- Beyond [""]
- }
-##else
-type ScaleElement {
- Slider ["slider"]
- Trough1 ["trough1"]
- Trough2 ["trough2"]
- Beyond [""]
- }
-##endif
-
-widget scale {
- % Standard options
- option ActiveBackground
- option Background
- option BorderWidth
- option Cursor
- option Font
- option Foreground
- option HighlightBackground
- option HighlightColor
- option HighlightThickness
- option Orient
- option Relief
- option RepeatDelay
- option RepeatInterval
- option TakeFocus
- option TroughColor
-
- % Widget specific options
- option BigIncrement ["-bigincrement"; float]
- option ScaleCommand ["-command"; function (float)]
- option Digits ["-digits"; int]
- option From(Min) ["-from"; float]
- option Label ["-label"; string]
- option Length ["-length"; Units/int]
- option Resolution ["-resolution"; float]
- option ShowValue ["-showvalue"; bool]
- option SliderLength ["-sliderlength"; Units/int]
- option State
- option TickInterval ["-tickinterval"; float]
- option To(Max) ["-to"; float]
- option Variable
- option Width
-
-##ifdef CAMLTK
- function (int,int) coords [widget(scale); "coords"]
- function (int,int) coords_at [widget(scale); "coords"; at: float]
-##else
- function (int,int) coords [widget(scale); "coords"; ?at: [float]]
-##endif
- function () configure [widget(scale); "configure"; option(scale) list]
- function (string) configure_get [widget(scale); "configure"]
- function (float) get [widget(scale); "get"]
- function (float) get_xy [widget(scale); "get"; x: int; y: int]
- function (WidgetElement/ScaleElement) identify [widget(scale); x: int; y: int]
- function () set [widget(scale); "set"; float]
- }
-
-
-%%%%% scrollbar(n)
-##ifdef CAMLTK
-subtype WidgetElement(scrollbar) {
- Arrow1 ["arrow1"]
- Trough1
- Trough2
- Slider
- Arrow2 ["arrow2"]
- Beyond
- }
-##else
-type ScrollbarElement {
- Arrow1 ["arrow1"]
- Trough1 ["through1"]
- Trough2 ["through2"]
- Slider ["slider"]
- Arrow2 ["arrow2"]
- Beyond [""]
- }
-##endif
-
-widget scrollbar {
- % Standard options
- option ActiveBackground
- option Background
- option BorderWidth
- option Cursor
- option HighlightBackground
- option HighlightColor
- option HighlightThickness
- option Jump
- option Orient
- option Relief
- option RepeatDelay
- option RepeatInterval
- option TakeFocus
- option TroughColor
- % Widget specific options
- option ActiveRelief ["-activerelief"; Relief]
- option ScrollCommand ["-command"; function(scroll: ScrollValue)]
- option ElementBorderWidth ["-elementborderwidth"; Units/int]
- option Width
-
-##ifdef CAMLTK
- function () activate [widget(scrollbar); "activate"; element: WidgetElement(scrollbar)]
-##else
- function () activate [widget(scrollbar); "activate"; element: ScrollbarElement]
-##endif
- function (WidgetElement/ScrollbarElement) activate_get [widget(scrollbar); "activate"]
- function () configure [widget(scrollbar); "configure"; option(scrollbar) list]
- function (string) configure_get [widget(scrollbar); "configure"]
- function (float) delta [widget(scrollbar); "delta"; x: int; y: int]
- function (float) fraction [widget(scrollbar); "fraction"; x: int; y: int]
- function (float, float) get [widget(scrollbar); "get"]
- function (int,int,int,int) old_get [widget(scrollbar); "get"]
- function (WidgetElement/ScrollbarElement) identify [widget(scale); "identify"; int; int]
- function () set [widget(scrollbar); "set"; first: float; last: float]
- function () old_set [widget(scrollbar); "set"; total:int; window:int; first:int; last:int]
- }
-
-
-%%%%% selection(n)
-
-subtype icccm(selection_clear) {
- DisplayOf ["-displayof"; widget]
- Selection ["-selection"; string]
- }
-
-subtype icccm(selection_get) {
- DisplayOf
- Selection
- ICCCMType
- }
-
-subtype icccm(selection_ownset) {
- LostCommand ["-command"; function()]
- Selection
- }
-
-subtype icccm(selection_handle) {
- Selection
- ICCCMType
- ICCCMFormat ["-format"; string]
- }
-
-module Selection {
- function () clear ["selection"; "clear"; icccm(selection_clear) list]
- function (string) get ["selection"; "get"; icccm(selection_get) list]
-
- % function () handle_set ["selection"; "handle"; icccm(selection_handle) list; widget; function(int,int)]
- external handle_set "builtin/selection_handle_set"
- unsafe function (widget) own_get ["selection"; "own"; icccm(selection_clear) list]
- % builtin
- % function () own_set ["selection"; "own"; widget; icccm(selection_ownset) list]
- external own_set "builtin/selection_own_set"
- }
-
-
-%%%%% send(n)
-type SendOption {
- SendDisplayOf ["-displayof"; widget] % DisplayOf is used for icccm !
- SendAsync ["-async"]
-}
-
-unsafe function () send ["send"; SendOption list; "--"; app: string; command: string list]
-
-%%%%% text(n)
-
-type TextIndex external
-type TextTag external
-type TextMark external
-
-
-type TabType {
- TabLeft [Units/int; "left"]
- TabRight [Units/int; "right"]
- TabCenter [Units/int; "center"]
- TabNumeric [Units/int; "numeric"]
- }
-
-type WrapMode {
- WrapNone ["none"]
- WrapChar ["char"]
- WrapWord ["word"]
-}
-
-type Comparison {
- LT (Lt) ["<"]
- LE (Le) ["<="]
- EQ (Eq) ["=="]
- GE (Ge) [">="]
- GT (Gt) [">"]
- NEQ (Neq) ["!="]
-}
-
-type MarkDirection {
- Mark_Left ["left"]
- Mark_Right ["right"]
- }
-
-type AlignType {
- Align_Top ["top"]
- Align_Bottom ["bottom"]
- Align_Center ["center"]
- Align_Baseline ["baseline"]
- }
-
-subtype option(embeddedi) {
- Align ["-align"; AlignType]
-##ifdef CAMLTK
- ImageBitmap
- ImagePhoto
-##else
- Image
-##endif
- Name ["-name"; string]
- PadX
- PadY
- }
-
-subtype option(embeddedw) {
- Align ["-align"; AlignType]
- PadX
- PadY
- Stretch ["-stretch"; bool]
- Window
- }
-
-type TextSearch {
- Forwards ["-forwards"]
- Backwards ["-backwards"]
- Exact ["-exact"]
- Regexp ["-regexp"]
- Nocase ["-nocase"]
- Count ["-count"; TextVariable]
- }
-
-type text_dump {
- DumpAll ["-all"]
- DumpCommand ["-command"; function (key: string, value: string, index: string)]
- DumpMark ["-mark"]
- DumpTag ["-tag"]
- DumpText ["-text"]
- DumpWindow ["-window"]
- }
-
-widget text {
- % Standard options
- option Background
- option BorderWidth
- option Cursor
- option ExportSelection
- option Font
- option Foreground
- option HighlightBackground
- option HighlightColor
- option HighlightThickness
- option InsertBackground
- option InsertBorderWidth
- option InsertOffTime
- option InsertOnTime
- option InsertWidth
- option PadX
- option PadY
- option Relief
- option SelectBackground
- option SelectBorderWidth
- option SelectForeground
- option SetGrid
- option TakeFocus
- option XScrollCommand
- option YScrollCommand
-
- % Widget specific options
- option TextHeight
- option Spacing1 ["-spacing1"; Units/int]
- option Spacing2 ["-spacing2"; Units/int]
- option Spacing3 ["-spacing3"; Units/int]
-##ifdef CAMLTK
- option State
-##else
- option EntryState
-##endif
- option Tabs ["-tabs"; [TabType list]]
- option TextWidth
- option Wrap ["-wrap"; WrapMode]
-
- function (int,int,int,int) bbox [widget(text); "bbox"; index: TextIndex]
- function (bool) compare [widget(text); "compare"; index: TextIndex; op: Comparison; index: TextIndex]
- function () configure [widget(text); "configure"; option(text) list]
- function (string) configure_get [widget(text); "configure"]
- function () debug [widget(text); "debug"; bool]
- function () delete [widget(text); "delete"; start: TextIndex; stop: TextIndex]
- function () delete_char [widget(text); "delete"; index: TextIndex]
- function (int, int, int, int, int) dlineinfo [widget(text); "dlineinfo"; index: TextIndex]
-
- % require result parser
- function (string list) dump [widget(text); "dump"; text_dump list; start: TextIndex; stop: TextIndex]
- function (string list) dump_char [widget(text); "dump"; text_dump list; index: TextIndex]
-
- function (string) get [widget(text); "get"; start: TextIndex; stop: TextIndex]
- function (string) get_char [widget(text); "get"; index: TextIndex]
- function () image_configure
- [widget(text); "image"; "configure"; name: string; option(embeddedi) list]
- function (string) image_configure_get
- [widget(text); "image"; "cgets"; name: string]
- function (string) image_create
- [widget(text); "image"; "create"; index: TextIndex; option(embeddedi) list]
- function (string list) image_names [widget(text); "image"; "names"]
- function (Index(text) as "[>`Linechar of int * int]") index [widget(text); "index"; index: TextIndex]
-##ifdef CAMLTK
- function () insert [widget(text); "insert"; index: TextIndex; text: string; [TextTag list]]
-##else
- function () insert [widget(text); "insert"; index: TextIndex; text: string; ?tags: [TextTag list]]
-##endif
- % Mark
- function () mark_gravity_set [widget(text); "mark"; "gravity"; mark: TextMark; direction: MarkDirection]
- function (MarkDirection) mark_gravity_get [widget(text); "mark"; "gravity"; mark: TextMark]
- function (TextMark list) mark_names [widget(text); "mark"; "names"]
- function (TextMark) mark_next [widget(text); "mark"; "next"; index: TextIndex]
- function (TextMark) mark_previous [widget(text); "mark"; "previous"; index: TextIndex]
- function () mark_set [widget(text); "mark"; "set"; mark: TextMark; index: TextIndex]
- function () mark_unset [widget(text); "mark"; "unset"; marks: TextMark list]
- % Scan
- function () scan_mark [widget(text); "scan"; "mark"; x: int; y: int]
- function () scan_dragto [widget(text); "scan"; "dragto"; x: int; y: int]
-##ifdef CAMLTK
- function (Index) search [widget(text); "search"; TextSearch list; "--"; string; TextIndex; TextIndex]
-##else
- function (Index(text) as "[>`Linechar of int * int]") search [widget(text); "search"; switches: TextSearch list; "--"; pattern: string; start: TextIndex; ?stop: [TextIndex]]
-##endif
- function () see [widget(text); "see"; index: TextIndex]
- % Tags
- function () tag_add [widget(text); "tag"; "add"; tag: TextTag; start: TextIndex; stop: TextIndex]
- function () tag_add_char [widget(text); "tag"; "add"; tag: TextTag; index: TextIndex]
- external tag_bind "builtin/text_tag_bind"
- function () tag_configure [widget(text); "tag"; "configure"; tag: TextTag; option(texttag) list]
- function () tag_delete [widget(text); "tag"; "delete"; TextTag list]
-
- function () tag_lower [widget(text); "tag"; "lower"; tag: TextTag; ?below: [TextTag]]
-##ifdef CAMLTK
- function () tag_lower_below [widget(text); "tag"; "lower"; TextTag; TextTag]
- function () tag_lower_bot [widget(text); "tag"; "lower"; TextTag]
-##endif
-
- function (TextTag list) tag_names [widget(text); "tag"; "names"; ?index: [TextIndex]]
-##ifdef CAMLTK
- function (TextTag list) tag_allnames [widget(text); "tag"; "names"]
- function (TextTag list) tag_indexnames [widget(text); "tag"; "names"; TextIndex]
-##endif
-
-##ifdef CAMLTK
- function (Index, Index) tag_nextrange [widget(text); "tag"; "nextrange"; TextTag; start: TextIndex; stop: TextIndex]
- function (Index, Index) tag_prevrange [widget(text); "tag"; "prevrange"; TextTag; start: TextIndex; stop: TextIndex]
-##else
- function (Index(text) as "[>`Linechar of int * int]", Index(text) as "[>`Linechar of int * int]") tag_nextrange [widget(text); "tag"; "nextrange"; tag: TextTag; start: TextIndex; ?stop: [TextIndex]]
- function (Index(text) as "[>`Linechar of int * int]", Index(text) as "[>`Linechar of int * int]") tag_prevrange [widget(text); "tag"; "prevrange"; tag: TextTag; start: TextIndex; ?stop: [TextIndex]]
-##endif
-
- function () tag_raise [widget(text); "tag"; "raise"; tag: TextTag; ?above: [TextTag]]
-##ifdef CAMLTK
- function () tag_raise_above [widget(text); "tag"; "raise"; TextTag; TextTag]
- function () tag_raise_top [widget(text); "tag"; "raise"; TextTag]
-##endif
-
-##ifdef CAMLTK
- function (Index list) tag_ranges [widget(text); "tag"; "ranges"; TextTag]
-##else
- function (Index(text) as "[>`Linechar of int * int]" list) tag_ranges [widget(text); "tag"; "ranges"; tag: TextTag]
-##endif
-
- function () tag_remove [widget(text); "tag"; "remove"; tag: TextTag; start: TextIndex; stop: TextIndex]
- function () tag_remove_char [widget(text); "tag"; "remove"; tag: TextTag; index: TextIndex]
-
- function () window_configure [widget(text); "window"; "configure"; tag: TextTag; option(embeddedw) list]
- function () window_create [widget(text); "window"; "create"; index: TextIndex; option(embeddedw) list]
- function (widget list) window_names [widget(text); "window"; "names"]
- % scrolling
- function (float,float) xview_get [widget(text); "xview"]
- function (float,float) yview_get [widget(text); "yview"]
- function () xview [widget(text); "xview"; scroll: ScrollValue]
- function () yview [widget(text); "yview"; scroll: ScrollValue]
- function () yview_index [widget(text); "yview"; index: TextIndex]
- function () yview_index_pickplace [widget(text); "yview"; "-pickplace"; index: TextIndex]
- function () yview_line [widget(text); "yview"; line: int] % obsolete
- }
-
-subtype option(texttag) {
- Background
- BgStipple ["-bgstipple"; Bitmap]
- BorderWidth
- FgStipple ["-fgstipple"; Bitmap]
- Font
- Foreground
- Justify
- LMargin1 ["-lmargin1"; Units/int]
- LMargin2 ["-lmargin2"; Units/int]
- Offset ["-offset"; Units/int]
- OverStrike ["-overstrike"; bool]
- Relief
- RMargin ["-rmargin"; Units/int]
- Spacing1
- Spacing2
- Spacing3
- Tabs
- Underline ["-underline"; bool]
- Wrap ["-wrap"; WrapMode]
- }
-
-
-%%%%% tk(n)
-unsafe function () appname_set ["tk"; "appname"; string]
-unsafe function (string) appname_get ["tk"; "appname"]
-function (float) scaling_get ["tk"; "scaling"; ?displayof:["-displayof"; widget]]
-unsafe function () scaling_set ["tk"; "scaling"; ?displayof:["-displayof"; widget]; float]
-
-%%%%% tk_chooseColor(n)
-
-subtype option(chooseColor){
- InitialColor ["-initialcolor"; Color]
- Parent ["-parent"; widget]
- Title ["-title"; string]
- }
-function (Color) chooseColor ["tk_chooseColor"; option(chooseColor) list]
-
-%%%%% tkwait(n)
-module Tkwait {
- function () variable ["tkwait"; "variable"; TextVariable]
- function () visibility ["tkwait"; "visibility"; widget]
- function () window ["tkwait"; "window"; widget]
- }
-
-
-%%%%% toplevel(n)
-% This module will be renamed "toplevelw" to avoid collision with
-% Caml Light standard toplevel module.
-widget toplevel {
- % Standard options
- option BorderWidth
- option Cursor
- option HighlightBackground
- option HighlightColor
- option HighlightThickness
- option Relief
- option TakeFocus
-
- % Widget specific options
- option Background
-##ifdef CAMLTK
- option Class
-##else
- option Clas
-##endif
- option Colormap
- option Container ["-container"; bool]
- option Height
- option Menu
- option Screen ["-screen"; string]
- option Use ["-use"; string] % must be hexadecimal "0x????"
- option Visual
- option Width
-
- function () configure [widget(toplevel); "configure"; option(toplevel) list]
- function (string) configure_get [widget(toplevel); "configure"]
- }
-
-
-%%%%% update(n)
-function () update ["update"]
-function () update_idletasks ["update"; "idletasks"]
-
-
-%%%%% winfo(n)
-
-type AtomId {
- AtomId [int]
- }
-
-module Winfo {
-
- unsafe function (AtomId) atom ["winfo"; "atom"; ?displayof:["-displayof"; widget]; string]
- unsafe function (string) atomname ["winfo"; "atomname"; ?displayof:["-displayof"; widget]; AtomId]
-##ifdef CAMLTK
- unsafe function (AtomId) atom_displayof ["winfo"; "atom"; "-displayof"; widget; string]
- unsafe function (string) atomname_displayof ["winfo"; "atomname"; "-displayof"; widget; AtomId]
-##endif
- function (int) cells ["winfo"; "cells"; widget]
- function (widget list) children ["winfo"; "children"; widget]
- function (string) class_name ["winfo"; "class"; widget]
- function (bool) colormapfull ["winfo"; "colormapfull"; widget]
- unsafe function (widget) containing ["winfo"; "containing"; ?displayof:["-displayof"; widget]; x: int; y: int]
-##ifdef CAMLTK
- unsafe function (widget) containing_displayof ["winfo"; "containing"; "-displayof"; widget; int; int]
-##endif
- % addition for applets
- external contained "builtin/winfo_contained"
- function (int) depth ["winfo"; "depth"; widget]
- function (bool) exists ["winfo"; "exists"; widget]
- function (float) fpixels ["winfo"; "fpixels"; widget; length: Units]
- function (string) geometry ["winfo"; "geometry"; widget]
- function (int) height ["winfo"; "height"; widget]
- unsafe function (string) id ["winfo"; "id"; widget]
- unsafe function (string list) interps ["winfo"; "interps"; ?displayof:["-displayof"; widget]]
-##ifdef CAMLTK
- unsafe function (string list) interps_displayof ["winfo"; "interps"; "-displayof"; widget]
-##endif
- function (bool) ismapped ["winfo"; "ismapped"; widget]
- function (string) manager ["winfo"; "manager"; widget]
- function (string) name ["winfo"; "name"; widget]
- unsafe function (widget) parent ["winfo"; "parent"; widget] % bogus for top
- unsafe function (widget) pathname ["winfo"; "pathname"; ?displayof:["-displayof"; widget]; string]
-##ifdef CAMLTK
- unsafe function (widget) pathname_displayof ["winfo"; "pathname"; "-displayof"; widget; string]
-##endif
- function (int) pixels ["winfo"; "pixels"; widget; length: Units]
- function (int) pointerx ["winfo"; "pointerx"; widget]
- function (int) pointery ["winfo"; "pointery"; widget]
- function (int, int) pointerxy ["winfo"; "pointerxy"; widget]
- function (int) reqheight ["winfo"; "reqheight"; widget]
- function (int) reqwidth ["winfo"; "reqwidth"; widget]
- function (int,int,int) rgb ["winfo"; "rgb"; widget; color: Color]
- function (int) rootx ["winfo"; "rootx"; widget]
- function (int) rooty ["winfo"; "rooty"; widget]
- unsafe function (string) screen ["winfo"; "screen"; widget]
- function (int) screencells ["winfo"; "screencells"; widget]
- function (int) screendepth ["winfo"; "screendepth"; widget]
- function (int) screenheight ["winfo"; "screenheight"; widget]
- function (int) screenmmheight ["winfo"; "screenmmheight"; widget]
- function (int) screenmmwidth ["winfo"; "screenmmwidth"; widget]
- function (string) screenvisual ["winfo"; "screenvisual"; widget]
- function (int) screenwidth ["winfo"; "screenwidth"; widget]
- unsafe function (string) server ["winfo"; "server"; widget]
- unsafe function (widget(toplevel)) toplevel ["winfo"; "toplevel"; widget]
- function (bool) viewable ["winfo"; "viewable"; widget]
- function (string) visual ["winfo"; "visual"; widget]
- function (int) visualid ["winfo"; "visualid"; widget]
- % need special parser
- function (string) visualsavailable ["winfo"; "visualsavailable"; widget; ?includeids: [int list]]
- function (int) vrootheight ["winfo"; "vrootheight"; widget]
- function (int) vrootwidth ["winfo"; "vrootwidth"; widget]
- function (int) vrootx ["winfo"; "vrootx"; widget]
- function (int) vrooty ["winfo"; "vrooty"; widget]
- function (int) width ["winfo"; "width"; widget]
- function (int) x ["winfo"; "x"; widget]
- function (int) y ["winfo"; "y"; widget]
-}
-
-
-%%%%% wm(n)
-
-type FocusModel {
- FocusActive ["active"]
- FocusPassive ["passive"]
-}
-
-type WmFrom {
- User ["user"]
- Program ["program"]
-}
-
-module Wm {
-%%% Aspect
- function () aspect_set ["wm"; "aspect"; widget(toplevel); minnum:int; mindenom:int; maxnum:int; maxdenom:int]
- % aspect: problem with empty return
- function (int,int,int,int) aspect_get ["wm"; "aspect"; widget(toplevel)]
-%%% WM_CLIENT_MACHINE
- function () client_set ["wm"; "client"; widget(toplevel); name: string]
- function (string) client_get ["wm"; "client"; widget(toplevel)]
-%%% WM_COLORMAP_WINDOWS
- function () colormapwindows_set
- ["wm"; "colormapwindows"; widget(toplevel); [windows: widget list]]
- unsafe function (widget list) colormapwindows_get
- ["wm"; "colormapwindows"; widget(toplevel)]
-%%% WM_COMMAND
- function () command_clear ["wm"; "command"; widget(toplevel); ""]
- function () command_set ["wm"; "command"; widget(toplevel); [string list]]
- function (string list) command_get ["wm"; "command"; widget(toplevel)]
-
- function () deiconify ["wm"; "deiconify"; widget(toplevel)]
-
-%%% Focus model
- function () focusmodel_set ["wm"; "focusmodel"; widget(toplevel); FocusModel]
- function (FocusModel) focusmodel_get ["wm"; "focusmodel"; widget(toplevel)]
-
- function (string) frame ["wm"; "frame"; widget(toplevel)]
-
-%%% Geometry
- function () geometry_set ["wm"; "geometry"; widget(toplevel); string]
- function (string) geometry_get ["wm"; "geometry"; widget(toplevel)]
-
-%%% Grid
- function () grid_clear ["wm"; "grid"; widget(toplevel); ""; ""; ""; ""]
- function () grid_set ["wm"; "grid"; widget(toplevel); basewidth: int; baseheight: int; widthinc: int; heightinc: int]
- function (int,int,int,int) grid_get ["wm"; "grid"; widget(toplevel)]
-
-%%% Groups
- function () group_clear ["wm"; "group"; widget(toplevel); ""]
- function () group_set ["wm"; "group"; widget(toplevel); leader: widget]
- unsafe function (widget) group_get ["wm"; "group"; widget(toplevel)]
-%%% Icon bitmap
- function () iconbitmap_clear ["wm"; "iconbitmap"; widget(toplevel); ""]
- function () iconbitmap_set ["wm"; "iconbitmap"; widget(toplevel); Bitmap]
- function (Bitmap) iconbitmap_get ["wm"; "iconbitmap"; widget(toplevel)]
-
- function () iconify ["wm"; "iconify"; widget(toplevel)]
-
-%%% Icon mask
- function () iconmask_clear ["wm"; "iconmask"; widget(toplevel); ""]
- function () iconmask_set ["wm"; "iconmask"; widget(toplevel); Bitmap]
- function (Bitmap) iconmask_get ["wm"; "iconmask"; widget(toplevel)]
-
-%%% Icon name
- function () iconname_set ["wm"; "iconname"; widget(toplevel); string]
- function (string) iconname_get ["wm"; "iconname"; widget(toplevel)]
-%%% Icon position
- function () iconposition_clear ["wm"; "iconposition"; widget(toplevel); ""; ""]
- function () iconposition_set ["wm"; "iconposition"; widget(toplevel); x: int; y: int]
- function (int,int) iconposition_get ["wm"; "iconposition"; widget(toplevel)]
-%%% Icon window
- function () iconwindow_clear ["wm"; "iconwindow"; widget(toplevel); ""]
- function () iconwindow_set ["wm"; "iconwindow"; widget(toplevel); icon: widget(toplevel)]
- unsafe function (widget(toplevel)) iconwindow_get ["wm"; "iconwindow"; widget(toplevel)]
-
-%%% Sizes
- function () maxsize_set ["wm"; "maxsize"; widget(toplevel); width: int; height: int]
- function (int,int) maxsize_get ["wm"; "maxsize"; widget(toplevel)]
- function () minsize_set ["wm"; "minsize"; widget(toplevel); width: int; height: int]
- function (int,int) minsize_get ["wm"; "minsize"; widget(toplevel)]
-%%% Override
- unsafe function () overrideredirect_set ["wm"; "overrideredirect"; widget(toplevel); bool]
- function (bool) overrideredirect_get ["wm"; "overrideredirect"; widget(toplevel)]
-%%% Position
- function () positionfrom_clear ["wm"; "positionfrom"; widget(toplevel); ""]
- function () positionfrom_set ["wm"; "positionfrom"; widget(toplevel); WmFrom]
- function (WmFrom) positionfrom_get ["wm"; "positionfrom"; widget(toplevel)]
-%%% Protocols
- function () protocol_set ["wm"; "protocol"; widget(toplevel); name: string; command: function()]
- function () protocol_clear ["wm"; "protocol"; widget(toplevel); name: string; ""]
- function (string list) protocols ["wm"; "protocol"; widget(toplevel)]
-%%% Resize
- function () resizable_set ["wm"; "resizable"; widget(toplevel); width: bool; height: bool]
- function (bool, bool) resizable_get ["wm"; "resizable"; widget(toplevel)]
-%%% Sizefrom
- function () sizefrom_clear ["wm"; "sizefrom"; widget(toplevel); ""]
- function () sizefrom_set ["wm"; "sizefrom"; widget(toplevel); WmFrom]
- function (WmFrom) sizefrom_get ["wm"; "sizefrom"; widget(toplevel)]
-
- function (string) state ["wm"; "state"; widget(toplevel)]
-
-%%% Title
- function (string) title_get ["wm"; "title"; widget(toplevel)]
- function () title_set ["wm"; "title"; widget(toplevel); string]
-%%% Transient
- function () transient_clear ["wm"; "transient"; widget(toplevel); ""]
- function () transient_set ["wm"; "transient"; widget(toplevel); master: widget]
- unsafe function (widget) transient_get ["wm"; "transient"; widget(toplevel)]
-
- function () withdraw ["wm"; "withdraw"; widget(toplevel)]
-
-}
-
-%%%%% tk_getOpenFile(n) (since version 8.0)
-type FilePattern external
-
-subtype option(getFile) {
- DefaultExtension ["-defaultextension"; string]
- FileTypes ["-filetypes"; [FilePattern list]]
- InitialDir ["-initialdir"; string]
- InitialFile ["-initialfile"; string]
- Parent ["-parent"; widget]
- Title ["-title"; string]
-}
-
-function (string) getOpenFile ["tk_getOpenFile"; option(getFile) list]
-function (string) getSaveFile ["tk_getSaveFile"; option(getFile) list]
-
-%%%%% tk_messageBox
-type MessageIcon {
- Error ["error"]
- Info ["info"]
- Question ["question"]
- Warning ["warning"]
-}
-type MessageType {
- AbortRetryIgnore ["abortretryignore"]
- Ok ["ok"]
- OkCancel ["okcancel"]
- RetryCancel ["retrycancel"]
- YesNo ["yesno"]
- YesNoCancel ["yesnocancel"]
-}
-subtype option(messageBox) {
- MessageDefault ["-default"; string]
- MessageIcon ["-icon"; MessageIcon]
- Message ["-message"; string]
- Parent
- Title
- MessageType ["-type"; MessageType]
-}
-
-function (string) messageBox ["tk_messageBox"; option(messageBox) list]
-
-module Tkvars {
- function (string) library ["$tk_library"]
- function (string) patchLevel ["$tk_patchLevel"]
- function (bool) strictMotif ["$tk_strictMotif"]
- function () set_strictMotif ["set"; "tk_strictMotif"; bool]
- function (string) version ["$tk_version"]
-}
-
-% Direct API calls, non Tcl-based modules
-
-module Pixmap {
- external create "builtin/rawimg"
- }
-
-%%% encodings : require if you want write your application international
-
-module Encoding {
- function (string) convertfrom ["encoding"; "convertfrom";
- ?encoding: [string]; string]
- function (string) convertto ["encoding"; "convertto";
- ?encoding: [string]; string]
- function (string list) names ["encoding"; "names"]
- function () system_set ["encoding"; "system"; string]
- function (string) system_get ["encoding"; "system"]
-}
diff --git a/otherlibs/labltk/browser/.cvsignore b/otherlibs/labltk/browser/.cvsignore
deleted file mode 100644
index 8ced21de22..0000000000
--- a/otherlibs/labltk/browser/.cvsignore
+++ /dev/null
@@ -1,2 +0,0 @@
-ocamlbrowser
-dummy.mli
diff --git a/otherlibs/labltk/browser/.depend b/otherlibs/labltk/browser/.depend
deleted file mode 100644
index 558ccdd268..0000000000
--- a/otherlibs/labltk/browser/.depend
+++ /dev/null
@@ -1,66 +0,0 @@
-editor.cmo: fileselect.cmi jg_bind.cmi jg_button.cmo jg_menu.cmo \
- jg_message.cmi jg_text.cmi jg_tk.cmo jg_toplevel.cmo lexical.cmi \
- mytypes.cmi searchid.cmi searchpos.cmi setpath.cmi shell.cmi \
- typecheck.cmi viewer.cmi editor.cmi
-editor.cmx: fileselect.cmx jg_bind.cmx jg_button.cmx jg_menu.cmx \
- jg_message.cmx jg_text.cmx jg_tk.cmx jg_toplevel.cmx lexical.cmx \
- mytypes.cmi searchid.cmx searchpos.cmx setpath.cmx shell.cmx \
- typecheck.cmx viewer.cmx editor.cmi
-fileselect.cmo: jg_box.cmo jg_entry.cmo jg_memo.cmi jg_toplevel.cmo list2.cmo \
- setpath.cmi useunix.cmi fileselect.cmi
-fileselect.cmx: jg_box.cmx jg_entry.cmx jg_memo.cmx jg_toplevel.cmx list2.cmx \
- setpath.cmx useunix.cmx fileselect.cmi
-jg_bind.cmo: jg_bind.cmi
-jg_bind.cmx: jg_bind.cmi
-jg_box.cmo: jg_bind.cmi jg_completion.cmi
-jg_box.cmx: jg_bind.cmx jg_completion.cmx
-jg_completion.cmo: jg_completion.cmi
-jg_completion.cmx: jg_completion.cmi
-jg_config.cmo: jg_tk.cmo jg_config.cmi
-jg_config.cmx: jg_tk.cmx jg_config.cmi
-jg_entry.cmo: jg_bind.cmi
-jg_entry.cmx: jg_bind.cmx
-jg_memo.cmo: jg_memo.cmi
-jg_memo.cmx: jg_memo.cmi
-jg_message.cmo: jg_bind.cmi jg_text.cmi jg_tk.cmo jg_toplevel.cmo \
- jg_message.cmi
-jg_message.cmx: jg_bind.cmx jg_text.cmx jg_tk.cmx jg_toplevel.cmx \
- jg_message.cmi
-jg_multibox.cmo: jg_bind.cmi jg_completion.cmi jg_multibox.cmi
-jg_multibox.cmx: jg_bind.cmx jg_completion.cmx jg_multibox.cmi
-jg_text.cmo: jg_bind.cmi jg_button.cmo jg_tk.cmo jg_toplevel.cmo jg_text.cmi
-jg_text.cmx: jg_bind.cmx jg_button.cmx jg_tk.cmx jg_toplevel.cmx jg_text.cmi
-lexical.cmo: jg_tk.cmo lexical.cmi
-lexical.cmx: jg_tk.cmx lexical.cmi
-main.cmo: editor.cmi jg_config.cmi searchid.cmi searchpos.cmi shell.cmi \
- viewer.cmi
-main.cmx: editor.cmx jg_config.cmx searchid.cmx searchpos.cmx shell.cmx \
- viewer.cmx
-searchid.cmo: list2.cmo searchid.cmi
-searchid.cmx: list2.cmx searchid.cmi
-searchpos.cmo: jg_bind.cmi jg_memo.cmi jg_message.cmi jg_text.cmi jg_tk.cmo \
- lexical.cmi searchid.cmi searchpos.cmi
-searchpos.cmx: jg_bind.cmx jg_memo.cmx jg_message.cmx jg_text.cmx jg_tk.cmx \
- lexical.cmx searchid.cmx searchpos.cmi
-setpath.cmo: jg_bind.cmi jg_box.cmo jg_button.cmo jg_toplevel.cmo list2.cmo \
- useunix.cmi setpath.cmi
-setpath.cmx: jg_bind.cmx jg_box.cmx jg_button.cmx jg_toplevel.cmx list2.cmx \
- useunix.cmx setpath.cmi
-shell.cmo: dummy.cmi fileselect.cmi jg_memo.cmi jg_menu.cmo jg_message.cmi \
- jg_text.cmi jg_tk.cmo jg_toplevel.cmo lexical.cmi list2.cmo shell.cmi
-shell.cmx: dummy.cmi fileselect.cmx jg_memo.cmx jg_menu.cmx jg_message.cmx \
- jg_text.cmx jg_tk.cmx jg_toplevel.cmx lexical.cmx list2.cmx shell.cmi
-typecheck.cmo: jg_message.cmi jg_text.cmi jg_tk.cmo mytypes.cmi typecheck.cmi
-typecheck.cmx: jg_message.cmx jg_text.cmx jg_tk.cmx mytypes.cmi typecheck.cmi
-useunix.cmo: useunix.cmi
-useunix.cmx: useunix.cmi
-viewer.cmo: help.cmo jg_bind.cmi jg_box.cmo jg_button.cmo jg_completion.cmi \
- jg_entry.cmo jg_menu.cmo jg_message.cmi jg_multibox.cmi jg_text.cmi \
- jg_tk.cmo jg_toplevel.cmo mytypes.cmi searchid.cmi searchpos.cmi \
- setpath.cmi shell.cmi useunix.cmi viewer.cmi
-viewer.cmx: help.cmx jg_bind.cmx jg_box.cmx jg_button.cmx jg_completion.cmx \
- jg_entry.cmx jg_menu.cmx jg_message.cmx jg_multibox.cmx jg_text.cmx \
- jg_tk.cmx jg_toplevel.cmx mytypes.cmi searchid.cmx searchpos.cmx \
- setpath.cmx shell.cmx useunix.cmx viewer.cmi
-mytypes.cmi: shell.cmi
-typecheck.cmi: mytypes.cmi
diff --git a/otherlibs/labltk/browser/Makefile b/otherlibs/labltk/browser/Makefile
deleted file mode 100644
index c1daed9461..0000000000
--- a/otherlibs/labltk/browser/Makefile
+++ /dev/null
@@ -1,64 +0,0 @@
-include ../support/Makefile.common
-
-LABLTKLIB=-I ../labltk -I ../lib -I ../support
-#OTHERSLIB=-I $(OTHERS)/win32unix -I $(OTHERS)/systhreads -I $(OTHERS)/str
-OTHERSLIB=-I $(OTHERS)/unix -I $(OTHERS)/str
-OCAMLTOPLIB=-I $(TOPDIR)/parsing -I $(TOPDIR)/utils -I $(TOPDIR)/typing
-INCLUDES=$(OTHERSLIB) $(LABLTKLIB) $(OCAMLTOPLIB)
-
-OBJ = list2.cmo useunix.cmo setpath.cmo lexical.cmo \
- fileselect.cmo searchid.cmo searchpos.cmo shell.cmo \
- help.cmo \
- viewer.cmo typecheck.cmo editor.cmo main.cmo
-
-JG = jg_tk.cmo jg_config.cmo jg_bind.cmo jg_completion.cmo \
- jg_box.cmo \
- jg_button.cmo jg_toplevel.cmo jg_text.cmo jg_message.cmo \
- jg_menu.cmo jg_entry.cmo jg_multibox.cmo jg_memo.cmo
-
-# Default rules
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.ml.cmo:
- $(CAMLCOMP) $(INCLUDES) $<
-
-.mli.cmi:
- $(CAMLCOMP) $(INCLUDES) $<
-
-all: ocamlbrowser$(EXE)
-
-ocamlbrowser$(EXE): $(TOPDIR)/toplevel/toplevellib.cma jglib.cma $(OBJ) \
- ../support/lib$(LIBNAME).a
- $(CAMLC) -o ocamlbrowser$(EXE) $(INCLUDES) \
- $(TOPDIR)/toplevel/toplevellib.cma \
- unix.cma str.cma $(LIBNAME).cma jglib.cma $(OBJ)
-
-ocamlbrowser.cma: jglib.cma $(OBJ)
- $(CAMLC) -a -o $@ -linkall jglib.cma $(OBJ)
-
-jglib.cma: $(JG)
- $(CAMLCOMP) -a -o jglib.cma $(JG)
-
-help.ml:
- echo 'let text = "\\' > $@
- sed -e 's/^ /\\032/' -e 's/$$/\\n\\/' help.txt >> $@
- echo '";;' >> $@
-
-install:
- if test -f ocamlbrowser$(EXE); then : ; \
- cp ocamlbrowser$(EXE) $(BINDIR); fi
-
-clean:
- rm -f *.cm? ocamlbrowser$(EXE) dummy.mli *~ *.orig
-
-depend:
- $(CAMLDEP) *.ml *.mli > .depend
-
-dummy.mli:
- rm -f $@
- ln -s dummyUnix.mli $@
-shell.cmo: dummy.cmi
-setpath.cmo fileselect.cmo lexical.cmi searchid.cmi typecheck.cmi: $(TOPDIR)/toplevel/toplevellib.cma
-
-include .depend
diff --git a/otherlibs/labltk/browser/Makefile.nt b/otherlibs/labltk/browser/Makefile.nt
deleted file mode 100644
index 6079723637..0000000000
--- a/otherlibs/labltk/browser/Makefile.nt
+++ /dev/null
@@ -1,70 +0,0 @@
-include ../support/Makefile.common.nt
-
-LABLTKLIB=-I ../labltk -I ../lib -I ../support
-OTHERSLIB=-I $(OTHERS)/win32unix -I $(OTHERS)/str -I $(OTHERS)/systhreads
-OCAMLTOPLIB=-I $(TOPDIR)/parsing -I $(TOPDIR)/utils -I $(TOPDIR)/typing
-INCLUDES=$(OTHERSLIB) $(LABLTKLIB) $(OCAMLTOPLIB)
-CCFLAGS=-I../../../byterun $(TK_DEFS)
-
-ifeq ($(CCOMPTYPE),cc)
-WINDOWS_APP=
-else
-WINDOWS_APP=-cclib "/link /subsystem:windows"
-endif
-
-OBJS = list2.cmo useunix.cmo setpath.cmo lexical.cmo \
- fileselect.cmo searchid.cmo searchpos.cmo shell.cmo \
- help.cmo \
- viewer.cmo typecheck.cmo editor.cmo main.cmo
-
-JG = jg_tk.cmo jg_config.cmo jg_bind.cmo jg_completion.cmo \
- jg_box.cmo \
- jg_button.cmo jg_toplevel.cmo jg_text.cmo jg_message.cmo \
- jg_menu.cmo jg_entry.cmo jg_multibox.cmo jg_memo.cmo
-
-# Default rules
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx .c .$(O)
-
-.ml.cmo:
- $(CAMLCOMP) $(INCLUDES) $<
-
-.mli.cmi:
- $(CAMLCOMP) $(INCLUDES) $<
-
-.c.$(O):
- $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $<
-
-all: ocamlbrowser.exe
-
-ocamlbrowser.exe: $(TOPDIR)/toplevel/toplevellib.cma \
- ../support/lib$(LIBNAME).$(A)
-ocamlbrowser.exe: jglib.cma $(OBJS) winmain.$(O)
- $(CAMLC) -o ocamlbrowser.exe -custom $(INCLUDES) \
- $(TOPDIR)/toplevel/toplevellib.cma \
- unix.cma threads.cma str.cma $(LIBNAME).cma jglib.cma $(OBJS) \
- winmain.$(O) $(WINDOWS_APP)
-
-jglib.cma: $(JG)
- $(CAMLCOMP) -a -o jglib.cma $(JG)
-
-help.ml:
- echo 'let text = "\\' > $@
- sed -e 's/^ /\\032/' -e 's/$$/\\n\\/' help.txt >> $@
- echo '";;' >> $@
-
-install:
- if test -f ocamlbrowser.exe; then cp ocamlbrowser.exe $(BINDIR); fi
-
-clean:
- rm -f *.cm? ocamlbrowser.exe dummy.mli *~ *.orig *.$(O)
-
-depend:
- $(CAMLDEP) *.ml *.mli > .depend
-
-dummy.mli:
- cp dummyWin.mli dummy.mli
-shell.cmo: dummy.cmi
-setpath.cmo fileselect.cmo lexical.cmi searchid.cmi typecheck.cmi: $(TOPDIR)/toplevel/toplevellib.cma
-
-include .depend
diff --git a/otherlibs/labltk/browser/README b/otherlibs/labltk/browser/README
deleted file mode 100644
index e8953541bf..0000000000
--- a/otherlibs/labltk/browser/README
+++ /dev/null
@@ -1,170 +0,0 @@
-
- Installing and Using OCamlBrowser
-
-
-INSTALLATION
- If you installed it with LablTk, nothing to do.
- Otherwise, the source is in labltk/browser.
- After installing LablTk, simply do "make" and "make install".
- The name of the command is `ocamlbrowser'.
-
-USE
- OCamlBrowser is composed of three tools, the Viewer, to walk around
- compiled modules, the Editor, which allows one to
- edit/typecheck/analyse .mli and .ml files, and the Shell, to run an
- OCaml subshell. You may only have one instance of Editor and
- Viewer, but you may use several subshells.
-
- As with the compiler, you may specify a different path for the
- standard library by setting CAMLLIB. You may also extend the
- initial load path (only standard library by default) by using the
- -I command line option, or set various other options (see -help).
-
- If you prefered the old GUI, it is still available with the option
- -oldui, otherwise you get a new Smalltalkish user interface.
-
-1) Viewer
-
- Menus
-
- File - Open and File - Editor give access to the editor.
-
- File - Shell opens an OCaml shell.
-
- View - Show all defs displays all the interface of the currently
- selected module
- View - Search entry shows/hides the search entry at the top of the
- window
-
- Modules - Path editor changes the load path.
- Pressing [Add to path] or Insert key adds selected directories
- to the load path.
- Pressing [Remove from path] or Delete key removes selected
- paths from the load path.
- Modules - Reset cache rescans the load path and resets the module
- cache. Do it if you recompile some interface, or change the load
- path in a conflictual way.
-
- Modules - Search symbol allows to search a symbol either by its
- name, like the bottom line of the viewer, or, more
- interestingly, by its type. Exact type searches for a type
- with exactly the same information as the pattern (variables
- match only variables), included type allows to give only
- partial information: the actual type may take more arguments
- and return more results, and variables in the pattern match
- anything. In both cases, argument and tuple order is
- irrelevant (*), and unlabeled arguments in the pattern match
- any label.
-
- (*) To avoid combinatorial explosion of the search space, optional
- arguments in the actual type are ignored if (1) there are to many
- of them, and (2) they do not appear explicitly in the pattern.
-
- Search entry
-
- The entry line at the top allows one to search for an identifier
- in all modules, either by its name (? and * patterns allowed) or by
- its type. When search by type is used, it is done in inclusion mode
- (cf. Modules - search symbol)
-
- The Close all button at the bottom is there to dismiss the windows
- created by the Detach button. By double-clicking on it you will
- quit the browser.
-
- Module browsing
-
- You select a module in the leftmost box by either cliking on it or
- pressing return when it is selected. Fast access is available in
- all boxes pressing the first few letter of the desired
- name. Double-clicking / double-return displays the whole signature
- for the module.
-
- Defined identifiers inside the module are displayed in a box to the
- right of the previous one. If you click on one, this will either
- display its contents in another box (if this is a sub-module) or
- display the signature for this identifier below.
-
- Signatures are clickable. Double clicking with the left mouse
- button on an identifier in a signature brings you to its signature.
- A single click on the right button pops up a menu displaying the
- type declaration for the selected identifier. Its title, when
- selectable, also brings you to its signature.
-
- At the bottom, a series of buttons, depending on the context.
- * Detach copies the currently displayed signature in a new window,
- to keep it. You can discard these windows with Close all.
- * Impl and Intf bring you to the implementation or interface of
- the currently displayed signature, if it is available.
-
- C-s opens a text search dialog for the displayed signature.
-
-2) Editor
- You can edit files with it, but there is no auto-save nor undo at
- the moment. Otherwise you can use it as a browser, making
- occasional corrections.
-
- The Edit menu contains commands for jump (C-g), search (C-s), and
- sending the current selection to a sub-shell (M-x). For this last
- option, you may choose the shell via a dialog.
-
- Essential function are in the Compiler menu.
-
- Preferences opens a dialog to set internals of the editor and
- type checker.
-
- Lex (M-l) adds colors according to lexical categories.
-
- Typecheck (M-t) verifies typing, and memorizes it to let one see an
- expression's type by double-clicking on it. This is also valid for
- interfaces. If an error occurs, the part of the interface preceding
- the error is computed.
-
- After typechecking, pressing the right button pops up a menu giving
- the type of the pointed expression, and eventually allowing to
- follow some links.
-
- Clear errors dismisses type checker error messages and warnings.
-
- Signature shows the signature of the current file.
-
-3) Shell
- When you create a shell, a dialog is presented to you, letting you
- choose which command you want to run, and the title of the shell
- (to choose it in the Editor).
-
- You may change the default command by setting the OLABL environment
- variable.
-
- The executed subshell is given the current load path.
- File: use a source file or load a bytecode file.
- You may also import the browser's path into the subprocess.
- History: M-p and M-n browse up and down.
- Signal: C-c interrupts and you can kill the subprocess.
-
-BUGS
-
-* This not really a bug, but OCamlBrowser is a huge memory consumer.
- Go and buy some.
-
-* When you quit the editor and some file was modified, a dialogue is
- displayed asking wether you want to really quit or not. But 1) if
- you quit directly from the viewer, there is no dialogue at all, and
- 2) if you close from the window manager, the dialogue is displayed,
- but you cannot cancel the destruction... Beware.
-
-* When you run it through xon, the shell hangs at the first error. But
- its ok if you start ocamlbrowser from a remote shell...
-
-TODO
-
-* Complete cross-references.
-
-* Power up editor.
-
-* Add support for the debugger.
-
-* Make this a real programming environment, both for beginners an
- experimented users.
-
-
-Bug reports and comments to <garrigue@kurims.kyoto-u.ac.jp>
diff --git a/otherlibs/labltk/browser/dummyUnix.mli b/otherlibs/labltk/browser/dummyUnix.mli
deleted file mode 100644
index 163d14ad34..0000000000
--- a/otherlibs/labltk/browser/dummyUnix.mli
+++ /dev/null
@@ -1,27 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2000 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-module Mutex : sig
- type t
- external create : unit -> t = "%ignore"
- external lock : t -> unit = "%ignore"
- external unlock : t -> unit = "%ignore"
-end
-
-module Thread : sig
- type t
- external create : ('a -> 'b) -> 'a -> t = "caml_input"
-end
diff --git a/otherlibs/labltk/browser/dummyWin.mli b/otherlibs/labltk/browser/dummyWin.mli
deleted file mode 100644
index a4b75ee37b..0000000000
--- a/otherlibs/labltk/browser/dummyWin.mli
+++ /dev/null
@@ -1,15 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2000 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
diff --git a/otherlibs/labltk/browser/editor.ml b/otherlibs/labltk/browser/editor.ml
deleted file mode 100644
index 1e6e3c0ee2..0000000000
--- a/otherlibs/labltk/browser/editor.ml
+++ /dev/null
@@ -1,671 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open StdLabels
-open Tk
-open Parsetree
-open Location
-open Jg_tk
-open Mytypes
-
-let lex_on_load = ref true
-and type_on_load = ref false
-
-let compiler_preferences master =
- let tl = Jg_toplevel.titled "Compiler" in
- Wm.transient_set tl ~master;
- let mk_chkbutton ~text ~ref ~invert =
- let variable = Textvariable.create ~on:tl () in
- if (if invert then not !ref else !ref) then
- Textvariable.set variable "1";
- Checkbutton.create tl ~text ~variable,
- (fun () ->
- ref := Textvariable.get variable = (if invert then "0" else "1"))
- in
- let use_pp = ref (!Clflags.preprocessor <> None) in
- let chkbuttons, setflags = List.split
- (List.map
- ~f:(fun (text, ref, invert) -> mk_chkbutton ~text ~ref ~invert)
- [ "No pervasives", Clflags.nopervasives, false;
- "No warnings", Typecheck.nowarnings, false;
- "No labels", Clflags.classic, false;
- "Recursive types", Clflags.recursive_types, false;
- "Lex on load", lex_on_load, false;
- "Type on load", type_on_load, false;
- "Preprocessor", use_pp, false ])
- in
- let pp_command = Entry.create tl (* ~state:(if !use_pp then `Normal else`Disabled) *) in
- begin match !Clflags.preprocessor with None -> ()
- | Some pp -> Entry.insert pp_command ~index:(`Num 0) ~text:pp
- end;
- let buttons = Frame.create tl in
- let ok = Button.create buttons ~text:"Ok" ~padx:20 ~command:
- begin fun () ->
- List.iter ~f:(fun f -> f ()) setflags;
- Clflags.preprocessor :=
- if !use_pp then Some (Entry.get pp_command) else None;
- destroy tl
- end
- and cancel = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel"
- in
- pack chkbuttons ~side:`Top ~anchor:`W;
- pack [pp_command] ~side:`Top ~anchor:`E;
- pack [ok;cancel] ~side:`Left ~fill:`X ~expand:true;
- pack [buttons] ~side:`Bottom ~fill:`X
-
-let rec exclude txt = function
- [] -> []
- | x :: l -> if txt.number = x.number then l else x :: exclude txt l
-
-let goto_line tw =
- let tl = Jg_toplevel.titled "Go to" in
- Wm.transient_set tl ~master:(Winfo.toplevel tw);
- Jg_bind.escape_destroy tl;
- let ef = Frame.create tl in
- let fl = Frame.create ef
- and fi = Frame.create ef in
- let ll = Label.create fl ~text:"Line ~number:"
- and il = Entry.create fi ~width:10
- and lc = Label.create fl ~text:"Col ~number:"
- and ic = Entry.create fi ~width:10
- and get_int ew =
- try int_of_string (Entry.get ew)
- with Failure "int_of_string" -> 0
- in
- let buttons = Frame.create tl in
- let ok = Button.create buttons ~text:"Ok" ~command:
- begin fun () ->
- let l = get_int il
- and c = get_int ic in
- Text.mark_set tw ~mark:"insert" ~index:(`Linechar (l,0), [`Char c]);
- Text.see tw ~index:(`Mark "insert", []);
- destroy tl
- end
- and cancel = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" in
-
- Focus.set il;
- List.iter [il; ic] ~f:
- begin fun w ->
- Jg_bind.enter_focus w;
- Jg_bind.return_invoke w ~button:ok
- end;
- pack [ll; lc] ~side:`Top ~anchor:`W;
- pack [il; ic] ~side:`Top ~fill:`X ~expand:true;
- pack [fl; fi] ~side:`Left ~fill:`X ~expand:true;
- pack [ok; cancel] ~side:`Left ~fill:`X ~expand:true;
- pack [ef; buttons] ~side:`Top ~fill:`X ~expand:true
-
-let select_shell txt =
- let shells = Shell.get_all () in
- let shells = List.sort shells ~cmp:compare in
- let tl = Jg_toplevel.titled "Select Shell" in
- Jg_bind.escape_destroy tl;
- Wm.transient_set tl ~master:(Winfo.toplevel txt.tw);
- let label = Label.create tl ~text:"Send to:"
- and box = Listbox.create tl
- and frame = Frame.create tl in
- Jg_bind.enter_focus box;
- let cancel = Jg_button.create_destroyer tl ~parent:frame ~text:"Cancel"
- and ok = Button.create frame ~text:"Ok" ~command:
- begin fun () ->
- try
- let name = Listbox.get box ~index:`Active in
- txt.shell <- Some (name, List.assoc name shells);
- destroy tl
- with Not_found -> txt.shell <- None; destroy tl
- end
- in
- Listbox.insert box ~index:`End ~texts:(List.map ~f:fst shells);
- Listbox.configure box ~height:(List.length shells);
- bind box ~events:[`KeyPressDetail"Return"] ~breakable:true
- ~action:(fun _ -> Button.invoke ok; break ());
- bind box ~events:[`Modified([`Double],`ButtonPressDetail 1)] ~breakable:true
- ~fields:[`MouseX;`MouseY]
- ~action:(fun ev ->
- Listbox.activate box ~index:(`Atxy (ev.ev_MouseX, ev.ev_MouseY));
- Button.invoke ok; break ());
- pack [label] ~side:`Top ~anchor:`W;
- pack [box] ~side:`Top ~fill:`Both;
- pack [frame] ~side:`Bottom ~fill:`X ~expand:true;
- pack [ok;cancel] ~side:`Left ~fill:`X ~expand:true
-
-open Parser
-
-let send_phrase txt =
- if txt.shell = None then begin
- match Shell.get_all () with [] -> ()
- | [sh] -> txt.shell <- Some sh
- | l -> select_shell txt
- end;
- match txt.shell with None -> ()
- | Some (_,sh) ->
- try
- let i1,i2 = Text.tag_nextrange txt.tw ~tag:"sel" ~start:tstart in
- let phrase = Text.get txt.tw ~start:(i1,[]) ~stop:(i2,[]) in
- sh#send phrase;
- if Str.string_match (Str.regexp ";;") phrase 0
- then sh#send "\n" else sh#send ";;\n"
- with Not_found | Protocol.TkError _ ->
- let text = Text.get txt.tw ~start:tstart ~stop:tend in
- let buffer = Lexing.from_string text in
- let start = ref 0
- and block_start = ref []
- and pend = ref (-1)
- and after = ref false in
- while !pend = -1 do
- let token = Lexer.token buffer in
- let pos =
- if token = SEMISEMI then Lexing.lexeme_end buffer
- else Lexing.lexeme_start buffer
- in
- let bol = (pos = 0) || text.[pos-1] = '\n' in
- if not !after &&
- Text.compare txt.tw ~index:(tpos pos) ~op:(if bol then `Gt else `Ge)
- ~index:(`Mark"insert",[])
- then begin
- after := true;
- let anon, real =
- List.partition !block_start ~f:(fun x -> x = -1) in
- block_start := anon;
- if real <> [] then start := List.hd real;
- end;
- match token with
- CLASS | EXTERNAL | EXCEPTION | FUNCTOR
- | LET | MODULE | OPEN | TYPE | VAL | SHARP when bol ->
- if !block_start = [] then
- if !after then pend := pos else start := pos
- else block_start := pos :: List.tl !block_start
- | SEMISEMI ->
- if !block_start = [] then
- if !after then pend := Lexing.lexeme_start buffer
- else start := pos
- else block_start := pos :: List.tl !block_start
- | BEGIN | OBJECT ->
- block_start := -1 :: !block_start
- | STRUCT | SIG ->
- block_start := Lexing.lexeme_end buffer :: !block_start
- | END ->
- if !block_start = [] then
- if !after then pend := pos else ()
- else block_start := List.tl !block_start
- | EOF ->
- pend := pos
- | _ ->
- ()
- done;
- let phrase = String.sub text ~pos:!start ~len:(!pend - !start) in
- sh#send phrase;
- sh#send ";;\n"
-
-let search_pos_window txt ~x ~y =
- if txt.type_info = [] && txt.psignature = [] then () else
- let `Linechar (l, c) = Text.index txt.tw ~index:(`Atxy(x,y), []) in
- let text = Jg_text.get_all txt.tw in
- let pos = Searchpos.lines_to_chars l ~text + c in
- try if txt.type_info <> [] then begin match
- Searchpos.search_pos_info txt.type_info ~pos
- with [] -> ()
- | (kind, env, loc) :: _ -> Searchpos.view_type kind ~env
- end else begin match
- Searchpos.search_pos_signature txt.psignature ~pos ~env:!Searchid.start_env
- with [] -> ()
- | ((kind, lid), env, loc) :: _ ->
- Searchpos.view_decl lid ~kind ~env
- end
- with Not_found -> ()
-
-let search_pos_menu txt ~x ~y =
- if txt.type_info = [] && txt.psignature = [] then () else
- let `Linechar (l, c) = Text.index txt.tw ~index:(`Atxy(x,y), []) in
- let text = Jg_text.get_all txt.tw in
- let pos = Searchpos.lines_to_chars l ~text + c in
- try if txt.type_info <> [] then begin match
- Searchpos.search_pos_info txt.type_info ~pos
- with [] -> ()
- | (kind, env, loc) :: _ ->
- let menu = Searchpos.view_type_menu kind ~env ~parent:txt.tw in
- let x = x + Winfo.rootx txt.tw and y = y + Winfo.rooty txt.tw - 10 in
- Menu.popup menu ~x ~y
- end else begin match
- Searchpos.search_pos_signature txt.psignature ~pos ~env:!Searchid.start_env
- with [] -> ()
- | ((kind, lid), env, loc) :: _ ->
- let menu = Searchpos.view_decl_menu lid ~kind ~env ~parent:txt.tw in
- let x = x + Winfo.rootx txt.tw and y = y + Winfo.rooty txt.tw - 10 in
- Menu.popup menu ~x ~y
- end
- with Not_found -> ()
-
-let string_width s =
- let width = ref 0 in
- for i = 0 to String.length s - 1 do
- if s.[i] = '\t' then width := (!width / 8 + 1) * 8
- else incr width
- done;
- !width
-
-let indent_line =
- let ins = `Mark"insert" and reg = Str.regexp "[ \t]*" in
- fun tw ->
- let `Linechar(l,c) = Text.index tw ~index:(ins,[])
- and line = Text.get tw ~start:(ins,[`Linestart]) ~stop:(ins,[`Lineend]) in
- ignore (Str.string_match reg line 0);
- let len = Str.match_end () in
- if len < c then Text.insert tw ~index:(ins,[]) ~text:"\t" else
- let width = string_width (Str.matched_string line) in
- Text.mark_set tw ~mark:"insert" ~index:(ins,[`Linestart;`Char len]);
- let indent =
- if l <= 1 then 2 else
- let previous =
- Text.get tw ~start:(ins,[`Line(-1);`Linestart])
- ~stop:(ins,[`Line(-1);`Lineend]) in
- ignore (Str.string_match reg previous 0);
- let previous = Str.matched_string previous in
- let width_previous = string_width previous in
- if width_previous <= width then 2 else width_previous - width
- in
- Text.insert tw ~index:(ins,[]) ~text:(String.make indent ' ')
-
-(* The editor class *)
-
-class editor ~top ~menus = object (self)
- val file_menu = new Jg_menu.c "File" ~parent:menus
- val edit_menu = new Jg_menu.c "Edit" ~parent:menus
- val compiler_menu = new Jg_menu.c "Compiler" ~parent:menus
- val module_menu = new Jg_menu.c "Modules" ~parent:menus
- val window_menu = new Jg_menu.c "Windows" ~parent:menus
- val label =
- Checkbutton.create menus ~state:`Disabled
- ~onvalue:"modified" ~offvalue:"unchanged"
- val mutable current_dir = Unix.getcwd ()
- val mutable error_messages = []
- val mutable windows = []
- val mutable current_tw = Text.create top
- val vwindow = Textvariable.create ~on:top ()
- val mutable window_counter = 0
-
- method has_window name =
- List.exists windows ~f:(fun x -> x.name = name)
-
- method reset_window_menu =
- Menu.delete window_menu#menu ~first:(`Num 0) ~last:`End;
- List.iter
- (List.sort windows ~cmp:
- (fun w1 w2 ->
- compare (Filename.basename w1.name) (Filename.basename w2.name)))
- ~f:
- begin fun txt ->
- Menu.add_radiobutton window_menu#menu
- ~label:(Filename.basename txt.name)
- ~variable:vwindow ~value:txt.number
- ~command:(fun () -> self#set_edit txt)
- end
-
- method set_edit txt =
- if windows <> [] then
- Pack.forget [(List.hd windows).frame];
- windows <- txt :: exclude txt windows;
- self#reset_window_menu;
- current_tw <- txt.tw;
- Checkbutton.configure label ~text:(Filename.basename txt.name)
- ~variable:txt.modified;
- Textvariable.set vwindow txt.number;
- Text.yview txt.tw ~scroll:(`Page 0);
- pack [txt.frame] ~fill:`Both ~expand:true ~side:`Bottom
-
- method new_window name =
- let tl, tw, sb = Jg_text.create_with_scrollbar top in
- Text.configure tw ~background:`White;
- Jg_bind.enter_focus tw;
- window_counter <- window_counter + 1;
- let txt =
- { name = name; tw = tw; frame = tl;
- number = string_of_int window_counter;
- modified = Textvariable.create ~on:tw ();
- shell = None;
- structure = []; type_info = []; signature = []; psignature = [] }
- in
- let control c = Char.chr (Char.code c - 96) in
- bind tw ~events:[`Modified([`Alt], `KeyPress)] ~action:ignore;
- bind tw ~events:[`KeyPress] ~fields:[`Char]
- ~action:(fun ev ->
- if ev.ev_Char <> "" &&
- (ev.ev_Char.[0] >= ' ' ||
- List.mem ev.ev_Char.[0]
- (List.map ~f:control ['d'; 'h'; 'i'; 'k'; 'o'; 't'; 'w'; 'y']))
- then Textvariable.set txt.modified "modified");
- bind tw ~events:[`KeyPressDetail"Tab"] ~breakable:true
- ~action:(fun _ ->
- indent_line tw;
- Textvariable.set txt.modified "modified";
- break ());
- bind tw ~events:[`Modified([`Control],`KeyPressDetail"k")]
- ~action:(fun _ ->
- let text =
- Text.get tw ~start:(`Mark"insert",[]) ~stop:(`Mark"insert",[`Lineend])
- in ignore (Str.string_match (Str.regexp "[ \t]*") text 0);
- if Str.match_end () <> String.length text then begin
- Clipboard.clear ();
- Clipboard.append ~data:text ()
- end);
- bind tw ~events:[`KeyRelease] ~fields:[`Char]
- ~action:(fun ev ->
- if ev.ev_Char <> "" then
- Lexical.tag tw ~start:(`Mark"insert", [`Linestart])
- ~stop:(`Mark"insert", [`Lineend]));
- bind tw ~events:[`Motion] ~action:(fun _ -> Focus.set tw);
- bind tw ~events:[`ButtonPressDetail 2]
- ~action:(fun _ ->
- Textvariable.set txt.modified "modified";
- Lexical.tag txt.tw ~start:(`Mark"insert", [`Linestart])
- ~stop:(`Mark"insert", [`Lineend]));
- bind tw ~events:[`Modified([`Double], `ButtonPressDetail 1)]
- ~fields:[`MouseX;`MouseY]
- ~action:(fun ev -> search_pos_window txt ~x:ev.ev_MouseX ~y:ev.ev_MouseY);
- bind tw ~events:[`ButtonPressDetail 3] ~fields:[`MouseX;`MouseY]
- ~action:(fun ev -> search_pos_menu txt ~x:ev.ev_MouseX ~y:ev.ev_MouseY);
-
- pack [sb] ~fill:`Y ~side:`Right;
- pack [tw] ~fill:`Both ~expand:true ~side:`Left;
- self#set_edit txt;
- Checkbutton.deselect label;
- Lexical.init_tags txt.tw
-
- method clear_errors () =
- Text.tag_remove current_tw ~tag:"error" ~start:tstart ~stop:tend;
- List.iter error_messages
- ~f:(fun tl -> try destroy tl with Protocol.TkError _ -> ());
- error_messages <- []
-
- method typecheck () =
- self#clear_errors ();
- error_messages <- Typecheck.f (List.hd windows)
-
- method lex () =
- List.iter [ Widget.default_toplevel; top ]
- ~f:(Toplevel.configure ~cursor:(`Xcursor "watch"));
- Text.configure current_tw ~cursor:(`Xcursor "watch");
- ignore (Timer.add ~ms:1 ~callback:
- begin fun () ->
- Text.tag_remove current_tw ~tag:"error" ~start:tstart ~stop:tend;
- Lexical.tag current_tw;
- Text.configure current_tw ~cursor:(`Xcursor "xterm");
- List.iter [ Widget.default_toplevel; top ]
- ~f:(Toplevel.configure ~cursor:(`Xcursor ""))
- end)
-
- method save_text ?name:l txt =
- let l = match l with None -> [txt.name] | Some l -> l in
- if l = [] then () else
- let name = List.hd l in
- if txt.name <> name then current_dir <- Filename.dirname name;
- try
- if Sys.file_exists name then
- if txt.name = name then begin
- let backup = name ^ "~" in
- if Sys.file_exists backup then Sys.remove backup;
- try Sys.rename name backup with Sys_error _ -> ()
- end else begin
- match Jg_message.ask ~master:top ~title:"Save"
- ("File `" ^ name ^ "' exists. Overwrite it?")
- with `Yes -> Sys.remove name
- | `No -> raise (Sys_error "")
- | `Cancel -> raise Exit
- end;
- let file = open_out name in
- let text = Text.get txt.tw ~start:tstart ~stop:(tposend 1) in
- output_string file text;
- close_out file;
- Checkbutton.configure label ~text:(Filename.basename name);
- Checkbutton.deselect label;
- txt.name <- name
- with
- Sys_error _ ->
- Jg_message.info ~master:top ~title:"Error"
- ("Could not save `" ^ name ^ "'.")
- | Exit -> ()
-
- method load_text l =
- if l = [] then () else
- let name = List.hd l in
- try
- let index =
- try
- self#set_edit (List.find windows ~f:(fun x -> x.name = name));
- let txt = List.hd windows in
- if Textvariable.get txt.modified = "modified" then
- begin match Jg_message.ask ~master:top ~title:"Open"
- ("`" ^ Filename.basename txt.name ^ "' modified. Save it?")
- with `Yes -> self#save_text txt
- | `No -> ()
- | `Cancel -> raise Exit
- end;
- Checkbutton.deselect label;
- (Text.index current_tw ~index:(`Mark"insert", []), [])
- with Not_found -> self#new_window name; tstart
- in
- current_dir <- Filename.dirname name;
- let file = open_in name
- and tw = current_tw
- and len = ref 0
- and buf = String.create 4096 in
- Text.delete tw ~start:tstart ~stop:tend;
- while
- len := input file buf 0 4096;
- !len > 0
- do
- Jg_text.output tw ~buf ~pos:0 ~len:!len
- done;
- close_in file;
- Text.mark_set tw ~mark:"insert" ~index;
- Text.see tw ~index;
- if Filename.check_suffix name ".ml" ||
- Filename.check_suffix name ".mli"
- then begin
- if !lex_on_load then self#lex ();
- if !type_on_load then self#typecheck ()
- end
- with
- Sys_error _ | Exit -> ()
-
- method close_window txt =
- try
- if Textvariable.get txt.modified = "modified" then
- begin match Jg_message.ask ~master:top ~title:"Close"
- ("`" ^ Filename.basename txt.name ^ "' modified. Save it?")
- with `Yes -> self#save_text txt
- | `No -> ()
- | `Cancel -> raise Exit
- end;
- windows <- exclude txt windows;
- if windows = [] then
- self#new_window (current_dir ^ "/untitled")
- else self#set_edit (List.hd windows);
- destroy txt.frame
- with Exit -> ()
-
- method open_file () =
- Fileselect.f ~title:"Open File" ~action:self#load_text
- ~dir:current_dir ~filter:("*.{ml,mli}") ~sync:true ()
-
- method save_file () = self#save_text (List.hd windows)
-
- method close_file () = self#close_window (List.hd windows)
-
- method quit ?(cancel=true) () =
- try
- List.iter windows ~f:
- begin fun txt ->
- if Textvariable.get txt.modified = "modified" then
- match Jg_message.ask ~master:top ~title:"Quit" ~cancel
- ("`" ^ Filename.basename txt.name ^ "' modified. Save it?")
- with `Yes -> self#save_text txt
- | `No -> ()
- | `Cancel -> raise Exit
- end;
- bind top ~events:[`Destroy];
- destroy top
- with Exit -> ()
-
- method reopen ~file ~pos =
- if not (Winfo.ismapped top) then Wm.deiconify top;
- match file with None -> ()
- | Some file ->
- self#load_text [file];
- Text.mark_set current_tw ~mark:"insert" ~index:(tpos pos);
- try
- let index =
- Text.search current_tw ~switches:[`Backwards] ~pattern:"*)"
- ~start:(tpos pos) ~stop:(tpos pos ~modi:[`Line(-1)]) in
- let index =
- Text.search current_tw ~switches:[`Backwards] ~pattern:"(*"
- ~start:(index,[]) ~stop:(tpos pos ~modi:[`Line(-20)]) in
- let s = Text.get current_tw ~start:(index,[`Line(-1);`Linestart])
- ~stop:(index,[`Line(-1);`Lineend]) in
- for i = 0 to String.length s - 1 do
- match s.[i] with '\t'|' ' -> () | _ -> raise Not_found
- done;
- Text.yview_index current_tw ~index:(index,[`Line(-1)])
- with _ ->
- Text.yview_index current_tw ~index:(tpos pos ~modi:[`Line(-2)])
-
- initializer
- (* Create a first window *)
- self#new_window (current_dir ^ "/untitled");
-
- (* Bindings for the main window *)
- List.iter
- [ [`Control], "s", (fun () -> Jg_text.search_string current_tw);
- [`Control], "g", (fun () -> goto_line current_tw);
- [`Alt], "s", self#save_file;
- [`Alt], "x", (fun () -> send_phrase (List.hd windows));
- [`Alt], "l", self#lex;
- [`Alt], "t", self#typecheck ]
- ~f:begin fun (modi,key,act) ->
- bind top ~events:[`Modified(modi, `KeyPressDetail key)] ~breakable:true
- ~action:(fun _ -> act (); break ())
- end;
-
- bind top ~events:[`Destroy] ~fields:[`Widget] ~action:
- begin fun ev ->
- if Widget.name ev.ev_Widget = Widget.name top
- then self#quit ~cancel:false ()
- end;
-
- (* File menu *)
- file_menu#add_command "Open File..." ~command:self#open_file;
- file_menu#add_command "Reopen"
- ~command:(fun () -> self#load_text [(List.hd windows).name]);
- file_menu#add_command "Save File" ~command:self#save_file ~accelerator:"M-s";
- file_menu#add_command "Save As..." ~underline:5 ~command:
- begin fun () ->
- let txt = List.hd windows in
- Fileselect.f ~title:"Save as File"
- ~action:(fun name -> self#save_text txt ~name)
- ~dir:(Filename.dirname txt.name)
- ~filter:"*.{ml,mli}"
- ~file:(Filename.basename txt.name)
- ~sync:true ~usepath:false ()
- end;
- file_menu#add_command "Close File" ~command:self#close_file;
- file_menu#add_command "Close Window" ~command:self#quit ~underline:6;
-
- (* Edit menu *)
- edit_menu#add_command "Paste selection" ~command:
- begin fun () ->
- Text.insert current_tw ~index:(`Mark"insert",[])
- ~text:(Selection.get ~displayof:top ())
- end;
- edit_menu#add_command "Goto..." ~accelerator:"C-g"
- ~command:(fun () -> goto_line current_tw);
- edit_menu#add_command "Search..." ~accelerator:"C-s"
- ~command:(fun () -> Jg_text.search_string current_tw);
- edit_menu#add_command "To shell" ~accelerator:"M-x"
- ~command:(fun () -> send_phrase (List.hd windows));
- edit_menu#add_command "Select shell..."
- ~command:(fun () -> select_shell (List.hd windows));
-
- (* Compiler menu *)
- compiler_menu#add_command "Preferences..."
- ~command:(fun () -> compiler_preferences top);
- compiler_menu#add_command "Lex" ~accelerator:"M-l"
- ~command:self#lex;
- compiler_menu#add_command "Typecheck" ~accelerator:"M-t"
- ~command:self#typecheck;
- compiler_menu#add_command "Clear errors"
- ~command:self#clear_errors;
- compiler_menu#add_command "Signature..." ~command:
- begin fun () ->
- let txt = List.hd windows in if txt.signature <> [] then
- let basename = Filename.basename txt.name in
- let modname = String.capitalize
- (try Filename.chop_extension basename with _ -> basename) in
- let env =
- Env.add_module (Ident.create modname)
- (Types.Tmty_signature txt.signature)
- Env.initial
- in Viewer.view_defined (Longident.Lident modname) ~env ~show_all:true
- end;
-
- (* Modules *)
- module_menu#add_command "Path editor..."
- ~command:(fun () -> Setpath.set ~dir:current_dir);
- module_menu#add_command "Reset cache"
- ~command:(fun () -> Setpath.exec_update_hooks (); Env.reset_cache ());
- module_menu#add_command "Search symbol..."
- ~command:Viewer.search_symbol;
- module_menu#add_command "Close all"
- ~command:Viewer.close_all_views;
-
- (* pack everything *)
- pack (List.map ~f:(fun m -> coe m#button)
- [file_menu; edit_menu; compiler_menu; module_menu; window_menu]
- @ [coe label])
- ~side:`Left ~ipadx:5 ~anchor:`W;
- pack [menus] ~before:(List.hd windows).frame ~side:`Top ~fill:`X
-end
-
-(* The main function starts here ! *)
-
-let already_open : editor list ref = ref []
-
-let editor ?file ?(pos=0) ?(reuse=false) () =
-
- if !already_open <> [] &&
- let ed = List.hd !already_open
- (* try
- let name = match file with Some f -> f | None -> raise Not_found in
- List.find !already_open ~f:(fun ed -> ed#has_window name)
- with Not_found -> List.hd !already_open *)
- in try
- ed#reopen ~file ~pos;
- true
- with Protocol.TkError _ ->
- already_open := [] (* List.filter !already_open ~f:((<>) ed) *);
- false
- then () else
- let top = Jg_toplevel.titled "OCamlBrowser Editor" in
- let menus = Frame.create top ~name:"menubar" in
- let ed = new editor ~top ~menus in
- already_open := !already_open @ [ed];
- if file <> None then ed#reopen ~file ~pos
-
-let f ?file ?pos ?(opendialog=false) () =
- if opendialog then
- Fileselect.f ~title:"Open File"
- ~action:(function [file] -> editor ~file () | _ -> ())
- ~filter:("*.{ml,mli}") ~sync:true ()
- else editor ?file ?pos ~reuse:(file <> None) ()
diff --git a/otherlibs/labltk/browser/editor.mli b/otherlibs/labltk/browser/editor.mli
deleted file mode 100644
index 665ee813f3..0000000000
--- a/otherlibs/labltk/browser/editor.mli
+++ /dev/null
@@ -1,20 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open Widget
-
-val f : ?file:string -> ?pos:int -> ?opendialog:bool -> unit -> unit
- (* open the file editor *)
diff --git a/otherlibs/labltk/browser/fileselect.ml b/otherlibs/labltk/browser/fileselect.ml
deleted file mode 100644
index 6ca08f5aca..0000000000
--- a/otherlibs/labltk/browser/fileselect.ml
+++ /dev/null
@@ -1,290 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-(* file selection box *)
-
-open StdLabels
-open Str
-open Filename
-open Tk
-
-open Useunix
-
-(**** Memoized rexgexp *)
-
-let (~!) = Jg_memo.fast ~f:Str.regexp
-
-(************************************************************ Path name *)
-
-(* Convert Windows-style directory separator '\' to caml-style '/' *)
-let caml_dir path =
- if Sys.os_type = "Win32" then
- global_replace ~!"\\\\" "/" path
- else path
-
-let parse_filter s =
- let s = caml_dir s in
- (* replace // by / *)
- let s = global_replace ~!"/+" "/" s in
- (* replace /./ by / *)
- let s = global_replace ~!"/\\./" "/" s in
- (* replace hoge/../ by "" *)
- let s = global_replace
- ~!"\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\./" "" s in
- (* replace hoge/..$ by *)
- let s = global_replace
- ~!"\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\.$" "" s in
- (* replace ^/hoge/../ by / *)
- let s = global_replace ~!"^\\(/\\.\\.\\)+/" "/" s in
- if string_match ~!"^\\([^\\*?[]*[/:]\\)\\(.*\\)" s 0 then
- let dirs = matched_group 1 s
- and ptrn = matched_group 2 s
- in
- dirs, ptrn
- else "", s
-
-let rec fixpoint ~f v =
- let v' = f v in
- if v = v' then v else fixpoint ~f v'
-
-let unix_regexp s =
- let s = Str.global_replace ~!"[$^.+]" "\\\\\\0" s in
- let s = Str.global_replace ~!"\\*" ".*" s in
- let s = Str.global_replace ~!"\\?" ".?" s in
- let s =
- fixpoint s
- ~f:(Str.replace_first ~!"\\({.*\\),\\(.*}\\)" "\\1\\|\\2") in
- let s =
- Str.global_replace ~!"{\\(.*\\)}" "\\(\\1\\)" s in
- Str.regexp s
-
-let exact_match ~pat s =
- Str.string_match pat s 0 && Str.match_end () = String.length s
-
-let ls ~dir ~pattern =
- let files = get_files_in_directory dir in
- let regexp = unix_regexp pattern in
- List.filter files ~f:(exact_match ~pat:regexp)
-
-(********************************************* Creation *)
-let load_in_path = ref false
-
-let search_in_path ~name = Misc.find_in_path !Config.load_path name
-
-let f ~title ~action:proc ?(dir = Unix.getcwd ())
- ?filter:(deffilter ="*") ?file:(deffile ="")
- ?(multi=false) ?(sync=false) ?(usepath=true) () =
-
- let current_pattern = ref ""
- and current_dir = ref (caml_dir dir) in
-
- let may_prefix name =
- if Filename.is_relative name then concat !current_dir name else name in
-
- let tl = Jg_toplevel.titled title in
- Focus.set tl;
-
- let new_var () = Textvariable.create ~on:tl () in
- let filter_var = new_var ()
- and selection_var = new_var ()
- and sync_var = new_var () in
- Textvariable.set filter_var deffilter;
-
- let frm = Frame.create tl ~borderwidth:1 ~relief:`Raised in
- let df = Frame.create frm in
- let dfl = Frame.create df in
- let dfll = Label.create dfl ~text:"Directories" in
- let dflf, directory_listbox, directory_scrollbar =
- Jg_box.create_with_scrollbar dfl in
- let dfr = Frame.create df in
- let dfrl = Label.create dfr ~text:"Files" in
- let dfrf, filter_listbox, filter_scrollbar =
- Jg_box.create_with_scrollbar dfr in
- let cfrm = Frame.create tl ~borderwidth:1 ~relief:`Raised in
-
- let configure ~filter =
- let filter = may_prefix filter in
- let dir, pattern = parse_filter filter in
- let dir = if !load_in_path && usepath then "" else
- (current_dir := Filename.dirname dir; dir)
- and pattern = if pattern = "" then "*" else pattern in
- current_pattern := pattern;
- let filter =
- if !load_in_path && usepath then pattern else dir ^ pattern in
- let directories = get_directories_in_files ~path:dir
- (get_files_in_directory dir) in
- let matched_files = (* get matched file by subshell call. *)
- if !load_in_path && usepath then
- List.fold_left !Config.load_path ~init:[] ~f:
- begin fun acc dir ->
- let files = ls ~dir ~pattern in
- Sort.merge (<) files
- (List.fold_left files ~init:acc
- ~f:(fun acc name -> List2.exclude name acc))
- end
- else
- List.fold_left directories ~init:(ls ~dir ~pattern)
- ~f:(fun acc dir -> List2.exclude dir acc)
- in
- Textvariable.set filter_var filter;
- Textvariable.set selection_var (dir ^ deffile);
- Listbox.delete filter_listbox ~first:(`Num 0) ~last:`End;
- Listbox.insert filter_listbox ~index:`End ~texts:matched_files;
- Jg_box.recenter filter_listbox ~index:(`Num 0);
- if !load_in_path && usepath then
- Listbox.configure directory_listbox ~takefocus:false
- else
- begin
- Listbox.configure directory_listbox ~takefocus:true;
- Listbox.delete directory_listbox ~first:(`Num 0) ~last:`End;
- Listbox.insert directory_listbox ~index:`End ~texts:directories;
- Jg_box.recenter directory_listbox ~index:(`Num 0)
- end
- in
-
- let selected_files = ref [] in (* used for synchronous mode *)
- let activate l =
- Grab.release tl;
- destroy tl;
- let l =
- if !load_in_path && usepath then
- List.fold_right l ~init:[] ~f:
- begin fun name acc ->
- if not (Filename.is_implicit name) then
- may_prefix name :: acc
- else try search_in_path ~name :: acc with Not_found -> acc
- end
- else
- List.map l ~f:may_prefix
- in
- if sync then
- begin
- selected_files := l;
- Textvariable.set sync_var "1"
- end
- else proc l
- in
-
- (* entries *)
- let fl = Label.create frm ~text:"Filter" in
- let sl = Label.create frm ~text:"Selection" in
- let filter_entry = Jg_entry.create frm ~textvariable:filter_var
- ~command:(fun filter -> configure ~filter) in
- let selection_entry = Jg_entry.create frm ~textvariable:selection_var
- ~command:(fun file -> activate [file]) in
-
- (* and buttons *)
- let set_path = Button.create dfl ~text:"Path editor" ~command:
- begin fun () ->
- Setpath.add_update_hook (fun () -> configure ~filter:!current_pattern);
- let w = Setpath.f ~dir:!current_dir in
- Grab.set w;
- bind w ~events:[`Destroy] ~extend:true ~action:(fun _ -> Grab.set tl)
- end in
- let toggle_in_path = Checkbutton.create dfl ~text:"Use load path"
- ~command:
- begin fun () ->
- load_in_path := not !load_in_path;
- if !load_in_path then
- pack [set_path] ~side:`Bottom ~fill:`X ~expand:true
- else
- Pack.forget [set_path];
- configure ~filter:(Textvariable.get filter_var)
- end
- and okb = Button.create cfrm ~text:"Ok" ~command:
- begin fun () ->
- let files =
- List.map (Listbox.curselection filter_listbox) ~f:
- begin fun x ->
- !current_dir ^ Listbox.get filter_listbox ~index:x
- end
- in
- let files = if files = [] then [Textvariable.get selection_var]
- else files in
- activate [Textvariable.get selection_var]
- end
- and flb = Button.create cfrm ~text:"Filter"
- ~command:(fun () -> configure ~filter:(Textvariable.get filter_var))
- and ccb = Button.create cfrm ~text:"Cancel"
- ~command:(fun () -> activate []) in
-
- (* binding *)
- bind tl ~events:[`KeyPressDetail "Escape"] ~action:(fun _ -> activate []);
- Jg_box.add_completion filter_listbox
- ~action:(fun index -> activate [Listbox.get filter_listbox ~index]);
- if multi then Listbox.configure filter_listbox ~selectmode:`Multiple else
- bind filter_listbox ~events:[`ButtonPressDetail 1] ~fields:[`MouseY]
- ~action:(fun ev ->
- let name = Listbox.get filter_listbox
- ~index:(Listbox.nearest filter_listbox ~y:ev.ev_MouseY) in
- if !load_in_path && usepath then
- try Textvariable.set selection_var (search_in_path ~name)
- with Not_found -> ()
- else Textvariable.set selection_var (may_prefix name));
-
- Jg_box.add_completion directory_listbox ~action:
- begin fun index ->
- let filter =
- may_prefix (Listbox.get directory_listbox ~index) ^
- "/" ^ !current_pattern
- in configure ~filter
- end;
-
- pack [frm] ~fill:`Both ~expand:true;
- (* filter *)
- pack [fl] ~side:`Top ~anchor:`W;
- pack [filter_entry] ~side:`Top ~fill:`X;
-
- (* directory + files *)
- pack [df] ~side:`Top ~fill:`Both ~expand:true;
- (* directory *)
- pack [dfl] ~side:`Left ~fill:`Both ~expand:true;
- pack [dfll] ~side:`Top ~anchor:`W;
- if usepath then pack [toggle_in_path] ~side:`Bottom ~anchor:`W;
- pack [dflf] ~side:`Top ~fill:`Both ~expand:true;
- pack [directory_scrollbar] ~side:`Right ~fill:`Y;
- pack [directory_listbox] ~side:`Left ~fill:`Both ~expand:true;
- (* files *)
- pack [dfr] ~side:`Right ~fill:`Both ~expand:true;
- pack [dfrl] ~side:`Top ~anchor:`W;
- pack [dfrf] ~side:`Top ~fill:`Both ~expand:true;
- pack [filter_scrollbar] ~side:`Right ~fill:`Y;
- pack [filter_listbox] ~side:`Left ~fill:`Both ~expand:true;
-
- (* selection *)
- pack [sl] ~before:df ~side:`Bottom ~anchor:`W;
- pack [selection_entry] ~before:sl ~side:`Bottom ~fill:`X;
-
- (* create OK, Filter and Cancel buttons *)
- pack [okb; flb; ccb] ~side:`Left ~fill:`X ~expand:true;
- pack [cfrm] ~before:frm ~side:`Bottom ~fill:`X;
-
- if !load_in_path && usepath then begin
- load_in_path := false;
- Checkbutton.invoke toggle_in_path;
- Checkbutton.select toggle_in_path
- end
- else configure ~filter:deffilter;
-
- Tkwait.visibility tl;
- Grab.set tl;
-
- if sync then
- begin
- Tkwait.variable sync_var;
- proc !selected_files
- end;
- ()
diff --git a/otherlibs/labltk/browser/fileselect.mli b/otherlibs/labltk/browser/fileselect.mli
deleted file mode 100644
index 75ee582aea..0000000000
--- a/otherlibs/labltk/browser/fileselect.mli
+++ /dev/null
@@ -1,39 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-val f :
- title:string ->
- action:(string list -> unit) ->
- ?dir:string ->
- ?filter:string ->
- ?file:string ->
- ?multi:bool -> ?sync:bool -> ?usepath:bool -> unit -> unit
-
-(* action
- [] means canceled
- if multi select is false, then the list is null or a singleton *)
-
-(* multi
- If true then more than one file are selectable *)
-
-(* sync
- If true then synchronous mode *)
-
-(* usepath
- Enables/disables load path search. Defaults to true *)
-
-val caml_dir : string -> string
-(* Convert Windows-style directory separator '\' to caml-style '/' *)
diff --git a/otherlibs/labltk/browser/help.ml b/otherlibs/labltk/browser/help.ml
deleted file mode 100644
index 632e762fdb..0000000000
--- a/otherlibs/labltk/browser/help.ml
+++ /dev/null
@@ -1,168 +0,0 @@
-let text = "\
-\032 OCamlBrowser Help\n\
-\n\
-USE\n\
-\n\
-\032 OCamlBrowser is composed of three tools, the Editor, which allows\n\
-\032 one to edit/typecheck/analyse .mli and .ml files, the Viewer, to\n\
-\032 walk around compiled modules, and the Shell, to run an OCaml\n\
-\032 subshell. You may only have one instance of Editor and Viewer, but\n\
-\032 you may use several subshells.\n\
-\n\
-\032 As with the compiler, you may specify a different path for the\n\
-\032 standard library by setting OCAMLLIB. You may also extend the\n\
-\032 initial load path (only standard library by default) by using the\n\
-\032 -I command line option. The -nolabels, -rectypes and -w options are\n\
-\032 also accepted, and inherited by subshells.\n\
-\032 The -oldui options selects the old multi-window interface. The\n\
-\032 default is now more like Smalltalk's class browser.\n\
-\n\
-1) Viewer\n\
-\n\
-\032 This is the first window you get when you start OCamlBrowser. It\n\
-\032 displays a search window, and the list of modules in the load path.\n\
-\032 At the top a row of menus.\n\
-\n\
-\032 File - Open and File - Editor give access to the editor.\n\
-\n\
-\032 File - Shell opens an OCaml shell.\n\
-\n\
-\032 View - Show all defs displays the signature of the currently\n\
-\032 selected module.\n\
-\n\
-\032 View - Search entry shows/hides the search entry just\n\
-\032 below the menu bar.\n\
-\n\
-\032 Modules - Path editor changes the load path.\n\
-\032 Pressing [Add to path] or Insert key adds selected directories\n\
-\032 to the load path.\n\
-\032 Pressing [Remove from path] or Delete key removes selected\n\
-\032 paths from the load path.\n\
-\n\
-\032 Modules - Reset cache rescans the load path and resets the module\n\
-\032 cache. Do it if you recompile some interface, or change the load\n\
-\032 path in a conflictual way.\n\
-\n\
-\032 Modules - Search symbol allows to search a symbol either by its\n\
-\032 name, like the bottom line of the viewer, or, more interestingly,\n\
-\032 by its type. Exact type searches for a type with exactly the same\n\
-\032 information as the pattern (variables match only variables),\n\
-\032 included type allows to give only partial information: the actual\n\
-\032 type may take more arguments and return more results, and variables\n\
-\032 in the pattern match anything. In both cases, argument and tuple\n\
-\032 order is irrelevant (*), and unlabeled arguments in the pattern\n\
-\032 match any label.\n\
-\n\
-\032 (*) To avoid combinatorial explosion of the search space, optional\n\
-\032 arguments in the actual type are ignored if (1) there are to many\n\
-\032 of them, and (2) they do not appear explicitly in the pattern.\n\
-\n\
-\032 The Search entry just below the menu bar allows one to search for\n\
-\032 an identifier in all modules, either by its name (? and * patterns\n\
-\032 allowed) or by its type (if there is an arrow in the input). When\n\
-\032 search by type is used, it is done in inclusion mode (cf. Modules -\n\
-\032 search symbol)\n\
-\n\
-\032 The Close all button is there to dismiss the windows created\n\
-\032 by the Detach button. By double-clicking on it you will quit the\n\
-\032 browser.\n\
-\n\
-\n\
-2) Module browsing\n\
-\n\
-\032 You select a module in the leftmost box by either cliking on it or\n\
-\032 pressing return when it is selected. Fast access is available in\n\
-\032 all boxes pressing the first few letter of the desired name.\n\
-\032 Double-clicking / double-return displays the whole signature for\n\
-\032 the module.\n\
-\n\
-\032 Defined identifiers inside the module are displayed in a box to the\n\
-\032 right of the previous one. If you click on one, this will either\n\
-\032 display its contents in another box (if this is a sub-module) or\n\
-\032 display the signature for this identifier below.\n\
-\n\
-\032 Signatures are clickable. Double clicking with the left mouse\n\
-\032 button on an identifier in a signature brings you to its signature,\n\
-\032 inside its module box.\n\
-\032 A single click on the right button pops up a menu displaying the\n\
-\032 type declaration for the selected identifier. Its title, when\n\
-\032 selectable, also brings you to its signature.\n\
-\n\
-\032 At the bottom, a series of buttons, depending on the context.\n\
-\032 * Detach copies the currently displayed signature in a new window,\n\
-\032 to keep it.\n\
-\032 * Impl and Intf bring you to the implementation or interface of\n\
-\032 the currently displayed signature, if it is available.\n\
-\n\
-\032 C-s opens a text search dialog for the displayed signature.\n\
-\n\
-3) File editor\n\
-\n\
-\032 You can edit files with it, but there is no auto-save nor undo at\n\
-\032 the moment. Otherwise you can use it as a browser, making\n\
-\032 occasional corrections.\n\
-\n\
-\032 The Edit menu contains commands for jump (C-g), search (C-s), and\n\
-\032 sending the current selection to a sub-shell (M-x). For this last\n\
-\032 option, you may choose the shell via a dialog.\n\
-\n\
-\032 Essential function are in the Compiler menu.\n\
-\n\
-\032 Preferences opens a dialog to set internals of the editor and\n\
-\032 type checker.\n\
-\n\
-\032 Lex (M-l) adds colors according to lexical categories.\n\
-\n\
-\032 Typecheck (M-t) verifies typing, and memorizes it to let one see an\n\
-\032 expression's type by double-clicking on it. This is also valid for\n\
-\032 interfaces. If an error occurs, the part of the interface preceding\n\
-\032 the error is computed.\n\
-\n\
-\032 After typechecking, pressing the right button pops up a menu giving\n\
-\032 the type of the pointed expression, and eventually allowing to\n\
-\032 follow some links.\n\
-\n\
-\032 Clear errors dismisses type checker error messages and warnings.\n\
-\n\
-\032 Signature shows the signature of the current file.\n\
-\n\
-4) Shell\n\
-\n\
-\032 When you create a shell, a dialog is presented to you, letting you\n\
-\032 choose which command you want to run, and the title of the shell\n\
-\032 (to choose it in the Editor).\n\
-\n\
-\032 You may change the default command by setting the OLABL environment\n\
-\032 variable.\n\
-\n\
-\032 The executed subshell is given the current load path.\n\
-\032 File: use a source file or load a bytecode file.\n\
-\032 You may also import the browser's path into the subprocess.\n\
-\032 History: M-p and M-n browse up and down.\n\
-\032 Signal: C-c interrupts and you can kill the subprocess.\n\
-\n\
-BUGS\n\
-\n\
-* When you quit the editor and some file was modified, a dialogue is\n\
-\032 displayed asking wether you want to really quit or not. But 1) if\n\
-\032 you quit directly from the viewer, there is no dialogue at all, and\n\
-\032 2) if you close from the window manager, the dialogue is displayed,\n\
-\032 but you cannot cancel the destruction... Beware.\n\
-\n\
-* When you run it through xon, the shell hangs at the first error. But\n\
-\032 its ok if you start ocamlbrowser from a remote shell...\n\
-\n\
-TODO\n\
-\n\
-* Complete cross-references.\n\
-\n\
-* Power up editor.\n\
-\n\
-* Add support for the debugger.\n\
-\n\
-* Make this a real programming environment, both for beginners an\n\
-\032 experimented users.\n\
-\n\
-\n\
-Bug reports and comments to <garrigue@kurims.kyoto-u.ac.jp>\n\
-";;
diff --git a/otherlibs/labltk/browser/help.txt b/otherlibs/labltk/browser/help.txt
deleted file mode 100644
index 62bfc59211..0000000000
--- a/otherlibs/labltk/browser/help.txt
+++ /dev/null
@@ -1,166 +0,0 @@
- OCamlBrowser Help
-
-USE
-
- OCamlBrowser is composed of three tools, the Editor, which allows
- one to edit/typecheck/analyse .mli and .ml files, the Viewer, to
- walk around compiled modules, and the Shell, to run an OCaml
- subshell. You may only have one instance of Editor and Viewer, but
- you may use several subshells.
-
- As with the compiler, you may specify a different path for the
- standard library by setting OCAMLLIB. You may also extend the
- initial load path (only standard library by default) by using the
- -I command line option. The -nolabels, -rectypes and -w options are
- also accepted, and inherited by subshells.
- The -oldui options selects the old multi-window interface. The
- default is now more like Smalltalk's class browser.
-
-1) Viewer
-
- This is the first window you get when you start OCamlBrowser. It
- displays a search window, and the list of modules in the load path.
- At the top a row of menus.
-
- File - Open and File - Editor give access to the editor.
-
- File - Shell opens an OCaml shell.
-
- View - Show all defs displays the signature of the currently
- selected module.
-
- View - Search entry shows/hides the search entry just
- below the menu bar.
-
- Modules - Path editor changes the load path.
- Pressing [Add to path] or Insert key adds selected directories
- to the load path.
- Pressing [Remove from path] or Delete key removes selected
- paths from the load path.
-
- Modules - Reset cache rescans the load path and resets the module
- cache. Do it if you recompile some interface, or change the load
- path in a conflictual way.
-
- Modules - Search symbol allows to search a symbol either by its
- name, like the bottom line of the viewer, or, more interestingly,
- by its type. Exact type searches for a type with exactly the same
- information as the pattern (variables match only variables),
- included type allows to give only partial information: the actual
- type may take more arguments and return more results, and variables
- in the pattern match anything. In both cases, argument and tuple
- order is irrelevant (*), and unlabeled arguments in the pattern
- match any label.
-
- (*) To avoid combinatorial explosion of the search space, optional
- arguments in the actual type are ignored if (1) there are to many
- of them, and (2) they do not appear explicitly in the pattern.
-
- The Search entry just below the menu bar allows one to search for
- an identifier in all modules, either by its name (? and * patterns
- allowed) or by its type (if there is an arrow in the input). When
- search by type is used, it is done in inclusion mode (cf. Modules -
- search symbol)
-
- The Close all button is there to dismiss the windows created
- by the Detach button. By double-clicking on it you will quit the
- browser.
-
-
-2) Module browsing
-
- You select a module in the leftmost box by either cliking on it or
- pressing return when it is selected. Fast access is available in
- all boxes pressing the first few letter of the desired name.
- Double-clicking / double-return displays the whole signature for
- the module.
-
- Defined identifiers inside the module are displayed in a box to the
- right of the previous one. If you click on one, this will either
- display its contents in another box (if this is a sub-module) or
- display the signature for this identifier below.
-
- Signatures are clickable. Double clicking with the left mouse
- button on an identifier in a signature brings you to its signature,
- inside its module box.
- A single click on the right button pops up a menu displaying the
- type declaration for the selected identifier. Its title, when
- selectable, also brings you to its signature.
-
- At the bottom, a series of buttons, depending on the context.
- * Detach copies the currently displayed signature in a new window,
- to keep it.
- * Impl and Intf bring you to the implementation or interface of
- the currently displayed signature, if it is available.
-
- C-s opens a text search dialog for the displayed signature.
-
-3) File editor
-
- You can edit files with it, but there is no auto-save nor undo at
- the moment. Otherwise you can use it as a browser, making
- occasional corrections.
-
- The Edit menu contains commands for jump (C-g), search (C-s), and
- sending the current selection to a sub-shell (M-x). For this last
- option, you may choose the shell via a dialog.
-
- Essential function are in the Compiler menu.
-
- Preferences opens a dialog to set internals of the editor and
- type checker.
-
- Lex (M-l) adds colors according to lexical categories.
-
- Typecheck (M-t) verifies typing, and memorizes it to let one see an
- expression's type by double-clicking on it. This is also valid for
- interfaces. If an error occurs, the part of the interface preceding
- the error is computed.
-
- After typechecking, pressing the right button pops up a menu giving
- the type of the pointed expression, and eventually allowing to
- follow some links.
-
- Clear errors dismisses type checker error messages and warnings.
-
- Signature shows the signature of the current file.
-
-4) Shell
-
- When you create a shell, a dialog is presented to you, letting you
- choose which command you want to run, and the title of the shell
- (to choose it in the Editor).
-
- You may change the default command by setting the OLABL environment
- variable.
-
- The executed subshell is given the current load path.
- File: use a source file or load a bytecode file.
- You may also import the browser's path into the subprocess.
- History: M-p and M-n browse up and down.
- Signal: C-c interrupts and you can kill the subprocess.
-
-BUGS
-
-* When you quit the editor and some file was modified, a dialogue is
- displayed asking wether you want to really quit or not. But 1) if
- you quit directly from the viewer, there is no dialogue at all, and
- 2) if you close from the window manager, the dialogue is displayed,
- but you cannot cancel the destruction... Beware.
-
-* When you run it through xon, the shell hangs at the first error. But
- its ok if you start ocamlbrowser from a remote shell...
-
-TODO
-
-* Complete cross-references.
-
-* Power up editor.
-
-* Add support for the debugger.
-
-* Make this a real programming environment, both for beginners an
- experimented users.
-
-
-Bug reports and comments to <garrigue@kurims.kyoto-u.ac.jp>
diff --git a/otherlibs/labltk/browser/jg_bind.ml b/otherlibs/labltk/browser/jg_bind.ml
deleted file mode 100644
index 128a88ae55..0000000000
--- a/otherlibs/labltk/browser/jg_bind.ml
+++ /dev/null
@@ -1,28 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open Tk
-
-let enter_focus w =
- bind w ~events:[`Enter] ~action:(fun _ -> Focus.set w)
-
-let escape_destroy ?destroy:tl w =
- let tl = match tl with Some w -> w | None -> w in
- bind w ~events:[`KeyPressDetail "Escape"] ~action:(fun _ -> destroy tl)
-
-let return_invoke w ~button =
- bind w ~events:[`KeyPressDetail "Return"]
- ~action:(fun _ -> Button.invoke button)
diff --git a/otherlibs/labltk/browser/jg_bind.mli b/otherlibs/labltk/browser/jg_bind.mli
deleted file mode 100644
index e09c2ba460..0000000000
--- a/otherlibs/labltk/browser/jg_bind.mli
+++ /dev/null
@@ -1,21 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open Widget
-
-val enter_focus : 'a widget -> unit
-val escape_destroy : ?destroy:'a widget -> 'a widget ->unit
-val return_invoke : 'a widget -> button:button widget -> unit
diff --git a/otherlibs/labltk/browser/jg_box.ml b/otherlibs/labltk/browser/jg_box.ml
deleted file mode 100644
index ac0cb82121..0000000000
--- a/otherlibs/labltk/browser/jg_box.ml
+++ /dev/null
@@ -1,82 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open Tk
-
-let add_scrollbar lb =
- let sb =
- Scrollbar.create (Winfo.parent lb) ~command:(Listbox.yview lb) in
- Listbox.configure lb ~yscrollcommand:(Scrollbar.set sb); sb
-
-let create_with_scrollbar ?selectmode parent =
- let frame = Frame.create parent in
- let lb = Listbox.create frame ?selectmode in
- frame, lb, add_scrollbar lb
-
-(* from frx_listbox,adapted *)
-
-let recenter lb ~index =
- Listbox.selection_clear lb ~first:(`Num 0) ~last:`End;
- (* Activate it, to keep consistent with Up/Down.
- You have to be in Extended or Browse mode *)
- Listbox.activate lb ~index;
- Listbox.selection_anchor lb ~index;
- Listbox.yview_index lb ~index
-
-class timed ?wait ?nocase get_texts = object
- val get_texts = get_texts
- inherit Jg_completion.timed [] ?wait ?nocase as super
- method reset =
- texts <- get_texts ();
- super#reset
-end
-
-let add_completion ?action ?wait ?nocase ?(double=true) lb =
- let comp =
- new timed ?wait ?nocase
- (fun () -> Listbox.get_range lb ~first:(`Num 0) ~last:`End) in
-
- Jg_bind.enter_focus lb;
-
- bind lb ~events:[`KeyPress] ~fields:[`Char] ~action:
- begin fun ev ->
- (* consider only keys producing characters. The callback is called
- even if you press Shift. *)
- if ev.ev_Char <> "" then
- recenter lb ~index:(`Num (comp#add ev.ev_Char))
- end;
-
- begin match action with
- Some action ->
- bind lb ~events:[`KeyPressDetail "Return"]
- ~action:(fun _ -> action `Active);
- let bmod = if double then [`Double] else [] in
- bind lb ~events:[`Modified(bmod, `ButtonPressDetail 1)]
- ~breakable:true ~fields:[`MouseY]
- ~action:
- begin fun ev ->
- let index = Listbox.nearest lb ~y:ev.ev_MouseY in
- if not double then begin
- Listbox.selection_clear lb ~first:(`Num 0) ~last:`End;
- Listbox.selection_set lb ~first:index ~last:index;
- end;
- action index;
- break ()
- end
- | None -> ()
- end;
-
- recenter lb ~index:(`Num 0) (* so that first item is active *)
diff --git a/otherlibs/labltk/browser/jg_button.ml b/otherlibs/labltk/browser/jg_button.ml
deleted file mode 100644
index 11abd68aba..0000000000
--- a/otherlibs/labltk/browser/jg_button.ml
+++ /dev/null
@@ -1,25 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open Tk
-
-let create_destroyer ~parent ?(text="Ok") tl =
- Button.create parent ~text ~command:(fun () -> destroy tl)
-
-let add_destroyer ?text tl =
- let b = create_destroyer tl ~parent:tl ?text in
- pack [b] ~side:`Bottom ~fill:`X;
- b
diff --git a/otherlibs/labltk/browser/jg_completion.ml b/otherlibs/labltk/browser/jg_completion.ml
deleted file mode 100644
index feb03c42f2..0000000000
--- a/otherlibs/labltk/browser/jg_completion.ml
+++ /dev/null
@@ -1,53 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-let lt_string ?(nocase=false) s1 s2 =
- if nocase then String.lowercase s1 < String.lowercase s2 else s1 < s2
-
-class completion ?nocase texts = object
- val mutable texts = texts
- val nocase = nocase
- val mutable prefix = ""
- val mutable current = 0
- method add c =
- prefix <- prefix ^ c;
- while current < List.length texts - 1 &&
- lt_string (List.nth texts current) prefix ?nocase
- do
- current <- current + 1
- done;
- current
- method current = current
- method get_current = List.nth texts current
- method reset =
- prefix <- "";
- current <- 0
-end
-
-class timed ?nocase ?wait texts = object (self)
- inherit completion texts ?nocase as super
- val wait = match wait with None -> 500 | Some n -> n
- val mutable timer = None
- method add c =
- begin match timer with
- None -> self#reset
- | Some t -> Timer.remove t
- end;
- timer <- Some (Timer.add ~ms:wait ~callback:(fun () -> self#reset));
- super#add c
- method reset =
- timer <- None; super#reset
-end
diff --git a/otherlibs/labltk/browser/jg_completion.mli b/otherlibs/labltk/browser/jg_completion.mli
deleted file mode 100644
index 69c7a134c2..0000000000
--- a/otherlibs/labltk/browser/jg_completion.mli
+++ /dev/null
@@ -1,25 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-val lt_string : ?nocase:bool -> string -> string -> bool
-
-class timed : ?nocase:bool -> ?wait:int -> string list -> object
- val mutable texts : string list
- method add : string -> int
- method current : int
- method get_current : string
- method reset : unit
-end
diff --git a/otherlibs/labltk/browser/jg_config.ml b/otherlibs/labltk/browser/jg_config.ml
deleted file mode 100644
index bce0e50e76..0000000000
--- a/otherlibs/labltk/browser/jg_config.ml
+++ /dev/null
@@ -1,40 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open StdLabels
-open Jg_tk
-
-let fixed = if wingui then "{Courier New} 8" else "fixed"
-let variable = if wingui then "Arial 9" else "variable"
-
-let init () =
- if wingui then Option.add ~path:"*font" fixed;
- let font =
- let font =
- Option.get Widget.default_toplevel ~name:"variableFont" ~clas:"Font" in
- if font = "" then variable else font
- in
- List.iter ["Button"; "Label"; "Menu"; "Menubutton"; "Radiobutton"]
- ~f:(fun cl -> Option.add ~path:("*" ^ cl ^ ".font") font);
- Option.add ~path:"*Menu.tearOff" "0" ~priority:`StartupFile;
- Option.add ~path:"*Button.padY" "0" ~priority:`StartupFile;
- Option.add ~path:"*Text.highlightThickness" "0" ~priority:`StartupFile;
- Option.add ~path:"*interface.background" "gray85" ~priority:`StartupFile;
- let foreground =
- Option.get Widget.default_toplevel
- ~name:"disabledForeground" ~clas:"Foreground" in
- if foreground = "" then
- Option.add ~path:"*disabledForeground" "black"
diff --git a/otherlibs/labltk/browser/jg_config.mli b/otherlibs/labltk/browser/jg_config.mli
deleted file mode 100644
index 511e2b3a67..0000000000
--- a/otherlibs/labltk/browser/jg_config.mli
+++ /dev/null
@@ -1,17 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-val init: unit -> unit
diff --git a/otherlibs/labltk/browser/jg_entry.ml b/otherlibs/labltk/browser/jg_entry.ml
deleted file mode 100644
index c09a273e82..0000000000
--- a/otherlibs/labltk/browser/jg_entry.ml
+++ /dev/null
@@ -1,27 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open Tk
-
-let create ?command ?width ?textvariable parent =
- let ew = Entry.create parent ?width ?textvariable in
- Jg_bind.enter_focus ew;
- begin match command with Some command ->
- bind ew ~events:[`KeyPressDetail "Return"]
- ~action:(fun _ -> command (Entry.get ew))
- | None -> ()
- end;
- ew
diff --git a/otherlibs/labltk/browser/jg_memo.ml b/otherlibs/labltk/browser/jg_memo.ml
deleted file mode 100644
index c6d7634ac6..0000000000
--- a/otherlibs/labltk/browser/jg_memo.ml
+++ /dev/null
@@ -1,35 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-type ('a, 'b) assoc_list =
- Nil
- | Cons of 'a * 'b * ('a, 'b) assoc_list
-
-let rec assq key = function
- Nil -> raise Not_found
- | Cons (a, b, l) ->
- if key == a then b else assq key l
-
-let fast ~f =
- let memo = ref Nil in
- fun key ->
- try assq key !memo
- with Not_found ->
- let data = f key in
- memo := Cons(key, data, !memo);
- data
-
-
diff --git a/otherlibs/labltk/browser/jg_memo.mli b/otherlibs/labltk/browser/jg_memo.mli
deleted file mode 100644
index 5491dee32f..0000000000
--- a/otherlibs/labltk/browser/jg_memo.mli
+++ /dev/null
@@ -1,19 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-val fast : f:('a -> 'b) -> 'a -> 'b
-(* "fast" memoizer: uses a List.assq like function *)
-(* Good for a smallish number of keys, phisically equal *)
diff --git a/otherlibs/labltk/browser/jg_menu.ml b/otherlibs/labltk/browser/jg_menu.ml
deleted file mode 100644
index 62712f36db..0000000000
--- a/otherlibs/labltk/browser/jg_menu.ml
+++ /dev/null
@@ -1,42 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open Tk
-
-class c ~parent ?underline:(n=0) text = object (self)
- val pair =
- let button =
- Menubutton.create parent ~text ~underline:n in
- let menu = Menu.create button in
- Menubutton.configure button ~menu;
- button, menu
- method button = fst pair
- method menu = snd pair
- method virtual add_command :
- ?underline:int ->
- ?accelerator:string -> ?activebackground:color ->
- ?activeforeground:color -> ?background:color ->
- ?bitmap:bitmap -> ?command:(unit -> unit) ->
- ?font:string -> ?foreground:color ->
- ?image:image -> ?state:state ->
- string -> unit
- method add_command ?underline:(n=0) ?accelerator ?activebackground
- ?activeforeground ?background ?bitmap ?command ?font ?foreground
- ?image ?state label =
- Menu.add_command (self#menu) ~label ~underline:n ?accelerator
- ?activebackground ?activeforeground ?background ?bitmap
- ?command ?font ?foreground ?image ?state
-end
diff --git a/otherlibs/labltk/browser/jg_message.ml b/otherlibs/labltk/browser/jg_message.ml
deleted file mode 100644
index 811c52b15b..0000000000
--- a/otherlibs/labltk/browser/jg_message.ml
+++ /dev/null
@@ -1,111 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open StdLabels
-open Tk
-open Jg_tk
-
-(*
-class formatted ~parent ~width ~maxheight ~minheight =
- val parent = (parent : Widget.any Widget.widget)
- val width = width
- val maxheight = maxheight
- val minheight = minheight
- val tw = Text.create ~parent ~width ~wrap:`Word
- val fof = Format.get_formatter_output_functions ()
- method parent = parent
- method init =
- pack [tw] ~side:`Left ~fill:`Both ~expand:true;
- Format.print_flush ();
- Format.set_margin (width - 2);
- Format.set_formatter_output_functions ~out:(Jg_text.output tw)
- ~flush:(fun () -> ())
- method finish =
- Format.print_flush ();
- Format.set_formatter_output_functions ~out:(fst fof) ~flush:(snd fof);
- let `Linechar (l, _) = Text.index tw ~index:(tposend 1) in
- Text.configure tw ~height:(max minheight (min l maxheight));
- if l > 5 then
- pack [Jg_text.add_scrollbar tw] ~before:tw ~side:`Right ~fill:`Y
-end
-*)
-
-let formatted ~title ?on ?(ppf = Format.std_formatter)
- ?(width=60) ?(maxheight=10) ?(minheight=0) () =
- let tl, frame =
- match on with
- Some frame ->
-(* let label = Label.create frame ~anchor:`W ~padx:10 ~text:title in
- pack [label] ~side:`Top ~fill:`X;
- let frame2 = Frame.create frame in
- pack [frame2] ~side:`Bottom ~fill:`Both ~expand:true; *)
- coe frame, frame
- | None ->
- let tl = Jg_toplevel.titled title in
- Jg_bind.escape_destroy tl;
- let frame = Frame.create tl in
- pack [frame] ~side:`Top ~fill:`Both ~expand:true;
- coe tl, frame
- in
- let tw = Text.create frame ~width ~wrap:`Word in
- pack [tw] ~side:`Left ~fill:`Both ~expand:true;
- Format.pp_print_flush ppf ();
- Format.pp_set_margin ppf (width - 2);
- let fof,fff = Format.pp_get_formatter_output_functions ppf () in
- Format.pp_set_formatter_output_functions ppf
- (fun buf pos len -> Jg_text.output tw ~buf ~pos ~len)
- ignore;
- tl, tw,
- begin fun () ->
- Format.pp_print_flush ppf ();
- Format.pp_set_formatter_output_functions ppf fof fff;
- let `Linechar (l, _) = Text.index tw ~index:(tposend 1) in
- Text.configure tw ~height:(max minheight (min l maxheight));
- if l > 5 then
- pack [Jg_text.add_scrollbar tw] ~before:tw ~side:`Right ~fill:`Y
- end
-
-let ask ~title ?master ?(no=true) ?(cancel=true) text =
- let tl = Jg_toplevel.titled title in
- begin match master with None -> ()
- | Some master -> Wm.transient_set tl ~master
- end;
- let mw = Message.create tl ~text ~padx:20 ~pady:10
- ~width:250 ~justify:`Left ~aspect:400 ~anchor:`W
- and fw = Frame.create tl
- and sync = Textvariable.create ~on:tl ()
- and r = ref (`Cancel : [`Yes|`No|`Cancel]) in
- let accept = Button.create fw
- ~text:(if no || cancel then "Yes" else "Dismiss")
- ~command:(fun () -> r := `Yes; destroy tl)
- and refuse = Button.create fw ~text:"No"
- ~command:(fun () -> r := `No; destroy tl)
- and cancelB = Button.create fw ~text:"Cancel"
- ~command:(fun () -> r := `Cancel; destroy tl)
- in
- bind tl ~events:[`Destroy] ~extend:true
- ~action:(fun _ -> Textvariable.set sync "1");
- pack [accept] ~side:`Left ~fill:`X ~expand:true;
- if no then pack [refuse] ~side:`Left ~fill:`X ~expand:true;
- if cancel then pack [cancelB] ~side:`Left ~fill:`X ~expand:true;
- pack [mw] ~side:`Top ~fill:`Both;
- pack [fw] ~side:`Bottom ~fill:`X ~expand:true;
- Grab.set tl;
- Tkwait.variable sync;
- !r
-
-let info ~title ?master text =
- ignore (ask ~title ?master ~no:false ~cancel:false text)
diff --git a/otherlibs/labltk/browser/jg_message.mli b/otherlibs/labltk/browser/jg_message.mli
deleted file mode 100644
index 0a83a594ff..0000000000
--- a/otherlibs/labltk/browser/jg_message.mli
+++ /dev/null
@@ -1,33 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open Widget
-
-val formatted :
- title:string ->
- ?on:frame widget ->
- ?ppf:Format.formatter ->
- ?width:int ->
- ?maxheight:int ->
- ?minheight:int ->
- unit -> any widget * text widget * (unit -> unit)
-
-val ask :
- title:string -> ?master:toplevel widget ->
- ?no:bool -> ?cancel:bool -> string -> [`Cancel|`No|`Yes]
-
-val info :
- title:string -> ?master:toplevel widget -> string -> unit
diff --git a/otherlibs/labltk/browser/jg_multibox.ml b/otherlibs/labltk/browser/jg_multibox.ml
deleted file mode 100644
index dc905aba6c..0000000000
--- a/otherlibs/labltk/browser/jg_multibox.ml
+++ /dev/null
@@ -1,185 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open StdLabels
-
-let rec gen_list ~f:f ~len =
- if len = 0 then [] else f () :: gen_list ~f:f ~len:(len - 1)
-
-let rec make_list ~len ~fill =
- if len = 0 then [] else fill :: make_list ~len:(len - 1) ~fill
-
-(* By column version
-let rec firsts ~len l =
- if len = 0 then ([],l) else
- match l with
- a::l ->
- let (f,l) = firsts l len:(len - 1) in
- (a::f,l)
- | [] ->
- (l,[])
-
-let rec split ~len = function
- [] -> []
- | l ->
- let (f,r) = firsts l ~len in
- let ret = split ~len r in
- f :: ret
-
-let extend l ~len ~fill =
- if List.length l >= len then l
- else l @ make_list ~fill len:(len - List.length l)
-*)
-
-(* By row version *)
-
-let rec first l ~len =
- if len = 0 then [], l else
- match l with
- [] -> make_list ~len ~fill:"", []
- | a::l ->
- let (l',r) = first ~len:(len - 1) l in a::l',r
-
-let rec split l ~len =
- if l = [] then make_list ~len ~fill:[] else
- let (cars,r) = first l ~len in
- let cdrs = split r ~len in
- List.map2 cars cdrs ~f:(fun a l -> a::l)
-
-
-open Tk
-
-class c ~cols ~texts ?maxheight ?width parent = object (self)
- val parent' = coe parent
- val length = List.length texts
- val boxes =
- let height = (List.length texts - 1) / cols + 1 in
- let height =
- match maxheight with None -> height
- | Some max -> min max height
- in
- gen_list ~len:cols ~f:
- begin fun () ->
- Listbox.create parent ~height ?width
- ~highlightthickness:0
- ~borderwidth:1
- end
- val mutable current = 0
- method cols = cols
- method texts = texts
- method parent = parent'
- method boxes = boxes
- method current = current
- method recenter ?(aligntop=false) n =
- current <-
- if n < 0 then 0 else
- if n < length then n else length - 1;
- (* Activate it, to keep consistent with Up/Down.
- You have to be in Extended or Browse mode *)
- let box = List.nth boxes (current mod cols)
- and index = `Num (current / cols) in
- List.iter boxes ~f:
- begin fun box ->
- Listbox.selection_clear box ~first:(`Num 0) ~last:`End;
- Listbox.selection_anchor box ~index;
- Listbox.activate box ~index
- end;
- Focus.set box;
- if aligntop then Listbox.yview_index box ~index
- else Listbox.see box ~index;
- let (first,last) = Listbox.yview_get box in
- List.iter boxes ~f:(Listbox.yview ~scroll:(`Moveto first))
- method init =
- let textl = split ~len:cols texts in
- List.iter2 boxes textl ~f:
- begin fun box texts ->
- Jg_bind.enter_focus box;
- Listbox.insert box ~texts ~index:`End
- end;
- pack boxes ~side:`Left ~expand:true ~fill:`Both;
- self#bind_mouse ~events:[`ButtonPressDetail 1]
- ~action:(fun _ ~index:n -> self#recenter n; break ());
- let current_height () =
- let (top,bottom) = Listbox.yview_get (List.hd boxes) in
- truncate ((bottom -. top) *. float (Listbox.size (List.hd boxes))
- +. 0.99)
- in
- List.iter
- [ "Right", (fun n -> n+1);
- "Left", (fun n -> n-1);
- "Up", (fun n -> n-cols);
- "Down", (fun n -> n+cols);
- "Prior", (fun n -> n - current_height () * cols);
- "Next", (fun n -> n + current_height () * cols);
- "Home", (fun _ -> 0);
- "End", (fun _ -> List.length texts) ]
- ~f:begin fun (key,f) ->
- self#bind_kbd ~events:[`KeyPressDetail key]
- ~action:(fun _ ~index:n -> self#recenter (f n); break ())
- end;
- self#recenter 0
- method bind_mouse ~events ~action =
- let i = ref 0 in
- List.iter boxes ~f:
- begin fun box ->
- let b = !i in
- bind box ~events ~breakable:true ~fields:[`MouseX;`MouseY]
- ~action:(fun ev ->
- let `Num n = Listbox.nearest box ~y:ev.ev_MouseY
- in action ev ~index:(n * cols + b));
- incr i
- end
- method bind_kbd ~events ~action =
- let i = ref 0 in
- List.iter boxes ~f:
- begin fun box ->
- let b = !i in
- bind box ~events ~breakable:true ~fields:[`Char]
- ~action:(fun ev ->
- let `Num n = Listbox.index box ~index:`Active in
- action ev ~index:(n * cols + b));
- incr i
- end
-end
-
-let add_scrollbar (box : c) =
- let boxes = box#boxes in
- let sb =
- Scrollbar.create (box#parent)
- ~command:(fun ~scroll -> List.iter boxes ~f:(Listbox.yview ~scroll)) in
- List.iter boxes
- ~f:(fun lb -> Listbox.configure lb ~yscrollcommand:(Scrollbar.set sb));
- pack [sb] ~before:(List.hd boxes) ~side:`Right ~fill:`Y;
- sb
-
-let add_completion ?action ?wait (box : c) =
- let comp = new Jg_completion.timed (box#texts) ?wait in
- box#bind_kbd ~events:[`KeyPress]
- ~action:(fun ev ~index ->
- (* consider only keys producing characters. The callback is called
- * even if you press Shift. *)
- if ev.ev_Char <> "" then
- box#recenter (comp#add ev.ev_Char) ~aligntop:true);
- match action with
- Some action ->
- box#bind_kbd ~events:[`KeyPressDetail "space"]
- ~action:(fun ev ~index -> action (box#current));
- box#bind_kbd ~events:[`KeyPressDetail "Return"]
- ~action:(fun ev ~index -> action (box#current));
- box#bind_mouse ~events:[`ButtonPressDetail 1]
- ~action:(fun ev ~index ->
- box#recenter index; action (box#current); break ())
- | None -> ()
diff --git a/otherlibs/labltk/browser/jg_multibox.mli b/otherlibs/labltk/browser/jg_multibox.mli
deleted file mode 100644
index 6dfe7d8fb3..0000000000
--- a/otherlibs/labltk/browser/jg_multibox.mli
+++ /dev/null
@@ -1,35 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-class c :
- cols:int -> texts:string list ->
- ?maxheight:int -> ?width:int -> 'a Widget.widget ->
-object
- method cols : int
- method texts : string list
- method parent : Widget.any Widget.widget
- method boxes : Widget.listbox Widget.widget list
- method current : int
- method init : unit
- method recenter : ?aligntop:bool -> int -> unit
- method bind_mouse :
- events:Tk.event list -> action:(Tk.eventInfo -> index:int -> unit) -> unit
- method bind_kbd :
- events:Tk.event list -> action:(Tk.eventInfo -> index:int -> unit) -> unit
-end
-
-val add_scrollbar : c -> Widget.scrollbar Widget.widget
-val add_completion : ?action:(int -> unit) -> ?wait:int -> c -> unit
diff --git a/otherlibs/labltk/browser/jg_text.ml b/otherlibs/labltk/browser/jg_text.ml
deleted file mode 100644
index 067b9dac55..0000000000
--- a/otherlibs/labltk/browser/jg_text.ml
+++ /dev/null
@@ -1,104 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open StdLabels
-open Tk
-open Jg_tk
-
-let get_all tw = Text.get tw ~start:tstart ~stop:(tposend 1)
-
-let tag_and_see tw ~tag ~start ~stop =
- Text.tag_remove tw ~start:(tpos 0) ~stop:tend ~tag;
- Text.tag_add tw ~start ~stop ~tag;
- try
- Text.see tw ~index:(`Tagfirst tag, []);
- Text.mark_set tw ~mark:"insert" ~index:(`Tagfirst tag, [])
- with Protocol.TkError _ -> ()
-
-let output tw ~buf ~pos ~len =
- Text.insert tw ~index:tend ~text:(String.sub buf ~pos ~len)
-
-let add_scrollbar tw =
- let sb = Scrollbar.create (Winfo.parent tw) ~command:(Text.yview tw)
- in Text.configure tw ~yscrollcommand:(Scrollbar.set sb); sb
-
-let create_with_scrollbar parent =
- let frame = Frame.create parent in
- let tw = Text.create frame in
- frame, tw, add_scrollbar tw
-
-let goto_tag tw ~tag =
- let index = (`Tagfirst tag, []) in
- try Text.see tw ~index;
- Text.mark_set tw ~index ~mark:"insert"
- with Protocol.TkError _ -> ()
-
-let search_string tw =
- let tl = Jg_toplevel.titled "Search" in
- Wm.transient_set tl ~master:(Winfo.toplevel tw);
- let fi = Frame.create tl
- and fd = Frame.create tl
- and fm = Frame.create tl
- and buttons = Frame.create tl
- and direction = Textvariable.create ~on:tl ()
- and mode = Textvariable.create ~on:tl ()
- and count = Textvariable.create ~on:tl ()
- in
- let label = Label.create fi ~text:"Pattern:"
- and text = Entry.create fi ~width:20
- and back = Radiobutton.create fd ~variable:direction
- ~text:"Backwards" ~value:"backward"
- and forw = Radiobutton.create fd ~variable:direction
- ~text:"Forwards" ~value:"forward"
- and exact = Radiobutton.create fm ~variable:mode
- ~text:"Exact" ~value:"exact"
- and nocase = Radiobutton.create fm ~variable:mode
- ~text:"No case" ~value:"nocase"
- and regexp = Radiobutton.create fm ~variable:mode
- ~text:"Regexp" ~value:"regexp"
- in
- let search = Button.create buttons ~text:"Search" ~command:
- begin fun () ->
- try
- let pattern = Entry.get text in
- let dir, ofs = match Textvariable.get direction with
- "forward" -> `Forwards, 1
- | "backward" -> `Backwards, -1
- | _ -> assert false
- and mode = match Textvariable.get mode with "exact" -> [`Exact]
- | "nocase" -> [`Nocase] | "regexp" -> [`Regexp] | _ -> []
- in
- let ndx =
- Text.search tw ~pattern ~switches:([dir;`Count count] @ mode)
- ~start:(`Mark "insert", [`Char ofs])
- in
- tag_and_see tw ~tag:"sel" ~start:(ndx,[])
- ~stop:(ndx,[`Char(int_of_string (Textvariable.get count))])
- with Invalid_argument _ -> ()
- end
- and ok = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" in
-
- Focus.set text;
- Jg_bind.return_invoke text ~button:search;
- Jg_bind.escape_destroy tl;
- Textvariable.set direction "forward";
- Textvariable.set mode "nocase";
- pack [label] ~side:`Left;
- pack [text] ~side:`Right ~fill:`X ~expand:true;
- pack [back; forw] ~side:`Left;
- pack [exact; nocase; regexp] ~side:`Left;
- pack [search; ok] ~side:`Left ~fill:`X ~expand:true;
- pack [fi; fd; fm; buttons] ~side:`Top ~fill:`X
diff --git a/otherlibs/labltk/browser/jg_text.mli b/otherlibs/labltk/browser/jg_text.mli
deleted file mode 100644
index e8646dd9d1..0000000000
--- a/otherlibs/labltk/browser/jg_text.mli
+++ /dev/null
@@ -1,28 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open Widget
-
-val get_all : text widget -> string
-val tag_and_see :
- text widget ->
- tag:Tk.textTag -> start:Tk.textIndex -> stop:Tk.textIndex -> unit
-val output : text widget -> buf:string -> pos:int -> len:int -> unit
-val add_scrollbar : text widget -> scrollbar widget
-val create_with_scrollbar :
- 'a widget -> frame widget * text widget * scrollbar widget
-val goto_tag : text widget -> tag:string -> unit
-val search_string : text widget -> unit
diff --git a/otherlibs/labltk/browser/jg_tk.ml b/otherlibs/labltk/browser/jg_tk.ml
deleted file mode 100644
index 7fc77f096a..0000000000
--- a/otherlibs/labltk/browser/jg_tk.ml
+++ /dev/null
@@ -1,24 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open Tk
-
-let tpos ?(modi=[]) x : textIndex = `Linechar (1,0), `Char x :: modi
-and tposend ?(modi=[]) x : textIndex = `End, `Char (-x) :: modi
-let tstart : textIndex = `Linechar (1,0), []
-and tend : textIndex = `End, []
-
-let wingui = Sys.os_type = "Win32" || Sys.os_type = "Cygwin"
diff --git a/otherlibs/labltk/browser/jg_toplevel.ml b/otherlibs/labltk/browser/jg_toplevel.ml
deleted file mode 100644
index c6a2b89593..0000000000
--- a/otherlibs/labltk/browser/jg_toplevel.ml
+++ /dev/null
@@ -1,25 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open Tk
-
-let titled ?iconname title =
- let iconname = match iconname with None -> title | Some s -> s in
- let tl = Toplevel.create Widget.default_toplevel in
- Wm.title_set tl title;
- Wm.iconname_set tl iconname;
- Wm.group_set tl ~leader: Widget.default_toplevel;
- tl
diff --git a/otherlibs/labltk/browser/lexical.ml b/otherlibs/labltk/browser/lexical.ml
deleted file mode 100644
index a2573ef7c2..0000000000
--- a/otherlibs/labltk/browser/lexical.ml
+++ /dev/null
@@ -1,143 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open StdLabels
-open Tk
-open Jg_tk
-open Parser
-
-let tags =
- ["control"; "define"; "structure"; "char";
- "infix"; "label"; "uident"]
-and colors =
- ["blue"; "forestgreen"; "purple"; "gray40";
- "indianred4"; "saddlebrown"; "midnightblue"]
-
-let init_tags tw =
- List.iter2 tags colors ~f:
- begin fun tag col ->
- Text.tag_configure tw ~tag ~foreground:(`Color col)
- end;
- Text.tag_configure tw ~tag:"error" ~foreground:`Red;
- Text.tag_configure tw ~tag:"error" ~relief:`Raised;
- Text.tag_raise tw ~tag:"error"
-
-let tag ?(start=tstart) ?(stop=tend) tw =
- let tpos c = (Text.index tw ~index:start, [`Char c]) in
- let text = Text.get tw ~start ~stop in
- let buffer = Lexing.from_string text in
- List.iter tags
- ~f:(fun tag -> Text.tag_remove tw ~start ~stop ~tag);
- let last = ref (EOF, 0, 0) in
- try
- while true do
- let token = Lexer.token buffer
- and start = Lexing.lexeme_start buffer
- and stop = Lexing.lexeme_end buffer in
- let tag =
- match token with
- AMPERAMPER
- | AMPERSAND
- | BARBAR
- | DO | DONE
- | DOWNTO
- | ELSE
- | FOR
- | IF
- | LAZY
- | MATCH
- | OR
- | THEN
- | TO
- | TRY
- | WHEN
- | WHILE
- | WITH
- -> "control"
- | AND
- | AS
- | BAR
- | CLASS
- | CONSTRAINT
- | EXCEPTION
- | EXTERNAL
- | FUN
- | FUNCTION
- | FUNCTOR
- | IN
- | INHERIT
- | INITIALIZER
- | LET
- | METHOD
- | MODULE
- | MUTABLE
- | NEW
- | OF
- | PRIVATE
- | REC
- | TYPE
- | VAL
- | VIRTUAL
- -> "define"
- | BEGIN
- | END
- | INCLUDE
- | OBJECT
- | OPEN
- | SIG
- | STRUCT
- -> "structure"
- | CHAR _
- | STRING _
- -> "char"
- | BACKQUOTE
- | INFIXOP1 _
- | INFIXOP2 _
- | INFIXOP3 _
- | INFIXOP4 _
- | PREFIXOP _
- | SHARP
- -> "infix"
- | LABEL _
- | OPTLABEL _
- | QUESTION
- | TILDE
- -> "label"
- | UIDENT _ -> "uident"
- | LIDENT _ ->
- begin match !last with
- (QUESTION | TILDE), _, _ -> "label"
- | _ -> ""
- end
- | COLON ->
- begin match !last with
- LIDENT _, lstart, lstop ->
- if lstop = start then
- Text.tag_add tw ~tag:"label"
- ~start:(tpos lstart) ~stop:(tpos stop);
- ""
- | _ -> ""
- end
- | EOF -> raise End_of_file
- | _ -> ""
- in
- if tag <> "" then
- Text.tag_add tw ~tag ~start:(tpos start) ~stop:(tpos stop);
- last := (token, start, stop)
- done
- with
- End_of_file -> ()
- | Lexer.Error (err, loc) -> ()
diff --git a/otherlibs/labltk/browser/lexical.mli b/otherlibs/labltk/browser/lexical.mli
deleted file mode 100644
index 3be04d3246..0000000000
--- a/otherlibs/labltk/browser/lexical.mli
+++ /dev/null
@@ -1,20 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open Widget
-
-val init_tags : text widget -> unit
-val tag : ?start:Tk.textIndex -> ?stop:Tk.textIndex -> text widget -> unit
diff --git a/otherlibs/labltk/browser/list2.ml b/otherlibs/labltk/browser/list2.ml
deleted file mode 100644
index 87b88f496a..0000000000
--- a/otherlibs/labltk/browser/list2.ml
+++ /dev/null
@@ -1,23 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open StdLabels
-
-let exclude x l = List.filter l ~f:((<>) x)
-
-let rec flat_map ~f = function
- [] -> []
- | x :: l -> f x @ flat_map ~f l
diff --git a/otherlibs/labltk/browser/main.ml b/otherlibs/labltk/browser/main.ml
deleted file mode 100644
index 2ff17a5519..0000000000
--- a/otherlibs/labltk/browser/main.ml
+++ /dev/null
@@ -1,132 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open StdLabels
-module Unix = UnixLabels
-open Tk
-
-let fatal_error text =
- let top = openTk ~clas:"OCamlBrowser" () in
- let mw = Message.create top ~text ~padx:20 ~pady:10
- ~width:400 ~justify:`Left ~aspect:400 ~anchor:`W
- and b = Button.create top ~text:"OK" ~command:(fun () -> destroy top) in
- pack [mw] ~side:`Top ~fill:`Both;
- pack [b] ~side:`Bottom;
- mainLoop ();
- exit 0
-
-let rec get_incr key = function
- [] -> raise Not_found
- | (k, c, d) :: rem ->
- if k = key then
- match c with Arg.Set _ | Arg.Clear _ -> false | _ -> true
- else get_incr key rem
-
-let check ~spec argv =
- let i = ref 1 in
- while !i < Array.length argv do
- try
- let a = get_incr argv.(!i) spec in
- incr i; if a then incr i
- with Not_found ->
- i := Array.length argv + 1
- done;
- !i = Array.length argv
-
-open Printf
-
-let usage ~spec errmsg =
- let b = Buffer.create 1024 in
- bprintf b "%s\n" errmsg;
- List.iter (function (key, _, doc) -> bprintf b " %s %s\n" key doc) spec;
- Buffer.contents b
-
-let _ =
- let is_win32 = Sys.os_type = "Win32" in
- if is_win32 then
- Format.pp_set_formatter_output_functions Format.err_formatter
- (fun _ _ _ -> ()) (fun _ -> ());
-
- let path = ref [] in
- let st = ref true in
- let spec =
- [ "-I", Arg.String (fun s -> path := s :: !path),
- "<dir> Add <dir> to the list of include directories";
- "-labels", Arg.Clear Clflags.classic, " <obsolete>";
- "-nolabels", Arg.Set Clflags.classic,
- " Ignore non-optional labels in types";
- "-pp", Arg.String (fun s -> Clflags.preprocessor := Some s),
- "<command> Pipe sources through preprocessor <command>";
- "-rectypes", Arg.Set Clflags.recursive_types,
- " Allow arbitrary recursive types";
- "-oldui", Arg.Clear st, " Revert back to old UI";
- "-w", Arg.String (fun s -> Shell.warnings := s),
- "<flags> Enable or disable warnings according to <flags>:\n\
- \032 A/a enable/disable all warnings\n\
- \032 C/c enable/disable suspicious comment\n\
- \032 D/d enable/disable deprecated features\n\
- \032 E/e enable/disable fragile match\n\
- \032 F/f enable/disable partially applied function\n\
- \032 L/l enable/disable labels omitted in application\n\
- \032 M/m enable/disable overriden method\n\
- \032 P/p enable/disable partial match\n\
- \032 S/s enable/disable non-unit statement\n\
- \032 U/u enable/disable unused match case\n\
- \032 V/v enable/disable hidden instance variable\n\
- \032 X/x enable/disable all other warnings\n\
- \032 default setting is \"Ale\"\n\
- \032 (all warnings but labels and fragile match enabled)"; ]
- and errmsg = "Command line: ocamlbrowser <options>" in
- if not (check ~spec Sys.argv) then fatal_error (usage ~spec errmsg);
- Arg.parse spec
- (fun name -> raise(Arg.Bad("don't know what to do with " ^ name)))
- errmsg;
- Config.load_path :=
- Sys.getcwd ()
- :: List.rev_map ~f:(Misc.expand_directory Config.standard_library) !path
- @ [Config.standard_library];
- Warnings.parse_options false !Shell.warnings;
- Unix.putenv "TERM" "noterminal";
- begin
- try Searchid.start_env := Env.open_pers_signature "Pervasives" Env.initial
- with _ ->
- fatal_error
- (Printf.sprintf "%s\nPlease check that %s %s\nCurrent value is `%s'"
- "Couldn't initialize environment."
- (if is_win32 then "%OCAMLLIB%" else "$OCAMLLIB")
- "points to the Objective Caml library."
- Config.standard_library)
- end;
-
- Searchpos.view_defined_ref := (fun s ~env -> Viewer.view_defined s ~env);
- Searchpos.editor_ref := Editor.f;
-
- let top = openTk ~clas:"OCamlBrowser" () in
- Jg_config.init ();
-
- (* bind top ~events:[`Destroy] ~action:(fun _ -> exit 0); *)
- at_exit Shell.kill_all;
-
-
- if !st then Viewer.st_viewer ~on:top ()
- else Viewer.f ~on:top ();
-
- while true do
- try
- if is_win32 then mainLoop ()
- else Printexc.print mainLoop ()
- with Protocol.TkError _ -> ()
- done
diff --git a/otherlibs/labltk/browser/mytypes.mli b/otherlibs/labltk/browser/mytypes.mli
deleted file mode 100644
index 6703ff1019..0000000000
--- a/otherlibs/labltk/browser/mytypes.mli
+++ /dev/null
@@ -1,29 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open Widget
-
-type edit_window =
- { mutable name: string;
- tw: text widget;
- frame: frame widget;
- modified: Textvariable.textVariable;
- mutable shell: (string * Shell.shell) option;
- mutable structure: Typedtree.structure;
- mutable type_info: Stypes.type_info list;
- mutable signature: Types.signature;
- mutable psignature: Parsetree.signature;
- number: string }
diff --git a/otherlibs/labltk/browser/searchid.ml b/otherlibs/labltk/browser/searchid.ml
deleted file mode 100644
index c285dbbced..0000000000
--- a/otherlibs/labltk/browser/searchid.ml
+++ /dev/null
@@ -1,532 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open StdLabels
-open Location
-open Longident
-open Path
-open Types
-open Typedtree
-open Env
-open Btype
-open Ctype
-
-(* only initial here, but replaced by Pervasives later *)
-let start_env = ref initial
-let module_list = ref []
-
-type pkind =
- Pvalue
- | Ptype
- | Plabel
- | Pconstructor
- | Pmodule
- | Pmodtype
- | Pclass
- | Pcltype
-
-let string_of_kind = function
- Pvalue -> "v"
- | Ptype -> "t"
- | Plabel -> "l"
- | Pconstructor -> "cn"
- | Pmodule -> "m"
- | Pmodtype -> "s"
- | Pclass -> "c"
- | Pcltype -> "ct"
-
-let rec longident_of_path = function
- Pident id -> Lident (Ident.name id)
- | Pdot (path, s, _) -> Ldot (longident_of_path path, s)
- | Papply (p1, p2) -> Lapply (longident_of_path p1, longident_of_path p2)
-
-let rec remove_prefix lid ~prefix =
- let rec remove_hd lid ~name =
- match lid with
- Ldot (Lident s1, s2) when s1 = name -> Lident s2
- | Ldot (l, s) -> Ldot (remove_hd ~name l, s)
- | _ -> raise Not_found
- in
- match prefix with
- [] -> lid
- | name :: prefix ->
- try remove_prefix ~prefix (remove_hd ~name lid)
- with Not_found -> lid
-
-let rec permutations l = match l with
- [] | [_] -> [l]
- | [a;b] -> [l; [b;a]]
- | _ ->
- let _, perms =
- List.fold_left l ~init:(l,[]) ~f:
- begin fun (l, perms) a ->
- let l = List.tl l in
- l @ [a],
- List.map (permutations l) ~f:(fun l -> a :: l) @ perms
- end
- in perms
-
-let rec choose n ~card:l =
- let len = List.length l in
- if n = len then [l] else
- if n = 1 then List.map l ~f:(fun x -> [x]) else
- if n = 0 then [[]] else
- if n > len then [] else
- match l with [] -> []
- | a :: l ->
- List.map (choose (n-1) ~card:l) ~f:(fun l -> a :: l)
- @ choose n ~card:l
-
-let rec arr p ~card:n =
- if p = 0 then 1 else n * arr (p-1) ~card:(n-1)
-
-let rec all_args ty =
- let ty = repr ty in
- match ty.desc with
- Tarrow(l, ty1, ty2, _) -> let (tl,ty) = all_args ty2 in ((l,ty1)::tl, ty)
- | _ -> ([], ty)
-
-let rec equal ~prefix t1 t2 =
- match (repr t1).desc, (repr t2).desc with
- Tvar, Tvar -> true
- | Tvariant row1, Tvariant row2 ->
- let row1 = row_repr row1 and row2 = row_repr row2 in
- let fields1 = filter_row_fields false row1.row_fields
- and fields2 = filter_row_fields false row1.row_fields
- in
- let r1, r2, pairs = merge_row_fields fields1 fields2 in
- row1.row_closed = row2.row_closed && r1 = [] && r2 = [] &&
- List.for_all pairs ~f:
- begin fun (_,f1,f2) ->
- match row_field_repr f1, row_field_repr f2 with
- Rpresent None, Rpresent None -> true
- | Rpresent(Some t1), Rpresent (Some t2) -> equal t1 t2 ~prefix
- | Reither(c1, tl1, _, _), Reither(c2, tl2, _, _) ->
- c1 = c2 && List.length tl1 = List.length tl2 &&
- List.for_all2 tl1 tl2 ~f:(equal ~prefix)
- | _ -> false
- end
- | Tarrow _, Tarrow _ ->
- let l1, t1 = all_args t1 and l2, t2 = all_args t2 in
- equal t1 t2 ~prefix &&
- List.length l1 = List.length l2 &&
- List.exists (permutations l1) ~f:
- begin fun l1 ->
- List.for_all2 l1 l2 ~f:
- begin fun (p1,t1) (p2,t2) ->
- (p1 = "" || p1 = p2) && equal t1 t2 ~prefix
- end
- end
- | Ttuple l1, Ttuple l2 ->
- List.length l1 = List.length l2 &&
- List.for_all2 l1 l2 ~f:(equal ~prefix)
- | Tconstr (p1, l1, _), Tconstr (p2, l2, _) ->
- remove_prefix ~prefix (longident_of_path p1) = (longident_of_path p2)
- && List.length l1 = List.length l2
- && List.for_all2 l1 l2 ~f:(equal ~prefix)
- | _ -> false
-
-let is_opt s = s <> "" && s.[0] = '?'
-let get_options = List.filter ~f:is_opt
-
-let rec included ~prefix t1 t2 =
- match (repr t1).desc, (repr t2).desc with
- Tvar, _ -> true
- | Tvariant row1, Tvariant row2 ->
- let row1 = row_repr row1 and row2 = row_repr row2 in
- let fields1 = filter_row_fields false row1.row_fields
- and fields2 = filter_row_fields false row1.row_fields
- in
- let r1, r2, pairs = merge_row_fields fields1 fields2 in
- r1 = [] &&
- List.for_all pairs ~f:
- begin fun (_,f1,f2) ->
- match row_field_repr f1, row_field_repr f2 with
- Rpresent None, Rpresent None -> true
- | Rpresent(Some t1), Rpresent (Some t2) -> included t1 t2 ~prefix
- | Reither(c1, tl1, _, _), Reither(c2, tl2, _, _) ->
- c1 = c2 && List.length tl1 = List.length tl2 &&
- List.for_all2 tl1 tl2 ~f:(included ~prefix)
- | _ -> false
- end
- | Tarrow _, Tarrow _ ->
- let l1, t1 = all_args t1 and l2, t2 = all_args t2 in
- included t1 t2 ~prefix &&
- let len1 = List.length l1 and len2 = List.length l2 in
- let l2 = if arr len1 ~card:len2 < 100 then l2 else
- let ll1 = get_options (fst (List.split l1)) in
- List.filter l2
- ~f:(fun (l,_) -> not (is_opt l) || List.mem l ll1)
- in
- len1 <= len2 &&
- List.exists (List2.flat_map ~f:permutations (choose len1 ~card:l2)) ~f:
- begin fun l2 ->
- List.for_all2 l1 l2 ~f:
- begin fun (p1,t1) (p2,t2) ->
- (p1 = "" || p1 = p2) && included t1 t2 ~prefix
- end
- end
- | Ttuple l1, Ttuple l2 ->
- let len1 = List.length l1 in
- len1 <= List.length l2 &&
- List.exists (List2.flat_map ~f:permutations (choose len1 ~card:l2)) ~f:
- begin fun l2 ->
- List.for_all2 l1 l2 ~f:(included ~prefix)
- end
- | _, Ttuple _ -> included (newty (Ttuple [t1])) t2 ~prefix
- | Tconstr (p1, l1, _), Tconstr (p2, l2, _) ->
- remove_prefix ~prefix (longident_of_path p1) = (longident_of_path p2)
- && List.length l1 = List.length l2
- && List.for_all2 l1 l2 ~f:(included ~prefix)
- | _ -> false
-
-let mklid = function
- [] -> raise (Invalid_argument "Searchid.mklid")
- | x :: l ->
- List.fold_left l ~init:(Lident x) ~f:(fun acc x -> Ldot (acc, x))
-
-let mkpath = function
- [] -> raise (Invalid_argument "Searchid.mklid")
- | x :: l ->
- List.fold_left l ~init:(Pident (Ident.create x))
- ~f:(fun acc x -> Pdot (acc, x, 0))
-
-let get_fields ~prefix ~sign self =
- let env = open_signature (mkpath prefix) sign initial in
- match (expand_head env self).desc with
- Tobject (ty_obj, _) ->
- let l,_ = flatten_fields ty_obj in l
- | _ -> []
-
-let rec search_type_in_signature t ~sign ~prefix ~mode =
- let matches = match mode with
- `Included -> included t ~prefix
- | `Exact -> equal t ~prefix
- and lid_of_id id = mklid (prefix @ [Ident.name id]) in
- List2.flat_map sign ~f:
- begin fun item -> match item with
- Tsig_value (id, vd) ->
- if matches vd.val_type then [lid_of_id id, Pvalue] else []
- | Tsig_type (id, td) ->
- if
- begin match td.type_manifest with
- None -> false
- | Some t -> matches t
- end ||
- begin match td.type_kind with
- Type_abstract -> false
- | Type_variant(l, priv) ->
- List.exists l ~f:(fun (_, l) -> List.exists l ~f:matches)
- | Type_record(l, rep, priv) ->
- List.exists l ~f:(fun (_, _, t) -> matches t)
- end
- then [lid_of_id id, Ptype] else []
- | Tsig_exception (id, l) ->
- if List.exists l ~f:matches
- then [lid_of_id id, Pconstructor]
- else []
- | Tsig_module (id, Tmty_signature sign) ->
- search_type_in_signature t ~sign ~mode
- ~prefix:(prefix @ [Ident.name id])
- | Tsig_module _ -> []
- | Tsig_modtype _ -> []
- | Tsig_class (id, cl) ->
- let self = self_type cl.cty_type in
- if matches self
- || (match cl.cty_new with None -> false | Some ty -> matches ty)
- (* || List.exists (get_fields ~prefix ~sign self)
- ~f:(fun (_,_,ty_field) -> matches ty_field) *)
- then [lid_of_id id, Pclass] else []
- | Tsig_cltype (id, cl) ->
- let self = self_type cl.clty_type in
- if matches self
- (* || List.exists (get_fields ~prefix ~sign self)
- ~f:(fun (_,_,ty_field) -> matches ty_field) *)
- then [lid_of_id id, Pclass] else []
- end
-
-let search_all_types t ~mode =
- let tl = match mode, t.desc with
- `Exact, _ -> [t]
- | `Included, Tarrow _ -> [t]
- | `Included, _ ->
- [t; newty(Tarrow("",t,newvar(),Cok)); newty(Tarrow("",newvar(),t,Cok))]
- in List2.flat_map !module_list ~f:
- begin fun modname ->
- let mlid = Lident modname in
- try match lookup_module mlid initial with
- _, Tmty_signature sign ->
- List2.flat_map tl
- ~f:(search_type_in_signature ~sign ~prefix:[modname] ~mode)
- | _ -> []
- with Not_found | Env.Error _ -> []
- end
-
-exception Error of int * int
-
-let search_string_type text ~mode =
- try
- let sexp = Parse.interface (Lexing.from_string ("val z : " ^ text)) in
- let sign =
- try Typemod.transl_signature !start_env sexp with _ ->
- let env = List.fold_left !module_list ~init:initial ~f:
- begin fun acc m ->
- try open_pers_signature m acc with Env.Error _ -> acc
- end in
- try Typemod.transl_signature env sexp
- with Env.Error err -> []
- | Typemod.Error (l,_) ->
- let start_c = l.loc_start.Lexing.pos_cnum in
- let end_c = l.loc_end.Lexing.pos_cnum in
- raise (Error (start_c - 8, end_c - 8))
- | Typetexp.Error (l,_) ->
- let start_c = l.loc_start.Lexing.pos_cnum in
- let end_c = l.loc_end.Lexing.pos_cnum in
- raise (Error (start_c - 8, end_c - 8))
- in match sign with
- [Tsig_value (_, vd)] ->
- search_all_types vd.val_type ~mode
- | _ -> []
- with
- Syntaxerr.Error(Syntaxerr.Unclosed(l,_,_,_)) ->
- let start_c = l.loc_start.Lexing.pos_cnum in
- let end_c = l.loc_end.Lexing.pos_cnum in
- raise (Error (start_c - 8, end_c - 8))
- | Syntaxerr.Error(Syntaxerr.Other l) ->
- let start_c = l.loc_start.Lexing.pos_cnum in
- let end_c = l.loc_end.Lexing.pos_cnum in
- raise (Error (start_c - 8, end_c - 8))
- | Lexer.Error (_, l) ->
- let start_c = l.loc_start.Lexing.pos_cnum in
- let end_c = l.loc_end.Lexing.pos_cnum in
- raise (Error (start_c - 8, end_c - 8))
-
-let longident_of_string text =
- let exploded = ref [] and l = ref 0 in
- for i = 0 to String.length text - 2 do
- if text.[i] ='.' then
- (exploded := String.sub text ~pos:!l ~len:(i - !l) :: !exploded; l := i+1)
- done;
- let sym = String.sub text ~pos:!l ~len:(String.length text - !l) in
- let rec mklid = function
- [s] -> Lident s
- | s :: l -> Ldot (mklid l, s)
- | [] -> assert false in
- sym, fun l -> mklid (sym :: !exploded @ l)
-
-
-let explode s =
- let l = ref [] in
- for i = String.length s - 1 downto 0 do
- l := s.[i] :: !l
- done; !l
-
-let rec check_match ~pattern s =
- match pattern, s with
- [], [] -> true
- | '*'::l, l' -> check_match ~pattern:l l'
- || check_match ~pattern:('?'::'*'::l) l'
- | '?'::l, _::l' -> check_match ~pattern:l l'
- | x::l, y::l' when x == y -> check_match ~pattern:l l'
- | _ -> false
-
-let search_pattern_symbol text =
- if text = "" then [] else
- let pattern = explode text in
- let check i = check_match ~pattern (explode (Ident.name i)) in
- let l = List.map !module_list ~f:
- begin fun modname -> Lident modname,
- try match lookup_module (Lident modname) initial with
- _, Tmty_signature sign ->
- List2.flat_map sign ~f:
- begin function
- Tsig_value (i, _) when check i -> [i, Pvalue]
- | Tsig_type (i, _) when check i -> [i, Ptype]
- | Tsig_exception (i, _) when check i -> [i, Pconstructor]
- | Tsig_module (i, _) when check i -> [i, Pmodule]
- | Tsig_modtype (i, _) when check i -> [i, Pmodtype]
- | Tsig_class (i, cl) when check i
- || List.exists
- (get_fields ~prefix:[modname] ~sign (self_type cl.cty_type))
- ~f:(fun (name,_,_) -> check_match ~pattern (explode name))
- -> [i, Pclass]
- | Tsig_cltype (i, cl) when check i
- || List.exists
- (get_fields ~prefix:[modname] ~sign (self_type cl.clty_type))
- ~f:(fun (name,_,_) -> check_match ~pattern (explode name))
- -> [i, Pcltype]
- | _ -> []
- end
- | _ -> []
- with Env.Error _ -> []
- end
- in
- List2.flat_map l ~f:
- begin fun (m, l) ->
- List.map l ~f:(fun (i, p) -> Ldot (m, Ident.name i), p)
- end
-
-(*
-let is_pattern s =
- try for i = 0 to String.length s -1 do
- if s.[i] = '?' || s.[i] = '*' then raise Exit
- done; false
- with Exit -> true
-*)
-
-let search_string_symbol text =
- if text = "" then [] else
- let lid = snd (longident_of_string text) [] in
- let try_lookup f k =
- try let _ = f lid Env.initial in [lid, k]
- with Not_found | Env.Error _ -> []
- in
- try_lookup lookup_constructor Pconstructor @
- try_lookup lookup_module Pmodule @
- try_lookup lookup_modtype Pmodtype @
- try_lookup lookup_value Pvalue @
- try_lookup lookup_type Ptype @
- try_lookup lookup_label Plabel @
- try_lookup lookup_class Pclass
-
-open Parsetree
-
-let rec bound_variables pat =
- match pat.ppat_desc with
- Ppat_any | Ppat_constant _ | Ppat_type _ -> []
- | Ppat_var s -> [s]
- | Ppat_alias (pat,s) -> s :: bound_variables pat
- | Ppat_tuple l -> List2.flat_map l ~f:bound_variables
- | Ppat_construct (_,None,_) -> []
- | Ppat_construct (_,Some pat,_) -> bound_variables pat
- | Ppat_variant (_,None) -> []
- | Ppat_variant (_,Some pat) -> bound_variables pat
- | Ppat_record l ->
- List2.flat_map l ~f:(fun (_,pat) -> bound_variables pat)
- | Ppat_array l ->
- List2.flat_map l ~f:bound_variables
- | Ppat_or (pat1,pat2) ->
- bound_variables pat1 @ bound_variables pat2
- | Ppat_constraint (pat,_) -> bound_variables pat
-
-let search_structure str ~name ~kind ~prefix =
- let loc = ref 0 in
- let rec search_module str ~prefix =
- match prefix with [] -> str
- | modu::prefix ->
- let str =
- List.fold_left ~init:[] str ~f:
- begin fun acc item ->
- match item.pstr_desc with
- Pstr_module (s, mexp) when s = modu ->
- loc := mexp.pmod_loc.loc_start.Lexing.pos_cnum;
- begin match mexp.pmod_desc with
- Pmod_structure str -> str
- | _ -> []
- end
- | _ -> acc
- end
- in search_module str ~prefix
- in
- List.iter (search_module str ~prefix) ~f:
- begin fun item ->
- if match item.pstr_desc with
- Pstr_value (_, l) when kind = Pvalue ->
- List.iter l ~f:
- begin fun (pat,_) ->
- if List.mem name (bound_variables pat)
- then loc := pat.ppat_loc.loc_start.Lexing.pos_cnum
- end;
- false
- | Pstr_primitive (s, _) when kind = Pvalue -> name = s
- | Pstr_type l when kind = Ptype ->
- List.iter l ~f:
- begin fun (s, td) ->
- if s = name then loc := td.ptype_loc.loc_start.Lexing.pos_cnum
- end;
- false
- | Pstr_exception (s, _) when kind = Pconstructor -> name = s
- | Pstr_module (s, _) when kind = Pmodule -> name = s
- | Pstr_modtype (s, _) when kind = Pmodtype -> name = s
- | Pstr_class l when kind = Pclass || kind = Ptype || kind = Pcltype ->
- List.iter l ~f:
- begin fun c ->
- if c.pci_name = name
- then loc := c.pci_loc.loc_start.Lexing.pos_cnum
- end;
- false
- | Pstr_class_type l when kind = Pcltype || kind = Ptype ->
- List.iter l ~f:
- begin fun c ->
- if c.pci_name = name
- then loc := c.pci_loc.loc_start.Lexing.pos_cnum
- end;
- false
- | _ -> false
- then loc := item.pstr_loc.loc_start.Lexing.pos_cnum
- end;
- !loc
-
-let search_signature sign ~name ~kind ~prefix =
- let loc = ref 0 in
- let rec search_module_type sign ~prefix =
- match prefix with [] -> sign
- | modu::prefix ->
- let sign =
- List.fold_left ~init:[] sign ~f:
- begin fun acc item ->
- match item.psig_desc with
- Psig_module (s, mtyp) when s = modu ->
- loc := mtyp.pmty_loc.loc_start.Lexing.pos_cnum;
- begin match mtyp.pmty_desc with
- Pmty_signature sign -> sign
- | _ -> []
- end
- | _ -> acc
- end
- in search_module_type sign ~prefix
- in
- List.iter (search_module_type sign ~prefix) ~f:
- begin fun item ->
- if match item.psig_desc with
- Psig_value (s, _) when kind = Pvalue -> name = s
- | Psig_type l when kind = Ptype ->
- List.iter l ~f:
- begin fun (s, td) ->
- if s = name then loc := td.ptype_loc.loc_start.Lexing.pos_cnum
- end;
- false
- | Psig_exception (s, _) when kind = Pconstructor -> name = s
- | Psig_module (s, _) when kind = Pmodule -> name = s
- | Psig_modtype (s, _) when kind = Pmodtype -> name = s
- | Psig_class l when kind = Pclass || kind = Ptype || kind = Pcltype ->
- List.iter l ~f:
- begin fun c ->
- if c.pci_name = name
- then loc := c.pci_loc.loc_start.Lexing.pos_cnum
- end;
- false
- | Psig_class_type l when kind = Ptype || kind = Pcltype ->
- List.iter l ~f:
- begin fun c ->
- if c.pci_name = name
- then loc := c.pci_loc.loc_start.Lexing.pos_cnum
- end;
- false
- | _ -> false
- then loc := item.psig_loc.loc_start.Lexing.pos_cnum
- end;
- !loc
diff --git a/otherlibs/labltk/browser/searchid.mli b/otherlibs/labltk/browser/searchid.mli
deleted file mode 100644
index 980c141d08..0000000000
--- a/otherlibs/labltk/browser/searchid.mli
+++ /dev/null
@@ -1,45 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-val start_env : Env.t ref
-val module_list : string list ref
-val longident_of_path : Path.t ->Longident.t
-
-type pkind =
- Pvalue
- | Ptype
- | Plabel
- | Pconstructor
- | Pmodule
- | Pmodtype
- | Pclass
- | Pcltype
-
-val string_of_kind : pkind -> string
-
-exception Error of int * int
-
-val search_string_type :
- string -> mode:[`Exact|`Included] -> (Longident.t * pkind) list
-val search_pattern_symbol : string -> (Longident.t * pkind) list
-val search_string_symbol : string -> (Longident.t * pkind) list
-
-val search_structure :
- Parsetree.structure ->
- name:string -> kind:pkind -> prefix:string list -> int
-val search_signature :
- Parsetree.signature ->
- name:string -> kind:pkind -> prefix:string list -> int
diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
deleted file mode 100644
index 430d520403..0000000000
--- a/otherlibs/labltk/browser/searchpos.ml
+++ /dev/null
@@ -1,875 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open StdLabels
-open Support
-open Tk
-open Jg_tk
-open Parsetree
-open Types
-open Typedtree
-open Location
-open Longident
-open Path
-open Env
-open Searchid
-
-(* auxiliary functions *)
-
-let (~!) = Jg_memo.fast ~f:Str.regexp
-
-let lines_to_chars n ~text:s =
- let l = String.length s in
- let rec ltc n ~pos =
- if n = 1 || pos >= l then pos else
- if s.[pos] = '\n' then ltc (n-1) ~pos:(pos+1) else ltc n ~pos:(pos+1)
- in ltc n ~pos:0
-
-let in_loc loc ~pos =
- loc.loc_ghost || pos >= loc.loc_start.Lexing.pos_cnum
- && pos < loc.loc_end.Lexing.pos_cnum
-
-let le_loc loc1 loc2 =
- loc1.loc_start.Lexing.pos_cnum <= loc2.loc_start.Lexing.pos_cnum
- && loc1.loc_end.Lexing.pos_cnum >= loc2.loc_end.Lexing.pos_cnum
-
-let add_found ~found sol ~env ~loc =
- if loc.loc_ghost then () else
- if List.exists !found ~f:(fun (_,_,loc') -> le_loc loc loc') then ()
- else found := (sol, env, loc) ::
- List.filter !found ~f:(fun (_,_,loc') -> not (le_loc loc' loc))
-
-let observe ~ref ?init f x =
- let old = !ref in
- begin match init with None -> () | Some x -> ref := x end;
- try (f x : unit); let v = !ref in ref := old; v
- with exn -> ref := old; raise exn
-
-let rec string_of_longident = function
- Lident s -> s
- | Ldot (id,s) -> string_of_longident id ^ "." ^ s
- | Lapply (id1, id2) ->
- string_of_longident id1 ^ "(" ^ string_of_longident id2 ^ ")"
-
-let string_of_path p = string_of_longident (Searchid.longident_of_path p)
-
-let parent_path = function
- Pdot (path, _, _) -> Some path
- | Pident _ | Papply _ -> None
-
-let ident_of_path ~default = function
- Pident i -> i
- | Pdot (_, s, _) -> Ident.create s
- | Papply _ -> Ident.create default
-
-let rec head_id = function
- Pident id -> id
- | Pdot (path,_,_) -> head_id path
- | Papply (path,_) -> head_id path (* wrong, but ... *)
-
-let rec list_of_path = function
- Pident id -> [Ident.name id]
- | Pdot (path, s, _) -> list_of_path path @ [s]
- | Papply (path, _) -> list_of_path path (* wrong, but ... *)
-
-(* a simple wrapper *)
-
-class buffer ~size = object
- val buffer = Buffer.create size
- method out buf = Buffer.add_substring buffer buf
- method get = Buffer.contents buffer
-end
-
-(* Search in a signature *)
-
-type skind = [`Type|`Class|`Module|`Modtype]
-
-let found_sig = ref ([] : ((skind * Longident.t) * Env.t * Location.t) list)
-let add_found_sig = add_found ~found:found_sig
-
-let rec search_pos_type t ~pos ~env =
- if in_loc ~pos t.ptyp_loc then
- begin match t.ptyp_desc with
- Ptyp_any
- | Ptyp_var _ -> ()
- | Ptyp_variant(tl, _, _) ->
- List.iter tl ~f:
- begin function
- Rtag (_,_,tl) -> List.iter tl ~f:(search_pos_type ~pos ~env)
- | Rinherit st -> search_pos_type ~pos ~env st
- end
- | Ptyp_arrow (_, t1, t2) ->
- search_pos_type t1 ~pos ~env;
- search_pos_type t2 ~pos ~env
- | Ptyp_tuple tl ->
- List.iter tl ~f:(search_pos_type ~pos ~env)
- | Ptyp_constr (lid, tl) ->
- List.iter tl ~f:(search_pos_type ~pos ~env);
- add_found_sig (`Type, lid) ~env ~loc:t.ptyp_loc
- | Ptyp_object fl ->
- List.iter fl ~f:
- begin function
- | {pfield_desc = Pfield (_, ty)} -> search_pos_type ty ~pos ~env
- | _ -> ()
- end
- | Ptyp_class (lid, tl, _) ->
- List.iter tl ~f:(search_pos_type ~pos ~env);
- add_found_sig (`Type, lid) ~env ~loc:t.ptyp_loc
- | Ptyp_alias (t, _)
- | Ptyp_poly (_, t) -> search_pos_type ~pos ~env t
- end
-
-let rec search_pos_class_type cl ~pos ~env =
- if in_loc cl.pcty_loc ~pos then
- begin match cl.pcty_desc with
- Pcty_constr (lid, _) ->
- add_found_sig (`Class, lid) ~env ~loc:cl.pcty_loc
- | Pcty_signature (_, cfl) ->
- List.iter cfl ~f:
- begin function
- Pctf_inher cty -> search_pos_class_type cty ~pos ~env
- | Pctf_val (_, _, Some ty, loc) ->
- if in_loc loc ~pos then search_pos_type ty ~pos ~env
- | Pctf_val _ -> ()
- | Pctf_virt (_, _, ty, loc) ->
- if in_loc loc ~pos then search_pos_type ty ~pos ~env
- | Pctf_meth (_, _, ty, loc) ->
- if in_loc loc ~pos then search_pos_type ty ~pos ~env
- | Pctf_cstr (ty1, ty2, loc) ->
- if in_loc loc ~pos then begin
- search_pos_type ty1 ~pos ~env;
- search_pos_type ty2 ~pos ~env
- end
- end
- | Pcty_fun (_, ty, cty) ->
- search_pos_type ty ~pos ~env;
- search_pos_class_type cty ~pos ~env
- end
-
-let search_pos_type_decl td ~pos ~env =
- if in_loc ~pos td.ptype_loc then begin
- begin match td.ptype_manifest with
- Some t -> search_pos_type t ~pos ~env
- | None -> ()
- end;
- let rec search_tkind = function
- Ptype_abstract -> ()
- | Ptype_variant (dl, _) ->
- List.iter dl
- ~f:(fun (_, tl) -> List.iter tl ~f:(search_pos_type ~pos ~env))
- | Ptype_record (dl, _) ->
- List.iter dl ~f:(fun (_, _, t) -> search_pos_type t ~pos ~env) in
- search_tkind td.ptype_kind;
- List.iter td.ptype_cstrs ~f:
- begin fun (t1, t2, _) ->
- search_pos_type t1 ~pos ~env;
- search_pos_type t2 ~pos ~env
- end
- end
-
-let rec search_pos_signature l ~pos ~env =
- ignore (
- List.fold_left l ~init:env ~f:
- begin fun env pt ->
- let env = match pt.psig_desc with
- Psig_open id ->
- let path, mt = lookup_module id env in
- begin match mt with
- Tmty_signature sign -> open_signature path sign env
- | _ -> env
- end
- | sign_item ->
- try add_signature (Typemod.transl_signature env [pt]) env
- with Typemod.Error _ | Typeclass.Error _
- | Typetexp.Error _ | Typedecl.Error _ -> env
- in
- if in_loc ~pos pt.psig_loc then
- begin match pt.psig_desc with
- Psig_value (_, desc) -> search_pos_type desc.pval_type ~pos ~env
- | Psig_type l ->
- List.iter l ~f:(fun (_,desc) -> search_pos_type_decl ~pos desc ~env)
- | Psig_exception (_, l) ->
- List.iter l ~f:(search_pos_type ~pos ~env);
- add_found_sig (`Type, Lident "exn") ~env ~loc:pt.psig_loc
- | Psig_module (_, t) ->
- search_pos_module t ~pos ~env
- | Psig_recmodule decls ->
- assert false (* to be fixed *)
- | Psig_modtype (_, Pmodtype_manifest t) ->
- search_pos_module t ~pos ~env
- | Psig_modtype _ -> ()
- | Psig_class l ->
- List.iter l
- ~f:(fun ci -> search_pos_class_type ci.pci_expr ~pos ~env)
- | Psig_class_type l ->
- List.iter l
- ~f:(fun ci -> search_pos_class_type ci.pci_expr ~pos ~env)
- (* The last cases should not happen in generated interfaces *)
- | Psig_open lid -> add_found_sig (`Module, lid) ~env ~loc:pt.psig_loc
- | Psig_include t -> search_pos_module t ~pos ~env
- end;
- env
- end)
-
-and search_pos_module m ~pos ~env =
- if in_loc m.pmty_loc ~pos then begin
- begin match m.pmty_desc with
- Pmty_ident lid -> add_found_sig (`Modtype, lid) ~env ~loc:m.pmty_loc
- | Pmty_signature sg -> search_pos_signature sg ~pos ~env
- | Pmty_functor (_ , m1, m2) ->
- search_pos_module m1 ~pos ~env;
- search_pos_module m2 ~pos ~env
- | Pmty_with (m, l) ->
- search_pos_module m ~pos ~env;
- List.iter l ~f:
- begin function
- _, Pwith_type t -> search_pos_type_decl t ~pos ~env
- | _ -> ()
- end
- end
- end
-
-let search_pos_signature l ~pos ~env =
- observe ~ref:found_sig (search_pos_signature ~pos ~env) l
-
-(* the module display machinery *)
-
-type module_widgets =
- { mw_frame: Widget.frame Widget.widget;
- mw_title: Widget.label Widget.widget option;
- mw_detach: Widget.button Widget.widget;
- mw_edit: Widget.button Widget.widget;
- mw_intf: Widget.button Widget.widget }
-
-let shown_modules = Hashtbl.create 17
-let default_frame = ref None
-let set_path = ref (fun _ ~sign -> assert false)
-let filter_modules () =
- Hashtbl.iter
- (fun key data ->
- if not (Winfo.exists data.mw_frame) then
- Hashtbl.remove shown_modules key)
- shown_modules
-let add_shown_module path ~widgets =
- Hashtbl.add shown_modules path widgets
-let find_shown_module path =
- try
- filter_modules ();
- Hashtbl.find shown_modules path
- with Not_found ->
- match !default_frame with
- None -> raise Not_found
- | Some mw -> mw
-
-let is_shown_module path =
- !default_frame <> None ||
- (filter_modules (); Hashtbl.mem shown_modules path)
-
-(* Viewing a signature *)
-
-(* Forward definitions of Viewer.view_defined and Editor.editor *)
-let view_defined_ref = ref (fun lid ~env -> ())
-let editor_ref = ref (fun ?file ?pos ?opendialog () -> ())
-
-let edit_source ~file ~path ~sign =
- match sign with
- [item] ->
- let id, kind =
- match item with
- Tsig_value (id, _) -> id, Pvalue
- | Tsig_type (id, _) -> id, Ptype
- | Tsig_exception (id, _) -> id, Pconstructor
- | Tsig_module (id, _) -> id, Pmodule
- | Tsig_modtype (id, _) -> id, Pmodtype
- | Tsig_class (id, _) -> id, Pclass
- | Tsig_cltype (id, _) -> id, Pcltype
- in
- let prefix = List.tl (list_of_path path) and name = Ident.name id in
- let pos =
- try
- let chan = open_in file in
- if Filename.check_suffix file ".ml" then
- let parsed = Parse.implementation (Lexing.from_channel chan) in
- close_in chan;
- Searchid.search_structure parsed ~name ~kind ~prefix
- else
- let parsed = Parse.interface (Lexing.from_channel chan) in
- close_in chan;
- Searchid.search_signature parsed ~name ~kind ~prefix
- with _ -> 0
- in !editor_ref ~file ~pos ()
- | _ -> !editor_ref ~file ()
-
-(* List of windows to destroy by Close All *)
-let top_widgets = ref []
-
-let rec view_signature ?title ?path ?(env = !start_env) ?(detach=false) sign =
- let env =
- match path with None -> env
- | Some path -> Env.open_signature path sign env in
- let title =
- match title, path with Some title, _ -> title
- | None, Some path -> string_of_path path
- | None, None -> "Signature"
- in
- let tl, tw, finish =
- try match path, !default_frame with
- None, Some ({mw_title=Some label} as mw) when not detach ->
- Button.configure mw.mw_detach
- ~command:(fun () -> view_signature sign ~title ~env ~detach:true);
- pack [mw.mw_detach] ~side:`Left;
- Pack.forget [mw.mw_edit; mw.mw_intf];
- List.iter ~f:destroy (Winfo.children mw.mw_frame);
- Label.configure label ~text:title;
- pack [label] ~fill:`X ~side:`Bottom;
- Jg_message.formatted ~title ~on:mw.mw_frame ~maxheight:15 ()
- | None, _ -> raise Not_found
- | Some path, _ ->
- let mw =
- try find_shown_module path
- with Not_found ->
- view_module path ~env;
- find_shown_module path
- in
- (try !set_path path ~sign with _ -> ());
- begin match mw.mw_title with None -> ()
- | Some label ->
- Label.configure label ~text:title;
- pack [label] ~fill:`X ~side:`Bottom
- end;
- Button.configure mw.mw_detach
- ~command:(fun () -> view_signature sign ~title ~env ~detach:true);
- pack [mw.mw_detach] ~side:`Left;
- let repack = ref false in
- List.iter2 [mw.mw_edit; mw.mw_intf] [".ml"; ".mli"] ~f:
- begin fun button ext ->
- try
- let id = head_id path in
- let file =
- Misc.find_in_path_uncap !Config.load_path
- ((Ident.name id) ^ ext) in
- Button.configure button
- ~command:(fun () -> edit_source ~file ~path ~sign);
- if !repack then Pack.forget [button] else
- if not (Winfo.viewable button) then repack := true;
- pack [button] ~side:`Left
- with Not_found ->
- Pack.forget [button]
- end;
- let top = Winfo.toplevel mw.mw_frame in
- if not (Winfo.ismapped top) then Wm.deiconify top;
- List.iter ~f:destroy (Winfo.children mw.mw_frame);
- Jg_message.formatted ~title ~on:mw.mw_frame ~maxheight:15 ()
- with Not_found ->
- let tl, tw, finish = Jg_message.formatted ~title ~maxheight:15 () in
- top_widgets := tl :: !top_widgets;
- tl, tw, finish
- in
- Format.set_max_boxes 100;
- Printtyp.signature Format.std_formatter sign;
- finish ();
- Lexical.init_tags tw;
- Lexical.tag tw;
- Text.configure tw ~state:`Disabled;
- let text = Jg_text.get_all tw in
- let pt =
- try Parse.interface (Lexing.from_string text)
- with Syntaxerr.Error e ->
- let l =
- match e with
- Syntaxerr.Unclosed(l,_,_,_) -> l
- | Syntaxerr.Other l -> l
- in
- Jg_text.tag_and_see tw ~start:(tpos l.loc_start.Lexing.pos_cnum)
- ~stop:(tpos l.loc_end.Lexing.pos_cnum) ~tag:"error"; []
- | Lexer.Error (_, l) ->
- let s = l.loc_start.Lexing.pos_cnum in
- let e = l.loc_end.Lexing.pos_cnum in
- Jg_text.tag_and_see tw ~start:(tpos s) ~stop:(tpos e) ~tag:"error"; []
- in
- Jg_bind.enter_focus tw;
- bind tw ~events:[`Modified([`Control], `KeyPressDetail"s")]
- ~action:(fun _ -> Jg_text.search_string tw);
- bind tw ~events:[`Modified([`Double], `ButtonPressDetail 1)]
- ~fields:[`MouseX;`MouseY] ~breakable:true
- ~action:(fun ev ->
- let `Linechar (l, c) =
- Text.index tw ~index:(`Atxy(ev.ev_MouseX,ev.ev_MouseY), []) in
- try
- match search_pos_signature pt ~pos:(lines_to_chars l ~text + c) ~env
- with [] -> break ()
- | ((kind, lid), env, loc) :: _ -> view_decl lid ~kind ~env
- with Not_found | Env.Error _ -> ());
- bind tw ~events:[`ButtonPressDetail 3] ~breakable:true
- ~fields:[`MouseX;`MouseY]
- ~action:(fun ev ->
- let x = ev.ev_MouseX and y = ev.ev_MouseY in
- let `Linechar (l, c) =
- Text.index tw ~index:(`Atxy(x,y), []) in
- try
- match search_pos_signature pt ~pos:(lines_to_chars l ~text + c) ~env
- with [] -> break ()
- | ((kind, lid), env, loc) :: _ ->
- let menu = view_decl_menu lid ~kind ~env ~parent:tw in
- let x = x + Winfo.rootx tw and y = y + Winfo.rooty tw - 10 in
- Menu.popup menu ~x ~y
- with Not_found -> ())
-
-and view_signature_item sign ~path ~env =
- view_signature sign ~title:(string_of_path path)
- ?path:(parent_path path) ~env
-
-and view_module path ~env =
- match find_module path env with
- Tmty_signature sign ->
- !view_defined_ref (Searchid.longident_of_path path) ~env
- | modtype ->
- let id = ident_of_path path ~default:"M" in
- view_signature_item [Tsig_module (id, modtype)] ~path ~env
-
-and view_module_id id ~env =
- let path, _ = lookup_module id env in
- view_module path ~env
-
-and view_type_decl path ~env =
- let td = find_type path env in
- try match td.type_manifest with None -> raise Not_found
- | Some ty -> match Ctype.repr ty with
- {desc = Tobject _} ->
- let clt = find_cltype path env in
- view_signature_item ~path ~env
- [Tsig_cltype(ident_of_path path ~default:"ct", clt)]
- | _ -> raise Not_found
- with Not_found ->
- view_signature_item ~path ~env
- [Tsig_type(ident_of_path path ~default:"t", td)]
-
-and view_type_id li ~env =
- let path, decl = lookup_type li env in
- view_type_decl path ~env
-
-and view_class_id li ~env =
- let path, cl = lookup_class li env in
- view_signature_item ~path ~env
- [Tsig_class(ident_of_path path ~default:"c", cl)]
-
-and view_cltype_id li ~env =
- let path, clt = lookup_cltype li env in
- view_signature_item ~path ~env
- [Tsig_cltype(ident_of_path path ~default:"ct", clt)]
-
-and view_modtype_id li ~env =
- let path, td = lookup_modtype li env in
- view_signature_item ~path ~env
- [Tsig_modtype(ident_of_path path ~default:"S", td)]
-
-and view_expr_type ?title ?path ?env ?(name="noname") t =
- let title =
- match title, path with Some title, _ -> title
- | None, Some path -> string_of_path path
- | None, None -> "Expression type"
- and path, id =
- match path with None -> None, Ident.create name
- | Some path -> parent_path path, ident_of_path path ~default:name
- in
- view_signature ~title ?path ?env
- [Tsig_value (id, {val_type = t; val_kind = Val_reg})]
-
-and view_decl lid ~kind ~env =
- match kind with
- `Type -> view_type_id lid ~env
- | `Class -> view_class_id lid ~env
- | `Module -> view_module_id lid ~env
- | `Modtype -> view_modtype_id lid ~env
-
-and view_decl_menu lid ~kind ~env ~parent =
- let path, kname =
- try match kind with
- `Type -> fst (lookup_type lid env), "Type"
- | `Class -> fst (lookup_class lid env), "Class"
- | `Module -> fst (lookup_module lid env), "Module"
- | `Modtype -> fst (lookup_modtype lid env), "Module type"
- with Env.Error _ -> raise Not_found
- in
- let menu = Menu.create parent ~tearoff:false in
- let label = kname ^ " " ^ string_of_path path in
- begin match path with
- Pident _ ->
- Menu.add_command menu ~label ~state:`Disabled
- | _ ->
- Menu.add_command menu ~label
- ~command:(fun () -> view_decl lid ~kind ~env);
- end;
- if kind = `Type || kind = `Modtype then begin
- let buf = new buffer ~size:60 in
- let (fo,ff) = Format.get_formatter_output_functions ()
- and margin = Format.get_margin () in
- Format.set_formatter_output_functions buf#out (fun () -> ());
- Format.set_margin 60;
- Format.open_hbox ();
- if kind = `Type then
- Printtyp.type_declaration
- (ident_of_path path ~default:"t")
- Format.std_formatter
- (find_type path env)
- else
- Printtyp.modtype_declaration
- (ident_of_path path ~default:"S")
- Format.std_formatter
- (find_modtype path env);
- Format.close_box (); Format.print_flush ();
- Format.set_formatter_output_functions fo ff;
- Format.set_margin margin;
- let l = Str.split ~!"\n" buf#get in
- let font =
- let font =
- Option.get Widget.default_toplevel ~name:"font" ~clas:"Font" in
- if font = "" then "7x14" else font
- in
- (* Menu.add_separator menu; *)
- List.iter l
- ~f:(fun label -> Menu.add_command menu ~label ~font ~state:`Disabled)
- end;
- menu
-
-(* search and view in a structure *)
-
-type fkind = [
- `Exp of
- [`Expr|`Pat|`Const|`Val of Path.t|`Var of Path.t|`New of Path.t]
- * Types.type_expr
- | `Class of Path.t * Types.class_type
- | `Module of Path.t * Types.module_type
-]
-
-let view_type kind ~env =
- match kind with
- `Exp (k, ty) ->
- begin match k with
- `Expr -> view_expr_type ty ~title:"Expression type" ~env
- | `Pat -> view_expr_type ty ~title:"Pattern type" ~env
- | `Const -> view_expr_type ty ~title:"Constant type" ~env
- | `Val path ->
- begin try
- let vd = find_value path env in
- view_signature_item ~path ~env
- [Tsig_value(ident_of_path path ~default:"v", vd)]
- with Not_found ->
- view_expr_type ty ~path ~env
- end
- | `Var path ->
- let vd = find_value path env in
- view_expr_type vd.val_type ~env ~path ~title:"Variable type"
- | `New path ->
- let cl = find_class path env in
- view_signature_item ~path ~env
- [Tsig_class(ident_of_path path ~default:"c", cl)]
- end
- | `Class (path, cty) ->
- let cld = { cty_params = []; cty_type = cty;
- cty_path = path; cty_new = None } in
- view_signature_item ~path ~env
- [Tsig_class(ident_of_path path ~default:"c", cld)]
- | `Module (path, mty) ->
- match mty with
- Tmty_signature sign -> view_signature sign ~path ~env
- | modtype ->
- view_signature_item ~path ~env
- [Tsig_module(ident_of_path path ~default:"M", mty)]
-
-let view_type_menu kind ~env ~parent =
- let title =
- match kind with
- `Exp (`Expr,_) -> "Expression :"
- | `Exp (`Pat, _) -> "Pattern :"
- | `Exp (`Const, _) -> "Constant :"
- | `Exp (`Val path, _) -> "Value " ^ string_of_path path ^ " :"
- | `Exp (`Var path, _) ->
- "Variable " ^ Ident.name (ident_of_path path ~default:"noname") ^ " :"
- | `Exp (`New path, _) -> "Class " ^ string_of_path path ^ " :"
- | `Class (path, _) -> "Class " ^ string_of_path path ^ " :"
- | `Module (path,_) -> "Module " ^ string_of_path path in
- let menu = Menu.create parent ~tearoff:false in
- begin match kind with
- `Exp((`Expr | `Pat | `Const | `Val (Pident _)),_) ->
- Menu.add_command menu ~label:title ~state:`Disabled
- | `Exp _ | `Class _ | `Module _ ->
- Menu.add_command menu ~label:title
- ~command:(fun () -> view_type kind ~env)
- end;
- begin match kind with `Module _ | `Class _ -> ()
- | `Exp(_, ty) ->
- let buf = new buffer ~size:60 in
- let (fo,ff) = Format.get_formatter_output_functions ()
- and margin = Format.get_margin () in
- Format.set_formatter_output_functions buf#out ignore;
- Format.set_margin 60;
- Format.open_hbox ();
- Printtyp.reset ();
- Printtyp.mark_loops ty;
- Printtyp.type_expr Format.std_formatter ty;
- Format.close_box (); Format.print_flush ();
- Format.set_formatter_output_functions fo ff;
- Format.set_margin margin;
- let l = Str.split ~!"\n" buf#get in
- let font =
- let font =
- Option.get Widget.default_toplevel ~name:"font" ~clas:"Font" in
- if font = "" then "7x14" else font
- in
- (* Menu.add_separator menu; *)
- List.iter l ~f:
- begin fun label -> match (Ctype.repr ty).desc with
- Tconstr (path,_,_) ->
- Menu.add_command menu ~label ~font
- ~command:(fun () -> view_type_decl path ~env)
- | Tvariant {row_name = Some (path, _)} ->
- Menu.add_command menu ~label ~font
- ~command:(fun () -> view_type_decl path ~env)
- | _ ->
- Menu.add_command menu ~label ~font ~state:`Disabled
- end
- end;
- menu
-
-let found_str = ref ([] : (fkind * Env.t * Location.t) list)
-let add_found_str = add_found ~found:found_str
-
-let rec search_pos_structure ~pos str =
- List.iter str ~f:
- begin function
- Tstr_eval exp -> search_pos_expr exp ~pos
- | Tstr_value (rec_flag, l) ->
- List.iter l ~f:
- begin fun (pat, exp) ->
- let env =
- if rec_flag = Asttypes.Recursive then exp.exp_env else Env.empty in
- search_pos_pat pat ~pos ~env;
- search_pos_expr exp ~pos
- end
- | Tstr_primitive (_, vd) ->()
- | Tstr_type _ -> ()
- | Tstr_exception _ -> ()
- | Tstr_exn_rebind(_, _) -> ()
- | Tstr_module (_, m) -> search_pos_module_expr m ~pos
- | Tstr_recmodule bindings -> assert false (* to be fixed *)
- | Tstr_modtype _ -> ()
- | Tstr_open _ -> ()
- | Tstr_class l ->
- List.iter l ~f:(fun (id, _, _, cl) -> search_pos_class_expr cl ~pos)
- | Tstr_cltype _ -> ()
- | Tstr_include (m, _) -> search_pos_module_expr m ~pos
- end
-
-and search_pos_class_structure ~pos cls =
- List.iter cls.cl_field ~f:
- begin function
- Cf_inher (cl, _, _) ->
- search_pos_class_expr cl ~pos
- | Cf_val (_, _, exp) -> search_pos_expr exp ~pos
- | Cf_meth (_, exp) -> search_pos_expr exp ~pos
- | Cf_let (_, pel, iel) ->
- List.iter pel ~f:
- begin fun (pat, exp) ->
- search_pos_pat pat ~pos ~env:exp.exp_env;
- search_pos_expr exp ~pos
- end;
- List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos)
- | Cf_init exp -> search_pos_expr exp ~pos
- end
-
-and search_pos_class_expr ~pos cl =
- if in_loc cl.cl_loc ~pos then begin
- begin match cl.cl_desc with
- Tclass_ident path ->
- add_found_str (`Class (path, cl.cl_type))
- ~env:!start_env ~loc:cl.cl_loc
- | Tclass_structure cls ->
- search_pos_class_structure ~pos cls
- | Tclass_fun (pat, iel, cl, _) ->
- search_pos_pat pat ~pos ~env:pat.pat_env;
- List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos);
- search_pos_class_expr cl ~pos
- | Tclass_apply (cl, el) ->
- search_pos_class_expr cl ~pos;
- List.iter el ~f:(fun (x,_) -> Misc.may (search_pos_expr ~pos) x)
- | Tclass_let (_, pel, iel, cl) ->
- List.iter pel ~f:
- begin fun (pat, exp) ->
- search_pos_pat pat ~pos ~env:exp.exp_env;
- search_pos_expr exp ~pos
- end;
- List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos);
- search_pos_class_expr cl ~pos
- | Tclass_constraint (cl, _, _, _) ->
- search_pos_class_expr cl ~pos
- end;
- add_found_str (`Class (Pident (Ident.create "c"), cl.cl_type))
- ~env:!start_env ~loc:cl.cl_loc
- end
-
-and search_pos_expr ~pos exp =
- if in_loc exp.exp_loc ~pos then begin
- begin match exp.exp_desc with
- Texp_ident (path, _) ->
- add_found_str (`Exp(`Val path, exp.exp_type))
- ~env:exp.exp_env ~loc:exp.exp_loc
- | Texp_constant v ->
- add_found_str (`Exp(`Const, exp.exp_type))
- ~env:exp.exp_env ~loc:exp.exp_loc
- | Texp_let (_, expl, exp) ->
- List.iter expl ~f:
- begin fun (pat, exp') ->
- search_pos_pat pat ~pos ~env:exp.exp_env;
- search_pos_expr exp' ~pos
- end;
- search_pos_expr exp ~pos
- | Texp_function (l, _) ->
- List.iter l ~f:
- begin fun (pat, exp) ->
- search_pos_pat pat ~pos ~env:exp.exp_env;
- search_pos_expr exp ~pos
- end
- | Texp_apply (exp, l) ->
- List.iter l ~f:(fun (x,_) -> Misc.may (search_pos_expr ~pos) x);
- search_pos_expr exp ~pos
- | Texp_match (exp, l, _) ->
- search_pos_expr exp ~pos;
- List.iter l ~f:
- begin fun (pat, exp) ->
- search_pos_pat pat ~pos ~env:exp.exp_env;
- search_pos_expr exp ~pos
- end
- | Texp_try (exp, l) ->
- search_pos_expr exp ~pos;
- List.iter l ~f:
- begin fun (pat, exp) ->
- search_pos_pat pat ~pos ~env:exp.exp_env;
- search_pos_expr exp ~pos
- end
- | Texp_tuple l -> List.iter l ~f:(search_pos_expr ~pos)
- | Texp_construct (_, l) -> List.iter l ~f:(search_pos_expr ~pos)
- | Texp_variant (_, None) -> ()
- | Texp_variant (_, Some exp) -> search_pos_expr exp ~pos
- | Texp_record (l, opt) ->
- List.iter l ~f:(fun (_, exp) -> search_pos_expr exp ~pos);
- (match opt with None -> () | Some exp -> search_pos_expr exp ~pos)
- | Texp_field (exp, _) -> search_pos_expr exp ~pos
- | Texp_setfield (a, _, b) ->
- search_pos_expr a ~pos; search_pos_expr b ~pos
- | Texp_array l -> List.iter l ~f:(search_pos_expr ~pos)
- | Texp_ifthenelse (a, b, c) ->
- search_pos_expr a ~pos; search_pos_expr b ~pos;
- begin match c with None -> ()
- | Some exp -> search_pos_expr exp ~pos
- end
- | Texp_sequence (a,b) ->
- search_pos_expr a ~pos; search_pos_expr b ~pos
- | Texp_while (a,b) ->
- search_pos_expr a ~pos; search_pos_expr b ~pos
- | Texp_for (_, a, b, _, c) ->
- List.iter [a;b;c] ~f:(search_pos_expr ~pos)
- | Texp_when (a, b) ->
- search_pos_expr a ~pos; search_pos_expr b ~pos
- | Texp_send (exp, _) -> search_pos_expr exp ~pos
- | Texp_new (path, _) ->
- add_found_str (`Exp(`New path, exp.exp_type))
- ~env:exp.exp_env ~loc:exp.exp_loc
- | Texp_instvar (_,path) ->
- add_found_str (`Exp(`Var path, exp.exp_type))
- ~env:exp.exp_env ~loc:exp.exp_loc
- | Texp_setinstvar (_, path, exp) ->
- search_pos_expr exp ~pos;
- add_found_str (`Exp(`Var path, exp.exp_type))
- ~env:exp.exp_env ~loc:exp.exp_loc
- | Texp_override (_, l) ->
- List.iter l ~f:(fun (_, exp) -> search_pos_expr exp ~pos)
- | Texp_letmodule (id, modexp, exp) ->
- search_pos_module_expr modexp ~pos;
- search_pos_expr exp ~pos
- | Texp_assertfalse -> ()
- | Texp_assert exp ->
- search_pos_expr exp ~pos
- | Texp_lazy exp ->
- search_pos_expr exp ~pos
- | Texp_object (cls, _, _) ->
- search_pos_class_structure ~pos cls
-
- end;
- add_found_str (`Exp(`Expr, exp.exp_type)) ~env:exp.exp_env ~loc:exp.exp_loc
- end
-
-and search_pos_pat ~pos ~env pat =
- if in_loc pat.pat_loc ~pos then begin
- begin match pat.pat_desc with
- Tpat_any -> ()
- | Tpat_var id ->
- add_found_str (`Exp(`Val (Pident id), pat.pat_type))
- ~env ~loc:pat.pat_loc
- | Tpat_alias (pat, _) -> search_pos_pat pat ~pos ~env
- | Tpat_constant _ ->
- add_found_str (`Exp(`Const, pat.pat_type)) ~env ~loc:pat.pat_loc
- | Tpat_tuple l ->
- List.iter l ~f:(search_pos_pat ~pos ~env)
- | Tpat_construct (_, l) ->
- List.iter l ~f:(search_pos_pat ~pos ~env)
- | Tpat_variant (_, None, _) -> ()
- | Tpat_variant (_, Some pat, _) -> search_pos_pat pat ~pos ~env
- | Tpat_record l ->
- List.iter l ~f:(fun (_, pat) -> search_pos_pat pat ~pos ~env)
- | Tpat_array l ->
- List.iter l ~f:(search_pos_pat ~pos ~env)
- | Tpat_or (a, b, None) ->
- search_pos_pat a ~pos ~env; search_pos_pat b ~pos ~env
- | Tpat_or (_, _, Some _) ->
- ()
- end;
- add_found_str (`Exp(`Pat, pat.pat_type)) ~env ~loc:pat.pat_loc
- end
-
-and search_pos_module_expr ~pos m =
- if in_loc m.mod_loc ~pos then begin
- begin match m.mod_desc with
- Tmod_ident path ->
- add_found_str (`Module (path, m.mod_type))
- ~env:m.mod_env ~loc:m.mod_loc
- | Tmod_structure str -> search_pos_structure str ~pos
- | Tmod_functor (_, _, m) -> search_pos_module_expr m ~pos
- | Tmod_apply (a, b, _) ->
- search_pos_module_expr a ~pos; search_pos_module_expr b ~pos
- | Tmod_constraint (m, _, _) -> search_pos_module_expr m ~pos
- end;
- add_found_str (`Module (Pident (Ident.create "M"), m.mod_type))
- ~env:m.mod_env ~loc:m.mod_loc
- end
-
-let search_pos_structure ~pos str =
- observe ~ref:found_str (search_pos_structure ~pos) str
-
-open Stypes
-
-let search_pos_ti ~pos = function
- Ti_pat p -> search_pos_pat ~pos ~env:p.pat_env p
- | Ti_expr e -> search_pos_expr ~pos e
- | Ti_class c -> search_pos_class_expr ~pos c
- | Ti_mod m -> search_pos_module_expr ~pos m
-
-let rec search_pos_info ~pos = function
- [] -> []
- | ti :: l ->
- if in_loc ~pos (get_location ti)
- then observe ~ref:found_str (search_pos_ti ~pos) ti
- else search_pos_info ~pos l
diff --git a/otherlibs/labltk/browser/searchpos.mli b/otherlibs/labltk/browser/searchpos.mli
deleted file mode 100644
index 1da1a877ab..0000000000
--- a/otherlibs/labltk/browser/searchpos.mli
+++ /dev/null
@@ -1,78 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open Widget
-
-val top_widgets : any widget list ref
-
-type module_widgets =
- { mw_frame: frame widget;
- mw_title: label widget option;
- mw_detach: button widget;
- mw_edit: button widget;
- mw_intf: button widget }
-
-val add_shown_module : Path.t -> widgets:module_widgets -> unit
-val find_shown_module : Path.t -> module_widgets
-val is_shown_module : Path.t -> bool
-val default_frame : module_widgets option ref
-val set_path : (Path.t -> sign:Types.signature -> unit) ref
-
-val view_defined_ref : (Longident.t -> env:Env.t -> unit) ref
-val editor_ref :
- (?file:string -> ?pos:int -> ?opendialog:bool -> unit -> unit) ref
-
-val view_signature :
- ?title:string ->
- ?path:Path.t -> ?env:Env.t -> ?detach:bool -> Types.signature -> unit
-val view_signature_item :
- Types.signature -> path:Path.t -> env:Env.t -> unit
-val view_module_id : Longident.t -> env:Env.t -> unit
-val view_type_id : Longident.t -> env:Env.t -> unit
-val view_class_id : Longident.t -> env:Env.t -> unit
-val view_cltype_id : Longident.t -> env:Env.t -> unit
-val view_modtype_id : Longident.t -> env:Env.t -> unit
-val view_type_decl : Path.t -> env:Env.t -> unit
-
-type skind = [`Type|`Class|`Module|`Modtype]
-val search_pos_signature :
- Parsetree.signature -> pos:int -> env:Env.t ->
- ((skind * Longident.t) * Env.t * Location.t) list
-val view_decl : Longident.t -> kind:skind -> env:Env.t -> unit
-val view_decl_menu :
- Longident.t ->
- kind:skind -> env:Env.t -> parent:text widget -> menu widget
-
-type fkind = [
- `Exp of
- [`Expr|`Pat|`Const|`Val of Path.t|`Var of Path.t|`New of Path.t]
- * Types.type_expr
- | `Class of Path.t * Types.class_type
- | `Module of Path.t * Types.module_type
-]
-val search_pos_structure :
- pos:int -> Typedtree.structure_item list ->
- (fkind * Env.t * Location.t) list
-val search_pos_info :
- pos:int -> Stypes.type_info list -> (fkind * Env.t * Location.t) list
-val view_type : fkind -> env:Env.t -> unit
-val view_type_menu : fkind -> env:Env.t -> parent:'a widget -> menu widget
-
-val parent_path : Path.t -> Path.t option
-val string_of_path : Path.t -> string
-val string_of_longident : Longident.t -> string
-val lines_to_chars : int -> text:string -> int
-
diff --git a/otherlibs/labltk/browser/setpath.ml b/otherlibs/labltk/browser/setpath.ml
deleted file mode 100644
index 3e7470dfc3..0000000000
--- a/otherlibs/labltk/browser/setpath.ml
+++ /dev/null
@@ -1,162 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open StdLabels
-open Tk
-
-(* Listboxes *)
-
-let update_hooks = ref []
-
-let add_update_hook f = update_hooks := f :: !update_hooks
-
-let exec_update_hooks () =
- update_hooks := List.filter !update_hooks ~f:
- begin fun f ->
- try f (); true
- with Protocol.TkError _ -> false
- end
-
-let set_load_path l =
- Config.load_path := l;
- exec_update_hooks ()
-
-let get_load_path () = !Config.load_path
-
-let renew_dirs box ~var ~dir =
- Textvariable.set var dir;
- Listbox.delete box ~first:(`Num 0) ~last:`End;
- Listbox.insert box ~index:`End
- ~texts:(Useunix.get_directories_in_files ~path:dir
- (Useunix.get_files_in_directory dir));
- Jg_box.recenter box ~index:(`Num 0)
-
-let renew_path box =
- Listbox.delete box ~first:(`Num 0) ~last:`End;
- Listbox.insert box ~index:`End ~texts:!Config.load_path;
- Jg_box.recenter box ~index:(`Num 0)
-
-let add_to_path ~dirs ?(base="") box =
- let dirs =
- if base = "" then dirs else
- if dirs = [] then [base] else
- List.map dirs ~f:
- begin function
- "." -> base
- | ".." -> Filename.dirname base
- | x -> Filename.concat base x
- end
- in
- set_load_path
- (dirs @ List.fold_left dirs ~init:(get_load_path ())
- ~f:(fun acc x -> List2.exclude x acc))
-
-let remove_path box ~dirs =
- set_load_path
- (List.fold_left dirs ~init:(get_load_path ())
- ~f:(fun acc x -> List2.exclude x acc))
-
-(* main function *)
-
-let f ~dir =
- let current_dir = ref dir in
- let tl = Jg_toplevel.titled "Edit Load Path" in
- Jg_bind.escape_destroy tl;
- let var_dir = Textvariable.create ~on:tl () in
- let caplab = Label.create tl ~text:"Path"
- and dir_name = Entry.create tl ~textvariable:var_dir
- and browse = Frame.create tl in
- let dirs = Frame.create browse
- and path = Frame.create browse in
- let dirframe, dirbox, dirsb = Jg_box.create_with_scrollbar dirs
- and pathframe, pathbox, pathsb = Jg_box.create_with_scrollbar path
- in
- add_update_hook (fun () -> renew_path pathbox);
- Listbox.configure pathbox ~width:40 ~selectmode:`Multiple;
- Listbox.configure dirbox ~selectmode:`Multiple;
- Jg_box.add_completion dirbox ~action:
- begin fun index ->
- begin match Listbox.get dirbox ~index with
- "." -> ()
- | ".." -> current_dir := Filename.dirname !current_dir
- | x -> current_dir := !current_dir ^ "/" ^ x
- end;
- renew_dirs dirbox ~var:var_dir ~dir:!current_dir;
- Listbox.selection_clear dirbox ~first:(`Num 0) ~last:`End
- end;
- Jg_box.add_completion pathbox ~action:
- begin fun index ->
- current_dir := Listbox.get pathbox ~index;
- renew_dirs dirbox ~var:var_dir ~dir:!current_dir
- end;
-
- bind dir_name ~events:[`KeyPressDetail"Return"]
- ~action:(fun _ ->
- let dir = Textvariable.get var_dir in
- if Useunix.is_directory dir then begin
- current_dir := dir;
- renew_dirs dirbox ~var:var_dir ~dir
- end);
-
- (* Avoid space being used by the completion mechanism *)
- let bind_space_toggle lb =
- bind lb ~events:[`KeyPressDetail "space"] ~extend:true ~action:ignore in
- bind_space_toggle dirbox;
- bind_space_toggle pathbox;
-
- let add_paths _ =
- add_to_path pathbox ~base:!current_dir
- ~dirs:(List.map (Listbox.curselection dirbox)
- ~f:(fun x -> Listbox.get dirbox ~index:x));
- Listbox.selection_clear dirbox ~first:(`Num 0) ~last:`End
- and remove_paths _ =
- remove_path pathbox
- ~dirs:(List.map (Listbox.curselection pathbox)
- ~f:(fun x -> Listbox.get pathbox ~index:x))
- in
- bind dirbox ~events:[`KeyPressDetail "Insert"] ~action:add_paths;
- bind pathbox ~events:[`KeyPressDetail "Delete"] ~action:remove_paths;
-
- let dirlab = Label.create dirs ~text:"Directories"
- and pathlab = Label.create path ~text:"Load path"
- and addbutton = Button.create dirs ~text:"Add to path" ~command:add_paths
- and pathbuttons = Frame.create path in
- let removebutton =
- Button.create pathbuttons ~text:"Remove from path" ~command:remove_paths
- and ok =
- Jg_button.create_destroyer tl ~parent:pathbuttons
- in
- renew_dirs dirbox ~var:var_dir ~dir:!current_dir;
- renew_path pathbox;
- pack [dirsb] ~side:`Right ~fill:`Y;
- pack [dirbox] ~side:`Left ~fill:`Y ~expand:true;
- pack [pathsb] ~side:`Right ~fill:`Y;
- pack [pathbox] ~side:`Left ~fill:`Both ~expand:true;
- pack [dirlab] ~side:`Top ~anchor:`W ~padx:10;
- pack [addbutton] ~side:`Bottom ~fill:`X;
- pack [dirframe] ~fill:`Y ~expand:true;
- pack [pathlab] ~side:`Top ~anchor:`W ~padx:10;
- pack [removebutton; ok] ~side:`Left ~fill:`X ~expand:true;
- pack [pathbuttons] ~fill:`X ~side:`Bottom;
- pack [pathframe] ~fill:`Both ~expand:true;
- pack [dirs] ~side:`Left ~fill:`Y;
- pack [path] ~side:`Right ~fill:`Both ~expand:true;
- pack [caplab] ~side:`Top ~anchor:`W ~padx:10;
- pack [dir_name] ~side:`Top ~anchor:`W ~fill:`X;
- pack [browse] ~side:`Bottom ~expand:true ~fill:`Both;
- tl
-
-let set ~dir = ignore (f ~dir);;
diff --git a/otherlibs/labltk/browser/setpath.mli b/otherlibs/labltk/browser/setpath.mli
deleted file mode 100644
index f5e70090fd..0000000000
--- a/otherlibs/labltk/browser/setpath.mli
+++ /dev/null
@@ -1,25 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open Widget
-
-val add_update_hook : (unit -> unit) -> unit
-val exec_update_hooks : unit -> unit
- (* things to do when Config.load_path changes *)
-
-val set : dir:string -> unit
-val f : dir:string -> toplevel widget
- (* edit the load path *)
diff --git a/otherlibs/labltk/browser/shell.ml b/otherlibs/labltk/browser/shell.ml
deleted file mode 100644
index 18e1f34945..0000000000
--- a/otherlibs/labltk/browser/shell.ml
+++ /dev/null
@@ -1,367 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open StdLabels
-module Unix = UnixLabels
-open Tk
-open Jg_tk
-open Dummy
-
-(* Here again, memoize regexps *)
-
-let (~!) = Jg_memo.fast ~f:Str.regexp
-
-(* Nice history class. May reuse *)
-
-class ['a] history () = object
- val mutable history = ([] : 'a list)
- val mutable count = 0
- method empty = history = []
- method add s = count <- 0; history <- s :: history
- method previous =
- let s = List.nth history count in
- count <- (count + 1) mod List.length history;
- s
- method next =
- let l = List.length history in
- count <- (l + count - 1) mod l;
- List.nth history ((l + count - 1) mod l)
-end
-
-let dump_handle (h : Unix.file_descr) =
- let obj = Obj.repr h in
- if Obj.is_int obj || Obj.tag obj <> Obj.custom_tag then
- invalid_arg "Shell.dump_handle";
- Nativeint.format "%x" (Obj.obj obj)
-
-(* The shell class. Now encapsulated *)
-
-let protect f x = try f x with _ -> ()
-
-let is_win32 = Sys.os_type = "Win32"
-let use_threads = is_win32
-let use_sigpipe = is_win32
-
-class shell ~textw ~prog ~args ~env ~history =
- let (in2,out1) = Unix.pipe ()
- and (in1,out2) = Unix.pipe ()
- and (err1,err2) = Unix.pipe ()
- and (sig2,sig1) = Unix.pipe () in
-object (self)
- val pid =
- let env =
- if use_sigpipe then
- let sigdef = "CAMLSIGPIPE=" ^ dump_handle sig2 in
- Array.append env [|sigdef|]
- else env
- in
- Unix.create_process_env ~prog ~args ~env
- ~stdin:in2 ~stdout:out2 ~stderr:err2
- val out = Unix.out_channel_of_descr out1
- val h : _ history = history
- val mutable alive = true
- val mutable reading = false
- val ibuffer = Buffer.create 1024
- val imutex = Mutex.create ()
- val mutable ithreads = []
- method alive = alive
- method kill =
- if Winfo.exists textw then Text.configure textw ~state:`Disabled;
- if alive then begin
- alive <- false;
- protect close_out out;
- try
- if use_sigpipe then ignore (Unix.write sig1 ~buf:"T" ~pos:0 ~len:1);
- List.iter ~f:(protect Unix.close) [in1; err1; sig1; sig2];
- if not use_threads then begin
- Fileevent.remove_fileinput ~fd:in1;
- Fileevent.remove_fileinput ~fd:err1;
- end;
- if not use_sigpipe then begin
- Unix.kill ~pid ~signal:Sys.sigkill;
- ignore (Unix.waitpid ~mode:[] pid)
- end
- with _ -> ()
- end
- method interrupt =
- if alive then try
- reading <- false;
- if use_sigpipe then begin
- ignore (Unix.write sig1 ~buf:"C" ~pos:0 ~len:1);
- self#send " "
- end else
- Unix.kill ~pid ~signal:Sys.sigint
- with Unix.Unix_error _ -> ()
- method send s =
- if alive then try
- output_string out s;
- flush out
- with Sys_error _ -> ()
- method private read ~fd ~len =
- begin try
- let buf = String.create len in
- let len = Unix.read fd ~buf ~pos:0 ~len in
- if len > 0 then begin
- self#insert (String.sub buf ~pos:0 ~len);
- Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Char(-1)])
- end;
- len
- with Unix.Unix_error _ -> 0
- end;
- method history (dir : [`Next|`Previous]) =
- if not h#empty then begin
- if reading then begin
- Text.delete textw ~start:(`Mark"input",[`Char 1])
- ~stop:(`Mark"insert",[])
- end else begin
- reading <- true;
- Text.mark_set textw ~mark:"input"
- ~index:(`Mark"insert",[`Char(-1)])
- end;
- self#insert (if dir = `Previous then h#previous else h#next)
- end
- method private lex ?(start = `Mark"insert",[`Linestart])
- ?(stop = `Mark"insert",[`Lineend]) () =
- Lexical.tag textw ~start ~stop
- method insert text =
- let idx = Text.index textw
- ~index:(`Mark"insert",[`Char(-1);`Linestart]) in
- Text.insert textw ~text ~index:(`Mark"insert",[]);
- self#lex ~start:(idx,[`Linestart]) ();
- Text.see textw ~index:(`Mark"insert",[])
- method private keypress c =
- if not reading && c > " " then begin
- reading <- true;
- Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Char(-1)])
- end
- method private keyrelease c = if c <> "" then self#lex ()
- method private return =
- if reading then reading <- false
- else Text.mark_set textw ~mark:"input"
- ~index:(`Mark"insert",[`Linestart;`Char 1]);
- Text.mark_set textw ~mark:"insert"~index:(`Mark"insert",[`Line 1]);
- self#lex ~start:(`Mark"input",[`Linestart]) ();
- let s =
- (* input is one character before real input *)
- Text.get textw ~start:(`Mark"input",[`Char 1])
- ~stop:(`Mark"insert",[]) in
- h#add s;
- Text.insert textw ~index:(`Mark"insert",[]) ~text:"\n";
- Text.yview_index textw ~index:(`Mark"insert",[]);
- self#send s;
- self#send "\n"
- method private paste ev =
- if not reading then begin
- reading <- true;
- Text.mark_set textw ~mark:"input"
- ~index:(`Atxy(ev.ev_MouseX, ev.ev_MouseY),[`Char(-1)])
- end
- initializer
- Lexical.init_tags textw;
- let rec bindings =
- [ ([], `KeyPress, [`Char], fun ev -> self#keypress ev.ev_Char);
- ([], `KeyRelease, [`Char], fun ev -> self#keyrelease ev.ev_Char);
- (* [], `KeyPressDetail"Return", [], fun _ -> self#return; *)
- ([], `ButtonPressDetail 2, [`MouseX; `MouseY], self#paste);
- ([`Alt], `KeyPressDetail"p", [], fun _ -> self#history `Previous);
- ([`Alt], `KeyPressDetail"n", [], fun _ -> self#history `Next);
- ([`Meta], `KeyPressDetail"p", [], fun _ -> self#history `Previous);
- ([`Meta], `KeyPressDetail"n", [], fun _ -> self#history `Next);
- ([`Control], `KeyPressDetail"c", [], fun _ -> self#interrupt);
- ([], `Destroy, [], fun _ -> self#kill) ]
- in
- List.iter bindings ~f:
- begin fun (modif,event,fields,action) ->
- bind textw ~events:[`Modified(modif,event)] ~fields ~action
- end;
- bind textw ~events:[`KeyPressDetail"Return"] ~breakable:true
- ~action:(fun _ -> self#return; break());
- List.iter ~f:Unix.close [in2;out2;err2];
- if use_threads then begin
- let fileinput_thread fd =
- let buf = String.create 1024 in
- let len = ref 0 in
- try while len := Unix.read fd ~buf ~pos:0 ~len:1024; !len > 0 do
- Mutex.lock imutex;
- Buffer.add_substring ibuffer buf 0 !len;
- Mutex.unlock imutex
- done with Unix.Unix_error _ -> ()
- in
- ithreads <- List.map [in1; err1] ~f:(Thread.create fileinput_thread);
- let rec read_buffer () =
- Mutex.lock imutex;
- if Buffer.length ibuffer > 0 then begin
- self#insert (Str.global_replace ~!"\r\n" "\n"
- (Buffer.contents ibuffer));
- Buffer.reset ibuffer;
- Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Char(-1)])
- end;
- Mutex.unlock imutex;
- Timer.set ~ms:100 ~callback:read_buffer
- in
- read_buffer ()
- end else begin
- try
- List.iter [in1;err1] ~f:
- begin fun fd ->
- Fileevent.add_fileinput ~fd
- ~callback:(fun () -> ignore (self#read ~fd ~len:1024))
- end
- with _ -> ()
- end
-end
-
-(* Specific use of shell, for OCamlBrowser *)
-
-let shells : (string * shell) list ref = ref []
-
-(* Called before exiting *)
-let kill_all () =
- List.iter !shells ~f:(fun (_,sh) -> if sh#alive then sh#kill);
- shells := []
-
-let get_all () =
- let all = List.filter !shells ~f:(fun (_,sh) -> sh#alive) in
- shells := all;
- all
-
-let may_exec_unix prog =
- try Unix.access prog ~perm:[Unix.X_OK]; prog
- with Unix.Unix_error _ -> ""
-
-let may_exec_win prog =
- let has_ext =
- List.exists ~f:(Filename.check_suffix prog) ["exe"; "com"; "bat"] in
- if has_ext then may_exec_unix prog else
- List.fold_left [prog^".bat"; prog^".exe"; prog^".com"] ~init:""
- ~f:(fun res prog -> if res = "" then may_exec_unix prog else res)
-
-let may_exec =
- if is_win32 then may_exec_win else may_exec_unix
-
-let path_sep = if is_win32 then ";" else ":"
-
-let warnings = ref "Al"
-
-let program_not_found prog =
- Jg_message.info ~title:"Error"
- ("Program \"" ^ prog ^ "\"\nwas not found in path")
-
-let protect_arg s =
- if String.contains s ' ' then "\"" ^ s ^ "\"" else s
-
-let f ~prog ~title =
- let progargs =
- List.filter ~f:((<>) "") (Str.split ~!" " prog) in
- if progargs = [] then () else
- let prog = List.hd progargs in
- let path =
- try Sys.getenv "PATH" with Not_found -> "/bin" ^ path_sep ^ "/usr/bin" in
- let exec_path = Str.split ~!path_sep path in
- let exec_path = if is_win32 then "."::exec_path else exec_path in
- let progpath =
- if not (Filename.is_implicit prog) then may_exec prog else
- List.fold_left exec_path ~init:"" ~f:
- (fun res dir ->
- if res = "" then may_exec (Filename.concat dir prog) else res) in
- if progpath = "" then program_not_found prog else
- let tl = Jg_toplevel.titled title in
- let menus = Frame.create tl ~name:"menubar" in
- let file_menu = new Jg_menu.c "File" ~parent:menus
- and history_menu = new Jg_menu.c "History" ~parent:menus
- and signal_menu = new Jg_menu.c "Signal" ~parent:menus in
- pack [menus] ~side:`Top ~fill:`X;
- pack [file_menu#button; history_menu#button; signal_menu#button]
- ~side:`Left ~ipadx:5 ~anchor:`W;
- let frame, tw, sb = Jg_text.create_with_scrollbar tl in
- Text.configure tw ~background:`White;
- pack [sb] ~fill:`Y ~side:`Right;
- pack [tw] ~fill:`Both ~expand:true ~side:`Left;
- pack [frame] ~fill:`Both ~expand:true;
- let env = Array.map (Unix.environment ()) ~f:
- begin fun s ->
- if Str.string_match ~!"TERM=" s 0 then "TERM=dumb" else s
- end in
- let load_path =
- List2.flat_map !Config.load_path ~f:(fun dir -> ["-I"; dir]) in
- let load_path =
- if is_win32 then List.map ~f:protect_arg load_path else load_path in
- let labels = if !Clflags.classic then ["-nolabels"] else [] in
- let rectypes = if !Clflags.recursive_types then ["-rectypes"] else [] in
- let warnings =
- if List.mem "-w" progargs || !warnings = "Al" then []
- else ["-w"; !warnings]
- in
- let args =
- Array.of_list (progargs @ labels @ warnings @ rectypes @ load_path) in
- let history = new history () in
- let start_shell () =
- let sh = new shell ~textw:tw ~prog:progpath ~env ~args ~history in
- shells := (title, sh) :: !shells;
- sh
- in
- let sh = ref (start_shell ()) in
- let current_dir = ref (Unix.getcwd ()) in
- file_menu#add_command "Restart" ~command:
- begin fun () ->
- (!sh)#kill;
- Text.configure tw ~state:`Normal;
- Text.insert tw ~index:(`End,[]) ~text:"\n";
- Text.see tw ~index:(`End,[]);
- Text.mark_set tw ~mark:"insert" ~index:(`End,[]);
- sh := start_shell ();
- end;
- file_menu#add_command "Use..." ~command:
- begin fun () ->
- Fileselect.f ~title:"Use File" ~filter:"*.ml"
- ~sync:true ~dir:!current_dir ()
- ~action:(fun l ->
- if l = [] then () else
- let name = Fileselect.caml_dir (List.hd l) in
- current_dir := Filename.dirname name;
- if Filename.check_suffix name ".ml"
- then
- let cmd = "#use \"" ^ String.escaped name ^ "\";;\n" in
- (!sh)#insert cmd; (!sh)#send cmd)
- end;
- file_menu#add_command "Load..." ~command:
- begin fun () ->
- Fileselect.f ~title:"Load File" ~filter:"*.cm[oa]" ~sync:true ()
- ~dir:!current_dir
- ~action:(fun l ->
- if l = [] then () else
- let name = Fileselect.caml_dir (List.hd l) in
- current_dir := Filename.dirname name;
- if Filename.check_suffix name ".cmo" ||
- Filename.check_suffix name ".cma"
- then
- let cmd = "#load \"" ^ String.escaped name ^ "\";;\n" in
- (!sh)#insert cmd; (!sh)#send cmd)
- end;
- file_menu#add_command "Import path" ~command:
- begin fun () ->
- List.iter (List.rev !Config.load_path) ~f:
- (fun dir ->
- (!sh)#send ("#directory \"" ^ String.escaped dir ^ "\";;\n"))
- end;
- file_menu#add_command "Close" ~command:(fun () -> destroy tl);
- history_menu#add_command "Previous " ~accelerator:"M-p"
- ~command:(fun () -> (!sh)#history `Previous);
- history_menu#add_command "Next" ~accelerator:"M-n"
- ~command:(fun () -> (!sh)#history `Next);
- signal_menu#add_command "Interrupt " ~accelerator:"C-c"
- ~command:(fun () -> (!sh)#interrupt);
- signal_menu#add_command "Kill" ~command:(fun () -> (!sh)#kill)
diff --git a/otherlibs/labltk/browser/shell.mli b/otherlibs/labltk/browser/shell.mli
deleted file mode 100644
index ac94f43d7c..0000000000
--- a/otherlibs/labltk/browser/shell.mli
+++ /dev/null
@@ -1,46 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-class ['a] history :
- unit ->
- object
- val mutable count : int
- val mutable history : 'a list
- method add : 'a -> unit
- method empty : bool
- method next : 'a
- method previous : 'a
- end
-
-(* toplevel shell *)
-
-class shell :
- textw:Widget.text Widget.widget -> prog:string ->
- args:string array -> env:string array -> history:string history ->
- object
- method alive : bool
- method kill : unit
- method interrupt : unit
- method insert : string -> unit
- method send : string -> unit
- method history : [`Next|`Previous] -> unit
- end
-
-val kill_all : unit -> unit
-val get_all : unit -> (string * shell) list
-val warnings : string ref
-
-val f : prog:string -> title:string -> unit
diff --git a/otherlibs/labltk/browser/typecheck.ml b/otherlibs/labltk/browser/typecheck.ml
deleted file mode 100644
index 8199e46103..0000000000
--- a/otherlibs/labltk/browser/typecheck.ml
+++ /dev/null
@@ -1,181 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open StdLabels
-open Tk
-open Parsetree
-open Location
-open Jg_tk
-open Mytypes
-
-(* Optionally preprocess a source file *)
-
-let preprocess ~pp ~ext text =
- let sourcefile = Filename.temp_file "caml" ext in
- begin try
- let oc = open_out_bin sourcefile in
- output_string oc text;
- flush oc;
- close_out oc
- with _ ->
- failwith "Preprocessing error"
- end;
- let tmpfile = Filename.temp_file "camlpp" ext in
- let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in
- if Ccomp.command comm <> 0 then begin
- Sys.remove sourcefile;
- Sys.remove tmpfile;
- failwith "Preprocessing error"
- end;
- Sys.remove sourcefile;
- tmpfile
-
-exception Outdated_version
-
-let parse_pp ~parse ~wrap ~ext text =
- match !Clflags.preprocessor with
- None -> parse (Lexing.from_string text)
- | Some pp ->
- let tmpfile = preprocess ~pp ~ext text in
- let ast_magic =
- if ext = ".ml" then Config.ast_impl_magic_number
- else Config.ast_intf_magic_number in
- let ic = open_in_bin tmpfile in
- let ast =
- try
- let buffer = String.create (String.length ast_magic) in
- really_input ic buffer 0 (String.length ast_magic);
- if buffer = ast_magic then begin
- ignore (input_value ic);
- wrap (input_value ic)
- end else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then
- raise Outdated_version
- else
- raise Exit
- with
- Outdated_version ->
- close_in ic;
- Sys.remove tmpfile;
- failwith "Ocaml and preprocessor have incompatible versions"
- | _ ->
- seek_in ic 0;
- parse (Lexing.from_channel ic)
- in
- close_in ic;
- Sys.remove tmpfile;
- ast
-
-let nowarnings = ref false
-
-let f txt =
- let error_messages = ref [] in
- let text = Jg_text.get_all txt.tw
- and env = ref (Env.open_pers_signature "Pervasives" Env.initial) in
- let tl, ew, end_message =
- Jg_message.formatted ~title:"Warnings" ~ppf:Format.err_formatter () in
- Text.tag_remove txt.tw ~tag:"error" ~start:tstart ~stop:tend;
- txt.structure <- [];
- txt.type_info <- [];
- txt.signature <- [];
- txt.psignature <- [];
- ignore (Stypes.get_info ());
- Clflags.save_types := true;
-
- begin try
-
- if Filename.check_suffix txt.name ".mli" then
- let psign = parse_pp text ~ext:".mli"
- ~parse:Parse.interface ~wrap:(fun x -> x) in
- txt.psignature <- psign;
- txt.signature <- Typemod.transl_signature !env psign
-
- else (* others are interpreted as .ml *)
-
- let psl = parse_pp text ~ext:".ml"
- ~parse:Parse.use_file ~wrap:(fun x -> [Parsetree.Ptop_def x]) in
- List.iter psl ~f:
- begin function
- Ptop_def pstr ->
- let str, sign, env' = Typemod.type_structure !env pstr in
- txt.structure <- txt.structure @ str;
- txt.signature <- txt.signature @ sign;
- env := env'
- | Ptop_dir _ -> ()
- end;
- txt.type_info <- Stypes.get_info ();
-
- with
- Lexer.Error _ | Syntaxerr.Error _
- | Typecore.Error _ | Typemod.Error _
- | Typeclass.Error _ | Typedecl.Error _
- | Typetexp.Error _ | Includemod.Error _
- | Env.Error _ | Ctype.Tags _ | Failure _ as exn ->
- txt.type_info <- Stypes.get_info ();
- let et, ew, end_message = Jg_message.formatted ~title:"Error !" () in
- error_messages := et :: !error_messages;
- let range = match exn with
- Lexer.Error (err, l) ->
- Lexer.report_error Format.std_formatter err; l
- | Syntaxerr.Error err ->
- Syntaxerr.report_error Format.std_formatter err;
- begin match err with
- Syntaxerr.Unclosed(l,_,_,_) -> l
- | Syntaxerr.Other l -> l
- end
- | Typecore.Error (l,err) ->
- Typecore.report_error Format.std_formatter err; l
- | Typeclass.Error (l,err) ->
- Typeclass.report_error Format.std_formatter err; l
- | Typedecl.Error (l, err) ->
- Typedecl.report_error Format.std_formatter err; l
- | Typemod.Error (l,err) ->
- Typemod.report_error Format.std_formatter err; l
- | Typetexp.Error (l,err) ->
- Typetexp.report_error Format.std_formatter err; l
- | Includemod.Error errl ->
- Includemod.report_error Format.std_formatter errl; Location.none
- | Env.Error err ->
- Env.report_error Format.std_formatter err; Location.none
- | Ctype.Tags(l, l') ->
- Format.printf "In this program,@ variant constructors@ `%s and `%s@ have same hash value.@." l l';
- Location.none
- | Failure s ->
- Format.printf "%s.@." s; Location.none
- | _ -> assert false
- in
- end_message ();
- let s = range.loc_start.Lexing.pos_cnum in
- let e = range.loc_end.Lexing.pos_cnum in
- if s < e then
- Jg_text.tag_and_see txt.tw ~start:(tpos s) ~stop:(tpos e) ~tag:"error"
- end;
- end_message ();
- if !nowarnings || Text.index ew ~index:tend = `Linechar (2,0)
- then destroy tl
- else begin
- error_messages := tl :: !error_messages;
- Text.configure ew ~state:`Disabled;
- bind ew ~events:[`Modified([`Double], `ButtonReleaseDetail 1)]
- ~action:(fun _ ->
- try
- let start, ende = Text.tag_nextrange ew ~tag:"sel" ~start:(tpos 0) in
- let s = Text.get ew ~start:(start,[]) ~stop:(ende,[]) in
- let n = int_of_string s in
- Text.mark_set txt.tw ~index:(tpos n) ~mark:"insert";
- Text.see txt.tw ~index:(`Mark "insert", [])
- with _ -> ())
- end;
- !error_messages
diff --git a/otherlibs/labltk/browser/typecheck.mli b/otherlibs/labltk/browser/typecheck.mli
deleted file mode 100644
index d61fce62e3..0000000000
--- a/otherlibs/labltk/browser/typecheck.mli
+++ /dev/null
@@ -1,23 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open Widget
-open Mytypes
-
-val nowarnings : bool ref
-
-val f : edit_window -> any widget list
- (* Typechecks the window as much as possible *)
diff --git a/otherlibs/labltk/browser/useunix.ml b/otherlibs/labltk/browser/useunix.ml
deleted file mode 100644
index 4998bbd66c..0000000000
--- a/otherlibs/labltk/browser/useunix.ml
+++ /dev/null
@@ -1,69 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open StdLabels
-open UnixLabels
-
-let get_files_in_directory dir =
- let len = String.length dir in
- let dir =
- if len > 0 && Sys.os_type = "Win32" &&
- (dir.[len-1] = '/' || dir.[len-1] = '\\')
- then String.sub dir ~pos:0 ~len:(len-1)
- else dir
- in match
- try Some(opendir dir) with Unix_error _ -> None
- with
- None -> []
- | Some dirh ->
- let rec get_them l =
- match
- try Some(readdir dirh) with _ -> None
- with
- | Some x ->
- get_them (x::l)
- | None ->
- closedir dirh; l
- in
- List.sort ~cmp:compare (get_them [])
-
-let is_directory name =
- try
- (stat name).st_kind = S_DIR
- with _ -> false
-
-let concat dir name =
- let len = String.length dir in
- if len = 0 then name else
- if dir.[len-1] = '/' then dir ^ name
- else dir ^ "/" ^ name
-
-let get_directories_in_files ~path =
- List.filter ~f:(fun x -> is_directory (concat path x))
-
-(************************************************** Subshell call *)
-let subshell ~cmd =
- let rc = open_process_in cmd in
- let rec it l =
- match
- try Some(input_line rc) with _ -> None
- with
- Some x -> it (x::l)
- | None -> List.rev l
- in
- let answer = it [] in
- ignore (close_process_in rc);
- answer
diff --git a/otherlibs/labltk/browser/useunix.mli b/otherlibs/labltk/browser/useunix.mli
deleted file mode 100644
index 2850c0d2da..0000000000
--- a/otherlibs/labltk/browser/useunix.mli
+++ /dev/null
@@ -1,23 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-(* Unix utilities *)
-
-val get_files_in_directory : string -> string list
-val is_directory : string -> bool
-val concat : string -> string -> string
-val get_directories_in_files : path:string -> string list -> string list
-val subshell : cmd:string -> string list
diff --git a/otherlibs/labltk/browser/viewer.ml b/otherlibs/labltk/browser/viewer.ml
deleted file mode 100644
index 2d21f42f00..0000000000
--- a/otherlibs/labltk/browser/viewer.ml
+++ /dev/null
@@ -1,636 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-open StdLabels
-open Tk
-open Jg_tk
-open Mytypes
-open Longident
-open Types
-open Typedtree
-open Env
-open Searchpos
-open Searchid
-
-(* Managing the module list *)
-
-let list_modules ~path =
- List.fold_left path ~init:[] ~f:
- begin fun modules dir ->
- let l =
- List.filter (Useunix.get_files_in_directory dir)
- ~f:(fun x -> Filename.check_suffix x ".cmi") in
- let l = List.map l ~f:
- begin fun x ->
- String.capitalize (Filename.chop_suffix x ".cmi")
- end in
- List.fold_left l ~init:modules
- ~f:(fun modules item ->
- if List.mem item modules then modules else item :: modules)
- end
-
-let reset_modules box =
- Listbox.delete box ~first:(`Num 0) ~last:`End;
- module_list := Sort.list (Jg_completion.lt_string ~nocase:true)
- (list_modules ~path:!Config.load_path);
- Listbox.insert box ~index:`End ~texts:!module_list;
- Jg_box.recenter box ~index:(`Num 0)
-
-
-(* How to display a symbol *)
-
-let view_symbol ~kind ~env ?path id =
- let name = match id with
- Lident x -> x
- | Ldot (_, x) -> x
- | _ -> match kind with Pvalue | Ptype | Plabel -> "z" | _ -> "Z"
- in
- match kind with
- Pvalue ->
- let path, vd = lookup_value id env in
- view_signature_item ~path ~env [Tsig_value (Ident.create name, vd)]
- | Ptype -> view_type_id id ~env
- | Plabel -> let ld = lookup_label id env in
- begin match ld.lbl_res.desc with
- Tconstr (path, _, _) -> view_type_decl path ~env
- | _ -> ()
- end
- | Pconstructor ->
- let cd = lookup_constructor id env in
- begin match cd.cstr_res.desc with
- Tconstr (cpath, _, _) ->
- if Path.same cpath Predef.path_exn then
- view_signature ~title:(string_of_longident id) ~env ?path
- [Tsig_exception (Ident.create name, cd.cstr_args)]
- else
- view_type_decl cpath ~env
- | _ -> ()
- end
- | Pmodule -> view_module_id id ~env
- | Pmodtype -> view_modtype_id id ~env
- | Pclass -> view_class_id id ~env
- | Pcltype -> view_cltype_id id ~env
-
-
-(* Create a list of symbols you can choose from *)
-
-let choose_symbol ~title ~env ?signature ?path l =
- if match path with
- None -> false
- | Some path -> is_shown_module path
- then () else
- let tl = Jg_toplevel.titled title in
- Jg_bind.escape_destroy tl;
- top_widgets := coe tl :: !top_widgets;
- let buttons = Frame.create tl in
- let all = Button.create buttons ~text:"Show all" ~padx:20
- and ok = Jg_button.create_destroyer tl ~parent:buttons
- and detach = Button.create buttons ~text:"Detach"
- and edit = Button.create buttons ~text:"Impl"
- and intf = Button.create buttons ~text:"Intf" in
- let l = List.sort l ~cmp:(fun (li1, _) (li2,_) -> compare li1 li2) in
- let nl = List.map l ~f:
- begin fun (li, k) ->
- string_of_longident li ^ " (" ^ string_of_kind k ^ ")"
- end in
- let fb = Frame.create tl in
- let box =
- new Jg_multibox.c fb ~cols:3 ~texts:nl ~maxheight:3 ~width:21 in
- box#init;
- box#bind_kbd ~events:[`KeyPressDetail"Escape"]
- ~action:(fun _ ~index -> destroy tl; break ());
- if List.length nl > 9 then ignore (Jg_multibox.add_scrollbar box);
- Jg_multibox.add_completion box ~action:
- begin fun pos ->
- let li, k = List.nth l pos in
- let path =
- match path, li with
- None, Ldot (lip, _) ->
- begin try
- Some (fst (lookup_module lip env))
- with Not_found -> None
- end
- | _ -> path
- in view_symbol li ~kind:k ~env ?path
- end;
- pack [buttons] ~side:`Bottom ~fill:`X;
- pack [fb] ~side:`Top ~fill:`Both ~expand:true;
- begin match signature with
- None -> pack [ok] ~fill:`X ~expand:true
- | Some signature ->
- Button.configure all ~command:
- begin fun () ->
- view_signature signature ~title ~env ?path
- end;
- pack [ok; all] ~side:`Right ~fill:`X ~expand:true
- end;
- begin match path with None -> ()
- | Some path ->
- let frame = Frame.create tl in
- pack [frame] ~side:`Bottom ~fill:`X;
- add_shown_module path
- ~widgets:{ mw_frame = frame; mw_title = None; mw_detach = detach;
- mw_edit = edit; mw_intf = intf }
- end
-
-let choose_symbol_ref = ref choose_symbol
-
-
-(* Search, both by type and name *)
-
-let guess_search_mode s : [`Type | `Long | `Pattern] =
- let is_type = ref false and is_long = ref false in
- for i = 0 to String.length s - 2 do
- if s.[i] = '-' && s.[i+1] = '>' then is_type := true;
- if s.[i] = '.' then is_long := true
- done;
- if !is_type then `Type else if !is_long then `Long else `Pattern
-
-
-let search_string ?(mode="symbol") ew =
- let text = Entry.get ew in
- try
- if text = "" then () else
- let l = match mode with
- "Name" ->
- begin match guess_search_mode text with
- `Long -> search_string_symbol text
- | `Pattern -> search_pattern_symbol text
- | `Type -> search_string_type text ~mode:`Included
- end
- | "Type" -> search_string_type text ~mode:`Included
- | "Exact" -> search_string_type text ~mode:`Exact
- | _ -> assert false
- in
- match l with [] -> ()
- | [lid,kind] -> view_symbol lid ~kind ~env:!start_env
- | l -> choose_symbol ~title:"Choose symbol" ~env:!start_env l
- with Searchid.Error (s,e) ->
- Entry.icursor ew ~index:(`Num s)
-
-let search_which = ref "Name"
-
-let search_symbol () =
- if !module_list = [] then
- module_list := List.sort ~cmp:compare (list_modules ~path:!Config.load_path);
- let tl = Jg_toplevel.titled "Search symbol" in
- Jg_bind.escape_destroy tl;
- let ew = Entry.create tl ~width:30 in
- let choice = Frame.create tl
- and which = Textvariable.create ~on:tl () in
- let itself = Radiobutton.create choice ~text:"Itself"
- ~variable:which ~value:"Name"
- and extype = Radiobutton.create choice ~text:"Exact type"
- ~variable:which ~value:"Exact"
- and iotype = Radiobutton.create choice ~text:"Included type"
- ~variable:which ~value:"Type"
- and buttons = Frame.create tl in
- let search = Button.create buttons ~text:"Search" ~command:
- begin fun () ->
- search_which := Textvariable.get which;
- search_string ew ~mode:!search_which
- end
- and ok = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" in
-
- Focus.set ew;
- Jg_bind.return_invoke ew ~button:search;
- Textvariable.set which !search_which;
- pack [itself; extype; iotype] ~side:`Left ~anchor:`W;
- pack [search; ok] ~side:`Left ~fill:`X ~expand:true;
- pack [coe ew; coe choice; coe buttons]
- ~side:`Top ~fill:`X ~expand:true
-
-
-(* Display the contents of a module *)
-
-let ident_of_decl ~modlid = function
- Tsig_value (id, _) -> Lident (Ident.name id), Pvalue
- | Tsig_type (id, _) -> Lident (Ident.name id), Ptype
- | Tsig_exception (id, _) -> Ldot (modlid, Ident.name id), Pconstructor
- | Tsig_module (id, _) -> Lident (Ident.name id), Pmodule
- | Tsig_modtype (id, _) -> Lident (Ident.name id), Pmodtype
- | Tsig_class (id, _) -> Lident (Ident.name id), Pclass
- | Tsig_cltype (id, _) -> Lident (Ident.name id), Pcltype
-
-let view_defined ~env ?(show_all=false) modlid =
- try match lookup_module modlid env with path, Tmty_signature sign ->
- let rec iter_sign sign idents =
- match sign with
- [] -> List.rev idents
- | decl :: rem ->
- let rem = match decl, rem with
- Tsig_class _, cty :: ty1 :: ty2 :: rem -> rem
- | Tsig_cltype _, ty1 :: ty2 :: rem -> rem
- | _, rem -> rem
- in iter_sign rem (ident_of_decl ~modlid decl :: idents)
- in
- let l = iter_sign sign [] in
- let title = string_of_path path in
- let env = open_signature path sign env in
- !choose_symbol_ref l ~title ~signature:sign ~env ~path;
- if show_all then view_signature sign ~title ~env ~path
- | _ -> ()
- with Not_found -> ()
- | Env.Error err ->
- let tl, tw, finish = Jg_message.formatted ~title:"Error!" () in
- Env.report_error Format.std_formatter err;
- finish ()
-
-
-(* Manage toplevel windows *)
-
-let close_all_views () =
- List.iter !top_widgets
- ~f:(fun tl -> try destroy tl with Protocol.TkError _ -> ());
- top_widgets := []
-
-
-(* Launch a shell *)
-
-let shell_counter = ref 1
-let default_shell = ref "ocaml"
-
-let start_shell master =
- let tl = Jg_toplevel.titled "Start New Shell" in
- Wm.transient_set tl ~master;
- let input = Frame.create tl
- and buttons = Frame.create tl in
- let ok = Button.create buttons ~text:"Ok"
- and cancel = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel"
- and labels = Frame.create input
- and entries = Frame.create input in
- let l1 = Label.create labels ~text:"Command:"
- and l2 = Label.create labels ~text:"Title:"
- and e1 =
- Jg_entry.create entries ~command:(fun _ -> Button.invoke ok)
- and e2 =
- Jg_entry.create entries ~command:(fun _ -> Button.invoke ok)
- and names = List.map ~f:fst (Shell.get_all ()) in
- Entry.insert e1 ~index:`End ~text:!default_shell;
- let shell_name () = "Shell #" ^ string_of_int !shell_counter in
- while List.mem (shell_name ()) names do
- incr shell_counter
- done;
- Entry.insert e2 ~index:`End ~text:(shell_name ());
- Button.configure ok ~command:(fun () ->
- if not (List.mem (Entry.get e2) names) then begin
- default_shell := Entry.get e1;
- Shell.f ~prog:!default_shell ~title:(Entry.get e2);
- destroy tl
- end);
- pack [l1;l2] ~side:`Top ~anchor:`W;
- pack [e1;e2] ~side:`Top ~fill:`X ~expand:true;
- pack [labels;entries] ~side:`Left ~fill:`X ~expand:true;
- pack [ok;cancel] ~side:`Left ~fill:`X ~expand:true;
- pack [input;buttons] ~side:`Top ~fill:`X ~expand:true
-
-
-(* Help window *)
-
-let show_help () =
- let tl = Jg_toplevel.titled "OCamlBrowser Help" in
- Jg_bind.escape_destroy tl;
- let fw, tw, sb = Jg_text.create_with_scrollbar tl in
- let ok = Jg_button.create_destroyer ~parent:tl ~text:"Ok" tl in
- Text.insert tw ~index:tend ~text:Help.text;
- Text.configure tw ~state:`Disabled;
- Jg_bind.enter_focus tw;
- pack [tw] ~side:`Left ~fill:`Both ~expand:true;
- pack [sb] ~side:`Right ~fill:`Y;
- pack [fw] ~side:`Top ~expand:true ~fill:`Both;
- pack [ok] ~side:`Bottom ~fill:`X
-
-(* Launch the classical viewer *)
-
-let f ?(dir=Unix.getcwd()) ?on () =
- let tl = match on with
- None ->
- let tl = Jg_toplevel.titled "Module viewer" in
- ignore (Jg_bind.escape_destroy tl); coe tl
- | Some top ->
- Wm.title_set top "OCamlBrowser";
- Wm.iconname_set top "OCamlBrowser";
- let tl = Frame.create top in
- bind tl ~events:[`Destroy] ~action:(fun _ -> exit 0);
- pack [tl] ~expand:true ~fill:`Both;
- coe tl
- in
- let menus = Frame.create tl ~name:"menubar" in
- let filemenu = new Jg_menu.c "File" ~parent:menus
- and modmenu = new Jg_menu.c "Modules" ~parent:menus in
- let fmbox, mbox, msb = Jg_box.create_with_scrollbar tl in
-
- Jg_box.add_completion mbox ~nocase:true ~action:
- begin fun index ->
- view_defined (Lident (Listbox.get mbox ~index)) ~env:!start_env
- end;
- Setpath.add_update_hook (fun () -> reset_modules mbox);
-
- let ew = Entry.create tl in
- let buttons = Frame.create tl in
- let search = Button.create buttons ~text:"Search" ~pady:1
- ~command:(fun () -> search_string ew)
- and close =
- Button.create buttons ~text:"Close all" ~pady:1 ~command:close_all_views
- in
- (* bindings *)
- Jg_bind.enter_focus ew;
- Jg_bind.return_invoke ew ~button:search;
- bind close ~events:[`Modified([`Double], `ButtonPressDetail 1)]
- ~action:(fun _ -> destroy tl);
-
- (* File menu *)
- filemenu#add_command "Open..."
- ~command:(fun () -> !editor_ref ~opendialog:true ());
- filemenu#add_command "Editor..." ~command:(fun () -> !editor_ref ());
- filemenu#add_command "Shell..." ~command:(fun () -> start_shell tl);
- filemenu#add_command "Quit" ~command:(fun () -> destroy tl);
-
- (* modules menu *)
- modmenu#add_command "Path editor..."
- ~command:(fun () -> Setpath.set ~dir);
- modmenu#add_command "Reset cache"
- ~command:(fun () -> reset_modules mbox; Env.reset_cache ());
- modmenu#add_command "Search symbol..." ~command:search_symbol;
-
- pack [filemenu#button; modmenu#button] ~side:`Left ~ipadx:5 ~anchor:`W;
- pack [menus] ~side:`Top ~fill:`X;
- pack [close; search] ~fill:`X ~side:`Right ~expand:true;
- pack [coe buttons; coe ew] ~fill:`X ~side:`Bottom;
- pack [msb] ~side:`Right ~fill:`Y;
- pack [mbox] ~side:`Left ~fill:`Both ~expand:true;
- pack [fmbox] ~fill:`Both ~expand:true ~side:`Top;
- reset_modules mbox
-
-(* Smalltalk-like version *)
-
-class st_viewer ?(dir=Unix.getcwd()) ?on () =
- let tl = match on with
- None ->
- let tl = Jg_toplevel.titled "Module viewer" in
- ignore (Jg_bind.escape_destroy tl); coe tl
- | Some top ->
- Wm.title_set top "OCamlBrowser";
- Wm.iconname_set top "OCamlBrowser";
- let tl = Frame.create top in
- bind tl ~events:[`Destroy] ~action:(fun _ -> exit 0);
- pack [tl] ~expand:true ~fill:`Both;
- coe tl
- in
- let menus = Frame.create tl ~name:"menubar" in
- let filemenu = new Jg_menu.c "File" ~parent:menus
- and modmenu = new Jg_menu.c "Modules" ~parent:menus
- and viewmenu = new Jg_menu.c "View" ~parent:menus
- and helpmenu = new Jg_menu.c "Help" ~parent:menus in
- let search_frame = Frame.create tl in
- let boxes_frame = Frame.create tl ~name:"boxes" in
- let label = Label.create tl ~anchor:`W ~padx:5 in
- let view = Frame.create tl in
- let buttons = Frame.create tl in
- let all = Button.create buttons ~text:"Show all" ~padx:20
- and close = Button.create buttons ~text:"Close all" ~command:close_all_views
- and detach = Button.create buttons ~text:"Detach"
- and edit = Button.create buttons ~text:"Impl"
- and intf = Button.create buttons ~text:"Intf" in
-object (self)
- val mutable boxes = []
- val mutable show_all = fun () -> ()
-
- method create_box =
- let fmbox, mbox, sb = Jg_box.create_with_scrollbar boxes_frame in
- bind mbox ~events:[`Modified([`Double], `ButtonPressDetail 1)]
- ~action:(fun _ -> show_all ());
- bind mbox ~events:[`Modified([`Double], `KeyPressDetail "Return")]
- ~action:(fun _ -> show_all ());
- boxes <- boxes @ [fmbox, mbox];
- pack [sb] ~side:`Right ~fill:`Y;
- pack [mbox] ~side:`Left ~fill:`Both ~expand:true;
- pack [fmbox] ~side:`Left ~fill:`Both ~expand:true;
- fmbox, mbox
-
- initializer
- (* Search *)
- let ew = Entry.create search_frame
- and searchtype = Textvariable.create ~on:tl () in
- bind ew ~events:[`KeyPressDetail "Return"] ~action:
- (fun _ -> search_string ew ~mode:(Textvariable.get searchtype));
- Jg_bind.enter_focus ew;
- let search_button ?value text =
- Radiobutton.create search_frame
- ~text ~variable:searchtype ~value:text in
- let symbol = search_button "Name"
- and atype = search_button "Type" in
- Radiobutton.select symbol;
- pack [Label.create search_frame ~text:"Search"] ~side:`Left ~ipadx:5;
- pack [ew] ~fill:`X ~expand:true ~side:`Left;
- pack [Label.create search_frame ~text:"by"] ~side:`Left ~ipadx:5;
- pack [symbol; atype] ~side:`Left;
- pack [Label.create search_frame] ~side:`Right
-
- initializer
- (* Boxes *)
- let fmbox, mbox = self#create_box in
- Jg_box.add_completion mbox ~nocase:true ~double:false ~action:
- begin fun index ->
- view_defined (Lident (Listbox.get mbox ~index)) ~env:!start_env
- end;
- Setpath.add_update_hook (fun () -> reset_modules mbox; self#hide_after 1);
- List.iter [1;2] ~f:(fun _ -> ignore self#create_box);
- Searchpos.default_frame := Some
- { mw_frame = view; mw_title = Some label;
- mw_detach = detach; mw_edit = edit; mw_intf = intf };
- Searchpos.set_path := self#set_path;
-
- (* Buttons *)
- pack [close] ~side:`Right ~fill:`X ~expand:true;
- bind close ~events:[`Modified([`Double], `ButtonPressDetail 1)]
- ~action:(fun _ -> destroy tl);
-
- (* File menu *)
- filemenu#add_command "Open..."
- ~command:(fun () -> !editor_ref ~opendialog:true ());
- filemenu#add_command "Editor..." ~command:(fun () -> !editor_ref ());
- filemenu#add_command "Shell..." ~command:(fun () -> start_shell tl);
- filemenu#add_command "Quit" ~command:(fun () -> destroy tl);
-
- (* View menu *)
- viewmenu#add_command "Show all defs" ~command:(fun () -> show_all ());
- let show_search = Textvariable.create ~on:tl () in
- Textvariable.set show_search "1";
- Menu.add_checkbutton viewmenu#menu ~label:"Search Entry"
- ~variable:show_search ~indicatoron:true ~state:`Active
- ~command:
- begin fun () ->
- let v = Textvariable.get show_search in
- if v = "1" then begin
- pack [search_frame] ~after:menus ~fill:`X
- end else Pack.forget [search_frame]
- end;
-
- (* modules menu *)
- modmenu#add_command "Path editor..."
- ~command:(fun () -> Setpath.set ~dir);
- modmenu#add_command "Reset cache"
- ~command:(fun () -> reset_modules mbox; Env.reset_cache ());
- modmenu#add_command "Search symbol..." ~command:search_symbol;
-
- (* Help menu *)
- helpmenu#add_command "Manual..." ~command:show_help;
-
- pack [filemenu#button; viewmenu#button; modmenu#button]
- ~side:`Left ~ipadx:5 ~anchor:`W;
- pack [helpmenu#button] ~side:`Right ~anchor:`E ~ipadx:5;
- pack [menus] ~fill:`X;
- pack [search_frame] ~fill:`X;
- pack [boxes_frame] ~fill:`Both ~expand:true;
- pack [buttons] ~fill:`X ~side:`Bottom;
- pack [view] ~fill:`Both ~side:`Bottom ~expand:true;
- reset_modules mbox
-
- val mutable shown_paths = []
-
- method hide_after n =
- for i = n to List.length boxes - 1 do
- let fm, box = List.nth boxes i in
- if i < 3 then Listbox.delete box ~first:(`Num 0) ~last:`End
- else destroy fm
- done;
- let rec firsts n = function [] -> []
- | a :: l -> if n > 0 then a :: firsts (pred n) l else [] in
- shown_paths <- firsts (n-1) shown_paths;
- boxes <- firsts (max 3 n) boxes
-
- method get_box ~path =
- let rec path_index p = function
- [] -> raise Not_found
- | a :: l -> if Path.same p a then 1 else path_index p l + 1 in
- try
- let n = path_index path shown_paths in
- self#hide_after (n+1);
- n
- with Not_found ->
- match path with
- Path.Pdot (path', _, _) ->
- let n = self#get_box ~path:path' in
- shown_paths <- shown_paths @ [path];
- if n + 1 >= List.length boxes then ignore self#create_box;
- n+1
- | _ ->
- self#hide_after 2;
- shown_paths <- [path];
- 1
-
- method set_path path ~sign =
- let rec path_elems l path =
- match path with
- Path.Pdot (path, _, _) -> path_elems (path::l) path
- | _ -> []
- in
- let path_elems path =
- match path with
- | Path.Pident _ -> [path]
- | _ -> path_elems [] path
- in
- let see_path ~box:n ?(sign=[]) path =
- let (_, box) = List.nth boxes n in
- let texts = Listbox.get_range box ~first:(`Num 0) ~last:`End in
- let rec index s = function
- [] -> raise Not_found
- | a :: l -> if a = s then 0 else 1 + index s l
- in
- try
- let modlid, s =
- match path with
- Path.Pdot (p, s, _) -> longident_of_path p, s
- | Path.Pident i -> Longident.Lident "M", Ident.name i
- | _ -> assert false
- in
- let li, k =
- if sign = [] then Longident.Lident s, Pmodule else
- ident_of_decl ~modlid (List.hd sign) in
- let s =
- if n = 0 then string_of_longident li else
- string_of_longident li ^ " (" ^ string_of_kind k ^ ")" in
- let n = index s texts in
- Listbox.see box (`Num n);
- Listbox.activate box (`Num n)
- with Not_found -> ()
- in
- let l = path_elems path in
- if l <> [] then begin
- List.iter l ~f:
- begin fun path ->
- if not (List.mem path shown_paths) then
- view_symbol (longident_of_path path) ~kind:Pmodule
- ~env:Env.initial ~path;
- let n = self#get_box path - 1 in
- see_path path ~box:n
- end;
- see_path path ~box:(self#get_box path) ~sign
- end
-
- method choose_symbol ~title ~env ?signature ?path l =
- let n =
- match path with None -> 1
- | Some path -> self#get_box ~path
- in
- let l = List.sort l ~cmp:(fun (li1, _) (li2,_) -> compare li1 li2) in
- let nl = List.map l ~f:
- begin fun (li, k) ->
- string_of_longident li ^ " (" ^ string_of_kind k ^ ")"
- end in
- let _, box = List.nth boxes n in
- Listbox.delete box ~first:(`Num 0) ~last:`End;
- Listbox.insert box ~index:`End ~texts:nl;
-
- let current = ref None in
- let display index =
- let `Num pos = Listbox.index box ~index in
- try
- let li, k = List.nth l pos in
- self#hide_after (n+1);
- if !current = Some (li,k) then () else
- let path =
- match path, li with
- None, Ldot (lip, _) ->
- begin try
- Some (fst (lookup_module lip env))
- with Not_found -> None
- end
- | _ -> path
- in
- current := Some (li,k);
- view_symbol li ~kind:k ~env ?path
- with Failure "nth" -> ()
- in
- Jg_box.add_completion box ~double:false ~action:display;
- bind box ~events:[`KeyRelease] ~fields:[`Char]
- ~action:(fun ev -> display `Active);
-
- begin match signature with
- None -> ()
- | Some signature ->
- show_all <-
- begin fun () ->
- current := None;
- view_signature signature ~title ~env ?path
- end
- end
-end
-
-let st_viewer ?dir ?on () =
- let viewer = new st_viewer ?dir ?on () in
- choose_symbol_ref := viewer#choose_symbol
diff --git a/otherlibs/labltk/browser/viewer.mli b/otherlibs/labltk/browser/viewer.mli
deleted file mode 100644
index d8bec671df..0000000000
--- a/otherlibs/labltk/browser/viewer.mli
+++ /dev/null
@@ -1,31 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-(* Module viewer *)
-open Widget
-
-val search_symbol : unit -> unit
- (* search a symbol in all modules in the path *)
-
-val f : ?dir:string -> ?on:toplevel widget -> unit -> unit
- (* open then module viewer *)
-val st_viewer : ?dir:string -> ?on:toplevel widget -> unit -> unit
- (* one-box viewer *)
-
-val view_defined : env:Env.t -> ?show_all:bool -> Longident.t -> unit
- (* displays a signature, found in environment *)
-
-val close_all_views : unit -> unit
diff --git a/otherlibs/labltk/browser/winmain.c b/otherlibs/labltk/browser/winmain.c
deleted file mode 100644
index d36f6786f9..0000000000
--- a/otherlibs/labltk/browser/winmain.c
+++ /dev/null
@@ -1,18 +0,0 @@
-#include <windows.h>
-#include <mlvalues.h>
-#include <callback.h>
-#include <sys.h>
-
-extern int __argc;
-extern char **__argv;
-extern void expand_command_line(int * argcp, char *** argvp);
-extern void caml_main (char **);
-
-int WINAPI WinMain(HINSTANCE h, HINSTANCE HPrevInstance,
- LPSTR lpCmdLine, int nCmdShow)
-{
- expand_command_line(&__argc, &__argv);
- caml_main(__argv);
- sys_exit(Val_int(0));
- return 0;
-}
diff --git a/otherlibs/labltk/builtin/LICENSE b/otherlibs/labltk/builtin/LICENSE
deleted file mode 100644
index c006f51d5c..0000000000
--- a/otherlibs/labltk/builtin/LICENSE
+++ /dev/null
@@ -1,19 +0,0 @@
-(*************************************************************************)
-(* *)
-(* Objective Caml LablTk library *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../../../LICENSE. *)
-(* *)
-(*************************************************************************)
-
-(* $Id$ *)
-
-All the files in this directory are subject to the above copyright notice. \ No newline at end of file
diff --git a/otherlibs/labltk/builtin/builtin_FilePattern.ml b/otherlibs/labltk/builtin/builtin_FilePattern.ml
deleted file mode 100644
index f7dd1d60e6..0000000000
--- a/otherlibs/labltk/builtin/builtin_FilePattern.ml
+++ /dev/null
@@ -1,20 +0,0 @@
-(* File patterns *)
-(* type *)
-type filePattern = {
- typename : string;
- extensions : string list;
- mactypes : string list
- }
-(* /type *)
-
-let cCAMLtoTKfilePattern fp =
- let typename = TkQuote (TkToken fp.typename) in
- let extensions =
- TkQuote (TkTokenList (List.map (fun x -> TkToken x) fp.extensions)) in
- let mactypes =
- match fp.mactypes with
- | [] -> []
- | [s] -> [TkToken s]
- | _ -> [TkQuote (TkTokenList (List.map (fun x -> TkToken x) fp.mactypes))]
- in
- TkQuote (TkTokenList (typename :: extensions :: mactypes))
diff --git a/otherlibs/labltk/builtin/builtin_GetBitmap.ml b/otherlibs/labltk/builtin/builtin_GetBitmap.ml
deleted file mode 100644
index bf02d20f86..0000000000
--- a/otherlibs/labltk/builtin/builtin_GetBitmap.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-(* Tk_GetBitmap emulation *)
-
-##ifdef CAMLTK
-
-(* type *)
-type bitmap =
- | BitmapFile of string (* path of file *)
- | Predefined of string (* bitmap name *)
-;;
-(* /type *)
-
-##else
-
-(* type *)
-type bitmap = [
- | `File of string (* path of file *)
- | `Predefined of string (* bitmap name *)
-]
-;;
-(* /type *)
-
-##endif
diff --git a/otherlibs/labltk/builtin/builtin_GetCursor.ml b/otherlibs/labltk/builtin/builtin_GetCursor.ml
deleted file mode 100644
index 6c7034b166..0000000000
--- a/otherlibs/labltk/builtin/builtin_GetCursor.ml
+++ /dev/null
@@ -1,61 +0,0 @@
-(* Color *)
-
-##ifdef CAMLTK
-
-(* type *)
-type color =
- | NamedColor of string
- | Black (* tk keyword: black *)
- | White (* tk keyword: white *)
- | Red (* tk keyword: red *)
- | Green (* tk keyword: green *)
- | Blue (* tk keyword: blue *)
- | Yellow (* tk keyword: yellow *)
-;;
-(* /type *)
-
-##else
-
-(* type *)
-type color = [
- | `Color of string
- | `Black (* tk keyword: black *)
- | `White (* tk keyword: white *)
- | `Red (* tk keyword: red *)
- | `Green (* tk keyword: green *)
- | `Blue (* tk keyword: blue *)
- | `Yellow (* tk keyword: yellow *)
-]
-;;
-(* /type *)
-
-##endif
-
-##ifdef CAMLTK
-
-(* type *)
-type cursor =
- | XCursor of string
- | XCursorFg of string * color
- | XCursortFgBg of string * color * color
- | CursorFileFg of string * color
- | CursorMaskFile of string * string * color * color
-;;
-(* /type *)
-
-##else
-
-(* Tk_GetCursor emulation *)
-(* type *)
-type cursor = [
- | `Xcursor of string
- | `Xcursorfg of string * color
- | `Xcursorfgbg of string * color * color
- | `Cursorfilefg of string * color
- | `Cursormaskfile of string * string * color * color
-]
-;;
-(* /type *)
-
-##endif
-
diff --git a/otherlibs/labltk/builtin/builtin_GetPixel.ml b/otherlibs/labltk/builtin/builtin_GetPixel.ml
deleted file mode 100644
index 772a2c2842..0000000000
--- a/otherlibs/labltk/builtin/builtin_GetPixel.ml
+++ /dev/null
@@ -1,28 +0,0 @@
-(* Tk_GetPixels emulation *)
-
-##ifdef CAMLTK
-
-(* type *)
-type units =
- | Pixels of int (* specified as floating-point, but inconvenient *)
- | Centimeters of float
- | Inches of float
- | Millimeters of float
- | PrinterPoint of float
-;;
-(* /type *)
-
-##else
-
-(* type *)
-type units = [
- | `Pix of int
- | `Cm of float
- | `In of float
- | `Mm of float
- | `Pt of float
-]
-;;
-(* /type *)
-
-##endif
diff --git a/otherlibs/labltk/builtin/builtin_ScrollValue.ml b/otherlibs/labltk/builtin/builtin_ScrollValue.ml
deleted file mode 100644
index 75a509e69a..0000000000
--- a/otherlibs/labltk/builtin/builtin_ScrollValue.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-##ifdef CAMLTK
-
-(* type *)
-type scrollValue =
- | ScrollPage of int (* tk option: scroll <int> page *)
- | ScrollUnit of int (* tk option: scroll <int> unit *)
- | MoveTo of float (* tk option: moveto <float> *)
-;;
-(* /type *)
-
-##else
-
-(* type *)
-type scrollValue = [
- | `Page of int (* tk option: scroll <int> page *)
- | `Unit of int (* tk option: scroll <int> unit *)
- | `Moveto of float (* tk option: moveto <float> *)
-]
-;;
-(* /type *)
-
-##endif
diff --git a/otherlibs/labltk/builtin/builtin_bind.ml b/otherlibs/labltk/builtin/builtin_bind.ml
deleted file mode 100644
index 35d0d3c1a4..0000000000
--- a/otherlibs/labltk/builtin/builtin_bind.ml
+++ /dev/null
@@ -1,469 +0,0 @@
-##ifdef CAMLTK
-
-open Widget;;
-
-(* Events and bindings *)
-(* Builtin types *)
-(* type *)
-type xEvent =
- | Activate
- | ButtonPress (* also Button, but we omit it *)
- | ButtonPressDetail of int
- | ButtonRelease
- | ButtonReleaseDetail of int
- | Circulate
- | ColorMap (* not Colormap, avoiding confusion between the Colormap option *)
- | Configure
- | Deactivate
- | Destroy
- | Enter
- | Expose
- | FocusIn
- | FocusOut
- | Gravity
- | KeyPress (* also Key, but we omit it *)
- | KeyPressDetail of string (* /usr/include/X11/keysymdef.h *)
- | KeyRelease
- | KeyReleaseDetail of string
- | Leave
- | Map
- | Motion
- | Property
- | Reparent
- | Unmap
- | Visibility
- | Virtual of string (* Virtual event. Must be without modifiers *)
-;;
-(* /type *)
-
-(* type *)
-type modifier =
- | Control
- | Shift
- | Lock
- | Button1
- | Button2
- | Button3
- | Button4
- | Button5
- | Double
- | Triple
- | Mod1
- | Mod2
- | Mod3
- | Mod4
- | Mod5
- | Meta
- | Alt
-;;
-(* /type *)
-
-(* Event structure, passed to bounded functions *)
-
-(* type *)
-type eventInfo =
- {
- (* %# : event serial number is unsupported *)
- mutable ev_Above : int; (* tk: %a *)
- mutable ev_ButtonNumber : int; (* tk: %b *)
- mutable ev_Count : int; (* tk: %c *)
- mutable ev_Detail : string; (* tk: %d *)
- mutable ev_Focus : bool; (* tk: %f *)
- mutable ev_Height : int; (* tk: %h *)
- mutable ev_KeyCode : int; (* tk: %k *)
- mutable ev_Mode : string; (* tk: %m *)
- mutable ev_OverrideRedirect : bool; (* tk: %o *)
- mutable ev_Place : string; (* tk: %p *)
- mutable ev_State : string; (* tk: %s *)
- mutable ev_Time : int; (* tk: %t *)
- mutable ev_Width : int; (* tk: %w *)
- mutable ev_MouseX : int; (* tk: %x *)
- mutable ev_MouseY : int; (* tk: %y *)
- mutable ev_Char : string; (* tk: %A *)
- mutable ev_BorderWidth : int; (* tk: %B *)
- mutable ev_SendEvent : bool; (* tk: %E *)
- mutable ev_KeySymString : string; (* tk: %K *)
- mutable ev_KeySymInt : int; (* tk: %N *)
- mutable ev_RootWindow : int; (* tk: %R *)
- mutable ev_SubWindow : int; (* tk: %S *)
- mutable ev_Type : int; (* tk: %T *)
- mutable ev_Widget : widget; (* tk: %W *)
- mutable ev_RootX : int; (* tk: %X *)
- mutable ev_RootY : int (* tk: %Y *)
- }
-;;
-(* /type *)
-
-
-(* To avoid collision with other constructors (Width, State),
- use Ev_ prefix *)
-(* type *)
-type eventField =
- | Ev_Above
- | Ev_ButtonNumber
- | Ev_Count
- | Ev_Detail
- | Ev_Focus
- | Ev_Height
- | Ev_KeyCode
- | Ev_Mode
- | Ev_OverrideRedirect
- | Ev_Place
- | Ev_State
- | Ev_Time
- | Ev_Width
- | Ev_MouseX
- | Ev_MouseY
- | Ev_Char
- | Ev_BorderWidth
- | Ev_SendEvent
- | Ev_KeySymString
- | Ev_KeySymInt
- | Ev_RootWindow
- | Ev_SubWindow
- | Ev_Type
- | Ev_Widget
- | Ev_RootX
- | Ev_RootY
-;;
-(* /type *)
-
-let filleventInfo ev v = function
- | Ev_Above -> ev.ev_Above <- int_of_string v
- | Ev_ButtonNumber -> ev.ev_ButtonNumber <- int_of_string v
- | Ev_Count -> ev.ev_Count <- int_of_string v
- | Ev_Detail -> ev.ev_Detail <- v
- | Ev_Focus -> ev.ev_Focus <- v = "1"
- | Ev_Height -> ev.ev_Height <- int_of_string v
- | Ev_KeyCode -> ev.ev_KeyCode <- int_of_string v
- | Ev_Mode -> ev.ev_Mode <- v
- | Ev_OverrideRedirect -> ev.ev_OverrideRedirect <- v = "1"
- | Ev_Place -> ev.ev_Place <- v
- | Ev_State -> ev.ev_State <- v
- | Ev_Time -> ev.ev_Time <- int_of_string v
- | Ev_Width -> ev.ev_Width <- int_of_string v
- | Ev_MouseX -> ev.ev_MouseX <- int_of_string v
- | Ev_MouseY -> ev.ev_MouseY <- int_of_string v
- | Ev_Char -> ev.ev_Char <- v
- | Ev_BorderWidth -> ev.ev_BorderWidth <- int_of_string v
- | Ev_SendEvent -> ev.ev_SendEvent <- v = "1"
- | Ev_KeySymString -> ev.ev_KeySymString <- v
- | Ev_KeySymInt -> ev.ev_KeySymInt <- int_of_string v
- | Ev_RootWindow -> ev.ev_RootWindow <- int_of_string v
- | Ev_SubWindow -> ev.ev_SubWindow <- int_of_string v
- | Ev_Type -> ev.ev_Type <- int_of_string v
- | Ev_Widget -> ev.ev_Widget <- cTKtoCAMLwidget v
- | Ev_RootX -> ev.ev_RootX <- int_of_string v
- | Ev_RootY -> ev.ev_RootY <- int_of_string v
-;;
-
-let wrapeventInfo f what =
- let ev = {
- ev_Above = 0;
- ev_ButtonNumber = 0;
- ev_Count = 0;
- ev_Detail = "";
- ev_Focus = false;
- ev_Height = 0;
- ev_KeyCode = 0;
- ev_Mode = "";
- ev_OverrideRedirect = false;
- ev_Place = "";
- ev_State = "";
- ev_Time = 0;
- ev_Width = 0;
- ev_MouseX = 0;
- ev_MouseY = 0;
- ev_Char = "";
- ev_BorderWidth = 0;
- ev_SendEvent = false;
- ev_KeySymString = "";
- ev_KeySymInt = 0;
- ev_RootWindow = 0;
- ev_SubWindow = 0;
- ev_Type = 0;
- ev_Widget = Widget.default_toplevel;
- ev_RootX = 0;
- ev_RootY = 0 } in
- function args ->
- let l = ref args in
- List.iter (function field ->
- match !l with
- [] -> ()
- | v::rest -> filleventInfo ev v field; l:=rest)
- what;
- f ev
-;;
-
-let rec writeeventField = function
- | [] -> ""
- | field::rest ->
- begin
- match field with
- | Ev_Above -> " %a"
- | Ev_ButtonNumber ->" %b"
- | Ev_Count -> " %c"
- | Ev_Detail -> " %d"
- | Ev_Focus -> " %f"
- | Ev_Height -> " %h"
- | Ev_KeyCode -> " %k"
- | Ev_Mode -> " %m"
- | Ev_OverrideRedirect -> " %o"
- | Ev_Place -> " %p"
- | Ev_State -> " %s"
- | Ev_Time -> " %t"
- | Ev_Width -> " %w"
- | Ev_MouseX -> " %x"
- | Ev_MouseY -> " %y"
- (* Quoting is done by Tk *)
- | Ev_Char -> " %A"
- | Ev_BorderWidth -> " %B"
- | Ev_SendEvent -> " %E"
- | Ev_KeySymString -> " %K"
- | Ev_KeySymInt -> " %N"
- | Ev_RootWindow ->" %R"
- | Ev_SubWindow -> " %S"
- | Ev_Type -> " %T"
- | Ev_Widget ->" %W"
- | Ev_RootX -> " %X"
- | Ev_RootY -> " %Y"
- end
- ^ writeeventField rest
-;;
-
-##else
-
-open Widget;;
-
-(* Events and bindings *)
-(* Builtin types *)
-
-(* type *)
-type event = [
- | `Activate
- | `ButtonPress (* also Button, but we omit it *)
- | `ButtonPressDetail of int
- | `ButtonRelease
- | `ButtonReleaseDetail of int
- | `Circulate
- | `Colormap
- | `Configure
- | `Deactivate
- | `Destroy
- | `Enter
- | `Expose
- | `FocusIn
- | `FocusOut
- | `Gravity
- | `KeyPress (* also Key, but we omit it *)
- | `KeyPressDetail of string (* /usr/include/X11/keysymdef.h *)
- | `KeyRelease
- | `KeyReleaseDetail of string
- | `Leave
- | `Map
- | `Motion
- | `Property
- | `Reparent
- | `Unmap
- | `Visibility
- | `Virtual of string (* Virtual event. Must be without modifiers *)
- | `Modified of modifier list * event
-]
-
-and modifier = [
- | `Control
- | `Shift
- | `Lock
- | `Button1
- | `Button2
- | `Button3
- | `Button4
- | `Button5
- | `Double
- | `Triple
- | `Mod1
- | `Mod2
- | `Mod3
- | `Mod4
- | `Mod5
- | `Meta
- | `Alt
-]
-;;
-(* /type *)
-
-(* Event structure, passed to bounded functions *)
-
-(* type *)
-type eventInfo = {
- (* %# : event serial number is unsupported *)
- mutable ev_Above : int; (* tk: %a *)
- mutable ev_ButtonNumber : int; (* tk: %b *)
- mutable ev_Count : int; (* tk: %c *)
- mutable ev_Detail : string; (* tk: %d *)
- mutable ev_Focus : bool; (* tk: %f *)
- mutable ev_Height : int; (* tk: %h *)
- mutable ev_KeyCode : int; (* tk: %k *)
- mutable ev_Mode : string; (* tk: %m *)
- mutable ev_OverrideRedirect : bool; (* tk: %o *)
- mutable ev_Place : string; (* tk: %p *)
- mutable ev_State : string; (* tk: %s *)
- mutable ev_Time : int; (* tk: %t *)
- mutable ev_Width : int; (* tk: %w *)
- mutable ev_MouseX : int; (* tk: %x *)
- mutable ev_MouseY : int; (* tk: %y *)
- mutable ev_Char : string; (* tk: %A *)
- mutable ev_BorderWidth : int; (* tk: %B *)
- mutable ev_SendEvent : bool; (* tk: %E *)
- mutable ev_KeySymString : string; (* tk: %K *)
- mutable ev_KeySymInt : int; (* tk: %N *)
- mutable ev_RootWindow : int; (* tk: %R *)
- mutable ev_SubWindow : int; (* tk: %S *)
- mutable ev_Type : int; (* tk: %T *)
- mutable ev_Widget : any widget; (* tk: %W *)
- mutable ev_RootX : int; (* tk: %X *)
- mutable ev_RootY : int (* tk: %Y *)
- }
-;;
-(* /type *)
-
-
-(* To avoid collision with other constructors (Width, State),
- use Ev_ prefix *)
-(* type *)
-type eventField = [
- | `Above
- | `ButtonNumber
- | `Count
- | `Detail
- | `Focus
- | `Height
- | `KeyCode
- | `Mode
- | `OverrideRedirect
- | `Place
- | `State
- | `Time
- | `Width
- | `MouseX
- | `MouseY
- | `Char
- | `BorderWidth
- | `SendEvent
- | `KeySymString
- | `KeySymInt
- | `RootWindow
- | `SubWindow
- | `Type
- | `Widget
- | `RootX
- | `RootY
-]
-;;
-(* /type *)
-
-let filleventInfo ev v : eventField -> unit = function
- | `Above -> ev.ev_Above <- int_of_string v
- | `ButtonNumber -> ev.ev_ButtonNumber <- int_of_string v
- | `Count -> ev.ev_Count <- int_of_string v
- | `Detail -> ev.ev_Detail <- v
- | `Focus -> ev.ev_Focus <- v = "1"
- | `Height -> ev.ev_Height <- int_of_string v
- | `KeyCode -> ev.ev_KeyCode <- int_of_string v
- | `Mode -> ev.ev_Mode <- v
- | `OverrideRedirect -> ev.ev_OverrideRedirect <- v = "1"
- | `Place -> ev.ev_Place <- v
- | `State -> ev.ev_State <- v
- | `Time -> ev.ev_Time <- int_of_string v
- | `Width -> ev.ev_Width <- int_of_string v
- | `MouseX -> ev.ev_MouseX <- int_of_string v
- | `MouseY -> ev.ev_MouseY <- int_of_string v
- | `Char -> ev.ev_Char <- v
- | `BorderWidth -> ev.ev_BorderWidth <- int_of_string v
- | `SendEvent -> ev.ev_SendEvent <- v = "1"
- | `KeySymString -> ev.ev_KeySymString <- v
- | `KeySymInt -> ev.ev_KeySymInt <- int_of_string v
- | `RootWindow -> ev.ev_RootWindow <- int_of_string v
- | `SubWindow -> ev.ev_SubWindow <- int_of_string v
- | `Type -> ev.ev_Type <- int_of_string v
- | `Widget -> ev.ev_Widget <- cTKtoCAMLwidget v
- | `RootX -> ev.ev_RootX <- int_of_string v
- | `RootY -> ev.ev_RootY <- int_of_string v
-;;
-
-let wrapeventInfo f (what : eventField list) =
- let ev = {
- ev_Above = 0;
- ev_ButtonNumber = 0;
- ev_Count = 0;
- ev_Detail = "";
- ev_Focus = false;
- ev_Height = 0;
- ev_KeyCode = 0;
- ev_Mode = "";
- ev_OverrideRedirect = false;
- ev_Place = "";
- ev_State = "";
- ev_Time = 0;
- ev_Width = 0;
- ev_MouseX = 0;
- ev_MouseY = 0;
- ev_Char = "";
- ev_BorderWidth = 0;
- ev_SendEvent = false;
- ev_KeySymString = "";
- ev_KeySymInt = 0;
- ev_RootWindow = 0;
- ev_SubWindow = 0;
- ev_Type = 0;
- ev_Widget = forget_type default_toplevel;
- ev_RootX = 0;
- ev_RootY = 0 } in
- function args ->
- let l = ref args in
- List.iter what ~f:
- begin fun field ->
- match !l with
- | [] -> ()
- | v :: rest -> filleventInfo ev v field; l := rest
- end;
- f ev
-;;
-
-let rec writeeventField : eventField list -> string = function
- | [] -> ""
- | field :: rest ->
- begin
- match field with
- | `Above -> " %a"
- | `ButtonNumber ->" %b"
- | `Count -> " %c"
- | `Detail -> " %d"
- | `Focus -> " %f"
- | `Height -> " %h"
- | `KeyCode -> " %k"
- | `Mode -> " %m"
- | `OverrideRedirect -> " %o"
- | `Place -> " %p"
- | `State -> " %s"
- | `Time -> " %t"
- | `Width -> " %w"
- | `MouseX -> " %x"
- | `MouseY -> " %y"
- (* Quoting is done by Tk *)
- | `Char -> " %A"
- | `BorderWidth -> " %B"
- | `SendEvent -> " %E"
- | `KeySymString -> " %K"
- | `KeySymInt -> " %N"
- | `RootWindow ->" %R"
- | `SubWindow -> " %S"
- | `Type -> " %T"
- | `Widget -> " %W"
- | `RootX -> " %X"
- | `RootY -> " %Y"
- end
- ^ writeeventField rest
-;;
-
-##endif
diff --git a/otherlibs/labltk/builtin/builtin_bindtags.ml b/otherlibs/labltk/builtin/builtin_bindtags.ml
deleted file mode 100644
index 4529fcdfea..0000000000
--- a/otherlibs/labltk/builtin/builtin_bindtags.ml
+++ /dev/null
@@ -1,21 +0,0 @@
-##ifdef CAMLTK
-
-(* type *)
-type bindings =
- | TagBindings of string (* tk option: <string> *)
- | WidgetBindings of widget (* tk option: <widget> *)
-;;
-(* /type *)
-
-##else
-
-(* type *)
-type bindings = [
- | `Tag of string (* tk option: <string> *)
- | `Widget of any widget (* tk option: <widget> *)
-]
-;;
-(* /type *)
-
-##endif
-
diff --git a/otherlibs/labltk/builtin/builtin_font.ml b/otherlibs/labltk/builtin/builtin_font.ml
deleted file mode 100644
index 3425391bbf..0000000000
--- a/otherlibs/labltk/builtin/builtin_font.ml
+++ /dev/null
@@ -1,4 +0,0 @@
-(* type *)
-type font = string
-(* /type *)
-
diff --git a/otherlibs/labltk/builtin/builtin_grab.ml b/otherlibs/labltk/builtin/builtin_grab.ml
deleted file mode 100644
index 256926821d..0000000000
--- a/otherlibs/labltk/builtin/builtin_grab.ml
+++ /dev/null
@@ -1,3 +0,0 @@
-(* type *)
-type grabGlobal = bool
-(* /type *)
diff --git a/otherlibs/labltk/builtin/builtin_index.ml b/otherlibs/labltk/builtin/builtin_index.ml
deleted file mode 100644
index a42af55390..0000000000
--- a/otherlibs/labltk/builtin/builtin_index.ml
+++ /dev/null
@@ -1,92 +0,0 @@
-(* Various indexes
- canvas
- entry
- listbox
-*)
-
-##ifdef CAMLTK
-
-(* A large type for all indices in all widgets *)
-(* a bit overkill though *)
-
-(* type *)
-type index =
- | Number of int (* no keyword *)
- | ActiveElement (* tk keyword: active *)
- | End (* tk keyword: end *)
- | Last (* tk keyword: last *)
- | NoIndex (* tk keyword: none *)
- | Insert (* tk keyword: insert *)
- | SelFirst (* tk keyword: sel.first *)
- | SelLast (* tk keyword: sel.last *)
- | At of int (* tk keyword: @n *)
- | AtXY of int * int (* tk keyword: @x,y *)
- | AnchorPoint (* tk keyword: anchor *)
- | Pattern of string (* no keyword *)
- | LineChar of int * int (* tk keyword: l.c *)
- | Mark of string (* no keyword *)
- | TagFirst of string (* tk keyword: tag.first *)
- | TagLast of string (* tk keyword: tag.last *)
- | Embedded of widget (* no keyword *)
-;;
-(* /type *)
-
-##else
-
-type canvas_index = [
- | `Num of int
- | `End
- | `Insert
- | `Selfirst
- | `Sellast
- | `Atxy of int * int
-]
-;;
-
-type entry_index = [
- | `Num of int
- | `End
- | `Insert
- | `Selfirst
- | `Sellast
- | `At of int
- | `Anchor
-]
-;;
-
-type listbox_index = [
- | `Num of int
- | `Active
- | `Anchor
- | `End
- | `Atxy of int * int
-]
-;;
-
-type menu_index = [
- | `Num of int
- | `Active
- | `End
- | `Last
- | `None
- | `At of int
- | `Pattern of string
-]
-;;
-
-type text_index = [
- | `Linechar of int * int
- | `Atxy of int * int
- | `End
- | `Mark of string
- | `Tagfirst of string
- | `Taglast of string
- | `Window of any widget
- | `Image of string
-]
-;;
-
-type linechar_index = int * int;;
-type num_index = int;;
-
-##endif
diff --git a/otherlibs/labltk/builtin/builtin_palette.ml b/otherlibs/labltk/builtin/builtin_palette.ml
deleted file mode 100644
index 4eab69a0f9..0000000000
--- a/otherlibs/labltk/builtin/builtin_palette.ml
+++ /dev/null
@@ -1,20 +0,0 @@
-##ifdef CAMLTK
-
-(* type *)
-type paletteType =
- | GrayShades of int
- | RGBShades of int * int * int
-;;
-(* /type *)
-
-##else
-
-(* type *)
-type paletteType = [
- | `Gray of int
- | `Rgb of int * int * int
-]
-;;
-(* /type *)
-
-##endif
diff --git a/otherlibs/labltk/builtin/builtin_text.ml b/otherlibs/labltk/builtin/builtin_text.ml
deleted file mode 100644
index b2d69589ba..0000000000
--- a/otherlibs/labltk/builtin/builtin_text.ml
+++ /dev/null
@@ -1,50 +0,0 @@
-(* Not a string as such, more like a symbol *)
-
-(* type *)
-type textMark = string;;
-(* /type *)
-
-(* type *)
-type textTag = string;;
-(* /type *)
-
-##ifdef CAMLTK
-
-(* type *)
-type textModifier =
- | CharOffset of int (* tk keyword: +/- Xchars *)
- | LineOffset of int (* tk keyword: +/- Xlines *)
- | LineStart (* tk keyword: linestart *)
- | LineEnd (* tk keyword: lineend *)
- | WordStart (* tk keyword: wordstart *)
- | WordEnd (* tk keyword: wordend *)
-;;
-(* /type *)
-
-(* type *)
-type textIndex =
- | TextIndex of index * textModifier list
- | TextIndexNone
-;;
-(* /type *)
-
-##else
-
-(* type *)
-type textModifier = [
- | `Char of int (* tk keyword: +/- Xchars *)
- | `Line of int (* tk keyword: +/- Xlines *)
- | `Linestart (* tk keyword: linestart *)
- | `Lineend (* tk keyword: lineend *)
- | `Wordstart (* tk keyword: wordstart *)
- | `Wordend (* tk keyword: wordend *)
-]
-;;
-(* /type *)
-
-(* type *)
-type textIndex = text_index * textModifier list
-;;
-(* /type *)
-
-##endif
diff --git a/otherlibs/labltk/builtin/builtina_empty.ml b/otherlibs/labltk/builtin/builtina_empty.ml
deleted file mode 100644
index e69de29bb2..0000000000
--- a/otherlibs/labltk/builtin/builtina_empty.ml
+++ /dev/null
diff --git a/otherlibs/labltk/builtin/builtinf_GetPixel.ml b/otherlibs/labltk/builtin/builtinf_GetPixel.ml
deleted file mode 100644
index 7e7c596bca..0000000000
--- a/otherlibs/labltk/builtin/builtinf_GetPixel.ml
+++ /dev/null
@@ -1,23 +0,0 @@
-##ifdef CAMLTK
-
-let pixels units =
- let res =
- tkEval
- [|TkToken"winfo";
- TkToken"pixels";
- cCAMLtoTKwidget widget_any_table default_toplevel;
- cCAMLtoTKunits units|] in
- int_of_string res
-
-##else
-
-let pixels units =
- let res =
- tkEval
- [|TkToken"winfo";
- TkToken"pixels";
- cCAMLtoTKwidget default_toplevel;
- cCAMLtoTKunits units|] in
- int_of_string res
-
-##endif
diff --git a/otherlibs/labltk/builtin/builtinf_bind.ml b/otherlibs/labltk/builtin/builtinf_bind.ml
deleted file mode 100644
index d78541e1d0..0000000000
--- a/otherlibs/labltk/builtin/builtinf_bind.ml
+++ /dev/null
@@ -1,133 +0,0 @@
-##ifdef CAMLTK
-
-(* type *)
-type bindAction =
- | BindSet of eventField list * (eventInfo -> unit)
- | BindSetBreakable of eventField list * (eventInfo -> unit)
- | BindRemove
- | BindExtend of eventField list * (eventInfo -> unit)
-(* /type *)
-
-(*
-FUNCTION
- val bind:
- widget -> (modifier list * xEvent) list -> bindAction -> unit
-/FUNCTION
-*)
-let bind widget eventsequence action =
- tkCommand [| TkToken "bind";
- TkToken (Widget.name widget);
- cCAMLtoTKeventSequence eventsequence;
- begin match action with
- BindRemove -> TkToken ""
- | BindSet (what, f) ->
- let cbId = register_callback widget (wrapeventInfo f what)
- in
- TkToken ("camlcb " ^ cbId ^ (writeeventField what))
- | BindSetBreakable (what, f) ->
- let cbId = register_callback widget (wrapeventInfo f what)
- in
- TkToken ("camlcb " ^ cbId ^ (writeeventField what) ^
- " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0")
- | BindExtend (what, f) ->
- let cbId = register_callback widget (wrapeventInfo f what)
- in
- TkToken ("+camlcb " ^ cbId ^ (writeeventField what))
- end |]
-;;
-
-(* FUNCTION
-(* unsafe *)
- val bind_class :
- string -> (modifier list * xEvent) list -> bindAction -> unit
-(* /unsafe *)
-/FUNCTION class arg is not constrained *)
-
-let bind_class clas eventsequence action =
- tkCommand [| TkToken "bind";
- TkToken clas;
- cCAMLtoTKeventSequence eventsequence;
- begin match action with
- BindRemove -> TkToken ""
- | BindSet (what, f) ->
- let cbId = register_callback Widget.dummy
- (wrapeventInfo f what) in
- TkToken ("camlcb " ^ cbId ^ (writeeventField what))
- | BindSetBreakable (what, f) ->
- let cbId = register_callback Widget.dummy
- (wrapeventInfo f what) in
- TkToken ("camlcb " ^ cbId ^ (writeeventField what)^
- " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0" )
- | BindExtend (what, f) ->
- let cbId = register_callback Widget.dummy
- (wrapeventInfo f what) in
- TkToken ("+camlcb " ^ cbId ^ (writeeventField what))
- end |]
-;;
-
-(* FUNCTION
-(* unsafe *)
- val bind_tag :
- string -> (modifier list * xEvent) list -> bindAction -> unit
-(* /unsafe *)
-/FUNCTION *)
-
-let bind_tag = bind_class
-;;
-
-(*
-FUNCTION
- val break : unit -> unit
-/FUNCTION
-*)
-let break = function () ->
- Textvariable.set (Textvariable.coerce "BreakBindingsSequence") "1"
-;;
-
-(* Legacy functions *)
-let tag_bind = bind_tag;;
-let class_bind = bind_class;;
-
-##else
-
-let bind_class ~events ?(extend = false) ?(breakable = false) ?(fields = [])
- ?action ?on:widget name =
- let widget = match widget with None -> Widget.dummy | Some w -> coe w in
- tkCommand
- [| TkToken "bind";
- TkToken name;
- cCAMLtoTKeventSequence events;
- begin match action with None -> TkToken ""
- | Some f ->
- let cbId =
- register_callback widget ~callback: (wrapeventInfo f fields) in
- let cb = if extend then "+camlcb " else "camlcb " in
- let cb = cb ^ cbId ^ writeeventField fields in
- let cb =
- if breakable then
- cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}"
- ^ " ; set BreakBindingsSequence 0"
- else cb in
- TkToken cb
- end
- |]
-;;
-
-let bind ~events ?extend ?breakable ?fields ?action widget =
- bind_class ~events ?extend ?breakable ?fields ?action ~on:widget
- (Widget.name widget)
-;;
-
-let bind_tag = bind_class
-;;
-
-(*
-FUNCTION
- val break : unit -> unit
-/FUNCTION
-*)
-let break = function () ->
- tkCommand [| TkToken "set" ; TkToken "BreakBindingsSequence" ; TkToken "1" |]
-;;
-
-##endif
diff --git a/otherlibs/labltk/builtin/builtini_GetBitmap.ml b/otherlibs/labltk/builtin/builtini_GetBitmap.ml
deleted file mode 100644
index 1afa0cd91c..0000000000
--- a/otherlibs/labltk/builtin/builtini_GetBitmap.ml
+++ /dev/null
@@ -1,28 +0,0 @@
-##ifdef CAMLTK
-
-let cCAMLtoTKbitmap = function
- BitmapFile s -> TkToken ("@" ^ s)
-| Predefined s -> TkToken s
-;;
-
-let cTKtoCAMLbitmap s =
- if s = "" then Predefined ""
- else if String.get s 0 = '@'
- then BitmapFile (String.sub s 1 (String.length s - 1))
- else Predefined s
-;;
-
-##else
-
-let cCAMLtoTKbitmap : bitmap -> tkArgs = function
- | `File s -> TkToken ("@" ^ s)
- | `Predefined s -> TkToken s
-;;
-
-let cTKtoCAMLbitmap s =
- if String.get s 0 = '@'
- then `File (String.sub s ~pos:1 ~len:(String.length s - 1))
- else `Predefined s
-;;
-
-##endif
diff --git a/otherlibs/labltk/builtin/builtini_GetCursor.ml b/otherlibs/labltk/builtin/builtini_GetCursor.ml
deleted file mode 100644
index 8f4e3971fa..0000000000
--- a/otherlibs/labltk/builtin/builtini_GetCursor.ml
+++ /dev/null
@@ -1,55 +0,0 @@
-##ifdef CAMLTK
-
-let cCAMLtoTKcolor = function
- NamedColor x -> TkToken x
- | Black -> TkToken "black"
- | White -> TkToken "white"
- | Red -> TkToken "red"
- | Green -> TkToken "green"
- | Blue -> TkToken "blue"
- | Yellow -> TkToken "yellow"
-;;
-
-let cTKtoCAMLcolor = function s -> NamedColor s
-;;
-
-let cCAMLtoTKcursor = function
- XCursor s -> TkToken s
- | XCursorFg (s,fg) ->
- TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg])
- | XCursortFgBg (s,fg,bg) ->
- TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg])
- | CursorFileFg (s,fg) ->
- TkQuote(TkTokenList [TkToken ("@"^s); cCAMLtoTKcolor fg])
- | CursorMaskFile (s,m,fg,bg) ->
- TkQuote(TkTokenList [TkToken ("@"^s); TkToken m; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg])
-;;
-
-##else
-
-let cCAMLtoTKcolor : color -> tkArgs = function
- | `Color x -> TkToken x
- | `Black -> TkToken "black"
- | `White -> TkToken "white"
- | `Red -> TkToken "red"
- | `Green -> TkToken "green"
- | `Blue -> TkToken "blue"
- | `Yellow -> TkToken "yellow"
-;;
-
-let cTKtoCAMLcolor = function s -> `Color s
-;;
-
-let cCAMLtoTKcursor : cursor -> tkArgs = function
- | `Xcursor s -> TkToken s
- | `Xcursorfg (s,fg) ->
- TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg])
- | `Xcursorfgbg (s,fg,bg) ->
- TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg])
- | `Cursorfilefg (s,fg) ->
- TkQuote(TkTokenList [TkToken ("@"^s); cCAMLtoTKcolor fg])
- | `Cursormaskfile (s,m,fg,bg) ->
- TkQuote(TkTokenList [TkToken ("@"^s); TkToken m; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg])
-;;
-
-##endif
diff --git a/otherlibs/labltk/builtin/builtini_GetPixel.ml b/otherlibs/labltk/builtin/builtini_GetPixel.ml
deleted file mode 100644
index 12e7890f45..0000000000
--- a/otherlibs/labltk/builtin/builtini_GetPixel.ml
+++ /dev/null
@@ -1,43 +0,0 @@
-##ifdef CAMLTK
-
-let cCAMLtoTKunits = function
- Pixels (foo) -> TkToken (string_of_int foo)
- | Millimeters (foo) -> TkToken(Printf.sprintf "%gm" foo)
- | Inches (foo) -> TkToken(Printf.sprintf "%gi" foo)
- | PrinterPoint (foo) -> TkToken(Printf.sprintf "%gp" foo)
- | Centimeters (foo) -> TkToken(Printf.sprintf "%gc" foo)
-;;
-
-let cTKtoCAMLunits str =
- let len = String.length str in
- let num_part str = String.sub str 0 (len - 1) in
- match String.get str (pred len) with
- 'c' -> Centimeters (float_of_string (num_part str))
- | 'i' -> Inches (float_of_string (num_part str))
- | 'm' -> Millimeters (float_of_string (num_part str))
- | 'p' -> PrinterPoint (float_of_string (num_part str))
- | _ -> Pixels(int_of_string str)
-;;
-
-##else
-
-let cCAMLtoTKunits : units -> tkArgs = function
- | `Pix (foo) -> TkToken (string_of_int foo)
- | `Mm (foo) -> TkToken(Printf.sprintf "%gm" foo)
- | `In (foo) -> TkToken(Printf.sprintf "%gi" foo)
- | `Pt (foo) -> TkToken(Printf.sprintf "%gp" foo)
- | `Cm (foo) -> TkToken(Printf.sprintf "%gc" foo)
-;;
-
-let cTKtoCAMLunits str =
- let len = String.length str in
- let num_part str = String.sub str ~pos:0 ~len:(len - 1) in
- match String.get str (pred len) with
- | 'c' -> `Cm (float_of_string (num_part str))
- | 'i' -> `In (float_of_string (num_part str))
- | 'm' -> `Mm (float_of_string (num_part str))
- | 'p' -> `Pt (float_of_string (num_part str))
- | _ -> `Pix(int_of_string str)
-;;
-
-##endif
diff --git a/otherlibs/labltk/builtin/builtini_ScrollValue.ml b/otherlibs/labltk/builtin/builtini_ScrollValue.ml
deleted file mode 100644
index 08498a00d2..0000000000
--- a/otherlibs/labltk/builtin/builtini_ScrollValue.ml
+++ /dev/null
@@ -1,45 +0,0 @@
-##ifdef CAMLTK
-
-let cCAMLtoTKscrollValue = function
- ScrollPage v1 ->
- TkTokenList [TkToken"scroll"; TkToken (string_of_int v1); TkToken"pages"]
- | ScrollUnit v1 ->
- TkTokenList [TkToken"scroll"; TkToken (string_of_int v1); TkToken"units"]
- | MoveTo v1 ->
- TkTokenList [TkToken"moveto"; TkToken (Printf.sprintf "%g" v1)]
-;;
-
-(* str l -> scrllv -> str l *)
-let cTKtoCAMLscrollValue = function
- "scroll"::n::"pages"::l ->
- ScrollPage (int_of_string n), l
- | "scroll"::n::"units"::l ->
- ScrollUnit (int_of_string n), l
- | "moveto"::f::l ->
- MoveTo (float_of_string f), l
- | _ -> raise (Invalid_argument "TKtoCAMLscrollValue")
-;;
-
-##else
-
-let cCAMLtoTKscrollValue : scrollValue -> tkArgs = function
- | `Page v1 ->
- TkTokenList [TkToken"scroll"; TkToken (string_of_int v1); TkToken"pages"]
- | `Unit v1 ->
- TkTokenList [TkToken"scroll"; TkToken (string_of_int v1); TkToken"units"]
- | `Moveto v1 ->
- TkTokenList [TkToken"moveto"; TkToken (Printf.sprintf "%g" v1)]
-;;
-
-(* str l -> scrllv -> str l *)
-let cTKtoCAMLscrollValue = function
- | "scroll" :: n :: "pages" :: l ->
- `Page (int_of_string n), l
- | "scroll" :: n :: "units" :: l ->
- `Unit (int_of_string n), l
- | "moveto" :: f :: l ->
- `Moveto (float_of_string f), l
- | _ -> raise (Invalid_argument "TKtoCAMLscrollValue")
-;;
-
-##endif
diff --git a/otherlibs/labltk/builtin/builtini_bind.ml b/otherlibs/labltk/builtin/builtini_bind.ml
deleted file mode 100644
index 13109cb0a9..0000000000
--- a/otherlibs/labltk/builtin/builtini_bind.ml
+++ /dev/null
@@ -1,136 +0,0 @@
-##ifdef CAMLTK
-
-let cCAMLtoTKxEvent = function
- | Activate -> "Activate"
- | ButtonPress -> "ButtonPress"
- | ButtonPressDetail n -> "ButtonPress-"^string_of_int n
- | ButtonRelease -> "ButtonRelease"
- | ButtonReleaseDetail n -> "ButtonRelease-"^string_of_int n
- | Circulate -> "Circulate"
- | ColorMap -> "Colormap"
- | Configure -> "Configure"
- | Deactivate -> "Deactivate"
- | Destroy -> "Destroy"
- | Enter -> "Enter"
- | Expose -> "Expose"
- | FocusIn -> "FocusIn"
- | FocusOut -> "FocusOut"
- | Gravity -> "Gravity"
- | KeyPress -> "KeyPress"
- | KeyPressDetail s -> "KeyPress-"^s
- | KeyRelease -> "KeyRelease"
- | KeyReleaseDetail s -> "KeyRelease-"^s
- | Leave -> "Leave"
- | Map -> "Map"
- | Motion -> "Motion"
- | Property -> "Property"
- | Reparent -> "Reparent"
- | Unmap -> "Unmap"
- | Visibility -> "Visibility"
- | Virtual s -> "<"^s^">"
-;;
-
-let cCAMLtoTKmodifier = function
- | Control -> "Control-"
- | Shift -> "Shift-"
- | Lock -> "Lock-"
- | Button1 -> "Button1-"
- | Button2 -> "Button2-"
- | Button3 -> "Button3-"
- | Button4 -> "Button4-"
- | Button5 -> "Button5-"
- | Double -> "Double-"
- | Triple -> "Triple-"
- | Mod1 -> "Mod1-"
- | Mod2 -> "Mod2-"
- | Mod3 -> "Mod3-"
- | Mod4 -> "Mod4-"
- | Mod5 -> "Mod5-"
- | Meta -> "Meta-"
- | Alt -> "Alt-"
-;;
-
-exception IllegalVirtualEvent
-
-(* type event = modifier list * xEvent *)
-let cCAMLtoTKevent (ml, xe) =
- match xe with
- | Virtual s ->
- if ml = [] then "<<"^s^">>"
- else raise IllegalVirtualEvent
- | _ ->
- "<" ^ (String.concat " " (List.map cCAMLtoTKmodifier ml))
- ^ (cCAMLtoTKxEvent xe) ^ ">"
-;;
-
-(* type eventSequence == (modifier list * xEvent) list *)
-let cCAMLtoTKeventSequence l =
- TkToken(List.fold_left (^) "" (List.map cCAMLtoTKevent l))
-
-##else
-
-let cCAMLtoTKmodifier : modifier -> string = function
- | `Control -> "Control-"
- | `Shift -> "Shift-"
- | `Lock -> "Lock-"
- | `Button1 -> "Button1-"
- | `Button2 -> "Button2-"
- | `Button3 -> "Button3-"
- | `Button4 -> "Button4-"
- | `Button5 -> "Button5-"
- | `Double -> "Double-"
- | `Triple -> "Triple-"
- | `Mod1 -> "Mod1-"
- | `Mod2 -> "Mod2-"
- | `Mod3 -> "Mod3-"
- | `Mod4 -> "Mod4-"
- | `Mod5 -> "Mod5-"
- | `Meta -> "Meta-"
- | `Alt -> "Alt-"
-;;
-
-exception IllegalVirtualEvent
-
-let cCAMLtoTKevent (ev : event) =
- let modified = ref false in
- let rec convert = function
- | `Activate -> "Activate"
- | `ButtonPress -> "ButtonPress"
- | `ButtonPressDetail n -> "ButtonPress-"^string_of_int n
- | `ButtonRelease -> "ButtonRelease"
- | `ButtonReleaseDetail n -> "ButtonRelease-"^string_of_int n
- | `Circulate -> "Circulate"
- | `Colormap -> "Colormap"
- | `Configure -> "Configure"
- | `Deactivate -> "Deactivate"
- | `Destroy -> "Destroy"
- | `Enter -> "Enter"
- | `Expose -> "Expose"
- | `FocusIn -> "FocusIn"
- | `FocusOut -> "FocusOut"
- | `Gravity -> "Gravity"
- | `KeyPress -> "KeyPress"
- | `KeyPressDetail s -> "KeyPress-"^s
- | `KeyRelease -> "KeyRelease"
- | `KeyReleaseDetail s -> "KeyRelease-"^s
- | `Leave -> "Leave"
- | `Map -> "Map"
- | `Motion -> "Motion"
- | `Property -> "Property"
- | `Reparent -> "Reparent"
- | `Unmap -> "Unmap"
- | `Visibility -> "Visibility"
- | `Virtual s ->
- if !modified then raise IllegalVirtualEvent else "<"^s^">"
- | `Modified(ml, ev) ->
- modified := true;
- String.concat ~sep:"" (List.map ~f:cCAMLtoTKmodifier ml)
- ^ convert ev
- in "<" ^ convert ev ^ ">"
-;;
-
-let cCAMLtoTKeventSequence (l : event list) =
- TkToken(String.concat ~sep:"" (List.map ~f:cCAMLtoTKevent l))
-;;
-
-##endif
diff --git a/otherlibs/labltk/builtin/builtini_bindtags.ml b/otherlibs/labltk/builtin/builtini_bindtags.ml
deleted file mode 100644
index e09734870c..0000000000
--- a/otherlibs/labltk/builtin/builtini_bindtags.ml
+++ /dev/null
@@ -1,29 +0,0 @@
-##ifdef CAMLTK
-
-let cCAMLtoTKbindings = function
- | WidgetBindings v1 -> cCAMLtoTKwidget widget_any_table v1
- | TagBindings v1 -> TkToken v1
-;;
-
-(* this doesn't really belong here *)
-let cTKtoCAMLbindings s =
- if String.length s > 0 && s.[0] = '.' then
- WidgetBindings (cTKtoCAMLwidget s)
- else TagBindings s
-;;
-
-##else
-
-let cCAMLtoTKbindings = function
-| `Widget v1 -> cCAMLtoTKwidget v1
-| `Tag v1 -> TkToken v1
-;;
-
-(* this doesn't really belong here *)
-let cTKtoCAMLbindings s =
- if String.length s > 0 && s.[0] = '.' then
- `Widget (cTKtoCAMLwidget s)
- else `Tag s
-;;
-
-##endif
diff --git a/otherlibs/labltk/builtin/builtini_font.ml b/otherlibs/labltk/builtin/builtini_font.ml
deleted file mode 100644
index 521b24d6d5..0000000000
--- a/otherlibs/labltk/builtin/builtini_font.ml
+++ /dev/null
@@ -1,3 +0,0 @@
-let cCAMLtoTKfont (s : font) = TkToken s
-let cTKtoCAMLfont (s : font) = s
-
diff --git a/otherlibs/labltk/builtin/builtini_grab.ml b/otherlibs/labltk/builtin/builtini_grab.ml
deleted file mode 100644
index 9007d04fa7..0000000000
--- a/otherlibs/labltk/builtin/builtini_grab.ml
+++ /dev/null
@@ -1,2 +0,0 @@
-let cCAMLtoTKgrabGlobal x =
- if x then TkToken "-global" else TkTokenList []
diff --git a/otherlibs/labltk/builtin/builtini_index.ml b/otherlibs/labltk/builtin/builtini_index.ml
deleted file mode 100644
index 7718cab952..0000000000
--- a/otherlibs/labltk/builtin/builtini_index.ml
+++ /dev/null
@@ -1,140 +0,0 @@
-##ifdef CAMLTK
-
-(* sp to avoid being picked up by doc scripts *)
- type index_constrs =
- CNumber
- | CActiveElement
- | CEnd
- | CLast
- | CNoIndex
- | CInsert
- | CSelFirst
- | CSelLast
- | CAt
- | CAtXY
- | CAnchorPoint
- | CPattern
- | CLineChar
- | CMark
- | CTagFirst
- | CTagLast
- | CEmbedded
-;;
-
-let index_any_table =
- [CNumber; CActiveElement; CEnd; CLast; CNoIndex; CInsert; CSelFirst;
- CSelLast; CAt; CAtXY; CAnchorPoint; CPattern; CLineChar;
- CMark; CTagFirst; CTagLast; CEmbedded]
-;;
-
-let index_canvas_table =
- [CNumber; CEnd; CInsert; CSelFirst; CSelLast; CAtXY]
-;;
-let index_entry_table =
- [CNumber; CAnchorPoint; CEnd; CInsert; CSelFirst; CSelLast; CAt]
-;;
-let index_listbox_table =
- [CNumber; CActiveElement; CAnchorPoint; CEnd; CAtXY]
-;;
-let index_menu_table =
- [CNumber; CActiveElement; CEnd; CLast; CNoIndex; CAt; CPattern]
-;;
-let index_text_table =
- [CLineChar; CAtXY; CEnd; CMark; CTagFirst; CTagLast; CEmbedded]
-;;
-
-let cCAMLtoTKindex table = function
- Number x -> chk_sub "Number" table CNumber; TkToken (string_of_int x)
- | ActiveElement -> chk_sub "ActiveElement" table CActiveElement; TkToken "active"
- | End -> chk_sub "End" table CEnd; TkToken "end"
- | Last -> chk_sub "Last" table CLast; TkToken "last"
- | NoIndex -> chk_sub "NoIndex" table CNoIndex; TkToken "none"
- | Insert -> chk_sub "Insert" table CInsert; TkToken "insert"
- | SelFirst -> chk_sub "SelFirst" table CSelFirst; TkToken "sel.first"
- | SelLast -> chk_sub "SelLast" table CSelLast; TkToken "sel.last"
- | At n -> chk_sub "At" table CAt; TkToken ("@"^string_of_int n)
- | AtXY (x,y) -> chk_sub "AtXY" table CAtXY;
- TkToken ("@"^string_of_int x^","^string_of_int y)
- | AnchorPoint -> chk_sub "AnchorPoint" table CAnchorPoint; TkToken "anchor"
- | Pattern s -> chk_sub "Pattern" table CPattern; TkToken s
- | LineChar (l,c) -> chk_sub "LineChar" table CLineChar;
- TkToken (string_of_int l^"."^string_of_int c)
- | Mark s -> chk_sub "Mark" table CMark; TkToken s
- | TagFirst t -> chk_sub "TagFirst" table CTagFirst;
- TkToken (t^".first")
- | TagLast t -> chk_sub "TagLast" table CTagLast;
- TkToken (t^".last")
- | Embedded w -> chk_sub "Embedded" table CEmbedded;
- cCAMLtoTKwidget widget_any_table w
-;;
-
-let char_index c s =
- let rec find i =
- if i >= String.length s
- then raise Not_found
- else if String.get s i = c then i
- else find (i+1) in
- find 0
-;;
-
-(* Assume returned values are only numerical and l.c *)
-(* .menu index returns none if arg is none, but blast it *)
-let cTKtoCAMLindex s =
- try
- let p = char_index '.' s in
- LineChar(int_of_string (String.sub s 0 p),
- int_of_string (String.sub s (p+1) (String.length s - p - 1)))
- with
- Not_found ->
- try Number (int_of_string s)
- with _ -> raise (Invalid_argument ("TKtoCAMLindex: "^s))
-;;
-
-##else
-
-let cCAMLtoTKindex (* Don't put explicit typing *) = function
- | `Num x -> TkToken (string_of_int x)
- | `Active -> TkToken "active"
- | `End -> TkToken "end"
- | `Last -> TkToken "last"
- | `None -> TkToken "none"
- | `Insert -> TkToken "insert"
- | `Selfirst -> TkToken "sel.first"
- | `Sellast -> TkToken "sel.last"
- | `At n -> TkToken ("@" ^ string_of_int n)
- | `Atxy (x,y) -> TkToken ("@" ^ string_of_int x ^ "," ^ string_of_int y)
- | `Anchor -> TkToken "anchor"
- | `Pattern s -> TkToken s
- | `Linechar (l,c) -> TkToken (string_of_int l ^ "." ^ string_of_int c)
- | `Mark s -> TkToken s
- | `Tagfirst t -> TkToken (t ^ ".first")
- | `Taglast t -> TkToken (t ^ ".last")
- | `Window (w : any widget) -> cCAMLtoTKwidget w
- | `Image s -> TkToken s
-;;
-
-let cCAMLtoTKcanvas_index = (cCAMLtoTKindex : canvas_index -> tkArgs);;
-let cCAMLtoTKentry_index = (cCAMLtoTKindex : entry_index -> tkArgs);;
-let cCAMLtoTKlistbox_index = (cCAMLtoTKindex : listbox_index -> tkArgs);;
-let cCAMLtoTKmenu_index = (cCAMLtoTKindex : menu_index -> tkArgs);;
-let cCAMLtoTKtext_index = (cCAMLtoTKindex : text_index -> tkArgs);;
-
-(* Assume returned values are only numerical and l.c *)
-
-let cTKtoCAMLtext_index s =
- try
- let p = String.index s '.' in
- `Linechar (int_of_string (String.sub s ~pos:0 ~len:p),
- int_of_string (String.sub s ~pos:(p + 1)
- ~len:(String.length s - p - 1)))
- with
- Not_found ->
- raise (Invalid_argument ("TKtoCAMLtext_index: " ^ s))
-;;
-
-let cTKtoCAMLlistbox_index s =
- try `Num (int_of_string s)
- with _ -> raise (Invalid_argument ("TKtoCAMLlistbox_index: " ^ s))
-;;
-
-##endif
diff --git a/otherlibs/labltk/builtin/builtini_palette.ml b/otherlibs/labltk/builtin/builtini_palette.ml
deleted file mode 100644
index e1fe37dbe4..0000000000
--- a/otherlibs/labltk/builtin/builtini_palette.ml
+++ /dev/null
@@ -1,19 +0,0 @@
-##ifdef CAMLTK
-
-let cCAMLtoTKpaletteType = function
- GrayShades (foo) -> TkToken (string_of_int foo)
- | RGBShades (r,v,b) -> TkToken (string_of_int r^"/"^
- string_of_int v^"/"^
- string_of_int b)
-;;
-
-##else
-
-let cCAMLtoTKpaletteType : paletteType -> tkArgs = function
- | `Gray (foo) -> TkToken (string_of_int foo)
- | `Rgb (r,v,b) -> TkToken (string_of_int r ^ "/" ^
- string_of_int v ^ "/" ^
- string_of_int b)
-;;
-
-##endif
diff --git a/otherlibs/labltk/builtin/builtini_text.ml b/otherlibs/labltk/builtin/builtini_text.ml
deleted file mode 100644
index 966c28a325..0000000000
--- a/otherlibs/labltk/builtin/builtini_text.ml
+++ /dev/null
@@ -1,64 +0,0 @@
-let cCAMLtoTKtextMark x = TkToken x;;
-let cTKtoCAMLtextMark x = x;;
-
-let cCAMLtoTKtextTag x = TkToken x;;
-let cTKtoCAMLtextTag x = x;;
-
-##ifdef CAMLTK
-
-(* TextModifiers are never returned by Tk *)
-let ppTextModifier = function
- CharOffset n ->
- if n > 0 then "+" ^ (string_of_int n) ^ "chars"
- else if n = 0 then ""
- else (string_of_int n) ^ "chars"
- | LineOffset n ->
- if n > 0 then "+" ^ (string_of_int n) ^ "lines"
- else if n = 0 then ""
- else (string_of_int n) ^ "lines"
- | LineStart -> " linestart"
- | LineEnd -> " lineend"
- | WordStart -> " wordstart"
- | WordEnd -> " wordend"
-;;
-
-let ppTextIndex = function
- | TextIndexNone -> ""
- | TextIndex (base, ml) ->
- match cCAMLtoTKindex index_text_table base with
- | TkToken ppbase -> List.fold_left (^) ppbase (List.map ppTextModifier ml)
- | _ -> assert false
-;;
-
-let cCAMLtoTKtextIndex i =
- TkToken (ppTextIndex i)
-;;
-
-##else
-
-(* TextModifiers are never returned by Tk *)
-let cCAMLtoTKtextIndex (i : textIndex) =
- let ppTextModifier = function
- | `Char n ->
- if n > 0 then "+" ^ (string_of_int n) ^ "chars"
- else if n = 0 then ""
- else (string_of_int n) ^ "chars"
- | `Line n ->
- if n > 0 then "+" ^ (string_of_int n) ^ "lines"
- else if n = 0 then ""
- else (string_of_int n) ^ "lines"
- | `Linestart -> " linestart"
- | `Lineend -> " lineend"
- | `Wordstart -> " wordstart"
- | `Wordend -> " wordend"
- in
- let ppTextIndex (base, ml : textIndex) =
- match cCAMLtoTKtext_index base with
- TkToken ppbase ->
- String.concat ~sep:"" (ppbase :: List.map ~f:ppTextModifier ml)
- | _ -> assert false
- in
- TkToken (ppTextIndex i)
-;;
-
-##endif
diff --git a/otherlibs/labltk/builtin/canvas_bind.ml b/otherlibs/labltk/builtin/canvas_bind.ml
deleted file mode 100644
index 1b46fae010..0000000000
--- a/otherlibs/labltk/builtin/canvas_bind.ml
+++ /dev/null
@@ -1,52 +0,0 @@
-##ifdef CAMLTK
-
-let bind widget tag eventsequence action =
- tkCommand [|
- cCAMLtoTKwidget widget_canvas_table widget;
- TkToken "bind";
- cCAMLtoTKtagOrId tag;
- cCAMLtoTKeventSequence eventsequence;
- begin match action with
- | BindRemove -> TkToken ""
- | BindSet (what, f) ->
- let cbId = register_callback widget (wrapeventInfo f what) in
- TkToken ("camlcb " ^ cbId ^ (writeeventField what))
- | BindSetBreakable (what, f) ->
- let cbId = register_callback widget (wrapeventInfo f what) in
- TkToken ("camlcb " ^ cbId ^ (writeeventField what)^
- " ; if { $BreakBindingsSequence == 1 } then { break ;} ; \
- set BreakBindingsSequence 0")
- | BindExtend (what, f) ->
- let cbId = register_callback widget (wrapeventInfo f what) in
- TkToken ("+camlcb " ^ cbId ^ (writeeventField what))
- end
- |]
-;;
-
-##else
-
-let bind ~events
- ?(extend = false) ?(breakable = false) ?(fields = [])
- ?action widget tag =
- tkCommand
- [| cCAMLtoTKwidget widget;
- TkToken "bind";
- cCAMLtoTKtagOrId tag;
- cCAMLtoTKeventSequence events;
- begin match action with None -> TkToken ""
- | Some f ->
- let cbId =
- register_callback widget ~callback: (wrapeventInfo f fields) in
- let cb = if extend then "+camlcb " else "camlcb " in
- let cb = cb ^ cbId ^ writeeventField fields in
- let cb =
- if breakable then
- cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}"
- ^ " ; set BreakBindingsSequence 0"
- else cb in
- TkToken cb
- end
- |]
-;;
-
-##endif
diff --git a/otherlibs/labltk/builtin/canvas_bind.mli b/otherlibs/labltk/builtin/canvas_bind.mli
deleted file mode 100644
index 39ce93e7c3..0000000000
--- a/otherlibs/labltk/builtin/canvas_bind.mli
+++ /dev/null
@@ -1,16 +0,0 @@
-##ifdef CAMLTK
-
-val bind : widget -> tagOrId ->
- (modifier list * xEvent) list -> bindAction -> unit
-
-##else
-
-val bind :
- events: event list ->
- ?extend: bool ->
- ?breakable: bool ->
- ?fields: eventField list ->
- ?action: (eventInfo -> unit) ->
- canvas widget -> tagOrId -> unit
-
-##endif
diff --git a/otherlibs/labltk/builtin/dialog.ml b/otherlibs/labltk/builtin/dialog.ml
deleted file mode 100644
index e6654d8c46..0000000000
--- a/otherlibs/labltk/builtin/dialog.ml
+++ /dev/null
@@ -1,45 +0,0 @@
-##ifdef CAMLTK
-
-let create ?name parent title mesg bitmap def buttons =
- let w = Widget.new_atom "toplevel" ~parent ?name in
- let res = tkEval [|TkToken"tk_dialog";
- cCAMLtoTKwidget widget_any_table w;
- TkToken title;
- TkToken mesg;
- cCAMLtoTKbitmap bitmap;
- TkToken (string_of_int def);
- TkTokenList (List.map (function x -> TkToken x) buttons)|]
- in
- int_of_string res
-;;
-
-let create_named parent name title mesg bitmap def buttons =
- let w = Widget.new_atom "toplevel" ~parent ~name in
- let res = tkEval [|TkToken"tk_dialog";
- cCAMLtoTKwidget widget_any_table w;
- TkToken title;
- TkToken mesg;
- cCAMLtoTKbitmap bitmap;
- TkToken (string_of_int def);
- TkTokenList (List.map (function x -> TkToken x) buttons)|]
- in
- int_of_string res
-;;
-
-##else
-
-let create ~parent ~title ~message ~buttons ?name
- ?(bitmap = `Predefined "") ?(default = -1) () =
- let w = Widget.new_atom "toplevel" ?name ~parent in
- let res = tkEval [|TkToken"tk_dialog";
- cCAMLtoTKwidget w;
- TkToken title;
- TkToken message;
- cCAMLtoTKbitmap bitmap;
- TkToken (string_of_int default);
- TkTokenList (List.map ~f:(fun x -> TkToken x) buttons)|]
- in
- int_of_string res
-;;
-
-##endif
diff --git a/otherlibs/labltk/builtin/dialog.mli b/otherlibs/labltk/builtin/dialog.mli
deleted file mode 100644
index debb6ce207..0000000000
--- a/otherlibs/labltk/builtin/dialog.mli
+++ /dev/null
@@ -1,24 +0,0 @@
-##ifdef CAMLTK
-
-val create : ?name: string ->
- widget -> string -> string -> bitmap -> int -> string list -> int
- (* [create ~name parent title message bitmap default button_names]
- cf. tk_dialog *)
-
-val create_named :
- widget -> string -> string -> string -> bitmap -> int -> string list -> int
- (* [create_named parent name title message bitmap default button_names]
- cf. tk_dialog *)
-
-##else
-
-val create :
- parent: 'a widget ->
- title: string ->
- message: string ->
- buttons: string list ->
- ?name: string -> ?bitmap: bitmap -> ?default: int -> unit ->int
- (* [create title message bitmap default button_names parent]
- cf. tk_dialog *)
-
-##endif
diff --git a/otherlibs/labltk/builtin/image.ml b/otherlibs/labltk/builtin/image.ml
deleted file mode 100644
index ac4c7238a9..0000000000
--- a/otherlibs/labltk/builtin/image.ml
+++ /dev/null
@@ -1,33 +0,0 @@
-##ifdef CAMLTK
-
-let cTKtoCAMLimage s =
- let res = tkEval [|TkToken "image"; TkToken "type"; TkToken s|] in
- match res with
- | "bitmap" -> ImageBitmap (BitmapImage s)
- | "photo" -> ImagePhoto (PhotoImage s)
- | _ -> raise (TkError ("unknown image type \"" ^ res ^ "\""))
-;;
-
-let names () =
- let res = tkEval [|TkToken "image"; TkToken "names"|] in
- let names = splitlist res in
- List.map cTKtoCAMLimage names
-;;
-
-##else
-
-let cTKtoCAMLimage s =
- let res = tkEval [|TkToken "image"; TkToken "type"; TkToken s|] in
- match res with
- | "bitmap" -> `Bitmap s
- | "photo" -> `Photo s
- | _ -> raise (TkError ("unknown image type \"" ^ res ^ "\""))
-;;
-
-let names () =
- let res = tkEval [|TkToken "image"; TkToken "names"|] in
- let names = splitlist res in
- List.map cTKtoCAMLimage names
-;;
-
-##endif
diff --git a/otherlibs/labltk/builtin/image.mli b/otherlibs/labltk/builtin/image.mli
deleted file mode 100644
index a92a9f8c70..0000000000
--- a/otherlibs/labltk/builtin/image.mli
+++ /dev/null
@@ -1,9 +0,0 @@
-##ifdef CAMLTK
-
-val names : unit -> options list
-
-##else
-
-val names : unit -> image list
-
-##endif
diff --git a/otherlibs/labltk/builtin/optionmenu.ml b/otherlibs/labltk/builtin/optionmenu.ml
deleted file mode 100644
index c0a760abae..0000000000
--- a/otherlibs/labltk/builtin/optionmenu.ml
+++ /dev/null
@@ -1,54 +0,0 @@
-##ifdef CAMLTK
-
-open Protocol;;
-(* Implementation of the tk_optionMenu *)
-
-let create ?name parent variable values =
- let w = Widget.new_atom "menubutton" ~parent ?name in
- let mw = Widget.new_atom "menu" ~parent:w ~name:"menu" in
- let res =
- tkEval [|TkToken "tk_optionMenu";
- TkToken (Widget.name w);
- cCAMLtoTKtextVariable variable;
- TkTokenList (List.map (function x -> TkToken x) values)|] in
- if res <> Widget.name mw then
- raise (TkError "internal error in Optionmenu.create")
- else
- w,mw
-;;
-
-let create_named parent name variable values =
- let w = Widget.new_atom "menubutton" ~parent ~name in
- let mw = Widget.new_atom "menu" ~parent:w ~name: "menu" in
- let res =
- tkEval [|TkToken "tk_optionMenu";
- TkToken (Widget.name w);
- cCAMLtoTKtextVariable variable;
- TkTokenList (List.map (function x -> TkToken x) values)|] in
- if res <> Widget.name mw then
- raise (TkError "internal error in Optionmenu.create")
- else
- w,mw
-;;
-
-##else
-
-open Protocol;;
-(* Implementation of the tk_optionMenu *)
-
-let create ~parent ~variable ?name values =
- let w = Widget.new_atom "menubutton" ~parent ?name in
- let mw = Widget.new_atom "menu" ~parent:w ~name:"menu" in
- (* assumes .menu naming *)
- let res =
- tkEval [|TkToken "tk_optionMenu";
- TkToken (Widget.name w);
- cCAMLtoTKtextVariable variable;
- TkTokenList (List.map ~f:(fun x -> TkToken x) values)|] in
- if res <> Widget.name mw then
- raise (TkError "internal error in Optionmenu.create")
- else
- w, mw
-;;
-
-##endif
diff --git a/otherlibs/labltk/builtin/optionmenu.mli b/otherlibs/labltk/builtin/optionmenu.mli
deleted file mode 100644
index 0c6b5c9e13..0000000000
--- a/otherlibs/labltk/builtin/optionmenu.mli
+++ /dev/null
@@ -1,21 +0,0 @@
-##ifdef CAMLTK
-
-(* Support for tk_optionMenu *)
-val create: ?name: string ->
- widget -> textVariable -> string list -> widget * widget
-(** [create ?name parent var options] creates a multi-option menubutton and
- its associated menu. The option is also stored in the variable.
- Both widgets (menubutton and menu) are returned. *)
-
-##else
-
-(* Support for tk_optionMenu *)
-val create:
- parent:'a widget ->
- variable:textVariable ->
- ?name: string -> string list -> menubutton widget * menu widget
-(** [create ~parent ~var ~name options] creates a multi-option menubutton
- and its associated menu. The option is also stored in the variable.
- Both widgets (menubutton and menu) are returned *)
-
-##endif
diff --git a/otherlibs/labltk/builtin/rawimg.ml b/otherlibs/labltk/builtin/rawimg.ml
deleted file mode 100644
index 6bd0ad2838..0000000000
--- a/otherlibs/labltk/builtin/rawimg.ml
+++ /dev/null
@@ -1,142 +0,0 @@
-external rawget : string -> string
- = "camltk_getimgdata"
-external rawset : string -> string -> int -> int -> int -> int -> unit
- = "camltk_setimgdata_bytecode" (* all int parameters MUST be positive *)
- "camltk_setimgdata_native"
-
-type t = {
- pixmap_width : int;
- pixmap_height: int;
- pixmap_data: string
-}
-
-type pixel = string (* 3 chars *)
-
-(* pixmap will be an abstract type *)
-let width pix = pix.pixmap_width
-let height pix = pix.pixmap_height
-
-
-(* note: invalid size would have been caught by String.create, but we put
- * it here for documentation purpose *)
-let create w h =
- if w < 0 || h < 0 then invalid_arg "invalid size"
- else {
- pixmap_width = w;
- pixmap_height = h;
- pixmap_data = String.create (w * h * 3);
- }
-
-(*
- * operations on pixmaps
- *)
-let unsafe_copy pix_from pix_to =
- String.unsafe_blit pix_from.pixmap_data 0
- pix_to.pixmap_data 0
- (String.length pix_from.pixmap_data)
-
-(* We check only the length. w,h might be different... *)
-let copy pix_from pix_to =
- let l = String.length pix_from.pixmap_data in
- if l <> String.length pix_to.pixmap_data then
- raise (Invalid_argument "copy: incompatible length")
- else unsafe_copy pix_from pix_to
-
-
-(* Pixel operations *)
-let unsafe_get_pixel pixmap x y =
- let pos = (y * pixmap.pixmap_width + x) * 3 in
- let r = String.create 3 in
- String.unsafe_blit pixmap.pixmap_data pos r 0 3;
- r
-
-let unsafe_set_pixel pixmap x y pixel =
- let pos = (y * pixmap.pixmap_width + x) * 3 in
- String.unsafe_blit pixel 0 pixmap.pixmap_data pos 3
-
-(* To get safe operations, we can either check x,y wrt [0,w[ and [0,h[
- or rely on blit checking. We choose the first for clarity.
- *)
-let get_pixel pix x y =
- if x < 0 || y < 0 || x >= pix.pixmap_width || y >= pix.pixmap_height
- then invalid_arg "invalid pixel"
- else unsafe_get_pixel pix x y
-
-(* same check (pixel being abstract, it must be of good size *)
-let set_pixel pix x y pixel =
- if x < 0 || y < 0 || x >= pix.pixmap_width || y >= pix.pixmap_height
- then invalid_arg "invalid pixel"
- else unsafe_set_pixel pix x y pixel
-
-(* black as default_color, if at all needed *)
-let default_color = "\000\000\000"
-
-(* Char.chr does range checking *)
-let pixel r g b =
- let s = String.create 3 in
- s.[0] <- Char.chr r;
- s.[1] <- Char.chr g;
- s.[2] <- Char.chr b;
- s
-
-##ifdef CAMLTK
-
-(* create pixmap from an existing image *)
-let get photo =
- match photo with
- | PhotoImage s -> {
- pixmap_width = CImagephoto.width photo;
- pixmap_height = CImagephoto.height photo;
- pixmap_data = rawget s;
- }
-
-(* copy a full pixmap into an image *)
-let set photo pix =
- match photo with
- | PhotoImage s ->
- rawset s pix.pixmap_data 0 0 pix.pixmap_width pix.pixmap_height
-
-(* general blit of pixmap into image *)
-let blit photo pix x y w h =
- if x < 0 || y < 0 || w < 0 || h < 0 then invalid_arg "negative argument"
- else match photo with
- | PhotoImage s ->
- rawset s pix.pixmap_data x y w h
-
-(* get from a file *)
-let from_file filename =
- let img = CImagephoto.create [File filename] in
- let pix = get img in
- CImagephoto.delete img;
- pix
-
-##else
-
-(* create pixmap from an existing image *)
-let get photo =
- match photo with
- | `Photo s -> {
- pixmap_width = Imagephoto.width photo;
- pixmap_height = Imagephoto.height photo;
- pixmap_data = rawget s;
- }
-
-(* copy a full pixmap into an image *)
-let set photo pix =
- match photo with
- | `Photo s -> rawset s pix.pixmap_data 0 0 pix.pixmap_width pix.pixmap_height
-
-(* general blit of pixmap into image *)
-let blit photo pix x y w h =
- if x < 0 || y < 0 || w < 0 || h < 0 then invalid_arg "negative argument"
- else match photo with
- | `Photo s -> rawset s pix.pixmap_data x y w h
-
-(* get from a file *)
-let from_file filename =
- let img = Imagephoto.create ~file: filename () in
- let pix = get img in
- Imagephoto.delete img;
- pix
-
-##endif
diff --git a/otherlibs/labltk/builtin/rawimg.mli b/otherlibs/labltk/builtin/rawimg.mli
deleted file mode 100644
index 1bb120f648..0000000000
--- a/otherlibs/labltk/builtin/rawimg.mli
+++ /dev/null
@@ -1,44 +0,0 @@
-(*
- * Minimal pixmap support
- *)
-
-type t
-type pixel
-
-val width : t -> int
- (* [width pixmap] *)
-val height : t -> int
- (* [height pixmap] *)
-
-val create : int -> int -> t
- (* [create width height] *)
-val get : imagePhoto -> t
- (* [get img] *)
-val set : imagePhoto -> t -> unit
- (* [set img pixmap] *)
-val blit : imagePhoto -> t -> int -> int -> int -> int -> unit
- (* [blit img pixmap x y w h] (all ints must be non-negative) *)
-val from_file : string -> t
- (* [from_file filename] *)
-
-val copy : t -> t -> unit
- (* [copy src dst] *)
-
-(*
- * Pixel operations
- *)
-val get_pixel : t -> int -> int -> pixel
- (* [get_pixel pixmap x y] *)
-val set_pixel : t -> int -> int -> pixel -> unit
- (* [set_pixel pixmap x y pixel] *)
-val default_color : pixel
-
-val pixel : int -> int -> int -> pixel
- (* [pixel r g b] (r,g,b must be in [0..255]) *)
-
-(*-*)
-(* unsafe *)
-val unsafe_copy : t -> t -> unit
-val unsafe_get_pixel : t -> int -> int -> pixel
-val unsafe_set_pixel : t -> int -> int -> pixel -> unit
-(* /unsafe *)
diff --git a/otherlibs/labltk/builtin/report.ml b/otherlibs/labltk/builtin/report.ml
deleted file mode 100644
index 852b4c141c..0000000000
--- a/otherlibs/labltk/builtin/report.ml
+++ /dev/null
@@ -1,17 +0,0 @@
-(* Report globals from protocol *)
-let opentk = Protocol.opentk
-let keywords = Protocol.keywords
-let opentk_with_args = Protocol.opentk_with_args
-let openTk = Protocol.openTk
-let openTkClass = Protocol.openTkClass
-let openTkDisplayClass = Protocol.openTkDisplayClass
-let closeTk = Protocol.closeTk
-let mainLoop = Protocol.mainLoop
-let register = Protocol.register
-
-(* From support *)
-let may = Support.may
-let maycons = Support.maycons
-
-(* From widget *)
-let coe = Widget.coe
diff --git a/otherlibs/labltk/builtin/selection_handle_set.ml b/otherlibs/labltk/builtin/selection_handle_set.ml
deleted file mode 100644
index fe19489a51..0000000000
--- a/otherlibs/labltk/builtin/selection_handle_set.ml
+++ /dev/null
@@ -1,41 +0,0 @@
-##ifdef CAMLTK
-
-(* The function *must* use tkreturn *)
-let handle_set opts w cmd =
- tkCommand [|
- TkToken"selection";
- TkToken"handle";
- TkTokenList
- (List.map
- (function x -> cCAMLtoTKicccm w icccm_selection_handle_table x)
- opts);
- cCAMLtoTKwidget widget_any_table w;
- let id = register_callback w (function args ->
- let (a1,args) = int_of_string (List.hd args), List.tl args in
- let (a2,args) = int_of_string (List.hd args), List.tl args in
- cmd a1 a2) in
- TkToken ("camlcb "^id)
- |]
-;;
-
-##else
-
-(* The function *must* use tkreturn *)
-let handle_set ~command =
-selection_handle_icccm_optionals (fun opts w ->
- tkCommand [|
- TkToken"selection";
- TkToken"handle";
- TkTokenList opts;
- cCAMLtoTKwidget w;
- let id = register_callback w ~callback:
- begin fun args ->
- let pos = int_of_string (List.hd args) in
- let len = int_of_string (List.nth args 1) in
- tkreturn (command ~pos ~len)
- end
- in TkToken ("camlcb " ^ id)
- |])
-;;
-
-##endif
diff --git a/otherlibs/labltk/builtin/selection_handle_set.mli b/otherlibs/labltk/builtin/selection_handle_set.mli
deleted file mode 100644
index 66ae6b7349..0000000000
--- a/otherlibs/labltk/builtin/selection_handle_set.mli
+++ /dev/null
@@ -1,13 +0,0 @@
-##ifdef CAMLTK
-
-val handle_set : icccm list -> widget -> (int -> int -> unit) -> unit
-(** tk invocation: selection handle <icccm list> <widget> <command> *)
-
-##else
-
-val handle_set :
- command: (pos:int -> len:int -> string) ->
- ?format: string -> ?selection:string -> ?typ: string -> 'a widget -> unit
-(** tk invocation: selection handle <icccm list> <widget> <command> *)
-
-##endif
diff --git a/otherlibs/labltk/builtin/selection_own_set.ml b/otherlibs/labltk/builtin/selection_own_set.ml
deleted file mode 100644
index 253cdb5b64..0000000000
--- a/otherlibs/labltk/builtin/selection_own_set.ml
+++ /dev/null
@@ -1,29 +0,0 @@
-##ifdef CAMLTK
-
-(* builtin to handle callback association to widget *)
-let own_set v1 v2 =
- tkCommand [|
- TkToken"selection";
- TkToken"own";
- TkTokenList
- (List.map
- (function x -> cCAMLtoTKicccm v2 icccm_selection_ownset_table x)
- v1);
- cCAMLtoTKwidget widget_any_table v2
- |]
-;;
-
-##else
-
-(* builtin to handle callback association to widget *)
-let own_set ?command =
- selection_ownset_icccm_optionals ?command (fun opts w ->
- tkCommand [|
- TkToken"selection";
- TkToken"own";
- TkTokenList opts;
- cCAMLtoTKwidget w
- |])
-;;
-
-##endif
diff --git a/otherlibs/labltk/builtin/selection_own_set.mli b/otherlibs/labltk/builtin/selection_own_set.mli
deleted file mode 100644
index 95b3de363c..0000000000
--- a/otherlibs/labltk/builtin/selection_own_set.mli
+++ /dev/null
@@ -1,12 +0,0 @@
-##ifdef CAMLTK
-
-val own_set : icccm list -> widget -> unit
-(** tk invocation: selection own <icccm list> <widget> *)
-
-##else
-
-val own_set :
- ?command:(unit->unit) -> ?selection:string -> 'a widget -> unit
-(** tk invocation: selection own <icccm list> <widget> *)
-
-##endif
diff --git a/otherlibs/labltk/builtin/text_tag_bind.ml b/otherlibs/labltk/builtin/text_tag_bind.ml
deleted file mode 100644
index 7a1bab3a5d..0000000000
--- a/otherlibs/labltk/builtin/text_tag_bind.ml
+++ /dev/null
@@ -1,55 +0,0 @@
-##ifdef CAMLTK
-
-let tag_bind widget tag eventsequence action =
- check_class widget widget_text_table;
- tkCommand [|
- cCAMLtoTKwidget widget_text_table widget;
- TkToken "tag";
- TkToken "bind";
- cCAMLtoTKtextTag tag;
- cCAMLtoTKeventSequence eventsequence;
- begin match action with
- | BindRemove -> TkToken ""
- | BindSet (what, f) ->
- let cbId = register_callback widget (wrapeventInfo f what) in
- TkToken ("camlcb " ^ cbId ^ (writeeventField what))
- | BindSetBreakable (what, f) ->
- let cbId = register_callback widget (wrapeventInfo f what) in
- TkToken ("camlcb " ^ cbId ^ (writeeventField what) ^
- " ; if { $BreakBindingsSequence == 1 } then { break ;} ; \
- set BreakBindingsSequence 0")
- | BindExtend (what, f) ->
- let cbId = register_callback widget (wrapeventInfo f what) in
- TkToken ("+camlcb " ^ cbId ^ (writeeventField what))
- end
- |]
-;;
-
-##else
-
-let tag_bind ~tag ~events ?(extend = false) ?(breakable = false)
- ?(fields = []) ?action widget =
- tkCommand [|
- cCAMLtoTKwidget widget;
- TkToken "tag";
- TkToken "bind";
- cCAMLtoTKtextTag tag;
- cCAMLtoTKeventSequence events;
- begin match action with
- | None -> TkToken ""
- | Some f ->
- let cbId =
- register_callback widget ~callback: (wrapeventInfo f fields) in
- let cb = if extend then "+camlcb " else "camlcb " in
- let cb = cb ^ cbId ^ writeeventField fields in
- let cb =
- if breakable then
- cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}"
- ^ " ; set BreakBindingsSequence 0"
- else cb in
- TkToken cb
- end
- |]
-;;
-
-##endif
diff --git a/otherlibs/labltk/builtin/text_tag_bind.mli b/otherlibs/labltk/builtin/text_tag_bind.mli
deleted file mode 100644
index 1f334a796c..0000000000
--- a/otherlibs/labltk/builtin/text_tag_bind.mli
+++ /dev/null
@@ -1,13 +0,0 @@
-##ifdef CAMLTK
-
-val tag_bind:
- widget -> textTag -> (modifier list * xEvent) list -> bindAction -> unit
-
-##else
-
-val tag_bind :
- tag: string -> events: event list ->
- ?extend: bool -> ?breakable: bool -> ?fields: eventField list ->
- ?action: (eventInfo -> unit) -> text widget -> unit
-
-##endif
diff --git a/otherlibs/labltk/builtin/winfo_contained.ml b/otherlibs/labltk/builtin/winfo_contained.ml
deleted file mode 100644
index f1fb3735ca..0000000000
--- a/otherlibs/labltk/builtin/winfo_contained.ml
+++ /dev/null
@@ -1,13 +0,0 @@
-##ifdef CAMLTK
-
-let contained x y w =
- w = containing x y
-;;
-
-##else
-
-let contained ~x ~y w =
- forget_type w = containing ~x ~y ()
-;;
-
-##endif
diff --git a/otherlibs/labltk/builtin/winfo_contained.mli b/otherlibs/labltk/builtin/winfo_contained.mli
deleted file mode 100644
index 41cc57c0f1..0000000000
--- a/otherlibs/labltk/builtin/winfo_contained.mli
+++ /dev/null
@@ -1,11 +0,0 @@
-##ifdef CAMLTK
-
-val contained : int -> int -> widget -> bool
-(** [contained x y w] returns true if (x,y) is in w *)
-
-##else
-
-val contained : x:int -> y:int -> 'a widget -> bool
-(** [contained x y w] returns true if (x,y) is in w *)
-
-##endif
diff --git a/otherlibs/labltk/camltk/.cvsignore b/otherlibs/labltk/camltk/.cvsignore
deleted file mode 100644
index 585067641e..0000000000
--- a/otherlibs/labltk/camltk/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-*.ml *.mli labltktop labltk
-modules
-.depend
diff --git a/otherlibs/labltk/camltk/Makefile b/otherlibs/labltk/camltk/Makefile
deleted file mode 100644
index afa6f3af26..0000000000
--- a/otherlibs/labltk/camltk/Makefile
+++ /dev/null
@@ -1,45 +0,0 @@
-include ../support/Makefile.common
-
-COMPFLAGS= -I ../support
-
-TOPDEPS = $(TOPDIR)/toplevel/toplevellib.cma $(TOPDIR)/toplevel/topmain.cmo
-
-all: camltkobjs
-
-opt: camltkobjsx
-
-include ./modules
-
-CAMLTKOBJS= $(CWIDGETOBJS) cTk.cmo camltk.cmo
-CAMLTKOBJSX = $(CAMLTKOBJS:.cmo=.cmx)
-
-camltkobjs: $(CAMLTKOBJS)
-
-camltkobjsx: $(CAMLTKOBJSX)
-
-clean:
- $(MAKE) -f Makefile.gen clean
-
-install: $(CAMLTKOBJS)
- if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi
- cp $(CAMLTKOBJS:.cmo=.cmi) $(CWIDGETOBJS:.cmo=.mli) $(INSTALLDIR)
- chmod 644 $(INSTALLDIR)/*.cmi
-
-installopt: $(CAMLTKOBJSX)
- @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi
- cp $(CAMLTKOBJSX) $(INSTALLDIR)
- chmod 644 $(INSTALLDIR)/*.cmx
-
-.SUFFIXES :
-.SUFFIXES : .mli .ml .cmi .cmx .cmo .mlp
-
-.mli.cmi:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-include .depend
diff --git a/otherlibs/labltk/camltk/Makefile.gen b/otherlibs/labltk/camltk/Makefile.gen
deleted file mode 100644
index 1e4f50a10a..0000000000
--- a/otherlibs/labltk/camltk/Makefile.gen
+++ /dev/null
@@ -1,46 +0,0 @@
-include ../support/Makefile.common
-
-all: cTk.ml camltk.ml .depend
-
-_tkgen.ml: ../Widgets.src ../compiler/tkcompiler
- cd ..; ../../boot/ocamlrun compiler/tkcompiler -camltk -outdir camltk
-
-cTk.ml camltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp #../builtin/builtin_*.ml
- (echo '##define CAMLTK'; \
- echo 'include Camltkwrap'; \
- echo 'open Widget'; \
- echo 'open Protocol'; \
- echo 'open Textvariable'; \
- echo ; \
- cat ../builtin/report.ml; \
- echo ; \
- cat ../builtin/builtin_*.ml; \
- echo ; \
- cat _tkgen.ml; \
- echo ; \
- echo ; \
- echo 'module Tkintf = struct'; \
- cat ../builtin/builtini_*.ml; \
- cat _tkigen.ml; \
- echo 'end (* module Tkintf *)'; \
- echo ; \
- echo ; \
- echo 'open Tkintf' ;\
- echo ; \
- echo ; \
- cat ../builtin/builtinf_*.ml; \
- cat _tkfgen.ml; \
- echo ; \
- ) > _cTk.ml
- ../../../boot/ocamlrun ../compiler/pp < _cTk.ml > cTk.ml
- rm -f _cTk.ml
- $(CAMLDEP) -I ../support [a-z]*.mli [a-z]*.ml > .depend
-
-../compiler/pp:
- cd ../compiler; $(MAKE) pp
-
-# All .{ml,mli} files are generated in this directory
-clean:
- rm -f *.cm* *.ml *.mli *.o *.a .depend
-
-# rm -f modules
diff --git a/otherlibs/labltk/camltk/Makefile.gen.nt b/otherlibs/labltk/camltk/Makefile.gen.nt
deleted file mode 100644
index 71a7c143f9..0000000000
--- a/otherlibs/labltk/camltk/Makefile.gen.nt
+++ /dev/null
@@ -1,46 +0,0 @@
-include ../support/Makefile.common.nt
-
-all: cTk.ml camltk.ml .depend
-
-_tkgen.ml: ../Widgets.src ../compiler/tkcompiler.exe
- cd .. ; ../../boot/ocamlrun compiler/tkcompiler.exe -camltk -outdir camltk
-
-# dependencies are broken: wouldn't work with gmake 3.77
-
-cTk.ml camltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp.exe #../builtin/builtin_*.ml
- (echo '##define CAMLTK'; \
- echo 'include Camltkwrap'; \
- echo 'open Widget'; \
- echo 'open Protocol'; \
- echo 'open Textvariable'; \
- echo ; \
- cat ../builtin/report.ml; \
- echo ; \
- cat ../builtin/builtin_*.ml; \
- echo ; \
- cat _tkgen.ml; \
- echo ; \
- echo ; \
- echo 'module Tkintf = struct'; \
- cat ../builtin/builtini_*.ml; \
- cat _tkigen.ml; \
- echo 'end (* module Tkintf *)'; \
- echo ; \
- echo ; \
- echo 'open Tkintf' ;\
- echo ; \
- echo ; \
- cat ../builtin/builtinf_*.ml; \
- cat _tkfgen.ml; \
- echo ; \
- ) > _cTk.ml
- ../../../boot/ocamlrun ../compiler/pp < _cTk.ml > cTk.ml
- rm -f _cTk.ml
- $(CAMLDEP) -slash -I ../support [a-z]*.mli [a-z]*.ml > .depend
-
-../compiler/pp.exe:
- cd ../compiler; $(MAKEREC) pp.exe
-
-clean:
- rm -f *.cm* *.ml *.mli *.$(O) *.$(A)
-# rm -f modules .depend
diff --git a/otherlibs/labltk/camltk/Makefile.nt b/otherlibs/labltk/camltk/Makefile.nt
deleted file mode 100644
index 6c81dbc494..0000000000
--- a/otherlibs/labltk/camltk/Makefile.nt
+++ /dev/null
@@ -1,43 +0,0 @@
-include ../support/Makefile.common.nt
-
-COMPFLAGS= -I ../support
-
-all: camltkobjs
-
-opt: camltkobjsx
-
-# All .{ml,mli} files are generated in this directory
-clean :
- rm -f *.cm* *.ml *.mli *.$(A) *.$(O)
- $(MAKE) -f Makefile.gen.nt clean
-
-include ./modules
-
-CAMLTKOBJS = $(WIDGETOBJS) cTk.cmo camltk.cmo
-CAMLTKOBJSX = $(CAMLTKOBJS:.cmo=.cmx)
-
-camltkobjs: $(CAMLTKOBJS)
-
-camltkobjsx: $(CAMLTKOBJSX)
-
-install: $(CAMLTKOBJS)
- mkdir -p $(INSTALLDIR)
- cp *.cmi [a-z]*.mli $(INSTALLDIR)
-
-installopt: $(CAMLTKOBJSX)
- mkdir -p $(INSTALLDIR)
- cp $(CAMLTKOBJSX) $(INSTALLDIR)
-
-.SUFFIXES :
-.SUFFIXES : .mli .ml .cmi .cmx .cmo .mlp
-
-.mli.cmi:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-include .depend
diff --git a/otherlibs/labltk/camltk/modules b/otherlibs/labltk/camltk/modules
deleted file mode 100644
index c1a2eed857..0000000000
--- a/otherlibs/labltk/camltk/modules
+++ /dev/null
@@ -1,80 +0,0 @@
-CWIDGETOBJS=cPlace.cmo cResource.cmo cWm.cmo cImagephoto.cmo cCanvas.cmo cButton.cmo cText.cmo cLabel.cmo cScrollbar.cmo cImage.cmo cEncoding.cmo cPixmap.cmo cPalette.cmo cFont.cmo cMessage.cmo cMenu.cmo cEntry.cmo cListbox.cmo cFocus.cmo cMenubutton.cmo cPack.cmo cOption.cmo cToplevel.cmo cFrame.cmo cDialog.cmo cImagebitmap.cmo cClipboard.cmo cRadiobutton.cmo cTkwait.cmo cGrab.cmo cSelection.cmo cScale.cmo cOptionmenu.cmo cWinfo.cmo cGrid.cmo cCheckbutton.cmo cBell.cmo cTkvars.cmo
-cPlace.ml cResource.ml cWm.ml cImagephoto.ml cCanvas.ml cButton.ml cText.ml cLabel.ml cScrollbar.ml cImage.ml cEncoding.ml cPixmap.ml cPalette.ml cFont.ml cMessage.ml cMenu.ml cEntry.ml cListbox.ml cFocus.ml cMenubutton.ml cPack.ml cOption.ml cToplevel.ml cFrame.ml cDialog.ml cImagebitmap.ml cClipboard.ml cRadiobutton.ml cTkwait.ml cGrab.ml cSelection.ml cScale.ml cOptionmenu.ml cWinfo.ml cGrid.ml cCheckbutton.ml cBell.ml cTkvars.ml : _tkgen.ml
-
-cPlace.cmo : cPlace.ml
-cPlace.cmi : cPlace.mli
-cResource.cmo : cResource.ml
-cResource.cmi : cResource.mli
-cWm.cmo : cWm.ml
-cWm.cmi : cWm.mli
-cImagephoto.cmo : cImagephoto.ml
-cImagephoto.cmi : cImagephoto.mli
-cCanvas.cmo : cCanvas.ml
-cCanvas.cmi : cCanvas.mli
-cButton.cmo : cButton.ml
-cButton.cmi : cButton.mli
-cText.cmo : cText.ml
-cText.cmi : cText.mli
-cLabel.cmo : cLabel.ml
-cLabel.cmi : cLabel.mli
-cScrollbar.cmo : cScrollbar.ml
-cScrollbar.cmi : cScrollbar.mli
-cImage.cmo : cImage.ml
-cImage.cmi : cImage.mli
-cEncoding.cmo : cEncoding.ml
-cEncoding.cmi : cEncoding.mli
-cPixmap.cmo : cPixmap.ml
-cPixmap.cmi : cPixmap.mli
-cPalette.cmo : cPalette.ml
-cPalette.cmi : cPalette.mli
-cFont.cmo : cFont.ml
-cFont.cmi : cFont.mli
-cMessage.cmo : cMessage.ml
-cMessage.cmi : cMessage.mli
-cMenu.cmo : cMenu.ml
-cMenu.cmi : cMenu.mli
-cEntry.cmo : cEntry.ml
-cEntry.cmi : cEntry.mli
-cListbox.cmo : cListbox.ml
-cListbox.cmi : cListbox.mli
-cFocus.cmo : cFocus.ml
-cFocus.cmi : cFocus.mli
-cMenubutton.cmo : cMenubutton.ml
-cMenubutton.cmi : cMenubutton.mli
-cPack.cmo : cPack.ml
-cPack.cmi : cPack.mli
-cOption.cmo : cOption.ml
-cOption.cmi : cOption.mli
-cToplevel.cmo : cToplevel.ml
-cToplevel.cmi : cToplevel.mli
-cFrame.cmo : cFrame.ml
-cFrame.cmi : cFrame.mli
-cDialog.cmo : cDialog.ml
-cDialog.cmi : cDialog.mli
-cImagebitmap.cmo : cImagebitmap.ml
-cImagebitmap.cmi : cImagebitmap.mli
-cClipboard.cmo : cClipboard.ml
-cClipboard.cmi : cClipboard.mli
-cRadiobutton.cmo : cRadiobutton.ml
-cRadiobutton.cmi : cRadiobutton.mli
-cTkwait.cmo : cTkwait.ml
-cTkwait.cmi : cTkwait.mli
-cGrab.cmo : cGrab.ml
-cGrab.cmi : cGrab.mli
-cSelection.cmo : cSelection.ml
-cSelection.cmi : cSelection.mli
-cScale.cmo : cScale.ml
-cScale.cmi : cScale.mli
-cOptionmenu.cmo : cOptionmenu.ml
-cOptionmenu.cmi : cOptionmenu.mli
-cWinfo.cmo : cWinfo.ml
-cWinfo.cmi : cWinfo.mli
-cGrid.cmo : cGrid.ml
-cGrid.cmi : cGrid.mli
-cCheckbutton.cmo : cCheckbutton.ml
-cCheckbutton.cmi : cCheckbutton.mli
-cBell.cmo : cBell.ml
-cBell.cmi : cBell.mli
-cTkvars.cmo : cTkvars.ml
-cTkvars.cmi : cTkvars.mli
-camltk.cmo : cTk.cmo cPlace.cmo cResource.cmo cWm.cmo cImagephoto.cmo cCanvas.cmo cButton.cmo cText.cmo cLabel.cmo cScrollbar.cmo cImage.cmo cEncoding.cmo cPixmap.cmo cPalette.cmo cFont.cmo cMessage.cmo cMenu.cmo cEntry.cmo cListbox.cmo cFocus.cmo cMenubutton.cmo cPack.cmo cOption.cmo cToplevel.cmo cFrame.cmo cDialog.cmo cImagebitmap.cmo cClipboard.cmo cRadiobutton.cmo cTkwait.cmo cGrab.cmo cSelection.cmo cScale.cmo cOptionmenu.cmo cWinfo.cmo cGrid.cmo cCheckbutton.cmo cBell.cmo cTkvars.cmo
diff --git a/otherlibs/labltk/compiler/.cvsignore b/otherlibs/labltk/compiler/.cvsignore
deleted file mode 100644
index 060114e624..0000000000
--- a/otherlibs/labltk/compiler/.cvsignore
+++ /dev/null
@@ -1,11 +0,0 @@
-lexer.ml
-parser.output
-parser.ml
-parser.mli
-tkcompiler
-pp
-copyright.ml
-pplex.ml
-ppyac.ml
-ppyac.output
-ppyac.mli
diff --git a/otherlibs/labltk/compiler/.depend b/otherlibs/labltk/compiler/.depend
deleted file mode 100644
index d33149e8cf..0000000000
--- a/otherlibs/labltk/compiler/.depend
+++ /dev/null
@@ -1,28 +0,0 @@
-pplex.cmi: ppyac.cmi
-ppyac.cmi: code.cmi
-compile.cmo: code.cmi flags.cmo ppexec.cmo ppparse.cmo tables.cmo
-compile.cmx: code.cmi flags.cmx ppexec.cmx ppparse.cmx tables.cmx
-intf.cmo: code.cmi compile.cmo flags.cmo ppexec.cmo ppparse.cmo tables.cmo
-intf.cmx: code.cmi compile.cmx flags.cmx ppexec.cmx ppparse.cmx tables.cmx
-lexer.cmo: parser.cmi
-lexer.cmx: parser.cmx
-maincompile.cmo: code.cmi compile.cmo flags.cmo intf.cmo lexer.cmo parser.cmi \
- ppexec.cmo ppparse.cmo printer.cmo tables.cmo tsort.cmo
-maincompile.cmx: code.cmi compile.cmx flags.cmx intf.cmx lexer.cmx parser.cmx \
- ppexec.cmx ppparse.cmx printer.cmx tables.cmx tsort.cmx
-parser.cmo: flags.cmo tables.cmo parser.cmi
-parser.cmx: flags.cmx tables.cmx parser.cmi
-pp.cmo: ppexec.cmo ppparse.cmo
-pp.cmx: ppexec.cmx ppparse.cmx
-ppexec.cmo: code.cmi
-ppexec.cmx: code.cmi
-pplex.cmo: ppyac.cmi pplex.cmi
-pplex.cmx: ppyac.cmx pplex.cmi
-ppparse.cmo: pplex.cmi ppyac.cmi
-ppparse.cmx: pplex.cmx ppyac.cmx
-ppyac.cmo: code.cmi ppyac.cmi
-ppyac.cmx: code.cmi ppyac.cmi
-printer.cmo: tables.cmo
-printer.cmx: tables.cmx
-tables.cmo: tsort.cmo
-tables.cmx: tsort.cmx
diff --git a/otherlibs/labltk/compiler/Makefile b/otherlibs/labltk/compiler/Makefile
deleted file mode 100644
index a2b8453312..0000000000
--- a/otherlibs/labltk/compiler/Makefile
+++ /dev/null
@@ -1,63 +0,0 @@
-include ../support/Makefile.common
-
-OBJS= ../support/support.cmo flags.cmo copyright.cmo \
- tsort.cmo tables.cmo printer.cmo lexer.cmo \
- pplex.cmo ppyac.cmo ppexec.cmo ppparse.cmo \
- parser.cmo compile.cmo intf.cmo maincompile.cmo
-
-PPOBJS= pplex.cmo ppyac.cmo ppexec.cmo ppparse.cmo pp.cmo
-
-all: tkcompiler$(EXE) pp$(EXE)
-
-tkcompiler$(EXE) : $(OBJS)
- $(CAMLC) -g $(LINKFLAGS) -o tkcompiler$(EXE) $(OBJS)
-
-pp$(EXE): $(PPOBJS)
- $(CAMLC) -g $(LINKFLAGS) -o pp$(EXE) $(PPOBJS)
-
-lexer.ml: lexer.mll
- $(CAMLLEX) lexer.mll
-
-parser.ml parser.mli: parser.mly
- $(CAMLYACC) -v parser.mly
-
-pplex.ml: pplex.mll
- $(CAMLLEX) pplex.mll
-
-pplex.mli: ppyac.cmi
-
-ppyac.ml ppyac.mli: ppyac.mly
- $(CAMLYACC) -v ppyac.mly
-
-copyright.ml: copyright
- (echo "let copyright=\"\\"; \
- cat copyright; \
- echo "\""; \
- echo "let write ~w = w copyright;;") > copyright.ml
-
-clean :
- rm -f *.cm* parser.ml parser.mli lexer.ml copyright.ml
- rm -f pplex.ml ppyac.ml ppyac.mli ppyac.output
- rm -f tkcompiler$(EXE) pp$(EXE) parser.output
-
-scratch :
- rm -f *.cm* parser.ml parser.mli lexer.ml tkcompiler$(EXE)
- rm -f *.cm* pplex.ml ppyac.ml ppyac.mli pp$(EXE)
-
-install:
- cp tkcompiler$(EXE) $(INSTALLDIR)
- cp pp$(EXE) $(INSTALLDIR)
-
-.SUFFIXES :
-.SUFFIXES : .mli .ml .cmi .cmo .mlp
-
-.mli.cmi:
- $(CAMLCOMP) -g $(COMPFLAGS) -I ../support $<
-
-.ml.cmo:
- $(CAMLCOMP) -g $(COMPFLAGS) -I ../support $<
-
-depend: parser.ml parser.mli lexer.ml pplex.ml ppyac.ml ppyac.mli
- $(CAMLDEP) *.mli *.ml > .depend
-
-include .depend
diff --git a/otherlibs/labltk/compiler/Makefile.nt b/otherlibs/labltk/compiler/Makefile.nt
deleted file mode 100644
index 3c936ba4c6..0000000000
--- a/otherlibs/labltk/compiler/Makefile.nt
+++ /dev/null
@@ -1,63 +0,0 @@
-include ../support/Makefile.common.nt
-
-OBJS= ../support/support.cmo flags.cmo copyright.cmo \
- tsort.cmo tables.cmo printer.cmo lexer.cmo \
- pplex.cmo ppyac.cmo ppexec.cmo ppparse.cmo \
- parser.cmo compile.cmo intf.cmo maincompile.cmo
-
-PPOBJS= pplex.cmo ppyac.cmo ppexec.cmo ppparse.cmo pp.cmo
-
-all: tkcompiler.exe pp.exe
-
-tkcompiler.exe : $(OBJS)
- $(CAMLC) $(LINKFLAGS) -o tkcompiler.exe $(OBJS)
-
-pp.exe : $(PPOBJS)
- $(CAMLC) $(LINKFLAGS) -o pp.exe $(PPOBJS)
-
-lexer.ml: lexer.mll
- $(CAMLLEX) lexer.mll
-
-parser.ml parser.mli: parser.mly
- $(CAMLYACC) -v parser.mly
-
-pplex.ml: pplex.mll
- $(CAMLLEX) pplex.mll
-
-pplex.mli: ppyac.cmi
-
-ppyac.ml ppyac.mli: ppyac.mly
- $(CAMLYACC) -v ppyac.mly
-
-copyright.ml: copyright
- (echo "let copyright=\"\\"; \
- cat copyright; \
- echo "\""; \
- echo "let write ~w = w copyright;;") > copyright.ml
-
-clean :
- rm -f *.cm* parser.ml parser.mli lexer.ml copyright.ml
- rm -f pplex.ml ppyac.ml ppyac.mli ppyac.output
- rm -f tkcompiler.exe pp.exe parser.output
-
-scratch :
- rm -f *.cm* parser.ml parser.mli lexer.ml tkcompiler.exe
- rm -f *.cm* pplex.ml ppyac.ml ppyac.mli pp.exe
-
-install:
- cp tkcompiler.exe $(INSTALLDIR)
- cp pp.exe $(INSTALLDIR)
-
-.SUFFIXES :
-.SUFFIXES : .mli .ml .cmi .cmo .mlp
-
-.mli.cmi:
- $(CAMLCOMP) $(COMPFLAGS) -I ../support $<
-
-.ml.cmo:
- $(CAMLCOMP) $(COMPFLAGS) -I ../support $<
-
-depend: parser.ml parser.mli lexer.ml pplex.ml ppyac.ml ppyac.mli
- $(CAMLDEP) *.mli *.ml > .depend
-
-include .depend
diff --git a/otherlibs/labltk/compiler/code.mli b/otherlibs/labltk/compiler/code.mli
deleted file mode 100644
index 6f3e292134..0000000000
--- a/otherlibs/labltk/compiler/code.mli
+++ /dev/null
@@ -1,22 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-type code =
- | Line of string
- | Ifdef of bool * string * code list * code list option
- | Define of string
- | Undef of string
-;;
diff --git a/otherlibs/labltk/compiler/compile.ml b/otherlibs/labltk/compiler/compile.ml
deleted file mode 100644
index 891078e982..0000000000
--- a/otherlibs/labltk/compiler/compile.ml
+++ /dev/null
@@ -1,1074 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open StdLabels
-open Tables
-
-(* CONFIGURE *)
-(* if you set it true, ImagePhoto and ImageBitmap will annoy you... *)
-let safetype = true
-
-let labeloff ~at l = match l with
- "", t -> t
-| l, t -> raise (Failure ("labeloff: " ^ l ^ " at " ^ at))
-
-let labltk_labelstring l =
- if l = "" then l else
- if l.[0] = '?' then l ^ ":" else
- "~" ^ l ^ ":"
-
-let camltk_labelstring l =
- if l = "" then l else
- if l.[0] = '?' then l ^ ":" else ""
-
-let labelstring l =
- if !Flags.camltk then camltk_labelstring l
- else labltk_labelstring l
-
-let labltk_typelabel l =
- if l = "" then l else l ^ ":"
-
-let camltk_typelabel l =
- if l = "" then l
- else if l.[0] = '?' then l ^ ":" else ""
-
-let typelabel l =
- if !Flags.camltk then camltk_typelabel l
- else labltk_typelabel l
-
-let forbidden = [ "class"; "type"; "in"; "from"; "to" ]
-let nicknames =
- [ "class", "clas";
- "type", "typ" ]
-
-let small = String.lowercase
-
-let gettklabel fc =
- match fc.template with
- ListArg( StringArg s :: _ ) ->
- let s = small s in
- if s = "" then s else
- let s =
- if s.[0] = '-'
- then String.sub s ~pos:1 ~len:(String.length s - 1)
- else s
- in begin
- if List.mem s forbidden then
- try List.assoc s nicknames
- with Not_found -> small fc.var_name
- else s
- end
- | _ -> raise (Failure "gettklabel")
-
-let count ~item:x l =
- let count = ref 0 in
- List.iter ~f:(fun y -> if x = y then incr count) l;
- !count
-
-(* Extract all types from a template *)
-let rec types_of_template = function
- StringArg _ -> []
- | TypeArg (l, t) -> [l, t]
- | ListArg l -> List.flatten (List.map ~f:types_of_template l)
- | OptionalArgs (l, tl, _) ->
- begin
- match List.flatten (List.map ~f:types_of_template tl) with
- ["", t] -> ["?" ^ l, t]
- | [_, _] -> raise (Failure "0 label required")
- | _ -> raise (Failure "0 or more than 1 args in for optionals")
- end
-
-(*
- * Pretty print a type
- * used to write ML type definitions
- *)
-let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) =
- let rec ppMLtype =
- function
- Unit -> "unit"
- | Int -> "int"
- | Float -> "float"
- | Bool -> "bool"
- | Char -> "char"
- | String -> "string"
-(* new *)
- | List (Subtype (sup, sub)) ->
- if !Flags.camltk then "(* " ^ sub ^ " *) " ^ sup ^ " list"
- else begin
- if return then
- sub ^ "_" ^ sup ^ " list"
- else begin
- try
- let typdef = Hashtbl.find types_table sup in
- let fcl = List.assoc sub typdef.subtypes in
- let tklabels = List.map ~f:gettklabel fcl in
- let l = List.map fcl ~f:
- begin fun fc ->
- "?" ^ begin let p = gettklabel fc in
- if count ~item:p tklabels > 1 then small fc.var_name else p
- end
- ^ ":" ^
- let l = types_of_template fc.template in
- match l with
- [] -> "unit"
- | [lt] -> ppMLtype (labeloff lt ~at:"ppMLtype")
- | l ->
- "(" ^ String.concat ~sep:"*"
- (List.map l
- ~f:(fun lt -> ppMLtype (labeloff lt ~at:"ppMLtype")))
- ^ ")"
- end in
- String.concat ~sep:" ->\n" l
- with
- Not_found -> Printf.eprintf "ppMLtype %s/%s\n" sup sub; exit (-1)
- end
- end
- | List ty -> (ppMLtype ty) ^ " list"
- | Product tyl ->
- "(" ^ String.concat ~sep:" * " (List.map ~f:ppMLtype tyl) ^ ")"
- | Record tyl ->
- String.concat ~sep:" * "
- (List.map tyl ~f:(fun (l, t) -> typelabel l ^ ppMLtype t))
- | Subtype ("widget", sub) ->
- if !Flags.camltk then "(* " ^ sub ^" *) widget" else sub ^ " widget"
- | UserDefined "widget" ->
- if !Flags.camltk then "widget"
- else begin
- if any then "any widget" else
- let c = String.make 1 (Char.chr(Char.code 'a' + !counter)) in
- incr counter;
- "'" ^ c ^ " widget"
- end
- | UserDefined s ->
- if !Flags.camltk then s
- else begin
- (* a bit dirty hack for ImageBitmap and ImagePhoto *)
- try
- let typdef = Hashtbl.find types_table s in
- if typdef.variant then
- if return then try
- "[>" ^
- String.concat ~sep:"|"
- (List.map typdef.constructors ~f:
- begin
- fun c ->
- "`" ^ c.var_name ^
- (match types_of_template c.template with
- [] -> ""
- | l -> " of " ^ ppMLtype (Product (List.map l
- ~f:(labeloff ~at:"ppMLtype UserDefined"))))
- end) ^ "]"
- with
- Not_found -> prerr_endline ("ppMLtype " ^ s ^ " ?"); s
- else if not def && List.length typdef.constructors > 1 then
- "[< " ^ s ^ "]"
- else s
- else s
- with Not_found -> s
- end
- | Subtype (s, s') ->
- if !Flags.camltk then "(* " ^ s' ^ " *) " ^ s else s' ^ "_" ^ s
- | Function (Product tyl) ->
- raise (Failure "Function (Product tyl) ? ppMLtype")
- | Function (Record tyl) ->
- "(" ^ String.concat ~sep:" -> "
- (List.map tyl ~f:(fun (l, t) -> typelabel l ^ ppMLtype t))
- ^ " -> unit)"
- | Function ty ->
- "(" ^ (ppMLtype ty) ^ " -> unit)"
- | As (t, s) ->
- if !Flags.camltk then ppMLtype t
- else s
- in
- ppMLtype
-
-(* Produce a documentation version of a template *)
-let rec ppTemplate = function
- StringArg s -> s
- | TypeArg (l, t) -> "<" ^ ppMLtype t ^ ">"
- | ListArg l -> "{" ^ String.concat ~sep:" " (List.map ~f:ppTemplate l) ^ "}"
- | OptionalArgs (l, tl, d) ->
- "?" ^ l ^ "{" ^ String.concat ~sep:" " (List.map ~f:ppTemplate tl)
- ^ "}[<" ^ String.concat ~sep:" " (List.map ~f:ppTemplate d) ^ ">]"
-
-let doc_of_template = function
- ListArg l -> String.concat ~sep:" " (List.map ~f:ppTemplate l)
- | t -> ppTemplate t
-
-(*
- * Type definitions
- *)
-
-(* Write an ML constructor *)
-let write_constructor ~w {ml_name = mlconstr; template = t} =
- w mlconstr;
- begin match types_of_template t with
- [] -> ()
- | l -> w " of ";
- w (ppMLtype ~any:true (Product (List.map l
- ~f:(labeloff ~at:"write_constructor"))))
- end;
- w " (* tk option: "; w (doc_of_template t); w " *)"
-
-(* Write a rhs type decl *)
-let write_constructors ~w = function
- [] -> fatal_error "empty type"
- | x :: l ->
- write_constructor ~w x;
- List.iter l ~f:
- begin fun x ->
- w "\n | ";
- write_constructor ~w x
- end
-
-(* Write an ML variant *)
-let write_variant ~w {var_name = varname; template = t} =
- w "`";
- w varname;
- begin match types_of_template t with
- [] -> ()
- | l ->
- w " of ";
- w (ppMLtype ~any:true ~def:true
- (Product (List.map l ~f:(labeloff ~at:"write_variant"))))
- end;
- w " (* tk option: "; w (doc_of_template t); w " *)"
-
-let write_variants ~w = function
- [] -> fatal_error "empty variants"
- | l ->
- List.iter l ~f:
- begin fun x ->
- w "\n | ";
- write_variant ~w x
- end
-
-(* Definition of a type *)
-let labltk_write_type ~intf:w ~impl:w' name ~def:typdef =
- (* Only needed if no subtypes, otherwise use optionals *)
- if typdef.subtypes = [] then begin
- w "(* Variant type *)\n";
- w ("type " ^ name ^ " = [");
- write_variants ~w (sort_components typdef.constructors);
- w "\n]\n\n"
- end
-
-(* CamlTk: List of constructors, for runtime subtyping *)
-let write_constructor_set ~w ~sep = function
- | [] -> fatal_error "empty type"
- | x::l ->
- w ("C" ^ x.ml_name);
- List.iter l ~f: (function x ->
- w sep;
- w ("C" ^ x.ml_name))
-
-(* CamlTk: Definition of a type *)
-let camltk_write_type ~intf:w ~impl:w' name ~def:typdef =
- (* Put markers for extraction *)
- w "(* type *)\n";
- w ("type " ^ name ^ " =\n");
- w " | ";
- write_constructors ~w (sort_components typdef.constructors);
- w "\n(* /type *)\n\n";
- (* Dynamic Subtyping *)
- if typdef.subtypes <> [] then begin
- (* The set of its constructors *)
- if name = "options" then begin
- w "(* type *)\n";
- w ("type "^name^"_constrs =\n\t")
- end else begin
- (* added some prefix to avoid being picked up in documentation *)
- w ("(* no doc *) type "^name^"_constrs =\n")
- end;
- w " | ";
- write_constructor_set ~w:w ~sep: "\n | "
- (sort_components typdef.constructors);
- w "\n\n";
- (* The set of all constructors *)
- w' ("let "^name^"_any_table = [");
- write_constructor_set ~w:w' ~sep:"; "
- (sort_components typdef.constructors);
- w' ("]\n\n");
- (* The subset of constructors for each subtype *)
- List.iter ~f:(function (s,l) ->
- w' ("let "^name^"_"^s^"_table = [");
- write_constructor_set ~w:w' ~sep:"; " (sort_components l);
- w' ("]\n\n"))
- typdef.subtypes
- end
-
-let write_type ~intf:w ~impl:w' name ~def:typdef =
- (if !Flags.camltk then camltk_write_type else labltk_write_type)
- ~intf:w ~impl:w' name ~def:typdef
-
-(************************************************************)
-(* Converters *)
-(************************************************************)
-
-let rec converterTKtoCAML ~arg = function
- | Int -> "int_of_string " ^ arg
- | Float -> "float_of_string " ^ arg
- | Bool -> "(match " ^ arg ^ " with
- | \"1\" -> true
- | \"0\" -> false
- | s -> Pervasives.raise (Invalid_argument (\"cTKtoCAMLbool\" ^ s)))"
- | Char -> "String.get " ^ arg ^ " 0"
- | String -> arg
- | UserDefined s -> "cTKtoCAML" ^ s ^ " " ^ arg
- | Subtype ("widget", s') when not !Flags.camltk ->
- String.concat ~sep:" "
- ["(Obj.magic (cTKtoCAMLwidget "; arg; ") :"; s'; "widget)"]
- | Subtype (s, s') ->
- if !Flags.camltk then
- "cTKtoCAML" ^ s ^ " " ^ arg
- else
- "cTKtoCAML" ^ s' ^ "_" ^ s ^ " " ^ arg
- | List ty ->
- begin match type_parser_arity ty with
- OneToken ->
- String.concat ~sep:" "
- ["(List.map (function x ->";
- converterTKtoCAML ~arg:"x" ty; ")"; arg; ")"]
- | MultipleToken ->
- String.concat ~sep:" "
- ["iterate_converter (function x ->";
- converterTKtoCAML ~arg:"x" ty; ")"; arg; ")"]
- end
- | As (ty, _) -> converterTKtoCAML ~arg ty
- | t ->
- prerr_endline ("ERROR with " ^ arg ^ " " ^ ppMLtype t);
- fatal_error "converterTKtoCAML"
-
-
-(*******************************)
-(* Wrappers *)
-(*******************************)
-let varnames ~prefix n =
- let rec var i =
- if i > n then []
- else (prefix ^ string_of_int i) :: var (succ i)
- in var 1
-
-(*
- * generate wrapper source for callbacks
- * transform a function ... -> unit in a function : unit -> unit
- * using primitives arg_ ... from the protocol
- * Warning: sequentiality is important in generated code
- * TODO: remove arg_ stuff and process lists directly ?
- *)
-
-let rec wrapper_code ~name ty =
- match ty with
- Unit -> "(fun _ -> " ^ name ^ " ())"
- | As (ty, _) -> wrapper_code ~name ty
- | ty ->
- "(fun args ->\n " ^
- begin match ty with
- Product tyl -> raise (Failure "Product -> record was done. ???")
- | Record tyl ->
- (* variables for each component of the product *)
- let vnames = varnames ~prefix:"a" (List.length tyl) in
- (* getting the arguments *)
- let readarg =
- List.map2 vnames tyl ~f:
- begin fun v (l, ty) ->
- match type_parser_arity ty with
- OneToken ->
- "let (" ^ v ^ ", args) = " ^
- converterTKtoCAML ~arg:"(List.hd args)" ty ^
- ", List.tl args in\n "
- | MultipleToken ->
- "let (" ^ v ^ ", args) = " ^
- converterTKtoCAML ~arg:"args" ty ^
- " in\n "
- end in
- String.concat ~sep:"" readarg ^ name ^ " " ^
- String.concat ~sep:" "
- (List.map2 ~f:(fun v (l, _) ->
- if !Flags.camltk then v
- else labelstring l ^ v) vnames tyl)
-
- (* all other types are read in one operation *)
- | List ty ->
- name ^ "(" ^ converterTKtoCAML ~arg:"args" ty ^ ")"
- | String ->
- name ^ "(" ^ converterTKtoCAML ~arg:"(List.hd args)" ty ^ ")"
- | ty ->
- begin match type_parser_arity ty with
- OneToken ->
- name ^ "(" ^ converterTKtoCAML ~arg:"(List.hd args)" ty ^ ")"
- | MultipleToken ->
- "let (v, _) = " ^ converterTKtoCAML ~arg:"args" ty ^
- " in\n " ^ name ^ " v"
- end
- end ^ ")"
-
-(*************************************************************)
-(* Parsers *)
-(* are required only for values returned by commands and *)
-(* functions (table is computed by the parser) *)
-
-(* Tuples/Lists are Ok if they don't contain strings *)
-(* they will be returned as list of strings *)
-
-(* Can we generate a "parser" ?
- -> all constructors are unit and at most one int and one string, with null constr
-*)
-type parser_pieces =
- { mutable zeroary : (string * string) list ; (* kw string, ml name *)
- mutable intpar : string list; (* one at most, mlname *)
- mutable stringpar : string list (* idem *)
- }
-
-type mini_parser =
- NoParser
- | ParserPieces of parser_pieces
-
-let can_generate_parser constructors =
- let pp = {zeroary = []; intpar = []; stringpar = []} in
- if List.for_all constructors ~f:
- begin fun c ->
- let vname = if !Flags.camltk then c.ml_name else c.var_name in
- match c.template with
- ListArg [StringArg s] ->
- pp.zeroary <- (s, vname) ::
- pp.zeroary; true
- | ListArg [TypeArg(_, Int)] | ListArg[TypeArg(_, Float)] ->
- if pp.intpar <> [] then false
- else (pp.intpar <- [vname]; true)
- | ListArg [TypeArg(_, String)] ->
- if pp.stringpar <> [] then false
- else (pp.stringpar <- [vname]; true)
- | _ -> false
- end
- then ParserPieces pp
- else NoParser
-
-
-(* We can generate parsers only for simple types *)
-(* we should avoid multiple walks *)
-let labltk_write_TKtoCAML ~w name ~def:typdef =
- if typdef.parser_arity = MultipleToken then
- prerr_string ("You must write cTKtoCAML" ^ name ^
- " : string list ->" ^ name ^ " * string list\n")
- else
- let write ~consts ~name =
- match can_generate_parser consts with
- NoParser ->
- prerr_string
- ("You must write cTKtoCAML" ^ name ^ " : string ->" ^ name ^ "\n")
- | ParserPieces pp ->
- w ("let cTKtoCAML" ^ name ^ " n =\n");
- (* First check integer *)
- if pp.intpar <> [] then
- begin
- w (" try `" ^ List.hd pp.intpar ^ " (int_of_string n)\n");
- w (" with _ ->\n")
- end;
- w (" match n with\n");
- List.iter pp.zeroary ~f:
- begin fun (tk, ml) ->
- w " | \""; w tk; w "\" -> `"; w ml; w "\n"
- end;
- let final = if pp.stringpar <> [] then
- "n -> `" ^ List.hd pp.stringpar ^ " n"
- else "s -> Pervasives.raise (Invalid_argument (\"cTKtoCAML"
- ^ name ^ ": \" ^ s))"
- in
- w " | ";
- w final;
- w "\n\n"
- in
- begin
- write ~name ~consts:typdef.constructors;
- List.iter typdef.subtypes ~f: begin
- fun (subname, consts) -> write ~name:(subname ^ "_" ^ name) ~consts
- end
- end
-
-let camltk_write_TKtoCAML ~w name ~def:typdef =
- if typdef.parser_arity = MultipleToken then
- prerr_string ("You must write cTKtoCAML" ^ name ^
- " : string list ->" ^ name ^ " * string list\n")
- else
- let write ~consts ~name =
- match can_generate_parser consts with
- NoParser ->
- prerr_string
- ("You must write cTKtoCAML" ^ name ^ " : string ->" ^ name ^ "\n")
- | ParserPieces pp ->
- w ("let cTKtoCAML" ^ name ^ " n =\n");
- (* First check integer *)
- if pp.intpar <> [] then
- begin
- w (" try " ^ List.hd pp.intpar ^ " (int_of_string n)\n");
- w (" with _ ->\n")
- end;
- w (" match n with\n");
- List.iter pp.zeroary ~f:
- begin fun (tk, ml) ->
- w " | \""; w tk; w "\" -> "; w ml; w "\n"
- end;
- let final = if pp.stringpar <> [] then
- "n -> " ^ List.hd pp.stringpar ^ " n"
- else "s -> Pervasives.raise (Invalid_argument (\"cTKtoCAML"
- ^ name ^ ": \" ^ s))"
- in
- w " | ";
- w final;
- w "\n\n"
- in
- begin
- write ~name ~consts:typdef.constructors;
- List.iter typdef.subtypes ~f: begin
- fun (subname, consts) -> write ~name:(subname ^ "_" ^ name) ~consts
- end
- end
-
-let write_TKtoCAML ~w name ~def:typdef =
- (if !Flags.camltk then camltk_write_TKtoCAML else labltk_write_TKtoCAML)
- ~w name ~def: typdef
-
-(******************************)
-(* Converters *)
-(******************************)
-
-(* Produce an in-lined converter Caml -> Tk for simple types *)
-(* the converter is a function of type: <type> -> string *)
-let rec converterCAMLtoTK ~context_widget argname ty =
- match ty with
- Int -> "TkToken (string_of_int " ^ argname ^ ")"
- | Float -> "TkToken (Printf.sprintf \"%g\" " ^ argname ^ ")"
- | Bool -> "if " ^ argname ^ " then TkToken \"1\" else TkToken \"0\""
- | Char -> "TkToken (Char.escaped " ^ argname ^ ")"
- | String -> "TkToken " ^ argname
- | As (ty, _) -> converterCAMLtoTK ~context_widget argname ty
- | UserDefined s ->
- let name = "cCAMLtoTK" ^ s ^ " " in
- let args = argname in
- let args =
- if !Flags.camltk then begin
- if is_subtyped s then (* unconstraint subtype *)
- s ^ "_any_table " ^ args
- else args
- end else args
- in
- let args =
- if requires_widget_context s then
- context_widget ^ " " ^ args
- else args in
- name ^ args
- | Subtype ("widget", s') ->
- if !Flags.camltk then
- let name = "cCAMLtoTKwidget " in
- let args = "widget_"^s'^"_table "^argname in
- let args =
- if requires_widget_context "widget" then
- context_widget^" "^args
- else args in
- name^args
- else begin
- let name = "cCAMLtoTKwidget " in
- let args = "(" ^ argname ^ " : " ^ s' ^ " widget)" in
- name ^ args
- end
- | Subtype (s, s') ->
- let name =
- if !Flags.camltk then "cCAMLtoTK" ^ s ^ " "
- else "cCAMLtoTK" ^ s' ^ "_" ^ s ^ " "
- in
- let args =
- if !Flags.camltk then begin
- s^"_"^s'^"_table "^argname
- end else begin
- if safetype then "(" ^ argname ^ " : [< " ^ s' ^ "_" ^ s ^ "])"
- else argname
- end
- in
- let args =
- if requires_widget_context s then context_widget ^ " " ^ args
- else args in
- name ^ args
- | Product tyl ->
- let vars = varnames ~prefix:"z" (List.length tyl) in
- String.concat ~sep:" "
- ("let" :: String.concat ~sep:"," vars :: "=" :: argname ::
- "in TkTokenList [" ::
- String.concat ~sep:"; "
- (List.map2 vars tyl ~f:(converterCAMLtoTK ~context_widget)) ::
- ["]"])
- | List ty -> (* Just added for Imagephoto.put *)
- String.concat ~sep:" "
- [(if !Flags.camltk then
- "TkQuote (TkTokenList (List.map (fun y -> "
- else
- "TkQuote (TkTokenList (List.map ~f:(fun y -> ");
- converterCAMLtoTK ~context_widget "y" ty;
- ")";
- argname;
- "))"]
- | Function _ -> fatal_error "unexpected function type in converterCAMLtoTK"
- | Unit -> fatal_error "unexpected unit type in converterCAMLtoTK"
- | Record _ -> fatal_error "unexpected product type in converterCAMLtoTK"
-
-(*
- * Produce a list of arguments from a template
- * The idea here is to avoid allocation as much as possible
- *
- *)
-
-let code_of_template ~context_widget ?func:(funtemplate=false) template =
- let catch_opts = ref ("", "") in (* class name and first option *)
- let variables = ref [] in
- let variables2 = ref [] in
- let varcnter = ref 0 in
- let optionvar = ref None in
- let newvar1 l =
- match !optionvar with
- Some v -> optionvar := None; v
- | None ->
- incr varcnter;
- let v = "v" ^ (string_of_int !varcnter) in
- variables := (l, v) :: !variables; v in
- let newvar2 l =
- match !optionvar with
- Some v -> optionvar := None; v
- | None ->
- incr varcnter;
- let v = "v" ^ (string_of_int !varcnter) in
- variables2 := (l, v) :: !variables2; v in
- let newvar = ref newvar1 in
- let rec coderec = function
- StringArg s -> "TkToken \"" ^ s ^ "\""
- | TypeArg (_, List (Subtype (sup, sub) as ty)) when not !Flags.camltk ->
- begin try
- let typdef = Hashtbl.find types_table sup in
- let classdef = List.assoc sub typdef.subtypes in
- let lbl = gettklabel (List.hd classdef) in
- catch_opts := (sub ^ "_" ^ sup, lbl);
- newvar := newvar2;
- "TkTokenList opts"
- with Not_found ->
- raise (Failure (Printf.sprintf "type %s(%s) not found" sup sub));
- end
- | TypeArg (l, List ty) ->
- (if !Flags.camltk then
- "TkTokenList (List.map (function x -> "
- else
- "TkTokenList (List.map ~f:(function x -> ")
- ^ converterCAMLtoTK ~context_widget "x" ty
- ^ ") " ^ !newvar l ^ ")"
- | TypeArg (l, Function tyarg) ->
- "let id = register_callback " ^ context_widget
- ^ " ~callback: " ^ wrapper_code ~name:(!newvar l) tyarg
- ^ " in TkToken (\"camlcb \" ^ id)"
- | TypeArg (l, ty) -> converterCAMLtoTK ~context_widget (!newvar l) ty
- | ListArg l ->
- "TkQuote (TkTokenList ["
- ^ String.concat ~sep:";\n " (List.map ~f:coderec l) ^ "])"
- | OptionalArgs (l, tl, d) ->
- let nv = !newvar ("?" ^ l) in
- optionvar := Some nv; (* Store *)
- let argstr = String.concat ~sep:"; " (List.map ~f:coderec tl) in
- let defstr = String.concat ~sep:"; " (List.map ~f:coderec d) in
- "TkTokenList (match " ^ nv ^ " with\n"
- ^ " | Some " ^ nv ^ " -> [" ^ argstr ^ "]\n"
- ^ " | None -> [" ^ defstr ^ "])"
- in
- let code =
- if funtemplate then
- match template with
- ListArg l ->
- "[|" ^ String.concat ~sep:";\n " (List.map ~f:coderec l) ^ "|]"
- | _ -> "[|" ^ coderec template ^ "|]"
- else
- match template with
- ListArg [x] -> coderec x
- | ListArg l ->
- "TkTokenList [" ^
- String.concat ~sep:";\n " (List.map ~f:coderec l) ^
- "]"
- | _ -> coderec template
- in
- code, List.rev !variables, List.rev !variables2, !catch_opts
-
-(*
- * Converters for user defined types
- *)
-
-(* For each case of a concrete type *)
-let labltk_write_clause ~w ~context_widget comp =
- let warrow () = w " -> " in
- w "`";
- w comp.var_name;
-
- let code, variables, variables2, (co, _) =
- code_of_template ~context_widget comp.template in
-
- (* no subtype I think ... *)
- if co <> "" then raise (Failure "write_clause subtype ?");
- begin match variables with
- | [] -> warrow()
- | [x] -> w " "; w (labeloff x ~at:"write_clause"); warrow()
- | l ->
- w " ( ";
- w (String.concat ~sep:", " (List.map ~f:(labeloff ~at:"write_clause") l));
- w ")";
- warrow()
- end;
- w code
-
-let camltk_write_clause ~w ~context_widget ~subtype comp =
- let warrow () =
- w " -> ";
- if subtype then
- w ("chk_sub \""^comp.ml_name^"\" table C" ^ comp.ml_name ^ "; ")
- in
-
- w comp.ml_name; (* we use ml_name, not var_name, specialized for labltk *)
-
- let code, variables, variables2, (co, _) =
- code_of_template ~context_widget comp.template in
-
- (* no subtype I think ... *)
- if co <> "" then raise (Failure "write_clause subtype ?");
- begin match variables with
- | [] -> warrow()
- | [x] -> w " "; w (labeloff x ~at:"write_clause"); warrow()
- | l ->
- w " ( ";
- w (String.concat ~sep:", " (List.map ~f:(labeloff ~at:"write_clause") l));
- w ")";
- warrow()
- end;
- w code
-
-let write_clause ~w ~context_widget ~subtype comp =
- if !Flags.camltk then camltk_write_clause ~w ~context_widget ~subtype comp
- else labltk_write_clause ~w ~context_widget comp
-
-(* The full converter *)
-let write_CAMLtoTK ~w ~def:typdef ?safetype:(st = true) name =
- let write_one name constrs =
- let subtype = typdef.subtypes <> [] in
- w ("let cCAMLtoTK" ^ name);
- let context_widget =
- if typdef.requires_widget_context then begin
- w " w"; "w"
- end
- else
- "dummy" in
- if !Flags.camltk && subtype then w " table";
- if st then begin
- w " : ";
- if typdef.variant then w ("[< " ^ name ^ "]") else w name;
- w " -> tkArgs "
- end;
- w (" = function");
- List.iter constrs
- ~f:(fun c -> w "\n | "; write_clause ~w ~context_widget ~subtype c);
- w "\n\n\n"
- in
-
- let constrs = typdef.constructors in
- if !Flags.camltk then write_one name constrs
- else begin
- (* Only needed if no subtypes, otherwise use optionals *)
- if typdef.subtypes == [] then
- write_one name constrs
- else
- List.iter constrs ~f:
- begin fun fc ->
- let code, vars, _, (co, _) =
- code_of_template ~context_widget:"dummy" fc.template in
- if co <> "" then fatal_error "optionals in optionals";
- let vars = List.map ~f:snd vars in
- w "let ccCAMLtoTK"; w name; w "_"; w (small fc.ml_name);
- w " ("; w (String.concat ~sep:", " vars); w ") =\n ";
- w code; w "\n\n"
- end
- end
-
-(* Tcl does not really return "lists". It returns sp separated tokens *)
-let rec write_result_parsing ~w = function
- List String ->
- w "(splitlist res)"
- | List ty ->
- if !Flags.camltk then
- w (" List.map " ^ converterTKtoCAML ~arg:"(splitlist res)" ty)
- else
- w (" List.map ~f: " ^ converterTKtoCAML ~arg:"(splitlist res)" ty)
- | Product tyl -> raise (Failure "Product -> record was done. ???")
- | Record tyl -> (* of course all the labels are "" *)
- let rnames = varnames ~prefix:"r" (List.length tyl) in
- w " let l = splitlist res in";
- w ("\n if List.length l <> " ^ string_of_int (List.length tyl));
- w ("\n then Pervasives.raise (TkError (\"unexpected result: \" ^ res))");
- w ("\n else ");
- List.iter2 rnames tyl ~f:
- begin fun r (l, ty) ->
- if l <> "" then raise (Failure "lables in return type!!!");
- w (" let " ^ r ^ ", l = ");
- begin match type_parser_arity ty with
- OneToken ->
- w (converterTKtoCAML ~arg:"(List.hd l)" ty); w (", List.tl l")
- | MultipleToken ->
- w (converterTKtoCAML ~arg:"l" ty)
- end;
- w (" in\n")
- end;
- w (String.concat ~sep:", " rnames)
- | String ->
- w (converterTKtoCAML ~arg:"res" String)
- | As (ty, _) -> write_result_parsing ~w ty
- | ty ->
- match type_parser_arity ty with
- OneToken -> w (converterTKtoCAML ~arg:"res" ty)
- | MultipleToken -> w (converterTKtoCAML ~arg:"(splitlist res)" ty)
-
-let labltk_write_function ~w def =
- w ("let " ^ def.ml_name);
- (* a bit approximative *)
- let context_widget = match def.template with
- ListArg (TypeArg(_, UserDefined("widget")) :: _) -> "v1"
- | ListArg (TypeArg(_, Subtype("widget", _)) :: _) -> "v1"
- | _ -> "dummy" in
-
- let code, variables, variables2, (co, lbl) =
- code_of_template ~func:true ~context_widget def.template in
- (* Arguments *)
- let uv, lv, ov =
- let rec replace_args ~u ~l ~o = function
- [] -> u, l, o
- | ("", x) :: ls ->
- replace_args ~u:(x :: u) ~l ~o ls
- | (p, _ as x) :: ls when p.[0] = '?' ->
- replace_args ~u ~l ~o:(x :: o) ls
- | x :: ls ->
- replace_args ~u ~l:(x :: l) ~o ls
- in
- replace_args ~u:[] ~l:[] ~o:[] (List.rev (variables @ variables2))
- in
- let has_opts = (ov <> [] || co <> "") in
- if not has_opts then List.iter uv ~f:(fun x -> w " "; w x);
- List.iter (lv@ov) ~f:(fun (l, v) -> w " "; w (labelstring l); w v);
- if co <> "" then begin
- if lv = [] && ov = [] then w (" ?" ^ lbl ^ ":eta");
- w " =\n";
- w (co ^ "_optionals");
- if lv = [] && ov = [] then w (" ?" ^ lbl ^ ":eta");
- w " (fun opts";
- if uv = [] then w " ()" else
- if has_opts then List.iter uv ~f:(fun x -> w " "; w x);
- w " ->\n"
- end else begin
- if (ov <> [] || lv = []) && uv = [] then w " ()" else
- if has_opts then List.iter uv ~f:(fun x -> w " "; w x);
- w " =\n"
- end;
- begin match def.result with
- | Unit | As (Unit, _) -> w "tkCommand "; w code
- | ty ->
- w "let res = tkEval "; w code ; w " in \n";
- write_result_parsing ~w ty
- end;
- if co <> "" then w ")";
- w "\n\n"
-
-let camltk_write_function ~w def =
- w ("let " ^ def.ml_name);
- (* a bit approximative *)
- let context_widget = match def.template with
- ListArg (TypeArg(_, UserDefined("widget")) :: _) -> "v1"
- | ListArg (TypeArg(_, Subtype("widget", _)) :: _) -> "v1"
- | _ -> "dummy" in
-
- let code, variables, variables2, (co, lbl) =
- code_of_template ~func:true ~context_widget def.template in
- (* Arguments *)
- let uv, ov =
- let rec replace_args ~u ~o = function
- [] -> u, o
- | ("", x) :: ls ->
- replace_args ~u:(x :: u) ~o ls
- | (p, _ as x) :: ls when p.[0] = '?' ->
- replace_args ~u ~o:(x :: o) ls
- | (_,x) :: ls ->
- replace_args ~u:(x::u) ~o ls
- in
- replace_args ~u:[] ~o:[] (List.rev (variables @ variables2))
- in
- let has_opts = ov <> [] (* (ov <> [] || co <> "") *) in
- if not has_opts then List.iter uv ~f:(fun x -> w " "; w x);
- List.iter ov ~f:(fun (l, v) -> w " "; w (labelstring l); w v);
- begin
- if uv = [] then w " ()" else
- if has_opts then List.iter uv ~f:(fun x -> w " "; w x);
- w " =\n"
- end;
- begin match def.result with
- | Unit | As (Unit, _) -> w "tkCommand "; w code
- | ty ->
- w "let res = tkEval "; w code ; w " in \n";
- write_result_parsing ~w ty
- end;
- w "\n\n"
-
-(*
- w ("let " ^ def.ml_name);
- (* a bit approximative *)
- let context_widget = match def.template with
- ListArg (TypeArg(_, UserDefined("widget")) :: _) -> "v1"
- | ListArg (TypeArg(_, Subtype("widget", _)) :: _) -> "v1"
- | _ -> "dummy" in
-
- let code, variables, variables2, (co, lbl) =
- code_of_template ~func:true ~context_widget def.template in
- let variables = variables @ variables2 in
- (* Arguments *)
- begin match variables with
- [] -> w " () =\n"
- | l ->
- let has_normal_argument = ref false in
- List.iter (fun (l,x) ->
- w " ";
- if l <> "" then
- if l.[0] = '?' then w (l ^ ":") else has_normal_argument := true
- else has_normal_argument := true;
- w x) l;
- if not !has_normal_argument then w " ()";
- w " =\n"
- end;
- begin match def.result with
- | Unit | As (Unit, _) -> w "tkCommand "; w code
- | ty ->
- w "let res = tkEval "; w code ; w " in \n";
- write_result_parsing ~w ty
- end;
- w "\n\n"
-*)
-
-let write_function ~w def =
- if !Flags.camltk then camltk_write_function ~w def
- else labltk_write_function ~w def
-;;
-
-let labltk_write_create ~w clas =
- w ("let create ?name =\n");
- w (" " ^ clas ^ "_options_optionals (fun opts parent ->\n");
- w (" let w = new_atom \"" ^ clas ^ "\" ~parent ?name in\n");
- w " tkCommand [|";
- w ("TkToken \"" ^ clas ^ "\";\n");
- w (" TkToken (Widget.name w);\n");
- w (" TkTokenList opts |];\n");
- w (" w)\n\n\n")
-
-let camltk_write_create ~w clas =
- w ("let create ?name parent options =\n");
- w (" let w = new_atom \"" ^ clas ^ "\" ~parent ?name in\n");
- w " tkCommand [|";
- w ("TkToken \"" ^ clas ^ "\";\n");
- w (" TkToken (Widget.name w);\n");
- w (" TkTokenList (List.map (function x -> "^
- converterCAMLtoTK "w" "x" (Subtype("options",clas)) ^ ") options)\n");
- w (" |];\n");
- w (" w\n\n")
-
-let camltk_write_named_create ~w clas =
- w ("let create_named parent name options =\n");
- w (" let w = new_atom \"" ^ clas ^ "\" ~parent ~name in\n");
- w " tkCommand [|";
- w ("TkToken \"" ^ clas ^ "\";\n");
- w (" TkToken (Widget.name w);\n");
- w (" TkTokenList (List.map (function x -> "^
- converterCAMLtoTK "w" "x" (Subtype("options",clas)) ^ ") options)\n");
- w (" |];\n");
- w (" w\n\n")
-
-(* Search Path. *)
-let search_path = ref ["."]
-
-(* taken from utils/misc.ml *)
-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
-
-(* builtin-code: the file (without suffix) is in .template... *)
-(* not efficient, but hell *)
-let write_external ~w def =
- match def.template with
- | StringArg fname ->
- begin try
- let realname = find_in_path !search_path (fname ^ ".ml") in
- let ic = open_in_bin realname in
- try
- let code_list = Ppparse.parse_channel ic in
- close_in ic;
- List.iter (Ppexec.exec (fun _ -> ()) w)
- (if !Flags.camltk then
- Code.Define "CAMLTK" :: code_list else code_list );
- with
- | Ppparse.Error s ->
- close_in ic;
- raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s))
- with
- | Not_found ->
- raise (Compiler_Error ("can't find external file: " ^ fname))
- end
- | _ -> raise (Compiler_Error "invalid external definition")
-
-let write_catch_optionals ~w clas ~def:typdef =
- if typdef.subtypes = [] then () else
- List.iter typdef.subtypes ~f:
- begin fun (subclass, classdefs) ->
- w ("let " ^ subclass ^ "_" ^ clas ^ "_optionals f = fun\n");
- let tklabels = List.map ~f:gettklabel classdefs in
- let l =
- List.map classdefs ~f:
- begin fun fc ->
- (*
- let code, vars, _, (co, _) =
- code_of_template ~context_widget:"dummy" fc.template in
- if co <> "" then fatal_error "optionals in optionals";
- *)
- let p = gettklabel fc in
- (if count ~item:p tklabels > 1 then small fc.var_name else p),
- small fc.ml_name
- end in
- let p = List.map l ~f:(fun (si, _) -> " ?" ^ si) in
- let v =
- List.map l ~f:
- begin fun (si, s) ->
- "(maycons ccCAMLtoTK" ^ clas ^ "_" ^ s ^ " " ^ si
- end in
- w (String.concat ~sep:"\n" p);
- w " ->\n";
- w " f ";
- w (String.concat ~sep:"\n " v);
- w "\n []";
- w (String.make (List.length v) ')');
- w "\n\n"
- end
diff --git a/otherlibs/labltk/compiler/copyright b/otherlibs/labltk/compiler/copyright
deleted file mode 100644
index 23dff46dce..0000000000
--- a/otherlibs/labltk/compiler/copyright
+++ /dev/null
@@ -1,15 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
diff --git a/otherlibs/labltk/compiler/flags.ml b/otherlibs/labltk/compiler/flags.ml
deleted file mode 100644
index 009d5e725a..0000000000
--- a/otherlibs/labltk/compiler/flags.ml
+++ /dev/null
@@ -1,17 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-let camltk = ref false;;
diff --git a/otherlibs/labltk/compiler/intf.ml b/otherlibs/labltk/compiler/intf.ml
deleted file mode 100644
index 58955b962b..0000000000
--- a/otherlibs/labltk/compiler/intf.ml
+++ /dev/null
@@ -1,191 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open StdLabels
-
-(* Write .mli for widgets *)
-
-open Tables
-open Compile
-
-let labltk_write_create_p ~w wname =
- w "val create :\n ?name:string ->\n";
- begin
- try
- let option = Hashtbl.find types_table "options" in
- let classdefs = List.assoc wname option.subtypes in
- let tklabels = List.map ~f:gettklabel classdefs in
- let l = List.map classdefs ~f:
- begin fun fc ->
- begin let p = gettklabel fc in
- if count ~item:p tklabels > 1 then small fc.var_name else p
- end,
- fc.template
- end in
- w (String.concat ~sep:" ->\n"
- (List.map l ~f:
- begin fun (s, t) ->
- " ?" ^ s ^ ":"
- ^(ppMLtype
- (match types_of_template t with
- | [t] -> labeloff t ~at:"write_create_p"
- | [] -> fatal_error "multiple"
- | l -> Product (List.map ~f:(labeloff ~at:"write_create_p") l)))
- end))
- with Not_found -> fatal_error "in write_create_p"
- end;
- w (" ->\n 'a widget -> " ^ wname ^ " widget\n");
- w "(** [create ?name parent options...] creates a new widget with\n";
- w " parent [parent] and new patch component [name], if specified. *)\n\n"
-;;
-
-let camltk_write_create_p ~w wname =
- w "val create : ?name: string -> widget -> options list -> widget \n";
- w "(** [create ?name parent options] creates a new widget with\n";
- w " parent [parent] and new patch component [name] if specified.\n";
- w " Options are restricted to the widget class subset, and checked\n";
- w " dynamically. *)\n\n"
-;;
-
-let camltk_write_named_create_p ~w wname =
- w "val create_named : widget -> string -> options list -> widget \n";
- w "(** [create_named parent name options] creates a new widget with\n";
- w " parent [parent] and new patch component [name].\n";
- w " This function is now obsolete and unified with [create]. *)\n\n";
-;;
-
-(* Unsafe: write special comment *)
-let labltk_write_function_type ~w def =
- if not def.safe then w "(* unsafe *)\n";
- w "val "; w def.ml_name; w " : ";
- let us, ls, os =
- let tys = types_of_template def.template in
- let rec replace_args ~u ~l ~o = function
- [] -> u, l, o
- | (_, List(Subtype _) as x)::ls ->
- replace_args ~u ~l ~o:(x::o) ls
- | ("", _ as x)::ls ->
- replace_args ~u:(x::u) ~l ~o ls
- | (p, _ as x)::ls when p.[0] = '?' ->
- replace_args ~u ~l ~o:(x::o) ls
- | x::ls ->
- replace_args ~u ~l:(x::l) ~o ls
- in
- replace_args ~u:[] ~l:[] ~o:[] (List.rev tys)
- in
- let counter = ref 0 in
- let params =
- if os = [] then us @ ls else ls @ os @ us in
- List.iter params ~f:
- begin fun (l, t) ->
- if l <> "" then w (l ^ ":");
- w (ppMLtype t ~counter);
- w " -> "
- end;
- if (os <> [] || ls = []) && us = [] then w "unit -> ";
- w (ppMLtype ~any:true ~return:true def.result); (* RETURN TYPE !!! *)
- w " \n";
-(* w "(* tk invocation: "; w (doc_of_template def.template); w " *)"; *)
- if def.safe then w "\n"
- else w "\n(* /unsafe *)\n"
-
-let camltk_write_function_type ~w def =
- if not def.safe then w "(* unsafe *)\n";
- w "val "; w def.ml_name; w " : ";
- let us, os =
- let tys = types_of_template def.template in
- let rec replace_args ~u ~o = function
- [] -> u, o
- | ("", _ as x)::ls ->
- replace_args ~u:(x::u) ~o ls
- | (p, _ as x)::ls when p.[0] = '?' ->
- replace_args ~u ~o:(x::o) ls
- | x::ls ->
- replace_args ~u:(x::u) ~o ls
- in
- replace_args ~u:[] ~o:[] (List.rev tys)
- in
- let counter = ref 0 in
- let params =
- if os = [] then us else os @ us in
- List.iter params ~f:
- begin fun (l, t) ->
- if l <> "" then if l.[0] = '?' then w (l ^ ":");
- w (ppMLtype t ~counter);
- w " -> "
- end;
- if us = [] then w "unit -> ";
- w (ppMLtype ~any:true ~return:true def.result); (* RETURN TYPE !!! *)
- w " \n";
-(* w "(* tk invocation: "; w (doc_of_template def.template); w " *)"; *)
- if def.safe then w "\n"
- else w "\n(* /unsafe *)\n"
-
-(*
- if not def.safe then w "(* unsafe *)\n";
- w "val "; w def.ml_name; w " : ";
- let tys = types_of_template def.template in
- let counter = ref 0 in
- let have_normal_arg = ref false in
- List.iter tys ~f:
- begin fun (l, t) ->
- if l <> "" then
- if l.[0] = '?' then w (l^":")
- else begin
- have_normal_arg := true;
- w (" (* " ^ l ^ ":*)")
- end
- else have_normal_arg := true;
- w (ppMLtype t ~counter);
- w " -> "
- end;
- if not !have_normal_arg then w "unit -> ";
- w (ppMLtype ~any:true ~return:true def.result); (* RETURN TYPE !!! *)
- w " \n";
- if def.safe then w "\n"
- else w "\n(* /unsafe *)\n"
-*)
-
-let write_function_type ~w def =
- if !Flags.camltk then camltk_write_function_type ~w def
- else labltk_write_function_type ~w def
-
-let write_external_type ~w def =
- match def.template with
- | StringArg fname ->
- begin try
- let realname = find_in_path !search_path (fname ^ ".mli") in
- let ic = open_in_bin realname in
- try
- let code_list = Ppparse.parse_channel ic in
- close_in ic;
- if not def.safe then w "(* unsafe *)\n";
- List.iter (Ppexec.exec (fun _ -> ()) w)
- (if !Flags.camltk then
- Code.Define "CAMLTK" :: code_list else code_list );
- if def.safe then w "\n\n"
- else w "\n(* /unsafe *)\n\n"
- with
- | Ppparse.Error s ->
- close_in ic;
- raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s))
- with
- | Not_found ->
- raise (Compiler_Error ("can't find external file: " ^ fname))
- end
- | _ -> raise (Compiler_Error "invalid external definition")
diff --git a/otherlibs/labltk/compiler/lexer.mll b/otherlibs/labltk/compiler/lexer.mll
deleted file mode 100644
index c65c9a604b..0000000000
--- a/otherlibs/labltk/compiler/lexer.mll
+++ /dev/null
@@ -1,170 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-{
-open StdLabels
-open Lexing
-open Parser
-open Support
-
-exception Lexical_error of string
-let current_line = ref 1
-
-
-(* The table of keywords *)
-
-let keyword_table = (Hashtbl.create 149 : (string, token) Hashtbl.t)
-
-let _ = List.iter
- ~f:(fun (str,tok) -> Hashtbl.add keyword_table str tok)
- [
- "int", TYINT;
- "float", TYFLOAT;
- "bool", TYBOOL;
- "char", TYCHAR;
- "string", TYSTRING;
- "list", LIST;
- "as", AS;
- "variant", VARIANT;
- "widget", WIDGET;
- "option", OPTION;
- "type", TYPE;
- "subtype", SUBTYPE;
- "function", FUNCTION;
- "module", MODULE;
- "external", EXTERNAL;
- "sequence", SEQUENCE;
- "unsafe", UNSAFE
-]
-
-
-(* 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 ~src:(!string_buff) ~src_pos:0 ~dst:new_buff ~dst_pos:0
- ~len:(String.length (!string_buff));
- string_buff := new_buff
- end;
- String.set (!string_buff) (!string_index) c;
- incr string_index
-
-let get_stored_string () =
- let s = String.sub (!string_buff) ~pos:0 ~len:(!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))
-
-let saved_string_start = ref 0
-
-}
-
-rule main = parse
- '\010' { incr current_line; main lexbuf }
- | [' ' '\013' '\009' '\026' '\012'] +
- { main lexbuf }
- | ['A'-'Z' 'a'-'z' '\192'-'\214' '\216'-'\246' '\248'-'\255' ]
- ( '_' ? ['A'-'Z' 'a'-'z' '\192'-'\214' '\216'-'\246' '\248'-'\255' (*'*) '0'-'9' ] ) *
- { let s = Lexing.lexeme lexbuf in
- try
- Hashtbl.find keyword_table s
- with Not_found ->
- IDENT s }
-
- | "\""
- { reset_string_buffer();
- (* Start of token is start of string. *)
- saved_string_start := lexbuf.lex_start_pos;
- string lexbuf;
- lexbuf.lex_start_pos <- !saved_string_start;
- STRING (get_stored_string()) }
- | "(" { LPAREN }
- | ")" { RPAREN }
- | "[" { LBRACKET }
- | "]" { RBRACKET }
- | "{" { LBRACE }
- | "}" { RBRACE }
- | "," { COMMA }
- | ";" { SEMICOLON }
- | ":" {COLON}
- | "?" {QUESTION}
- | "/" {SLASH}
- | "%" { comment lexbuf; main lexbuf }
- | "##line" { line lexbuf; main lexbuf }
- | eof { EOF }
- | _
- { raise (Lexical_error("illegal character")) }
-
-
-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("string not terminated")) }
- | '\010'
- { incr current_line;
- store_string_char(Lexing.lexeme_char lexbuf 0);
- string lexbuf }
- | _
- { store_string_char(Lexing.lexeme_char lexbuf 0);
- string lexbuf }
-
-and comment = parse
- '\010' { incr current_line }
- | eof { () }
- | _ { comment lexbuf }
-
-and linenum = parse
- | ['0'-'9']+ {
- let next_line = int_of_string (Lexing.lexeme lexbuf) in
- current_line := next_line - 1
- }
- | _ { raise (Lexical_error("illegal ##line directive: no line number"))}
-
-and line = parse
- | [' ' '\t']* { linenum lexbuf }
diff --git a/otherlibs/labltk/compiler/maincompile.ml b/otherlibs/labltk/compiler/maincompile.ml
deleted file mode 100644
index 2e0c3c3697..0000000000
--- a/otherlibs/labltk/compiler/maincompile.ml
+++ /dev/null
@@ -1,418 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open StdLabels
-open Support
-open Tables
-open Printer
-open Compile
-open Intf
-
-let flag_verbose = ref false
-let verbose_string s =
- if !flag_verbose then prerr_string s
-let verbose_endline s =
- if !flag_verbose then prerr_endline s
-
-let input_name = ref "Widgets.src"
-let output_dir = ref ""
-let destfile f = Filename.concat !output_dir f
-
-let usage () =
- prerr_string "Usage: tkcompiler input.src\n";
- flush stderr;
- exit 1
-
-
-let prerr_error_header () =
- prerr_string "File \""; prerr_string !input_name;
- prerr_string "\", line ";
- prerr_string (string_of_int !Lexer.current_line);
- prerr_string ": "
-
-(* parse Widget.src config file *)
-let parse_file filename =
- let ic = open_in_bin filename in
- let lexbuf =
- try
- let code_list = Ppparse.parse_channel ic in
- close_in ic;
- let buf = Buffer.create 50000 in
- List.iter (Ppexec.exec
- (fun l -> Buffer.add_string buf
- (Printf.sprintf "##line %d\n" l))
- (Buffer.add_string buf))
- (if !Flags.camltk then Code.Define "CAMLTK" :: code_list
- else code_list);
- Lexing.from_string (Buffer.contents buf)
- with
- | Ppparse.Error s ->
- close_in ic;
- raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s))
- in
- try
- while true do
- Parser.entry Lexer.main lexbuf
- done
- with
- | Parsing.Parse_error ->
- prerr_error_header();
- prerr_string "Syntax error \n";
- exit 1
- | Lexer.Lexical_error s ->
- prerr_error_header();
- prerr_string "Lexical error (";
- prerr_string s;
- prerr_string ")\n";
- exit 1
- | Duplicate_Definition (s,s') ->
- prerr_error_header();
- prerr_string s; prerr_string " "; prerr_string s';
- prerr_string " is defined twice.\n";
- exit 1
- | Compiler_Error s ->
- prerr_error_header();
- prerr_string "Internal error: "; prerr_string s; prerr_string "\n";
- prerr_string "Please report bug\n";
- exit 1
- | End_of_file ->
- ()
-
-(* The hack to provoke the production of cCAMLtoTKoptions_constrs *)
-
-(* Auxiliary function: the list of all the elements associated to keys
- in an hash table. *)
-let elements t =
- let elems = ref [] in
- Hashtbl.iter (fun _ d -> elems := d :: !elems) t;
- !elems;;
-
-(* Verifies that duplicated clauses are semantically equivalent and
- returns a unique set of clauses. *)
-let uniq_clauses = function
- | [] -> []
- | l ->
- let check_constr constr1 constr2 =
- if constr1.template <> constr2.template then
- begin
- let code1, vars11, vars12, opts1 =
- code_of_template ~context_widget:"dummy" constr1.template in
- let code2, vars12, vars22, opts2 =
- code_of_template ~context_widget:"dummy" constr2.template in
- let err =
- Printf.sprintf
- "uncompatible redondant clauses for variant %s:\n %s\n and\n %s"
- constr1.var_name code1 code2 in
- Format.print_newline();
- print_fullcomponent constr1;
- Format.print_newline();
- print_fullcomponent constr2;
- Format.print_newline();
- prerr_endline err;
- fatal_error err
- end in
- let t = Hashtbl.create 11 in
- List.iter l
- ~f:(fun constr ->
- let c = constr.var_name in
- if Hashtbl.mem t c
- then (check_constr constr (Hashtbl.find t c))
- else Hashtbl.add t c constr);
- elements t;;
-
-let option_hack oc =
- if Hashtbl.mem types_table "options" then
- let typdef = Hashtbl.find types_table "options" in
- let hack =
- { parser_arity = OneToken;
- constructors = begin
- let constrs =
- List.map typdef.constructors ~f:
- begin fun c ->
- { component = Constructor;
- ml_name = (if !Flags.camltk then "C" ^ c.ml_name
- else c.ml_name);
- var_name = c.var_name; (* as variants *)
- template =
- begin match c.template with
- ListArg (x :: _) -> x
- | _ -> fatal_error "bogus hack"
- end;
- result = UserDefined "options_constrs";
- safe = true }
- end in
- if !Flags.camltk then constrs else uniq_clauses constrs (* JPF ?? *)
- end;
- subtypes = [];
- requires_widget_context = false;
- variant = false }
- in
- write_CAMLtoTK
- ~w:(output_string oc) ~def:hack ~safetype:false "options_constrs"
-
-let realname name =
- (* module name fix for camltk *)
- if !Flags.camltk then "c" ^ String.capitalize name
- else name
-;;
-
-(* analize the parsed Widget.src and output source files *)
-let compile () =
- verbose_endline "Creating _tkgen.ml ...";
- let oc = open_out_bin (destfile "_tkgen.ml") in
- let oc' = open_out_bin (destfile "_tkigen.ml") in
- let oc'' = open_out_bin (destfile "_tkfgen.ml") in
- let sorted_types = Tsort.sort types_order in
- verbose_endline " writing types ...";
- List.iter sorted_types ~f:
- begin fun typname ->
- verbose_string (" " ^ typname ^ " ");
- try
- let typdef = Hashtbl.find types_table typname in
- verbose_string "type ";
- write_type ~intf:(output_string oc)
- ~impl:(output_string oc')
- typname ~def:typdef;
- verbose_string "C2T ";
- write_CAMLtoTK ~w:(output_string oc') typname ~def:typdef;
- verbose_string "T2C ";
- if List.mem typname !types_returned then
- write_TKtoCAML ~w:(output_string oc') typname ~def:typdef;
- verbose_string "CO ";
- if not !Flags.camltk then (* only for LablTk *)
- write_catch_optionals ~w:(output_string oc') typname ~def:typdef;
- verbose_endline "."
- with Not_found ->
- if not (List.mem_assoc typname !types_external) then
- begin
- verbose_string "Type ";
- verbose_string typname;
- verbose_string " is undeclared external or undefined\n"
- end
- else verbose_endline "."
- end;
- verbose_endline " option hacking ...";
- option_hack oc';
- verbose_endline " writing functions ...";
- List.iter ~f:(write_function ~w:(output_string oc'')) !function_table;
- close_out oc;
- close_out oc';
- close_out oc'';
- (* Write the interface for public functions *)
- (* this interface is used only for documentation *)
- verbose_endline "Creating _tkgen.mli ...";
- let oc = open_out_bin (destfile "_tkgen.mli") in
- List.iter (sort_components !function_table)
- ~f:(write_function_type ~w:(output_string oc));
- close_out oc;
- verbose_endline "Creating other ml, mli ...";
- let write_module wname wdef =
- verbose_endline (" "^wname);
- let modname = realname wname in
- let oc = open_out_bin (destfile (modname ^ ".ml"))
- and oc' = open_out_bin (destfile (modname ^ ".mli")) in
- Copyright.write ~w:(output_string oc);
- Copyright.write ~w:(output_string oc');
- begin match wdef.module_type with
- Widget -> output_string oc' ("(* The "^wname^" widget *)\n")
- | Family -> output_string oc' ("(* The "^wname^" commands *)\n")
- end;
- List.iter ~f:(fun s -> output_string oc s; output_string oc' s)
- begin
- if !Flags.camltk then
- [ "open CTk\n";
- "open Tkintf\n";
- "open Widget\n";
- "open Textvariable\n\n" ]
- else
- [ "open StdLabels\n";
- "open Tk\n";
- "open Tkintf\n";
- "open Widget\n";
- "open Textvariable\n\n" ]
- end;
- output_string oc "open Protocol\n";
- begin match wdef.module_type with
- Widget ->
- if !Flags.camltk then begin
- camltk_write_create ~w:(output_string oc) wname;
- camltk_write_named_create ~w:(output_string oc) wname;
- camltk_write_create_p ~w:(output_string oc') wname;
- camltk_write_named_create_p ~w:(output_string oc') wname;
- end else begin
- labltk_write_create ~w:(output_string oc) wname;
- labltk_write_create_p ~w:(output_string oc') wname
- end
- | Family -> ()
- end;
- List.iter ~f:(write_function ~w:(output_string oc))
- (sort_components wdef.commands);
- List.iter ~f:(write_function_type ~w:(output_string oc'))
- (sort_components wdef.commands);
- List.iter ~f:(write_external ~w:(output_string oc))
- (sort_components wdef.externals);
- List.iter ~f:(write_external_type ~w:(output_string oc'))
- (sort_components wdef.externals);
- close_out oc;
- close_out oc'
- in Hashtbl.iter write_module module_table;
-
- (* wrapper code camltk.ml and labltk.ml *)
- if !Flags.camltk then begin
- let oc = open_out_bin (destfile "camltk.ml") in
- Copyright.write ~w:(output_string oc);
- output_string oc
-"(** This module Camltk provides the module name spaces of the CamlTk API.
-
- The users of the CamlTk API should open this module first to access
- the types, functions and modules of the CamlTk API easier.
- For the documentation of each sub modules such as [Button] and [Toplevel],
- refer to its defintion file, [cButton.mli], [cToplevel.mli], etc.
- *)
-
-";
- output_string oc "include CTk\n";
- output_string oc "module Tk = CTk\n";
- Hashtbl.iter (fun name _ ->
- let cname = realname name in
- output_string oc (Printf.sprintf "module %s = %s;;\n"
- (String.capitalize name)
- (String.capitalize cname))) module_table;
- close_out oc
- end else begin
- let oc = open_out_bin (destfile "labltk.ml") in
- Copyright.write ~w:(output_string oc);
- output_string oc
-"(** This module Labltk provides the module name spaces of the LablTk API,
- useful to call LablTk functions inside CamlTk programs. 100% LablTk users
- do not need to use this. *)
-
-";
- output_string oc "module Widget = Widget;;
-module Protocol = Protocol;;
-module Textvariable = Textvariable;;
-module Fileevent = Fileevent;;
-module Timer = Timer;;
-";
- Hashtbl.iter (fun name _ ->
- let cname = realname name in
- output_string oc (Printf.sprintf "module %s = %s;;\n"
- (String.capitalize name)
- (String.capitalize name))) module_table;
- (* widget typer *)
- output_string oc "\n(** Widget typers *)\n\nopen Widget\n\n";
- Hashtbl.iter (fun name def ->
- match def.module_type with
- | Widget ->
- output_string oc (Printf.sprintf
- "let %s (w : any widget) =\n" name);
- output_string oc (Printf.sprintf
- " Rawwidget.check_class w widget_%s_table;\n" name);
- output_string oc (Printf.sprintf
- " (Obj.magic w : %s widget);;\n\n" name);
- | _ -> () ) module_table;
- close_out oc
- end;
-
- (* write the module list for the Makefile *)
- (* and hack to death until it works *)
- let oc = open_out_bin (destfile "modules") in
- if !Flags.camltk then output_string oc "CWIDGETOBJS="
- else output_string oc "WIDGETOBJS=";
- Hashtbl.iter
- (fun name _ ->
- let name = realname name in
- output_string oc name;
- output_string oc ".cmo ")
- module_table;
- output_string oc "\n";
- Hashtbl.iter
- (fun name _ ->
- let name = realname name in
- output_string oc name;
- output_string oc ".ml ")
- module_table;
- output_string oc ": _tkgen.ml\n\n";
- Hashtbl.iter
- (fun name _ ->
- let name = realname name in
- output_string oc name;
- output_string oc ".cmo : ";
- output_string oc name;
- output_string oc ".ml\n";
- output_string oc name;
- output_string oc ".cmi : ";
- output_string oc name;
- output_string oc ".mli\n")
- module_table;
-
- (* for camltk.ml wrapper *)
- if !Flags.camltk then begin
- output_string oc "camltk.cmo : cTk.cmo ";
- Hashtbl.iter
- (fun name _ ->
- let name = realname name in
- output_string oc name;
- output_string oc ".cmo ") module_table;
- output_string oc "\n"
- end;
- close_out oc
-
-let main () =
- Arg.parse
- [ "-verbose", Arg.Unit (fun () -> flag_verbose := true),
- "Make output verbose";
- "-camltk", Arg.Unit (fun () -> Flags.camltk := true),
- "Make CamlTk interface";
- "-outdir", Arg.String (fun s -> output_dir := s),
- "output directory";
- "-debugpp", Arg.Unit (fun () -> Ppexec.debug := true),
- "debug preprocessor"
- ]
- (fun filename -> input_name := filename)
- "Usage: tkcompiler <source file>" ;
- if !output_dir = "" then begin
- prerr_endline "specify -outdir option";
- exit 1
- end;
- try
- verbose_endline "Parsing...";
- parse_file !input_name;
- verbose_endline "Compiling...";
- compile ();
- verbose_endline "Finished";
- exit 0
- with
- | Lexer.Lexical_error s ->
- prerr_string "Invalid lexical character: ";
- prerr_endline s;
- exit 1
- | Duplicate_Definition (s, s') ->
- prerr_string s; prerr_string " "; prerr_string s';
- prerr_endline " is redefined illegally";
- exit 1
- | Invalid_implicit_constructor c ->
- prerr_string "Constructor ";
- prerr_string c;
- prerr_endline " is used implicitly before defined";
- exit 1
- | Tsort.Cyclic ->
- prerr_endline "Cyclic dependency of types";
- exit 1
-
-let () = Printexc.catch main ()
diff --git a/otherlibs/labltk/compiler/parser.mly b/otherlibs/labltk/compiler/parser.mly
deleted file mode 100644
index c797f4fb5b..0000000000
--- a/otherlibs/labltk/compiler/parser.mly
+++ /dev/null
@@ -1,330 +0,0 @@
-/***********************************************************************/
-/* */
-/* MLTk, Tcl/Tk interface of Objective Caml */
-/* */
-/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */
-/* projet Cristal, INRIA Rocquencourt */
-/* Jacques Garrigue, Kyoto University RIMS */
-/* */
-/* Copyright 2002 Institut National de Recherche en Informatique et */
-/* en Automatique and Kyoto University. All rights reserved. */
-/* This file is distributed under the terms of the GNU Library */
-/* General Public License, with the special exception on linking */
-/* described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-%{
-
-open Tables
-
-%}
-
-/* Tokens */
-%token <string> IDENT
-%token <string> STRING
-%token EOF
-
-%token LPAREN /* "(" */
-%token RPAREN /* ")" */
-%token COMMA /* "," */
-%token SEMICOLON /* ";" */
-%token COLON /* ":" */
-%token QUESTION /* "?" */
-%token LBRACKET /* "[" */
-%token RBRACKET /* "]" */
-%token LBRACE /* "{" */
-%token RBRACE /* "}" */
-%token SLASH /* "/" */
-
-%token TYINT /* "int" */
-%token TYFLOAT /* "float" */
-%token TYBOOL /* "bool" */
-%token TYCHAR /* "char" */
-%token TYSTRING /* "string" */
-%token LIST /* "list" */
-
-%token AS /* "as" */
-%token VARIANT /* "variant" */
-%token WIDGET /* "widget" */
-%token OPTION /* "option" */
-%token TYPE /* "type" */
-%token SEQUENCE /* "sequence" */
-%token SUBTYPE /* "subtype" */
-%token FUNCTION /* "function" */
-%token MODULE /* "module" */
-%token EXTERNAL /* "external" */
-%token UNSAFE /* "unsafe" */
-/* Entry points */
-%start entry
-%type <unit> entry
-
-%%
-TypeName:
- IDENT { String.uncapitalize $1 }
- | WIDGET { "widget" }
-;
-
-/* Atomic types */
-Type0 :
- TYINT
- { Int }
- | TYFLOAT
- { Float }
- | TYBOOL
- { Bool }
- | TYCHAR
- { Char }
- | TYSTRING
- { String }
- | TypeName
- { UserDefined $1 }
-;
-
-/* Camltk/Labltk types */
-Type0_5:
- | Type0 SLASH Type0 { if !Flags.camltk then $1 else $3 }
- | Type0 { $1 }
-;
-
-/* with subtypes */
-Type1 :
- Type0_5
- { $1 }
- | TypeName LPAREN IDENT RPAREN
- { Subtype ($1, $3) }
- | WIDGET LPAREN IDENT RPAREN
- { Subtype ("widget", $3) }
- | OPTION LPAREN IDENT RPAREN
- { Subtype ("options", $3) }
- | Type1 AS STRING
- { As ($1, $3) }
- | LBRACE Type_list RBRACE
- { Product $2 }
-;
-
-/* with list constructors */
-Type2 :
- Type1
- { $1 }
- | Type2 LIST
- { List $1 }
-;
-
-Labeled_type2 :
- Type2
- { "", $1 }
- | IDENT COLON Type2
- { $1, $3 }
-;
-
-/* products */
-Type_list :
- Type2 COMMA Type_list
- { $1 :: $3 }
- | Type2
- { [$1] }
-;
-
-/* records */
-Type_record :
- Labeled_type2 COMMA Type_record
- { $1 :: $3 }
- | Labeled_type2
- { [$1] }
-;
-
-/* callback arguments or function results*/
-FType :
- LPAREN RPAREN
- { Unit }
- | LPAREN Type2 RPAREN
- { $2 }
- | LPAREN Type_record RPAREN
- { Record $2 }
-;
-
-Type :
- Type2
- { $1 }
- | FUNCTION FType
- { Function $2 }
-;
-
-
-
-SimpleArg:
- STRING
- {StringArg $1}
- | Type
- {TypeArg ("", $1) }
-;
-
-Arg:
- STRING
- {StringArg $1}
- | Type
- {TypeArg ("", $1) }
- | IDENT COLON Type
- {TypeArg ($1, $3)}
- | QUESTION IDENT COLON LBRACKET SimpleArgList RBRACKET DefaultList
- {OptionalArgs ( $2, $5, $7 )}
- | QUESTION WIDGET COLON LBRACKET SimpleArgList RBRACKET DefaultList
- {OptionalArgs ( "widget", $5, $7 )}
- | QUESTION IDENT COLON LBRACKET SimpleArgList RBRACKET
- {OptionalArgs ( $2, $5, [] )}
- | QUESTION WIDGET COLON LBRACKET SimpleArgList RBRACKET
- {OptionalArgs ( "widget", $5, [] )}
- | WIDGET COLON Type
- {TypeArg ("widget", $3)}
- | Template
- { $1 }
-;
-
-SimpleArgList:
- SimpleArg SEMICOLON SimpleArgList
- { $1 :: $3}
- | SimpleArg
- { [$1] }
-;
-
-ArgList:
- Arg SEMICOLON ArgList
- { $1 :: $3}
- | Arg
- { [$1] }
-;
-
-/* DefaultList Only one TypeArg in ArgList and it must be unlabeled */
-DefaultList :
- LBRACKET LBRACE ArgList RBRACE RBRACKET
- {$3}
-
-/* Template */
-Template :
- LBRACKET ArgList RBRACKET
- { ListArg $2 }
-;
-
-
-/* Constructors for type declarations */
-Constructor :
- IDENT Template
- {{ component = Constructor;
- ml_name = $1;
- var_name = getvarname $1 $2;
- template = $2;
- result = Unit;
- safe = true }}
- | IDENT LPAREN IDENT RPAREN Template
- {{ component = Constructor;
- ml_name = $1;
- var_name = $3;
- template = $5;
- result = Unit;
- safe = true }}
-;
-
-AbbrevConstructor :
- Constructor
- { Full $1 }
- | IDENT
- { Abbrev $1 }
-;
-
-Constructors :
- Constructor Constructors
- { $1 :: $2 }
-| Constructor
- { [$1] }
-;
-
-AbbrevConstructors :
- AbbrevConstructor AbbrevConstructors
- { $1 :: $2 }
-| AbbrevConstructor
- { [$1] }
-;
-
-Safe:
- /* */
- { true }
- | UNSAFE
- { false }
-
-Command :
- Safe FUNCTION FType IDENT Template
- {{component = Command; ml_name = $4; var_name = "";
- template = $5; result = $3; safe = $1 }}
-;
-
-External :
- Safe EXTERNAL IDENT STRING
- {{component = External; ml_name = $3; var_name = "";
- template = StringArg $4; result = Unit; safe = $1}}
-;
-
-Option :
- OPTION IDENT Template
- {{component = Constructor; ml_name = $2; var_name = getvarname $2 $3;
- template = $3; result = Unit; safe = true }}
- /* Abbreviated */
-| OPTION IDENT LPAREN IDENT RPAREN Template
- {{component = Constructor; ml_name = $2; var_name = $4;
- template = $6; result = Unit; safe = true }}
- /* Abbreviated */
-| OPTION IDENT
- { retrieve_option $2 }
-;
-
-WidgetComponents :
- /* */
- { [] }
- | Command WidgetComponents
- { $1 :: $2 }
- | Option WidgetComponents
- { $1 :: $2 }
- | External WidgetComponents
- { $1 :: $2 }
-;
-
-ModuleComponents :
- /* */
- { [] }
- | Command ModuleComponents
- { $1 :: $2 }
- | External ModuleComponents
- { $1 :: $2 }
-;
-
-ParserArity :
- /* */
- { OneToken }
- | SEQUENCE
- { MultipleToken }
-;
-
-
-
-entry :
- TYPE ParserArity TypeName LBRACE Constructors RBRACE
- { enter_type $3 $2 $5 }
-| VARIANT TYPE ParserArity TypeName LBRACE Constructors RBRACE
- { enter_type $4 $3 $6 ~variant: true }
-| TYPE ParserArity TypeName EXTERNAL
- { enter_external_type $3 $2 }
-| SUBTYPE ParserArity OPTION LPAREN IDENT RPAREN LBRACE AbbrevConstructors RBRACE
- { enter_subtype "options" $2 $5 $8 }
-| SUBTYPE ParserArity TypeName LPAREN IDENT RPAREN LBRACE AbbrevConstructors RBRACE
- { enter_subtype $3 $2 $5 $8 }
-| Command
- { enter_function $1 }
-| WIDGET IDENT LBRACE WidgetComponents RBRACE
- { enter_widget $2 $4 }
-| MODULE IDENT LBRACE ModuleComponents RBRACE
- { enter_module (String.uncapitalize $2) $4 }
-| EOF
- { raise End_of_file }
-;
diff --git a/otherlibs/labltk/compiler/pp.ml b/otherlibs/labltk/compiler/pp.ml
deleted file mode 100644
index 5c46766af7..0000000000
--- a/otherlibs/labltk/compiler/pp.ml
+++ /dev/null
@@ -1,23 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-let _ =
- try
- let code_list = Ppparse.parse_channel stdin in
- List.iter (Ppexec.exec (fun _ -> ()) print_string) code_list
- with
- | Ppparse.Error s -> prerr_endline s; exit 2
-;;
diff --git a/otherlibs/labltk/compiler/ppexec.ml b/otherlibs/labltk/compiler/ppexec.ml
deleted file mode 100644
index 9946882030..0000000000
--- a/otherlibs/labltk/compiler/ppexec.ml
+++ /dev/null
@@ -1,60 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-open Code
-
-let debug = ref false
-let defined = ref []
-let linenum = ref 1
-
-let rec nop = function
- | Line _ -> incr linenum
- | Ifdef (_, _, c1, c2o) ->
- List.iter nop c1;
- begin match c2o with
- | Some c2 -> List.iter nop c2
- | None -> ()
- end
- | _ -> ()
-;;
-
-let rec exec lp f = function
- | Line line ->
- if !debug then
- prerr_endline (Printf.sprintf "%03d: %s" !linenum
- (String.sub line 0 ((String.length line) - 1)));
- f line; incr linenum
- | Ifdef (sw, k, c1, c2o) ->
- if List.mem k !defined = sw then begin
- List.iter (exec lp f) c1;
- begin match c2o with
- | Some c2 -> List.iter nop c2
- | None -> ()
- end;
- lp !linenum
- end else begin
- List.iter nop c1;
- match c2o with
- | Some c2 ->
- lp !linenum;
- List.iter (exec lp f) c2
- | None -> ()
- end
- | Define k -> defined := k :: !defined
- | Undef k ->
- defined := List.fold_right (fun k' s ->
- if k = k' then s else k' :: s) [] !defined
-;;
diff --git a/otherlibs/labltk/compiler/pplex.mli b/otherlibs/labltk/compiler/pplex.mli
deleted file mode 100644
index 4eaa183b24..0000000000
--- a/otherlibs/labltk/compiler/pplex.mli
+++ /dev/null
@@ -1,18 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-exception Error of string
-val token : Lexing.lexbuf -> Ppyac.token
diff --git a/otherlibs/labltk/compiler/pplex.mll b/otherlibs/labltk/compiler/pplex.mll
deleted file mode 100644
index bb30c233ac..0000000000
--- a/otherlibs/labltk/compiler/pplex.mll
+++ /dev/null
@@ -1,57 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file ../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-{
-open Ppyac
-exception Error of string
-let linenum = ref 1
-}
-
-let blank = [' ' '\013' '\009' '\012']
-let identchar =
- ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
-let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_']
-let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222']
-
-rule token = parse
- blank + { token lexbuf }
-| "##" [' ' '\t']* { directive lexbuf }
-| ("#")? [^ '#' '\n']* '\n'? {
- begin
- let str = Lexing.lexeme lexbuf in
- let line = !linenum in
- if String.length str <> 0 && str.[String.length str - 1] = '\n' then
- begin
- incr linenum
- end;
- OTHER (str)
- end
- }
-| eof { EOF }
-
-and directive = parse
-| "ifdef" [' ' '\t']+ { IFDEF (ident lexbuf)}
-| "ifndef" [' ' '\t']+ { IFNDEF (ident lexbuf)}
-| "else" { ELSE }
-| "endif" { ENDIF }
-| "define" [' ' '\t']+* { DEFINE (ident lexbuf)}
-| "undef" [' ' '\t']+ { UNDEF (ident lexbuf)}
-| _ { raise (Error (Printf.sprintf "unknown directive at line %d" !linenum))}
-
-and ident = parse
-| lowercase identchar* | uppercase identchar*
- { Lexing.lexeme lexbuf }
-| _ { raise (Error (Printf.sprintf "illegal identifier at line %d" !linenum)) }
diff --git a/otherlibs/labltk/compiler/ppparse.ml b/otherlibs/labltk/compiler/ppparse.ml
deleted file mode 100644
index 3d1ee2af4f..0000000000
--- a/otherlibs/labltk/compiler/ppparse.ml
+++ /dev/null
@@ -1,36 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-exception Error of string
-
-let parse_channel ic =
- let lexbuf = Lexing.from_channel ic in
- try
- Ppyac.code_list Pplex.token lexbuf
- with
- | Pplex.Error s ->
- let loc_start = Lexing.lexeme_start lexbuf
- and loc_end = Lexing.lexeme_end lexbuf
- in
- raise (Error (Printf.sprintf "parse error at char %d, %d: %s"
- loc_start loc_end s))
- | Parsing.Parse_error ->
- let loc_start = Lexing.lexeme_start lexbuf
- and loc_end = Lexing.lexeme_end lexbuf
- in
- raise (Error (Printf.sprintf "parse error at char %d, %d"
- loc_start loc_end))
-;;
diff --git a/otherlibs/labltk/compiler/ppyac.mly b/otherlibs/labltk/compiler/ppyac.mly
deleted file mode 100644
index da7ee681f2..0000000000
--- a/otherlibs/labltk/compiler/ppyac.mly
+++ /dev/null
@@ -1,52 +0,0 @@
-/***********************************************************************/
-/* */
-/* MLTk, Tcl/Tk interface of Objective Caml */
-/* */
-/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */
-/* projet Cristal, INRIA Rocquencourt */
-/* Jacques Garrigue, Kyoto University RIMS */
-/* */
-/* Copyright 2002 Institut National de Recherche en Informatique et */
-/* en Automatique and Kyoto University. All rights reserved. */
-/* This file is distributed under the terms of the GNU Library */
-/* General Public License, with the special exception on linking */
-/* described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-%{
-open Code
-%}
-
-%token <string> IFDEF
-%token <string> IFNDEF
-%token ELSE
-%token ENDIF
-%token <string> DEFINE
-%token <string> UNDEF
-%token <string> OTHER
-%token EOF
-
-/* entry */
-
-%start code_list
-%type <Code.code list> code_list
-
-%%
-
-code_list:
- /* empty */ { [] }
- | code code_list { $1 :: $2 }
-;
-
-code:
- | DEFINE { Define $1 }
- | UNDEF { Undef $1 }
- | IFDEF code_list ELSE code_list ENDIF { Ifdef (true, $1, $2, Some ($4)) }
- | IFNDEF code_list ELSE code_list ENDIF { Ifdef (false, $1, $2, Some ($4)) }
- | IFDEF code_list ENDIF { Ifdef (true, $1, $2, None) }
- | IFNDEF code_list ENDIF { Ifdef (false, $1, $2, None) }
- | OTHER { Line $1 }
-;
-
-%%
diff --git a/otherlibs/labltk/compiler/printer.ml b/otherlibs/labltk/compiler/printer.ml
deleted file mode 100644
index 60362d17fb..0000000000
--- a/otherlibs/labltk/compiler/printer.ml
+++ /dev/null
@@ -1,173 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-open Tables;;
-
-open Format;;
-
-let escape_string s =
- let more = ref 0 in
- for i = 0 to String.length s - 1 do
- match s.[i] with
- | '\\' | '"' -> incr more
- | _ -> ()
- done;
- if !more = 0 then s else
- let res = String.create (String.length s + !more) in
- let j = ref 0 in
- for i = 0 to String.length s - 1 do
- let c = s.[i] in
- match c with
- | '\\' | '"' -> res.[!j] <- '\\'; incr j; res.[!j] <- c; incr j
- | _ -> res.[!j] <- c; incr j
- done;
- res;;
-
-let escape_char c = if c = '\'' then "\\'" else String.make 1 c;;
-
-let print_quoted_string s = printf "\"%s\"" (escape_string s);;
-let print_quoted_char c = printf "'%s'" (escape_char c);;
-let print_quoted_int i =
- if i < 0 then printf "(%d)" i else printf "%d" i;;
-let print_quoted_float f =
- if f <= 0.0 then printf "(%f)" f else printf "%f" f;;
-
-(* Iterators *)
-let print_list f l =
- printf "@[<1>[";
- let rec pl = function
- | [] -> printf "@;<0 -1>]@]"
- | [x] -> f x; pl []
- | x :: xs -> f x; printf ";@ "; pl xs in
- pl l;;
-
-let print_array f v =
- printf "@[<2>[|";
- let l = Array.length v in
- if l >= 1 then f v.(0);
- if l >= 2 then
- for i = 1 to l - 1 do
- printf ";@ "; f v.(i)
- done;
- printf "@;<0 -1>|]@]";;
-
-let print_option f = function
- | None -> print_string "None"
- | Some x -> printf "@[<1>Some@ "; f x; printf "@]";;
-
-let print_bool = function
- | true -> print_string "true" | _ -> print_string "false";;
-
-let print_poly x = print_string "<poly>";;
-
-(* Types of the description language *)
-let rec print_mltype = function
- | Unit -> printf "Unit" | Int -> printf "Int" | Float -> printf "Float"
- | Bool -> printf "Bool" | Char -> printf "Char" | String -> printf "String"
- | List m -> printf "@[<1>(%s@ " "List"; print_mltype m; printf ")@]"
- | Product l_m ->
- printf "@[<1>(%s@ " "Product"; print_list print_mltype l_m; printf ")@]"
- | Record l_t_s_m ->
- printf "@[<1>(%s@ " "Record";
- print_list
- (function (s, m) ->
- printf "@[<1>("; print_quoted_string s; printf ",@ "; print_mltype m;
- printf ")@]")
- l_t_s_m;
- printf ")@]"
- | UserDefined s ->
- printf "@[<1>(%s@ " "UserDefined"; print_quoted_string s; printf ")@]"
- | Subtype (s, s0) ->
- printf "@[<1>(%s@ " "Subtype"; printf "@[<1>("; print_quoted_string s;
- printf ",@ "; print_quoted_string s0; printf ")@]"; printf ")@]"
- | Function m ->
- printf "@[<1>(%s@ " "Function"; print_mltype m; printf ")@]"
- | As (m, s) ->
- printf "@[<1>(%s@ " "As"; printf "@[<1>("; print_mltype m; printf ",@ ";
- print_quoted_string s; printf ")@]"; printf ")@]";;
-
-let rec print_template = function
- | StringArg s ->
- printf "@[<1>(%s@ " "StringArg"; print_quoted_string s; printf ")@]"
- | TypeArg (s, m) ->
- printf "@[<1>(%s@ " "TypeArg"; printf "@[<1>("; print_quoted_string s;
- printf ",@ "; print_mltype m; printf ")@]"; printf ")@]"
- | ListArg l_t ->
- printf "@[<1>(%s@ " "ListArg"; print_list print_template l_t;
- printf ")@]"
- | OptionalArgs (s, l_t, l_t0) ->
- printf "@[<1>(%s@ " "OptionalArgs"; printf "@[<1>(";
- print_quoted_string s; printf ",@ "; print_list print_template l_t;
- printf ",@ "; print_list print_template l_t0; printf ")@]"; printf ")@]";;
-
-(* Sorts of components *)
-let rec print_component_type = function
- | Constructor -> printf "Constructor" | Command -> printf "Command"
- | External -> printf "External";;
-
-(* Full definition of a component *)
-let rec print_fullcomponent = function
- {component = c; ml_name = s; var_name = s0; template = t; result = m;
- safe = b;
- } ->
- printf "@[<1>{"; printf "@[<1>component =@ "; print_component_type c;
- printf ";@]@ "; printf "@[<1>ml_name =@ "; print_quoted_string s;
- printf ";@]@ "; printf "@[<1>var_name =@ "; print_quoted_string s0;
- printf ";@]@ "; printf "@[<1>template =@ "; print_template t;
- printf ";@]@ "; printf "@[<1>result =@ "; print_mltype m; printf ";@]@ ";
- printf "@[<1>safe =@ "; print_bool b; printf ";@]@ "; printf "@,}@]";;
-
-(* components are given either in full or abbreviated *)
-let rec print_component = function
- | Full f -> printf "@[<1>(%s@ " "Full"; print_fullcomponent f; printf ")@]"
- | Abbrev s ->
- printf "@[<1>(%s@ " "Abbrev"; print_quoted_string s; printf ")@]";;
-
-(* A type definition *)
-(*
- requires_widget_context: the converter of the type MUST be passed
- an additional argument of type Widget.
-*)
-let rec print_parser_arity = function
- | OneToken -> printf "OneToken" | MultipleToken -> printf "MultipleToken";;
-
-let rec print_type_def = function
- {parser_arity = p; constructors = l_f; subtypes = l_t_s_l_f;
- requires_widget_context = b; variant = b0;
- } ->
- printf "@[<1>{"; printf "@[<1>parser_arity =@ "; print_parser_arity p;
- printf ";@]@ "; printf "@[<1>constructors =@ ";
- print_list print_fullcomponent l_f; printf ";@]@ ";
- printf "@[<1>subtypes =@ ";
- print_list
- (function (s, l_f0) ->
- printf "@[<1>("; print_quoted_string s; printf ",@ ";
- print_list print_fullcomponent l_f0; printf ")@]")
- l_t_s_l_f;
- printf ";@]@ "; printf "@[<1>requires_widget_context =@ "; print_bool b;
- printf ";@]@ "; printf "@[<1>variant =@ "; print_bool b0; printf ";@]@ ";
- printf "@,}@]";;
-
-let rec print_module_type = function
- | Widget -> printf "Widget" | Family -> printf "Family";;
-
-let rec print_module_def = function
- {module_type = m; commands = l_f; externals = l_f0; } ->
- printf "@[<1>{"; printf "@[<1>module_type =@ "; print_module_type m;
- printf ";@]@ "; printf "@[<1>commands =@ ";
- print_list print_fullcomponent l_f; printf ";@]@ ";
- printf "@[<1>externals =@ "; print_list print_fullcomponent l_f0;
- printf ";@]@ "; printf "@,}@]";;
diff --git a/otherlibs/labltk/compiler/tables.ml b/otherlibs/labltk/compiler/tables.ml
deleted file mode 100644
index 0d395cdc2f..0000000000
--- a/otherlibs/labltk/compiler/tables.ml
+++ /dev/null
@@ -1,427 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open StdLabels
-open Support
-
-(* Internal compiler errors *)
-
-exception Compiler_Error of string
-let fatal_error s = raise (Compiler_Error s)
-
-
-(* Types of the description language *)
-type mltype =
- Unit
- | Int
- | Float
- | Bool
- | Char
- | String
- | List of mltype
- | Product of mltype list
- | Record of (string * mltype) list
- | UserDefined of string
- | Subtype of string * string
- | Function of mltype (* arg type only *)
- | As of mltype * string
-
-type template =
- StringArg of string
- | TypeArg of string * mltype
- | ListArg of template list
- | OptionalArgs of string * template list * template list
-
-(* Sorts of components *)
-type component_type =
- Constructor
- | Command
- | External
-
-(* Full definition of a component *)
-type fullcomponent = {
- component : component_type;
- ml_name : string; (* used for camltk *)
- var_name : string; (* used just for labltk *)
- template : template;
- result : mltype;
- safe : bool
- }
-
-let sort_components =
- List.sort ~cmp:(fun c1 c2 -> compare c1.ml_name c2.ml_name)
-
-
-(* components are given either in full or abbreviated *)
-type component =
- Full of fullcomponent
- | Abbrev of string
-
-(* A type definition *)
-(*
- requires_widget_context: the converter of the type MUST be passed
- an additional argument of type Widget.
-*)
-
-type parser_arity =
- OneToken
-| MultipleToken
-
-type type_def = {
- parser_arity : parser_arity;
- mutable constructors : fullcomponent list;
- mutable subtypes : (string * fullcomponent list) list;
- mutable requires_widget_context : bool;
- mutable variant : bool
-}
-
-type module_type =
- Widget
- | Family
-
-type module_def = {
- module_type : module_type;
- commands : fullcomponent list;
- externals : fullcomponent list
-}
-
-(******************** The tables ********************)
-
-(* the table of all explicitly defined types *)
-let types_table = (Hashtbl.create 37 : (string, type_def) Hashtbl.t)
-(* "builtin" types *)
-let types_external = ref ([] : (string * parser_arity) list)
-(* dependancy order *)
-let types_order = (Tsort.create () : string Tsort.porder)
-(* Types of atomic values returned by Tk functions *)
-let types_returned = ref ([] : string list)
-(* Function table *)
-let function_table = ref ([] : fullcomponent list)
-(* Widget/Module table *)
-let module_table = (Hashtbl.create 37 : (string, module_def) Hashtbl.t)
-
-
-(* variant name *)
-let rec getvarname ml_name temp =
- let offhypben s =
- let s = String.copy s in
- if (try String.sub s ~pos:0 ~len:1 with _ -> "") = "-" then
- String.sub s ~pos:1 ~len:(String.length s - 1)
- else s
- and makecapital s =
- begin
- try
- let cd = s.[0] in
- if cd >= 'a' && cd <= 'z' then
- s.[0] <- Char.chr (Char.code cd + (Char.code 'A' - Char.code 'a'))
- with
- _ -> ()
- end;
- s
- in
- let head = makecapital (offhypben begin
- match temp with
- StringArg s -> s
- | TypeArg (s,t) -> s
- | ListArg (h::_) -> getvarname ml_name h
- | OptionalArgs (s,_,_) -> s
- | ListArg [] -> ""
- end)
- in
- let varname = if head = "" then ml_name
- else if head.[0] >= 'A' && head.[0] <= 'Z' then head
- else ml_name
- in varname
-
-(***** Some utilities on the various tables *****)
-(* Enter a new empty type *)
-let new_type typname arity =
- Tsort.add_element types_order typname;
- let typdef = {parser_arity = arity;
- constructors = [];
- subtypes = [];
- requires_widget_context = false;
- variant = false} in
- Hashtbl.add types_table typname typdef;
- typdef
-
-
-(* Assume that types not yet defined are not subtyped *)
-(* Widget is builtin and implicitly subtyped *)
-let is_subtyped s =
- s = "widget" ||
- try
- let typdef = Hashtbl.find types_table s in
- typdef.subtypes <> []
- with
- Not_found -> false
-
-let requires_widget_context s =
- try
- (Hashtbl.find types_table s).requires_widget_context
- with
- Not_found -> false
-
-let declared_type_parser_arity s =
- try
- (Hashtbl.find types_table s).parser_arity
- with
- Not_found ->
- try List.assoc s !types_external
- with
- Not_found ->
- prerr_string "Type "; prerr_string s;
- prerr_string " is undeclared external or undefined\n";
- prerr_string ("Assuming cTKtoCAML"^s^" : string -> "^s^"\n");
- OneToken
-
-let rec type_parser_arity = function
- Unit -> OneToken
- | Int -> OneToken
- | Float -> OneToken
- | Bool -> OneToken
- | Char -> OneToken
- | String -> OneToken
- | List _ -> MultipleToken
- | Product _ -> MultipleToken
- | Record _ -> MultipleToken
- | UserDefined s -> declared_type_parser_arity s
- | Subtype (s,_) -> declared_type_parser_arity s
- | Function _ -> OneToken
- | As (ty, _) -> type_parser_arity ty
-
-let enter_external_type s v =
- types_external := (s,v)::!types_external
-
-(*** Stuff for topological Sort.list of types ***)
-(* Make sure all types used in commands and functions are in *)
-(* the table *)
-let rec enter_argtype = function
- Unit | Int | Float | Bool | Char | String -> ()
- | List ty -> enter_argtype ty
- | Product tyl -> List.iter ~f:enter_argtype tyl
- | Record tyl -> List.iter tyl ~f:(fun (l,t) -> enter_argtype t)
- | UserDefined s -> Tsort.add_element types_order s
- | Subtype (s,_) -> Tsort.add_element types_order s
- | Function ty -> enter_argtype ty
- | As (ty, _) -> enter_argtype ty
-
-let rec enter_template_types = function
- StringArg _ -> ()
- | TypeArg (l,t) -> enter_argtype t
- | ListArg l -> List.iter ~f:enter_template_types l
- | OptionalArgs (_,tl,_) -> List.iter ~f:enter_template_types tl
-
-(* Find type dependancies on s *)
-let rec add_dependancies s =
- function
- List ty -> add_dependancies s ty
- | Product tyl -> List.iter ~f:(add_dependancies s) tyl
- | Subtype(s',_) -> if s <> s' then Tsort.add_relation types_order (s', s)
- | UserDefined s' -> if s <> s' then Tsort.add_relation types_order (s', s)
- | Function ty -> add_dependancies s ty
- | As (ty, _) -> add_dependancies s ty
- | _ -> ()
-
-let rec add_template_dependancies s = function
- StringArg _ -> ()
- | TypeArg (l,t) -> add_dependancies s t
- | ListArg l -> List.iter ~f:(add_template_dependancies s) l
- | OptionalArgs (_,tl,_) -> List.iter ~f:(add_template_dependancies s) tl
-
-(* Assumes functions are not nested in products, which is reasonable due to syntax*)
-let rec has_callback = function
- StringArg _ -> false
- | TypeArg (l,Function _ ) -> true
- | TypeArg _ -> false
- | ListArg l -> List.exists ~f:has_callback l
- | OptionalArgs (_,tl,_) -> List.exists ~f:has_callback tl
-
-(*** Returned types ***)
-let really_add ty =
- if List.mem ty !types_returned then ()
- else types_returned := ty :: !types_returned
-
-let rec add_return_type = function
- Unit -> ()
- | Int -> ()
- | Float -> ()
- | Bool -> ()
- | Char -> ()
- | String -> ()
- | List ty -> add_return_type ty
- | Product tyl -> List.iter ~f:add_return_type tyl
- | Record tyl -> List.iter tyl ~f:(fun (l,t) -> add_return_type t)
- | UserDefined s -> really_add s
- | Subtype (s,_) -> really_add s
- | Function _ -> fatal_error "unexpected return type (function)" (* whoah *)
- | As (ty, _) -> add_return_type ty
-
-(*** Update tables for a component ***)
-let enter_component_types {template = t; result = r} =
- add_return_type r;
- enter_argtype r;
- enter_template_types t
-
-
-(******************** Types and subtypes ********************)
-exception Duplicate_Definition of string * string
-exception Invalid_implicit_constructor of string
-
-(* Checking duplicate definition of constructor in subtypes *)
-let rec check_duplicate_constr allowed c =
- function
- [] -> false (* not defined *)
- | c'::rest ->
- if c.ml_name = c'.ml_name then (* defined *)
- if allowed then
- if c.template = c'.template then true (* same arg *)
- else raise (Duplicate_Definition ("constructor",c.ml_name))
- else raise (Duplicate_Definition ("constructor", c.ml_name))
- else check_duplicate_constr allowed c rest
-
-(* Retrieve constructor *)
-let rec find_constructor cname = function
- [] -> raise (Invalid_implicit_constructor cname)
- | c::l -> if c.ml_name = cname then c
- else find_constructor cname l
-
-(* Enter a type, must not be previously defined *)
-let enter_type typname ?(variant = false) arity constructors =
- if Hashtbl.mem types_table typname then
- raise (Duplicate_Definition ("type", typname)) else
- let typdef = new_type typname arity in
- if variant then typdef.variant <- true;
- List.iter constructors ~f:
- begin fun c ->
- if not (check_duplicate_constr false c typdef.constructors)
- then begin
- typdef.constructors <- c :: typdef.constructors;
- add_template_dependancies typname c.template
- end;
- (* Callbacks require widget context *)
- typdef.requires_widget_context <-
- typdef.requires_widget_context ||
- has_callback c.template
- end
-
-(* Enter a subtype *)
-let enter_subtype typ arity subtyp constructors =
- (* Retrieve the type if already defined, else add a new one *)
- let typdef =
- try Hashtbl.find types_table typ
- with Not_found -> new_type typ arity
- in
- if List.mem_assoc subtyp typdef.subtypes
- then raise (Duplicate_Definition ("subtype", typ ^" "^subtyp))
- else begin
- let real_constructors =
- List.map constructors ~f:
- begin function
- Full c ->
- if not (check_duplicate_constr true c typdef.constructors)
- then begin
- add_template_dependancies typ c.template;
- typdef.constructors <- c :: typdef.constructors
- end;
- typdef.requires_widget_context <-
- typdef.requires_widget_context ||
- has_callback c.template;
- c
- | Abbrev name -> find_constructor name typdef.constructors
- end
- in
- (* TODO: duplicate def in subtype are not checked *)
- typdef.subtypes <-
- (subtyp , List.sort real_constructors
- ~cmp:(fun c1 c2 -> compare c1.var_name c2.var_name)) ::
- typdef.subtypes
- end
-
-(******************** Widgets ********************)
-(* used by the parser; when enter_widget is called,
- all components are assumed to be in Full form *)
-let retrieve_option optname =
- let optiontyp =
- try Hashtbl.find types_table "options"
- with
- Not_found -> raise (Invalid_implicit_constructor optname)
- in find_constructor optname optiontyp.constructors
-
-(* Sort components by type *)
-let rec add_sort l obj =
- match l with
- [] -> [obj.component ,[obj]]
- | (s',l)::rest ->
- if obj.component = s' then
- (s',obj::l)::rest
- else
- (s',l)::(add_sort rest obj)
-
-let separate_components = List.fold_left ~f:add_sort ~init:[]
-
-let enter_widget name components =
- if Hashtbl.mem module_table name then
- raise (Duplicate_Definition ("widget/module", name)) else
- let sorted_components = separate_components components in
- List.iter sorted_components ~f:
- begin function
- Constructor, l ->
- enter_subtype "options" MultipleToken
- name (List.map ~f:(fun c -> Full c) l)
- | Command, l ->
- List.iter ~f:enter_component_types l
- | External, _ -> ()
- end;
- let commands =
- try List.assoc Command sorted_components
- with Not_found -> []
- and externals =
- try List.assoc External sorted_components
- with Not_found -> []
- in
- Hashtbl.add module_table name
- {module_type = Widget; commands = commands; externals = externals}
-
-(******************** Functions ********************)
-
-let enter_function comp =
- enter_component_types comp;
- function_table := comp :: !function_table
-
-
-(******************** Modules ********************)
-let enter_module name components =
- if Hashtbl.mem module_table name then
- raise (Duplicate_Definition ("widget/module", name)) else
- let sorted_components = separate_components components in
- List.iter sorted_components ~f:
- begin function
- Constructor, l -> fatal_error "unexpected Constructor"
- | Command, l -> List.iter ~f:enter_component_types l
- | External, _ -> ()
- end;
- let commands =
- try List.assoc Command sorted_components
- with Not_found -> []
- and externals =
- try List.assoc External sorted_components
- with Not_found -> []
- in
- Hashtbl.add module_table name
- {module_type = Family; commands = commands; externals = externals}
diff --git a/otherlibs/labltk/compiler/tsort.ml b/otherlibs/labltk/compiler/tsort.ml
deleted file mode 100644
index a174fb3da4..0000000000
--- a/otherlibs/labltk/compiler/tsort.ml
+++ /dev/null
@@ -1,89 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open StdLabels
-
-(* Topological Sort.list *)
-(* d'apres More Programming Pearls *)
-
-(* node * pred count * successors *)
-
-type 'a entry =
- {node : 'a;
- mutable pred_count : int;
- mutable successors : 'a entry list
- }
-
-type 'a porder = 'a entry list ref
-
-exception Cyclic
-
-let find_entry order node =
- let rec search_entry =
- function
- [] -> raise Not_found
- | x::l -> if x.node = node then x else search_entry l
- in
- try
- search_entry !order
- with
- Not_found -> let entry = {node = node;
- pred_count = 0;
- successors = []} in
- order := entry::!order;
- entry
-
-let create () = ref []
-
-(* Inverted args because Sort.list builds list in reverse order *)
-let add_relation order (succ,pred) =
- let pred_entry = find_entry order pred
- and succ_entry = find_entry order succ in
- succ_entry.pred_count <- succ_entry.pred_count + 1;
- pred_entry.successors <- succ_entry::pred_entry.successors
-
-(* Just add it *)
-let add_element order e =
- ignore (find_entry order e)
-
-let sort order =
- let q = Queue.create ()
- and result = ref [] in
- List.iter !order
- ~f:(function {pred_count = n} as node ->
- if n = 0 then Queue.add node q);
- begin try
- while true do
- let t = Queue.take q in
- result := t.node :: !result;
- List.iter t.successors ~f:
- begin fun s ->
- let n = s.pred_count - 1 in
- s.pred_count <- n;
- if n = 0 then Queue.add s q
- end
- done
- with
- Queue.Empty ->
- List.iter !order
- ~f:(fun node -> if node.pred_count <> 0
- then raise Cyclic)
- end;
- !result
-
-
diff --git a/camlp4/ocaml_src/tools/extract_crc.sh b/otherlibs/labltk/example/.gitignore
index e69de29bb2..e69de29bb2 100755..100644
--- a/camlp4/ocaml_src/tools/extract_crc.sh
+++ b/otherlibs/labltk/example/.gitignore
diff --git a/otherlibs/labltk/examples_camltk/.cvsignore b/otherlibs/labltk/examples_camltk/.cvsignore
deleted file mode 100644
index 801812fd38..0000000000
--- a/otherlibs/labltk/examples_camltk/.cvsignore
+++ /dev/null
@@ -1,8 +0,0 @@
-addition
-eyes
-fileinput
-fileopen
-helloworld
-tetris
-winskel
-mytext
diff --git a/otherlibs/labltk/examples_camltk/Makefile b/otherlibs/labltk/examples_camltk/Makefile
deleted file mode 100644
index 42613054b4..0000000000
--- a/otherlibs/labltk/examples_camltk/Makefile
+++ /dev/null
@@ -1,52 +0,0 @@
-include ../support/Makefile.common
-
-# We are using the non-installed library !
-COMPFLAGS=-I ../lib -I ../camltk -I ../support -I $(OTHERS)/unix -w s -dllpath ../support
-
-
-all: addition$(EXE) helloworld$(EXE) winskel$(EXE) fileinput$(EXE) \
- eyes$(EXE) tetris$(EXE) mytext$(EXE) fileopen$(EXE)
-
-addition$(EXE): addition.cmo
- $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma addition.cmo
-
-helloworld$(EXE): helloworld.cmo
- $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma helloworld.cmo
-
-winskel$(EXE): winskel.cmo
- $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma winskel.cmo
-
-fileinput$(EXE): fileinput.cmo
- $(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma fileinput.cmo
-
-socketinput$(EXE): socketinput.cmo
- $(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma socketinput.cmo
-
-eyes$(EXE): eyes.cmo
- $(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma eyes.cmo
-
-tetris$(EXE): tetris.cmo
- $(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma tetris.cmo
-
-mytext$(EXE): mytext.cmo
- $(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma mytext.cmo
-
-# graph$(EXE): graphics.cmo graphics_test.cmo
-# $(CAMLC) -o $@ graphics.cmo graphics_test.cmo
-#
-# graphics_test.cmo: graphics.cmo
-
-fileopen$(EXE): fileopen.cmo
- $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma fileopen.cmo
-
-clean :
- rm -f *.cm? $(EXECS) addition eyes fileinput fileopen helloworld jptest mytext tetris winskel
-
-.SUFFIXES :
-.SUFFIXES : .mli .ml .cmi .cmo
-
-.mli.cmi:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLCOMP) $(COMPFLAGS) $<
diff --git a/otherlibs/labltk/examples_camltk/Makefile.nt b/otherlibs/labltk/examples_camltk/Makefile.nt
deleted file mode 100644
index 13f27a01da..0000000000
--- a/otherlibs/labltk/examples_camltk/Makefile.nt
+++ /dev/null
@@ -1,38 +0,0 @@
-include ../support/Makefile.common.nt
-
-# We are using the non-installed library !
-COMPFLAGS= -I ../lib -I ../camltk -I ../support
-LINKFLAGS= -I ../lib -I ../camltk -I ../support
-
-# Use pieces of Makefile.config
-TKLINKOPT=$(LIBNAME).cma $(TKLIBS)
-
-all: addition.exe helloworld.exe winskel.exe socketinput.exe
-
-addition.exe: addition.cmo
- $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \
- -o $@ addition.cmo
-
-helloworld.exe: helloworld.cmo
- $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \
- -o $@ helloworld.cmo
-
-winskel.exe: winskel.cmo
- $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \
- -o $@ winskel.cmo
-
-socketinput.exe: socketinput.cmo
- $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) unix.cma \
- -o $@ socketinput.cmo
-
-clean :
- rm -f *.cm? *.exe
-
-.SUFFIXES :
-.SUFFIXES : .mli .ml .cmi .cmo
-
-.mli.cmi:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLCOMP) $(COMPFLAGS) $<
diff --git a/otherlibs/labltk/examples_camltk/addition.ml b/otherlibs/labltk/examples_camltk/addition.ml
deleted file mode 100644
index d4b333dcd4..0000000000
--- a/otherlibs/labltk/examples_camltk/addition.ml
+++ /dev/null
@@ -1,53 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-
-let main () =
- let top = opentk () in
- (* The widgets. They all have "top" as parent widget. *)
- let en1 = Entry.create top [TextWidth 6; Relief Sunken] in
- let lab1 = Label.create top [Text "plus"] in
- let en2 = Entry.create top [TextWidth 6 ; Relief Sunken] in
- let lab2 = Label.create top [Text "="] in
- let result_display = Label.create top [] in
- (* References holding values of entry widgets *)
- let n1 = ref 0
- and n2 = ref 0 in
- (* Refresh result *)
- let refresh () =
- Label.configure result_display [Text (string_of_int (!n1 + !n2))] in
- (* Electric *)
- let get_and_refresh (w,r) =
- fun _ _ ->
- try
- r := int_of_string (Entry.get w);
- refresh ()
- with
- Failure "int_of_string" ->
- Label.configure result_display [Text "error"]
- in
- (* Set the callbacks *)
- Entry.configure en1 [XScrollCommand (get_and_refresh (en1,n1)) ];
- Entry.configure en2 [XScrollCommand (get_and_refresh (en2,n2)) ];
- (* Map the widgets *)
- pack [en1;lab1;en2;lab2;result_display] [];
- (* Make the window resizable *)
- Wm.minsize_set top 1 1;
- (* Start interaction (event-driven program) *)
- mainLoop ()
-;;
-
-let _ = Printexc.catch main () ;;
diff --git a/otherlibs/labltk/examples_camltk/eyes.ml b/otherlibs/labltk/examples_camltk/eyes.ml
deleted file mode 100644
index 5666c69c55..0000000000
--- a/otherlibs/labltk/examples_camltk/eyes.ml
+++ /dev/null
@@ -1,67 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* The eyes of Caml (CamlTk) *)
-
-open Camltk;;
-
-let _ =
- let top = opentk () in
-
- let fw = Frame.create top [] in
- pack [fw] [];
- let c = Canvas.create fw [Width (Pixels 200); Height (Pixels 200)] in
- let create_eye cx cy wx wy ewx ewy bnd =
- let o2 =
- Canvas.create_oval c
- (Pixels (cx - wx)) (Pixels (cy - wy))
- (Pixels (cx + wx)) (Pixels (cy + wy))
- [Outline (NamedColor "black"); Width (Pixels 7);
- FillColor (NamedColor "white")]
- and o =
- Canvas.create_oval c
- (Pixels (cx - ewx)) (Pixels (cy - ewy))
- (Pixels (cx + ewx)) (Pixels (cy + ewy))
- [FillColor (NamedColor "black")] in
- let curx = ref cx
- and cury = ref cy in
- bind c [[], Motion]
- (BindExtend ([Ev_MouseX; Ev_MouseY],
- (fun e ->
- let nx, ny =
- let xdiff = e.ev_MouseX - cx
- and ydiff = e.ev_MouseY - cy in
- let diff = sqrt ((float xdiff /. (float wx *. bnd)) ** 2.0 +.
- (float ydiff /. (float wy *. bnd)) ** 2.0) in
- if diff > 1.0 then
- truncate ((float xdiff) *. (1.0 /. diff)) + cx,
- truncate ((float ydiff) *. (1.0 /. diff)) + cy
- else
- e.ev_MouseX, e.ev_MouseY
- in
- Canvas.move c o (Pixels (nx - !curx)) (Pixels (ny - !cury));
- curx := nx;
- cury := ny)))
- in
- create_eye 60 100 30 40 5 6 0.6;
- create_eye 140 100 30 40 5 6 0.6;
- pack [c] []
-
-let _ = Printexc.print mainLoop ()
-
-
-
-
diff --git a/otherlibs/labltk/examples_camltk/fileinput.ml b/otherlibs/labltk/examples_camltk/fileinput.ml
deleted file mode 100644
index c6190bdd49..0000000000
--- a/otherlibs/labltk/examples_camltk/fileinput.ml
+++ /dev/null
@@ -1,35 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk ;;
-
-let top_w = opentk () ;;
-let buffer = String.create 256 ;;
-let (fd_in, fd_out) = Unix.pipe () ;;
-let text0_w = Text.create top_w [] ;;
-let entry0_w = Entry.create top_w [] ;;
-let button0_w = Button.create top_w [Text "Quit"; Command (fun _ -> exit 0)] ;;
-Fileevent.add_fileinput fd_in (fun _ ->
- let n = Unix.read fd_in buffer 0 (String.length buffer) in
- let txt = String.sub buffer 0 n in
- Text.insert text0_w (TextIndex (End, [])) txt []) ;;
-let send _ =
- let txt = Entry.get entry0_w ^ "\n" in
- Entry.delete_range entry0_w (At 0) End ;
- ignore (Unix.write fd_out txt 0 (String.length txt));;
-
-bind entry0_w [([], KeyPressDetail "Return")] (BindSet ([], send)) ;
-pack [text0_w; entry0_w; button0_w][Side Side_Top; Fill Fill_X; Expand true] ;;
-mainLoop () ;;
diff --git a/otherlibs/labltk/examples_camltk/fileopen.ml b/otherlibs/labltk/examples_camltk/fileopen.ml
deleted file mode 100644
index b7bd163f37..0000000000
--- a/otherlibs/labltk/examples_camltk/fileopen.ml
+++ /dev/null
@@ -1,56 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk;;
-
-let win = opentk();;
-
-let cvs = Canvas.create win [];;
-
-let t = Label.create cvs [Text "File name"];;
-
-let b =
- Button.create cvs
- [Text "Save";
- Command
- (function _ ->
- let s =
- getSaveFile
- [Title "SAVE FILE TEST";
- DefaultExtension ".foo";
- FileTypes [ { typename= "just test";
- extensions= [".foo"; ".test"];
- mactypes= ["FOOO"; "BARR"] } ];
- InitialDir "/tmp";
- InitialFile "hogehoge" ] in
- Label.configure t [Text s])];;
-
-let bb =
- Button.create cvs
- [Text "Open";
- Command
- (function _ ->
- let s = getOpenFile [] in
- Label.configure t [Text s])];;
-
-let q =
- Button.create cvs
- [Text "Quit";
- Command
- (function _ -> closeTk (); exit 0)];;
-
-pack [cvs; q; bb; b; t] [];;
-
-mainLoop ();;
diff --git a/otherlibs/labltk/examples_camltk/helloworld.ml b/otherlibs/labltk/examples_camltk/helloworld.ml
deleted file mode 100644
index b32b515ae3..0000000000
--- a/otherlibs/labltk/examples_camltk/helloworld.ml
+++ /dev/null
@@ -1,37 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk;; (* Make interface functions available *)
-
-let top = opentk ();; (* Initialisation of the interface *)
-(* top is now the toplevel widget *)
-
-(* Widget initialisation *)
-let b = Button.create top
- [Text "foobar";
- Command (function () ->
- print_string "foobar";
- print_newline();
- flush stdout)];;
-(* b exists but is not yet visible *)
-
-let q = Button.create top
- [Text "quit";
- Command closeTk];;
-(* q exists but is not yet visible *)
-
-pack [b; q][] ;; (* Make b visible *)
-mainLoop() ;; (* User interaction*)
-(* You can quit this program by deleting its main window *)
diff --git a/otherlibs/labltk/examples_camltk/images/CamlBook.gif b/otherlibs/labltk/examples_camltk/images/CamlBook.gif
deleted file mode 100644
index fb7e52b100..0000000000
--- a/otherlibs/labltk/examples_camltk/images/CamlBook.gif
+++ /dev/null
Binary files differ
diff --git a/otherlibs/labltk/examples_camltk/images/Lambda2.back.gif b/otherlibs/labltk/examples_camltk/images/Lambda2.back.gif
deleted file mode 100644
index fdd1f078f4..0000000000
--- a/otherlibs/labltk/examples_camltk/images/Lambda2.back.gif
+++ /dev/null
Binary files differ
diff --git a/otherlibs/labltk/examples_camltk/images/dojoji.back.gif b/otherlibs/labltk/examples_camltk/images/dojoji.back.gif
deleted file mode 100644
index d4e07fdd7c..0000000000
--- a/otherlibs/labltk/examples_camltk/images/dojoji.back.gif
+++ /dev/null
Binary files differ
diff --git a/otherlibs/labltk/examples_camltk/jptest.ml b/otherlibs/labltk/examples_camltk/jptest.ml
deleted file mode 100644
index 38d9694c3f..0000000000
--- a/otherlibs/labltk/examples_camltk/jptest.ml
+++ /dev/null
@@ -1,23 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Tk
-
-let win = opentk();;
-
-let b = Button.create win [ Text "¤³¤ó¤Á¤Ï" ];;
-let _ = pack [b] [];;
-
-mainLoop();;
diff --git a/otherlibs/labltk/examples_camltk/mytext.ml b/otherlibs/labltk/examples_camltk/mytext.ml
deleted file mode 100644
index 0695d931aa..0000000000
--- a/otherlibs/labltk/examples_camltk/mytext.ml
+++ /dev/null
@@ -1,63 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-
-let top = opentk ()
-
-let scroll_link sb tx =
- Text.configure tx [YScrollCommand (Scrollbar.set sb)];
- Scrollbar.configure sb [ScrollCommand (Text.yview tx)]
-
-let f = Frame.create top []
-let text = Text.create f []
-let scrollbar = Scrollbar.create f []
-
-(* kill buffer *)
-let buffer = ref ""
-
-(* Note: for the text widgets, the insertion cursor is
- not TextIndex(Insert, []),
- but TextIndex(Mark "insert", [])
-*)
-let insertMark = TextIndex(Mark "insert", [])
-let eol_insertMark = TextIndex(Mark "insert", [LineEnd])
-
-let kill () =
- buffer :=
- Text.get text insertMark eol_insertMark;
- prerr_endline ("Killed: " ^ !buffer);
- Text.delete text insertMark eol_insertMark
-;;
-
-let yank () =
- Text.insert text insertMark !buffer [];
- prerr_endline ("Yanked: " ^ !buffer)
-;;
-
-let _ =
- scroll_link scrollbar text;
-
- pack [text; scrollbar][Side Side_Left; Fill Fill_Y];
- pack [f][];
-
- bind text [[Control], KeyPressDetail "y"]
- (BindSet ([], fun _ -> yank () ));
- bind text [[Control], KeyPressDetail "k"]
- (BindSet ([], fun _ -> kill () ));
-
- mainLoop ()
-;;
-
diff --git a/otherlibs/labltk/examples_camltk/socketinput.ml b/otherlibs/labltk/examples_camltk/socketinput.ml
deleted file mode 100644
index d23b8fd5e1..0000000000
--- a/otherlibs/labltk/examples_camltk/socketinput.ml
+++ /dev/null
@@ -1,43 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-
-let _ =
- let top_w = opentk () in
- let text0_w = Text.create top_w [] in
- let entry0_w = Entry.create top_w [] in
- let button0_w = Button.create top_w
- [Text "Quit"; Command (fun _ -> exit 0)] in
- let buffer = String.create 256 in
- let master_socket = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
- Unix.bind master_socket (Unix.ADDR_INET(Unix.inet_addr_any, 6789));
- Unix.listen master_socket 3;
- print_string "Please connect to port 6789..."; print_newline();
- let (sock, _) = Unix.accept master_socket in
- Fileevent.add_fileinput sock
- (fun _ ->
- let n = Unix.recv sock buffer 0 (String.length buffer) [] in
- let txt = String.sub buffer 0 n in
- Text.insert text0_w (TextIndex (End, [])) txt []);
- let send _ =
- let txt = Entry.get entry0_w ^ "\n" in
- Entry.delete_range entry0_w (At 0) End ;
- Unix.send sock txt 0 (String.length txt) [];
- () in
- bind entry0_w [([], KeyPressDetail "Return")] (BindSet ([], send));
- pack [text0_w; entry0_w; button0_w][Side Side_Top; Fill Fill_X; Expand true];
- mainLoop ()
-
diff --git a/otherlibs/labltk/examples_camltk/taddition.ml b/otherlibs/labltk/examples_camltk/taddition.ml
deleted file mode 100644
index 990812d730..0000000000
--- a/otherlibs/labltk/examples_camltk/taddition.ml
+++ /dev/null
@@ -1,53 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Tk
-
-let main () =
- let top = opentk () in
- (* The widgets. They all have "top" as parent widget. *)
- let en1 = Entry.create top [TextWidth 6; Relief Sunken] in
- let lab1 = Label.create top [Text "plus"] in
- let en2 = Entry.create top [TextWidth 6 ; Relief Sunken] in
- let lab2 = Label.create top [Text "="] in
- let result_display = Label.create top [] in
- (* References holding values of entry widgets *)
- let n1 = ref 0
- and n2 = ref 0 in
- (* Refresh result *)
- let refresh () =
- Label.configure result_display [Text (string_of_int (!n1 + !n2))] in
- (* Electric *)
- let get_and_refresh (w,r) =
- fun _ _ ->
- try
- r := int_of_string (Entry.get w);
- refresh ()
- with
- Failure "int_of_string" ->
- Label.configure result_display [Text "error"]
- in
- (* Set the callbacks *)
- Entry.configure en1 [XScrollCommand (get_and_refresh (en1,n1)) ];
- Entry.configure en2 [XScrollCommand (get_and_refresh (en2,n2)) ];
- (* Map the widgets *)
- pack [en1;lab1;en2;lab2;result_display] [];
- (* Make the window resizable *)
- Wm.minsize_set top 1 1;
- (* Start interaction (event-driven program) *)
- Threadtk.mainLoop ()
-;;
-
-let _ = Printexc.catch main () ;;
diff --git a/otherlibs/labltk/examples_camltk/tetris.ml b/otherlibs/labltk/examples_camltk/tetris.ml
deleted file mode 100644
index 79d9e3f1a5..0000000000
--- a/otherlibs/labltk/examples_camltk/tetris.ml
+++ /dev/null
@@ -1,685 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* A Tetris game for CamlTk *)
-(* written by Jun P. Furuse *)
-
-open Camltk
-
-exception Done
-
-type cell = {mutable color : int;
- tag : tagOrId * tagOrId * tagOrId}
-
-type falling_block = {
- mutable pattern: int array list;
- mutable bcolor: int;
- mutable x: int;
- mutable y: int;
- mutable d: int;
- mutable alive: bool
-}
-
-let stop_a_bit = 300
-
-let colors = [|
- NamedColor "red";
- NamedColor "yellow";
-
- NamedColor "blue";
- NamedColor "orange";
-
- NamedColor "magenta";
- NamedColor "green";
-
- NamedColor "cyan"
-|]
-
-let baseurl = "images/"
-
-let backgrounds =
- List.map (fun s -> baseurl ^ s)
- [ "dojoji.back.gif";
- "Lambda2back.gif";
- "CamlBook.gif";
- ]
-
-(* blocks *)
-let block_size = 16
-let cell_border = 2
-
-let blocks = [
- [ [|"0000";
- "0000";
- "1111";
- "0000" |];
-
- [|"0010";
- "0010";
- "0010";
- "0010" |];
-
- [|"0000";
- "0000";
- "1111";
- "0000" |];
-
- [|"0010";
- "0010";
- "0010";
- "0010" |] ];
-
- [ [|"0000";
- "0110";
- "0110";
- "0000" |];
-
- [|"0000";
- "0110";
- "0110";
- "0000" |];
-
- [|"0000";
- "0110";
- "0110";
- "0000" |];
-
- [|"0000";
- "0110";
- "0110";
- "0000" |] ];
-
- [ [|"0000";
- "0111";
- "0100";
- "0000" |];
-
- [|"0000";
- "0110";
- "0010";
- "0010" |];
-
- [|"0000";
- "0010";
- "1110";
- "0000" |];
-
- [|"0100";
- "0100";
- "0110";
- "0000" |] ];
-
- [ [|"0000";
- "0100";
- "0111";
- "0000" |];
-
- [|"0000";
- "0110";
- "0100";
- "0100" |];
-
- [|"0000";
- "1110";
- "0010";
- "0000" |];
-
- [|"0010";
- "0010";
- "0110";
- "0000" |] ];
-
- [ [|"0000";
- "1100";
- "0110";
- "0000" |];
-
- [|"0010";
- "0110";
- "0100";
- "0000" |];
-
- [|"0000";
- "1100";
- "0110";
- "0000" |];
-
- [|"0010";
- "0110";
- "0100";
- "0000" |] ];
-
- [ [|"0000";
- "0011";
- "0110";
- "0000" |];
-
- [|"0100";
- "0110";
- "0010";
- "0000" |];
-
- [|"0000";
- "0011";
- "0110";
- "0000" |];
-
- [|"0000";
- "0100";
- "0110";
- "0010" |] ];
-
- [ [|"0000";
- "0000";
- "1110";
- "0100" |];
-
- [|"0000";
- "0100";
- "1100";
- "0100" |];
-
- [|"0000";
- "0100";
- "1110";
- "0000" |];
-
- [|"0000";
- "0100";
- "0110";
- "0100" |] ]
-
-]
-
-let line_empty = int_of_string "0b1110000000000111"
-let line_full = int_of_string "0b1111111111111111"
-
-let decode_block dvec =
- let btoi d = int_of_string ("0b"^d) in
- Array.map btoi dvec
-
-let init fw =
- let scorev = Textvariable.create ()
- and linev = Textvariable.create ()
- and levv = Textvariable.create ()
- and namev = Textvariable.create ()
- in
- let f = Frame.create fw [BorderWidth (Pixels 2)] in
- let c = Canvas.create f [Width (Pixels (block_size * 10));
- Height (Pixels (block_size * 20));
- BorderWidth (Pixels cell_border);
- Relief Sunken;
- Background Black]
- and r = Frame.create f []
- and r' = Frame.create f [] in
-
- let nl = Label.create r [Text "Next"; Font "variable"] in
- let nc = Canvas.create r [Width (Pixels (block_size * 4));
- Height (Pixels (block_size * 4));
- BorderWidth (Pixels cell_border);
- Relief Sunken;
- Background Black] in
- let scl = Label.create r [Text "Score"; Font "variable"] in
- let sc = Label.create r [TextVariable scorev; Font "variable"] in
- let lnl = Label.create r [Text "Lines"; Font "variable"] in
- let ln = Label.create r [TextVariable linev; Font "variable"] in
- let levl = Label.create r [Text "Level"; Font "variable"] in
- let lev = Label.create r [TextVariable levv; Font "Variable"] in
- let newg = Button.create r [Text "New Game"; Font "variable"] in
- let exitg = Button.create r [Text "Quit"; Font "variable"] in
-
- pack [f] [];
- pack [c; r; r'] [Side Side_Left; Fill Fill_Y];
- pack [nl; nc] [Side Side_Top];
- pack [scl; sc; lnl; ln; levl; lev; newg; exitg] [Side Side_Top];
-
- let cells_src = Array.create 20 (Array.create 10 ()) in
- let cells = Array.map (Array.map (fun () ->
- {tag=
- (let t1, t2, t3 =
- Canvas.create_rectangle c
- (Pixels (-block_size - 8)) (Pixels (-block_size - 8))
- (Pixels (-9)) (Pixels (-9)) [],
- Canvas.create_rectangle c
- (Pixels (-block_size - 10)) (Pixels (-block_size - 10))
- (Pixels (-11)) (Pixels (-11)) [],
- Canvas.create_rectangle c
- (Pixels (-block_size - 12)) (Pixels (-block_size - 12))
- (Pixels (-13)) (Pixels (-13)) []
- in
- Canvas.raise_top c t1;
- Canvas.raise_top c t2;
- Canvas.lower_bot c t3;
- t1,t2,t3);
- color= 0})) cells_src
- in
- let nexts_src = Array.create 4 (Array.create 4 ()) in
- let nexts =
- Array.map (Array.map (fun () ->
- {tag=
- (let t1, t2, t3 =
- Canvas.create_rectangle nc
- (Pixels (-block_size - 8)) (Pixels (-block_size - 8))
- (Pixels (-9)) (Pixels (-9)) [],
- Canvas.create_rectangle nc
- (Pixels (-block_size - 10)) (Pixels (-block_size - 10))
- (Pixels (-11)) (Pixels (-11)) [],
- Canvas.create_rectangle nc
- (Pixels (-block_size - 12)) (Pixels (-block_size - 12))
- (Pixels (-13)) (Pixels (-13)) []
- in
- Canvas.raise_top nc t1;
- Canvas.raise_top nc t2;
- Canvas.lower_bot nc t3;
- t1, t2, t3);
- color= 0})) nexts_src in
- let game_over () = ()
- in
- [f; c; r; nl; nc; scl; sc; levl; lev; lnl; ln], newg, exitg,
- (c, cells), (nc, nexts), scorev, linev, levv, game_over
-
-let cell_get (c, cf) x y =
- (Array.get (Array.get cf y) x).color
-
-let cell_set (c, cf) x y col =
- let cur = Array.get (Array.get cf y) x in
- let t1,t2,t3 = cur.tag in
- if cur.color = col then ()
- else
- if cur.color <> 0 && col = 0 then
- begin
- Canvas.move c t1
- (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
- (Pixels (- block_size * (y + 1) -10 - cell_border * 2));
- Canvas.move c t2
- (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
- (Pixels (- block_size * (y + 1) -10 - cell_border * 2));
- Canvas.move c t3
- (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
- (Pixels (- block_size * (y + 1) -10 - cell_border * 2))
- end
- else
- begin
- Canvas.configure_rectangle c t2
- [FillColor (Array.get colors (col - 1));
- Outline (Array.get colors (col - 1))];
- Canvas.configure_rectangle c t1
- [FillColor Black;
- Outline Black];
- Canvas.configure_rectangle c t3
- [FillColor (NamedColor "light gray");
- Outline (NamedColor "light gray")];
- if cur.color = 0 && col <> 0 then
- begin
- Canvas.move c t1
- (Pixels (block_size * (x+1)+10+ cell_border*2))
- (Pixels (block_size * (y+1)+10+ cell_border*2));
- Canvas.move c t2
- (Pixels (block_size * (x+1)+10+ cell_border*2))
- (Pixels (block_size * (y+1)+10+ cell_border*2));
- Canvas.move c t3
- (Pixels (block_size * (x+1)+10+ cell_border*2))
- (Pixels (block_size * (y+1)+10+ cell_border*2))
- end
- end;
- cur.color <- col
-
-let draw_block field col d x y =
- for iy = 0 to 3 do
- let base = ref 1 in
- let xd = Array.get d iy in
- for ix = 0 to 3 do
- if xd land !base <> 0 then
- begin
- try cell_set field (ix + x) (iy + y) col with _ -> ()
- end
- else
- begin
- (* cell_set field (ix + x) (iy + y) 0 *) ()
- end;
- base := !base lsl 1
- done
- done
-
-let timer_ref = (ref None : Timer.t option ref)
-(* I know, this should be timer ref, but I'm not sure what should be
- the initial value ... *)
-
-let remove_timer () =
- match !timer_ref with
- | None -> ()
- | Some t -> Timer.remove t (* ; prerr_endline "removed!" *)
-
-let do_after milli f =
- timer_ref := Some (Timer.add milli f)
-
-let copy_block c =
- { pattern= !c.pattern;
- bcolor= !c.bcolor;
- x= !c.x;
- y= !c.y;
- d= !c.d;
- alive= !c.alive }
-
-let _ =
- let top = opentk () in
- let lb = Label.create top []
- and fw = Frame.create top []
- in
- let set_message s = Label.configure lb [Text s] in
- pack [lb; fw] [Side Side_Top];
- let score = ref 0 in
- let line = ref 0 in
- let level = ref 0 in
- let time = ref 1000 in
- let blocks = List.map (List.map decode_block) blocks in
- let field = Array.create 26 0 in
- let widgets, newg, exitg, cell_field, next_field,
- scorev, linev, levv, game_over =
- init fw in
- let canvas = fst cell_field in
-
- let init_field () =
- for i = 0 to 25 do
- field.(i) <- line_empty
- done;
- field.(23) <- line_full;
- for i = 0 to 19 do
- for j = 0 to 9 do
- cell_set cell_field j i 0
- done
- done;
- for i = 0 to 3 do
- for j = 0 to 3 do
- cell_set next_field j i 0
- done
- done
- in
-
- let draw_falling_block fb =
- draw_block cell_field fb.bcolor
- (List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3)
-
- and erase_falling_block fb =
- draw_block cell_field 0 (List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3)
- in
-
- let stone fb =
- for i=0 to 3 do
- let cur = field.(i + fb.y) in
- field.(i + fb.y) <-
- cur lor ((List.nth fb.pattern fb.d).(i) lsl fb.x)
- done;
- for i=0 to 2 do
- field.(i) <- line_empty
- done
-
- and clear fb =
- let l = ref 0 in
- for i = 0 to 3 do
- if i + fb.y >= 3 && i + fb.y <= 22 then
- if field.(i + fb.y) = line_full then
- begin
- incr l;
- field.(i + fb.y) <- line_empty;
- for j = 0 to 9 do
- cell_set cell_field j (i + fb.y - 3) 0
- done
- end
- done;
- !l
-
- and fall_lines () =
- let eye = ref 22 (* bottom *)
- and cur = ref 22 (* bottom *)
- in
- try
- while !eye >= 3 do
- while field.(!eye) = line_empty do
- decr eye;
- if !eye = 2 then raise Done
- done;
- field.(!cur) <- field.(!eye);
- for j = 0 to 9 do
- cell_set cell_field j (!cur-3) (cell_get cell_field j (!eye-3))
- done;
- decr eye;
- decr cur
- done
- with Done -> ();
- for i = 3 to !cur do
- field.(i) <- line_empty;
- for j = 0 to 9 do
- cell_set cell_field j (i-3) 0
- done
- done
- in
-
- let next = ref 42 (* THE ANSWER *)
- and current =
- ref { pattern= [[|0;0;0;0|]]; bcolor=0; x=0; y=0; d=0; alive= false}
- in
-
- let draw_next () =
- draw_block next_field (!next+1) (List.hd (List.nth blocks !next)) 0 0
-
- and erase_next () =
- draw_block next_field 0 (List.hd (List.nth blocks !next)) 0 0
- in
-
- let set_nextblock () =
- current :=
- { pattern= (List.nth blocks !next);
- bcolor= !next+1;
- x=6; y= 1; d= 0; alive= true};
- erase_next ();
- next := Random.int 7;
- draw_next ()
- in
-
- let death_check fb =
- try
- for i=0 to 3 do
- let cur = field.(i + fb.y) in
- if cur land ((List.nth fb.pattern fb.d).(i) lsl fb.x) <> 0
- then raise Done
- done;
- false
- with
- Done -> true
- in
-
- let try_to_move m =
- if !current.alive then
- let sub m =
- if death_check m then false
- else
- begin
- erase_falling_block !current;
- draw_falling_block m;
- current := m;
- true
- end
- in
- if sub m then ()
- else
- begin
- m.x <- m.x + 1;
- if sub m then ()
- else
- begin
- m.x <- m.x - 2;
- ignore (sub m)
- end
- end
- else ()
- in
-
- let image_load =
- let i = Canvas.create_image canvas
- (Pixels (block_size * 5 + block_size / 2))
- (Pixels (block_size * 10 + block_size / 2))
- [Anchor Center] in
- Canvas.lower_bot canvas i;
- let img = Imagephoto.create [] in
- fun file ->
- try
- Imagephoto.configure img [File file];
- Canvas.configure_image canvas i [ImagePhoto img]
- with
- _ ->
- begin
- Printf.eprintf "%s : No such image...\n" file;
- flush stderr
- end
- in
-
- let add_score l =
- let pline = !line in
- if l <> 0 then
- begin
- line := !line + l;
- score := !score + l * l;
- set_message (Printf.sprintf "%d pts" (1 lsl ((l - 1) * 2)))
- end;
- Textvariable.set linev (string_of_int !line);
- Textvariable.set scorev (string_of_int !score);
-
- if !line /10 <> pline /10 then
- (* update the background every 10 lines. *)
- begin
- let num_image = List.length backgrounds - 1 in
- let n = !line/10 in
- let n = if n > num_image then num_image else n in
- let file = List.nth backgrounds n in
- image_load file;
- (* Future work: We should gain level after an image is put... *)
- incr level;
- Textvariable.set levv (string_of_int !level)
- end
- in
-
- let rec newblock () =
- set_message "TETRIS";
- set_nextblock ();
- draw_falling_block !current;
- if death_check !current then
- begin
- !current.alive <- false;
- set_message "GAME OVER";
- game_over ()
- end
- else
- begin
- time := 1100 - (!level / 4 * 300) - ((!level mod 4) * 200);
- if !time < 60 - !level * 3 then time := 60 - !level * 3;
- do_after stop_a_bit loop
- end
-
- and loop () =
- let m = copy_block current in
- m.y <- m.y + 1;
- if death_check m then
- begin
- !current.alive <- false;
- stone !current;
- do_after stop_a_bit (fun () ->
- let l = clear !current in
- if l > 0 then
- do_after stop_a_bit (fun () ->
- fall_lines ();
- add_score l;
- do_after stop_a_bit newblock)
- else
- newblock ())
- end
- else
- begin
- erase_falling_block !current;
- draw_falling_block m;
- current := m;
- do_after !time loop
- end
- in
-
- let bind_game w =
- bind w [([], KeyPress)] (BindSet ([Ev_KeySymString],
- fun e ->
- match e.ev_KeySymString with
- | "h" ->
- let m = copy_block current in
- m.x <- m.x - 1;
- try_to_move m
- | "j" ->
- let m = copy_block current in
- m.d <- m.d + 1;
- if m.d = List.length m.pattern then m.d <- 0;
- try_to_move m
- | "k" ->
- let m = copy_block current in
- m.d <- m.d - 1;
- if m.d < 0 then m.d <- List.length m.pattern - 1;
- try_to_move m
- | "l" ->
- let m = copy_block current in
- m.x <- m.x + 1;
- try_to_move m
- | "m" ->
- remove_timer ();
- loop ()
- | "space" ->
- if !current.alive then
- begin
- let m = copy_block current
- and n = copy_block current in
- while
- m.y <- m.y + 1;
- if death_check m then false
- else begin n.y <- m.y; true end
- do () done;
- erase_falling_block !current;
- draw_falling_block n;
- current := n;
- remove_timer ();
- loop ()
- end
- | _ -> ()
- ))
- in
-
- let game_init () =
- (* Game Initialization *)
- set_message "Initializing ...";
- remove_timer ();
- image_load (List.hd backgrounds);
- time := 1000;
- score := 0;
- line := 0;
- level := 1;
- add_score 0;
- init_field ();
- next := Random.int 7;
- set_message "Welcome to TETRIS";
- set_nextblock ();
- draw_falling_block !current;
- do_after !time loop
- in
- bind_game top;
- Button.configure newg [Command game_init];
- Button.configure exitg [Command (fun () -> closeTk (); exit 0)];
- game_init ()
-
-let _ = Printexc.print mainLoop ()
diff --git a/otherlibs/labltk/examples_camltk/text.ml b/otherlibs/labltk/examples_camltk/text.ml
deleted file mode 100644
index 0001ae75ac..0000000000
--- a/otherlibs/labltk/examples_camltk/text.ml
+++ /dev/null
@@ -1,55 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Tk
-
-let top = opentk ()
-
-let scroll_link sb tx =
- Text.configure tx [YScrollCommand (Scrollbar.set sb)];
- Scrollbar.configure sb [ScrollCommand (Text.yview tx)]
-
-let f = Frame.create top []
-let text = Text.create f []
-let scrollbar = Scrollbar.create f []
-
-let buffer = ref ""
-
-let kill () =
- buffer :=
- Text.get text (TextIndex (Insert, []))
- (TextIndex (Insert, [LineEnd]));
- Text.delete text (TextIndex (Insert, []))
- (TextIndex (Insert, [LineEnd]))
-;;
-
-let yank () =
- Text.insert text (TextIndex (Insert, [])) !buffer []
-
-let _ = bind text [[Control], KeyPressDetail "y"] (BindSet ([], fun _ ->
- yank () ))
-;;
-let _ = bind text [[Control], KeyPressDetail "k"] (BindSet ([], fun _ ->
- kill () ))
-;;
-
-let _ =
- scroll_link scrollbar text;
-
- pack [text;f][];
- pack [f][];
- mainLoop ()
-;;
-
diff --git a/otherlibs/labltk/examples_camltk/winskel.ml b/otherlibs/labltk/examples_camltk/winskel.ml
deleted file mode 100644
index 2ca1da1745..0000000000
--- a/otherlibs/labltk/examples_camltk/winskel.ml
+++ /dev/null
@@ -1,63 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-(* This examples is based on Ousterhout's book (fig 16.15) *)
-open Camltk
-
-let main () =
- let top = opentk() in
- let mbar = Frame.create top [Relief Raised; BorderWidth (Pixels 2)]
- and dummy =
- Frame.create top [Width (Centimeters 10.); Height (Centimeters 5.)] in
- pack [mbar; dummy] [Side Side_Top; Fill Fill_X];
- let file = Menubutton.create mbar [Text "File"; UnderlinedChar 0]
- and edit = Menubutton.create mbar [Text "Edit"; UnderlinedChar 0]
- and graphics = Menubutton.create mbar [Text "Graphics"; UnderlinedChar 0]
- and text = Menubutton.create mbar [Text "Text"; UnderlinedChar 0]
- and view = Menubutton.create mbar [Text "View"; UnderlinedChar 0]
- and help = Menubutton.create mbar [Text "Help"; UnderlinedChar 0] in
- pack [file;edit;graphics;text;view] [Side Side_Left];
- pack [help] [Side Side_Right];
- (* same code as chap16-14 *)
- let m = Menu.create text [] in
- let bold = Textvariable.create()
- and italic = Textvariable.create()
- and underline = Textvariable.create() in
- Menu.add_checkbutton m [Label "Bold"; Variable bold];
- Menu.add_checkbutton m [Label "Italic"; Variable italic];
- Menu.add_checkbutton m [Label "Underline"; Variable underline];
- Menu.add_separator m;
- let font = Textvariable.create() in
- Menu.add_radiobutton m [Label "Times"; Variable font; Value "times"];
- Menu.add_radiobutton m [Label "Helvetica"; Variable font; Value "helvetica"]
-;
- Menu.add_radiobutton m [Label "Courier"; Variable font; Value "courier"];
- Menu.add_separator m;
- Menu.add_command m [Label "Insert Bullet";
- Command (function () ->
- print_string "Insert Bullet\n";
- flush stdout)];
- Menu.add_command m [Label "Margins and Tags...";
- Command (function () ->
- print_string "margins\n";
- flush stdout)];
- Menubutton.configure text [Menu m];
-
- mainLoop()
-
-
-
-let _ =
- Printexc.catch main ()
diff --git a/otherlibs/labltk/examples_labltk/.cvsignore b/otherlibs/labltk/examples_labltk/.cvsignore
deleted file mode 100644
index c1f6ec642f..0000000000
--- a/otherlibs/labltk/examples_labltk/.cvsignore
+++ /dev/null
@@ -1,8 +0,0 @@
-calc
-clock
-demo
-eyes
-hello
-tetris
-lang
-taquin
diff --git a/otherlibs/labltk/examples_labltk/Lambda2.back.gif b/otherlibs/labltk/examples_labltk/Lambda2.back.gif
deleted file mode 100644
index fdd1f078f4..0000000000
--- a/otherlibs/labltk/examples_labltk/Lambda2.back.gif
+++ /dev/null
Binary files differ
diff --git a/otherlibs/labltk/examples_labltk/Makefile b/otherlibs/labltk/examples_labltk/Makefile
deleted file mode 100644
index 3fa02632bf..0000000000
--- a/otherlibs/labltk/examples_labltk/Makefile
+++ /dev/null
@@ -1,53 +0,0 @@
-include ../support/Makefile.common
-
-COMPFLAGS=-I ../lib -I ../labltk -I ../support -I $(OTHERS)/unix -w s -dllpath ../support
-
-all: hello demo eyes calc clock tetris lang
-
-opt: hello.opt demo.opt eyes.opt calc.opt clock.opt tetris.opt
-
-hello: hello.cmo
- $(CAMLC) $(COMPFLAGS) -o hello $(LIBNAME).cma hello.cmo
-
-demo: demo.cmo
- $(CAMLC) $(COMPFLAGS) -o demo $(LIBNAME).cma demo.cmo
-
-eyes: eyes.cmo
- $(CAMLC) $(COMPFLAGS) -o eyes $(LIBNAME).cma eyes.cmo
-
-calc: calc.cmo
- $(CAMLC) $(COMPFLAGS) -o calc $(LIBNAME).cma calc.cmo
-
-clock: clock.cmo
- $(CAMLC) $(COMPFLAGS) -o clock $(LIBNAME).cma unix.cma clock.cmo
-
-clock.opt: clock.cmx
- $(CAMLOPT) $(COMPFLAGS) -o clock.opt \
- $(LIBNAME).cmxa unix.cmxa clock.cmx
-
-tetris: tetris.cmo
- $(CAMLC) $(COMPFLAGS) -o tetris $(LIBNAME).cma tetris.cmo
-
-taquin: taquin.cmo
- $(CAMLC) $(COMPFLAGS) -o taquin $(LIBNAME).cma taquin.cmo
-
-lang: lang.cmo
- $(CAMLC) $(COMPFLAGS) -o lang $(LIBNAME).cma lang.cmo
-
-clean:
- rm -f hello demo eyes calc clock tetris lang *.opt *.o *.cm*
-
-.SUFFIXES :
-.SUFFIXES : .mli .ml .cmi .cmx .cmo .opt
-
-.mli.cmi:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-.cmx.opt:
- $(CAMLOPT) $(COMPFLAGS) -o $@ $(LIBNAME).cmxa $<
diff --git a/otherlibs/labltk/examples_labltk/Makefile.nt b/otherlibs/labltk/examples_labltk/Makefile.nt
deleted file mode 100644
index 825d9e42be..0000000000
--- a/otherlibs/labltk/examples_labltk/Makefile.nt
+++ /dev/null
@@ -1,50 +0,0 @@
-include ../support/Makefile.common.nt
-
-# We are using the non-installed library !
-COMPFLAGS= -I ../lib -I ../labltk -I ../support
-LINKFLAGS= -I ../lib -I ../labltk -I ../support
-
-# Use pieces of Makefile.config
-TKLINKOPT=$(LIBNAME).cma $(TKLIBS)
-
-all: hello.exe demo.exe eyes.exe calc.exe clock.exe tetris.exe lang.exe
-
-hello.exe: hello.cmo
- $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \
- -o $@ hello.cmo
-
-demo.exe: demo.cmo
- $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \
- -o $@ demo.cmo
-
-eyes.exe: eyes.cmo
- $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \
- -o $@ eyes.cmo
-
-calc.exe: calc.cmo
- $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \
- -o $@ calc.cmo
-
-clock.exe: clock.cmo
- $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) unix.cma \
- -o $@ clock.cmo
-
-tetris.exe: tetris.cmo
- $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \
- -o $@ tetris.cmo
-
-lang.exe: lang.cmo
- $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \
- -o $@ lang.cmo
-
-clean :
- rm -f *.cm? *.exe
-
-.SUFFIXES :
-.SUFFIXES : .mli .ml .cmi .cmo
-
-.mli.cmi:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLCOMP) $(COMPFLAGS) $<
diff --git a/otherlibs/labltk/examples_labltk/README b/otherlibs/labltk/examples_labltk/README
deleted file mode 100644
index ec0f20de60..0000000000
--- a/otherlibs/labltk/examples_labltk/README
+++ /dev/null
@@ -1,20 +0,0 @@
-$Id$
-
-Some examples for LablTk.
-They are written in classic mode, except testris.ml which uses label
-commutation.
-You may either compile them here, or just run them as scripts with
- labltk example.ml
-
-hello.ml A very simple example of CamlTk
-hello.tcl The same programme in Tcl/Tk
-
-demo.ml A demonstration using many widget classes
-
-eyes.ml A "bind" test
-
-calc.ml A little calculator
-
-clock.ml An analog clock (uses unix.cma)
-
-tetris.ml You NEED a game also (uses -labels)
diff --git a/otherlibs/labltk/examples_labltk/calc.ml b/otherlibs/labltk/examples_labltk/calc.ml
deleted file mode 100644
index 088bf192f9..0000000000
--- a/otherlibs/labltk/examples_labltk/calc.ml
+++ /dev/null
@@ -1,129 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* A simple calculator demonstrating OO programming with O'Labl
- and LablTk.
-
- LablTk itself is not OO, but it is good to wrap complex
- structures in objects. Even if the absence of initializers
- makes things a little bit awkward.
-*)
-
-open StdLabels
-open Tk
-
-let mem_string ~elt:c s =
- try
- for i = 0 to String.length s -1 do
- if s.[i] = c then raise Exit
- done; false
- with Exit -> true
-
-let ops = ['+',(+.); '-',(-.); '*',( *.); '/',(/.)]
-
-(* The abstract calculator class.
- Does not use Tk (only Textvariable) *)
-
-class calc () = object (calc)
- val variable = Textvariable.create ()
- val mutable x = 0.0
- val mutable op = None
- val mutable displaying = true
-
- method set = Textvariable.set variable
- method get = Textvariable.get variable
- method insert s = calc#set (calc#get ^ s)
- method get_float = float_of_string (calc#get)
-
- method command s =
- if s <> "" then match s.[0] with
- '0'..'9' ->
- if displaying then (calc#set ""; displaying <- false);
- calc#insert s
- | '.' ->
- if displaying then
- (calc#set "0."; displaying <- false)
- else
- if not (mem_string ~elt:'.' calc#get) then calc#insert s
- | '+'|'-'|'*'|'/' as c ->
- displaying <- true;
- begin match op with
- None ->
- x <- calc#get_float;
- op <- Some (List.assoc c ops)
- | Some f ->
- x <- f x (calc#get_float);
- op <- Some (List.assoc c ops);
- calc#set (Printf.sprintf "%g" x)
- end
- | '='|'\n'|'\r' ->
- displaying <- true;
- begin match op with
- None -> ()
- | Some f ->
- x <- f x (calc#get_float);
- op <- None;
- calc#set (Printf.sprintf "%g" x)
- end
- | 'q' -> closeTk (); exit 0
- | _ -> ()
-end
-
-(* Buttons for the calculator *)
-
-let m =
- [|["7";"8";"9";"+"];
- ["4";"5";"6";"-"];
- ["1";"2";"3";"*"];
- ["0";".";"=";"/"]|]
-
-(* The physical calculator. Inherits from the abstract one *)
-
-class calculator ~parent = object
- inherit calc () as calc
-
- val label = Label.create ~anchor:`E ~relief:`Sunken ~padx:10 parent
- val frame = Frame.create parent
-
- initializer
- let buttons =
- Array.map ~f:
- (List.map ~f:
- (fun text ->
- Button.create ~text ~command:(fun () -> calc#command text) frame))
- m
- in
- Label.configure ~textvariable:variable label;
- calc#set "0";
- bind ~events:[`KeyPress] ~fields:[`Char]
- ~action:(fun ev -> calc#command ev.ev_Char)
- parent;
- for i = 0 to Array.length m - 1 do
- Grid.configure ~row:i buttons.(i)
- done;
- pack ~side:`Top ~fill:`X [label];
- pack ~side:`Bottom ~fill:`Both ~expand:true [frame];
-end
-
-(* Finally start everything *)
-
-let top = openTk ()
-
-let applet = new calculator ~parent:top
-
-let _ = mainLoop ()
diff --git a/otherlibs/labltk/examples_labltk/clock.ml b/otherlibs/labltk/examples_labltk/clock.ml
deleted file mode 100644
index 57a59b825b..0000000000
--- a/otherlibs/labltk/examples_labltk/clock.ml
+++ /dev/null
@@ -1,133 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Clock/V, a simple clock.
- Reverts every time you push the right button.
- Adapted from ASCII/V May 1997
-
- Uses Tk and Unix, so you must link with
- labltklink unix.cma clock.ml -o clock -cclib -lunix
-*)
-
-open Tk
-
-(* pi is not a constant! *)
-let pi = acos (-1.)
-
-(* The main class:
- * create it with a parent: [new clock parent:top]
- * initialize with [#init]
-*)
-
-class clock ~parent = object (self)
-
- (* Instance variables *)
- val canvas = Canvas.create ~width:100 ~height:100 parent
- val mutable height = 100
- val mutable width = 100
- val mutable rflag = -1
-
- (* Convert from -1.0 .. 1.0 to actual positions on the canvas *)
- method x x0 = truncate (float width *. (x0 +. 1.) /. 2.)
- method y y0 = truncate (float height *. (y0 +. 1.) /. 2.)
-
- initializer
- (* Create the oval border *)
- Canvas.create_oval canvas ~tags:["cadran"]
- ~x1:1 ~y1:1 ~x2:(width - 2) ~y2:(height - 2)
- ~width:3 ~outline:`Yellow ~fill:`White;
- (* Draw the figures *)
- self#draw_figures;
- (* Create the arrows with dummy position *)
- Canvas.create_line canvas
- ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.]
- ~tags:["hours"] ~fill:`Red;
- Canvas.create_line canvas
- ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.]
- ~tags:["minutes"] ~fill:`Blue;
- Canvas.create_line canvas
- ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.]
- ~tags:["seconds"] ~fill:`Black;
- (* Setup a timer every second *)
- let rec timer () =
- self#draw_arrows (Unix.localtime (Unix.time ()));
- Timer.add ~ms:1000 ~callback:timer; ()
- in timer ();
- (* Redraw when configured (changes size) *)
- bind canvas ~events:[`Configure] ~action:
- begin fun _ ->
- width <- Winfo.width canvas;
- height <- Winfo.height canvas;
- self#redraw
- end;
- (* Change direction with right button *)
- bind canvas ~events:[`ButtonPressDetail 3]
- ~action:(fun _ -> rflag <- -rflag; self#redraw);
- (* Pack, expanding in both directions *)
- pack ~fill:`Both ~expand:true [canvas]
-
- (* Redraw everything *)
- method redraw =
- Canvas.coords_set canvas (`Tag "cadran")
- ~xys:[ 1, 1; width - 2, height - 2 ];
- self#draw_figures;
- self#draw_arrows (Unix.localtime (Unix.time ()))
-
- (* Delete and redraw the figures *)
- method draw_figures =
- Canvas.delete canvas [`Tag "figures"];
- for i = 1 to 12 do
- let angle = float (rflag * i - 3) *. pi /. 6. in
- Canvas.create_text canvas
- ~x:(self#x (0.8 *. cos angle)) ~y:(self#y (0.8 *. sin angle))
- ~tags:["figures"]
- ~text:(string_of_int i) ~font:"variable"
- ~anchor:`Center
- done
-
- (* Resize and reposition the arrows *)
- method draw_arrows tm =
- Canvas.configure_line ~width:(min width height / 40)
- canvas (`Tag "hours");
- let hangle =
- float (rflag * (tm.Unix.tm_hour * 60 + tm.Unix.tm_min) - 180)
- *. pi /. 360. in
- Canvas.coords_set canvas (`Tag "hours")
- ~xys:[ self#x 0., self#y 0.;
- self#x (cos hangle /. 2.), self#y (sin hangle /. 2.) ];
- Canvas.configure_line ~width:(min width height / 50)
- canvas (`Tag "minutes");
- let mangle = float (rflag * tm.Unix.tm_min - 15) *. pi /. 30. in
- Canvas.coords_set canvas (`Tag "minutes")
- ~xys:[ self#x 0., self#y 0.;
- self#x (cos mangle /. 1.5), self#y (sin mangle /. 1.5) ];
- let sangle = float (rflag * tm.Unix.tm_sec - 15) *. pi /. 30. in
- Canvas.coords_set canvas (`Tag "seconds")
- ~xys:[ self#x 0., self#y 0.;
- self#x (cos sangle /. 1.25), self#y (sin sangle /. 1.25) ]
-end
-
-(* Initialize the Tcl interpreter *)
-let top = openTk ()
-
-(* Create a clock on the main window *)
-let clock =
- new clock ~parent:top
-
-(* Wait for events *)
-let _ = mainLoop ()
diff --git a/otherlibs/labltk/examples_labltk/demo.ml b/otherlibs/labltk/examples_labltk/demo.ml
deleted file mode 100644
index 2ccc448b19..0000000000
--- a/otherlibs/labltk/examples_labltk/demo.ml
+++ /dev/null
@@ -1,167 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Some CamlTk4 Demonstration by JPF *)
-
-(* First, open these modules for convenience *)
-open StdLabels
-open Tk
-
-(* Dummy let *)
-let _ =
-
-(* Initialize Tk *)
-let top = openTk () in
-(* Title setting *)
-Wm.title_set top "LablTk demo";
-
-(* Base frame *)
-let base = Frame.create top in
-pack [base];
-
-(* Menu bar *)
-let bar = Frame.create ~borderwidth:2 ~relief:`Raised base in
-pack ~fill:`X [bar];
-
- (* Menu and Menubutton *)
- let meb = Menubutton.create ~text:"Menu" bar in
- let men = Menu.create meb in
- Menu.add_command ~label:"Quit" ~command:(fun () -> closeTk (); exit 0) men;
- Menubutton.configure ~menu:men meb;
-
- (* Frames *)
- let base2 = Frame.create base in
- let left = Frame.create base2 in
- let right = Frame.create base2 in
- pack [base2];
- pack ~side:`Left [left; right];
-
- (* Widgets on left and right *)
-
- (* Button *)
- let but = Button.create ~text:"Welcome to LablTk" left in
-
- (* Canvas *)
- let can =
- Canvas.create ~width:100 ~height:100 ~borderwidth:1 ~relief:`Sunken left
- in
- let oval = Canvas.create_oval ~x1: 10 ~y1: 10
- ~x2: 90 ~y2: 90
- ~fill: `Red
- can
- in ignore oval;
-
- (* Check button *)
- let che = Checkbutton.create ~text:"Check" left in
-
- (* Entry *)
- let ent = Entry.create ~width:10 left in
-
- (* Label *)
- let lab = Label.create ~text:"Welcome to LablTk" left in
-
- (* Listbox *)
- let lis = Listbox.create left in
- Listbox.insert lis ~index:`End ~texts:["This"; "is"; "Listbox"];
-
- (* Message *)
- let mes = Message.create
- ~text: "Hello this is a message widget with very long text, but ..."
- left in
-
- (* Radio buttons *)
- let tv = Textvariable.create () in
- Textvariable.set tv "One";
- let radf = Frame.create right in
- let rads = List.map
- ~f:(fun t -> Radiobutton.create ~text:t ~value:t ~variable:tv radf)
- ["One"; "Two"; "Three"] in
-
- (* Scale *)
- let sca = Scale.create ~label:"Scale" ~length:100 ~showvalue:true right in
-
- (* Text and scrollbar *)
- let texf = Frame.create right in
-
- (* Text *)
- let tex = Text.create ~width:20 ~height:8 texf in
- Text.insert ~index:(`End,[]) ~text:"This is a text widget." tex;
-
- (* Scrollbar *)
- let scr = Scrollbar.create texf in
-
- (* Text and Scrollbar widget link *)
- let scroll_link sb tx =
- Text.configure ~yscrollcommand:(Scrollbar.set sb) tx;
- Scrollbar.configure ~command:(Text.yview tx) sb in
- scroll_link scr tex;
-
- pack ~side:`Right ~fill:`Y [scr];
- pack ~side:`Left ~fill:`Both ~expand:true [tex];
-
- (* Pack them *)
- pack ~side:`Left [meb];
- pack [coe but; coe can; coe che; coe ent; coe lab; coe lis; coe mes];
- pack [coe radf; coe sca; coe texf];
- pack rads;
-
- (* Toplevel *)
- let top2 = Toplevel.create top in
- Wm.title_set top2 "LablTk demo control";
- let defcol = `Color "#dfdfdf" in
- let selcol = `Color "#ffdfdf" in
- let buttons =
- List.map ~f:(fun (w, t, c, a) ->
- let b = Button.create ~text:t ~command:c top2 in
- bind ~events:[`Enter] ~action:(fun _ -> a selcol) b;
- bind ~events:[`Leave] ~action:(fun _ -> a defcol) b;
- b)
- [coe bar, "Frame", (fun () -> ()),
- (fun background -> Frame.configure ~background bar);
- coe meb, "Menubutton", (fun () -> ()),
- (fun background -> Menubutton.configure ~background meb);
- coe but, "Button", (fun () -> ()),
- (fun background -> Button.configure ~background but);
- coe can, "Canvas", (fun () -> ()),
- (fun background -> Canvas.configure ~background can);
- coe che, "CheckButton", (fun () -> ()),
- (fun background -> Checkbutton.configure ~background che);
- coe ent, "Entry", (fun () -> ()),
- (fun background -> Entry.configure ~background ent);
- coe lab, "Label", (fun () -> ()),
- (fun background -> Label.configure ~background lab);
- coe lis, "Listbox", (fun () -> ()),
- (fun background -> Listbox.configure ~background lis);
- coe mes, "Message", (fun () -> ()),
- (fun background -> Message.configure ~background mes);
- coe radf, "Radiobox", (fun () -> ()),
- (fun background ->
- List.iter ~f:(fun b -> Radiobutton.configure ~background b) rads);
- coe sca, "Scale", (fun () -> ()),
- (fun background -> Scale.configure ~background sca);
- coe tex, "Text", (fun () -> ()),
- (fun background -> Text.configure ~background tex);
- coe scr, "Scrollbar", (fun () -> ()),
- (fun background -> Scrollbar.configure ~background scr)
- ]
- in
- pack ~fill:`X buttons;
-
-(* Main Loop *)
-Printexc.print mainLoop ()
-
diff --git a/otherlibs/labltk/examples_labltk/eyes.ml b/otherlibs/labltk/examples_labltk/eyes.ml
deleted file mode 100644
index ce62159dbe..0000000000
--- a/otherlibs/labltk/examples_labltk/eyes.ml
+++ /dev/null
@@ -1,65 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Tk
-
-let _ =
- let top = openTk () in
- let fw = Frame.create top in
- pack [fw];
- let c = Canvas.create ~width: 200 ~height: 200 fw in
- let create_eye cx cy wx wy ewx ewy bnd =
- let o2 = Canvas.create_oval
- ~x1:(cx - wx) ~y1:(cy - wy)
- ~x2:(cx + wx) ~y2:(cy + wy)
- ~outline: `Black ~width: 7
- ~fill: `White
- c
- and o = Canvas.create_oval
- ~x1:(cx - ewx) ~y1:(cy - ewy)
- ~x2:(cx + ewx) ~y2:(cy + ewy)
- ~fill:`Black
- c in
- let curx = ref cx
- and cury = ref cy in
- bind ~events:[`Motion] ~extend:true ~fields:[`MouseX; `MouseY]
- ~action:(fun e ->
- let nx, ny =
- let xdiff = e.ev_MouseX - cx
- and ydiff = e.ev_MouseY - cy in
- let diff = sqrt ((float xdiff /. (float wx *. bnd)) ** 2.0 +.
- (float ydiff /. (float wy *. bnd)) ** 2.0) in
- if diff > 1.0 then
- truncate ((float xdiff) *. (1.0 /. diff)) + cx,
- truncate ((float ydiff) *. (1.0 /. diff)) + cy
- else
- e.ev_MouseX, e.ev_MouseY
- in
- Canvas.move c o ~x: (nx - !curx) ~y: (ny - !cury);
- curx := nx;
- cury := ny)
- c
- in
- create_eye 60 100 30 40 5 6 0.6;
- create_eye 140 100 30 40 5 6 0.6;
- pack [c]
-
-let _ = Printexc.print mainLoop ()
-
-
-
diff --git a/otherlibs/labltk/examples_labltk/hello.ml b/otherlibs/labltk/examples_labltk/hello.ml
deleted file mode 100644
index 4a89d48062..0000000000
--- a/otherlibs/labltk/examples_labltk/hello.ml
+++ /dev/null
@@ -1,38 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* LablTk4 Demonstration by JPF *)
-
-(* First, open this modules for convenience *)
-open Tk
-
-(* initialization of Tk --- the result is a toplevel widget *)
-let top = openTk ()
-
-(* create a button on top *)
-(* Button.create : use of create function defined in button.ml *)
-(* But you shouldn't open Button module for other widget class modules use *)
-let b = Button.create ~text: "Hello, LablTk!" top
-
-(* Lack of toplevel expressions in lsl, you must use dummy let exp. *)
-let _ = pack [coe b]
-
-(* Last, you must call mainLoop *)
-(* You can write just let _ = mainLoop () *)
-(* But Printexc.print will help you *)
-let _ = Printexc.print mainLoop ()
diff --git a/otherlibs/labltk/examples_labltk/hello.tcl b/otherlibs/labltk/examples_labltk/hello.tcl
deleted file mode 100755
index 84ceccd6d1..0000000000
--- a/otherlibs/labltk/examples_labltk/hello.tcl
+++ /dev/null
@@ -1,5 +0,0 @@
-#!/usr/bin/wish
-
-button .hello -text "Hello, TclTk!"
-
-pack .hello
diff --git a/otherlibs/labltk/examples_labltk/lang.ml b/otherlibs/labltk/examples_labltk/lang.ml
deleted file mode 100644
index e92377ecc3..0000000000
--- a/otherlibs/labltk/examples_labltk/lang.ml
+++ /dev/null
@@ -1,75 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* language encoding using UTF-8 *)
-open Tk
-
-let top = opentk ()
-
-(* declare Tk that we use utf-8 to communicate *)
-(* problem: Text display is highly dependent on your font installation
- and configulation. The fonts with no-scale setting are selected
- only if the point sizes are exactly same???
-*)
-let _ =
- Encoding.system_set "utf-8";
- let l = Label.create top ~text: "???" in
- pack [l];
- let t = Text.create top in
- pack [t];
-
- let create_hello lang hello =
- let b = Button.create t ~text: lang ~command: (fun () ->
- Label.configure l ~text: hello)
- in
- Text.window_create t ~index: (`End,[]) ~window: b
- in
- List.iter (fun (lang, hello) -> create_hello lang hello)
- ["Amharic(አማርኛ)", "ሠላáˆ";
- "Arabic", "�����������";
- "Croatian (Hrvatski)", "Bog (Bok), Dobar dan";
- "Czech (Äesky)", "Dobrý den";
- "Danish (Dansk)", "Hej, Goddag";
- "English", "Hello";
- "Esperanto", "Saluton";
- "Estonian", "Tere, Tervist";
- "FORTRAN", "PROGRAM";
- "Finnish (Suomi)", "Hei";
- "French (Français)", "Bonjour, Salut";
- "German (Deutsch Nord)", "Guten Tag";
- "German (Deutsch Süd)", "Grüß Gott";
- "Greek (Ελληνικά)", "Γειά σας";
- "Hebrew", "שלו×";
- "Italiano", "Ciao, Buon giorno";
- "Maltese", "Ciao";
- "Nederlands, Vlaams", "Hallo, Hoi, Goedendag";
- "Norwegian (Norsk)", "Hei, God dag";
- "Polish", "Cześć!";
- "Russian (РуÑÑкий)", "ЗдравÑтвуйте!";
- "Slovak", "Dobrý deň";
- "Spanish (Español)", "¡Hola!";
- "Swedish (Svenska)", "Hej, Goddag";
- "Thai (�������)", "�������, ������";
- "Tigrigna (ትáŒáˆ­áŠ›)", "ሰላማት";
- "Turkish (Türkçe)", "Merhaba";
- "Vietnamese (Tiếng Việt)", "Chào bạn";
- "Japanese (日本語)", "ã“ã‚“ã«ã¡ã¯";
- "Chinese (中文,普通è¯,汉语)", "你好";
- "Cantonese (粵語,廣æ±è©±)", "早晨, 你好";
- "Hangul (한글)", "안녕하세요, 안녕하십니까" ]
-;;
-
-let _ = Printexc.print mainLoop ()
diff --git a/otherlibs/labltk/examples_labltk/taquin.ml b/otherlibs/labltk/examples_labltk/taquin.ml
deleted file mode 100644
index a3bcbb1bfb..0000000000
--- a/otherlibs/labltk/examples_labltk/taquin.ml
+++ /dev/null
@@ -1,143 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Tk;;
-
-let découpe_image img nx ny =
- let l = Imagephoto.width img
- and h = Imagephoto.height img in
- let tx = l / nx and ty = h / ny in
- let pièces = ref [] in
- for x = 0 to nx - 1 do
- for y = 0 to ny - 1 do
- let pièce = Imagephoto.create ~width:tx ~height:ty () in
- Imagephoto.copy ~src:img
- ~src_area:(x * tx, y * ty, (x + 1) * tx, (y + 1) * ty) pièce;
- pièces := pièce :: !pièces
- done
- done;
- (tx, ty, List.tl !pièces);;
-
-let remplir_taquin c nx ny tx ty pièces =
- let trou_x = ref (nx - 1)
- and trou_y = ref (ny - 1) in
- let trou =
- Canvas.create_rectangle
- ~x1:(!trou_x * tx) ~y1:(!trou_y * ty) ~x2:tx ~y2:ty c in
- let taquin = Array.make_matrix nx ny trou in
- let p = ref pièces in
- for x = 0 to nx - 1 do
- for y = 0 to ny - 1 do
- match !p with
- | [] -> ()
- | pièce :: reste ->
- taquin.(x).(y) <-
- Canvas.create_image
- ~x:(x * tx) ~y:(y * ty)
- ~image:pièce ~anchor:`Nw ~tags:["pièce"] c;
- p := reste
- done
- done;
- let déplacer x y =
- let pièce = taquin.(x).(y) in
- Canvas.coords_set c pièce
- ~xys:[!trou_x * tx, !trou_y * ty];
- Canvas.coords_set c trou
- ~xys:[x * tx, y * ty; tx, ty];
- taquin.(!trou_x).(!trou_y) <- pièce;
- taquin.(x).(y) <- trou;
- trou_x := x; trou_y := y in
- let jouer ei =
- let x = ei.ev_MouseX / tx and y = ei.ev_MouseY / ty in
- if x = !trou_x && (y = !trou_y - 1 || y = !trou_y + 1)
- || y = !trou_y && (x = !trou_x - 1 || x = !trou_x + 1)
- then déplacer x y in
- Canvas.bind ~events:[`ButtonPress]
- ~fields:[`MouseX; `MouseY] ~action:jouer c (`Tag "pièce");;
-
-let rec permutation = function
- | [] -> []
- | l -> let n = Random.int (List.length l) in
- let (élément, reste) = partage l n in
- élément :: permutation reste
-
-and partage l n =
- match l with
- | [] -> failwith "partage"
- | tête :: reste ->
- if n = 0 then (tête, reste) else
- let (élément, reste') = partage reste (n - 1) in
- (élément, tête :: reste');;
-
-let create_filled_text parent lines =
- let lnum = List.length lines
- and lwidth =
- List.fold_right
- (fun line max ->
- let l = String.length line in
- if l > max then l else max)
- lines 1 in
- let txtw = Text.create ~width:lwidth ~height:lnum parent in
- List.iter
- (fun line ->
- Text.insert ~index:(`End, []) ~text:line txtw;
- Text.insert ~index:(`End, []) ~text:"\n" txtw)
- lines;
- txtw;;
-
-let give_help parent lines () =
- let help_window = Toplevel.create parent in
- Wm.title_set help_window "Help";
-
- let help_frame = Frame.create help_window in
-
- let help_txtw = create_filled_text help_frame lines in
-
- let quit_help () = destroy help_window in
- let ok_button = Button.create ~text:"Ok" ~command:quit_help help_frame in
-
- pack ~side:`Bottom [help_txtw];
- pack ~side:`Bottom [ok_button ];
- pack [help_frame];;
-
-let taquin nom_fichier nx ny =
- let fp = openTk () in
- Wm.title_set fp "Taquin";
- let img = Imagephoto.create ~file:nom_fichier () in
- let c =
- Canvas.create ~background:`Black
- ~width:(Imagephoto.width img)
- ~height:(Imagephoto.height img) fp in
- let (tx, ty, pièces) = découpe_image img nx ny in
- remplir_taquin c nx ny tx ty (permutation pièces);
- pack [c];
-
- let quit = Button.create ~text:"Quit" ~command:closeTk fp in
- let help_lines =
- ["Pour jouer, cliquer sur une des pièces";
- "entourant le trou";
- "";
- "To play, click on a part around the hole"] in
- let help =
- Button.create ~text:"Help" ~command:(give_help fp help_lines) fp in
- pack ~side:`Left ~fill:`X [quit] ;
- pack ~side:`Left ~fill:`X [help] ;
- mainLoop ();;
-
-if !Sys.interactive then () else
-begin taquin "Lambda2.back.gif" 4 4; exit 0 end;;
diff --git a/otherlibs/labltk/examples_labltk/tetris.ml b/otherlibs/labltk/examples_labltk/tetris.ml
deleted file mode 100644
index 3e3f1e8a4b..0000000000
--- a/otherlibs/labltk/examples_labltk/tetris.ml
+++ /dev/null
@@ -1,710 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* A Tetris game for LablTk *)
-(* written by Jun P. Furuse *)
-
-open StdLabels
-open Tk
-
-exception Done
-
-type falling_block = {
- mutable pattern: int array list;
- mutable bcolor: int;
- mutable x: int;
- mutable y: int;
- mutable d: int;
- mutable alive: bool
- }
-
-let stop_a_bit = 300
-
-let field_width = 10
-let field_height = 20
-
-let colors = [|
- `Color "red";
- `Color "yellow";
-
- `Color "blue";
- `Color "orange";
-
- `Color "magenta";
- `Color "green";
-
- `Color "cyan"
-|]
-
-(* Put here your favorite image files *)
-let backgrounds = [
- "Lambda2.back.gif"
-]
-
-(* blocks *)
-let block_size = 16
-let cell_border = 2
-
-let blocks = [
- [ [|"0000";
- "0000";
- "1111";
- "0000" |];
-
- [|"0010";
- "0010";
- "0010";
- "0010" |];
-
- [|"0000";
- "0000";
- "1111";
- "0000" |];
-
- [|"0010";
- "0010";
- "0010";
- "0010" |] ];
-
- [ [|"0000";
- "0110";
- "0110";
- "0000" |];
-
- [|"0000";
- "0110";
- "0110";
- "0000" |];
-
- [|"0000";
- "0110";
- "0110";
- "0000" |];
-
- [|"0000";
- "0110";
- "0110";
- "0000" |] ];
-
- [ [|"0000";
- "0111";
- "0100";
- "0000" |];
-
- [|"0000";
- "0110";
- "0010";
- "0010" |];
-
- [|"0000";
- "0010";
- "1110";
- "0000" |];
-
- [|"0100";
- "0100";
- "0110";
- "0000" |] ];
-
- [ [|"0000";
- "0100";
- "0111";
- "0000" |];
-
- [|"0000";
- "0110";
- "0100";
- "0100" |];
-
- [|"0000";
- "1110";
- "0010";
- "0000" |];
-
- [|"0010";
- "0010";
- "0110";
- "0000" |] ];
-
- [ [|"0000";
- "1100";
- "0110";
- "0000" |];
-
- [|"0010";
- "0110";
- "0100";
- "0000" |];
-
- [|"0000";
- "1100";
- "0110";
- "0000" |];
-
- [|"0010";
- "0110";
- "0100";
- "0000" |] ];
-
- [ [|"0000";
- "0011";
- "0110";
- "0000" |];
-
- [|"0100";
- "0110";
- "0010";
- "0000" |];
-
- [|"0000";
- "0011";
- "0110";
- "0000" |];
-
- [|"0000";
- "0100";
- "0110";
- "0010" |] ];
-
- [ [|"0000";
- "0000";
- "1110";
- "0100" |];
-
- [|"0000";
- "0100";
- "1100";
- "0100" |];
-
- [|"0000";
- "0100";
- "1110";
- "0000" |];
-
- [|"0000";
- "0100";
- "0110";
- "0100" |] ]
-
-]
-
-let line_empty = int_of_string "0b1110000000000111"
-let line_full = int_of_string "0b1111111111111111"
-
-let decode_block dvec =
- let btoi d = int_of_string ("0b"^d) in
- Array.map ~f:btoi dvec
-
-class cell t1 t2 t3 ~canvas ~x ~y = object
- val mutable color = 0
- method get = color
- method set ~color:col =
- if color = col then () else
- if color <> 0 && col = 0 then begin
- Canvas.move canvas t1
- ~x:(- block_size * (x + 1) -10 - cell_border * 2)
- ~y:(- block_size * (y + 1) -10 - cell_border * 2);
- Canvas.move canvas t2
- ~x:(- block_size * (x + 1) -10 - cell_border * 2)
- ~y:(- block_size * (y + 1) -10 - cell_border * 2);
- Canvas.move canvas t3
- ~x:(- block_size * (x + 1) -10 - cell_border * 2)
- ~y:(- block_size * (y + 1) -10 - cell_border * 2)
- end else begin
- Canvas.configure_rectangle canvas t2
- ~fill: colors.(col - 1)
- ~outline: colors.(col - 1);
- Canvas.configure_rectangle canvas t1
- ~fill: `Black
- ~outline: `Black;
- Canvas.configure_rectangle canvas t3
- ~fill: (`Color "light gray")
- ~outline: (`Color "light gray");
- if color = 0 && col <> 0 then begin
- Canvas.move canvas t1
- ~x: (block_size * (x+1)+10+ cell_border*2)
- ~y: (block_size * (y+1)+10+ cell_border*2);
- Canvas.move canvas t2
- ~x: (block_size * (x+1)+10+ cell_border*2)
- ~y: (block_size * (y+1)+10+ cell_border*2);
- Canvas.move canvas t3
- ~x: (block_size * (x+1)+10+ cell_border*2)
- ~y: (block_size * (y+1)+10+ cell_border*2)
- end
- end;
- color <- col
-end
-
-let cell_get (c, cf) x y = cf.(y).(x) #get
-
-let cell_set (c, cf) ~x ~y ~color =
- if x >= 0 && y >= 0 && Array.length cf > y && Array.length cf.(y) > x then
- let cur = cf.(y).(x) in
- if cur#get = color then () else cur#set ~color
-
-let create_base_matrix ~cols ~rows =
- let m = Array.create_matrix ~dimx:rows ~dimy:cols (0,0) in
- for x = 0 to cols - 1 do for y = 0 to rows - 1 do
- m.(y).(x) <- (x,y)
- done done;
- m
-
-let init fw =
- let scorev = Textvariable.create ()
- and linev = Textvariable.create ()
- and levv = Textvariable.create ()
- and namev = Textvariable.create ()
- in
- let f = Frame.create fw ~borderwidth: 2 in
- let c = Canvas.create f ~width: (block_size * 10)
- ~height: (block_size * 20)
- ~borderwidth: cell_border
- ~relief: `Sunken
- ~background: `Black
- and r = Frame.create f
- and r' = Frame.create f in
-
- let nl = Label.create r ~text: "Next" ~font: "variable" in
- let nc = Canvas.create r ~width: (block_size * 4)
- ~height: (block_size * 4)
- ~borderwidth: cell_border
- ~relief: `Sunken
- ~background: `Black in
- let scl = Label.create r ~text: "Score" ~font: "variable" in
- let sc = Label.create r ~textvariable: scorev ~font: "variable" in
- let lnl = Label.create r ~text: "Lines" ~font: "variable" in
- let ln = Label.create r ~textvariable: linev ~font: "variable" in
- let levl = Label.create r ~text: "Level" ~font: "variable" in
- let lev = Label.create r ~textvariable: levv ~font: "variable" in
- let newg = Button.create r ~text: "New Game" ~font: "variable" in
-
- pack [f];
- pack [coe c; coe r; coe r'] ~side: `Left ~fill: `Y;
- pack [coe nl; coe nc] ~side: `Top;
- pack [coe scl; coe sc; coe lnl; coe ln; coe levl; coe lev; coe newg]
- ~side: `Top;
-
- let cells_src = create_base_matrix ~cols:field_width ~rows:field_height in
- let cells =
- Array.map cells_src ~f:
- (Array.map ~f:
- begin fun (x,y) ->
- let t1 =
- Canvas.create_rectangle c
- ~x1:(-block_size - 8) ~y1:(-block_size - 8)
- ~x2:(-9) ~y2:(-9)
- and t2 =
- Canvas.create_rectangle c
- ~x1:(-block_size - 10) ~y1:(-block_size - 10)
- ~x2:(-11) ~y2:(-11)
- and t3 =
- Canvas.create_rectangle c
- ~x1:(-block_size - 12) ~y1:(-block_size - 12)
- ~x2:(-13) ~y2:(-13)
- in
- Canvas.raise c t1;
- Canvas.raise c t2;
- Canvas.lower c t3;
- new cell ~canvas:c ~x ~y t1 t2 t3
- end)
- in
- let nexts_src = create_base_matrix ~cols:4 ~rows:4 in
- let nexts =
- Array.map nexts_src ~f:
- (Array.map ~f:
- begin fun (x,y) ->
- let t1 =
- Canvas.create_rectangle nc
- ~x1:(-block_size - 8) ~y1:(-block_size - 8)
- ~x2:(-9) ~y2:(-9)
- and t2 =
- Canvas.create_rectangle nc
- ~x1:(-block_size - 10) ~y1:(-block_size - 10)
- ~x2:(-11) ~y2:(-11)
- and t3 =
- Canvas.create_rectangle nc
- ~x1:(-block_size - 12) ~y1:(-block_size - 12)
- ~x2:(-13) ~y2:(-13)
- in
- Canvas.raise nc t1;
- Canvas.raise nc t2;
- Canvas.lower nc t3;
- new cell ~canvas:nc ~x ~y t1 t2 t3
- end)
- in
- let game_over () = ()
- in
- (* What a mess ! *)
- [ coe f; coe c; coe r; coe nl; coe nc; coe scl; coe sc; coe levl; coe lev;
- coe lnl; coe ln ],
- newg, (c, cells), (nc, nexts), scorev, linev, levv, game_over
-
-
-let draw_block field ~color ~block ~x ~y =
- for iy = 0 to 3 do
- let base = ref 1 in
- let xd = block.(iy) in
- for ix = 0 to 3 do
- if xd land !base <> 0 then
- cell_set field ~x:(ix + x) ~y:(iy + y) ~color;
- base := !base lsl 1
- done
- done
-
-let timer_ref = (ref None : Timer.t option ref)
-(* I know, this should be timer ref, but I'm not sure what should be
- the initial value ... *)
-
-let remove_timer () =
- match !timer_ref with
- None -> ()
- | Some t -> Timer.remove t (* ; prerr_endline "removed!" *)
-
-let do_after ~ms ~callback =
- timer_ref := Some (Timer.add ~ms ~callback)
-
-let copy_block c =
- { pattern= !c.pattern;
- bcolor= !c.bcolor;
- x= !c.x;
- y= !c.y;
- d= !c.d;
- alive= !c.alive }
-
-let _ =
- let top = openTk () in
- let lb = Label.create top
- and fw = Frame.create top
- in
- let set_message s = Label.configure lb ~text:s in
- pack [coe lb; coe fw] ~side: `Top;
- let score = ref 0 in
- let line = ref 0 in
- let level = ref 0 in
- let time = ref 1000 in
- let blocks = List.map ~f:(List.map ~f:decode_block) blocks in
- let field = Array.create 26 0 in
- let widgets, button, cell_field, next_field, scorev, linev, levv, game_over
- = init fw in
- let canvas = fst cell_field in
-
- let init_field () =
- for i = 0 to 25 do
- field.(i) <- line_empty
- done;
- field.(23) <- line_full;
- for i = 0 to 19 do
- for j = 0 to 9 do
- cell_set cell_field ~x:j ~y:i ~color:0
- done
- done;
- for i = 0 to 3 do
- for j = 0 to 3 do
- cell_set next_field ~x:j ~y:i ~color:0
- done
- done
- in
-
- let draw_falling_block fb =
- draw_block cell_field ~color: fb.bcolor
- ~block: (List.nth fb.pattern fb.d)
- ~x: (fb.x - 3)
- ~y: (fb.y - 3)
-
- and erase_falling_block fb =
- draw_block cell_field ~color: 0
- ~block: (List.nth fb.pattern fb.d)
- ~x: (fb.x - 3)
- ~y: (fb.y - 3)
- in
-
- let stone fb =
- for i=0 to 3 do
- let cur = field.(i + fb.y) in
- field.(i + fb.y) <-
- cur lor ((List.nth fb.pattern fb.d).(i) lsl fb.x)
- done;
- for i=0 to 2 do
- field.(i) <- line_empty
- done
-
- and clear fb =
- let l = ref 0 in
- for i = 0 to 3 do
- if i + fb.y >= 3 && i + fb.y <= 22 then
- if field.(i + fb.y) = line_full then
- begin
- incr l;
- field.(i + fb.y) <- line_empty;
- for j = 0 to 9 do
- cell_set cell_field ~x:j ~y:(i + fb.y - 3) ~color:0
- done
- end
- done;
- !l
-
- and fall_lines () =
- let eye = ref 22 (* bottom *)
- and cur = ref 22 (* bottom *)
- in
- try
- while !eye >= 3 do
- while field.(!eye) = line_empty do
- decr eye;
- if !eye = 2 then raise Done
- done;
- field.(!cur) <- field.(!eye);
- for j = 0 to 9 do
- cell_set cell_field ~x:j ~y:(!cur-3)
- ~color:(cell_get cell_field j (!eye-3))
- done;
- decr eye;
- decr cur
- done
- with Done -> ();
- for i = 3 to !cur do
- field.(i) <- line_empty;
- for j = 0 to 9 do
- cell_set cell_field ~x:j ~y:(i-3) ~color:0
- done
- done
- in
-
- let next = ref 42 (* THE ANSWER *)
- and current =
- ref { pattern= [[|0;0;0;0|]]; bcolor=0; x=0; y=0; d=0; alive= false}
- in
-
- let draw_next () =
- draw_block next_field ~color: (!next+1)
- ~block: (List.hd (List.nth blocks !next))
- ~x: 0 ~y: 0
-
- and erase_next () =
- draw_block next_field ~color: 0
- ~block: (List.hd (List.nth blocks !next))
- ~x: 0 ~y: 0
- in
-
- let set_nextblock () =
- current :=
- { pattern= (List.nth blocks !next);
- bcolor= !next+1;
- x=6; y= 1; d= 0; alive= true};
- erase_next ();
- next := Random.int 7;
- draw_next ()
- in
-
- let death_check fb =
- try
- for i=0 to 3 do
- let cur = field.(i + fb.y) in
- if cur land ((List.nth fb.pattern fb.d).(i) lsl fb.x) <> 0
- then raise Done
- done;
- false
- with
- Done -> true
- in
-
- let try_to_move m =
- if !current.alive then
- let sub m =
- if death_check m then false
- else
- begin
- erase_falling_block !current;
- draw_falling_block m;
- current := m;
- true
- end
- in
- if sub m then true
- else
- begin
- m.x <- m.x + 1;
- if sub m then true
- else
- begin
- m.x <- m.x - 2;
- sub m
- end
- end
- else false
- in
-
- let image_load =
- let i = Canvas.create_image canvas
- ~x: (block_size * 5 + block_size / 2)
- ~y: (block_size * 10 + block_size / 2)
- ~anchor: `Center in
- Canvas.lower canvas i;
- let img = Imagephoto.create () in
- fun file ->
- try
- Imagephoto.configure img ~file: file;
- Canvas.configure_image canvas i ~image: img
- with
- _ ->
- begin
- Printf.eprintf "%s : No such image...\n" file;
- flush stderr
- end
- in
-
- let add_score l =
- let pline = !line in
- if l <> 0 then
- begin
- line := !line + l;
- score := !score + l * l;
- set_message (Printf.sprintf "%d pts" (1 lsl ((l - 1) * 2)))
- end;
- Textvariable.set linev (string_of_int !line);
- Textvariable.set scorev (string_of_int !score);
-
- if !line /10 <> pline /10 then
- (* update the background every 10 lines. *)
- begin
- let num_image = List.length backgrounds - 1 in
- let n = !line/10 in
- let n = if n > num_image then num_image else n in
- let file = List.nth backgrounds n in
- image_load file;
- incr level;
- Textvariable.set levv (string_of_int !level)
- end
- in
-
- let rec newblock () =
- set_message "TETRIS";
- set_nextblock ();
- draw_falling_block !current;
- if death_check !current then
- begin
- !current.alive <- false;
- set_message "GAME OVER";
- game_over ()
- end
- else
- begin
- time := 1100 - (!level / 4 * 300) - ((!level mod 4) * 200);
- if !time < 60 - !level * 3 then time := 60 - !level * 3;
- do_after ~ms:stop_a_bit ~callback:loop
- end
-
- and loop () =
- let m = copy_block current in
- m.y <- m.y + 1;
- if death_check m then
- begin
- !current.alive <- false;
- stone !current;
- do_after ~ms:stop_a_bit ~callback:
- begin fun () ->
- let l = clear !current in
- if l > 0 then
- do_after ~ms:stop_a_bit ~callback:
- begin fun () ->
- fall_lines ();
- add_score l;
- do_after ~ms:stop_a_bit ~callback:newblock
- end
- else
- newblock ()
- end
- end
- else
- begin
- erase_falling_block !current;
- draw_falling_block m;
- current := m;
- do_after ~ms:!time ~callback:loop
- end
- in
-
- let bind_game w =
- bind w ~events:[`KeyPress] ~fields:[`KeySymString] ~action:
- begin fun e ->
- match e.ev_KeySymString with
- | "h" ->
- let m = copy_block current in
- m.x <- m.x - 1;
- ignore (try_to_move m)
- | "j" ->
- let m = copy_block current in
- m.d <- m.d + 1;
- if m.d = List.length m.pattern then m.d <- 0;
- ignore (try_to_move m)
- | "k" ->
- let m = copy_block current in
- m.d <- m.d - 1;
- if m.d < 0 then m.d <- List.length m.pattern - 1;
- ignore (try_to_move m)
- | "l" ->
- let m = copy_block current in
- m.x <- m.x + 1;
- ignore (try_to_move m)
- | "m" ->
- remove_timer ();
- loop ()
- | "space" ->
- if !current.alive then
- begin
- let m = copy_block current
- and n = copy_block current in
- while
- m.y <- m.y + 1;
- if death_check m then false
- else begin n.y <- m.y; true end
- do () done;
- erase_falling_block !current;
- draw_falling_block n;
- current := n;
- remove_timer ();
- loop ()
- end
- | _ -> ()
- end
- in
-
- let game_init () =
- (* Game Initialization *)
- set_message "Initializing ...";
- remove_timer ();
- image_load (List.hd backgrounds);
- time := 1000;
- score := 0;
- line := 0;
- level := 1;
- add_score 0;
- init_field ();
- next := Random.int 7;
- set_message "Welcome to TETRIS";
- set_nextblock ();
- draw_falling_block !current;
- do_after ~ms:!time ~callback:loop
- in
- (* As an applet, it was required... *)
- (* List.iter f: bind_game widgets; *)
- bind_game top;
- Button.configure button ~command: game_init;
- game_init ()
-
-let _ = Printexc.print mainLoop ()
diff --git a/otherlibs/labltk/frx/.depend b/otherlibs/labltk/frx/.depend
deleted file mode 100644
index d815ab0eb0..0000000000
--- a/otherlibs/labltk/frx/.depend
+++ /dev/null
@@ -1,38 +0,0 @@
-frx_after.cmo: frx_after.cmi
-frx_after.cmx: frx_after.cmi
-frx_color.cmo: frx_color.cmi
-frx_color.cmx: frx_color.cmi
-frx_ctext.cmo: frx_fit.cmi frx_text.cmi frx_ctext.cmi
-frx_ctext.cmx: frx_fit.cmx frx_text.cmx frx_ctext.cmi
-frx_dialog.cmo: frx_dialog.cmi
-frx_dialog.cmx: frx_dialog.cmi
-frx_entry.cmo: frx_entry.cmi
-frx_entry.cmx: frx_entry.cmi
-frx_fillbox.cmo: frx_fillbox.cmi
-frx_fillbox.cmx: frx_fillbox.cmi
-frx_fit.cmo: frx_after.cmi frx_fit.cmi
-frx_fit.cmx: frx_after.cmx frx_fit.cmi
-frx_focus.cmo: frx_focus.cmi
-frx_focus.cmx: frx_focus.cmi
-frx_font.cmo: frx_misc.cmi frx_font.cmi
-frx_font.cmx: frx_misc.cmx frx_font.cmi
-frx_lbutton.cmo: frx_lbutton.cmi
-frx_lbutton.cmx: frx_lbutton.cmi
-frx_listbox.cmo: frx_listbox.cmi
-frx_listbox.cmx: frx_listbox.cmi
-frx_mem.cmo: frx_mem.cmi
-frx_mem.cmx: frx_mem.cmi
-frx_misc.cmo: frx_misc.cmi
-frx_misc.cmx: frx_misc.cmi
-frx_req.cmo: frx_entry.cmi frx_listbox.cmi frx_widget.cmi frx_req.cmi
-frx_req.cmx: frx_entry.cmx frx_listbox.cmx frx_widget.cmx frx_req.cmi
-frx_rpc.cmo: frx_rpc.cmi
-frx_rpc.cmx: frx_rpc.cmi
-frx_selection.cmo: frx_selection.cmi
-frx_selection.cmx: frx_selection.cmi
-frx_synth.cmo: frx_synth.cmi
-frx_synth.cmx: frx_synth.cmi
-frx_text.cmo: frx_misc.cmi frx_text.cmi
-frx_text.cmx: frx_misc.cmx frx_text.cmi
-frx_widget.cmo: frx_widget.cmi
-frx_widget.cmx: frx_widget.cmi
diff --git a/otherlibs/labltk/frx/Makefile b/otherlibs/labltk/frx/Makefile
deleted file mode 100644
index 226ba129f0..0000000000
--- a/otherlibs/labltk/frx/Makefile
+++ /dev/null
@@ -1,51 +0,0 @@
-include ../support/Makefile.common
-
-COMPFLAGS=-I ../camltk -I ../support -I $(OTHERS)/unix
-
-OBJS= frx_misc.cmo frx_widget.cmo frx_font.cmo frx_entry.cmo frx_text.cmo \
- frx_listbox.cmo frx_req.cmo frx_fillbox.cmo frx_focus.cmo \
- frx_dialog.cmo frx_mem.cmo frx_rpc.cmo frx_synth.cmo frx_selection.cmo \
- frx_after.cmo frx_fit.cmo frx_ctext.cmo frx_color.cmo
-
-OBJSX = $(OBJS:.cmo=.cmx)
-
-all: frxlib.cma
-
-opt: frxlib.cmxa
-
-frxlib.cma: $(OBJS)
- $(CAMLLIBR) -o frxlib.cma $(OBJS)
-
-frxlib.cmxa: $(OBJSX)
- $(CAMLOPTLIBR) -o frxlib.cmxa $(OBJSX)
-
-install: frxlib.cma
- cp *.cmi *.mli frxlib.cma $(INSTALLDIR)
-
-installopt: frxlib.cmxa
- cp frxlib.cmxa frxlib.a $(INSTALLDIR)
-
-clean:
- rm -f *.cm* *.o *.a
-
-$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma
-
-$(OBJSX): ../lib/$(LIBNAME).cmxa
-
-.SUFFIXES :
-.SUFFIXES : .mli .ml .cmi .cmo .cmx
-
-.mli.cmi:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-
-depend:
- $(CAMLDEP) *.mli *.ml > .depend
-
-include .depend
diff --git a/otherlibs/labltk/frx/Makefile.nt b/otherlibs/labltk/frx/Makefile.nt
deleted file mode 100644
index 2f37a4cb91..0000000000
--- a/otherlibs/labltk/frx/Makefile.nt
+++ /dev/null
@@ -1,53 +0,0 @@
-include ../support/Makefile.common.nt
-
-COMPFLAGS=-I ../camltk -I ../support
-
-OBJS= frx_misc.cmo frx_widget.cmo frx_font.cmo frx_entry.cmo frx_text.cmo \
- frx_listbox.cmo frx_req.cmo frx_fillbox.cmo frx_focus.cmo \
- frx_dialog.cmo frx_mem.cmo frx_rpc.cmo frx_synth.cmo frx_selection.cmo \
- frx_after.cmo frx_fit.cmo frx_ctext.cmo frx_color.cmo
-
-OBJSX = $(OBJS:.cmo=.cmx)
-
-all: libfrx.cma
-
-opt: libfrx.cmxa
-
-libfrx.cma: $(OBJS)
- $(CAMLLIBR) -o libfrx.cma $(OBJS)
-
-libfrx.cmxa: $(OBJSX)
- $(CAMLOPTLIBR) -o libfrx.cmxa $(OBJSX)
-
-
-install: libfrx.cma
- cp *.cmi *.mli libfrx.cma $(INSTALLDIR)
-
-installopt: libfrx.cmxa
- cp libfrx.cmxa libfrx.$(A) $(INSTALLDIR)
-
-
-clean:
- rm -f *.cm* *.$(O) *.$(A) *~ *test
-
-$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma
-
-$(OBJSX): ../lib/$(LIBNAME).cmxa
-
-.SUFFIXES :
-.SUFFIXES : .mli .ml .cmi .cmo .cmx
-
-.mli.cmi:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-
-depend:
- $(CAMLDEP) *.mli *.ml > .depend
-
-include .depend
diff --git a/otherlibs/labltk/frx/README b/otherlibs/labltk/frx/README
deleted file mode 100644
index b86f8dcd85..0000000000
--- a/otherlibs/labltk/frx/README
+++ /dev/null
@@ -1,2 +0,0 @@
-This is Francois Rouaix's widget set library, Frx.
-It uses CamlTk API. \ No newline at end of file
diff --git a/otherlibs/labltk/frx/frx_after.ml b/otherlibs/labltk/frx/frx_after.ml
deleted file mode 100644
index 7fe6a4f2a5..0000000000
--- a/otherlibs/labltk/frx/frx_after.ml
+++ /dev/null
@@ -1,24 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Protocol
-let idle f =
- let id = new_function_id () in
- let wrapped _ =
- clear_callback id; (* do it first in case f raises exception *)
- f() in
- Hashtbl.add callback_naming_table id wrapped;
- tkCommand [| TkToken "after"; TkToken "idle";
- TkToken ("camlcb "^ string_of_cbid id) |]
diff --git a/otherlibs/labltk/frx/frx_after.mli b/otherlibs/labltk/frx/frx_after.mli
deleted file mode 100644
index 73c07f7bb9..0000000000
--- a/otherlibs/labltk/frx/frx_after.mli
+++ /dev/null
@@ -1,17 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-val idle : (unit -> unit) -> unit
- (* [idle f] is equivalent to Tk "after idle {camlcb f}" *)
diff --git a/otherlibs/labltk/frx/frx_color.ml b/otherlibs/labltk/frx/frx_color.ml
deleted file mode 100644
index 4df3eb6b45..0000000000
--- a/otherlibs/labltk/frx/frx_color.ml
+++ /dev/null
@@ -1,35 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-open Protocol
-
-module StringSet = Set.Make(struct type t = string let compare = compare end)
-
-(* should we keep a negative cache ? *)
-let available_colors = ref (StringSet.empty)
-
-let check s =
- if StringSet.mem s !available_colors then true
- else begin
- try
- let f = Frame.create_named Widget.default_toplevel "frxcolorcheck"
- [Background (NamedColor s)] in
- available_colors := StringSet.add s !available_colors;
- destroy f;
- true
- with
- TkError _ -> false
- end
diff --git a/otherlibs/labltk/frx/frx_color.mli b/otherlibs/labltk/frx/frx_color.mli
deleted file mode 100644
index 513cb08394..0000000000
--- a/otherlibs/labltk/frx/frx_color.mli
+++ /dev/null
@@ -1,16 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-val check : string -> bool
diff --git a/otherlibs/labltk/frx/frx_ctext.ml b/otherlibs/labltk/frx/frx_ctext.ml
deleted file mode 100644
index 0d4fd836ef..0000000000
--- a/otherlibs/labltk/frx/frx_ctext.ml
+++ /dev/null
@@ -1,66 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-(* A trick by Steve Ball to do pixel scrolling on text widgets *)
-(* USES frx_fit *)
-open Camltk
-
-let create top opts navigation =
- let f = Frame.create top [BorderWidth (Pixels 2); Relief Raised] in
- let lf = Frame.create f [] in
- let rf = Frame.create f [] in
- let c = Canvas.create lf [BorderWidth (Pixels 0)]
- and xscroll = Scrollbar.create lf [Orient Horizontal]
- and yscroll = Scrollbar.create rf [Orient Vertical]
- and secret = Frame.create_named rf "secret" []
- in
- let t = Text.create c (BorderWidth(Pixels 0) :: opts) in
- if navigation then Frx_text.navigation_keys t;
-
- (* Make the text widget an embedded canvas object *)
- ignore
- (Canvas.create_window c (Pixels 0) (Pixels 0)
- [Anchor NW; Window t; Tags [Tag "main"]]);
- Canvas.focus c (Tag "main");
- (*
- Canvas.configure c [Width (Pixels (Winfo.reqwidth t));
- Height(Pixels (Winfo.reqheight t))];
- *)
- Canvas.configure c [YScrollCommand (Scrollbar.set yscroll)];
- (* The horizontal scrollbar is directly attached to the
- * text widget, because h scrolling works properly *)
- Scrollbar.configure xscroll [ScrollCommand (Text.xview t)];
- (* But vertical scroll is attached to the canvas *)
- Scrollbar.configure yscroll [ScrollCommand (Canvas.yview c)];
- let scroll, check = Frx_fit.vert t in
- Text.configure t [
- XScrollCommand (Scrollbar.set xscroll);
- YScrollCommand (fun first last ->
- scroll first last;
- let x,y,w,h = Canvas.bbox c [Tag "main"] in
- Canvas.configure c
- [ScrollRegion (Pixels x, Pixels y, Pixels w, Pixels h)])
- ];
-
- bind c [[],Configure] (BindSet ([Ev_Width], (fun ei ->
- Canvas.configure_window c (Tag "main") [Width (Pixels ei.ev_Width)])));
-
- pack [rf] [Side Side_Right; Fill Fill_Y];
- pack [lf] [Side Side_Left; Fill Fill_Both; Expand true];
- pack [secret] [Side Side_Bottom];
- pack [yscroll] [Side Side_Top; Fill Fill_Y; Expand true];
- pack [xscroll] [Side Side_Bottom; Fill Fill_X];
- pack [c] [Side Side_Left; Fill Fill_Both; Expand true];
- f, t
diff --git a/otherlibs/labltk/frx/frx_ctext.mli b/otherlibs/labltk/frx/frx_ctext.mli
deleted file mode 100644
index 157c0cad16..0000000000
--- a/otherlibs/labltk/frx/frx_ctext.mli
+++ /dev/null
@@ -1,25 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-
-val create :
- Widget.widget -> Camltk.options list -> bool -> Widget.widget * Widget.widget
- (* [create parent opts nav_keys] creates a text widget
- with "pixel scrolling". Based on a trick learned from Steve Ball.
- Returns (frame widget, text widget).
- *)
-
-
diff --git a/otherlibs/labltk/frx/frx_dialog.ml b/otherlibs/labltk/frx/frx_dialog.ml
deleted file mode 100644
index 0b65b419e3..0000000000
--- a/otherlibs/labltk/frx/frx_dialog.ml
+++ /dev/null
@@ -1,115 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-open Protocol
-
-let rec mapi f n l =
- match l with
- [] -> []
- | x::l -> let v = f n x in v::(mapi f (succ n) l)
-
-(* Same as tk_dialog, but not sharing the tkwait variable *)
-(* w IS the parent widget *)
-let f w name title mesg bitmap def buttons =
- let t = Toplevel.create_named w name [Class "Dialog"] in
- Wm.title_set t title;
- Wm.iconname_set t "Dialog";
- Wm.protocol_set t "WM_DELETE_WINDOW" (function () -> ());
- (* Wm.transient_set t (Winfo.toplevel w); *)
- let ftop =
- Frame.create_named t "top" [Relief Raised; BorderWidth (Pixels 1)]
- and fbot =
- Frame.create_named t "bot" [Relief Raised; BorderWidth (Pixels 1)]
- in
- pack [ftop][Side Side_Top; Fill Fill_Both];
- pack [fbot][Side Side_Bottom; Fill Fill_Both];
-
- let l =
- Label.create_named ftop "msg"
- [Justify Justify_Left; Text mesg; WrapLength (Pixels 600)] in
- pack [l][Side Side_Right; Expand true; Fill Fill_Both;
- PadX (Millimeters 3.0); PadY (Millimeters 3.0)];
- begin match bitmap with
- Predefined "" -> ()
- | _ ->
- let b =
- Label.create_named ftop "bitmap" [Bitmap bitmap] in
- pack [b][Side Side_Left; PadX (Millimeters 3.0); PadY (Millimeters 3.0)]
- end;
-
- let waitv = Textvariable.create_temporary t in
-
- let buttons =
- mapi (fun i bname ->
- let b = Button.create t
- [Text bname;
- Command (fun () -> Textvariable.set waitv (string_of_int i))] in
- if i = def then begin
- let f = Frame.create_named fbot "default"
- [Relief Sunken; BorderWidth (Pixels 1)] in
- raise_window_above b f;
- pack [f][Side Side_Left; Expand true;
- PadX (Millimeters 3.0); PadY (Millimeters 2.0)];
- pack [b][In f; PadX (Millimeters 2.0); PadY (Millimeters 2.0)];
- bind t [[], KeyPressDetail "Return"]
- (BindSet ([], (fun _ -> Button.flash b; Button.invoke b)))
- end
- else
- pack [b][In fbot; Side Side_Left; Expand true;
- PadX (Millimeters 3.0); PadY (Millimeters 2.0)];
- b
- )
- 0 buttons in
-
- Wm.withdraw t;
- update_idletasks();
- let x = (Winfo.screenwidth t)/2 - (Winfo.reqwidth t)/2 -
- (Winfo.vrootx (Winfo.parent t))
- and y = (Winfo.screenheight t)/2 - (Winfo.reqheight t)/2 -
- (Winfo.vrooty (Winfo.parent t)) in
- Wm.geometry_set t (Printf.sprintf "+%d+%d" x y);
- Wm.deiconify t;
-
- let oldfocus = try Some (Focus.get()) with _ -> None
- and oldgrab = Grab.current ~displayof: t ()
- and grabstatus = ref None in
- begin match oldgrab with
- [] -> ()
- | x::l -> grabstatus := Some(Grab.status x)
- end;
-
- (* avoid errors here because it makes the entire app useless *)
- (try Grab.set t with TkError _ -> ());
- Tkwait.visibility t;
- Focus.set (if def >= 0 then List.nth buttons def else t);
-
- Tkwait.variable waitv;
- begin match oldfocus with
- None -> ()
- | Some w -> try Focus.set w with _ -> ()
- end;
- destroy t;
- begin match oldgrab with
- [] -> ()
- | x::l ->
- try
- match !grabstatus with
- Some(GrabGlobal) -> Grab.set_global x
- | _ -> Grab.set x
- with TkError _ -> ()
- end;
-
- int_of_string (Textvariable.get waitv)
diff --git a/otherlibs/labltk/frx/frx_dialog.mli b/otherlibs/labltk/frx/frx_dialog.mli
deleted file mode 100644
index 2124150caa..0000000000
--- a/otherlibs/labltk/frx/frx_dialog.mli
+++ /dev/null
@@ -1,22 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-val f :
- Widget.widget ->
- string -> string -> string -> Camltk.bitmap -> int -> string list -> int
- (* same as Dialog.create_named, but with a local variable for
- synchronisation. Makes it possible to have several dialogs
- simultaneously *)
diff --git a/otherlibs/labltk/frx/frx_entry.ml b/otherlibs/labltk/frx/frx_entry.ml
deleted file mode 100644
index eea7362d66..0000000000
--- a/otherlibs/labltk/frx/frx_entry.ml
+++ /dev/null
@@ -1,42 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-
-let version = "$Id$"
-
-(*
- * Tk 4.0 has emacs bindings for entry widgets
- *)
-
-let new_label_entry parent txt action =
- let f = Frame.create parent [] in
- let m = Label.create f [Text txt]
- and e = Entry.create f [Relief Sunken; TextWidth 0] in
- Camltk.bind e [[], KeyPressDetail "Return"]
- (BindSet ([], fun _ -> action(Entry.get e)));
- pack [m][Side Side_Left];
- pack [e][Side Side_Right; Fill Fill_X; Expand true];
- f,e
-
-let new_labelm_entry parent txt memo =
- let f = Frame.create parent [] in
- let m = Label.create f [Text txt]
- and e = Entry.create f [Relief Sunken; TextVariable memo; TextWidth 0] in
- pack [m][Side Side_Left];
- pack [e][Side Side_Right; Fill Fill_X; Expand true];
- f,e
-
-
diff --git a/otherlibs/labltk/frx/frx_entry.mli b/otherlibs/labltk/frx/frx_entry.mli
deleted file mode 100644
index 2f34a7e64c..0000000000
--- a/otherlibs/labltk/frx/frx_entry.mli
+++ /dev/null
@@ -1,31 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-val new_label_entry :
- Widget.widget ->
- string -> (string -> unit) -> Widget.widget * Widget.widget
- (* [new_label_entry parent label action]
- creates a "labelled" entry widget where [action] will be invoked
- when the user types Return in the widget.
- Returns (frame widget, entry widget)
- *)
-val new_labelm_entry :
- Widget.widget ->
- string -> Textvariable.textVariable -> Widget.widget * Widget.widget
- (* [new_labelm_entry parent label variable]
- creates a "labelled" entry widget whose contents is [variable].
- Returns (frame widget, entry widget)
- *)
diff --git a/otherlibs/labltk/frx/frx_fileinput.ml b/otherlibs/labltk/frx/frx_fileinput.ml
deleted file mode 100644
index cf59d1303b..0000000000
--- a/otherlibs/labltk/frx/frx_fileinput.ml
+++ /dev/null
@@ -1,40 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-
-let version = "$Id$"
-
-(*
- * Simple spooling for fileinput callbacks
- *)
-
-let waiting_list = Queue. new()
-and waiting = ref 0
-and max_open = ref 10
-and cur_open = ref 0
-
-let add fd f =
- if !cur_open < !max_open then begin
- incr cur_open;
- add_fileinput fd f
- end
- else begin
- incr waiting;
- Queue.add (fd,f) waiting_list
- end
-
-let remove fd =
-
diff --git a/otherlibs/labltk/frx/frx_fillbox.ml b/otherlibs/labltk/frx/frx_fillbox.ml
deleted file mode 100644
index d9e4741889..0000000000
--- a/otherlibs/labltk/frx/frx_fillbox.ml
+++ /dev/null
@@ -1,65 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-
-(*
- * Progress indicators
- *)
-let okcolor = NamedColor "#3cb371"
-and kocolor = NamedColor "#dc5c5c"
-
-
-let new_vertical parent w h =
- let c = Canvas.create_named parent "fillbox"
- [Width (Pixels w); Height (Pixels h); BorderWidth (Pixels 1);
- Relief Sunken]
- in
- let i = Canvas.create_rectangle c (Pixels 0) (Pixels 0) (Pixels w) (Pixels 0)
- [FillColor okcolor; Outline okcolor]
- in
- c, (function
- 0 -> Canvas.configure_rectangle c i [FillColor okcolor;
- Outline okcolor];
- Canvas.coords_set c i [Pixels 0; Pixels 0;
- Pixels w; Pixels 0]
- | -1 -> Canvas.configure_rectangle c i [FillColor kocolor;
- Outline kocolor]
- | n ->
- let percent = if n > 100 then 100 else n in
- let hf = percent*h/100 in
- Canvas.coords_set c i [Pixels 0; Pixels 0;
- Pixels w; Pixels hf])
-
-let new_horizontal parent w h =
- let c = Canvas.create_named parent "fillbox"
- [Width (Pixels w); Height (Pixels h); BorderWidth (Pixels 1);
- Relief Sunken]
- in
- let i = Canvas.create_rectangle c (Pixels 0) (Pixels 0) (Pixels 0) (Pixels h)
- [FillColor okcolor; Outline okcolor]
- in
- c, (function
- 0 -> Canvas.configure_rectangle c i [FillColor okcolor;
- Outline okcolor];
- Canvas.coords_set c i [Pixels 0; Pixels 0;
- Pixels 0; Pixels h]
- | -1 -> Canvas.configure_rectangle c i [FillColor kocolor;
- Outline kocolor]
- | n ->
- let percent = if n > 100 then 100 else n in
- let wf = percent*w/100 in
- Canvas.coords_set c i [Pixels 0; Pixels 0;
- Pixels wf; Pixels h])
diff --git a/otherlibs/labltk/frx/frx_fillbox.mli b/otherlibs/labltk/frx/frx_fillbox.mli
deleted file mode 100644
index a825524cdc..0000000000
--- a/otherlibs/labltk/frx/frx_fillbox.mli
+++ /dev/null
@@ -1,31 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-
-val new_vertical :
- Widget.widget -> int -> int -> Widget.widget * (int -> unit)
- (* [new_vertical parent width height]
- creates a vertical fillbox of [width] and [height].
- Returns a frame widget and a function to set the current value of
- the fillbox. The value can be
- n < 0 : the fillbox changes color (reddish)
- 0 <= n <= 100: the fillbox fills up to n percent
- 100 <= n : the fillbox fills up to 95%
- *)
-
-val new_horizontal :
- Widget.widget -> int -> int -> Widget.widget * (int -> unit)
- (* save as above, except the widget is horizontal *)
diff --git a/otherlibs/labltk/frx/frx_fit.ml b/otherlibs/labltk/frx/frx_fit.ml
deleted file mode 100644
index 2011699ab7..0000000000
--- a/otherlibs/labltk/frx/frx_fit.ml
+++ /dev/null
@@ -1,83 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-
-let debug = ref false
-
-let vert wid =
- let newsize = ref 0
- and pending_resize = ref false
- and last_last = ref 0.0 in
- let rec resize () =
- pending_resize := false;
- if !debug then
- (Printf.eprintf "%s Resize %d\n"
- (Widget.name wid) !newsize; flush stderr);
- Text.configure wid [TextHeight !newsize];
- ()
- and check () =
- let first, last = Text.yview_get wid in
- check1 first last
-
- and check1 first last =
- let curheight = int_of_string (cget wid CHeight) in
- if !debug then begin
- Printf.eprintf "%s C %d %f %f\n"
- (Widget.name wid) curheight first last;
- flush stderr
- end;
- if first = 0.0 && last = 1.0 then ()
- (* Don't attempt anything if widget is not visible *)
- else if not (Winfo.viewable wid) then begin
- if !debug then
- (Printf.eprintf "%s C notviewable\n" (Widget.name wid);
- flush stderr);
- (* Try again later *)
- bind wid [[], Expose] (BindSet ([], fun _ ->
- bind wid [[], Expose] BindRemove;
- check()))
- end
- else begin
- let delta =
- if last = 0.0 then 1
- else if last = !last_last then
- (* it didn't change since our last resize ! *)
- 1
- else begin
- last_last := last;
- (* never to more than double *)
- let visible = max 0.5 (last -. first) in
- max 1 (truncate (float curheight *. (1. -. visible)))
- end in
- newsize := max (curheight + delta) !newsize;
- if !debug then
- (Printf.eprintf "%s newsize: %d\n" (Widget.name wid) !newsize;
- flush stderr);
- if !pending_resize then ()
- else begin
- pending_resize := true;
- Timer.set 300 (fun () -> Frx_after.idle resize)
- end
- end
-
- and scroll first last =
- if !debug then
- (Printf.eprintf "%s V %f %f\n" (Widget.name wid) first last;
- flush stderr);
- if first = 0.0 && last = 1.0 then ()
- else check1 first last
- in
- scroll, check
diff --git a/otherlibs/labltk/frx/frx_fit.mli b/otherlibs/labltk/frx/frx_fit.mli
deleted file mode 100644
index 29479d8013..0000000000
--- a/otherlibs/labltk/frx/frx_fit.mli
+++ /dev/null
@@ -1,29 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-open Widget
-
-val debug: bool ref
-val vert: widget -> (float -> float -> unit) * (unit -> unit)
-
-(* [vert widget]
- can be applied to a text widget so that it expands to show its full
- contents. Returns [scroll] and [check]. [scroll] must be used as
- the YScrollCommand of the widget. [check] can be called when some
- modification occurs in the content of the widget (such as a size change
- in some embedded windows.
- This feature is a terrible hack and should be used with extreme caution.
- *)
diff --git a/otherlibs/labltk/frx/frx_focus.ml b/otherlibs/labltk/frx/frx_focus.ml
deleted file mode 100644
index f33b9e6df1..0000000000
--- a/otherlibs/labltk/frx/frx_focus.ml
+++ /dev/null
@@ -1,26 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-
-(* Temporary focus *)
-
-(* ? use bind tag ? how about the global reference then *)
-let auto w =
- let old_focus = ref w in
- bind w [[],Enter]
- (BindSet([], fun _ -> old_focus := Focus.get (); Focus.set w));
- bind w [[],Leave]
- (BindSet([], fun _ -> Focus.set !old_focus))
diff --git a/otherlibs/labltk/frx/frx_focus.mli b/otherlibs/labltk/frx/frx_focus.mli
deleted file mode 100644
index 919f704754..0000000000
--- a/otherlibs/labltk/frx/frx_focus.mli
+++ /dev/null
@@ -1,18 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-val auto : Widget.widget -> unit
- (* *)
diff --git a/otherlibs/labltk/frx/frx_font.ml b/otherlibs/labltk/frx/frx_font.ml
deleted file mode 100644
index 023470261f..0000000000
--- a/otherlibs/labltk/frx/frx_font.ml
+++ /dev/null
@@ -1,51 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-open Widget
-
-let version = "$Id$"
-
-(*
- * Finding fonts. Inspired by code in Ical by Sanjay Ghemawat.
- * Possibly bogus because some families use "i" for italic where others
- * use "o".
- * wght: bold, medium
- * slant: i, o, r
- * pxlsz: 8, 10, ...
-*)
-module StringSet = Set.Make(struct type t = string let compare = compare end)
-
-let available_fonts = ref (StringSet.empty)
-
-let get_canvas =
- Frx_misc.autodef (fun () -> Canvas.create Widget.default_toplevel [])
-
-
-let find fmly wght slant pxlsz =
- let fontspec =
- "-*-"^fmly^"-"^wght^"-"^slant^"-normal-*-"^string_of_int pxlsz^"-*-*-*-*-*-iso8859-1" in
- if StringSet.mem fontspec !available_fonts then fontspec
- else
- let c = get_canvas() in
- try
- let tag = Canvas.create_text c (Pixels 0) (Pixels 0)
- [Text "foo"; Font fontspec] in
- Canvas.delete c [tag];
- available_fonts := StringSet.add fontspec !available_fonts;
- fontspec
- with
- _ -> raise (Invalid_argument fontspec)
-
diff --git a/otherlibs/labltk/frx/frx_font.mli b/otherlibs/labltk/frx/frx_font.mli
deleted file mode 100644
index c0b7e68067..0000000000
--- a/otherlibs/labltk/frx/frx_font.mli
+++ /dev/null
@@ -1,20 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-val find : string -> string -> string -> int -> string
- (* [find family weight slant pxlsz] returns the X11 full name of
- the font required font, if available.
- Raises Invalid_argument fullname otherwise.
- *)
diff --git a/otherlibs/labltk/frx/frx_group.ml b/otherlibs/labltk/frx/frx_group.ml
deleted file mode 100644
index 17c8a0310d..0000000000
--- a/otherlibs/labltk/frx/frx_group.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-
-let vgroup top l =
- let f = Frame.create top [] in
- Pack.forget l;
- Pack.configure l [In f];
- f
diff --git a/otherlibs/labltk/frx/frx_lbutton.ml b/otherlibs/labltk/frx/frx_lbutton.ml
deleted file mode 100644
index c4d51f7b59..0000000000
--- a/otherlibs/labltk/frx/frx_lbutton.ml
+++ /dev/null
@@ -1,50 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-
-open Widget
-
-
-let version = "$Id$"
-
-(*
- * Simulate a button with a bitmap AND a label
- *)
-
-let rec sort_options but lab com = function
- [] -> but,lab,com
- |(Command f as o)::l -> sort_options (o::but) lab com l
- |(Bitmap b as o)::l -> sort_options (o::but) lab com l
- |(Text t as o)::l -> sort_options but (o::lab) com l
- |o::l -> sort_options but lab (o::com) l
-
-let create parent options =
- let but,lab,com = sort_options [] [] [] options in
- let f = Frame.create parent com in
- let b = Button.create f (but@com)
- and l = Label.create f (lab@com) in
- pack [b;l][];
- bind l [[],ButtonPressDetail 1] (BindSet ([],(function _ -> Button.invoke b)));
- f
-
-let configure f options =
- let but,lab,com = sort_options [] [] [] options in
- match Pack.slaves f with
- [b;l] ->
- Frame.configure f com;
- Button.configure b (but@com);
- Label.configure l (lab@com)
- | _ -> raise (Invalid_argument "lbutton configure")
diff --git a/otherlibs/labltk/frx/frx_lbutton.mli b/otherlibs/labltk/frx/frx_lbutton.mli
deleted file mode 100644
index d79431f345..0000000000
--- a/otherlibs/labltk/frx/frx_lbutton.mli
+++ /dev/null
@@ -1,24 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Widget
-open Camltk
-
-
-val version : string
-
-val create : Widget -> option list -> Widget
-and configure : Widget -> option list -> unit
-
diff --git a/otherlibs/labltk/frx/frx_listbox.ml b/otherlibs/labltk/frx/frx_listbox.ml
deleted file mode 100644
index 8bb2941c0b..0000000000
--- a/otherlibs/labltk/frx/frx_listbox.ml
+++ /dev/null
@@ -1,92 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-
-let version = "$Id$"
-
-(*
- * Link a scrollbar and a listbox
- *)
-let scroll_link sb lb =
- Listbox.configure lb
- [YScrollCommand (Scrollbar.set sb)];
- Scrollbar.configure sb
- [ScrollCommand (Listbox.yview lb)]
-
-(*
- * Completion for listboxes, Macintosh style.
- * As long as you type fast enough, the listbox is repositioned to the
- * first entry "greater" than the typed prefix.
- * assumes:
- * sorted list (otherwise it's stupid)
- * fixed size, because we don't recompute size at each callback invocation
- *)
-
-let add_completion lb action =
- let prefx = ref "" (* current match prefix *)
- and maxi = Listbox.size lb - 1 (* maximum index (doesn't matter actually) *)
- and current = ref 0 (* current position *)
- and lastevent = ref 0 in
-
- let rec move_forward () =
- if Listbox.get lb (Number !current) < !prefx then
- if !current < maxi then begin incr current; move_forward() end
-
- and recenter () =
- let element = Number !current in
- (* Clean the selection *)
- Listbox.selection_clear lb (Number 0) End;
- (* Set it to our unique element *)
- Listbox.selection_set lb element element;
- (* Activate it, to keep consistent with Up/Down.
- You have to be in Extended or Browse mode *)
- Listbox.activate lb element;
- Listbox.selection_anchor lb element;
- Listbox.see lb element in
-
- let complete time s =
- if time - !lastevent < 500 then (* sorry, hard coded limit *)
- prefx := !prefx ^ s
- else begin (* reset *)
- current := 0;
- prefx := s
- end;
- lastevent := time;
- move_forward();
- recenter() in
-
-
- bind lb [[], KeyPress]
- (BindSet([Ev_Char; Ev_Time],
- (function ev ->
- (* consider only keys producing characters. The callback is called
- * even if you press Shift.
- *)
- if ev.ev_Char <> "" then complete ev.ev_Time ev.ev_Char)));
- (* Key specific bindings override KeyPress *)
- bind lb [[], KeyPressDetail "Return"] (BindSet([], action));
- (* Finally, we have to set focus, otherwise events dont get through *)
- Focus.set lb;
- recenter() (* so that first item is selected *)
-
-let new_scrollable_listbox top options =
- let f = Frame.create top [] in
- let lb = Listbox.create f options
- and sb = Scrollbar.create f [] in
- scroll_link sb lb;
- pack [lb] [Side Side_Left; Fill Fill_Both; Expand true];
- pack [sb] [Side Side_Left; Fill Fill_Y];
- f, lb
diff --git a/otherlibs/labltk/frx/frx_listbox.mli b/otherlibs/labltk/frx/frx_listbox.mli
deleted file mode 100644
index b44b6ee9d3..0000000000
--- a/otherlibs/labltk/frx/frx_listbox.mli
+++ /dev/null
@@ -1,32 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-val scroll_link : Widget.widget -> Widget.widget -> unit
- (* [scroll_link scrollbar listbox] links [scrollbar] and [listbox]
- as expected.
- *)
-
-val add_completion : Widget.widget -> (eventInfo -> unit) -> unit
- (* [add_completion listbox action] adds Macintosh like electric navigation
- in the listbox when characters are typed in.
- [action] is invoked if Return is pressed
- *)
-
-val new_scrollable_listbox :
- Widget.widget -> options list -> Widget.widget * Widget.widget
- (* [new_scrollable_listbox parent options] makes a scrollable listbox and
- returns (frame, listbox)
- *)
diff --git a/otherlibs/labltk/frx/frx_mem.ml b/otherlibs/labltk/frx/frx_mem.ml
deleted file mode 100644
index 4bab868624..0000000000
--- a/otherlibs/labltk/frx/frx_mem.ml
+++ /dev/null
@@ -1,89 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-(* Memory gauge *)
-open Camltk
-open Gc
-
-let inited = ref None
-let w = ref 300
-let delay = ref 5 (* in seconds *)
-let wordsize = (* officially approved *)
- if 1 lsl 31 = 0 then 4 else 8
-
-
-let init () =
- let top = Toplevel.create Widget.default_toplevel [Class "CamlGC"] in
- let name = Camltk.appname_get () in
- Wm.title_set top (name ^ " Memory Gauge");
- Wm.withdraw top;
- inited := Some top;
- (* this should be executed before the internal "all" binding *)
- bind top [[], Destroy] (BindSet ([], (fun _ -> inited := None)));
- let fminors = Frame.create top [] in
- let lminors = Label.create fminors [Text "Minor collections"]
- and vminors = Label.create fminors [] in
- pack [lminors][Side Side_Left];
- pack [vminors][Side Side_Right; Fill Fill_X; Expand true];
- let fmajors = Frame.create top [] in
- let lmajors = Label.create fmajors [Text "Major collections"]
- and vmajors = Label.create fmajors [] in
- pack [lmajors][Side Side_Left];
- pack [vmajors][Side Side_Right; Fill Fill_X; Expand true];
- let fcompacts = Frame.create top [] in
- let lcompacts = Label.create fcompacts [Text "Compactions"]
- and vcompacts = Label.create fcompacts [] in
- pack [lcompacts][Side Side_Left];
- pack [vcompacts][Side Side_Right; Fill Fill_X; Expand true];
- let fsize = Frame.create top [] in
- let lsize = Label.create fsize [Text "Heap size (bytes)"]
- and vsize = Label.create fsize [] in
- pack [lsize][Side Side_Left];
- pack [vsize][Side Side_Right; Fill Fill_X; Expand true];
- let fheap = Frame.create top [Width (Pixels !w); Height (Pixels 10)] in
- let flive = Frame.create fheap [Background Red]
- and ffree = Frame.create fheap [Background Green]
- and fdead = Frame.create fheap [Background Black] in
- pack [fminors; fmajors; fcompacts; fsize; fheap][Fill Fill_X];
-
- let display () =
- let st = Gc.stat() in
- Label.configure vminors [Text (string_of_int st.minor_collections)];
- Label.configure vmajors [Text (string_of_int st.major_collections)];
- Label.configure vcompacts [Text (string_of_int st.compactions)];
- Label.configure vsize [Text (string_of_int (wordsize * st.heap_words))];
- let liver = (float st.live_words) /. (float st.heap_words)
- and freer = (float st.free_words) /. (float st.heap_words) in
- Place.configure flive [X (Pixels 0); Y (Pixels 0);
- RelWidth liver; RelHeight 1.0];
- Place.configure ffree [RelX liver; Y (Pixels 0);
- RelWidth freer; RelHeight 1.0];
- Place.configure fdead [RelX (liver +. freer); Y (Pixels 0);
- RelWidth (1.0 -. freer -. liver); RelHeight 1.0]
-
- in
- let rec tim () =
- if Winfo.exists top then begin
- display();
- Timer.set (!delay * 1000) tim
- end
- in
- tim()
-
-
-let rec f () =
- match !inited with
- Some w -> Wm.deiconify w
- | None -> init (); f()
diff --git a/otherlibs/labltk/frx/frx_mem.mli b/otherlibs/labltk/frx/frx_mem.mli
deleted file mode 100644
index f3069ec28b..0000000000
--- a/otherlibs/labltk/frx/frx_mem.mli
+++ /dev/null
@@ -1,22 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-(* A Garbage Collector Gauge for Caml *)
-
-val init : unit -> unit
- (* [init ()] creates the gauge and its updater, but keeps it iconified *)
-
-val f : unit -> unit
- (* [f ()] makes the gauge visible if it has not been destroyed *)
diff --git a/otherlibs/labltk/frx/frx_misc.ml b/otherlibs/labltk/frx/frx_misc.ml
deleted file mode 100644
index d2be009224..0000000000
--- a/otherlibs/labltk/frx/frx_misc.ml
+++ /dev/null
@@ -1,69 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-(* Delayed global, a.k.a cache&carry *)
-let autodef f =
- let v = ref None in
- (function () ->
- match !v with
- None ->
- let x = f() in
- v := Some x;
- x
- | Some x -> x)
-
-open Camltk
-
-(* allows Data in options *)
-let create_photo options =
- let hasopt = ref None in
- (* Check options *)
- List.iter (function
- Data s ->
- begin match !hasopt with
- None -> hasopt := Some (Data s)
- | Some _ -> raise (Protocol.TkError "two data sources in options")
- end
- | File f ->
- begin match !hasopt with
- None -> hasopt := Some (File f)
- | Some _ -> raise (Protocol.TkError "two data sources in options")
- end
- | o -> ())
- options;
- match !hasopt with
- None -> raise (Protocol.TkError "no data source in options")
- | Some (Data s) ->
- begin
- let tmpfile = Filename.temp_file "img" "" in
- let oc = open_out_bin tmpfile in
- output_string oc s;
- close_out oc;
- let newopts =
- List.map (function
- | Data s -> File tmpfile
- | o -> o)
- options in
- try
- let i = Imagephoto.create newopts in
- (try Sys.remove tmpfile with Sys_error _ -> ());
- i
- with
- e ->
- (try Sys.remove tmpfile with Sys_error _ -> ());
- raise e
- end
- | Some (File s) -> Imagephoto.create options
- | _ -> assert false
diff --git a/otherlibs/labltk/frx/frx_misc.mli b/otherlibs/labltk/frx/frx_misc.mli
deleted file mode 100644
index 2df8ce3d20..0000000000
--- a/otherlibs/labltk/frx/frx_misc.mli
+++ /dev/null
@@ -1,21 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-val autodef : (unit -> 'a) -> (unit -> 'a)
- (* [autodef make] is a pleasant wrapper around 'a option ref *)
-
-val create_photo : Camltk.options list -> Camltk.imagePhoto
- (* [create_photo options] allows Data in options (by saving to tmp file) *)
diff --git a/otherlibs/labltk/frx/frx_req.ml b/otherlibs/labltk/frx/frx_req.ml
deleted file mode 100644
index 029f4973b6..0000000000
--- a/otherlibs/labltk/frx/frx_req.ml
+++ /dev/null
@@ -1,198 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-
-(*
- * Some standard requesters (in Amiga techspeak) or dialog boxes (in Apple
- * jargon).
-*)
-
-let version = "$Id$"
-
-(*
- * Simple requester
- * an entry field, unrestricted, with emacs-like bindings
- * Note: grabs focus, thus always unique at one given moment, and we
- * shouldn't have to worry about toplevel widget name.
- * We add a title widget in case the window manager does not decorate
- * toplevel windows.
-*)
-
-let open_simple title action notaction memory =
- let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in
- Focus.set t;
- Wm.title_set t title;
- let tit = Label.create t [Text title] in
- let len = max 40 (String.length (Textvariable.get memory)) in
- let e =
- Entry.create t [Relief Sunken; TextVariable memory; TextWidth len] in
-
- let activate _ =
- let v = Entry.get e in
- Grab.release t; (* because of wm *)
- destroy t; (* so action can call open_simple *)
- action v in
-
- bind e [[], KeyPressDetail "Return"] (BindSet ([], activate));
-
- let f = Frame.create t [] in
- let bok = Button.create f [Text "Ok"; Command activate] in
- let bcancel = Button.create f
- [Text "Cancel";
- Command (fun () -> notaction(); Grab.release t; destroy t)] in
-
- bind e [[], KeyPressDetail "Escape"]
- (BindSet ([], (fun _ -> Button.invoke bcancel)));
- pack [bok] [Side Side_Left; Expand true];
- pack [bcancel] [Side Side_Right; Expand true];
- pack [tit;e] [Fill Fill_X];
- pack [f] [Side Side_Bottom; Fill Fill_X];
- Frx_widget.resizeable t;
- Focus.set e;
- Tkwait.visibility t;
- Grab.set t
-
-(* A synchronous version *)
-let open_simple_synchronous title memory =
- let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in
- Focus.set t;
- Wm.title_set t title;
- let tit = Label.create t [Text title] in
- let len = max 40 (String.length (Textvariable.get memory)) in
- let e =
- Entry.create t [Relief Sunken; TextVariable memory; TextWidth len] in
-
- let waiting = Textvariable.create_temporary t in
-
- let activate _ =
- Grab.release t; (* because of wm *)
- destroy t; (* so action can call open_simple *)
- Textvariable.set waiting "1" in
-
- bind e [[], KeyPressDetail "Return"] (BindSet ([], activate));
-
- let f = Frame.create t [] in
- let bok = Button.create f [Text "Ok"; Command activate] in
- let bcancel =
- Button.create f
- [Text "Cancel";
- Command (fun () ->
- Grab.release t; destroy t; Textvariable.set waiting "0")] in
-
- bind e [[], KeyPressDetail "Escape"]
- (BindSet ([], (fun _ -> Button.invoke bcancel)));
- pack [bok] [Side Side_Left; Expand true];
- pack [bcancel] [Side Side_Right; Expand true];
- pack [tit;e] [Fill Fill_X];
- pack [f] [Side Side_Bottom; Fill Fill_X];
- Frx_widget.resizeable t;
- Focus.set e;
- Tkwait.visibility t;
- Grab.set t;
- Tkwait.variable waiting;
- begin match Textvariable.get waiting with
- "1" -> true
- | _ -> false
- end
-
-(*
- * Simple list requester
- * Same remarks as in open_simple.
- * focus seems to be in the listbox automatically
- *)
-let open_list title elements action notaction =
- let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in
- Wm.title_set t title;
-
- let tit = Label.create t [Text title] in
- let fls = Frame.create t [Relief Sunken; BorderWidth (Pixels 2)] in
- let lb = Listbox.create fls [SelectMode Extended] in
- let sb = Scrollbar.create fls [] in
- Frx_listbox.scroll_link sb lb;
- Listbox.insert lb End elements;
-
- (* activation: we have to break() because we destroy the requester *)
- let activate _ =
- let l = List.map (Listbox.get lb) (Listbox.curselection lb) in
- Grab.release t;
- destroy t;
- List.iter action l;
- break() in
-
-
- bind lb [[Double], ButtonPressDetail 1] (BindSetBreakable ([], activate));
-
- Frx_listbox.add_completion lb activate;
-
- let f = Frame.create t [] in
- let bok = Button.create f [Text "Ok"; Command activate] in
- let bcancel = Button.create f
- [Text "Cancel";
- Command (fun () -> notaction(); Grab.release t; destroy t)] in
-
- pack [bok; bcancel] [Side Side_Left; Fill Fill_X; Expand true];
- pack [lb] [Side Side_Left; Fill Fill_Both; Expand true];
- pack [sb] [Side Side_Right; Fill Fill_Y];
- pack [tit] [Fill Fill_X];
- pack [fls] [Fill Fill_Both; Expand true];
- pack [f] [Side Side_Bottom; Fill Fill_X];
- Frx_widget.resizeable t;
- Tkwait.visibility t;
- Grab.set t
-
-
-(* Synchronous *)
-let open_passwd title =
- let username = ref ""
- and password = ref ""
- and cancelled = ref false in
- let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in
- Focus.set t;
- Wm.title_set t title;
- let tit = Label.create t [Text title]
- and fu,eu = Frx_entry.new_label_entry t "Username" (fun s -> ())
- and fp,ep = Frx_entry.new_label_entry t "Password" (fun s -> ())
- in
- let fb = Frame.create t [] in
- let bok = Button.create fb
- [Text "Ok"; Command (fun _ ->
- username := Entry.get eu;
- password := Entry.get ep;
- Grab.release t; (* because of wm *)
- destroy t)] (* will return from tkwait *)
- and bcancel = Button.create fb
- [Text "Cancel"; Command (fun _ ->
- cancelled := true;
- Grab.release t; (* because of wm *)
- destroy t)] (* will return from tkwait *)
- in
- Entry.configure ep [Show '*'];
- bind eu [[], KeyPressDetail "Return"]
- (BindSetBreakable ([], (fun _ -> Focus.set ep; break())));
- bind ep [[], KeyPressDetail "Return"]
- (BindSetBreakable ([], (fun _ -> Button.flash bok;
- Button.invoke bok;
- break())));
-
- pack [bok] [Side Side_Left; Expand true];
- pack [bcancel] [Side Side_Right; Expand true];
- pack [tit;fu;fp;fb] [Fill Fill_X];
- Tkwait.visibility t;
- Focus.set eu;
- Grab.set t;
- Tkwait.window t;
- if !cancelled then failwith "cancelled"
- else (!username, !password)
diff --git a/otherlibs/labltk/frx/frx_req.mli b/otherlibs/labltk/frx/frx_req.mli
deleted file mode 100644
index 815b284596..0000000000
--- a/otherlibs/labltk/frx/frx_req.mli
+++ /dev/null
@@ -1,43 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-(* Various dialog boxes *)
-val open_simple :
- string ->
- (string -> unit) -> (unit -> 'a) -> Textvariable.textVariable -> unit
- (* [open_simple title action cancelled memory]
- A dialog with a message and an entry field (with memory between
- invocations). Either [action] or [cancelled] is called when the user
- answers to the dialog (with Ok or Cancel)
- *)
-
-val open_simple_synchronous : string -> Textvariable.textVariable -> bool
- (* [open_simple_synchronous title memory]
- A synchronous dialog with a message and an entry field (with
- memory between invocations). Returns true if the user clicks Ok
- or false if the user clicks Cancel.
- *)
-val open_list :
- string -> string list -> (string -> unit) -> (unit -> unit) -> unit
- (* [open_list title elements action cancelled]
- A dialog for selecting from a list of elements. [action] is called
- on each selected element, or [cancelled] is called if the user clicks
- Cancel.
- *)
-
-val open_passwd : string -> string * string
- (* [open_passwd title] pops up a username/password dialog and returns
- (username, password).
- *)
diff --git a/otherlibs/labltk/frx/frx_rpc.ml b/otherlibs/labltk/frx/frx_rpc.ml
deleted file mode 100644
index 5f29cbce5d..0000000000
--- a/otherlibs/labltk/frx/frx_rpc.ml
+++ /dev/null
@@ -1,55 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-(* Some notion of RPC *)
-open Camltk
-open Protocol
-
-(* A RPC is just a callback with a particular name, plus a Tcl procedure *)
-let register name f =
- let id = new_function_id() in
- Hashtbl.add callback_naming_table id f;
- (* For rpc_info *)
- Textvariable.set (Textvariable.coerce ("camltkrpc("^name^")"))
- (string_of_cbid id);
- tkCommand [| TkToken "proc"; TkToken name; TkToken "args";
- TkToken ("camlcb "^(string_of_cbid id)^" $args") |]
-
-(* RPC *)
-let invoke interp f args =
- tkEval [|
- TkToken "send";
- TkToken interp;
- TkToken f;
- TkTokenList (List.map (fun s -> TkToken s) args)
- |]
-
-let async_invoke interp f args =
- tkCommand [|
- TkToken "send";
- TkToken "-async";
- TkToken interp;
- TkToken f;
- TkTokenList (List.map (fun s -> TkToken s) args)
- |]
-
-let rpc_info interp =
- tkEval [|
- TkToken "send";
- TkToken interp;
- TkToken "array";
- TkToken "names";
- TkToken "camltkrpc"
- |]
diff --git a/otherlibs/labltk/frx/frx_rpc.mli b/otherlibs/labltk/frx/frx_rpc.mli
deleted file mode 100644
index 808fe87c75..0000000000
--- a/otherlibs/labltk/frx/frx_rpc.mli
+++ /dev/null
@@ -1,25 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-(* Some notion of RPC *)
-
-val register : string -> (string list -> unit) -> unit
- (* [register external_name f] *)
-val invoke : string -> string -> string list -> string
- (* [invoke interp name args] *)
-val async_invoke : string -> string -> string list -> unit
- (* [async_invoke interp name args] *)
-val rpc_info : string -> string
- (* [rpc_info interp] *)
diff --git a/otherlibs/labltk/frx/frx_selection.ml b/otherlibs/labltk/frx/frx_selection.ml
deleted file mode 100644
index 7ef64ce860..0000000000
--- a/otherlibs/labltk/frx/frx_selection.ml
+++ /dev/null
@@ -1,45 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-(* A selection handler *)
-open Widget
-open Protocol
-open Camltk
-
-let frame = ref None
-let selection = ref ""
-
-let read ofs n =
- let res =
- if ofs < 0 then ""
- else if ofs + n > String.length !selection
- then String.sub !selection ofs (String.length !selection - ofs)
- else String.sub !selection ofs n in
- tkreturn res
-
-(* As long as we don't loose the selection, we keep the widget *)
-(* Calling this function means that we own the selection *)
-(* When we loose the selection, both cb are destroyed *)
-let own () =
- match !frame with
- None ->
- let f = Frame.create_named Widget.default_toplevel "frx_selection" [] in
- let lost () = selection := ""; destroy f; frame := None in
- Selection.own_set [Selection "PRIMARY"; LostCommand lost] f;
- Selection.handle_set [Selection "PRIMARY"; ICCCMType "STRING"] f read;
- frame := Some f
- | Some f -> ()
-
-let set s = own(); selection := s
diff --git a/otherlibs/labltk/frx/frx_selection.mli b/otherlibs/labltk/frx/frx_selection.mli
deleted file mode 100644
index dfb27ee249..0000000000
--- a/otherlibs/labltk/frx/frx_selection.mli
+++ /dev/null
@@ -1,17 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-val set : string -> unit
- (* [set s] sets the X PRIMARY selection to [s] *)
diff --git a/otherlibs/labltk/frx/frx_synth.ml b/otherlibs/labltk/frx/frx_synth.ml
deleted file mode 100644
index d7acf06f7e..0000000000
--- a/otherlibs/labltk/frx/frx_synth.ml
+++ /dev/null
@@ -1,88 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-(* Some notion of synthetic events *)
-open Camltk
-open Widget
-open Protocol
-
-(* To each event is associated a table of (widget, callback) *)
-let events = Hashtbl.create 37
-
-(* Notes:
- * "cascading" events (on the same event) are not supported
- * Only one binding active at a time for each event on each widget.
- *)
-
-(* Get the callback table associated with <name>. Initializes if required *)
-let get_event name =
- try Hashtbl.find events name
- with
- Not_found ->
- let h = Hashtbl.create 37 in
- Hashtbl.add events name h;
- (* Initialize the callback invocation mechanism, based on
- variable trace
- *)
- let var = "camltk_events(" ^ name ^")" in
- let tkvar = Textvariable.coerce var in
- let rec set () =
- Textvariable.handle tkvar
- (fun () ->
- begin match Textvariable.get tkvar with
- "all" -> (* Invoke all callbacks *)
- Hashtbl.iter
- (fun p f ->
- try
- f (cTKtoCAMLwidget p)
- with _ -> ())
- h
- | p -> (* Invoke callback for p *)
- try
- let w = cTKtoCAMLwidget p
- and f = Hashtbl.find h p in
- f w
- with
- _ -> ()
- end;
- set ()(* reactivate the callback *)
- ) in
- set();
- h
-
-(* Remove binding for event <name> on widget <w> *)
-let remove w name =
- Hashtbl.remove (get_event name) (Widget.name w)
-
-(* Adds <f> as callback for widget <w> on event <name> *)
-let bind w name f =
- remove w name;
- Hashtbl.add (get_event name) (Widget.name w) f
-
-(* Sends event <name> to all widgets *)
-let broadcast name =
- Textvariable.set (Textvariable.coerce ("camltk_events(" ^ name ^")")) "all"
-
-(* Sends event <name> to widget <w> *)
-let send name w =
- Textvariable.set (Textvariable.coerce ("camltk_events(" ^ name ^")"))
- (Widget.name w)
-
-(* Remove all callbacks associated to widget <w> *)
-let remove_callbacks w =
- Hashtbl.iter (fun _ h -> Hashtbl.remove h (Widget.name w)) events
-
-let _ =
- add_destroy_hook remove_callbacks
diff --git a/otherlibs/labltk/frx/frx_synth.mli b/otherlibs/labltk/frx/frx_synth.mli
deleted file mode 100644
index 0b8d85d85e..0000000000
--- a/otherlibs/labltk/frx/frx_synth.mli
+++ /dev/null
@@ -1,31 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-(* Synthetic events *)
-open Camltk
-open Widget
-
-
-val send : string -> widget -> unit
- (* [send event_name widget] *)
-
-val broadcast : string -> unit
- (* [broadcase event_name] *)
-
-val bind : widget -> string -> (widget -> unit) -> unit
- (* [bind event_name callback] *)
-
-val remove : widget -> string -> unit
- (* [remove widget event_name] *)
diff --git a/otherlibs/labltk/frx/frx_text.ml b/otherlibs/labltk/frx/frx_text.ml
deleted file mode 100644
index 7c1f551b15..0000000000
--- a/otherlibs/labltk/frx/frx_text.ml
+++ /dev/null
@@ -1,229 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-
-let version = "$Id$"
-
-(*
- * convert an integer to an absolute index
-*)
-let abs_index n =
- TextIndex (LineChar(0,0), [CharOffset n])
-
-let insertMark =
- TextIndex(Mark "insert", [])
-
-let currentMark =
- TextIndex(Mark "current", [])
-
-let textEnd =
- TextIndex(End, [])
-
-let textBegin =
- TextIndex (LineChar(0,0), [])
-
-(*
- * Link a scrollbar and a text widget
-*)
-let scroll_link sb tx =
- Text.configure tx [YScrollCommand (Scrollbar.set sb)];
- Scrollbar.configure sb [ScrollCommand (Text.yview tx)]
-
-
-(*
- * Tk 4.0 has navigation in Text widgets, sometimes using scrolling
- * sometimes using the insertion mark. It is a pain to add more
- * compatible bindings. We do our own.
- *)
-let page_up tx = Text.yview tx (ScrollPage (-1))
-and page_down tx = Text.yview tx (ScrollPage 1)
-and line_up tx = Text.yview tx (ScrollUnit (-1))
-and line_down tx = Text.yview tx (ScrollUnit 1)
-and top tx = Text.yview_index tx textBegin
-and bottom tx = Text.yview_index tx textEnd
-
-let navigation_keys tx =
- let tags = bindtags_get tx in
- match tags with
- (WidgetBindings t)::l when t = tx ->
- bindtags tx ((WidgetBindings tx) :: (TagBindings "TEXT_RO") :: l)
- | _ -> ()
-
-let new_scrollable_text top options navigation =
- let f = Frame.create top [] in
- let tx = Text.create f options
- and sb = Scrollbar.create f [] in
- scroll_link sb tx;
- (* IN THIS ORDER -- RESIZING *)
- pack [sb] [Side Side_Right; Fill Fill_Y];
- pack [tx] [Side Side_Left; Fill Fill_Both; Expand true];
- if navigation then navigation_keys tx;
- f, tx
-
-(*
- * Searching
- *)
-let patternv = Frx_misc.autodef Textvariable.create
-and casev = Frx_misc.autodef Textvariable.create
-
-let topsearch t =
- (* The user interface *)
- let top = Toplevel.create t [Class "TextSearch"] in
- Wm.title_set top "Text search";
- let f = Frame.create_named top "fpattern" [] in
- let m = Label.create_named f "search" [Text "Search pattern"]
- and e = Entry.create_named f "pattern"
- [Relief Sunken; TextVariable (patternv()) ] in
- let hgroup = Frame.create top []
- and bgroup = Frame.create top [] in
- let fdir = Frame.create hgroup []
- and fmisc = Frame.create hgroup [] in
- let direction = Textvariable.create_temporary fdir
- and exactv = Textvariable.create_temporary fdir
- in
- let forw = Radiobutton.create_named fdir "forward"
- [Text "Forward"; Variable direction; Value "f"]
- and backw = Radiobutton.create_named fdir "backward"
- [Text "Backward"; Variable direction; Value "b"]
- and exact = Checkbutton.create_named fmisc "exact"
- [Text "Exact match"; Variable exactv]
- and case = Checkbutton.create_named fmisc "case"
- [Text "Fold Case"; Variable (casev())]
- and searchb = Button.create_named bgroup "search" [Text "Search"]
- and contb = Button.create_named bgroup "continue" [Text "Continue"]
- and dismissb = Button.create_named bgroup "dismiss"
- [Text "Dismiss";
- Command (fun () -> Text.tag_delete t ["search"]; destroy top)] in
-
- Radiobutton.invoke forw;
- pack [m][Side Side_Left];
- pack [e][Side Side_Right; Fill Fill_X; Expand true];
- pack [forw; backw] [Anchor W];
- pack [exact; case] [Anchor W];
- pack [fdir; fmisc] [Side Side_Left; Anchor Center];
- pack [searchb; contb; dismissb] [Side Side_Left; Fill Fill_X];
- pack [f;hgroup;bgroup] [Fill Fill_X; Expand true];
-
- let current_index = ref textBegin in
-
- let search cont = fun () ->
- let opts = ref [] in
- if Textvariable.get direction = "f" then
- opts := Forwards :: !opts
- else opts := Backwards :: !opts ;
- if Textvariable.get exactv = "1" then
- opts := Exact :: !opts;
- if Textvariable.get (casev()) = "1" then
- opts := Nocase :: !opts;
- try
- let forward = Textvariable.get direction = "f" in
- let i = Text.search t !opts (Entry.get e)
- (if cont then !current_index
- else if forward then textBegin
- else TextIndex(End, [CharOffset (-1)])) (* does not work with end *)
- (if forward then textEnd
- else textBegin) in
- let found = TextIndex (i, []) in
- current_index :=
- TextIndex(i, [CharOffset (if forward then 1 else (-1))]);
- Text.tag_delete t ["search"];
- Text.tag_add t "search" found (TextIndex (i, [WordEnd]));
- Text.tag_configure t "search"
- [Relief Raised; BorderWidth (Pixels 1);
- Background Red];
- Text.see t found
- with
- Invalid_argument _ -> Bell.ring() in
-
- bind e [[], KeyPressDetail "Return"]
- (BindSet ([], fun _ -> search false ()));
- Button.configure searchb [Command (search false)];
- Button.configure contb [Command (search true)];
- Tkwait.visibility top;
- Focus.set e
-
-let addsearch tx =
- let tags = bindtags_get tx in
- match tags with
- (WidgetBindings t)::l when t = tx ->
- bindtags tx ((WidgetBindings tx) :: (TagBindings "SEARCH") :: l)
- | _ -> ()
-
-(* We use Mod1 instead of Meta or Alt *)
-let init () =
- List.iter (function ev ->
- tag_bind "TEXT_RO" ev
- (BindSetBreakable ([Ev_Widget],
- (fun ei -> page_up ei.ev_Widget; break()))))
- [
- [[], KeyPressDetail "BackSpace"];
- [[], KeyPressDetail "Delete"];
- [[], KeyPressDetail "Prior"];
- [[], KeyPressDetail "b"];
- [[Mod1], KeyPressDetail "v"]
- ];
- List.iter (function ev ->
- tag_bind "TEXT_RO" ev
- (BindSetBreakable ([Ev_Widget],
- (fun ei -> page_down ei.ev_Widget; break()))))
- [
- [[], KeyPressDetail "space"];
- [[], KeyPressDetail "Next"];
- [[Control], KeyPressDetail "v"]
- ];
- List.iter (function ev ->
- tag_bind "TEXT_RO" ev
- (BindSetBreakable ([Ev_Widget],
- (fun ei -> line_up ei.ev_Widget; break()))))
- [
- [[], KeyPressDetail "Up"];
- [[Mod1], KeyPressDetail "z"]
- ];
- List.iter (function ev ->
- tag_bind "TEXT_RO" ev
- (BindSetBreakable ([Ev_Widget],
- (fun ei -> line_down ei.ev_Widget; break()))))
- [
- [[], KeyPressDetail "Down"];
- [[Control], KeyPressDetail "z"]
- ];
-
- List.iter (function ev ->
- tag_bind "TEXT_RO" ev
- (BindSetBreakable ([Ev_Widget],
- (fun ei -> top ei.ev_Widget; break()))))
- [
- [[], KeyPressDetail "Home"];
- [[Mod1], KeyPressDetail "less"]
- ];
-
- List.iter (function ev ->
- tag_bind "TEXT_RO" ev
- (BindSetBreakable ([Ev_Widget],
- (fun ei -> bottom ei.ev_Widget; break()))))
- [
- [[], KeyPressDetail "End"];
- [[Mod1], KeyPressDetail "greater"]
- ];
-
- List.iter (function ev ->
- tag_bind "SEARCH" ev
- (BindSetBreakable ([Ev_Widget],
- (fun ei -> topsearch ei.ev_Widget; break()))))
- [
- [[Control], KeyPressDetail "s"]
- ]
-
diff --git a/otherlibs/labltk/frx/frx_text.mli b/otherlibs/labltk/frx/frx_text.mli
deleted file mode 100644
index ac03844323..0000000000
--- a/otherlibs/labltk/frx/frx_text.mli
+++ /dev/null
@@ -1,46 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-
-val abs_index : int -> textIndex
- (* [abs_index offs] returns the corresponding TextIndex *)
-
-val insertMark : textIndex
-val currentMark : textIndex
-val textEnd : textIndex
-val textBegin : textIndex
- (* shortcuts for various positions in a text widget *)
-
-val scroll_link : Widget.widget -> Widget.widget -> unit
- (* [scroll_link scrollbar text] links a scrollbar and a text widget
- as expected
- *)
-
-val new_scrollable_text :
- Widget.widget -> options list -> bool -> Widget.widget * Widget.widget
- (* [new_scrollable_text parent opts nav_keys] makes a scrollable text
- widget with optional navigation keys. Returns frame and text widget.
- *)
-val addsearch : Widget.widget -> unit
- (* [addsearch textw] adds a search dialog bound on [Control-s]
- on the text widget
- *)
-
-val navigation_keys : Widget.widget -> unit
- (* [navigation_keys textw] adds common navigations functions to [textw] *)
-
-val init : unit -> unit
- (* [init ()] must be called before any of the above features is used *)
diff --git a/otherlibs/labltk/frx/frx_toplevel.mli b/otherlibs/labltk/frx/frx_toplevel.mli
deleted file mode 100644
index 3608e1e578..0000000000
--- a/otherlibs/labltk/frx/frx_toplevel.mli
+++ /dev/null
@@ -1,17 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Widget
-val make_visible : Widget -> unit
diff --git a/otherlibs/labltk/frx/frx_widget.ml b/otherlibs/labltk/frx/frx_widget.ml
deleted file mode 100644
index ab7d26112d..0000000000
--- a/otherlibs/labltk/frx/frx_widget.ml
+++ /dev/null
@@ -1,24 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-open Widget
-
-let version = "$Id$"
-(* Make a window (toplevel widget) resizeable *)
-let resizeable t =
- update_idletasks(); (* wait until layout is computed *)
- Wm.minsize_set t (Winfo.width t) (Winfo.height t)
-
diff --git a/otherlibs/labltk/frx/frx_widget.mli b/otherlibs/labltk/frx/frx_widget.mli
deleted file mode 100644
index ff26749ca2..0000000000
--- a/otherlibs/labltk/frx/frx_widget.mli
+++ /dev/null
@@ -1,18 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-open Widget
-val resizeable : widget -> unit
diff --git a/otherlibs/labltk/jpf/Makefile b/otherlibs/labltk/jpf/Makefile
deleted file mode 100644
index 1c499356d5..0000000000
--- a/otherlibs/labltk/jpf/Makefile
+++ /dev/null
@@ -1,77 +0,0 @@
-include ../support/Makefile.common
-
-COMPFLAGS=-I ../labltk -I ../support -I $(OTHERS)/unix -I $(OTHERS)/str
-
-OBJS= fileselect.cmo balloon.cmo shell.cmo jpf_font.cmo
-
-OBJSX = $(OBJS:.cmo=.cmx)
-
-all: jpflib.cma
-
-opt: jpflib.cmxa
-
-test: balloontest
-
-testopt: balloontest.opt
-
-jpflib.cma: $(OBJS)
- $(CAMLLIBR) -o jpflib.cma $(OBJS)
-
-jpflib.cmxa: $(OBJSX)
- $(CAMLOPTLIBR) -o jpflib.cmxa $(OBJSX)
-
-install: jpflib.cma
- cp $(OBJS:.cmo=.cmi) $(OBJS:.cmo=.mli) jpflib.cma $(INSTALLDIR)
-
-installopt: jpflib.cmxa
- cp jpflib.cmxa jpflib.a $(OBJS:.cmo=.cmx) $(INSTALLDIR)
-
-clean:
- rm -f *.cm* *.o *.a *~ *test
-
-$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma
-
-$(OBJSX): ../lib/$(LIBNAME).cmxa
-
-### Tests
-
-balloontest: balloontest.cmo
- $(CAMLC) -o balloontest -I ../support -I ../lib \
- -custom $(LIBNAME).cma jpflib.cma balloontest.cmo
-
-balloontest.opt: balloontest.cmx
- $(CAMLOPT) -o balloontest.opt -I ../support -I ../lib \
- $(LIBNAME).cmxa jpflib.cmxa balloontest.cmx
-
-balloontest.cmo : balloon.cmo jpflib.cma
-
-balloontest.cmx : balloon.cmx jpflib.cmxa
-
-.SUFFIXES :
-.SUFFIXES : .mli .ml .cmi .cmx .cmo
-
-.mli.cmi:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-depend:
- mv Makefile Makefile.bak
- (sed -n -e '1,/^### DO NOT DELETE THIS LINE/p' Makefile.bak; \
- $(CAMLDEP) *.mli *.ml) > Makefile
-
-
-### EVERYTHING THAT GOES BEYOND THIS COMMENT IS GENERATED
-### DO NOT DELETE THIS LINE
-balloon.cmo: balloon.cmi
-balloon.cmx: balloon.cmi
-fileselect.cmo: fileselect.cmi
-fileselect.cmx: fileselect.cmi
-jpf_font.cmo: shell.cmi jpf_font.cmi
-jpf_font.cmx: shell.cmx jpf_font.cmi
-shell.cmo: shell.cmi
-shell.cmx: shell.cmi
diff --git a/otherlibs/labltk/jpf/Makefile.nt b/otherlibs/labltk/jpf/Makefile.nt
deleted file mode 100644
index 7501a01d4b..0000000000
--- a/otherlibs/labltk/jpf/Makefile.nt
+++ /dev/null
@@ -1,75 +0,0 @@
-include ../support/Makefile.common.nt
-
-COMPFLAGS=-I ../labltk -I ../support -I $(OTHERS)/win32unix -I $(OTHERS)/str
-
-OBJS= fileselect.cmo balloon.cmo
-
-OBJSX = $(OBJS:.cmo=.cmx)
-
-all: libjpf.cma
-
-opt: libjpf.cmxa
-
-test: balloontest
-
-testopt: balloontest.opt
-
-libjpf.cma: $(OBJS)
- $(CAMLLIBR) -o libjpf.cma $(OBJS)
-
-libjpf.cmxa: $(OBJSX)
- $(CAMLOPTLIBR) -o libjpf.cmxa $(OBJSX)
-
-install: libjpf.cma
- cp $(OBJS:.cmo=.cmi) $(OBJS:.cmo=.mli) libjpf.cma $(INSTALLDIR)
-
-installopt: libjpf.cmxa
- cp libjpf.cmxa libjpf.$(A) $(INSTALLDIR)
-
-clean:
- rm -f *.cm* *.$(O) *.$(A) *~ *test
-
-$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma
-
-$(OBJSX): ../lib/$(LIBNAME).cmxa
-
-### Tests
-
-balloontest: balloontest.cmo
- $(CAMLC) -o balloontest -I ../support -I ../labltk -I ../lib \
- -custom $(LIBNAME).cma libjpf.cma balloontest.cmo $(TKLINKOPT)
-
-balloontest.opt: balloontest.cmx
- $(CAMLOPT) -o balloontest.opt -I ../support -I ../labltk -I ../lib \
- $(LIBNAME).cmxa libjpf.cmxa balloontest.cmx $(TKLINKOPT)
-
-balloontest.cmo : balloon.cmo libjpf.cma
-
-balloontest.cmx : balloon.cmx libjpf.cmxa
-
-.SUFFIXES :
-.SUFFIXES : .mli .ml .cmi .cmx .cmo
-
-.mli.cmi:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-depend:
- mv Makefile Makefile.bak
- (sed -n -e '1,/^### DO NOT DELETE THIS LINE/p' Makefile.bak; \
- $(CAMLDEP) *.mli *.ml) > Makefile
-
-
-### EVERYTHING THAT GOES BEYOND THIS COMMENT IS GENERATED
-### DO NOT DELETE THIS LINE
-balloon.cmo: balloon.cmi
-balloon.cmx: balloon.cmi
-balloontest.cmo: balloon.cmi
-balloontest.cmx: balloon.cmx
-fileselect.cmo: fileselect.cmi
-fileselect.cmx: fileselect.cmi
diff --git a/otherlibs/labltk/jpf/README b/otherlibs/labltk/jpf/README
deleted file mode 100644
index 275c2d7803..0000000000
--- a/otherlibs/labltk/jpf/README
+++ /dev/null
@@ -1,2 +0,0 @@
-This is Jun Furuse's widget set library, Jpf.
-It uses LablTk API.
diff --git a/otherlibs/labltk/jpf/balloon.ml b/otherlibs/labltk/jpf/balloon.ml
deleted file mode 100644
index 6b2f36d209..0000000000
--- a/otherlibs/labltk/jpf/balloon.ml
+++ /dev/null
@@ -1,102 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open StdLabels
-
-(* easy balloon help facility *)
-
-open Tk
-open Widget
-open Protocol
-open Support
-
-(* switch -- if you do not want balloons, set false *)
-let flag = ref true
-let debug = ref false
-
-(* We assume we have at most one popup label at a time *)
-let topw = ref default_toplevel
-and popupw = ref (Obj.magic dummy : message widget)
-
-let configure_cursor w cursor =
- (* DDDDDDDDDIIIIIIIRRRRRRRRTTTTTTTTYYYYYYY *)
- Protocol.tkCommand [| TkToken (name w);
- TkToken "configure";
- TkToken "-cursor";
- TkToken cursor |]
-
-let put ~on: w ~ms: millisec mesg =
- let t = ref None in
- let cursor = ref "" in
-
- let reset () =
- begin
- match !t with
- Some t -> Timer.remove t
- | _ -> ()
- end;
- (* if there is a popup label, unmap it *)
- if Winfo.exists !topw && Wm.state !topw <> "withdrawn" then
- begin
- Wm.withdraw !topw;
- if Winfo.exists w then configure_cursor w !cursor
- end
- and set ev =
- if !flag then
- t := Some (Timer.add ~ms: millisec ~callback: (fun () ->
- t := None;
- if !debug then
- prerr_endline ("Balloon: " ^ Widget.name w);
- update_idletasks();
- Message.configure !popupw ~text: mesg;
- raise_window !topw;
- Wm.geometry_set !topw (* 9 & 8 are some kind of magic... *)
- ("+"^(string_of_int (ev.ev_RootX + 9))^
- "+"^(string_of_int (ev.ev_RootY + 8)));
- Wm.deiconify !topw;
- cursor := cget w `Cursor;
- configure_cursor w "hand2"))
- in
-
- List.iter [[`Leave]; [`ButtonPress]; [`ButtonRelease]; [`Destroy];
- [`KeyPress]; [`KeyRelease]]
- ~f:(fun events -> bind w ~events ~extend:true ~action:(fun _ -> reset ()));
- List.iter [[`Enter]; [`Motion]] ~f:
- begin fun events ->
- bind w ~events ~extend:true ~fields:[`RootX; `RootY]
- ~action:(fun ev -> reset (); set ev)
- end
-
-let init () =
- let t = Hashtbl.create 101 in
- Protocol.add_destroy_hook (fun w ->
- Hashtbl.remove t w);
- topw := Toplevel.create default_toplevel;
- Wm.overrideredirect_set !topw true;
- Wm.withdraw !topw;
- popupw := Message.create !topw ~name: "balloon"
- ~background: (`Color "yellow") ~aspect: 300;
- pack [!popupw];
- bind_class "all" ~events: [`Enter] ~extend:true ~fields:[`Widget] ~action:
- begin fun w ->
- try Hashtbl.find t w.ev_Widget
- with Not_found ->
- Hashtbl.add t w.ev_Widget ();
- let x = Option.get w.ev_Widget ~name: "balloon" ~clas: "Balloon" in
- if x <> "" then put ~on: w.ev_Widget ~ms: 1000 x
- end
diff --git a/otherlibs/labltk/jpf/balloon.mli b/otherlibs/labltk/jpf/balloon.mli
deleted file mode 100644
index 633796ce6b..0000000000
--- a/otherlibs/labltk/jpf/balloon.mli
+++ /dev/null
@@ -1,24 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* easy balloon help facility *)
-open Widget
-
-val flag : bool ref
-val init : unit -> unit
-val put : on: 'a widget -> ms: int -> string -> unit
diff --git a/otherlibs/labltk/jpf/balloontest.ml b/otherlibs/labltk/jpf/balloontest.ml
deleted file mode 100644
index 36e6c8dbf1..0000000000
--- a/otherlibs/labltk/jpf/balloontest.ml
+++ /dev/null
@@ -1,32 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Tk
-open Widget
-open Balloon
-open Protocol
-
-let _ =
- let t = openTk () in
- Balloon.init ();
- let b = Button.create t ~text: "hello" in
- Button.configure b ~command: (fun () -> destroy b);
- pack [b];
- Balloon.put ~on: b ~ms: 1000 "Balloon";
- Printexc.catch mainLoop ()
-
diff --git a/otherlibs/labltk/jpf/fileselect.ml b/otherlibs/labltk/jpf/fileselect.ml
deleted file mode 100644
index ec0e7749f1..0000000000
--- a/otherlibs/labltk/jpf/fileselect.ml
+++ /dev/null
@@ -1,368 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* file selection box *)
-
-(* This file selecter works only under the OS with the full unix support.
- For the portability, Tk.getOpenFile and Tk.getSaveFile are recommended. *)
-
-open StdLabels
-open UnixLabels
-open Str
-open Filename
-
-open Tk
-open Widget
-
-exception Not_selected
-
-(********************************************************** Search directory *)
-(* Default is curdir *)
-let global_dir = ref (getcwd ())
-
-(***************************************************** Some widgets creation *)
-
-(* from frx_listbox.ml *)
-let scroll_link sb lb =
- Listbox.configure lb ~yscrollcommand: (Scrollbar.set sb);
- Scrollbar.configure sb ~command: (Listbox.yview lb)
-
-(* focus when enter binding *)
-let bind_enter_focus w =
- bind w ~events:[`Enter] ~action:(fun _ -> Focus.set w);;
-
-let myentry_create p ~variable =
- let w = Entry.create p ~relief: `Sunken ~textvariable: variable in
- bind_enter_focus w; w
-
-(************************************************************* Subshell call *)
-
-let subshell cmd =
- let r,w = pipe () in
- match fork () with
- 0 -> close r; dup2 ~src:w ~dst:stdout;
- execv ~prog:"/bin/sh" ~args:[| "/bin/sh"; "-c"; cmd |];
- exit 127
- | id ->
- close w;
- let rc = in_channel_of_descr r in
- let rec it l =
- match
- try Some(input_line rc) with _ -> None
- with
- Some x -> it (x::l)
- | None -> List.rev l
- in
- let answer = it [] in
- close_in rc; (* because of finalize_channel *)
- let p, st = waitpid ~mode:[] id in answer
-
-(***************************************************************** Path name *)
-
-(* find directory name which doesn't contain "?*[" *)
-let dirget = regexp "^\\([^\\*?[]*/\\)\\(.*\\)"
-
-let parse_filter src =
- (* replace // by / *)
- let s = global_replace (regexp "/+") "/" src in
- (* replace /./ by / *)
- let s = global_replace (regexp "/\\./") "/" s in
- (* replace ????/../ by "" *)
- let s = global_replace
- (regexp "\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\./")
- ""
- s in
- (* replace ????/..$ by "" *)
- let s = global_replace
- (regexp "\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\.$")
- ""
- s in
- (* replace ^/../../ by / *)
- let s = global_replace (regexp "^\\(/\\.\\.\\)+/") "/" s in
- if string_match dirget s 0 then
- let dirs = matched_group 1 s
- and ptrn = matched_group 2 s
- in
- dirs, ptrn
- else "", s
-
-let ls dir pattern =
- subshell ("cd " ^ dir ^ ";/bin/ls -ad " ^ pattern ^" 2>/dev/null")
-
-(*************************************************************** File System *)
-
-let get_files_in_directory dir =
- let dirh = opendir dir in
- let rec get_them l =
- match
- try Some(Unix.readdir dirh) with _ -> None
- with
- | None ->
- Unix.closedir dirh; l
- | Some x ->
- get_them (x::l)
- in
- List.sort ~cmp:compare (get_them [])
-
-let rec get_directories_in_files path =
- List.filter
- ~f:(fun x -> try (stat (path ^ x)).st_kind = S_DIR with _ -> false)
-
-let remove_directories path =
- List.filter
- ~f:(fun x -> try (stat (path ^ x)).st_kind <> S_DIR with _ -> false)
-
-(************************* a nice interface to listbox - from frx_listbox.ml *)
-
-let add_completion lb action =
- let prefx = ref "" (* current match prefix *)
- and maxi = ref 0 (* maximum index (doesn'y matter actually) *)
- and current = ref 0 (* current position *)
- and lastevent = ref 0 in
-
- let rec move_forward () =
- if Listbox.get lb ~index:(`Num !current) < !prefx then
- if !current < !maxi then begin incr current; move_forward() end
-
- and recenter () =
- let element = `Num !current in
- (* Clean the selection *)
- Listbox.selection_clear lb ~first:(`Num 0) ~last:`End;
- (* Set it to our unique element *)
- Listbox.selection_set lb ~first:element ~last:element;
- (* Activate it, to keep consistent with Up/Down.
- You have to be in Extended or Browse mode *)
- Listbox.activate lb ~index:element;
- Listbox.selection_anchor lb ~index:element;
- Listbox.see lb ~index:element in
-
- let complete time s =
- if time - !lastevent < 500 then (* sorry, hard coded limit *)
- prefx := !prefx ^ s
- else begin (* reset *)
- current := 0;
- prefx := s
- end;
- lastevent := time;
- move_forward();
- recenter() in
-
-
- bind lb ~events:[`KeyPress] ~fields:[`Char; `Time]
- (* consider only keys producing characters. The callback is called
- if you press Shift. *)
- ~action:(fun ev -> if ev.ev_Char <> "" then complete ev.ev_Time ev.ev_Char);
- (* Key specific bindings override KeyPress *)
- bind lb ~events:[`KeyPressDetail "Return"] ~action;
- (* Finally, we have to set focus, otherwise events dont get through *)
- Focus.set lb;
- recenter() (* so that first item is selected *);
- (* returns init_completion function *)
- (fun lb ->
- prefx := "";
- maxi := Listbox.size lb - 1;
- current := 0)
-
-(****************************************************************** Creation *)
-
-let f ~title ~action:proc ~filter:deffilter ~file:deffile ~multi ~sync =
- (* Ah ! Now I regret about the names of the widgets... *)
-
- let current_pattern = ref ""
- and current_dir = ref "" in
-
- (* init_completions *)
- let filter_init_completion = ref (fun _ -> ())
- and directory_init_completion = ref (fun _ -> ()) in
-
- let tl = Toplevel.create default_toplevel in
- Focus.set tl;
- Wm.title_set tl title;
-
- let filter_var = Textvariable.create ~on:tl () (* new_temporary *)
- and selection_var = Textvariable.create ~on:tl ()
- and sync_var = Textvariable.create ~on:tl () in
-
- let frm' = Frame.create tl ~borderwidth: 1 ~relief: `Raised in
- let frm = Frame.create frm' ~borderwidth: 8 in
- let fl = Label.create frm ~text: "Filter" in
- let df = Frame.create frm in
- let dfl = Frame.create df in
- let dfll = Label.create dfl ~text: "Directories" in
- let dflf = Frame.create dfl in
- let directory_listbox = Listbox.create dflf ~relief: `Sunken
- and directory_scrollbar = Scrollbar.create dflf in
- scroll_link directory_scrollbar directory_listbox;
- let dfr = Frame.create df in
- let dfrl = Label.create dfr ~text: "Files" in
- let dfrf = Frame.create dfr in
- let filter_listbox = Listbox.create dfrf ~relief: `Sunken in
- let filter_scrollbar = Scrollbar.create dfrf in
- scroll_link filter_scrollbar filter_listbox;
- let sl = Label.create frm ~text: "Selection" in
- let filter_entry = myentry_create frm ~variable: filter_var in
- let selection_entry = myentry_create frm ~variable: selection_var
- in
- let cfrm' = Frame.create tl ~borderwidth: 1 ~relief: `Raised in
- let cfrm = Frame.create cfrm' ~borderwidth: 8 in
- let dumf = Frame.create cfrm in
- let dumf2 = Frame.create cfrm in
-
- let configure filter =
- (* OLDER let curdir = getcwd () in *)
-(* Printf.eprintf "CURDIR %s\n" curdir; *)
- let filter =
- if string_match (regexp "^/.*") filter 0 then filter
- else
- if filter = "" then !global_dir ^ "/*"
- else !global_dir ^ "/" ^ filter in
-(* Printf.eprintf "FILTER %s\n" filter; *)
- let dirname, patternname = parse_filter filter in
-(* Printf.eprintf "DIRNAME %s PATTERNNAME %s\n" dirname patternname; *)
- current_dir := dirname;
- global_dir := dirname;
- let patternname = if patternname = "" then "*" else patternname in
- current_pattern := patternname;
- let filter = dirname ^ patternname in
-(* Printf.eprintf "FILTER : %s\n\n" filter; *)
-(* flush Pervasives.stderr; *)
- try
- let directories = get_directories_in_files dirname
- (get_files_in_directory dirname) in
- (* get matched file by subshell call. *)
- let matched_files = remove_directories dirname (ls dirname patternname)
- in
- Textvariable.set filter_var filter;
- Textvariable.set selection_var (dirname ^ deffile);
- Listbox.delete directory_listbox ~first:(`Num 0) ~last:`End;
- Listbox.insert directory_listbox ~index:`End ~texts:directories;
- Listbox.delete filter_listbox ~first:(`Num 0) ~last:`End;
- Listbox.insert filter_listbox ~index:`End ~texts:matched_files;
- !directory_init_completion directory_listbox;
- !filter_init_completion filter_listbox
- with
- Unix_error (ENOENT,_,_) ->
- (* Directory is not found (maybe) *)
- Bell.ring ()
- in
-
- let selected_files = ref [] in (* used for synchronous mode *)
- let activate l () =
- Grab.release tl;
- destroy tl;
- if sync then
- begin
- selected_files := l;
- Textvariable.set sync_var "1"
- end
- else
- begin
- proc l;
- break ()
- end
- in
-
- (* and buttons *)
- let okb = Button.create cfrm ~text: "OK" ~command:
- begin fun () ->
- let files =
- List.map (Listbox.curselection filter_listbox)
- ~f:(fun x -> !current_dir ^ (Listbox.get filter_listbox ~index:x))
- in
- let files = if files = [] then [Textvariable.get selection_var]
- else files in
- activate files ()
- end
- in
- let flb = Button.create cfrm ~text: "Filter"
- ~command: (fun () -> configure (Textvariable.get filter_var)) in
- let ccb = Button.create cfrm ~text: "Cancel"
- ~command: (fun () -> activate [] ()) in
-
- (* binding *)
- bind selection_entry ~events:[`KeyPressDetail "Return"] ~breakable:true
- ~action:(fun _ -> activate [Textvariable.get selection_var] ());
- bind filter_entry ~events:[`KeyPressDetail "Return"]
- ~action:(fun _ -> configure (Textvariable.get filter_var));
-
- let action _ =
- let files =
- List.map (Listbox.curselection filter_listbox)
- ~f:(fun x -> !current_dir ^ (Listbox.get filter_listbox ~index:x))
- in
- activate files ()
- in
- bind filter_listbox ~events:[`Modified([`Double], `ButtonPressDetail 1)]
- ~breakable:true ~action;
- if multi then Listbox.configure filter_listbox ~selectmode: `Multiple;
- filter_init_completion := add_completion filter_listbox action;
-
- let action _ =
- try
- configure (!current_dir ^ ((function
- [x] -> Listbox.get directory_listbox ~index:x
- | _ -> (* you must choose at least one directory. *)
- Bell.ring (); raise Not_selected)
- (Listbox.curselection directory_listbox)) ^ "/" ^ !current_pattern)
- with _ -> () in
- bind directory_listbox ~events:[`Modified([`Double], `ButtonPressDetail 1)]
- ~breakable:true ~action;
- Listbox.configure directory_listbox ~selectmode: `Browse;
- directory_init_completion := add_completion directory_listbox action;
-
- pack [frm'; frm] ~fill: `X;
- (* filter *)
- pack [fl] ~side: `Top ~anchor: `W;
- pack [filter_entry] ~side: `Top ~fill: `X;
- (* directory + files *)
- pack [df] ~side: `Top ~fill: `X ~ipadx: 8;
- (* directory *)
- pack [dfl] ~side: `Left;
- pack [dfll] ~side: `Top ~anchor: `W;
- pack [dflf] ~side: `Top;
- pack [coe directory_listbox; coe directory_scrollbar]
- ~side: `Left ~fill: `Y;
- (* files *)
- pack [dfr] ~side: `Right;
- pack [dfrl] ~side: `Top ~anchor: `W;
- pack [dfrf] ~side: `Top;
- pack [coe filter_listbox; coe filter_scrollbar] ~side: `Left ~fill: `Y;
- (* selection *)
- pack [sl] ~side: `Top ~anchor: `W;
- pack [selection_entry] ~side: `Top ~fill: `X;
-
- (* create OK, Filter and Cancel buttons *)
- pack [cfrm'] ~fill: `X;
- pack [cfrm] ~fill: `X;
- pack [okb] ~side: `Left;
- pack [dumf] ~side: `Left ~expand: true;
- pack [flb] ~side: `Left;
- pack [dumf2] ~side: `Left ~expand: true;
- pack [ccb] ~side: `Left;
-
- configure deffilter;
-
- Tkwait.visibility tl;
- Grab.set tl;
-
- if sync then
- begin
- Tkwait.variable sync_var;
- proc !selected_files
- end;
- ()
diff --git a/otherlibs/labltk/jpf/fileselect.mli b/otherlibs/labltk/jpf/fileselect.mli
deleted file mode 100644
index 79dc828f94..0000000000
--- a/otherlibs/labltk/jpf/fileselect.mli
+++ /dev/null
@@ -1,37 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* This file selecter works only under the OS with the full unix support.
- For the portability, Tk.getOpenFile and Tk.getSaveFile are recommended. *)
-
-open Support
-
-val f :
- title:string ->
- action:(string list -> unit) ->
- filter:string -> file:string -> multi:bool -> sync:bool -> unit
-
-(* action
- [] means canceled
- if multi select is false, then the list is null or a singleton *)
-
-(* multi select
- if true then more than one file are selectable *)
-
-(* sync it
- if true then in synchronous mode *)
diff --git a/otherlibs/labltk/jpf/jpf_font.ml b/otherlibs/labltk/jpf/jpf_font.ml
deleted file mode 100644
index c9c3d05267..0000000000
--- a/otherlibs/labltk/jpf/jpf_font.ml
+++ /dev/null
@@ -1,218 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-(* find font information *)
-
-let debug = ref false
-let log s =
- if !debug then try prerr_endline s with _ -> ()
-
-type ('s, 'i) xlfd = {
- (* some of them are currently not interesting for me *)
- mutable foundry: 's;
- mutable family: 's;
- mutable weight: 's;
- mutable slant: 's;
- mutable setWidth: 's;
- mutable addStyle: 's;
- mutable pixelSize: 'i;
- mutable pointSize: 'i;
- mutable resolutionX: 'i;
- mutable resolutionY: 'i;
- mutable spacing: 's;
- mutable averageWidth: 'i;
- mutable registry: 's;
- mutable encoding: 's
- }
-
-let copy xlfd = {xlfd with foundry= xlfd.foundry}
-
-let string_of_xlfd s i xlfd =
- let foundry= s xlfd.foundry
- and family= s xlfd.family
- and weight= s xlfd.weight
- and slant= s xlfd.slant
- and setWidth = s xlfd.setWidth
- and addStyle = s xlfd.addStyle
- and pixelSize= i xlfd.pixelSize
- and pointSize = i xlfd.pointSize
- and resolutionX = i xlfd.resolutionX
- and resolutionY = i xlfd.resolutionY
- and spacing= s xlfd.spacing
- and averageWidth = i xlfd.averageWidth
- and registry= s xlfd.registry
- and encoding = s xlfd.encoding in
-
- "-"^foundry^
- "-"^family^
- "-"^weight^
- "-"^slant^
- "-"^setWidth ^
- "-"^addStyle ^
- "-"^pixelSize^
- "-"^pointSize ^
- "-"^resolutionX ^
- "-"^resolutionY ^
- "-"^spacing^
- "-"^averageWidth ^
- "-"^registry^
- "-"^encoding
-
-exception Parse_Xlfd_Failure of string
-
-let parse_xlfd xlfd_string =
- (* this must not be a pattern *)
- let split_str char_sep str =
- let len = String.length str in
- let rec split beg cur =
- if cur >= len then [String.sub str beg (len - beg)]
- else if char_sep (String.get str cur)
- then
- let nextw = succ cur in
- (String.sub str beg (cur - beg))
- ::(split nextw nextw)
- else split beg (succ cur) in
- split 0 0
- in
- match split_str (function '-' -> true | _ -> false) xlfd_string with
- | [ _; foundry; family; weight; slant; setWidth; addStyle; pixelSize;
- pointSize; resolutionX; resolutionY; spacing; averageWidth;
- registry; encoding ] ->
- { foundry= foundry;
- family= family;
- weight= weight;
- slant= slant;
- setWidth= setWidth;
- addStyle= addStyle;
- pixelSize= int_of_string pixelSize;
- pointSize= int_of_string pointSize;
- resolutionX= int_of_string resolutionX;
- resolutionY= int_of_string resolutionY;
- spacing= spacing;
- averageWidth= int_of_string averageWidth;
- registry= registry;
- encoding= encoding;
- }
- | _ -> raise (Parse_Xlfd_Failure xlfd_string)
-
-type valid_xlfd = (string, int) xlfd
-
-let string_of_valid_xlfd = string_of_xlfd (fun x -> x) string_of_int
-
-type pattern = (string option, int option) xlfd
-
-let empty_pattern =
- { foundry= None;
- family= None;
- weight= None;
- slant= None;
- setWidth= None;
- addStyle= None;
- pixelSize= None;
- pointSize= None;
- resolutionX= None;
- resolutionY= None;
- spacing= None;
- averageWidth= None;
- registry= None;
- encoding= None;
- }
-
-let string_of_pattern =
- let pat f = function
- Some x -> f x
- | None -> "*"
- in
- let pat_string = pat (fun x -> x) in
- let pat_int = pat string_of_int in
- string_of_xlfd pat_string pat_int
-
-let is_vector_font xlfd =
- (xlfd.pixelSize = 0 && xlfd.resolutionX = 0 && xlfd.resolutionY = 0) ||
- xlfd.spacing <> "c"
-
-let list_fonts dispname pattern =
- let dispopt = match dispname with
- None -> ""
- | Some x -> "-display " ^ x
- in
- let result = List.map parse_xlfd
- (Shell.subshell ("xlsfonts "^dispopt^" -fn "^string_of_pattern pattern))
- in
- if result = [] then raise Not_found
- else result
-
-let available_pixel_size_aux dispname pattern =
- (* return available pixel size without font resizing *)
- (* to obtain good result, *)
- (* the pattern should contain as many information as possible *)
- let pattern = copy pattern in
- pattern.pixelSize <- None;
- let xlfds = list_fonts dispname pattern in
- let pxszs = Hashtbl.create 107 in
- List.iter (fun xlfd ->
- Hashtbl.add pxszs xlfd.pixelSize xlfd) xlfds;
- pxszs
-
-let extract_size_font_hash tbl =
- let keys = ref [] in
- Hashtbl.iter (fun k _ ->
- if not (List.mem k !keys) then keys := k :: !keys) tbl;
- Sort.list (fun (k1,_) (k2,_) -> k1 < k2)
- (List.map (fun k -> k, Hashtbl.find_all tbl k) !keys)
-
-let available_pixel_size dispname pattern =
- let pxszs = available_pixel_size_aux dispname pattern in
- extract_size_font_hash pxszs
-
-let nearest_pixel_size dispname vector_ok pattern =
- (* find the font with the nearest pixel size *)
- log ("\n*** "^string_of_pattern pattern);
- let pxlsz =
- match pattern.pixelSize with
- None -> raise (Failure "invalid pixelSize pattern")
- | Some x -> x
- in
- let tbl = available_pixel_size_aux dispname pattern in
- let newtbl = Hashtbl.create 107 in
- Hashtbl.iter (fun s xlfd ->
- if vector_ok then
- if s = 0 then begin
- if is_vector_font xlfd then begin
- log (Printf.sprintf "%s is vector" (string_of_valid_xlfd xlfd));
- xlfd.pixelSize <- pxlsz;
- Hashtbl.add newtbl pxlsz xlfd
- end
- end else Hashtbl.add newtbl s xlfd
- else if not (is_vector_font xlfd) && s <> 0 then
- Hashtbl.add newtbl s xlfd) tbl;
-
- let size_font_table = extract_size_font_hash newtbl in
-
- let diff = ref 10000 in
- let min = ref None in
- List.iter (fun (s,xlfds) ->
- let d = abs(s - pxlsz) in
- if d < !diff then begin
- min := Some (s,xlfds);
- diff := d
- end) size_font_table;
- (* if it contains more than one font, just return the first *)
- match !min with
- | None -> raise Not_found
- | Some(s, xlfds) ->
- log (Printf.sprintf "Size %d is selected" s);
- List.iter (fun xlfd -> log (string_of_valid_xlfd xlfd)) xlfds;
- List.hd xlfds
diff --git a/otherlibs/labltk/jpf/jpf_font.mli b/otherlibs/labltk/jpf/jpf_font.mli
deleted file mode 100644
index cd1e212297..0000000000
--- a/otherlibs/labltk/jpf/jpf_font.mli
+++ /dev/null
@@ -1,54 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-val debug : bool ref
-
-type ('a, 'b) xlfd =
- { mutable foundry: 'a;
- mutable family: 'a;
- mutable weight: 'a;
- mutable slant: 'a;
- mutable setWidth: 'a;
- mutable addStyle: 'a;
- mutable pixelSize: 'b;
- mutable pointSize: 'b;
- mutable resolutionX: 'b;
- mutable resolutionY: 'b;
- mutable spacing: 'a;
- mutable averageWidth: 'b;
- mutable registry: 'a;
- mutable encoding: 'a }
-
-exception Parse_Xlfd_Failure of string
-
-type valid_xlfd = (string, int) xlfd
-type pattern = (string option, int option) xlfd
-
-val empty_pattern : pattern
-
-val copy : ('a, 'b) xlfd -> ('a, 'b) xlfd
-
-val string_of_valid_xlfd : valid_xlfd -> string
-val string_of_pattern : pattern -> string
-
-val is_vector_font : valid_xlfd -> bool
-
-val list_fonts : string option -> pattern -> valid_xlfd list
-
-val available_pixel_size :
- string option -> pattern -> (int * valid_xlfd list) list
-
-val nearest_pixel_size :
- string option -> bool -> pattern -> valid_xlfd
diff --git a/otherlibs/labltk/jpf/shell.ml b/otherlibs/labltk/jpf/shell.ml
deleted file mode 100644
index 485a0d8741..0000000000
--- a/otherlibs/labltk/jpf/shell.ml
+++ /dev/null
@@ -1,36 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Unix
-
-(************************************************************* Subshell call *)
-
-let subshell cmd =
- let r,w = pipe () in
- match fork () with
- 0 -> close r; dup2 w stdout;
- close stderr;
- execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]; exit 127
- | id ->
- close w;
- let rc = in_channel_of_descr r in
- let rec it () = try
- let x = input_line rc in x:: it ()
- with _ -> []
- in
- let answer = it() in
- close_in rc; (* because of finalize_channel *)
- let p, st = waitpid [] id in answer
-
diff --git a/otherlibs/labltk/jpf/shell.mli b/otherlibs/labltk/jpf/shell.mli
deleted file mode 100644
index be93f5f1a9..0000000000
--- a/otherlibs/labltk/jpf/shell.mli
+++ /dev/null
@@ -1,17 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-val subshell : string -> string list
-
diff --git a/otherlibs/labltk/labl.gif b/otherlibs/labltk/labl.gif
deleted file mode 100644
index d0a29fab1d..0000000000
--- a/otherlibs/labltk/labl.gif
+++ /dev/null
Binary files differ
diff --git a/otherlibs/labltk/labltk/.cvsignore b/otherlibs/labltk/labltk/.cvsignore
deleted file mode 100644
index 585067641e..0000000000
--- a/otherlibs/labltk/labltk/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-*.ml *.mli labltktop labltk
-modules
-.depend
diff --git a/otherlibs/labltk/labltk/Makefile b/otherlibs/labltk/labltk/Makefile
deleted file mode 100644
index 53276dd164..0000000000
--- a/otherlibs/labltk/labltk/Makefile
+++ /dev/null
@@ -1,43 +0,0 @@
-include ../support/Makefile.common
-
-COMPFLAGS= -I ../support
-
-all: labltkobjs
-
-opt: labltkobjsx
-
-include ./modules
-
-LABLTKOBJS = $(WIDGETOBJS) tk.cmo labltk.cmo
-LABLTKOBJSX = $(LABLTKOBJS:.cmo=.cmx)
-
-labltkobjs: $(LABLTKOBJS)
-
-labltkobjsx: $(LABLTKOBJSX)
-
-install: $(LABLTKOBJS)
- if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi
- cp $(LABLTKOBJS:.cmo=.cmi) $(WIDGETOBJS:.cmo=.mli) $(INSTALLDIR)
- chmod 644 $(INSTALLDIR)/*.cmi
-
-installopt: $(LABLTKOBJSX)
- @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi
- cp $(LABLTKOBJSX) $(INSTALLDIR)
- chmod 644 $(INSTALLDIR)/*.cmx
-
-clean:
- $(MAKE) -f Makefile.gen clean
-
-.SUFFIXES :
-.SUFFIXES : .mli .ml .cmi .cmx .cmo .mlp
-
-.mli.cmi:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-include .depend
diff --git a/otherlibs/labltk/labltk/Makefile.gen b/otherlibs/labltk/labltk/Makefile.gen
deleted file mode 100644
index a7f85082ed..0000000000
--- a/otherlibs/labltk/labltk/Makefile.gen
+++ /dev/null
@@ -1,45 +0,0 @@
-include ../support/Makefile.common
-
-all: tk.ml labltk.ml .depend
-
-_tkgen.ml: ../Widgets.src ../compiler/tkcompiler
- cd ..; ../../boot/ocamlrun compiler/tkcompiler -outdir labltk
-
-# dependencies are broken: wouldn't work with gmake 3.77
-
-tk.ml labltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp #../builtin/builtin_*.ml
- (echo 'open StdLabels'; \
- echo 'open Widget'; \
- echo 'open Protocol'; \
- echo 'open Support'; \
- echo 'open Textvariable'; \
- cat ../builtin/report.ml; \
- cat ../builtin/builtin_*.ml; \
- cat _tkgen.ml; \
- echo ; \
- echo ; \
- echo 'module Tkintf = struct'; \
- cat ../builtin/builtini_*.ml; \
- cat _tkigen.ml; \
- echo 'end (* module Tkintf *)'; \
- echo ; \
- echo ; \
- echo 'open Tkintf' ;\
- echo ; \
- echo ; \
- cat ../builtin/builtinf_*.ml; \
- cat _tkfgen.ml; \
- echo ; \
- ) > _tk.ml
- ../../../boot/ocamlrun ../compiler/pp < _tk.ml > tk.ml
- rm -f _tk.ml
- $(CAMLDEP) -I ../support [a-z]*.mli [a-z]*.ml > .depend
-
-../compiler/pp:
- cd ../compiler; $(MAKE) pp
-
-# All .{ml,mli} files are generated in this directory
-clean:
- rm -f *.cm* *.ml *.mli *.o *.a .depend
-
-# rm -f modules
diff --git a/otherlibs/labltk/labltk/Makefile.gen.nt b/otherlibs/labltk/labltk/Makefile.gen.nt
deleted file mode 100644
index 8bac832b9e..0000000000
--- a/otherlibs/labltk/labltk/Makefile.gen.nt
+++ /dev/null
@@ -1,40 +0,0 @@
-include ../support/Makefile.common.nt
-
-all: tk.ml labltk.ml .depend
-
-_tkgen.ml: ../Widgets.src ../compiler/tkcompiler.exe
- cd .. ; ../../boot/ocamlrun compiler/tkcompiler.exe -outdir labltk
-
-# dependencies are broken: wouldn't work with gmake 3.77
-
-tk.ml labltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp.exe #../builtin/builtin_*.ml
- (echo 'open StdLabels'; \
- echo 'open Widget'; \
- echo 'open Protocol'; \
- echo 'open Support'; \
- echo 'open Textvariable'; \
- cat ../builtin/report.ml; \
- cat ../builtin/builtin_*.ml; \
- cat _tkgen.ml; \
- echo ; \
- echo ; \
- echo 'module Tkintf = struct'; \
- cat ../builtin/builtini_*.ml; \
- cat _tkigen.ml; \
- echo 'end (* module Tkintf *)'; \
- echo ; \
- echo ; \
- echo 'open Tkintf' ;\
- echo ; \
- echo ; \
- cat ../builtin/builtinf_*.ml; \
- cat _tkfgen.ml; \
- echo ; \
- ) > _tk.ml
- ../../../boot/ocamlrun ../compiler/pp < _tk.ml > tk.ml
- rm -f _tk.ml
- $(CAMLDEP) -slash -I ../support [a-z]*.mli [a-z]*.ml > .depend
-
-clean:
- rm -f *.cm* *.ml *.mli *.$(O) *.$(A)
-# rm -f modules .depend
diff --git a/otherlibs/labltk/labltk/Makefile.nt b/otherlibs/labltk/labltk/Makefile.nt
deleted file mode 100644
index a8f4f694d9..0000000000
--- a/otherlibs/labltk/labltk/Makefile.nt
+++ /dev/null
@@ -1,43 +0,0 @@
-include ../support/Makefile.common.nt
-
-COMPFLAGS= -I ../support
-
-all: labltkobjs
-
-opt: labltkobjsx
-
-# All .{ml,mli} files are generated in this directory
-clean :
- rm -f *.cm* *.ml *.mli *.$(A) *.$(O)
- $(MAKE) -f Makefile.gen.nt clean
-
-include ./modules
-
-LABLTKOBJS = $(WIDGETOBJS) tk.cmo labltk.cmo
-LABLTKOBJSX = $(LABLTKOBJS:.cmo=.cmx)
-
-labltkobjs: $(LABLTKOBJS)
-
-labltkobjsx: $(LABLTKOBJSX)
-
-install: $(LABLTKOBJS)
- mkdir -p $(INSTALLDIR)
- cp *.cmi [a-z]*.mli $(INSTALLDIR)
-
-installopt: $(LABLTKOBJSX)
- mkdir -p $(INSTALLDIR)
- cp $(LABLTKOBJSX) $(INSTALLDIR)
-
-.SUFFIXES :
-.SUFFIXES : .mli .ml .cmi .cmx .cmo
-
-.mli.cmi:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-include .depend
diff --git a/otherlibs/labltk/labltk/modules b/otherlibs/labltk/labltk/modules
deleted file mode 100644
index a17b6ab1eb..0000000000
--- a/otherlibs/labltk/labltk/modules
+++ /dev/null
@@ -1,77 +0,0 @@
-WIDGETOBJS=place.cmo wm.cmo imagephoto.cmo canvas.cmo button.cmo text.cmo label.cmo scrollbar.cmo image.cmo encoding.cmo pixmap.cmo palette.cmo font.cmo message.cmo menu.cmo entry.cmo listbox.cmo focus.cmo menubutton.cmo pack.cmo option.cmo toplevel.cmo frame.cmo dialog.cmo imagebitmap.cmo clipboard.cmo radiobutton.cmo tkwait.cmo grab.cmo selection.cmo scale.cmo optionmenu.cmo winfo.cmo grid.cmo checkbutton.cmo bell.cmo tkvars.cmo
-place.ml wm.ml imagephoto.ml canvas.ml button.ml text.ml label.ml scrollbar.ml image.ml encoding.ml pixmap.ml palette.ml font.ml message.ml menu.ml entry.ml listbox.ml focus.ml menubutton.ml pack.ml option.ml toplevel.ml frame.ml dialog.ml imagebitmap.ml clipboard.ml radiobutton.ml tkwait.ml grab.ml selection.ml scale.ml optionmenu.ml winfo.ml grid.ml checkbutton.ml bell.ml tkvars.ml : _tkgen.ml
-
-place.cmo : place.ml
-place.cmi : place.mli
-wm.cmo : wm.ml
-wm.cmi : wm.mli
-imagephoto.cmo : imagephoto.ml
-imagephoto.cmi : imagephoto.mli
-canvas.cmo : canvas.ml
-canvas.cmi : canvas.mli
-button.cmo : button.ml
-button.cmi : button.mli
-text.cmo : text.ml
-text.cmi : text.mli
-label.cmo : label.ml
-label.cmi : label.mli
-scrollbar.cmo : scrollbar.ml
-scrollbar.cmi : scrollbar.mli
-image.cmo : image.ml
-image.cmi : image.mli
-encoding.cmo : encoding.ml
-encoding.cmi : encoding.mli
-pixmap.cmo : pixmap.ml
-pixmap.cmi : pixmap.mli
-palette.cmo : palette.ml
-palette.cmi : palette.mli
-font.cmo : font.ml
-font.cmi : font.mli
-message.cmo : message.ml
-message.cmi : message.mli
-menu.cmo : menu.ml
-menu.cmi : menu.mli
-entry.cmo : entry.ml
-entry.cmi : entry.mli
-listbox.cmo : listbox.ml
-listbox.cmi : listbox.mli
-focus.cmo : focus.ml
-focus.cmi : focus.mli
-menubutton.cmo : menubutton.ml
-menubutton.cmi : menubutton.mli
-pack.cmo : pack.ml
-pack.cmi : pack.mli
-option.cmo : option.ml
-option.cmi : option.mli
-toplevel.cmo : toplevel.ml
-toplevel.cmi : toplevel.mli
-frame.cmo : frame.ml
-frame.cmi : frame.mli
-dialog.cmo : dialog.ml
-dialog.cmi : dialog.mli
-imagebitmap.cmo : imagebitmap.ml
-imagebitmap.cmi : imagebitmap.mli
-clipboard.cmo : clipboard.ml
-clipboard.cmi : clipboard.mli
-radiobutton.cmo : radiobutton.ml
-radiobutton.cmi : radiobutton.mli
-tkwait.cmo : tkwait.ml
-tkwait.cmi : tkwait.mli
-grab.cmo : grab.ml
-grab.cmi : grab.mli
-selection.cmo : selection.ml
-selection.cmi : selection.mli
-scale.cmo : scale.ml
-scale.cmi : scale.mli
-optionmenu.cmo : optionmenu.ml
-optionmenu.cmi : optionmenu.mli
-winfo.cmo : winfo.ml
-winfo.cmi : winfo.mli
-grid.cmo : grid.ml
-grid.cmi : grid.mli
-checkbutton.cmo : checkbutton.ml
-checkbutton.cmi : checkbutton.mli
-bell.cmo : bell.ml
-bell.cmi : bell.mli
-tkvars.cmo : tkvars.ml
-tkvars.cmi : tkvars.mli
diff --git a/otherlibs/labltk/lib/.cvsignore b/otherlibs/labltk/lib/.cvsignore
deleted file mode 100644
index 80df4415f0..0000000000
--- a/otherlibs/labltk/lib/.cvsignore
+++ /dev/null
@@ -1,8 +0,0 @@
-labltktop labltk mltktop mltk
-.depend
-*.ml
-*.mli
-modules
-labltk.cma
-labltk.cmxa
-
diff --git a/otherlibs/labltk/lib/Makefile b/otherlibs/labltk/lib/Makefile
deleted file mode 100644
index 225c3d1c44..0000000000
--- a/otherlibs/labltk/lib/Makefile
+++ /dev/null
@@ -1,74 +0,0 @@
-include ../support/Makefile.common
-
-all: $(LIBNAME).cma $(LIBNAME)top$(EXE) $(LIBNAME)
-
-opt: $(LIBNAME).cmxa
-
-clean:
- rm -f $(LIBNAME)top$(EXE) $(LIBNAME) *.cm* *.a
-
-superclean:
- - if test -f tk.cmo; then \
- echo We have changes... Now lib directory has no .cmo files; \
- rm -f *.cm* *.o; \
- fi
-
-include ../labltk/modules
-LABLTKOBJS=tk.cmo $(WIDGETOBJS)
-
-include ../camltk/modules
-CAMLTKOBJS=cTk.cmo $(CWIDGETOBJS) labltk.cmo camltk.cmo
-
-SUPPORT=../support/support.cmo ../support/rawwidget.cmo \
- ../support/widget.cmo ../support/protocol.cmo \
- ../support/textvariable.cmo ../support/timer.cmo \
- ../support/fileevent.cmo ../support/camltkwrap.cmo
-
-TKOBJS=$(SUPPORT) $(LABLTKOBJS) $(CAMLTKOBJS)
-
-TOPDEPS = $(TOPDIR)/toplevel/toplevellib.cma $(TOPDIR)/toplevel/topmain.cmo
-
-$(LIBNAME).cma: $(SUPPORT) ../Widgets.src
- $(MAKE) superclean
- cd ../labltk; $(MAKE)
- cd ../camltk; $(MAKE)
- $(MKLIB) -ocamlc '$(CAMLC)' -o $(LIBNAME) -oc $(LIBNAME) \
- -I ../labltk -I ../camltk $(TKOBJS) \
- $(TK_LINK)
-
-$(LIBNAME).cmxa: $(SUPPORT:.cmo=.cmx) ../Widgets.src
- $(MAKE) superclean
- cd ../labltk; $(MAKE) opt
- cd ../camltk; $(MAKE) opt
- $(MKLIB) -ocamlopt '$(CAMLOPT)' -o $(LIBNAME) -oc $(LIBNAME) \
- -I ../labltk -I ../camltk $(TKOBJS:.cmo=.cmx) \
- $(TK_LINK)
-
-$(LIBNAME)top$(EXE) : $(TOPDEPS) $(LIBNAME).cma ../support/lib$(LIBNAME).a
- $(CAMLC) -verbose -linkall -o $(LIBNAME)top$(EXE) -I ../support \
- -I $(TOPDIR)/toplevel toplevellib.cma \
- -I ../labltk -I ../camltk $(LIBNAME).cma \
- -I $(OTHERS)/unix unix.cma \
- -I $(OTHERS)/str str.cma \
- topstart.cmo
-
-$(LIBNAME): Makefile $(TOPDIR)/config/Makefile
- @echo Generate $@
- @echo "#!/bin/sh" > $@
- @echo 'exec $(INSTALLDIR)/$(LIBNAME)top$(EXE) -I $(INSTALLDIR) $$*' >> $@
-
-install:
- if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi
- cp $(LIBNAME).cma $(LIBNAME)top$(EXE) $(INSTALLDIR)
- chmod 644 $(INSTALLDIR)/$(LIBNAME).cma
- chmod 755 $(INSTALLDIR)/$(LIBNAME)top$(EXE)
- @if test -d $(BINDIR); then : ; else mkdir $(BINDIR); fi
- cp $(LIBNAME) $(BINDIR)
- chmod 755 $(BINDIR)/$(LIBNAME)
-
-installopt:
- @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi
- cp $(LIBNAME).cmxa $(LIBNAME).a $(INSTALLDIR)
- cd $(INSTALLDIR); $(RANLIB) $(LIBNAME).a
- chmod 644 $(INSTALLDIR)/$(LIBNAME).cmxa
- chmod 644 $(INSTALLDIR)/$(LIBNAME).a
diff --git a/otherlibs/labltk/lib/Makefile.nt b/otherlibs/labltk/lib/Makefile.nt
deleted file mode 100644
index 4ce22aca5e..0000000000
--- a/otherlibs/labltk/lib/Makefile.nt
+++ /dev/null
@@ -1,60 +0,0 @@
-include ../support/Makefile.common.nt
-
-all: $(LIBNAME).cma
-
-opt: $(LIBNAME).cmxa
-
-clean:
- rm -f $(LIBNAME).cma $(LIBNAME).cmxa *.$(A)
-
-include ../labltk/modules
-LABLTKOBJS=tk.cmo $(WIDGETOBJS)
-
-include ../camltk/modules
-CAMLTKOBJS=cTk.cmo $(CWIDGETOBJS) labltk.cmo camltk.cmo
-
-SUPPORT=../support/support.cmo ../support/rawwidget.cmo \
- ../support/widget.cmo ../support/protocol.cmo \
- ../support/textvariable.cmo ../support/timer.cmo \
- ../support/fileevent.cmo ../support/camltkwrap.cmo
-
-TKOBJS=$(SUPPORT) $(LABLTKOBJS) $(CAMLTKOBJS)
-
-TOPDEPS = $(TOPDIR)/toplevel/toplevellib.cma $(TOPDIR)/toplevel/topmain.cmo
-
-UNIXLIB = $(call SYSLIB,wsock32)
-
-$(LIBNAME).cma: $(SUPPORT)
- cd ../labltk ; $(MAKEREC)
- cd ../camltk ; $(MAKEREC)
- $(CAMLLIBR) -o $(LIBNAME).cma -I ../labltk -I ../camltk $(TKOBJS) \
- -dllib -l$(LIBNAME) -cclib -l$(LIBNAME) \
- -cclib "$(TK_LINK)" -cclib $(UNIXLIB)
-
-$(LIBNAME).cmxa: $(SUPPORT:.cmo=.cmx)
- cd ../labltk; $(MAKEREC) opt
- cd ../camltk; $(MAKEREC) opt
- $(CAMLOPTLIBR) -o $(LIBNAME).cmxa -I ../labltk -I ../camltk \
- $(TKOBJS:.cmo=.cmx) -cclib -l$(LIBNAME) \
- -cclib "$(TK_LINK)" -cclib $(UNIXLIB)
-
-# $(LIBNAME)top$(EXE) : $(TOPDEPS) $(LIBNAME).cma ../support/lib$(LIBNAME).a
-# $(CAMLC) -linkall -o $(LIBNAME)top$(EXE) -I ../support \
-# -I $(TOPDIR)/toplevel toplevellib.cma \
-# -I ../labltk -I ../camltk $(LIBNAME).cma \
-# -I $(OTHERS)/unix unix.cma \
-# -I $(OTHERS)/str str.cma \
-# topmain.cmo
-#
-# $(LIBNAME): Makefile $(TOPDIR)/config/Makefile
-# @echo Generate $@
-# @echo "#!/bin/sh" > $@
-# @echo 'exec $(INSTALLDIR)/$(LIBNAME)top$(EXE) -I $(INSTALLDIR) $$*' >> $@
-
-install: all
- mkdir -p $(INSTALLDIR)
- cp $(LIBNAME).cma $(INSTALLDIR)
-
-installopt: opt
- mkdir -p $(INSTALLDIR)
- cp $(LIBNAME).cmxa $(LIBNAME).$(A) $(INSTALLDIR)
diff --git a/otherlibs/labltk/support/.depend b/otherlibs/labltk/support/.depend
deleted file mode 100644
index 0abefc8922..0000000000
--- a/otherlibs/labltk/support/.depend
+++ /dev/null
@@ -1,24 +0,0 @@
-camltkwrap.cmi: protocol.cmi textvariable.cmi timer.cmi widget.cmi
-protocol.cmi: widget.cmi
-textvariable.cmi: protocol.cmi widget.cmi
-widget.cmi: rawwidget.cmi
-camltkwrap.cmo: fileevent.cmi protocol.cmi rawwidget.cmi textvariable.cmi \
- timer.cmi camltkwrap.cmi
-camltkwrap.cmx: fileevent.cmx protocol.cmx rawwidget.cmx textvariable.cmx \
- timer.cmx camltkwrap.cmi
-fileevent.cmo: protocol.cmi support.cmi fileevent.cmi
-fileevent.cmx: protocol.cmx support.cmx fileevent.cmi
-protocol.cmo: support.cmi widget.cmi protocol.cmi
-protocol.cmx: support.cmx widget.cmx protocol.cmi
-rawwidget.cmo: support.cmi rawwidget.cmi
-rawwidget.cmx: support.cmx rawwidget.cmi
-slave.cmo: widget.cmi
-slave.cmx: widget.cmx
-support.cmo: support.cmi
-support.cmx: support.cmi
-textvariable.cmo: protocol.cmi support.cmi widget.cmi textvariable.cmi
-textvariable.cmx: protocol.cmx support.cmx widget.cmx textvariable.cmi
-timer.cmo: protocol.cmi support.cmi timer.cmi
-timer.cmx: protocol.cmx support.cmx timer.cmi
-widget.cmo: rawwidget.cmi widget.cmi
-widget.cmx: rawwidget.cmx widget.cmi
diff --git a/otherlibs/labltk/support/Makefile b/otherlibs/labltk/support/Makefile
deleted file mode 100644
index 36d5190308..0000000000
--- a/otherlibs/labltk/support/Makefile
+++ /dev/null
@@ -1,59 +0,0 @@
-include Makefile.common
-
-all: support.cmo rawwidget.cmo widget.cmo protocol.cmo \
- textvariable.cmo timer.cmo fileevent.cmo camltkwrap.cmo \
- lib$(LIBNAME).a
-
-opt: support.cmx rawwidget.cmx widget.cmx protocol.cmx \
- textvariable.cmx timer.cmx fileevent.cmx camltkwrap.cmx \
- lib$(LIBNAME).a
-
-COBJS=cltkCaml.o cltkUtf.o cltkEval.o cltkEvent.o cltkFile.o cltkMain.o \
- cltkMisc.o cltkTimer.o cltkVar.o cltkWait.o cltkImg.o
-
-CCFLAGS=-I../../../byterun $(TK_DEFS) $(SHAREDCCCOMPOPTS)
-
-COMPFLAGS=-I $(OTHERS)/unix
-
-lib$(LIBNAME).a : $(COBJS)
- $(MKLIB) -o $(LIBNAME) $(COBJS) $(TK_LINK)
-
-PUB=fileevent.cmi fileevent.mli \
- protocol.cmi protocol.mli \
- textvariable.cmi textvariable.mli \
- timer.cmi timer.mli \
- rawwidget.cmi rawwidget.mli \
- widget.cmi widget.mli
-
-install: lib$(LIBNAME).a $(PUB)
- if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi
- cp $(PUB) lib$(LIBNAME).a $(INSTALLDIR)
- cd $(INSTALLDIR); $(RANLIB) lib$(LIBNAME).a
- cd $(INSTALLDIR); chmod 644 $(PUB) lib$(LIBNAME).a
- if test -f dll$(LIBNAME).so; then \
- cp dll$(LIBNAME).so $(STUBLIBDIR)/dll$(LIBNAME).so; fi
-
-clean :
- rm -f *.cm* *.o *.a *.so
-
-.SUFFIXES :
-.SUFFIXES : .mli .ml .cmi .cmo .cmx .mlp .c .o
-
-.mli.cmi:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-.c.o:
- $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $<
-
-depend:
- $(CAMLDEP) *.mli *.ml > .depend
-
-$(COBJS): $(TOPDIR)/config/Makefile camltk.h
-
-include .depend
diff --git a/otherlibs/labltk/support/Makefile.common b/otherlibs/labltk/support/Makefile.common
deleted file mode 100644
index 8745fee80b..0000000000
--- a/otherlibs/labltk/support/Makefile.common
+++ /dev/null
@@ -1,26 +0,0 @@
-## Paths are relative to subdirectories
-## Where you compiled Objective Caml
-TOPDIR=../../..
-## Path to the otherlibs subdirectory
-OTHERS=../..
-
-LIBNAME=labltk
-
-include $(TOPDIR)/config/Makefile
-
-INSTALLDIR=$(LIBDIR)/$(LIBNAME)
-
-## Tools from the Objective Caml distribution
-
-CAMLRUN=$(TOPDIR)/boot/ocamlrun
-CAMLC=$(TOPDIR)/ocamlcomp.sh
-CAMLOPT=$(TOPDIR)/ocamlcompopt.sh
-CAMLCOMP=$(CAMLC) -c -warn-error A
-CAMLYACC=$(TOPDIR)/boot/ocamlyacc -v
-CAMLLEX=$(CAMLRUN) $(TOPDIR)/boot/ocamllex
-CAMLLIBR=$(CAMLC) -a
-CAMLDEP=$(CAMLRUN) $(TOPDIR)/tools/ocamldep
-COMPFLAGS=
-LINKFLAGS=
-CAMLOPTLIBR=$(CAMLOPT) -a
-MKLIB=$(CAMLRUN) $(TOPDIR)/tools/ocamlmklib
diff --git a/otherlibs/labltk/support/Makefile.common.nt b/otherlibs/labltk/support/Makefile.common.nt
deleted file mode 100644
index d31de99dc5..0000000000
--- a/otherlibs/labltk/support/Makefile.common.nt
+++ /dev/null
@@ -1,29 +0,0 @@
-## Paths are relative to subdirectories
-## Where you compiled Objective Caml
-TOPDIR=../../..
-## Where to find OCaml binaries
-EXEDIR=$(TOPDIR)
-## Path to the otherlibs subdirectory
-OTHERS=../..
-
-LIBNAME=labltk
-
-include $(TOPDIR)/config/Makefile
-
-INSTALLDIR=$(LIBDIR)/$(LIBNAME)
-TKLINKOPT=$(STATIC)
-
-## Tools from the Objective Caml distribution
-
-CAMLRUN=$(EXEDIR)/boot/ocamlrun
-CAMLC=$(CAMLRUN) $(TOPDIR)/ocamlc -I $(TOPDIR)/stdlib
-CAMLCOMP=$(CAMLC) -c
-CAMLYACC=$(EXEDIR)/boot/ocamlyacc -v
-CAMLLEX=$(CAMLRUN) $(TOPDIR)/boot/ocamllex
-CAMLLIBR=$(CAMLC) -a
-CAMLDEP=$(CAMLRUN) $(TOPDIR)/tools/ocamldep
-COMPFLAGS=
-LINKFLAGS=
-
-CAMLOPT=$(CAMLRUN) $(TOPDIR)/ocamlopt -I $(TOPDIR)/stdlib
-CAMLOPTLIBR=$(CAMLOPT) -a
diff --git a/otherlibs/labltk/support/Makefile.nt b/otherlibs/labltk/support/Makefile.nt
deleted file mode 100644
index e1720efb46..0000000000
--- a/otherlibs/labltk/support/Makefile.nt
+++ /dev/null
@@ -1,69 +0,0 @@
-include Makefile.common.nt
-
-all: support.cmo rawwidget.cmo widget.cmo protocol.cmo \
- textvariable.cmo timer.cmo fileevent.cmo camltkwrap.cmo \
- dll$(LIBNAME).dll lib$(LIBNAME).$(A)
-
-opt: support.cmx rawwidget.cmx widget.cmx protocol.cmx \
- textvariable.cmx timer.cmx fileevent.cmx camltkwrap.cmx \
- lib$(LIBNAME).$(A)
-
-COBJS=cltkCaml.o cltkUtf.o cltkEval.o cltkEvent.o cltkFile.o \
- cltkMain.o cltkMisc.o cltkTimer.o cltkVar.o cltkWait.o cltkImg.o
-DCOBJS=$(COBJS:.o=.$(DO))
-SCOBJS=$(COBJS:.o=.$(SO))
-
-CCFLAGS=-I../../../byterun -I../../win32unix $(TK_DEFS) -DIN_CAMLTKSUPPORT
-
-COMPFLAGS=-I $(OTHERS)/win32unix
-
-dll$(LIBNAME).dll : $(DCOBJS)
- $(call MKDLL,dll$(LIBNAME).dll,dll$(LIBNAME).$(A),\
- $(DCOBJS) ../../../byterun/ocamlrun.$(A) \
- $(TK_LINK) $(call SYSLIB,wsock32))
-
-lib$(LIBNAME).$(A) : $(SCOBJS)
- $(call MKLIB,lib$(LIBNAME).$(A), $(SCOBJS))
-
-PUB=fileevent.cmi fileevent.mli \
- protocol.cmi protocol.mli \
- textvariable.cmi textvariable.mli \
- timer.cmi timer.mli \
- rawwidget.cmi rawwidget.mli \
- widget.cmi widget.mli
-
-install:
- mkdir -p $(INSTALLDIR)
- cp $(PUB) $(INSTALLDIR)
- cp dll$(LIBNAME).dll $(STUBLIBDIR)/dll$(LIBNAME).dll
- cp dll$(LIBNAME).$(A) lib$(LIBNAME).$(A) $(INSTALLDIR)
-
-clean :
- rm -f *.cm* *.$(O) *.dll *.$(A) *.exp
-
-.SUFFIXES :
-.SUFFIXES : .mli .ml .cmi .cmo .cmx .mlp .c .$(DO) .$(SO)
-
-.mli.cmi:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-.c.$(DO):
- $(BYTECC) $(DLLCCCOMPOPTS) $(CCFLAGS) -c $<
- mv $*.$(O) $*.$(DO)
-
-.c.$(SO):
- $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $<
- mv $*.$(O) $*.$(SO)
-
-depend:
- $(CAMLDEP) *.mli *.ml > .depend
-
-$(DCOBJS) $(SCOBJS): camltk.h
-
-include .depend
diff --git a/otherlibs/labltk/support/camltk.h b/otherlibs/labltk/support/camltk.h
deleted file mode 100644
index deba33086c..0000000000
--- a/otherlibs/labltk/support/camltk.h
+++ /dev/null
@@ -1,56 +0,0 @@
-/*************************************************************************/
-/* */
-/* Objective Caml LablTk library */
-/* */
-/* Francois Rouaix, Francois Pessaux and Jun Furuse */
-/* projet Cristal, INRIA Rocquencourt */
-/* Jacques Garrigue, Kyoto University RIMS */
-/* */
-/* Copyright 1999 Institut National de Recherche en Informatique et */
-/* en Automatique and Kyoto University. All rights reserved. */
-/* This file is distributed under the terms of the GNU Library */
-/* General Public License, with the special exception on linking */
-/* described in file ../../../LICENSE. */
-/* */
-/*************************************************************************/
-
-/* $Id$ */
-
-#if defined(_WIN32) && defined(CAML_DLL) && defined(IN_CAMLTKSUPPORT)
-#define CAMLTKextern CAMLexport
-#else
-#define CAMLTKextern CAMLextern
-#endif
-
-/* cltkMisc.c */
-/* copy a Caml string to the C heap. Must be deallocated with stat_free */
-extern char *string_to_c(value s);
-
-/* cltkUtf.c */
-extern value tcl_string_to_caml( char * );
-extern char * caml_string_to_tcl( value );
-
-/* cltkEval.c */
-CAMLTKextern Tcl_Interp *cltclinterp; /* The Tcl interpretor */
-extern value copy_string_list(int argc, char ** argv);
-
-/* cltkCaml.c */
-/* pointers to Caml values */
-extern value *tkerror_exn;
-extern value *handler_code;
-extern int CamlCBCmd(ClientData clientdata, Tcl_Interp *interp,
- int argc, char *argv[]);
-CAMLTKextern void tk_error(char * errmsg) Noreturn;
-
-/* cltkMain.c */
-extern int signal_events;
-extern void invoke_pending_caml_signals(ClientData clientdata);
-extern Tk_Window cltk_mainWindow;
-extern int cltk_slave_mode;
-
-/* check that initialisations took place */
-#define CheckInit() if (!cltclinterp) tk_error("Tcl/Tk not initialised")
-
-#define RCNAME ".camltkrc"
-#define CAMLCB "camlcb"
-
diff --git a/otherlibs/labltk/support/camltkwrap.ml b/otherlibs/labltk/support/camltkwrap.ml
deleted file mode 100644
index 5afe864dfc..0000000000
--- a/otherlibs/labltk/support/camltkwrap.ml
+++ /dev/null
@@ -1,77 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-module Widget = struct
- include Rawwidget
- type widget = raw_any raw_widget
-
- let default_toplevel = coe default_toplevel
-end
-
-module Protocol = struct
- open Widget
- include Protocol
-
- let opentk () = coe (opentk ())
- let opentk_with_args args = coe (opentk_with_args args)
- let openTk ?display ?clas () = coe (openTk ?display ?clas ())
-
- let cCAMLtoTKwidget table w =
- Widget.check_class w table; (* we need run time type check of widgets *)
- TkToken (Widget.name w)
-
- (* backward compatibility *)
- let openTkClass s = coe (openTkClass s)
- let openTkDisplayClass disp c = coe (openTkDisplayClass disp c)
-end
-
-module Textvariable = struct
- open Textvariable
- type textVariable = Textvariable.textVariable
- let create = create
- let set = set
- let get = get
- let name = name
- let cCAMLtoTKtextVariable = cCAMLtoTKtextVariable
- let handle tv cbk = handle tv ~callback:cbk
- let coerce = coerce
-
- (*-*)
- let free = free
-
- (* backward compatibility *)
- let create_temporary w = create ~on: w ()
-end
-
-module Fileevent = struct
- open Fileevent
- let add_fileinput fd callback = add_fileinput ~fd ~callback
- let remove_fileinput fd = remove_fileinput ~fd
- let add_fileoutput fd callback = add_fileoutput ~fd ~callback
- let remove_fileoutput fd = remove_fileoutput ~fd
-end
-
-module Timer = struct
- open Timer
- type t = Timer.t
- let add ms callback = add ~ms ~callback
- let set ms callback = set ~ms ~callback
- let remove = remove
-end
-
-(*
-Not compiled in support
-module Tkwait = Tkwait
-*)
diff --git a/otherlibs/labltk/support/camltkwrap.mli b/otherlibs/labltk/support/camltkwrap.mli
deleted file mode 100644
index 9c9321c21e..0000000000
--- a/otherlibs/labltk/support/camltkwrap.mli
+++ /dev/null
@@ -1,251 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-module Widget : sig
- type widget = Widget.any Widget.widget
- (* widget is an abstract type *)
-
- val default_toplevel : widget
- (* [default_toplevel] is "." in Tk, the toplevel widget that is
- always existing during a Tk session. Destroying [default_toplevel]
- ends the main loop
- *)
-
- val atom : parent: widget -> name: string -> widget
- (* [atom parent name] returns the widget [parent.name]. The widget is
- not created. Only its name is returned. In a given parent, there may
- only exist one children for a given name.
- This function should only be used to check the existence of a widget
- with a known name. It doesn't add the widget to the internal tables
- of CamlTk.
- *)
-
- val name : widget -> string
- (* [name w] returns the name (tk "path") of a widget *)
-
- (*--*)
- (* The following functions are used internally.
- There is normally no need for them in users programs
- *)
-
- val known_class : widget -> string
- (* [known_class w] returns the class of a widget (e.g. toplevel, frame),
- as known by the CamlTk interface.
- Not equivalent to "winfo w" in Tk.
- *)
-
- val dummy : widget
- (* [dummy] is a widget used as context when we don't have any.
- It is *not* a real widget.
- *)
-
- val new_atom : parent: widget -> ?name: string -> string -> widget
- (* incompatible with the classic camltk *)
-
- val get_atom : string -> widget
- (* [get_atom path] returns the widget with Tk path [path] *)
-
- val remove : widget -> unit
- (* [remove w] removes widget from the internal tables *)
-
- (* Subtypes tables *)
- val widget_any_table : string list
- val widget_button_table : string list
- val widget_canvas_table : string list
- val widget_checkbutton_table : string list
- val widget_entry_table : string list
- val widget_frame_table : string list
- val widget_label_table : string list
- val widget_listbox_table : string list
- val widget_menu_table : string list
- val widget_menubutton_table : string list
- val widget_message_table : string list
- val widget_radiobutton_table : string list
- val widget_scale_table : string list
- val widget_scrollbar_table : string list
- val widget_text_table : string list
- val widget_toplevel_table : string list
-
- val chk_sub : string -> 'a list -> 'a -> unit
- val check_class : widget -> string list -> unit
- (* Widget subtyping *)
-
- exception IllegalWidgetType of string
- (* Raised when widget command applied illegally*)
-
- (* this function is not used, but introduced for the compatibility
- with labltk. useless for camltk users *)
- val coe : 'a Widget.widget -> Widget.any Widget.widget
-end
-
-module Protocol : sig
- open Widget
-
- (* Lower level interface *)
- exception TkError of string
- (* Raised by the communication functions *)
-
- val debug : bool ref
- (* When set to true, displays approximation of intermediate Tcl code *)
-
- type tkArgs =
- TkToken of string
- | TkTokenList of tkArgs list (* to be expanded *)
- | TkQuote of tkArgs (* mapped to Tcl list *)
-
-
- (* Misc *)
- external splitlist : string -> string list
- = "camltk_splitlist"
-
- val add_destroy_hook : (widget -> unit) -> unit
-
-
- (* Opening, closing, and mainloop *)
- val default_display : unit -> string
-
- val opentk : unit -> widget
- (* The basic initialization function. [opentk ()] parses automatically
- the command line options and use the tk related options in them
- such as "-display localhost:0" to initialize Tk applications.
- Consult wish manpage about the supported options. *)
-
- val keywords : (string * Arg.spec * string) list
- (* Command line parsing specification for Arg.parse, which contains
- the standard Tcl/Tk command line options such as "-display" and "-name".
- These Tk command line options are used by opentk *)
-
- val opentk_with_args : string list -> widget
- (* [opentk_with_args argv] invokes [opentk] with the tk related
- command line options given by [argv] to the executable program. *)
-
- val openTk : ?display:string -> ?clas:string -> unit -> widget
- (* [openTk ~display:display ~clas:clas ()] is equivalent to
- [opentk ["-display"; display; "-name"; clas]] *)
-
- (* Legacy opentk functions *)
- val openTkClass: string -> widget
- (* [openTkClass class] is equivalent to [opentk ["-name"; class]] *)
- val openTkDisplayClass: string -> string -> widget
- (* [openTkDisplayClass disp class] is equivalent to
- [opentk ["-display"; disp; "-name"; class]] *)
-
- val closeTk : unit -> unit
- val finalizeTk : unit -> unit
- (* Finalize tcl/tk before exiting. This function will be automatically
- called when you call [Pervasives.exit ()] *)
-
- val mainLoop : unit -> unit
-
-
- (* Direct evaluation of tcl code *)
- val tkEval : tkArgs array -> string
-
- val tkCommand : tkArgs array -> unit
-
- (* Returning a value from a Tcl callback *)
- val tkreturn: string -> unit
-
-
- (* Callbacks: this is private *)
-
- type cbid = Protocol.cbid
-
- type callback_buffer = string list
- (* Buffer for reading callback arguments *)
-
- val callback_naming_table : (cbid, callback_buffer -> unit) Hashtbl.t
- (* CAMLTK val callback_memo_table : (widget, cbid) Hashtbl.t *)
- val callback_memo_table : (widget, cbid) Hashtbl.t
- (* Exported for debug purposes only. Don't use them unless you
- know what you are doing *)
- val new_function_id : unit -> cbid
- val string_of_cbid : cbid -> string
- val register_callback : widget -> callback:(callback_buffer -> unit) -> string
- (* Callback support *)
- val clear_callback : cbid -> unit
- (* Remove a given callback from the table *)
- val remove_callbacks : widget -> unit
- (* Clean up callbacks associated to widget. Must be used only when
- the Destroy event is bind by the user and masks the default
- Destroy event binding *)
-
- val cTKtoCAMLwidget : string -> widget
- val cCAMLtoTKwidget : string list -> widget -> tkArgs
-
- val register : string -> callback:(callback_buffer -> unit) -> unit
-
- (*-*)
- val prerr_cbid : cbid -> unit
-end
-
-module Textvariable : sig
- open Widget
- open Protocol
-
- type textVariable = Textvariable.textVariable
- (* TextVariable is an abstract type *)
-
- val create : ?on: widget -> unit -> textVariable
- (* Allocation of a textVariable with lifetime associated to widget
- if a widget is specified *)
- val create_temporary : widget -> textVariable
- (* for backward compatibility
- [create_temporary w] is equivalent to [create ~on:w ()] *)
-
- val set : textVariable -> string -> unit
- (* Setting the val of a textVariable *)
- val get : textVariable -> string
- (* Reading the val of a textVariable *)
- val name : textVariable -> string
- (* Its tcl name *)
-
- val cCAMLtoTKtextVariable : textVariable -> tkArgs
- (* Internal conversion function *)
-
- val handle : textVariable -> (unit -> unit) -> unit
- (* Callbacks on variable modifications *)
-
- val coerce : string -> textVariable
-
- (*-*)
- val free : textVariable -> unit
-end
-
-module Fileevent : sig
- open Unix
-
- val add_fileinput : file_descr -> (unit -> unit) -> unit
- val remove_fileinput: file_descr -> unit
- val add_fileoutput : file_descr -> (unit -> unit) -> unit
- val remove_fileoutput: file_descr -> unit
- (* see [tk] module *)
-end
-
-module Timer : sig
- type t = Timer.t
-
- val add : int -> (unit -> unit) -> t
- val set : int -> (unit -> unit) -> unit
- val remove : t -> unit
-end
-
-(*
-Tkwait exists, but is not used in support
-module Tkwait : sig
- val internal_tracevis : string -> string -> unit
- val internal_tracedestroy : string -> string -> unit
-end
-*)
diff --git a/otherlibs/labltk/support/cltkCaml.c b/otherlibs/labltk/support/cltkCaml.c
deleted file mode 100644
index 976c864efa..0000000000
--- a/otherlibs/labltk/support/cltkCaml.c
+++ /dev/null
@@ -1,83 +0,0 @@
-/***********************************************************************/
-/* */
-/* MLTk, Tcl/Tk interface of Objective Caml */
-/* */
-/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */
-/* projet Cristal, INRIA Rocquencourt */
-/* Jacques Garrigue, Kyoto University RIMS */
-/* */
-/* Copyright 2002 Institut National de Recherche en Informatique et */
-/* en Automatique and Kyoto University. All rights reserved. */
-/* This file is distributed under the terms of the GNU Library */
-/* General Public License, with the special exception on linking */
-/* described in file LICENSE found in the Objective Caml source tree. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <tcl.h>
-#include <tk.h>
-#include <mlvalues.h>
-#include <alloc.h>
-#include <callback.h>
-#include <fail.h>
-#include "camltk.h"
-
-value * tkerror_exn = NULL;
-value * handler_code = NULL;
-
-/* The Tcl command for evaluating callback in Caml */
-int CamlCBCmd(ClientData clientdata, Tcl_Interp *interp, int argc, char **argv)
-{
- CheckInit();
-
- /* Assumes no result */
- Tcl_SetResult(interp, NULL, NULL);
- if (argc >= 2) {
- int id;
- if (Tcl_GetInt(interp, argv[1], &id) != TCL_OK)
- return TCL_ERROR;
- callback2(*handler_code,Val_int(id),copy_string_list(argc - 2,&argv[2]));
- /* Never fails (Caml would have raised an exception) */
- /* but result may have been set by callback */
- return TCL_OK;
- }
- else
- return TCL_ERROR;
-}
-
-/* Callbacks are always of type _ -> unit, to simplify storage
- * But a callback can nevertheless return something (to Tcl) by
- * using the following. TCL_VOLATILE ensures that Tcl will make
- * a copy of the string
- */
-CAMLprim value camltk_return (value v)
-{
- CheckInit();
-
- Tcl_SetResult(cltclinterp, String_val(v), TCL_VOLATILE);
- return Val_unit;
-}
-
-/* Note: raise_with_string WILL copy the error message */
-CAMLprim void tk_error(char *errmsg)
-{
- raise_with_string(*tkerror_exn, errmsg);
-}
-
-
-/* The initialisation of the C global variables pointing to Caml values
- must be made accessible from Caml, so that we are sure that it *always*
- takes place during loading of the protocol module
- */
-
-CAMLprim value camltk_init(value v)
-{
- /* Initialize the Caml pointers */
- if (tkerror_exn == NULL)
- tkerror_exn = caml_named_value("tkerror");
- if (handler_code == NULL)
- handler_code = caml_named_value("camlcb");
- return Val_unit;
-}
diff --git a/otherlibs/labltk/support/cltkDMain.c b/otherlibs/labltk/support/cltkDMain.c
deleted file mode 100644
index 7b2e59bc2d..0000000000
--- a/otherlibs/labltk/support/cltkDMain.c
+++ /dev/null
@@ -1,247 +0,0 @@
-/*************************************************************************/
-/* */
-/* Objective Caml LablTk library */
-/* */
-/* Francois Rouaix, Francois Pessaux and Jun Furuse */
-/* projet Cristal, INRIA Rocquencourt */
-/* Jacques Garrigue, Kyoto University RIMS */
-/* */
-/* Copyright 1999 Institut National de Recherche en Informatique et */
-/* en Automatique and Kyoto University. All rights reserved. */
-/* This file is distributed under the terms of the GNU Library */
-/* General Public License, with the special exception on linking */
-/* described in file ../../../LICENSE. */
-/* */
-/*************************************************************************/
-
-/* $Id$ */
-
-#include <unistd.h>
-#include <fcntl.h>
-#include <tcl.h>
-#include <tk.h>
-#include "gc.h"
-#include "exec.h"
-#include "sys.h"
-#include "fail.h"
-#include "io.h"
-#include "mlvalues.h"
-#include "memory.h"
-#include "camltk.h"
-
-#ifndef O_BINARY
-#define O_BINARY 0
-#endif
-
-
-/*
- * Dealing with signals: when a signal handler is defined in Caml,
- * the actual execution of the signal handler upon reception of the
- * signal is delayed until we are sure we are out of the GC.
- * If a signal occurs during the MainLoop, we would have to wait
- * the next event for the handler to be invoked.
- * The following function will invoke a pending signal handler if any,
- * and we put in on a regular timer.
- */
-
-#define SIGNAL_INTERVAL 300
-
-int signal_events = 0; /* do we have a pending timer */
-
-void invoke_pending_caml_signals (clientdata)
- ClientData clientdata;
-{
- signal_events = 0;
- enter_blocking_section(); /* triggers signal handling */
- /* Rearm timer */
- Tk_CreateTimerHandler(SIGNAL_INTERVAL, invoke_pending_caml_signals, NULL);
- signal_events = 1;
- leave_blocking_section();
-}
-/* The following is taken from byterun/startup.c */
-header_t atom_table[256];
-code_t start_code;
-asize_t code_size;
-
-static void init_atoms()
-{
- int i;
- for(i = 0; i < 256; i++) atom_table[i] = Make_header(0, i, White);
-}
-
-static unsigned long read_size(p)
- unsigned char * p;
-{
- return ((unsigned long) p[0] << 24) + ((unsigned long) p[1] << 16) +
- ((unsigned long) p[2] << 8) + p[3];
-}
-
-#define FILE_NOT_FOUND (-1)
-#define TRUNCATED_FILE (-2)
-#define BAD_MAGIC_NUM (-3)
-
-static int read_trailer(fd, trail)
- int fd;
- struct exec_trailer * trail;
-{
- char buffer[TRAILER_SIZE];
-
- lseek(fd, (long) -TRAILER_SIZE, 2);
- if (read(fd, buffer, TRAILER_SIZE) < TRAILER_SIZE) return TRUNCATED_FILE;
- trail->code_size = read_size(buffer);
- trail->data_size = read_size(buffer+4);
- trail->symbol_size = read_size(buffer+8);
- trail->debug_size = read_size(buffer+12);
- if (strncmp(buffer + 16, EXEC_MAGIC, 12) == 0)
- return 0;
- else
- return BAD_MAGIC_NUM;
-}
-
-int attempt_open(name, trail, do_open_script)
- char ** name;
- struct exec_trailer * trail;
- int do_open_script;
-{
- char * truename;
- int fd;
- int err;
- char buf [2];
-
- truename = searchpath(*name);
- if (truename == 0) truename = *name; else *name = truename;
- fd = open(truename, O_RDONLY | O_BINARY);
- if (fd == -1) return FILE_NOT_FOUND;
- if (!do_open_script){
- err = read (fd, buf, 2);
- if (err < 2) { close(fd); return TRUNCATED_FILE; }
- if (buf [0] == '#' && buf [1] == '!') { close(fd); return BAD_MAGIC_NUM; }
- }
- err = read_trailer(fd, trail);
- if (err != 0) { close(fd); return err; }
- return fd;
-}
-
-
-/* Command for loading the bytecode file */
-int CamlRunCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
-{
- int fd;
- struct exec_trailer trail;
- struct longjmp_buffer raise_buf;
- struct channel * chan;
-
- if (argc < 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " foo.cmo args\"", (char *) NULL);
- return TCL_ERROR;
- }
- fd = attempt_open(&argv[1], &trail, 1);
-
- switch(fd) {
- case FILE_NOT_FOUND:
- fatal_error_arg("Fatal error: cannot find file %s\n", argv[1]);
- break;
- case TRUNCATED_FILE:
- case BAD_MAGIC_NUM:
- fatal_error_arg(
- "Fatal error: the file %s is not a bytecode executable file\n",
- argv[1]);
- break;
- }
-
- if (sigsetjmp(raise_buf.buf, 1) == 0) {
-
- external_raise = &raise_buf;
-
- lseek(fd, - (long) (TRAILER_SIZE + trail.code_size + trail.data_size
- + trail.symbol_size + trail.debug_size), 2);
-
- code_size = trail.code_size;
- start_code = (code_t) stat_alloc(code_size);
- if (read(fd, (char *) start_code, code_size) != code_size)
- fatal_error("Fatal error: truncated bytecode file.\n");
-
-#ifdef ARCH_BIG_ENDIAN
- fixup_endianness(start_code, code_size);
-#endif
-
- chan = open_descr(fd);
- global_data = input_value(chan);
- close_channel(chan);
- /* Ensure that the globals are in the major heap. */
- oldify(global_data, &global_data);
-
- sys_init(argv + 1);
- interprete(start_code, code_size);
- return TCL_OK;
- } else {
- Tcl_AppendResult(interp, "Caml program", argv[1], " raised exception \"",
- String_val(Field(Field(exn_bucket, 0), 0)));
- return TCL_ERROR;
- }
-}
-
-int CamlInvokeCmd(dummy
-
-
-
-/* Now the real Tk stuff */
-Tk_Window cltk_mainWindow;
-
-#define RCNAME ".camltkrc"
-#define CAMLCB "camlcb"
-
-/* Initialisation of the dynamically loaded module */
-int Caml_Init(interp)
- Tcl_Interp *interp;
-{
- cltclinterp = interp;
- /* Create the camlcallback command */
- Tcl_CreateCommand(cltclinterp,
- CAMLCB, CamlCBCmd,
- (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);
-
- /* This is required by "unknown" and thus autoload */
- Tcl_SetVar(cltclinterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
- /* Our hack for implementing break in callbacks */
- Tcl_SetVar(cltclinterp, "BreakBindingsSequence", "0", TCL_GLOBAL_ONLY);
-
- /* Load the traditional rc file */
- {
- char *home = getenv("HOME");
- if (home != NULL) {
- char *f = stat_alloc(strlen(home)+strlen(RCNAME)+2);
- f[0]='\0';
- strcat(f, home);
- strcat(f, "/");
- strcat(f, RCNAME);
- if (0 == access(f,R_OK))
- if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) {
- stat_free(f);
- tk_error(cltclinterp->result);
- };
- stat_free(f);
- }
- }
-
- /* Initialisations from caml_main */
- {
- int verbose_init = 0,
- percent_free_init = Percent_free_def;
- long minor_heap_init = Minor_heap_def,
- heap_chunk_init = Heap_chunk_def;
-
- /* Machine-dependent initialization of the floating-point hardware
- so that it behaves as much as possible as specified in IEEE */
- init_ieee_floats();
- init_gc (minor_heap_init, heap_chunk_init, percent_free_init,
- verbose_init);
- init_stack();
- init_atoms();
- }
-}
diff --git a/otherlibs/labltk/support/cltkEval.c b/otherlibs/labltk/support/cltkEval.c
deleted file mode 100644
index b31bc1adfd..0000000000
--- a/otherlibs/labltk/support/cltkEval.c
+++ /dev/null
@@ -1,245 +0,0 @@
-/***********************************************************************/
-/* */
-/* MLTk, Tcl/Tk interface of Objective Caml */
-/* */
-/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */
-/* projet Cristal, INRIA Rocquencourt */
-/* Jacques Garrigue, Kyoto University RIMS */
-/* */
-/* Copyright 2002 Institut National de Recherche en Informatique et */
-/* en Automatique and Kyoto University. All rights reserved. */
-/* This file is distributed under the terms of the GNU Library */
-/* General Public License, with the special exception on linking */
-/* described in file LICENSE found in the Objective Caml source tree. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <stdlib.h>
-#include <string.h>
-
-#include <tcl.h>
-#include <tk.h>
-#include <mlvalues.h>
-#include <alloc.h>
-#include <memory.h>
-#ifdef HAS_UNISTD
-#include <unistd.h>
-#endif
-#include "camltk.h"
-
-/* The Tcl interpretor */
-Tcl_Interp *cltclinterp = NULL;
-
-/* Copy a list of strings from the C heap to Caml */
-value copy_string_list(int argc, char **argv)
-{
- CAMLparam0();
- CAMLlocal3( res, oldres, str );
- int i;
- oldres = Val_unit;
- str = Val_unit;
-
- res = Val_int(0); /* [] */
- for (i = argc-1; i >= 0; i--) {
- oldres = res;
- str = tcl_string_to_caml(argv[i]);
- res = alloc(2, 0);
- Field(res, 0) = str;
- Field(res, 1) = oldres;
- }
- CAMLreturn(res);
-}
-
-/*
- * Calling Tcl from Caml
- * this version works on an arbitrary Tcl command,
- * and does parsing and substitution
- */
-CAMLprim value camltk_tcl_eval(value str)
-{
- int code;
- char *cmd = NULL;
-
- CheckInit();
-
- /* Tcl_Eval may write to its argument, so we take a copy
- * If the evaluation raises a Caml exception, we have a space
- * leak
- */
- Tcl_ResetResult(cltclinterp);
- cmd = caml_string_to_tcl(str);
- code = Tcl_Eval(cltclinterp, cmd);
- stat_free(cmd);
-
- switch (code) {
- case TCL_OK:
- return tcl_string_to_caml(cltclinterp->result);
- case TCL_ERROR:
- tk_error(cltclinterp->result);
- default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */
- tk_error("bad tcl result");
- }
-}
-
-
-/*
- * Calling Tcl from Caml
- * direct call, argument is TkArgs vect
- type TkArgs =
- TkToken of string
- | TkTokenList of TkArgs list (* to be expanded *)
- | TkQuote of TkArgs (* mapped to Tcl list *)
- * NO PARSING, NO SUBSTITUTION
- */
-
-/*
- * Compute the size of the argument (of type TkArgs).
- * TkTokenList must be expanded,
- * TkQuote count for one.
- */
-int argv_size(value v)
-{
- switch (Tag_val(v)) {
- case 0: /* TkToken */
- return 1;
- case 1: /* TkTokenList */
- { int n = 0;
- value l;
- for (l=Field(v,0), n=0; Is_block(l); l=Field(l,1))
- n+=argv_size(Field(l,0));
- return n;
- }
- case 2: /* TkQuote */
- return 1;
- default:
- tk_error("argv_size: illegal tag");
- }
-}
-
-/* Fill a preallocated vector arguments, doing expansion and all.
- * Assumes Tcl will
- * not tamper with our strings
- * make copies if strings are "persistent"
- */
-int fill_args (char **argv, int where, value v)
-{
- value l;
-
- switch (Tag_val(v)) {
- case 0:
- argv[where] = caml_string_to_tcl(Field(v,0)); /* must free by stat_free */
- return (where + 1);
- case 1:
- for (l=Field(v,0); Is_block(l); l=Field(l,1))
- where = fill_args(argv,where,Field(l,0));
- return where;
- case 2:
- { char **tmpargv;
- char *merged;
- int i;
- int size = argv_size(Field(v,0));
- tmpargv = (char **)stat_alloc((size + 1) * sizeof(char *));
- fill_args(tmpargv,0,Field(v,0));
- tmpargv[size] = NULL;
- merged = Tcl_Merge(size,tmpargv);
- for(i = 0 ; i<size; i++){ stat_free(tmpargv[i]); }
- stat_free((char *)tmpargv);
- /* must be freed by stat_free */
- argv[where] = (char*)stat_alloc(strlen(merged)+1);
- strcpy(argv[where], merged);
- Tcl_Free(merged);
- return (where + 1);
- }
- default:
- tk_error("fill_args: illegal tag");
- }
-}
-
-/* v is an array of TkArg */
-CAMLprim value camltk_tcl_direct_eval(value v)
-{
- int i;
- int size; /* size of argv */
- char **argv, **allocated;
- int result;
- Tcl_CmdInfo info;
-
- CheckInit();
-
- /* walk the array to compute final size for Tcl */
- for(i=0,size=0;i<Wosize_val(v);i++)
- size += argv_size(Field(v,i));
-
- /* +2: one slot for NULL
- one slot for "unknown" if command not found */
- argv = (char **)stat_alloc((size + 2) * sizeof(char *));
- allocated = (char **)stat_alloc(size * sizeof(char *));
-
- /* Copy -- argv[i] must be freed by stat_free */
- {
- int where;
- for(i=0, where=0;i<Wosize_val(v);i++){
- where = fill_args(argv,where,Field(v,i));
- }
- if( size != where ){ tk_error("fill_args error!!! Call the CamlTk maintainer!"); }
- for(i=0; i<where; i++){ allocated[i] = argv[i]; }
- argv[size] = NULL;
- argv[size + 1] = NULL;
- }
-
- /* Eval */
- Tcl_ResetResult(cltclinterp);
- if (Tcl_GetCommandInfo(cltclinterp,argv[0],&info)) { /* command found */
-#if (TCL_MAJOR_VERSION >= 8)
- /* info.proc might be a NULL pointer
- * We should probably attempt an Obj invocation, but the following quick
- * hack is easier.
- */
- if (info.proc == NULL) {
- Tcl_DString buf;
- char *string;
- Tcl_DStringInit(&buf);
- Tcl_DStringAppend(&buf, argv[0], -1);
- for (i=1; i<size; i++) {
- Tcl_DStringAppend(&buf, " ", -1);
- Tcl_DStringAppend(&buf, argv[i], -1);
- }
- result = Tcl_Eval(cltclinterp, Tcl_DStringValue(&buf));
- Tcl_DStringFree(&buf);
- } else {
- result = (*info.proc)(info.clientData,cltclinterp,size,argv);
- }
-#else
- result = (*info.proc)(info.clientData,cltclinterp,size,argv);
-#endif
- } else { /* implement the autoload stuff */
- if (Tcl_GetCommandInfo(cltclinterp,"unknown",&info)) { /* unknown found */
- for (i = size; i >= 0; i--)
- argv[i+1] = argv[i];
- argv[0] = "unknown";
- result = (*info.proc)(info.clientData,cltclinterp,size+1,argv);
- } else { /* ah, it isn't there at all */
- result = TCL_ERROR;
- Tcl_AppendResult(cltclinterp, "Unknown command \"",
- argv[0], "\"", NULL);
- }
- }
-
- /* Free the various things we allocated */
- for(i=0; i< size; i ++){
- stat_free((char *) allocated[i]);
- }
- stat_free((char *)argv);
- stat_free((char *)allocated);
-
- switch (result) {
- case TCL_OK:
- return tcl_string_to_caml (cltclinterp->result);
- case TCL_ERROR:
- tk_error(cltclinterp->result);
- default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */
- tk_error("bad tcl result");
- }
-}
diff --git a/otherlibs/labltk/support/cltkEvent.c b/otherlibs/labltk/support/cltkEvent.c
deleted file mode 100644
index 81c9413f6c..0000000000
--- a/otherlibs/labltk/support/cltkEvent.c
+++ /dev/null
@@ -1,55 +0,0 @@
-/***********************************************************************/
-/* */
-/* MLTk, Tcl/Tk interface of Objective Caml */
-/* */
-/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */
-/* projet Cristal, INRIA Rocquencourt */
-/* Jacques Garrigue, Kyoto University RIMS */
-/* */
-/* Copyright 2002 Institut National de Recherche en Informatique et */
-/* en Automatique and Kyoto University. All rights reserved. */
-/* This file is distributed under the terms of the GNU Library */
-/* General Public License, with the special exception on linking */
-/* described in file LICENSE found in the Objective Caml source tree. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <tcl.h>
-#include <tk.h>
-#include <mlvalues.h>
-#include <alloc.h>
-#include "camltk.h"
-
-CAMLprim value camltk_tk_mainloop(void)
-{
- CheckInit();
-
- if (cltk_slave_mode) return Val_unit;
-
- if (!signal_events) {
- /* Initialise signal handling */
- signal_events = 1;
- Tk_CreateTimerHandler(100, invoke_pending_caml_signals, NULL);
- }
- Tk_MainLoop();
- return Val_unit;
-}
-
-/* Note: this HAS to be reported "as-is" in ML source */
-static int event_flag_table[] = {
- TK_DONT_WAIT, TK_X_EVENTS, TK_FILE_EVENTS, TK_TIMER_EVENTS, TK_IDLE_EVENTS,
- TK_ALL_EVENTS
-};
-
-CAMLprim value camltk_dooneevent(value flags)
-{
- int ret;
-
- CheckInit();
-
- ret = Tk_DoOneEvent(convert_flag_list(flags, event_flag_table));
- return Val_int(ret);
-}
-
diff --git a/otherlibs/labltk/support/cltkFile.c b/otherlibs/labltk/support/cltkFile.c
deleted file mode 100644
index 9ea6004edf..0000000000
--- a/otherlibs/labltk/support/cltkFile.c
+++ /dev/null
@@ -1,158 +0,0 @@
-/***********************************************************************/
-/* */
-/* MLTk, Tcl/Tk interface of Objective Caml */
-/* */
-/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */
-/* projet Cristal, INRIA Rocquencourt */
-/* Jacques Garrigue, Kyoto University RIMS */
-/* */
-/* Copyright 2002 Institut National de Recherche en Informatique et */
-/* en Automatique and Kyoto University. All rights reserved. */
-/* This file is distributed under the terms of the GNU Library */
-/* General Public License, with the special exception on linking */
-/* described in file LICENSE found in the Objective Caml source tree. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#ifdef __CYGWIN__
-#define _WIN32
-#endif
-
-#ifdef _WIN32
-#include <wtypes.h>
-#include <winbase.h>
-#include <winsock.h>
-#endif
-#include <tcl.h>
-#include <tk.h>
-#include <mlvalues.h>
-#include <callback.h>
-#include "camltk.h"
-
-/*
- * File descriptor callbacks
- */
-
-void FileProc(ClientData clientdata, int mask)
-{
- callback2(*handler_code,Val_int(clientdata),Val_int(0));
-}
-
-/* Map Unix.file_descr values to Tcl file handles */
-
-#ifndef _WIN32
-
-/* Under Unix, we use file handlers */
-
-/* Map Unix.file_descr values to Tcl file handles (for tcl 7)
- or Unix file descriptors (for tcl 8). */
-
-#if (TCL_MAJOR_VERSION < 8)
-static Tcl_File tcl_filehandle(value fd)
-{
- return Tcl_GetFile((ClientData)Long_val(fd), TCL_UNIX_FD);
-}
-#else
-#define tcl_filehandle(fd) Int_val(fd)
-#define Tcl_File int
-#endif
-
-CAMLprim value camltk_add_file_input(value fd, value cbid)
-{
- CheckInit();
- Tcl_CreateFileHandler(tcl_filehandle(fd), TCL_READABLE,
- FileProc, (ClientData)(Long_val(cbid)));
- return Val_unit;
-}
-
-/* We have to free the Tcl handle when we are finished using it (Tcl
- * asks us to, and moreover it is probably dangerous to keep the same
- * handle over two allocations of the same fd by the kernel).
- * But we don't know when we are finished with the fd, so we free it
- * in rem_file (it doesn't close the fd anyway). For fds for which we
- * repeatedly add/rem, this will cause some overhead.
- */
-CAMLprim value camltk_rem_file_input(value fd, value cbid)
-{
- Tcl_File fh = tcl_filehandle(fd);
- Tcl_DeleteFileHandler(fh);
-#if (TCL_MAJOR_VERSION < 8)
- Tcl_FreeFile(fh);
-#endif
- return Val_unit;
-}
-
-CAMLprim value camltk_add_file_output(value fd, value cbid)
-{
- CheckInit();
- Tcl_CreateFileHandler(tcl_filehandle(fd), TCL_WRITABLE,
- FileProc, (ClientData) (Long_val(cbid)));
- return Val_unit;
-}
-
-CAMLprim value camltk_rem_file_output(value fd, value cbid)
-{
- Tcl_File fh = tcl_filehandle(fd);
- Tcl_DeleteFileHandler(fh);
-#if (TCL_MAJOR_VERSION < 8)
- Tcl_FreeFile(fh);
-#endif
- return Val_unit;
-}
-
-#else
-
-/* Under Win32, we go through the generic channel abstraction */
-
-#define Handle_val(v) (*((HANDLE *) Data_custom_val(v)))
-
-/* Map Unix.file_descr values to Tcl channels */
-
-static Tcl_Channel tcl_channel(value fd, int flags)
-{
- HANDLE h = Handle_val(fd);
- int optval, optsize;
-
- optsize = sizeof(optval);
- if (getsockopt((SOCKET) h, SOL_SOCKET, SO_TYPE,
- (char *)&optval, &optsize) == 0)
- return Tcl_MakeTcpClientChannel((ClientData) h);
- else
- return Tcl_MakeFileChannel((ClientData) h, flags);
-}
-
-CAMLprim value camltk_add_file_input(value fd, value cbid)
-{
- CheckInit();
- Tcl_CreateChannelHandler(tcl_channel(fd, TCL_READABLE),
- TCL_READABLE,
- FileProc, (ClientData) (Int_val(cbid)));
- return Val_unit;
-}
-
-CAMLprim value camltk_rem_file_input(value fd, value cbid)
-{
- Tcl_DeleteChannelHandler(tcl_channel(fd, TCL_READABLE),
- FileProc, (ClientData) (Int_val(cbid)));
- return Val_unit;
-}
-
-CAMLprim value camltk_add_file_output(value fd, value cbid)
-{
- CheckInit();
- Tcl_CreateChannelHandler(tcl_channel(fd, TCL_WRITABLE),
- TCL_WRITABLE,
- FileProc, (ClientData) (Int_val(cbid)));
- return Val_unit;
-}
-
-CAMLprim value camltk_rem_file_output(value fd, value cbid)
-{
- Tcl_DeleteChannelHandler(tcl_channel(fd, TCL_WRITABLE),
- FileProc, (ClientData) (Int_val(cbid)));
- return Val_unit;
-}
-
-#endif
diff --git a/otherlibs/labltk/support/cltkImg.c b/otherlibs/labltk/support/cltkImg.c
deleted file mode 100644
index 1debe822e5..0000000000
--- a/otherlibs/labltk/support/cltkImg.c
+++ /dev/null
@@ -1,115 +0,0 @@
-/***********************************************************************/
-/* */
-/* MLTk, Tcl/Tk interface of Objective Caml */
-/* */
-/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */
-/* projet Cristal, INRIA Rocquencourt */
-/* Jacques Garrigue, Kyoto University RIMS */
-/* */
-/* Copyright 2002 Institut National de Recherche en Informatique et */
-/* en Automatique and Kyoto University. All rights reserved. */
-/* This file is distributed under the terms of the GNU Library */
-/* General Public License, with the special exception on linking */
-/* described in file LICENSE found in the Objective Caml source tree. */
-/* */
-/***********************************************************************/
-#include <string.h>
-#include <tcl.h>
-#include <tk.h>
-#include <mlvalues.h>
-#include <memory.h>
-#include <alloc.h>
-#include "camltk.h"
-
-/*
- * Pixmap manipulation from OCaml : get the pixmap from an arbitrary photo
- * image, and put it back in some (possibly other) image.
- * TODO: other blits
- * We use the same format of "internal" pixmap data as in Tk, that is
- * 24 bits per pixel
- */
-
-CAMLprim value camltk_getimgdata (value imgname) /* ML */
-{
- CAMLparam1(imgname);
- CAMLlocal1(res);
- Tk_PhotoHandle ph;
- Tk_PhotoImageBlock pib;
- int code,size;
-
-#if (TK_MAJOR_VERSION < 8)
- if (NULL == (ph = Tk_FindPhoto(String_val(imgname))))
- tk_error("no such image");
-#else
- if (NULL == (ph = Tk_FindPhoto(cltclinterp, String_val(imgname))))
- tk_error("no such image");
-#endif
-
- code = Tk_PhotoGetImage(ph,&pib); /* never fails ? */
- size = pib.width * pib.height * pib.pixelSize;
- res = alloc_string(size);
-
- /* no holes, default format ? */
- if ((pib.pixelSize == 3) &&
- (pib.pitch == (pib.width * pib.pixelSize)) &&
- (pib.offset[0] == 0) &&
- (pib.offset[1] == 1) &&
- (pib.offset[2] == 2)) {
- memcpy(pib.pixelPtr, String_val(res),size);
- CAMLreturn(res);
- } else {
- int y; /* varies from 0 to height - 1 */
- int yoffs = 0; /* byte offset of line in src */
- int yidx = 0; /* byte offset of line in dst */
- for (y=0; y<pib.height; y++,yoffs+=pib.pitch,yidx+=pib.width * 3) {
- int x; /* varies from 0 to width - 1 */
- int xoffs = yoffs; /* byte offset of pxl in src */
- int xidx = yidx; /* byte offset of pxl in dst */
- for (x=0; x<pib.width; x++,xoffs+=pib.pixelSize,xidx+=3) {
- Byte(res, xidx) = pib.pixelPtr[xoffs+pib.offset[0]];
- Byte(res, xidx + 1) = pib.pixelPtr[xoffs+pib.offset[1]];
- Byte(res, xidx + 2) = pib.pixelPtr[xoffs+pib.offset[2]];
- };
- }
- CAMLreturn(res);
- }
-}
-
-CAMLprim void
-camltk_setimgdata_native (value imgname, value pixmap, value x, value y,
- value w, value h) /* ML */
-{
- Tk_PhotoHandle ph;
- Tk_PhotoImageBlock pib;
- int code;
-
-#if (TK_MAJOR_VERSION < 8)
- if (NULL == (ph = Tk_FindPhoto(String_val(imgname))))
- tk_error("no such image");
-#else
- if (NULL == (ph = Tk_FindPhoto(cltclinterp, String_val(imgname))))
- tk_error("no such image");
-#endif
-
- pib.pixelPtr = String_val(pixmap);
- pib.width = Int_val(w);
- pib.height = Int_val(h);
- pib.pitch = pib.width * 3;
- pib.pixelSize = 3;
- pib.offset[0] = 0;
- pib.offset[1] = 1;
- pib.offset[2] = 2;
- Tk_PhotoPutBlock(ph,&pib,Int_val(x),Int_val(y),Int_val(w),Int_val(h)
-#if (TK_MAJOR_VERSION == 8 && TK_MINOR_VERSION >= 4 || TK_MAJOR_VERSION > 8)
- , TK_PHOTO_COMPOSITE_SET
-#endif
- );
-}
-
-CAMLprim void camltk_setimgdata_bytecode(argv,argn)
- value *argv;
- int argn;
-{
- camltk_setimgdata_native(argv[0], argv[1], argv[2], argv[3],
- argv[4], argv[5]);
-}
diff --git a/otherlibs/labltk/support/cltkMain.c b/otherlibs/labltk/support/cltkMain.c
deleted file mode 100644
index 6a3a35641b..0000000000
--- a/otherlibs/labltk/support/cltkMain.c
+++ /dev/null
@@ -1,181 +0,0 @@
-/***********************************************************************/
-/* */
-/* MLTk, Tcl/Tk interface of Objective Caml */
-/* */
-/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */
-/* projet Cristal, INRIA Rocquencourt */
-/* Jacques Garrigue, Kyoto University RIMS */
-/* */
-/* Copyright 2002 Institut National de Recherche en Informatique et */
-/* en Automatique and Kyoto University. All rights reserved. */
-/* This file is distributed under the terms of the GNU Library */
-/* General Public License, with the special exception on linking */
-/* described in file LICENSE found in the Objective Caml source tree. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <string.h>
-#include <tcl.h>
-#include <tk.h>
-#include <mlvalues.h>
-#include <memory.h>
-#include <alloc.h>
-#include <callback.h>
-#include <signals.h>
-#include <fail.h>
-#ifdef HAS_UNISTD
-#include <unistd.h> /* for R_OK */
-#endif
-#include "camltk.h"
-
-#ifndef R_OK
-#define R_OK 4
-#endif
-
-/*
- * Dealing with signals: when a signal handler is defined in Caml,
- * the actual execution of the signal handler upon reception of the
- * signal is delayed until we are sure we are out of the GC.
- * If a signal occurs during the MainLoop, we would have to wait
- * the next event for the handler to be invoked.
- * The following function will invoke a pending signal handler if any,
- * and we put in on a regular timer.
- */
-
-#define SIGNAL_INTERVAL 300
-
-int signal_events = 0; /* do we have a pending timer */
-
-void invoke_pending_caml_signals (ClientData clientdata)
-{
- signal_events = 0;
- enter_blocking_section(); /* triggers signal handling */
- /* Rearm timer */
- Tk_CreateTimerHandler(SIGNAL_INTERVAL, invoke_pending_caml_signals, NULL);
- signal_events = 1;
- leave_blocking_section();
-}
-
-/* Now the real Tk stuff */
-
-Tk_Window cltk_mainWindow;
-
-
-/* In slave mode, the interpreter *already* exists */
-int cltk_slave_mode = 0;
-
-/* Initialisation, based on tkMain.c */
-CAMLprim value camltk_opentk(value argv)
-{
- CAMLparam1(argv);
- CAMLlocal1(tmp);
- char *argv0;
-
- /* argv must contain argv[0], the application command name */
- tmp = Val_unit;
-
- if ( argv == Val_int(0) ){
- failwith("camltk_opentk: argv is empty");
- }
- argv0 = String_val( Field( argv, 0 ) );
-
- if (!cltk_slave_mode) {
- /* Create an interpreter, dies if error */
-#if TCL_MAJOR_VERSION >= 8
- Tcl_FindExecutable(String_val(argv0));
-#endif
- cltclinterp = Tcl_CreateInterp();
- {
- /* Register cltclinterp for use in other related extensions */
- value *interp = caml_named_value("cltclinterp");
- if (interp != NULL)
- Store_field(*interp,0,copy_nativeint((long)cltclinterp));
- }
-
- if (Tcl_Init(cltclinterp) != TCL_OK)
- tk_error(cltclinterp->result);
- Tcl_SetVar(cltclinterp, "argv0", String_val (argv0), TCL_GLOBAL_ONLY);
-
- { /* Sets argv */
- int argc = 0;
-
- tmp = Field(argv, 1); /* starts from argv[1] */
- while ( tmp != Val_int(0) ) {
- argc++;
- tmp = Field(tmp, 1);
- }
-
- if( argc != 0 ){
- int i;
- char *args;
- char **tkargv;
- char argcstr[256]; /* string of argc */
-
- tkargv = (char**)stat_alloc(sizeof( char* ) * argc );
- tmp = Field(argv, 1); /* starts from argv[1] */
- i = 0;
-
- while ( tmp != Val_int(0) ) {
- tkargv[i] = String_val(Field(tmp, 0));
- tmp = Field(tmp, 1);
- i++;
- }
-
- sprintf( argcstr, "%d", argc );
- Tcl_SetVar(cltclinterp, "argc", argcstr, TCL_GLOBAL_ONLY);
- args = Tcl_Merge(argc, tkargv); /* args must be freed by Tcl_Free */
- Tcl_SetVar(cltclinterp, "argv", args, TCL_GLOBAL_ONLY);
- Tcl_Free(args);
- stat_free( tkargv );
- }
- }
- if (Tk_Init(cltclinterp) != TCL_OK)
- tk_error(cltclinterp->result);
-
- /* Retrieve the main window */
- cltk_mainWindow = Tk_MainWindow(cltclinterp);
-
- if (NULL == cltk_mainWindow)
- tk_error(cltclinterp->result);
-
- Tk_GeometryRequest(cltk_mainWindow,200,200);
- }
-
- /* Create the camlcallback command */
- Tcl_CreateCommand(cltclinterp,
- CAMLCB, CamlCBCmd,
- (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);
-
- /* This is required by "unknown" and thus autoload */
- Tcl_SetVar(cltclinterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
- /* Our hack for implementing break in callbacks */
- Tcl_SetVar(cltclinterp, "BreakBindingsSequence", "0", TCL_GLOBAL_ONLY);
-
- /* Load the traditional rc file */
- {
- char *home = getenv("HOME");
- if (home != NULL) {
- char *f = stat_alloc(strlen(home)+strlen(RCNAME)+2);
- f[0]='\0';
- strcat(f, home);
- strcat(f, "/");
- strcat(f, RCNAME);
- if (0 == access(f,R_OK))
- if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) {
- stat_free(f);
- tk_error(cltclinterp->result);
- };
- stat_free(f);
- }
- }
-
- CAMLreturn(Val_unit);
-}
-
-CAMLprim value camltk_finalize(value unit) /* ML */
-{
- Tcl_Finalize();
- return Val_unit;
-}
diff --git a/otherlibs/labltk/support/cltkMisc.c b/otherlibs/labltk/support/cltkMisc.c
deleted file mode 100644
index e9824b6e9e..0000000000
--- a/otherlibs/labltk/support/cltkMisc.c
+++ /dev/null
@@ -1,64 +0,0 @@
-/***********************************************************************/
-/* */
-/* MLTk, Tcl/Tk interface of Objective Caml */
-/* */
-/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */
-/* projet Cristal, INRIA Rocquencourt */
-/* Jacques Garrigue, Kyoto University RIMS */
-/* */
-/* Copyright 2002 Institut National de Recherche en Informatique et */
-/* en Automatique and Kyoto University. All rights reserved. */
-/* This file is distributed under the terms of the GNU Library */
-/* General Public License, with the special exception on linking */
-/* described in file LICENSE found in the Objective Caml source tree. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <string.h>
-#include <tcl.h>
-#include <tk.h>
-#include <mlvalues.h>
-#include <memory.h>
-#include "camltk.h"
-
-/* Parsing results */
-CAMLprim value camltk_splitlist (value v)
-{
- int argc;
- char **argv;
- int result;
- char *utf;
-
- CheckInit();
-
- utf = caml_string_to_tcl(v);
- /* argv is allocated by Tcl, to be freed by us */
- result = Tcl_SplitList(cltclinterp,utf,&argc,&argv);
- switch(result) {
- case TCL_OK:
- { value res = copy_string_list(argc,argv);
- Tcl_Free((char *)argv); /* only one large block was allocated */
- /* argv points into utf: utf must be freed after argv are freed */
- stat_free( utf );
- return res;
- }
- case TCL_ERROR:
- default:
- stat_free( utf );
- tk_error(cltclinterp->result);
- }
-}
-
-/* Copy a Caml string to the C heap. Should deallocate with stat_free */
-char *string_to_c(value s)
-{
- int l = string_length(s);
- char *res = stat_alloc(l + 1);
- memmove (res, String_val (s), l);
- res[l] = '\0';
- return res;
-}
-
-
diff --git a/otherlibs/labltk/support/cltkTimer.c b/otherlibs/labltk/support/cltkTimer.c
deleted file mode 100644
index 21f1b15885..0000000000
--- a/otherlibs/labltk/support/cltkTimer.c
+++ /dev/null
@@ -1,45 +0,0 @@
-/***********************************************************************/
-/* */
-/* MLTk, Tcl/Tk interface of Objective Caml */
-/* */
-/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */
-/* projet Cristal, INRIA Rocquencourt */
-/* Jacques Garrigue, Kyoto University RIMS */
-/* */
-/* Copyright 2002 Institut National de Recherche en Informatique et */
-/* en Automatique and Kyoto University. All rights reserved. */
-/* This file is distributed under the terms of the GNU Library */
-/* General Public License, with the special exception on linking */
-/* described in file LICENSE found in the Objective Caml source tree. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <tcl.h>
-#include <tk.h>
-#include <mlvalues.h>
-#include <callback.h>
-#include "camltk.h"
-
-
-/* Basically the same thing as FileProc */
-void TimerProc (ClientData clientdata)
-{
- callback2(*handler_code,Val_long(clientdata),Val_int(0));
-}
-
-CAMLprim value camltk_add_timer(value milli, value cbid)
-{
- CheckInit();
- /* look at tkEvent.c , Tk_Token is an int */
- return (Val_int(Tcl_CreateTimerHandler(Int_val(milli), TimerProc,
- (ClientData) (Int_val(cbid)))));
-}
-
-CAMLprim value camltk_rem_timer(value token)
-{
- Tcl_DeleteTimerHandler((Tcl_TimerToken) Int_val(token));
- return Val_unit;
-}
-
diff --git a/otherlibs/labltk/support/cltkUtf.c b/otherlibs/labltk/support/cltkUtf.c
deleted file mode 100644
index fd01bd15a4..0000000000
--- a/otherlibs/labltk/support/cltkUtf.c
+++ /dev/null
@@ -1,89 +0,0 @@
-/***********************************************************************/
-/* */
-/* MLTk, Tcl/Tk interface of Objective Caml */
-/* */
-/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */
-/* projet Cristal, INRIA Rocquencourt */
-/* Jacques Garrigue, Kyoto University RIMS */
-/* */
-/* Copyright 2002 Institut National de Recherche en Informatique et */
-/* en Automatique and Kyoto University. All rights reserved. */
-/* This file is distributed under the terms of the GNU Library */
-/* General Public License, with the special exception on linking */
-/* described in file LICENSE found in the Objective Caml source tree. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <stdlib.h>
-#include <string.h>
-
-#include <tcl.h>
-#include <tk.h>
-#include <mlvalues.h>
-#include <alloc.h>
-#include <memory.h>
-#ifdef HAS_UNISTD
-#include <unistd.h>
-#endif
-#include "camltk.h"
-
-#if (TCL_MAJOR_VERSION > 8 || \
- (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1)) /* 8.1 */
-# define UTFCONVERSION
-#endif
-
-#ifdef UTFCONVERSION
-
-char *external_to_utf( char *str ){
- char *res;
- Tcl_DString dstr;
- int length;
-
- Tcl_ExternalToUtfDString(NULL, str, strlen(str), &dstr);
- length = Tcl_DStringLength(&dstr);
- res = stat_alloc(length + 1);
- memmove( res, Tcl_DStringValue(&dstr), length+1);
- Tcl_DStringFree(&dstr);
-
- return res;
-}
-
-char *utf_to_external( char *str ){
- char *res;
- Tcl_DString dstr;
- int length;
-
- Tcl_UtfToExternalDString(NULL, str, strlen(str), &dstr);
- length = Tcl_DStringLength(&dstr);
- res = stat_alloc(length + 1);
- memmove( res, Tcl_DStringValue(&dstr), length+1);
- Tcl_DStringFree(&dstr);
-
- return res;
-}
-
-char *caml_string_to_tcl( value s )
-{
- return external_to_utf( String_val(s) );
-}
-
-value tcl_string_to_caml( char *s )
-{
- CAMLparam0();
- CAMLlocal1(res);
- char *str;
-
- str = utf_to_external( s );
- res = copy_string(str);
- stat_free(str);
- CAMLreturn(res);
-}
-
-#else
-
-char *caml_string_to_tcl(value s){ return string_to_c(s); }
-value tcl_string_to_caml(char *s){ return copy_string(s); }
-
-#endif
diff --git a/otherlibs/labltk/support/cltkVar.c b/otherlibs/labltk/support/cltkVar.c
deleted file mode 100644
index 83fedbafd4..0000000000
--- a/otherlibs/labltk/support/cltkVar.c
+++ /dev/null
@@ -1,128 +0,0 @@
-/***********************************************************************/
-/* */
-/* MLTk, Tcl/Tk interface of Objective Caml */
-/* */
-/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */
-/* projet Cristal, INRIA Rocquencourt */
-/* Jacques Garrigue, Kyoto University RIMS */
-/* */
-/* Copyright 2002 Institut National de Recherche en Informatique et */
-/* en Automatique and Kyoto University. All rights reserved. */
-/* This file is distributed under the terms of the GNU Library */
-/* General Public License, with the special exception on linking */
-/* described in file LICENSE found in the Objective Caml source tree. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Alternative to tkwait variable */
-#include <string.h>
-#include <tcl.h>
-#include <tk.h>
-#include <mlvalues.h>
-#include <memory.h>
-#include <alloc.h>
-#include <callback.h>
-#include "camltk.h"
-
-CAMLprim value camltk_getvar(value var)
-{
- char *s;
- char *stable_var = NULL;
- CheckInit();
-
- stable_var = string_to_c(var);
- s = Tcl_GetVar(cltclinterp,stable_var,
- TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
- stat_free(stable_var);
-
- if (s == NULL)
- tk_error(cltclinterp->result);
- else
- return(tcl_string_to_caml(s));
-}
-
-CAMLprim value camltk_setvar(value var, value contents)
-{
- char *s;
- char *stable_var = NULL;
- char *utf_contents;
- CheckInit();
-
- /* SetVar makes a copy of the contents. */
- /* In case we have write traces in Caml, it's better to make sure that
- var doesn't move... */
- stable_var = string_to_c(var);
- utf_contents = caml_string_to_tcl(contents);
- s = Tcl_SetVar(cltclinterp,stable_var, utf_contents,
- TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
- stat_free(stable_var);
- if( s == utf_contents ){
- tk_error("camltk_setvar: Tcl_SetVar returned strange result. Call the author of mlTk!");
- }
- stat_free(utf_contents);
-
- if (s == NULL)
- tk_error(cltclinterp->result);
- else
- return(Val_unit);
-}
-
-
-/* The appropriate type is
-typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, char *part1, char *part2, int flags));
- */
-static char * tracevar(clientdata, interp, name1, name2, flags)
- ClientData clientdata;
- Tcl_Interp *interp; /* Interpreter containing variable. */
- char *name1; /* Name of variable. */
- char *name2; /* Second part of variable name. */
- int flags; /* Information about what happened. */
-{
- Tcl_UntraceVar2(interp, name1, name2,
- TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- tracevar, clientdata);
- callback2(*handler_code,Val_int(clientdata),Val_unit);
- return (char *)NULL;
-}
-
-/* Sets up a callback upon modification of a variable */
-CAMLprim value camltk_trace_var(value var, value cbid)
-{
- char *cvar = NULL;
-
- CheckInit();
- /* Make a copy of var, since Tcl will modify it in place, and we
- * don't trust that much what it will do here
- */
- cvar = string_to_c(var);
- if (Tcl_TraceVar(cltclinterp, cvar,
- TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- tracevar,
- (ClientData) (Long_val(cbid)))
- != TCL_OK) {
- stat_free(cvar);
- tk_error(cltclinterp->result);
- };
- stat_free(cvar);
- return Val_unit;
-}
-
-CAMLprim value camltk_untrace_var(value var, value cbid)
-{
- char *cvar = NULL;
-
- CheckInit();
- /* Make a copy of var, since Tcl will modify it in place, and we
- * don't trust that much what it will do here
- */
- cvar = string_to_c(var);
- Tcl_UntraceVar(cltclinterp, cvar,
- TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- tracevar,
- (ClientData) (Long_val(cbid)));
- stat_free(cvar);
- return Val_unit;
-}
diff --git a/otherlibs/labltk/support/cltkWait.c b/otherlibs/labltk/support/cltkWait.c
deleted file mode 100644
index 7c3cef53fd..0000000000
--- a/otherlibs/labltk/support/cltkWait.c
+++ /dev/null
@@ -1,102 +0,0 @@
-/***********************************************************************/
-/* */
-/* MLTk, Tcl/Tk interface of Objective Caml */
-/* */
-/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */
-/* projet Cristal, INRIA Rocquencourt */
-/* Jacques Garrigue, Kyoto University RIMS */
-/* */
-/* Copyright 2002 Institut National de Recherche en Informatique et */
-/* en Automatique and Kyoto University. All rights reserved. */
-/* This file is distributed under the terms of the GNU Library */
-/* General Public License, with the special exception on linking */
-/* described in file LICENSE found in the Objective Caml source tree. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <tcl.h>
-#include <tk.h>
-#include <mlvalues.h>
-#include <memory.h>
-#include <callback.h>
-#include "camltk.h"
-
-/* The following are replacements for
- tkwait visibility
- tkwait window
- in the case where we use threads (tkwait internally calls an event loop,
- and thus prevents thread scheduling from taking place).
-
- Instead, one should set up a callback, wait for a signal, and signal
- from inside the callback
-*/
-
-static void WaitVisibilityProc _ANSI_ARGS_((ClientData clientData,
- XEvent *eventPtr));
-static void WaitWindowProc _ANSI_ARGS_((ClientData clientData,
- XEvent *eventPtr));
-
-/* For the other handlers, we need a bit more data */
-struct WinCBData {
- int cbid;
- Tk_Window win;
-};
-
-static void WaitVisibilityProc(clientData, eventPtr)
- ClientData clientData;
- XEvent *eventPtr; /* Information about event (not used). */
-{
- struct WinCBData *vis = clientData;
- value cbid = Val_int(vis->cbid);
-
- Tk_DeleteEventHandler(vis->win, VisibilityChangeMask,
- WaitVisibilityProc, clientData);
-
- stat_free((char *)vis);
- callback2(*handler_code,cbid,Val_int(0));
-}
-
-/* Sets up a callback upon Visibility of a window */
-CAMLprim value camltk_wait_vis(value win, value cbid)
-{
- struct WinCBData *vis =
- (struct WinCBData *)stat_alloc(sizeof(struct WinCBData));
- vis->win = Tk_NameToWindow(cltclinterp, String_val(win), cltk_mainWindow);
- if (vis -> win == NULL) {
- stat_free((char *)vis);
- tk_error(cltclinterp->result);
- };
- vis->cbid = Int_val(cbid);
- Tk_CreateEventHandler(vis->win, VisibilityChangeMask,
- WaitVisibilityProc, (ClientData) vis);
- return Val_unit;
-}
-
-static void WaitWindowProc(ClientData clientData, XEvent *eventPtr)
-{
- if (eventPtr->type == DestroyNotify) {
- struct WinCBData *vis = clientData;
- value cbid = Val_int(vis->cbid);
- stat_free((char *)clientData);
- /* The handler is destroyed by Tk itself */
- callback2(*handler_code,cbid,Val_int(0));
- }
-}
-
-/* Sets up a callback upon window destruction */
-CAMLprim value camltk_wait_des(value win, value cbid)
-{
- struct WinCBData *vis =
- (struct WinCBData *)stat_alloc(sizeof(struct WinCBData));
- vis->win = Tk_NameToWindow(cltclinterp, String_val(win), cltk_mainWindow);
- if (vis -> win == NULL) {
- stat_free((char *)vis);
- tk_error(cltclinterp->result);
- };
- vis->cbid = Int_val(cbid);
- Tk_CreateEventHandler(vis->win, StructureNotifyMask,
- WaitWindowProc, (ClientData) vis);
- return Val_unit;
-}
diff --git a/otherlibs/labltk/support/fileevent.ml b/otherlibs/labltk/support/fileevent.ml
deleted file mode 100644
index 9d985147c9..0000000000
--- a/otherlibs/labltk/support/fileevent.ml
+++ /dev/null
@@ -1,81 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Unix
-open Support
-open Protocol
-
-external add_file_input : file_descr -> cbid -> unit
- = "camltk_add_file_input"
-external rem_file_input : file_descr -> cbid -> unit
- = "camltk_rem_file_input"
-external add_file_output : file_descr -> cbid -> unit
- = "camltk_add_file_output"
-external rem_file_output : file_descr -> cbid -> unit
- = "camltk_rem_file_output"
-
-(* File input handlers *)
-
-let fd_table = Hashtbl.create 37 (* Avoid space leak in callback table *)
-
-let add_fileinput ~fd ~callback:f =
- let id = new_function_id () in
- Hashtbl.add callback_naming_table id (fun _ -> f());
- Hashtbl.add fd_table (fd, 'r') id;
- if !Protocol.debug then begin
- Protocol.prerr_cbid id; prerr_endline " for fileinput"
- end;
- add_file_input fd id
-
-let remove_fileinput ~fd =
- try
- let id = Hashtbl.find fd_table (fd, 'r') in
- clear_callback id;
- Hashtbl.remove fd_table (fd, 'r');
- if !Protocol.debug then begin
- prerr_string "clear ";
- Protocol.prerr_cbid id;
- prerr_endline " for fileinput"
- end;
- rem_file_input fd id
- with
- Not_found -> ()
-
-let add_fileoutput ~fd ~callback:f =
- let id = new_function_id () in
- Hashtbl.add callback_naming_table id (fun _ -> f());
- Hashtbl.add fd_table (fd, 'w') id;
- if !Protocol.debug then begin
- Protocol.prerr_cbid id; prerr_endline " for fileoutput"
- end;
- add_file_output fd id
-
-let remove_fileoutput ~fd =
- try
- let id = Hashtbl.find fd_table (fd, 'w') in
- clear_callback id;
- Hashtbl.remove fd_table (fd, 'w');
- if !Protocol.debug then begin
- prerr_string "clear ";
- Protocol.prerr_cbid id;
- prerr_endline " for fileoutput"
- end;
- rem_file_output fd id
- with
- Not_found -> ()
-
diff --git a/otherlibs/labltk/support/fileevent.mli b/otherlibs/labltk/support/fileevent.mli
deleted file mode 100644
index 34760f0c7e..0000000000
--- a/otherlibs/labltk/support/fileevent.mli
+++ /dev/null
@@ -1,25 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Unix
-
-val add_fileinput : fd:file_descr -> callback:(unit -> unit) -> unit
-val remove_fileinput: fd:file_descr -> unit
-val add_fileoutput : fd:file_descr -> callback:(unit -> unit) -> unit
-val remove_fileoutput: fd:file_descr -> unit
- (* see [tk] module *)
diff --git a/otherlibs/labltk/support/protocol.ml b/otherlibs/labltk/support/protocol.ml
deleted file mode 100644
index 6e3208cfe7..0000000000
--- a/otherlibs/labltk/support/protocol.ml
+++ /dev/null
@@ -1,276 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Support
-open Widget
-
-type callback_buffer = string list
- (* Buffer for reading callback arguments *)
-
-type tkArgs =
- TkToken of string
- | TkTokenList of tkArgs list (* to be expanded *)
- | TkQuote of tkArgs (* mapped to Tcl list *)
-
-type cbid = int
-
-external opentk_low : string list -> unit
- = "camltk_opentk"
-external tcl_eval : string -> string
- = "camltk_tcl_eval"
-external tk_mainloop : unit -> unit
- = "camltk_tk_mainloop"
-external tcl_direct_eval : tkArgs array -> string
- = "camltk_tcl_direct_eval"
-external splitlist : string -> string list
- = "camltk_splitlist"
-external tkreturn : string -> unit
- = "camltk_return"
-external callback_init : unit -> unit
- = "camltk_init"
-external finalizeTk : unit -> unit
- = "camltk_finalize"
- (* Finalize tcl/tk before exiting. This function will be automatically
- called when you call [Pervasives.exit ()] (This is installed at
- [install_cleanup ()] *)
-
-let tcl_command s = ignore (tcl_eval s);;
-
-exception TkError of string
- (* Raised by the communication functions *)
-let () = Callback.register_exception "tkerror" (TkError "")
-
-let cltclinterp = ref Nativeint.zero
- (* For use in other extensions *)
-let () = Callback.register "cltclinterp" cltclinterp
-
-(* Debugging support *)
-let debug =
- ref (try ignore (Sys.getenv "CAMLTKDEBUG"); true
- with Not_found -> false)
-
-(* This is approximative, since we don't quote what needs to be quoted *)
-let dump_args args =
- let rec print_arg = function
- TkToken s -> prerr_string s; prerr_string " "
- | TkTokenList l -> List.iter print_arg l
- | TkQuote a -> prerr_string "{"; print_arg a; prerr_string "} "
- in
- Array.iter print_arg args;
- prerr_newline()
-
-(*
- * Evaluating Tcl code
- * debugging support should not affect performances...
- *)
-
-let tkEval args =
- if !debug then dump_args args;
- let res = tcl_direct_eval args in
- if !debug then begin
- prerr_string "->>";
- prerr_endline res
- end;
- res
-
-let tkCommand args = ignore (tkEval args)
-
-(*
- * Callbacks
- *)
-
-(* LablTk only *)
-let cCAMLtoTKwidget w =
- (* Widget.check_class w table; (* with subtyping, it is redundant *) *)
- TkToken (Widget.name w)
-
-let cTKtoCAMLwidget = function
- "" -> raise (Invalid_argument "cTKtoCAMLwidget")
- | s -> Widget.get_atom s
-
-let callback_naming_table =
- (Hashtbl.create 401 : (int, callback_buffer -> unit) Hashtbl.t)
-
-let callback_memo_table =
- (Hashtbl.create 401 : (any widget, int) Hashtbl.t)
-
-let new_function_id =
- let counter = ref 0 in
- function () -> incr counter; !counter
-
-let string_of_cbid = string_of_int
-
-(* Add a new callback, associated to widget w *)
-(* The callback should be cleared when w is destroyed *)
-let register_callback w ~callback:f =
- let id = new_function_id () in
- Hashtbl.add callback_naming_table id f;
- if (forget_type w) <> (forget_type Widget.dummy) then
- Hashtbl.add callback_memo_table (forget_type w) id;
- (string_of_cbid id)
-
-let clear_callback id =
- Hashtbl.remove callback_naming_table id
-
-(* Clear callbacks associated to a given widget *)
-let remove_callbacks w =
- let w = forget_type w in
- let cb_ids = Hashtbl.find_all callback_memo_table w in
- List.iter clear_callback cb_ids;
- for i = 1 to List.length cb_ids do
- Hashtbl.remove callback_memo_table w
- done
-
-(* Hand-coded callback for destroyed widgets
- * This may be extended by the application, or by other layers of Camltk.
- * Could use bind + of Tk, but I'd rather give an alternate mechanism so
- * that hooks can be set up at load time (i.e. before openTk)
- *)
-let destroy_hooks = ref []
-let add_destroy_hook f =
- destroy_hooks := f :: !destroy_hooks
-
-let _ =
- add_destroy_hook (fun w -> remove_callbacks w; Widget.remove w)
-
-let install_cleanup () =
- let call_destroy_hooks = function
- [wname] ->
- let w = cTKtoCAMLwidget wname in
- List.iter (fun f -> f w) !destroy_hooks
- | _ -> raise (TkError "bad cleanup callback") in
- let fid = new_function_id () in
- Hashtbl.add callback_naming_table fid call_destroy_hooks;
- (* setup general destroy callback *)
- tcl_command ("bind all <Destroy> {camlcb " ^ (string_of_cbid fid) ^" %W}");
- at_exit finalizeTk
-
-let prerr_cbid id =
- prerr_string "camlcb "; prerr_int id
-
-(* The callback dispatch function *)
-let dispatch_callback id args =
- if !debug then begin
- prerr_cbid id;
- List.iter (fun x -> prerr_string " "; prerr_string x) args;
- prerr_newline()
- end;
- (Hashtbl.find callback_naming_table id) args;
- if !debug then prerr_endline "<<-"
-
-let protected_dispatch id args =
- try
- dispatch_callback id args
- with
- | e ->
- try
- Printf.eprintf "Uncaught exception: %s\n" (Printexc.to_string e);
- flush stderr;
- (* raise x *)
- with
- Out_of_memory -> raise Out_of_memory
- | Sys.Break -> raise Sys.Break
-
-let _ = Callback.register "camlcb" protected_dispatch
-
-(* Make sure the C variables are initialised *)
-let _ = callback_init ()
-
-(* Different version of initialisation functions *)
-let default_display_name = ref ""
-let default_display () = !default_display_name
-
-let camltk_argv = ref []
-
-(* options for Arg.parse *)
-let keywords = [
- "-display", Arg.String (fun s ->
- camltk_argv := "-display" :: s :: !camltk_argv),
- "<disp> : X server to contact (CamlTk)";
- "-colormap", Arg.String (fun s ->
- camltk_argv := "-colormap" :: s :: !camltk_argv),
- "<colormap> : colormap to use (CamlTk)";
- "-geometry", Arg.String (fun s ->
- camltk_argv := "-geometry" :: s :: !camltk_argv),
- "<geom> : size and position (CamlTk)";
- "-name", Arg.String (fun s ->
- camltk_argv := "-name" :: s :: !camltk_argv),
- "<name> : application class (CamlTk)";
- "-sync", Arg.Unit (fun () ->
- camltk_argv := "-sync" :: !camltk_argv),
- ": sync mode (CamlTk)";
- "-use", Arg.String (fun s ->
- camltk_argv := "-use" :: s :: !camltk_argv),
- "<id> : parent window id (CamlTk)";
- "-window", Arg.String (fun s ->
- camltk_argv := "-use" :: s :: !camltk_argv),
- "<id> : parent window id (CamlTk)";
- "-visual", Arg.String (fun s ->
- camltk_argv := "-visual" :: s :: !camltk_argv),
- "<visual> : visual to use (CamlTk)" ]
-
-let opentk_with_args argv (* = [argv1;..;argvn] *) =
- (* argv must be command line for wish *)
- let argv0 = Sys.argv.(0) in
- let rec find_display = function
- | "-display" :: s :: xs -> s
- | "-colormap" :: s :: xs -> find_display xs
- | "-geometry" :: s :: xs -> find_display xs
- | "-name" :: s :: xs -> find_display xs
- | "-sync" :: xs -> find_display xs
- | "-use" :: s :: xs -> find_display xs
- | "-window" :: s :: xs -> find_display xs
- | "-visual" :: s :: xs -> find_display xs
- | "--" :: _ -> ""
- | _ :: xs -> find_display xs
- | [] -> ""
- in
- default_display_name := find_display argv;
- opentk_low (argv0 :: argv);
- install_cleanup();
- Widget.default_toplevel
-
-let opentk () = opentk_with_args !camltk_argv;;
-
-let openTkClass s = opentk_with_args ["-name"; s]
-let openTkDisplayClass disp cl = opentk_with_args ["-display"; disp; "-name"; cl]
-
-(*JPF CAMLTK/LABLTK? *)
-let openTk ?(display = "") ?(clas = "LablTk") () =
- let dispopt =
- match display with
- | "" -> []
- | _ -> ["-display"; display]
- in
- opentk_with_args (dispopt @ ["-name"; clas])
-
-(* Destroy all widgets, thus cleaning up table and exiting the loop *)
-let closeTk () =
- tcl_command "destroy ."
-
-let mainLoop =
- tk_mainloop
-
-
-(* [register tclname f] makes [f] available from Tcl with
- name [tclname] *)
-let register tclname ~callback =
- let s = register_callback Widget.default_toplevel ~callback in
- tcl_command (Printf.sprintf "proc %s {args} {eval {camlcb %s} $args}"
- tclname s)
-
diff --git a/otherlibs/labltk/support/protocol.mli b/otherlibs/labltk/support/protocol.mli
deleted file mode 100644
index fe3ff794f8..0000000000
--- a/otherlibs/labltk/support/protocol.mli
+++ /dev/null
@@ -1,115 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Widget
-
-(* Lower level interface *)
-exception TkError of string
- (* Raised by the communication functions *)
-
-val debug : bool ref
- (* When set to true, displays approximation of intermediate Tcl code *)
-
-type tkArgs =
- TkToken of string
- | TkTokenList of tkArgs list (* to be expanded *)
- | TkQuote of tkArgs (* mapped to Tcl list *)
-
-
-(* Misc *)
-external splitlist : string -> string list
- = "camltk_splitlist"
-
-val add_destroy_hook : (any widget -> unit) -> unit
-
-
-(* Opening, closing, and mainloop *)
-val default_display : unit -> string
-
-val opentk : unit -> toplevel widget
- (* The basic initialization function. *)
-
-val keywords : (string * Arg.spec * string) list
- (* Command line parsing specification for Arg.parse, which contains
- the standard Tcl/Tk command line options such as "-display" and "-name".
- Add [keywords] to a [Arg.parse] call, then call [opentk].
- Then [opentk] can make use of these command line options
- to initiate applications. *)
-
-val opentk_with_args : string list -> toplevel widget
- (* [opentk_with_args] is a lower level interface to initiate Tcl/Tk
- applications. [opentk_with_args argv] initializes Tcl/Tk with
- the command line options given by [argv] *)
-
-val openTk : ?display:string -> ?clas:string -> unit -> toplevel widget
- (* [openTk ~display:display ~clas:clas ()] is equivalent to
- [opentk_with_args ["-display"; display; "-name"; clas]] *)
-
-(* Legacy opentk functions *)
-val openTkClass: string -> toplevel widget
- (* [openTkClass class] is equivalent to [opentk ["-name"; class]] *)
-val openTkDisplayClass: string -> string -> toplevel widget
- (* [openTkDisplayClass disp class] is equivalent to
- [opentk ["-display"; disp; "-name"; class]] *)
-
-val closeTk : unit -> unit
-val finalizeTk : unit -> unit
- (* Finalize tcl/tk before exiting. This function will be automatically
- called when you call [Pervasives.exit ()] *)
-
-val mainLoop : unit -> unit
-
-
-(* Direct evaluation of tcl code *)
-val tkEval : tkArgs array -> string
-
-val tkCommand : tkArgs array -> unit
-
-(* Returning a value from a Tcl callback *)
-val tkreturn: string -> unit
-
-
-(* Callbacks: this is private *)
-
-type cbid
-
-type callback_buffer = string list
- (* Buffer for reading callback arguments *)
-
-val callback_naming_table : (cbid, callback_buffer -> unit) Hashtbl.t
-val callback_memo_table : (any widget, cbid) Hashtbl.t
- (* Exported for debug purposes only. Don't use them unless you
- know what you are doing *)
-val new_function_id : unit -> cbid
-val string_of_cbid : cbid -> string
-val register_callback : 'a widget -> callback:(callback_buffer -> unit) -> string
- (* Callback support *)
-val clear_callback : cbid -> unit
- (* Remove a given callback from the table *)
-val remove_callbacks : 'a widget -> unit
- (* Clean up callbacks associated to widget. Must be used only when
- the Destroy event is bind by the user and masks the default
- Destroy event binding *)
-
-val cTKtoCAMLwidget : string -> any widget
-val cCAMLtoTKwidget : 'a widget -> tkArgs
-
-val register : string -> callback:(callback_buffer -> unit) -> unit
-
-(*-*)
-val prerr_cbid : cbid -> unit
diff --git a/otherlibs/labltk/support/rawwidget.ml b/otherlibs/labltk/support/rawwidget.ml
deleted file mode 100644
index 8eba3b8b14..0000000000
--- a/otherlibs/labltk/support/rawwidget.ml
+++ /dev/null
@@ -1,176 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Support
-
-(*
- * Widgets
- *)
-
-exception IllegalWidgetType of string
- (* Raised when widget command applied illegally*)
-
-(***************************************************)
-(* Widgets *)
-(* This 'a raw_widget will be 'a Widget.widget *)
-(***************************************************)
-type 'a raw_widget =
- Untyped of string
-| Typed of string * string
-
-type raw_any (* will be Widget.any *)
-and button
-and canvas
-and checkbutton
-and entry
-and frame
-and label
-and listbox
-and menu
-and menubutton
-and message
-and radiobutton
-and scale
-and scrollbar
-and text
-and toplevel
-
-let forget_type w = (Obj.magic (w : 'a raw_widget) : raw_any raw_widget)
-let coe = forget_type
-
-(* table of widgets *)
-let table = (Hashtbl.create 401 : (string, raw_any raw_widget) Hashtbl.t)
-
-let name = function
- Untyped s -> s
- | Typed (s,_) -> s
-
-(* Normally all widgets are known *)
-(* this is a provision for send commands to external tk processes *)
-let known_class = function
- Untyped _ -> "unknown"
- | Typed (_,c) -> c
-
-(* This one is always created by opentk *)
-let default_toplevel =
- let wname = "." in
- let w = Typed (wname, "toplevel") in
- Hashtbl.add table wname w;
- w
-
-(* Dummy widget to which global callbacks are associated *)
-(* also passed around by camltotkoption when no widget in context *)
-let dummy =
- Untyped "dummy"
-
-let remove w =
- Hashtbl.remove table (name w)
-
-(* Retype widgets returned from Tk *)
-(* JPF report: sometime s is "", see Protocol.cTKtoCAMLwidget *)
-let get_atom s =
- try
- Hashtbl.find table s
- with
- Not_found -> Untyped s
-
-let naming_scheme = [
- "button", "b";
- "canvas", "ca";
- "checkbutton", "cb";
- "entry", "en";
- "frame", "f";
- "label", "l";
- "listbox", "li";
- "menu", "me";
- "menubutton", "mb";
- "message", "ms";
- "radiobutton", "rb";
- "scale", "sc";
- "scrollbar", "sb";
- "text", "t";
- "toplevel", "top" ]
-
-
-let widget_any_table = List.map fst naming_scheme
-(* subtypes *)
-let widget_button_table = [ "button" ]
-and widget_canvas_table = [ "canvas" ]
-and widget_checkbutton_table = [ "checkbutton" ]
-and widget_entry_table = [ "entry" ]
-and widget_frame_table = [ "frame" ]
-and widget_label_table = [ "label" ]
-and widget_listbox_table = [ "listbox" ]
-and widget_menu_table = [ "menu" ]
-and widget_menubutton_table = [ "menubutton" ]
-and widget_message_table = [ "message" ]
-and widget_radiobutton_table = [ "radiobutton" ]
-and widget_scale_table = [ "scale" ]
-and widget_scrollbar_table = [ "scrollbar" ]
-and widget_text_table = [ "text" ]
-and widget_toplevel_table = [ "toplevel" ]
-
-let new_suffix clas n =
- try
- (List.assoc clas naming_scheme) ^ (string_of_int n)
- with
- Not_found -> "w" ^ (string_of_int n)
-
-(* The function called by generic creation *)
-let counter = ref 0
-let new_atom ~parent ?name:nom clas =
- let parentpath = name parent in
- let path =
- match nom with
- None ->
- incr counter;
- if parentpath = "."
- then "." ^ (new_suffix clas !counter)
- else parentpath ^ "." ^ (new_suffix clas !counter)
- | Some name ->
- if parentpath = "."
- then "." ^ name
- else parentpath ^ "." ^ name
- in
- let w = Typed(path,clas) in
- Hashtbl.add table path w;
- w
-
-(* Just create a path. Only to check existence of widgets *)
-(* Use with care *)
-let atom ~parent ~name:pathcomp =
- let parentpath = name parent in
- let path =
- if parentpath = "."
- then "." ^ pathcomp
- else parentpath ^ "." ^ pathcomp in
- Untyped path
-
-(* LablTk: Redundant with subtyping of Widget, backward compatibility *)
-let check_class w clas =
- match w with
- Untyped _ -> () (* assume run-time check by tk*)
- | Typed(_,c) ->
- if List.mem c clas then ()
- else raise (IllegalWidgetType c)
-
-
-(* Checking membership of constructor in subtype table *)
-let chk_sub errname table c =
- if List.mem c table then ()
- else raise (Invalid_argument errname)
diff --git a/otherlibs/labltk/support/rawwidget.mli b/otherlibs/labltk/support/rawwidget.mli
deleted file mode 100644
index 7a7857dc7e..0000000000
--- a/otherlibs/labltk/support/rawwidget.mli
+++ /dev/null
@@ -1,109 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Support for widget manipulations *)
-
-type 'a raw_widget
- (* widget is an abstract type *)
-
-type raw_any
-and button
-and canvas
-and checkbutton
-and entry
-and frame
-and label
-and listbox
-and menu
-and menubutton
-and message
-and radiobutton
-and scale
-and scrollbar
-and text
-and toplevel
-
-val forget_type : 'a raw_widget -> raw_any raw_widget
-val coe : 'a raw_widget -> raw_any raw_widget
-
-val default_toplevel : toplevel raw_widget
- (* [default_toplevel] is "." in Tk, the toplevel widget that is
- always existing during a Tk session. Destroying [default_toplevel]
- ends the main loop
- *)
-
-val atom : parent: 'a raw_widget -> name: string -> raw_any raw_widget
- (* [atom parent name] returns the widget [parent.name]. The widget is
- not created. Only its name is returned. In a given parent, there may
- only exist one children for a given name.
- This function should only be used to check the existence of a widget
- with a known name. It doesn't add the widget to the internal tables
- of CamlTk.
- *)
-
-val name : 'a raw_widget -> string
- (* [name w] returns the name (tk "path") of a widget *)
-
-(*--*)
-(* The following functions are used internally.
- There is normally no need for them in users programs
- *)
-
-val known_class : 'a raw_widget -> string
- (* [known_class w] returns the class of a widget (e.g. toplevel, frame),
- as known by the CamlTk interface.
- Not equivalent to "winfo w" in Tk.
- *)
-
-val dummy : raw_any raw_widget
- (* [dummy] is a widget used as context when we don't have any.
- It is *not* a real widget.
- *)
-
-val new_atom : parent:'a raw_widget -> ?name: string -> string -> 'b raw_widget
-
-val get_atom : string -> raw_any raw_widget
- (* [get_atom path] returns the widget with Tk path [path] *)
-
-val remove : 'a raw_widget -> unit
- (* [remove w] removes widget from the internal tables *)
-
-(* Subtypes tables *)
-val widget_any_table : string list
-val widget_button_table : string list
-val widget_canvas_table : string list
-val widget_checkbutton_table : string list
-val widget_entry_table : string list
-val widget_frame_table : string list
-val widget_label_table : string list
-val widget_listbox_table : string list
-val widget_menu_table : string list
-val widget_menubutton_table : string list
-val widget_message_table : string list
-val widget_radiobutton_table : string list
-val widget_scale_table : string list
-val widget_scrollbar_table : string list
-val widget_text_table : string list
-val widget_toplevel_table : string list
-
-val chk_sub : string -> 'a list -> 'a -> unit
-val check_class : 'a raw_widget -> string list -> unit
- (* Widget subtyping *)
-
-exception IllegalWidgetType of string
- (* Raised when widget command applied illegally*)
diff --git a/otherlibs/labltk/support/slave.ml b/otherlibs/labltk/support/slave.ml
deleted file mode 100644
index b994fe17e7..0000000000
--- a/otherlibs/labltk/support/slave.ml
+++ /dev/null
@@ -1,51 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* The code run on initialisation, in addition to normal Tk code
- * NOTE: camltk has not fully been initialised yet
- *)
-external tcl_eval : string -> string
- = "camltk_tcl_eval"
-let tcl_command s = ignore (tcl_eval s);;
-open Printf
-
-let dynload args =
- List.iter Dynlink.loadfile args
-
-(* Default modules include everything from
-let default_modules = []
-*)
-
-(* [caml::run foo.cmo .. bar.cmo] is now available from Tcl *)
-let init () =
- Dynlink.init();
- (* Make it unsafe by default, with everything available *)
- Dynlink.allow_unsafe_modules true;
- Dynlink.add_interfaces [] [];
- let s = register_callback Widget.dummy dynload in
- tcl_command (sprintf "proc caml::run {l} {camlcb %s l}" s)
-
-let _ =
- Printexc.print init ()
-
-(* A typical master program would then
- * caml::run foo.cmo
- * # during initialisation, "foo" was registered as a tcl procedure
- * foo x y z
- * # proceed with some Tcl code calling foo
- *)
diff --git a/otherlibs/labltk/support/support.ml b/otherlibs/labltk/support/support.ml
deleted file mode 100644
index c8bebc2fc7..0000000000
--- a/otherlibs/labltk/support/support.ml
+++ /dev/null
@@ -1,48 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Parsing results of Tcl *)
-(* List.split a string according to char_sep predicate *)
-let split_str ~pred:char_sep str =
- let len = String.length str in
- let rec skip_sep cur =
- if cur >= len then cur
- else if char_sep str.[cur] then skip_sep (succ cur)
- else cur in
- let rec split beg cur =
- if cur >= len then
- if beg = cur then []
- else [String.sub str beg (len - beg)]
- else if char_sep str.[cur]
- then
- let nextw = skip_sep cur in
- (String.sub str beg (cur - beg))
- ::(split nextw nextw)
- else split beg (succ cur) in
- let wstart = skip_sep 0 in
- split wstart wstart
-
-(* Very easy hack for option type *)
-let may f = function
- Some x -> Some (f x)
-| None -> None
-
-let maycons f x l =
- match x with
- Some x -> f x :: l
- | None -> l
diff --git a/otherlibs/labltk/support/support.mli b/otherlibs/labltk/support/support.mli
deleted file mode 100644
index 95a2255cb5..0000000000
--- a/otherlibs/labltk/support/support.mli
+++ /dev/null
@@ -1,21 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-val split_str : pred:(char -> bool) -> string -> string list
-val may : ('a -> 'b) -> 'a option -> 'b option
-val maycons : ('a -> 'b) -> 'a option -> 'b list -> 'b list
diff --git a/otherlibs/labltk/support/textvariable.ml b/otherlibs/labltk/support/textvariable.ml
deleted file mode 100644
index 4581976b5d..0000000000
--- a/otherlibs/labltk/support/textvariable.ml
+++ /dev/null
@@ -1,152 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Support
-open Protocol
-
-external internal_tracevar : string -> cbid -> unit
- = "camltk_trace_var"
-external internal_untracevar : string -> cbid -> unit
- = "camltk_untrace_var"
-external set : string -> string -> unit = "camltk_setvar"
-external get : string -> string = "camltk_getvar"
-
-
-type textVariable = string
-
-(* List of handles *)
-let handles = Hashtbl.create 401
-
-let add_handle var cbid =
- try
- let r = Hashtbl.find handles var in
- r := cbid :: !r
- with
- Not_found ->
- Hashtbl.add handles var (ref [cbid])
-
-let exceptq x =
- let rec ex acc = function
- [] -> acc
- | y::l when y == x -> ex acc l
- | y::l -> ex (y::acc) l
- in
- ex []
-
-let rem_handle var cbid =
- try
- let r = Hashtbl.find handles var in
- match exceptq cbid !r with
- [] -> Hashtbl.remove handles var
- | remaining -> r := remaining
- with
- Not_found -> ()
-
-(* Used when we "free" the variable (otherwise, old handlers would apply to
- * new usage of the variable)
- *)
-let rem_all_handles var =
- try
- let r = Hashtbl.find handles var in
- List.iter (internal_untracevar var) !r;
- Hashtbl.remove handles var
- with
- Not_found -> ()
-
-
-(* Variable trace *)
-let handle vname ~callback:f =
- let id = new_function_id() in
- let wrapped _ =
- clear_callback id;
- rem_handle vname id;
- f() in
- Hashtbl.add callback_naming_table id wrapped;
- add_handle vname id;
- if !Protocol.debug then begin
- prerr_cbid id; prerr_string " for variable "; prerr_endline vname
- end;
- internal_tracevar vname id
-
-(* Avoid space leak (all variables are global in Tcl) *)
-module StringSet =
- Set.Make(struct type t = string let compare = compare end)
-let freelist = ref (StringSet.empty)
-let memo = Hashtbl.create 101
-
-(* Added a variable v referenced by widget w *)
-let add w v =
- let w = Widget.forget_type w in
- let r =
- try Hashtbl.find memo w
- with
- Not_found ->
- let r = ref StringSet.empty in
- Hashtbl.add memo w r;
- r in
- r := StringSet.add v !r
-
-(* to be used with care ! *)
-let free v =
- rem_all_handles v;
- freelist := StringSet.add v !freelist
-
-(* Free variables associated with a widget *)
-let freew w =
- try
- let r = Hashtbl.find memo w in
- StringSet.iter free !r;
- Hashtbl.remove memo w
- with
- Not_found -> ()
-
-let _ = add_destroy_hook freew
-
-(* Allocate a new variable *)
-let counter = ref 0
-let getv () =
- let v =
- if StringSet.is_empty !freelist then begin
- incr counter;
- "camlv("^ string_of_int !counter ^")"
- end
- else
- let v = StringSet.choose !freelist in
- freelist := StringSet.remove v !freelist;
- v in
- set v "";
- v
-
-let create ?on: w () =
- let v = getv() in
- begin
- match w with
- Some w -> add w v
- | None -> ()
- end;
- v
-
-(* to be used with care ! *)
-let free v =
- freelist := StringSet.add v !freelist
-
-let cCAMLtoTKtextVariable s = TkToken s
-
-let name s = s
-let coerce s = s
-
diff --git a/otherlibs/labltk/support/textvariable.mli b/otherlibs/labltk/support/textvariable.mli
deleted file mode 100644
index 09a19148a1..0000000000
--- a/otherlibs/labltk/support/textvariable.mli
+++ /dev/null
@@ -1,45 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Support for Tk -textvariable option *)
-open Widget
-open Protocol
-
-type textVariable
- (* TextVariable is an abstract type *)
-
-val create : ?on: 'a widget -> unit -> textVariable
- (* Allocation of a textVariable with lifetime associated to widget
- if a widget is specified *)
-val set : textVariable -> string -> unit
- (* Setting the val of a textVariable *)
-val get : textVariable -> string
- (* Reading the val of a textVariable *)
-val name : textVariable -> string
- (* Its tcl name *)
-
-val cCAMLtoTKtextVariable : textVariable -> tkArgs
- (* Internal conversion function *)
-
-val handle : textVariable -> callback:(unit -> unit) -> unit
- (* Callbacks on variable modifications *)
-
-val coerce : string -> textVariable
-
-(*-*)
-val free : textVariable -> unit
diff --git a/otherlibs/labltk/support/timer.ml b/otherlibs/labltk/support/timer.ml
deleted file mode 100644
index ada8100fd2..0000000000
--- a/otherlibs/labltk/support/timer.ml
+++ /dev/null
@@ -1,58 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Timers *)
-open Support
-open Protocol
-
-type tkTimer = int
-
-external internal_add_timer : int -> cbid -> tkTimer
- = "camltk_add_timer"
-external internal_rem_timer : tkTimer -> unit
- = "camltk_rem_timer"
-
-type t = tkTimer * cbid (* the token and the cb id *)
-
-(* A timer is used only once, so we must clean the callback table *)
-let add ~ms ~callback =
- if !Protocol.debug then begin
- prerr_string "Timer.add "; flush stderr;
- end;
- let id = new_function_id () in
- if !Protocol.debug then begin
- prerr_string "id="; prerr_cbid id; flush stderr;
- end;
- let wrapped _ =
- clear_callback id; (* do it first in case f raises exception *)
- callback() in
- Hashtbl.add callback_naming_table id wrapped;
- let t = internal_add_timer ms id in
- if !Protocol.debug then begin
- prerr_endline " done"
- end;
- t,id
-
-let set ~ms ~callback = ignore (add ~ms ~callback);;
-
-(* If the timer has never been used, there is a small space leak in
- the C heap, where a copy of id has been stored *)
-let remove (tkTimer, id) =
- internal_rem_timer tkTimer;
- clear_callback id
-
diff --git a/otherlibs/labltk/support/timer.mli b/otherlibs/labltk/support/timer.mli
deleted file mode 100644
index a45e1c9d22..0000000000
--- a/otherlibs/labltk/support/timer.mli
+++ /dev/null
@@ -1,23 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-type t
-
-val add : ms:int -> callback:(unit -> unit) -> t
-val set : ms:int -> callback:(unit -> unit) -> unit
-val remove : t -> unit
diff --git a/otherlibs/labltk/support/tkwait.ml b/otherlibs/labltk/support/tkwait.ml
deleted file mode 100644
index 2574928c0f..0000000000
--- a/otherlibs/labltk/support/tkwait.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-external internal_tracevis : string -> string -> unit
- = "camltk_wait_vis"
-external internal_tracedestroy : string -> string -> unit
- = "camltk_wait_des"
diff --git a/otherlibs/labltk/support/widget.ml b/otherlibs/labltk/support/widget.ml
deleted file mode 100644
index 65e0d26a9e..0000000000
--- a/otherlibs/labltk/support/widget.ml
+++ /dev/null
@@ -1,23 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Hack to permit having the different data type with the same name
- [widget] for CamlTk and LablTk. *)
-include Rawwidget
-type 'a widget = 'a raw_widget
-type any = raw_any
diff --git a/otherlibs/labltk/support/widget.mli b/otherlibs/labltk/support/widget.mli
deleted file mode 100644
index fd3b461c2b..0000000000
--- a/otherlibs/labltk/support/widget.mli
+++ /dev/null
@@ -1,109 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Support for widget manipulations *)
-
-type 'a widget = 'a Rawwidget.raw_widget
- (* widget is an abstract type *)
-
-type any = Rawwidget.raw_any
-and button
-and canvas
-and checkbutton
-and entry
-and frame
-and label
-and listbox
-and menu
-and menubutton
-and message
-and radiobutton
-and scale
-and scrollbar
-and text
-and toplevel
-
-val forget_type : 'a widget -> any widget
-val coe : 'a widget -> any widget
-
-val default_toplevel : toplevel widget
- (* [default_toplevel] is "." in Tk, the toplevel widget that is
- always existing during a Tk session. Destroying [default_toplevel]
- ends the main loop
- *)
-
-val atom : parent: 'a widget -> name: string -> any widget
- (* [atom parent name] returns the widget [parent.name]. The widget is
- not created. Only its name is returned. In a given parent, there may
- only exist one children for a given name.
- This function should only be used to check the existence of a widget
- with a known name. It doesn't add the widget to the internal tables
- of CamlTk.
- *)
-
-val name : 'a widget -> string
- (* [name w] returns the name (tk "path") of a widget *)
-
-(*--*)
-(* The following functions are used internally.
- There is normally no need for them in users programs
- *)
-
-val known_class : 'a widget -> string
- (* [known_class w] returns the class of a widget (e.g. toplevel, frame),
- as known by the CamlTk interface.
- Not equivalent to "winfo w" in Tk.
- *)
-
-val dummy : any widget
- (* [dummy] is a widget used as context when we don't have any.
- It is *not* a real widget.
- *)
-
-val new_atom : parent:'a widget -> ?name: string -> string -> 'b widget
-
-val get_atom : string -> any widget
- (* [get_atom path] returns the widget with Tk path [path] *)
-
-val remove : 'a widget -> unit
- (* [remove w] removes widget from the internal tables *)
-
-(* Subtypes tables *)
-val widget_any_table : string list
-val widget_button_table : string list
-val widget_canvas_table : string list
-val widget_checkbutton_table : string list
-val widget_entry_table : string list
-val widget_frame_table : string list
-val widget_label_table : string list
-val widget_listbox_table : string list
-val widget_menu_table : string list
-val widget_menubutton_table : string list
-val widget_message_table : string list
-val widget_radiobutton_table : string list
-val widget_scale_table : string list
-val widget_scrollbar_table : string list
-val widget_text_table : string list
-val widget_toplevel_table : string list
-
-val chk_sub : string -> 'a list -> 'a -> unit
-val check_class : 'a widget -> string list -> unit
- (* Widget subtyping *)
-
-exception IllegalWidgetType of string
- (* Raised when widget command applied illegally*)
diff --git a/otherlibs/labltk/tkanim/.cvsignore b/otherlibs/labltk/tkanim/.cvsignore
deleted file mode 100644
index e1c70145f5..0000000000
--- a/otherlibs/labltk/tkanim/.cvsignore
+++ /dev/null
@@ -1,2 +0,0 @@
-gifanimtest
-gifanimtest-static
diff --git a/otherlibs/labltk/tkanim/.depend b/otherlibs/labltk/tkanim/.depend
deleted file mode 100644
index 6009347798..0000000000
--- a/otherlibs/labltk/tkanim/.depend
+++ /dev/null
@@ -1,2 +0,0 @@
-tkanim.cmo: tkanim.cmi
-tkanim.cmx: tkanim.cmi
diff --git a/otherlibs/labltk/tkanim/Makefile b/otherlibs/labltk/tkanim/Makefile
deleted file mode 100644
index 0e841da77e..0000000000
--- a/otherlibs/labltk/tkanim/Makefile
+++ /dev/null
@@ -1,70 +0,0 @@
-include ../support/Makefile.common
-
-COMPFLAGS=-I ../../../byterun -I ../support -I ../camltk -I ../../unix
-CCFLAGS=-I../../../byterun -I../support $(TK_DEFS) $(SHAREDCCCOMPOPTS)
-
-all: tkanim.cma libtkanim.a
-opt: tkanim.cmxa libtkanim.a
-example: gifanimtest
-
-OBJS=tkanim.cmo
-COBJS= cltkaniminit.o tkAnimGIF.o
-
-tkanim.cma: $(OBJS)
- $(MKLIB) -ocamlc '$(CAMLC)' -o tkanim -oc tkanim \
- $(OBJS) $(TK_LINK)
-
-tkanim.cmxa: $(OBJS:.cmo=.cmx)
- $(MKLIB) -ocamlopt '$(CAMLOPT)' -o tkanim -oc tkanim \
- $(OBJS:.cmo=.cmx) $(TK_LINK)
-
-libtkanim.a: $(COBJS)
- $(MKLIB) -o tkanim $(COBJS) $(TK_LINK)
-
-gifanimtest-static: all gifanimtest.cmo
- $(CAMLC) -custom -o $@ -I ../lib -I ../support -I ../../unix -dllpath ../support -dllpath . unix.cma -ccopt -L. $(LIBNAME).cma tkanim.cma gifanimtest.cmo
-
-# dynamic loading
-gifanimtest: all gifanimtest.cmo
- $(CAMLC) -o $@ -I ../lib -I ../support -I ../../unix -dllpath ../support -dllpath . unix.cma $(LIBNAME).cma tkanim.cma gifanimtest.cmo
-
-animwish: $(TKANIM_LIB) tkAppInit.o
- $(CC) -o $@ tkAppInit.o $(TK_LINK) $(X11_LINK) \
- -L. -ltkanim $(LIBS)
-
-$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma
-
-$(OBJS:.cmo=.cmx): ../lib/$(LIBNAME).cmxa
-
-clean:
- rm -f *.cm* *.o *.a dlltkanim.so animwish gifanimtest gifanimtest-static
-
-.SUFFIXES :
-.SUFFIXES : .mli .ml .cmi .cmo .mlp .cmx .c .o
-
-.mli.cmi:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-.c.o:
- $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $<
-
-
-install: tkanim.cma
- cp tkanim.cma *.cmi *.mli libtkanim.a $(INSTALLDIR)
- if [ -f dlltkanim.so ]; then \
- cp dlltkanim.so $(STUBLIBDIR)/dlltkanim.so; \
- fi
-
-installopt: tkanim.cmxa
- cp tkanim.cmxa tkanim.a $(INSTALLDIR)
-
-depend: tkanim.ml
- $(CAMLDEP) *.mli *.ml > .depend
-
-include .depend
diff --git a/otherlibs/labltk/tkanim/Makefile.nt b/otherlibs/labltk/tkanim/Makefile.nt
deleted file mode 100644
index 9c6da7ee2a..0000000000
--- a/otherlibs/labltk/tkanim/Makefile.nt
+++ /dev/null
@@ -1,78 +0,0 @@
-include ../support/Makefile.common.nt
-
-CCFLAGS=-I../support -I../../../byterun $(TK_DEFS)
-
-COMPFLAGS=-I $(OTHERS)/win32unix -I ../support -I ../camltk
-
-all: tkanim.cma dlltkanim.dll libtkanim.$(A)
-opt: tkanim.cmxa libtkanim.$(A)
-example: gifanimtest.exe
-
-OBJS=tkanim.cmo
-COBJS= cltkaniminit.obj tkAnimGIF.obj
-DCOBJS=$(COBJS:.obj=.$(DO))
-SCOBJS=$(COBJS:.obj=.$(SO))
-
-tkanim.cma: $(OBJS)
- $(CAMLLIBR) -o tkanim.cma $(OBJS) \
- -dllib -ltkanim -cclib -ltkanim -cclib "$(TK_LINK)"
-
-tkanim.cmxa: $(OBJS:.cmo=.cmx)
- $(CAMLOPTLIBR) -o tkanim.cmxa $(OBJS:.cmo=.cmx) \
- -cclib -ltkanim -cclib "$(TK_LINK)"
-
-libtkanim.$(A): $(SCOBJS)
- $(call MKLIB,libtkanim.$(A), $(SCOBJS))
-
-dlltkanim.dll: $(DCOBJS)
- $(call MKDLL,dlltkanim.dll,tmp.$(A), \
- $(DCOBJS) ../support/dll$(LIBNAME).$(A) \
- ../../../byterun/ocamlrun.$(A) \
- $(TK_LINK) $(call SYSLIB,wsock32))
- rm tmp.*
-
-gifanimtest.exe: all gifanimtest.cmo
- $(CAMLC) -custom -o $@ -I ../lib -I ../camltk -I ../support unix.cma $(LIBNAME).cma tkanim.cma gifanimtest.cmo
-
-# animwish: $(TKANIM_LIB) tkAppInit.o
-# $(CC) -o $@ tkAppInit.o $(TK_LINK) $(X11_LINK) \
-# -L. -ltkanim $(LIBS)
-
-clean:
- rm -f *.cm* *.$(O) *.$(A) *.dll gifanimtest.exe
-
-$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma
-
-$(OBJS:.cmo=.cmx): ../lib/$(LIBNAME).cmxa
-
-.SUFFIXES :
-.SUFFIXES : .mli .ml .cmi .cmo .mlp .cmx .c .$(DO) .$(SO)
-
-.mli.cmi:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-.c.$(DO):
- $(BYTECC) $(DLLCCCOMPOPTS) $(CCFLAGS) -c $<
- mv $*.$(O) $*.$(DO)
-
-.c.$(SO):
- $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $<
- mv $*.$(O) $*.$(SO)
-
-install: tkanim.cma
- cp dlltkanim.dll $(STUBLIBDIR)/dlltkanim.dll
- cp tkanim.cma *.cmi *.mli libtkanim.$(A) $(INSTALLDIR)
-
-installopt: tkanim.cmxa
- cp tkanim.cmxa tkanim.$(A) $(INSTALLDIR)
-
-depend: tkanim.ml
- $(CAMLDEP) *.mli *.ml > .depend
-
-include .depend
diff --git a/otherlibs/labltk/tkanim/README b/otherlibs/labltk/tkanim/README
deleted file mode 100644
index 175401f30c..0000000000
--- a/otherlibs/labltk/tkanim/README
+++ /dev/null
@@ -1,5 +0,0 @@
-This ML code is an interface for Tkanim Tcl/Tk extension. Unfortunately
-it is still test implementation. Look example directory for an example.
-
-The codes under this directory are mainly written by Jun Furuse
-(Jun.Furuse@inria.fr).
diff --git a/otherlibs/labltk/tkanim/cltkaniminit.c b/otherlibs/labltk/tkanim/cltkaniminit.c
deleted file mode 100644
index a45bedcb50..0000000000
--- a/otherlibs/labltk/tkanim/cltkaniminit.c
+++ /dev/null
@@ -1,28 +0,0 @@
-/***********************************************************************/
-/* */
-/* MLTk, Tcl/Tk interface of Objective Caml */
-/* */
-/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */
-/* projet Cristal, INRIA Rocquencourt */
-/* Jacques Garrigue, Kyoto University RIMS */
-/* */
-/* Copyright 2002 Institut National de Recherche en Informatique et */
-/* en Automatique and Kyoto University. All rights reserved. */
-/* This file is distributed under the terms of the GNU Library */
-/* General Public License, with the special exception on linking */
-/* described in file LICENSE found in the Objective Caml source tree. */
-/* */
-/***********************************************************************/
-#include <tk.h>
-#include <mlvalues.h>
-#include "camltk.h"
-
-extern int Tkanim_Init(Tcl_Interp *);
-
-CAMLprim value tkanim_init (rien) /* ML */
- value rien;
-{
- if (Tkanim_Init(cltclinterp) != TCL_OK)
- tk_error ("Can't initialize TkAnim");
- return Val_unit;
-}
diff --git a/otherlibs/labltk/tkanim/gifanimtest.ml b/otherlibs/labltk/tkanim/gifanimtest.ml
deleted file mode 100644
index 5b79985449..0000000000
--- a/otherlibs/labltk/tkanim/gifanimtest.ml
+++ /dev/null
@@ -1,71 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-open Widget
-open Tkanim
-open Tk
-
-let main () =
- let file = ref "" in
- Arg.parse [] (fun s -> file := s)
- "usage: gifanimtest file (animated gif)\n\
- \tbutton 1 toggles the animation,\n\
- \tbutton 2 displays the next frame,\n\
- \tbutton 3 quits.";
- let t = openTk () in
-
- (* First of all, you must initialize the extension. *)
- Tkanim.init ();
-
- prerr_endline !file;
-
- (* Then load the animated gif. *)
- let anim = Tkanim.create !file in
- prerr_endline "load done";
-
- (* Check it is really animated or not. *)
- match anim with
- | Still x ->
- (* Use whatever you want in CamlTk with this ImagePhoto. *)
- prerr_endline "Sorry, it is not an animated GIF."
-
- | Animated x ->
- (* OK, let's animate it. *)
- let l = Label.create t [] in
- pack [l] [];
-
- (* animate returns an interface function. *)
- let f = animate l x in
-
- (* Button1 toggles the animation *)
- bind l [[], ButtonPressDetail 1] (BindSet ([], (fun _ ->
- f false)));
-
- (* Button2 displays the next frame. *)
- bind l [[], ButtonPressDetail 2] (BindSet ([], (fun _ ->
- f true)));
-
- (* Button3 quits. *)
- bind l [[], ButtonPressDetail 3] (BindSet ([], (fun _ ->
- closeTk ())));
-
- (* start the animation *)
- f false;
-
- (* Go to the main loop. *)
- mainLoop ()
-
-let _ = Printexc.print main ()
diff --git a/otherlibs/labltk/tkanim/mmm.anim.gif b/otherlibs/labltk/tkanim/mmm.anim.gif
deleted file mode 100644
index daeee00eea..0000000000
--- a/otherlibs/labltk/tkanim/mmm.anim.gif
+++ /dev/null
Binary files differ
diff --git a/otherlibs/labltk/tkanim/tkAnimGIF.c b/otherlibs/labltk/tkanim/tkAnimGIF.c
deleted file mode 100644
index 1beb814397..0000000000
--- a/otherlibs/labltk/tkanim/tkAnimGIF.c
+++ /dev/null
@@ -1,911 +0,0 @@
-/***********************************************************************/
-/* */
-/* MLTk, Tcl/Tk interface of Objective Caml */
-/* */
-/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */
-/* projet Cristal, INRIA Rocquencourt */
-/* Jacques Garrigue, Kyoto University RIMS */
-/* */
-/* Copyright 2002 Institut National de Recherche en Informatique et */
-/* en Automatique and Kyoto University. All rights reserved. */
-/* This file is distributed under the terms of the GNU Library */
-/* General Public License, with the special exception on linking */
-/* described in file LICENSE found in the Objective Caml source tree. */
-/* */
-/***********************************************************************/
-#define TKANIM_VERSION "1.0"
-/* #define TKANIM_DEBUG */
-
-#include <tk.h>
-#include <string.h>
-
-/*
- * The format record for the Animated GIF file format:
- */
-
-static int FileMatchGIF _ANSI_ARGS_((FILE *f, char *fileName,
- char *formatString, int *widthPtr, int *heightPtr));
-static int FileReadGIF _ANSI_ARGS_((Tcl_Interp *interp,
- FILE *f, char *fileName, char *formatString));
-
-#define INTERLACE 0x40
-#define LOCALCOLORMAP 0x80
-#define BitSet(byte, bit) (((byte) & (bit)) == (bit))
-#define MAXCOLORMAPSIZE 256
-#define CM_RED 0
-#define CM_GREEN 1
-#define CM_BLUE 2
-#define MAX_LWZ_BITS 12
-#define LM_to_uint(a,b) (((b)<<8)|(a))
-#define ReadOK(file,buffer,len) (fread(buffer, len, 1, file) != 0)
-
-/*
- * Prototypes for local procedures defined in this file:
- */
-
-static int DoExtension _ANSI_ARGS_((FILE *fd, int label,
- int *transparent, int *delay, int *loop));
-static int GetCode _ANSI_ARGS_((FILE *fd, int code_size,
- int flag));
-static int GetDataBlock _ANSI_ARGS_((FILE *fd,
- unsigned char *buf));
-static int LWZReadByte _ANSI_ARGS_((FILE *fd, int flag,
- int input_code_size));
-static int ReadColorMap _ANSI_ARGS_((FILE *fd, int number,
- unsigned char buffer[3][MAXCOLORMAPSIZE]));
-static int ReadGIFHeader _ANSI_ARGS_((FILE *f, int *widthPtr,
- int *heightPtr));
-static int ReadImage _ANSI_ARGS_((Tcl_Interp *interp,
- char *imagePtr, FILE *fd, int len, int height,
- unsigned char cmap[3][MAXCOLORMAPSIZE],
- int interlace, int transparent));
-
-static int
-FileMatchGIF(f, fileName, formatString, widthPtr, heightPtr)
- FILE *f; /* The image file, open for reading. */
- char *fileName; /* The name of the image file. */
- char *formatString; /* User-specified format string, or NULL. */
- int *widthPtr, *heightPtr; /* The dimensions of the image are
- * returned here if the file is a valid
- * raw GIF file. */
-{
- return ReadGIFHeader(f, widthPtr, heightPtr);
-}
-
-static int
-FileReadGIF(interp, f, fileName, formatString)
- Tcl_Interp *interp; /* Interpreter to use for reporting errors. */
- FILE *f; /* The image file, open for reading. */
- char *fileName; /* The name of the image file. */
- char *formatString; /* User-specified format string, or NULL. */
-{
- int logicalWidth, logicalHeight;
- int nBytes;
- Tk_PhotoImageBlock block;
- unsigned char buf[100];
- int bitPixel;
- unsigned int colorResolution;
- unsigned int background;
- unsigned int aspectRatio;
- unsigned char localColorMap[3][MAXCOLORMAPSIZE];
- unsigned char colorMap[3][MAXCOLORMAPSIZE];
- int useGlobalColormap;
- int transparent = -1;
- int delay = 0;
- Tk_Window winPtr;
- int imageLeftPos, imageTopPos, imageWidth, imageHeight;
- Tk_PhotoHandle photoHandle;
-
- char widthbuf[32], heightbuf[32];
- Tcl_DString resultbuf;
-
- char newresbuf[640];
- char *imageName;
- char *resultptr;
- int prevpos;
- int loop = -1;
-
- if((winPtr = Tk_MainWindow(interp)) == NULL){
- return TCL_ERROR;
- }
-
-#ifdef TKANIM_DEBUG
- fprintf(stderr, "\n\t\tHeader check...");
-#endif
- if (!ReadGIFHeader(f, &logicalWidth, &logicalHeight)) {
- Tcl_AppendResult(interp, "couldn't read GIF header from file \"",
- fileName, "\"", NULL);
- return TCL_ERROR;
- }
-#ifdef TKANIM_DEBUG
- fprintf(stderr, "done ");
-#endif
- if ((logicalWidth <= 0) || (logicalHeight <= 0)) {
- Tcl_AppendResult(interp, "GIF image file \"", fileName,
- "\" has dimension(s) <= 0", (char *) NULL);
- return TCL_ERROR;
- }
-
- if (fread(buf, 1, 3, f) != 3) {
- return TCL_OK;
- }
- bitPixel = 2<<(buf[0]&0x07);
- colorResolution = (((buf[0]&0x70)>>3)+1);
- background = buf[1];
- aspectRatio = buf[2];
-
- if (BitSet(buf[0], LOCALCOLORMAP)) { /* Global Colormap */
- if (!ReadColorMap(f, bitPixel, colorMap)) {
- Tcl_AppendResult(interp, "error reading color map",
- (char *) NULL);
- return TCL_ERROR;
- }
- }
-
-#ifdef TKANIM_DEBUG
- fprintf(stderr, "\n\t\tReading frames ");
- prevpos = ftell(f);
-#endif
- sprintf( widthbuf, "%d ", logicalWidth);
- sprintf( heightbuf, "%d ", logicalHeight);
-
- Tcl_DStringInit(&resultbuf);
- Tcl_DStringAppend(&resultbuf, widthbuf, -1);
- Tcl_DStringAppend(&resultbuf, " ", -1);
- Tcl_DStringAppend(&resultbuf, heightbuf, -1);
- Tcl_DStringAppend(&resultbuf, " ", -1);
- Tcl_DStringAppend(&resultbuf, "{", -1);
-
- while (1) {
- if (fread(buf, 1, 1, f) != 1) {
- /*
- * Premature end of image. We should really notify
- * the user, but for now just show garbage.
- */
-#ifdef TKANIM_DEBUG
- fprintf(stderr, "Premature end of image");
-#endif
-
- break;
- }
-
- if (buf[0] == ';') {
- /*
- * GIF terminator.
- */
-#ifdef TKANIM_DEBUG
- fprintf(stderr, ";");
- prevpos = ftell(f);
-#endif
-
- break;
- }
-
- if (buf[0] == '!') {
- /*
- * This is a GIF extension.
- */
-#ifdef TKANIM_DEBUG
- fprintf(stderr, "!");
- prevpos = ftell(f);
-#endif
-
- if (fread(buf, 1, 1, f) != 1) {
- Tcl_AppendResult( interp,
- "error reading extension function code in GIF image", NULL );
-/*
- interp->result =
- "error reading extension function code in GIF image";
-*/
- goto error;
- }
- if (DoExtension(f, buf[0], &transparent, &delay, &loop) < 0) {
- Tcl_AppendResult( interp,
- "error reading extension in GIF image", NULL );
-/*
- interp->result = "error reading extension in GIF image";
-*/ goto error;
- }
- continue;
- }
-
- if (buf[0] == '\0') {
- /*
- * Not a valid start character; ignore it.
- */
-#ifdef TKANIM_DEBUG
- fprintf(stderr, "0", buf[0]);
- prevpos = ftell(f);
-#endif
- continue;
- }
-
- if (buf[0] != ',') {
- /*
- * Not a valid start character; ignore it.
- */
-#ifdef TKANIM_DEBUG
- fprintf(stderr, "?(%c)", buf[0]);
- prevpos = ftell(f);
-#endif
- continue;
- }
-
- if (fread(buf, 1, 9, f) != 9) {
- Tcl_AppendResult( interp,
- "couldn't read left/top/width/height in GIF image", NULL );
-/*
- interp->result = "couldn't read left/top/width/height in GIF image";
-*/
- goto error;
- }
-
- useGlobalColormap = ! BitSet(buf[8], LOCALCOLORMAP);
-
- bitPixel = 1<<((buf[8]&0x07)+1);
-
- imageLeftPos= LM_to_uint(buf[0], buf[1]);
- imageTopPos= LM_to_uint(buf[2], buf[3]);
- imageWidth= LM_to_uint(buf[4], buf[5]);
- imageHeight= LM_to_uint(buf[6], buf[7]);
-
- block.width = imageWidth;
- block.height = imageHeight;
- block.pixelSize = 3;
- block.pitch = 3 * imageWidth;
- block.offset[0] = 0;
- block.offset[1] = 1;
- block.offset[2] = 2;
- block.offset[3] = 3;
- nBytes = imageHeight * block.pitch;
- block.pixelPtr = (unsigned char *) ckalloc((unsigned) nBytes);
-
- sprintf(widthbuf, "%d", imageWidth);
- sprintf(heightbuf, "%d", imageHeight);
-
- /* save result */
-
- {
-#if (TK_MAJOR_VERSION >= 8 && TK_MINOR_VERSION >= 1)
- Tcl_Obj *argv[7];
- int i;
-
- argv[0] = Tcl_NewStringObj("image", -1);
- argv[1] = Tcl_NewStringObj("create", -1);
- argv[2] = Tcl_NewStringObj("photo", -1);
- argv[3] = Tcl_NewStringObj("-width", -1);
- argv[4] = Tcl_NewStringObj(widthbuf, -1);
- argv[5] = Tcl_NewStringObj("-height", -1);
- argv[6] = Tcl_NewStringObj(heightbuf, -1);
-
- for(i=0; i<7; i++){ Tcl_IncrRefCount(argv[i]); }
-
- if( Tk_ImageObjCmd((ClientData) winPtr, interp,
- /* "image create photo -width <imageWidth>
- -height <imageHeight>" */
- 7, argv) == TCL_ERROR ){
- return TCL_ERROR;
- }
-
- for(i=0; i<7; i++){ Tcl_DecrRefCount(argv[i]); }
-
-#else
- char *argv[7] = {"image", "create", "photo", "-width", NULL,
- "-height", NULL};
- argv[4] = widthbuf;
- argv[6] = heightbuf;
-#ifdef TKANIM_DEBUG
- fprintf(stderr, "\n\t\timage creation (%s %s %s %s %s %s %s)",
- argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6]);
-#endif
- if( Tk_ImageCmd((ClientData) winPtr, interp,
- /* "image create photo -width <imageWidth>
- -height <imageHeight>" */
- 7, argv) == TCL_ERROR ){
- return TCL_ERROR;
- }
-#endif
-
-#ifdef TKANIM_DEBUG
- fprintf(stderr, " done ");
-#endif
- }
-
- imageName = interp->result;
-#if (TK_MAJOR_VERSION < 8)
- photoHandle = Tk_FindPhoto(interp->result);
-#else
- photoHandle = Tk_FindPhoto(interp, interp->result);
-#endif
- if (!useGlobalColormap) {
- if (!ReadColorMap(f, bitPixel, localColorMap)) {
- Tcl_AppendResult(interp, "error reading color map",
- (char *) NULL);
- goto error;
- }
- if (ReadImage(interp, (char *) block.pixelPtr, f, imageWidth,
- imageHeight, localColorMap, BitSet(buf[8], INTERLACE),
- transparent) != TCL_OK) {
- goto error;
- }
- } else {
- if (ReadImage(interp, (char *) block.pixelPtr, f, imageWidth,
- imageHeight, colorMap, BitSet(buf[8], INTERLACE),
- transparent) != TCL_OK) {
- goto error;
- }
- }
- Tk_PhotoPutBlock(photoHandle, &block, 0, 0, imageWidth, imageHeight
-#if (TK_MAJOR_VERSION == 8 && TK_MINOR_VERSION >= 4 || TK_MAJOR_VERSION > 8)
- , TK_PHOTO_COMPOSITE_SET
-#endif
- );
-#ifdef TKANIM_DEBUG
- fprintf(stderr, " Retrieving result\n");
-#endif
- /* retrieve result */
- sprintf(newresbuf, "{%s %d %d %d %d %d} ",
- imageName, imageWidth, imageHeight, imageLeftPos, imageTopPos,
- delay);
-#ifdef TKANIM_DEBUG
- fprintf(stderr, " newresbuf = %s\n", newresbuf);
-#endif
- ckfree((char *) block.pixelPtr);
-#ifdef TKANIM_DEBUG
- fprintf(stderr, " free done (now append result)");
-#endif
- Tcl_DStringAppend( &resultbuf, newresbuf, -1 );
-#ifdef TKANIM_DEBUG
- fprintf(stderr, "\n\t\tFrame done (%d)", ftell(f) - prevpos);
- prevpos = ftell(f);
-#endif
- }
- sprintf( widthbuf, "%d", loop );
- Tcl_DStringAppend( &resultbuf, "} ", -1 );
- resultptr = Tcl_DStringAppend( &resultbuf, widthbuf, -1 );
-#ifdef TKANIM_DEBUG
- fprintf(stderr, "\nResult = %s\n", resultptr);
-#endif
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, resultptr, NULL);
- Tcl_DStringFree(&resultbuf);
- return TCL_OK;
-
- error:
- Tcl_DStringFree(&resultbuf);
- ckfree((char *) block.pixelPtr);
- return TCL_ERROR;
-
-}
-
-static int
-DoExtension(fd, label, transparent, delay, loop)
-FILE *fd;
-int label;
-int *transparent;
-int *delay;
-int *loop;
-{
- static unsigned char buf[256];
- int count = 0;
-
- switch (label) {
- case 0x01: /* Plain Text Extension */
- break;
-
- case 0xff: /* Application Extension */
- count = GetDataBlock(fd, (unsigned char*) buf);
- if( count < 0){
- return 1;
- }
- if( !strncmp (buf, "NETSCAPE", 8) ) {
- /* we ignore check of "2.0" */
- count = GetDataBlock (fd, (unsigned char*) buf);
- if( count < 0){
- return 1;
- }
- if( buf[0] != 1 ){
- fprintf(stderr, "??? %d", buf[0]);
- }
- *loop = LM_to_uint(buf[1], buf[2]);
- }
- do {
- count = GetDataBlock(fd, (unsigned char*) buf);
- } while (count > 0);
- return count;
- break;
-
- case 0xfe: /* Comment Extension */
- do {
- count = GetDataBlock(fd, (unsigned char*) buf);
- } while (count > 0);
- return count;
-
- case 0xf9: /* Graphic Control Extension */
- count = GetDataBlock(fd, (unsigned char*) buf);
- if (count < 0) {
- return 1;
- }
- if ((buf[0] & 0x1) != 0) {
- *transparent = buf[3];
- }
-
- /* Delay time */
- *delay = LM_to_uint(buf[1],buf[2]);
-
- do {
- count = GetDataBlock(fd, (unsigned char*) buf);
- } while (count > 0);
- return count;
- }
-
- do {
- count = GetDataBlock(fd, (unsigned char*) buf);
- } while (count > 0);
- return count;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ReadGIFHeader --
- *
- * This procedure reads the GIF header from the beginning of a
- * GIF file and returns the dimensions of the image.
- *
- * Results:
- * The return value is 1 if file "f" appears to start with
- * a valid GIF header, 0 otherwise. If the header is valid,
- * then *widthPtr and *heightPtr are modified to hold the
- * dimensions of the image.
- *
- * Side effects:
- * The access position in f advances.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-ReadGIFHeader(f, widthPtr, heightPtr)
- FILE *f; /* Image file to read the header from */
- int *widthPtr, *heightPtr; /* The dimensions of the image are
- * returned here. */
-{
- unsigned char buf[7];
-
- if ((fread(buf, 1, 6, f) != 6)
- || ((strncmp("GIF87a", (char *) buf, 6) != 0)
- && (strncmp("GIF89a", (char *) buf, 6) != 0))) {
- return 0;
- }
-
- if (fread(buf, 1, 4, f) != 4) {
- return 0;
- }
-
- *widthPtr = LM_to_uint(buf[0],buf[1]);
- *heightPtr = LM_to_uint(buf[2],buf[3]);
- return 1;
-}
-
-/*
- *-----------------------------------------------------------------
- * The code below is copied from the giftoppm program and modified
- * just slightly.
- *-----------------------------------------------------------------
- */
-
-static int
-ReadColorMap(fd,number,buffer)
-FILE *fd;
-int number;
-unsigned char buffer[3][MAXCOLORMAPSIZE];
-{
- int i;
- unsigned char rgb[3];
-
- for (i = 0; i < number; ++i) {
- if (! ReadOK(fd, rgb, sizeof(rgb)))
- return 0;
-
- buffer[CM_RED][i] = rgb[0] ;
- buffer[CM_GREEN][i] = rgb[1] ;
- buffer[CM_BLUE][i] = rgb[2] ;
- }
- return 1;
-}
-
-
-
-static int ZeroDataBlock = 0;
-
-static int
-GetDataBlock(fd, buf)
-FILE *fd;
-unsigned char *buf;
-{
- unsigned char count;
-
- if (! ReadOK(fd,&count,1)) {
- return -1;
- }
-
- ZeroDataBlock = count == 0;
-
- if ((count != 0) && (! ReadOK(fd, buf, count))) {
- return -1;
- }
-
- return count;
-}
-
-
-static int
-ReadImage(interp, imagePtr, fd, len, height, cmap, interlace, transparent)
-Tcl_Interp *interp;
-char *imagePtr;
-FILE *fd;
-int len, height;
-unsigned char cmap[3][MAXCOLORMAPSIZE];
-int interlace;
-int transparent;
-{
- unsigned char c;
- int v;
- int xpos = 0, ypos = 0, pass = 0;
- char *colStr;
-
-
- /*
- * Initialize the Compression routines
- */
- if (! ReadOK(fd,&c,1)) {
- Tcl_AppendResult(interp, "error reading GIF image: ",
- Tcl_PosixError(interp), (char *) NULL);
- return TCL_ERROR;
- }
-
- if (LWZReadByte(fd, 1, c) < 0) {
- interp->result = "format error in GIF image";
- return TCL_ERROR;
- }
-
- if (transparent!=-1 &&
- (colStr = Tcl_GetVar(interp, "TRANSPARENT_GIF_COLOR", 0L))) {
- XColor *colorPtr;
- colorPtr = Tk_GetColor(interp, Tk_MainWindow(interp),
- Tk_GetUid(colStr));
- if (colorPtr) {
-/*
- printf("color is %d %d %d\n",
- colorPtr->red >> 8,
- colorPtr->green >> 8,
- colorPtr->blue >> 8);
-*/
- cmap[CM_RED][transparent] = colorPtr->red >> 8;
- cmap[CM_GREEN][transparent] = colorPtr->green >> 8;
- cmap[CM_BLUE][transparent] = colorPtr->blue >> 8;
- Tk_FreeColor(colorPtr);
- }
- }
-
- while ((v = LWZReadByte(fd,0,c)) >= 0 ) {
-
- imagePtr[ (xpos*3) + (ypos *len*3)] = cmap[CM_RED][v];
- imagePtr[ (xpos*3) + (ypos *len*3) +1] = cmap[CM_GREEN][v];
- imagePtr[ (xpos*3) + (ypos *len*3) +2] = cmap[CM_BLUE][v];
-
- ++xpos;
- if (xpos == len) {
- xpos = 0;
- if (interlace) {
- switch (pass) {
- case 0:
- case 1:
- ypos += 8; break;
- case 2:
- ypos += 4; break;
- case 3:
- ypos += 2; break;
- }
-
- if (ypos >= height) {
- ++pass;
- switch (pass) {
- case 1:
- ypos = 4; break;
- case 2:
- ypos = 2; break;
- case 3:
- ypos = 1; break;
- default:
- return TCL_OK;
- }
- }
- } else {
- ++ypos;
- }
- }
- if (ypos >= height)
- break;
- }
- return TCL_OK;
-}
-
-static int
-LWZReadByte(fd, flag, input_code_size)
-FILE *fd;
-int flag;
-int input_code_size;
-{
- static int fresh = 0;
- int code, incode;
- static int code_size, set_code_size;
- static int max_code, max_code_size;
- static int firstcode, oldcode;
- static int clear_code, end_code;
- static int table[2][(1<< MAX_LWZ_BITS)];
- static int stack[(1<<(MAX_LWZ_BITS))*2], *sp;
- register int i;
-
-
- if (flag) {
-
- set_code_size = input_code_size;
- code_size = set_code_size+1;
- clear_code = 1 << set_code_size ;
- end_code = clear_code + 1;
- max_code_size = 2*clear_code;
- max_code = clear_code+2;
-
- GetCode(fd, 0, 1);
-
- fresh = 1;
-
- for (i = 0; i < clear_code; ++i) {
- table[0][i] = 0;
- table[1][i] = i;
- }
- for (; i < (1<<MAX_LWZ_BITS); ++i) {
- table[0][i] = table[1][0] = 0;
- }
-
- sp = stack;
-
- return 0;
-
- } else if (fresh) {
-
- fresh = 0;
- do {
- firstcode = oldcode = GetCode(fd, code_size, 0);
- } while (firstcode == clear_code);
- return firstcode;
- }
-
- if (sp > stack)
- return *--sp;
-
- while ((code = GetCode(fd, code_size, 0)) >= 0) {
- if (code == clear_code) {
- for (i = 0; i < clear_code; ++i) {
- table[0][i] = 0;
- table[1][i] = i;
- }
-
- for (; i < (1<<MAX_LWZ_BITS); ++i) {
- table[0][i] = table[1][i] = 0;
- }
-
- code_size = set_code_size+1;
- max_code_size = 2*clear_code;
- max_code = clear_code+2;
- sp = stack;
- firstcode = oldcode = GetCode(fd, code_size, 0);
- return firstcode;
-
- } else if (code == end_code) {
- int count;
- unsigned char buf[260];
-
- if (ZeroDataBlock)
- return -2;
-
- while ((count = GetDataBlock(fd, buf)) > 0)
- ;
-
- if (count != 0)
- return -2;
- }
-
- incode = code;
-
- if (code >= max_code) {
- *sp++ = firstcode;
- code = oldcode;
- }
-
- while (code >= clear_code) {
- *sp++ = table[1][code];
- if (code == table[0][code]) {
- return -2;
-
- fprintf(stderr, "circular table entry BIG ERROR\n");
- /*
- * Used to be this instead, Steve Ball suggested
- * the change to just return.
-
- printf("circular table entry BIG ERROR\n");
- */
- }
- code = table[0][code];
- }
-
- *sp++ = firstcode = table[1][code];
-
- if ((code = max_code) <(1<<MAX_LWZ_BITS)) {
-
- table[0][code] = oldcode;
- table[1][code] = firstcode;
- ++max_code;
- if ((max_code>=max_code_size) && (max_code_size < (1<<MAX_LWZ_BITS))) {
- max_code_size *= 2;
- ++code_size;
- }
- }
-
- oldcode = incode;
-
- if (sp > stack)
- return *--sp;
- }
- return code;
-}
-
-
-static int
-GetCode(fd, code_size, flag)
-FILE *fd;
-int code_size;
-int flag;
-{
- static unsigned char buf[280];
- static int curbit, lastbit, done, last_byte;
- int i, j, ret;
- unsigned char count;
-
- if (flag) {
- curbit = 0;
- lastbit = 0;
- done = 0;
- return 0;
- }
-
-
- if ( (curbit+code_size) >= lastbit) {
- if (done) {
- /* ran off the end of my bits */
- return -1;
- }
- buf[0] = buf[last_byte-2];
- buf[1] = buf[last_byte-1];
-
- if ((count = GetDataBlock(fd, &buf[2])) == 0)
- done = 1;
-
- last_byte = 2 + count;
- curbit = (curbit - lastbit) + 16;
- lastbit = (2+count)*8 ;
- }
-
- ret = 0;
- for (i = curbit, j = 0; j < code_size; ++i, ++j)
- ret |= ((buf[ i / 8 ] & (1 << (i % 8))) != 0) << j;
-
-
- curbit += code_size;
-
- return ret;
-}
-
-int Tk_AnimationCmd(clientData, interp, argc, argv)
- ClientData clientData; /* Main window associated with interpreter. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
-{
- char c;
- int length;
-
- if (argc < 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " option ?arg arg ...?\"", (char *) NULL);
- return TCL_ERROR;
- }
- c = argv[1][0];
- length = strlen(argv[1]);
- if((c == 'c') && (length >= 2)
- && (strncmp(argv[1], "create", length) == 0)) {
-
- char * realFileName;
- Tcl_DString buffer;
- FILE *f;
-
-#ifdef TKANIM_DEBUG
- fprintf(stderr, "AnimationCmd => create ");
-#endif
-
- if ( argc != 3 ){
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " create GifFile\"", (char *) NULL);
- return TCL_ERROR;
- }
-#ifdef TKANIM_DEBUG
- fprintf(stderr, "\n\tRealFileName = ");
-#endif
- realFileName = Tcl_TranslateFileName(interp, argv[2],
- &buffer);
- if(realFileName == NULL) {
- Tcl_DStringFree(&buffer);
- return TCL_ERROR;
- }
-#ifdef TKANIM_DEBUG
- fprintf(stderr, "%s ", realFileName);
-#endif
-#ifdef TKANIM_DEBUG
- fprintf(stderr, "\n\tOpen ", realFileName);
-#endif
- f = fopen(realFileName, "rb");
- Tcl_DStringFree(&buffer);
- if (f == NULL ){
- Tcl_AppendResult(interp, "couldn't read image file \"",
- argv[2], "\": ", Tcl_PosixError(interp),
- (char *) NULL);
- return TCL_ERROR;
- }
-#ifdef TKANIM_DEBUG
- fprintf(stderr, "success ", realFileName);
-#endif
-#ifdef TKANIM_DEBUG
- fprintf(stderr, "\n\tRead ", realFileName);
-#endif
- if( FileReadGIF(interp, f, argv[2], "gif") != TCL_OK ){
-#ifdef TKANIM_DEBUG
- fprintf(stderr, "\n\tRead failed", realFileName);
-#endif
- return TCL_ERROR;
- }
- fclose(f);
-#ifdef TKANIM_DEBUG
- fprintf(stderr, "\n\tRead done", realFileName);
-#endif
-#ifdef TKANIM_DEBUG
- fprintf(stderr, "done\n");
-#endif
- }
- return TCL_OK;
-}
-
-void
-TkDeleteTkAnim(clientData)
- ClientData clientData;
-{
-#ifdef TKANIM_DEBUG
- fprintf(stderr, "TkDeleteTkAnim\n");
-#endif
-}
-
-int Tkanim_Init(interp)
- Tcl_Interp *interp;
-{
-#ifdef TKANIM_DEBUG
- fprintf(stderr, "Tkanim initialize...");
-#endif
- Tcl_CreateCommand(interp, "animation", Tk_AnimationCmd,
- (ClientData) NULL,
- (Tcl_CmdDeleteProc *) TkDeleteTkAnim);
-#ifdef TKANIM_DEBUG
- fprintf(stderr, "done\n");
-#endif
- return Tcl_PkgProvide(interp, "Tkanim", TKANIM_VERSION );
-}
diff --git a/otherlibs/labltk/tkanim/tkAppInit.c b/otherlibs/labltk/tkanim/tkAppInit.c
deleted file mode 100644
index 60807d9152..0000000000
--- a/otherlibs/labltk/tkanim/tkAppInit.c
+++ /dev/null
@@ -1,141 +0,0 @@
-/***********************************************************************/
-/* */
-/* MLTk, Tcl/Tk interface of Objective Caml */
-/* */
-/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */
-/* projet Cristal, INRIA Rocquencourt */
-/* Jacques Garrigue, Kyoto University RIMS */
-/* */
-/* Copyright 2002 Institut National de Recherche en Informatique et */
-/* en Automatique and Kyoto University. All rights reserved. */
-/* This file is distributed under the terms of the GNU Library */
-/* General Public License, with the special exception on linking */
-/* described in file LICENSE found in the Objective Caml source tree. */
-/* */
-/***********************************************************************/
-/*
- * tkAppInit.c --
- *
- * Provides a default version of the Tcl_AppInit procedure for
- * use in wish and similar Tk-based applications.
- *
- * Copyright (c) 1993 The Regents of the University of California.
- * Copyright (c) 1994 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- */
-
-#ifndef lint
-static char sccsid[] = "@(#) tkAppInit.c 1.19 95/12/23 17:09:24";
-#endif /* not lint */
-
-#include "tk.h"
-
-int Tkanimation_Init _ANSI_ARGS_ ((Tcl_Interp *interp));
-
-/*
- * The following variable is a special hack that is needed in order for
- * Sun shared libraries to be used for Tcl.
- */
-
-extern int matherr();
-int *tclDummyMathPtr = (int *) matherr;
-
-#ifdef TK_TEST
-EXTERN int Tktest_Init _ANSI_ARGS_((Tcl_Interp *interp));
-#endif /* TK_TEST */
-
-/*
- *----------------------------------------------------------------------
- *
- * main --
- *
- * This is the main program for the application.
- *
- * Results:
- * None: Tk_Main never returns here, so this procedure never
- * returns either.
- *
- * Side effects:
- * Whatever the application does.
- *
- *----------------------------------------------------------------------
- */
-
-int
-main(argc, argv)
- int argc; /* Number of command-line arguments. */
- char **argv; /* Values of command-line arguments. */
-{
- Tk_Main(argc, argv, Tcl_AppInit);
- return 0; /* Needed only to prevent compiler warning. */
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_AppInit --
- *
- * This procedure performs application-specific initialization.
- * Most applications, especially those that incorporate additional
- * packages, will have their own version of this procedure.
- *
- * Results:
- * Returns a standard Tcl completion code, and leaves an error
- * message in interp->result if an error occurs.
- *
- * Side effects:
- * Depends on the startup script.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_AppInit(interp)
- Tcl_Interp *interp; /* Interpreter for application. */
-{
- if (Tcl_Init(interp) == TCL_ERROR) {
- return TCL_ERROR;
- }
- if (Tk_Init(interp) == TCL_ERROR) {
- return TCL_ERROR;
- }
- Tcl_StaticPackage(interp, "Tk", Tk_Init, (Tcl_PackageInitProc *) NULL);
-#ifdef TK_TEST
- if (Tktest_Init(interp) == TCL_ERROR) {
- return TCL_ERROR;
- }
-#endif /* TK_TEST */
-
-
- /*
- * Call the init procedures for included packages. Each call should
- * look like this:
- *
- * if (Mod_Init(interp) == TCL_ERROR) {
- * return TCL_ERROR;
- * }
- *
- * where "Mod" is the name of the module.
- */
-
- if (Tkanim_Init(interp) == TCL_ERROR) {
- return TCL_ERROR;
- }
-
- /*
- * Call Tcl_CreateCommand for application-specific commands, if
- * they weren't already created by the init procedures called above.
- */
-
- /*
- * Specify a user-specific startup file to invoke if the application
- * is run interactively. Typically the startup file is "~/.apprc"
- * where "app" is the name of the application. If this line is deleted
- * then no user-specific startup file will be run under any conditions.
- */
-
- Tcl_SetVar(interp, "tcl_rcFileName", "~/.tkanimationrc", TCL_GLOBAL_ONLY);
- return TCL_OK;
-}
diff --git a/otherlibs/labltk/tkanim/tkanim.ml b/otherlibs/labltk/tkanim/tkanim.ml
deleted file mode 100644
index cc859e1cfd..0000000000
--- a/otherlibs/labltk/tkanim/tkanim.ml
+++ /dev/null
@@ -1,230 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-open Widget
-open Support
-open Protocol
-open Tkintf
-
-external init : unit -> unit = "tkanim_init"
-
-type gifFrame = {
- imagephoto : imagePhoto;
- frameWidth : int;
- frameHeight : int;
- left : int;
- top : int;
- delay : int
- }
-
-type animatedGif = {
- frames : gifFrame list;
- animWidth : int;
- animHeight : int;
- loop : int
-}
-
-type imageType =
- | Still of Tk.options
- | Animated of animatedGif
-
-let debug = ref false
-
-let cTKtoCAMLgifFrame s =
- match splitlist s with
- | [photo; width; height; left; top; delay] ->
- {imagephoto = cTKtoCAMLimagePhoto photo;
- frameWidth = int_of_string width;
- frameHeight = int_of_string height;
- left = int_of_string left;
- top = int_of_string top;
- delay = int_of_string delay}
- | _ -> raise (Invalid_argument ("cTKtoCAMLgifFrame: " ^ s))
-
-let cTKtoCAMLanimatedGif s =
- match splitlist s with
- | [width; height; frames; loop] ->
- {frames = List.map cTKtoCAMLgifFrame (splitlist frames);
- animWidth = int_of_string width;
- animHeight = int_of_string height;
- loop = int_of_string loop}
- | _ -> raise (Invalid_argument ("cTKtoCAMLgifFrame: " ^ s))
-
-(* check Tkanim package is in the interpreter *)
-let available () =
- let packages =
- splitlist (Protocol.tkEval [| TkToken "package";
- TkToken "names" |])
- in
- List.mem "Tkanim" packages
-
-let create file =
- let s =
- Protocol.tkEval [| TkToken "animation";
- TkToken "create";
- TkToken file |]
- in
- let anmgif = cTKtoCAMLanimatedGif s in
- match anmgif.frames with
- | [] -> raise (TkError "Null frame in a gif ?")
- | [x] -> Still (ImagePhoto x.imagephoto)
- | _ -> Animated anmgif
-
-let delete anim =
- List.iter (fun {imagephoto = i} -> Imagephoto.delete i) anim.frames
-
-let width anm = anm.animWidth
-let height anm = anm.animHeight
-let images anm = List.map (fun x -> x.imagephoto) anm.frames
-
-let image_existence_check img =
- (* I found there is a bug in Tk (even v8.0a2). *)
- (* We can copy from deleted images, Tk never says "it doesn't exist", *)
- (* But just do some operation. And sometimes it causes Seg-fault. *)
- (* So, before using Imagephoto.copy, I should check the source image *)
- (* really exists. *)
- try ignore (Imagephoto.height img) with
- TkError s -> prerr_endline ("tkanim: " ^ s); raise (TkError s)
-
-let imagephoto_copy dst src opts =
- image_existence_check src;
- Imagephoto.copy dst src opts
-
-let animate_gen w i anim =
- let length = List.length anim.frames in
- let frames = Array.of_list anim.frames in
- let current = ref 0 in
- let loop = ref anim.loop in
- let f = frames.(!current) in
- imagephoto_copy i f.imagephoto
- [ImgTo (f.left, f.top, f.left + f.frameWidth,
- f.top + f.frameHeight)];
- let visible = ref true in
- let animated = ref false in
- let timer = ref None in
- (* Loop *)
- let display_current () =
- let f = frames.(!current) in
- imagephoto_copy i f.imagephoto
- [ImgTo (f.left, f.top,
- f.left + f.frameWidth, f.top + f.frameHeight)]
- in
- let rec tick () =
- if not (Winfo.exists w && Winfo.viewable w) then begin
- (* the widget is invisible. stop animation for efficiency *)
- if !debug then prerr_endline "Stopped (Visibility)";
- visible := false;
- end else
- begin
- display_current ();
- let t =
- Timer.add (if f.delay = 0 then 100 else f.delay * 10)
- (fun () ->
- incr current;
- if !current = length then begin
- current := 0;
- (* loop check *)
- if !loop > 1 then begin
- decr loop;
- if !loop = 0 then begin
- if !debug then prerr_endline "Loop end";
- (* stop *)
- loop := anim.loop;
- timer := None
- end
- end
- end;
- tick ())
- in
- timer := Some t
- end
- in
- let start () =
- animated := true;
- tick ()
- in
- let stop () =
- match !timer with
- | Some t ->
- Timer.remove t;
- timer := None;
- animated := false
- | None -> ()
- in
- let next () =
- if !timer = None then begin
- incr current;
- if !current = length then current := 0;
- display_current ()
- end
- in
- (* We shouldn't delete the animation here. *)
-(*
- bind w [[], Destroy]
- (BindSet ([], (fun _ -> Imagephoto.delete i)));
-*)
- bind w [[], Visibility]
- (BindSet ([], (fun _ ->
- if not !visible then begin
- visible := true;
- if !animated then start ()
- end)));
- (function
- | false ->
- if !animated then stop () else start ()
- | true -> next ())
-
-let animate label anim =
- (* prerr_endline "animate"; *)
- let i = Imagephoto.create [Width (Pixels anim.animWidth);
- Height (Pixels anim.animHeight)]
- in
- bind label [[], Destroy] (BindExtend ([], (fun _ ->
- Imagephoto.delete i)));
- Label.configure label [ImagePhoto i];
- animate_gen label i anim
-
-let animate_canvas_item canvas tag anim =
-(* prerr_endline "animate"; *)
- let i = Imagephoto.create [Width (Pixels anim.animWidth);
- Height (Pixels anim.animHeight)]
- in
- bind canvas [[], Destroy] (BindExtend ([], (fun _ ->
- Imagephoto.delete i)));
- Canvas.configure_image canvas tag [ImagePhoto i];
- animate_gen canvas i anim
-
-let gifdata s =
- let tmp_dir = ref "/tmp" in
- let mktemp =
- let cnter = ref 0
- and pid = Unix.getpid() in
- (function prefx ->
- incr cnter;
- (Filename.concat !tmp_dir
- (prefx ^ string_of_int pid ^ "." ^ string_of_int !cnter)))
- in
- let fname = mktemp "gifdata" in
- let oc = open_out_bin fname in
- try
- output_string oc s;
- close_out oc;
- let anim = create fname in
- Unix.unlink fname;
- anim
- with
- e -> begin Unix.unlink fname; raise e end
-
diff --git a/otherlibs/labltk/tkanim/tkanim.mli b/otherlibs/labltk/tkanim/tkanim.mli
deleted file mode 100644
index e83ceb9bd1..0000000000
--- a/otherlibs/labltk/tkanim/tkanim.mli
+++ /dev/null
@@ -1,95 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique and Kyoto University. All rights reserved. *)
-(* This file is distributed under the terms of the GNU Library *)
-(* General Public License, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Camltk
-open Widget
-open Support
-
-(*** Data types ***)
-
-type animatedGif
-
- (* This data type contains all the information of an animation of
- gif89a format. It is still test implementation, so I should
- keep it abstract. --- JPF *)
-
-type imageType =
- | Still of Tk.options
- | Animated of animatedGif
-
- (* This data type is required to distinguish normal still images
- and animated gifs. Usually objects typed imagePhoto or
- imageBitmap are used for Still. *)
-
-(*** Flags ***)
-
-val debug : bool ref
-
-(*** Library availability check ***)
-
-val init : unit -> unit
-
- (* This function calls the initialization function for Tkanim
- Tcl/Tk extension. *)
-
-val available : unit -> bool
-
- (* [available ()] returns true if there is Tkanim Tcl/Tk
- extension linked statically/dynamically in Tcl/Tk
- interpreter. Otherwise, return false. *)
-
-(*** User interface ***)
-
-(* create is unsafe *)
-val create : string -> imageType
-
- (* [create file] loads a gif87 or gif89 image file and parse it,
- and returns [Animated animated_gif] if the image file has
- more than one images. Otherwise, it returns
- [Still (ImagePhoto image_photo)] *)
-
-val delete : animatedGif -> unit
-
- (* [delete anim] deletes all the images in anim. Usually
- animatedGifs contain many images, so you must not forget to
- use this function to free the memory. *)
-
-val width : animatedGif -> int
-val height : animatedGif -> int
- (* [width anim] and [height anim] return the width and height of
- given animated gif. *)
-
-val images : animatedGif -> imagePhoto list
- (* [images anim] returns the list of still images used in the
- animation *)
-
-val animate : widget -> animatedGif -> bool -> unit
-val animate_canvas_item : widget -> tagOrId -> animatedGif -> bool -> unit
- (* The display functions for animated gifs. Since [animatedGif] is
- an abstract type, you must use those functions to display
- [animatedGif] images.
- [animate label anim] and [animate_canvas_item canvas tag anim]
- display animation [anim] on a label widget [label] or an
- image tag [tag] on a canvas widget [canvas] respectively.
-
- Note that animation is stopped by default.
- These functions return interface functions, say, [inter :
- bool -> unit]. Currently, [inter false] toggles start/stop of
- the animation, and [inter true] displays the next frame of
- the animation if the animation is stopped. *)
-
-val gifdata : string -> imageType
- (* [gifdata data] reads [data] as a row data of a gif file and
- decodes it. *)
diff --git a/otherlibs/macosunix/.cvsignore b/otherlibs/macosunix/.cvsignore
deleted file mode 100644
index 2bbb2a16c5..0000000000
--- a/otherlibs/macosunix/.cvsignore
+++ /dev/null
@@ -1,71 +0,0 @@
-*.x
-byterun
-config
-accept.c
-access.c
-addrofstr.c
-alarm.c
-bind.c
-chdir.c
-chmod.c
-close.c
-closedir.c
-connect.c
-cst2constr.c
-cstringv.c
-dup.c
-dup2.c
-errmsg.c
-exit.c
-fchmod.c
-fchown.c
-fcntl.c
-ftruncate.c
-getcwd.c
-getgroups.c
-gethost.c
-gethostname.c
-getpeername.c
-getproto.c
-getserv.c
-getsockname.c
-gettimeofday.c
-gmtime.c
-itimer.c
-listen.c
-lockf.c
-lseek.c
-mkdir.c
-open.c
-opendir.c
-pipe.c
-putenv.c
-read.c
-readdir.c
-readlink.c
-rename.c
-rewinddir.c
-rmdir.c
-select.c
-sendrecv.c
-setsid.c
-shutdown.c
-signals.c
-sleep.c
-socket.c
-socketaddr.c
-socketpair.c
-sockopt.c
-stat.c
-strofaddr.c
-symlink.c
-termios.c
-truncate.c
-unixsupport.c
-unlink.c
-utimes.c
-write.c
-cst2constr.h
-socketaddr.h
-unix.ml
-unix.mli
diff --git a/otherlibs/macosunix/Makefile.Mac b/otherlibs/macosunix/Makefile.Mac
deleted file mode 100644
index 4eecaf1cbf..0000000000
--- a/otherlibs/macosunix/Makefile.Mac
+++ /dev/null
@@ -1,152 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Damien Doligez, projet Moscova, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-includepath = ":config:,:byterun:,{GUSI}include:"
-
-C = sc
-COptions = -i {includepath} -includes unix -w 30,35 {cdbgflag} -model far
-
-PPCC = mrc
-PPCCOptions = -i {includepath} -includes unix -w 30,35 {cdbgflag}
-
-CAMLC = :::boot:ocamlrun :::boot:ocamlc -I :::stdlib: -warn-error A
-
-
-# Files in this directory
-MAC_OBJS = macosunix.c.o
-
-MAC_OBJSPPC = macosunix.c.x
-
-# Files from the ::unix: directory
-UNIX_FILES = accept.c access.c addrofstr.c alarm.c bind.c ¶
- chdir.c chmod.c close.c closedir.c ¶
- connect.c cst2constr.c cstringv.c dup.c dup2.c ¶
- errmsg.c exit.c ¶
- fchmod.c fchown.c fcntl.c ftruncate.c ¶
- getcwd.c ¶
- getgroups.c gethost.c gethostname.c ¶
- getpeername.c getproto.c ¶
- getserv.c getsockname.c gettimeofday.c ¶
- gmtime.c itimer.c listen.c lockf.c ¶
- lseek.c mkdir.c open.c opendir.c ¶
- pipe.c putenv.c read.c readdir.c readlink.c ¶
- rename.c rewinddir.c rmdir.c select.c sendrecv.c ¶
- setsid.c shutdown.c signals.c ¶
- sleep.c socket.c socketaddr.c socketpair.c ¶
- sockopt.c stat.c strofaddr.c symlink.c termios.c ¶
- truncate.c unixsupport.c ¶
- unlink.c utimes.c write.c ¶
- ¶
- cst2constr.h socketaddr.h ¶
- unix.ml unix.mli
-
-UNIX_OBJS = accept.c.o access.c.o addrofstr.c.o alarm.c.o bind.c.o ¶
- chdir.c.o chmod.c.o close.c.o closedir.c.o ¶
- connect.c.o cst2constr.c.o cstringv.c.o dup.c.o dup2.c.o ¶
- errmsg.c.o exit.c.o ¶
- fchmod.c.o fchown.c.o fcntl.c.o ftruncate.c.o ¶
- getcwd.c.o ¶
- getgroups.c.o gethost.c.o gethostname.c.o ¶
- getpeername.c.o getproto.c.o ¶
- getserv.c.o getsockname.c.o gettimeofday.c.o ¶
- gmtime.c.o itimer.c.o listen.c.o lockf.c.o ¶
- lseek.c.o mkdir.c.o open.c.o opendir.c.o ¶
- pipe.c.o putenv.c.o read.c.o readdir.c.o readlink.c.o ¶
- rename.c.o rewinddir.c.o rmdir.c.o select.c.o sendrecv.c.o ¶
- setsid.c.o shutdown.c.o signals.c.o ¶
- sleep.c.o socket.c.o socketaddr.c.o socketpair.c.o ¶
- sockopt.c.o stat.c.o strofaddr.c.o symlink.c.o termios.c.o ¶
- truncate.c.o unixsupport.c.o ¶
- unlink.c.o utimes.c.o write.c.o
-
-PPCUNIX_OBJS = accept.c.x access.c.x addrofstr.c.x alarm.c.x bind.c.x ¶
- chdir.c.x chmod.c.x close.c.x closedir.c.x ¶
- connect.c.x cst2constr.c.x cstringv.c.x dup.c.x dup2.c.x ¶
- errmsg.c.x exit.c.x ¶
- fchmod.c.x fchown.c.x fcntl.c.x ftruncate.c.x ¶
- getcwd.c.x ¶
- getgroups.c.x gethost.c.x gethostname.c.x ¶
- getpeername.c.x getproto.c.x ¶
- getserv.c.x getsockname.c.x gettimeofday.c.x ¶
- gmtime.c.x itimer.c.x listen.c.x lockf.c.x ¶
- lseek.c.x mkdir.c.x open.c.x opendir.c.x ¶
- pipe.c.x putenv.c.x read.c.x readdir.c.x readlink.c.x ¶
- rename.c.x rewinddir.c.x rmdir.c.x select.c.x sendrecv.c.x ¶
- setsid.c.x shutdown.c.x signals.c.x ¶
- sleep.c.x socket.c.x socketaddr.c.x socketpair.c.x ¶
- sockopt.c.x stat.c.x strofaddr.c.x symlink.c.x termios.c.x ¶
- truncate.c.x unixsupport.c.x ¶
- unlink.c.x utimes.c.x write.c.x
-
-C_OBJS = {MAC_OBJS} {UNIX_OBJS}
-C_OBJSPPC = {MAC_OBJSPPC} {PPCUNIX_OBJS}
-
-CAML_OBJS = macosunix_startup.cmo unix.cmo
-
-all Ä
- domake copy-files
- directory :byterun:
- domake libcamlrun.x libcamlrun.o
- directory ::
- domake libcamlrun-unix.x libcamlrun-unix.o unix.cma
-
-### WATCH OUT: libcamlrun.[ox] must be linked last to override getcwd
-
-libcamlrun-unix.x Ä {C_OBJSPPC} :byterun:libcamlrun.x
- ppclink {ldbgflag} -xm library -o libcamlrun-unix.x ¶
- {C_OBJSPPC} :byterun:libcamlrun.x
-
-libcamlrun-unix.o Ä {C_OBJS} :byterun:libcamlrun.o
- lib {ldbgflag} -o libcamlrun-unix.o {C_OBJS} :byterun:libcamlrun.o
-
-copy-files Ä $OutOfDate
- directory ::unix:
- duplicate -y {UNIX_FILES} ::macosunix:
- directory ::macosunix:
- newfolder :byterun || set status 0
- duplicate -y :::byterun:Å.[ach] :::byterun:Makefile.Mac.depend :byterun:
- begin
- echo 'ocamlgusiflag = -d macintosh_GUSI -includes unix -i "{GUSI}include:"'
- catenate :::byterun:Makefile.Mac
- end > :byterun:Makefile.Mac
- duplicate -y :::config: :
-
-unix.cma Ä {CAML_OBJS}
- {CAMLC} -a -linkall -o unix.cma {CAML_OBJS}
-
-partialclean Ä
- delete -i Å.cmÅ || set status 0
-
-clean Ä partialclean
- delete -i Å.[xo] || set status 0
- delete -i -y :byterun :config
- delete -i {UNIX_FILES}
-
-install Ä
- duplicate -y libcamlrun-unix.o libcamlrun-unix.x unix.cmi unix.cma ¶
- "{LIBDIR}"
-
-.cmi Ä .mli
- {CAMLC} -c {COMPFLAGS} "{depdir}{default}.mli"
-
-.cmo Ä .ml
- {CAMLC} -c {COMPFLAGS} "{depdir}{default}.ml"
-
-depend Ä copy-files
- begin
- MakeDepend -w -objext .x Å.c
- MakeDepend -w Å.c
- :::boot:ocamlrun :::tools:ocamldep Å.mli Å.ml
- end | streamedit -e "/¶t/ replace // ' ' -c °" > Makefile.Mac.depend
diff --git a/otherlibs/macosunix/Makefile.Mac.depend b/otherlibs/macosunix/Makefile.Mac.depend
deleted file mode 100644
index bf3f0f8fbe..0000000000
--- a/otherlibs/macosunix/Makefile.Mac.depend
+++ /dev/null
@@ -1,872 +0,0 @@
-#*** Dependencies: Cut here ***
-# These dependencies were produced at 23:43:09 on 27 fŽv 2001 by MakeDepend
-
-:accept.c.x Ä ¶
- :accept.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- :socketaddr.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:access.c.x Ä ¶
- :access.c ¶
- :unixsupport.h
-
-:addrofstr.c.x Ä ¶
- :addrofstr.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:alarm.c.x Ä ¶
- :alarm.c ¶
- :unixsupport.h
-
-:bind.c.x Ä ¶
- :bind.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:chdir.c.x Ä ¶
- :chdir.c ¶
- :unixsupport.h
-
-:chmod.c.x Ä ¶
- :chmod.c ¶
- :unixsupport.h
-
-:close.c.x Ä ¶
- :close.c ¶
- :unixsupport.h
-
-:closedir.c.x Ä ¶
- :closedir.c ¶
- :unixsupport.h
-
-:connect.c.x Ä ¶
- :connect.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:cst2constr.c.x Ä ¶
- :cst2constr.c ¶
- :cst2constr.h
-
-:cstringv.c.x Ä ¶
- :cstringv.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:dup.c.x Ä ¶
- :dup.c ¶
- :unixsupport.h
-
-:dup2.c.x Ä ¶
- :dup2.c ¶
- :unixsupport.h
-
-:errmsg.c.x Ä ¶
- :errmsg.c ¶
- "{CIncludes}"errno.h
-
-:exit.c.x Ä ¶
- :exit.c ¶
- :unixsupport.h
-
-:fchmod.c.x Ä ¶
- :fchmod.c ¶
- :unixsupport.h
-
-:fchown.c.x Ä ¶
- :fchown.c ¶
- :unixsupport.h
-
-:fcntl.c.x Ä ¶
- :fcntl.c ¶
- :unixsupport.h ¶
- "{CIncludes}"fcntl.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"SizeTDef.h
-
-:ftruncate.c.x Ä ¶
- :ftruncate.c ¶
- :unixsupport.h
-
-:getcwd.c.x Ä ¶
- :getcwd.c ¶
- :unixsupport.h
-
-:getgroups.c.x Ä ¶
- :getgroups.c ¶
- "{CIncludes}"limits.h ¶
- :unixsupport.h
-
-:gethost.c.x Ä ¶
- :gethost.c ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- :socketaddr.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:gethostname.c.x Ä ¶
- :gethostname.c ¶
- :unixsupport.h
-
-:getpeername.c.x Ä ¶
- :getpeername.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:getproto.c.x Ä ¶
- :getproto.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:getserv.c.x Ä ¶
- :getserv.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:getsockname.c.x Ä ¶
- :getsockname.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:gettimeofday.c.x Ä ¶
- :gettimeofday.c ¶
- :unixsupport.h
-
-:gmtime.c.x Ä ¶
- :gmtime.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"time.h ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:itimer.c.x Ä ¶
- :itimer.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:listen.c.x Ä ¶
- :listen.c ¶
- :unixsupport.h
-
-:lockf.c.x Ä ¶
- :lockf.c ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"fcntl.h ¶
- :unixsupport.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"SizeTDef.h
-
-:lseek.c.x Ä ¶
- :lseek.c ¶
- :unixsupport.h
-
-:macosunix.c.x Ä ¶
- :macosunix.c ¶
- "{CIncludes}"Events.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"Resources.h ¶
- "{CIncludes}"TextUtils.h ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"time.h ¶
- :unixsupport.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Quickdraw.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"MixedMode.h ¶
- "{CIncludes}"NumberFormatting.h ¶
- "{CIncludes}"StringCompare.h ¶
- "{CIncludes}"DateTimeUtils.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"TextCommon.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"IntlResources.h ¶
- "{CIncludes}"Script.h ¶
- "{CIncludes}"MacErrors.h
-
-:mkdir.c.x Ä ¶
- :mkdir.c ¶
- :unixsupport.h
-
-:open.c.x Ä ¶
- :open.c ¶
- :unixsupport.h ¶
- "{CIncludes}"fcntl.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"SizeTDef.h
-
-:opendir.c.x Ä ¶
- :opendir.c ¶
- :unixsupport.h
-
-:pipe.c.x Ä ¶
- :pipe.c ¶
- :unixsupport.h
-
-:putenv.c.x Ä ¶
- :putenv.c ¶
- "{CIncludes}"stdlib.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"WCharTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:read.c.x Ä ¶
- :read.c ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:readdir.c.x Ä ¶
- :readdir.c ¶
- :unixsupport.h
-
-:readlink.c.x Ä ¶
- :readlink.c ¶
- :unixsupport.h
-
-:rename.c.x Ä ¶
- :rename.c ¶
- "{CIncludes}"stdio.h ¶
- :unixsupport.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"VaListTDef.h
-
-:rewinddir.c.x Ä ¶
- :rewinddir.c ¶
- :unixsupport.h
-
-:rmdir.c.x Ä ¶
- :rmdir.c ¶
- :unixsupport.h
-
-:select.c.x Ä ¶
- :select.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:sendrecv.c.x Ä ¶
- :sendrecv.c ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- :socketaddr.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:setsid.c.x Ä ¶
- :setsid.c ¶
- :unixsupport.h
-
-:shutdown.c.x Ä ¶
- :shutdown.c ¶
- :unixsupport.h
-
-:signals.c.x Ä ¶
- :signals.c ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:sleep.c.x Ä ¶
- :sleep.c ¶
- :unixsupport.h
-
-:socket.c.x Ä ¶
- :socket.c ¶
- :unixsupport.h
-
-:socketaddr.c.x Ä ¶
- :socketaddr.c ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"memory.h ¶
- "{CIncludes}"errno.h ¶
- :unixsupport.h ¶
- :socketaddr.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:socketpair.c.x Ä ¶
- :socketpair.c ¶
- :unixsupport.h
-
-:sockopt.c.x Ä ¶
- :sockopt.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:stat.c.x Ä ¶
- :stat.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- :cst2constr.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:strofaddr.c.x Ä ¶
- :strofaddr.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:symlink.c.x Ä ¶
- :symlink.c ¶
- :unixsupport.h
-
-:termios.c.x Ä ¶
- :termios.c ¶
- :unixsupport.h ¶
- "{CIncludes}"errno.h
-
-:truncate.c.x Ä ¶
- :truncate.c ¶
- :unixsupport.h
-
-:unixsupport.c.x Ä ¶
- :unixsupport.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- :cst2constr.h ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:unlink.c.x Ä ¶
- :unlink.c ¶
- :unixsupport.h
-
-:utimes.c.x Ä ¶
- :utimes.c ¶
- :unixsupport.h
-
-:write.c.x Ä ¶
- :write.c ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-#*** Dependencies: Cut here ***
-# These dependencies were produced at 23:43:16 on 27 fŽv 2001 by MakeDepend
-
-:accept.c.o Ä ¶
- :accept.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- :socketaddr.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:access.c.o Ä ¶
- :access.c ¶
- :unixsupport.h
-
-:addrofstr.c.o Ä ¶
- :addrofstr.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:alarm.c.o Ä ¶
- :alarm.c ¶
- :unixsupport.h
-
-:bind.c.o Ä ¶
- :bind.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:chdir.c.o Ä ¶
- :chdir.c ¶
- :unixsupport.h
-
-:chmod.c.o Ä ¶
- :chmod.c ¶
- :unixsupport.h
-
-:close.c.o Ä ¶
- :close.c ¶
- :unixsupport.h
-
-:closedir.c.o Ä ¶
- :closedir.c ¶
- :unixsupport.h
-
-:connect.c.o Ä ¶
- :connect.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:cst2constr.c.o Ä ¶
- :cst2constr.c ¶
- :cst2constr.h
-
-:cstringv.c.o Ä ¶
- :cstringv.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:dup.c.o Ä ¶
- :dup.c ¶
- :unixsupport.h
-
-:dup2.c.o Ä ¶
- :dup2.c ¶
- :unixsupport.h
-
-:errmsg.c.o Ä ¶
- :errmsg.c ¶
- "{CIncludes}"errno.h
-
-:exit.c.o Ä ¶
- :exit.c ¶
- :unixsupport.h
-
-:fchmod.c.o Ä ¶
- :fchmod.c ¶
- :unixsupport.h
-
-:fchown.c.o Ä ¶
- :fchown.c ¶
- :unixsupport.h
-
-:fcntl.c.o Ä ¶
- :fcntl.c ¶
- :unixsupport.h ¶
- "{CIncludes}"fcntl.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"SizeTDef.h
-
-:ftruncate.c.o Ä ¶
- :ftruncate.c ¶
- :unixsupport.h
-
-:getcwd.c.o Ä ¶
- :getcwd.c ¶
- :unixsupport.h
-
-:getgroups.c.o Ä ¶
- :getgroups.c ¶
- "{CIncludes}"limits.h ¶
- :unixsupport.h
-
-:gethost.c.o Ä ¶
- :gethost.c ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- :socketaddr.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:gethostname.c.o Ä ¶
- :gethostname.c ¶
- :unixsupport.h
-
-:getpeername.c.o Ä ¶
- :getpeername.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:getproto.c.o Ä ¶
- :getproto.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:getserv.c.o Ä ¶
- :getserv.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:getsockname.c.o Ä ¶
- :getsockname.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:gettimeofday.c.o Ä ¶
- :gettimeofday.c ¶
- :unixsupport.h
-
-:gmtime.c.o Ä ¶
- :gmtime.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"time.h ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:itimer.c.o Ä ¶
- :itimer.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:listen.c.o Ä ¶
- :listen.c ¶
- :unixsupport.h
-
-:lockf.c.o Ä ¶
- :lockf.c ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"fcntl.h ¶
- :unixsupport.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"SizeTDef.h
-
-:lseek.c.o Ä ¶
- :lseek.c ¶
- :unixsupport.h
-
-:macosunix.c.o Ä ¶
- :macosunix.c ¶
- "{CIncludes}"Events.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"Resources.h ¶
- "{CIncludes}"TextUtils.h ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"time.h ¶
- :unixsupport.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Quickdraw.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"MixedMode.h ¶
- "{CIncludes}"NumberFormatting.h ¶
- "{CIncludes}"StringCompare.h ¶
- "{CIncludes}"DateTimeUtils.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"TextCommon.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"IntlResources.h ¶
- "{CIncludes}"Script.h ¶
- "{CIncludes}"MacErrors.h
-
-:mkdir.c.o Ä ¶
- :mkdir.c ¶
- :unixsupport.h
-
-:open.c.o Ä ¶
- :open.c ¶
- :unixsupport.h ¶
- "{CIncludes}"fcntl.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"SizeTDef.h
-
-:opendir.c.o Ä ¶
- :opendir.c ¶
- :unixsupport.h
-
-:pipe.c.o Ä ¶
- :pipe.c ¶
- :unixsupport.h
-
-:putenv.c.o Ä ¶
- :putenv.c ¶
- "{CIncludes}"stdlib.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"WCharTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:read.c.o Ä ¶
- :read.c ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:readdir.c.o Ä ¶
- :readdir.c ¶
- :unixsupport.h
-
-:readlink.c.o Ä ¶
- :readlink.c ¶
- :unixsupport.h
-
-:rename.c.o Ä ¶
- :rename.c ¶
- "{CIncludes}"stdio.h ¶
- :unixsupport.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"VaListTDef.h
-
-:rewinddir.c.o Ä ¶
- :rewinddir.c ¶
- :unixsupport.h
-
-:rmdir.c.o Ä ¶
- :rmdir.c ¶
- :unixsupport.h
-
-:select.c.o Ä ¶
- :select.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:sendrecv.c.o Ä ¶
- :sendrecv.c ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- :socketaddr.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:setsid.c.o Ä ¶
- :setsid.c ¶
- :unixsupport.h
-
-:shutdown.c.o Ä ¶
- :shutdown.c ¶
- :unixsupport.h
-
-:signals.c.o Ä ¶
- :signals.c ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:sleep.c.o Ä ¶
- :sleep.c ¶
- :unixsupport.h
-
-:socket.c.o Ä ¶
- :socket.c ¶
- :unixsupport.h
-
-:socketaddr.c.o Ä ¶
- :socketaddr.c ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"memory.h ¶
- "{CIncludes}"errno.h ¶
- :unixsupport.h ¶
- :socketaddr.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:socketpair.c.o Ä ¶
- :socketpair.c ¶
- :unixsupport.h
-
-:sockopt.c.o Ä ¶
- :sockopt.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:stat.c.o Ä ¶
- :stat.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- :cst2constr.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:strofaddr.c.o Ä ¶
- :strofaddr.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:symlink.c.o Ä ¶
- :symlink.c ¶
- :unixsupport.h
-
-:termios.c.o Ä ¶
- :termios.c ¶
- :unixsupport.h ¶
- "{CIncludes}"errno.h
-
-:truncate.c.o Ä ¶
- :truncate.c ¶
- :unixsupport.h
-
-:unixsupport.c.o Ä ¶
- :unixsupport.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- :cst2constr.h ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:unlink.c.o Ä ¶
- :unlink.c ¶
- :unixsupport.h
-
-:utimes.c.o Ä ¶
- :utimes.c ¶
- :unixsupport.h
-
-:write.c.o Ä ¶
- :write.c ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-macosunix_startup.cmoÄ macosunix_startup.cmi
-macosunix_startup.cmxÄ macosunix_startup.cmi
-unix.cmoÄ unix.cmi
-unix.cmxÄ unix.cmi
diff --git a/otherlibs/macosunix/macosunix.c b/otherlibs/macosunix/macosunix.c
deleted file mode 100644
index 403aaf7045..0000000000
--- a/otherlibs/macosunix/macosunix.c
+++ /dev/null
@@ -1,119 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Moscova, INRIA Rocquencourt */
-/* */
-/* Copyright 1999 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <Events.h>
-#include <Processes.h>
-#include <Resources.h>
-#include <TextUtils.h>
-
-#include <errno.h>
-#include <string.h>
-#include <time.h>
-
-#include <alloc.h>
-#include <mlvalues.h>
-#include <ui.h>
-
-#include "unixsupport.h"
-
-
-static unsigned long start_ticks;
-
-value macosunix_startup (value unit) /* ML */
-{
- start_ticks = TickCount ();
-
- return Val_unit;
-}
-
-value unix_getlogin (void) /* ML */
-{
- char **hs = (char **) GetString (-16096);
- if (hs == NULL || *hs == NULL || strlen (*hs) == 0){
- unix_error (ENOENT, "getlogin", Nothing);
- }
- return copy_string (*hs);
-}
-
-value unix_getegid (void) /* ML */
-{
- return Val_int (1);
-}
-
-value unix_geteuid (void) /* ML */
-{
- return Val_int (1);
-}
-
-value unix_getgid (void) /* ML */
-{
- return Val_int (1);
-}
-
-value unix_getuid (void) /* ML */
-{
- return Val_int (1);
-}
-
-value unix_getpid (void) /* ML */
-{
- ProcessSerialNumber psn;
-
- GetCurrentProcess (&psn);
- return Val_long (psn.lowLongOfPSN);
-}
-
-value unix_time (void) /* ML */
-{
- return copy_double (time (NULL) /* - 2082844800. */);
-}
-
-value unix_times (void) /* ML */
-{
- value res;
-
- res = alloc_small(4 * Double_wosize, Double_array_tag);
- Store_double_field(res, 0, (double) (TickCount () - start_ticks) / 60);
- Store_double_field(res, 1, (double) 0.0);
- Store_double_field(res, 2, (double) 0.0);
- Store_double_field(res, 3, (double) 0.0);
- return res;
-}
-
-#define Unimplemented(f, args) \
- value unix_##f args { invalid_argument (#f " not implemented"); }
-
-Unimplemented (chown, (value path, value uid, value gid))
-Unimplemented (chroot, (value path))
-Unimplemented (environment, (void))
-Unimplemented (execv, (value path, value args))
-Unimplemented (execve, (value path, value args, value env))
-Unimplemented (execvp, (value path, value args))
-Unimplemented (execvpe, (value path, value args, value env))
-Unimplemented (fork, (value unit))
-Unimplemented (getgrnam, (value name))
-Unimplemented (getgrgid, (value gid))
-Unimplemented (getppid, (void))
-Unimplemented (getpwnam, (value name))
-Unimplemented (getpwuid, (value uid))
-Unimplemented (kill, (value pid, value signal))
-Unimplemented (link, (value path1, value path2))
-Unimplemented (mkfifo, (value path, value mode))
-Unimplemented (nice, (value incr))
-Unimplemented (setgid, (value gid))
-Unimplemented (setuid, (value uid))
-Unimplemented (umask, (value perm))
-Unimplemented (wait, (void))
-Unimplemented (waitpid, (value flags, value pid_req))
diff --git a/otherlibs/macosunix/macosunix_startup.ml b/otherlibs/macosunix/macosunix_startup.ml
deleted file mode 100644
index 93c4f213b1..0000000000
--- a/otherlibs/macosunix/macosunix_startup.ml
+++ /dev/null
@@ -1,17 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Damien Doligez, projet Moscova, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2000 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-external startup : unit -> unit = "macosunix_startup";;
-startup ();;
diff --git a/otherlibs/macosunix/macosunix_startup.mli b/otherlibs/macosunix/macosunix_startup.mli
deleted file mode 100644
index 96a84e30b2..0000000000
--- a/otherlibs/macosunix/macosunix_startup.mli
+++ /dev/null
@@ -1,16 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Damien Doligez, projet Moscova, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2000 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* This file left blank intentionally. *)
diff --git a/otherlibs/macosunix/unix-primitives b/otherlibs/macosunix/unix-primitives
deleted file mode 100644
index 9f920883a7..0000000000
--- a/otherlibs/macosunix/unix-primitives
+++ /dev/null
@@ -1,113 +0,0 @@
-macosunix_startup
-unix_accept
-unix_access
-unix_alarm
-unix_bind
-unix_chdir
-unix_chmod
-unix_chown
-unix_chroot
-unix_clear_close_on_exec
-unix_clear_nonblock
-unix_close
-unix_closedir
-unix_connect
-unix_dup
-unix_dup2
-unix_environment
-unix_error_message
-unix_execv
-unix_execve
-unix_execvp
-unix_execvpe
-unix_exit
-unix_fchmod
-unix_fchown
-unix_fork
-unix_fstat
-unix_ftruncate
-unix_getcwd
-unix_getegid
-unix_geteuid
-unix_getgid
-unix_getgrgid
-unix_getgrnam
-unix_getgroups
-unix_gethostbyaddr
-unix_gethostbyname
-unix_gethostname
-unix_getitimer
-unix_getlogin
-unix_getpeername
-unix_getpid
-unix_getppid
-unix_getprotobyname
-unix_getprotobynumber
-unix_getpwnam
-unix_getpwuid
-unix_getservbyname
-unix_getservbyport
-unix_getsockname
-unix_getsockopt
-unix_gettimeofday
-unix_getuid
-unix_gmtime
-unix_inet_addr_of_string
-unix_kill
-unix_link
-unix_listen
-unix_localtime
-unix_lockf
-unix_lseek
-unix_lstat
-unix_mkdir
-unix_mkfifo
-unix_mktime
-unix_nice
-unix_open
-unix_opendir
-unix_pipe
-unix_putenv
-unix_read
-unix_readdir
-unix_readlink
-unix_recv
-unix_recvfrom
-unix_rename
-unix_rewinddir
-unix_rmdir
-unix_select
-unix_send
-unix_sendto
-unix_set_close_on_exec
-unix_set_nonblock
-unix_setgid
-unix_setitimer
-unix_setsid
-unix_setsockopt
-unix_setuid
-unix_shutdown
-unix_sigpending
-unix_sigprocmask
-unix_sigsuspend
-unix_sleep
-unix_socket
-unix_socketpair
-unix_stat
-unix_string_of_inet_addr
-unix_symlink
-unix_tcdrain
-unix_tcflow
-unix_tcflush
-unix_tcgetattr
-unix_tcsendbreak
-unix_tcsetattr
-unix_time
-unix_times
-unix_truncate
-unix_umask
-unix_unlink
-unix_utimes
-unix_wait
-unix_waitpid
-unix_write
diff --git a/otherlibs/macosunix/unixsupport.h b/otherlibs/macosunix/unixsupport.h
deleted file mode 100644
index 8b9e4526f1..0000000000
--- a/otherlibs/macosunix/unixsupport.h
+++ /dev/null
@@ -1,43 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Moscova, INRIA Rocquencourt */
-/* */
-/* Copyright 1999 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#define POSIX_SIGNALS
-#define HAS_MEMMOVE
-#define HAS_STRERROR
-#define HAS_SOCKETS
-#define HAS_SOCKLEN_T
-#define HAS_UNISTD
-#define HAS_DIRENT
-#define HAS_REWINDDIR
-#define HAS_GETCWD
-#define HAS_UTIME
-#define HAS_DUP2
-#define HAS_TRUNCATE
-#define HAS_SELECT
-#define HAS_SYMLINK
-#define HAS_GETHOSTNAME
-#define HAS_GETTIMEOFDAY
-#define HAS_MKTIME
-
-#ifdef HAS_UNISTD
-#include <unistd.h>
-#endif
-
-#define Nothing ((value) 0)
-
-extern void unix_error (int errcode, char * cmdname, value arg) Noreturn;
-extern void uerror (char * cmdname, value arg) Noreturn;
-
-#define UNIX_BUFFER_SIZE 2048
diff --git a/otherlibs/num/.cvsignore b/otherlibs/num/.cvsignore
deleted file mode 100644
index 7786c62f9f..0000000000
--- a/otherlibs/num/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-libnums.x
-*.c.x
-so_locations
diff --git a/otherlibs/num/.depend b/otherlibs/num/.depend
deleted file mode 100644
index a44606d1d8..0000000000
--- a/otherlibs/num/.depend
+++ /dev/null
@@ -1,35 +0,0 @@
-bng_alpha.o: bng_alpha.c
-bng_amd64.o: bng_amd64.c
-bng.o: bng.c bng.h bng_ia32.c bng_digit.c
-bng_digit.o: bng_digit.c
-bng_ia32.o: bng_ia32.c
-bng_mips.o: bng_mips.c
-bng_ppc.o: bng_ppc.c
-bng_sparc.o: bng_sparc.c
-nat_stubs.o: nat_stubs.c ../../byterun/alloc.h ../../byterun/misc.h \
- ../../byterun/config.h ../../config/m.h ../../config/s.h \
- ../../byterun/mlvalues.h ../../byterun/custom.h ../../byterun/intext.h \
- ../../byterun/io.h ../../byterun/fix_code.h ../../byterun/fail.h \
- ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
- ../../byterun/freelist.h ../../byterun/minor_gc.h bng.h nat.h
-big_int.cmi: nat.cmi
-num.cmi: big_int.cmi nat.cmi ratio.cmi
-ratio.cmi: big_int.cmi nat.cmi
-arith_flags.cmo: arith_flags.cmi
-arith_flags.cmx: arith_flags.cmi
-arith_status.cmo: arith_flags.cmi arith_status.cmi
-arith_status.cmx: arith_flags.cmx arith_status.cmi
-big_int.cmo: int_misc.cmi nat.cmi big_int.cmi
-big_int.cmx: int_misc.cmx nat.cmx big_int.cmi
-int_misc.cmo: int_misc.cmi
-int_misc.cmx: int_misc.cmi
-nat.cmo: int_misc.cmi nat.cmi
-nat.cmx: int_misc.cmx nat.cmi
-num.cmo: arith_flags.cmi big_int.cmi int_misc.cmi nat.cmi ratio.cmi num.cmi
-num.cmx: arith_flags.cmx big_int.cmx int_misc.cmx nat.cmx ratio.cmx num.cmi
-ratio.cmo: arith_flags.cmi big_int.cmi int_misc.cmi nat.cmi string_misc.cmi \
- ratio.cmi
-ratio.cmx: arith_flags.cmx big_int.cmx int_misc.cmx nat.cmx string_misc.cmx \
- ratio.cmi
-string_misc.cmo: string_misc.cmi
-string_misc.cmx: string_misc.cmi
diff --git a/otherlibs/num/.depend.nt b/otherlibs/num/.depend.nt
deleted file mode 100644
index 0d604eab10..0000000000
--- a/otherlibs/num/.depend.nt
+++ /dev/null
@@ -1,56 +0,0 @@
-nat_stubs.dobj: nat_stubs.c ../../byterun/alloc.h ../../byterun/misc.h \
- ../../byterun/config.h ../../byterun/../config/m.h \
- ../../byterun/../config/s.h ../../byterun/mlvalues.h \
- ../../byterun/custom.h ../../byterun/intext.h ../../byterun/io.h \
- ../../byterun/fix_code.h ../../byterun/fail.h ../../byterun/memory.h \
- ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
- ../../byterun/minor_gc.h nat.h bignum/h/BigNum.h bignum/h/BntoBnn.h
-big_int.cmi: nat.cmi
-num.cmi: big_int.cmi nat.cmi ratio.cmi
-ratio.cmi: big_int.cmi nat.cmi
-arith_flags.cmo: arith_flags.cmi
-arith_flags.cmx: arith_flags.cmi
-arith_status.cmo: arith_flags.cmi arith_status.cmi
-arith_status.cmx: arith_flags.cmx arith_status.cmi
-big_int.cmo: int_misc.cmi nat.cmi big_int.cmi
-big_int.cmx: int_misc.cmx nat.cmx big_int.cmi
-int_misc.cmo: int_misc.cmi
-int_misc.cmx: int_misc.cmi
-nat.cmo: int_misc.cmi nat.cmi
-nat.cmx: int_misc.cmx nat.cmi
-num.cmo: arith_flags.cmi big_int.cmi int_misc.cmi nat.cmi ratio.cmi num.cmi
-num.cmx: arith_flags.cmx big_int.cmx int_misc.cmx nat.cmx ratio.cmx num.cmi
-ratio.cmo: arith_flags.cmi big_int.cmi int_misc.cmi nat.cmi string_misc.cmi \
- ratio.cmi
-ratio.cmx: arith_flags.cmx big_int.cmx int_misc.cmx nat.cmx string_misc.cmx \
- ratio.cmi
-string_misc.cmo: string_misc.cmi
-string_misc.cmx: string_misc.cmi
-nat_stubs.sobj: nat_stubs.c ../../byterun/alloc.h ../../byterun/misc.h \
- ../../byterun/config.h ../../byterun/../config/m.h \
- ../../byterun/../config/s.h ../../byterun/mlvalues.h \
- ../../byterun/custom.h ../../byterun/intext.h ../../byterun/io.h \
- ../../byterun/fix_code.h ../../byterun/fail.h ../../byterun/memory.h \
- ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
- ../../byterun/minor_gc.h nat.h bignum/h/BigNum.h bignum/h/BntoBnn.h
-big_int.cmi: nat.cmi
-num.cmi: big_int.cmi nat.cmi ratio.cmi
-ratio.cmi: big_int.cmi nat.cmi
-arith_flags.cmo: arith_flags.cmi
-arith_flags.cmx: arith_flags.cmi
-arith_status.cmo: arith_flags.cmi arith_status.cmi
-arith_status.cmx: arith_flags.cmx arith_status.cmi
-big_int.cmo: int_misc.cmi nat.cmi big_int.cmi
-big_int.cmx: int_misc.cmx nat.cmx big_int.cmi
-int_misc.cmo: int_misc.cmi
-int_misc.cmx: int_misc.cmi
-nat.cmo: int_misc.cmi nat.cmi
-nat.cmx: int_misc.cmx nat.cmi
-num.cmo: arith_flags.cmi big_int.cmi int_misc.cmi nat.cmi ratio.cmi num.cmi
-num.cmx: arith_flags.cmx big_int.cmx int_misc.cmx nat.cmx ratio.cmx num.cmi
-ratio.cmo: arith_flags.cmi big_int.cmi int_misc.cmi nat.cmi string_misc.cmi \
- ratio.cmi
-ratio.cmx: arith_flags.cmx big_int.cmx int_misc.cmx nat.cmx string_misc.cmx \
- ratio.cmi
-string_misc.cmo: string_misc.cmi
-string_misc.cmx: string_misc.cmi
diff --git a/otherlibs/num/Makefile b/otherlibs/num/Makefile
deleted file mode 100644
index e79df16c70..0000000000
--- a/otherlibs/num/Makefile
+++ /dev/null
@@ -1,86 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-# Makefile for the "num" (exact rational arithmetic) library
-
-include ../../config/Makefile
-
-# Compilation options
-CC=$(BYTECC)
-CFLAGS=-O -I../../byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) \
- -DBNG_ARCH_$(BNG_ARCH) -DBNG_ASM_LEVEL=$(BNG_ASM_LEVEL)
-CAMLC=../../ocamlcomp.sh -w s
-CAMLOPT=../../ocamlcompopt.sh -w s
-MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib
-COMPFLAGS=-warn-error A
-
-CAMLOBJS=int_misc.cmo string_misc.cmo nat.cmo big_int.cmo arith_flags.cmo \
- ratio.cmo num.cmo arith_status.cmo
-
-CMIFILES=big_int.cmi nat.cmi num.cmi ratio.cmi arith_status.cmi
-
-COBJS=bng.o nat_stubs.o
-
-all: libnums.a nums.cma $(CMIFILES)
-
-allopt: libnums.a nums.cmxa $(CMIFILES)
-
-nums.cma: $(CAMLOBJS)
- $(MKLIB) -ocamlc '$(CAMLC)' -o nums $(CAMLOBJS)
-
-nums.cmxa: $(CAMLOBJS:.cmo=.cmx)
- $(MKLIB) -ocamlopt '$(CAMLOPT)' -o nums $(CAMLOBJS:.cmo=.cmx)
-
-libnums.a: $(COBJS)
- $(MKLIB) -o nums $(COBJS)
-
-$(CAMLOBJS:.cmo=.cmx): ../../ocamlopt
-
-install:
- if test -f dllnums.so; then cp dllnums.so $(STUBLIBDIR)/dllnums.so; fi
- cp libnums.a $(LIBDIR)/libnums.a
- cd $(LIBDIR); $(RANLIB) libnums.a
- cp nums.cma $(CMIFILES) $(CMIFILES:.cmi=.mli) $(LIBDIR)
-
-installopt:
- cp $(CAMLOBJS:.cmo=.cmx) nums.cmxa nums.a $(LIBDIR)
- cd $(LIBDIR); $(RANLIB) nums.a
-
-partialclean:
- rm -f *.cm*
-
-clean: partialclean
- rm -f *.a *.o *.so
- cd test; $(MAKE) clean
-
-.SUFFIXES: .ml .mli .cmi .cmo .cmx
-
-.mli.cmi:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-bng.o: bng.h bng_digit.c \
- bng_alpha.c bng_amd64.c bng_ia32.c bng_mips.c bng_ppc.c bng_sparc.c
-
-depend:
- gcc -MM $(CFLAGS) *.c > .depend
- ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend
-
-include .depend
diff --git a/otherlibs/num/Makefile.Mac b/otherlibs/num/Makefile.Mac
deleted file mode 100644
index 6e3c1e5fd2..0000000000
--- a/otherlibs/num/Makefile.Mac
+++ /dev/null
@@ -1,64 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-# Makefile for the "num" (exact rational arithmetic) library
-
-# Compilation options
-PPCC = mrc
-PPCCOptions = -i :bignum:h:,:::byterun:,:::config: -w 35 {cdbgflag}
-
-CAMLC = :::boot:ocamlrun :::ocamlc -I :::stdlib: -w s
-CAMLOPT = :::boot:ocamlrun :::ocamlopt: -I :::stdlib: -w s
-
-CAMLOBJS = int_misc.cmo string_misc.cmo nat.cmo big_int.cmo arith_flags.cmo ¶
- ratio.cmo num.cmo arith_status.cmo
-
-CMIFILES = big_int.cmi nat.cmi num.cmi ratio.cmi arith_status.cmi
-
-PPCCOBJS = nat_stubs.c.x
-
-all Ä libnums.x nums.cma {CMIFILES}
-
-nums.cma Ä {CAMLOBJS}
- {CAMLC} -a -o nums.cma {CAMLOBJS}
-
-libnums.x Ä :bignum:libbignum.x {PPCCOBJS}
- ppclink {ldbgflag} -xm library -o libnums.x :bignum:libbignum.x {PPCCOBJS}
-
-:bignum:libbignum.x Ä :bignum:libbignum.o
- directory :bignum; domake C; directory ::
-
-install Ä
- duplicate -y libnums.x nums.cma {CMIFILES} "{LIBDIR}"
-
-partialclean Ä
- delete -i Å.cm[aio] || set status 0
-
-clean Ä partialclean
- delete -i Å.x || set status 0
- directory :bignum; domake scratch; directory ::
- directory :test; domake clean; directory ::
-
-.cmi Ä .mli
- {CAMLC} -c {COMPFLAGS} {default}.mli
-
-.cmo Ä .ml
- {CAMLC} -c {COMPFLAGS} {default}.ml
-
-depend Ä
- begin
- MakeDepend -w -objext .x Å.c
- :::boot:ocamlrun :::tools:ocamldep Å.mli Å.ml
- end | streamedit -e "/¶t/ replace // ' ' -c °" > Makefile.Mac.depend
diff --git a/otherlibs/num/Makefile.Mac.depend b/otherlibs/num/Makefile.Mac.depend
deleted file mode 100644
index c36b26712d..0000000000
--- a/otherlibs/num/Makefile.Mac.depend
+++ /dev/null
@@ -1,33 +0,0 @@
-#*** Dependencies: Cut here ***
-# These dependencies were produced at 20:33:19 on Tue, Aug 21, 2001 by MakeDepend
-
-:nat_stubs.c.x Ä ¶
- :nat_stubs.c ¶
- "{CIncludes}"memory.h ¶
- :nat.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-big_int.cmiÄ nat.cmi
-num.cmiÄ big_int.cmi nat.cmi ratio.cmi
-ratio.cmiÄ big_int.cmi nat.cmi
-arith_flags.cmoÄ arith_flags.cmi
-arith_flags.cmxÄ arith_flags.cmi
-arith_status.cmoÄ arith_flags.cmi arith_status.cmi
-arith_status.cmxÄ arith_flags.cmx arith_status.cmi
-big_int.cmoÄ int_misc.cmi nat.cmi big_int.cmi
-big_int.cmxÄ int_misc.cmx nat.cmx big_int.cmi
-int_misc.cmoÄ int_misc.cmi
-int_misc.cmxÄ int_misc.cmi
-nat.cmoÄ int_misc.cmi nat.cmi
-nat.cmxÄ int_misc.cmx nat.cmi
-num.cmoÄ arith_flags.cmi big_int.cmi int_misc.cmi nat.cmi ratio.cmi num.cmi
-num.cmxÄ arith_flags.cmx big_int.cmx int_misc.cmx nat.cmx ratio.cmx num.cmi
-ratio.cmoÄ arith_flags.cmi big_int.cmi int_misc.cmi nat.cmi string_misc.cmi ¶
- ratio.cmi
-ratio.cmxÄ arith_flags.cmx big_int.cmx int_misc.cmx nat.cmx string_misc.cmx ¶
- ratio.cmi
-string_misc.cmoÄ string_misc.cmi
-string_misc.cmxÄ string_misc.cmi
diff --git a/otherlibs/num/Makefile.nt b/otherlibs/num/Makefile.nt
deleted file mode 100644
index a36a3d3b99..0000000000
--- a/otherlibs/num/Makefile.nt
+++ /dev/null
@@ -1,97 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-# Makefile for the "num" (exact rational arithmetic) library
-
-include ../../config/Makefile
-
-# Compilation options
-CC=$(BYTECC)
-CFLAGS=-O -I../../byterun \
- -DBNG_ARCH_$(BNG_ARCH) -DBNG_ASM_LEVEL=$(BNG_ASM_LEVEL)
-CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../boot -w s
-CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -w s
-
-CAMLOBJS=int_misc.cmo string_misc.cmo nat.cmo big_int.cmo arith_flags.cmo \
- ratio.cmo num.cmo arith_status.cmo
-
-CMIFILES=big_int.cmi nat.cmi num.cmi ratio.cmi arith_status.cmi
-
-DCOBJS=bng.$(DO) nat_stubs.$(DO)
-SCOBJS=bng.$(SO) nat_stubs.$(SO)
-
-all: dllnums.dll libnums.$(A) nums.cma $(CMIFILES)
-
-allopt: libnums.$(A) nums.cmxa $(CMIFILES)
-
-nums.cma: $(CAMLOBJS)
- $(CAMLC) -a -o nums.cma $(CAMLOBJS) -dllib -lnums -cclib -lnums
-
-nums.cmxa: $(CAMLOBJS:.cmo=.cmx)
- $(CAMLOPT) -a -o nums.cmxa $(CAMLOBJS:.cmo=.cmx) -cclib -lnums
-
-dllnums.dll: $(DCOBJS)
- $(call MKDLL,dllnums.dll,tmp.$(A),\
- $(DCOBJS) ../../byterun/ocamlrun.$(A))
- rm tmp.*
-
-libnums.$(A): $(SCOBJS)
- $(call MKLIB,libnums.$(A),$(SCOBJS))
-
-$(CAMLOBJS:.cmo=.cmx): ../../ocamlopt
-
-install:
- cp dllnums.dll $(STUBLIBDIR)/dllnums.dll
- cp libnums.$(A) $(LIBDIR)/libnums.$(A)
- cp nums.cma $(CMIFILES) $(LIBDIR)
-
-installopt:
- cp $(CAMLOBJS:.cmo=.cmx) nums.cmxa nums.$(A) $(LIBDIR)
-
-partialclean:
- rm -f *.cm*
-
-clean: partialclean
- rm -f *.dll *.$(A) *.$(O)
- cd bignum ; $(MAKEREC) scratch
- cd test ; $(MAKEREC) clean
-
-.SUFFIXES: .ml .mli .cmi .cmo .cmx .$(DO) .$(SO)
-
-.mli.cmi:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-.c.$(DO):
- $(BYTECC) $(DLLCCCOMPOPTS) $(CFLAGS) -c $<
- mv $*.$(O) $*.$(DO)
-
-.c.$(SO):
- $(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c $<
- mv $*.$(O) $*.$(SO)
-
-bng.$(DO) bng.$(SO): bng.h bng_digit.c \
- bng_alpha.c bng_amd64.c bng_ia32.c bng_mips.c bng_ppc.c bng_sparc.c
-
-depend:
- sed -e 's/\.o/.$(DO)/g' .depend > .depend.nt
- sed -e 's/\.o/.$(SO)/g' .depend >> .depend.nt
-
-include .depend.nt
diff --git a/otherlibs/num/README b/otherlibs/num/README
deleted file mode 100644
index d4969bfdd0..0000000000
--- a/otherlibs/num/README
+++ /dev/null
@@ -1,55 +0,0 @@
-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
deleted file mode 100644
index 6192ba2027..0000000000
--- a/otherlibs/num/arith_flags.ml
+++ /dev/null
@@ -1,25 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-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
deleted file mode 100644
index 36160edb24..0000000000
--- a/otherlibs/num/arith_flags.mli
+++ /dev/null
@@ -1,20 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-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
deleted file mode 100644
index 02affd92b2..0000000000
--- a/otherlibs/num/arith_status.ml
+++ /dev/null
@@ -1,100 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-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
deleted file mode 100644
index ec339cc422..0000000000
--- a/otherlibs/num/arith_status.mli
+++ /dev/null
@@ -1,60 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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
deleted file mode 100644
index 7542f1f89b..0000000000
--- a/otherlibs/num/big_int.ml
+++ /dev/null
@@ -1,603 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Int_misc
-open Nat
-
-type big_int =
- { sign : int;
- abs_value : nat }
-
-let create_big_int sign nat =
- if sign = 1 || sign = -1 ||
- (sign = 0 &&
- is_zero_nat nat 0 (num_digits_nat nat 0 (length_nat nat)))
- then { sign = sign;
- abs_value = nat }
- else invalid_arg "create_big_int"
-
-(* Sign of a big_int *)
-let sign_big_int bi = bi.sign
-
-let zero_big_int =
- { sign = 0;
- abs_value = make_nat 1 }
-
-let unit_big_int =
- { sign = 1;
- abs_value = nat_of_int 1 }
-
-(* Number of digits in a big_int *)
-let num_digits_big_int bi =
- num_digits_nat (bi.abs_value) 0 (length_nat bi.abs_value)
-
-(* Opposite of a big_int *)
-let minus_big_int bi =
- { sign = - bi.sign;
- abs_value = copy_nat (bi.abs_value) 0 (num_digits_big_int bi)}
-
-(* Absolute value of a big_int *)
-let abs_big_int bi =
- { sign = if bi.sign = 0 then 0 else 1;
- abs_value = copy_nat (bi.abs_value) 0 (num_digits_big_int bi)}
-
-(* Comparison operators on big_int *)
-
-(*
- compare_big_int (bi, bi2) = sign of (bi-bi2)
- i.e. 1 if bi > bi2
- 0 if bi = bi2
- -1 if bi < bi2
-*)
-let compare_big_int bi1 bi2 =
- if bi1.sign = 0 && bi2.sign = 0 then 0
- else if bi1.sign < bi2.sign then -1
- else if bi1.sign > bi2.sign then 1
- else if bi1.sign = 1 then
- compare_nat (bi1.abs_value) 0 (num_digits_big_int bi1)
- (bi2.abs_value) 0 (num_digits_big_int bi2)
- else
- compare_nat (bi2.abs_value) 0 (num_digits_big_int bi2)
- (bi1.abs_value) 0 (num_digits_big_int bi1)
-
-let eq_big_int bi1 bi2 = compare_big_int bi1 bi2 = 0
-and le_big_int bi1 bi2 = compare_big_int bi1 bi2 <= 0
-and ge_big_int bi1 bi2 = compare_big_int bi1 bi2 >= 0
-and lt_big_int bi1 bi2 = compare_big_int bi1 bi2 < 0
-and gt_big_int bi1 bi2 = compare_big_int bi1 bi2 > 0
-
-let max_big_int bi1 bi2 = if lt_big_int bi1 bi2 then bi2 else bi1
-and min_big_int bi1 bi2 = if gt_big_int bi1 bi2 then bi2 else bi1
-
-(* Operations on big_int *)
-
-let pred_big_int bi =
- match bi.sign with
- 0 -> { sign = -1; abs_value = nat_of_int 1}
- | 1 -> let size_bi = num_digits_big_int bi in
- let copy_bi = copy_nat (bi.abs_value) 0 size_bi in
- decr_nat copy_bi 0 size_bi 0;
- { sign = if is_zero_nat copy_bi 0 size_bi then 0 else 1;
- abs_value = copy_bi }
- | _ -> let size_bi = num_digits_big_int bi in
- let size_res = succ (size_bi) in
- let copy_bi = create_nat (size_res) in
- blit_nat copy_bi 0 (bi.abs_value) 0 size_bi;
- set_digit_nat copy_bi size_bi 0;
- incr_nat copy_bi 0 size_res 1;
- { sign = -1;
- abs_value = copy_bi }
-
-let succ_big_int bi =
- match bi.sign with
- 0 -> {sign = 1; abs_value = nat_of_int 1}
- | -1 -> let size_bi = num_digits_big_int bi in
- let copy_bi = copy_nat (bi.abs_value) 0 size_bi in
- decr_nat copy_bi 0 size_bi 0;
- { sign = if is_zero_nat copy_bi 0 size_bi then 0 else -1;
- abs_value = copy_bi }
- | _ -> let size_bi = num_digits_big_int bi in
- let size_res = succ (size_bi) in
- let copy_bi = create_nat (size_res) in
- blit_nat copy_bi 0 (bi.abs_value) 0 size_bi;
- set_digit_nat copy_bi size_bi 0;
- incr_nat copy_bi 0 size_res 1;
- { sign = 1;
- abs_value = copy_bi }
-
-let add_big_int bi1 bi2 =
- let size_bi1 = num_digits_big_int bi1
- and size_bi2 = num_digits_big_int bi2 in
- if bi1.sign = bi2.sign
- then (* Add absolute values if signs are the same *)
- { sign = bi1.sign;
- abs_value =
- match compare_nat (bi1.abs_value) 0 size_bi1
- (bi2.abs_value) 0 size_bi2 with
- -1 -> let res = create_nat (succ size_bi2) in
- (blit_nat res 0 (bi2.abs_value) 0 size_bi2;
- set_digit_nat res size_bi2 0;
- add_nat res 0 (succ size_bi2)
- (bi1.abs_value) 0 size_bi1 0;
- res)
- |_ -> let res = create_nat (succ size_bi1) in
- (blit_nat res 0 (bi1.abs_value) 0 size_bi1;
- set_digit_nat res size_bi1 0;
- add_nat res 0 (succ size_bi1)
- (bi2.abs_value) 0 size_bi2 0;
- res)}
-
- else (* Subtract absolute values if signs are different *)
- match compare_nat (bi1.abs_value) 0 size_bi1
- (bi2.abs_value) 0 size_bi2 with
- 0 -> zero_big_int
- | 1 -> { sign = bi1.sign;
- abs_value =
- let res = copy_nat (bi1.abs_value) 0 size_bi1 in
- (sub_nat res 0 size_bi1
- (bi2.abs_value) 0 size_bi2 1;
- res) }
- | _ -> { sign = bi2.sign;
- abs_value =
- let res = copy_nat (bi2.abs_value) 0 size_bi2 in
- (sub_nat res 0 size_bi2
- (bi1.abs_value) 0 size_bi1 1;
- res) }
-
-(* Coercion with int type *)
-let big_int_of_int i =
- { sign = sign_int i;
- abs_value =
- let res = (create_nat 1)
- in (if i = monster_int
- then (set_digit_nat res 0 biggest_int;
- incr_nat res 0 1 1; ())
- else set_digit_nat res 0 (abs i));
- res }
-
-let add_int_big_int i bi = add_big_int (big_int_of_int i) bi
-
-let sub_big_int bi1 bi2 = add_big_int bi1 (minus_big_int bi2)
-
-(* Returns i * bi *)
-let mult_int_big_int i bi =
- let size_bi = num_digits_big_int bi in
- let size_res = succ size_bi in
- if i = monster_int
- then let res = create_nat size_res in
- blit_nat res 0 (bi.abs_value) 0 size_bi;
- mult_digit_nat res 0 size_res (bi.abs_value) 0 size_bi
- (nat_of_int biggest_int) 0;
- { sign = - (sign_big_int bi);
- abs_value = res }
- else let res = make_nat (size_res) in
- mult_digit_nat res 0 size_res (bi.abs_value) 0 size_bi
- (nat_of_int (abs i)) 0;
- { sign = (sign_int i) * (sign_big_int bi);
- abs_value = res }
-
-let mult_big_int bi1 bi2 =
- let size_bi1 = num_digits_big_int bi1
- and size_bi2 = num_digits_big_int bi2 in
- let size_res = size_bi1 + size_bi2 in
- let res = make_nat (size_res) in
- { sign = bi1.sign * bi2.sign;
- abs_value =
- if size_bi2 > size_bi1
- then (mult_nat res 0 size_res (bi2.abs_value) 0 size_bi2
- (bi1.abs_value) 0 size_bi1;res)
- else (mult_nat res 0 size_res (bi1.abs_value) 0 size_bi1
- (bi2.abs_value) 0 size_bi2;res) }
-
-(* (quotient, rest) of the euclidian division of 2 big_int *)
-let quomod_big_int bi1 bi2 =
- if bi2.sign = 0 then raise Division_by_zero
- else
- let size_bi1 = num_digits_big_int bi1
- and size_bi2 = num_digits_big_int bi2 in
- match compare_nat (bi1.abs_value) 0 size_bi1
- (bi2.abs_value) 0 size_bi2 with
- -1 -> (* 1/2 -> 0, reste 1, -1/2 -> -1, reste 1 *)
- if bi1.sign = -1
- then (big_int_of_int(-1), add_big_int bi2 bi1)
- else (big_int_of_int 0, bi1)
- | 0 -> (big_int_of_int (bi1.sign * bi2.sign), zero_big_int)
- | _ -> let bi1_negatif = bi1.sign = -1 in
- let size_q =
- if bi1_negatif
- then succ (max (succ (size_bi1 - size_bi2)) 1)
- else max (succ (size_bi1 - size_bi2)) 1
- and size_r = succ (max size_bi1 size_bi2)
- (* r is long enough to contain both quotient and remainder *)
- (* of the euclidian division *)
- in
- (* set up quotient, remainder *)
- let q = create_nat size_q
- and r = create_nat size_r in
- blit_nat r 0 (bi1.abs_value) 0 size_bi1;
- set_to_zero_nat r size_bi1 (size_r - size_bi1);
-
- (* do the division of |bi1| by |bi2|
- - at the beginning, r contains |bi1|
- - at the end, r contains
- * in the size_bi2 least significant digits, the remainder
- * in the size_r-size_bi2 most significant digits, the quotient
- note the conditions for application of div_nat are verified here
- *)
- div_nat r 0 size_r (bi2.abs_value) 0 size_bi2;
-
- (* separate quotient and remainder *)
- blit_nat q 0 r size_bi2 (size_r - size_bi2);
- let not_null_mod = not (is_zero_nat r 0 size_bi2) in
-
- (* correct the signs, adjusting the quotient and remainder *)
- if bi1_negatif && not_null_mod
- then
- (* bi1<0, r>0, noting r for (r, size_bi2) the remainder, *)
- (* we have |bi1|=q * |bi2| + r with 0 < r < |bi2|, *)
- (* thus -bi1 = q * |bi2| + r *)
- (* and bi1 = (-q) * |bi2| + (-r) with -|bi2| < (-r) < 0 *)
- (* thus bi1 = -(q+1) * |bi2| + (|bi2|-r) *)
- (* with 0 < (|bi2|-r) < |bi2| *)
- (* so the quotient has for sign the opposite of the bi2'one *)
- (* and for value q+1 *)
- (* and the remainder is strictly positive *)
- (* has for value |bi2|-r *)
- (let new_r = copy_nat (bi2.abs_value) 0 size_bi2 in
- (* new_r contains (r, size_bi2) the remainder *)
- { sign = - bi2.sign;
- abs_value = (set_digit_nat q (pred size_q) 0;
- incr_nat q 0 size_q 1; q) },
- { sign = 1;
- abs_value =
- (sub_nat new_r 0 size_bi2 r 0 size_bi2 1;
- new_r) })
- else
- (if bi1_negatif then set_digit_nat q (pred size_q) 0;
- { sign = if is_zero_nat q 0 size_q
- then 0
- else bi1.sign * bi2.sign;
- abs_value = q },
- { sign = if not_null_mod then 1 else 0;
- abs_value = copy_nat r 0 size_bi2 })
-
-let div_big_int bi1 bi2 = fst (quomod_big_int bi1 bi2)
-and mod_big_int bi1 bi2 = snd (quomod_big_int bi1 bi2)
-
-let gcd_big_int bi1 bi2 =
- let size_bi1 = num_digits_big_int bi1
- and size_bi2 = num_digits_big_int bi2 in
- if is_zero_nat (bi1.abs_value) 0 size_bi1 then abs_big_int bi2
- else if is_zero_nat (bi2.abs_value) 0 size_bi2 then
- { sign = 1;
- abs_value = bi1.abs_value }
- else
- { sign = 1;
- abs_value =
- match compare_nat (bi1.abs_value) 0 size_bi1
- (bi2.abs_value) 0 size_bi2 with
- 0 -> bi1.abs_value
- | 1 ->
- let res = copy_nat (bi1.abs_value) 0 size_bi1 in
- let len =
- gcd_nat res 0 size_bi1 (bi2.abs_value) 0 size_bi2 in
- copy_nat res 0 len
- | _ ->
- let res = copy_nat (bi2.abs_value) 0 size_bi2 in
- let len =
- gcd_nat res 0 size_bi2 (bi1.abs_value) 0 size_bi1 in
- copy_nat res 0 len
- }
-
-(* Coercion operators *)
-
-let monster_big_int = big_int_of_int monster_int;;
-
-let monster_nat = monster_big_int.abs_value;;
-
-let is_int_big_int bi =
- num_digits_big_int bi == 1 &&
- match compare_nat bi.abs_value 0 1 monster_nat 0 1 with
- | 0 -> bi.sign == -1
- | -1 -> true
- | _ -> false;;
-
-let int_of_big_int bi =
- try let n = int_of_nat bi.abs_value in
- if bi.sign = -1 then - n else n
- with Failure _ ->
- if eq_big_int bi monster_big_int then monster_int
- else failwith "int_of_big_int";;
-
-(* Coercion with nat type *)
-let nat_of_big_int bi =
- if bi.sign = -1
- then failwith "nat_of_big_int"
- else copy_nat (bi.abs_value) 0 (num_digits_big_int bi)
-
-let sys_big_int_of_nat nat off len =
- let length = num_digits_nat nat off len in
- { sign = if is_zero_nat nat off length then 0 else 1;
- abs_value = copy_nat nat off length }
-
-let big_int_of_nat nat =
- sys_big_int_of_nat nat 0 (length_nat nat)
-
-(* Coercion with string type *)
-
-let string_of_big_int bi =
- if bi.sign = -1
- then "-" ^ string_of_nat bi.abs_value
- else string_of_nat bi.abs_value
-
-
-let sys_big_int_of_string_aux s ofs len sgn =
- if len < 1 then failwith "sys_big_int_of_string";
- let n = sys_nat_of_string 10 s ofs len in
- if is_zero_nat n 0 (length_nat n) then zero_big_int
- else {sign = sgn; abs_value = n}
-;;
-
-let sys_big_int_of_string s ofs len =
- match s.[ofs] with
- | '-' -> sys_big_int_of_string_aux s (ofs+1) (len-1) (-1)
- | '+' -> sys_big_int_of_string_aux s (ofs+1) (len-1) 1
- | _ -> sys_big_int_of_string_aux s ofs len 1
-;;
-
-let big_int_of_string s =
- sys_big_int_of_string s 0 (String.length s)
-
-let power_base_nat base nat off len =
- if is_zero_nat nat off len then nat_of_int 1 else
- let power_base = make_nat (succ length_of_digit) in
- let (pmax, pint) = make_power_base base power_base in
- let (n, rem) =
- let (x, y) = quomod_big_int (sys_big_int_of_nat nat off len)
- (big_int_of_int (succ pmax)) in
- (int_of_big_int x, int_of_big_int y) in
- if n = 0 then copy_nat power_base (pred rem) 1 else
- begin
- let res = make_nat n
- and res2 = make_nat (succ n)
- and l = num_bits_int n - 2 in
- let p = ref (1 lsl l) in
- blit_nat res 0 power_base pmax 1;
- for i = l downto 0 do
- let len = num_digits_nat res 0 n in
- let len2 = min n (2 * len) in
- let succ_len2 = succ len2 in
- square_nat res2 0 len2 res 0 len;
- begin
- if n land !p > 0
- then (set_to_zero_nat res 0 len;
- mult_digit_nat res 0 succ_len2
- res2 0 len2
- power_base pmax; ())
- else blit_nat res 0 res2 0 len2
- end;
- set_to_zero_nat res2 0 len2;
- p := !p lsr 1
- done;
- if rem > 0
- then (mult_digit_nat res2 0 (succ n)
- res 0 n power_base (pred rem);
- res2)
- else res
- end
-
-let power_int_positive_int i n =
- match sign_int n with
- 0 -> unit_big_int
- | -1 -> invalid_arg "power_int_positive_int"
- | _ -> let nat = power_base_int (abs i) n in
- { sign = if i >= 0
- then sign_int i
- else if n land 1 = 0
- then 1
- else -1;
- abs_value = nat}
-
-let power_big_int_positive_int bi n =
- match sign_int n with
- 0 -> unit_big_int
- | -1 -> invalid_arg "power_big_int_positive_int"
- | _ -> let bi_len = num_digits_big_int bi in
- let res_len = bi_len * n in
- let res = make_nat res_len
- and res2 = make_nat res_len
- and l = num_bits_int n - 2 in
- let p = ref (1 lsl l) in
- blit_nat res 0 (bi.abs_value) 0 bi_len;
- for i = l downto 0 do
- let len = num_digits_nat res 0 res_len in
- let len2 = min res_len (2 * len) in
- let succ_len2 = succ len2 in
- square_nat res2 0 len2 res 0 len;
- (if n land !p > 0
- then (set_to_zero_nat res 0 len;
- mult_nat res 0 succ_len2
- res2 0 len2 (bi.abs_value) 0 bi_len;
- set_to_zero_nat res2 0 len2)
- else blit_nat res 0 res2 0 len2;
- set_to_zero_nat res2 0 len2);
- p := !p lsr 1
- done;
- {sign = if bi.sign >= 0
- then bi.sign
- else if n land 1 = 0
- then 1
- else -1;
- abs_value = res}
-
-let power_int_positive_big_int i bi =
- match sign_big_int bi with
- 0 -> unit_big_int
- | -1 -> invalid_arg "power_int_positive_big_int"
- | _ -> let nat = power_base_nat
- (abs i) (bi.abs_value) 0 (num_digits_big_int bi) in
- { sign = if i >= 0
- then sign_int i
- else if is_digit_odd (bi.abs_value) 0
- then -1
- else 1;
- abs_value = nat }
-
-let power_big_int_positive_big_int bi1 bi2 =
- match sign_big_int bi2 with
- 0 -> unit_big_int
- | -1 -> invalid_arg "power_big_int_positive_big_int"
- | _ -> let nat = bi2.abs_value
- and off = 0
- and len_bi2 = num_digits_big_int bi2 in
- let bi1_len = num_digits_big_int bi1 in
- let res_len = int_of_big_int (mult_int_big_int bi1_len bi2) in
- let res = make_nat res_len
- and res2 = make_nat res_len
- and l = (len_bi2 * length_of_digit
- - num_leading_zero_bits_in_digit nat (pred len_bi2)) - 2 in
- let p = ref (1 lsl l) in
- blit_nat res 0 (bi1.abs_value) 0 bi1_len;
- for i = l downto 0 do
- let nat = copy_nat bi2.abs_value 0 len_bi2 in
- let len = num_digits_nat res 0 res_len in
- let len2 = min res_len (2 * len) in
- let succ_len2 = succ len2 in
- square_nat res2 0 len2 res 0 len;
- land_digit_nat nat 0 (nat_of_int !p) 0;
- if is_zero_nat nat 0 len_bi2
- then (blit_nat res 0 res2 0 len2;
- set_to_zero_nat res2 0 len2)
- else (set_to_zero_nat res 0 len;
- mult_nat res 0 succ_len2
- res2 0 len2 (bi1.abs_value) 0 bi1_len;
- set_to_zero_nat res2 0 len2);
- p := !p lsr 1
- done;
- {sign = if bi1.sign >= 0
- then bi1.sign
- else if is_digit_odd (bi2.abs_value) 0
- then -1
- else 1;
- abs_value = res}
-
-(* base_power_big_int compute bi*base^n *)
-let base_power_big_int base n bi =
- match sign_int n with
- 0 -> bi
- | -1 -> let nat = power_base_int base (-n) in
- let len_nat = num_digits_nat nat 0 (length_nat nat)
- and len_bi = num_digits_big_int bi in
- if len_bi < len_nat then
- invalid_arg "base_power_big_int"
- else if len_bi = len_nat &&
- compare_digits_nat (bi.abs_value) len_bi nat len_nat = -1
- then invalid_arg "base_power_big_int"
- else
- let copy = create_nat (succ len_bi) in
- blit_nat copy 0 (bi.abs_value) 0 len_bi;
- set_digit_nat copy len_bi 0;
- div_nat copy 0 (succ len_bi)
- nat 0 len_nat;
- if not (is_zero_nat copy 0 len_nat)
- then invalid_arg "base_power_big_int"
- else { sign = bi.sign;
- abs_value = copy_nat copy len_nat 1 }
- | _ -> let nat = power_base_int base n in
- let len_nat = num_digits_nat nat 0 (length_nat nat)
- and len_bi = num_digits_big_int bi in
- let new_len = len_bi + len_nat in
- let res = make_nat new_len in
- (if len_bi > len_nat
- then mult_nat res 0 new_len
- (bi.abs_value) 0 len_bi
- nat 0 len_nat
- else mult_nat res 0 new_len
- nat 0 len_nat
- (bi.abs_value) 0 len_bi)
- ; if is_zero_nat res 0 new_len
- then zero_big_int
- else create_big_int (bi.sign) res
-
-(* Coercion with float type *)
-
-let float_of_big_int bi =
- float_of_string (string_of_big_int bi)
-
-(* XL: suppression de big_int_of_float et nat_of_float. *)
-
-(* Other functions needed *)
-
-(* Integer part of the square root of a big_int *)
-let sqrt_big_int bi =
- match bi.sign with
- | 0 -> zero_big_int
- | -1 -> invalid_arg "sqrt_big_int"
- | _ -> {sign = 1;
- abs_value = sqrt_nat (bi.abs_value) 0 (num_digits_big_int bi)}
-
-let square_big_int bi =
- if bi.sign == 0 then zero_big_int else
- let len_bi = num_digits_big_int bi in
- let len_res = 2 * len_bi in
- let res = make_nat len_res in
- square_nat res 0 len_res (bi.abs_value) 0 len_bi;
- {sign = 1; abs_value = res}
-
-(* round off of the futur last digit (of the integer represented by the string
- argument of the function) that is now the previous one.
- if s contains an integer of the form (10^n)-1
- then s <- only 0 digits and the result_int is true
- else s <- the round number and the result_int is false *)
-let round_futur_last_digit s off_set length =
- let l = pred (length + off_set) in
- if Char.code(String.get s l) >= Char.code '5'
- then
- let rec round_rec l =
- let current_char = String.get s l in
- if current_char = '9'
- then
- (String.set s l '0';
- if l = off_set then true else round_rec (pred l))
- else
- (String.set s l (Char.chr (succ (Char.code current_char)));
- false)
- in round_rec (pred l)
- else false
-
-
-(* Approximation with floating decimal point a` la approx_ratio_exp *)
-let approx_big_int prec bi =
- let len_bi = num_digits_big_int bi in
- let n =
- max 0
- (int_of_big_int (
- add_int_big_int
- (-prec)
- (div_big_int (mult_big_int (big_int_of_int (pred len_bi))
- (big_int_of_string "963295986"))
- (big_int_of_string "100000000")))) in
- let s =
- string_of_big_int (div_big_int bi (power_int_positive_int 10 n)) in
- let (sign, off, len) =
- if String.get s 0 = '-'
- then ("-", 1, succ prec)
- else ("", 0, prec) in
- if (round_futur_last_digit s off (succ prec))
- then (sign^"1."^(String.make prec '0')^"e"^
- (string_of_int (n + 1 - off + String.length s)))
- else (sign^(String.sub s off 1)^"."^
- (String.sub s (succ off) (pred prec))
- ^"e"^(string_of_int (n - succ off + String.length s)))
diff --git a/otherlibs/num/big_int.mli b/otherlibs/num/big_int.mli
deleted file mode 100644
index 9b140abf2f..0000000000
--- a/otherlibs/num/big_int.mli
+++ /dev/null
@@ -1,143 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Operations on arbitrary-precision integers.
-
- Big integers (type [big_int]) are signed integers of arbitrary size.
-*)
-
-open Nat
-
-type big_int
- (** The type of big integers. *)
-
-val zero_big_int : big_int
- (** The big integer [0]. *)
-val unit_big_int : big_int
- (** The big integer [1]. *)
-
-(** {6 Arithmetic operations} *)
-
-val minus_big_int : big_int -> big_int
- (** Unary negation. *)
-val abs_big_int : big_int -> big_int
- (** Absolute value. *)
-val add_big_int : big_int -> big_int -> big_int
- (** Addition. *)
-val succ_big_int : big_int -> big_int
- (** Successor (add 1). *)
-val add_int_big_int : int -> big_int -> big_int
- (** Addition of a small integer to a big integer. *)
-val sub_big_int : big_int -> big_int -> big_int
- (** Subtraction. *)
-val pred_big_int : big_int -> big_int
- (** Predecessor (subtract 1). *)
-val mult_big_int : big_int -> big_int -> big_int
- (** Multiplication of two big integers. *)
-val mult_int_big_int : int -> big_int -> big_int
- (** Multiplication of a big integer by a small integer *)
-val square_big_int: big_int -> big_int
- (** Return the square of the given big integer *)
-val sqrt_big_int: big_int -> big_int
- (** [sqrt_big_int a] returns the integer square root of [a],
- that is, the largest big integer [r] such that [r * r <= a].
- Raise [Invalid_argument] if [a] is negative. *)
-val quomod_big_int : big_int -> big_int -> big_int * big_int
- (** Euclidean division of two big integers.
- The first part of the result is the quotient,
- the second part is the remainder.
- Writing [(q,r) = quomod_big_int a b], we have
- [a = q * b + r] and [0 <= r < |b|].
- Raise [Division_by_zero] if the divisor is zero. *)
-val div_big_int : big_int -> big_int -> big_int
- (** Euclidean quotient of two big integers.
- This is the first result [q] of [quomod_big_int] (see above). *)
-val mod_big_int : big_int -> big_int -> big_int
- (** Euclidean modulus of two big integers.
- This is the second result [r] of [quomod_big_int] (see above). *)
-val gcd_big_int : big_int -> big_int -> big_int
- (** Greatest common divisor of two big integers. *)
-val power_int_positive_int: int -> int -> big_int
-val power_big_int_positive_int: big_int -> int -> big_int
-val power_int_positive_big_int: int -> big_int -> big_int
-val power_big_int_positive_big_int: big_int -> big_int -> big_int
- (** Exponentiation functions. Return the big integer
- representing the first argument [a] raised to the power [b]
- (the second argument). Depending
- on the function, [a] and [b] can be either small integers
- or big integers. Raise [Invalid_argument] if [b] is negative. *)
-
-(** {6 Comparisons and tests} *)
-
-val sign_big_int : big_int -> int
- (** Return [0] if the given big integer is zero,
- [1] if it is positive, and [-1] if it is negative. *)
-val compare_big_int : big_int -> big_int -> int
- (** [compare_big_int a b] returns [0] if [a] and [b] are equal,
- [1] if [a] is greater than [b], and [-1] if [a] is smaller
- than [b]. *)
-val eq_big_int : big_int -> big_int -> bool
-val le_big_int : big_int -> big_int -> bool
-val ge_big_int : big_int -> big_int -> bool
-val lt_big_int : big_int -> big_int -> bool
-val gt_big_int : big_int -> big_int -> bool
- (** Usual boolean comparisons between two big integers. *)
-val max_big_int : big_int -> big_int -> big_int
- (** Return the greater of its two arguments. *)
-val min_big_int : big_int -> big_int -> big_int
- (** Return the smaller of its two arguments. *)
-val num_digits_big_int : big_int -> int
- (** Return the number of machine words used to store the
- given big integer. *)
-
-(** {6 Conversions to and from strings} *)
-
-val string_of_big_int : big_int -> string
- (** Return the string representation of the given big integer,
- in decimal (base 10). *)
-val big_int_of_string : string -> big_int
- (** Convert a string to a big integer, in decimal.
- The string consists of an optional [-] or [+] sign,
- followed by one or several decimal digits. *)
-
-(** {6 Conversions to and from other numerical types} *)
-
-val big_int_of_int : int -> big_int
- (** Convert a small integer to a big integer. *)
-val is_int_big_int : big_int -> bool
- (** Test whether the given big integer is small enough to
- be representable as a small integer (type [int])
- without loss of precision. On a 32-bit platform,
- [is_int_big_int a] returns [true] if and only if
- [a] is between 2{^30} and 2{^30}-1. On a 64-bit platform,
- [is_int_big_int a] returns [true] if and only if
- [a] is between -2{^62} and 2{^62}-1. *)
-val int_of_big_int : big_int -> int
- (** Convert a big integer to a small integer (type [int]).
- Raises [Failure "int_of_big_int"] if the big integer
- is not representable as a small integer. *)
-val float_of_big_int : big_int -> float
- (** Returns a floating-point number approximating the
- given big integer. *)
-
-(**/**)
-
-(** {6 For internal use} *)
-val nat_of_big_int : big_int -> nat
-val big_int_of_nat : nat -> big_int
-val base_power_big_int: int -> int -> big_int -> big_int
-val sys_big_int_of_string: string -> int -> int -> big_int
-val round_futur_last_digit : string -> int -> int -> bool
-val approx_big_int: int -> big_int -> string
diff --git a/otherlibs/num/bignum/.cvsignore b/otherlibs/num/bignum/.cvsignore
deleted file mode 100644
index c76baffd17..0000000000
--- a/otherlibs/num/bignum/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-libbignum.x
diff --git a/otherlibs/num/bng.c b/otherlibs/num/bng.c
deleted file mode 100644
index c96af2cf28..0000000000
--- a/otherlibs/num/bng.c
+++ /dev/null
@@ -1,434 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 2003 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "bng.h"
-
-#if defined(__GNUC__) && BNG_ASM_LEVEL > 0
-#if defined(BNG_ARCH_ia32)
-#include "bng_ia32.c"
-#elif defined(BNG_ARCH_amd64)
-#include "bng_amd64.c"
-#elif defined(BNG_ARCH_ppc)
-#include "bng_ppc.c"
-#elif defined (BNG_ARCH_alpha)
-#include "bng_alpha.c"
-#elif defined (BNG_ARCH_sparc)
-#include "bng_sparc.c"
-#elif defined (BNG_ARCH_mips)
-#include "bng_mips.c"
-#endif
-#endif
-
-#include "bng_digit.c"
-
-/**** Operations that cannot be overriden ****/
-
-/* Return number of leading zero bits in d */
-int bng_leading_zero_bits(bngdigit d)
-{
- int n = BNG_BITS_PER_DIGIT;
-#ifdef ARCH_SIXTYFOUR
- if ((d & 0xFFFFFFFF00000000L) != 0) { n -= 32; d = d >> 32; }
-#endif
- if ((d & 0xFFFF0000) != 0) { n -= 16; d = d >> 16; }
- if ((d & 0xFF00) != 0) { n -= 8; d = d >> 8; }
- if ((d & 0xF0) != 0) { n -= 4; d = d >> 4; }
- if ((d & 0xC) != 0) { n -= 2; d = d >> 2; }
- if ((d & 2) != 0) { n -= 1; d = d >> 1; }
- return n - d;
-}
-
-/* Complement the digits of {a,len} */
-void bng_complement(bng a/*[alen]*/, bngsize alen)
-{
- for (/**/; alen > 0; alen--, a++) *a = ~*a;
-}
-
-/* Return number of significant digits in {a,alen}. */
-bngsize bng_num_digits(bng a/*[alen]*/, bngsize alen)
-{
- while (1) {
- if (alen == 0) return 1;
- if (a[alen - 1] != 0) return alen;
- alen--;
- }
-}
-
-/* Return 0 if {a,alen} = {b,blen}
- -1 if {a,alen} < {b,blen}
- 1 if {a,alen} > {b,blen}. */
-int bng_compare(bng a/*[alen]*/, bngsize alen,
- bng b/*[blen]*/, bngsize blen)
-{
- bngdigit da, db;
-
- while (alen > 0 && a[alen-1] == 0) alen--;
- while (blen > 0 && b[blen-1] == 0) blen--;
- if (alen > blen) return 1;
- if (alen < blen) return -1;
- while (alen > 0) {
- alen--;
- da = a[alen];
- db = b[alen];
- if (da > db) return 1;
- if (da < db) return -1;
- }
- return 0;
-}
-
-/**** Generic definitions of the overridable operations ****/
-
-/* {a,alen} := {a, alen} + carry. Return carry out. */
-static bngcarry bng_generic_add_carry
- (bng a/*[alen]*/, bngsize alen, bngcarry carry)
-{
- if (carry == 0 || alen == 0) return carry;
- do {
- if (++(*a) != 0) return 0;
- a++;
- } while (--alen);
- return 1;
-}
-
-/* {a,alen} := {a,alen} + {b,blen} + carry. Return carry out.
- Require alen >= blen. */
-static bngcarry bng_generic_add
- (bng a/*[alen]*/, bngsize alen,
- bng b/*[blen]*/, bngsize blen,
- bngcarry carry)
-{
- alen -= blen;
- for (/**/; blen > 0; blen--, a++, b++) {
- BngAdd2Carry(*a, carry, *a, *b, carry);
- }
- if (carry == 0 || alen == 0) return carry;
- do {
- if (++(*a) != 0) return 0;
- a++;
- } while (--alen);
- return 1;
-}
-
-/* {a,alen} := {a, alen} - carry. Return carry out. */
-static bngcarry bng_generic_sub_carry
- (bng a/*[alen]*/, bngsize alen, bngcarry carry)
-{
- if (carry == 0 || alen == 0) return carry;
- do {
- if ((*a)-- != 0) return 0;
- a++;
- } while (--alen);
- return 1;
-}
-
-/* {a,alen} := {a,alen} - {b,blen} - carry. Return carry out.
- Require alen >= blen. */
-static bngcarry bng_generic_sub
- (bng a/*[alen]*/, bngsize alen,
- bng b/*[blen]*/, bngsize blen,
- bngcarry carry)
-{
- alen -= blen;
- for (/**/; blen > 0; blen--, a++, b++) {
- BngSub2Carry(*a, carry, *a, *b, carry);
- }
- if (carry == 0 || alen == 0) return carry;
- do {
- if ((*a)-- != 0) return 0;
- a++;
- } while (--alen);
- return 1;
-}
-
-/* {a,alen} := {a,alen} << shift.
- Return the bits shifted out of the most significant digit of a.
- Require 0 <= shift < BITS_PER_BNGDIGIT. */
-static bngdigit bng_generic_shift_left
- (bng a/*[alen]*/, bngsize alen,
- int shift)
-{
- int shift2 = BNG_BITS_PER_DIGIT - shift;
- bngdigit carry = 0;
- if (shift > 0) {
- for (/**/; alen > 0; alen--, a++) {
- bngdigit d = *a;
- *a = (d << shift) | carry;
- carry = d >> shift2;
- }
- }
- return carry;
-}
-
-/* {a,alen} := {a,alen} >> shift.
- Return the bits shifted out of the least significant digit of a.
- Require 0 <= shift < BITS_PER_BNGDIGIT. */
-static bngdigit bng_generic_shift_right
- (bng a/*[alen]*/, bngsize alen,
- int shift)
-{
- int shift2 = BNG_BITS_PER_DIGIT - shift;
- bngdigit carry = 0;
- if (shift > 0) {
- for (a = a + alen - 1; alen > 0; alen--, a--) {
- bngdigit d = *a;
- *a = (d >> shift) | carry;
- carry = d << shift2;
- }
- }
- return carry;
-}
-
-/* {a,alen} := {a,alen} + d * {b,blen}. Return carry out.
- Require alen >= blen. */
-static bngdigit bng_generic_mult_add_digit
- (bng a/*[alen]*/, bngsize alen,
- bng b/*[blen]*/, bngsize blen,
- bngdigit d)
-{
- bngdigit out, ph, pl;
- bngcarry carry;
-
- alen -= blen;
- for (out = 0; blen > 0; blen--, a++, b++) {
- bngdigit bd = *b;
- /* ph:pl = double-digit product of b's current digit and d */
- BngMult(ph, pl, bd, d);
- /* current digit of a += pl + out. Accumulate carries in ph. */
- BngAdd3(*a, ph, *a, pl, out);
- /* prepare out for next iteration */
- out = ph;
- }
- if (alen == 0) return out;
- /* current digit of a += out */
- BngAdd2(*a, carry, *a, out);
- a++;
- alen--;
- /* Propagate carry */
- if (carry == 0 || alen == 0) return carry;
- do {
- if (++(*a) != 0) return 0;
- a++;
- } while (--alen);
- return 1;
-}
-
-/* {a,alen} := {a,alen} - d * {b,blen}. Return carry out.
- Require alen >= blen. */
-static bngdigit bng_generic_mult_sub_digit
- (bng a/*[alen]*/, bngsize alen,
- bng b/*[blen]*/, bngsize blen,
- bngdigit d)
-{
- bngdigit out, ph, pl;
- bngcarry carry;
-
- alen -= blen;
- for (out = 0; blen > 0; blen--, a++, b++) {
- bngdigit bd = *b;
- /* ph:pl = double-digit product of b's current digit and d */
- BngMult(ph, pl, bd, d);
- /* current digit of a -= pl + out. Accumulate carrys in ph. */
- BngSub3(*a, ph, *a, pl, out);
- /* prepare out for next iteration */
- out = ph;
- }
- if (alen == 0) return out;
- /* current digit of a -= out */
- BngSub2(*a, carry, *a, out);
- a++;
- alen--;
- /* Propagate carry */
- if (carry == 0 || alen == 0) return carry;
- do {
- if ((*a)-- != 0) return 0;
- a++;
- } while (--alen);
- return 1;
-}
-
-/* {a,alen} := {a,alen} + {b,blen} * {c,clen}. Return carry out.
- Require alen >= blen + clen. */
-static bngcarry bng_generic_mult_add
- (bng a/*[alen]*/, bngsize alen,
- bng b/*[blen]*/, bngsize blen,
- bng c/*[clen]*/, bngsize clen)
-{
- bngcarry carry;
- for (carry = 0; clen > 0; clen--, c++, alen--, a++)
- carry += bng_mult_add_digit(a, alen, b, blen, *c);
- return carry;
-}
-
-/* {a,alen} := 2 * {a,alen} + {b,blen}^2. Return carry out.
- Require alen >= 2 * blen. */
-static bngcarry bng_generic_square_add
- (bng a/*[alen]*/, bngsize alen,
- bng b/*[blen]*/, bngsize blen)
-{
- bngcarry carry1, carry2;
- bngsize i, aofs;
- bngdigit ph, pl, d;
-
- /* Double products */
- for (carry1 = 0, i = 1; i < blen; i++) {
- aofs = 2 * i - 1;
- carry1 += bng_mult_add_digit(a + aofs, alen - aofs,
- b + i, blen - i, b[i - 1]);
- }
- /* Multiply by two */
- carry1 = (carry1 << 1) | bng_shift_left(a, alen, 1);
- /* Add square of digits */
- carry2 = 0;
- for (i = 0; i < blen; i++) {
- d = b[i];
- BngMult(ph, pl, d, d);
- BngAdd2Carry(*a, carry2, *a, pl, carry2);
- a++;
- BngAdd2Carry(*a, carry2, *a, ph, carry2);
- a++;
- }
- alen -= 2 * blen;
- if (alen > 0 && carry2 != 0) {
- do {
- if (++(*a) != 0) { carry2 = 0; break; }
- a++;
- } while (--alen);
- }
- return carry1 + carry2;
-}
-
-/* {a,len-1} := {b,len} / d. Return {b,len} modulo d.
- Require MSD of b < d.
- If BngDivNeedsNormalization is defined, require d normalized. */
-static bngdigit bng_generic_div_rem_norm_digit
- (bng a/*[len-1]*/, bng b/*[len]*/, bngsize len, bngdigit d)
-{
- bngdigit topdigit, quo, rem;
- long i;
-
- topdigit = b[len - 1];
- for (i = len - 2; i >= 0; i--) {
- /* Divide topdigit:current digit of numerator by d */
- BngDiv(quo, rem, topdigit, b[i], d);
- /* Quotient is current digit of result */
- a[i] = quo;
- /* Iterate with topdigit = remainder */
- topdigit = rem;
- }
- return topdigit;
-}
-
-#ifdef BngDivNeedsNormalization
-/* {a,len-1} := {b,len} / d. Return {b,len} modulo d.
- Require MSD of b < d. */
-static bngdigit bng_generic_div_rem_digit
- (bng a/*[len-1]*/, bng b/*[len]*/, bngsize len, bngdigit d)
-{
- bngdigit rem;
- int shift;
-
- /* Normalize d and b */
- shift = bng_leading_zero_bits(d);
- d <<= shift;
- bng_shift_left(b, len, shift);
- /* Do the division */
- rem = bng_div_rem_norm_digit(a, b, len, d);
- /* Undo normalization on b and remainder */
- bng_shift_right(b, len, shift);
- return rem >> shift;
-}
-#endif
-
-/* {n+dlen, nlen-dlen} := {n,nlen} / {d, dlen}.
- {n, dlen} := {n,nlen} modulo {d, dlen}.
- Require nlen > dlen and MSD of n < MSD of d.
- (This implies MSD of d > 0). */
-static void bng_generic_div_rem
- (bng n/*[nlen]*/, bngsize nlen,
- bng d/*[dlen]*/, bngsize dlen)
-{
- bngdigit topden, quo, rem;
- int shift;
- bngsize i, j;
-
- /* Normalize d */
- shift = bng_leading_zero_bits(d[dlen - 1]);
- /* Note that no bits of n are lost by the following shift,
- since n[nlen-1] < d[dlen-1] */
- bng_shift_left(n, nlen, shift);
- bng_shift_left(d, dlen, shift);
- /* Special case if d is just one digit */
- if (dlen == 1) {
- *n = bng_div_rem_norm_digit(n + 1, n, nlen, *d);
- } else {
- topden = d[dlen - 1];
- /* Long division */
- for (j = nlen - 1; j >= dlen; j--) {
- i = j - dlen;
- /* At this point:
- - the current numerator is n[j] : ...................... : n[0]
- - to be subtracted quo times: d[dlen-1] : ... : d[0] : 0... : 0
- (there are i zeroes at the end) */
- /* Under-estimate the next digit of the quotient (quo) */
- if (topden + 1 == 0)
- quo = n[j];
- else
- BngDiv(quo, rem, n[j], n[j - 1], topden + 1);
- /* Subtract d * quo (shifted i places) from numerator */
- n[j] -= bng_mult_sub_digit(n + i, dlen, d, dlen, quo);
- /* Adjust if necessary */
- while (n[j] != 0 || bng_compare(n + i, dlen, d, dlen) >= 0) {
- /* Numerator is still bigger than shifted divisor.
- Increment quotient and subtract shifted divisor. */
- quo++;
- n[j] -= bng_sub(n + i, dlen, d, dlen, 0);
- }
- /* Store quotient digit */
- n[j] = quo;
- }
- }
- /* Undo normalization on remainder and divisor */
- bng_shift_right(n, dlen, shift);
- bng_shift_right(d, dlen, shift);
-}
-
-/**** Construction of the table of operations ****/
-
-struct bng_operations bng_ops = {
- bng_generic_add_carry,
- bng_generic_add,
- bng_generic_sub_carry,
- bng_generic_sub,
- bng_generic_shift_left,
- bng_generic_shift_right,
- bng_generic_mult_add_digit,
- bng_generic_mult_sub_digit,
- bng_generic_mult_add,
- bng_generic_square_add,
- bng_generic_div_rem_norm_digit,
-#ifdef BngDivNeedsNormalization
- bng_generic_div_rem_digit,
-#else
- bng_generic_div_rem_norm_digit,
-#endif
- bng_generic_div_rem
-};
-
-void bng_init(void)
-{
-#ifdef BNG_SETUP_OPS
- BNG_SETUP_OPS;
-#endif
-}
diff --git a/otherlibs/num/bng.h b/otherlibs/num/bng.h
deleted file mode 100644
index 28c6b2d105..0000000000
--- a/otherlibs/num/bng.h
+++ /dev/null
@@ -1,156 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 2003 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <string.h>
-
-typedef unsigned long bngdigit;
-typedef bngdigit * bng;
-typedef unsigned int bngcarry;
-typedef unsigned long bngsize;
-
-#define BNG_BITS_PER_DIGIT (sizeof(bngdigit) * 8)
-#define BNG_BITS_PER_HALF_DIGIT (sizeof(bngdigit) * 4)
-
-struct bng_operations {
-
- /* {a,alen} := {a, alen} + carry. Return carry out. */
- bngcarry (*add_carry)
- (bng a/*[alen]*/, bngsize alen, bngcarry carry);
-#define bng_add_carry bng_ops.add_carry
-
- /* {a,alen} := {a,alen} + {b,blen} + carry. Return carry out.
- Require alen >= blen. */
- bngcarry (*add)
- (bng a/*[alen]*/, bngsize alen,
- bng b/*[blen]*/, bngsize blen,
- bngcarry carry);
-#define bng_add bng_ops.add
-
- /* {a,alen} := {a, alen} - carry. Return carry out. */
- bngcarry (*sub_carry)
- (bng a/*[alen]*/, bngsize alen, bngcarry carry);
-#define bng_sub_carry bng_ops.sub_carry
-
- /* {a,alen} := {a,alen} - {b,blen} - carry. Return carry out.
- Require alen >= blen. */
- bngcarry (*sub)
- (bng a/*[alen]*/, bngsize alen,
- bng b/*[blen]*/, bngsize blen,
- bngcarry carry);
-#define bng_sub bng_ops.sub
-
- /* {a,alen} := {a,alen} << shift.
- Return the bits shifted out of the most significant digit of a.
- Require 0 <= shift < BITS_PER_BNGDIGIT. */
- bngdigit (*shift_left)
- (bng a/*[alen]*/, bngsize alen,
- int shift);
-#define bng_shift_left bng_ops.shift_left
-
- /* {a,alen} := {a,alen} >> shift.
- Return the bits shifted out of the least significant digit of a.
- Require 0 <= shift < BITS_PER_BNGDIGIT. */
- bngdigit (*shift_right)
- (bng a/*[alen]*/, bngsize alen,
- int shift);
-#define bng_shift_right bng_ops.shift_right
-
- /* {a,alen} := {a,alen} + d * {b,blen}. Return carry out.
- Require alen >= blen.
- If alen > blen, the carry out returned is 0 or 1.
- If alen == blen, the carry out returned is a full digit. */
- bngdigit (*mult_add_digit)
- (bng a/*[alen]*/, bngsize alen,
- bng b/*[blen]*/, bngsize blen,
- bngdigit d);
-#define bng_mult_add_digit bng_ops.mult_add_digit
-
- /* {a,alen} := {a,alen} - d * {b,blen}. Return carry out.
- Require alen >= blen.
- If alen > blen, the carry out returned is 0 or 1.
- If alen == blen, the carry out returned is a full digit. */
- bngdigit (*mult_sub_digit)
- (bng a/*[alen]*/, bngsize alen,
- bng b/*[blen]*/, bngsize blen,
- bngdigit d);
-#define bng_mult_sub_digit bng_ops.mult_sub_digit
-
- /* {a,alen} := {a,alen} + {b,blen} * {c,clen}. Return carry out.
- Require alen >= blen + clen. */
- bngcarry (*mult_add)
- (bng a/*[alen]*/, bngsize alen,
- bng b/*[blen]*/, bngsize blen,
- bng c/*[clen]*/, bngsize clen);
-#define bng_mult_add bng_ops.mult_add
-
- /* {a,alen} := 2 * {a,alen} + {b,blen}^2. Return carry out.
- Require alen >= 2 * blen. */
- bngcarry (*square_add)
- (bng a/*[alen]*/, bngsize alen,
- bng b/*[blen]*/, bngsize blen);
-#define bng_square_add bng_ops.square_add
-
- /* {a,len-1} := {b,len} / d. Return {b,len} modulo d.
- Require d is normalized and MSD of b < d.
- See div_rem_digit for a function that does not require d
- to be normalized */
- bngdigit (*div_rem_norm_digit)
- (bng a/*[len-1]*/, bng b/*[len]*/, bngsize len, bngdigit d);
-#define bng_div_rem_norm_digit bng_ops.div_rem_norm_digit
-
- /* {a,len-1} := {b,len} / d. Return {b,len} modulo d.
- Require MSD of b < d. */
- bngdigit (*div_rem_digit)
- (bng a/*[len-1]*/, bng b/*[len]*/, bngsize len, bngdigit d);
-#define bng_div_rem_digit bng_ops.div_rem_digit
-
- /* {n+dlen, nlen-dlen} := {n,nlen} / {d, dlen}.
- {n, dlen} := {n,nlen} modulo {d, dlen}.
- Require nlen > dlen and MSD of n < MSD of d (which implies d != 0). */
- void (*div_rem)
- (bng n/*[nlen]*/, bngsize nlen,
- bng d/*[nlen]*/, bngsize dlen);
-#define bng_div_rem bng_ops.div_rem
-};
-
-extern struct bng_operations bng_ops;
-
-/* Initialize the BNG library */
-extern void bng_init(void);
-
-/* {a,alen} := 0 */
-#define bng_zero(a,alen) memset((a), 0, (alen) * sizeof(bngdigit))
-
-/* {a,len} := {b,len} */
-#define bng_assign(a,b,len) memmove((a), (b), (len) * sizeof(bngdigit))
-
-/* Complement the digits of {a,len} */
-extern void bng_complement(bng a/*[alen]*/, bngsize alen);
-
-/* Return number of significant digits in {a,alen}. */
-extern bngsize bng_num_digits(bng a/*[alen]*/, bngsize alen);
-
-/* Return 1 if {a,alen} is 0, 0 otherwise. */
-#define bng_is_zero(a,alen) (bng_num_digits(a,alen) == 0)
-
-/* Return 0 if {a,alen} = {b,blen}
- <0 if {a,alen} < {b,blen}
- >0 if {a,alen} > {b,blen}. */
-extern int bng_compare(bng a/*[alen]*/, bngsize alen,
- bng b/*[blen]*/, bngsize blen);
-
-/* Return the number of leading zero bits in digit d. */
-extern int bng_leading_zero_bits(bngdigit d);
-
diff --git a/otherlibs/num/bng_alpha.c b/otherlibs/num/bng_alpha.c
deleted file mode 100644
index 0360cff7bc..0000000000
--- a/otherlibs/num/bng_alpha.c
+++ /dev/null
@@ -1,23 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 2003 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Code specific to the Alpha architecture. */
-
-#define BngMult(resh,resl,arg1,arg2) \
- asm("mulq %2, %3, %0 \n\t" \
- "umulh %2, %3, %1" \
- : "=&r" (resl), "=r" (resh) \
- : "r" (arg1), "r" (arg2))
-
diff --git a/otherlibs/num/bng_amd64.c b/otherlibs/num/bng_amd64.c
deleted file mode 100644
index 0a0bd107f7..0000000000
--- a/otherlibs/num/bng_amd64.c
+++ /dev/null
@@ -1,196 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 2003 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Code specific to the AMD x86_64 architecture. */
-
-#define BngAdd2(res,carryout,arg1,arg2) \
- asm("xorl %1, %1 \n\t" \
- "addq %3, %0 \n\t" \
- "setc %b1" \
- : "=r" (res), "=&q" (carryout) \
- : "0" (arg1), "rm" (arg2))
-
-#define BngSub2(res,carryout,arg1,arg2) \
- asm("xorl %1, %1 \n\t" \
- "subq %3, %0 \n\t" \
- "setc %b1" \
- : "=r" (res), "=&q" (carryout) \
- : "0" (arg1), "rm" (arg2))
-
-#define BngMult(resh,resl,arg1,arg2) \
- asm("mulq %3" \
- : "=a" (resl), "=d" (resh) \
- : "a" (arg1), "r" (arg2))
-
-#define BngDiv(quo,rem,nh,nl,d) \
- asm("divq %4" \
- : "=a" (quo), "=d" (rem) \
- : "a" (nl), "d" (nh), "r" (d))
-
-/* Reimplementation in asm of some of the bng operations. */
-
-static bngcarry bng_amd64_add
- (bng a/*[alen]*/, bngsize alen,
- bng b/*[blen]*/, bngsize blen,
- bngcarry carry)
-{
- bngdigit tmp;
- alen -= blen;
- if (blen > 0) {
- asm("negb %b3 \n\t"
- "1: \n\t"
- "movq (%0), %4 \n\t"
- "adcq (%1), %4 \n\t"
- "movq %4, (%0) \n\t"
- "leaq 8(%0), %0 \n\t"
- "leaq 8(%1), %1 \n\t"
- "decq %2 \n\t"
- "jnz 1b \n\t"
- "setc %b3"
- : "=r" (a), "=r" (b), "=r" (blen), "=q" (carry), "=r" (tmp)
- : "0" (a), "1" (b), "2" (blen), "3" (carry));
- }
- if (carry == 0 || alen == 0) return carry;
- do {
- if (++(*a) != 0) return 0;
- a++;
- } while (--alen);
- return 1;
-}
-
-static bngcarry bng_amd64_sub
- (bng a/*[alen]*/, bngsize alen,
- bng b/*[blen]*/, bngsize blen,
- bngcarry carry)
-{
- bngdigit tmp;
- alen -= blen;
- if (blen > 0) {
- asm("negb %b3 \n\t"
- "1: \n\t"
- "movq (%0), %4 \n\t"
- "sbbq (%1), %4 \n\t"
- "movq %4, (%0) \n\t"
- "leaq 8(%0), %0 \n\t"
- "leaq 8(%1), %1 \n\t"
- "decq %2 \n\t"
- "jnz 1b \n\t"
- "setc %b3"
- : "=r" (a), "=r" (b), "=r" (blen), "=q" (carry), "=r" (tmp)
- : "0" (a), "1" (b), "2" (blen), "3" (carry));
- }
- if (carry == 0 || alen == 0) return carry;
- do {
- if ((*a)-- != 0) return 0;
- a++;
- } while (--alen);
- return 1;
-}
-
-static bngdigit bng_amd64_mult_add_digit
- (bng a/*[alen]*/, bngsize alen,
- bng b/*[blen]*/, bngsize blen,
- bngdigit d)
-{
- bngdigit out;
- bngcarry carry;
-
- alen -= blen;
- out = 0;
- if (blen > 0) {
- asm("1: \n\t"
- "movq (%1), %%rax \n\t"
- "mulq %7\n\t" /* rdx:rax = d * next digit of b */
- "addq (%0), %%rax \n\t" /* add next digit of a to rax */
- "adcq $0, %%rdx \n\t" /* accumulate carry in rdx */
- "addq %3, %%rax \n\t" /* add out to rax */
- "adcq $0, %%rdx \n\t" /* accumulate carry in rdx */
- "movq %%rax, (%0) \n\t" /* rax is next digit of result */
- "movq %%rdx, %3 \n\t" /* rdx is next out */
- "leaq 8(%0), %0 \n\t"
- "leaq 8(%1), %1 \n\t"
- "decq %2 \n\t"
- "jnz 1b"
- : "=&r" (a), "=&r" (b), "=&r" (blen), "=&r" (out)
- : "0" (a), "1" (b), "2" (blen), "rm" (d), "3" (out)
- : "rax", "rdx");
- }
- if (alen == 0) return out;
- /* current digit of a += out */
- BngAdd2(*a, carry, *a, out);
- a++;
- alen--;
- /* Propagate carry */
- if (carry == 0 || alen == 0) return carry;
- do {
- if (++(*a) != 0) return 0;
- a++;
- } while (--alen);
- return 1;
-}
-
-static bngdigit bng_amd64_mult_sub_digit
- (bng a/*[alen]*/, bngsize alen,
- bng b/*[blen]*/, bngsize blen,
- bngdigit d)
-{
- bngdigit out, tmp;
- bngcarry carry;
-
- alen -= blen;
- out = 0;
- if (blen > 0) {
- asm("1: \n\t"
- "movq (%1), %%rax \n\t"
- "movq (%0), %4 \n\t"
- "mulq %8\n\t" /* rdx:rax = d * next digit of b */
- "subq %%rax, %4 \n\t" /* subtract rax from next digit of a */
- "adcq $0, %%rdx \n\t" /* accumulate carry in rdx */
- "subq %3, %4 \n\t" /* subtract out */
- "adcq $0, %%rdx \n\t" /* accumulate carry in rdx */
- "movq %4, (%0) \n\t" /* store next digit of result */
- "movq %%rdx, %3 \n\t" /* rdx is next out */
- "leaq 8(%0), %0 \n\t"
- "leaq 8(%1), %1 \n\t"
- "decq %2 \n\t"
- "jnz 1b"
- : "=&r" (a), "=&r" (b), "=&rm" (blen), "=&r" (out), "=&r" (tmp)
- : "0" (a), "1" (b), "2" (blen), "rm" (d), "3" (out)
- : "rax", "rdx");
- }
- if (alen == 0) return out;
- /* current digit of a -= out */
- BngSub2(*a, carry, *a, out);
- a++;
- alen--;
- /* Propagate carry */
- if (carry == 0 || alen == 0) return carry;
- do {
- if ((*a)-- != 0) return 0;
- a++;
- } while (--alen);
- return 1;
-}
-
-static void bng_amd64_setup_ops(void)
-{
- bng_ops.add = bng_amd64_add;
- bng_ops.sub = bng_amd64_sub;
- bng_ops.mult_add_digit = bng_amd64_mult_add_digit;
- bng_ops.mult_sub_digit = bng_amd64_mult_sub_digit;
-}
-
-#define BNG_SETUP_OPS bng_amd64_setup_ops()
-
diff --git a/otherlibs/num/bng_digit.c b/otherlibs/num/bng_digit.c
deleted file mode 100644
index e46eacb6b8..0000000000
--- a/otherlibs/num/bng_digit.c
+++ /dev/null
@@ -1,171 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 2003 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/**** Generic operations on digits ****/
-
-/* These macros can be defined in the machine-specific include file.
- Below are the default definitions (in plain C).
- Except for BngMult, all macros are guaranteed to evaluate their
- arguments exactly once. */
-
-#ifndef BngAdd2
-/* res = arg1 + arg2. carryout = carry out. */
-#define BngAdd2(res,carryout,arg1,arg2) { \
- bngdigit tmp1, tmp2; \
- tmp1 = arg1; \
- tmp2 = tmp1 + (arg2); \
- carryout = (tmp2 < tmp1); \
- res = tmp2; \
-}
-#endif
-
-#ifndef BngAdd2Carry
-/* res = arg1 + arg2 + carryin. carryout = carry out. */
-#define BngAdd2Carry(res,carryout,arg1,arg2,carryin) { \
- bngdigit tmp1, tmp2, tmp3; \
- tmp1 = arg1; \
- tmp2 = tmp1 + (arg2); \
- tmp3 = tmp2 + (carryin); \
- carryout = (tmp2 < tmp1) + (tmp3 < tmp2); \
- res = tmp3; \
-}
-#endif
-
-#ifndef BngAdd3
-/* res = arg1 + arg2 + arg3. Each carry increments carryaccu. */
-#define BngAdd3(res,carryaccu,arg1,arg2,arg3) { \
- bngdigit tmp1, tmp2, tmp3; \
- tmp1 = arg1; \
- tmp2 = tmp1 + (arg2); \
- carryaccu += (tmp2 < tmp1); \
- tmp3 = tmp2 + (arg3); \
- carryaccu += (tmp3 < tmp2); \
- res = tmp3; \
-}
-#endif
-
-#ifndef BngSub2
-/* res = arg1 - arg2. carryout = carry out. */
-#define BngSub2(res,carryout,arg1,arg2) { \
- bngdigit tmp1, tmp2; \
- tmp1 = arg1; \
- tmp2 = arg2; \
- res = tmp1 - tmp2; \
- carryout = (tmp1 < tmp2); \
-}
-#endif
-
-#ifndef BngSub2Carry
-/* res = arg1 - arg2 - carryin. carryout = carry out. */
-#define BngSub2Carry(res,carryout,arg1,arg2,carryin) { \
- bngdigit tmp1, tmp2, tmp3; \
- tmp1 = arg1; \
- tmp2 = arg2; \
- tmp3 = tmp1 - tmp2; \
- res = tmp3 - (carryin); \
- carryout = (tmp1 < tmp2) + (tmp3 < carryin); \
-}
-#endif
-
-#ifndef BngSub3
-/* res = arg1 - arg2 - arg3. Each carry increments carryaccu. */
-#define BngSub3(res,carryaccu,arg1,arg2,arg3) { \
- bngdigit tmp1, tmp2, tmp3, tmp4; \
- tmp1 = arg1; \
- tmp2 = arg2; \
- tmp3 = arg3; \
- tmp4 = tmp1 - tmp2; \
- res = tmp4 - tmp3; \
- carryaccu += (tmp1 < tmp2) + (tmp4 < tmp3); \
-}
-#endif
-
-#define BngLowHalf(d) ((d) & ((1L << BNG_BITS_PER_HALF_DIGIT) - 1))
-#define BngHighHalf(d) ((d) >> BNG_BITS_PER_HALF_DIGIT)
-
-#ifndef BngMult
-/* resl = low digit of product arg1 * arg2
- resh = high digit of product arg1 * arg2. */
-#define BngMult(resh,resl,arg1,arg2) { \
- bngdigit p11 = BngLowHalf(arg1) * BngLowHalf(arg2); \
- bngdigit p12 = BngLowHalf(arg1) * BngHighHalf(arg2); \
- bngdigit p21 = BngHighHalf(arg1) * BngLowHalf(arg2); \
- bngdigit p22 = BngHighHalf(arg1) * BngHighHalf(arg2); \
- resh = p22 + (p12 >> BNG_BITS_PER_HALF_DIGIT) \
- + (p21 >> BNG_BITS_PER_HALF_DIGIT); \
- BngAdd3(resl, resh, \
- p11, p12 << BNG_BITS_PER_HALF_DIGIT, p21 << BNG_BITS_PER_HALF_DIGIT); \
-}
-#endif
-
-#ifndef BngDiv
-/* Divide the double-width number nh:nl by d.
- Require d != 0 and nh < d.
- Store quotient in quo, remainder in rem.
- Can be slow if d is not normalized. */
-#define BngDiv(quo,rem,nh,nl,d) bng_div_aux(&(quo),&(rem),nh,nl,d)
-#define BngDivNeedsNormalization
-
-static void bng_div_aux(bngdigit * quo, bngdigit * rem,
- bngdigit nh, bngdigit nl, bngdigit d)
-{
- bngdigit dl, dh, ql, qh, pl, ph, nsaved;
-
- dl = BngLowHalf(d);
- dh = BngHighHalf(d);
- /* Under-estimate the top half of the quotient (qh) */
- qh = nh / (dh + 1);
- /* Shift nh:nl right by BNG_BITS_PER_HALF_DIGIT bits,
- so that we focus on the top 1.5 digits of the numerator.
- Then, subtract (qh * d) from nh:nl. */
- nsaved = BngLowHalf(nl);
- ph = qh * dh;
- pl = qh * dl;
- nh -= ph; /* Subtract before shifting so that carry propagates for free */
- nl = (nl >> BNG_BITS_PER_HALF_DIGIT) | (nh << BNG_BITS_PER_HALF_DIGIT);
- nh = (nh >> BNG_BITS_PER_HALF_DIGIT);
- nh -= (nl < pl); /* Borrow */
- nl -= pl;
- /* Adjust estimate qh until nh:nl < 0:d */
- while (nh != 0 || nl >= d) {
- nh -= (nl < d); /* Borrow */
- nl -= d;
- qh++;
- }
- /* Under-estimate the bottom half of the quotient (ql) */
- ql = nl / (dh + 1);
- /* Shift nh:nl left by BNG_BITS_PER_HALF_DIGIT bits, restoring the
- low bits we saved earlier, so that we focus on the bottom 1.5 digit
- of the numerator. Then, subtract (ql * d) from nh:nl. */
- ph = ql * dh;
- pl = ql * dl;
- nl -= ph; /* Subtract before shifting so that carry propagates for free */
- nh = (nl >> BNG_BITS_PER_HALF_DIGIT);
- nl = (nl << BNG_BITS_PER_HALF_DIGIT) | nsaved;
- nh -= (nl < pl); /* Borrow */
- nl -= pl;
- /* Adjust estimate ql until nh:nl < 0:d */
- while (nh != 0 || nl >= d) {
- nh -= (nl < d); /* Borrow */
- nl -= d;
- ql++;
- }
- /* We're done */
- *quo = (qh << BNG_BITS_PER_HALF_DIGIT) | ql;
- *rem = nl;
-}
-
-#endif
-
diff --git a/otherlibs/num/bng_ia32.c b/otherlibs/num/bng_ia32.c
deleted file mode 100644
index c3ca9a9805..0000000000
--- a/otherlibs/num/bng_ia32.c
+++ /dev/null
@@ -1,412 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 2003 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Code specific to the Intel IA32 (x86) architecture. */
-
-#define BngAdd2(res,carryout,arg1,arg2) \
- asm("xorl %1, %1 \n\t" \
- "addl %3, %0 \n\t" \
- "setc %b1" \
- : "=r" (res), "=&q" (carryout) \
- : "0" (arg1), "rm" (arg2))
-
-#define BngSub2(res,carryout,arg1,arg2) \
- asm("xorl %1, %1 \n\t" \
- "subl %3, %0 \n\t" \
- "setc %b1" \
- : "=r" (res), "=&q" (carryout) \
- : "0" (arg1), "rm" (arg2))
-
-#define BngMult(resh,resl,arg1,arg2) \
- asm("mull %3" \
- : "=a" (resl), "=d" (resh) \
- : "a" (arg1), "r" (arg2))
-
-#define BngDiv(quo,rem,nh,nl,d) \
- asm("divl %4" \
- : "=a" (quo), "=d" (rem) \
- : "a" (nl), "d" (nh), "r" (d))
-
-/* Reimplementation in asm of some of the bng operations. */
-
-static bngcarry bng_ia32_add
- (bng a/*[alen]*/, bngsize alen,
- bng b/*[blen]*/, bngsize blen,
- bngcarry carry)
-{
- bngdigit tmp;
- alen -= blen;
- if (blen > 0) {
- asm("negb %b3 \n\t"
- "1: \n\t"
- "movl (%0), %4 \n\t"
- "adcl (%1), %4 \n\t"
- "movl %4, (%0) \n\t"
- "leal 4(%0), %0 \n\t"
- "leal 4(%1), %1 \n\t"
- "decl %2 \n\t"
- "jnz 1b \n\t"
- "setc %b3"
- : "+&r" (a), "+&r" (b), "+&r" (blen), "+&q" (carry), "=&r" (tmp));
- }
- if (carry == 0 || alen == 0) return carry;
- do {
- if (++(*a) != 0) return 0;
- a++;
- } while (--alen);
- return 1;
-}
-
-static bngcarry bng_ia32_sub
- (bng a/*[alen]*/, bngsize alen,
- bng b/*[blen]*/, bngsize blen,
- bngcarry carry)
-{
- bngdigit tmp;
- alen -= blen;
- if (blen > 0) {
- asm("negb %b3 \n\t"
- "1: \n\t"
- "movl (%0), %4 \n\t"
- "sbbl (%1), %4 \n\t"
- "movl %4, (%0) \n\t"
- "leal 4(%0), %0 \n\t"
- "leal 4(%1), %1 \n\t"
- "decl %2 \n\t"
- "jnz 1b \n\t"
- "setc %b3"
- : "+&r" (a), "+&r" (b), "+&r" (blen), "+&q" (carry), "=&r" (tmp));
- }
- if (carry == 0 || alen == 0) return carry;
- do {
- if ((*a)-- != 0) return 0;
- a++;
- } while (--alen);
- return 1;
-}
-
-static bngdigit bng_ia32_mult_add_digit
- (bng a/*[alen]*/, bngsize alen,
- bng b/*[blen]*/, bngsize blen,
- bngdigit d)
-{
- bngdigit out;
- bngcarry carry;
-
- alen -= blen;
- out = 0;
- if (blen > 0) {
- asm("1: \n\t"
- "movl (%1), %%eax \n\t"
- "mull %4\n\t" /* edx:eax = d * next digit of b */
- "addl (%0), %%eax \n\t" /* add next digit of a to eax */
- "adcl $0, %%edx \n\t" /* accumulate carry in edx */
- "addl %3, %%eax \n\t" /* add out to eax */
- "adcl $0, %%edx \n\t" /* accumulate carry in edx */
- "movl %%eax, (%0) \n\t" /* eax is next digit of result */
- "movl %%edx, %3 \n\t" /* edx is next out */
- "leal 4(%0), %0 \n\t"
- "leal 4(%1), %1 \n\t"
- "decl %2 \n\t"
- "jnz 1b"
- : "+&r" (a), "+&r" (b), "+&rm" (blen), "+&r" (out)
- : "rm" (d)
- : "eax", "edx");
- }
- if (alen == 0) return out;
- /* current digit of a += out */
- BngAdd2(*a, carry, *a, out);
- a++;
- alen--;
- /* Propagate carry */
- if (carry == 0 || alen == 0) return carry;
- do {
- if (++(*a) != 0) return 0;
- a++;
- } while (--alen);
- return 1;
-}
-
-static bngdigit bng_ia32_mult_sub_digit
- (bng a/*[alen]*/, bngsize alen,
- bng b/*[blen]*/, bngsize blen,
- bngdigit d)
-{
- bngdigit out, tmp;
- bngcarry carry;
-
- alen -= blen;
- out = 0;
- if (blen > 0) {
- asm("1: \n\t"
- "movl (%1), %%eax \n\t"
- "movl (%0), %4 \n\t"
- "mull %5\n\t" /* edx:eax = d * next digit of b */
- "subl %%eax, %4 \n\t" /* subtract eax from next digit of a */
- "adcl $0, %%edx \n\t" /* accumulate carry in edx */
- "subl %3, %4 \n\t" /* subtract out */
- "adcl $0, %%edx \n\t" /* accumulate carry in edx */
- "movl %4, (%0) \n\t" /* store next digit of result */
- "movl %%edx, %3 \n\t" /* edx is next out */
- "leal 4(%0), %0 \n\t"
- "leal 4(%1), %1 \n\t"
- "decl %2 \n\t"
- "jnz 1b"
- : "+&r" (a), "+&r" (b), "+&rm" (blen), "+&rm" (out), "=&r" (tmp)
- : "rm" (d)
- : "eax", "edx");
- }
- if (alen == 0) return out;
- /* current digit of a -= out */
- BngSub2(*a, carry, *a, out);
- a++;
- alen--;
- /* Propagate carry */
- if (carry == 0 || alen == 0) return carry;
- do {
- if ((*a)-- != 0) return 0;
- a++;
- } while (--alen);
- return 1;
-}
-
-/* This is another asm implementation of some of the bng operations,
- using SSE2 operations to provide 64-bit arithmetic.
- This is faster than the plain IA32 code above on the Pentium 4.
- (Arithmetic operations with carry are slow on the Pentium 4). */
-
-#if BNG_ASM_LEVEL >= 2
-
-static bngcarry bng_ia32sse2_add
- (bng a/*[alen]*/, bngsize alen,
- bng b/*[blen]*/, bngsize blen,
- bngcarry carry)
-{
- alen -= blen;
- if (blen > 0) {
- asm("movd %3, %%mm0 \n\t" /* MM0 is carry */
- "1: \n\t"
- "movd (%0), %%mm1 \n\t" /* MM1 is next digit of a */
- "movd (%1), %%mm2 \n\t" /* MM2 is next digit of b */
- "paddq %%mm1, %%mm0 \n\t" /* Add carry (64 bits) */
- "paddq %%mm2, %%mm0 \n\t" /* Add digits (64 bits) */
- "movd %%mm0, (%0) \n\t" /* Store low 32 bits of result */
- "psrlq $32, %%mm0 \n\t" /* Next carry is top 32 bits of results */
- "addl $4, %0\n\t"
- "addl $4, %1\n\t"
- "subl $1, %2\n\t"
- "jne 1b \n\t"
- "movd %%mm0, %3 \n\t"
- "emms"
- : "+&r" (a), "+&r" (b), "+&r" (blen), "+&rm" (carry));
- }
- if (carry == 0 || alen == 0) return carry;
- do {
- if (++(*a) != 0) return 0;
- a++;
- } while (--alen);
- return 1;
-}
-
-static bngcarry bng_ia32sse2_sub
- (bng a/*[alen]*/, bngsize alen,
- bng b/*[blen]*/, bngsize blen,
- bngcarry carry)
-{
- alen -= blen;
- if (blen > 0) {
- asm("movd %3, %%mm0 \n\t" /* MM0 is carry */
- "1: \n\t"
- "movd (%0), %%mm1 \n\t" /* MM1 is next digit of a */
- "movd (%1), %%mm2 \n\t" /* MM2 is next digit of b */
- "psubq %%mm0, %%mm1 \n\t" /* Subtract carry (64 bits) */
- "psubq %%mm2, %%mm1 \n\t" /* Subtract digits (64 bits) */
- "movd %%mm1, (%0) \n\t" /* Store low 32 bits of result */
- "psrlq $63, %%mm1 \n\t" /* Next carry is sign bit of result */
- "movq %%mm1, %%mm0 \n\t"
- "addl $4, %0\n\t"
- "addl $4, %1\n\t"
- "subl $1, %2\n\t"
- "jne 1b \n\t"
- "movd %%mm0, %3 \n\t"
- "emms"
- : "+&r" (a), "+&r" (b), "+&r" (blen), "+&rm" (carry));
- }
- if (carry == 0 || alen == 0) return carry;
- do {
- if ((*a)-- != 0) return 0;
- a++;
- } while (--alen);
- return 1;
-}
-
-static bngdigit bng_ia32sse2_mult_add_digit
- (bng a/*[alen]*/, bngsize alen,
- bng b/*[blen]*/, bngsize blen,
- bngdigit d)
-{
- bngdigit out;
- bngcarry carry;
-
- alen -= blen;
- out = 0;
- if (blen > 0) {
- asm("pxor %%mm0, %%mm0 \n\t" /* MM0 is carry */
- "movd %4, %%mm7 \n\t" /* MM7 is digit d */
- "1: \n\t"
- "movd (%0), %%mm1 \n\t" /* MM1 is next digit of a */
- "movd (%1), %%mm2 \n\t" /* MM2 is next digit of b */
- "pmuludq %%mm7, %%mm2 \n\t" /* MM2 = d * digit of b */
- "paddq %%mm1, %%mm0 \n\t" /* Add product and carry ... */
- "paddq %%mm2, %%mm0 \n\t" /* ... and digit of a */
- "movd %%mm0, (%0) \n\t" /* Store low 32 bits of result */
- "psrlq $32, %%mm0 \n\t" /* Next carry is high 32 bits result */
- "addl $4, %0\n\t"
- "addl $4, %1\n\t"
- "subl $1, %2\n\t"
- "jne 1b \n\t"
- "movd %%mm0, %3 \n\t"
- "emms"
- : "+&r" (a), "+&r" (b), "+&r" (blen), "=&rm" (out)
- : "m" (d));
- }
- if (alen == 0) return out;
- /* current digit of a += out */
- BngAdd2(*a, carry, *a, out);
- a++;
- alen--;
- /* Propagate carry */
- if (carry == 0 || alen == 0) return carry;
- do {
- if (++(*a) != 0) return 0;
- a++;
- } while (--alen);
- return 1;
-}
-
-static bngdigit bng_ia32sse2_mult_sub_digit
- (bng a/*[alen]*/, bngsize alen,
- bng b/*[blen]*/, bngsize blen,
- bngdigit d)
-{
- static unsigned long long bias1 = 0xFFFFFFFF00000000ULL - 0xFFFFFFFFULL;
- static unsigned long bias2 = 0xFFFFFFFFUL;
- bngdigit out;
- bngcarry carry;
-
- alen -= blen;
- out = 0;
- if (blen > 0) {
- /* Carry C is represented by ENC(C) = 0xFFFFFFFF - C (one's complement) */
- asm("movd %6, %%mm0 \n\t" /* MM0 is carry (initially 0xFFFFFFFF) */
- "movq %5, %%mm6 \n\t" /* MM6 is magic constant bias1 */
- "movd %4, %%mm7 \n\t" /* MM7 is digit d */
- "1: \n\t"
- "movd (%0), %%mm1 \n\t" /* MM1 is next digit of a */
- "movd (%1), %%mm2 \n\t" /* MM2 is next digit of b */
- "paddq %%mm6, %%mm1 \n\t" /* bias digit of a */
- "pmuludq %%mm7, %%mm2 \n\t" /* MM2 = d * digit of b */
- /* Compute
- digit of a + ENC(carry) + 0xFFFFFFFF00000000 - 0xFFFFFFFF - product
- = digit of a - carry + 0xFFFFFFFF00000000 - product
- = digit of a - carry - productlow + (ENC(nextcarry) << 32) */
- "psubq %%mm2, %%mm1 \n\t"
- "paddq %%mm1, %%mm0 \n\t"
- "movd %%mm0, (%0) \n\t" /* Store low 32 bits of result */
- "psrlq $32, %%mm0 \n\t" /* Next carry is 32 high bits of result */
- "addl $4, %0\n\t"
- "addl $4, %1\n\t"
- "subl $1, %2\n\t"
- "jne 1b \n\t"
- "movd %%mm0, %3 \n\t"
- "emms"
- : "+&r" (a), "+&r" (b), "+&r" (blen), "=&rm" (out)
- : "m" (d), "m" (bias1), "m" (bias2));
- out = ~out; /* Undo encoding on out digit */
- }
- if (alen == 0) return out;
- /* current digit of a -= out */
- BngSub2(*a, carry, *a, out);
- a++;
- alen--;
- /* Propagate carry */
- if (carry == 0 || alen == 0) return carry;
- do {
- if ((*a)-- != 0) return 0;
- a++;
- } while (--alen);
- return 1;
-}
-
-/* Detect whether SSE2 instructions are supported */
-
-static int bng_ia32_sse2_supported(void)
-{
- unsigned int flags, newflags, max_id, capabilities;
-
-#define EFLAG_CPUID 0x00200000
-#define CPUID_IDENTIFY 0
-#define CPUID_CAPABILITIES 1
-#define SSE2_CAPABILITY 26
-
- /* Check if processor has CPUID instruction */
- asm("pushfl \n\t"
- "popl %0"
- : "=r" (flags) : );
- newflags = flags ^ EFLAG_CPUID; /* CPUID detection flag */
- asm("pushfl \n\t"
- "pushl %1 \n\t"
- "popfl \n\t"
- "pushfl \n\t"
- "popl %0 \n\t"
- "popfl"
- : "=r" (flags) : "r" (newflags));
- /* If CPUID detection flag cannot be changed, CPUID instruction is not
- available */
- if ((flags & EFLAG_CPUID) != (newflags & EFLAG_CPUID)) return 0;
- /* See if SSE2 extensions are supported */
- asm("pushl %%ebx \n\t" /* need to preserve %ebx for PIC */
- "cpuid \n\t"
- "popl %%ebx"
- : "=a" (max_id) : "a" (CPUID_IDENTIFY): "ecx", "edx");
- if (max_id < 1) return 0;
- asm("pushl %%ebx \n\t"
- "cpuid \n\t"
- "popl %%ebx"
- : "=d" (capabilities) : "a" (CPUID_CAPABILITIES) : "ecx");
- return capabilities & (1 << SSE2_CAPABILITY);
-}
-
-#endif
-
-static void bng_ia32_setup_ops(void)
-{
-#if BNG_ASM_LEVEL >= 2
- if (bng_ia32_sse2_supported()) {
- bng_ops.add = bng_ia32sse2_add;
- bng_ops.sub = bng_ia32sse2_sub;
- bng_ops.mult_add_digit = bng_ia32sse2_mult_add_digit;
- bng_ops.mult_sub_digit = bng_ia32sse2_mult_sub_digit;
- return;
- }
-#endif
- bng_ops.add = bng_ia32_add;
- bng_ops.sub = bng_ia32_sub;
- bng_ops.mult_add_digit = bng_ia32_mult_add_digit;
- bng_ops.mult_sub_digit = bng_ia32_mult_sub_digit;
-}
-
-#define BNG_SETUP_OPS bng_ia32_setup_ops()
-
diff --git a/otherlibs/num/bng_mips.c b/otherlibs/num/bng_mips.c
deleted file mode 100644
index 2b760e4b5e..0000000000
--- a/otherlibs/num/bng_mips.c
+++ /dev/null
@@ -1,24 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 2003 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Code specific to the MIPS architecture. */
-
-#define BngMult(resh,resl,arg1,arg2) \
- asm("multu %2, %3 \n\t" \
- "mflo %0 \n\t" \
- "mfhi %1" \
- : "=r" (resl), "=r" (resh) \
- : "r" (arg1), "r" (arg2))
-
diff --git a/otherlibs/num/bng_ppc.c b/otherlibs/num/bng_ppc.c
deleted file mode 100644
index d0e33a2f25..0000000000
--- a/otherlibs/num/bng_ppc.c
+++ /dev/null
@@ -1,86 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 2003 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Code specific to the PowerPC architecture. */
-
-#define BngAdd2(res,carryout,arg1,arg2) \
- asm("addc %0, %2, %3 \n\t" \
- "li %1, 0 \n\t" \
- "addze %1, %1" \
- : "=r" (res), "=r" (carryout) \
- : "r" (arg1), "r" (arg2))
-
-#define BngAdd2Carry(res,carryout,arg1,arg2,carryin) \
- asm("addic %1, %4, -1 \n\t" \
- "adde %0, %2, %3 \n\t" \
- "li %1, 0 \n\t" \
- "addze %1, %1" \
- : "=r" (res), "=&r" (carryout) \
- : "r" (arg1), "r" (arg2), "1" (carryin))
-
-#define BngAdd3(res,carryaccu,arg1,arg2,arg3) \
- asm("addc %0, %2, %3 \n\t" \
- "addze %1, %1 \n\t" \
- "addc %0, %0, %4 \n\t" \
- "addze %1, %1" \
- : "=&r" (res), "=&r" (carryaccu) \
- : "r" (arg1), "r" (arg2), "r" (arg3), "1" (carryaccu))
-
-/* The "subtract" instructions interpret carry differently than what we
- need: the processor carry bit CA is 1 if no carry occured,
- 0 if a carry occured. In other terms, CA = !carry.
- Thus, subfe rd,ra,rb computes rd = ra - rb - !CA
- subfe rd,rd,rd sets rd = - !CA
- subfe rd,rd,rd; neg rd, rd sets rd = !CA and recovers "our" carry. */
-
-#define BngSub2(res,carryout,arg1,arg2) \
- asm("subfc %0, %3, %2 \n\t" \
- "subfe %1, %1, %1\n\t" \
- "neg %1, %1" \
- : "=r" (res), "=r" (carryout) \
- : "r" (arg1), "r" (arg2))
-
-#define BngSub2Carry(res,carryout,arg1,arg2,carryin) \
- asm("subfic %1, %4, 0 \n\t" \
- "subfe %0, %3, %2 \n\t" \
- "subfe %1, %1, %1 \n\t" \
- "neg %1, %1" \
- : "=r" (res), "=&r" (carryout) \
- : "r" (arg1), "r" (arg2), "1" (carryin))
-
-/* Here is what happens with carryaccu:
- neg %1, %1 carryaccu = -carryaccu
- addze %1, %1 carryaccu += !carry1
- addze %1, %1 carryaccu += !carry2
- subifc %1, %1, 2 carryaccu = 2 - carryaccu
- Thus, carryaccu_final = carryaccu_initial + 2 - (1 - carry1) - (1 - carry2)
- = carryaccu_initial + carry1 + carry2
-*/
-
-#define BngSub3(res,carryaccu,arg1,arg2,arg3) \
- asm("neg %1, %1 \n\t" \
- "subfc %0, %3, %2 \n\t" \
- "addze %1, %1 \n\t" \
- "subfc %0, %4, %0 \n\t" \
- "addze %1, %1 \n\t" \
- "subfic %1, %1, 2 \n\t" \
- : "=&r" (res), "=&r" (carryaccu) \
- : "r" (arg1), "r" (arg2), "r" (arg3), "1" (carryaccu))
-
-#define BngMult(resh,resl,arg1,arg2) \
- asm("mullw %0, %2, %3 \n\t" \
- "mulhwu %1, %2, %3" \
- : "=&r" (resl), "=r" (resh) \
- : "r" (arg1), "r" (arg2))
diff --git a/otherlibs/num/bng_sparc.c b/otherlibs/num/bng_sparc.c
deleted file mode 100644
index 934c0b2f7e..0000000000
--- a/otherlibs/num/bng_sparc.c
+++ /dev/null
@@ -1,77 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 2003 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* 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
deleted file mode 100644
index b7eb4c67d4..0000000000
--- a/otherlibs/num/int_misc.ml
+++ /dev/null
@@ -1,36 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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
deleted file mode 100644
index 28bb335b8e..0000000000
--- a/otherlibs/num/int_misc.mli
+++ /dev/null
@@ -1,25 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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
deleted file mode 100644
index 66a664fab0..0000000000
--- a/otherlibs/num/nat.h
+++ /dev/null
@@ -1,19 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1999 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* 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
deleted file mode 100644
index dcfb4c5057..0000000000
--- a/otherlibs/num/nat.ml
+++ /dev/null
@@ -1,570 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Int_misc
-
-type nat;;
-
-external create_nat: int -> nat = "create_nat"
-external set_to_zero_nat: nat -> int -> int -> unit = "set_to_zero_nat"
-external blit_nat: nat -> int -> nat -> int -> int -> unit = "blit_nat"
-external set_digit_nat: nat -> int -> int -> unit = "set_digit_nat"
-external nth_digit_nat: nat -> int -> int = "nth_digit_nat"
-external num_digits_nat: nat -> int -> int -> int = "num_digits_nat"
-external num_leading_zero_bits_in_digit: nat -> int -> int = "num_leading_zero_bits_in_digit"
-external is_digit_int: nat -> int -> bool = "is_digit_int"
-external is_digit_zero: nat -> int -> bool = "is_digit_zero"
-external is_digit_normalized: nat -> int -> bool = "is_digit_normalized"
-external is_digit_odd: nat -> int -> bool = "is_digit_odd"
-external incr_nat: nat -> int -> int -> int -> int = "incr_nat"
-external add_nat: nat -> int -> int -> nat -> int -> int -> int -> int = "add_nat" "add_nat_native"
-external complement_nat: nat -> int -> int -> unit = "complement_nat"
-external decr_nat: nat -> int -> int -> int -> int = "decr_nat"
-external sub_nat: nat -> int -> int -> nat -> int -> int -> int -> int = "sub_nat" "sub_nat_native"
-external mult_digit_nat: nat -> int -> int -> nat -> int -> int -> nat -> int -> int = "mult_digit_nat" "mult_digit_nat_native"
-external mult_nat: nat -> int -> int -> nat -> int -> int -> nat -> int -> int -> int = "mult_nat" "mult_nat_native"
-external square_nat: nat -> int -> int -> nat -> int -> int -> int = "square_nat" "square_nat_native"
-external shift_left_nat: nat -> int -> int -> nat -> int -> int -> unit = "shift_left_nat" "shift_left_nat_native"
-external div_digit_nat: nat -> int -> nat -> int -> nat -> int -> int -> nat -> int -> unit = "div_digit_nat" "div_digit_nat_native"
-external div_nat: nat -> int -> int -> nat -> int -> int -> unit = "div_nat" "div_nat_native"
-external shift_right_nat: nat -> int -> int -> nat -> int -> int -> unit = "shift_right_nat" "shift_right_nat_native"
-external compare_digits_nat: nat -> int -> nat -> int -> int = "compare_digits_nat"
-external compare_nat: nat -> int -> int -> nat -> int -> int -> int = "compare_nat" "compare_nat_native"
-external land_digit_nat: nat -> int -> nat -> int -> unit = "land_digit_nat"
-external lor_digit_nat: nat -> int -> nat -> int -> unit = "lor_digit_nat"
-external lxor_digit_nat: nat -> int -> nat -> int -> unit = "lxor_digit_nat"
-
-external initialize_nat: unit -> unit = "initialize_nat"
-let _ = initialize_nat()
-
-let length_nat (n : nat) = Obj.size (Obj.repr n) - 1
-
-let length_of_digit = Sys.word_size;;
-
-let make_nat len =
- if len < 0 then invalid_arg "make_nat" else
- let res = create_nat len in set_to_zero_nat res 0 len; res
-
-(* Nat temporaries *)
-let a_2 = make_nat 2
-and a_1 = make_nat 1
-and b_2 = make_nat 2
-
-let copy_nat nat off_set length =
- let res = create_nat (length) in
- blit_nat res 0 nat off_set length;
- res
-
-let is_zero_nat n off len =
- compare_nat (make_nat 1) 0 1 n off (num_digits_nat n off len) = 0
-
-let is_nat_int nat off len =
- num_digits_nat nat off len = 1 && is_digit_int nat off
-
-let sys_int_of_nat nat off len =
- if is_nat_int nat off len
- then nth_digit_nat nat off
- else failwith "int_of_nat"
-
-let int_of_nat nat =
- sys_int_of_nat nat 0 (length_nat nat)
-
-let nat_of_int i =
- if i < 0 then invalid_arg "nat_of_int" else
- let res = make_nat 1 in
- if i = 0 then res else begin set_digit_nat res 0 i; res end
-
-let eq_nat nat1 off1 len1 nat2 off2 len2 =
- compare_nat nat1 off1 (num_digits_nat nat1 off1 len1)
- nat2 off2 (num_digits_nat nat2 off2 len2) = 0
-and le_nat nat1 off1 len1 nat2 off2 len2 =
- compare_nat nat1 off1 (num_digits_nat nat1 off1 len1)
- nat2 off2 (num_digits_nat nat2 off2 len2) <= 0
-and lt_nat nat1 off1 len1 nat2 off2 len2 =
- compare_nat nat1 off1 (num_digits_nat nat1 off1 len1)
- nat2 off2 (num_digits_nat nat2 off2 len2) < 0
-and ge_nat nat1 off1 len1 nat2 off2 len2 =
- compare_nat nat1 off1 (num_digits_nat nat1 off1 len1)
- nat2 off2 (num_digits_nat nat2 off2 len2) >= 0
-and gt_nat nat1 off1 len1 nat2 off2 len2 =
- compare_nat nat1 off1 (num_digits_nat nat1 off1 len1)
- nat2 off2 (num_digits_nat nat2 off2 len2) > 0
-
-(* XL: now implemented in C for better performance.
- The code below doesn't handle carries correctly.
- Fortunately, the carry is never used. *)
-(***
-let square_nat nat1 off1 len1 nat2 off2 len2 =
- let c = ref 0
- and trash = make_nat 1 in
- (* Double product *)
- for i = 0 to len2 - 2 do
- c := !c + mult_digit_nat
- nat1
- (succ (off1 + 2 * i))
- (2 * (pred (len2 - i)))
- nat2
- (succ (off2 + i))
- (pred (len2 - i))
- nat2
- (off2 + i)
- done;
- shift_left_nat nat1 0 len1 trash 0 1;
- (* Square of digit *)
- for i = 0 to len2 - 1 do
- c := !c + mult_digit_nat
- nat1
- (off1 + 2 * i)
- (len1 - 2 * i)
- nat2
- (off2 + i)
- 1
- nat2
- (off2 + i)
- done;
- !c
-***)
-
-let gcd_int_nat i nat off len =
- if i = 0 then 1 else
- if is_nat_int nat off len then begin
- set_digit_nat nat off (gcd_int (nth_digit_nat nat off) i); 0
- end else begin
- let len_copy = succ len in
- let copy = create_nat len_copy
- and quotient = create_nat 1
- and remainder = create_nat 1 in
- blit_nat copy 0 nat off len;
- set_digit_nat copy len 0;
- div_digit_nat quotient 0 remainder 0 copy 0 len_copy (nat_of_int i) 0;
- set_digit_nat nat off (gcd_int (nth_digit_nat remainder 0) i);
- 0
- end
-
-let exchange r1 r2 =
- let old1 = !r1 in r1 := !r2; r2 := old1
-
-let gcd_nat nat1 off1 len1 nat2 off2 len2 =
- if is_zero_nat nat1 off1 len1 then begin
- blit_nat nat1 off1 nat2 off2 len2; len2
- end else begin
- let copy1 = ref (create_nat (succ len1))
- and copy2 = ref (create_nat (succ len2)) in
- blit_nat !copy1 0 nat1 off1 len1;
- blit_nat !copy2 0 nat2 off2 len2;
- set_digit_nat !copy1 len1 0;
- set_digit_nat !copy2 len2 0;
- if lt_nat !copy1 0 len1 !copy2 0 len2
- then exchange copy1 copy2;
- let real_len1 =
- ref (num_digits_nat !copy1 0 (length_nat !copy1))
- and real_len2 =
- ref (num_digits_nat !copy2 0 (length_nat !copy2)) in
- while not (is_zero_nat !copy2 0 !real_len2) do
- set_digit_nat !copy1 !real_len1 0;
- div_nat !copy1 0 (succ !real_len1) !copy2 0 !real_len2;
- exchange copy1 copy2;
- real_len1 := !real_len2;
- real_len2 := num_digits_nat !copy2 0 !real_len2
- done;
- blit_nat nat1 off1 !copy1 0 !real_len1;
- !real_len1
- end
-
-(* Racine carrée entière par la méthode de Newton (entière par défaut). *)
-
-(* Théorème: la suite xn+1 = (xn + a/xn) / 2 converge vers la racine *)
-(* carrée entière de a par défaut, si on part d'une valeur x0 *)
-(* strictement plus grande que la racine de a, sauf quand a est un *)
-(* carré - 1, cas auquel la suite alterne entre la racine par défaut *)
-(* et par excès. Dans tous les cas, le dernier terme de la partie *)
-(* strictement décroissante de la suite est le résultat cherché. *)
-
-let sqrt_nat rad off len =
- let len = num_digits_nat rad off len in
- (* Copie de travail du radicande *)
- let len_parity = len mod 2 in
- let rad_len = len + 1 + len_parity in
- let rad =
- let res = create_nat rad_len in
- blit_nat res 0 rad off len;
- set_digit_nat res len 0;
- set_digit_nat res (rad_len - 1) 0;
- res in
- let cand_len = (len + 1) / 2 in (* ceiling len / 2 *)
- let cand_rest = rad_len - cand_len in
- (* Racine carrée supposée cand = "|FFFF .... |" *)
- let cand = make_nat cand_len in
- (* Amélioration de la racine de départ:
- on calcule nbb le nombre de bits significatifs du premier digit du candidat
- (la moitié du nombre de bits significatifs dans les deux premiers
- digits du radicande étendu à une longueur paire).
- shift_cand est word_size - nbb *)
- let shift_cand =
- ((num_leading_zero_bits_in_digit rad (len-1)) +
- Sys.word_size * len_parity) / 2 in
- (* Tous les bits du radicande sont à 0, on rend 0. *)
- if shift_cand = Sys.word_size then cand else
- begin
- complement_nat cand 0 cand_len;
- shift_right_nat cand 0 1 a_1 0 shift_cand;
- let next_cand = create_nat rad_len in
- (* Repeat until *)
- let rec loop () =
- (* next_cand := rad *)
- blit_nat next_cand 0 rad 0 rad_len;
- (* next_cand <- next_cand / cand *)
- div_nat next_cand 0 rad_len cand 0 cand_len;
- (* next_cand (poids fort) <- next_cand (poids fort) + cand,
- i.e. next_cand <- cand + rad / cand *)
- add_nat next_cand cand_len cand_rest cand 0 cand_len 0;
- (* next_cand <- next_cand / 2 *)
- shift_right_nat next_cand cand_len cand_rest a_1 0 1;
- if lt_nat next_cand cand_len cand_rest cand 0 cand_len then
- begin (* cand <- next_cand *)
- blit_nat cand 0 next_cand cand_len cand_len; loop ()
- end
- else cand in
- loop ()
- end;;
-
-let power_base_max = make_nat 2;;
-
-match length_of_digit with
- | 64 ->
- set_digit_nat power_base_max 0 (Int64.to_int 1000000000000000000L);
- mult_digit_nat power_base_max 0 2
- power_base_max 0 1 (nat_of_int 9) 0;
- ()
- | 32 -> set_digit_nat power_base_max 0 1000000000
- | _ -> assert false
-;;
-
-let pmax =
- match length_of_digit with
- | 64 -> 19
- | 32 -> 9
- | _ -> assert false
-;;
-
-let max_superscript_10_power_in_int =
- match length_of_digit with
- | 64 -> 18
- | 32 -> 9
- | _ -> assert false
-;;
-let max_power_10_power_in_int =
- match length_of_digit with
- | 64 -> nat_of_int (Int64.to_int 1000000000000000000L)
- | 32 -> nat_of_int 1000000000
- | _ -> assert false
-;;
-
-let raw_string_of_digit nat off =
- if is_nat_int nat off 1
- then begin string_of_int (nth_digit_nat nat off) end
- else begin
- blit_nat b_2 0 nat off 1;
- div_digit_nat a_2 0 a_1 0 b_2 0 2 max_power_10_power_in_int 0;
- let leading_digits = nth_digit_nat a_2 0
- and s1 = string_of_int (nth_digit_nat a_1 0) in
- let len = String.length s1 in
- if leading_digits < 10 then begin
- let result = String.make (max_superscript_10_power_in_int+1) '0' in
- String.set result 0
- (Char.chr (48 + leading_digits));
- String.blit s1 0
- result (String.length result - len) len;
- result
- end else begin
- let result = String.make (max_superscript_10_power_in_int+2) '0' in
- String.blit (string_of_int leading_digits) 0 result 0 2;
- String.blit s1 0
- result (String.length result - len) len;
- result
- end
- end
-
-(* XL: suppression de string_of_digit et de sys_string_of_digit.
- La copie est de toute facon faite dans string_of_nat, qui est le
- seul point d entree public dans ce code. *)
-
-(******
-let sys_string_of_digit nat off =
- let s = raw_string_of_digit nat off in
- let result = String.create (String.length s) in
- String.blit s 0 result 0 (String.length s);
- s
-
-let string_of_digit nat =
- sys_string_of_digit nat 0
-
-*******)
-
-let digits = "0123456789ABCDEF"
-
-(*
- make_power_base affecte power_base des puissances successives de base a
- partir de la puissance 1-ieme.
- A la fin de la boucle i-1 est la plus grande puissance de la base qui tient
- sur un seul digit et j est la plus grande puissance de la base qui tient
- sur un int.
-*)
-let make_power_base base power_base =
- let i = ref 0
- and j = ref 0 in
- set_digit_nat power_base 0 base;
- while incr i; is_digit_zero power_base !i do
- mult_digit_nat power_base !i 2
- power_base (pred !i) 1
- power_base 0
- done;
- while !j <= !i && is_digit_int power_base !j do incr j done;
- (!i - 2, !j)
-
-(*
- int_to_string place la representation de l entier int en base base
- dans la chaine s en le rangeant de la fin indiquee par pos vers le
- debut, sur times places et affecte a pos sa nouvelle valeur.
-*)
-let int_to_string int s pos_ref base times =
- let i = ref int
- and j = ref times in
- while ((!i != 0) || (!j != 0)) && (!pos_ref != -1) do
- String.set s !pos_ref (String.get digits (!i mod base));
- decr pos_ref;
- decr j;
- i := !i / base
- done
-
-(* XL: suppression de adjust_string *)
-
-let power_base_int base i =
- if i = 0 then
- nat_of_int 1
- else if i < 0 then
- invalid_arg "power_base_int"
- else begin
- let power_base = make_nat (succ length_of_digit) in
- let (pmax, pint) = make_power_base base power_base in
- let n = i / (succ pmax)
- and rem = i mod (succ pmax) in
- if n > 0 then begin
- let newn =
- if i = biggest_int then n else (succ n) in
- let res = make_nat newn
- and res2 = make_nat newn
- and l = num_bits_int n - 2 in
- let p = ref (1 lsl l) in
- blit_nat res 0 power_base pmax 1;
- for i = l downto 0 do
- let len = num_digits_nat res 0 newn in
- let len2 = min n (2 * len) in
- let succ_len2 = succ len2 in
- square_nat res2 0 len2 res 0 len;
- if n land !p > 0 then begin
- set_to_zero_nat res 0 len;
- mult_digit_nat res 0 succ_len2
- res2 0 len2
- power_base pmax;
- ()
- end else
- blit_nat res 0 res2 0 len2;
- set_to_zero_nat res2 0 len2;
- p := !p lsr 1
- done;
- if rem > 0 then begin
- mult_digit_nat res2 0 newn
- res 0 n power_base (pred rem);
- res2
- end else res
- end else
- copy_nat power_base (pred rem) 1
- end
-
-(* the ith element (i >= 2) of num_digits_max_vector is :
- | |
- | biggest_string_length * log (i) |
- | ------------------------------- | + 1
- | length_of_digit * log (2) |
- -- --
-*)
-
-(* XL: ai specialise le code d origine a length_of_digit = 32. *)
-(* Puis suppression (inutile?) *)
-
-(******
-let num_digits_max_vector =
- [|0; 0; 1024; 1623; 2048; 2378; 2647; 2875; 3072; 3246; 3402;
- 3543; 3671; 3789; 3899; 4001; 4096|]
-
-let num_digits_max_vector =
- match length_of_digit with
- 16 -> [|0; 0; 2048; 3246; 4096; 4755; 5294; 5749; 6144; 6492; 6803;
- 7085; 7342; 7578; 7797; 8001; 8192|]
-(* If really exotic machines !!!!
- | 17 -> [|0; 0; 1928; 3055; 3855; 4476; 4983; 5411; 5783; 6110; 6403;
- 6668; 6910; 7133; 7339; 7530; 7710|]
- | 18 -> [|0; 0; 1821; 2886; 3641; 4227; 4706; 5111; 5461; 5771; 6047;
- 6298; 6526; 6736; 6931; 7112; 7282|]
- | 19 -> [|0; 0; 1725; 2734; 3449; 4005; 4458; 4842; 5174; 5467; 5729;
- 5966; 6183; 6382; 6566; 6738; 6898|]
- | 20 -> [|0; 0; 1639; 2597; 3277; 3804; 4235; 4600; 4915; 5194; 5443;
- 5668; 5874; 6063; 6238; 6401; 6553|]
- | 21 -> [|0; 0; 1561; 2473; 3121; 3623; 4034; 4381; 4681; 4946; 5183;
- 5398; 5594; 5774; 5941; 6096; 6241|]
- | 22 -> [|0; 0; 1490; 2361; 2979; 3459; 3850; 4182; 4468; 4722; 4948;
- 5153; 5340; 5512; 5671; 5819; 5958|]
- | 23 -> [|0; 0; 1425; 2258; 2850; 3308; 3683; 4000; 4274; 4516; 4733;
- 4929; 5108; 5272; 5424; 5566; 5699|]
- | 24 -> [|0; 0; 1366; 2164; 2731; 3170; 3530; 3833; 4096; 4328; 4536;
- 4723; 4895; 5052; 5198; 5334; 5461|]
- | 25 -> [|0; 0; 1311; 2078; 2622; 3044; 3388; 3680; 3932; 4155; 4354;
- 4534; 4699; 4850; 4990; 5121; 5243|]
- | 26 -> [|0; 0; 1261; 1998; 2521; 2927; 3258; 3538; 3781; 3995; 4187;
- 4360; 4518; 4664; 4798; 4924; 5041|]
- | 27 -> [|0; 0; 1214; 1924; 2428; 2818; 3137; 3407; 3641; 3847; 4032;
- 4199; 4351; 4491; 4621; 4742; 4855|]
- | 28 -> [|0; 0; 1171; 1855; 2341; 2718; 3025; 3286; 3511; 3710; 3888;
- 4049; 4196; 4331; 4456; 4572; 4681|]
- | 29 -> [|0; 0; 1130; 1791; 2260; 2624; 2921; 3172; 3390; 3582; 3754;
- 3909; 4051; 4181; 4302; 4415; 4520|]
- | 30 -> [|0; 0; 1093; 1732; 2185; 2536; 2824; 3067; 3277; 3463; 3629;
- 3779; 3916; 4042; 4159; 4267; 4369|]
- | 31 -> [|0; 0; 1057; 1676; 2114; 2455; 2733; 2968; 3171; 3351; 3512;
- 3657; 3790; 3912; 4025; 4130; 4228|]
-*)
- | 32 -> [|0; 0; 1024; 1623; 2048; 2378; 2647; 2875; 3072; 3246; 3402;
- 3543; 3671; 3789; 3899; 4001; 4096|]
- | n -> failwith "num_digits_max_vector"
-******)
-
-(* XL: suppression de string_list_of_nat *)
-
-let unadjusted_string_of_nat nat off len_nat =
- let len = num_digits_nat nat off len_nat in
- if len = 1 then
- raw_string_of_digit nat off
- else
- let len_copy = ref (succ len) in
- let copy1 = create_nat !len_copy
- and copy2 = make_nat !len_copy
- and rest_digit = make_nat 2 in
- if len > biggest_int / (succ pmax)
- then failwith "number too long"
- else let len_s = (succ pmax) * len in
- let s = String.make len_s '0'
- and pos_ref = ref len_s in
- len_copy := pred !len_copy;
- blit_nat copy1 0 nat off len;
- set_digit_nat copy1 len 0;
- while not (is_zero_nat copy1 0 !len_copy) do
- div_digit_nat copy2 0
- rest_digit 0
- copy1 0 (succ !len_copy)
- power_base_max 0;
- let str = raw_string_of_digit rest_digit 0 in
- String.blit str 0
- s (!pos_ref - String.length str)
- (String.length str);
- (* XL: il y avait pmax a la place de String.length str
- mais ca ne marche pas avec le blit de Caml Light,
- qui ne verifie pas les debordements *)
- pos_ref := !pos_ref - pmax;
- len_copy := num_digits_nat copy2 0 !len_copy;
- blit_nat copy1 0 copy2 0 !len_copy;
- set_digit_nat copy1 !len_copy 0
- done;
- s
-
-let string_of_nat nat =
- let s = unadjusted_string_of_nat nat 0 (length_nat nat)
- and index = ref 0 in
- begin try
- for i = 0 to String.length s - 2 do
- if String.get s i <> '0' then (index:= i; raise Exit)
- done
- with Exit -> ()
- end;
- String.sub s !index (String.length s - !index)
-
-(* XL: suppression de sys_string_of_nat *)
-
-(* XL: suppression de debug_string_nat *)
-
-let base_digit_of_char c base =
- let n = Char.code c in
- if n >= 48 && n <= 47 + min base 10 then n - 48
- else if n >= 65 && n <= 65 + base - 11 then n - 55
- else failwith "invalid digit"
-
-(*
- La sous-chaine (s, off, len) represente un nat en base base que
- on determine ici
-*)
-let sys_nat_of_string base s off len =
- let power_base = make_nat (succ length_of_digit) in
- let (pmax, pint) = make_power_base base power_base in
- let new_len = ref (1 + len / (pmax + 1))
- and current_len = ref 1 in
- let possible_len = ref (min 2 !new_len) in
-
- let nat1 = make_nat !new_len
- and nat2 = make_nat !new_len
-
- and digits_read = ref 0
- and bound = off + len - 1
- and int = ref 0 in
-
- for i = off to bound do
- (*
- on lit pint (au maximum) chiffres, on en fait un int
- et on l integre au nombre
- *)
- let c = String.get s i in
- begin match c with
- ' ' | '\t' | '\n' | '\r' | '\\' -> ()
- | _ -> int := !int * base + base_digit_of_char c base;
- incr digits_read
- end;
- if (!digits_read = pint || i = bound) && not (!digits_read = 0) then
- begin
- set_digit_nat nat1 0 !int;
- let erase_len = if !new_len = !current_len then !current_len - 1
- else !current_len in
- for j = 1 to erase_len do
- set_digit_nat nat1 j 0
- done;
- mult_digit_nat nat1 0 !possible_len
- nat2 0 !current_len
- power_base (pred !digits_read);
- blit_nat nat2 0 nat1 0 !possible_len;
- current_len := num_digits_nat nat1 0 !possible_len;
- possible_len := min !new_len (succ !current_len);
- int := 0;
- digits_read := 0
- end
- done;
- (*
- On recadre le nat
- *)
- let nat = create_nat !current_len in
- blit_nat nat 0 nat1 0 !current_len;
- nat
-
-let nat_of_string s = sys_nat_of_string 10 s 0 (String.length s)
-
-let float_of_nat nat = float_of_string(string_of_nat nat)
-
diff --git a/otherlibs/num/nat.mli b/otherlibs/num/nat.mli
deleted file mode 100644
index 18cd812011..0000000000
--- a/otherlibs/num/nat.mli
+++ /dev/null
@@ -1,71 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Module [Nat]: operations on natural numbers *)
-
-type nat
-
-(* Natural numbers (type [nat]) are positive integers of arbitrary size.
- All operations on [nat] are performed in-place. *)
-
-external create_nat: int -> nat = "create_nat"
-val make_nat: int -> nat
-external set_to_zero_nat: nat -> int -> int -> unit = "set_to_zero_nat"
-external blit_nat: nat -> int -> nat -> int -> int -> unit = "blit_nat"
-val copy_nat: nat -> int -> int -> nat
-external set_digit_nat: nat -> int -> int -> unit = "set_digit_nat"
-external nth_digit_nat: nat -> int -> int = "nth_digit_nat"
-val length_nat : nat -> int
-external num_digits_nat: nat -> int -> int -> int = "num_digits_nat"
-external num_leading_zero_bits_in_digit: nat -> int -> int = "num_leading_zero_bits_in_digit"
-external is_digit_int: nat -> int -> bool = "is_digit_int"
-external is_digit_zero: nat -> int -> bool = "is_digit_zero"
-external is_digit_normalized: nat -> int -> bool = "is_digit_normalized"
-external is_digit_odd: nat -> int -> bool = "is_digit_odd"
-val is_zero_nat: nat -> int -> int -> bool
-val is_nat_int: nat -> int -> int -> bool
-val int_of_nat: nat -> int
-val nat_of_int: int -> nat
-external incr_nat: nat -> int -> int -> int -> int = "incr_nat"
-external add_nat: nat -> int -> int -> nat -> int -> int -> int -> int = "add_nat" "add_nat_native"
-external complement_nat: nat -> int -> int -> unit = "complement_nat"
-external decr_nat: nat -> int -> int -> int -> int = "decr_nat"
-external sub_nat: nat -> int -> int -> nat -> int -> int -> int -> int = "sub_nat" "sub_nat_native"
-external mult_digit_nat: nat -> int -> int -> nat -> int -> int -> nat -> int -> int = "mult_digit_nat" "mult_digit_nat_native"
-external mult_nat: nat -> int -> int -> nat -> int -> int -> nat -> int -> int -> int = "mult_nat" "mult_nat_native"
-external square_nat: nat -> int -> int -> nat -> int -> int -> int = "square_nat" "square_nat_native"
-external shift_left_nat: nat -> int -> int -> nat -> int -> int -> unit = "shift_left_nat" "shift_left_nat_native"
-external div_digit_nat: nat -> int -> nat -> int -> nat -> int -> int -> nat -> int -> unit = "div_digit_nat" "div_digit_nat_native"
-external div_nat: nat -> int -> int -> nat -> int -> int -> unit = "div_nat" "div_nat_native"
-external shift_right_nat: nat -> int -> int -> nat -> int -> int -> unit = "shift_right_nat" "shift_right_nat_native"
-external compare_digits_nat: nat -> int -> nat -> int -> int = "compare_digits_nat"
-external compare_nat: nat -> int -> int -> nat -> int -> int -> int = "compare_nat" "compare_nat_native"
-val eq_nat : nat -> int -> int -> nat -> int -> int -> bool
-val le_nat : nat -> int -> int -> nat -> int -> int -> bool
-val lt_nat : nat -> int -> int -> nat -> int -> int -> bool
-val ge_nat : nat -> int -> int -> nat -> int -> int -> bool
-val gt_nat : nat -> int -> int -> nat -> int -> int -> bool
-external land_digit_nat: nat -> int -> nat -> int -> unit = "land_digit_nat"
-external lor_digit_nat: nat -> int -> nat -> int -> unit = "lor_digit_nat"
-external lxor_digit_nat: nat -> int -> nat -> int -> unit = "lxor_digit_nat"
-val gcd_nat : nat -> int -> int -> nat -> int -> int -> int
-val sqrt_nat : nat -> int -> int -> nat
-val string_of_nat : nat -> string
-val nat_of_string : string -> nat
-val sys_nat_of_string : int -> string -> int -> int -> nat
-val float_of_nat : nat -> float
-val make_power_base : int -> nat -> int * int
-val power_base_int : int -> int -> nat
-val length_of_digit: int
diff --git a/otherlibs/num/nat_stubs.c b/otherlibs/num/nat_stubs.c
deleted file mode 100644
index a7fb7dcfe0..0000000000
--- a/otherlibs/num/nat_stubs.c
+++ /dev/null
@@ -1,369 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include "alloc.h"
-#include "custom.h"
-#include "intext.h"
-#include "fail.h"
-#include "memory.h"
-#include "mlvalues.h"
-
-#include "bng.h"
-#include "nat.h"
-
-/* Stub code for the Nat module. */
-
-static void serialize_nat(value, unsigned long *, unsigned long *);
-static unsigned long deserialize_nat(void * dst);
-
-static struct custom_operations nat_operations = {
- "_nat",
- custom_finalize_default,
- custom_compare_default,
- custom_hash_default,
- serialize_nat,
- deserialize_nat
-};
-
-CAMLprim value initialize_nat(value unit)
-{
- bng_init();
- register_custom_operations(&nat_operations);
- return Val_unit;
-}
-
-CAMLprim value create_nat(value size)
-{
- mlsize_t sz = Long_val(size);
-
- return alloc_custom(&nat_operations, sz * sizeof(value), 0, 1);
-}
-
-CAMLprim value length_nat(value nat)
-{
- return Val_long(Wosize_val(nat) - 1);
-}
-
-CAMLprim value set_to_zero_nat(value nat, value ofs, value len)
-{
- bng_zero(&Digit_val(nat, Long_val(ofs)), Long_val(len));
- return Val_unit;
-}
-
-CAMLprim value blit_nat(value nat1, value ofs1,
- value nat2, value ofs2,
- value len)
-{
- bng_assign(&Digit_val(nat1, Long_val(ofs1)),
- &Digit_val(nat2, Long_val(ofs2)),
- Long_val(len));
- return Val_unit;
-}
-
-CAMLprim value set_digit_nat(value nat, value ofs, value digit)
-{
- Digit_val(nat, Long_val(ofs)) = Long_val(digit);
- return Val_unit;
-}
-
-CAMLprim value nth_digit_nat(value nat, value ofs)
-{
- return Val_long(Digit_val(nat, Long_val(ofs)));
-}
-
-CAMLprim value num_digits_nat(value nat, value ofs, value len)
-{
- return Val_long(bng_num_digits(&Digit_val(nat, Long_val(ofs)),
- Long_val(len)));
-}
-
-CAMLprim value num_leading_zero_bits_in_digit(value nat, value ofs)
-{
- return
- Val_long(bng_leading_zero_bits(Digit_val(nat, Long_val(ofs))));
-}
-
-CAMLprim value is_digit_int(value nat, value ofs)
-{
- return Val_bool(Digit_val(nat, Long_val(ofs)) <= Max_long);
-}
-
-CAMLprim value is_digit_zero(value nat, value ofs)
-{
- return Val_bool(Digit_val(nat, Long_val(ofs)) == 0);
-}
-
-CAMLprim value is_digit_normalized(value nat, value ofs)
-{
- return
- Val_bool(Digit_val(nat, Long_val(ofs)) & (1L << (BNG_BITS_PER_DIGIT-1)));
-}
-
-CAMLprim value is_digit_odd(value nat, value ofs)
-{
- return Val_bool(Digit_val(nat, Long_val(ofs)) & 1);
-}
-
-CAMLprim value incr_nat(value nat, value ofs, value len, value carry_in)
-{
- return Val_long(bng_add_carry(&Digit_val(nat, Long_val(ofs)),
- Long_val(len), Long_val(carry_in)));
-}
-
-value add_nat_native(value nat1, value ofs1, value len1,
- value nat2, value ofs2, value len2, value carry_in)
-{
- return Val_long(bng_add(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
- &Digit_val(nat2, Long_val(ofs2)), Long_val(len2),
- Long_val(carry_in)));
-}
-
-CAMLprim value add_nat(value *argv, int argn)
-{
- return add_nat_native(argv[0], argv[1], argv[2], argv[3],
- argv[4], argv[5], argv[6]);
-}
-
-CAMLprim value complement_nat(value nat, value ofs, value len)
-{
- bng_complement(&Digit_val(nat, Long_val(ofs)), Long_val(len));
- return Val_unit;
-}
-
-CAMLprim value decr_nat(value nat, value ofs, value len, value carry_in)
-{
- return Val_long(1 ^ bng_sub_carry(&Digit_val(nat, Long_val(ofs)),
- Long_val(len), 1 ^ Long_val(carry_in)));
-}
-
-value sub_nat_native(value nat1, value ofs1, value len1,
- value nat2, value ofs2, value len2, value carry_in)
-{
- return Val_long(1 ^ bng_sub(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
- &Digit_val(nat2, Long_val(ofs2)), Long_val(len2),
- 1 ^ Long_val(carry_in)));
-}
-
-CAMLprim value sub_nat(value *argv, int argn)
-{
- return sub_nat_native(argv[0], argv[1], argv[2], argv[3],
- argv[4], argv[5], argv[6]);
-}
-
-value mult_digit_nat_native(value nat1, value ofs1, value len1,
- value nat2, value ofs2, value len2,
- value nat3, value ofs3)
-{
- return
- Val_long(bng_mult_add_digit(
- &Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
- &Digit_val(nat2, Long_val(ofs2)), Long_val(len2),
- Digit_val(nat3, Long_val(ofs3))));
-}
-
-CAMLprim value mult_digit_nat(value *argv, int argn)
-{
- return mult_digit_nat_native(argv[0], argv[1], argv[2], argv[3],
- argv[4], argv[5], argv[6], argv[7]);
-}
-
-value mult_nat_native(value nat1, value ofs1, value len1,
- value nat2, value ofs2, value len2,
- value nat3, value ofs3, value len3)
-{
- return
- Val_long(bng_mult_add(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
- &Digit_val(nat2, Long_val(ofs2)), Long_val(len2),
- &Digit_val(nat3, Long_val(ofs3)), Long_val(len3)));
-}
-
-CAMLprim value mult_nat(value *argv, int argn)
-{
- return mult_nat_native(argv[0], argv[1], argv[2], argv[3],
- argv[4], argv[5], argv[6], argv[7], argv[8]);
-}
-
-value square_nat_native(value nat1, value ofs1, value len1,
- value nat2, value ofs2, value len2)
-{
- return
- Val_long(bng_square_add(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
- &Digit_val(nat2, Long_val(ofs2)), Long_val(len2)));
-}
-
-CAMLprim value square_nat(value *argv, int argn)
-{
- return square_nat_native(argv[0], argv[1], argv[2],
- argv[3], argv[4], argv[5]);
-}
-
-value shift_left_nat_native(value nat1, value ofs1, value len1,
- value nat2, value ofs2, value nbits)
-{
- Digit_val(nat2, Long_val(ofs2)) =
- bng_shift_left(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
- Long_val(nbits));
- return Val_unit;
-}
-
-CAMLprim value shift_left_nat(value *argv, int argn)
-{
- return shift_left_nat_native(argv[0], argv[1], argv[2],
- argv[3], argv[4], argv[5]);
-}
-
-value div_digit_nat_native(value natq, value ofsq,
- value natr, value ofsr,
- value nat1, value ofs1, value len1,
- value nat2, value ofs2)
-{
- Digit_val(natr, Long_val(ofsr)) =
- bng_div_rem_digit(&Digit_val(natq, Long_val(ofsq)),
- &Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
- Digit_val(nat2, Long_val(ofs2)));
- return Val_unit;
-}
-
-CAMLprim value div_digit_nat(value *argv, int argn)
-{
- return div_digit_nat_native(argv[0], argv[1], argv[2], argv[3],
- argv[4], argv[5], argv[6], argv[7], argv[8]);
-}
-
-value div_nat_native(value nat1, value ofs1, value len1,
- value nat2, value ofs2, value len2)
-{
- bng_div_rem(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
- &Digit_val(nat2, Long_val(ofs2)), Long_val(len2));
- return Val_unit;
-}
-
-CAMLprim value div_nat(value *argv, int argn)
-{
- return div_nat_native(argv[0], argv[1], argv[2],
- argv[3], argv[4], argv[5]);
-}
-
-value shift_right_nat_native(value nat1, value ofs1, value len1,
- value nat2, value ofs2, value nbits)
-{
- Digit_val(nat2, Long_val(ofs2)) =
- bng_shift_right(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
- Long_val(nbits));
- return Val_unit;
-}
-
-CAMLprim value shift_right_nat(value *argv, int argn)
-{
- return shift_right_nat_native(argv[0], argv[1], argv[2],
- argv[3], argv[4], argv[5]);
-}
-
-CAMLprim value compare_digits_nat(value nat1, value ofs1,
- value nat2, value ofs2)
-{
- bngdigit d1 = Digit_val(nat1, Long_val(ofs1));
- bngdigit d2 = Digit_val(nat2, Long_val(ofs2));
- if (d1 > d2) return Val_int(1);
- if (d1 < d2) return Val_int(-1);
- return Val_int(0);
-}
-
-value compare_nat_native(value nat1, value ofs1, value len1,
- value nat2, value ofs2, value len2)
-{
- return
- Val_int(bng_compare(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
- &Digit_val(nat2, Long_val(ofs2)), Long_val(len2)));
-}
-
-CAMLprim value compare_nat(value *argv, int argn)
-{
- return compare_nat_native(argv[0], argv[1], argv[2],
- argv[3], argv[4], argv[5]);
-}
-
-CAMLprim value land_digit_nat(value nat1, value ofs1, value nat2, value ofs2)
-{
- Digit_val(nat1, Long_val(ofs1)) &= Digit_val(nat2, Long_val(ofs2));
- return Val_unit;
-}
-
-CAMLprim value lor_digit_nat(value nat1, value ofs1, value nat2, value ofs2)
-{
- Digit_val(nat1, Long_val(ofs1)) |= Digit_val(nat2, Long_val(ofs2));
- return Val_unit;
-}
-
-CAMLprim value lxor_digit_nat(value nat1, value ofs1, value nat2, value ofs2)
-{
- Digit_val(nat1, Long_val(ofs1)) ^= Digit_val(nat2, Long_val(ofs2));
- return Val_unit;
-}
-
-/* The wire format for a nat is:
- - 32-bit word: number of 32-bit words in nat
- - N 32-bit words (big-endian format)
- For little-endian platforms, the memory layout between 32-bit and 64-bit
- machines is identical, so we can write the nat using serialize_block_4.
- For big-endian 64-bit platforms, we need to swap the two 32-bit halves
- of 64-bit words to obtain the correct behavior. */
-
-static void serialize_nat(value nat,
- unsigned long * wsize_32,
- unsigned long * wsize_64)
-{
- mlsize_t len = Wosize_val(nat) - 1;
-
-#ifdef ARCH_SIXTYFOUR
- len = len * 2; /* two 32-bit words per 64-bit digit */
- if (len >= (1L << 32))
- failwith("output_value: nat too big");
-#endif
- serialize_int_4((int32) len);
-#if defined(ARCH_SIXTYFOUR) && defined(ARCH_BIG_ENDIAN)
- { int32 * p;
- mlsize_t i;
- for (i = len, p = Data_custom_val(nat); i > 0; i -= 2, p += 2) {
- serialize_int_4(p[1]); /* low 32 bits of 64-bit digit */
- serialize_int_4(p[0]); /* high 32 bits of 64-bit digit */
- }
- }
-#else
- serialize_block_4(Data_custom_val(nat), len);
-#endif
- *wsize_32 = len * 4;
- *wsize_64 = len * 4;
-}
-
-static unsigned long deserialize_nat(void * dst)
-{
- mlsize_t len;
-
- len = deserialize_uint_4();
-#if defined(ARCH_SIXTYFOUR) && defined(ARCH_BIG_ENDIAN)
- { uint32 * p;
- mlsize_t i;
- for (i = len, p = dst; i > 0; i -= 2, p += 2) {
- p[1] = deserialize_uint_4(); /* low 32 bits of 64-bit digit */
- p[0] = deserialize_uint_4(); /* high 32 bits of 64-bit digit */
- }
- }
-#else
- deserialize_block_4(dst, len);
-#endif
- return len * 4;
-}
-
diff --git a/otherlibs/num/num.ml b/otherlibs/num/num.ml
deleted file mode 100644
index 3d53aefdf8..0000000000
--- a/otherlibs/num/num.ml
+++ /dev/null
@@ -1,396 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Int_misc
-open Nat
-open Big_int
-open Arith_flags
-open Ratio
-
-type num = Int of int | Big_int of big_int | Ratio of ratio
- (* The type of numbers. *)
-
-let biggest_INT = big_int_of_int biggest_int
-and least_INT = big_int_of_int least_int
-
-(* Coercion big_int -> num *)
-let num_of_big_int bi =
- if le_big_int bi biggest_INT && ge_big_int bi least_INT
- then Int (int_of_big_int bi)
- else Big_int bi
-
-let numerator_num = function
- Ratio r -> normalize_ratio r; num_of_big_int (numerator_ratio r)
-| n -> n
-
-let denominator_num = function
- Ratio r -> normalize_ratio r; num_of_big_int (denominator_ratio r)
-| n -> Int 1
-
-let normalize_num = function
- Int i -> Int i
-| Big_int bi -> num_of_big_int bi
-| Ratio r -> if is_integer_ratio r
- then num_of_big_int (numerator_ratio r)
- else Ratio r
-
-let cautious_normalize_num_when_printing n =
- if (!normalize_ratio_when_printing_flag) then (normalize_num n) else n
-
-let num_of_ratio r =
- normalize_ratio r;
- if not (is_integer_ratio r) then Ratio r
- else if is_int_big_int (numerator_ratio r) then
- Int (int_of_big_int (numerator_ratio r))
- else Big_int (numerator_ratio r)
-
-(* Operations on num *)
-
-let add_num a b = match (a,b) with
- ((Int int1), (Int int2)) ->
- let r = int1 + int2 in
- if (int1 lxor int2) lor (int1 lxor (r lxor (-1))) < 0
- then Int r (* No overflow *)
- else Big_int(add_big_int (big_int_of_int int1) (big_int_of_int int2))
- | ((Int i), (Big_int bi)) ->
- num_of_big_int (add_int_big_int i bi)
- | ((Big_int bi), (Int i)) ->
- num_of_big_int (add_int_big_int i bi)
-
- | ((Int i), (Ratio r)) ->
- Ratio (add_int_ratio i r)
- | ((Ratio r), (Int i)) ->
- Ratio (add_int_ratio i r)
-
- | ((Big_int bi1), (Big_int bi2)) -> num_of_big_int (add_big_int bi1 bi2)
-
- | ((Big_int bi), (Ratio r)) ->
- Ratio (add_big_int_ratio bi r)
- | ((Ratio r), (Big_int bi)) ->
- Ratio (add_big_int_ratio bi r)
-
- | ((Ratio r1), (Ratio r2)) -> num_of_ratio (add_ratio r1 r2)
-
-let ( +/ ) = add_num
-
-let minus_num = function
- Int i -> if i = monster_int
- then Big_int (minus_big_int (big_int_of_int i))
- else Int (-i)
-| Big_int bi -> Big_int (minus_big_int bi)
-| Ratio r -> Ratio (minus_ratio r)
-
-let sub_num n1 n2 = add_num n1 (minus_num n2)
-
-let ( -/ ) = sub_num
-
-let mult_num a b = match (a,b) with
- ((Int int1), (Int int2)) ->
- if num_bits_int int1 + num_bits_int int2 < length_of_int
- then Int (int1 * int2)
- else num_of_big_int (mult_big_int (big_int_of_int int1)
- (big_int_of_int int2))
-
- | ((Int i), (Big_int bi)) ->
- num_of_big_int (mult_int_big_int i bi)
- | ((Big_int bi), (Int i)) ->
- num_of_big_int (mult_int_big_int i bi)
-
- | ((Int i), (Ratio r)) ->
- num_of_ratio (mult_int_ratio i r)
- | ((Ratio r), (Int i)) ->
- num_of_ratio (mult_int_ratio i r)
-
- | ((Big_int bi1), (Big_int bi2)) ->
- num_of_big_int (mult_big_int bi1 bi2)
-
- | ((Big_int bi), (Ratio r)) ->
- num_of_ratio (mult_big_int_ratio bi r)
- | ((Ratio r), (Big_int bi)) ->
- num_of_ratio (mult_big_int_ratio bi r)
-
- | ((Ratio r1), (Ratio r2)) ->
- num_of_ratio (mult_ratio r1 r2)
-
-let ( */ ) = mult_num
-
-let square_num = function
- Int i -> if 2 * num_bits_int i < length_of_int
- then Int (i * i)
- else num_of_big_int (square_big_int (big_int_of_int i))
- | Big_int bi -> Big_int (square_big_int bi)
- | Ratio r -> Ratio (square_ratio r)
-
-let div_num n1 n2 =
- match n1 with
- | Int i1 ->
- begin match n2 with
- | Int i2 ->
- num_of_ratio (create_ratio (big_int_of_int i1) (big_int_of_int i2))
- | Big_int bi2 -> num_of_ratio (create_ratio (big_int_of_int i1) bi2)
- | Ratio r2 -> num_of_ratio (div_int_ratio i1 r2) end
-
- | Big_int bi1 ->
- begin match n2 with
- | Int i2 -> num_of_ratio (create_ratio bi1 (big_int_of_int i2))
- | Big_int bi2 -> num_of_ratio (create_ratio bi1 bi2)
- | Ratio r2 -> num_of_ratio (div_big_int_ratio bi1 r2) end
-
- | Ratio r1 ->
- begin match n2 with
- | Int i2 -> num_of_ratio (div_ratio_int r1 i2)
- | Big_int bi2 -> num_of_ratio (div_ratio_big_int r1 bi2)
- | Ratio r2 -> num_of_ratio (div_ratio r1 r2) end
-;;
-
-let ( // ) = div_num
-
-let floor_num = function
- Int i as n -> n
-| Big_int bi as n -> n
-| Ratio r -> num_of_big_int (floor_ratio r)
-
-let quo_num x y = floor_num (div_num x y)
-
-let mod_num x y = sub_num x (mult_num y (quo_num x y))
-
-let power_num_int a b = match (a,b) with
- ((Int i), n) ->
- (match sign_int n with
- 0 -> Int 1
- | 1 -> num_of_big_int (power_int_positive_int i n)
- | _ -> Ratio (create_normalized_ratio
- unit_big_int (power_int_positive_int i (-n))))
-| ((Big_int bi), n) ->
- (match sign_int n with
- 0 -> Int 1
- | 1 -> num_of_big_int (power_big_int_positive_int bi n)
- | _ -> Ratio (create_normalized_ratio
- unit_big_int (power_big_int_positive_int bi (-n))))
-| ((Ratio r), n) ->
- (match sign_int n with
- 0 -> Int 1
- | 1 -> Ratio (power_ratio_positive_int r n)
- | _ -> Ratio (power_ratio_positive_int
- (inverse_ratio r) (-n)))
-
-let power_num_big_int a b = match (a,b) with
- ((Int i), n) ->
- (match sign_big_int n with
- 0 -> Int 1
- | 1 -> num_of_big_int (power_int_positive_big_int i n)
- | _ -> Ratio (create_normalized_ratio
- unit_big_int
- (power_int_positive_big_int i (minus_big_int n))))
-| ((Big_int bi), n) ->
- (match sign_big_int n with
- 0 -> Int 1
- | 1 -> num_of_big_int (power_big_int_positive_big_int bi n)
- | _ -> Ratio (create_normalized_ratio
- unit_big_int
- (power_big_int_positive_big_int bi (minus_big_int n))))
-| ((Ratio r), n) ->
- (match sign_big_int n with
- 0 -> Int 1
- | 1 -> Ratio (power_ratio_positive_big_int r n)
- | _ -> Ratio (power_ratio_positive_big_int
- (inverse_ratio r) (minus_big_int n)))
-
-let power_num a b = match (a,b) with
- (n, (Int i)) -> power_num_int n i
-| (n, (Big_int bi)) -> power_num_big_int n bi
-| _ -> invalid_arg "power_num"
-
-let ( **/ ) = power_num
-
-let is_integer_num = function
- Int _ -> true
-| Big_int _ -> true
-| Ratio r -> is_integer_ratio r
-
-(* integer_num, floor_num, round_num, ceiling_num rendent des nums *)
-let integer_num = function
- Int i as n -> n
-| Big_int bi as n -> n
-| Ratio r -> num_of_big_int (integer_ratio r)
-
-and round_num = function
- Int i as n -> n
-| Big_int bi as n -> n
-| Ratio r -> num_of_big_int (round_ratio r)
-
-and ceiling_num = function
- Int i as n -> n
-| Big_int bi as n -> n
-| Ratio r -> num_of_big_int (ceiling_ratio r)
-
-(* Comparisons on nums *)
-
-let sign_num = function
- Int i -> sign_int i
-| Big_int bi -> sign_big_int bi
-| Ratio r -> sign_ratio r
-
-let eq_num a b = match (a,b) with
- ((Int int1), (Int int2)) -> int1 = int2
-
-| ((Int i), (Big_int bi)) -> eq_big_int (big_int_of_int i) bi
-| ((Big_int bi), (Int i)) -> eq_big_int (big_int_of_int i) bi
-
-| ((Int i), (Ratio r)) -> eq_big_int_ratio (big_int_of_int i) r
-| ((Ratio r), (Int i)) -> eq_big_int_ratio (big_int_of_int i) r
-
-| ((Big_int bi1), (Big_int bi2)) -> eq_big_int bi1 bi2
-
-| ((Big_int bi), (Ratio r)) -> eq_big_int_ratio bi r
-| ((Ratio r), (Big_int bi)) -> eq_big_int_ratio bi r
-
-| ((Ratio r1), (Ratio r2)) -> eq_ratio r1 r2
-
-let ( =/ ) = eq_num
-
-let ( <>/ ) a b = not(eq_num a b)
-
-let compare_num a b = match (a,b) with
- ((Int int1), (Int int2)) -> compare_int int1 int2
-
-| ((Int i), (Big_int bi)) -> compare_big_int (big_int_of_int i) bi
-| ((Big_int bi), (Int i)) -> compare_big_int bi (big_int_of_int i)
-
-| ((Int i), (Ratio r)) -> compare_big_int_ratio (big_int_of_int i) r
-| ((Ratio r), (Int i)) -> -(compare_big_int_ratio (big_int_of_int i) r)
-
-| ((Big_int bi1), (Big_int bi2)) -> compare_big_int bi1 bi2
-
-| ((Big_int bi), (Ratio r)) -> compare_big_int_ratio bi r
-| ((Ratio r), (Big_int bi)) -> -(compare_big_int_ratio bi r)
-
-| ((Ratio r1), (Ratio r2)) -> compare_ratio r1 r2
-
-let lt_num num1 num2 = compare_num num1 num2 < 0
-and le_num num1 num2 = compare_num num1 num2 <= 0
-and gt_num num1 num2 = compare_num num1 num2 > 0
-and ge_num num1 num2 = compare_num num1 num2 >= 0
-
-let ( </ ) = lt_num
-and ( <=/ ) = le_num
-and ( >/ ) = gt_num
-and ( >=/ ) = ge_num
-
-let max_num num1 num2 = if lt_num num1 num2 then num2 else num1
-and min_num num1 num2 = if gt_num num1 num2 then num2 else num1
-
-(* Coercions with basic types *)
-
-(* Coercion with int type *)
-let int_of_num = function
- Int i -> i
-| Big_int bi -> int_of_big_int bi
-| Ratio r -> int_of_ratio r
-
-and num_of_int i =
- if i = monster_int
- then Big_int (big_int_of_int i)
- else Int i
-
-(* Coercion with nat type *)
-let nat_of_num = function
- Int i -> nat_of_int i
-| Big_int bi -> nat_of_big_int bi
-| Ratio r -> nat_of_ratio r
-
-and num_of_nat nat =
- if (is_nat_int nat 0 (length_nat nat))
- then Int (nth_digit_nat nat 0)
- else Big_int (big_int_of_nat nat)
-
-(* Coercion with big_int type *)
-let big_int_of_num = function
- Int i -> big_int_of_int i
-| Big_int bi -> bi
-| Ratio r -> big_int_of_ratio r
-
-(* Coercion with ratio type *)
-let ratio_of_num = function
- Int i -> ratio_of_int i
-| Big_int bi -> ratio_of_big_int bi
-| Ratio r -> r;;
-
-let string_of_big_int_for_num bi =
- if !approx_printing_flag
- then approx_big_int !floating_precision bi
- else string_of_big_int bi
-
-(* Coercion with string type *)
-
-(* XL: suppression de sys_string_of_num *)
-
-let string_of_normalized_num = function
- Int i -> string_of_int i
-| Big_int bi -> string_of_big_int_for_num bi
-| Ratio r -> string_of_ratio r
-let string_of_num n =
- string_of_normalized_num (cautious_normalize_num_when_printing n)
-let num_of_string s =
- try
- let flag = !normalize_ratio_flag in
- normalize_ratio_flag := true;
- let r = ratio_of_string s in
- normalize_ratio_flag := flag;
- if eq_big_int (denominator_ratio r) unit_big_int
- then num_of_big_int (numerator_ratio r)
- else Ratio r
- with Failure _ ->
- failwith "num_of_string"
-
-(* Coercion with float type *)
-let float_of_num = function
- Int i -> float i
-| Big_int bi -> float_of_big_int bi
-| Ratio r -> float_of_ratio r
-
-(* XL: suppression de num_of_float, float_num *)
-
-let succ_num = function
- Int i -> if i = biggest_int
- then Big_int (succ_big_int (big_int_of_int i))
- else Int (succ i)
-| Big_int bi -> num_of_big_int (succ_big_int bi)
-| Ratio r -> Ratio (add_int_ratio 1 r)
-
-and pred_num = function
- Int i -> if i = monster_int
- then Big_int (pred_big_int (big_int_of_int i))
- else Int (pred i)
-| Big_int bi -> num_of_big_int (pred_big_int bi)
-| Ratio r -> Ratio (add_int_ratio (-1) r)
-
-let abs_num = function
- Int i -> if i = monster_int
- then Big_int (minus_big_int (big_int_of_int i))
- else Int (abs i)
- | Big_int bi -> Big_int (abs_big_int bi)
- | Ratio r -> Ratio (abs_ratio r)
-
-let approx_num_fix n num = approx_ratio_fix n (ratio_of_num num)
-and approx_num_exp n num = approx_ratio_exp n (ratio_of_num num)
-
-let incr_num r = r := succ_num !r
-and decr_num r = r := pred_num !r
-
-
-
-
-
diff --git a/otherlibs/num/num.mli b/otherlibs/num/num.mli
deleted file mode 100644
index c69f3b0d4a..0000000000
--- a/otherlibs/num/num.mli
+++ /dev/null
@@ -1,171 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Operation on arbitrary-precision numbers.
-
- Numbers (type [num]) are arbitrary-precision rational numbers,
- plus the special elements [1/0] (infinity) and [0/0] (undefined).
-*)
-
-open Nat
-open Big_int
-open Ratio
-
-(** The type of numbers. *)
-type num =
- Int of int
- | Big_int of big_int
- | Ratio of ratio
-
-
-(** {6 Arithmetic operations} *)
-
-
-val ( +/ ) : num -> num -> num
-(** Same as {!Num.add_num}.*)
-
-val add_num : num -> num -> num
-(** Addition *)
-
-val minus_num : num -> num
-(** Unary negation. *)
-
-val ( -/ ) : num -> num -> num
-(** Same as {!Num.sub_num}.*)
-
-val sub_num : num -> num -> num
-(** Subtraction *)
-
-val ( */ ) : num -> num -> num
-(** Same as {!Num.mult_num}.*)
-
-val mult_num : num -> num -> num
-(** Multiplication *)
-
-val square_num : num -> num
-(** Squaring *)
-
-val ( // ) : num -> num -> num
-(** Same as {!Num.div_num}.*)
-
-val div_num : num -> num -> num
-(** Division *)
-
-val quo_num : num -> num -> num
-(** Euclidean division: quotient. *)
-
-val mod_num : num -> num -> num
-(** Euclidean division: remainder. *)
-
-val ( **/ ) : num -> num -> num
-(** Same as {!Num.power_num}. *)
-
-val power_num : num -> num -> num
-(** Exponentiation *)
-
-val abs_num : num -> num
-(** Absolute value. *)
-
-val succ_num : num -> num
-(** [succ n] is [n+1] *)
-
-val pred_num : num -> num
-(** [pred n] is [n-1] *)
-
-val incr_num : num ref -> unit
-(** [incr r] is [r:=!r+1], where [r] is a reference to a number. *)
-
-val decr_num : num ref -> unit
-(** [decr r] is [r:=!r-1], where [r] is a reference to a number. *)
-
-val is_integer_num : num -> bool
-(** Test if a number is an integer *)
-
-(** The four following functions approximate a number by an integer : *)
-
-val integer_num : num -> num
-(** [integer_num n] returns the integer closest to [n]. In case of ties,
- rounds towards zero. *)
-
-val floor_num : num -> num
-(** [floor_num n] returns the largest integer smaller or equal to [n]. *)
-
-val round_num : num -> num
-(** [round_num n] returns the integer closest to [n]. In case of ties,
- rounds off zero. *)
-
-val ceiling_num : num -> num
-(** [ceiling_num n] returns the smallest integer bigger or equal to [n]. *)
-
-
-val sign_num : num -> int
-(** Return [-1], [0] or [1] according to the sign of the argument. *)
-
-(** {7 Comparisons between numbers} *)
-
-val ( =/ ) : num -> num -> bool
-val ( </ ) : num -> num -> bool
-val ( >/ ) : num -> num -> bool
-val ( <=/ ) : num -> num -> bool
-val ( >=/ ) : num -> num -> bool
-val ( <>/ ) : num -> num -> bool
-val eq_num : num -> num -> bool
-val lt_num : num -> num -> bool
-val le_num : num -> num -> bool
-val gt_num : num -> num -> bool
-val ge_num : num -> num -> bool
-
-val compare_num : num -> num -> int
-(** Return [-1], [0] or [1] if the first argument is less than,
- equal to, or greater than the second argument. *)
-
-val max_num : num -> num -> num
-(** Return the greater of the two arguments. *)
-
-val min_num : num -> num -> num
-(** Return the smaller of the two arguments. *)
-
-
-(** {6 Coercions with strings} *)
-
-val string_of_num : num -> string
-(** Convert a number to a string, using fractional notation. *)
-
-val approx_num_fix : int -> num -> string
-(** See {!Num.approx_num_exp}.*)
-
-val approx_num_exp : int -> num -> string
-(** Approximate a number by a decimal. The first argument is the
- required precision. The second argument is the number to
- approximate. {!Num.approx_num_fix} uses decimal notation; the first
- argument is the number of digits after the decimal point.
- [approx_num_exp] uses scientific (exponential) notation; the
- first argument is the number of digits in the mantissa. *)
-
-val num_of_string : string -> num
-(** Convert a string to a number. *)
-
-(** {6 Coercions between numerical types} *)
-
-val int_of_num : num -> int
-val num_of_int : int -> num
-val nat_of_num : num -> nat
-val num_of_nat : nat -> num
-val num_of_big_int : big_int -> num
-val big_int_of_num : num -> big_int
-val ratio_of_num : num -> ratio
-val num_of_ratio : ratio -> num
-val float_of_num : num -> float
-
diff --git a/otherlibs/num/ratio.ml b/otherlibs/num/ratio.ml
deleted file mode 100644
index 500236420d..0000000000
--- a/otherlibs/num/ratio.ml
+++ /dev/null
@@ -1,577 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-open Int_misc
-open String_misc
-open Nat
-open Big_int
-open Arith_flags
-
-(* Definition of the type ratio :
- Conventions :
- - the denominator is always a positive number
- - the sign of n/0 is the sign of n
-These convention is automatically respected when a ratio is created with
-the create_ratio primitive
-*)
-
-type ratio = { mutable numerator : big_int;
- mutable denominator : big_int;
- mutable normalized : bool}
-
-let failwith_zero name =
- let s = "infinite or undefined rational number" in
- failwith (if String.length name = 0 then s else name ^ " " ^ s)
-
-let numerator_ratio r = r.numerator
-and denominator_ratio r = r.denominator
-
-let null_denominator r = sign_big_int r.denominator = 0
-
-let verify_null_denominator r =
- if sign_big_int r.denominator = 0
- then (if !error_when_null_denominator_flag
- then (failwith_zero "")
- else true)
- else false
-
-let sign_ratio r = sign_big_int r.numerator
-
-(* Physical normalization of rational numbers *)
-(* 1/0, 0/0 and -1/0 are the normalized forms for n/0 numbers *)
-let normalize_ratio r =
- if r.normalized then r
- else if verify_null_denominator r then begin
- r.numerator <- big_int_of_int (sign_big_int r.numerator);
- r.normalized <- true;
- r
- end else begin
- let p = gcd_big_int r.numerator r.denominator in
- if eq_big_int p unit_big_int
- then begin
- r.normalized <- true; r
- end else begin
- r.numerator <- div_big_int (r.numerator) p;
- r.denominator <- div_big_int (r.denominator) p;
- r.normalized <- true; r
- end
- end
-
-let cautious_normalize_ratio r =
- if (!normalize_ratio_flag) then (normalize_ratio r) else r
-
-let cautious_normalize_ratio_when_printing r =
- if (!normalize_ratio_when_printing_flag) then (normalize_ratio r) else r
-
-let create_ratio bi1 bi2 =
- match sign_big_int bi2 with
- -1 -> cautious_normalize_ratio
- { numerator = minus_big_int bi1;
- denominator = minus_big_int bi2;
- normalized = false }
- | 0 -> if !error_when_null_denominator_flag
- then (failwith_zero "create_ratio")
- else cautious_normalize_ratio
- { numerator = bi1; denominator = bi2; normalized = false }
- | _ -> cautious_normalize_ratio
- { numerator = bi1; denominator = bi2; normalized = false }
-
-let create_normalized_ratio bi1 bi2 =
- match sign_big_int bi2 with
- -1 -> { numerator = minus_big_int bi1;
- denominator = minus_big_int bi2;
- normalized = true }
-| 0 -> if !error_when_null_denominator_flag
- then failwith_zero "create_normalized_ratio"
- else { numerator = bi1; denominator = bi2; normalized = true }
-| _ -> { numerator = bi1; denominator = bi2; normalized = true }
-
-let is_normalized_ratio r = r.normalized
-
-let report_sign_ratio r bi =
- if sign_ratio r = -1
- then minus_big_int bi
- else bi
-
-let abs_ratio r =
- { numerator = abs_big_int r.numerator;
- denominator = r.denominator;
- normalized = r.normalized }
-
-let is_integer_ratio r =
- eq_big_int ((normalize_ratio r).denominator) unit_big_int
-
-(* Operations on rational numbers *)
-
-let add_ratio r1 r2 =
- if !normalize_ratio_flag then begin
- let p = gcd_big_int ((normalize_ratio r1).denominator)
- ((normalize_ratio r2).denominator) in
- if eq_big_int p unit_big_int then
- {numerator = add_big_int (mult_big_int (r1.numerator) r2.denominator)
- (mult_big_int (r2.numerator) r1.denominator);
- denominator = mult_big_int (r1.denominator) r2.denominator;
- normalized = true}
- else begin
- let d1 = div_big_int (r1.denominator) p
- and d2 = div_big_int (r2.denominator) p in
- let n = add_big_int (mult_big_int (r1.numerator) d2)
- (mult_big_int d1 r2.numerator) in
- let p' = gcd_big_int n p in
- { numerator = div_big_int n p';
- denominator = mult_big_int d1 (div_big_int (r2.denominator) p');
- normalized = true }
- end
- end else
- { numerator = add_big_int (mult_big_int (r1.numerator) r2.denominator)
- (mult_big_int (r1.denominator) r2.numerator);
- denominator = mult_big_int (r1.denominator) r2.denominator;
- normalized = false }
-
-let minus_ratio r =
- { numerator = minus_big_int (r.numerator);
- denominator = r.denominator;
- normalized = r.normalized }
-
-let add_int_ratio i r =
- cautious_normalize_ratio r;
- { numerator = add_big_int (mult_int_big_int i r.denominator) r.numerator;
- denominator = r.denominator;
- normalized = r.normalized }
-
-let add_big_int_ratio bi r =
- cautious_normalize_ratio r;
- { numerator = add_big_int (mult_big_int bi r.denominator) r.numerator ;
- denominator = r.denominator;
- normalized = r.normalized }
-
-let sub_ratio r1 r2 = add_ratio r1 (minus_ratio r2)
-
-let mult_ratio r1 r2 =
- if !normalize_ratio_flag then begin
- let p1 = gcd_big_int ((normalize_ratio r1).numerator)
- ((normalize_ratio r2).denominator)
- and p2 = gcd_big_int (r2.numerator) r1.denominator in
- let (n1, d2) =
- if eq_big_int p1 unit_big_int
- then (r1.numerator, r2.denominator)
- else (div_big_int (r1.numerator) p1, div_big_int (r2.denominator) p1)
- and (n2, d1) =
- if eq_big_int p2 unit_big_int
- then (r2.numerator, r1.denominator)
- else (div_big_int r2.numerator p2, div_big_int r1.denominator p2) in
- { numerator = mult_big_int n1 n2;
- denominator = mult_big_int d1 d2;
- normalized = true }
- end else
- { numerator = mult_big_int (r1.numerator) r2.numerator;
- denominator = mult_big_int (r1.denominator) r2.denominator;
- normalized = false }
-
-let mult_int_ratio i r =
- if !normalize_ratio_flag then
- begin
- let p = gcd_big_int ((normalize_ratio r).denominator) (big_int_of_int i) in
- if eq_big_int p unit_big_int
- then { numerator = mult_big_int (big_int_of_int i) r.numerator;
- denominator = r.denominator;
- normalized = true }
- else { numerator = mult_big_int (div_big_int (big_int_of_int i) p)
- r.numerator;
- denominator = div_big_int (r.denominator) p;
- normalized = true }
- end
- else
- { numerator = mult_int_big_int i r.numerator;
- denominator = r.denominator;
- normalized = false }
-
-let mult_big_int_ratio bi r =
- if !normalize_ratio_flag then
- begin
- let p = gcd_big_int ((normalize_ratio r).denominator) bi in
- if eq_big_int p unit_big_int
- then { numerator = mult_big_int bi r.numerator;
- denominator = r.denominator;
- normalized = true }
- else { numerator = mult_big_int (div_big_int bi p) r.numerator;
- denominator = div_big_int (r.denominator) p;
- normalized = true }
- end
- else
- { numerator = mult_big_int bi r.numerator;
- denominator = r.denominator;
- normalized = false }
-
-let square_ratio r =
- cautious_normalize_ratio r;
- { numerator = square_big_int r.numerator;
- denominator = square_big_int r.denominator;
- normalized = r.normalized }
-
-let inverse_ratio r =
- if !error_when_null_denominator_flag && (sign_big_int r.numerator) = 0
- then failwith_zero "inverse_ratio"
- else {numerator = report_sign_ratio r r.denominator;
- denominator = abs_big_int r.numerator;
- normalized = r.normalized}
-
-let div_ratio r1 r2 =
- mult_ratio r1 (inverse_ratio r2)
-
-(* Integer part of a rational number *)
-(* Odd function *)
-let integer_ratio r =
- if null_denominator r then failwith_zero "integer_ratio"
- else if sign_ratio r = 0 then zero_big_int
- else report_sign_ratio r (div_big_int (abs_big_int r.numerator)
- (abs_big_int r.denominator))
-
-(* Floor of a rational number *)
-(* Always less or equal to r *)
-let floor_ratio r =
- verify_null_denominator r;
- div_big_int (r.numerator) r.denominator
-
-(* Round of a rational number *)
-(* Odd function, 1/2 -> 1 *)
-let round_ratio r =
- verify_null_denominator r;
- let abs_num = abs_big_int r.numerator in
- let bi = div_big_int abs_num r.denominator in
- report_sign_ratio r
- (if sign_big_int
- (sub_big_int
- (mult_int_big_int
- 2
- (sub_big_int abs_num (mult_big_int (r.denominator) bi)))
- r.denominator) = -1
- then bi
- else succ_big_int bi)
-
-let ceiling_ratio r =
- if (is_integer_ratio r)
- then r.numerator
- else succ_big_int (floor_ratio r)
-
-
-(* Comparison operators on rational numbers *)
-let eq_ratio r1 r2 =
- normalize_ratio r1;
- normalize_ratio r2;
- eq_big_int (r1.numerator) r2.numerator &&
- eq_big_int (r1.denominator) r2.denominator
-
-let compare_ratio r1 r2 =
- if verify_null_denominator r1 then
- let sign_num_r1 = sign_big_int r1.numerator in
- if (verify_null_denominator r2)
- then
- let sign_num_r2 = sign_big_int r2.numerator in
- if sign_num_r1 = 1 && sign_num_r2 = -1 then 1
- else if sign_num_r1 = -1 && sign_num_r2 = 1 then -1
- else 0
- else sign_num_r1
- else if verify_null_denominator r2 then
- -(sign_big_int r2.numerator)
- else match compare_int (sign_big_int r1.numerator)
- (sign_big_int r2.numerator) with
- 1 -> 1
- | -1 -> -1
- | _ -> if eq_big_int (r1.denominator) r2.denominator
- then compare_big_int (r1.numerator) r2.numerator
- else compare_big_int
- (mult_big_int (r1.numerator) r2.denominator)
- (mult_big_int (r1.denominator) r2.numerator)
-
-
-let lt_ratio r1 r2 = compare_ratio r1 r2 < 0
-and le_ratio r1 r2 = compare_ratio r1 r2 <= 0
-and gt_ratio r1 r2 = compare_ratio r1 r2 > 0
-and ge_ratio r1 r2 = compare_ratio r1 r2 >= 0
-
-let max_ratio r1 r2 = if lt_ratio r1 r2 then r2 else r1
-and min_ratio r1 r2 = if gt_ratio r1 r2 then r2 else r1
-
-let eq_big_int_ratio bi r =
- (is_integer_ratio r) && eq_big_int bi r.numerator
-
-let compare_big_int_ratio bi r =
- normalize_ratio r;
- if (verify_null_denominator r)
- then -(sign_big_int r.numerator)
- else compare_big_int (mult_big_int bi r.denominator) r.numerator
-
-let lt_big_int_ratio bi r = compare_big_int_ratio bi r < 0
-and le_big_int_ratio bi r = compare_big_int_ratio bi r <= 0
-and gt_big_int_ratio bi r = compare_big_int_ratio bi r > 0
-and ge_big_int_ratio bi r = compare_big_int_ratio bi r >= 0
-
-(* Coercions *)
-
-(* Coercions with type int *)
-let int_of_ratio r =
- if ((is_integer_ratio r) && (is_int_big_int r.numerator))
- then (int_of_big_int r.numerator)
- else failwith "integer argument required"
-
-and ratio_of_int i =
- { numerator = big_int_of_int i;
- denominator = unit_big_int;
- normalized = true }
-
-(* Coercions with type nat *)
-let ratio_of_nat nat =
- { numerator = big_int_of_nat nat;
- denominator = unit_big_int;
- normalized = true }
-
-and nat_of_ratio r =
- normalize_ratio r;
- if not (is_integer_ratio r) then
- failwith "nat_of_ratio"
- else if sign_big_int r.numerator > -1 then
- nat_of_big_int (r.numerator)
- else failwith "nat_of_ratio"
-
-(* Coercions with type big_int *)
-let ratio_of_big_int bi =
- { numerator = bi; denominator = unit_big_int; normalized = true }
-
-and big_int_of_ratio r =
- normalize_ratio r;
- if is_integer_ratio r
- then r.numerator
- else failwith "big_int_of_ratio"
-
-let div_int_ratio i r =
- verify_null_denominator r;
- mult_int_ratio i (inverse_ratio r)
-
-let div_ratio_int r i =
- div_ratio r (ratio_of_int i)
-
-let div_big_int_ratio bi r =
- verify_null_denominator r;
- mult_big_int_ratio bi (inverse_ratio r)
-
-let div_ratio_big_int r bi =
- div_ratio r (ratio_of_big_int bi)
-
-(* Functions on type string *)
-(* giving floating point approximations of rational numbers *)
-
-(* Compares strings that contains only digits, have the same length,
- from index i to index i + l *)
-let rec compare_num_string s1 s2 i len =
- if i >= len then 0 else
- let c1 = int_of_char s1.[i]
- and c2 = int_of_char s2.[i] in
- match compare_int c1 c2 with
- | 0 -> compare_num_string s1 s2 (succ i) len
- | c -> c;;
-
-(* Position of the leading digit of the decimal expansion *)
-(* of a strictly positive rational number *)
-(* if the decimal expansion of a non null rational r is equal to *)
-(* sigma for k=-P to N of r_k*10^k then msd_ratio r = N *)
-(* Nota : for a big_int we have msd_ratio = nums_digits_big_int -1 *)
-
-(* Tests if s has only zeros characters from index i to index lim *)
-let rec only_zeros s i lim =
- i >= lim || s.[i] == '0' && only_zeros s (succ i) lim;;
-
-(* Nota : for a big_int we have msd_ratio = nums_digits_big_int -1 *)
-let msd_ratio r =
- cautious_normalize_ratio r;
- if null_denominator r then failwith_zero "msd_ratio"
- else if sign_big_int r.numerator == 0 then 0
- else begin
- let str_num = string_of_big_int r.numerator
- and str_den = string_of_big_int r.denominator in
- let size_num = String.length str_num
- and size_den = String.length str_den in
- let size_min = min size_num size_den in
- let m = size_num - size_den in
- let cmp = compare_num_string str_num str_den 0 size_min in
- match cmp with
- | 1 -> m
- | -1 -> pred m
- | _ ->
- if m >= 0 then m else
- if only_zeros str_den size_min size_den then m
- else pred m
- end
-;;
-
-(* Decimal approximations of rational numbers *)
-
-(* Approximation with fix decimal point *)
-(* This is an odd function and the last digit is round off *)
-(* Format integer_part . decimal_part_with_n_digits *)
-let approx_ratio_fix n r =
- (* Don't need to normalize *)
- if (null_denominator r) then failwith_zero "approx_ratio_fix"
- else
- let sign_r = sign_ratio r in
- if sign_r = 0
- then "+0" (* r = 0 *)
- else (* r.numerator and r.denominator are not null numbers
- s contains one more digit than desired for the round off operation
- and to have enough room in s when including the decimal point *)
- if n >= 0 then
- let s =
- let nat =
- (nat_of_big_int
- (div_big_int
- (base_power_big_int
- 10 (succ n) (abs_big_int r.numerator))
- r.denominator))
- in (if sign_r = -1 then "-" else "+") ^ string_of_nat nat in
- let l = String.length s in
- if round_futur_last_digit s 1 (pred l)
- then begin (* if one more char is needed in s *)
- let str = (String.make (succ l) '0') in
- String.set str 0 (if sign_r = -1 then '-' else '+');
- String.set str 1 '1';
- String.set str (l - n) '.';
- str
- end else (* s can contain the final result *)
- if l > n + 2
- then begin (* |r| >= 1, set decimal point *)
- let l2 = (pred l) - n in
- String.blit s l2 s (succ l2) n;
- String.set s l2 '.'; s
- end else begin (* |r| < 1, there must be 0-characters *)
- (* before the significant development, *)
- (* with care to the sign of the number *)
- let size = n + 3 in
- let m = size - l + 2
- and str = String.make size '0' in
-
- (String.blit (if sign_r = 1 then "+0." else "-0.") 0 str 0 3);
- (String.blit s 1 str m (l - 2));
- str
- end
- else begin
- let s = string_of_big_int
- (div_big_int
- (abs_big_int r.numerator)
- (base_power_big_int
- 10 (-n) r.denominator)) in
- let len = succ (String.length s) in
- let s' = String.make len '0' in
- String.set s' 0 (if sign_r = -1 then '-' else '+');
- String.blit s 0 s' 1 (pred len);
- s'
- end
-
-(* Number of digits of the decimal representation of an int *)
-let num_decimal_digits_int n =
- String.length (string_of_int n)
-
-(* Approximation with floating decimal point *)
-(* This is an odd function and the last digit is round off *)
-(* Format (+/-)(0. n_first_digits e msd)/(1. n_zeros e (msd+1) *)
-let approx_ratio_exp n r =
- (* Don't need to normalize *)
- if (null_denominator r) then failwith_zero "approx_ratio_exp"
- else if n <= 0 then invalid_arg "approx_ratio_exp"
- else
- let sign_r = sign_ratio r
- and i = ref (n + 3) in
- if sign_r = 0
- then
- let s = String.make (n + 5) '0' in
- (String.blit "+0." 0 s 0 3);
- (String.blit "e0" 0 s !i 2); s
- else
- let msd = msd_ratio (abs_ratio r) in
- let k = n - msd in
- let s =
- (let nat = nat_of_big_int
- (if k < 0
- then
- div_big_int (abs_big_int r.numerator)
- (base_power_big_int 10 (- k)
- r.denominator)
- else
- div_big_int (base_power_big_int
- 10 k (abs_big_int r.numerator))
- r.denominator) in
- string_of_nat nat) in
- if (round_futur_last_digit s 0 (String.length s))
- then
- let m = num_decimal_digits_int (succ msd) in
- let str = String.make (n + m + 4) '0' in
- (String.blit (if sign_r = -1 then "-1." else "+1.") 0 str 0 3);
- String.set str !i ('e');
- incr i;
- (if m = 0
- then String.set str !i '0'
- else String.blit (string_of_int (succ msd)) 0 str !i m);
- str
- else
- let m = num_decimal_digits_int (succ msd)
- and p = n + 3 in
- let str = String.make (succ (m + p)) '0' in
- (String.blit (if sign_r = -1 then "-0." else "+0.") 0 str 0 3);
- (String.blit s 0 str 3 n);
- String.set str p 'e';
- (if m = 0
- then String.set str (succ p) '0'
- else (String.blit (string_of_int (succ msd)) 0 str (succ p) m));
- str
-
-(* String approximation of a rational with a fixed number of significant *)
-(* digits printed *)
-let float_of_rational_string r =
- let s = approx_ratio_exp !floating_precision r in
- if String.get s 0 = '+'
- then (String.sub s 1 (pred (String.length s)))
- else s
-
-(* Coercions with type string *)
-let string_of_ratio r =
- cautious_normalize_ratio_when_printing r;
- if !approx_printing_flag
- then float_of_rational_string r
- else string_of_big_int r.numerator ^ "/" ^ string_of_big_int r.denominator
-
-(* XL: j'ai puissamment simplifie "ratio_of_string" en virant la notation
- scientifique. *)
-
-let ratio_of_string s =
- let n = index_char s '/' 0 in
- if n = -1 then
- { numerator = big_int_of_string s;
- denominator = unit_big_int;
- normalized = true }
- else
- create_ratio (sys_big_int_of_string s 0 n)
- (sys_big_int_of_string s (n+1) (String.length s - n - 1))
-
-(* Coercion with type float *)
-
-let float_of_ratio r =
- float_of_string (float_of_rational_string r)
-
-(* XL: suppression de ratio_of_float *)
-
-let power_ratio_positive_int r n =
- create_ratio (power_big_int_positive_int (r.numerator) n)
- (power_big_int_positive_int (r.denominator) n)
-
-let power_ratio_positive_big_int r bi =
- create_ratio (power_big_int_positive_big_int (r.numerator) bi)
- (power_big_int_positive_big_int (r.denominator) bi)
diff --git a/otherlibs/num/ratio.mli b/otherlibs/num/ratio.mli
deleted file mode 100644
index 64fc6b9cdc..0000000000
--- a/otherlibs/num/ratio.mli
+++ /dev/null
@@ -1,88 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Module [Ratio]: operations on rational numbers *)
-
-open Nat
-open Big_int
-
-(* Rationals (type [ratio]) are arbitrary-precision rational numbers,
- plus the special elements [1/0] (infinity) and [0/0] (undefined).
- In constrast with numbers (type [num]), the special cases of
- small integers and big integers are not optimized specially. *)
-
-type ratio
-
-val null_denominator : ratio -> bool
-val numerator_ratio : ratio -> big_int
-val denominator_ratio : ratio -> big_int
-val sign_ratio : ratio -> int
-val normalize_ratio : ratio -> ratio
-val cautious_normalize_ratio : ratio -> ratio
-val cautious_normalize_ratio_when_printing : ratio -> ratio
-val create_ratio : big_int -> big_int -> ratio
-val create_normalized_ratio : big_int -> big_int -> ratio
-val is_normalized_ratio : ratio -> bool
-val report_sign_ratio : ratio -> big_int -> big_int
-val abs_ratio : ratio -> ratio
-val is_integer_ratio : ratio -> bool
-val add_ratio : ratio -> ratio -> ratio
-val minus_ratio : ratio -> ratio
-val add_int_ratio : int -> ratio -> ratio
-val add_big_int_ratio : big_int -> ratio -> ratio
-val sub_ratio : ratio -> ratio -> ratio
-val mult_ratio : ratio -> ratio -> ratio
-val mult_int_ratio : int -> ratio -> ratio
-val mult_big_int_ratio : big_int -> ratio -> ratio
-val square_ratio : ratio -> ratio
-val inverse_ratio : ratio -> ratio
-val div_ratio : ratio -> ratio -> ratio
-val integer_ratio : ratio -> big_int
-val floor_ratio : ratio -> big_int
-val round_ratio : ratio -> big_int
-val ceiling_ratio : ratio -> big_int
-val eq_ratio : ratio -> ratio -> bool
-val compare_ratio : ratio -> ratio -> int
-val lt_ratio : ratio -> ratio -> bool
-val le_ratio : ratio -> ratio -> bool
-val gt_ratio : ratio -> ratio -> bool
-val ge_ratio : ratio -> ratio -> bool
-val max_ratio : ratio -> ratio -> ratio
-val min_ratio : ratio -> ratio -> ratio
-val eq_big_int_ratio : big_int -> ratio -> bool
-val compare_big_int_ratio : big_int -> ratio -> int
-val lt_big_int_ratio : big_int -> ratio -> bool
-val le_big_int_ratio : big_int -> ratio -> bool
-val gt_big_int_ratio : big_int -> ratio -> bool
-val ge_big_int_ratio : big_int -> ratio -> bool
-val int_of_ratio : ratio -> int
-val ratio_of_int : int -> ratio
-val ratio_of_nat : nat -> ratio
-val nat_of_ratio : ratio -> nat
-val ratio_of_big_int : big_int -> ratio
-val big_int_of_ratio : ratio -> big_int
-val div_int_ratio : int -> ratio -> ratio
-val div_ratio_int : ratio -> int -> ratio
-val div_big_int_ratio : big_int -> ratio -> ratio
-val div_ratio_big_int : ratio -> big_int -> ratio
-val approx_ratio_fix : int -> ratio -> string
-val approx_ratio_exp : int -> ratio -> string
-val float_of_rational_string : ratio -> string
-val string_of_ratio : ratio -> string
-val ratio_of_string : string -> ratio
-val float_of_ratio : ratio -> float
-val power_ratio_positive_int : ratio -> int -> ratio
-val power_ratio_positive_big_int : ratio -> big_int -> ratio
-
diff --git a/otherlibs/num/string_misc.ml b/otherlibs/num/string_misc.ml
deleted file mode 100644
index b6e33b9b71..0000000000
--- a/otherlibs/num/string_misc.ml
+++ /dev/null
@@ -1,20 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-let rec index_char str chr pos =
- if pos >= String.length str then -1
- else if String.get str pos = chr then pos
- else index_char str chr (pos + 1)
-;;
diff --git a/otherlibs/num/string_misc.mli b/otherlibs/num/string_misc.mli
deleted file mode 100644
index ef89c91b82..0000000000
--- a/otherlibs/num/string_misc.mli
+++ /dev/null
@@ -1,16 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-val index_char: string -> char -> int -> int
diff --git a/otherlibs/num/test/.depend b/otherlibs/num/test/.depend
deleted file mode 100644
index 28fea1f58e..0000000000
--- a/otherlibs/num/test/.depend
+++ /dev/null
@@ -1,10 +0,0 @@
-end_test.cmo: test.cmo
-end_test.cmx: test.cmx
-test_big_ints.cmo: test.cmo
-test_big_ints.cmx: test.cmx
-test_nats.cmo: test.cmo
-test_nats.cmx: test.cmx
-test_nums.cmo: test.cmo
-test_nums.cmx: test.cmx
-test_ratios.cmo: test.cmo
-test_ratios.cmx: test.cmx
diff --git a/otherlibs/num/test/Makefile b/otherlibs/num/test/Makefile
deleted file mode 100644
index ce56b35d7e..0000000000
--- a/otherlibs/num/test/Makefile
+++ /dev/null
@@ -1,61 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../../LICENSE.#
-# #
-#########################################################################
-
-# $Id$
-
-include ../../../config/Makefile
-
-CAMLC=../../../boot/ocamlrun ../../../ocamlc -I ../../../stdlib
-CAMLOPT=../../../boot/ocamlrun ../../../ocamlopt -I ../../../stdlib
-CC=$(BYTECC)
-CFLAGS=-I.. $(BYTECCCOMPOPTS)
-
-test: test.byt test.opt
- if $(SUPPORTS_SHARED_LIBRARIES); then ../../../byterun/ocamlrun -I .. ./test.byt; else ./test.byt; fi
- ./test.opt
-
-TESTFILES=test.cmo \
- test_nats.cmo test_big_ints.cmo test_ratios.cmo test_nums.cmo \
- test_io.cmo end_test.cmo
-
-TESTOPTFILES=$(TESTFILES:.cmo=.cmx)
-
-test.byt: $(TESTFILES) ../nums.cma ../libnums.a
- $(CAMLC) -ccopt -L.. -o test.byt ../nums.cma $(TESTFILES)
-
-test.opt: $(TESTOPTFILES) ../nums.cmxa ../libnums.a
- $(CAMLOPT) -ccopt -L.. -o test.opt ../nums.cmxa $(TESTOPTFILES)
-
-test_bng: test_bng.o
- $(CC) $(CFLAGS) -o test_bng ../bng.o test_bng.o -lbignum
-
-$(TESTOPTFILES): ../../../ocamlopt
-
-.SUFFIXES: .ml .cmo .cmx
-
-.ml.cmo:
- $(CAMLC) -I .. -c $<
-
-.ml.cmx:
- $(CAMLOPT) -I .. -c $<
-
-ocamlnum:
- ocamlmktop -o ocamlnum -custom ../nums.cma ../libnums.a
-
-clean:
- rm -f test.byt test.opt test_bng *.o *.cm? ocamlnum
-
-depend:
- ocamldep *.ml > .depend
-
-include .depend
diff --git a/otherlibs/num/test/Makefile.Mac b/otherlibs/num/test/Makefile.Mac
deleted file mode 100644
index 3e01c72205..0000000000
--- a/otherlibs/num/test/Makefile.Mac
+++ /dev/null
@@ -1,40 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../../LICENSE.#
-# #
-#########################################################################
-
-# $Id$
-
-CAMLC = ::::boot:ocamlrun ::::ocamlc -I ::::stdlib:
-CAMLOPT = ::::boot:ocamlrun ::::ocamlopt -I ::::stdlib:
-
-test Ä test.byt
- :test.byt
-
-TESTFILES = test.cmo test_nats.cmo test_big_ints.cmo ¶
- test_ratios.cmo test_nums.cmo test_io.cmo end_test.cmo
-
-test.byt Ä {TESTFILES} ::nums.cma ::libnums.o
- alias ocamlc "{CAMLC}"
- ::::tools:ocamlc-custom -o test.byt ::nums.cma {TESTFILES} ::libnums.[ox]
-
-.cmo Ä .ml
- {CAMLC} -I :: -c {default}.ml
-
-ocamlnum Ä
- ocamlmktop -o ocamlnum -custom ::nums.cma ::libnums.[ox]
-
-clean Ä
- delete -i test.byt ocamlnum
- delete -i Å.cm[io] || set status 0
-
-depend Ä
- ocamldep Å.ml > Makefile.Mac.depend
diff --git a/otherlibs/num/test/Makefile.Mac.depend b/otherlibs/num/test/Makefile.Mac.depend
deleted file mode 100644
index bda141c07a..0000000000
--- a/otherlibs/num/test/Makefile.Mac.depend
+++ /dev/null
@@ -1,10 +0,0 @@
-end_test.cmoÄ test.cmo
-end_test.cmxÄ test.cmx
-test_big_ints.cmoÄ test.cmo
-test_big_ints.cmxÄ test.cmx
-test_nats.cmoÄ test.cmo
-test_nats.cmxÄ test.cmx
-test_nums.cmoÄ test.cmo
-test_nums.cmxÄ test.cmx
-test_ratios.cmoÄ test.cmo
-test_ratios.cmxÄ test.cmx
diff --git a/otherlibs/num/test/Makefile.nt b/otherlibs/num/test/Makefile.nt
deleted file mode 100644
index 0d342145e7..0000000000
--- a/otherlibs/num/test/Makefile.nt
+++ /dev/null
@@ -1,59 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../../LICENSE.#
-# #
-#########################################################################
-
-# $Id$
-
-CAMLC=../../../boot/ocamlrun ../../../ocamlc -I ../../../stdlib -I ..
-CAMLOPT=../../../boot/ocamlrun ../../../ocamlopt -I ../../../stdlib -I ..
-CC=$(BYTECC)
-CFLAGS=-I.. $(BYTECCCOMPOPTS)
-
-test: test.byt test.opt
- ../../../byterun/ocamlrun -I .. ./test.byt
- ./test.opt
-
-TESTFILES=test.cmo \
- test_nats.cmo test_big_ints.cmo test_ratios.cmo test_nums.cmo \
- test_io.cmo end_test.cmo
-
-TESTOPTFILES=$(TESTFILES:.cmo=.cmx)
-
-test.byt: $(TESTFILES) ../nums.cma ../libnums.lib
- $(CAMLC) -o test.byt nums.cma $(TESTFILES)
-
-test.opt: $(TESTOPTFILES) ../nums.cmxa ../libnums.lib
- $(CAMLOPT) -o test.opt nums.cmxa $(TESTOPTFILES)
-
-test_bng.exe: test_bng.o
- $(CC) $(CFLAGS) -o test_bng.exe ../bng.o test_bng.o -lbignum
-
-$(TESTOPTFILES): ../../../ocamlopt
-
-.SUFFIXES: .ml .cmo .cmx
-
-.ml.cmo:
- $(CAMLC) -c $<
-
-.ml.cmx:
- $(CAMLOPT) -c $<
-
-ocamltopnum.exe:
- ocamlmktop -o ocamltopnum.exe -custom ../nums.cma ../libnums.$(A)
-
-clean:
- rm -f test.byt test.opt test_bng.exe *.$(O) *.cm? ocamltopnum.exe
-
-depend:
- ocamldep *.ml > .depend
-
-include .depend
diff --git a/otherlibs/num/test/end_test.ml b/otherlibs/num/test/end_test.ml
deleted file mode 100644
index 57e099eda5..0000000000
--- a/otherlibs/num/test/end_test.ml
+++ /dev/null
@@ -1 +0,0 @@
-Test.end_tests ();;
diff --git a/otherlibs/num/test/test.ml b/otherlibs/num/test/test.ml
deleted file mode 100644
index 8426e0ae82..0000000000
--- a/otherlibs/num/test/test.ml
+++ /dev/null
@@ -1,77 +0,0 @@
-open Printf;;
-
-let flush_all () = flush stdout; flush stderr;;
-
-let message s = print_string s; print_newline ();;
-
-let error_occurred = ref false;;
-let immediate_failure = ref true;;
-
-let error () =
- if !immediate_failure then exit 2 else begin
- error_occurred := true; flush_all (); false
- end;;
-
-let success () = flush_all (); true;;
-
-let function_tested = ref "";;
-
-let testing_function s =
- flush_all ();
- function_tested := s;
- print_newline();
- message s;;
-
-let test test_number eq_fun (answer, correct_answer) =
- flush_all ();
- if not (eq_fun answer correct_answer) then begin
- fprintf stderr ">>> Bad result (%s, test %d)\n" !function_tested test_number;
- error ()
- end else begin
- printf " %d..." test_number;
- success ()
- end;;
-
-let failure_test test_number fun_to_test arg =
- flush_all ();
- try
- fun_to_test arg;
- fprintf stderr ">>> Failure expected (%s, test %d)\n"
- !function_tested test_number;
- error ()
- with _ ->
- printf " %d..." test_number;
- success ();;
-
-let failwith_test test_number fun_to_test arg correct_failure =
- flush_all ();
- try
- fun_to_test arg;
- fprintf stderr ">>> Failure expected (%s, test %d)\n"
- !function_tested test_number;
- error ()
- with x ->
- if x = correct_failure then begin
- printf " %d..." test_number;
- success ()
- end else begin
- fprintf stderr ">>> Bad failure (%s, test %d)\n"
- !function_tested test_number;
- error ()
- end;;
-
-let end_tests () =
- flush_all ();
- print_newline ();
- if !error_occurred then begin
- prerr_endline "************* TESTS FAILED ****************"; exit 2
- end else begin
- prerr_endline "************* TESTS COMPLETED SUCCESSFULLY ****************";
- exit 0
- end;;
-
-let eq = (==);;
-let eq_int = (==);;
-let eq_string = (=);;
-
-let sixtyfour = (1 lsl 31) <> 0;;
diff --git a/otherlibs/num/test/test_big_ints.ml b/otherlibs/num/test/test_big_ints.ml
deleted file mode 100644
index 61e9ae4df0..0000000000
--- a/otherlibs/num/test/test_big_ints.ml
+++ /dev/null
@@ -1,468 +0,0 @@
-open Test;;
-open Nat;;
-open Big_int;;
-open Int_misc;;
-open List;;
-
-testing_function "compare_big_int";;
-
-test 1
-eq_int (compare_big_int zero_big_int zero_big_int, 0);;
-test 2
-eq_int (compare_big_int zero_big_int (big_int_of_int 1), (-1));;
-test 3
-eq_int (compare_big_int zero_big_int (big_int_of_int (-1)), 1);;
-test 4
-eq_int (compare_big_int (big_int_of_int 1) zero_big_int, 1);;
-test 5
-eq_int (compare_big_int (big_int_of_int (-1)) zero_big_int, (-1));;
-test 6
-eq_int (compare_big_int (big_int_of_int 1) (big_int_of_int 1), 0);;
-test 7
-eq_int (compare_big_int (big_int_of_int (-1)) (big_int_of_int (-1)), 0);;
-test 8
-eq_int (compare_big_int (big_int_of_int 1) (big_int_of_int (-1)), 1);;
-test 9
-eq_int (compare_big_int (big_int_of_int (-1)) (big_int_of_int 1), (-1));;
-test 10
-eq_int (compare_big_int (big_int_of_int 1) (big_int_of_int 2), (-1));;
-test 11
-eq_int (compare_big_int (big_int_of_int 2) (big_int_of_int 1), 1);;
-test 12
-eq_int (compare_big_int (big_int_of_int (-1)) (big_int_of_int (-2)), 1);;
-test 13
-eq_int (compare_big_int (big_int_of_int (-2)) (big_int_of_int (-1)), (-1));;
-
-
-testing_function "pred_big_int";;
-
-test 1
-eq_big_int (pred_big_int zero_big_int, big_int_of_int (-1));;
-test 2
-eq_big_int (pred_big_int unit_big_int, zero_big_int);;
-test 3
-eq_big_int (pred_big_int (big_int_of_int (-1)), big_int_of_int (-2));;
-
-testing_function "succ_big_int";;
-
-test 1
-eq_big_int (succ_big_int zero_big_int, unit_big_int);;
-test 2
-eq_big_int (succ_big_int unit_big_int, big_int_of_int 2);;
-test 3
-eq_big_int (succ_big_int (big_int_of_int (-1)), zero_big_int);;
-
-testing_function "add_big_int";;
-
-test 1
-eq_big_int (add_big_int zero_big_int zero_big_int, zero_big_int);;
-test 2
-eq_big_int (add_big_int zero_big_int (big_int_of_int 1),
- big_int_of_int 1);;
-test 3
-eq_big_int (add_big_int (big_int_of_int 1) zero_big_int,
- big_int_of_int 1);;
-test 4
-eq_big_int (add_big_int zero_big_int (big_int_of_int (-1)),
- big_int_of_int (-1));;
-test 5
-eq_big_int (add_big_int (big_int_of_int (-1)) zero_big_int,
- big_int_of_int (-1));;
-test 6
-eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int 1),
- big_int_of_int 2);;
-test 7
-eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int 2),
- big_int_of_int 3);;
-test 8
-eq_big_int (add_big_int (big_int_of_int 2) (big_int_of_int 1),
- big_int_of_int 3);;
-test 9
-eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int (-1)),
- big_int_of_int (-2));;
-test 10
-eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int (-2)),
- big_int_of_int (-3));;
-test 11
-eq_big_int (add_big_int (big_int_of_int (-2)) (big_int_of_int (-1)),
- big_int_of_int (-3));;
-test 12
-eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int (-1)),
- zero_big_int);;
-test 13
-eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int 1),
- zero_big_int);;
-test 14
-eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int (-2)),
- big_int_of_int (-1));;
-test 15
-eq_big_int (add_big_int (big_int_of_int (-2)) (big_int_of_int 1),
- big_int_of_int (-1));;
-test 16
-eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int 2),
- big_int_of_int 1);;
-test 17
-eq_big_int (add_big_int (big_int_of_int 2) (big_int_of_int (-1)),
- big_int_of_int 1);;
-
-
-testing_function "sub_big_int";;
-
-test 1
-eq_big_int (sub_big_int zero_big_int zero_big_int, zero_big_int);;
-test 2
-eq_big_int (sub_big_int zero_big_int (big_int_of_int 1),
- big_int_of_int (-1));;
-test 3
-eq_big_int (sub_big_int (big_int_of_int 1) zero_big_int,
- big_int_of_int 1);;
-test 4
-eq_big_int (sub_big_int zero_big_int (big_int_of_int (-1)),
- big_int_of_int 1);;
-test 5
-eq_big_int (sub_big_int (big_int_of_int (-1)) zero_big_int,
- big_int_of_int (-1));;
-test 6
-eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int 1),
- zero_big_int);;
-test 7
-eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int 2),
- big_int_of_int (-1));;
-test 8
-eq_big_int (sub_big_int (big_int_of_int 2) (big_int_of_int 1),
- big_int_of_int 1);;
-test 9
-eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int (-1)),
- zero_big_int);;
-test 10
-eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int (-2)),
- big_int_of_int 1);;
-test 11
-eq_big_int (sub_big_int (big_int_of_int (-2)) (big_int_of_int (-1)),
- big_int_of_int (-1));;
-test 12
-eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int (-1)),
- big_int_of_int 2);;
-test 13
-eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int 1),
- big_int_of_int (-2));;
-test 14
-eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int (-2)),
- big_int_of_int 3);;
-test 15
-eq_big_int (sub_big_int (big_int_of_int (-2)) (big_int_of_int 1),
- big_int_of_int (-3));;
-test 16
-eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int 2),
- big_int_of_int (-3));;
-test 17
-eq_big_int (sub_big_int (big_int_of_int 2) (big_int_of_int (-1)),
- big_int_of_int 3);;
-
-testing_function "mult_int_big_int";;
-
-test 1
-eq_big_int (mult_int_big_int 0 (big_int_of_int 3), zero_big_int);;
-test 2
-eq_big_int (mult_int_big_int 1 (big_int_of_int 3), big_int_of_int 3);;
-test 3
-eq_big_int (mult_int_big_int 1 zero_big_int, zero_big_int);;
-test 4
-eq_big_int (mult_int_big_int 2 (big_int_of_int 3), big_int_of_int 6);;
-
-testing_function "mult_big_int";;
-
-test 1
-eq_big_int (mult_big_int zero_big_int zero_big_int,
- zero_big_int);;
-test 2
-eq_big_int (mult_big_int (big_int_of_int 2) (big_int_of_int 3),
- big_int_of_int 6);;
-test 3
-eq_big_int (mult_big_int (big_int_of_int 2) (big_int_of_int (-3)),
- big_int_of_int (-6));;
-test 4
-eq_big_int (mult_big_int (big_int_of_string "12724951")
- (big_int_of_string "81749606400"),
- big_int_of_string "1040259735709286400");;
-test 5
-eq_big_int (mult_big_int (big_int_of_string "26542080")
- (big_int_of_string "81749606400"),
- big_int_of_string "2169804593037312000");;
-
-testing_function "quomod_big_int";;
-
-let (quotient, modulo) =
- quomod_big_int (big_int_of_int 1) (big_int_of_int 1) in
- test 1 eq_big_int (quotient, big_int_of_int 1) &&
- test 2 eq_big_int (modulo, zero_big_int);;
-
-let (quotient, modulo) =
- quomod_big_int (big_int_of_int 1) (big_int_of_int (-1)) in
- test 3 eq_big_int (quotient, big_int_of_int (-1)) &&
- test 4 eq_big_int (modulo, zero_big_int);;
-
-let (quotient, modulo) =
- quomod_big_int (big_int_of_int (-1)) (big_int_of_int 1) in
- test 5 eq_big_int (quotient, big_int_of_int (-1)) &&
- test 6 eq_big_int (modulo, zero_big_int);;
-
-let (quotient, modulo) =
- quomod_big_int (big_int_of_int 3) (big_int_of_int 2) in
- test 7 eq_big_int (quotient, big_int_of_int 1) &&
- test 8 eq_big_int (modulo, big_int_of_int 1);;
-
-let (quotient, modulo) =
- quomod_big_int (big_int_of_int 5) (big_int_of_int 3) in
- test 9 eq_big_int (quotient, big_int_of_int 1) &&
- test 10 eq_big_int (modulo, big_int_of_int 2);;
-
-let (quotient, modulo) =
- quomod_big_int (big_int_of_int (-5)) (big_int_of_int 3) in
- test 11 eq_big_int (quotient, big_int_of_int (-2)) &&
- test 12 eq_big_int (modulo, big_int_of_int 1);;
-
-let (quotient, modulo) =
- quomod_big_int (big_int_of_int 1) (big_int_of_int 2) in
- test 13 eq_big_int (quotient, zero_big_int) &&
- test 14 eq_big_int (modulo, big_int_of_int 1);;
-
-let (quotient, modulo) =
- quomod_big_int (big_int_of_int (-1)) (big_int_of_int 3) in
- test 15 eq_big_int (quotient, minus_big_int unit_big_int) &&
- test 16 eq_big_int (modulo, big_int_of_int 2);;
-
-failwith_test 17
-(quomod_big_int (big_int_of_int 1)) zero_big_int
-Division_by_zero
-;;
-
-testing_function "gcd_big_int";;
-
-test 1
-eq_big_int (gcd_big_int zero_big_int zero_big_int,
- zero_big_int);;
-test 2
-eq_big_int (gcd_big_int zero_big_int (big_int_of_int 1),
- big_int_of_int 1);;
-test 3
-eq_big_int (gcd_big_int (big_int_of_int 1) zero_big_int,
- big_int_of_int 1);;
-test 4
-eq_big_int (gcd_big_int (big_int_of_int 1) (big_int_of_int 2),
- big_int_of_int 1);;
-test 5
-eq_big_int (gcd_big_int (big_int_of_int 2) (big_int_of_int 1),
- big_int_of_int 1);;
-test 6
-eq_big_int (gcd_big_int (big_int_of_int 1) (big_int_of_int 1),
- big_int_of_int 1);;
-test 7
-eq_big_int (gcd_big_int (big_int_of_int 9) (big_int_of_int 16),
- big_int_of_int 1);;
-test 8
-eq_big_int (gcd_big_int (big_int_of_int 12) (big_int_of_int 16),
- big_int_of_int 4);;
-
-for i = 9 to 28 do
- let n1 = Random.int 1000000000
- and n2 = Random.int 100000 in
- let _ =
- test i eq
- (int_of_big_int (gcd_big_int (big_int_of_int n1) (big_int_of_int n2)),
- gcd_int n1 n2) in
- ()
-done;;
-
-testing_function "int_of_big_int";;
-
-test 1
-eq_int (int_of_big_int (big_int_of_int 1), 1);;
-
-
-testing_function "is_int_big_int";;
-
-test 1
-eq (is_int_big_int (big_int_of_int 1), true);;
-test 2
-eq (is_int_big_int (big_int_of_int (-1)), true);;
-test 3
-eq (is_int_big_int (succ_big_int (big_int_of_int biggest_int)), false);;
-test 4
-eq (int_of_big_int (big_int_of_int monster_int), monster_int);;
-(* Should be true *)
-test 5
-eq (is_int_big_int (big_int_of_string (string_of_int biggest_int)), true);;
-test 6
-eq (is_int_big_int (big_int_of_string (string_of_int least_int)), true);;
-test 7
-eq (is_int_big_int (big_int_of_string (string_of_int monster_int)), true);;
-
-(* Should be false *)
-(* Successor of biggest_int is not an int *)
-test 8
-eq (is_int_big_int (succ_big_int (big_int_of_int (biggest_int))), false);;
-test 9
-eq (is_int_big_int
- (succ_big_int (succ_big_int (big_int_of_int (biggest_int)))), false);;
-(* Negation of monster_int (as a big_int) is not an int *)
-test 10
-eq (is_int_big_int
- (minus_big_int (big_int_of_string (string_of_int monster_int))), false);;
-
-
-testing_function "sys_string_of_big_int";;
-
-test 1
-eq_string (string_of_big_int (big_int_of_int 1), "1");;
-
-
-testing_function "big_int_of_string";;
-
-test 1
-eq_big_int (big_int_of_string "1", big_int_of_int 1);;
-test 2
-eq_big_int (big_int_of_string "-1", big_int_of_int (-1));;
-test 4
-eq_big_int (big_int_of_string "0", zero_big_int);;
-
-failwith_test 5 big_int_of_string "sdjdkfighdgf"
- (Failure "invalid digit");;
-
-test 6
-eq_big_int (big_int_of_string "123", big_int_of_int 123);;
-test 7
-eq_big_int (big_int_of_string "3456", big_int_of_int 3456);;
-
-test 9
-eq_big_int (big_int_of_string "-3456", big_int_of_int (-3456));;
-
-
-let implode = List.fold_left (^) "";; (* Au diable l'efficacite *)
-
-let l = rev [
-"174679877494298468451661416292903906557638850173895426081611831060970135303";
-"044177587617233125776581034213405720474892937404345377707655788096850784519";
-"539374048533324740018513057210881137248587265169064879918339714405948322501";
-"445922724181830422326068913963858377101914542266807281471620827145038901025";
-"322784396182858865537924078131032036927586614781817695777639491934361211399";
-"888524140253852859555118862284235219972858420374290985423899099648066366558";
-"238523612660414395240146528009203942793935957539186742012316630755300111472";
-"852707974927265572257203394961525316215198438466177260614187266288417996647";
-"132974072337956513457924431633191471716899014677585762010115338540738783163";
-"739223806648361958204720897858193606022290696766988489073354139289154127309";
-"916985231051926209439373780384293513938376175026016587144157313996556653811";
-"793187841050456120649717382553450099049321059330947779485538381272648295449";
-"847188233356805715432460040567660999184007627415398722991790542115164516290";
-"619821378529926683447345857832940144982437162642295073360087284113248737998";
-"046564369129742074737760485635495880623324782103052289938185453627547195245";
-"688272436219215066430533447287305048225780425168823659431607654712261368560";
-"702129351210471250717394128044019490336608558608922841794819375031757643448";
-"32"
-] in
-
-let bi1 = big_int_of_string (implode (rev l)) in
-
-let bi2 = big_int_of_string (implode (rev ("3" :: tl l))) in
-
-test 10
-eq_big_int (bi1, (add_big_int (mult_big_int bi2 (big_int_of_string "10"))
- (big_int_of_string "2")))
-(* test 11
- &&
-eq_big_int (bi1, (add_big_int (mult_big_int bi2 (big_int_of_string "10e0"))
- (big_int_of_string "20e-1"))) &&
-test 12
-eq_big_int (minus_big_int bi1,
- (add_big_int (mult_big_int bi2 (big_int_of_string "-10e0"))
- (big_int_of_string "-20e-1"))) &&
-test 13
-eq_big_int (bi1, (add_big_int (mult_big_int bi2 (big_int_of_string "+10e0"))
- (big_int_of_string "+20e-1"))) &&
-test 14
-eq_big_int (minus_big_int bi1,
- (add_big_int (mult_big_int bi2 (big_int_of_string "-10e+0"))
- (big_int_of_string "-20e-1"))) &&
-test 15
-eq_big_int (minus_big_int bi1,
- (add_big_int (mult_big_int bi2 (big_int_of_string "-1e+1"))
- (big_int_of_string "-2e-0"))) &&
-test 16
-eq_big_int (minus_big_int bi1,
- (add_big_int (mult_big_int bi2 (big_int_of_string "-0.1e+2"))
- (big_int_of_string "-2.0e-0"))) &&
-test 17
-eq_big_int (minus_big_int bi1,
- (add_big_int (mult_big_int bi2 (big_int_of_string "-1.000e+1"))
- (big_int_of_string "-0.02e2")))*)
-;;
-
-testing_function "power_base_int";;
-
-test 1
-eq_big_int (big_int_of_nat (power_base_int 10 0), unit_big_int)
-;;
-test 2
-eq_big_int (big_int_of_nat (power_base_int 10 8), big_int_of_int 100000000)
-;;
-test 3
-eq_big_int (big_int_of_nat (power_base_int 2 (length_of_int + 2)),
- big_int_of_nat (let nat = make_nat 2 in
- set_digit_nat nat 1 1;
- nat))
-;;
-
-testing_function "base_power_big_int";;
-
-test 1
-eq_big_int (base_power_big_int 10 0 (big_int_of_int 2), big_int_of_int 2);;
-test 2
-eq_big_int (base_power_big_int 10 2 (big_int_of_int 2), big_int_of_int 200);;
-test 3
-eq_big_int (base_power_big_int 10 1 (big_int_of_int 123), big_int_of_int 1230)
-;;
-
-testing_function "power_int_positive_big_int";;
-
-test 1
-eq_big_int (power_int_positive_big_int 2 (big_int_of_int 10),
- big_int_of_int 1024);;
-test 2
-eq_big_int
- (power_int_positive_big_int 2 (big_int_of_int 65),
- big_int_of_string "36893488147419103232");;
-
-test 3
-eq_big_int
- (power_int_positive_big_int 3 (big_int_of_string "47"),
- big_int_of_string "26588814358957503287787");;
-
-
-testing_function "power_big_int_positive_big_int";;
-
-test 1
-eq_big_int
- (power_big_int_positive_big_int (big_int_of_int 2) (big_int_of_int 10),
- big_int_of_int 1024);;
-
-test 2
-eq_big_int
- (power_big_int_positive_big_int (big_int_of_int 2) (big_int_of_int 65),
- big_int_of_string "36893488147419103232");;
-
-test 3
-eq_big_int
- (power_big_int_positive_big_int
- (big_int_of_string "3") (big_int_of_string "47"),
- big_int_of_string "26588814358957503287787");;
-
-testing_function "square_big_int";;
-
-test 1 eq_big_int
- (square_big_int (big_int_of_string "0"), big_int_of_string "0");;
-test 2 eq_big_int
- (square_big_int (big_int_of_string "1"), big_int_of_string "1");;
-test 3 eq_big_int
- (square_big_int (big_int_of_string "-1"), big_int_of_string "1");;
-test 4 eq_big_int
- (square_big_int (big_int_of_string "-7"), big_int_of_string "49");;
diff --git a/otherlibs/num/test/test_bng.c b/otherlibs/num/test/test_bng.c
deleted file mode 100644
index 4fedcdfd56..0000000000
--- a/otherlibs/num/test/test_bng.c
+++ /dev/null
@@ -1,408 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 2003 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Test harness for the BNG primitives. Use BigNum as a reference. */
-
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-
-#include <BigNum.h>
-
-#include "../../../config/m.h"
-#include "bng.h"
-
-#if defined(__GNUC__) && BNG_ASM_LEVEL > 0
-#if defined(BNG_ARCH_ia32)
-#include "bng_ia32.c"
-#elif defined(BNG_ARCH_amd64)
-#include "bng_amd64.c"
-#elif defined(BNG_ARCH_ppc)
-#include "bng_ppc.c"
-#elif defined (BNG_ARCH_alpha)
-#include "bng_alpha.c"
-#elif defined (BNG_ARCH_sparc)
-#include "bng_sparc.c"
-#elif defined (BNG_ARCH_mips)
-#include "bng_mips.c"
-#endif
-#endif
-
-#include "bng_digit.c"
-
-/* Random generator for digits. Can either generate "true" PRN numbers
- or numbers consisting of long sequences of 0 and 1 bits. */
-
-static int rand_skewed = 0;
-static int rand_runlength = 0;
-static int rand_bit = 0;
-static bngdigit rand_seed = 0;
-
-static bngdigit randdigit(void)
-{
- bngdigit res;
- int i;
-
- if (rand_skewed) {
- for (i = 0, res = 0; i < BNG_BITS_PER_DIGIT; i++) {
- if (rand_runlength == 0) {
- rand_runlength = 1 + (rand() % (2 * BNG_BITS_PER_DIGIT));
- rand_bit ^= 1;
- }
- res = (res << 1) | rand_bit;
- rand_runlength--;
- }
- return res;
- } else {
- rand_seed = rand_seed * 69069 + 25173;
- return rand_seed;
- }
-}
-
-/* Test the operations on digits.
- This uses double-width integer arithmetic as reference.
- This is only available on 32-bit platforms that support a 64-bit int type.
-*/
-
-#if defined(ARCH_UINT64_TYPE) && !defined(ARCH_SIXTYFOUR)
-
-typedef ARCH_UINT64_TYPE dbldigit;
-
-static int test_digit_ops(int i)
-{
- bngdigit a1, a2, a3, r1, r2;
- int ci, co, n;
-
- a1 = randdigit();
- a2 = randdigit();
- a3 = randdigit();
- ci = randdigit() & 1;
-
- BngAdd2(r1,co,a1,a2);
- if ((dbldigit) r1 + ((dbldigit) co << BNG_BITS_PER_DIGIT)
- != (dbldigit) a1 + (dbldigit) a2) {
- printf("Round %d, BngAdd2(%lx,%x,%lx, %lx)\n", i, r1, co, a1, a2);
- return 1;
- }
-
- BngAdd2Carry(r1,co,a1,a2,ci);
- if ((dbldigit) r1 + ((dbldigit) co << BNG_BITS_PER_DIGIT)
- != (dbldigit) a1 + (dbldigit) a2 + (dbldigit) ci) {
- printf("Round %d, BngAdd2Carry(%lx,%x,%lx, %lx, %x)\n", i, r1, co, a1, a2, ci);
- return 1;
- }
-
- r2 = 0;
- BngAdd3(r1,r2,a1,a2,a3);
- if ((dbldigit) r1 + ((dbldigit) r2 << BNG_BITS_PER_DIGIT)
- != (dbldigit) a1 + (dbldigit) a2 + (dbldigit) a3) {
- printf("Round %d, BngAdd3(%lx,%x,%lx, %lx, %lx)\n", i, r1, co, a1, a2, a3);
- return 1;
- }
-
- BngSub2(r1,co,a1,a2);
- if ((dbldigit) r1 - ((dbldigit) co << BNG_BITS_PER_DIGIT)
- != (dbldigit) a1 - (dbldigit) a2) {
- printf("Round %d, BngSub2(%lx,%x,%lx, %lx)\n", i, r1, co, a1, a2);
- return 1;
- }
-
- BngSub2Carry(r1,co,a1,a2,ci);
- if ((dbldigit) r1 - ((dbldigit) co << BNG_BITS_PER_DIGIT)
- != (dbldigit) a1 - (dbldigit) a2 - (dbldigit) ci) {
- printf("Round %d, BngSub2Carry(%lx,%x,%lx, %lx, %x)\n", i, r1, co, a1, a2, ci);
- return 1;
- }
-
- r2 = 0;
- BngSub3(r1,r2,a1,a2,a3);
- if ((dbldigit) r1 - ((dbldigit) r2 << BNG_BITS_PER_DIGIT)
- != (dbldigit) a1 - (dbldigit) a2 - (dbldigit) a3) {
- printf("Round %d, BngSub3(%lx,%x,%lx, %lx, %lx)\n", i, r1, co, a1, a2, a3);
- return 1;
- }
-
- BngMult(r1,r2,a1,a2);
- if ((((dbldigit) r1 << BNG_BITS_PER_DIGIT) | (dbldigit) r2)
- != (dbldigit) a1 * (dbldigit) a2) {
- printf("Round %d, BngMult(%lx,%lx,%lx, %lx)\n", i, r1, r2, a1, a2);
- return 1;
- }
-
- /* Make sure a3 is normalized */
- a3 |= 1L << (BNG_BITS_PER_DIGIT - 1);
- if (a1 < a3) {
- BngDiv(r1,r2,a1,a2,a3);
- if (r1 != (((dbldigit) a1 << BNG_BITS_PER_DIGIT) | (dbldigit) a2) / a3
- ||
- r2 != (((dbldigit) a1 << BNG_BITS_PER_DIGIT) | (dbldigit) a2) % a3)
- {
- printf("Round %d, BngDiv(%lx,%lx,%lx, %lx, %lx)\n", i, r1, r2, a1, a2, a3);
- return 1;
- }
- }
-
- n = bng_leading_zero_bits(a1);
- if (a1 == 0) {
- if (n != BNG_BITS_PER_DIGIT) {
- printf("Round %d, bng_leading_zero(bits(%lx) = %d", i, a1, n);
- return 1;
- }
- } else {
- if ((a1 << n) >> n != a1 ||
- ((a1 << n) & (1L << (BNG_BITS_PER_DIGIT - 1))) == 0) {
- printf("Round %d, bng_leading_zero(bits(%lx) = %d", i, a1, n);
- return 1;
- }
- }
- return 0;
-}
-
-#endif
-
-/* Test the bng operations. Use BigNum as a reference. */
-
-#define MAX_DIGITS 32
-
-void randbng(bng a, bngsize n)
-{
- int i;
- for (i = 0; i < n; i++) a[i] = randdigit();
-}
-
-char * bng2string(bng a, bngsize n)
-{
- char * buffer = malloc((BNG_BITS_PER_DIGIT / 4 + 1) * MAX_DIGITS);
- char temp[BNG_BITS_PER_DIGIT / 4 + 1];
- int i;
-
- buffer[0] = 0;
- for (i = n - 1; i >= 0; i--) {
- sprintf(temp, "%lx", a[i]);
- strcat(buffer, temp);
- if (i > 0) strcat(buffer, "_");
- }
- return buffer;
-}
-
-int bngsame(bng a, bng b, bngsize n)
-{
- int i;
- for (i = 0; i < n; i++)
- if (a[i] != b[i]) return 0;
- return 1;
-}
-
-int test_bng_ops(int i)
-{
- bngsize p, q;
- bngdigit a[MAX_DIGITS], b[MAX_DIGITS], c[MAX_DIGITS], d[MAX_DIGITS];
- bngdigit f[2 * MAX_DIGITS], g[2 * MAX_DIGITS], h[2 * MAX_DIGITS];
- bngcarry ci, co, cp;
- bngdigit dg, do_, dp;
- int amount;
-
- /* Determine random lengths p and q between 1 and MAX_DIGITS.
- Ensure p >= q. */
- p = 1 + (rand() % MAX_DIGITS);
- q = 1 + (rand() % MAX_DIGITS);
- if (q > p) { bngsize t = p; p = q; q = t; }
-
- /* Randomly generate bignums a of size p, b of size q */
- randbng(a, p);
- randbng(b, q);
- ci = rand() & 1;
-
- /* comparison */
- co = bng_compare(a, p, b, q);
- cp = BnnCompare(a, p, b, q);
- if (co != cp) {
- printf("Round %d, bng_compare(%s, %ld, %s, %ld) = %d\n",
- i, bng2string(a, p), p, bng2string(b, q), q, co);
- return 1;
- }
- co = bng_compare(b, q, a, p);
- cp = BnnCompare(b, q, a, p);
- if (co != cp) {
- printf("Round %d, bng_compare(%s, %ld, %s, %ld) = %d\n",
- i, bng2string(b, q), q, bng2string(a, p), p, co);
- return 1;
- }
- /* add carry */
- bng_assign(c, a, p);
- co = bng_add_carry(c, p, ci);
- BnnAssign(d, a, p);
- cp = BnnAddCarry(d, p, ci);
- if (co != cp || !bngsame(c, d, p)) {
- printf("Round %d, bng_add_carry(%s, %ld, %d) -> %s, %d\n",
- i, bng2string(a, p), p, ci, bng2string(c, p), co);
- return 1;
- }
- /* add */
- bng_assign(c, a, p);
- co = bng_add(c, p, b, q, ci);
- BnnAssign(d, a, p);
- cp = BnnAdd(d, p, b, q, ci);
- if (co != cp || !bngsame(c, d, p)) {
- printf("Round %d, bng_add(%s, %ld, %s, %ld, %d) -> %s, %d\n",
- i, bng2string(a, p), p, bng2string(b, q), q, ci,
- bng2string(c, p), co);
- return 1;
- }
- /* sub carry */
- bng_assign(c, a, p);
- co = bng_sub_carry(c, p, ci);
- BnnAssign(d, a, p);
- cp = BnnSubtractBorrow(d, p, ci ^ 1) ^ 1;
- if (co != cp || !bngsame(c, d, p)) {
- printf("Round %d, bng_sub_carry(%s, %ld, %d) -> %s, %d\n",
- i, bng2string(a, p), p, ci, bng2string(c, p), co);
- return 1;
- }
- /* sub */
- bng_assign(c, a, p);
- co = bng_sub(c, p, b, q, ci);
- BnnAssign(d, a, p);
- cp = BnnSubtract(d, p, b, q, ci ^ 1) ^ 1;
- if (co != cp || !bngsame(c, d, p)) {
- printf("Round %d, bng_sub(%s, %ld, %s, %ld, %d) -> %s, %d\n",
- i, bng2string(a, p), p, bng2string(b, q), q, ci,
- bng2string(c, p), co);
- return 1;
- }
- /* shift left */
- amount = rand() % BNG_BITS_PER_DIGIT;
- bng_assign(c, a, p);
- do_ = bng_shift_left(c, p, amount);
- BnnAssign(d, a, p);
- dp = BnnShiftLeft(d, p, amount);
- if (do_ != dp || !bngsame(c, d, p)) {
- printf("Round %d, bng_shift_left(%s, %ld, %d) -> %s, %ld\n",
- i, bng2string(a, p), p, amount, bng2string(c, p), do_);
- return 1;
- }
- /* shift right */
- amount = rand() % BNG_BITS_PER_DIGIT;
- bng_assign(c, a, p);
- do_ = bng_shift_right(c, p, amount);
- BnnAssign(d, a, p);
- dp = BnnShiftRight(d, p, amount);
- if (do_ != dp || !bngsame(c, d, p)) {
- printf("Round %d, bng_shift_right(%s, %ld, %d) -> %s, %ld\n",
- i, bng2string(a, p), p, amount, bng2string(c, p), do_);
- return 1;
- }
- /* mult_add_digit */
- dg = randdigit();
- if (p >= q + 1) {
- bng_assign(c, a, p);
- co = bng_mult_add_digit(c, p, b, q, dg);
- BnnAssign(d, a, p);
- cp = BnnMultiplyDigit(d, p, b, q, dg);
- if (co != cp || !bngsame(c, d, p)) {
- printf("Round %d, bng_mult_add_digit(%s, %ld, %s, %ld, %ld) -> %s, %d\n",
- i, bng2string(a, p), p, bng2string(b, q), q, dg,
- bng2string(c, p), co);
- return 1;
- }
- }
- /* mult_sub_digit */
- dg = randdigit();
- bng_assign(c, a, p);
- do_ = bng_mult_add_digit(c, p, b, q, dg);
- bng_assign(d, c, p);
- dp = bng_mult_sub_digit(d, p, b, q, dg);
- if (do_ != dp || !bngsame(a, d, p)) {
- printf("Round %d, bng_mult_sub_digit(%s, %ld, %s, %ld, %ld) -> %s, %ld\n",
- i, bng2string(c, p), p, bng2string(b, q), q, dg,
- bng2string(d, p), dp);
- return 1;
- }
- /* mult_add */
- randbng(f, 2*p);
- bng_assign(g, f, 2*p);
- co = bng_mult_add(g, 2*p, a, p, b, q);
- BnnAssign(h, f, 2*p);
- cp = BnnMultiply(h, 2*p, a, p, b, q);
- if (co != cp || !bngsame(g, h, 2*p)) {
- printf("Round %d, bng_mult_add(%s, %ld, %s, %ld, %s, %ld) -> %s, %d\n",
- i, bng2string(f, 2*p), 2*p,
- bng2string(a, p), p,
- bng2string(b, q), q,
- bng2string(g, 2*p), co);
- return 1;
- }
- /* square_add */
- randbng(f, 2*p);
- bng_assign(g, f, 2*p);
- co = bng_square_add(g, 2*p, b, q);
- BnnAssign(h, f, 2*p);
- cp = BnnAdd(h, 2*p, h, 2*p);
- cp += BnnMultiply(h, 2*p, b, q, b, q);
- if (co != cp || !bngsame(g, h, 2*p)) {
- printf("Round %d, bng_square_add(%s, %ld, %s, %ld) -> %s, %d\n",
- i, bng2string(f, 2*p), 2*p,
- bng2string(b, q), q,
- bng2string(g, 2*p), co);
- return 1;
- }
- /* div_rem_digit */
- if (a[p - 1] < dg) {
- do_ = bng_div_rem_digit(c, a, p, dg);
- dp = BnnDivideDigit(d, a, p, dg);
- if (do_ != dp || !bngsame(c, d, p-1)) {
- printf("Round %d, bng_div_rem_digit(%s, %s, %ld, %lx) -> %lx\n",
- i, bng2string(d, p-1), bng2string(a, p), p, dg, do_);
- return 1;
- }
- }
- /* div_rem */
- if (p > q && a[p - 1] < b[q - 1]) {
- bng_assign(c, a, p);
- bng_div_rem(c, p, b, q);
- BnnAssign(d, a, p);
- BnnDivide(d, p, b, q);
- if (!bngsame(c, d, p)) {
- printf("Round %d, bng_div_rem(%s, %ld, %s, %ld) -> %s, %s\n",
- i, bng2string(a, p), p, bng2string(b, q), q,
- bng2string(c + q, p - q),
- bng2string(c, q));
- return 1;
- }
- }
- return 0;
-}
-
-int main(int argc, char ** argv)
-{
- int niter = 100000;
- int i, err;
-
- bng_init();
- if (argc >= 2) niter = atoi(argv[1]);
-#if defined(ARCH_UINT64_TYPE) && !defined(ARCH_SIXTYFOUR)
- printf("Testing single-digit operations\n");
- for (err = 0, i = 1; i < niter; i++) err += test_digit_ops(i);
- printf("%d rounds performed, %d errors found\n", niter, err);
-#endif
- printf("Testing bignum operations\n");
- for (err = 0, i = 1; i < niter; i++) err += test_bng_ops(i);
- printf("%d rounds performed, %d errors found\n", niter, err);
- printf("Testing bignum operations with skewed PRNG\n");
- rand_skewed = 1;
- for (err = 0, i = 1; i < niter; i++) err += test_bng_ops(i);
- printf("%d rounds performed, %d errors found\n", niter, err);
- return 0;
-}
diff --git a/otherlibs/num/test/test_io.ml b/otherlibs/num/test/test_io.ml
deleted file mode 100644
index 1df11a5fe6..0000000000
--- a/otherlibs/num/test/test_io.ml
+++ /dev/null
@@ -1,64 +0,0 @@
-open Test
-open Nat
-open Big_int
-open Num
-
-let intern_extern obj =
- let f = Filename.temp_file "testnum" ".data" in
- let oc = open_out_bin f in
- output_value oc obj;
- close_out oc;
- let ic = open_in_bin f in
- let res = input_value ic in
- close_in ic;
- Sys.remove f;
- res
-;;
-
-testing_function "output_value/input_value on nats";;
-
-let equal_nat n1 n2 =
- eq_nat n1 0 (length_nat n1) n2 0 (length_nat n2)
-;;
-
-List.iter
- (fun (i, s) ->
- let n = nat_of_string s in
- ignore(test i equal_nat (n, intern_extern n)))
- [1, "0";
- 2, "1234";
- 3, "8589934592";
- 4, "340282366920938463463374607431768211455";
- 5, String.make 100 '3';
- 6, String.make 1000 '9';
- 7, String.make 20000 '8']
-;;
-
-testing_function "output_value/input_value on big ints";;
-
-List.iter
- (fun (i, s) ->
- let b = big_int_of_string s in
- ignore(test i eq_big_int (b, intern_extern b)))
- [1, "0";
- 2, "1234";
- 3, "-1234";
- 4, "1040259735709286400";
- 5, "-" ^ String.make 20000 '7']
-;;
-
-testing_function "output_value/input_value on nums";;
-
-List.iter
- (fun (i, s) ->
- let n = num_of_string s in
- ignore(test i eq_num (n, intern_extern n)))
- [1, "0";
- 2, "1234";
- 3, "-1234";
- 4, "159873568791325097646845892426782";
- 5, "1/4";
- 6, "-15/2";
- 7, "159873568791325097646845892426782/24098772507410987265987";
- 8, String.make 10000 '3' ^ "/" ^ String.make 5000 '7']
-;;
diff --git a/otherlibs/num/test/test_nats.ml b/otherlibs/num/test/test_nats.ml
deleted file mode 100644
index bfb26f1027..0000000000
--- a/otherlibs/num/test/test_nats.ml
+++ /dev/null
@@ -1,142 +0,0 @@
-open Test;;
-open Nat;;
-
-(* Can compare nats less than 2**32 *)
-let equal_nat n1 n2 =
- eq_nat n1 0 (num_digits_nat n1 0 1)
- n2 0 (num_digits_nat n2 0 1);;
-
-testing_function "num_digits_nat";;
-
-test (-1) eq (false,not true);;
-test 0 eq (true,not false);;
-
-test 1
-eq_int
-(let r = make_nat 2 in
- set_digit_nat r 1 1;
- num_digits_nat r 0 1,1);;
-
-testing_function "length_nat";;
-
-test 1
-eq_int
-(let r = make_nat 2 in
- set_digit_nat r 0 1;
- length_nat r,2);;
-
-testing_function "equal_nat";;
-
-let zero_nat = make_nat 1 in
-
-test 1
-equal_nat (zero_nat,zero_nat);;
-test 2
-equal_nat (nat_of_int 1,nat_of_int 1);;
-
-test 3
-equal_nat (nat_of_string "2",nat_of_string "2");;
-test 4
-eq (equal_nat (nat_of_string "2")(nat_of_string "3"),false);;
-
-testing_function "incr_nat";;
-
-let zero = nat_of_int 0 in
-let res = incr_nat zero 0 1 1 in
- test 1
- equal_nat (zero, nat_of_int 1) &&
- test 2
- eq (res,0);;
-
-let n = nat_of_int 1 in
-let res = incr_nat n 0 1 1 in
- test 3
- equal_nat (n, nat_of_int 2) &&
- test 4
- eq (res,0);;
-
-
-testing_function "decr_nat";;
-
-let n = nat_of_int 1 in
-let res = decr_nat n 0 1 0 in
- test 1
- equal_nat (n, nat_of_int 0) &&
- test 2
- eq (res,1);;
-
-let n = nat_of_int 2 in
-let res = decr_nat n 0 1 0 in
- test 3
- equal_nat (n, nat_of_int 1) &&
- test 4
- eq (res,1);;
-
-testing_function "is_zero_nat";;
-
-let n = nat_of_int 1 in
-test 1 eq (is_zero_nat n 0 1,false) &&
-test 2 eq (is_zero_nat (make_nat 1) 0 1, true) &&
-test 3 eq (is_zero_nat (make_nat 2) 0 2, true) &&
-(let r = make_nat 2 in
- set_digit_nat r 1 1;
- test 4 eq (is_zero_nat r 0 1, true))
-;;
-
-testing_function "string_of_nat";;
-
-let n = make_nat 4;;
-
-test 1 eq_string (string_of_nat n, "0");;
-
-complement_nat n 0 (if sixtyfour then 2 else 4);;
-
-test 2 eq_string (string_of_nat n, "340282366920938463463374607431768211455");;
-
-testing_function "string_of_nat && nat_of_string";;
-
-for i = 1 to 20 do
- let s = String.make i '0' in
- String.set s 0 '1';
- test i eq_string (string_of_nat (nat_of_string s), s)
-done;;
-
-let s = "3333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333" in
-test 21 equal_nat (
-nat_of_string s,
-(let nat = make_nat 15 in
- set_digit_nat nat 0 3;
- mult_digit_nat nat 0 15
- (nat_of_string (String.sub s 0 135)) 0 14
- (nat_of_int 10) 0;
- nat))
-;;
-
-test 22 eq_string (string_of_nat(nat_of_string "1073741824"), "1073741824");;
-
-testing_function "gcd_nat";;
-
-for i = 1 to 20 do
- let n1 = Random.int 1000000000
- and n2 = Random.int 100000 in
- let nat1 = nat_of_int n1
- and nat2 = nat_of_int n2 in
- gcd_nat nat1 0 1 nat2 0 1;
- test i eq (int_of_nat nat1, Int_misc.gcd_int n1 n2)
-done
-;;
-
-testing_function "sqrt_nat";;
-
-test 1 equal_nat (sqrt_nat (nat_of_int 1) 0 1, nat_of_int 1);;
-test 2 equal_nat (let n = nat_of_string "8589934592" in
- sqrt_nat n 0 (length_nat n),
- nat_of_string "92681");;
-test 3 equal_nat (let n = nat_of_string "4294967295" in
- sqrt_nat n 0 (length_nat n),
- nat_of_string "65535");;
-test 4 equal_nat (let n = nat_of_string "18446744065119617025" in
- sqrt_nat n 0 (length_nat n),
- nat_of_string "4294967295");;
-test 5 equal_nat (sqrt_nat (nat_of_int 15) 0 1,
- nat_of_int 3);;
diff --git a/otherlibs/num/test/test_nums.ml b/otherlibs/num/test/test_nums.ml
deleted file mode 100644
index 424285808b..0000000000
--- a/otherlibs/num/test/test_nums.ml
+++ /dev/null
@@ -1,220 +0,0 @@
-open Test;;
-open Nat;;
-open Big_int;;
-open Ratio;;
-open Int_misc;;
-open Num;;
-open Arith_status;;
-
-testing_function "add_num";;
-
-test 1
-eq_num (add_num (Int 1) (Int 3), Int 4);;
-test 2
-eq_num (add_num (Int 1) (Big_int (big_int_of_int 3)), Int 4);;
-test 3
-eq_num (add_num (Int 1) (Ratio (ratio_of_string "3/4")),
- Ratio (ratio_of_string "7/4"));;
-test 4
-eq_num (add_num (Big_int (big_int_of_int 1)) (Ratio (ratio_of_string "3/4")),
- Ratio (ratio_of_string "7/4"));;
-test 5
-eq_num (add_num (Big_int (big_int_of_int 1)) (Big_int (big_int_of_int 3)),
- Int 4);;
-test 6
-eq_num (add_num (Big_int (big_int_of_int 1)) (Ratio (ratio_of_string "3/4")),
- Ratio (ratio_of_string "7/4"));;
-test 7
-eq_num (add_num (Ratio (ratio_of_string "2/3")) (Ratio (ratio_of_string "3/4")),
- Ratio (ratio_of_string "17/12"));;
-test 8
-eq_num (add_num (Int least_int) (Int 1),
- Int (- (pred biggest_int)));;
-test 9
-eq_num (add_num (Int biggest_int) (Int 1),
- Big_int (minus_big_int (pred_big_int (big_int_of_int least_int))));;
-
-testing_function "sub_num";;
-
-test 1
-eq_num (sub_num (Int 1) (Int 3), Int (-2));;
-test 2
-eq_num (sub_num (Int 1) (Big_int (big_int_of_int 3)), Int (-2));;
-test 3
-eq_num (sub_num (Int 1) (Ratio (ratio_of_string "3/4")),
- Ratio (ratio_of_string "1/4"));;
-test 4
-eq_num (sub_num (Big_int (big_int_of_int 1)) (Ratio (ratio_of_string "3/4")),
- Ratio (ratio_of_string "1/4"));;
-test 5
-eq_num (sub_num (Big_int (big_int_of_int 1)) (Big_int (big_int_of_int 3)),
- Int (-2));;
-test 7
-eq_num (sub_num (Big_int (big_int_of_int 1)) (Ratio (ratio_of_string "3/4")),
- Ratio (ratio_of_string "1/4"));;
-test 8
-eq_num (sub_num (Ratio (ratio_of_string "2/3")) (Ratio (ratio_of_string "3/4")),
- Ratio (ratio_of_string "-1/12"));;
-test 9
-eq_num (sub_num (Int least_int) (Int (-1)),
- Int (- (pred biggest_int)));;
-test 10
-eq_num (sub_num (Int (-1)) (Int biggest_int), pred_num (Int least_int));;
-
-testing_function "mult_num";;
-
-test 1
-eq_num (mult_num (Int 2) (Int 3), Int 6);;
-test 2
-eq_num (mult_num (Int 127) (Int (int_of_string "257")),
- Int (int_of_string "32639"));;
-test 3
-eq_num (mult_num (Int 257) (Int (int_of_string "260")),
- Big_int (big_int_of_string "66820"));;
-test 4
-eq_num (mult_num (Int 2) (Big_int (big_int_of_int 3)), Int 6);;
-test 5
-eq_num (mult_num (Int 10) (Ratio (ratio_of_string "3/4")),
- Ratio (ratio_of_string "15/2"));;
-test 6
-eq_num (mult_num (Big_int (big_int_of_int 10)) (Ratio (ratio_of_string "3/4")),
- Ratio (ratio_of_string "15/2"));;
-test 7
-eq_num (mult_num (Big_int (big_int_of_int 2)) (Big_int (big_int_of_int 3)),
- Int 6);;
-test 8
-eq_num (mult_num (Big_int (big_int_of_int 10)) (Ratio (ratio_of_string "3/4")),
- Ratio (ratio_of_string "15/2"));;
-test 9
-eq_num (mult_num (Ratio (ratio_of_string "2/3")) (Ratio (ratio_of_string "3/4"))
- , Ratio (ratio_of_string "1/2"));;
-
-testing_function "div_num";;
-
-test 1
-eq_num (div_num (Int 6) (Int 3), Int 2);;
-test 2
-eq_num (div_num (Int (int_of_string "32639"))
- (Int (int_of_string "257")), Int 127);;
-test 3
-eq_num (div_num (Big_int (big_int_of_string "66820"))
- (Int (int_of_string "257")),
- Int 260);;
-test 4
-eq_num (div_num (Int 6) (Big_int (big_int_of_int 3)), Int 2);;
-test 5
-eq_num (div_num (Ratio (ratio_of_string "15/2"))
- (Int 10),
- Ratio (ratio_of_string "3/4"));;
-test 6
-eq_num (div_num (Big_int (big_int_of_int 6)) (Big_int (big_int_of_int 3)),
- Int 2);;
-test 7
-eq_num (div_num (Ratio (ratio_of_string "15/2"))
- (Big_int (big_int_of_int 10)),
- Ratio (ratio_of_string "3/4"));;
-test 8
-eq_num (div_num (Ratio (ratio_of_string "15/2"))
- (Ratio (ratio_of_string "3/4")),
- Big_int (big_int_of_int 10));;
-test 9
-eq_num (div_num (Ratio (ratio_of_string "1/2"))
- (Ratio (ratio_of_string "3/4")),
- Ratio (ratio_of_string "2/3"));;
-
-testing_function "is_integer_num";;
-
-test 1
-eq (is_integer_num (Int 3),true);;
-test 2
-eq (is_integer_num (Big_int (big_int_of_string "1234567890")),true);;
-test 3
-eq (not (is_integer_num (Ratio (ratio_of_string "1/2"))),true);;
-test 4
-eq (is_integer_num (Ratio (ratio_of_string "1073774590/32770")),true);;
-
-testing_function "num_of_ratio";;
-
-test 1
-eq_num (num_of_ratio (ratio_of_string "4/2"), Int 2);;
-test 2
-eq_num (num_of_ratio (ratio_of_string "11811160075/11"),
- Big_int (big_int_of_string "1073741825"));;
-test 3
-eq_num (num_of_ratio (ratio_of_string "123456789012/1234"),
- Ratio (ratio_of_string "61728394506/617"));;
-
-testing_function "num_of_string";;
-
-test 1
-eq_num (num_of_string "123/3456", Ratio (ratio_of_string "123/3456"));;
-(*********
-test 2
-eq_num (num_of_string "12.3/34.56", Ratio (ratio_of_string "1230/3456"));;
-test 3
-eq_num (num_of_string "1.23/325.6", Ratio (ratio_of_string "123/32560"));;
-test 4
-eq_num (num_of_string "12.3/345.6", Ratio (ratio_of_string "123/3456"));;
-set_error_when_null_denominator false;;
-test 5
-eq_num (num_of_string "12.3/0.0", Ratio (ratio_of_string "123/0"));;
-test 6
-eq_num (num_of_string "0/0", Ratio (ratio_of_string "0/0"));;
-set_error_when_null_denominator true;;
-*********)
-test 7
-eq_num (num_of_string "1234567890",
- Big_int (big_int_of_string "1234567890"));;
-test 8
-eq_num (num_of_string "12345", Int (int_of_string "12345"));;
-(*********
-test 9
-eq_num (num_of_string "0.23", Ratio (ratio_of_string "23/100"));;
-test 10
-eq_num (num_of_string "0.23", Ratio (ratio_of_string "0.23/1"));;
-********)
-
-failwith_test 11
-num_of_string ("frlshjkurty") (Failure "num_of_string");;
-
-(*******
-
-testing_function "immediate numbers";;
-
-standard arith false;;
-
-let x = (1/2) in
-test 0 eq_string (string_of_num x, "1/2");;
-
-let y = 12345678901 in
-test 1 eq_string (string_of_num y, "12345678901");;
-testing_function "immediate numbers";;
-
-let x = (1/2) in
-test 0 eq_string (string_of_num x, "1/2");;
-
-let y = 12345678901 in
-test 1 eq_string (string_of_num y, "12345678901");;
-
-testing_function "pattern_matching on nums";;
-
-let f1 = function 0 -> true | _ -> false;;
-
-test 1 eq (f1 0, true);;
-
-test 2 eq (f1 1, false);;
-
-test 3 eq (f1 (0/1), true);;
-
-test 4 eq (f1 (let n = num_of_string "2000000000000000000000000" in n-n) ,
- true);;
-
-test 5 eq (f1 (let n = num_of_string "2000000000000000000000000" in n/n-1) ,
- true);;
-
-test 6 eq (f1 (let n = num_of_string "2000000000000000000000000" in n+1) ,
- false);;
-
-test 7 eq (f1 (1/2), false);;
-
-**************)
diff --git a/otherlibs/num/test/test_ratios.ml b/otherlibs/num/test/test_ratios.ml
deleted file mode 100644
index 45fdce8b15..0000000000
--- a/otherlibs/num/test/test_ratios.ml
+++ /dev/null
@@ -1,928 +0,0 @@
-open Test;;
-open Nat;;
-open Big_int;;
-open Ratio;;
-open Int_misc;;
-open Arith_status;;
-
-set_error_when_null_denominator false;;
-
-let infinite_failure = "infinite or undefined rational number";;
-
-testing_function "create_ratio";;
-
-let r = create_ratio (big_int_of_int 1) (big_int_of_int (-2)) in
-test 1 eq_big_int (numerator_ratio r, big_int_of_int (-1)) &&
-test 2 eq_big_int (denominator_ratio r, big_int_of_int 2);;
-
-let r = create_ratio (big_int_of_int 2) (big_int_of_int 3) in
-test 3 eq_big_int (numerator_ratio r, big_int_of_int 2) &&
-test 4 eq_big_int (denominator_ratio r, big_int_of_int 3);;
-
-set_normalize_ratio true;;
-
-let r = create_ratio (big_int_of_int 12) (big_int_of_int (-16)) in
-test 5 eq_big_int (numerator_ratio r, big_int_of_int (-3)) &&
-test 6 eq_big_int (denominator_ratio r, big_int_of_int 4);;
-
-set_normalize_ratio false;;
-
-let r = create_ratio (big_int_of_int 0) (big_int_of_int 0) in
-test 7 eq_big_int (numerator_ratio r, big_int_of_int 0) &&
-test 8 eq_big_int (denominator_ratio r, big_int_of_int 0);;
-
-testing_function "create_normalized_ratio";;
-
-let r = create_normalized_ratio (big_int_of_int 1) (big_int_of_int (-2)) in
-test 1 eq_big_int (numerator_ratio r, big_int_of_int (-1)) &&
-test 2 eq_big_int (denominator_ratio r, big_int_of_int 2);;
-
-let r = create_normalized_ratio (big_int_of_int 2) (big_int_of_int 3) in
-test 3 eq_big_int (numerator_ratio r, big_int_of_int 2) &&
-test 4 eq_big_int (denominator_ratio r, big_int_of_int 3);;
-
-set_normalize_ratio true;;
-
-let r = create_normalized_ratio (big_int_of_int 12) (big_int_of_int (-16)) in
-test 5 eq_big_int (numerator_ratio r, big_int_of_int (-12)) &&
-test 6 eq_big_int (denominator_ratio r, big_int_of_int 16);;
-
-set_normalize_ratio false;;
-
-let r = create_normalized_ratio (big_int_of_int 1) (big_int_of_int 0) in
-test 7 eq_big_int (numerator_ratio r, big_int_of_int 1) &&
-test 8 eq_big_int (denominator_ratio r, big_int_of_int 0);;
-
-let r = create_normalized_ratio (big_int_of_int 0) (big_int_of_int 0) in
-test 9 eq_big_int (numerator_ratio r, big_int_of_int 0) &&
-test 10 eq_big_int (denominator_ratio r, big_int_of_int 0);;
-
-testing_function "null_denominator";;
-
-test 1
- eq (null_denominator (create_ratio (big_int_of_int 1) (big_int_of_int (-2))),
- false);;
-test 2 eq
- (null_denominator (create_ratio (big_int_of_int 1) zero_big_int),true);;
-
-(*****
-testing_function "verify_null_denominator";;
-
-test 1
- eq (verify_null_denominator (ratio_of_string "0/1"), false);;
-test 2
- eq (verify_null_denominator (ratio_of_string "0/0"), true);;
-*****)
-
-testing_function "sign_ratio";;
-
-test 1
-eq_int (sign_ratio (create_ratio (big_int_of_int (-2)) (big_int_of_int (-3))),
- 1);;
-test 2
-eq_int (sign_ratio (create_ratio (big_int_of_int 2) (big_int_of_int (-3))),
- (-1));;
-test 3
-eq_int (sign_ratio (create_ratio zero_big_int (big_int_of_int (-3))), 0);;
-
-testing_function "normalize_ratio";;
-
-let r = create_ratio (big_int_of_int 12) (big_int_of_int (-16)) in
-normalize_ratio r;
-test 1 eq_big_int (numerator_ratio r, big_int_of_int (-3)) &&
-test 2 eq_big_int (denominator_ratio r, big_int_of_int 4);;
-
-let r = create_ratio (big_int_of_int (-1)) zero_big_int in
-normalize_ratio r;
-test 3 eq_big_int (numerator_ratio r, big_int_of_int (-1)) &&
-test 4 eq_big_int (denominator_ratio r, zero_big_int);;
-
-testing_function "report_sign_ratio";;
-
-test 1
-eq_big_int (report_sign_ratio
- (create_ratio (big_int_of_int 2) (big_int_of_int (-3)))
- (big_int_of_int 1),
- big_int_of_int (-1));;
-test 2
-eq_big_int (report_sign_ratio
- (create_ratio (big_int_of_int 2) (big_int_of_int 3))
- (big_int_of_int 1),
- big_int_of_int 1);;
-
-testing_function "is_integer_ratio";;
-
-test 1 eq
- (is_integer_ratio (create_ratio (big_int_of_int 2) (big_int_of_int (-1))),
- true);;
-test 2 eq
- (is_integer_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)),
- false);;
-
-testing_function "add_ratio";;
-
-let r = add_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 2))
- (create_ratio (big_int_of_int 2) (big_int_of_int 3)) in
-test 1 eq_big_int (numerator_ratio r, big_int_of_int 7) &&
-test 2 eq_big_int (denominator_ratio r, big_int_of_int 6);;
-
-let r = add_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3))
- (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in
-test 3 eq_big_int (numerator_ratio r, big_int_of_int 1) &&
-test 4 eq_big_int (denominator_ratio r, big_int_of_int 6);;
-
-let r = add_ratio (create_ratio (big_int_of_int 2) zero_big_int)
- (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in
-test 5 eq_big_int (numerator_ratio r, big_int_of_int 4) &&
-test 6 eq_big_int (denominator_ratio r, zero_big_int);;
-
-let r = add_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3))
- (create_ratio (big_int_of_int 1) zero_big_int) in
-test 7 eq_big_int (numerator_ratio r, big_int_of_int 3) &&
-test 8 eq_big_int (denominator_ratio r, zero_big_int);;
-
-let r = add_ratio (create_ratio (big_int_of_int 2) zero_big_int)
- (create_ratio (big_int_of_int 1) zero_big_int) in
-test 9 eq_big_int (numerator_ratio r, zero_big_int) &&
-test 10 eq_big_int (denominator_ratio r, zero_big_int);;
-
-let r = add_ratio (create_ratio (big_int_of_string "12724951")
- (big_int_of_string "26542080"))
- (create_ratio (big_int_of_string "-1")
- (big_int_of_string "81749606400")) in
-test 11 eq_big_int (numerator_ratio r,
- big_int_of_string "1040259735682744320") &&
-test 12 eq_big_int (denominator_ratio r,
- big_int_of_string "2169804593037312000");;
-
-let r1,r2 =
- (create_ratio (big_int_of_string "12724951")
- (big_int_of_string "26542080"),
- create_ratio (big_int_of_string "-1")
- (big_int_of_string "81749606400")) in
-
-let bi1 = mult_big_int (numerator_ratio r1) (denominator_ratio r2)
-and bi2 = mult_big_int (numerator_ratio r2) (denominator_ratio r1)
-in
-test 1
-eq_big_int (bi1,
- big_int_of_string "1040259735709286400")
-&&
-test 2
-eq_big_int (bi2,
- big_int_of_string "-26542080")
-&& test 3
-eq_big_int (mult_big_int (denominator_ratio r1) (denominator_ratio r2),
- big_int_of_string "2169804593037312000")
-&& test 4
-eq_big_int (add_big_int bi1 bi2,
- big_int_of_string "1040259735682744320")
-;;
-
-testing_function "sub_ratio";;
-
-let r = sub_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3))
- (create_ratio (big_int_of_int 1) (big_int_of_int 2)) in
-test 1 eq_big_int (numerator_ratio r, big_int_of_int 1) &&
-test 2 eq_big_int (denominator_ratio r, big_int_of_int 6);;
-
-let r = sub_ratio (create_ratio (big_int_of_int 2) zero_big_int)
- (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in
-test 3 eq_big_int (numerator_ratio r, big_int_of_int 4) &&
-test 4 eq_big_int (denominator_ratio r, zero_big_int);;
-
-let r = sub_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3))
- (create_ratio (big_int_of_int 1) zero_big_int) in
-test 5 eq_big_int (numerator_ratio r, big_int_of_int (-3)) &&
-test 6 eq_big_int (denominator_ratio r, zero_big_int);;
-
-let r = sub_ratio (create_ratio (big_int_of_int 2) zero_big_int)
- (create_ratio (big_int_of_int 1) zero_big_int) in
-test 7 eq_big_int (numerator_ratio r, zero_big_int) &&
-test 8 eq_big_int (denominator_ratio r, zero_big_int);;
-
-testing_function "mult_ratio";;
-
-let r = mult_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3))
- (create_ratio (big_int_of_int 7) (big_int_of_int 5)) in
-test 1 eq_big_int (numerator_ratio r, big_int_of_int 14) &&
-test 2 eq_big_int (denominator_ratio r, big_int_of_int 15);;
-
-let r = mult_ratio (create_ratio (big_int_of_int 2) zero_big_int)
- (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in
-test 3 eq_big_int (numerator_ratio r, big_int_of_int (-2)) &&
-test 4 eq_big_int (denominator_ratio r, zero_big_int);;
-
-let r = mult_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3))
- (create_ratio (big_int_of_int 1) zero_big_int) in
-test 5 eq_big_int (numerator_ratio r, big_int_of_int 2) &&
-test 6 eq_big_int (denominator_ratio r, zero_big_int);;
-
-let r = mult_ratio (create_ratio (big_int_of_int 2) zero_big_int)
- (create_ratio (big_int_of_int 1) zero_big_int) in
-test 7 eq_big_int (numerator_ratio r, big_int_of_int 2) &&
-test 8 eq_big_int (denominator_ratio r, zero_big_int);;
-
-testing_function "div_ratio";;
-
-let r = div_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3))
- (create_ratio (big_int_of_int 5) (big_int_of_int 7)) in
-test 1 eq_big_int (numerator_ratio r, big_int_of_int 14) &&
-test 2 eq_big_int (denominator_ratio r, big_int_of_int 15);;
-
-let r = div_ratio (create_ratio (big_int_of_int 2) zero_big_int)
- (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in
-test 3 eq_big_int (numerator_ratio r, big_int_of_int (-4)) &&
-test 4 eq_big_int (denominator_ratio r, zero_big_int);;
-
-let r = div_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3))
- (create_ratio (big_int_of_int 1) zero_big_int) in
-test 5 eq_big_int (numerator_ratio r, zero_big_int) &&
-test 6 eq_big_int (denominator_ratio r, big_int_of_int 3);;
-
-let r = div_ratio (create_ratio (big_int_of_int 2) zero_big_int)
- (create_ratio (big_int_of_int 1) zero_big_int) in
-test 7 eq_big_int (numerator_ratio r, zero_big_int) &&
-test 8 eq_big_int (denominator_ratio r, zero_big_int);;
-
-testing_function "integer_ratio";;
-
-test 1
-eq_big_int (integer_ratio
- (create_ratio (big_int_of_int 5) (big_int_of_int 3)),
- big_int_of_int 1);;
-test 2
-eq_big_int (integer_ratio
- (create_ratio (big_int_of_int 5) (big_int_of_int (-3))),
- big_int_of_int (-1));;
-test 3
-eq_big_int (integer_ratio
- (create_ratio (big_int_of_int 3) (big_int_of_int 2)),
- big_int_of_int 1);;
-test 4
-eq_big_int (integer_ratio
- (create_ratio (big_int_of_int 3) (big_int_of_int (-2))),
- big_int_of_int (-1));;
-
-failwith_test 5
-integer_ratio (create_ratio (big_int_of_int 3) zero_big_int)
-(Failure("integer_ratio "^infinite_failure));;
-
-testing_function "floor_ratio";;
-
-test 1
-eq_big_int (floor_ratio
- (create_ratio (big_int_of_int 5) (big_int_of_int 3)),
- big_int_of_int 1);;
-test 2
-eq_big_int (floor_ratio
- (create_ratio (big_int_of_int 5) (big_int_of_int (-3))),
- big_int_of_int (-2));;
-test 3
-eq_big_int (floor_ratio
- (create_ratio (big_int_of_int 3) (big_int_of_int 2)),
- big_int_of_int 1);;
-test 4
-eq_big_int (floor_ratio
- (create_ratio (big_int_of_int 3) (big_int_of_int (-2))),
- big_int_of_int (-2));;
-
-failwith_test 5 floor_ratio (create_ratio (big_int_of_int 3) zero_big_int)
-Division_by_zero;;
-
-
-testing_function "round_ratio";;
-
-test 1
-eq_big_int (round_ratio
- (create_ratio (big_int_of_int 5) (big_int_of_int 3)),
- big_int_of_int 2);;
-test 2
-eq_big_int (round_ratio
- (create_ratio (big_int_of_int 5) (big_int_of_int (-3))),
- big_int_of_int (-2));;
-test 3
-eq_big_int (round_ratio
- (create_ratio (big_int_of_int 3) (big_int_of_int 2)),
- big_int_of_int 2);;
-test 4
-eq_big_int (round_ratio
- (create_ratio (big_int_of_int 3) (big_int_of_int (-2))),
- big_int_of_int (-2));;
-
-failwith_test 5
-round_ratio (create_ratio (big_int_of_int 3) zero_big_int)
-Division_by_zero;;
-
-
-testing_function "ceiling_ratio";;
-
-test 1
-eq_big_int (ceiling_ratio
- (create_ratio (big_int_of_int 5) (big_int_of_int 3)),
- big_int_of_int 2);;
-test 2
-eq_big_int (ceiling_ratio
- (create_ratio (big_int_of_int 5) (big_int_of_int (-3))),
- big_int_of_int (-1));;
-test 3
-eq_big_int (ceiling_ratio
- (create_ratio (big_int_of_int 3) (big_int_of_int 2)),
- big_int_of_int 2);;
-test 4
-eq_big_int (ceiling_ratio
- (create_ratio (big_int_of_int 3) (big_int_of_int (-2))),
- big_int_of_int (-1));;
-test 5
-eq_big_int (ceiling_ratio
- (create_ratio (big_int_of_int 4) (big_int_of_int 2)),
- big_int_of_int 2);;
-failwith_test 6
-ceiling_ratio (create_ratio (big_int_of_int 3) zero_big_int)
-Division_by_zero;;
-
-testing_function "eq_ratio";;
-
-test 1
-eq_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3),
- create_ratio (big_int_of_int (-20)) (big_int_of_int (-12)));;
-test 2
-eq_ratio (create_ratio (big_int_of_int 1) zero_big_int,
- create_ratio (big_int_of_int 2) zero_big_int);;
-
-let neq_ratio x y = not (eq_ratio x y);;
-
-test 3
-neq_ratio (create_ratio (big_int_of_int 1) zero_big_int,
- create_ratio (big_int_of_int (-1)) zero_big_int);;
-test 4
-neq_ratio (create_ratio (big_int_of_int 1) zero_big_int,
- create_ratio zero_big_int zero_big_int);;
-test 5
-eq_ratio (create_ratio zero_big_int zero_big_int,
- create_ratio zero_big_int zero_big_int);;
-
-testing_function "compare_ratio";;
-
-test 1
-eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0))
- (create_ratio (big_int_of_int 0) (big_int_of_int 0)),
- 0);;
-test 2
-eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0))
- (create_ratio (big_int_of_int 1) (big_int_of_int 0)),
- 0);;
-test 3
-eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0))
- (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)),
- 0);;
-test 4
-eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0))
- (create_ratio (big_int_of_int 0) (big_int_of_int 0)),
- 0);;
-test 5
-eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0))
- (create_ratio (big_int_of_int 0) (big_int_of_int 0)),
- 0);;
-test 6
-eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0))
- (create_ratio (big_int_of_int 5) (big_int_of_int 3)),
- 0);;
-test 7
-eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3))
- (create_ratio (big_int_of_int 0) (big_int_of_int 0)),
- 0);;
-test 8
-eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0))
- (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)),
- 0);;
-test 9
-eq_int (compare_ratio (create_ratio (big_int_of_int (-5)) (big_int_of_int 3))
- (create_ratio (big_int_of_int 0) (big_int_of_int 0)),
- 0);;
-test 10
-eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0))
- (create_ratio (big_int_of_int 0) (big_int_of_int 1)),
- 0);;
-test 11
-eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 1))
- (create_ratio (big_int_of_int 0) (big_int_of_int 0)),
- 0);;
-test 12
-eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0))
- (create_ratio (big_int_of_int 1) (big_int_of_int 0)),
- 0);;
-test 13
-eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0))
- (create_ratio (big_int_of_int 2) (big_int_of_int 0)),
- 0);;
-test 14
-eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0))
- (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)),
- 1);;
-test 15
-eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0))
- (create_ratio (big_int_of_int 1) (big_int_of_int 0)),
- (-1));;
-test 16
-eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3))
- (create_ratio (big_int_of_int 1) (big_int_of_int 0)),
- (-1));;
-test 17
-eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0))
- (create_ratio (big_int_of_int 5) (big_int_of_int 3)),
- 1);;
-test 18
-eq_int (compare_ratio (create_ratio (big_int_of_int (-5)) (big_int_of_int 3))
- (create_ratio (big_int_of_int 1) (big_int_of_int 0)),
- (-1));;
-test 19
-eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0))
- (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)),
- 1);;
-test 20
-eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0))
- (create_ratio (big_int_of_int 0) (big_int_of_int 3)),
- 1);;
-test 21
-eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0))
- (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)),
- 0);;
-test 22
-eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0))
- (create_ratio (big_int_of_int (-2)) (big_int_of_int 0)),
- 0);;
-test 23
-eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3))
- (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)),
- 1);;
-test 24
-eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0))
- (create_ratio (big_int_of_int 5) (big_int_of_int 3)),
- (-1));;
-test 25
-eq_int (compare_ratio (create_ratio (big_int_of_int (-5)) (big_int_of_int 3))
- (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)),
- 1);;
-test 26
-eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0))
- (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)),
- (-1));;
-test 27
-eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0))
- (create_ratio (big_int_of_int 0) (big_int_of_int 3)),
- (-1));;
-test 28
-eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3))
- (create_ratio (big_int_of_int 3) (big_int_of_int 2)),
- 1);;
-test 29
-eq_int (compare_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 2))
- (create_ratio (big_int_of_int 5) (big_int_of_int 3)),
- (-1));;
-test 30
-eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3))
- (create_ratio (big_int_of_int (-3)) (big_int_of_int 2)),
- 1);;
-test 31
-eq_int (compare_ratio (create_ratio (big_int_of_int (-3)) (big_int_of_int 2))
- (create_ratio (big_int_of_int 5) (big_int_of_int 3)),
- (-1));;
-test 32
-eq_int (compare_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 2))
- (create_ratio (big_int_of_int 0) (big_int_of_int 3)),
- 1);;
-test 33
-eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 2))
- (create_ratio (big_int_of_int 5) (big_int_of_int 3)),
- (-1));;
-test 34
-eq_int (compare_ratio (create_ratio (big_int_of_int (-3)) (big_int_of_int 2))
- (create_ratio (big_int_of_int 0) (big_int_of_int 3)),
- (-1));;
-test 35
-eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 2))
- (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)),
- 1);;
-test 36
-eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 2))
- (create_ratio (big_int_of_int 0) (big_int_of_int 3)),
- 0);;
-
-testing_function "eq_big_int_ratio";;
-
-test 1
-eq_big_int_ratio (big_int_of_int 3,
- (create_ratio (big_int_of_int 3) (big_int_of_int 1)));;
-test 2
-eq
-(not (eq_big_int_ratio (big_int_of_int 1)
- (create_ratio (big_int_of_int 3) (big_int_of_int 1))),
-true);;
-
-test 3
-eq
-(not (eq_big_int_ratio (big_int_of_int 1)
- (create_ratio (big_int_of_int 3) (big_int_of_int 2))),
- true);;
-
-test 4
-eq
-(not (eq_big_int_ratio (big_int_of_int 1)
- (create_ratio (big_int_of_int 3) (big_int_of_int 0))),
- true);;
-
-test 5
-eq
-(not (eq_big_int_ratio (big_int_of_int 1)
- (create_ratio (big_int_of_int (-3)) (big_int_of_int 2))),
- true);;
-
-testing_function "compare_big_int_ratio";;
-
-test 1
-eq_int (compare_big_int_ratio
- (big_int_of_int 1)
- (create_ratio (big_int_of_int 3) (big_int_of_int 0)), (-1));;
-test 2
-eq_int (compare_big_int_ratio
- (big_int_of_int 1)
- (create_ratio (big_int_of_int 0) (big_int_of_int 0)), 0);;
-test 3
-eq_int (compare_big_int_ratio
- (big_int_of_int 1)
- (create_ratio (big_int_of_int (-3)) (big_int_of_int 0)), 1);;
-test 4
-eq_int (compare_big_int_ratio
- (big_int_of_int (-1))
- (create_ratio (big_int_of_int 3) (big_int_of_int 0)), (-1));;
-test 5
-eq_int (compare_big_int_ratio
- (big_int_of_int (-1))
- (create_ratio (big_int_of_int 0) (big_int_of_int 0)), 0);;
-test 6
-eq_int (compare_big_int_ratio
- (big_int_of_int (-1))
- (create_ratio (big_int_of_int (-3)) (big_int_of_int 0)), 1);;
-test 7
-eq_int (compare_big_int_ratio
- (big_int_of_int 1)
- (create_ratio (big_int_of_int 1) (big_int_of_int 1)), 0);;
-test 8
-eq_int (compare_big_int_ratio
- (big_int_of_int 1)
- (create_ratio (big_int_of_int 3) (big_int_of_int 2)), (-1));;
-test 9
-eq_int (compare_big_int_ratio
- (big_int_of_int 1)
- (create_ratio (big_int_of_int 2) (big_int_of_int 3)), 1);;
-
-
-
-testing_function "int_of_ratio";;
-
-test 1
-eq_int (int_of_ratio (create_ratio (big_int_of_int 4) (big_int_of_int 2)),
- 2);;
-
-test 2
-eq_int (int_of_ratio
- (create_ratio (big_int_of_int biggest_int) (big_int_of_int 1)),
- biggest_int);;
-
-failwith_test 3
-int_of_ratio (create_ratio (big_int_of_int 4) (big_int_of_int 0))
-(Failure "integer argument required");;
-
-failwith_test 4
-int_of_ratio (create_ratio (succ_big_int (big_int_of_int biggest_int))
- (big_int_of_int 1))
-(Failure "integer argument required");;
-
-failwith_test 5
-int_of_ratio (create_ratio (big_int_of_int 4) (big_int_of_int 3))
-(Failure "integer argument required");;
-
-testing_function "ratio_of_int";;
-
-test 1
-eq_ratio (ratio_of_int 3,
- create_ratio (big_int_of_int 3) (big_int_of_int 1));;
-
-test 2
-eq_ratio (ratio_of_nat (nat_of_int 2),
- create_ratio (big_int_of_int 2) (big_int_of_int 1));;
-
-testing_function "nat_of_ratio";;
-
-let nat1 = nat_of_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 1))
-and nat2 = nat_of_int 3 in
-test 1
-eq (eq_nat nat1 0 (length_nat nat1) nat2 0 (length_nat nat2), true)
-;;
-
-failwith_test 2
-nat_of_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 0))
-(Failure "nat_of_ratio");;
-
-failwith_test 3
-nat_of_ratio (create_ratio (big_int_of_int (-3)) (big_int_of_int 1))
-(Failure "nat_of_ratio");;
-
-failwith_test 4
-nat_of_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 2))
-(Failure "nat_of_ratio");;
-
-testing_function "ratio_of_big_int";;
-
-test 1
-eq_ratio (ratio_of_big_int (big_int_of_int 3),
- create_ratio (big_int_of_int 3) (big_int_of_int 1));;
-
-testing_function "big_int_of_ratio";;
-
-test 1
-eq_big_int (big_int_of_ratio
- (create_ratio (big_int_of_int 3) (big_int_of_int 1)),
- big_int_of_int 3);;
-test 2
-eq_big_int (big_int_of_ratio
- (create_ratio (big_int_of_int (-3)) (big_int_of_int 1)),
- big_int_of_int (-3));;
-
-failwith_test 3
-big_int_of_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 0))
-(Failure "big_int_of_ratio");;
-
-testing_function "string_of_ratio";;
-
-test 1
-eq_string (string_of_ratio
- (create_ratio (big_int_of_int 43) (big_int_of_int 35)),
- "43/35");;
-test 2
-eq_string (string_of_ratio
- (create_ratio (big_int_of_int 42) (big_int_of_int 0)),
- "1/0");;
-
-set_normalize_ratio_when_printing false;;
-
-test 3
-eq_string (string_of_ratio
- (create_ratio (big_int_of_int 42) (big_int_of_int 35)),
- "42/35");;
-
-set_normalize_ratio_when_printing true;;
-
-test 4
-eq_string (string_of_ratio
- (create_ratio (big_int_of_int 42) (big_int_of_int 35)),
- "6/5");;
-
-testing_function "ratio_of_string";;
-
-test 1
-eq_ratio (ratio_of_string ("123/3456"),
- create_ratio (big_int_of_int 123) (big_int_of_int 3456));;
-
-(***********
-test 2
-eq_ratio (ratio_of_string ("12.3/34.56"),
- create_ratio (big_int_of_int 1230) (big_int_of_int 3456));;
-test 3
-eq_ratio (ratio_of_string ("1.23/325.6"),
- create_ratio (big_int_of_int 123) (big_int_of_int 32560));;
-test 4
-eq_ratio (ratio_of_string ("12.3/345.6"),
- create_ratio (big_int_of_int 123) (big_int_of_int 3456));;
-test 5
-eq_ratio (ratio_of_string ("12.3/0.0"),
- create_ratio (big_int_of_int 123) (big_int_of_int 0));;
-***********)
-test 6
-eq_ratio (ratio_of_string ("0/0"),
- create_ratio (big_int_of_int 0) (big_int_of_int 0));;
-
-test 7
-eq_ratio (ratio_of_string "1234567890",
- create_ratio (big_int_of_string "1234567890") unit_big_int);;
-failwith_test 8
-ratio_of_string "frlshjkurty" (Failure "invalid digit");;
-
-(***********
-testing_function "msd_ratio";;
-
-test 1
-eq_int (msd_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 1)),
- 0);;
-test 2
-eq_int (msd_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 12)),
- (-2));;
-test 3
-eq_int (msd_ratio (create_ratio (big_int_of_int 12) (big_int_of_int 1)),
- 1);;
-test 4
-eq_int (msd_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 2)),
- (-1));;
-test 5
-eq_int (msd_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 1)),
- 0);;
-test 6
-eq_int (msd_ratio (create_ratio (big_int_of_int 25) (big_int_of_int 21)),
- 0);;
-test 7
-eq_int (msd_ratio (create_ratio (big_int_of_int 35) (big_int_of_int 21)),
- 0);;
-test 8
-eq_int (msd_ratio (create_ratio (big_int_of_int 215) (big_int_of_int 31)),
- 0);;
-test 9
-eq_int (msd_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 30)),
- (-2));;
-test 10
-eq_int (msd_ratio (create_ratio (big_int_of_int 2345)
- (big_int_of_int 23456)),
- (-2));;
-test 11
-eq_int (msd_ratio (create_ratio (big_int_of_int 2345)
- (big_int_of_int 2346)),
- (-1));;
-test 12
-eq_int (msd_ratio (create_ratio (big_int_of_int 2345)
- (big_int_of_int 2344)),
- 0);;
-test 13
-eq_int (msd_ratio (create_ratio (big_int_of_int 23456)
- (big_int_of_int 2345)),
- 1);;
-test 14
-eq_int (msd_ratio (create_ratio (big_int_of_int 23467)
- (big_int_of_int 2345)),
- 1);;
-failwith_test 15
-msd_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0))
-("msd_ratio "^infinite_failure);;
-failwith_test 16
-msd_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0))
-("msd_ratio "^infinite_failure);;
-failwith_test 17
-msd_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0))
-("msd_ratio "^infinite_failure);;
-*************************)
-
-testing_function "round_futur_last_digit";;
-
-let s = "+123456" in
-test 1 eq (round_futur_last_digit s 1 (pred (String.length s)),
- false) &&
-test 2 eq_string (s, "+123466");;
-
-let s = "123456" in
-test 3 eq (round_futur_last_digit s 0 (String.length s), false) &&
-test 4 eq_string (s, "123466");;
-
-let s = "-123456" in
-test 5 eq (round_futur_last_digit s 1 (pred (String.length s)),
- false) &&
-test 6 eq_string (s, "-123466");;
-
-let s = "+123496" in
-test 7 eq (round_futur_last_digit s 1 (pred (String.length s)),
- false) &&
-test 8 eq_string (s, "+123506");;
-
-let s = "123496" in
-test 9 eq (round_futur_last_digit s 0 (String.length s), false) &&
-test 10 eq_string (s, "123506");;
-
-let s = "-123496" in
-test 11 eq (round_futur_last_digit s 1 (pred (String.length s)),
- false) &&
-test 12 eq_string (s, "-123506");;
-
-let s = "+996" in
-test 13 eq (round_futur_last_digit s 1 (pred (String.length s)),
- true) &&
-test 14 eq_string (s, "+006");;
-
-let s = "996" in
-test 15 eq (round_futur_last_digit s 0 (String.length s), true) &&
-test 16 eq_string (s, "006");;
-
-let s = "-996" in
-test 17 eq (round_futur_last_digit s 1 (pred (String.length s)),
- true) &&
-test 18 eq_string (s, "-006");;
-
-let s = "+6666666" in
-test 19 eq (round_futur_last_digit s 1 (pred (String.length s)),
- false) &&
-test 20 eq_string (s, "+6666676") ;;
-
-let s = "6666666" in
-test 21 eq (round_futur_last_digit s 0 (String.length s), false) &&
-test 22 eq_string (s, "6666676") ;;
-
-let s = "-6666666" in
-test 23 eq (round_futur_last_digit s 1 (pred (String.length s)),
- false) &&
-test 24 eq_string (s, "-6666676") ;;
-
-testing_function "approx_ratio_fix";;
-
-let s = approx_ratio_fix 5
- (create_ratio (big_int_of_int 2)
- (big_int_of_int 3)) in
-test 1
-eq_string (s, "+0.66667");;
-
-test 2
-eq_string (approx_ratio_fix 5
- (create_ratio (big_int_of_int 20)
- (big_int_of_int 3)),
- "+6.66667");;
-test 3
-eq_string (approx_ratio_fix 5
- (create_ratio (big_int_of_int 2)
- (big_int_of_int 30)),
- "+0.06667");;
-test 4
-eq_string (approx_ratio_fix 5
- (create_ratio (big_int_of_string "999996")
- (big_int_of_string "1000000")),
- "+1.00000");;
-test 5
-eq_string (approx_ratio_fix 5
- (create_ratio (big_int_of_string "299996")
- (big_int_of_string "100000")),
- "+2.99996");;
-test 6
-eq_string (approx_ratio_fix 5
- (create_ratio (big_int_of_string "2999996")
- (big_int_of_string "1000000")),
- "+3.00000");;
-test 7
-eq_string (approx_ratio_fix 4
- (create_ratio (big_int_of_string "299996")
- (big_int_of_string "100000")),
- "+3.0000");;
-test 8
-eq_string (approx_ratio_fix 5
- (create_ratio (big_int_of_int 29996)
- (big_int_of_string "100000")),
- "+0.29996");;
-test 9
-eq_string (approx_ratio_fix 5
- (create_ratio (big_int_of_int 0)
- (big_int_of_int 1)),
- "+0");;
-failwith_test 10
-(approx_ratio_fix 5) (create_ratio (big_int_of_int 1) (big_int_of_int 0))
-(Failure "approx_ratio_fix infinite or undefined rational number");;
-failwith_test 11
-(approx_ratio_fix 5) (create_ratio (big_int_of_int 0) (big_int_of_int 0))
-(Failure "approx_ratio_fix infinite or undefined rational number");;
-
-testing_function "approx_ratio_exp";;
-
-test 1
-eq_string (approx_ratio_exp 5
- (create_ratio (big_int_of_int 2)
- (big_int_of_int 3)),
- "+0.66667e0");;
-test 2
-eq_string (approx_ratio_exp 5
- (create_ratio (big_int_of_int 20)
- (big_int_of_int 3)),
- "+0.66667e1");;
-test 3
-eq_string (approx_ratio_exp 5
- (create_ratio (big_int_of_int 2)
- (big_int_of_int 30)),
- "+0.66667e-1");;
-test 4
-eq_string (approx_ratio_exp 5
- (create_ratio (big_int_of_string "999996")
- (big_int_of_string "1000000")),
- "+1.00000e0");;
-test 5
-eq_string (approx_ratio_exp 5
- (create_ratio (big_int_of_string "299996")
- (big_int_of_string "100000")),
- "+0.30000e1");;
-test 6
-eq_string (approx_ratio_exp 5
- (create_ratio (big_int_of_int 29996)
- (big_int_of_string "100000")),
- "+0.29996e0");;
-test 7
-eq_string (approx_ratio_exp 5
- (create_ratio (big_int_of_int 0)
- (big_int_of_int 1)),
- "+0.00000e0");;
-failwith_test 8
-(approx_ratio_exp 5) (create_ratio (big_int_of_int 1) (big_int_of_int 0))
-(Failure "approx_ratio_exp infinite or undefined rational number");;
-failwith_test 9
-(approx_ratio_exp 5) (create_ratio (big_int_of_int 0) (big_int_of_int 0))
-(Failure "approx_ratio_exp infinite or undefined rational number");;
diff --git a/otherlibs/str/.cvsignore b/otherlibs/str/.cvsignore
deleted file mode 100644
index a37b133d05..0000000000
--- a/otherlibs/str/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-libstr.x
-*.c.x
-so_locations
diff --git a/otherlibs/str/.depend b/otherlibs/str/.depend
deleted file mode 100644
index c93656bae4..0000000000
--- a/otherlibs/str/.depend
+++ /dev/null
@@ -1,7 +0,0 @@
-strstubs.o: strstubs.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \
- ../../byterun/major_gc.h ../../byterun/freelist.h \
- ../../byterun/minor_gc.h ../../byterun/fail.h
-str.cmo: str.cmi
-str.cmx: str.cmi
diff --git a/otherlibs/str/Makefile b/otherlibs/str/Makefile
deleted file mode 100644
index 97123ddaa2..0000000000
--- a/otherlibs/str/Makefile
+++ /dev/null
@@ -1,75 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-# Makefile for the str library
-
-include ../../config/Makefile
-
-# Compilation options
-CC=$(BYTECC)
-CFLAGS=-O -I../../byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS)
-CAMLC=../../ocamlcomp.sh
-CAMLOPT=../../ocamlcompopt.sh
-COMPFLAGS=-warn-error A
-COBJS=strstubs.o
-MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib
-
-all: libstr.a str.cmi str.cma
-
-allopt: libstr.a str.cmi str.cmxa
-
-libstr.a: $(COBJS)
- $(MKLIB) -o str $(COBJS)
-
-str.cma: str.cmo
- $(MKLIB) -ocamlc '$(CAMLC)' -o str str.cmo
-
-str.cmxa: str.cmx
- $(MKLIB) -ocamlopt '$(CAMLOPT)' -o str str.cmx
-
-str.cmx: ../../ocamlopt
-
-partialclean:
- rm -f *.cm*
-
-clean: partialclean
- rm -f *.a *.so *.o
-
-install:
- if test -f dllstr.so; then cp dllstr.so $(STUBLIBDIR)/dllstr.so; fi
- cp libstr.a $(LIBDIR)/libstr.a
- cd $(LIBDIR); $(RANLIB) libstr.a
- cp str.cma str.cmi str.mli $(LIBDIR)
-
-installopt:
- cp str.cmx str.cmxa str.a $(LIBDIR)
- cd $(LIBDIR); $(RANLIB) str.a
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.mli.cmi:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-depend:
- gcc -MM $(CFLAGS) *.c > .depend
- ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend
-
-include .depend
diff --git a/otherlibs/str/Makefile.Mac b/otherlibs/str/Makefile.Mac
deleted file mode 100644
index c5345acd09..0000000000
--- a/otherlibs/str/Makefile.Mac
+++ /dev/null
@@ -1,53 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-# Makefile for the str library
-
-# Compilation options
-PPCC = mrc
-PPCCOptions = -i :::byterun:,:::config: -w 7 {cdbgflag}
-
-CAMLC = :::boot:ocamlrun :::ocamlc -I :::stdlib:
-
-PPCCOBJS = strstubs.c.x
-
-all Ä libstr.x str.cmi str.cma
-
-libstr.x Ä {PPCCOBJS}
- ppclink {ldbgflag} -xm library -o libstr.x {PPCCOBJS}
-
-str.cma Ä str.cmo
- {CAMLC} -a -o str.cma str.cmo
-
-partialclean Ä
- delete -i Å.cm[aio] || set status 0
-
-clean Ä partialclean
- delete -i Å.x || set status 0
-
-install Ä
- duplicate -y libstr.x str.cma str.cmi "{LIBDIR}"
-
-.cmi Ä .mli
- {CAMLC} -c {COMPFLAGS} {default}.mli
-
-.cmo Ä .ml
- {CAMLC} -c {COMPFLAGS} {default}.ml
-
-depend Ä
- begin
- MakeDepend -w -objext .x Å.c
- :::boot:ocamlrun :::tools:ocamldep Å.mli Å.ml
- end | streamedit -e "/¶t/ replace // ' ' -c °" > Makefile.Mac.depend
diff --git a/otherlibs/str/Makefile.Mac.depend b/otherlibs/str/Makefile.Mac.depend
deleted file mode 100644
index ddcc070e9b..0000000000
--- a/otherlibs/str/Makefile.Mac.depend
+++ /dev/null
@@ -1,16 +0,0 @@
-#*** Dependencies: Cut here ***
-# These dependencies were produced at 20:33:21 on Tue, Aug 21, 2001 by MakeDepend
-
-:strstubs.c.x Ä ¶
- :strstubs.c ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"memory.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-str.cmoÄ str.cmi
-str.cmxÄ str.cmi
diff --git a/otherlibs/str/Makefile.nt b/otherlibs/str/Makefile.nt
deleted file mode 100644
index 3d65d19f00..0000000000
--- a/otherlibs/str/Makefile.nt
+++ /dev/null
@@ -1,83 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-# Makefile for the str library
-
-include ../../config/Makefile
-
-# Compilation options
-CC=$(BYTECC)
-CFLAGS=-I../../byterun
-CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../boot
-CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib
-DCOBJS=strstubs.$(DO)
-SCOBJS=strstubs.$(SO)
-
-all: dllstr.dll libstr.$(A) str.cmi str.cma
-
-allopt: libstr.$(A) str.cmi str.cmxa
-
-dllstr.dll: $(DCOBJS)
- $(call MKDLL,dllstr.dll,tmp.$(A),$(DCOBJS) ../../byterun/ocamlrun.$(A))
- rm tmp.*
-
-libstr.$(A): $(SCOBJS)
- $(call MKLIB,libstr.$(A),$(SCOBJS))
-
-str.cma: str.cmo
- $(CAMLC) -a -o str.cma str.cmo -dllib -lstr -cclib -lstr
-
-str.cmxa: str.cmx
- $(CAMLOPT) -a -o str.cmxa str.cmx -cclib -lstr
-
-str.cmx: ../../ocamlopt
-
-partialclean:
- rm -f *.cm*
-
-clean: partialclean
- rm -f *.$(A) *.dll *.$(O) *.$(SO)
-
-install:
- cp dllstr.dll $(STUBLIBDIR)/dllstr.dll
- cp libstr.$(A) $(LIBDIR)/libstr.$(A)
- cp str.cma str.cmi $(LIBDIR)
-
-installopt:
- cp str.cmx str.cmxa str.$(A) $(LIBDIR)
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx .$(DO) .$(SO)
-
-.mli.cmi:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-.c.$(DO):
- $(BYTECC) $(DLLCCCOMPOPTS) $(CFLAGS) -c $<
- mv $*.$(O) $*.$(DO)
-
-.c.$(SO):
- $(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c $<
- mv $*.$(O) $*.$(SO)
-
-depend:
-
-str.cmo: str.cmi
-str.cmx: str.cmi
diff --git a/otherlibs/str/str.ml b/otherlibs/str/str.ml
deleted file mode 100644
index ca128aed23..0000000000
--- a/otherlibs/str/str.ml
+++ /dev/null
@@ -1,716 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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 = string (* of length 32 *)
-
- let empty = String.make 32 '\000'
- let full = String.make 32 '\255'
-
- let make_empty () = String.make 32 '\000'
-
- let add s c =
- let i = Char.code c in
- s.[i lsr 3] <- Char.chr(Char.code 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 = String.create 32 in
- for i = 0 to 31 do
- r.[i] <- Char.chr(Char.code s.[i] lxor 0xFF)
- done;
- r
-
- let union s1 s2 =
- let r = String.create 32 in
- for i = 0 to 31 do
- r.[i] <- Char.chr(Char.code s1.[i] lor Char.code s2.[i])
- done;
- r
-
- let disjoint s1 s2 =
- try
- for i = 0 to 31 do
- if Char.code s1.[i] land Char.code 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 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 = String.make 256 '\000' in
- iter (fun c -> 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
-
- end
-
-(** Abstract syntax tree for regular expressions *)
-
-type re_syntax =
- Char of char
- | String of string
- | CharClass of Charset.t
- | 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 c -> false
- | String s -> s = ""
- | CharClass cl -> false
- | Seq rl -> List.for_all is_nullable rl
- | Alt (r1, r2) -> is_nullable r1 || is_nullable r2
- | Star r -> true
- | Plus r -> is_nullable r
- | Option r -> true
- | Group(n, r) -> is_nullable r
- | Refgroup n -> 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 -> cl
- | Seq rl -> first_seq rl
- | Alt (r1, r2) -> Charset.union (first r1) (first r2)
- | Star r -> Charset.full
- | Plus r -> first r
- | Option r -> Charset.full
- | Group(n, r) -> first r
- | Refgroup n -> 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 :: rl -> first r
-
-(* Transform a Char or CharClass regexp into a character class *)
-
-let charclass_of_regexp fold_case re =
- let cl =
- match re with
- Char c -> Charset.singleton c
- | CharClass cl -> cl
- | _ -> assert false in
- if fold_case then Charset.fold_case cl else cl
-
-(* The case fold table: maps characters to their lowercase equivalent *)
-
-let fold_case_table =
- let t = String.create 256 in
- for i = 0 to 255 do t.[i] <- Char.lowercase(Char.chr i) done;
- t
-
-module StringMap = Map.Make(struct type t = string let compare = compare 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 nprog = Array.make (2 * Array.length !prog) 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 incr progpos; 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))
- 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]))
- 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))
- else
- emit_instr op_STRING (cpool_index s)
- end
- | CharClass cl ->
- let cl' = if fold_case then Charset.fold_case cl else cl in
- emit_instr op_CHARCLASS (cpool_index cl')
- | 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) ->
- if n >= 32 then failwith "too many \\(...\\) groups";
- 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
- | 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 (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, j) = regexpclass0 (i+1) in (CharClass c, j)
- | '^' -> (Bol, i+1)
- | '$' -> (Eol, i+1)
- | '.' -> (CharClass dotclass, 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
- if group_no < 32 then incr group_counter;
- let (r, j) = regexp0 (i+1) in
- if j + 1 < len && s.[j] = '\\' && s.[j+1] = ')' then
- if group_no < 32
- then (Group(group_no, r), j + 2)
- else (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 (Charset.complement c, j)
- else regexpclass1 i
- 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 = String.create (2 * len) in
- let pos = ref 0 in
- for i = 0 to len - 1 do
- match s.[i] with
- '[' | ']' | '*' | '.' | '\\' | '?' | '+' | '^' | '$' as c ->
- buf.[!pos] <- '\\'; buf.[!pos + 1] <- c; pos := !pos + 2
- | c ->
- buf.[!pos] <- c; pos := !pos + 1
- done;
- String.sub 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 global_substitute expr repl_fun text =
- let rec replace start last_was_empty =
- try
- let startpos = if last_was_empty then start + 1 else start in
- if startpos > String.length text then raise Not_found;
- let pos = search_forward expr text startpos in
- let end_pos = match_end() in
- let repl_text = repl_fun text in
- String.sub text start (pos-start) ::
- repl_text ::
- replace end_pos (end_pos = pos)
- with Not_found ->
- [string_after text start] in
- String.concat "" (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 bounded_split expr text num =
- let start =
- if string_match expr text 0 then match_end() else 0 in
- let rec split start n =
- if start >= String.length text then [] else
- if n = 1 then [string_after text start] else
- try
- let pos = search_forward expr text start in
- String.sub text start (pos-start) :: split (match_end()) (n-1)
- with Not_found ->
- [string_after text start] in
- split start num
-
-let split expr text = bounded_split expr text 0
-
-let bounded_split_delim expr text num =
- let rec split start n =
- if start > String.length text then [] else
- if n = 1 then [string_after text start] else
- try
- let pos = search_forward expr text start in
- String.sub text start (pos-start) :: split (match_end()) (n-1)
- with Not_found ->
- [string_after text start] in
- if text = "" then [] else 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 start n =
- if start >= String.length text then [] else
- if n = 1 then [Text(string_after text start)] else
- try
- let pos = search_forward expr text start in
- let s = matched_string text in
- if pos > start then
- Text(String.sub text start (pos-start)) ::
- Delim(s) ::
- split (match_end()) (n-1)
- else
- Delim(s) ::
- split (match_end()) (n-1)
- with Not_found ->
- [Text(string_after text start)] in
- 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
deleted file mode 100644
index 5aaee9fb34..0000000000
--- a/otherlibs/str/str.mli
+++ /dev/null
@@ -1,239 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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 syntax for regular expressions
- is the same as in Gnu Emacs. The special characters are
- [$^.*+?[]]. The following constructs are recognized:
- - [. ] matches any character except newline
- - [* ] (postfix) matches the previous expression zero, one or
- several times
- - [+ ] (postfix) matches the previous expression one or
- several times
- - [? ] (postfix) matches the previous expression once or
- not at all
- - [[..] ] character set; ranges are denoted with [-], as in [[a-z]];
- an initial [^], as in [[^0-9]], complements the set
- - [^ ] matches at beginning of line
- - [$ ] matches at end of line
- - [\| ] (infix) alternative between two expressions
- - [\(..\)] grouping and naming of the enclosed expression
- - [\1 ] the text matched by the first [\(...\)] expression
- ([\2] for the second expression, and so on up to [\9])
- - [\b ] matches word boundaries
- - [\ ] quotes special characters. *)
-
-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 the characters in [s]
- starting at position [start] match 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] searchs the string [s] for a substring
- matching the regular expression [r]. The search starts at position
- [start] and proceeds towards the end of the string.
- Return the position of the first character of the matched
- substring, or raise [Not_found] if no substring matches. *)
-
-val search_backward : regexp -> string -> int -> int
-(** Same as {!Str.search_forward}, but the search proceeds towards the
- beginning of the string. *)
-
-val string_partial_match : regexp -> string -> int -> bool
-(** Similar to {!Str.string_match}, but succeeds whenever 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 latest {!Str.string_match}, {!Str.search_forward} or
- {!Str.search_backward}.
- 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 {!Str.string_match},
- {!Str.search_forward} or {!Str.search_backward}. *)
-
-val match_end : unit -> int
-(** [match_end()] returns the position of the character following the
- last character of the substring that was matched by [string_match],
- [search_forward] or [search_backward]. *)
-
-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 during
- the latest {!Str.string_match}, {!Str.search_forward} or
- {!Str.search_backward}.
- The user must make sure that the parameter [s] is the same string
- that was passed to the matching or searching function.
- [matched_group n s] raises [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.
- @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.
- @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 most recent matching
- operation. [s] must be the same string that was matched during
- this matching operation. *)
-
-
-(** {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 and 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
deleted file mode 100644
index 0b518dcbe0..0000000000
--- a/otherlibs/str/strstubs.c
+++ /dev/null
@@ -1,527 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <assert.h>
-#include <string.h>
-#include <ctype.h>
-#include <mlvalues.h>
-#include <alloc.h>
-#include <memory.h>
-#include <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 *) ((long)(p) | 1))
-#define Clear_tag(p) ((value *) ((long)(p) & ~1))
-#define Tag_is_set(p) ((long)(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) ((unsigned long)(x) >> 8)
-#define SignedArg(x) ((long)(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 NUM_GROUPS 32
-struct re_group {
- unsigned char * start;
- unsigned char * end;
-};
-static struct re_group re_group[NUM_GROUPS];
-
-/* 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) {
- 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 */
-static unsigned char re_word_letters[32] = {
- 0, 0, 0, 0, 0, 0, 0, 0, 254, 255, 255, 7, 254, 255, 255, 7,
- 0, 0, 0, 0, 0, 0, 0, 0, 255, 255, 127, 255, 255, 255, 127, 255
-};
-#define Is_word_letter(c) ((re_word_letters[(c) >> 3] >> ((c) & 7)) & 1)
-
-/* The bytecode interpreter for the NFA */
-static int re_match(value re,
- unsigned char * starttxt,
- register unsigned char * txt,
- register unsigned char * endtxt,
- int accept_partial_match)
-{
- register value * pc;
- long instr;
- struct backtrack_stack * stack;
- union backtrack_point * sp;
- value cpool;
- value normtable;
- unsigned char c;
- union backtrack_point back;
-
- { int i;
- struct re_group * p;
- unsigned char ** q;
- for (p = &re_group[1], i = Numgroups(re); 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);
- re_group[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 = &(re_group[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 = &(re_group[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 = &(re_group[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:
- assert(0);
- }
- /* 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 =
- 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) return 0;
- 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);
- re_group[0].end = txt;
- return 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, value str)
-{
- CAMLparam1(str);
- CAMLlocal1(res);
- unsigned char * starttxt = (unsigned char *) String_val(str);
- int n = Numgroups(re);
- int i;
- struct re_group * group;
-
- res = alloc(n * 2, 0);
- for (i = 0; i < n; i++) {
- group = &(re_group[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);
- }
- }
- CAMLreturn(res);
-}
-
-/* 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, string_length(str));
-
- if (txt < starttxt || txt > endtxt)
- invalid_argument("Str.string_match");
- if (re_match(re, starttxt, txt, endtxt, 0)) {
- return re_alloc_groups(re, str);
- } else {
- return Atom(0);
- }
-}
-
-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, string_length(str));
-
- if (txt < starttxt || txt > endtxt)
- invalid_argument("Str.string_partial_match");
- if (re_match(re, starttxt, txt, endtxt, 1)) {
- return re_alloc_groups(re, str);
- } else {
- return Atom(0);
- }
-}
-
-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, string_length(str));
- unsigned char * startchars;
- unsigned char c;
-
- if (txt < starttxt || txt > endtxt)
- invalid_argument("Str.search_forward");
- if (Startchars(re) == -1) {
- do {
- if (re_match(re, starttxt, txt, endtxt, 0))
- return re_alloc_groups(re, str);
- 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++;
- if (re_match(re, starttxt, txt, endtxt, 0))
- return re_alloc_groups(re, str);
- 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, string_length(str));
- unsigned char * startchars;
- unsigned char c;
-
- if (txt < starttxt || txt > endtxt)
- invalid_argument("Str.search_backward");
- if (Startchars(re) == -1) {
- do {
- if (re_match(re, starttxt, txt, endtxt, 0))
- return re_alloc_groups(re, str);
- 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--;
- if (re_match(re, starttxt, txt, endtxt, 0))
- return re_alloc_groups(re, str);
- 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 = string_length(repl);
- while (n > 0) {
- c = *p++; n--;
- if(c != '\\')
- len++;
- else {
- if (n == 0) 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))
- 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)
- failwith("Str.replace: reference to unmatched group");
- len += end - start;
- break;
- default:
- len += 2; break;
- }
- }
- }
- res = alloc_string(len);
- p = String_val(repl);
- q = String_val(res);
- n = 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/.cvsignore b/otherlibs/systhreads/.cvsignore
deleted file mode 100644
index b175e39d68..0000000000
--- a/otherlibs/systhreads/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-*.x
-thread.ml
-so_locations
diff --git a/otherlibs/systhreads/.depend b/otherlibs/systhreads/.depend
deleted file mode 100644
index 6fdbf1c669..0000000000
--- a/otherlibs/systhreads/.depend
+++ /dev/null
@@ -1,27 +0,0 @@
-posix.o: posix.c ../../byterun/alloc.h ../../byterun/misc.h \
- ../../byterun/config.h ../../config/m.h ../../config/s.h \
- ../../byterun/mlvalues.h ../../byterun/backtrace.h \
- ../../byterun/callback.h ../../byterun/custom.h ../../byterun/fail.h \
- ../../byterun/io.h ../../byterun/memory.h ../../byterun/gc.h \
- ../../byterun/major_gc.h ../../byterun/freelist.h \
- ../../byterun/minor_gc.h ../../byterun/printexc.h ../../byterun/roots.h \
- ../../byterun/signals.h ../../byterun/stacks.h ../../byterun/sys.h
-win32.o: win32.c ../../byterun/alloc.h ../../byterun/misc.h \
- ../../byterun/config.h ../../config/m.h ../../config/s.h \
- ../../byterun/mlvalues.h ../../byterun/backtrace.h \
- ../../byterun/callback.h ../../byterun/custom.h ../../byterun/fail.h \
- ../../byterun/io.h ../../byterun/memory.h ../../byterun/gc.h \
- ../../byterun/major_gc.h ../../byterun/freelist.h \
- ../../byterun/minor_gc.h ../../byterun/printexc.h ../../byterun/roots.h \
- ../../byterun/signals.h ../../byterun/stacks.h ../../byterun/sys.h
-condition.cmi: mutex.cmi
-condition.cmo: mutex.cmi condition.cmi
-condition.cmx: mutex.cmx condition.cmi
-event.cmo: condition.cmi mutex.cmi event.cmi
-event.cmx: condition.cmx mutex.cmx event.cmi
-mutex.cmo: mutex.cmi
-mutex.cmx: mutex.cmi
-thread.cmo: thread.cmi
-thread.cmx: thread.cmi
-threadUnix.cmo: thread.cmi threadUnix.cmi
-threadUnix.cmx: thread.cmx threadUnix.cmi
diff --git a/otherlibs/systhreads/Makefile b/otherlibs/systhreads/Makefile
deleted file mode 100644
index 1b7eda46fc..0000000000
--- a/otherlibs/systhreads/Makefile
+++ /dev/null
@@ -1,102 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-include ../../config/Makefile
-
-CAMLC=../../ocamlcomp.sh -I ../unix
-CAMLOPT=../../ocamlcompopt.sh -I ../unix
-MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib
-COMPFLAGS=-warn-error A
-
-BYTECODE_C_OBJS=posix_b.o
-NATIVECODE_C_OBJS=posix_n.o
-
-THREAD_OBJS= thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo
-
-GENFILES=thread.ml
-
-all: libthreads.a threads.cma
-
-allopt: libthreadsnat.a threads.cmxa
-
-libthreads.a: $(BYTECODE_C_OBJS)
- $(MKLIB) -o threads $(BYTECODE_C_OBJS)
-
-posix_b.o: posix.c
- $(BYTECC) -O -I../../byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) \
- -c posix.c
- mv posix.o posix_b.o
-
-# Dynamic linking with -lpthread is risky on many platforms, so
-# do not create a shared object for libthreadsnat.
-libthreadsnat.a: $(NATIVECODE_C_OBJS)
- $(AR) rc libthreadsnat.a $(NATIVECODE_C_OBJS)
-
-posix_n.o: posix.c
- $(NATIVECC) -O -I../../asmrun -I../../byterun $(NATIVECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -DNATIVE_CODE -DTARGET_$(ARCH) -DSYS_$(SYSTEM) -c posix.c
- mv posix.o posix_n.o
-
-threads.cma: $(THREAD_OBJS)
- $(MKLIB) -ocamlc '$(CAMLC)' -o threads $(THREAD_OBJS) \
- -cclib -lunix $(PTHREAD_LINK)
-
-# See remark above: force static linking of libthreadsnat.a
-threads.cmxa: $(THREAD_OBJS:.cmo=.cmx)
- $(CAMLOPT) -a -o threads.cmxa $(THREAD_OBJS:.cmo=.cmx) \
- -cclib -lthreadsnat -cclib -lunix -cclib "$(PTHREAD_LINK)"
-
-$(THREAD_OBJS:.cmo=.cmx): ../../ocamlopt
-
-thread.ml: thread_posix.ml
- ln -s thread_posix.ml thread.ml
-
-partialclean:
- rm -f *.cm*
-
-clean: partialclean
- rm -f *.o *.a *.so
- rm -f $(GENFILES)
-
-install:
- if test -f dllthreads.so; then cp dllthreads.so $(STUBLIBDIR)/dllthreads.so; fi
- cp libthreads.a $(LIBDIR)/libthreads.a
- cd $(LIBDIR); $(RANLIB) libthreads.a
- if test -d $(LIBDIR)/threads; then :; else mkdir $(LIBDIR)/threads; fi
- cp $(THREAD_OBJS:.cmo=.cmi) threads.cma $(LIBDIR)/threads
- rm -f $(LIBDIR)/threads/stdlib.cma
- cp thread.mli mutex.mli condition.mli event.mli threadUnix.mli $(LIBDIR)
-
-installopt:
- cp libthreadsnat.a $(LIBDIR)/libthreadsnat.a
- cd $(LIBDIR); $(RANLIB) libthreadsnat.a
- cp $(THREAD_OBJS:.cmo=.cmx) threads.cmxa threads.a $(LIBDIR)/threads
- cd $(LIBDIR)/threads; $(RANLIB) threads.a
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.mli.cmi:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLC) -c -g $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-depend: $(GENFILES)
- gcc -MM -I../../byterun *.c > .depend
- ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend
-
-include .depend
diff --git a/otherlibs/systhreads/Makefile.Mac b/otherlibs/systhreads/Makefile.Mac
deleted file mode 100644
index e6e0277986..0000000000
--- a/otherlibs/systhreads/Makefile.Mac
+++ /dev/null
@@ -1,78 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Damien Doligez, projet Moscova, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-# systhread library
-# not supported yet: too many bugs in GUSI and in posix.c.
-
-C = sc
-COptions = -includes unix -i ":::byterun:,:::config:,{GUSI}include:" -w 35 ¶
- {cdbgflag} -model far
-
-PPCC = mrc
-PPCCOptions = -includes unix -i ":::byterun:,:::config:,{GUSI}include:" -w 35 ¶
- {cdbgflag}
-
-CAMLC = :::boot:ocamlrun :::ocamlc -I :::stdlib: -I ::unix:
-
-C_OBJS = posix.c.o
-PPCC_OBJS = posix.c.x
-
-THREAD_OBJS = thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo
-THREAD_INTF = thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi
-
-GENFILES = thread.ml
-
-all Ä libthreads.x libthreads.o threads.cma
-
-libthreads.x Ä {PPCC_OBJS}
- ppclink {ldbgflag} -xm library -o libthreads.x {PPCC_OBJS}
-
-libthreads.o Ä {C_OBJS}
- lib {ldbgflag} -o libthreads.o {C_OBJS}
-
-threads.cma Ä {THREAD_OBJS}
- {CAMLC} -a -o threads.cma -custom {THREAD_OBJS}
-
-thread.ml Ä thread_posix.ml
- duplicate -y thread_posix.ml thread.ml
-
-partialclean Ä
- delete -i Å.cmÅ || set status 0
-
-clean Ä partialclean
- delete -i Å.[ox] || set status 0
- delete -i {GENFILES}
-
-install Ä
- duplicate -y libthreads.x libthreads.o "{LIBDIR}"
- if "`exists "{LIBDIR}threads"`" == ""
- newfolder "{LIBDIR}threads"
- end
- duplicate -y {THREAD_INTF} threads.cma "{LIBDIR}threads"
- duplicate -y thread.mli mutex.mli condition.mli event.mli threadUnix.mli ¶
- "{LIBDIR}"
-
-.cmi Ä .mli
- {CAMLC} -c {COMPFLAGS} {depdir}{default}.mli
-
-.cmo Ä .ml
- {CAMLC} -c {COMPFLAGS} {depdir}{default}.ml
-
-depend Ä {GENFILES}
- begin
- MakeDepend -w -objext .x Å.c
- MakeDepend -w Å.c
- :::boot:ocamlrun :::tools:ocamldep -I :::stdlib: -I ::unix: Å.mli Å.ml
- end | streamedit -e "/¶t/ replace // ' ' -c °" > Makefile.Mac.depend
diff --git a/otherlibs/systhreads/Makefile.Mac.depend b/otherlibs/systhreads/Makefile.Mac.depend
deleted file mode 100644
index e9a4ee135a..0000000000
--- a/otherlibs/systhreads/Makefile.Mac.depend
+++ /dev/null
@@ -1,131 +0,0 @@
-#*** Dependencies: Cut here ***
-# These dependencies were produced at 23:43:37 on 27 fŽv 2001 by MakeDepend
-
-:posix.c.x Ä ¶
- :posix.c ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"memory.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:win32.c.x Ä ¶
- :win32.c ¶
- "{CIncludes}"windows.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"memory.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacWindows.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"Aliases.h ¶
- "{CIncludes}"AppleEvents.h ¶
- "{CIncludes}"Collections.h ¶
- "{CIncludes}"Drag.h ¶
- "{CIncludes}"Events.h ¶
- "{CIncludes}"Menus.h ¶
- "{CIncludes}"MixedMode.h ¶
- "{CIncludes}"QDOffscreen.h ¶
- "{CIncludes}"Quickdraw.h ¶
- "{CIncludes}"TextCommon.h ¶
- "{CIncludes}"Icons.h ¶
- "{CIncludes}"MacErrors.h ¶
- "{CIncludes}"AppleTalk.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"Notification.h ¶
- "{CIncludes}"AEDataModel.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"Fonts.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"CodeFragments.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"DateTimeUtils.h
-
-#*** Dependencies: Cut here ***
-# These dependencies were produced at 23:43:42 on 27 fŽv 2001 by MakeDepend
-
-:posix.c.o Ä ¶
- :posix.c ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"memory.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:win32.c.o Ä ¶
- :win32.c ¶
- "{CIncludes}"windows.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"memory.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacWindows.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"Aliases.h ¶
- "{CIncludes}"AppleEvents.h ¶
- "{CIncludes}"Collections.h ¶
- "{CIncludes}"Drag.h ¶
- "{CIncludes}"Events.h ¶
- "{CIncludes}"Menus.h ¶
- "{CIncludes}"MixedMode.h ¶
- "{CIncludes}"QDOffscreen.h ¶
- "{CIncludes}"Quickdraw.h ¶
- "{CIncludes}"TextCommon.h ¶
- "{CIncludes}"Icons.h ¶
- "{CIncludes}"MacErrors.h ¶
- "{CIncludes}"AppleTalk.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"Notification.h ¶
- "{CIncludes}"AEDataModel.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"Fonts.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"CodeFragments.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"DateTimeUtils.h
-
-condition.cmiÄ mutex.cmi
-thread.cmiÄ ::unix:unix.cmi
-threadUnix.cmiÄ ::unix:unix.cmi
-condition.cmoÄ mutex.cmi condition.cmi
-condition.cmxÄ mutex.cmx condition.cmi
-event.cmoÄ :::stdlib:array.cmi condition.cmi :::stdlib:list.cmi mutex.cmi ¶
- :::stdlib:queue.cmi :::stdlib:random.cmi event.cmi
-event.cmxÄ :::stdlib:array.cmx condition.cmx :::stdlib:list.cmx mutex.cmx ¶
- :::stdlib:queue.cmx :::stdlib:random.cmx event.cmi
-mutex.cmoÄ mutex.cmi
-mutex.cmxÄ mutex.cmi
-thread.cmoÄ :::stdlib:printexc.cmi :::stdlib:printf.cmi :::stdlib:sys.cmi ¶
- ::unix:unix.cmi thread.cmi
-thread.cmxÄ :::stdlib:printexc.cmx :::stdlib:printf.cmx :::stdlib:sys.cmx ¶
- ::unix:unix.cmx thread.cmi
-thread_posix.cmoÄ :::stdlib:printexc.cmi :::stdlib:printf.cmi ¶
- :::stdlib:sys.cmi ::unix:unix.cmi
-thread_posix.cmxÄ :::stdlib:printexc.cmx :::stdlib:printf.cmx ¶
- :::stdlib:sys.cmx ::unix:unix.cmx
-thread_win32.cmoÄ :::stdlib:printexc.cmi :::stdlib:printf.cmi ¶
- :::stdlib:sys.cmi ::unix:unix.cmi
-thread_win32.cmxÄ :::stdlib:printexc.cmx :::stdlib:printf.cmx ¶
- :::stdlib:sys.cmx ::unix:unix.cmx
-threadUnix.cmoÄ thread.cmi ::unix:unix.cmi threadUnix.cmi
-threadUnix.cmxÄ thread.cmx ::unix:unix.cmx threadUnix.cmi
diff --git a/otherlibs/systhreads/Makefile.nt b/otherlibs/systhreads/Makefile.nt
deleted file mode 100644
index 530a08e5eb..0000000000
--- a/otherlibs/systhreads/Makefile.nt
+++ /dev/null
@@ -1,96 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-include ../../config/Makefile
-
-# Compilation options
-CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib -I ../win32unix
-CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -I ../win32unix
-
-THREAD_OBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo
-
-GENFILES=thread.ml
-
-all: dllthreads.dll libthreads.$(A) threads.cma
-
-allopt: libthreadsnat.$(A) threads.cmxa
-
-dllthreads.dll: win32_b.$(DO)
- $(call MKDLL,dllthreads.dll,tmp.$(A),win32_b.$(DO) ../../byterun/ocamlrun.$(A))
- rm tmp.*
-
-libthreads.$(A): win32_b.$(SO)
- $(call MKLIB,libthreads.$(A),win32_b.$(SO))
-
-win32_b.$(DO): win32.c
- $(BYTECC) -I../../byterun $(DLLCCCOMPOPTS) -c win32.c
- mv win32.$(O) win32_b.$(DO)
-
-win32_b.$(SO): win32.c
- $(BYTECC) -I../../byterun $(BYTECCCOMPOPTS) -c win32.c
- mv win32.$(O) win32_b.$(SO)
-
-libthreadsnat.$(A): win32_n.$(O)
- $(call MKLIB,libthreadsnat.$(A),win32_n.$(O))
-
-win32_n.$(O): win32.c
- $(NATIVECC) -DNATIVE_CODE -O -I../../asmrun -I../../byterun $(NATIVECCCOMPOPTS) -c win32.c
- mv win32.$(O) win32_n.$(O)
-
-threads.cma: $(THREAD_OBJS)
- $(CAMLC) -a -o threads.cma $(THREAD_OBJS) \
- -dllib -lthreads -cclib -lthreads
-
-threads.cmxa: $(THREAD_OBJS:.cmo=.cmx)
- $(CAMLOPT) -a -o threads.cmxa $(THREAD_OBJS:.cmo=.cmx) \
- -cclib -lthreadsnat
-
-$(THREAD_OBJS:.cmo=.cmx): ../../ocamlopt
-
-thread.ml: thread_win32.ml
- cp thread_win32.ml thread.ml
-
-partialclean:
- rm -f *.cm*
-
-clean: partialclean
- rm -f *.dll *.$(A) *.$(O)
- rm -f $(GENFILES)
-
-install:
- cp dllthreads.dll $(STUBLIBDIR)/dllthreads.dll
- cp libthreads.$(A) $(LIBDIR)/libthreads.$(A)
- mkdir -p $(LIBDIR)/threads
- cp $(THREAD_OBJS:.cmo=.cmi) threads.cma $(LIBDIR)/threads
- rm -f $(LIBDIR)/threads/stdlib.cma
-
-installopt:
- cp libthreadsnat.$(A) $(LIBDIR)/libthreadsnat.$(A)
- cp $(THREAD_OBJS:.cmo=.cmx) threads.cmxa threads.$(A) $(LIBDIR)/threads
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.mli.cmi:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLC) -c -g $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-depend:
-
-include .depend
diff --git a/otherlibs/systhreads/Tests/Makefile b/otherlibs/systhreads/Tests/Makefile
deleted file mode 100644
index 4d860b3e0c..0000000000
--- a/otherlibs/systhreads/Tests/Makefile
+++ /dev/null
@@ -1,44 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../../LICENSE.#
-# #
-#########################################################################
-
-# $Id$
-
-PROGS=test1.byt test2.byt test3.byt test4.byt test5.byt test6.byt \
- test7.byt test8.byt test9.byt testA.byt sieve.byt \
- testio.byt testsocket.byt testsignal.byt testsignal2.byt \
- torture.byt
-
-include ../../../config/Makefile
-
-CAMLC=../../../boot/ocamlrun ../../../ocamlc -I .. -I ../../unix -I ../../../stdlib
-
-CAMLOPT=../../../boot/ocamlrun ../../../ocamlopt -I .. -I ../../unix -I ../../../stdlib
-
-all: $(PROGS)
-
-allopt: $(PROGS:.byt=.out)
-
-clean:
- rm -f *.cm* *.byt *.out
- rm -f $(PROGS:.byt=.ml)
-
-%.byt: ../../threads/Tests/%.ml
- cp ../../threads/Tests/$*.ml $*.ml
- $(CAMLC) -custom -o $*.byt unix.cma threads.cma $*.ml ../libthreads.a ../../unix/libunix.a -cclib -lpthread
-
-%.out: ../../threads/Tests/%.ml
- cp ../../threads/Tests/$*.ml $*.ml
- $(CAMLOPT) -o $*.out unix.cmxa threads.cmxa $*.ml ../libthreadsnat.a ../../unix/libunix.a -cclib -lpthread
-
-$(PROGS): ../threads.cma ../libthreads.a
-$(PROGS:.byt=.out): ../threads.cmxa ../libthreadsnat.a
diff --git a/otherlibs/systhreads/Tests/Makefile.nt b/otherlibs/systhreads/Tests/Makefile.nt
deleted file mode 100644
index bc3cf96afc..0000000000
--- a/otherlibs/systhreads/Tests/Makefile.nt
+++ /dev/null
@@ -1,43 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../../LICENSE.#
-# #
-#########################################################################
-
-# $Id$
-
-PROGS=test1.byt test2.byt test3.byt test4.byt test5.byt test6.byt \
- test7.byt test8.byt test9.byt testA.byt sieve.byt \
- testio.byt testsocket.byt testwait.byt testsignal.byt testsignal2.byt \
- torture.byt
-
-include ../../../config/Makefile
-
-CAMLC=../../../boot/ocamlrun ../../../ocamlc -I .. -I ../../unix -I ../../../stdlib
-
-CAMLOPT=../../../boot/ocamlrun ../../../ocamlopt -I .. -I ../../unix -I ../../../stdlib
-
-all: $(PROGS)
-
-allopt: $(PROGS:.byt=.out)
-
-clean:
- rm -f *.cm* *.byt *.out
- rm -f $(PROGS:.byt=.ml)
-
-%.byt: ../../threads/Tests/%.ml
- cp ../../threads/Tests/$*.ml $*.ml
- $(CAMLC) -custom -o $*.byt unix.cma threads.cma $*.ml ../libthreads.$(A) ../../unix/libunix.$(A)
-
-%.out: ../../threads/Tests/%.ml
- cp ../../threads/Tests/$*.ml $*.ml
- $(CAMLOPT) -o $*.out unix.cmxa threads.cmxa $*.ml ../libthreadsnat.$(A) ../../unix/libunix.$(A) -cclib -lpthread
-
-$(PROGS): ../threads.cma ../libthreads.$(A)
diff --git a/otherlibs/systhreads/condition.ml b/otherlibs/systhreads/condition.ml
deleted file mode 100644
index 6549c642d8..0000000000
--- a/otherlibs/systhreads/condition.ml
+++ /dev/null
@@ -1,20 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Caml Special Light *)
-(* *)
-(* 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 Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-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
deleted file mode 100644
index 02c108b7b1..0000000000
--- a/otherlibs/systhreads/condition.mli
+++ /dev/null
@@ -1,53 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy and Damien Doligez, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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 satified *) 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
deleted file mode 100644
index bd47d6526a..0000000000
--- a/otherlibs/systhreads/event.ml
+++ /dev/null
@@ -1,274 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* 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 Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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.create (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.create(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
deleted file mode 100644
index 21d5459a57..0000000000
--- a/otherlibs/systhreads/event.mli
+++ /dev/null
@@ -1,82 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* 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 Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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
deleted file mode 100644
index 4e108f4a9f..0000000000
--- a/otherlibs/systhreads/mutex.ml
+++ /dev/null
@@ -1,20 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Caml Special Light *)
-(* *)
-(* 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 Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-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
deleted file mode 100644
index 0c41c843e8..0000000000
--- a/otherlibs/systhreads/mutex.mli
+++ /dev/null
@@ -1,50 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy and Damien Doligez, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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/posix.c b/otherlibs/systhreads/posix.c
deleted file mode 100644
index cf5f90dfab..0000000000
--- a/otherlibs/systhreads/posix.c
+++ /dev/null
@@ -1,820 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Thread interface for POSIX 1003.1c threads */
-
-#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
-#include "alloc.h"
-#include "backtrace.h"
-#include "callback.h"
-#include "custom.h"
-#include "fail.h"
-#include "io.h"
-#include "memory.h"
-#include "misc.h"
-#include "mlvalues.h"
-#include "printexc.h"
-#include "roots.h"
-#include "signals.h"
-#ifdef NATIVE_CODE
-#include "stack.h"
-#else
-#include "stacks.h"
-#endif
-#include "sys.h"
-
-/* Initial size of stack when a thread is created (4 Ko) */
-#define Thread_stack_size (Stack_size / 4)
-
-/* Max computation time before rescheduling, in microseconds (50ms) */
-#define Thread_timeout 50000
-
-/* 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; /* Mutex held while the thread is running */
-};
-
-#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 {
- pthread_t pthread; /* The Posix thread id */
- 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 * bottom_of_stack; /* Saved value of caml_bottom_of_stack */
- unsigned long 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 */
-#else
- value * stack_low; /* The execution stack for this thread */
- value * stack_high;
- value * stack_threshold;
- value * sp; /* Saved value of extern_sp for this thread */
- value * trapsp; /* Saved value of trapsp for this thread */
- struct caml__roots_block * local_roots; /* Saved value of local_roots */
- struct longjmp_buffer * external_raise; /* Saved external_raise */
- int backtrace_pos; /* Saved backtrace_pos */
- code_t * backtrace_buffer; /* Saved backtrace_buffer */
- value backtrace_last_exn; /* Saved backtrace_last_exn (root) */
-#endif
-};
-
-typedef struct caml_thread_struct * caml_thread_t;
-
-/* The descriptor for the currently executing thread */
-
-static caml_thread_t curr_thread = NULL;
-
-/* The global mutex used to ensure that at most one thread is running
- Caml code */
-static pthread_mutex_t caml_mutex;
-
-/* The key used for storing the thread descriptor in the specific data
- of the corresponding Posix thread. */
-static pthread_key_t thread_descriptor_key;
-
-/* The key used for unlocking I/O channels on exceptions */
-static pthread_key_t last_channel_locked_key;
-
-/* Identifier for next thread creation */
-static long thread_next_ident = 0;
-
-/* Forward declarations */
-value caml_threadstatus_new (void);
-void caml_threadstatus_terminate (value);
-int caml_threadstatus_wait (value);
-static void caml_pthread_check (int, char *);
-
-/* Imports for the native-code compiler */
-extern struct longjmp_buffer caml_termination_jmpbuf;
-extern void (*caml_termination_hook)(void *);
-
-/* 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);
-#ifndef NATIVE_CODE
- (*action)(th->backtrace_last_exn, &th->backtrace_last_exn);
-#endif
- /* 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)
- do_local_roots(action, th->bottom_of_stack, th->last_retaddr,
- th->gc_regs, th->local_roots);
-#else
- 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);
-}
-
-/* Hooks for enter_blocking_section and leave_blocking_section */
-
-static void (*prev_enter_blocking_section_hook) () = NULL;
-static void (*prev_leave_blocking_section_hook) () = NULL;
-
-static void caml_thread_enter_blocking_section(void)
-{
- if (prev_enter_blocking_section_hook != NULL)
- (*prev_enter_blocking_section_hook)();
- /* Save the stack-related global variables in the thread descriptor
- of the current thread */
-#ifdef NATIVE_CODE
- 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 = local_roots;
-#else
- curr_thread->stack_low = stack_low;
- curr_thread->stack_high = stack_high;
- curr_thread->stack_threshold = stack_threshold;
- curr_thread->sp = extern_sp;
- curr_thread->trapsp = trapsp;
- curr_thread->local_roots = local_roots;
- curr_thread->external_raise = external_raise;
- curr_thread->backtrace_pos = backtrace_pos;
- curr_thread->backtrace_buffer = backtrace_buffer;
- curr_thread->backtrace_last_exn = backtrace_last_exn;
-#endif
- /* Release the global mutex */
- pthread_mutex_unlock(&caml_mutex);
-}
-
-static void caml_thread_leave_blocking_section(void)
-{
- /* Re-acquire the global mutex */
- pthread_mutex_lock(&caml_mutex);
- /* Update curr_thread to point to the thread descriptor corresponding
- to the thread currently executing */
- curr_thread = pthread_getspecific(thread_descriptor_key);
- /* Restore the stack-related global variables */
-#ifdef NATIVE_CODE
- 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;
- local_roots = curr_thread->local_roots;
-#else
- stack_low = curr_thread->stack_low;
- stack_high = curr_thread->stack_high;
- stack_threshold = curr_thread->stack_threshold;
- extern_sp = curr_thread->sp;
- trapsp = curr_thread->trapsp;
- local_roots = curr_thread->local_roots;
- external_raise = curr_thread->external_raise;
- backtrace_pos = curr_thread->backtrace_pos;
- backtrace_buffer = curr_thread->backtrace_buffer;
- backtrace_last_exn = curr_thread->backtrace_last_exn;
-#endif
- if (prev_leave_blocking_section_hook != NULL)
- (*prev_leave_blocking_section_hook)();
-}
-
-/* Hooks for I/O locking */
-
-static void caml_io_mutex_free(struct channel *chan)
-{
- pthread_mutex_t * mutex = chan->mutex;
- if (mutex != NULL) {
- pthread_mutex_destroy(mutex);
- stat_free((char *) mutex);
- }
-}
-
-static void caml_io_mutex_lock(struct channel *chan)
-{
- if (chan->mutex == NULL) {
- pthread_mutex_t * mutex =
- (pthread_mutex_t *) stat_alloc(sizeof(pthread_mutex_t));
- pthread_mutex_init(mutex, NULL);
- chan->mutex = (void *) mutex;
- }
- enter_blocking_section();
- pthread_mutex_lock(chan->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. */
- pthread_setspecific(last_channel_locked_key, (void *) chan);
- leave_blocking_section();
-}
-
-static void caml_io_mutex_unlock(struct channel *chan)
-{
- pthread_mutex_unlock(chan->mutex);
- pthread_setspecific(last_channel_locked_key, NULL);
-}
-
-static void caml_io_mutex_unlock_exn(void)
-{
- struct channel * chan = pthread_getspecific(last_channel_locked_key);
- if (chan != NULL) caml_io_mutex_unlock(chan);
-}
-
-/* The "tick" thread fakes a SIGVTALRM signal at regular intervals. */
-
-static void * caml_thread_tick(void * arg)
-{
- struct timeval timeout;
- sigset_t mask;
-#ifdef __linux__
- int tickcount = 0;
-#endif
-
- /* Block all signals so that we don't try to execute
- a Caml signal handler */
- sigfillset(&mask);
- pthread_sigmask(SIG_BLOCK, &mask, NULL);
- while(1) {
- /* 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;
- select(0, NULL, NULL, NULL, &timeout);
- /* This signal should never cause a callback, so don't go through
- handle_signal(), tweak the global variable directly. */
- if (pending_signal == 0) pending_signal = SIGVTALRM;
-#ifdef NATIVE_CODE
- young_limit = young_end;
-#else
- something_to_do = 1;
-#endif
-#ifdef __linux__
- /* Hack around LinuxThreads' non-standard signal handling:
- if program is killed on a signal, e.g. SIGINT, the current
- thread will not die on this signal (because of the signal blocking
- above). Hence, periodically check that the thread manager (our
- parent process) still exists. */
- tickcount++;
- if (tickcount >= 2000000 / Thread_timeout) { /* every 2 secs approx */
- tickcount = 0;
- if (getppid() == 1) pthread_exit(NULL);
- }
-#endif
- }
- return NULL; /* prevents compiler warning */
-}
-
-/* Initialize the thread machinery */
-
-value caml_thread_initialize(value unit) /* ML */
-{
- pthread_t tick_pthread;
- pthread_attr_t attr;
- value mu = Val_unit;
- value descr;
-
- /* Protect against repeated initialization (PR#1325) */
- if (curr_thread != NULL) return Val_unit;
- Begin_root (mu);
- /* Initialize the main mutex */
- caml_pthread_check(pthread_mutex_init(&caml_mutex, NULL),
- "Thread.init");
- pthread_mutex_lock(&caml_mutex);
- /* Initialize the keys */
- pthread_key_create(&thread_descriptor_key, NULL);
- pthread_key_create(&last_channel_locked_key, NULL);
- /* Create and initialize the termination semaphore */
- mu = caml_threadstatus_new();
- /* Create a descriptor for the current thread */
- descr = alloc_small(3, 0);
- Ident(descr) = Val_long(thread_next_ident);
- Start_closure(descr) = Val_unit;
- Terminated(descr) = mu;
- thread_next_ident++;
- /* Create an info block for the current thread */
- curr_thread =
- (caml_thread_t) stat_alloc(sizeof(struct caml_thread_struct));
- curr_thread->pthread = pthread_self();
- curr_thread->descr = descr;
- curr_thread->next = curr_thread;
- curr_thread->prev = curr_thread;
-#ifdef NATIVE_CODE
- curr_thread->exit_buf = &caml_termination_jmpbuf;
-#endif
- /* The stack-related fields will be filled in at the next
- enter_blocking_section */
- /* Associate the thread descriptor with the thread */
- pthread_setspecific(thread_descriptor_key, (void *) curr_thread);
- /* Set up the hooks */
- prev_scan_roots_hook = scan_roots_hook;
- scan_roots_hook = caml_thread_scan_roots;
- prev_enter_blocking_section_hook = enter_blocking_section_hook;
- enter_blocking_section_hook = caml_thread_enter_blocking_section;
- prev_leave_blocking_section_hook = leave_blocking_section_hook;
- leave_blocking_section_hook = caml_thread_leave_blocking_section;
-#ifdef NATIVE_CODE
- caml_termination_hook = pthread_exit;
-#endif
- channel_mutex_free = caml_io_mutex_free;
- channel_mutex_lock = caml_io_mutex_lock;
- channel_mutex_unlock = caml_io_mutex_unlock;
- channel_mutex_unlock_exn = caml_io_mutex_unlock_exn;
- /* Fork the tick thread */
- pthread_attr_init(&attr);
- pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);
- caml_pthread_check(
- pthread_create(&tick_pthread, &attr, caml_thread_tick, NULL),
- "Thread.init");
- End_roots();
- return Val_unit;
-}
-
-/* Thread cleanup at termination */
-
-static void caml_thread_stop(void)
-{
- caml_thread_t th = curr_thread;
-
- /* Signal that the thread has terminated */
- caml_threadstatus_terminate(Terminated(th->descr));
- /* Remove th from the doubly-linked list of threads */
- th->next->prev = th->prev;
- th->prev->next = th->next;
- /* Release the main mutex (forever) */
- async_signal_mode = 1;
- pthread_mutex_unlock(&caml_mutex);
-#ifndef NATIVE_CODE
- /* Free the memory resources */
- stat_free(th->stack_low);
- if (th->backtrace_buffer != NULL) free(th->backtrace_buffer);
-#endif
- /* Free the thread descriptor */
- stat_free(th);
-}
-
-/* Create a thread */
-
-static void * caml_thread_start(void * arg)
-{
- caml_thread_t th = (caml_thread_t) arg;
- value clos;
- struct longjmp_buffer termination_buf;
-
- /* Associate the thread descriptor with the thread */
- pthread_setspecific(thread_descriptor_key, (void *) th);
- /* Acquire the global mutex and set up the stack variables */
- leave_blocking_section();
-#ifdef NATIVE_CODE
- /* 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);
- modify(&(Start_closure(th->descr)), Val_unit);
- callback_exn(clos, Val_unit);
- caml_thread_stop();
-#ifdef NATIVE_CODE
- }
-#endif
- /* The thread now stops running */
- return NULL;
-}
-
-value caml_thread_new(value clos) /* ML */
-{
- pthread_attr_t attr;
- caml_thread_t th;
- value mu = Val_unit;
- value descr;
- int err;
-
- Begin_roots2 (clos, mu)
- /* Create and initialize the termination semaphore */
- mu = caml_threadstatus_new();
- /* Create a descriptor for the new thread */
- descr = alloc_small(3, 0);
- Ident(descr) = Val_long(thread_next_ident);
- Start_closure(descr) = clos;
- Terminated(descr) = mu;
- thread_next_ident++;
- /* Create an info block for the current thread */
- th = (caml_thread_t) stat_alloc(sizeof(struct caml_thread_struct));
- th->descr = descr;
-#ifdef NATIVE_CODE
- th->bottom_of_stack = NULL;
- th->exception_pointer = NULL;
- th->local_roots = NULL;
-#else
- /* Allocate the stacks */
- th->stack_low = (value *) 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;
- th->backtrace_pos = 0;
- th->backtrace_buffer = NULL;
- th->backtrace_last_exn = Val_unit;
-#endif
- /* 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;
- /* Fork the new thread */
- pthread_attr_init(&attr);
- pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);
- err = pthread_create(&th->pthread, &attr, caml_thread_start, (void *) th);
- if (err != 0) {
- /* Fork failed, remove thread info block from list of threads */
- th->next->prev = curr_thread;
- curr_thread->next = th->next;
-#ifndef NATIVE_CODE
- stat_free(th->stack_low);
-#endif
- stat_free(th);
- caml_pthread_check(err, "Thread.create");
- }
- End_roots();
- return descr;
-}
-
-/* Return the current thread */
-
-value caml_thread_self(value unit) /* ML */
-{
- if (curr_thread == NULL) invalid_argument("Thread.self: not initialized");
- return curr_thread->descr;
-}
-
-/* Return the identifier of a thread */
-
-value caml_thread_id(value th) /* ML */
-{
- return Ident(th);
-}
-
-/* Print uncaught exception and backtrace */
-
-value caml_thread_uncaught_exception(value exn) /* ML */
-{
- char * msg = format_caml_exception(exn);
- fprintf(stderr, "Thread %d killed on uncaught exception %s\n",
- Int_val(Ident(curr_thread->descr)), msg);
- free(msg);
-#ifndef NATIVE_CODE
- if (backtrace_active) print_exception_backtrace();
-#endif
- fflush(stderr);
- return Val_unit;
-}
-
-/* Terminate current thread */
-
-value caml_thread_exit(value unit) /* ML */
-{
-#ifdef 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. */
- struct longjmp_buffer * exit_buf;
- if (curr_thread == NULL) invalid_argument("Thread.exit: not initialized");
- exit_buf = curr_thread->exit_buf;
- caml_thread_stop();
- siglongjmp(exit_buf->buf, 1);
-#else
- /* No such problem in bytecode */
- if (curr_thread == NULL) invalid_argument("Thread.exit: not initialized");
- caml_thread_stop();
- pthread_exit(NULL);
-#endif
- return Val_unit; /* not reached */
-}
-
-/* Allow re-scheduling */
-
-value caml_thread_yield(value unit) /* ML */
-{
- enter_blocking_section();
- sched_yield();
- leave_blocking_section();
- return Val_unit;
-}
-
-/* Suspend the current thread until another thread terminates */
-
-value caml_thread_join(value th) /* ML */
-{
- int retcode = caml_threadstatus_wait(Terminated(th));
- caml_pthread_check(retcode, "Thread.join");
- return Val_unit;
-}
-
-/* Mutex operations */
-
-#define Mutex_val(v) (* ((pthread_mutex_t **) Data_custom_val(v)))
-#define Max_mutex_number 1000
-
-static void caml_mutex_finalize(value wrapper)
-{
- pthread_mutex_t * mut = Mutex_val(wrapper);
- pthread_mutex_destroy(mut);
- stat_free(mut);
-}
-
-static int caml_mutex_condition_compare(value wrapper1, value wrapper2)
-{
- pthread_mutex_t * mut1 = Mutex_val(wrapper1);
- pthread_mutex_t * mut2 = Mutex_val(wrapper2);
- return mut1 == mut2 ? 0 : mut1 < mut2 ? -1 : 1;
-}
-
-static struct custom_operations caml_mutex_ops = {
- "_mutex",
- caml_mutex_finalize,
- caml_mutex_condition_compare,
- custom_hash_default,
- custom_serialize_default,
- custom_deserialize_default
-};
-
-value caml_mutex_new(value unit) /* ML */
-{
- pthread_mutex_t * mut;
- value wrapper;
- mut = stat_alloc(sizeof(pthread_mutex_t));
- caml_pthread_check(pthread_mutex_init(mut, NULL), "Mutex.create");
- wrapper = alloc_custom(&caml_mutex_ops, sizeof(pthread_mutex_t *),
- 1, Max_mutex_number);
- Mutex_val(wrapper) = mut;
- return wrapper;
-}
-
-value caml_mutex_lock(value wrapper) /* ML */
-{
- int retcode;
- pthread_mutex_t * mut = Mutex_val(wrapper);
- Begin_root(wrapper) /* prevent the deallocation of mutex */
- enter_blocking_section();
- retcode = pthread_mutex_lock(mut);
- leave_blocking_section();
- End_roots();
- caml_pthread_check(retcode, "Mutex.lock");
- return Val_unit;
-}
-
-value caml_mutex_unlock(value wrapper) /* ML */
-{
- int retcode;
- pthread_mutex_t * mut = Mutex_val(wrapper);
- Begin_root(wrapper) /* prevent the deallocation of mutex */
- enter_blocking_section();
- retcode = pthread_mutex_unlock(mut);
- leave_blocking_section();
- End_roots();
- caml_pthread_check(retcode, "Mutex.unlock");
- return Val_unit;
-}
-
-value caml_mutex_try_lock(value wrapper) /* ML */
-{
- int retcode;
- pthread_mutex_t * mut = Mutex_val(wrapper);
- retcode = pthread_mutex_trylock(mut);
- if (retcode == EBUSY) return Val_false;
- caml_pthread_check(retcode, "Mutex.try_lock");
- return Val_true;
-}
-
-/* Conditions operations */
-
-#define Condition_val(v) (* ((pthread_cond_t **) Data_custom_val(v)))
-#define Max_condition_number 1000
-
-static void caml_condition_finalize(value wrapper)
-{
- pthread_cond_t * cond = Condition_val(wrapper);
- pthread_cond_destroy(cond);
- stat_free(cond);
-}
-
-static struct custom_operations caml_condition_ops = {
- "_condition",
- caml_condition_finalize,
- caml_mutex_condition_compare,
- custom_hash_default,
- custom_serialize_default,
- custom_deserialize_default
-};
-
-value caml_condition_new(value unit) /* ML */
-{
- pthread_cond_t * cond;
- value wrapper;
- cond = stat_alloc(sizeof(pthread_cond_t));
- caml_pthread_check(pthread_cond_init(cond, NULL), "Condition.create");
- wrapper = alloc_custom(&caml_condition_ops, sizeof(pthread_cond_t *),
- 1, Max_condition_number);
- Condition_val(wrapper) = cond;
- return wrapper;
-}
-
-value caml_condition_wait(value wcond, value wmut) /* ML */
-{
- int retcode;
- pthread_cond_t * cond = Condition_val(wcond);
- pthread_mutex_t * mut = Mutex_val(wmut);
- Begin_roots2(wcond, wmut) /* prevent deallocation of cond and mutex */
- enter_blocking_section();
- retcode = pthread_cond_wait(cond, mut);
- leave_blocking_section();
- End_roots();
- caml_pthread_check(retcode, "Condition.wait");
- return Val_unit;
-}
-
-value caml_condition_signal(value wrapper) /* ML */
-{
- int retcode;
- pthread_cond_t * cond = Condition_val(wrapper);
- Begin_root(wrapper) /* prevent deallocation of condition */
- enter_blocking_section();
- retcode = pthread_cond_signal(cond);
- leave_blocking_section();
- End_roots();
- caml_pthread_check(retcode, "Condition.signal");
- return Val_unit;
-}
-
-value caml_condition_broadcast(value wrapper) /* ML */
-{
- int retcode;
- pthread_cond_t * cond = Condition_val(wrapper);
- Begin_root(wrapper) /* prevent deallocation of condition */
- enter_blocking_section();
- retcode = pthread_cond_broadcast(cond);
- leave_blocking_section();
- End_roots();
- caml_pthread_check(retcode, "Condition.broadcast");
- return Val_unit;
-}
-
-/* Thread status blocks */
-
-struct caml_threadstatus {
- pthread_mutex_t lock; /* mutex for mutual exclusion */
- enum { ALIVE, TERMINATED } status; /* status of thread */
- pthread_cond_t terminated; /* signaled when thread terminates */
-};
-
-#define Threadstatus_val(v) \
- (* ((struct caml_threadstatus **) Data_custom_val(v)))
-#define Max_threadstatus_number 500
-
-static void caml_threadstatus_finalize(value wrapper)
-{
- struct caml_threadstatus * ts = Threadstatus_val(wrapper);
- pthread_mutex_destroy(&ts->lock);
- pthread_cond_destroy(&ts->terminated);
- stat_free(ts);
-}
-
-static struct custom_operations caml_threadstatus_ops = {
- "_threadstatus",
- caml_threadstatus_finalize,
- caml_mutex_condition_compare,
- custom_hash_default,
- custom_serialize_default,
- custom_deserialize_default
-};
-
-value caml_threadstatus_new (void)
-{
- struct caml_threadstatus * ts;
- value wrapper;
- ts = stat_alloc(sizeof(struct caml_threadstatus));
- caml_pthread_check(pthread_mutex_init(&ts->lock, NULL), "Thread.create");
- caml_pthread_check(pthread_cond_init(&ts->terminated, NULL),
- "Thread.create");
- ts->status = ALIVE;
- wrapper = alloc_custom(&caml_threadstatus_ops,
- sizeof(struct caml_threadstatus *),
- 1, Max_threadstatus_number);
- Threadstatus_val(wrapper) = ts;
- return wrapper;
-}
-
-void caml_threadstatus_terminate (value wrapper)
-{
- struct caml_threadstatus * ts = Threadstatus_val(wrapper);
- pthread_mutex_lock(&ts->lock);
- ts->status = TERMINATED;
- pthread_mutex_unlock(&ts->lock);
- pthread_cond_broadcast(&ts->terminated);
-}
-
-int caml_threadstatus_wait (value wrapper)
-{
- struct caml_threadstatus * ts = Threadstatus_val(wrapper);
- int retcode;
-
- Begin_roots1(wrapper) /* prevent deallocation of ts */
- enter_blocking_section();
- retcode = pthread_mutex_lock(&ts->lock);
- if (retcode != 0) goto error;
- while (ts->status != TERMINATED) {
- retcode = pthread_cond_wait(&ts->terminated, &ts->lock);
- if (retcode != 0) goto error;
- }
- retcode = pthread_mutex_unlock(&ts->lock);
- error:
- leave_blocking_section();
- End_roots();
- return retcode;
-}
-
-/* Synchronous signal wait */
-
-value caml_wait_signal(value sigs) /* ML */
-{
-#ifdef HAS_SIGWAIT
- sigset_t set;
- int retcode, signo;
-
- sigemptyset(&set);
- while (sigs != Val_int(0)) {
- int sig = convert_signal_number(Int_val(Field(sigs, 0)));
- sigaddset(&set, sig);
- sigs = Field(sigs, 1);
- }
- enter_blocking_section();
- retcode = sigwait(&set, &signo);
- leave_blocking_section();
- caml_pthread_check(retcode, "Thread.wait_signal");
- return Val_int(signo);
-#else
- invalid_argument("Thread.wait_signal not implemented");
- return Val_int(0); /* not reached */
-#endif
-}
-
-/* Error report */
-
-static void caml_pthread_check(int retcode, char *msg)
-{
- char * err;
- int errlen, msglen;
- value str;
-
- if (retcode == 0) return;
- err = strerror(retcode);
- msglen = strlen(msg);
- errlen = strlen(err);
- str = alloc_string(msglen + 2 + errlen);
- memmove (&Byte(str, 0), msg, msglen);
- memmove (&Byte(str, msglen), ": ", 2);
- memmove (&Byte(str, msglen + 2), err, errlen);
- raise_sys_error(str);
-}
diff --git a/otherlibs/systhreads/thread.mli b/otherlibs/systhreads/thread.mli
deleted file mode 100644
index fbc3d6a8cf..0000000000
--- a/otherlibs/systhreads/thread.mli
+++ /dev/null
@@ -1,111 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* 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 Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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. *)
-
-external self : unit -> t = "caml_thread_self"
-(** Return the thread currently executing. *)
-
-external id : t -> int = "caml_thread_id"
-(** 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. *)
-
-external join : t -> unit = "caml_thread_join"
-(** [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 thead 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 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. *)
diff --git a/otherlibs/systhreads/threadUnix.ml b/otherlibs/systhreads/threadUnix.ml
deleted file mode 100644
index 71855ec696..0000000000
--- a/otherlibs/systhreads/threadUnix.ml
+++ /dev/null
@@ -1,59 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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 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 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 sendto = Unix.sendto
-
-let open_connection = Unix.open_connection
diff --git a/otherlibs/systhreads/threadUnix.mli b/otherlibs/systhreads/threadUnix.mli
deleted file mode 100644
index c05346fef3..0000000000
--- a/otherlibs/systhreads/threadUnix.mli
+++ /dev/null
@@ -1,85 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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 -> string -> int -> int -> int
-val write : Unix.file_descr -> string -> int -> int -> int
-
-(** {6 Input/output with timeout} *)
-
-val timed_read :
- Unix.file_descr ->
- string -> int -> int -> float -> int
-(** See {!ThreadUnix.timed_write}. *)
-
-val timed_write :
- Unix.file_descr ->
- string -> 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. *)
-
-(** {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 : 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 : Unix.socket_domain ->
- Unix.socket_type -> int -> Unix.file_descr
-val accept : Unix.file_descr -> Unix.file_descr * Unix.sockaddr
-val connect : Unix.file_descr -> Unix.sockaddr -> unit
-val recv : Unix.file_descr -> string ->
- int -> int -> Unix.msg_flag list -> int
-val recvfrom : Unix.file_descr -> string -> int -> int ->
- Unix.msg_flag list -> int * Unix.sockaddr
-val send : Unix.file_descr -> string -> int -> int ->
- Unix.msg_flag list -> int
-val sendto : 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/thread_posix.ml b/otherlibs/systhreads/thread_posix.ml
deleted file mode 100644
index ebd54c4cf6..0000000000
--- a/otherlibs/systhreads/thread_posix.ml
+++ /dev/null
@@ -1,73 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* 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 Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* User-level threads *)
-
-type t
-
-external thread_initialize : unit -> unit = "caml_thread_initialize"
-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"
-external id : t -> int = "caml_thread_id"
-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 _ =
- ignore(Sys.signal Sys.sigvtalrm (Sys.Signal_handle preempt));
- thread_initialize()
-
-(* 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 wait_signal : int list -> int = "caml_wait_signal"
diff --git a/otherlibs/systhreads/thread_win32.ml b/otherlibs/systhreads/thread_win32.ml
deleted file mode 100644
index 81691278f3..0000000000
--- a/otherlibs/systhreads/thread_win32.ml
+++ /dev/null
@@ -1,75 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Caml Special Light *)
-(* *)
-(* 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 Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* User-level threads *)
-
-type t
-
-external thread_initialize : unit -> unit = "caml_thread_initialize"
-external thread_new : (unit -> unit) -> t = "caml_thread_new"
-
-external yield : unit -> unit = "caml_thread_yield"
-external self : unit -> t = "caml_thread_self"
-external id : t -> int = "caml_thread_id"
-external join : t -> unit = "caml_thread_join"
-external thread_uncaught_exception : exn -> unit =
- "caml_thread_uncaught_exception"
-
-(* For new, make sure the function passed to thread_new never
- raises an exception. *)
-
-exception Thread_exit
-
-let create fn arg =
- thread_new
- (fun () ->
- try
- fn arg; ()
- with Thread_exit -> ()
- | exn ->
- flush stdout; flush stderr;
- thread_uncaught_exception exn)
-
-let exit () = raise Thread_exit
-
-(* Thread.kill is currently not implemented because there is no way
- to do correct cleanup under Win32. *)
-
-let kill th = invalid_arg "Thread.kill: not implemented"
-
-(* Preemption *)
-
-let preempt signal = yield()
-
-(* Initialization of the scheduler *)
-
-let _ =
- ignore(Sys.signal Sys.sigterm (Sys.Signal_handle preempt));
- thread_initialize()
-
-(* Wait functions *)
-
-external delay: float -> unit = "caml_thread_delay"
-
-let wait_read fd = ()
-let wait_write fd = ()
-
-let wait_timed_read fd delay = true
-let wait_timed_write fd delay = true
-let select rd wr ex delay = invalid_arg "Thread.select: not implemented"
-
-let wait_pid p = Unix.waitpid [] p
-
-external wait_signal : int list -> int = "caml_wait_signal"
diff --git a/otherlibs/systhreads/win32.c b/otherlibs/systhreads/win32.c
deleted file mode 100644
index b8cdaef302..0000000000
--- a/otherlibs/systhreads/win32.c
+++ /dev/null
@@ -1,719 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Thread interface for Win32 threads */
-
-#include <windows.h>
-#include <process.h>
-#include <signal.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include "alloc.h"
-#include "backtrace.h"
-#include "callback.h"
-#include "custom.h"
-#include "fail.h"
-#include "io.h"
-#include "memory.h"
-#include "misc.h"
-#include "mlvalues.h"
-#include "printexc.h"
-#include "roots.h"
-#include "signals.h"
-#ifdef NATIVE_CODE
-#include "stack.h"
-#else
-#include "stacks.h"
-#endif
-#include "sys.h"
-
-/* Initial size of stack when a thread is created (4 Ko) */
-#define Thread_stack_size (Stack_size / 4)
-
-/* Max computation time before rescheduling, in milliseconds (50ms) */
-#define Thread_timeout 50
-
-/* Signal used for timer preemption (any unused, legal signal number) */
-#define SIGTIMER SIGTERM
-
-/* The ML value describing a thread (heap-allocated) */
-
-struct caml_thread_handle {
- value final_fun; /* Finalization function */
- HANDLE handle; /* Windows handle */
-};
-
-struct caml_thread_descr {
- value ident; /* Unique integer ID */
- value start_closure; /* The closure to start this thread */
- struct caml_thread_handle * thread_handle; /* Finalized object with handle */
-};
-
-#define Ident(v) (((struct caml_thread_descr *)(v))->ident)
-#define Start_closure(v) (((struct caml_thread_descr *)(v))->start_closure)
-#define Threadhandle(v) (((struct caml_thread_descr *)(v))->thread_handle)
-
-/* The infos on threads (allocated via malloc()) */
-
-struct caml_thread_struct {
- HANDLE wthread; /* The Windows thread handle */
- 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 * bottom_of_stack; /* Saved value of caml_bottom_of_stack */
- unsigned long 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 */
-#else
- value * stack_low; /* The execution stack for this thread */
- value * stack_high;
- value * stack_threshold;
- value * sp; /* Saved value of extern_sp for this thread */
- value * trapsp; /* Saved value of trapsp for this thread */
- struct caml__roots_block * local_roots; /* Saved value of local_roots */
- struct longjmp_buffer * external_raise; /* Saved external_raise */
- int backtrace_pos; /* Saved backtrace_pos */
- code_t * backtrace_buffer; /* Saved backtrace_buffer */
- value backtrace_last_exn; /* Saved backtrace_last_exn (root) */
-#endif
-};
-
-typedef struct caml_thread_struct * caml_thread_t;
-
-/* The descriptor for the currently executing thread (thread-specific) */
-
-static caml_thread_t curr_thread = NULL;
-
-/* The global mutex used to ensure that at most one thread is running
- Caml code */
-static HANDLE caml_mutex;
-
-/* The key used for storing the thread descriptor in the specific data
- of the corresponding Posix thread. */
-static DWORD thread_descriptor_key;
-
-/* The key used for unlocking I/O channels on exceptions */
-static DWORD last_channel_locked_key;
-
-/* Identifier for next thread creation */
-static long thread_next_ident = 0;
-
-/* Forward declarations */
-
-static void caml_wthread_error (char * msg);
-
-/* 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);
-#ifndef NATIVE_CODE
- (*action)(th->backtrace_last_exn, &th->backtrace_last_exn);
-#endif
- /* 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)
- do_local_roots(action, th->bottom_of_stack, th->last_retaddr,
- th->gc_regs, th->local_roots);
-#else
- 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);
-}
-
-/* Hooks for enter_blocking_section and leave_blocking_section */
-
-static void (*prev_enter_blocking_section_hook) () = NULL;
-static void (*prev_leave_blocking_section_hook) () = NULL;
-
-static void caml_thread_enter_blocking_section(void)
-{
- if (prev_enter_blocking_section_hook != NULL)
- (*prev_enter_blocking_section_hook)();
- /* Save the stack-related global variables in the thread descriptor
- of the current thread */
-#ifdef NATIVE_CODE
- 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 = local_roots;
-#else
- curr_thread->stack_low = stack_low;
- curr_thread->stack_high = stack_high;
- curr_thread->stack_threshold = stack_threshold;
- curr_thread->sp = extern_sp;
- curr_thread->trapsp = trapsp;
- curr_thread->local_roots = local_roots;
- curr_thread->external_raise = external_raise;
- curr_thread->backtrace_pos = backtrace_pos;
- curr_thread->backtrace_buffer = backtrace_buffer;
- curr_thread->backtrace_last_exn = backtrace_last_exn;
-#endif
- /* Release the global mutex */
- ReleaseMutex(caml_mutex);
-}
-
-static void caml_thread_leave_blocking_section(void)
-{
- /* Re-acquire the global mutex */
- WaitForSingleObject(caml_mutex, INFINITE);
- /* Update curr_thread to point to the thread descriptor corresponding
- to the thread currently executing */
- curr_thread = TlsGetValue(thread_descriptor_key);
- /* Restore the stack-related global variables */
-#ifdef NATIVE_CODE
- 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;
- local_roots = curr_thread->local_roots;
-#else
- stack_low = curr_thread->stack_low;
- stack_high = curr_thread->stack_high;
- stack_threshold = curr_thread->stack_threshold;
- extern_sp = curr_thread->sp;
- trapsp = curr_thread->trapsp;
- local_roots = curr_thread->local_roots;
- external_raise = curr_thread->external_raise;
- backtrace_pos = curr_thread->backtrace_pos;
- backtrace_buffer = curr_thread->backtrace_buffer;
- backtrace_last_exn = curr_thread->backtrace_last_exn;
-#endif
- if (prev_leave_blocking_section_hook != NULL)
- (*prev_leave_blocking_section_hook)();
-}
-
-/* Hooks for I/O locking */
-
-static void caml_io_mutex_free(struct channel * chan)
-{
- HANDLE mutex = chan->mutex;
- if (mutex != NULL) {
- CloseHandle(mutex);
- }
-}
-
-static void caml_io_mutex_lock(struct channel * chan)
-{
- if (chan->mutex == NULL) {
- HANDLE mutex = CreateMutex(NULL, FALSE, NULL);
- if (mutex == NULL) caml_wthread_error("Thread.iolock");
- chan->mutex = (void *) mutex;
- }
- enter_blocking_section();
- WaitForSingleObject((HANDLE) chan->mutex, INFINITE);
- /* 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. */
- TlsSetValue(last_channel_locked_key, (void *) chan);
- leave_blocking_section();
-}
-
-static void caml_io_mutex_unlock(struct channel * chan)
-{
- ReleaseMutex((HANDLE) chan->mutex);
- TlsSetValue(last_channel_locked_key, NULL);
-}
-
-static void caml_io_mutex_unlock_exn(void)
-{
- struct channel * chan = TlsGetValue(last_channel_locked_key);
- if (chan != NULL) caml_io_mutex_unlock(chan);
-}
-
-/* The "tick" thread fakes a signal at regular intervals. */
-
-static void caml_thread_tick(void * arg)
-{
- while(1) {
- Sleep(Thread_timeout);
- pending_signal = SIGTIMER;
-#ifdef NATIVE_CODE
- young_limit = young_end;
-#else
- something_to_do = 1;
-#endif
- }
-}
-
-static void caml_thread_finalize(value vthread)
-{
- CloseHandle(((struct caml_thread_handle *)vthread)->handle);
-}
-
-/* Initialize the thread machinery */
-
-CAMLprim value caml_thread_initialize(value unit)
-{
- value vthread = Val_unit;
- value descr;
- HANDLE tick_thread;
- unsigned long tick_id;
-
- /* Protect against repeated initialization (PR#1325) */
- if (curr_thread != NULL) return Val_unit;
- Begin_root (vthread);
- /* Initialize the main mutex and acquire it */
- caml_mutex = CreateMutex(NULL, TRUE, NULL);
- if (caml_mutex == NULL) caml_wthread_error("Thread.init");
- /* Initialize the TLS keys */
- thread_descriptor_key = TlsAlloc();
- last_channel_locked_key = TlsAlloc();
- /* Create a finalized value to hold thread handle */
- vthread = alloc_final(sizeof(struct caml_thread_handle) / sizeof(value),
- caml_thread_finalize, 1, 1000);
- ((struct caml_thread_handle *)vthread)->handle = NULL;
- /* Create a descriptor for the current thread */
- descr = alloc_tuple(sizeof(struct caml_thread_descr) / sizeof(value));
- Ident(descr) = Val_long(thread_next_ident);
- Start_closure(descr) = Val_unit;
- Threadhandle(descr) = (struct caml_thread_handle *) vthread;
- thread_next_ident++;
- /* Create an info block for the current thread */
- curr_thread =
- (caml_thread_t) stat_alloc(sizeof(struct caml_thread_struct));
- DuplicateHandle(GetCurrentProcess(), GetCurrentThread(),
- GetCurrentProcess(), &(curr_thread->wthread),
- 0, FALSE, DUPLICATE_SAME_ACCESS);
- if (curr_thread->wthread == NULL) caml_wthread_error("Thread.init");
- ((struct caml_thread_handle *)vthread)->handle = curr_thread->wthread;
- curr_thread->descr = descr;
- curr_thread->next = curr_thread;
- curr_thread->prev = curr_thread;
- /* The stack-related fields will be filled in at the next
- enter_blocking_section */
- /* Associate the thread descriptor with the thread */
- TlsSetValue(thread_descriptor_key, (void *) curr_thread);
- /* Set up the hooks */
- prev_scan_roots_hook = scan_roots_hook;
- scan_roots_hook = caml_thread_scan_roots;
- prev_enter_blocking_section_hook = enter_blocking_section_hook;
- enter_blocking_section_hook = caml_thread_enter_blocking_section;
- prev_leave_blocking_section_hook = leave_blocking_section_hook;
- leave_blocking_section_hook = caml_thread_leave_blocking_section;
- channel_mutex_free = caml_io_mutex_free;
- channel_mutex_lock = caml_io_mutex_lock;
- channel_mutex_unlock = caml_io_mutex_unlock;
- channel_mutex_unlock_exn = caml_io_mutex_unlock_exn;
- /* Fork the tick thread */
- tick_thread = (HANDLE) _beginthread(caml_thread_tick, 0, NULL);
- if (tick_thread == (HANDLE)(-1)) caml_wthread_error("Thread.init");
- CloseHandle(tick_thread);
- End_roots();
- return Val_unit;
-}
-
-/* Create a thread */
-
-static void caml_thread_start(void * arg)
-{
- caml_thread_t th = (caml_thread_t) arg;
- value clos;
-
- /* Associate the thread descriptor with the thread */
- TlsSetValue(thread_descriptor_key, (void *) th);
- TlsSetValue(last_channel_locked_key, NULL);
- /* Acquire the global mutex and set up the stack variables */
- leave_blocking_section();
- /* Callback the closure */
- clos = Start_closure(th->descr);
- modify(&(Start_closure(th->descr)), Val_unit);
- callback_exn(clos, Val_unit);
- /* Remove th from the doubly-linked list of threads */
- th->next->prev = th->prev;
- th->prev->next = th->next;
- /* Release the main mutex (forever) */
- async_signal_mode = 1;
- ReleaseMutex(caml_mutex);
-#ifndef NATIVE_CODE
- /* Free the memory resources */
- stat_free(th->stack_low);
- if (th->backtrace_buffer != NULL) free(th->backtrace_buffer);
-#endif
- /* Free the thread descriptor */
- stat_free(th);
- /* The thread now stops running */
-}
-
-CAMLprim value caml_thread_new(value clos)
-{
- caml_thread_t th;
- value vthread = Val_unit;
- value descr;
- unsigned long th_id;
-
- Begin_roots2 (clos, vthread)
- /* Create a finalized value to hold thread handle */
- vthread = alloc_final(sizeof(struct caml_thread_handle) / sizeof(value),
- caml_thread_finalize, 1, 1000);
- ((struct caml_thread_handle *)vthread)->handle = NULL;
- /* Create a descriptor for the new thread */
- descr = alloc_tuple(sizeof(struct caml_thread_descr) / sizeof(value));
- Ident(descr) = Val_long(thread_next_ident);
- Start_closure(descr) = clos;
- Threadhandle(descr) = (struct caml_thread_handle *) vthread;
- thread_next_ident++;
- /* Create an info block for the current thread */
- th = (caml_thread_t) stat_alloc(sizeof(struct caml_thread_struct));
- th->descr = descr;
-#ifdef NATIVE_CODE
- th->bottom_of_stack = NULL;
- th->exception_pointer = NULL;
- th->local_roots = NULL;
-#else
- /* Allocate the stacks */
- th->stack_low = (value *) 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;
- th->backtrace_pos = 0;
- th->backtrace_buffer = NULL;
- th->backtrace_last_exn = Val_unit;
-#endif
- /* 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;
- /* Fork the new thread */
-#if 0
- th->wthread =
- CreateThread(NULL,0, (LPTHREAD_START_ROUTINE) caml_thread_start,
- (void *) th, 0, &th_id);
- if (th->wthread == NULL) {
-#endif
- th->wthread = (HANDLE) _beginthread(caml_thread_start, 0, (void *) th);
- if (th->wthread == (HANDLE)(-1)) {
- /* Fork failed, remove thread info block from list of threads */
- th->next->prev = curr_thread;
- curr_thread->next = th->next;
-#ifndef NATIVE_CODE
- stat_free(th->stack_low);
-#endif
- stat_free(th);
- caml_wthread_error("Thread.create");
- }
- ((struct caml_thread_handle *)vthread)->handle = th->wthread;
- End_roots();
- return descr;
-}
-
-/* Return the current thread */
-
-CAMLprim value caml_thread_self(value unit)
-{
- if (curr_thread == NULL) invalid_argument("Thread.self: not initialized");
- return curr_thread->descr;
-}
-
-/* Return the identifier of a thread */
-
-CAMLprim value caml_thread_id(value th)
-{
- return Ident(th);
-}
-
-/* Print uncaught exception and backtrace */
-
-CAMLprim value caml_thread_uncaught_exception(value exn)
-{
- char * msg = format_caml_exception(exn);
- fprintf(stderr, "Thread %d killed on uncaught exception %s\n",
- Int_val(Ident(curr_thread->descr)), msg);
- free(msg);
-#ifndef NATIVE_CODE
- if (backtrace_active) print_exception_backtrace();
-#endif
- fflush(stderr);
- return Val_unit;
-}
-
-/* Allow re-scheduling */
-
-CAMLprim value caml_thread_yield(value unit)
-{
- enter_blocking_section();
- Sleep(0);
- leave_blocking_section();
- return Val_unit;
-}
-
-/* Suspend the current thread until another thread terminates */
-
-CAMLprim value caml_thread_join(value th)
-{
- HANDLE h;
- Begin_root(th) /* prevent deallocation of handle */
- h = Threadhandle(th)->handle;
- enter_blocking_section();
- WaitForSingleObject(h, INFINITE);
- leave_blocking_section();
- End_roots();
- return Val_unit;
-}
-
-/* Mutex operations */
-
-#define Mutex_val(v) (*((HANDLE *) Data_custom_val(v)))
-#define Max_mutex_number 1000
-
-static void caml_mutex_finalize(value mut)
-{
- CloseHandle(Mutex_val(mut));
-}
-
-static int caml_mutex_compare(value wrapper1, value wrapper2)
-{
- HANDLE h1 = Mutex_val(wrapper1);
- HANDLE h2 = Mutex_val(wrapper2);
- return h1 == h2 ? 0 : h1 < h2 ? -1 : 1;
-}
-
-static struct custom_operations caml_mutex_ops = {
- "_mutex",
- caml_mutex_finalize,
- caml_mutex_compare,
- custom_hash_default,
- custom_serialize_default,
- custom_deserialize_default
-};
-
-CAMLprim value caml_mutex_new(value unit)
-{
- value mut;
- mut = alloc_custom(&caml_mutex_ops, sizeof(HANDLE), 1, Max_mutex_number);
- Mutex_val(mut) = CreateMutex(0, FALSE, NULL);
- if (Mutex_val(mut) == NULL) caml_wthread_error("Mutex.create");
- return mut;
-}
-
-CAMLprim value caml_mutex_lock(value mut)
-{
- int retcode;
- Begin_root(mut) /* prevent deallocation of mutex */
- enter_blocking_section();
- retcode = WaitForSingleObject(Mutex_val(mut), INFINITE);
- leave_blocking_section();
- End_roots();
- if (retcode == WAIT_FAILED) caml_wthread_error("Mutex.lock");
- return Val_unit;
-}
-
-CAMLprim value caml_mutex_unlock(value mut)
-{
- BOOL retcode;
- Begin_root(mut) /* prevent deallocation of mutex */
- enter_blocking_section();
- retcode = ReleaseMutex(Mutex_val(mut));
- leave_blocking_section();
- End_roots();
- if (!retcode) caml_wthread_error("Mutex.unlock");
- return Val_unit;
-}
-
-CAMLprim value caml_mutex_try_lock(value mut)
-{
- int retcode;
- retcode = WaitForSingleObject(Mutex_val(mut), 0);
- if (retcode == WAIT_FAILED || retcode == WAIT_ABANDONED)
- caml_wthread_error("Mutex.try_lock");
- return Val_bool(retcode == WAIT_OBJECT_0);
-}
-
-/* Delay */
-
-CAMLprim value caml_thread_delay(value val)
-{
- enter_blocking_section();
- Sleep((DWORD)(Double_val(val)*1000)); /* milliseconds */
- leave_blocking_section();
- return Val_unit;
-}
-
-/* Conditions operations */
-
-struct caml_condvar {
- unsigned long count; /* Number of waiting threads */
- HANDLE sem; /* Semaphore on which threads are waiting */
-};
-
-#define Condition_val(v) ((struct caml_condvar *) Data_custom_val(v))
-#define Max_condition_number 1000
-
-static void caml_condition_finalize(value cond)
-{
- CloseHandle(Condition_val(cond)->sem);
-}
-
-static int caml_condition_compare(value wrapper1, value wrapper2)
-{
- HANDLE h1 = Condition_val(wrapper1)->sem;
- HANDLE h2 = Condition_val(wrapper2)->sem;
- return h1 == h2 ? 0 : h1 < h2 ? -1 : 1;
-}
-
-static struct custom_operations caml_condition_ops = {
- "_condition",
- caml_condition_finalize,
- caml_condition_compare,
- custom_hash_default,
- custom_serialize_default,
- custom_deserialize_default
-};
-
-CAMLprim value caml_condition_new(value unit)
-{
- value cond;
- cond = alloc_custom(&caml_condition_ops, sizeof(struct caml_condvar),
- 1, Max_condition_number);
- Condition_val(cond)->sem = CreateSemaphore(NULL, 0, 0x7FFFFFFF, NULL);
- if (Condition_val(cond)->sem == NULL)
- caml_wthread_error("Condition.create");
- Condition_val(cond)->count = 0;
- return cond;
-}
-
-CAMLprim value caml_condition_wait(value cond, value mut)
-{
- int retcode;
- HANDLE m = Mutex_val(mut);
- HANDLE s = Condition_val(cond)->sem;
- HANDLE handles[2];
-
- Condition_val(cond)->count ++;
- Begin_roots2(cond, mut) /* prevent deallocation of cond and mutex */
- enter_blocking_section();
- /* Release mutex */
- ReleaseMutex(m);
- /* Wait for semaphore to be non-null, and decrement it.
- Simultaneously, re-acquire mutex. */
- handles[0] = s;
- handles[1] = m;
- retcode = WaitForMultipleObjects(2, handles, TRUE, INFINITE);
- leave_blocking_section();
- End_roots();
- if (retcode == WAIT_FAILED) caml_wthread_error("Condition.wait");
- return Val_unit;
-}
-
-CAMLprim value caml_condition_signal(value cond)
-{
- HANDLE s = Condition_val(cond)->sem;
-
- if (Condition_val(cond)->count > 0) {
- Condition_val(cond)->count --;
- Begin_root(cond) /* prevent deallocation of cond */
- enter_blocking_section();
- /* Increment semaphore by 1, waking up one waiter */
- ReleaseSemaphore(s, 1, NULL);
- leave_blocking_section();
- End_roots();
- }
- return Val_unit;
-}
-
-CAMLprim value caml_condition_broadcast(value cond)
-{
- HANDLE s = Condition_val(cond)->sem;
- unsigned long c = Condition_val(cond)->count;
-
- if (c > 0) {
- Condition_val(cond)->count = 0;
- Begin_root(cond) /* prevent deallocation of cond */
- enter_blocking_section();
- /* Increment semaphore by c, waking up all waiters */
- ReleaseSemaphore(s, c, NULL);
- leave_blocking_section();
- End_roots();
- }
- return Val_unit;
-}
-
-/* Synchronous signal wait */
-
-static HANDLE wait_signal_event[NSIG];
-static int * wait_signal_received[NSIG];
-
-static void caml_wait_signal_handler(int signo)
-{
- *(wait_signal_received[signo]) = signo;
- SetEvent(wait_signal_event[signo]);
-}
-
-typedef void (*sighandler_type)(int);
-
-CAMLprim value caml_wait_signal(value sigs)
-{
- HANDLE event;
- int res, s, retcode;
- value l;
- sighandler_type oldsignals[NSIG];
-
- Begin_root(sigs);
- event = CreateEvent(NULL, FALSE, FALSE, NULL);
- if (event == NULL)
- caml_wthread_error("Thread.wait_signal (CreateEvent)");
- res = 0;
- for (l = sigs; l != Val_int(0); l = Field(l, 1)) {
- s = convert_signal_number(Int_val(Field(l, 0)));
- oldsignals[s] = signal(s, caml_wait_signal_handler);
- if (oldsignals[s] == SIG_ERR) {
- CloseHandle(event);
- caml_wthread_error("Thread.wait_signal (signal)");
- }
- wait_signal_event[s] = event;
- wait_signal_received[s] = &res;
- }
- enter_blocking_section();
- retcode = WaitForSingleObject(event, INFINITE);
- leave_blocking_section();
- for (l = sigs; l != Val_int(0); l = Field(l, 1)) {
- s = convert_signal_number(Int_val(Field(l, 0)));
- signal(s, oldsignals[s]);
- }
- CloseHandle(event);
- End_roots();
- if (retcode == WAIT_FAILED)
- caml_wthread_error("Thread.wait_signal (WaitForSingleObject)");
- return Val_int(res);
-}
-
-/* Error report */
-
-static void caml_wthread_error(char * msg)
-{
- char errmsg[1024];
- sprintf(errmsg, "%s: error code %lx", msg, GetLastError());
- raise_sys_error(copy_string(errmsg));
-}
diff --git a/otherlibs/threads/.cvsignore b/otherlibs/threads/.cvsignore
deleted file mode 100644
index fb2df562de..0000000000
--- a/otherlibs/threads/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-marshal.mli
-pervasives.mli
-unix.mli
diff --git a/otherlibs/threads/.depend b/otherlibs/threads/.depend
deleted file mode 100644
index d73c31e4c4..0000000000
--- a/otherlibs/threads/.depend
+++ /dev/null
@@ -1,27 +0,0 @@
-scheduler.o: scheduler.c ../../byterun/alloc.h ../../byterun/misc.h \
- ../../byterun/config.h ../../config/m.h ../../config/s.h \
- ../../byterun/mlvalues.h ../../byterun/backtrace.h \
- ../../byterun/callback.h ../../byterun/fail.h ../../byterun/io.h \
- ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
- ../../byterun/freelist.h ../../byterun/minor_gc.h \
- ../../byterun/printexc.h ../../byterun/roots.h ../../byterun/signals.h \
- ../../byterun/stacks.h ../../byterun/sys.h
-condition.cmi: mutex.cmi
-thread.cmi: unix.cmi
-threadUnix.cmi: unix.cmi
-condition.cmo: mutex.cmi thread.cmi condition.cmi
-condition.cmx: mutex.cmx thread.cmx condition.cmi
-event.cmo: condition.cmi mutex.cmi event.cmi
-event.cmx: condition.cmx mutex.cmx event.cmi
-marshal.cmo: pervasives.cmi marshal.cmi
-marshal.cmx: pervasives.cmx marshal.cmi
-mutex.cmo: thread.cmi mutex.cmi
-mutex.cmx: thread.cmx mutex.cmi
-pervasives.cmo: unix.cmi pervasives.cmi
-pervasives.cmx: unix.cmx pervasives.cmi
-thread.cmo: unix.cmi thread.cmi
-thread.cmx: unix.cmx thread.cmi
-threadUnix.cmo: thread.cmi unix.cmi threadUnix.cmi
-threadUnix.cmx: thread.cmx unix.cmx threadUnix.cmi
-unix.cmo: unix.cmi
-unix.cmx: unix.cmi
diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile
deleted file mode 100644
index d76ce536bf..0000000000
--- a/otherlibs/threads/Makefile
+++ /dev/null
@@ -1,126 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-include ../../config/Makefile
-
-CC=$(BYTECC)
-CFLAGS=-I../../byterun -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -g
-CAMLC=../../ocamlcomp.sh -I ../unix
-MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib
-COMPFLAGS=-warn-error A
-
-C_OBJS=scheduler.o
-
-CAML_OBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo
-
-LIB=../../stdlib
-
-LIB_OBJS=pervasives.cmo \
- $(LIB)/array.cmo $(LIB)/list.cmo $(LIB)/char.cmo $(LIB)/string.cmo \
- $(LIB)/sys.cmo $(LIB)/hashtbl.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)/stream.cmo $(LIB)/buffer.cmo \
- $(LIB)/printf.cmo $(LIB)/format.cmo \
- $(LIB)/scanf.cmo $(LIB)/arg.cmo \
- $(LIB)/printexc.cmo $(LIB)/gc.cmo $(LIB)/digest.cmo $(LIB)/random.cmo \
- $(LIB)/camlinternalOO.cmo \
- $(LIB)/oo.cmo $(LIB)/genlex.cmo $(LIB)/callback.cmo $(LIB)/weak.cmo \
- $(LIB)/lazy.cmo $(LIB)/filename.cmo $(LIB)/complex.cmo \
- $(LIB)/arrayLabels.cmo $(LIB)/listLabels.cmo $(LIB)/stringLabels.cmo \
- $(LIB)/stdLabels.cmo $(LIB)/moreLabels.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.cmo: unix.mli unix.cmi unix.ml
- $(CAMLC) ${COMPFLAGS} -c unix.ml
-
-unix.mli: $(UNIXLIB)/unix.mli
- ln -s $(UNIXLIB)/unix.mli unix.mli
-
-unix.cmi: $(UNIXLIB)/unix.cmi
- ln -s $(UNIXLIB)/unix.cmi unix.cmi
-
-partialclean:
- rm -f *.cm*
-
-clean: partialclean
- rm -f libvmthreads.a dllvmthreads.so *.o
- rm -f pervasives.mli marshal.mli unix.mli
-
-install:
- if test -f dllvmthreads.so; then cp dllvmthreads.so $(STUBLIBDIR)/.; fi
- mkdir -p $(LIBDIR)/vmthreads
- cp libvmthreads.a $(LIBDIR)/vmthreads/libvmthreads.a
- cd $(LIBDIR)/vmthreads; $(RANLIB) libvmthreads.a
- cp thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi threads.cma stdlib.cma unix.cma $(LIBDIR)/vmthreads
- cp thread.mli mutex.mli condition.mli event.mli threadUnix.mli $(LIBDIR)/vmthreads
-
-installopt:
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.mli.cmi:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-depend:
- gcc -MM $(CFLAGS) *.c > .depend
- ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend
-
-include .depend
diff --git a/otherlibs/threads/Tests/.cvsignore b/otherlibs/threads/Tests/.cvsignore
deleted file mode 100644
index e6d9e45b70..0000000000
--- a/otherlibs/threads/Tests/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-*.byt
diff --git a/otherlibs/threads/Tests/Makefile b/otherlibs/threads/Tests/Makefile
deleted file mode 100644
index 6bf52ef059..0000000000
--- a/otherlibs/threads/Tests/Makefile
+++ /dev/null
@@ -1,38 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../../LICENSE.#
-# #
-#########################################################################
-
-# $Id$
-
-PROGS=test1.byt test2.byt test3.byt test4.byt test5.byt test6.byt \
- test7.byt test8.byt test9.byt testA.byt sieve.byt \
- testio.byt testsocket.byt testwait.byt testsignal.byt testsignal2.byt \
- testsieve.byt token1.byt token2.byt
-
-CAMLC=../../../boot/ocamlrun ../../../ocamlc -I .. -I ../../../stdlib -I ../../unix
-
-include ../../../config/Makefile
-
-all: $(PROGS)
-
-clean:
- rm -f *.cm* *.byt
-
-sorts.byt: sorts.ml
- $(CAMLC) -o sorts.byt -I ../../graph threads.cma graphics.cma sorts.ml $(LIBS) $(X11_LINK)
-
-.SUFFIXES: .ml .byt
-
-.ml.byt:
- $(CAMLC) -o $*.byt unix.cma threads.cma $*.ml $(LIBS)
-
-$(PROGS): ../threads.cma ../libthreads.a
diff --git a/otherlibs/threads/Tests/close.ml b/otherlibs/threads/Tests/close.ml
deleted file mode 100644
index 21ebb44a6a..0000000000
--- a/otherlibs/threads/Tests/close.ml
+++ /dev/null
@@ -1,14 +0,0 @@
-let main () =
- let (rd, wr) = Unix.pipe() in
- Thread.create
- (fun () ->
- Thread.delay 3.0;
- prerr_endline "closing fd...";
- Unix.close rd)
- ();
- let buf = String.create 10 in
- prerr_endline "reading...";
- Unix.read rd buf 0 10;
- prerr_endline "read returned"
-
-let _ = Unix.handle_unix_error main ()
diff --git a/otherlibs/threads/Tests/sieve.ml b/otherlibs/threads/Tests/sieve.ml
deleted file mode 100644
index 72e2656605..0000000000
--- a/otherlibs/threads/Tests/sieve.ml
+++ /dev/null
@@ -1,33 +0,0 @@
-open Printf
-open Thread
-
-let rec integers n ch =
- Event.sync (Event.send ch n);
- integers (n+1) ch
-
-let rec sieve n chin chout =
- let m = Event.sync (Event.receive chin)
- in if m mod n = 0
- then sieve n chin chout
- else Event.sync (Event.send chout m);
- sieve n chin chout
-
-let rec print_primes ch max =
- let n = Event.sync (Event.receive ch)
- in if n > max
- then ()
- else begin
- printf "%d\n" n; flush stdout;
- let ch_after_n = Event.new_channel ()
- in Thread.create (sieve n ch) ch_after_n;
- print_primes ch_after_n max
- end
-
-let go max =
- let ch = Event.new_channel ()
- in Thread.create (integers 2) ch;
- print_primes ch max;;
-
-let _ = go 1000
-
-;;
diff --git a/otherlibs/threads/Tests/sorts.ml b/otherlibs/threads/Tests/sorts.ml
deleted file mode 100644
index abc8dc1b5c..0000000000
--- a/otherlibs/threads/Tests/sorts.ml
+++ /dev/null
@@ -1,228 +0,0 @@
-(* Animation of sorting algorithms. *)
-
-open Graphics
-
-(* Information on a given sorting process *)
-
-type graphic_context =
- { array: int array; (* Data to sort *)
- x0: int; (* X coordinate, lower left corner *)
- y0: int; (* Y coordinate, lower left corner *)
- width: int; (* Width in pixels *)
- height: int; (* Height in pixels *)
- nelts: int; (* Number of elements in the array *)
- maxval: int; (* Max val in the array + 1 *)
- rad: int (* Dimension of the rectangles *)
- }
-
-(* Array assignment and exchange with screen update *)
-
-let screen_mutex = Mutex.create()
-
-let draw gc i v =
- fill_rect (gc.x0 + (gc.width * i) / gc.nelts)
- (gc.y0 + (gc.height * v) / gc.maxval)
- gc.rad gc.rad
-
-let assign gc i v =
- Mutex.lock screen_mutex;
- set_color background; draw gc i gc.array.(i);
- set_color foreground; draw gc i v;
- gc.array.(i) <- v;
- Mutex.unlock screen_mutex
-
-let exchange gc i j =
- let val_i = gc.array.(i) in
- assign gc i gc.array.(j);
- assign gc j val_i
-
-(* Construction of a graphic context *)
-
-let initialize name array maxval x y w h =
- let (_, label_height) = text_size name in
- let rad = (w - 2) / (Array.length array) - 1 in
- let gc =
- { array = Array.copy array;
- x0 = x + 1; (* Leave one pixel left for Y axis *)
- y0 = y + 1; (* Leave one pixel below for X axis *)
- width = w - 2; (* 1 pixel left, 1 pixel right *)
- height = h - 1 - label_height - rad;
- nelts = Array.length array;
- maxval = maxval;
- rad = rad } in
- moveto (gc.x0 - 1) (gc.y0 + gc.height);
- lineto (gc.x0 - 1) (gc.y0 - 1);
- lineto (gc.x0 + gc.width) (gc.y0 - 1);
- moveto (gc.x0 - 1) (gc.y0 + gc.height);
- draw_string name;
- for i = 0 to Array.length array - 1 do
- draw gc i array.(i)
- done;
- gc
-
-(* Main animation function *)
-
-let display functs nelts maxval =
- let a = Array.create nelts 0 in
- for i = 0 to nelts - 1 do
- a.(i) <- Random.int maxval
- done;
- let num_finished = ref 0 in
- let lock_finished = Mutex.create() in
- let cond_finished = Condition.create() in
- for i = 0 to Array.length functs - 1 do
- let (name, funct, x, y, w, h) = functs.(i) in
- let gc = initialize name a maxval x y w h in
- Thread.create
- (fun () ->
- funct gc;
- Mutex.lock lock_finished;
- incr num_finished;
- Mutex.unlock lock_finished;
- Condition.signal cond_finished)
- ()
- done;
- Mutex.lock lock_finished;
- while !num_finished < Array.length functs do
- Condition.wait cond_finished lock_finished
- done;
- Mutex.unlock lock_finished;
- read_key()
-
-(*****
- let delay = ref 0 in
- try
- while true do
- let gc = Queue.take q in
- begin match gc.action with
- Finished -> ()
- | Pause f ->
- gc.action <- f ();
- for i = 0 to !delay do () done;
- Queue.add gc q
- end;
- if key_pressed() then begin
- match read_key() with
- 'q'|'Q' ->
- raise Exit
- | '0'..'9' as c ->
- delay := (Char.code c - 48) * 500
- | _ ->
- ()
- end
- done
- with Exit -> ()
- | Queue.Empty -> read_key(); ()
-*****)
-
-(* The sorting functions. *)
-
-(* Bubble sort *)
-
-let bubble_sort gc =
- let ordered = ref false in
- while not !ordered do
- ordered := true;
- for i = 0 to Array.length gc.array - 2 do
- if gc.array.(i+1) < gc.array.(i) then begin
- exchange gc i (i+1);
- ordered := false
- end
- done
- done
-
-(* Insertion sort *)
-
-let insertion_sort gc =
- for i = 1 to Array.length gc.array - 1 do
- let val_i = gc.array.(i) in
- let j = ref (i - 1) in
- while !j >= 0 && val_i < gc.array.(!j) do
- assign gc (!j + 1) gc.array.(!j);
- decr j
- done;
- assign gc (!j + 1) val_i
- done
-
-(* Selection sort *)
-
-let selection_sort gc =
- for i = 0 to Array.length gc.array - 1 do
- let min = ref i in
- for j = i+1 to Array.length gc.array - 1 do
- if gc.array.(j) < gc.array.(!min) then min := j
- done;
- exchange gc i !min
- done
-
-(* Quick sort *)
-
-let quick_sort gc =
- let rec quick lo hi =
- if lo < hi then begin
- let i = ref lo in
- let j = ref hi in
- let pivot = gc.array.(hi) in
- while !i < !j do
- while !i < hi && gc.array.(!i) <= pivot do incr i done;
- while !j > lo && gc.array.(!j) >= pivot do decr j done;
- if !i < !j then exchange gc !i !j
- done;
- exchange gc !i hi;
- quick lo (!i-1);
- quick (!i+1) hi
- end
- in quick 0 (Array.length gc.array - 1)
-
-(* Merge sort *)
-
-let merge_sort gc =
- let rec merge i l1 l2 =
- match (l1, l2) with
- ([], []) ->
- ()
- | ([], v2::r2) ->
- assign gc i v2; merge (i+1) l1 r2
- | (v1::r1, []) ->
- assign gc i v1; merge (i+1) r1 l2
- | (v1::r1, v2::r2) ->
- if v1 < v2
- then begin assign gc i v1; merge (i+1) r1 l2 end
- else begin assign gc i v2; merge (i+1) l1 r2 end in
- let rec msort start len =
- if len < 2 then () else begin
- let m = len / 2 in
- msort start m;
- msort (start+m) (len-m);
- merge start
- (Array.to_list (Array.sub gc.array start m))
- (Array.to_list (Array.sub gc.array (start+m) (len-m)))
- end in
- msort 0 (Array.length gc.array)
-
-(* Main program *)
-
-let animate() =
- open_graph "";
- moveto 0 0; draw_string "Press a key to start...";
- let seed = ref 0 in
- while not (key_pressed()) do incr seed done;
- read_key();
- Random.init !seed;
- clear_graph();
- let prompt = "0: fastest ... 9: slowest, press 'q' to quit" in
- moveto 0 0; draw_string prompt;
- let (_, h) = text_size prompt in
- let sx = size_x() / 2 and sy = (size_y() - h) / 3 in
- display [| "Bubble", bubble_sort, 0, h, sx, sy;
- "Insertion", insertion_sort, 0, h+sy, sx, sy;
- "Selection", selection_sort, 0, h+2*sy, sx, sy;
- "Quicksort", quick_sort, sx, h, sx, sy;
- (** "Heapsort", heap_sort, sx, h+sy, sx, sy; **)
- "Mergesort", merge_sort, sx, h+2*sy, sx, sy |]
- 100 1000;
- close_graph()
-
-let _ = if !Sys.interactive then () else begin animate(); exit 0 end
-
-;;
diff --git a/otherlibs/threads/Tests/test1.ml b/otherlibs/threads/Tests/test1.ml
deleted file mode 100644
index 9d2cf0a5ee..0000000000
--- a/otherlibs/threads/Tests/test1.ml
+++ /dev/null
@@ -1,57 +0,0 @@
-(* Classic producer-consumer *)
-
-type 'a prodcons =
- { buffer: 'a array;
- lock: Mutex.t;
- mutable readpos: int;
- mutable writepos: int;
- notempty: Condition.t;
- notfull: Condition.t }
-
-let create size init =
- { buffer = Array.create size init;
- lock = Mutex.create();
- readpos = 0;
- writepos = 0;
- notempty = Condition.create();
- notfull = Condition.create() }
-
-let put p data =
- Mutex.lock p.lock;
- while (p.writepos + 1) mod Array.length p.buffer = p.readpos do
- Condition.wait p.notfull p.lock
- done;
- p.buffer.(p.writepos) <- data;
- p.writepos <- (p.writepos + 1) mod Array.length p.buffer;
- Condition.signal p.notempty;
- Mutex.unlock p.lock
-
-let get p =
- Mutex.lock p.lock;
- while p.writepos = p.readpos do
- Condition.wait p.notempty p.lock
- done;
- let data = p.buffer.(p.readpos) in
- p.readpos <- (p.readpos + 1) mod Array.length p.buffer;
- Condition.signal p.notfull;
- Mutex.unlock p.lock;
- data
-
-(* Test *)
-
-let buff = create 20 0
-
-let rec produce n =
- print_int n; print_string "-->"; print_newline();
- put buff n;
- if n < 10000 then produce (n+1)
-
-let rec consume () =
- let n = get buff in
- print_string "-->"; print_int n; print_newline();
- if n < 10000 then consume ()
-
-let t1 = Thread.create produce 0
-let _ = consume ()
-
-;;
diff --git a/otherlibs/threads/Tests/test2.ml b/otherlibs/threads/Tests/test2.ml
deleted file mode 100644
index 926f09078f..0000000000
--- a/otherlibs/threads/Tests/test2.ml
+++ /dev/null
@@ -1,15 +0,0 @@
-let yield = ref false
-
-let print_message c =
- for i = 1 to 10000 do
- print_char c; flush stdout;
- if !yield then Thread.yield()
- done
-
-let _ = yield := (Array.length Sys.argv > 1)
-let t1 = Thread.create print_message 'a'
-let t2 = Thread.create print_message 'b'
-let _ = Thread.join t1
-let _ = Thread.join t2
-
-;;
diff --git a/otherlibs/threads/Tests/test3.ml b/otherlibs/threads/Tests/test3.ml
deleted file mode 100644
index c6df3326e4..0000000000
--- a/otherlibs/threads/Tests/test3.ml
+++ /dev/null
@@ -1,8 +0,0 @@
-let print_message delay c =
- while true do
- print_char c; flush stdout; Thread.delay delay
- done
-
-let _ =
- Thread.create (print_message 0.6666666666) 'a';
- print_message 1.0 'b'
diff --git a/otherlibs/threads/Tests/test4.ml b/otherlibs/threads/Tests/test4.ml
deleted file mode 100644
index ff84961bb3..0000000000
--- a/otherlibs/threads/Tests/test4.ml
+++ /dev/null
@@ -1,13 +0,0 @@
-let rec fib n = if n <= 2 then 1 else fib(n-1) + fib(n-2)
-
-let fibtask n =
- while true do
- print_int(fib n); print_newline()
- done
-
-let _ =
- Thread.create fibtask 28;
- while true do
- let l = read_line () in
- print_string ">> "; print_string l; print_newline()
- done
diff --git a/otherlibs/threads/Tests/test5.ml b/otherlibs/threads/Tests/test5.ml
deleted file mode 100644
index 2baffe024b..0000000000
--- a/otherlibs/threads/Tests/test5.ml
+++ /dev/null
@@ -1,21 +0,0 @@
-open Event
-
-let ch = (new_channel() : string channel)
-
-let rec sender msg =
- sync (send ch msg);
- sender msg
-
-let rec receiver name =
- print_string (name ^ ": " ^ sync (receive ch) ^ "\n");
- flush stdout;
- receiver name
-
-let _ =
- Thread.create sender "hello";
- Thread.create sender "world";
- Thread.create receiver "A";
- receiver "B";
- exit 0
-
-
diff --git a/otherlibs/threads/Tests/test6.ml b/otherlibs/threads/Tests/test6.ml
deleted file mode 100644
index b846858e56..0000000000
--- a/otherlibs/threads/Tests/test6.ml
+++ /dev/null
@@ -1,17 +0,0 @@
-open Event
-
-let ch = (new_channel() : string channel)
-
-let rec f tag msg =
- select [
- send ch msg;
- wrap (receive ch) (fun x -> print_string(tag ^ ": " ^ x); print_newline())
- ];
- f tag msg
-
-let _ =
- Thread.create (f "A") "hello";
- f "B" "world";
- exit 0
-
-
diff --git a/otherlibs/threads/Tests/test7.ml b/otherlibs/threads/Tests/test7.ml
deleted file mode 100644
index e6bd1d810d..0000000000
--- a/otherlibs/threads/Tests/test7.ml
+++ /dev/null
@@ -1,28 +0,0 @@
-open Event
-
-let add_ch = new_channel()
-let sub_ch = new_channel()
-let read_ch = new_channel()
-
-let rec accu n =
- select [
- wrap (receive add_ch) (fun x -> accu (n+x));
- wrap (receive sub_ch) (fun x -> accu (n-x));
- wrap (send read_ch n) (fun () -> accu n)
- ]
-
-let rec sender chan value =
- sync(send chan value); sender chan value
-
-let read () =
- print_int(sync(receive read_ch)); print_newline()
-
-let main () =
- Thread.create accu 0;
- Thread.create (sender add_ch) 1;
- Thread.create (sender sub_ch) 1;
- while true do read() done
-
-let _ = Printexc.catch main ()
-
-
diff --git a/otherlibs/threads/Tests/test8.ml b/otherlibs/threads/Tests/test8.ml
deleted file mode 100644
index cc587b0a7c..0000000000
--- a/otherlibs/threads/Tests/test8.ml
+++ /dev/null
@@ -1,46 +0,0 @@
-open Event
-
-type 'a buffer_channel = { input: 'a channel; output: 'a channel }
-
-let new_buffer_channel() =
- let ic = new_channel() in
- let oc = new_channel() in
- let buff = Queue.create() in
- let rec buffer_process front rear =
- match (front, rear) with
- ([], []) -> buffer_process [sync(receive ic)] []
- | (hd::tl, _) ->
- select [
- wrap (receive ic) (fun x -> buffer_process front (x::rear));
- wrap (send oc hd) (fun () -> buffer_process tl rear)
- ]
- | ([], _) -> buffer_process (List.rev rear) [] in
- Thread.create (buffer_process []) [];
- { input = ic; output = oc }
-
-let buffer_send bc data =
- sync(send bc.input data)
-
-let buffer_receive bc =
- receive bc.output
-
-(* Test *)
-
-let box = new_buffer_channel()
-let ch = new_channel()
-
-let f () =
- buffer_send box "un";
- buffer_send box "deux";
- sync (send ch 3)
-
-let g () =
- print_int (sync(receive ch)); print_newline();
- print_string (sync(buffer_receive box)); print_newline();
- print_string (sync(buffer_receive box)); print_newline()
-
-let _ =
- Thread.create f ();
- g()
-
-
diff --git a/otherlibs/threads/Tests/test9.ml b/otherlibs/threads/Tests/test9.ml
deleted file mode 100644
index 1f80beb8f8..0000000000
--- a/otherlibs/threads/Tests/test9.ml
+++ /dev/null
@@ -1,26 +0,0 @@
-open Event
-
-type 'a swap_chan = ('a * 'a channel) channel
-
-let swap msg_out ch =
- guard (fun () ->
- let ic = new_channel() in
- choose [
- wrap (receive ch) (fun (msg_in, oc) -> sync (send oc msg_out); msg_in);
- wrap (send ch (msg_out, ic)) (fun () -> sync (receive ic))
- ])
-
-let ch = new_channel()
-
-let f () =
- let res = sync (swap "F" ch) in
- print_string "f "; print_string res; print_newline()
-
-let g () =
- let res = sync (swap "G" ch) in
- print_string "g "; print_string res; print_newline()
-
-let _ =
- let id = Thread.create f () in
- g ();
- Thread.join id
diff --git a/otherlibs/threads/Tests/testA.ml b/otherlibs/threads/Tests/testA.ml
deleted file mode 100644
index b1999b87bc..0000000000
--- a/otherlibs/threads/Tests/testA.ml
+++ /dev/null
@@ -1,24 +0,0 @@
-let private_data = (Hashtbl.create 17 : (Thread.t, string) Hashtbl.t)
-let private_data_lock = Mutex.create()
-
-let set_private_data data =
- Mutex.lock private_data_lock;
- Hashtbl.add private_data (Thread.self()) data;
- Mutex.unlock private_data_lock
-
-let get_private_data () =
- Hashtbl.find private_data (Thread.self())
-
-let process id data =
- set_private_data data;
- print_int id; print_string " --> "; print_string(get_private_data());
- print_newline()
-
-let _ =
- let t1 = Thread.create (process 1) "un" in
- let t2 = Thread.create (process 2) "deux" in
- let t3 = Thread.create (process 3) "trois" in
- let t4 = Thread.create (process 4) "quatre" in
- let t5 = Thread.create (process 5) "cinq" in
- List.iter Thread.join [t1;t2;t3;t4;t5]
-
diff --git a/otherlibs/threads/Tests/testexit.ml b/otherlibs/threads/Tests/testexit.ml
deleted file mode 100644
index 2045c25a86..0000000000
--- a/otherlibs/threads/Tests/testexit.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-(* Test Thread.exit *)
-
-let somethread (name, limit, last) =
- let counter = ref 0 in
- while true do
- incr counter;
- if !counter >= limit then begin
- print_string (name ^ " exiting\n");
- flush stdout;
- if last then exit 0 else Thread.exit()
- end;
- print_string (name ^ ": " ^ string_of_int !counter ^ "\n");
- flush stdout;
- Thread.delay 0.5
- done
-
-let _ =
- let _ = Thread.create somethread ("A", 5, false) in
- let _ = Thread.create somethread ("B", 8, false) in
- let _ = Thread.create somethread ("C", 11, true) in
- somethread ("Main", 3, false)
-
diff --git a/otherlibs/threads/Tests/testio.ml b/otherlibs/threads/Tests/testio.ml
deleted file mode 100644
index 3ed08a88f4..0000000000
--- a/otherlibs/threads/Tests/testio.ml
+++ /dev/null
@@ -1,119 +0,0 @@
-(* Test a file copy function *)
-
-let test msg producer consumer src dst =
- print_string msg; print_newline();
- let ic = open_in_bin src in
- let oc = open_out_bin dst in
- let (in_fd, out_fd) = Unix.pipe() in
- let ipipe = Unix.in_channel_of_descr in_fd in
- let opipe = Unix.out_channel_of_descr out_fd in
- let prod = Thread.create producer (ic, opipe) in
- let cons = Thread.create consumer (ipipe, oc) in
- Thread.join prod;
- Thread.join cons;
- if Unix.system ("cmp " ^ src ^ " " ^ dst) = Unix.WEXITED 0
- then print_string "passed"
- else print_string "FAILED";
- print_newline()
-
-(* File copy with constant-sized chunks *)
-
-let copy_file sz (ic, oc) =
- let buffer = String.create sz in
- let rec copy () =
- let n = input ic buffer 0 sz in
- if n = 0 then () else begin
- output oc buffer 0 n;
- copy ()
- end in
- copy();
- close_in ic;
- close_out oc
-
-(* File copy with random-sized chunks *)
-
-let copy_random sz (ic, oc) =
- let buffer = String.create sz in
- let rec copy () =
- let s = 1 + Random.int sz in
- let n = input ic buffer 0 s in
- if n = 0 then () else begin
- output oc buffer 0 n;
- copy ()
- end in
- copy();
- close_in ic;
- close_out oc
-
-(* File copy line per line *)
-
-let copy_line (ic, oc) =
- try
- while true do
- output_string oc (input_line ic); output_char oc '\n'
- done
- with End_of_file ->
- close_in ic;
- close_out oc
-
-(* Create long lines of text *)
-
-let make_lines ofile =
- let oc = open_out ofile in
- for i = 1 to 256 do
- output_string oc (String.make (i*16) '.'); output_char oc '\n'
- done;
- close_out oc
-
-(* Test input_line on truncated lines *)
-
-let test_trunc_line ofile =
- print_string "truncated line"; print_newline();
- let oc = open_out ofile in
- output_string oc "A line without newline!";
- close_out oc;
- try
- let ic = open_in ofile in
- let s = input_line ic in
- close_in ic;
- if s = "A line without newline!"
- then print_string "passed"
- else print_string "FAILED";
- print_newline()
- with End_of_file ->
- print_string "FAILED"; print_newline()
-
-(* The test *)
-
-let main() =
- let ifile = Sys.argv.(1) in
- let ofile = "/tmp/testio" in
- test "256-byte chunks, 256-byte chunks"
- (copy_file 256) (copy_file 256) ifile ofile;
- test "4096-byte chunks, 4096-byte chunks"
- (copy_file 4096) (copy_file 4096) ifile ofile;
- test "65536-byte chunks, 65536-byte chunks"
- (copy_file 65536) (copy_file 65536) ifile ofile;
- test "256-byte chunks, 4096-byte chunks"
- (copy_file 256) (copy_file 4096) ifile ofile;
- test "4096-byte chunks, 256-byte chunks"
- (copy_file 4096) (copy_file 256) ifile ofile;
- test "4096-byte chunks, 65536-byte chunks"
- (copy_file 4096) (copy_file 65536) ifile ofile;
- test "263-byte chunks, 4011-byte chunks"
- (copy_file 263) (copy_file 4011) ifile ofile;
- test "613-byte chunks, 1027-byte chunks"
- (copy_file 613) (copy_file 1027) ifile ofile;
- test "0...8192 byte chunks"
- (copy_random 8192) (copy_random 8192) ifile ofile;
- test "line per line, short lines"
- copy_line copy_line "/etc/hosts" ofile;
- make_lines "/tmp/lines";
- test "line per line, short and long lines"
- copy_line copy_line "/tmp/lines" ofile;
- test_trunc_line ofile;
- Sys.remove "/tmp/lines";
- Sys.remove ofile;
- exit 0
-
-let _ = Unix.handle_unix_error main (); exit 0
diff --git a/otherlibs/threads/Tests/testsieve.ml b/otherlibs/threads/Tests/testsieve.ml
deleted file mode 100644
index 6079d8a8eb..0000000000
--- a/otherlibs/threads/Tests/testsieve.ml
+++ /dev/null
@@ -1,42 +0,0 @@
-let sieve primes=
- Event.sync (Event.send primes 0);
- Event.sync (Event.send primes 1);
- Event.sync (Event.send primes 2);
- let integers = Event.new_channel () in
- let rec enumerate n=
- Event.sync (Event.send integers n);
- enumerate (n + 2)
- and filter inpout =
- let n = Event.sync (Event.receive inpout)
- (* On prepare le terrain pour l'appel recursif *)
- and output = Event.new_channel () in
- (* Celui qui etait en tete du crible est premier *)
- Event.sync (Event.send primes n);
- Thread.create filter output;
- (* On elimine de la sortie ceux qui sont des multiples de n *)
- while true do
- let m = Event.sync (Event.receive inpout) in
- (* print_int n; print_string ": "; print_int m; print_newline(); *)
- if (m mod n) = 0
- then ()
- else ((Event.sync (Event.send output m));())
- done in
- Thread.create filter integers;
- Thread.create enumerate 3
-
-let premiers = Event.new_channel ()
-
-let main _ =
- Thread.create sieve premiers;
- while true do
- for i = 1 to 100 do
- let n = Event.sync (Event.receive premiers) in
- print_int n; print_newline()
- done;
- exit 0
- done
-
-
-let _ =
- try main ()
- with _ -> exit 0;;
diff --git a/otherlibs/threads/Tests/testsignal.ml b/otherlibs/threads/Tests/testsignal.ml
deleted file mode 100644
index 7781f3377b..0000000000
--- a/otherlibs/threads/Tests/testsignal.ml
+++ /dev/null
@@ -1,13 +0,0 @@
-let sighandler _ =
- print_string "Got ctrl-C, exiting..."; print_newline();
- exit 0
-
-let print_message delay c =
- while true do
- print_char c; flush stdout; Thread.delay delay
- done
-
-let _ =
- Sys.signal Sys.sigint (Sys.Signal_handle sighandler);
- Thread.create (print_message 0.6666666666) 'a';
- print_message 1.0 'b'
diff --git a/otherlibs/threads/Tests/testsignal2.ml b/otherlibs/threads/Tests/testsignal2.ml
deleted file mode 100644
index 1f7fc0f91c..0000000000
--- a/otherlibs/threads/Tests/testsignal2.ml
+++ /dev/null
@@ -1,10 +0,0 @@
-let print_message delay c =
- while true do
- print_char c; flush stdout; Thread.delay delay
- done
-
-let _ =
- let th1 = Thread.create (print_message 0.6666666666) 'a' in
- let th2 = Thread.create (print_message 1.0) 'b' in
- let s = Thread.wait_signal [Sys.sigint; Sys.sigterm] in
- Printf.printf "Got signal %d, exiting...\n" s
diff --git a/otherlibs/threads/Tests/testsocket.ml b/otherlibs/threads/Tests/testsocket.ml
deleted file mode 100644
index d0f14cbf5b..0000000000
--- a/otherlibs/threads/Tests/testsocket.ml
+++ /dev/null
@@ -1,31 +0,0 @@
-open Unix
-
-let engine number address =
- print_int number; print_string "> connecting"; print_newline();
- let (ic, oc) = open_connection (ADDR_INET(address, 80)) in
- print_int number; print_string "> connected"; print_newline();
- output_string oc "GET / HTTP1.0\r\n\r\n"; flush oc;
- try
- while true do
- let s = input_line ic in
- print_int number; print_string ">"; print_string s; print_newline()
- done
- with End_of_file ->
- close_out oc
-
-let main() =
- let addresses = Array.create (Array.length Sys.argv - 1) inet_addr_any in
- for i = 1 to Array.length Sys.argv - 1 do
- addresses.(i - 1) <- (gethostbyname Sys.argv.(i)).h_addr_list.(0)
- done;
- let processes = Array.create (Array.length addresses) (Thread.self()) in
- for i = 0 to Array.length addresses - 1 do
- processes.(i) <- Thread.create (engine i) addresses.(i)
- done;
- for i = 0 to Array.length processes - 1 do
- Thread.join processes.(i)
- done
-
-let _ = Printexc.catch main (); exit 0
-
-
diff --git a/otherlibs/threads/Tests/token1.ml b/otherlibs/threads/Tests/token1.ml
deleted file mode 100644
index fb0ddb2dfd..0000000000
--- a/otherlibs/threads/Tests/token1.ml
+++ /dev/null
@@ -1,36 +0,0 @@
-(* Performance test for mutexes and conditions *)
-
-let mut = Mutex.create()
-
-let niter = ref 0
-
-let token = ref 0
-
-let process (n, conds, nprocs) =
- while true do
- Mutex.lock mut;
- while !token <> n do
- (* Printf.printf "Thread %d waiting (token = %d)\n" n !token; *)
- Condition.wait conds.(n) mut
- done;
- (* Printf.printf "Thread %d got token %d\n" n !token; *)
- incr token;
- if !token >= nprocs then token := 0;
- if n = 0 then begin
- decr niter;
- if !niter <= 0 then exit 0
- end;
- Condition.signal conds.(!token);
- Mutex.unlock mut
- done
-
-let main() =
- let nprocs = int_of_string Sys.argv.(1) in
- let iter = int_of_string Sys.argv.(2) in
- let conds = Array.create nprocs (Condition.create()) in
- for i = 1 to nprocs - 1 do conds.(i) <- Condition.create() done;
- niter := iter;
- for i = 0 to nprocs - 1 do Thread.create process (i, conds, nprocs) done;
- Thread.delay 3600.
-
-let _ = main()
diff --git a/otherlibs/threads/Tests/token2.ml b/otherlibs/threads/Tests/token2.ml
deleted file mode 100644
index 32b897dd13..0000000000
--- a/otherlibs/threads/Tests/token2.ml
+++ /dev/null
@@ -1,36 +0,0 @@
-(* Performance test for I/O scheduling *)
-
-let mut = Mutex.create()
-
-let niter = ref 0
-
-let token = ref 0
-
-let process (n, ins, outs, nprocs) =
- let buf = String.create 1 in
- while true do
- Unix.read ins.(n) buf 0 1;
- (* Printf.printf "Thread %d got the token\n" n; *)
- if n = 0 then begin
- decr niter;
- if !niter <= 0 then exit 0
- end;
- let next = if n + 1 >= nprocs then 0 else n + 1 in
- (* Printf.printf "Thread %d sending token to thread %d\n" n next; *)
- Unix.write outs.(next) buf 0 1
- done
-
-let main() =
- let nprocs = int_of_string Sys.argv.(1) in
- let iter = int_of_string Sys.argv.(2) in
- let ins = Array.create nprocs Unix.stdin in
- let outs = Array.create nprocs Unix.stdout in
- for n = 0 to nprocs - 1 do
- let (i, o) = Unix.pipe() in ins.(n) <- i; outs.(n) <- o
- done;
- niter := iter;
- for i = 0 to nprocs - 1 do Thread.create process (i, ins, outs, nprocs) done;
- Unix.write outs.(0) "X" 0 1;
- Thread.delay 3600.
-
-let _ = main()
diff --git a/otherlibs/threads/Tests/torture.ml b/otherlibs/threads/Tests/torture.ml
deleted file mode 100644
index b52766dc72..0000000000
--- a/otherlibs/threads/Tests/torture.ml
+++ /dev/null
@@ -1,46 +0,0 @@
-(* Torture test - lots of GC *)
-
-let gc_thread () =
- while true do
-(* print_string "gc"; print_newline(); *)
- Gc.minor();
- Thread.yield()
- done
-
-let stdin_thread () =
- while true do
- print_string "> "; flush stdout;
- let s = read_line() in
- print_string ">>> "; print_string s; print_newline()
- done
-
-let writer_thread (oc, size) =
- while true do
-(* print_string "writer "; print_int size; print_newline(); *)
- let buff = String.make size 'a' in
- Unix.write oc buff 0 size
- done
-
-let reader_thread (ic, size) =
- while true do
-(* print_string "reader "; print_int size; print_newline(); *)
- let buff = String.create size in
- let n = Unix.read ic buff 0 size in
-(* print_string "reader "; print_int n; print_newline(); *)
- for i = 0 to n-1 do
- if buff.[i] <> 'a' then prerr_endline "error in reader_thread"
- done
- done
-
-let main() =
- Thread.create gc_thread ();
- let (out1, in1) = Unix.pipe() in
- Thread.create writer_thread (in1, 4096);
- Thread.create reader_thread (out1, 4096);
- let (out2, in2) = Unix.pipe() in
- Thread.create writer_thread (in2, 16);
- Thread.create reader_thread (out2, 16);
- stdin_thread()
-
-let _ = main()
-
diff --git a/otherlibs/threads/condition.ml b/otherlibs/threads/condition.ml
deleted file mode 100644
index 521711418d..0000000000
--- a/otherlibs/threads/condition.ml
+++ /dev/null
@@ -1,36 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy and Damien Doligez, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-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
deleted file mode 100644
index 02c108b7b1..0000000000
--- a/otherlibs/threads/condition.mli
+++ /dev/null
@@ -1,53 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy and Damien Doligez, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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 satified *) 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
deleted file mode 100644
index bd47d6526a..0000000000
--- a/otherlibs/threads/event.ml
+++ /dev/null
@@ -1,274 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* 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 Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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.create (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.create(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
deleted file mode 100644
index 21d5459a57..0000000000
--- a/otherlibs/threads/event.mli
+++ /dev/null
@@ -1,82 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* 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 Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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/threads/marshal.ml b/otherlibs/threads/marshal.ml
deleted file mode 100644
index 4297b98c87..0000000000
--- a/otherlibs/threads/marshal.ml
+++ /dev/null
@@ -1,57 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1997 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-type extern_flags =
- No_sharing
- | Closures
-
-external to_string: 'a -> extern_flags list -> string
- = "output_value_to_string"
-
-let to_channel chan v flags =
- output_string chan (to_string v flags)
-
-external to_buffer_unsafe:
- string -> int -> int -> 'a -> extern_flags list -> int
- = "output_value_to_buffer"
-
-let to_buffer buff ofs len v flags =
- if ofs < 0 || len < 0 || ofs + len > String.length buff
- then invalid_arg "Marshal.to_buffer: substring out of bounds"
- else to_buffer_unsafe buff ofs len v flags
-
-let to_buffer' ~buf ~pos ~len v ~mode = to_buffer buf pos len v mode
-
-external from_string_unsafe: string -> int -> 'a = "input_value_from_string"
-external data_size_unsafe: string -> int -> int = "marshal_data_size"
-
-let header_size = 20
-let data_size buff ofs =
- if ofs < 0 || ofs > String.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_string buff ofs =
- if ofs < 0 || ofs > String.length buff - header_size
- then invalid_arg "Marshal.from_size"
- else begin
- let len = data_size_unsafe buff ofs in
- if ofs > String.length buff - (header_size + len)
- then invalid_arg "Marshal.from_string"
- else from_string_unsafe buff ofs
- end
-
-let from_channel = Pervasives.input_value
diff --git a/otherlibs/threads/mutex.ml b/otherlibs/threads/mutex.ml
deleted file mode 100644
index 2858a2414d..0000000000
--- a/otherlibs/threads/mutex.ml
+++ /dev/null
@@ -1,39 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy and Damien Doligez, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-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
deleted file mode 100644
index 0c41c843e8..0000000000
--- a/otherlibs/threads/mutex.mli
+++ /dev/null
@@ -1,50 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy and Damien Doligez, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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
deleted file mode 100644
index 5b69d844d5..0000000000
--- a/otherlibs/threads/pervasives.ml
+++ /dev/null
@@ -1,528 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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 raise : exn -> 'a = "%raise"
-
-let failwith s = raise(Failure s)
-let invalid_arg s = raise(Invalid_argument s)
-
-exception Exit
-
-(* 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 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 min_int = 1 lsl (if 1 lsl 31 = 0 then 30 else 62)
-let max_int = min_int - 1
-
-(* Floating-point operations *)
-
-external (~-.) : float -> float = "%negfloat"
-external (+.) : float -> float -> float = "%addfloat"
-external (-.) : float -> float -> float = "%subfloat"
-external ( *. ) : float -> float -> float = "%mulfloat"
-external (/.) : float -> float -> float = "%divfloat"
-external ( ** ) : float -> float -> float = "power_float" "pow" "float"
-external exp : float -> float = "exp_float" "exp" "float"
-external acos : float -> float = "acos_float" "acos" "float"
-external asin : float -> float = "asin_float" "asin" "float"
-external atan : float -> float = "atan_float" "atan" "float"
-external atan2 : float -> float -> float = "atan2_float" "atan2" "float"
-external cos : float -> float = "cos_float" "cos" "float"
-external cosh : float -> float = "cosh_float" "cosh" "float"
-external log : float -> float = "log_float" "log" "float"
-external log10 : float -> float = "log10_float" "log10" "float"
-external sin : float -> float = "sin_float" "sin" "float"
-external sinh : float -> float = "sinh_float" "sinh" "float"
-external sqrt : float -> float = "sqrt_float" "sqrt" "float"
-external tan : float -> float = "tan_float" "tan" "float"
-external tanh : float -> float = "tanh_float" "tanh" "float"
-external ceil : float -> float = "ceil_float" "ceil" "float"
-external floor : float -> float = "floor_float" "floor" "float"
-external abs_float : float -> float = "%absfloat"
-external mod_float : float -> float -> float = "fmod_float" "fmod" "float"
-external frexp : float -> float * int = "frexp_float"
-external ldexp : float -> int -> float = "ldexp_float"
-external modf : float -> float * float = "modf_float"
-external float : int -> float = "%floatofint"
-external float_of_int : int -> float = "%floatofint"
-external truncate : float -> int = "%intoffloat"
-external int_of_float : float -> int = "%intoffloat"
-external float_of_bytes : string -> float = "float_of_bytes"
-let infinity =
- float_of_bytes "\127\240\000\000\000\000\000\000"
- (* 0x7F F0 00 00 00 00 00 00 *)
-let neg_infinity =
- float_of_bytes "\255\240\000\000\000\000\000\000"
- (* 0xFF F0 00 00 00 00 00 00 *)
-let nan =
- float_of_bytes "\127\240\000\000\000\000\000\001"
- (* 0x7F F0 00 00 00 00 00 01 *)
-let max_float =
- float_of_bytes "\127\239\255\255\255\255\255\255"
- (* 0x7f ef ff ff ff ff ff ff *)
-let min_float =
- float_of_bytes "\000\016\000\000\000\000\000\000"
- (* 0x00 10 00 00 00 00 00 00 *)
-let epsilon_float =
- float_of_bytes "\060\176\000\000\000\000\000\000"
- (* 0x3c b0 00 00 00 00 00 00 *)
-type fpclass =
- FP_normal
- | FP_subnormal
- | FP_zero
- | FP_infinite
- | FP_nan
-external classify_float: float -> fpclass = "classify_float"
-
-(* String operations -- more in module String *)
-
-external string_length : string -> int = "%string_length"
-external string_create: int -> string = "create_string"
-external string_blit : string -> int -> string -> int -> int -> unit
- = "blit_string" "noalloc"
-
-let (^) s1 s2 =
- let l1 = string_length s1 and l2 = string_length s2 in
- let s = string_create (l1 + l2) in
- string_blit s1 0 s 0 l1;
- string_blit s2 0 s l1 l2;
- 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"
-
-(* String conversion functions *)
-
-external format_int: string -> int -> string = "format_int"
-external format_float: string -> float -> string = "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 string_of_int n =
- format_int "%d" n
-
-external int_of_string : string -> int = "int_of_string"
-
-let valid_float_lexem 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 string_of_float f = valid_float_lexem (format_float "%.12g" f);;
-
-external float_of_string : string -> float = "float_of_string"
-
-(* 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_open_descriptor_out"
-external open_descriptor_in: int -> in_channel = "caml_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 inchan_ready : in_channel -> bool = "thread_inchan_ready"
-external outchan_ready : out_channel -> int -> bool = "thread_outchan_ready"
-external descr_inchan : in_channel -> Unix.file_descr = "channel_descriptor"
-external descr_outchan : out_channel -> Unix.file_descr = "channel_descriptor"
-
-let wait_inchan ic =
- if not (inchan_ready ic) then thread_wait_read(descr_inchan ic)
-
-let wait_outchan oc len =
- if not (outchan_ready oc len) then 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 = "sys_open"
-
-let open_out_gen mode perm name =
- open_descriptor_out(open_desc name mode perm)
-
-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_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_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 -> string -> int -> int -> int
- = "caml_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_output_char"
-external output_byte_blocking : out_channel -> int -> unit = "caml_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_string oc s =
- unsafe_output oc s 0 (string_length s)
-
-let output oc s ofs len =
- if ofs < 0 || len < 0 || ofs > string_length s - len
- then invalid_arg "output"
- else unsafe_output oc s ofs len
-
-let output' oc ~buf ~pos ~len = output oc buf pos 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
- = "output_value_to_string"
-
-let output_value oc v = output_string oc (marshal_to_string v [])
-
-external seek_out_blocking : out_channel -> int -> unit = "caml_seek_out"
-
-let seek_out oc pos = flush oc; seek_out_blocking oc pos
-
-external pos_out : out_channel -> int = "caml_pos_out"
-external out_channel_length : out_channel -> int = "caml_channel_size"
-external close_out_channel : out_channel -> unit = "caml_close_channel"
-
-let close_out oc = (try flush oc with _ -> ()); close_out_channel oc
-let close_out_noerr oc =
- (try flush oc with _ -> ());
- (try close_out_channel oc with _ -> ())
-external set_binary_mode_out : out_channel -> bool -> unit
- = "caml_set_binary_mode"
-
-(* General input functions *)
-
-let open_in_gen mode perm name =
- open_descriptor_in(open_desc name mode perm)
-
-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_input_char"
-external input_byte_blocking : in_channel -> int = "caml_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 -> string -> int -> int -> int
- = "caml_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 > string_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 > string_length s - len
- then invalid_arg "really_input"
- else unsafe_really_input ic s ofs len
-
-let input_line ic =
- let buf = ref (string_create 128) in
- let pos = ref 0 in
- begin try
- while true do
- if !pos = string_length !buf then begin
- let newbuf = string_create (2 * !pos) in
- string_blit !buf 0 newbuf 0 !pos;
- buf := newbuf
- end;
- let c = input_char ic in
- if c = '\n' then raise Exit;
- !buf.[!pos] <- c;
- incr pos
- done
- with Exit -> ()
- | End_of_file -> if !pos = 0 then raise End_of_file
- end;
- let res = string_create !pos in
- string_blit !buf 0 res 0 !pos;
- 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 : string -> int -> 'a = "input_value_from_string"
-external marshal_data_size : string -> int -> int = "marshal_data_size"
-
-let input_value ic =
- let header = string_create 20 in
- really_input ic header 0 20;
- let bsize = marshal_data_size header 0 in
- let buffer = string_create (20 + bsize) in
- string_blit header 0 buffer 0 20;
- really_input ic buffer 20 bsize;
- unmarshal buffer 0
-
-external seek_in : in_channel -> int -> unit = "caml_seek_in"
-external pos_in : in_channel -> int = "caml_pos_in"
-external in_channel_length : in_channel -> int = "caml_channel_size"
-external close_in : in_channel -> unit = "caml_close_channel"
-let close_in_noerr ic = (try close_in ic with _ -> ());;
-external set_binary_mode_in : in_channel -> bool -> unit
- = "caml_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_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_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_float () = float_of_string(read_line())
-
-(* Operations on large files *)
-
-module LargeFile =
- struct
- external seek_out : out_channel -> int64 -> unit = "caml_seek_out_64"
- external pos_out : out_channel -> int64 = "caml_pos_out_64"
- external out_channel_length : out_channel -> int64 = "caml_channel_size_64"
- external seek_in : in_channel -> int64 -> unit = "caml_seek_in_64"
- external pos_in : in_channel -> int64 = "caml_pos_in_64"
- external in_channel_length : in_channel -> int64 = "caml_channel_size_64"
- end
-
-(* Formats *)
-type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
-external format_of_string :
- ('a, 'b, 'c, 'd) format4 -> ('a, 'b, 'c, 'd) format4 = "%identity"
-external string_of_format : ('a, 'b, 'c, 'd) format4 -> string = "%identity"
-
-external string_to_format : string -> ('a, 'b, 'c, 'd) format4 = "%identity"
-let (( ^^ ) : ('a, 'b, 'c, 'd) format4 -> ('d, 'b, 'c, 'e) format4 ->
- ('a, 'b, 'c, 'e) format4) = fun fmt1 fmt2 ->
- string_to_format (string_of_format fmt1 ^ string_of_format fmt2);;
-
-(* Miscellaneous *)
-
-external sys_exit : int -> 'a = "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
-
-external register_named_value: string -> 'a -> unit = "register_named_value"
-
-let _ = register_named_value "Pervasives.do_at_exit" do_at_exit
diff --git a/otherlibs/threads/scheduler.c b/otherlibs/threads/scheduler.c
deleted file mode 100644
index 41854ead97..0000000000
--- a/otherlibs/threads/scheduler.c
+++ /dev/null
@@ -1,876 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* The thread scheduler */
-
-#include <string.h>
-#include <stdlib.h>
-#include <stdio.h>
-
-#include "alloc.h"
-#include "backtrace.h"
-#include "callback.h"
-#include "config.h"
-#include "fail.h"
-#include "io.h"
-#include "memory.h"
-#include "misc.h"
-#include "mlvalues.h"
-#include "printexc.h"
-#include "roots.h"
-#include "signals.h"
-#include "stacks.h"
-#include "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 (4 Ko) */
-#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 */
- code_t * 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) 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) {
- 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) 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 = stack_low;
- curr_thread->stack_high = stack_high;
- curr_thread->stack_threshold = stack_threshold;
- curr_thread->sp = extern_sp;
- curr_thread->trapsp = trapsp;
- curr_thread->backtrace_pos = Val_int(backtrace_pos);
- curr_thread->backtrace_buffer = backtrace_buffer;
- curr_thread->backtrace_last_exn = 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 = scan_roots_hook;
- 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) 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 *) 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 (callback_depth > 1) return curr_thread->retval;
-
- /* Save the status of the current thread */
- curr_thread->stack_low = stack_low;
- curr_thread->stack_high = stack_high;
- curr_thread->stack_threshold = stack_threshold;
- curr_thread->sp = extern_sp;
- curr_thread->trapsp = trapsp;
- curr_thread->backtrace_pos = Val_int(backtrace_pos);
- curr_thread->backtrace_buffer = backtrace_buffer;
- curr_thread->backtrace_last_exn = 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;
- }
- enter_blocking_section();
- retcode = select(FD_SETSIZE, &readfds, &writefds, &exceptfds, delay_ptr);
- 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:
- 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 = 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) 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;
- stack_low = curr_thread->stack_low;
- stack_high = curr_thread->stack_high;
- stack_threshold = curr_thread->stack_threshold;
- extern_sp = curr_thread->sp;
- trapsp = curr_thread->trapsp;
- backtrace_pos = Int_val(curr_thread->backtrace_pos);
- backtrace_buffer = curr_thread->backtrace_buffer;
- 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 (callback_depth > 1)
- 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 = *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 */
- *--extern_sp = accu;
-}
-
-/* Request a re-scheduling as soon as possible */
-
-value thread_request_reschedule(value unit) /* ML */
-{
- async_action_hook = thread_reschedule;
- 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 (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, 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, 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);
- long 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, 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:
- failwith("Thread.wakeup: killed thread");
- default:
- 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) failwith("Thread.kill: killed thread");
- /* Don't paint ourselves in a corner */
- if (th == th->next) 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 */
- 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 = format_caml_exception(exn);
- fprintf(stderr, "Thread %d killed on uncaught exception %s\n",
- Int_val(curr_thread->ident), msg);
- free(msg);
- if (backtrace_active) 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 = 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 = alloc_small(1, TAG_WEXITED);
- Field(st, 0) = Val_int(WEXITSTATUS(status));
- }
- else if (WIFSTOPPED(status)) {
- st = alloc_small(1, TAG_WSTOPPED);
- Field(st, 0) = Val_int(WSTOPSIG(status));
- }
- else {
- st = alloc_small(1, TAG_WSIGNALED);
- Field(st, 0) = Val_int(WTERMSIG(status));
- }
- Begin_root(st);
- res = 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
deleted file mode 100644
index 31fc7f0781..0000000000
--- a/otherlibs/threads/thread.ml
+++ /dev/null
@@ -1,141 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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
-
-(* 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"
-external thread_kill : t -> unit = "thread_kill"
-external thread_uncaught_exception : exn -> unit = "thread_uncaught_exception"
-
-external id : t -> int = "thread_id"
-
-(* 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 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
deleted file mode 100644
index 17a6260b30..0000000000
--- a/otherlibs/threads/thread.mli
+++ /dev/null
@@ -1,141 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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. *)
-
-external id : t -> int = "thread_id"
-(** 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_read}.*)
-
-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 thead 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
- explicitely 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
deleted file mode 100644
index 2510bdd993..0000000000
--- a/otherlibs/threads/threadUnix.ml
+++ /dev/null
@@ -1,60 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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 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 sendto = Unix.sendto
-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", ""))
diff --git a/otherlibs/threads/threadUnix.mli b/otherlibs/threads/threadUnix.mli
deleted file mode 100644
index e0a4a82b7d..0000000000
--- a/otherlibs/threads/threadUnix.mli
+++ /dev/null
@@ -1,89 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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 -> string -> int -> int -> int
-val write : Unix.file_descr -> string -> int -> int -> int
-
-(** {6 Input/output with timeout} *)
-
-val timed_read : Unix.file_descr -> string -> int -> int -> float -> int
-(** See {!ThreadUnix.timed_write}. *)
-
-val timed_write : Unix.file_descr -> string -> 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. *)
-
-(** {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 : 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 : Unix.socket_domain -> Unix.socket_type -> int -> Unix.file_descr
-val socketpair :
- Unix.socket_domain -> Unix.socket_type -> int ->
- Unix.file_descr * Unix.file_descr
-val accept : Unix.file_descr -> Unix.file_descr * Unix.sockaddr
-val connect : Unix.file_descr -> Unix.sockaddr -> unit
-val recv :
- Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int
-val recvfrom :
- Unix.file_descr -> string -> int -> int -> Unix.msg_flag list ->
- int * Unix.sockaddr
-val send :
- Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int
-val sendto :
- 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
deleted file mode 100644
index a8f2a06ae5..0000000000
--- a/otherlibs/threads/unix.ml
+++ /dev/null
@@ -1,929 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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
-
-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 = "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
-
-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 -> string -> int -> int -> int = "unix_read"
-external unsafe_write : file_descr -> string -> int -> int -> int = "unix_write"
-
-let rec read fd buf ofs len =
- try
- if ofs < 0 || len < 0 || ofs > String.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 > String.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
-
-external in_channel_of_descr : file_descr -> in_channel
- = "caml_open_descriptor_in"
-external out_channel_of_descr : file_descr -> out_channel
- = "caml_open_descriptor_out"
-external descr_of_in_channel : in_channel -> file_descr = "channel_descriptor"
-external descr_of_out_channel : out_channel -> file_descr
- = "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 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 : file_descr -> file_descr = "unix_dup"
-external dup2 : 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 : unit -> file_descr * file_descr = "unix_pipe"
-
-let pipe() =
- let (out_fd, in_fd as fd_pair) = _pipe() in
- set_nonblock in_fd;
- set_nonblock out_fd;
- fd_pair
-
-external symlink : string -> string -> unit = "unix_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 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"
-
-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
-
-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"
-
-type socket_domain =
- PF_UNIX
- | PF_INET
-
-type socket_type =
- SOCK_STREAM
- | SOCK_DGRAM
- | SOCK_RAW
- | SOCK_SEQPACKET
-
-type sockaddr =
- ADDR_UNIX of string
- | ADDR_INET of inet_addr * int
-
-type shutdown_command =
- SHUTDOWN_RECEIVE
- | SHUTDOWN_SEND
- | SHUTDOWN_ALL
-
-type msg_flag =
- MSG_OOB
- | MSG_DONTROUTE
- | MSG_PEEK
-
-type socket_bool_option =
- SO_DEBUG
- | SO_BROADCAST
- | SO_REUSEADDR
- | SO_KEEPALIVE
- | SO_DONTROUTE
- | SO_OOBINLINE
- | SO_ACCEPTCONN
-
-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
-
-external _socket : socket_domain -> socket_type -> int -> file_descr
- = "unix_socket"
-external _socketpair :
- socket_domain -> socket_type -> int -> file_descr * file_descr
- = "unix_socketpair"
-
-let socket dom typ proto =
- let s = _socket dom typ proto in
- set_nonblock s;
- s
-
-let socketpair dom typ proto =
- let (s1, s2 as spair) = _socketpair dom typ proto in
- set_nonblock s1; set_nonblock s2;
- spair
-
-external _accept : file_descr -> file_descr * sockaddr = "unix_accept"
-
-let rec accept req =
- wait_read req;
- try
- let (s, caller as result) = _accept 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 getsockopt : file_descr -> socket_bool_option -> bool
- = "unix_getsockopt_bool"
-external setsockopt : file_descr -> socket_bool_option -> bool -> unit
- = "unix_setsockopt_bool"
-external getsockopt_int : file_descr -> socket_int_option -> int
- = "unix_getsockopt_int"
-external setsockopt_int : file_descr -> socket_int_option -> int -> unit
- = "unix_setsockopt_int"
-external getsockopt_optint : file_descr -> socket_optint_option -> int option
- = "unix_getsockopt_optint"
-external setsockopt_optint : file_descr -> socket_optint_option -> int option -> unit
- = "unix_setsockopt_optint"
-external getsockopt_float : file_descr -> socket_float_option -> float
- = "unix_getsockopt_float"
-external setsockopt_float : file_descr -> socket_float_option -> float -> unit
- = "unix_setsockopt_float"
-
-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 -> string -> int -> int -> msg_flag list -> int
- = "unix_recv"
-external unsafe_recvfrom :
- file_descr -> string -> int -> int -> msg_flag list -> int * sockaddr
- = "unix_recvfrom"
-external unsafe_send :
- file_descr -> string -> int -> int -> msg_flag list -> int
- = "unix_send"
-external unsafe_sendto :
- file_descr -> string -> 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 > String.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 > String.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 > String.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 > String.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
-
-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 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 system cmd =
- match fork() with
- 0 -> begin try
- execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]
- with _ ->
- exit 127
- end
- | id -> snd(waitpid [] id)
-
-let rec safe_dup fd =
- let new_fd = dup fd in
- if new_fd >= 3 then
- new_fd
- else begin
- let res = safe_dup fd in
- close new_fd;
- res
- end
-
-let safe_close fd =
- try close fd with Unix_error(_,_,_) -> ()
-
-let perform_redirections new_stdin new_stdout new_stderr =
- let newnewstdin = safe_dup new_stdin in
- let newnewstdout = safe_dup new_stdout in
- let newnewstderr = safe_dup new_stderr in
- safe_close new_stdin;
- safe_close new_stdout;
- safe_close new_stderr;
- dup2 newnewstdin stdin; close newnewstdin;
- dup2 newnewstdout stdout; close newnewstdout;
- dup2 newnewstderr stderr; close newnewstderr
-
-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 proc input output toclose =
- match fork() with
- 0 -> if input <> stdin then begin dup2 input stdin; close input end;
- if output <> stdout then begin dup2 output stdout; close output end;
- List.iter close toclose;
- execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |];
- exit 127
- | id -> Hashtbl.add popen_processes proc id
-
-let open_process_in cmd =
- let (in_read, in_write) = pipe() in
- let inchan = in_channel_of_descr in_read in
- open_proc cmd (Process_in inchan) stdin in_write [in_read];
- close in_write;
- inchan
-
-let open_process_out cmd =
- let (out_read, out_write) = pipe() in
- let outchan = out_channel_of_descr out_write in
- open_proc cmd (Process_out outchan) out_read stdout [out_write];
- close out_read;
- outchan
-
-let open_process cmd =
- let (in_read, in_write) = pipe() in
- let (out_read, out_write) = pipe() in
- let inchan = in_channel_of_descr in_read in
- let outchan = out_channel_of_descr out_write in
- open_proc cmd (Process(inchan, outchan)) out_read in_write
- [in_read; out_write];
- close out_read;
- close in_write;
- (inchan, outchan)
-
-let open_proc_full cmd env proc input output error toclose =
- match fork() with
- 0 -> dup2 input stdin; close input;
- dup2 output stdout; close output;
- dup2 error stderr; close error;
- List.iter close toclose;
- execve "/bin/sh" [| "/bin/sh"; "-c"; cmd |] env;
- exit 127
- | id -> Hashtbl.add popen_processes proc id
-
-let open_process_full cmd env =
- let (in_read, in_write) = pipe() in
- let (out_read, out_write) = pipe() in
- let (err_read, err_write) = pipe() 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
- open_proc_full cmd env (Process_full(inchan, outchan, errchan))
- out_read in_write err_write [in_read; out_write; err_read];
- 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;
- begin try close_out outchan with Sys_error _ -> () end;
- 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;
- begin try close_out outchan with Sys_error _ -> () end;
- close_in errchan;
- snd(waitpid [] pid)
-
-(* High-level network functions *)
-
-let open_connection sockaddr =
- let domain =
- match sockaddr with ADDR_UNIX _ -> PF_UNIX | ADDR_INET(_,_) -> PF_INET in
- let sock =
- socket domain SOCK_STREAM 0 in
- 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 =
- let domain =
- match sockaddr with ADDR_UNIX _ -> PF_UNIX | ADDR_INET(_,_) -> PF_INET in
- let sock =
- socket domain SOCK_STREAM 0 in
- setsockopt sock SO_REUSEADDR true;
- bind sock sockaddr;
- listen sock 5;
- while true do
- let (s, caller) = accept 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 *)
- let inchan = in_channel_of_descr s in
- let outchan = out_channel_of_descr s in
- server_fun inchan outchan;
- close_out outchan;
- (* The file descriptor was already closed by close_out.
- close_in inchan;
- *)
- exit 0
- | id -> close s; ignore(waitpid [] id) (* Reclaim the son *)
- done
-
diff --git a/otherlibs/unix/.cvsignore b/otherlibs/unix/.cvsignore
deleted file mode 100644
index 074dd28a45..0000000000
--- a/otherlibs/unix/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-so_locations
diff --git a/otherlibs/unix/.depend b/otherlibs/unix/.depend
deleted file mode 100644
index cb4704c71f..0000000000
--- a/otherlibs/unix/.depend
+++ /dev/null
@@ -1,283 +0,0 @@
-accept.o: accept.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \
- ../../byterun/major_gc.h ../../byterun/freelist.h \
- ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \
- socketaddr.h
-access.o: access.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h unixsupport.h
-addrofstr.o: addrofstr.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/fail.h unixsupport.h socketaddr.h
-alarm.o: alarm.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-bind.o: bind.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h \
- socketaddr.h
-chdir.o: chdir.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-chmod.o: chmod.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-chown.o: chown.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-chroot.o: chroot.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-close.o: close.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-closedir.o: closedir.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-connect.o: connect.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/signals.h unixsupport.h socketaddr.h
-cst2constr.o: cst2constr.c ../../byterun/mlvalues.h \
- ../../byterun/config.h ../../config/m.h ../../config/s.h \
- ../../byterun/misc.h ../../byterun/fail.h cst2constr.h
-cstringv.o: cstringv.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
- ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h
-dup.o: dup.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-dup2.o: dup2.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-envir.o: envir.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h
-errmsg.o: errmsg.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h
-execv.o: execv.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
- ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h
-execve.o: execve.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
- ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h
-execvp.o: execvp.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
- ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h
-exit.o: exit.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-fchmod.o: fchmod.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-fchown.o: fchown.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-fcntl.o: fcntl.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-fork.o: fork.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-ftruncate.o: ftruncate.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/io.h unixsupport.h
-getcwd.o: getcwd.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h unixsupport.h
-getegid.o: getegid.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-geteuid.o: geteuid.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-getgid.o: getgid.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-getgr.o: getgr.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/fail.h ../../byterun/alloc.h ../../byterun/memory.h \
- ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
- ../../byterun/minor_gc.h unixsupport.h
-getgroups.o: getgroups.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h unixsupport.h
-gethost.o: gethost.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \
- ../../byterun/major_gc.h ../../byterun/freelist.h \
- ../../byterun/minor_gc.h ../../byterun/fail.h ../../byterun/signals.h \
- unixsupport.h socketaddr.h
-gethostname.o: gethostname.c ../../byterun/mlvalues.h \
- ../../byterun/config.h ../../config/m.h ../../config/s.h \
- ../../byterun/misc.h ../../byterun/alloc.h unixsupport.h
-getlogin.o: getlogin.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h unixsupport.h
-getpeername.o: getpeername.c ../../byterun/mlvalues.h \
- ../../byterun/config.h ../../config/m.h ../../config/s.h \
- ../../byterun/misc.h unixsupport.h socketaddr.h
-getpid.o: getpid.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-getppid.o: getppid.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-getproto.o: getproto.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \
- ../../byterun/major_gc.h ../../byterun/freelist.h \
- ../../byterun/minor_gc.h ../../byterun/fail.h unixsupport.h
-getpw.o: getpw.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \
- ../../byterun/major_gc.h ../../byterun/freelist.h \
- ../../byterun/minor_gc.h ../../byterun/fail.h unixsupport.h
-getserv.o: getserv.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \
- ../../byterun/major_gc.h ../../byterun/freelist.h \
- ../../byterun/minor_gc.h ../../byterun/fail.h unixsupport.h
-getsockname.o: getsockname.c ../../byterun/mlvalues.h \
- ../../byterun/config.h ../../config/m.h ../../config/s.h \
- ../../byterun/misc.h unixsupport.h socketaddr.h
-gettimeofday.o: gettimeofday.c ../../byterun/mlvalues.h \
- ../../byterun/config.h ../../config/m.h ../../config/s.h \
- ../../byterun/misc.h ../../byterun/alloc.h unixsupport.h
-getuid.o: getuid.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-gmtime.o: gmtime.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \
- ../../byterun/major_gc.h ../../byterun/freelist.h \
- ../../byterun/minor_gc.h unixsupport.h
-itimer.o: itimer.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \
- ../../byterun/major_gc.h ../../byterun/freelist.h \
- ../../byterun/minor_gc.h unixsupport.h
-kill.o: kill.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/fail.h unixsupport.h ../../byterun/signals.h
-link.o: link.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-listen.o: listen.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-lockf.o: lockf.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-lseek.o: lseek.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h ../../byterun/io.h unixsupport.h
-mkdir.o: mkdir.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-mkfifo.o: mkfifo.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-nice.o: nice.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-open.o: open.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \
- ../../byterun/major_gc.h ../../byterun/freelist.h \
- ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h
-opendir.o: opendir.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-pipe.o: pipe.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h unixsupport.h
-putenv.o: putenv.c ../../byterun/memory.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/gc.h \
- ../../byterun/mlvalues.h ../../byterun/misc.h ../../byterun/major_gc.h \
- ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h
-read.o: read.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
- ../../byterun/freelist.h ../../byterun/minor_gc.h \
- ../../byterun/signals.h unixsupport.h
-readdir.o: readdir.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/fail.h ../../byterun/alloc.h unixsupport.h
-readlink.o: readlink.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h unixsupport.h
-rename.o: rename.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-rewinddir.o: rewinddir.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-rmdir.o: rmdir.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-select.o: select.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \
- ../../byterun/major_gc.h ../../byterun/freelist.h \
- ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h
-sendrecv.o: sendrecv.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \
- ../../byterun/major_gc.h ../../byterun/freelist.h \
- ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \
- socketaddr.h
-setgid.o: setgid.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-setsid.o: setsid.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-setuid.o: setuid.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-shutdown.o: shutdown.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-signals.o: signals.c ../../byterun/alloc.h ../../byterun/misc.h \
- ../../byterun/config.h ../../config/m.h ../../config/s.h \
- ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/gc.h \
- ../../byterun/major_gc.h ../../byterun/freelist.h \
- ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h
-sleep.o: sleep.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/signals.h unixsupport.h
-socket.o: socket.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-socketaddr.o: socketaddr.c ../../byterun/mlvalues.h \
- ../../byterun/config.h ../../config/m.h ../../config/s.h \
- ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \
- ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
- ../../byterun/minor_gc.h unixsupport.h socketaddr.h
-socketpair.o: socketpair.c ../../byterun/mlvalues.h \
- ../../byterun/config.h ../../config/m.h ../../config/s.h \
- ../../byterun/misc.h ../../byterun/alloc.h unixsupport.h
-sockopt.o: sockopt.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h unixsupport.h socketaddr.h
-stat.o: stat.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
- ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/alloc.h \
- unixsupport.h cst2constr.h ../../byterun/io.h
-strofaddr.o: strofaddr.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h unixsupport.h socketaddr.h
-symlink.o: symlink.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-termios.o: termios.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h unixsupport.h
-time.o: time.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h unixsupport.h
-times.o: times.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \
- ../../byterun/major_gc.h ../../byterun/freelist.h \
- ../../byterun/minor_gc.h unixsupport.h
-truncate.o: truncate.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/io.h unixsupport.h
-umask.o: umask.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-unixsupport.o: unixsupport.c ../../byterun/mlvalues.h \
- ../../byterun/config.h ../../config/m.h ../../config/s.h \
- ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/callback.h \
- ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
- ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h \
- unixsupport.h cst2constr.h
-unlink.o: unlink.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-utimes.o: utimes.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-wait.o: wait.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \
- ../../byterun/major_gc.h ../../byterun/freelist.h \
- ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h
-write.o: write.c ../../byterun/mlvalues.h ../../byterun/config.h \
- ../../config/m.h ../../config/s.h ../../byterun/misc.h \
- ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
- ../../byterun/freelist.h ../../byterun/minor_gc.h \
- ../../byterun/signals.h unixsupport.h
-unixLabels.cmi: unix.cmi
-unix.cmo: unix.cmi
-unix.cmx: unix.cmi
-unixLabels.cmo: unix.cmi unixLabels.cmi
-unixLabels.cmx: unix.cmx unixLabels.cmi
diff --git a/otherlibs/unix/Makefile b/otherlibs/unix/Makefile
deleted file mode 100644
index 2121ce76df..0000000000
--- a/otherlibs/unix/Makefile
+++ /dev/null
@@ -1,92 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-# Makefile for the Unix interface library
-
-include ../../config/Makefile
-
-# Compilation options
-CC=$(BYTECC)
-CFLAGS=-I../../byterun -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS)
-CAMLC=../../ocamlcomp.sh
-CAMLOPT=../../ocamlcompopt.sh
-MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib
-COMPFLAGS=-warn-error A
-
-OBJS=accept.o access.o addrofstr.o alarm.o bind.o chdir.o chmod.o \
- chown.o chroot.o close.o closedir.o connect.o cst2constr.o cstringv.o \
- dup.o dup2.o envir.o errmsg.o execv.o execve.o execvp.o exit.o \
- fchmod.o fchown.o fcntl.o fork.o ftruncate.o getcwd.o getegid.o \
- geteuid.o getgid.o getgr.o getgroups.o gethost.o gethostname.o \
- getlogin.o getpeername.o getpid.o getppid.o getproto.o getpw.o \
- gettimeofday.o getserv.o getsockname.o getuid.o \
- gmtime.o itimer.o kill.o link.o listen.o lockf.o lseek.o mkdir.o \
- mkfifo.o nice.o open.o opendir.o pipe.o putenv.o read.o \
- readdir.o readlink.o rename.o rewinddir.o rmdir.o select.o sendrecv.o \
- setgid.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
-
-MLOBJS=unix.cmo unixLabels.cmo
-
-all: libunix.a unix.cma
-
-allopt: libunix.a unix.cmxa
-
-libunix.a: $(OBJS)
- $(MKLIB) -o unix $(OBJS)
-
-unix.cma: $(MLOBJS)
- $(MKLIB) -o unix -ocamlc '$(CAMLC)' -linkall $(MLOBJS)
-
-unix.cmxa: $(MLOBJS:.cmo=.cmx)
- $(MKLIB) -o unix -ocamlopt '$(CAMLOPT)' -linkall $(MLOBJS:.cmo=.cmx)
-
-unix.cmx: ../../ocamlopt
-
-partialclean:
- rm -f *.cm*
-
-clean: partialclean
- rm -f *.a *.o *.so
-
-install:
- if test -f dllunix.so; then cp dllunix.so $(STUBLIBDIR)/dllunix.so; fi
- cp libunix.a $(LIBDIR)/libunix.a
- cd $(LIBDIR); $(RANLIB) libunix.a
- cp unix.cma $(MLOBJS:.cmo=.cmi) $(MLOBJS:.cmo=.mli) $(LIBDIR)
-
-installopt:
- cp $(MLOBJS:.cmo=.cmx) unix.cmxa unix.a $(LIBDIR)
- cd $(LIBDIR); $(RANLIB) unix.a
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.mli.cmi:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLC) -c $(COMPFLAGS) -nolabels $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) -nolabels $<
-
-depend:
- gcc -MM $(CFLAGS) *.c > .depend
- ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend
-
-include .depend
diff --git a/otherlibs/unix/accept.c b/otherlibs/unix/accept.c
deleted file mode 100644
index 3247c43dce..0000000000
--- a/otherlibs/unix/accept.c
+++ /dev/null
@@ -1,52 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.h>
-#include <memory.h>
-#include <signals.h>
-#include "unixsupport.h"
-
-#ifdef HAS_SOCKETS
-
-#include "socketaddr.h"
-
-CAMLprim value unix_accept(value sock)
-{
- int retcode;
- value res;
- value a;
- union sock_addr_union addr;
- socklen_param_type addr_len;
-
- addr_len = sizeof(addr);
- enter_blocking_section();
- retcode = accept(Int_val(sock), &addr.s_gen, &addr_len);
- leave_blocking_section();
- if (retcode == -1) uerror("accept", Nothing);
- a = alloc_sockaddr(&addr, addr_len);
- Begin_root (a);
- res = alloc_small(2, 0);
- Field(res, 0) = Val_int(retcode);
- Field(res, 1) = a;
- End_roots();
- return res;
-}
-
-#else
-
-CAMLprim value unix_accept(value sock) { invalid_argument("accept not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/access.c b/otherlibs/unix/access.c
deleted file mode 100644
index 6d81c2bcd3..0000000000
--- a/otherlibs/unix/access.c
+++ /dev/null
@@ -1,51 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.h>
-#include "unixsupport.h"
-
-#ifdef HAS_UNISTD
-# include <unistd.h>
-#else
-# ifndef _WIN32
-# include <sys/file.h>
-# 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
-# else
-# 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, X_OK, F_OK
-};
-
-CAMLprim value unix_access(value path, value perms)
-{
- int ret;
- ret = access(String_val(path),
- convert_flag_list(perms, access_permission_table));
- if (ret == -1)
- uerror("access", path);
- return Val_unit;
-}
diff --git a/otherlibs/unix/addrofstr.c b/otherlibs/unix/addrofstr.c
deleted file mode 100644
index 140f9c3b0a..0000000000
--- a/otherlibs/unix/addrofstr.c
+++ /dev/null
@@ -1,44 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <fail.h>
-#include "unixsupport.h"
-
-#ifdef HAS_SOCKETS
-
-#include "socketaddr.h"
-
-CAMLprim value unix_inet_addr_of_string(value s)
-{
-#ifdef HAS_INET_ATON
- struct in_addr address;
- if (inet_aton(String_val(s), &address) == 0)
- failwith("inet_addr_of_string");
- return alloc_inet_addr(address.s_addr);
-#else
- unsigned int address;
- address = inet_addr(String_val(s));
- if (address == (unsigned int) -1) failwith("inet_addr_of_string");
- return alloc_inet_addr(address);
-#endif
-}
-
-#else
-
-CAMLprim value unix_inet_addr_of_string(value s)
-{ invalid_argument("inet_addr_of_string not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/alarm.c b/otherlibs/unix/alarm.c
deleted file mode 100644
index 6eb6ebe816..0000000000
--- a/otherlibs/unix/alarm.c
+++ /dev/null
@@ -1,23 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_alarm(t)
- value t;
-{
- return Val_int(alarm((unsigned int) Long_val(t)));
-}
diff --git a/otherlibs/unix/bind.c b/otherlibs/unix/bind.c
deleted file mode 100644
index d3520d3f52..0000000000
--- a/otherlibs/unix/bind.c
+++ /dev/null
@@ -1,40 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <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)
-{ invalid_argument("bind not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/chdir.c b/otherlibs/unix/chdir.c
deleted file mode 100644
index 7901eca0e4..0000000000
--- a/otherlibs/unix/chdir.c
+++ /dev/null
@@ -1,25 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_chdir(value path)
-{
- int ret;
- ret = chdir(String_val(path));
- if (ret == -1) uerror("chdir", path);
- return Val_unit;
-}
diff --git a/otherlibs/unix/chmod.c b/otherlibs/unix/chmod.c
deleted file mode 100644
index dff837223e..0000000000
--- a/otherlibs/unix/chmod.c
+++ /dev/null
@@ -1,27 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <sys/types.h>
-#include <sys/stat.h>
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_chmod(value path, value perm)
-{
- int ret;
- ret = chmod(String_val(path), Int_val(perm));
- if (ret == -1) uerror("chmod", path);
- return Val_unit;
-}
diff --git a/otherlibs/unix/chown.c b/otherlibs/unix/chown.c
deleted file mode 100644
index bfd164008f..0000000000
--- a/otherlibs/unix/chown.c
+++ /dev/null
@@ -1,25 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_chown(value path, value uid, value gid)
-{
- int ret;
- ret = chown(String_val(path), Int_val(uid), Int_val(gid));
- if (ret == -1) uerror("chown", path);
- return Val_unit;
-}
diff --git a/otherlibs/unix/chroot.c b/otherlibs/unix/chroot.c
deleted file mode 100644
index 24f49877d5..0000000000
--- a/otherlibs/unix/chroot.c
+++ /dev/null
@@ -1,25 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_chroot(value path)
-{
- int ret;
- ret = chroot(String_val(path));
- if (ret == -1) uerror("chroot", path);
- return Val_unit;
-}
diff --git a/otherlibs/unix/close.c b/otherlibs/unix/close.c
deleted file mode 100644
index 27e1937df4..0000000000
--- a/otherlibs/unix/close.c
+++ /dev/null
@@ -1,23 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_close(value fd)
-{
- if (close(Int_val(fd)) == -1) uerror("close", Nothing);
- return Val_unit;
-}
diff --git a/otherlibs/unix/closedir.c b/otherlibs/unix/closedir.c
deleted file mode 100644
index a168548a9b..0000000000
--- a/otherlibs/unix/closedir.c
+++ /dev/null
@@ -1,29 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-#include <sys/types.h>
-#ifdef HAS_DIRENT
-#include <dirent.h>
-#else
-#include <sys/dir.h>
-#endif
-
-CAMLprim value unix_closedir(value d)
-{
- closedir((DIR *) d);
- return Val_unit;
-}
diff --git a/otherlibs/unix/connect.c b/otherlibs/unix/connect.c
deleted file mode 100644
index 2db973b532..0000000000
--- a/otherlibs/unix/connect.c
+++ /dev/null
@@ -1,43 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <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);
- enter_blocking_section();
- retcode = connect(Int_val(socket), &addr.s_gen, addr_len);
- leave_blocking_section();
- if (retcode == -1) uerror("connect", Nothing);
- return Val_unit;
-}
-
-#else
-
-CAMLprim value unix_connect(value socket, value address)
-{ invalid_argument("connect not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/cst2constr.c b/otherlibs/unix/cst2constr.c
deleted file mode 100644
index 9035160dcc..0000000000
--- a/otherlibs/unix/cst2constr.c
+++ /dev/null
@@ -1,26 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <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
deleted file mode 100644
index 2ee2ce50ba..0000000000
--- a/otherlibs/unix/cst2constr.h
+++ /dev/null
@@ -1,20 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#ifdef __STDC__
-value cst_to_constr(int, int *, int, int);
-#else
-value cst_to_constr();
-#endif
diff --git a/otherlibs/unix/cstringv.c b/otherlibs/unix/cstringv.c
deleted file mode 100644
index d7bd396412..0000000000
--- a/otherlibs/unix/cstringv.c
+++ /dev/null
@@ -1,32 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <memory.h>
-#include "unixsupport.h"
-
-char ** cstringvect(value arg)
-{
- char ** res;
- mlsize_t size, i;
-
- size = Wosize_val(arg);
- res = (char **) 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
deleted file mode 100644
index 5935d0b440..0000000000
--- a/otherlibs/unix/dup.c
+++ /dev/null
@@ -1,25 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_dup(value fd)
-{
- int ret;
- ret = dup(Int_val(fd));
- if (ret == -1) uerror("dup", Nothing);
- return Val_int(ret);
-}
diff --git a/otherlibs/unix/dup2.c b/otherlibs/unix/dup2.c
deleted file mode 100644
index beb987133b..0000000000
--- a/otherlibs/unix/dup2.c
+++ /dev/null
@@ -1,49 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-#ifdef HAS_DUP2
-
-CAMLprim value unix_dup2(value fd1, value fd2)
-{
- if (dup2(Int_val(fd1), Int_val(fd2)) == -1) uerror("dup2", Nothing);
- return Val_unit;
-}
-
-#else
-
-static int do_dup2(int fd1, int fd2)
-{
- int fd;
- int res;
-
- fd = dup(fd1);
- if (fd == -1) return -1;
- if (fd == fd2) return 0;
- res = do_dup2(fd1, fd2);
- close(fd);
- return res;
-}
-
-CAMLprim value unix_dup2(value fd1, value fd2)
-{
- close(Int_val(fd2));
- if (do_dup2(Int_val(fd1), Int_val(fd2)) == -1) uerror("dup2", Nothing);
- return Val_unit;
-}
-
-#endif
diff --git a/otherlibs/unix/envir.c b/otherlibs/unix/envir.c
deleted file mode 100644
index d17aaa4106..0000000000
--- a/otherlibs/unix/envir.c
+++ /dev/null
@@ -1,26 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.h>
-
-#ifndef _WIN32
-extern char ** environ;
-#endif
-
-CAMLprim value unix_environment(void)
-{
- return copy_string_array((const char**)environ);
-}
diff --git a/otherlibs/unix/errmsg.c b/otherlibs/unix/errmsg.c
deleted file mode 100644
index ca09364eeb..0000000000
--- a/otherlibs/unix/errmsg.c
+++ /dev/null
@@ -1,49 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <errno.h>
-#include <mlvalues.h>
-#include <alloc.h>
-
-extern int error_table[];
-
-#ifdef HAS_STRERROR
-
-extern char * strerror(int);
-
-CAMLprim value unix_error_message(value err)
-{
- int errnum;
- errnum = Is_block(err) ? Int_val(Field(err, 0)) : error_table[Int_val(err)];
- return copy_string(strerror(errnum));
-}
-
-#else
-
-extern int sys_nerr;
-extern char *sys_errlist[];
-
-CAMLprim value unix_error_message(value err)
-{
- int errnum;
- errnum = Is_block(err) ? Int_val(Field(err, 0)) : error_table[Int_val(err)];
- if (errnum < 0 || errnum >= sys_nerr) {
- return copy_string("Unknown error");
- } else {
- return copy_string(sys_errlist[errnum]);
- }
-}
-
-#endif
diff --git a/otherlibs/unix/execv.c b/otherlibs/unix/execv.c
deleted file mode 100644
index b7cd800986..0000000000
--- a/otherlibs/unix/execv.c
+++ /dev/null
@@ -1,32 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <memory.h>
-#include "unixsupport.h"
-
-extern char ** cstringvect();
-
-CAMLprim value unix_execv(value path, value args)
-{
- char ** argv;
- argv = cstringvect(args);
- (void) execv(String_val(path), argv);
- 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
deleted file mode 100644
index 0f63aaef96..0000000000
--- a/otherlibs/unix/execve.c
+++ /dev/null
@@ -1,35 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <memory.h>
-#include "unixsupport.h"
-
-extern char ** cstringvect();
-
-CAMLprim value unix_execve(value path, value args, value env)
-{
- char ** argv;
- char ** envp;
- argv = cstringvect(args);
- envp = cstringvect(env);
- (void) execve(String_val(path), argv, envp);
- stat_free((char *) argv);
- 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
deleted file mode 100644
index 960b3bfe1a..0000000000
--- a/otherlibs/unix/execvp.c
+++ /dev/null
@@ -1,51 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <memory.h>
-#include "unixsupport.h"
-
-extern char ** cstringvect();
-#ifndef _WIN32
-extern char ** environ;
-#endif
-
-CAMLprim value unix_execvp(value path, value args)
-{
- char ** argv;
- argv = cstringvect(args);
- (void) execvp(String_val(path), argv);
- 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 ** argv;
- char ** saved_environ;
- argv = cstringvect(args);
- saved_environ = environ;
- environ = cstringvect(env);
- (void) execvp(String_val(path), argv);
- stat_free((char *) argv);
- stat_free((char *) environ);
- environ = saved_environ;
- uerror("execvp", path);
- return Val_unit; /* never reached, but suppress warnings */
- /* from smart compilers */
-}
-
diff --git a/otherlibs/unix/exit.c b/otherlibs/unix/exit.c
deleted file mode 100644
index 26afea3393..0000000000
--- a/otherlibs/unix/exit.c
+++ /dev/null
@@ -1,26 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <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
deleted file mode 100644
index f812edf16c..0000000000
--- a/otherlibs/unix/fchmod.c
+++ /dev/null
@@ -1,34 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <sys/types.h>
-#include <sys/stat.h>
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-#ifdef HAS_FCHMOD
-
-CAMLprim value unix_fchmod(value fd, value perm)
-{
- if (fchmod(Int_val(fd), Int_val(perm)) == -1) uerror("fchmod", Nothing);
- return Val_unit;
-}
-
-#else
-
-CAMLprim value unix_fchmod(value fd, value perm)
-{ invalid_argument("fchmod not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/fchown.c b/otherlibs/unix/fchown.c
deleted file mode 100644
index ba74ffeeb2..0000000000
--- a/otherlibs/unix/fchown.c
+++ /dev/null
@@ -1,33 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-#ifdef HAS_FCHMOD
-
-CAMLprim value unix_fchown(value fd, value uid, value gid)
-{
- if (fchown(Int_val(fd), Int_val(uid), Int_val(gid)) == -1)
- uerror("fchown", Nothing);
- return Val_unit;
-}
-
-#else
-
-CAMLprim value unix_fchown(value fd, value uid, value gid)
-{ invalid_argument("fchown not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/fcntl.c b/otherlibs/unix/fcntl.c
deleted file mode 100644
index 914406eede..0000000000
--- a/otherlibs/unix/fcntl.c
+++ /dev/null
@@ -1,77 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <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;
-}
-
-#ifdef FD_CLOEXEC
-
-CAMLprim value unix_set_close_on_exec(value fd)
-{
- int retcode;
- retcode = fcntl(Int_val(fd), F_GETFD, 0);
- if (retcode == -1 ||
- fcntl(Int_val(fd), F_SETFD, retcode | FD_CLOEXEC) == -1)
- uerror("set_close_on_exec", Nothing);
- return Val_unit;
-}
-
-CAMLprim value unix_clear_close_on_exec(value fd)
-{
- int retcode;
- retcode = fcntl(Int_val(fd), F_GETFD, 0);
- if (retcode == -1 ||
- fcntl(Int_val(fd), F_SETFD, retcode & ~FD_CLOEXEC) == -1)
- uerror("clear_close_on_exec", Nothing);
- return Val_unit;
-}
-
-#else
-
-CAMLprim value unix_set_close_on_exec(value fd)
-{ invalid_argument("set_close_on_exec not implemented"); }
-
-CAMLprim value unix_clear_close_on_exec(value fd)
-{ invalid_argument("clear_close_on_exec not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/fork.c b/otherlibs/unix/fork.c
deleted file mode 100644
index c78973474f..0000000000
--- a/otherlibs/unix/fork.c
+++ /dev/null
@@ -1,26 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_fork(value unit)
-{
- int ret;
- ret = fork();
- if (ret == -1) uerror("fork", Nothing);
- return Val_int(ret);
-}
-
diff --git a/otherlibs/unix/ftruncate.c b/otherlibs/unix/ftruncate.c
deleted file mode 100644
index 8fe041b475..0000000000
--- a/otherlibs/unix/ftruncate.c
+++ /dev/null
@@ -1,45 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <sys/types.h>
-#include <mlvalues.h>
-#include <io.h>
-#include "unixsupport.h"
-#ifdef HAS_UNISTD
-#include <unistd.h>
-#endif
-
-#ifdef HAS_TRUNCATE
-
-CAMLprim value unix_ftruncate(value fd, value len)
-{
- if (ftruncate(Int_val(fd), Long_val(len)) == -1)
- uerror("ftruncate", Nothing);
- return Val_unit;
-}
-
-CAMLprim value unix_ftruncate_64(value fd, value len)
-{
- if (ftruncate(Int_val(fd), File_offset_val(len)) == -1)
- uerror("ftruncate", Nothing);
- return Val_unit;
-}
-
-#else
-
-CAMLprim value unix_ftruncate(value fd, value len)
-{ invalid_argument("ftruncate not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/getcwd.c b/otherlibs/unix/getcwd.c
deleted file mode 100644
index ee96c88b93..0000000000
--- a/otherlibs/unix/getcwd.c
+++ /dev/null
@@ -1,57 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.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 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)
-{ invalid_argument("getcwd not implemented"); }
-
-#endif
-#endif
diff --git a/otherlibs/unix/getegid.c b/otherlibs/unix/getegid.c
deleted file mode 100644
index e9900fb69b..0000000000
--- a/otherlibs/unix/getegid.c
+++ /dev/null
@@ -1,22 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_getegid(void)
-{
- return Val_int(getegid());
-}
diff --git a/otherlibs/unix/geteuid.c b/otherlibs/unix/geteuid.c
deleted file mode 100644
index fd39879d21..0000000000
--- a/otherlibs/unix/geteuid.c
+++ /dev/null
@@ -1,22 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_geteuid(void)
-{
- return Val_int(geteuid());
-}
diff --git a/otherlibs/unix/getgid.c b/otherlibs/unix/getgid.c
deleted file mode 100644
index debac27ee7..0000000000
--- a/otherlibs/unix/getgid.c
+++ /dev/null
@@ -1,22 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_getgid(void)
-{
- return Val_int(getgid());
-}
diff --git a/otherlibs/unix/getgr.c b/otherlibs/unix/getgr.c
deleted file mode 100644
index eefaa5979c..0000000000
--- a/otherlibs/unix/getgr.c
+++ /dev/null
@@ -1,56 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <fail.h>
-#include <alloc.h>
-#include <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 = copy_string(entry->gr_name);
- pass = copy_string(entry->gr_passwd);
- mem = copy_string_array((const char**)entry->gr_mem);
- res = 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;
- entry = getgrnam(String_val(name));
- if (entry == NULL) 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) raise_not_found();
- return alloc_group_entry(entry);
-}
diff --git a/otherlibs/unix/getgroups.c b/otherlibs/unix/getgroups.c
deleted file mode 100644
index 7bbcfef163..0000000000
--- a/otherlibs/unix/getgroups.c
+++ /dev/null
@@ -1,48 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.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 = 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)
-{ invalid_argument("getgroups not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/gethost.c b/otherlibs/unix/gethost.c
deleted file mode 100644
index 5b3252d599..0000000000
--- a/otherlibs/unix/gethost.c
+++ /dev/null
@@ -1,167 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <string.h>
-#include <mlvalues.h>
-#include <alloc.h>
-#include <memory.h>
-#include <fail.h>
-#include <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;
- memmove (&addr, a, entry_h_length);
- return alloc_inet_addr(addr.s_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 = copy_string((char *)(entry->h_name));
- aliases = copy_string_array((const char**)entry->h_aliases);
- entry_h_length = entry->h_length;
-#ifdef h_addr
- addr_list = alloc_array(alloc_one_addr, (const char**)entry->h_addr_list);
-#else
- adr = alloc_one_addr(entry->h_addr);
- addr_list = alloc_small(1, 0);
- Field(addr_list, 0) = adr;
-#endif
- res = alloc_small(4, 0);
- Field(res, 0) = name;
- Field(res, 1) = aliases;
- Field(res, 2) = entry->h_addrtype == PF_UNIX ? Val_int(0) : Val_int(1);
- Field(res, 3) = addr_list;
- End_roots();
- return res;
-}
-
-CAMLprim value unix_gethostbyaddr(value a)
-{
- uint32 adr = GET_INET_ADDR(a);
- struct hostent * hp;
-#if HAS_GETHOSTBYADDR_R == 7
- struct hostent h;
- char buffer[NETDB_BUFFER_SIZE];
- int h_errnop;
- enter_blocking_section();
- hp = gethostbyaddr_r((char *) &adr, 4, AF_INET,
- &h, buffer, sizeof(buffer), &h_errnop);
- leave_blocking_section();
-#elif HAS_GETHOSTBYADDR_R == 8
- struct hostent h;
- char buffer[NETDB_BUFFER_SIZE];
- int h_errnop, rc;
- enter_blocking_section();
- rc = gethostbyaddr_r((char *) &adr, 4, AF_INET,
- &h, buffer, sizeof(buffer), &hp, &h_errnop);
- leave_blocking_section();
- if (rc != 0) hp = NULL;
-#else
-#ifdef GETHOSTBYADDR_IS_REENTRANT
- enter_blocking_section();
-#endif
- hp = gethostbyaddr((char *) &adr, 4, AF_INET);
-#ifdef GETHOSTBYADDR_IS_REENTRANT
- leave_blocking_section();
-#endif
-#endif
- if (hp == (struct hostent *) NULL) raise_not_found();
- return alloc_host_entry(hp);
-}
-
-CAMLprim value unix_gethostbyname(value name)
-{
- struct hostent * hp;
- char * hostname;
-
-#if HAS_GETHOSTBYNAME_R || GETHOSTBYNAME_IS_REENTRANT
- hostname = stat_alloc(string_length(name) + 1);
- strcpy(hostname, String_val(name));
-#else
- hostname = String_val(name);
-#endif
-
-#if HAS_GETHOSTBYNAME_R == 5
- {
- struct hostent h;
- char buffer[NETDB_BUFFER_SIZE];
- int h_errno;
- enter_blocking_section();
- hp = gethostbyname_r(hostname, &h, buffer, sizeof(buffer), &h_errno);
- leave_blocking_section();
- }
-#elif HAS_GETHOSTBYNAME_R == 6
- {
- struct hostent h;
- char buffer[NETDB_BUFFER_SIZE];
- int h_errno, rc;
- enter_blocking_section();
- rc = gethostbyname_r(hostname, &h, buffer, sizeof(buffer), &hp, &h_errno);
- leave_blocking_section();
- if (rc != 0) hp = NULL;
- }
-#else
-#ifdef GETHOSTBYNAME_IS_REENTRANT
- enter_blocking_section();
-#endif
- hp = gethostbyname(hostname);
-#ifdef GETHOSTBYNAME_IS_REENTRANT
- leave_blocking_section();
-#endif
-#endif
-
-#if HAS_GETHOSTBYNAME_R || GETHOSTBYNAME_IS_REENTRANT
- stat_free(hostname);
-#endif
-
- if (hp == (struct hostent *) NULL) raise_not_found();
- return alloc_host_entry(hp);
-}
-
-#else
-
-CAMLprim value unix_gethostbyaddr(value name)
-{ invalid_argument("gethostbyaddr not implemented"); }
-
-CAMLprim value unix_gethostbyname(value name)
-{ invalid_argument("gethostbyname not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/gethostname.c b/otherlibs/unix/gethostname.c
deleted file mode 100644
index 777076bf23..0000000000
--- a/otherlibs/unix/gethostname.c
+++ /dev/null
@@ -1,57 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.h>
-#if defined (_WIN32)
-#include <winsock.h>
-#elif !macintosh
-#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 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)
-{ invalid_argument("gethostname not implemented"); }
-
-#endif
-#endif
diff --git a/otherlibs/unix/getlogin.c b/otherlibs/unix/getlogin.c
deleted file mode 100644
index de569df7fb..0000000000
--- a/otherlibs/unix/getlogin.c
+++ /dev/null
@@ -1,29 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.h>
-#include "unixsupport.h"
-#include <errno.h>
-
-extern char * getlogin(void);
-
-CAMLprim value unix_getlogin(void)
-{
- char * name;
- name = getlogin();
- if (name == NULL) unix_error(ENOENT, "getlogin", Nothing);
- return copy_string(name);
-}
diff --git a/otherlibs/unix/getpeername.c b/otherlibs/unix/getpeername.c
deleted file mode 100644
index c306155644..0000000000
--- a/otherlibs/unix/getpeername.c
+++ /dev/null
@@ -1,40 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <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(sock_addr);
- retcode = getpeername(Int_val(sock), &addr.s_gen, &addr_len);
- if (retcode == -1) uerror("getpeername", Nothing);
- return alloc_sockaddr(&addr, addr_len);
-}
-
-#else
-
-CAMLprim value unix_getpeername(value sock)
-{ invalid_argument("getpeername not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/getpid.c b/otherlibs/unix/getpid.c
deleted file mode 100644
index 876c636050..0000000000
--- a/otherlibs/unix/getpid.c
+++ /dev/null
@@ -1,22 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_getpid(void)
-{
- return Val_int(getpid());
-}
diff --git a/otherlibs/unix/getppid.c b/otherlibs/unix/getppid.c
deleted file mode 100644
index 660c45c9ea..0000000000
--- a/otherlibs/unix/getppid.c
+++ /dev/null
@@ -1,22 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_getppid(void)
-{
- return Val_int(getppid());
-}
diff --git a/otherlibs/unix/getproto.c b/otherlibs/unix/getproto.c
deleted file mode 100644
index 7ab2d2e1f0..0000000000
--- a/otherlibs/unix/getproto.c
+++ /dev/null
@@ -1,70 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.h>
-#include <memory.h>
-#include <fail.h>
-#include "unixsupport.h"
-
-#ifdef HAS_SOCKETS
-
-#ifndef _WIN32
-#include <netdb.h>
-#else
-#include <winsock.h>
-#endif
-
-static value alloc_proto_entry(struct protoent *entry)
-{
- value res;
- value name = Val_unit, aliases = Val_unit;
-
- Begin_roots2 (name, aliases);
- name = copy_string(entry->p_name);
- aliases = copy_string_array((const char**)entry->p_aliases);
- res = 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;
- entry = getprotobyname(String_val(name));
- if (entry == (struct protoent *) NULL) 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) raise_not_found();
- return alloc_proto_entry(entry);
-}
-
-#else
-
-CAMLprim value unix_getprotobynumber(value proto)
-{ invalid_argument("getprotobynumber not implemented"); }
-
-CAMLprim value unix_getprotobyname(value name)
-{ invalid_argument("getprotobyname not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/getpw.c b/otherlibs/unix/getpw.c
deleted file mode 100644
index eba9d6c3c3..0000000000
--- a/otherlibs/unix/getpw.c
+++ /dev/null
@@ -1,65 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.h>
-#include <memory.h>
-#include <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 = copy_string(entry->pw_name);
- passwd = copy_string(entry->pw_passwd);
-#ifndef __BEOS__
- gecos = copy_string(entry->pw_gecos);
-#else
- gecos = copy_string("");
-#endif
- dir = copy_string(entry->pw_dir);
- shell = copy_string(entry->pw_shell);
- res = 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;
- entry = getpwnam(String_val(name));
- if (entry == (struct passwd *) NULL) 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) raise_not_found();
- return alloc_passwd_entry(entry);
-}
diff --git a/otherlibs/unix/getserv.c b/otherlibs/unix/getserv.c
deleted file mode 100644
index e580225837..0000000000
--- a/otherlibs/unix/getserv.c
+++ /dev/null
@@ -1,76 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.h>
-#include <memory.h>
-#include <fail.h>
-#include "unixsupport.h"
-
-#ifdef HAS_SOCKETS
-
-#include <sys/types.h>
-
-#ifndef _WIN32
-#include <sys/socket.h>
-#include <netinet/in.h>
-#include <netdb.h>
-#else
-#include <winsock.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 = copy_string(entry->s_name);
- aliases = copy_string_array((const char**)entry->s_aliases);
- proto = copy_string(entry->s_proto);
- res = 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;
- entry = getservbyname(String_val(name), String_val(proto));
- if (entry == (struct servent *) NULL) raise_not_found();
- return alloc_service_entry(entry);
-}
-
-CAMLprim value unix_getservbyport(value port, value proto)
-{
- struct servent * entry;
- entry = getservbyport(htons(Int_val(port)), String_val(proto));
- if (entry == (struct servent *) NULL) raise_not_found();
- return alloc_service_entry(entry);
-}
-
-#else
-
-CAMLprim value unix_getservbyport(value port, value proto)
-{ invalid_argument("getservbyport not implemented"); }
-
-CAMLprim value unix_getservbyname(value name, value proto)
-{ invalid_argument("getservbyname not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/getsockname.c b/otherlibs/unix/getsockname.c
deleted file mode 100644
index 94990e26d3..0000000000
--- a/otherlibs/unix/getsockname.c
+++ /dev/null
@@ -1,40 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <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);
-}
-
-#else
-
-CAMLprim value unix_getsockname(value sock)
-{ invalid_argument("getsockname not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/gettimeofday.c b/otherlibs/unix/gettimeofday.c
deleted file mode 100644
index 97f80f05ee..0000000000
--- a/otherlibs/unix/gettimeofday.c
+++ /dev/null
@@ -1,37 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.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 copy_double((double) tp.tv_sec + (double) tp.tv_usec / 1e6);
-}
-
-#else
-
-CAMLprim value unix_gettimeofday(value unit)
-{ invalid_argument("gettimeofday not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/getuid.c b/otherlibs/unix/getuid.c
deleted file mode 100644
index 0417665a2c..0000000000
--- a/otherlibs/unix/getuid.c
+++ /dev/null
@@ -1,22 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_getuid(void)
-{
- return Val_int(getuid());
-}
diff --git a/otherlibs/unix/gmtime.c b/otherlibs/unix/gmtime.c
deleted file mode 100644
index 502a5f9f90..0000000000
--- a/otherlibs/unix/gmtime.c
+++ /dev/null
@@ -1,93 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.h>
-#include <memory.h>
-#include "unixsupport.h"
-#include <time.h>
-#include <errno.h>
-
-static value alloc_tm(struct tm *tm)
-{
- value res;
- res = 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 = copy_double((double) clock);
- res = alloc_small(2, 0);
- Field(res, 0) = clkval;
- Field(res, 1) = tmval;
- End_roots ();
- return res;
-}
-
-#else
-
-CAMLprim value unix_mktime(value t) { invalid_argument("mktime not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/itimer.c b/otherlibs/unix/itimer.c
deleted file mode 100644
index 6e5ea35899..0000000000
--- a/otherlibs/unix/itimer.c
+++ /dev/null
@@ -1,74 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.h>
-#include <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 = 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)
-{ invalid_argument("setitimer not implemented"); }
-CAMLprim value unix_getitimer(value which)
-{ invalid_argument("getitimer not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/kill.c b/otherlibs/unix/kill.c
deleted file mode 100644
index 8d8a47340c..0000000000
--- a/otherlibs/unix/kill.c
+++ /dev/null
@@ -1,29 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <fail.h>
-#include "unixsupport.h"
-#include <signal.h>
-#include <signals.h>
-
-CAMLprim value unix_kill(value pid, value signal)
-{
- int sig;
- sig = 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
deleted file mode 100644
index 181e9c1800..0000000000
--- a/otherlibs/unix/link.c
+++ /dev/null
@@ -1,23 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_link(value path1, value path2)
-{
- if (link(String_val(path1), String_val(path2)) == -1) uerror("link", path2);
- return Val_unit;
-}
diff --git a/otherlibs/unix/listen.c b/otherlibs/unix/listen.c
deleted file mode 100644
index d85d854fc8..0000000000
--- a/otherlibs/unix/listen.c
+++ /dev/null
@@ -1,34 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <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)
-{ invalid_argument("listen not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/lockf.c b/otherlibs/unix/lockf.c
deleted file mode 100644
index fd71514f9f..0000000000
--- a/otherlibs/unix/lockf.c
+++ /dev/null
@@ -1,110 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <errno.h>
-#include <fcntl.h>
-#include <mlvalues.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;
- ret = fcntl(fildes, F_SETLKW, &l);
- 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;
- ret = fcntl(fildes, F_SETLKW, &l);
- 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)
-{ invalid_argument("lockf not implemented"); }
-
-#endif
-#endif
diff --git a/otherlibs/unix/lseek.c b/otherlibs/unix/lseek.c
deleted file mode 100644
index 5dfa7e37fd..0000000000
--- a/otherlibs/unix/lseek.c
+++ /dev/null
@@ -1,57 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <errno.h>
-#include <sys/types.h>
-#include <mlvalues.h>
-#include <alloc.h>
-#include <io.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;
- ret = lseek(Int_val(fd), Long_val(ofs),
- seek_command_table[Int_val(cmd)]);
- 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;
- ret = lseek(Int_val(fd), File_offset_val(ofs),
- seek_command_table[Int_val(cmd)]);
- if (ret == -1) uerror("lseek", Nothing);
- return Val_file_offset(ret);
-}
-
diff --git a/otherlibs/unix/mkdir.c b/otherlibs/unix/mkdir.c
deleted file mode 100644
index 1b8fd6242f..0000000000
--- a/otherlibs/unix/mkdir.c
+++ /dev/null
@@ -1,25 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <sys/types.h>
-#include <sys/stat.h>
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_mkdir(value path, value perm)
-{
- if (mkdir(String_val(path), Int_val(perm)) == -1) uerror("mkdir", path);
- return Val_unit;
-}
diff --git a/otherlibs/unix/mkfifo.c b/otherlibs/unix/mkfifo.c
deleted file mode 100644
index f260cb74e8..0000000000
--- a/otherlibs/unix/mkfifo.c
+++ /dev/null
@@ -1,49 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <sys/types.h>
-#include <sys/stat.h>
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-#ifdef HAS_MKFIFO
-
-CAMLprim value unix_mkfifo(value path, value mode)
-{
- if (mkfifo(String_val(path), Int_val(mode)) == -1)
- uerror("mkfifo", path);
- return Val_unit;
-}
-
-#else
-
-#include <sys/types.h>
-#include <sys/stat.h>
-
-#ifdef S_IFIFO
-
-CAMLprim value unix_mkfifo(value path, value mode)
-{
- if (mknod(String_val(path), (Int_val(mode) & 07777) | S_IFIFO, 0) == -1)
- uerror("mkfifo", path);
- return Val_unit;
-}
-
-#else
-
-CAMLprim value unix_mkfifo() { invalid_argument("mkfifo not implemented"); }
-
-#endif
-#endif
diff --git a/otherlibs/unix/nice.c b/otherlibs/unix/nice.c
deleted file mode 100644
index 6018af0c2b..0000000000
--- a/otherlibs/unix/nice.c
+++ /dev/null
@@ -1,50 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-#include <errno.h>
-
-#ifdef HAS_GETPRIORITY
-
-#include <sys/types.h>
-#include <sys/time.h>
-#include <sys/resource.h>
-
-CAMLprim value unix_nice(value incr)
-{
- int prio;
- errno = 0;
- prio = getpriority(PRIO_PROCESS, 0);
- if (prio == -1 && errno != 0)
- uerror("nice", Nothing);
- prio += Int_val(incr);
- if (setpriority(PRIO_PROCESS, 0, prio) == -1)
- uerror("nice", Nothing);
- return Val_int(prio);
-}
-
-#else
-
-CAMLprim value unix_nice(value incr)
-{
- int ret;
- errno = 0;
- ret = nice(Int_val(incr));
- if (ret == -1 && errno != 0) uerror("nice", Nothing);
- return Val_int(ret);
-}
-
-#endif
diff --git a/otherlibs/unix/open.c b/otherlibs/unix/open.c
deleted file mode 100644
index 880cbb5c6d..0000000000
--- a/otherlibs/unix/open.c
+++ /dev/null
@@ -1,57 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.h>
-#include <memory.h>
-#include <signals.h>
-#include "unixsupport.h"
-#include <string.h>
-#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[] = {
- O_RDONLY, O_WRONLY, O_RDWR, O_NONBLOCK, O_APPEND, O_CREAT, O_TRUNC, O_EXCL,
- O_NOCTTY, O_DSYNC, O_SYNC, O_RSYNC
-};
-
-CAMLprim value unix_open(value path, value flags, value perm)
-{
- CAMLparam3(path, flags, perm);
- int ret;
- char * p;
-
- p = stat_alloc(string_length(path) + 1);
- strcpy(p, String_val(path));
- /* open on a named FIFO can block (PR#1533) */
- enter_blocking_section();
- ret = open(p, convert_flag_list(flags, open_flag_table), Int_val(perm));
- leave_blocking_section();
- stat_free(p);
- if (ret == -1) uerror("open", path);
- CAMLreturn (Val_int(ret));
-}
diff --git a/otherlibs/unix/opendir.c b/otherlibs/unix/opendir.c
deleted file mode 100644
index 8852f5332e..0000000000
--- a/otherlibs/unix/opendir.c
+++ /dev/null
@@ -1,31 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.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)
-{
- DIR * d;
- d = opendir(String_val(path));
- if (d == (DIR *) NULL) uerror("opendir", path);
- return (value) d;
-}
diff --git a/otherlibs/unix/pipe.c b/otherlibs/unix/pipe.c
deleted file mode 100644
index 6b571be658..0000000000
--- a/otherlibs/unix/pipe.c
+++ /dev/null
@@ -1,29 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_pipe(void)
-{
- int fd[2];
- value res;
- if (pipe(fd) == -1) uerror("pipe", Nothing);
- res = 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
deleted file mode 100644
index 962fd7902a..0000000000
--- a/otherlibs/unix/putenv.c
+++ /dev/null
@@ -1,45 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1998 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <stdlib.h>
-#include <string.h>
-
-#include <memory.h>
-#include <mlvalues.h>
-
-#include "unixsupport.h"
-
-#ifdef HAS_PUTENV
-
-CAMLprim value unix_putenv(value name, value val)
-{
- mlsize_t namelen = string_length(name);
- mlsize_t vallen = string_length(val);
- char * s = (char *) 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) uerror("putenv", name);
- return Val_unit;
-}
-
-#else
-
-CAMLprim value unix_putenv(value name, value val)
-{ invalid_argument("putenv not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/read.c b/otherlibs/unix/read.c
deleted file mode 100644
index 03a9e6aaa7..0000000000
--- a/otherlibs/unix/read.c
+++ /dev/null
@@ -1,38 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <string.h>
-#include <mlvalues.h>
-#include <memory.h>
-#include <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;
- enter_blocking_section();
- ret = read(Int_val(fd), iobuf, (int) numbytes);
- 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
deleted file mode 100644
index 09cbc3726c..0000000000
--- a/otherlibs/unix/readdir.c
+++ /dev/null
@@ -1,36 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <fail.h>
-#include <alloc.h>
-#include "unixsupport.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 d)
-{
- directory_entry * e;
-
- e = readdir((DIR *) d);
- if (e == (directory_entry *) NULL) raise_end_of_file();
- return copy_string(e->d_name);
-}
diff --git a/otherlibs/unix/readlink.c b/otherlibs/unix/readlink.c
deleted file mode 100644
index 6cc4d9ec47..0000000000
--- a/otherlibs/unix/readlink.c
+++ /dev/null
@@ -1,47 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.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)
-{
- char buffer[PATH_MAX];
- int len;
- len = readlink(String_val(path), buffer, sizeof(buffer) - 1);
- if (len == -1) uerror("readlink", path);
- buffer[len] = '\0';
- return copy_string(buffer);
-}
-
-#else
-
-CAMLprim value unix_readlink(value path)
-{ invalid_argument("readlink not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/rename.c b/otherlibs/unix/rename.c
deleted file mode 100644
index 65f33c8b57..0000000000
--- a/otherlibs/unix/rename.c
+++ /dev/null
@@ -1,25 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <stdio.h>
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_rename(value path1, value path2)
-{
- if (rename(String_val(path1), String_val(path2)) == -1)
- uerror("rename", path1);
- return Val_unit;
-}
diff --git a/otherlibs/unix/rewinddir.c b/otherlibs/unix/rewinddir.c
deleted file mode 100644
index bc01e05598..0000000000
--- a/otherlibs/unix/rewinddir.c
+++ /dev/null
@@ -1,38 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.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 d)
-{
- rewinddir((DIR *) d);
- return Val_unit;
-}
-
-#else
-
-CAMLprim value unix_rewinddir(value d)
-{ invalid_argument("rewinddir not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/rmdir.c b/otherlibs/unix/rmdir.c
deleted file mode 100644
index 8de223464d..0000000000
--- a/otherlibs/unix/rmdir.c
+++ /dev/null
@@ -1,23 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_rmdir(value path)
-{
- if (rmdir(String_val(path)) == -1) uerror("rmdir", path);
- return Val_unit;
-}
diff --git a/otherlibs/unix/select.c b/otherlibs/unix/select.c
deleted file mode 100644
index 43de97709b..0000000000
--- a/otherlibs/unix/select.c
+++ /dev/null
@@ -1,109 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.h>
-#include <memory.h>
-#include <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>
-
-typedef fd_set file_descr_set;
-
-static void 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)) {
- int fd = Int_val(Field(l, 0));
- FD_SET(fd, fdset);
- if (fd > *maxfd) *maxfd = fd;
- }
-}
-
-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 = 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;
- fdlist_to_fdset(readfds, &read, &maxfd);
- fdlist_to_fdset(writefds, &write, &maxfd);
- fdlist_to_fdset(exceptfds, &except, &maxfd);
- 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;
- }
- enter_blocking_section();
- retcode = select(maxfd + 1, &read, &write, &except, tvp);
- 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 = 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)
-{ invalid_argument("select not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/sendrecv.c b/otherlibs/unix/sendrecv.c
deleted file mode 100644
index ac9b32e859..0000000000
--- a/otherlibs/unix/sendrecv.c
+++ /dev/null
@@ -1,139 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <string.h>
-#include <mlvalues.h>
-#include <alloc.h>
-#include <memory.h>
-#include <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;
- long numbytes;
- char iobuf[UNIX_BUFFER_SIZE];
-
- Begin_root (buff);
- numbytes = Long_val(len);
- if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
- enter_blocking_section();
- ret = recv(Int_val(sock), iobuf, (int) numbytes,
- convert_flag_list(flags, msg_flag_table));
- 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;
- long numbytes;
- char iobuf[UNIX_BUFFER_SIZE];
- value res;
- value adr = Val_unit;
- union sock_addr_union addr;
- socklen_param_type addr_len;
-
- Begin_roots2 (buff, adr);
- numbytes = Long_val(len);
- if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
- addr_len = sizeof(addr);
- enter_blocking_section();
- ret = recvfrom(Int_val(sock), iobuf, (int) numbytes,
- convert_flag_list(flags, msg_flag_table),
- &addr.s_gen, &addr_len);
- leave_blocking_section();
- if (ret == -1) uerror("recvfrom", Nothing);
- memmove (&Byte(buff, Long_val(ofs)), iobuf, ret);
- adr = alloc_sockaddr(&addr, addr_len);
- res = 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;
- long numbytes;
- char iobuf[UNIX_BUFFER_SIZE];
-
- numbytes = Long_val(len);
- if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
- memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes);
- enter_blocking_section();
- ret = send(Int_val(sock), iobuf, (int) numbytes,
- convert_flag_list(flags, msg_flag_table));
- 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;
- long numbytes;
- char iobuf[UNIX_BUFFER_SIZE];
- union sock_addr_union addr;
- socklen_param_type addr_len;
-
- 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);
- enter_blocking_section();
- ret = sendto(Int_val(sock), iobuf, (int) numbytes,
- convert_flag_list(flags, msg_flag_table),
- &addr.s_gen, addr_len);
- 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)
-{ invalid_argument("recv not implemented"); }
-
-CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len, value flags)
-{ invalid_argument("recvfrom not implemented"); }
-
-CAMLprim value unix_send(value sock, value buff, value ofs, value len, value flags)
-{ invalid_argument("send not implemented"); }
-
-CAMLprim value unix_sendto_native(value sock, value buff, value ofs, value len, value flags, value dest)
-{ invalid_argument("sendto not implemented"); }
-
-CAMLprim value unix_sendto(value *argv, int argc)
-{ invalid_argument("sendto not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/setgid.c b/otherlibs/unix/setgid.c
deleted file mode 100644
index bd8810f819..0000000000
--- a/otherlibs/unix/setgid.c
+++ /dev/null
@@ -1,23 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <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/setsid.c b/otherlibs/unix/setsid.c
deleted file mode 100644
index fed8e0dca0..0000000000
--- a/otherlibs/unix/setsid.c
+++ /dev/null
@@ -1,30 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1997 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <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
- invalid_argument("setsid not implemented");
- return Val_unit;
-#endif
-}
diff --git a/otherlibs/unix/setuid.c b/otherlibs/unix/setuid.c
deleted file mode 100644
index c867f4c68b..0000000000
--- a/otherlibs/unix/setuid.c
+++ /dev/null
@@ -1,23 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <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
deleted file mode 100644
index f8216bd2e9..0000000000
--- a/otherlibs/unix/shutdown.c
+++ /dev/null
@@ -1,39 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <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)
-{ invalid_argument("shutdown not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/signals.c b/otherlibs/unix/signals.c
deleted file mode 100644
index 95db00bd23..0000000000
--- a/otherlibs/unix/signals.c
+++ /dev/null
@@ -1,105 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1998 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <errno.h>
-#include <signal.h>
-
-#include <alloc.h>
-#include <memory.h>
-#include <mlvalues.h>
-#include <signals.h>
-#include "unixsupport.h"
-
-#ifndef NSIG
-#define NSIG 32
-#endif
-
-#ifdef POSIX_SIGNALS
-
-static void decode_sigset(value vset, sigset_t * set)
-{
- sigemptyset(set);
- while (vset != Val_int(0)) {
- int sig = 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)) {
- value newcons = alloc_small(2, 0);
- Field(newcons, 0) = Val_int(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);
- enter_blocking_section();
- retcode = sigprocmask(how, &set, &oldset);
- 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);
- enter_blocking_section();
- retcode = sigsuspend(&set);
- leave_blocking_section();
- if (retcode == -1 && errno != EINTR) uerror("sigsuspend", Nothing);
- return Val_unit;
-}
-
-#else
-
-CAMLprim value unix_sigprocmask(value vaction, value vset)
-{ invalid_argument("Unix.sigprocmask not available"); }
-
-CAMLprim value unix_sigpending(value unit)
-{ invalid_argument("Unix.sigpending not available"); }
-
-CAMLprim value unix_sigsuspend(value vset)
-{ invalid_argument("Unix.sigsuspend not available"); }
-
-#endif
diff --git a/otherlibs/unix/sleep.c b/otherlibs/unix/sleep.c
deleted file mode 100644
index ec14e39d0b..0000000000
--- a/otherlibs/unix/sleep.c
+++ /dev/null
@@ -1,26 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <signals.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_sleep(value t)
-{
- enter_blocking_section();
- sleep(Int_val(t));
- leave_blocking_section();
- return Val_unit;
-}
diff --git a/otherlibs/unix/socket.c b/otherlibs/unix/socket.c
deleted file mode 100644
index a61a1a3094..0000000000
--- a/otherlibs/unix/socket.c
+++ /dev/null
@@ -1,48 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-#ifdef HAS_SOCKETS
-
-#include <sys/types.h>
-#include <sys/socket.h>
-
-int socket_domain_table[] = {
- PF_UNIX, PF_INET
-};
-
-int socket_type_table[] = {
- SOCK_STREAM, SOCK_DGRAM, SOCK_RAW, SOCK_SEQPACKET
-};
-
-CAMLprim value unix_socket(value domain, value type, value proto)
-{
- int retcode;
- retcode = socket(socket_domain_table[Int_val(domain)],
- socket_type_table[Int_val(type)],
- Int_val(proto));
- if (retcode == -1) uerror("socket", Nothing);
- return Val_int(retcode);
-
-}
-
-#else
-
-CAMLprim value unix_socket(value domain, value type, value proto)
-{ invalid_argument("socket not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/socketaddr.c b/otherlibs/unix/socketaddr.c
deleted file mode 100644
index 4be5f12910..0000000000
--- a/otherlibs/unix/socketaddr.c
+++ /dev/null
@@ -1,110 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <string.h>
-#include <mlvalues.h>
-#include <alloc.h>
-#include <memory.h>
-#include <errno.h>
-#include "unixsupport.h"
-
-#ifdef HAS_SOCKETS
-
-#include "socketaddr.h"
-
-#ifdef _WIN32
-#define EAFNOSUPPORT WSAEAFNOSUPPORT
-#endif
-
-value alloc_inet_addr(uint32 a)
-{
- value res;
- /* Use a string rather than an abstract block so that it can be
- marshaled safely. Remember that a is in network byte order,
- hence can be marshaled safely. */
- res = alloc_string(sizeof(uint32));
- GET_INET_ADDR(res) = a;
- return res;
-}
-
-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 = string_length(path);
- adr->s_unix.sun_family = AF_UNIX;
- if (len >= sizeof(adr->s_unix.sun_path)) {
- unix_error(ENAMETOOLONG, "", 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 */
- {
- char * p;
- int n;
- for (p = (char *) &adr->s_inet, n = sizeof(adr->s_inet);
- n > 0; p++, n--)
- *p = 0;
- adr->s_inet.sin_family = AF_INET;
- adr->s_inet.sin_addr.s_addr = GET_INET_ADDR(Field(mladr, 0));
- adr->s_inet.sin_port = htons(Int_val(Field(mladr, 1)));
- *adr_len = sizeof(struct sockaddr_in);
- break;
- }
- }
-}
-
-value alloc_sockaddr(union sock_addr_union * adr /*in*/,
- socklen_param_type adr_len)
-{
- value res;
- switch(adr->s_gen.sa_family) {
-#ifndef _WIN32
- case AF_UNIX:
- { value n = copy_string(adr->s_unix.sun_path);
- Begin_root (n);
- res = 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.s_addr);
- Begin_root (a);
- res = alloc_small(2, 1);
- Field(res,0) = a;
- Field(res,1) = Val_int(ntohs(adr->s_inet.sin_port));
- End_roots();
- break;
- }
- default:
- unix_error(EAFNOSUPPORT, "", Nothing);
- }
- return res;
-}
-
-#endif
diff --git a/otherlibs/unix/socketaddr.h b/otherlibs/unix/socketaddr.h
deleted file mode 100644
index 9788a10098..0000000000
--- a/otherlibs/unix/socketaddr.h
+++ /dev/null
@@ -1,44 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <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;
-};
-
-extern union sock_addr_union sock_addr;
-
-#ifdef HAS_SOCKLEN_T
-typedef socklen_t socklen_param_type;
-#else
-typedef int socklen_param_type;
-#endif
-
-void get_sockaddr (value mladdr,
- union sock_addr_union * addr /*out*/,
- socklen_param_type * addr_len /*out*/);
-CAMLprim value alloc_sockaddr (union sock_addr_union * addr /*in*/,
- socklen_param_type addr_len);
-CAMLprim value alloc_inet_addr (uint32 inaddr);
-
-#define GET_INET_ADDR(v) (*((uint32 *) (v)))
diff --git a/otherlibs/unix/socketpair.c b/otherlibs/unix/socketpair.c
deleted file mode 100644
index 6c7b4ebc81..0000000000
--- a/otherlibs/unix/socketpair.c
+++ /dev/null
@@ -1,45 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.h>
-#include "unixsupport.h"
-
-#ifdef HAS_SOCKETS
-
-#include <sys/socket.h>
-
-extern int socket_domain_table[], socket_type_table[];
-
-CAMLprim value unix_socketpair(value domain, value type, value proto)
-{
- int sv[2];
- value res;
- if (socketpair(socket_domain_table[Int_val(domain)],
- socket_type_table[Int_val(type)],
- Int_val(proto), sv) == -1)
- uerror("socketpair", Nothing);
- res = 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)
-{ invalid_argument("socketpair not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/sockopt.c b/otherlibs/unix/sockopt.c
deleted file mode 100644
index 3d913dca3b..0000000000
--- a/otherlibs/unix/sockopt.c
+++ /dev/null
@@ -1,236 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.h>
-#include "unixsupport.h"
-
-#ifdef HAS_SOCKETS
-
-#include <sys/time.h>
-#include <sys/types.h>
-#include <sys/socket.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
-
-static int sockopt_bool[] = {
- SO_DEBUG, SO_BROADCAST, SO_REUSEADDR, SO_KEEPALIVE,
- SO_DONTROUTE, SO_OOBINLINE, SO_ACCEPTCONN };
-
-static int sockopt_int[] = {
- SO_SNDBUF, SO_RCVBUF, SO_ERROR, SO_TYPE, SO_RCVLOWAT, SO_SNDLOWAT };
-
-static int sockopt_optint[] = { SO_LINGER };
-
-static int sockopt_float[] = { SO_RCVTIMEO, SO_SNDTIMEO };
-
-CAMLprim value getsockopt_int(int *sockopt, value socket,
- int level, value option)
-{
- int optval;
- socklen_param_type optsize;
-
- optsize = sizeof(optval);
- if (getsockopt(Int_val(socket), level, sockopt[Int_val(option)],
- (void *) &optval, &optsize) == -1)
- uerror("getsockopt", Nothing);
- return Val_int(optval);
-}
-
-CAMLprim value setsockopt_int(int *sockopt, value socket, int level,
- value option, value status)
-{
- int optval = Int_val(status);
- if (setsockopt(Int_val(socket), level, sockopt[Int_val(option)],
- (void *) &optval, sizeof(optval)) == -1)
- uerror("setsockopt", Nothing);
- return Val_unit;
-}
-
-CAMLprim value unix_getsockopt_bool(value socket, value option) {
- value res = getsockopt_int(sockopt_bool, socket, SOL_SOCKET, option);
- return Val_bool(Int_val(res));
-}
-
-CAMLprim value unix_setsockopt_bool(value socket, value option, value status)
-{
- return setsockopt_int(sockopt_bool, socket, SOL_SOCKET, option, status);
-}
-
-CAMLprim value unix_getsockopt_int(value socket, value option) {
- return getsockopt_int(sockopt_int, socket, SOL_SOCKET, option);
-}
-
-CAMLprim value unix_setsockopt_int(value socket, value option, value status)
-{
- return setsockopt_int(sockopt_int, socket, SOL_SOCKET, option, status);
-}
-
-CAMLprim value getsockopt_optint(int *sockopt, value socket,
- int level, value option)
-{
- struct linger optval;
- socklen_param_type optsize;
- value res = Val_int(0); /* None */
-
- optsize = sizeof(optval);
- if (getsockopt(Int_val(socket), level, sockopt[Int_val(option)],
- (void *) &optval, &optsize) == -1)
- uerror("getsockopt_optint", Nothing);
- if (optval.l_onoff != 0) {
- res = alloc_small(1, 0);
- Field(res, 0) = Val_int(optval.l_linger);
- }
- return res;
-}
-
-CAMLprim value setsockopt_optint(int *sockopt, value socket, int level,
- value option, value status)
-{
- struct linger optval;
-
- optval.l_onoff = Is_block (status);
- if (optval.l_onoff)
- optval.l_linger = Int_val (Field (status, 0));
- if (setsockopt(Int_val(socket), level, sockopt[Int_val(option)],
- (void *) &optval, sizeof(optval)) == -1)
- uerror("setsockopt_optint", Nothing);
- return Val_unit;
-}
-
-CAMLprim value unix_getsockopt_optint(value socket, value option)
-{
- return getsockopt_optint(sockopt_optint, socket, SOL_SOCKET, option);
-}
-
-CAMLprim value unix_setsockopt_optint(value socket, value option, value status)
-{
- return setsockopt_optint(sockopt_optint, socket, SOL_SOCKET, option, status);
-}
-
-CAMLprim value getsockopt_float(int *sockopt, value socket,
- int level, value option)
-{
- struct timeval tv;
- socklen_param_type optsize;
-
- optsize = sizeof(tv);
- if (getsockopt(Int_val(socket), level, sockopt[Int_val(option)],
- (void *) &tv, &optsize) == -1)
- uerror("getsockopt_float", Nothing);
- return copy_double((double) tv.tv_sec + (double) tv.tv_usec / 1e6);
-}
-
-CAMLprim value setsockopt_float(int *sockopt, value socket, int level,
- value option, value status)
-{
- struct timeval tv;
- double tv_f;
-
- tv_f = Double_val(status);
- tv.tv_sec = (int)tv_f;
- tv.tv_usec = (int) (1e6 * (tv_f - tv.tv_sec));
- if (setsockopt(Int_val(socket), level, sockopt[Int_val(option)],
- (void *) &tv, sizeof(tv)) == -1)
- uerror("setsockopt_float", Nothing);
- return Val_unit;
-}
-
-CAMLprim value unix_getsockopt_float(value socket, value option)
-{
- return getsockopt_float(sockopt_float, socket, SOL_SOCKET, option);
-}
-
-CAMLprim value unix_setsockopt_float(value socket, value option, value status)
-{
- return setsockopt_float(sockopt_float, socket, SOL_SOCKET, option, status);
-}
-
-#else
-
-CAMLprim value unix_getsockopt_bool(value socket, value option)
-{ invalid_argument("getsockopt not implemented"); }
-
-CAMLprim value unix_setsockopt_bool(value socket, value option, value status)
-{ invalid_argument("setsockopt not implemented"); }
-
-CAMLprim value unix_getsockopt_int(value socket, value option)
-{ invalid_argument("getsockopt_int not implemented"); }
-
-CAMLprim value unix_setsockopt_int(value socket, value option, value status)
-{ invalid_argument("setsockopt_int not implemented"); }
-
-CAMLprim value unix_getsockopt_optint(value socket, value option)
-{ invalid_argument("getsockopt_optint not implemented"); }
-
-CAMLprim value unix_setsockopt_optint(value socket, value option, value status)
-{ invalid_argument("setsockopt_optint not implemented"); }
-
-CAMLprim value unix_getsockopt_float(value socket, value option)
-{ invalid_argument("getsockopt_float not implemented"); }
-
-CAMLprim value unix_setsockopt_float(value socket, value option, value status)
-{ invalid_argument("setsockopt_float not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/stat.c b/otherlibs/unix/stat.c
deleted file mode 100644
index 92a752f5e7..0000000000
--- a/otherlibs/unix/stat.c
+++ /dev/null
@@ -1,140 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <errno.h>
-#include <mlvalues.h>
-#include <memory.h>
-#include <alloc.h>
-#include "unixsupport.h"
-#include "cst2constr.h"
-#include <sys/types.h>
-#include <sys/stat.h>
-#include <io.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);
-
- atime = copy_double((double) buf->st_atime);
- mtime = copy_double((double) buf->st_mtime);
- ctime = copy_double((double) buf->st_ctime);
- offset = use_64 ? Val_file_offset(buf->st_size) : Val_int (buf->st_size);
- v = 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)
-{
- int ret;
- struct stat buf;
- ret = stat(String_val(path), &buf);
- if (ret == -1) uerror("stat", path);
- if (buf.st_size > Max_long && (buf.st_mode & S_IFMT) == S_IFREG)
- unix_error(EOVERFLOW, "stat", path);
- return stat_aux(0, &buf);
-}
-
-CAMLprim value unix_lstat(value path)
-{
- int ret;
- struct stat buf;
-#ifdef HAS_SYMLINK
- ret = lstat(String_val(path), &buf);
-#else
- ret = stat(String_val(path), &buf);
-#endif
- if (ret == -1) uerror("lstat", path);
- if (buf.st_size > Max_long && (buf.st_mode & S_IFMT) == S_IFREG)
- unix_error(EOVERFLOW, "lstat", path);
- return stat_aux(0, &buf);
-}
-
-CAMLprim value unix_fstat(value fd)
-{
- int ret;
- struct stat buf;
- ret = fstat(Int_val(fd), &buf);
- 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)
-{
- int ret;
- struct stat buf;
- ret = stat(String_val(path), &buf);
- if (ret == -1) uerror("stat", path);
- return stat_aux(1, &buf);
-}
-
-CAMLprim value unix_lstat_64(value path)
-{
- int ret;
- struct stat buf;
-#ifdef HAS_SYMLINK
- ret = lstat(String_val(path), &buf);
-#else
- ret = stat(String_val(path), &buf);
-#endif
- if (ret == -1) uerror("lstat", path);
- return stat_aux(1, &buf);
-}
-
-CAMLprim value unix_fstat_64(value fd)
-{
- int ret;
- struct stat buf;
- ret = fstat(Int_val(fd), &buf);
- if (ret == -1) uerror("fstat", Nothing);
- return stat_aux(1, &buf);
-}
-
diff --git a/otherlibs/unix/strofaddr.c b/otherlibs/unix/strofaddr.c
deleted file mode 100644
index f5a594d52c..0000000000
--- a/otherlibs/unix/strofaddr.c
+++ /dev/null
@@ -1,36 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.h>
-#include "unixsupport.h"
-
-#ifdef HAS_SOCKETS
-
-#include "socketaddr.h"
-
-CAMLprim value unix_string_of_inet_addr(value a)
-{
- struct in_addr address;
- address.s_addr = GET_INET_ADDR(a);
- return copy_string(inet_ntoa(address));
-}
-
-#else
-
-CAMLprim value unix_string_of_inet_addr(value a)
-{ invalid_argument("string_of_inet_addr not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/symlink.c b/otherlibs/unix/symlink.c
deleted file mode 100644
index 8c011152b3..0000000000
--- a/otherlibs/unix/symlink.c
+++ /dev/null
@@ -1,33 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-#ifdef HAS_SYMLINK
-
-CAMLprim value unix_symlink(value path1, value path2)
-{
- if (symlink(String_val(path1), String_val(path2)) == -1)
- uerror("symlink", path2);
- return Val_unit;
-}
-
-#else
-
-CAMLprim value unix_symlink(value path1, value path2)
-{ invalid_argument("symlink not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/termios.c b/otherlibs/unix/termios.c
deleted file mode 100644
index e3c759444d..0000000000
--- a/otherlibs/unix/termios.c
+++ /dev/null
@@ -1,316 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.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
-
-struct speedtable_entry ;
-
-static struct {
- speed_t speed;
- int baud;
-} speedtable[] = {
- {B50, 50},
- {B75, 75},
- {B110, 110},
- {B134, 134},
- {B150, 150},
- {B300, 300},
- {B600, 600},
- {B1200, 1200},
- {B1800, 1800},
- {B2400, 2400},
- {B4800, 4800},
- {B9600, 9600},
- {B19200, 19200},
- {B38400, 38400},
-#ifdef B57600
- {B57600, 57600},
-#endif
-#ifdef B115200
- {B115200, 115200},
-#endif
-#ifdef B230400
- {B230400, 230400},
-#endif
- {B0, 0}
-};
-
-#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 = 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;
-}
-
-CAMLprim value unix_tcdrain(value fd)
-{
- if (tcdrain(Int_val(fd)) == -1) uerror("tcdrain", Nothing);
- return Val_unit;
-}
-
-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)
-{ invalid_argument("tcgetattr not implemented"); }
-
-CAMLprim value unix_tcsetattr(value fd, value when, value arg)
-{ invalid_argument("tcsetattr not implemented"); }
-
-CAMLprim value unix_tcsendbreak(value fd, value delay)
-{ invalid_argument("tcsendbreak not implemented"); }
-
-CAMLprim value unix_tcdrain(value fd)
-{ invalid_argument("tcdrain not implemented"); }
-
-CAMLprim value unix_tcflush(value fd, value queue)
-{ invalid_argument("tcflush not implemented"); }
-
-CAMLprim value unix_tcflow(value fd, value action)
-{ invalid_argument("tcflow not implemented"); }
-
-#endif
-
diff --git a/otherlibs/unix/time.c b/otherlibs/unix/time.c
deleted file mode 100644
index c63c2eb804..0000000000
--- a/otherlibs/unix/time.c
+++ /dev/null
@@ -1,24 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <time.h>
-#include <mlvalues.h>
-#include <alloc.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_time(void)
-{
- return copy_double((double) time((time_t *) NULL));
-}
diff --git a/otherlibs/unix/times.c b/otherlibs/unix/times.c
deleted file mode 100644
index c108cbfde3..0000000000
--- a/otherlibs/unix/times.c
+++ /dev/null
@@ -1,44 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.h>
-#include <memory.h>
-#include "unixsupport.h"
-#include <time.h>
-#include <sys/types.h>
-#include <sys/times.h>
-
-#ifndef CLK_TCK
-#ifdef HZ
-#define CLK_TCK HZ
-#else
-#define CLK_TCK 60
-#endif
-#endif
-
-CAMLprim value unix_times(void)
-{
- value res;
- struct tms buffer;
-
- times(&buffer);
- res = 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;
-}
diff --git a/otherlibs/unix/truncate.c b/otherlibs/unix/truncate.c
deleted file mode 100644
index 009d3c0e55..0000000000
--- a/otherlibs/unix/truncate.c
+++ /dev/null
@@ -1,45 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <sys/types.h>
-#include <mlvalues.h>
-#include <io.h>
-#include "unixsupport.h"
-#ifdef HAS_UNISTD
-#include <unistd.h>
-#endif
-
-#ifdef HAS_TRUNCATE
-
-CAMLprim value unix_truncate(value path, value len)
-{
- if (truncate(String_val(path), Long_val(len)) == -1)
- uerror("truncate", path);
- return Val_unit;
-}
-
-CAMLprim value unix_truncate_64(value path, value len)
-{
- if (truncate(String_val(path), File_offset_val(len)) == -1)
- uerror("truncate", path);
- return Val_unit;
-}
-
-#else
-
-CAMLprim value unix_truncate(value path, value len)
-{ invalid_argument("truncate not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/umask.c b/otherlibs/unix/umask.c
deleted file mode 100644
index 6f5d14fd0c..0000000000
--- a/otherlibs/unix/umask.c
+++ /dev/null
@@ -1,24 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <sys/types.h>
-#include <sys/stat.h>
-#include <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
deleted file mode 100644
index daa24e61ec..0000000000
--- a/otherlibs/unix/unix.ml
+++ /dev/null
@@ -1,776 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-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 = "sys_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
-
-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 -> string -> int -> int -> int = "unix_read"
-external unsafe_write : file_descr -> string -> int -> int -> int = "unix_write"
-
-let read fd buf ofs len =
- if ofs < 0 || len < 0 || ofs > String.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 > String.length buf - len
- then invalid_arg "Unix.write"
- else unsafe_write fd buf ofs len
-
-external in_channel_of_descr : file_descr -> in_channel
- = "caml_open_descriptor_in"
-external out_channel_of_descr : file_descr -> out_channel
- = "caml_open_descriptor_out"
-external descr_of_in_channel : in_channel -> file_descr = "channel_descriptor"
-external descr_of_out_channel : out_channel -> file_descr
- = "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 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 : file_descr -> file_descr = "unix_dup"
-external dup2 : 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 : unit -> file_descr * file_descr = "unix_pipe"
-external symlink : string -> string -> unit = "unix_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 sleep : int -> unit = "unix_sleep"
-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"
-
-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
-
-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"
-
-type socket_domain =
- PF_UNIX
- | PF_INET
-
-type socket_type =
- SOCK_STREAM
- | SOCK_DGRAM
- | SOCK_RAW
- | SOCK_SEQPACKET
-
-type sockaddr =
- ADDR_UNIX of string
- | ADDR_INET of inet_addr * int
-
-type shutdown_command =
- SHUTDOWN_RECEIVE
- | SHUTDOWN_SEND
- | SHUTDOWN_ALL
-
-type msg_flag =
- MSG_OOB
- | MSG_DONTROUTE
- | MSG_PEEK
-
-type socket_bool_option =
- SO_DEBUG
- | SO_BROADCAST
- | SO_REUSEADDR
- | SO_KEEPALIVE
- | SO_DONTROUTE
- | SO_OOBINLINE
- | SO_ACCEPTCONN
-
-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
-
-external socket : socket_domain -> socket_type -> int -> file_descr
- = "unix_socket"
-external socketpair :
- socket_domain -> socket_type -> int -> file_descr * file_descr
- = "unix_socketpair"
-external accept : 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 -> string -> int -> int -> msg_flag list -> int
- = "unix_recv"
-external unsafe_recvfrom :
- file_descr -> string -> int -> int -> msg_flag list -> int * sockaddr
- = "unix_recvfrom"
-external unsafe_send :
- file_descr -> string -> int -> int -> msg_flag list -> int
- = "unix_send"
-external unsafe_sendto :
- file_descr -> string -> 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 > String.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 > String.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 > String.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 > String.length buf - len
- then invalid_arg "Unix.sendto"
- else unsafe_sendto fd buf ofs len flags addr
-
-external getsockopt : file_descr -> socket_bool_option -> bool
- = "unix_getsockopt_bool"
-external setsockopt : file_descr -> socket_bool_option -> bool -> unit
- = "unix_setsockopt_bool"
-external getsockopt_int : file_descr -> socket_int_option -> int
- = "unix_getsockopt_int"
-external setsockopt_int : file_descr -> socket_int_option -> int -> unit
- = "unix_setsockopt_int"
-external getsockopt_optint : file_descr -> socket_optint_option -> int option
- = "unix_getsockopt_optint"
-external setsockopt_optint : file_descr -> socket_optint_option -> int option -> unit
- = "unix_setsockopt_optint"
-external getsockopt_float : file_descr -> socket_float_option -> float
- = "unix_getsockopt_float"
-external setsockopt_float : file_descr -> socket_float_option -> float -> unit
- = "unix_setsockopt_float"
-
-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 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 system cmd =
- match fork() with
- 0 -> begin try
- execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]
- with _ ->
- exit 127
- end
- | id -> snd(waitpid [] id)
-
-let rec safe_dup fd =
- let new_fd = dup fd in
- if new_fd >= 3 then
- new_fd
- else begin
- let res = safe_dup fd in
- close new_fd;
- res
- end
-
-let safe_close fd =
- try close fd with Unix_error(_,_,_) -> ()
-
-let perform_redirections new_stdin new_stdout new_stderr =
- let newnewstdin = safe_dup new_stdin in
- let newnewstdout = safe_dup new_stdout in
- let newnewstderr = safe_dup new_stderr in
- safe_close new_stdin;
- safe_close new_stdout;
- safe_close new_stderr;
- dup2 newnewstdin stdin; close newnewstdin;
- dup2 newnewstdout stdout; close newnewstdout;
- dup2 newnewstderr stderr; close newnewstderr
-
-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 proc input output toclose =
- match fork() with
- 0 -> if input <> stdin then begin dup2 input stdin; close input end;
- if output <> stdout then begin dup2 output stdout; close output end;
- List.iter close toclose;
- execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |];
- exit 127
- | id -> Hashtbl.add popen_processes proc id
-
-let open_process_in cmd =
- let (in_read, in_write) = pipe() in
- let inchan = in_channel_of_descr in_read in
- open_proc cmd (Process_in inchan) stdin in_write [in_read];
- close in_write;
- inchan
-
-let open_process_out cmd =
- let (out_read, out_write) = pipe() in
- let outchan = out_channel_of_descr out_write in
- open_proc cmd (Process_out outchan) out_read stdout [out_write];
- close out_read;
- outchan
-
-let open_process cmd =
- let (in_read, in_write) = pipe() in
- let (out_read, out_write) = pipe() in
- let inchan = in_channel_of_descr in_read in
- let outchan = out_channel_of_descr out_write in
- open_proc cmd (Process(inchan, outchan)) out_read in_write
- [in_read; out_write];
- close out_read;
- close in_write;
- (inchan, outchan)
-
-let open_proc_full cmd env proc input output error toclose =
- match fork() with
- 0 -> dup2 input stdin; close input;
- dup2 output stdout; close output;
- dup2 error stderr; close error;
- List.iter close toclose;
- execve "/bin/sh" [| "/bin/sh"; "-c"; cmd |] env;
- exit 127
- | id -> Hashtbl.add popen_processes proc id
-
-let open_process_full cmd env =
- let (in_read, in_write) = pipe() in
- let (out_read, out_write) = pipe() in
- let (err_read, err_write) = pipe() 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
- open_proc_full cmd env (Process_full(inchan, outchan, errchan))
- out_read in_write err_write [in_read; out_write; err_read];
- 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;
- begin try close_out outchan with Sys_error _ -> () end;
- 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;
- begin try close_out outchan with Sys_error _ -> () end;
- close_in errchan;
- snd(waitpid [] pid)
-
-(* High-level network functions *)
-
-let open_connection sockaddr =
- let domain =
- match sockaddr with ADDR_UNIX _ -> PF_UNIX | ADDR_INET(_,_) -> PF_INET in
- let sock =
- socket domain SOCK_STREAM 0 in
- 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 =
- let domain =
- match sockaddr with ADDR_UNIX _ -> PF_UNIX | ADDR_INET(_,_) -> PF_INET in
- let sock =
- socket domain SOCK_STREAM 0 in
- setsockopt sock SO_REUSEADDR true;
- bind sock sockaddr;
- listen sock 5;
- while true do
- let (s, caller) = accept 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 *)
- let inchan = in_channel_of_descr s in
- let outchan = out_channel_of_descr s in
- server_fun inchan outchan;
- close_out outchan;
- (* The file descriptor was already closed by close_out.
- close_in inchan;
- *)
- exit 0
- | id -> close s; ignore(waitpid [] id) (* Reclaim the son *)
- done
-
diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli
deleted file mode 100644
index 4328fed5a9..0000000000
--- a/otherlibs/unix/unix.mli
+++ /dev/null
@@ -1,1206 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Interface to the Unix system *)
-
-
-(** {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. Raise [Not_found] if the variable is unbound.
- (This function is identical to [Sys.getenv].) *)
-
-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. *)
-
-
-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 -> unit
-(** [execv prog args] execute the program in file [prog], with
- the arguments [args], and the current process environment. *)
-
-val execve : string -> string array -> string array -> unit
-(** Same as {!Unix.execv}, except that the third argument provides the
- environment to the program executed. *)
-
-val execvp : string -> string array -> unit
-(** Same as {!Unix.execv} respectively, except that
- the program is searched in the path. *)
-
-val execvpe : string -> string array -> string array -> unit
-(** Same as {!Unix.execvp} respectively, 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 : wait_flag list -> int -> int * process_status
-(** Same as {!Unix.wait}, but waits for the 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
-(** 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 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) *)
-(** The flags to {!Unix.openfile}. *)
-
-
-type file_perm = int
-(** The type of file access rights. *)
-
-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. Return
- a file descriptor on the named file. *)
-
-val close : file_descr -> unit
-(** Close a file descriptor. *)
-
-val read : file_descr -> string -> int -> int -> int
-(** [read fd buff ofs len] reads [len] characters from descriptor
- [fd], storing them in string [buff], starting at position [ofs]
- in string [buff]. Return the number of characters actually read. *)
-
-val write : file_descr -> string -> int -> int -> int
-(** [write fd buff ofs len] writes [len] characters to descriptor
- [fd], taking them from string [buff], starting at position [ofs]
- in string [buff]. Return the number of characters actually
- written. *)
-
-
-
-(** {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 =
- 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 *)
-
-val truncate : string -> int -> unit
-(** Truncates the named file to the given size. *)
-
-val ftruncate : file_descr -> int -> unit
-(** Truncates the file corresponding to the given descriptor
- to the given size. *)
-
-
-(** {6 File statistics} *)
-
-
-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 informations returned by the {!Unix.stat} calls. *)
-
-val stat : string -> stats
-(** Return the informations for the named file. *)
-
-val lstat : string -> stats
-(** Same as {!Unix.stat}, but in case the file is a symbolic link,
- return the informations for the link itself. *)
-
-val fstat : file_descr -> stats
-(** Return the informations for the file associated with the given
- descriptor. *)
-
-
-(** {6 File operations on large files} *)
-
-module LargeFile :
- sig
- val lseek : file_descr -> int64 -> seek_command -> int64
- val truncate : string -> int64 -> unit
- val ftruncate : file_descr -> int64 -> unit
- 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 *)
-
-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. *)
-
-val chown : string -> int -> int -> unit
-(** Change the owner uid and owner gid of the named file. *)
-
-val fchown : file_descr -> int -> 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 -> 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 : file_descr -> file_descr
-(** Return a new file descriptor referencing the same file as
- the given descriptor. *)
-
-val dup2 : file_descr -> 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 {!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] functions. *)
-
-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. *)
-
-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
-(** 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 : 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 -> file_perm -> unit
-(** Create a named pipe with the given permissions. *)
-
-
-(** {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] (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 : string -> string -> unit
-(** [symlink source dest] creates the file [dest] as a symbolic link
- to the file [source]. *)
-
-val readlink : string -> string
-(** Read the contents of a 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 (set with [F_LOCK] or [F_TLOCK]) prevents any other
- process from acquiring a read or write lock on the region.
- A read lock (set with [F_RLOCK] or [F_TRLOCK]) prevents any other
- process from acquiring a write lock on the region, but lets
- other processes acquire read locks on it. *)
-
-
-(** {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]. *)
-
-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. *)
-
-val sigpending : unit -> int list
-(** Return the set of blocked signals that are currently pending. *)
-
-val sigsuspend : int list -> unit
-(** [sigsuspend sigs] atomically sets the blocked signals to [sig]
- 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 =
- { 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..59 *)
- 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. *)
-
-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. *)
-
-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. *)
-
-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 -> 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. *)
-
-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. *)
-
-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. *)
-
-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, 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
-(** The abstract type of Internet addresses. *)
-
-val inet_addr_of_string : string -> inet_addr
-(** Conversions between string with the format [XXX.YYY.ZZZ.TTT]
- and Internet addresses. [inet_addr_of_string] raises [Failure]
- when given a string that does not match this format. *)
-
-val string_of_inet_addr : inet_addr -> string
-(** See {!Unix.inet_addr_of_string}. *)
-
-val inet_addr_any : inet_addr
-(** A special Internet address, for use only with [bind], representing
- all the Internet addresses that the host machine possesses. *)
-
-
-(** {6 Sockets} *)
-
-
-type socket_domain =
- PF_UNIX (** Unix domain *)
- | PF_INET (** Internet domain *)
-(** The type of socket domains. *)
-
-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. *)
-
-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 : 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. *)
-
-val socketpair :
- socket_domain -> socket_type -> int -> file_descr * file_descr
-(** Create a pair of unnamed sockets, connected together. *)
-
-val accept : 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 -> 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 -> string -> int -> int -> msg_flag list -> int
-(** Receive data from a connected socket. *)
-
-val recvfrom :
- file_descr -> string -> int -> int -> msg_flag list -> int * sockaddr
-(** Receive data from an unconnected socket. *)
-
-val send : file_descr -> string -> int -> int -> msg_flag list -> int
-(** Send data over a connected socket. *)
-
-val sendto :
- file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int
-(** Send data over an unconnected socket. *)
-
-
-
-(** {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 *)
-(** 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 (** Report the error status and clear it *)
- | 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. *)
-
-external getsockopt_int :
- file_descr -> socket_int_option -> int = "unix_getsockopt_int"
-(** Same as {!Unix.getsockopt} for an integer-valued socket option. *)
-
-external setsockopt_int :
- file_descr -> socket_int_option -> int -> unit = "unix_setsockopt_int"
-(** Same as {!Unix.setsockopt} for an integer-valued socket option. *)
-
-external getsockopt_optint :
- file_descr -> socket_optint_option -> int option = "unix_getsockopt_optint"
-(** Same as {!Unix.getsockopt} for a socket option whose value is an [int option]. *)
-
-external setsockopt_optint :
- file_descr -> socket_optint_option -> int option ->
- unit = "unix_setsockopt_optint"
-(** Same as {!Unix.setsockopt} for a socket option whose value is an [int option]. *)
-
-external getsockopt_float :
- file_descr -> socket_float_option -> float = "unix_getsockopt_float"
-(** Same as {!Unix.getsockopt} for a socket option whose value is a floating-point number. *)
-
-external setsockopt_float :
- file_descr -> socket_float_option -> float -> unit = "unix_setsockopt_float"
-(** Same as {!Unix.setsockopt} for a socket option whose value is a floating-point number. *)
-
-(** {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. *)
-
-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. *)
-
-
-(** {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, 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 -> string -> service_entry
-(** Find an entry in [services] with the given name, or raise
- [Not_found]. *)
-
-val getservbyport : int -> string -> service_entry
-(** Find an entry in [services] with the given service number,
- or raise [Not_found]. *)
-
-
-
-(** {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. *)
-
-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. *)
-
-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). *)
-
-val tcdrain : file_descr -> unit
-(** Waits until all output written on the given file descriptor
- has been transmitted. *)
-
-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. *)
-
-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. *)
-
-val setsid : unit -> int
-(** Put the calling process in a new session and detach it from
- its controlling terminal. *)
diff --git a/otherlibs/unix/unixLabels.ml b/otherlibs/unix/unixLabels.ml
deleted file mode 100644
index 683f15ec67..0000000000
--- a/otherlibs/unix/unixLabels.ml
+++ /dev/null
@@ -1,18 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* 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 Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Module [UnixLabels]: labelled Unix module *)
-
-include Unix
diff --git a/otherlibs/unix/unixLabels.mli b/otherlibs/unix/unixLabels.mli
deleted file mode 100644
index 536df710c7..0000000000
--- a/otherlibs/unix/unixLabels.mli
+++ /dev/null
@@ -1,1242 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** 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, mostly 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 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. *)
-
-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 -> unit
-(** [execv prog args] execute the program in file [prog], with
- the arguments [args], and the current process environment. *)
-
-val execve : prog:string -> args:string array -> env:string array -> unit
-(** Same as {!UnixLabels.execv}, except that the third argument provides the
- environment to the program executed. *)
-
-val execvp : prog:string -> args:string array -> unit
-(** Same as {!UnixLabels.execv} respectively, except that
- the program is searched in the path. *)
-
-val execvpe : prog:string -> args:string array -> env:string array -> unit
-(** Same as {!UnixLabels.execvp} respectively, 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 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 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) *)
-(** The flags to {!UnixLabels.openfile}. *)
-
-
-type file_perm = int
-(** The type of file access rights. *)
-
-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:string -> pos:int -> len:int -> int
-(** [read fd buff ofs len] reads [len] characters from descriptor
- [fd], storing them in string [buff], starting at position [ofs]
- in string [buff]. Return the number of characters actually read. *)
-
-val write : file_descr -> buf:string -> pos:int -> len:int -> int
-(** [write fd buff ofs len] writes [len] characters to descriptor
- [fd], taking them from string [buff], starting at position [ofs]
- in string [buff]. Return the number of characters actually
- written. *)
-
-
-(** {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 *)
-
-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 statistics} *)
-
-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 informations 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. *)
-
-(** {6 Seeking, truncating and statistics 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
-(** 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 [new]. *)
-
-
-
-(** {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 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 : file_descr -> file_descr
-(** Return a new file descriptor referencing the same file as
- the given descriptor. *)
-
-val dup2 : 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 : 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.
- All file descriptors of the current process are closed in the
- new process, except those redirected to standard input and
- outputs. *)
-
-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. These functions
- (with {!UnixLabels.open_process_out} and {!UnixLabels.open_process})
- run the given command in parallel with the program,
- and return channels connected to the standard input and/or
- the standard output of the command. The command is interpreted
- by the shell [/bin/sh] (cf. [system]). Warning: writes on channels
- are buffered, hence be careful to call {!Pervasives.flush} at the right times
- to ensure correct synchronization. *)
-
-val open_process_out : string -> out_channel
-(** See {!UnixLabels.open_process_in}. *)
-
-val open_process : string -> in_channel * out_channel
-(** See {!UnixLabels.open_process_in}. *)
-
-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 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 : src:string -> dst:string -> unit
-(** [symlink source dest] creates the file [dest] as a symbolic link
- to the file [source]. *)
-
-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 (set with [F_LOCK] or [F_TLOCK]) prevents any other
- process from acquiring a read or write lock on the region.
- A read lock (set with [F_RLOCK] or [F_TRLOCK]) prevents any other
- process from acquiring a write lock on the region, but lets
- other processes acquire read locks on it. *)
-
-
-(** {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 [sig]
- 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..59 *)
- 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 Greenwich meridian time zone, also known as UTC. *)
-
-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}. Also return a normalized
- copy of the given [tm] record, with the [tm_wday], [tm_yday],
- and [tm_isdst] fields recomputed from the other fields.
- The [tm] argument is interpreted in the local time zone. *)
-
-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. *)
-
-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. *)
-
-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
-(** Conversions between string with the format [XXX.YYY.ZZZ.TTT]
- and Internet addresses. [inet_addr_of_string] raises [Failure]
- when given a string that does not match this format. *)
-
-val string_of_inet_addr : inet_addr -> string
-(** See {!UnixLabels.inet_addr_of_string}. *)
-
-val inet_addr_any : inet_addr
-(** A special Internet address, for use only with [bind], representing
- all the Internet addresses that the host machine possesses. *)
-
-
-(** {6 Sockets} *)
-
-
-type socket_domain =
- Unix.socket_domain =
- PF_UNIX (** Unix domain *)
- | PF_INET (** Internet domain *)
-(** The type of socket domains. *)
-
-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 :
- 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 socketpair :
- domain:socket_domain -> kind:socket_type -> protocol:int ->
- file_descr * file_descr
-(** Create a pair of unnamed sockets, connected together. *)
-
-val accept : 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:string -> pos:int -> len:int -> mode:msg_flag list -> int
-(** Receive data from an unconnected socket. *)
-
-val recvfrom :
- file_descr -> buf:string -> pos:int -> len:int -> mode:msg_flag list ->
- int * sockaddr
-(** Receive data from an unconnected socket. *)
-
-val send :
- file_descr -> buf:string -> pos:int -> len:int -> mode:msg_flag list -> int
-(** Send data over an unconnected socket. *)
-
-val sendto :
- file_descr -> buf:string -> pos:int -> len:int -> mode:msg_flag list ->
- addr:sockaddr -> int
-(** Send data over an unconnected socket. *)
-
-
-(** {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 *)
-(** 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 (** Report the error status and clear it *)
- | 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 {!UnixLabels.getsockopt_optint}
- and modified with {!UnixLabels.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. *)
-
-external getsockopt_int :
- file_descr -> socket_int_option -> int = "unix_getsockopt_int"
-(** Same as {!UnixLabels.getsockopt} for an integer-valued socket option. *)
-
-external setsockopt_int :
- file_descr -> socket_int_option -> int -> unit = "unix_setsockopt_int"
-(** Same as {!UnixLabels.setsockopt} for an integer-valued socket option. *)
-
-external getsockopt_optint :
- file_descr -> socket_optint_option -> int option = "unix_getsockopt_optint"
-(** Same as {!UnixLabels.getsockopt} for a socket option whose value is an [int option]. *)
-
-external setsockopt_optint :
- file_descr -> socket_optint_option -> int option ->
- unit = "unix_setsockopt_optint"
-(** Same as {!UnixLabels.setsockopt} for a socket option whose value is an [int option]. *)
-
-external getsockopt_float :
- file_descr -> socket_float_option -> float = "unix_getsockopt_float"
-(** Same as {!UnixLabels.getsockopt} for a socket option whose value is a floating-point number. *)
-
-external setsockopt_float :
- file_descr -> socket_float_option -> float -> unit = "unix_setsockopt_float"
-(** Same as {!UnixLabels.setsockopt} for a socket option whose value is a floating-point number. *)
-
-
-(** {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]. *)
-
-
-
-(** {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
deleted file mode 100644
index 2a723924c2..0000000000
--- a/otherlibs/unix/unixsupport.c
+++ /dev/null
@@ -1,285 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.h>
-#include <callback.h>
-#include <memory.h>
-#include <fail.h>
-#include "unixsupport.h"
-#include "cst2constr.h"
-#include <errno.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
-#define EOPNOTSUPP (-1)
-#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;
-
-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 ? copy_string("") : cmdarg;
- name = copy_string(cmdname);
- errconstr =
- cst_to_constr(errcode, error_table, sizeof(error_table)/sizeof(int), -1);
- if (errconstr == Val_int(-1)) {
- err = alloc_small(1, 0);
- Field(err, 0) = Val_int(errcode);
- } else {
- err = errconstr;
- }
- if (unix_error_exn == NULL) {
- unix_error_exn = caml_named_value("Unix.Unix_error");
- if (unix_error_exn == NULL)
- invalid_argument("Exception Unix.Unix_error not initialized, please link unix.cma");
- }
- res = alloc_small(4, 0);
- Field(res, 0) = *unix_error_exn;
- Field(res, 1) = err;
- Field(res, 2) = name;
- Field(res, 3) = arg;
- End_roots();
- mlraise(res);
-}
-
-void uerror(char *cmdname, value cmdarg)
-{
- unix_error(errno, cmdname, cmdarg);
-}
-
diff --git a/otherlibs/unix/unixsupport.h b/otherlibs/unix/unixsupport.h
deleted file mode 100644
index defd8e6922..0000000000
--- a/otherlibs/unix/unixsupport.h
+++ /dev/null
@@ -1,25 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#ifdef HAS_UNISTD
-#include <unistd.h>
-#endif
-
-#define Nothing ((value) 0)
-
-extern void unix_error (int errcode, char * cmdname, value arg) Noreturn;
-extern void uerror (char * cmdname, value arg) Noreturn;
-
-#define UNIX_BUFFER_SIZE 16384
diff --git a/otherlibs/unix/unlink.c b/otherlibs/unix/unlink.c
deleted file mode 100644
index 1d956758b3..0000000000
--- a/otherlibs/unix/unlink.c
+++ /dev/null
@@ -1,23 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_unlink(value path)
-{
- if (unlink(String_val(path)) == -1) uerror("unlink", path);
- return Val_unit;
-}
diff --git a/otherlibs/unix/utimes.c b/otherlibs/unix/utimes.c
deleted file mode 100644
index 51d34350cf..0000000000
--- a/otherlibs/unix/utimes.c
+++ /dev/null
@@ -1,71 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-#ifdef 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)
-{
- struct utimbuf times, * t;
- times.actime = Double_val(atime);
- times.modtime = Double_val(mtime);
- if (times.actime || times.modtime)
- t = &times;
- else
- t = (struct utimbuf *) NULL;
- if (utime(String_val(path), t) == -1) uerror("utimes", path);
- return Val_unit;
-}
-
-#else
-
-#ifdef HAS_UTIMES
-
-#include <sys/types.h>
-#include <sys/time.h>
-
-CAMLprim value unix_utimes(value path, value atime, value mtime)
-{
- struct timeval tv[2], * t;
- double at = Double_val(atime);
- double mt = Double_val(mtime);
- 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;
- if (tv[0].tv_sec || tv[1].tv_sec)
- t = tv;
- else
- t = (struct timeval *) NULL;
- if (utimes(String_val(path), t) == -1) uerror("utimes", path);
- return Val_unit;
-}
-
-#else
-
-CAMLprim value unix_utimes(value path, value atime, value mtime)
-{ invalid_argument("utimes not implemented"); }
-
-#endif
-#endif
diff --git a/otherlibs/unix/wait.c b/otherlibs/unix/wait.c
deleted file mode 100644
index b660a75e44..0000000000
--- a/otherlibs/unix/wait.c
+++ /dev/null
@@ -1,101 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.h>
-#include <memory.h>
-#include <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 = alloc_small(1, TAG_WEXITED);
- Field(st, 0) = Val_int(WEXITSTATUS(status));
- }
- else if (WIFSTOPPED(status)) {
- st = alloc_small(1, TAG_WSTOPPED);
- Field(st, 0) = Val_int(WSTOPSIG(status));
- }
- else {
- st = alloc_small(1, TAG_WSIGNALED);
- Field(st, 0) = Val_int(WTERMSIG(status));
- }
- Begin_root (st);
- res = alloc_small(2, 0);
- Field(res, 0) = Val_int(pid);
- Field(res, 1) = st;
- End_roots();
- return res;
-}
-
-CAMLprim value unix_wait(void)
-{
- int pid, status;
-
- enter_blocking_section();
- pid = wait(&status);
- 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;
-
- enter_blocking_section();
- pid = waitpid(Int_val(pid_req), &status,
- convert_flag_list(flags, wait_flag_table));
- 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)
-{ invalid_argument("waitpid not implemented"); }
-
-#endif
diff --git a/otherlibs/unix/write.c b/otherlibs/unix/write.c
deleted file mode 100644
index 0e02437b8c..0000000000
--- a/otherlibs/unix/write.c
+++ /dev/null
@@ -1,56 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <errno.h>
-#include <string.h>
-#include <mlvalues.h>
-#include <memory.h>
-#include <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);
- enter_blocking_section();
- ret = write(Int_val(fd), iobuf, numbytes);
- 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);
-}
diff --git a/otherlibs/win32graph/Makefile.nt b/otherlibs/win32graph/Makefile.nt
deleted file mode 100644
index 1274182614..0000000000
--- a/otherlibs/win32graph/Makefile.nt
+++ /dev/null
@@ -1,94 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 2001 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-include ../../config/Makefile
-
-# Compilation options
-CC=$(BYTECC)
-CFLAGS=-I../../byterun
-CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib
-CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib
-COMPFLAGS=-warn-error A
-
-COBJS=open.$(O) draw.$(O) dib.$(O)
-CAMLOBJS=graphics.cmo
-WIN32LIBS=$(call SYSLIB,kernel32) $(call SYSLIB,gdi32) $(call SYSLIB,user32)
-
-all: dllgraphics.dll libgraphics.$(A) graphics.cma
-
-allopt: libgraphics.$(A) graphics.cmxa
-
-dllgraphics.dll: $(COBJS:.$(O)=.$(DO))
- $(call MKDLL,dllgraphics.dll,tmp.$(A),\
- $(COBJS:.$(O)=.$(DO)) ../../byterun/ocamlrun.$(A) $(WIN32LIBS))
- rm tmp.*
-
-libgraphics.$(A): $(COBJS:.$(O)=.$(SO))
- $(call MKLIB,libgraphics.$(A),$(COBJS:.$(O)=.$(SO)))
-
-graphics.cma: $(CAMLOBJS)
- $(CAMLC) -a -o graphics.cma $(CAMLOBJS) \
- -dllib -lgraphics -cclib -lgraphics -cclib "$(WIN32LIBS)"
-
-graphics.cmxa: $(CAMLOBJS:.cmo=.cmx)
- $(CAMLOPT) -a -o graphics.cmxa $(CAMLOBJS:.cmo=.cmx) \
- -cclib -lgraphics -cclib "$(WIN32LIBS)"
-
-partialclean:
- rm -f *.cm*
-
-clean: partialclean
- rm -f *.$(A) *.dll *.exp *.$(O)
- rm -f graphics.ml graphics.mli
- rm -f io.h
-
-install:
- cp dllgraphics.dll $(STUBLIBDIR)/dllgraphics.dll
- cp libgraphics.$(A) $(LIBDIR)/libgraphics.$(A)
- cp graphics.cmi graphics.cma $(LIBDIR)
-
-installopt:
- cp graphics.cmxa graphics.cmx graphics.$(A) $(LIBDIR)
-
-graphics.ml: ../graph/graphics.ml
- cp ../graph/graphics.ml graphics.ml
-graphics.mli: ../graph/graphics.mli
- cp ../graph/graphics.mli graphics.mli
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx .$(DO) .$(SO)
-
-.mli.cmi:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-.c.$(DO):
- $(BYTECC) $(DLLCCCOMPOPTS) $(CFLAGS) -c $<
- mv $*.$(O) $*.$(DO)
-
-.c.$(SO):
- $(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c $<
- mv $*.$(O) $*.$(SO)
-
-depend:
-
-graphics.cmo: graphics.cmi
-graphics.cmx: graphics.cmi
-draw.$(SO) draw.$(DO): libgraph.h
-open.$(SO) open.$(DO): libgraph.h
diff --git a/otherlibs/win32graph/dib.c b/otherlibs/win32graph/dib.c
deleted file mode 100644
index d881a02819..0000000000
--- a/otherlibs/win32graph/dib.c
+++ /dev/null
@@ -1,496 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Developed by Jacob Navia */
-/* Copyright 2001 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-//-----------------------------------------------------------------------------
-// DIB.C
-//
-// This is a collection of useful DIB manipulation/information gathering
-// functions. Many functions are supplied simply to take the burden
-// of taking into account whether a DIB is a Win30 style or OS/2 style
-// DIB away from the application.
-//
-// The functions in this module assume that the DIB pointers or handles
-// passed to them point to a block of memory in one of two formats:
-//
-// a) BITMAPINFOHEADER + color table + DIB bits (3.0 style DIB)
-// b) BITMAPCOREHEADER + color table + DIB bits (OS/2 PM style)
-//
-// The SDK Reference, Volume 2 describes these data structures.
-//
-// A number of functions in this module were lifted from SHOWDIB,
-// and modified to handle OS/2 DIBs.
-//
-// The functions in this module could be streamlined (made faster and
-// smaller) by removing the OS/2 DIB specific code, and assuming all
-// DIBs passed to it are Win30 style DIBs. The DIB file reading code
-// would need to be modified to always convert DIBs to Win30 style
-// DIBs. The only reason this isn't done in DIBView is because DIBView
-// was written to test display and printer drivers (which are supposed
-// to support OS/2 DIBs wherever they support Win30 style DIBs). SHOWDIB
-// is a great example of how to go about doing this.
-//-----------------------------------------------------------------------------
-
-
-#include <windows.h>
-#include <memory.h>
-#include <string.h>
-#include <io.h>
-#include <stdio.h>
- // Size of window extra bytes (we store a handle to a PALINFO structure).
-
-#define PAL_CBWNDEXTRA (1 * sizeof (WORD))
-
-
-typedef struct
- {
- HPALETTE hPal; // Handle to palette being displayed.
- WORD wEntries; // # of entries in the palette.
- int nSquareSize; // Size of palette square (see PAL_SIZE)
- HWND hInfoWnd; // Handle to the info bar window.
- int nRows, nCols; // # of Rows/Columns in window.
- int cxSquare, cySquare; // Pixel width/height of palette square.
- WORD wEntry; // Currently selected palette square.
- } PALINFO, FAR *LPPALINFO;
- // Window Words.
-#define WW_PAL_HPALINFO 0 // Handle to PALINFO structure.
- // The following define is for CopyPaletteChangingFlags().
-#define DONT_CHANGE_FLAGS -1
- // The following is the palette version that goes in a
- // LOGPALETTE's palVersion field.
-#define PALVERSION 0x300
-// This is an enumeration for the various ways we can display
-// a palette in PaletteWndProc().
-enum PAL_SIZE
- {
- PALSIZE_TINY = 0,
- PALSIZE_SMALL,
- PALSIZE_MEDIUM,
- PALSIZE_LARGE
- };
-#define CopyPalette(hPal) CopyPaletteChangingFlags (hPal, DONT_CHANGE_FLAGS)
-#define CopyPalForAnimation(hPal) CopyPaletteChangingFlags (hPal, PC_RESERVED)
-// WIDTHBYTES takes # of bits in a scan line and rounds up to nearest
-// word.
-#define WIDTHBYTES(bits) (((bits) + 31) / 32 * 4)
-
- // Given a pointer to a DIB header, return TRUE if is a Windows 3.0 style
- // DIB, false if otherwise (PM style DIB).
-#define IS_WIN30_DIB(lpbi) ((*(LPDWORD) (lpbi)) == sizeof (BITMAPINFOHEADER))
-
-static WORD PaletteSize (LPSTR lpbi);
-
-extern void ShowDbgMsg(char *);
-static BOOL MyRead (int, LPSTR, DWORD);
-/*-------------- DIB header Marker Define -------------------------*/
-#define DIB_HEADER_MARKER ((WORD) ('M' << 8) | 'B')
-/*-------------- MyRead Function Define ---------------------------*/
-
-// When we read in a DIB, we read it in in chunks. We read half a segment
-// at a time. This way we insure that we don't cross any segment
-// boundries in _lread() during a read. We don't read in a full segment
-// at a time, since _lread takes some "int" type parms instead of
-// WORD type params (it'd work, but the compiler would give you warnings)...
-
-#define BYTES_PER_READ 32767
-
-/*-------------- Define for PM DIB -------------------------------*/
-// The constants for RGB, RLE4, RLE8 are already defined inside
-// of Windows.h
-
-#define BI_PM 3L
-
-
-/*-------------- Magic numbers -------------------------------------*/
-// Maximum length of a filename for DOS is 128 characters.
-
-#define MAX_FILENAME 129
-
-
-/*-------------- TypeDef Structures -------------------------------*/
-
-typedef struct InfoStruct
- {
- char szName[13];
- char szType[15];
- DWORD cbWidth;
- DWORD cbHeight;
- DWORD cbColors;
- char szCompress[5];
- } INFOSTRUCT;
-
-// Some macros.
-#define RECTWIDTH(lpRect) ((lpRect)->right - (lpRect)->left)
-#define RECTHEIGHT(lpRect) ((lpRect)->bottom - (lpRect)->top)
-//---------------------------------------------------------------------
-//
-// Function: FindDIBBits
-//
-// Purpose: Given a pointer to a DIB, returns a pointer to the
-// DIB's bitmap bits.
-//
-// Parms: lpbi == pointer to DIB header (either BITMAPINFOHEADER
-// or BITMAPCOREHEADER)
-//
-// History: Date Reason
-// 6/01/91 Created
-//
-//---------------------------------------------------------------------
-static LPSTR FindDIBBits (LPSTR lpbi)
-{
- return (lpbi + *(LPDWORD)lpbi + PaletteSize (lpbi));
-}
-
-
-//---------------------------------------------------------------------
-//
-// Function: DIBNumColors
-//
-// Purpose: Given a pointer to a DIB, returns a number of colors in
-// the DIB's color table.
-//
-// Parms: lpbi == pointer to DIB header (either BITMAPINFOHEADER
-// or BITMAPCOREHEADER)
-//
-// History: Date Reason
-// 6/01/91 Created
-//
-//---------------------------------------------------------------------
-static WORD DIBNumColors (LPSTR lpbi)
-{
- WORD wBitCount;
-
-
- // If this is a Windows style DIB, the number of colors in the
- // color table can be less than the number of bits per pixel
- // allows for (i.e. lpbi->biClrUsed can be set to some value).
- // If this is the case, return the appropriate value.
-
- if (IS_WIN30_DIB (lpbi))
- {
- DWORD dwClrUsed;
-
- dwClrUsed = ((LPBITMAPINFOHEADER) lpbi)->biClrUsed;
-
- if (dwClrUsed)
- return (WORD) dwClrUsed;
- }
-
-
- // Calculate the number of colors in the color table based on
- // the number of bits per pixel for the DIB.
-
- if (IS_WIN30_DIB (lpbi))
- wBitCount = ((LPBITMAPINFOHEADER) lpbi)->biBitCount;
- else
- wBitCount = ((LPBITMAPCOREHEADER) lpbi)->bcBitCount;
-
- switch (wBitCount)
- {
- case 1:
- return 2;
-
- case 4:
- return 16;
-
- case 8:
- return 256;
-
- default:
- return 0;
- }
-}
-
-//---------------------------------------------------------------------
-//
-// Function: PaletteSize
-//
-// Purpose: Given a pointer to a DIB, returns number of bytes
-// in the DIB's color table.
-//
-// Parms: lpbi == pointer to DIB header (either BITMAPINFOHEADER
-// or BITMAPCOREHEADER)
-//
-// History: Date Reason
-// 6/01/91 Created
-//
-//---------------------------------------------------------------------
-static WORD PaletteSize (LPSTR lpbi)
-{
- if (IS_WIN30_DIB (lpbi))
- return (DIBNumColors (lpbi) * sizeof (RGBQUAD));
- else
- return (DIBNumColors (lpbi) * sizeof (RGBTRIPLE));
-}
-
-//---------------------------------------------------------------------
-//
-// Function: DIBHeight
-//
-// Purpose: Given a pointer to a DIB, returns its height. Note
-// that it returns a DWORD (since a Win30 DIB can have
-// a DWORD in its height field), but under Win30, the
-// high order word isn't used!
-//
-// Parms: lpDIB == pointer to DIB header (either BITMAPINFOHEADER
-// or BITMAPCOREHEADER)
-//
-// History: Date Reason
-// 6/01/91 Created
-//
-//---------------------------------------------------------------------
-static DWORD DIBHeight (LPSTR lpDIB)
-{
- LPBITMAPINFOHEADER lpbmi;
- LPBITMAPCOREHEADER lpbmc;
-
- lpbmi = (LPBITMAPINFOHEADER) lpDIB;
- lpbmc = (LPBITMAPCOREHEADER) lpDIB;
-
- if (lpbmi->biSize == sizeof (BITMAPINFOHEADER))
- return lpbmi->biHeight;
- else
- return (DWORD) lpbmc->bcHeight;
-}
-
-/*************************************************************************
-
- Function: ReadDIBFile (int)
-
- Purpose: Reads in the specified DIB file into a global chunk of
- memory.
-
- Returns: A handle to a dib (hDIB) if successful.
- NULL if an error occurs.
-
- Comments: BITMAPFILEHEADER is stripped off of the DIB. Everything
- from the end of the BITMAPFILEHEADER structure on is
- returned in the global memory handle.
-
- History: Date Author Reason
-
- 6/1/91 Created
- 6/27/91 Removed PM bitmap conversion routines.
- 6/31/91 Removed logic which overallocated memory
- (to account for bad display drivers).
- 11/08/91 Again removed logic which overallocated
- memory (it had creeped back in!)
-
-*************************************************************************/
-static HANDLE ReadDIBFile (int hFile,int dwBitsSize)
-{
- BITMAPFILEHEADER bmfHeader;
- HANDLE hDIB;
- LPSTR pDIB;
-
-
-
- // Go read the DIB file header and check if it's valid.
-
- if ((_lread (hFile, (LPSTR) &bmfHeader, sizeof (bmfHeader)) != sizeof (bmfHeader)) ||
- (bmfHeader.bfType != DIB_HEADER_MARKER))
- {
- // ShowDbgMsg("Not a DIB file!");
- return NULL;
- }
-
- // Allocate memory for DIB
-
- hDIB = GlobalAlloc (GMEM_SHARE|GMEM_MOVEABLE | GMEM_ZEROINIT, dwBitsSize - sizeof(BITMAPFILEHEADER));
-
- if (hDIB == 0)
- {
- // ShowDbgMsg("Couldn't allocate memory!");
- return NULL;
- }
-
- pDIB = GlobalLock (hDIB);
-
- // Go read the bits.
-
- if (!MyRead (hFile, pDIB, dwBitsSize - sizeof(BITMAPFILEHEADER)))
- {
- GlobalUnlock (hDIB);
- GlobalFree (hDIB);
- // ShowDbgMsg("Error reading file!");
- return NULL;
- }
-
-
- GlobalUnlock (hDIB);
- return hDIB;
-}
-
-/*************************************************************************
-
- Function: MyRead (int, LPSTR, DWORD)
-
- Purpose: Routine to read files greater than 64K in size.
-
- Returns: TRUE if successful.
- FALSE if an error occurs.
-
- Comments:
-
- History: Date Reason
-
- 6/1/91 Created
-
-*************************************************************************/
-static BOOL MyRead (int hFile, LPSTR lpBuffer, DWORD dwSize)
-{
- char *lpInBuf = (char *) lpBuffer;
- int nBytes;
-
-
- while (dwSize)
- {
- nBytes = (int) (dwSize > (DWORD) BYTES_PER_READ ? BYTES_PER_READ :
- LOWORD (dwSize));
-
- if (_lread (hFile, (LPSTR) lpInBuf, nBytes) != (WORD) nBytes)
- return FALSE;
-
- dwSize -= nBytes;
- lpInBuf += nBytes;
- }
-
- return TRUE;
-}
-
-//---------------------------------------------------------------------
-//
-// Function: DIBPaint
-//
-// Purpose: Painting routine for a DIB. Calls StretchDIBits() or
-// SetDIBitsToDevice() to paint the DIB. The DIB is
-// output to the specified DC, at the coordinates given
-// in lpDCRect. The area of the DIB to be output is
-// given by lpDIBRect. The specified palette is used.
-//
-// Parms: hDC == DC to do output to.
-// lpDCRect == Rectangle on DC to do output to.
-// hDIB == Handle to global memory with a DIB spec
-// in it (either a BITMAPINFO or BITMAPCOREINFO
-// followed by the DIB bits).
-// lpDIBRect == Rect of DIB to output into lpDCRect.
-// hPal == Palette to be used.
-//
-// History: Date Reason
-// 6/01/91 Created
-//
-//---------------------------------------------------------------------
-static void DIBPaint (HDC hDC,LPRECT lpDCRect,HANDLE hDIB)
-{
- LPSTR lpDIBHdr, lpDIBBits;
-
- if (!hDIB)
- return;
- // Lock down the DIB, and get a pointer to the beginning of the bit
- // buffer.
- lpDIBHdr = GlobalLock (hDIB);
- lpDIBBits = FindDIBBits (lpDIBHdr);
- // Make sure to use the stretching mode best for color pictures.
- SetStretchBltMode (hDC, COLORONCOLOR);
- SetDIBitsToDevice (hDC, // hDC
- lpDCRect->left, // DestX
- lpDCRect->top, // DestY
- RECTWIDTH (lpDCRect), // nDestWidth
- RECTHEIGHT (lpDCRect), // nDestHeight
- 0, // SrcX
- 0,
- // (int) DIBHeight (lpDIBHdr), // SrcY
- 0, // nStartScan
- (WORD) DIBHeight (lpDIBHdr), // nNumScans
- lpDIBBits, // lpBits
- (LPBITMAPINFO) lpDIBHdr, // lpBitsInfo
- DIB_RGB_COLORS); // wUsage
-
- GlobalUnlock (hDIB);
-}
-
-static unsigned int Getfilesize(char *name)
-{
- FILE *f;
- unsigned int size;
-
- f = fopen(name,"rb");
- if (f == NULL)
- return 0;
- fseek(f,0,SEEK_END);
- size = ftell(f);
- fclose(f);
- return size;
-}
-
-
-HANDLE ChargerBitmap(char *FileName,POINT *lppt)
-{
- HFILE hFile;
- OFSTRUCT ofstruct;
- HANDLE result;
- LPSTR lpDIBHdr;
- unsigned int size;
-
- size = Getfilesize(FileName);
- hFile=OpenFile((LPSTR) FileName, &ofstruct, OF_READ | OF_SHARE_DENY_WRITE);
- result = ReadDIBFile(hFile,size);
- if (hFile) _lclose(hFile);
- if (result) {
- LPBITMAPINFOHEADER lpbmi;
- LPBITMAPCOREHEADER lpbmc;
-
- lpDIBHdr = GlobalLock (result);
- lpbmi = (LPBITMAPINFOHEADER) lpDIBHdr;
- lpbmc = (LPBITMAPCOREHEADER) lpDIBHdr;
-
- if (lpbmi->biSize == sizeof (BITMAPINFOHEADER)) {
- lppt->y = lpbmi->biHeight;
- lppt->x = lpbmi->biWidth;
- }
- else {
- lppt->y = lpbmc->bcHeight;
- lppt->x = lpbmc->bcWidth;
- }
- GlobalUnlock(result);
- }
- return(result);
-}
-
-void DessinerBitmap(HANDLE hDIB,HDC hDC,LPRECT lpDCRect)
-{
- DIBPaint (hDC,
- lpDCRect,
- hDIB);
-}
-
-void AfficheBitmap(char *filename,HDC hDC,int x,int y)
-{
- RECT rc;
- HANDLE hdib;
- POINT pt;
- char titi[60];
-
- hdib = ChargerBitmap(filename,&pt);
- if (hdib == NULL) {
- return;
- }
- rc.top = y;
- rc.left = x;
- rc.right = pt.x+x;
- rc.bottom = pt.y+y;
- pt.y += GetSystemMetrics(SM_CYCAPTION);
- DessinerBitmap(hdib,hDC,&rc);
- GlobalFree(hdib);
-}
-
diff --git a/otherlibs/win32graph/draw.c b/otherlibs/win32graph/draw.c
deleted file mode 100644
index 31166d8136..0000000000
--- a/otherlibs/win32graph/draw.c
+++ /dev/null
@@ -1,784 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <math.h>
-#include "mlvalues.h"
-#include "alloc.h"
-#include "libgraph.h"
-#include "custom.h"
-#include "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 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 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 gr_current_x(void)
-{
- return Val_int(grwindow.grx);
-}
-
-CAMLprim value gr_current_y(void)
-{
- return Val_int(grwindow.gry);
-}
-
-CAMLprim value 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 gr_draw_rect(value vx, value vy, value vw, value vh)
-{
-#if 0
- int x = Int_val(vx);
- int y = Int_val(vy);
- int w = Int_val(vw);
- int h = Int_val(vh);
-
- gr_check_open();
- if(grdisplay_mode) {
- Rectangle(grwindow.gc,x, Wcvt(y) , x+w, Wcvt(y+h));
- }
- if(grremember_mode) {
- Rectangle(grwindow.gcBitmap,x, Wcvt(y), x+w, Wcvt(h+y));
- }
- return Val_unit;
-#else
- int x, y, w, h;
- POINT pt[5];
- x=Int_val(vx);
- y=Int_val(vy);
- w=Int_val(vw);
- h=Int_val(vh);
-
- pt[0].x = x;
- pt[0].y = Wcvt(y-1);
- pt[1].x = x+w;
- pt[1].y = pt[0].y;
- pt[2].x = pt[1].x;
- pt[2].y = Wcvt(y+h-1);
- pt[3].x = pt[0].x;
- pt[3].y = pt[2].y;
- pt[4].x = pt[0].x;
- pt[4].y = pt[0].y;
- if (grremember_mode) {
- Polyline(grwindow.gcBitmap,pt, 5);
- }
- if (grdisplay_mode) {
- Polyline(grwindow.gc,pt, 5);
- }
- return Val_unit;
-#endif
-}
-
-CAMLprim value 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 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 gr_sound(value freq, value vdur)
-{
- Beep(freq,vdur);
- return Val_unit;
-}
-
-CAMLprim value 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 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 gr_set_window_title(value text)
-{
- SetWindowText(grwindow.hwnd,(char *)text);
- return Val_unit;
-}
-
-CAMLprim value gr_draw_arc(value *argv, int argc)
-{
- return gr_draw_or_fill_arc(argv[0], argv[1], argv[2], argv[3],
- argv[4], argv[5], FALSE);
-}
-
-CAMLprim value gr_draw_arc_nat(vx, vy, vrx, vry, vstart, vend)
-{
- return gr_draw_or_fill_arc(vx, vy, vrx, vry, vstart, vend, FALSE);
-}
-
-CAMLprim value 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 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))
- 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 gr_show_bitmap(value filename,int x,int y)
-{
- AfficheBitmap(filename,grwindow.gcBitmap,x,Wcvt(y));
- AfficheBitmap(filename,grwindow.gc,x,Wcvt(y));
- return Val_unit;
-}
-
-
-
-CAMLprim value gr_get_mousex(void)
-{
- POINT pt;
- GetCursorPos(&pt);
- MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1);
- return pt.x;
-}
-
-CAMLprim value gr_get_mousey(void)
-{
- 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 gr_set_font(value fontname)
-{
- gr_check_open();
- gr_font(String_val(fontname));
- return Val_unit;
-}
-
-CAMLprim value gr_set_text_size (value sz)
-{
- return Val_unit;
-}
-
-CAMLprim value gr_draw_char(value chr)
-{
- char str[1];
- gr_check_open();
- str[0] = Int_val(chr);
- gr_draw_text((value)str, 1);
- return Val_unit;
-}
-
-CAMLprim value gr_draw_string(value str)
-{
- gr_check_open();
- gr_draw_text(str, string_length(str));
- return Val_unit;
-}
-
-CAMLprim value gr_text_size(value str)
-{
- SIZE extent;
- value res;
-
- mlsize_t len = string_length(str);
- if (len > 32767) len = 32767;
-
- GetTextExtentPoint(grwindow.gc,String_val(str), len,&extent);
-
- res = alloc_tuple(2);
- Field(res, 0) = Val_long(extent.cx);
- Field(res, 1) = Val_long(extent.cy);
-
- return res;
-}
-
-#if 0
-static unsigned char gr_queue[SIZE_QUEUE];
-static int gr_head = 0; /* position of next read */
-static int gr_tail = 0; /* position of next write */
-
-#define QueueIsEmpty (gr_head == gr_tail)
-#define QueueIsFull (gr_head == gr_tail + 1)
-
-void gr_enqueue_char(unsigned char c)
-{
- if (QueueIsFull) return;
- gr_queue[gr_tail] = c;
- gr_tail++;
- if (gr_tail >= SIZE_QUEUE) gr_tail = 0;
-}
-#endif
-
-#define Button_down 1
-#define Button_up 2
-#define Key_pressed 4
-#define Mouse_motion 8
-#define Poll 16
-MSG * InspectMessages = NULL;
-
-CAMLprim value gr_wait_event(value eventlist)
-{
- value res;
- int mask;
- BOOL poll;
- int mouse_x, mouse_y, button, key;
- int root_x, root_y, win_x, win_y;
- int r,i,stop;
- unsigned int modifiers;
- POINT pt;
- MSG msg;
-
- gr_check_open();
- mask = 0;
- poll = FALSE;
- while (eventlist != Val_int(0)) {
- switch (Int_val(Field(eventlist,0))) {
- case 0: /* Button_down */
- mask |= Button_down;
- break;
- case 1: /* Button_up */
- mask |= Button_up;
- break;
- case 2: /* Key_pressed */
- mask |= Key_pressed;
- break;
- case 3: /* Mouse_motion */
- mask |= Mouse_motion;
- break;
- case 4: /* Poll */
- poll = TRUE;
- break;
- }
- eventlist = Field(eventlist,1);
- }
- mouse_x = -1;
- mouse_y = -1;
- button = 0;
- key = -1;
-
- if (poll) {
- // Poll uses info on last event stored in global variables
- mouse_x = MouseLastX;
- mouse_y = MouseLastY;
- button = MouseLbuttonDown | MouseMbuttonDown | MouseRbuttonDown;
- key = LastKey;
- }
- else { // Not polled. Block for a message
- InspectMessages = &msg;
- do {
- WaitForSingleObject(EventHandle,INFINITE);
- stop = 0;
- switch (msg.message) {
- case WM_LBUTTONDOWN:
- case WM_MBUTTONDOWN:
- case WM_RBUTTONDOWN:
- button = 1;
- if (mask&Button_down) stop = 1;
- break;
- case WM_LBUTTONUP:
- case WM_MBUTTONUP:
- case WM_RBUTTONUP:
- button = 0;
- if (mask&Button_up) stop = 1;
- break;
- case WM_MOUSEMOVE:
- if (mask&Mouse_motion) stop = 1;
- break;
- case WM_CHAR:
- key = msg.wParam & 0xFF;
- if (mask&Key_pressed) stop = 1;
- break;
- case WM_CLOSE:
- stop = 1;
- break;
- }
- if (stop) {
- pt = msg.pt;
- MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1);
- mouse_x = pt.x;
- mouse_y = grwindow.height- 1 - pt.y;
- }
- SetEvent(EventProcessedHandle);
- } while (! stop);
- InspectMessages = NULL;
- }
- res = alloc_small(5, 0);
- Field(res, 0) = Val_int(mouse_x);
- Field(res, 1) = Val_int(mouse_y);
- Field(res, 2) = Val_bool(button);
- Field(res, 3) = Val_bool(key != -1);
- Field(res, 4) = Val_int(key & 0xFF);
- return res;
-}
-
-CAMLprim value gr_fill_poly(value vect)
-{
- 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 gr_fill_arc(value *argv, int argc)
-{
- return gr_draw_or_fill_arc(argv[0], argv[1], argv[2], argv[3],
- argv[4], argv[5], TRUE);
-}
-
-CAMLprim value gr_fill_arc_nat(vx, vy, vrx, vry, vstart, vend)
-{
- 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 53000000
-
-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
-};
-
-CAMLprim value 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);
- res = 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 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 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 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 = 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 = alloc(size, 0);
- }
- else {
- res = alloc_shr(size, 0);
- }
- for (i = 0; i < size; i++) {
- Field(res, i) = Val_long(0);
- }
- return res;
-}
-
-CAMLprim value 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++) {
- 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/libgraph.h b/otherlibs/win32graph/libgraph.h
deleted file mode 100644
index 305270a41a..0000000000
--- a/otherlibs/win32graph/libgraph.h
+++ /dev/null
@@ -1,86 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Jacob Navia, after Xavier Leroy */
-/* */
-/* Copyright 2001 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#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 "Caml graphics"
-#define ICON_NAME "Caml graphics"
-#define DEFAULT_EVENT_MASK \
- (ExposureMask | KeyPressMask | StructureNotifyMask)
-#define DEFAULT_FONT "fixed"
-#define SIZE_QUEUE 256
-
-void gr_fail(char *fmt, char *arg);
-void gr_check_open(void);
-CAMLprim value gr_set_color(value vcolor);
-
-// 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 int MouseLbuttonDown,MouseMbuttonDown,MouseRbuttonDown;
-extern HANDLE EventHandle, EventProcessedHandle;
-extern MSG * InspectMessages;
-extern int MouseLbuttonDown,MouseMbuttonDown,MouseRbuttonDown;
-extern int MouseLastX, MouseLastY;
-extern int LastKey;
-
diff --git a/otherlibs/win32graph/open.c b/otherlibs/win32graph/open.c
deleted file mode 100644
index b400862319..0000000000
--- a/otherlibs/win32graph/open.c
+++ /dev/null
@@ -1,400 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <fcntl.h>
-#include <signal.h>
-#include "mlvalues.h"
-#include "libgraph.h"
-#include <windows.h>
-static value gr_reset(void);
-int MouseLbuttonDown,MouseMbuttonDown,MouseRbuttonDown;
-int MouseLastX, MouseLastY;
-int LastKey = -1;
-static long tid;
-static HANDLE threadHandle;
-HWND grdisplay = NULL;
-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;
-
-HANDLE EventHandle, EventProcessedHandle;
-static char *szOcamlWindowClass = "OcamlWindowClass";
-static BOOL gr_initialized = 0;
-CAMLprim value gr_clear_graph(void);
-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);
- strcpy(CurrentFont.lfFaceName, name); /* Courier */
- 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)
-{
- DeleteObject(grwindow.hBitmap);
- memset(&grwindow,0,sizeof(grwindow));
-}
-
-
-
-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;
- case WM_LBUTTONDOWN:
- MouseLbuttonDown = 1;
- break;
- case WM_LBUTTONUP:
- MouseLbuttonDown = 0;
- break;
- case WM_RBUTTONDOWN:
- MouseRbuttonDown = 1;
- break;
- case WM_RBUTTONUP:
- MouseRbuttonDown = 0;
- break;
- case WM_MBUTTONDOWN:
- MouseMbuttonDown = 1;
- break;
- case WM_MBUTTONUP:
- MouseMbuttonDown = 0;
- break;
- case WM_CHAR:
- LastKey = wParam & 0xFF;
- break;
- case WM_KEYUP:
- LastKey = -1;
- break;
- case WM_MOUSEMOVE:
-#if 0
- pt.x = GET_X_LPARAM(lParam);
- pt.y = GET_Y_LPARAM(lParam);
- MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1);
- MouseLastX = pt.x;
- MouseLastY = grwindow.height - 1 - pt.y;
-#else
- MouseLastX = GET_X_LPARAM(lParam);
- MouseLastY = grwindow.height - 1 - GET_Y_LPARAM(lParam);
-#endif
- break;
- }
- return DefWindowProc(hwnd,msg,wParam,lParam);
-}
-
-int DoRegisterClass(void)
-{
- WNDCLASS wc;
-
- memset(&wc,0,sizeof(WNDCLASS));
- wc.style = CS_HREDRAW|CS_VREDRAW |CS_DBLCLKS|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);
- 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;
-
- EventHandle = CreateEvent(NULL,0,0,NULL);
- EventProcessedHandle = CreateEvent(NULL,0,0,NULL);
-
- /* The global data structures are now correctly initialized.
- Restart the Caml main thread. */
- open_graph_errmsg = NULL;
- SetEvent(open_graph_event);
-
- /* Enter the message handling loop */
- while (GetMessage(&msg,NULL,0,0)) {
- if (InspectMessages != NULL) {
- *InspectMessages = msg;
- SetEvent(EventHandle);
- }
- TranslateMessage(&msg); // Translates virtual key codes
- DispatchMessage(&msg); // Dispatches message to window
- if (!IsWindow(grwindow.hwnd))
- break;
- if (InspectMessages != NULL) {
- WaitForSingleObject(EventProcessedHandle,INFINITE);
- }
- }
- return 0;
-}
-
-CAMLprim value gr_open_graph(value arg)
-{
- long 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 gr_close_graph(void)
-{
- if (gr_initialized) {
- DeleteDC(grwindow.tempDC);
- DeleteDC(grwindow.gcBitmap);
- DestroyWindow(grwindow.hwnd);
- memset(&grwindow,0,sizeof(grwindow));
- gr_initialized = 0;
- }
- return Val_unit;
-}
-
-CAMLprim value gr_clear_graph(void)
-{
- 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 gr_size_x(void)
-{
- gr_check_open();
- return Val_int(grwindow.width);
-}
-
-CAMLprim value gr_size_y(void)
-{
- gr_check_open();
- return Val_int(grwindow.height);
-}
-
-CAMLprim value gr_synchronize(void)
-{
- gr_check_open();
- BitBlt(grwindow.gc,0,0,grwindow.width,grwindow.height,
- grwindow.gcBitmap,0,0,SRCCOPY);
- return Val_unit ;
-}
-
-CAMLprim value gr_display_mode(value flag)
-{
- grdisplay_mode = (Int_val(flag)) ? 1 : 0;
- return Val_unit ;
-}
-
-CAMLprim value gr_remember_mode(value flag)
-{
- grremember_mode = (Int_val(flag)) ? 1 : 0;
- return Val_unit ;
-}
-
-CAMLprim value gr_sigio_signal(value unit)
-{
- return Val_unit;
-}
-
-CAMLprim value gr_sigio_handler(void)
-{
- return Val_unit;
-}
-
-
-/* Processing of graphic errors */
-
-value * caml_named_value (char * name);
-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)
- invalid_argument("Exception Graphics.Graphic_failure not initialized, must link graphics.cma");
- }
- sprintf(buffer, fmt, arg);
- 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/.cvsignore b/otherlibs/win32unix/.cvsignore
deleted file mode 100644
index 9aaa7161dd..0000000000
--- a/otherlibs/win32unix/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-unixLabels.ml*
-unix.mli
-unix.lib \ No newline at end of file
diff --git a/otherlibs/win32unix/.depend b/otherlibs/win32unix/.depend
deleted file mode 100644
index 6e1130b18a..0000000000
--- a/otherlibs/win32unix/.depend
+++ /dev/null
@@ -1,5 +0,0 @@
-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.nt b/otherlibs/win32unix/Makefile.nt
deleted file mode 100644
index b873b16dda..0000000000
--- a/otherlibs/win32unix/Makefile.nt
+++ /dev/null
@@ -1,120 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-include ../../config/Makefile
-
-# Compilation options
-CC=$(BYTECC)
-CFLAGS=-I../../byterun -I../unix
-CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib
-CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib
-COMPFLAGS=-warn-error A
-
-# 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 rename.c \
- select.c sendrecv.c \
- shutdown.c sleep.c socket.c sockopt.c startup.c stat.c \
- system.c unixsupport.c windir.c winwait.c write.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 getcwd.c gethost.c gethostname.c getproto.c \
- getserv.c gmtime.c putenv.c rmdir.c \
- socketaddr.c strofaddr.c time.c unlink.c utimes.c
-
-ALL_FILES=$(WIN_FILES) $(UNIX_FILES)
-
-DOBJS=$(ALL_FILES:.c=.$(DO))
-SOBJS=$(ALL_FILES:.c=.$(SO))
-
-LIBS=$(call SYSLIB,wsock32)
-
-CAML_OBJS=unix.cmo unixLabels.cmo
-CAMLOPT_OBJS=$(CAML_OBJS:.cmo=.cmx)
-
-UNIX_CAML_FILES = unix.mli unixLabels.mli unixLabels.ml
-
-all: dllunix.dll libunix.$(A) unix.cma
-
-allopt: libunix.$(A) unix.cmxa
-
-dllunix.dll: $(DOBJS)
- $(call MKDLL,dllunix.dll,tmp.$(A),$(DOBJS) ../../byterun/ocamlrun.$(A) $(LIBS))
- rm tmp.*
-
-libunix.$(A): $(SOBJS)
- $(call MKLIB,libunix.$(A),$(SOBJS))
-
-$(DOBJS) $(SOBJS): unixsupport.h
-
-unix.cma: $(CAML_OBJS)
- $(CAMLC) -a -linkall -o unix.cma $(CAML_OBJS) \
- -dllib -lunix -cclib -lunix -cclib $(LIBS)
-
-unix.cmxa: $(CAMLOPT_OBJS)
- $(CAMLOPT) -a -linkall -o unix.cmxa $(CAMLOPT_OBJS) \
- -cclib -lunix -cclib $(LIBS)
-
-partialclean:
- rm -f *.cm*
-
-clean: partialclean
- rm -f *.$(A) *.dll *.$(O)
- rm -f $(UNIX_FILES) $(UNIX_CAML_FILES)
-
-install:
- cp dllunix.dll $(STUBLIBDIR)/dllunix.dll
- cp libunix.$(A) $(LIBDIR)/libunix.$(A)
- cp $(CAML_OBJS:.cmo=.cmi) unix.cma $(LIBDIR)
-
-installopt:
- cp unix.cmxa $(CAML_OBJS:.cmo=.cmx) unix.$(A) $(LIBDIR)
-
-unixLabels.cmo: unixLabels.ml
- $(CAMLC) -c $(COMPFLAGS) -nolabels unixLabels.ml
-
-unixLabels.cmx: unixLabels.ml
- $(CAMLOPT) -c $(COMPFLAGS) -nolabels unixLabels.ml
-
-$(UNIX_FILES) $(UNIX_CAML_FILES): %: ../unix/%
- cp ../unix/$* $*
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx .$(DO) .$(SO)
-
-.mli.cmi:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-.c.$(DO):
- $(BYTECC) $(DLLCCCOMPOPTS) $(CFLAGS) -c $<
- mv $*.$(O) $*.$(DO)
-
-.c.$(SO):
- $(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c $<
- mv $*.$(O) $*.$(SO)
-
-depend:
-
-include .depend
diff --git a/otherlibs/win32unix/accept.c b/otherlibs/win32unix/accept.c
deleted file mode 100644
index ec7068bd3c..0000000000
--- a/otherlibs/win32unix/accept.c
+++ /dev/null
@@ -1,67 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.h>
-#include <memory.h>
-#include <signals.h>
-#include "unixsupport.h"
-#include "socketaddr.h"
-
-CAMLprim value unix_accept(sock)
- value sock;
-{
- SOCKET sconn = Socket_val(sock);
- SOCKET snew;
- value fd = Val_unit, adr = Val_unit, res;
- int oldvalue, oldvaluelen, newvalue, retcode;
- union sock_addr_union addr;
- socklen_param_type addr_len;
- int errcode = 0;
-
- oldvaluelen = sizeof(oldvalue);
- retcode = getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
- (char *) &oldvalue, &oldvaluelen);
- if (retcode == 0) {
- /* Set sockets to synchronous mode */
- newvalue = SO_SYNCHRONOUS_NONALERT;
- setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
- (char *) &newvalue, sizeof(newvalue));
- }
- addr_len = sizeof(sock_addr);
- enter_blocking_section();
- snew = accept(sconn, &addr.s_gen, &addr_len);
- leave_blocking_section();
- if( snew == INVALID_SOCKET )
- errcode = WSAGetLastError ();
- if (retcode == 0) {
- /* Restore initial mode */
- setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
- (char *) &oldvalue, oldvaluelen);
- }
- if (snew == INVALID_SOCKET) {
- win32_maperr(errcode);
- uerror("accept", Nothing);
- }
- Begin_roots2 (fd, adr)
- fd = win_alloc_socket(snew);
- adr = alloc_sockaddr(&addr, addr_len);
- res = 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
deleted file mode 100644
index 0a17c8d513..0000000000
--- a/otherlibs/win32unix/bind.c
+++ /dev/null
@@ -1,34 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <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
deleted file mode 100644
index 176aab9f5c..0000000000
--- a/otherlibs/win32unix/channels.c
+++ /dev/null
@@ -1,43 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.h>
-#include "unixsupport.h"
-#include <fcntl.h>
-
-extern long _get_osfhandle(int);
-extern int _open_osfhandle(long, int);
-
-CAMLprim value win_fd_handle(value handle)
-{
- int fd;
- if (CRT_fd_val(handle) != NO_CRT_FD) {
- fd = CRT_fd_val(handle);
- } else {
- fd = _open_osfhandle((long) Handle_val(handle), O_BINARY);
- if (fd == -1) uerror("channel_of_descr", Nothing);
- CRT_fd_val(handle) = fd;
- }
- return Val_int(fd);
-}
-
-CAMLprim value win_handle_fd(value vfd)
-{
- int crt_fd = Int_val(vfd);
- value res = win_alloc_handle_or_socket((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
deleted file mode 100644
index 48cd60e7aa..0000000000
--- a/otherlibs/win32unix/close.c
+++ /dev/null
@@ -1,33 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.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 (! 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
deleted file mode 100644
index 5b2c4ece32..0000000000
--- a/otherlibs/win32unix/close_on.c
+++ /dev/null
@@ -1,46 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <windows.h>
-#include "unixsupport.h"
-
-int win_set_inherit(value fd, BOOL inherit)
-{
- HANDLE oldh, newh;
-
- oldh = Handle_val(fd);
- if (! DuplicateHandle(GetCurrentProcess(), oldh,
- GetCurrentProcess(), &newh,
- 0L, inherit, DUPLICATE_SAME_ACCESS)) {
- win32_maperr(GetLastError());
- return -1;
- }
- Handle_val(fd) = newh;
- CloseHandle(oldh);
- 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
deleted file mode 100644
index 74e62252d8..0000000000
--- a/otherlibs/win32unix/connect.c
+++ /dev/null
@@ -1,38 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <signals.h>
-#include "unixsupport.h"
-#include "socketaddr.h"
-
-CAMLprim value unix_connect(socket, address)
- value socket, address;
-{
- SOCKET s = Socket_val(socket);
- int retcode;
- union sock_addr_union addr;
- socklen_param_type addr_len;
-
- get_sockaddr(address, &addr, &addr_len);
- enter_blocking_section();
- retcode = connect(s, &addr.s_gen, addr_len);
- leave_blocking_section();
- if (retcode == -1) {
- win32_maperr(WSAGetLastError());
- uerror("connect", Nothing);
- }
- return Val_unit;
-}
diff --git a/otherlibs/win32unix/createprocess.c b/otherlibs/win32unix/createprocess.c
deleted file mode 100644
index 8a92d18f03..0000000000
--- a/otherlibs/win32unix/createprocess.c
+++ /dev/null
@@ -1,87 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <windows.h>
-#include <mlvalues.h>
-#include <osdeps.h>
-#include "unixsupport.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;
- int flags;
-
- exefile = 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 */
- GetStartupInfo(&si);
- si.dwFlags |= STARTF_USESTDHANDLES;
- si.hStdInput = Handle_val(fd1);
- si.hStdOutput = Handle_val(fd2);
- si.hStdError = Handle_val(fd3);
- /* If we do not have a console window, then we must create one
- before running the process (keep it hidden for apparence).
- Also one must suppress spurious flags in si.dwFlags.
- Otherwise the redirections are ignored.
- 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)) {
- win32_maperr(GetLastError());
- uerror("create_process", cmd);
- }
- CloseHandle(pi.hThread);
- /* Return the process handle as pseudo-PID
- (this is consistent with the wait() emulation in the MSVC C library */
- return Val_int(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;
- }
-}
diff --git a/otherlibs/win32unix/dup.c b/otherlibs/win32unix/dup.c
deleted file mode 100644
index de2ea74499..0000000000
--- a/otherlibs/win32unix/dup.c
+++ /dev/null
@@ -1,34 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_dup(value fd)
-{
- HANDLE newh;
- value newfd;
- int kind = Descr_kind_val(fd);
- if (! DuplicateHandle(GetCurrentProcess(), Handle_val(fd),
- GetCurrentProcess(), &newh,
- 0L, 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
deleted file mode 100644
index 4be2d819fb..0000000000
--- a/otherlibs/win32unix/dup2.c
+++ /dev/null
@@ -1,43 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-extern value win_fd_handle(value);
-extern int _dup2(int, int);
-
-CAMLprim value unix_dup2(value fd1, value fd2)
-{
- HANDLE oldh, newh;
-
- oldh = Handle_val(fd2);
- if (! DuplicateHandle(GetCurrentProcess(), Handle_val(fd1),
- GetCurrentProcess(), &newh,
- 0L, 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(Int_val(win_fd_handle(fd1)), Int_val(win_fd_handle(fd2)));
- return Val_unit;
-}
diff --git a/otherlibs/win32unix/errmsg.c b/otherlibs/win32unix/errmsg.c
deleted file mode 100644
index 20a8c8d58f..0000000000
--- a/otherlibs/win32unix/errmsg.c
+++ /dev/null
@@ -1,44 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 2001 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <stdio.h>
-#include <errno.h>
-#include <string.h>
-#include <mlvalues.h>
-#include <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 copy_string(strerror(errnum));
- if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS,
- NULL,
- -errnum,
- 0,
- buffer,
- sizeof(buffer),
- NULL))
- return copy_string(buffer);
- sprintf(buffer, "unknown error #%d", errnum);
- return copy_string(buffer);
-}
-
diff --git a/otherlibs/win32unix/getpeername.c b/otherlibs/win32unix/getpeername.c
deleted file mode 100644
index 4460a7917c..0000000000
--- a/otherlibs/win32unix/getpeername.c
+++ /dev/null
@@ -1,35 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <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);
-}
diff --git a/otherlibs/win32unix/getpid.c b/otherlibs/win32unix/getpid.c
deleted file mode 100644
index 0892f8f95c..0000000000
--- a/otherlibs/win32unix/getpid.c
+++ /dev/null
@@ -1,24 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <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
deleted file mode 100644
index 8a1de78570..0000000000
--- a/otherlibs/win32unix/getsockname.c
+++ /dev/null
@@ -1,32 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <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);
-}
diff --git a/otherlibs/win32unix/gettimeofday.c b/otherlibs/win32unix/gettimeofday.c
deleted file mode 100644
index c7ee376cdd..0000000000
--- a/otherlibs/win32unix/gettimeofday.c
+++ /dev/null
@@ -1,35 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.h>
-#include <time.h>
-
-#include "unixsupport.h"
-
-static time_t initial_time = 0; /* 0 means uninitialized */
-static DWORD initial_tickcount;
-
-CAMLprim value unix_gettimeofday(value unit)
-{
- if (initial_time == 0) {
- initial_tickcount = GetTickCount();
- initial_time = time(NULL);
- return copy_double((double) initial_time);
- } else {
- return copy_double(initial_time +
- (GetTickCount() - initial_tickcount) * 1e-3);
- }
-}
diff --git a/otherlibs/win32unix/link.c b/otherlibs/win32unix/link.c
deleted file mode 100644
index 26202ed986..0000000000
--- a/otherlibs/win32unix/link.c
+++ /dev/null
@@ -1,42 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <windows.h>
-#include <mlvalues.h>
-#include <fail.h>
-#include "unixsupport.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)
- invalid_argument("Unix.link not implemented");
- 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
deleted file mode 100644
index 20789e1a4c..0000000000
--- a/otherlibs/win32unix/listen.c
+++ /dev/null
@@ -1,27 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <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
deleted file mode 100644
index 9183052817..0000000000
--- a/otherlibs/win32unix/lockf.c
+++ /dev/null
@@ -1,206 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* under the terms of the GNU Library General Public License. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <errno.h>
-#include <fcntl.h>
-#include <mlvalues.h>
-#include <fail.h>
-#include "unixsupport.h"
-#include <stdio.h>
-
-/*
-
-Commands for Unix.lockf:
-
-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 *)
-
-
-val lockf : file_descr -> lock_command -> int -> unitlockf 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 (set with F_LOCK or
- F_TLOCK) prevents any other process from acquiring a read or write lock on
- the region. A read lock (set with F_RLOCK or F_TRLOCK) prevents any other
- process from acquiring a write lock on the region, but lets other processes
- acquire read locks on it.
-*/
-
-#ifndef INVALID_SET_FILE_POINTER
-#define INVALID_SET_FILE_POINTER (-1)
-#endif
-
-static void set_file_pointer(HANDLE h, LARGE_INTEGER dest,
- PLARGE_INTEGER cur, DWORD method)
-{
- LONG high = dest.HighPart;
- DWORD ret = SetFilePointer(h, dest.LowPart, &high, method);
- if (ret == INVALID_SET_FILE_POINTER) {
- long err = GetLastError();
- if (err != NO_ERROR) { win32_maperr(err); uerror("lockf", Nothing); }
- }
- if (cur != NULL) { cur->LowPart = ret; cur->HighPart = high; }
-}
-
-CAMLprim value unix_lockf(value fd, value cmd, value span)
-{
- int ret;
- OVERLAPPED overlap;
- DWORD l_start;
- DWORD l_len;
- HANDLE h;
- OSVERSIONINFO VersionInfo;
- LARGE_INTEGER cur_position;
- LARGE_INTEGER end_position;
- LARGE_INTEGER offset_position;
-
- VersionInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
- if(GetVersionEx(&VersionInfo) == 0)
- {
- invalid_argument("lockf only supported on WIN32_NT platforms: could not determine current platform.");
- }
-/* file locking only exists on NT versions */
- if(VersionInfo.dwPlatformId != VER_PLATFORM_WIN32_NT)
- {
- invalid_argument("lockf only supported on WIN32_NT platforms");
- }
-
- h = Handle_val(fd);
-
- overlap.Offset = 0;
- overlap.OffsetHigh = 0;
- overlap.hEvent = 0;
- l_len = Long_val(span);
-
- offset_position.HighPart = 0;
- cur_position.HighPart = 0;
- end_position.HighPart = 0;
- offset_position.LowPart = 0;
- cur_position.LowPart = 0;
- end_position.LowPart = 0;
-
- if(l_len == 0)
- {
-/* save current pointer */
- set_file_pointer(h,offset_position,&cur_position,FILE_CURRENT);
-/* set to end and query */
- set_file_pointer(h,offset_position,&end_position,FILE_END);
- l_len = end_position.LowPart;
-/* restore previous current pointer */
- set_file_pointer(h,cur_position,NULL,FILE_BEGIN);
- }
- else
- {
- if (l_len < 0)
- {
- set_file_pointer(h,offset_position,&cur_position,FILE_CURRENT);
- l_len = abs(l_len);
- if(l_len > cur_position.LowPart)
- {
- errno = EINVAL;
- uerror("lockf", Nothing);
- return Val_unit;
- }
- overlap.Offset = cur_position.LowPart - l_len;
- }
- }
- switch (Int_val(cmd))
- {
- case 0: /* F_ULOCK */
- if(UnlockFileEx(h, 0, l_len,0,&overlap) == 0)
- {
- errno = EACCES;
- ret = -1;
- }
- break;
- case 1: /* F_LOCK */
-/* this should block until write lock is obtained */
- if(LockFileEx(h,LOCKFILE_EXCLUSIVE_LOCK,0,l_len,0,&overlap) == 0)
- {
- errno = EACCES;
- ret = -1;
- }
- break;
- case 2: /* F_TLOCK */
-/*
- * this should return immediately if write lock can-not
- * be obtained.
- */
- if(LockFileEx(h,LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK,0,l_len,0,&overlap) == 0)
- {
- errno = EACCES;
- ret = -1;
- }
- break;
- case 3: /* F_TEST */
-/*
- * 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,l_len,0,&overlap) == 0)
- {
- errno = EACCES;
- ret = -1;
- }
- else
- {
- UnlockFileEx(h, 0, l_len,0,&overlap);
- ret = 0;
- }
- break;
- case 4: /* F_RLOCK */
-/* this should block until read lock is obtained */
- if(LockFileEx(h,0,0,l_len,0,&overlap) == 0)
- {
- errno = EACCES;
- ret = -1;
- }
- break;
- case 5: /* F_TRLOCK */
-/*
- * this should return immediately if read lock can-not
- * be obtained.
- */
- if(LockFileEx(h,LOCKFILE_FAIL_IMMEDIATELY,0,l_len,0,&overlap) == 0)
- {
- errno = EACCES;
- ret = -1;
- }
- break;
- default:
- errno = EINVAL;
- ret = -1;
- }
- if (ret == -1) uerror("lockf", Nothing);
- return Val_unit;
-}
-
diff --git a/otherlibs/win32unix/lseek.c b/otherlibs/win32unix/lseek.c
deleted file mode 100644
index acc7b10044..0000000000
--- a/otherlibs/win32unix/lseek.c
+++ /dev/null
@@ -1,76 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <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 int seek_command_table[] = {
- FILE_BEGIN, FILE_CURRENT, FILE_END
-};
-
-#ifndef INVALID_SET_FILE_POINTER
-#define INVALID_SET_FILE_POINTER (-1)
-#endif
-
-CAMLprim value unix_lseek(value fd, value ofs, value cmd)
-{
- long ret;
- long ofs_low = Long_val(ofs);
- long ofs_high = ofs_low >= 0 ? 0 : -1;
- long err;
-
- ret = SetFilePointer(Handle_val(fd), ofs_low, &ofs_high,
- seek_command_table[Int_val(cmd)]);
- if (ret == INVALID_SET_FILE_POINTER) {
- err = GetLastError();
- if (err != NO_ERROR) {
- win32_maperr(err);
- uerror("lseek", Nothing);
- }
- }
- if (ofs_high != 0 || 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)
-{
- long ret;
- long ofs_low = (long) Int64_val(ofs);
- long ofs_high = (long) (Int64_val(ofs) >> 32);
- long err;
-
- ret = SetFilePointer(Handle_val(fd), ofs_low, &ofs_high,
- seek_command_table[Int_val(cmd)]);
- if (ret == INVALID_SET_FILE_POINTER) {
- err = GetLastError();
- if (err != NO_ERROR) {
- win32_maperr(err);
- uerror("lseek", Nothing);
- }
- }
- return copy_int64((int64) ofs_high << 32 | ret);
-}
diff --git a/otherlibs/win32unix/mkdir.c b/otherlibs/win32unix/mkdir.c
deleted file mode 100644
index aae54783bc..0000000000
--- a/otherlibs/win32unix/mkdir.c
+++ /dev/null
@@ -1,24 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_mkdir(path, perm)
- value path, perm;
-{
- if (_mkdir(String_val(path)) == -1) uerror("mkdir", path);
- return Val_unit;
-}
diff --git a/otherlibs/win32unix/nonblock.c b/otherlibs/win32unix/nonblock.c
deleted file mode 100755
index 733a79d89f..0000000000
--- a/otherlibs/win32unix/nonblock.c
+++ /dev/null
@@ -1,42 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 2002 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <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);
- }
- 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);
- }
- return Val_unit;
-}
diff --git a/otherlibs/win32unix/open.c b/otherlibs/win32unix/open.c
deleted file mode 100644
index 76e73e3aef..0000000000
--- a/otherlibs/win32unix/open.c
+++ /dev/null
@@ -1,66 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.h>
-#include "unixsupport.h"
-#include <fcntl.h>
-
-static int open_access_flags[8] = {
- GENERIC_READ, GENERIC_WRITE, GENERIC_READ|GENERIC_WRITE, 0, 0, 0, 0, 0,
-};
-
-static int open_create_flags[8] = {
- 0, 0, 0, 0, 0, O_CREAT, O_TRUNC, O_EXCL
-};
-
-CAMLprim value unix_open(value path, value flags, value perm)
-{
- int fileaccess, createflags, fileattrib, filecreate;
- SECURITY_ATTRIBUTES attr;
- HANDLE h;
-
- fileaccess = convert_flag_list(flags, open_access_flags);
-
- createflags = 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;
-
- attr.nLength = sizeof(attr);
- attr.lpSecurityDescriptor = NULL;
- attr.bInheritHandle = TRUE;
-
- h = CreateFile(String_val(path), fileaccess,
- FILE_SHARE_READ | FILE_SHARE_WRITE, &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
deleted file mode 100644
index 67e3812989..0000000000
--- a/otherlibs/win32unix/pipe.c
+++ /dev/null
@@ -1,45 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <memory.h>
-#include <alloc.h>
-#include "unixsupport.h"
-#include <fcntl.h>
-
-#define SIZEBUF 1024
-
-CAMLprim value unix_pipe(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 = 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 = 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
deleted file mode 100644
index 704cec2c7a..0000000000
--- a/otherlibs/win32unix/read.c
+++ /dev/null
@@ -1,55 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <string.h>
-#include <mlvalues.h>
-#include <memory.h>
-#include <signals.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_read(value fd, value buf, value ofs, value len)
-{
- DWORD numbytes, numread;
- char iobuf[UNIX_BUFFER_SIZE];
-
- Begin_root (buf);
- numbytes = Long_val(len);
- if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
- if (Descr_kind_val(fd) == KIND_SOCKET) {
- int ret;
- SOCKET s = Socket_val(fd);
- enter_blocking_section();
- ret = recv(s, iobuf, numbytes, 0);
- leave_blocking_section();
- if (ret == SOCKET_ERROR) {
- win32_maperr(WSAGetLastError());
- uerror("read", Nothing);
- }
- numread = ret;
- } else {
- BOOL ret;
- HANDLE h = Handle_val(fd);
- enter_blocking_section();
- ret = ReadFile(h, iobuf, numbytes, &numread, NULL);
- leave_blocking_section();
- if (! ret) {
- win32_maperr(GetLastError());
- uerror("read", Nothing);
- }
- }
- memmove (&Byte(buf, Long_val(ofs)), iobuf, numread);
- End_roots();
- return Val_int(numread);
-}
diff --git a/otherlibs/win32unix/rename.c b/otherlibs/win32unix/rename.c
deleted file mode 100644
index d84bcd66ac..0000000000
--- a/otherlibs/win32unix/rename.c
+++ /dev/null
@@ -1,29 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <stdio.h>
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_rename(value path1, value path2)
-{
- if (MoveFileEx(String_val(path1), String_val(path2),
- MOVEFILE_REPLACE_EXISTING | MOVEFILE_WRITE_THROUGH |
- MOVEFILE_COPY_ALLOWED) == 0) {
- win32_maperr(GetLastError());
- uerror("rename", path1);
- }
- return Val_unit;
-}
diff --git a/otherlibs/win32unix/select.c b/otherlibs/win32unix/select.c
deleted file mode 100644
index 4fa8e788b8..0000000000
--- a/otherlibs/win32unix/select.c
+++ /dev/null
@@ -1,99 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.h>
-#include <memory.h>
-#include <signals.h>
-#include "unixsupport.h"
-
-static void fdlist_to_fdset(value fdlist, fd_set *fdset)
-{
- value l;
- FD_ZERO(fdset);
- for (l = fdlist; l != Val_int(0); l = Field(l, 1)) {
- FD_SET(Socket_val(Field(l, 0)), fdset);
- }
-}
-
-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 = 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)
-{
- fd_set read, write, except;
- double tm;
- struct timeval tv;
- struct timeval * tvp;
- int retcode;
- value res;
- value read_list = Val_unit, write_list = Val_unit, except_list = Val_unit;
-
- Begin_roots3 (readfds, writefds, exceptfds)
- Begin_roots3 (read_list, write_list, except_list)
- tm = Double_val(timeout);
- if (readfds == Val_int(0)
- && writefds == Val_int(0)
- && exceptfds == Val_int(0)) {
- if ( tm > 0.0 ) {
- enter_blocking_section();
- Sleep( (int)(tm * 1000));
- leave_blocking_section();
- }
- read_list = write_list = except_list = Val_int(0);
- } else {
- fdlist_to_fdset(readfds, &read);
- fdlist_to_fdset(writefds, &write);
- fdlist_to_fdset(exceptfds, &except);
- if (tm < 0.0)
- tvp = (struct timeval *) NULL;
- else {
- tv.tv_sec = (int) tm;
- tv.tv_usec = (int) (1e6 * (tm - (int) tm));
- tvp = &tv;
- }
- enter_blocking_section();
- retcode = select(FD_SETSIZE, &read, &write, &except, tvp);
- leave_blocking_section();
- if (retcode == -1) {
- win32_maperr(WSAGetLastError());
- uerror("select", Nothing);
- }
- read_list = fdset_to_fdlist(readfds, &read);
- write_list = fdset_to_fdlist(writefds, &write);
- except_list = fdset_to_fdlist(exceptfds, &except);
- }
- res = alloc_small(3, 0);
- Field(res, 0) = read_list;
- Field(res, 1) = write_list;
- Field(res, 2) = except_list;
- End_roots();
- End_roots();
- return res;
-}
diff --git a/otherlibs/win32unix/sendrecv.c b/otherlibs/win32unix/sendrecv.c
deleted file mode 100644
index 57ca0fdb2f..0000000000
--- a/otherlibs/win32unix/sendrecv.c
+++ /dev/null
@@ -1,133 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.h>
-#include <memory.h>
-#include <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)
-{
- int ret;
- long numbytes;
- char iobuf[UNIX_BUFFER_SIZE];
-
- Begin_root (buff);
- numbytes = Long_val(len);
- if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
- enter_blocking_section();
- ret = recv(Socket_val(sock), iobuf, (int) numbytes,
- convert_flag_list(flags, msg_flag_table));
- leave_blocking_section();
- if (ret == -1) {
- win32_maperr(WSAGetLastError());
- 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;
- long numbytes;
- char iobuf[UNIX_BUFFER_SIZE];
- value res;
- value adr = Val_unit;
- union sock_addr_union addr;
- socklen_param_type addr_len;
-
- Begin_roots2 (buff, adr);
- numbytes = Long_val(len);
- if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
- addr_len = sizeof(sock_addr);
- enter_blocking_section();
- ret = recvfrom(Socket_val(sock),
- iobuf, (int) numbytes,
- convert_flag_list(flags, msg_flag_table),
- &addr.s_gen, &addr_len);
- leave_blocking_section();
- if (ret == -1) {
- win32_maperr(WSAGetLastError());
- uerror("recvfrom", Nothing);
- }
- memmove (&Byte(buff, Long_val(ofs)), iobuf, ret);
- adr = alloc_sockaddr(&addr, addr_len);
- res = 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;
- long numbytes;
- char iobuf[UNIX_BUFFER_SIZE];
-
- numbytes = Long_val(len);
- if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
- memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes);
- enter_blocking_section();
- ret = send(Socket_val(sock), iobuf, (int) numbytes,
- convert_flag_list(flags, msg_flag_table));
- leave_blocking_section();
- if (ret == -1) {
- win32_maperr(WSAGetLastError());
- uerror("send", Nothing);
- }
- return Val_int(ret);
-}
-
-value unix_sendto_native(value sock, value buff, value ofs, value len, value flags, value dest)
-{
- int ret;
- long numbytes;
- char iobuf[UNIX_BUFFER_SIZE];
- union sock_addr_union addr;
- socklen_param_type addr_len;
-
- 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);
- enter_blocking_section();
- ret = sendto(Socket_val(sock),
- iobuf, (int) numbytes,
- convert_flag_list(flags, msg_flag_table),
- &addr.s_gen, addr_len);
- leave_blocking_section();
- if (ret == -1) {
- win32_maperr(WSAGetLastError());
- uerror("sendto", Nothing);
- }
- return Val_int(ret);
-}
-
-CAMLprim value unix_sendto(argv, argc)
- 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
deleted file mode 100644
index f3d2c6e03f..0000000000
--- a/otherlibs/win32unix/shutdown.c
+++ /dev/null
@@ -1,32 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <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
deleted file mode 100644
index 421e5f9023..0000000000
--- a/otherlibs/win32unix/sleep.c
+++ /dev/null
@@ -1,27 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <signals.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_sleep(t)
- value t;
-{
- enter_blocking_section();
- Sleep(Int_val(t) * 1000);
- leave_blocking_section();
- return Val_unit;
-}
diff --git a/otherlibs/win32unix/socket.c b/otherlibs/win32unix/socket.c
deleted file mode 100644
index 079473f81f..0000000000
--- a/otherlibs/win32unix/socket.c
+++ /dev/null
@@ -1,55 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-int socket_domain_table[] = {
- PF_UNIX, PF_INET
-};
-
-int socket_type_table[] = {
- SOCK_STREAM, SOCK_DGRAM, SOCK_RAW, SOCK_SEQPACKET
-};
-
-CAMLprim value unix_socket(domain, type, proto)
- value domain, type, proto;
-{
- SOCKET s;
- int oldvalue, oldvaluelen, newvalue, retcode;
-
- oldvaluelen = sizeof(oldvalue);
- retcode = getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
- (char *) &oldvalue, &oldvaluelen);
- if (retcode == 0) {
- /* Set sockets to synchronous mode */
- newvalue = SO_SYNCHRONOUS_NONALERT;
- setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
- (char *) &newvalue, sizeof(newvalue));
- }
- s = socket(socket_domain_table[Int_val(domain)],
- socket_type_table[Int_val(type)],
- Int_val(proto));
- if (retcode == 0) {
- /* Restore initial mode */
- setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
- (char *) &oldvalue, oldvaluelen);
- }
- if (s == INVALID_SOCKET) {
- win32_maperr(WSAGetLastError());
- uerror("socket", Nothing);
- }
- return win_alloc_socket(s);
-}
diff --git a/otherlibs/win32unix/socketaddr.h b/otherlibs/win32unix/socketaddr.h
deleted file mode 100644
index 2b7884f305..0000000000
--- a/otherlibs/win32unix/socketaddr.h
+++ /dev/null
@@ -1,38 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <misc.h>
-
-union sock_addr_union {
- struct sockaddr s_gen;
- struct sockaddr_in s_inet;
-};
-
-extern union sock_addr_union sock_addr;
-
-#ifdef HAS_SOCKLEN_T
-typedef socklen_t socklen_param_type;
-#else
-typedef int socklen_param_type;
-#endif
-
-void get_sockaddr (value mladdr,
- union sock_addr_union * addr /*out*/,
- socklen_param_type * addr_len /*out*/);
-value alloc_sockaddr (union sock_addr_union * addr /*in*/,
- socklen_param_type addr_len);
-value alloc_inet_addr (uint32 inaddr);
-
-#define GET_INET_ADDR(v) (*((uint32 *) (v)))
diff --git a/otherlibs/win32unix/sockopt.c b/otherlibs/win32unix/sockopt.c
deleted file mode 100644
index 13d6a03e3e..0000000000
--- a/otherlibs/win32unix/sockopt.c
+++ /dev/null
@@ -1,157 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <alloc.h>
-#include "unixsupport.h"
-
-static int sockopt_bool[] = {
- SO_DEBUG, SO_BROADCAST, SO_REUSEADDR, SO_KEEPALIVE,
- SO_DONTROUTE, SO_OOBINLINE, SO_ACCEPTCONN };
-
-static int sockopt_int[] = {
- SO_SNDBUF, SO_RCVBUF, SO_ERROR, SO_TYPE, SO_RCVLOWAT, SO_SNDLOWAT };
-
-static int sockopt_optint[] = { SO_LINGER };
-
-static int sockopt_float[] = { SO_RCVTIMEO, SO_SNDTIMEO };
-
-CAMLprim value getsockopt_int(int *sockopt, value socket,
- int level, value option)
-{
- int optval;
- int optsize;
-
- optsize = sizeof(optval);
- if (getsockopt(Socket_val(socket),
- level, sockopt[Int_val(option)],
- (void *) &optval, &optsize) == -1)
- uerror("getsockopt", Nothing);
- return Val_int(optval);
-}
-
-CAMLprim value setsockopt_int(int *sockopt, value socket, int level,
- value option, value status)
-{
- int optval = Int_val(status);
- if (setsockopt(Socket_val(socket),
- level, sockopt[Int_val(option)],
- (void *) &optval, sizeof(optval)) == -1)
- uerror("setsockopt", Nothing);
- return Val_unit;
-}
-
-CAMLprim value unix_getsockopt_bool(value socket, value option) {
- return getsockopt_int(sockopt_bool, socket, SOL_SOCKET, option);
-}
-
-CAMLprim value unix_setsockopt_bool(value socket, value option, value status)
-{
- return setsockopt_int(sockopt_bool, socket, SOL_SOCKET, option, status);
-}
-
-CAMLprim value unix_getsockopt_int(value socket, value option) {
- return getsockopt_int(sockopt_int, socket, SOL_SOCKET, option);
-}
-
-CAMLprim value unix_setsockopt_int(value socket, value option, value status)
-{
- return setsockopt_int(sockopt_int, socket, SOL_SOCKET, option, status);
-}
-
-CAMLprim value getsockopt_optint(int *sockopt, value socket,
- int level, value option)
-{
- struct linger optval;
- int optsize;
- value res = Val_int(0); /* None */
-
- optsize = sizeof(optval);
- if (getsockopt(Socket_val(socket),
- level, sockopt[Int_val(option)],
- (void *) &optval, &optsize) == -1)
- uerror("getsockopt_optint", Nothing);
- if (optval.l_onoff != 0) {
- res = alloc_small(1, 0);
- Field(res, 0) = Val_int(optval.l_linger);
- }
- return res;
-}
-
-CAMLprim value setsockopt_optint(int *sockopt, value socket, int level,
- value option, value status)
-{
- struct linger optval;
-
- optval.l_onoff = Is_block (status);
- if (optval.l_onoff)
- optval.l_linger = Int_val (Field (status, 0));
- if (setsockopt(Socket_val(socket),
- level, sockopt[Int_val(option)],
- (void *) &optval, sizeof(optval)) == -1)
- uerror("setsockopt_optint", Nothing);
- return Val_unit;
-}
-
-CAMLprim value unix_getsockopt_optint(value socket, value option)
-{
- return getsockopt_optint(sockopt_optint, socket, SOL_SOCKET, option);
-}
-
-CAMLprim value unix_setsockopt_optint(value socket, value option, value status)
-{
- return setsockopt_optint(sockopt_optint, socket, SOL_SOCKET, option, status);
-}
-
-CAMLprim value getsockopt_float(int *sockopt, value socket,
- int level, value option)
-{
- struct timeval tv;
- int optsize;
-
- optsize = sizeof(tv);
- if (getsockopt(Socket_val(socket),
- level, sockopt[Int_val(option)],
- (void *) &tv, &optsize) == -1)
- uerror("getsockopt_float", Nothing);
- return copy_double((double) tv.tv_sec + (double) tv.tv_usec / 1e6);
-}
-
-CAMLprim value setsockopt_float(int *sockopt, value socket, int level,
- value option, value status)
-{
- struct timeval tv;
- double tv_f;
-
- tv_f = Double_val(status);
- tv.tv_sec = (int)tv_f;
- tv.tv_usec = (int) (1e6 * (tv_f - tv.tv_sec));
- if (setsockopt(Socket_val(socket),
- level, sockopt[Int_val(option)],
- (void *) &tv, sizeof(tv)) == -1)
- uerror("setsockopt_float", Nothing);
- return Val_unit;
-}
-
-CAMLprim value unix_getsockopt_float(value socket, value option)
-{
- return getsockopt_float(sockopt_float, socket, SOL_SOCKET, option);
-}
-
-CAMLprim value unix_setsockopt_float(value socket, value option, value status)
-{
- return setsockopt_float(sockopt_float, socket, SOL_SOCKET, option, status);
-}
-
diff --git a/otherlibs/win32unix/startup.c b/otherlibs/win32unix/startup.c
deleted file mode 100644
index ae584e5693..0000000000
--- a/otherlibs/win32unix/startup.c
+++ /dev/null
@@ -1,43 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-#include <stdio.h>
-#include <fcntl.h>
-#include <stdlib.h>
-#include <mlvalues.h>
-#include "unixsupport.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);
-
- return Val_unit;
-}
-
-CAMLprim value win_cleanup(unit)
- value unit;
-{
- (void) WSACleanup();
- return Val_unit;
-}
diff --git a/otherlibs/win32unix/stat.c b/otherlibs/win32unix/stat.c
deleted file mode 100644
index 6a1259acd2..0000000000
--- a/otherlibs/win32unix/stat.c
+++ /dev/null
@@ -1,93 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 2002 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <errno.h>
-#include <mlvalues.h>
-#include <memory.h>
-#include <alloc.h>
-#include "unixsupport.h"
-#include "cst2constr.h"
-#define _INTEGRAL_MAX_BITS 64
-#include <sys/types.h>
-#include <sys/stat.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
-
-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 _stati64 *buf)
-{
- value v;
- value atime = Val_unit, mtime = Val_unit, ctime = Val_unit;
-
- Begin_roots3(atime,mtime,ctime)
- atime = copy_double((double) buf->st_atime);
- mtime = copy_double((double) buf->st_mtime);
- ctime = copy_double((double) buf->st_ctime);
- v = 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) =
- use_64 ? copy_int64(buf->st_size) : Val_int (buf->st_size);
- Field (v, 9) = atime;
- Field (v, 10) = mtime;
- Field (v, 11) = ctime;
- End_roots();
- return v;
-}
-
-CAMLprim value unix_stat(value path)
-{
- int ret;
- struct _stati64 buf;
-
- ret = _stati64(String_val(path), &buf);
- if (ret == -1) uerror("stat", path);
- if (buf.st_size > Max_long) {
- win32_maperr(ERROR_ARITHMETIC_OVERFLOW);
- uerror("stat", path);
- }
- return stat_aux(0, &buf);
-}
-
-CAMLprim value unix_stat_64(value path)
-{
- int ret;
- struct _stati64 buf;
- ret = _stati64(String_val(path), &buf);
- if (ret == -1) uerror("stat", path);
- return stat_aux(1, &buf);
-}
-
diff --git a/otherlibs/win32unix/system.c b/otherlibs/win32unix/system.c
deleted file mode 100644
index 725817c37a..0000000000
--- a/otherlibs/win32unix/system.c
+++ /dev/null
@@ -1,41 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <memory.h>
-#include <alloc.h>
-#include <signals.h>
-#include "unixsupport.h"
-#include <process.h>
-#include <stdio.h>
-
-CAMLprim value win_system(cmd)
- value cmd;
-{
- int ret;
- value st;
-
- enter_blocking_section();
- _flushall();
- ret = system(String_val(cmd));;
- leave_blocking_section();
- if (ret == -1) uerror("system", Nothing);
- st = alloc_small(1, 0); /* Tag 0: Exited */
- Field(st, 0) = Val_int(ret);
- return st;
-}
-
-
-
diff --git a/otherlibs/win32unix/unix.ml b/otherlibs/win32unix/unix.ml
deleted file mode 100644
index f7a7e9ee7c..0000000000
--- a/otherlibs/win32unix/unix.ml
+++ /dev/null
@@ -1,797 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* 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 Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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 = "sys_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 -> unit = "unix_execv"
-external execve : string -> string array -> string array -> unit = "unix_execve"
-external execvp : string -> string array -> unit = "unix_execvp"
-external execvpe : string -> string array -> string array -> unit = "unix_execvpe"
-
-external 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 prio = 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
-
-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 -> string -> int -> int -> int
- = "unix_read"
-external unsafe_write : file_descr -> string -> int -> int -> int
- = "unix_write"
-
-let read fd buf ofs len =
- if ofs < 0 || len < 0 || ofs > String.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 > String.length buf - len
- then invalid_arg "Unix.write"
- else unsafe_write fd buf ofs len
-
-(* Interfacing with the standard input/output library *)
-
-external open_read_descriptor : int -> in_channel = "caml_open_descriptor_in"
-external open_write_descriptor : int -> out_channel = "caml_open_descriptor_out"
-external fd_of_in_channel : in_channel -> int = "channel_descriptor"
-external fd_of_out_channel : out_channel -> int = "channel_descriptor"
-
-external open_handle : file_descr -> int = "win_fd_handle"
-
-let in_channel_of_descr handle =
- open_read_descriptor(open_handle handle)
-let out_channel_of_descr handle =
- open_write_descriptor(open_handle handle)
-
-let descr_of_in_channel inchan =
- filedescr_of_fd(fd_of_in_channel inchan)
-let descr_of_out_channel outchan =
- filedescr_of_fd(fd_of_out_channel outchan)
-
-(* 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"
-let lstat = stat
-let fstat fd = invalid_arg "Unix.fstat not implemented"
-
-(* 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"
- let lstat = stat
- let fstat fd = invalid_arg "Unix.LargeFile.fstat not implemented"
- 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 : file_descr -> file_descr = "unix_dup"
-external dup2 : 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 (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 : unit -> file_descr * file_descr = "unix_pipe"
-
-let mkfifo name perm = invalid_arg "Unix.mkfifo not implemented"
-
-(* Symbolic links *)
-
-let readlink path = invalid_arg "Unix.readlink not implemented"
-let symlink path1 path2 = invalid_arg "Unix.symlink not implemented"
-
-(* 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"
-let kill pid signo = invalid_arg "Unix.kill not implemented"
-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 sleep : int -> unit = "unix_sleep"
-let times () =
- { tms_utime = Sys.time(); tms_stime = 0.0;
- tms_cutime = 0.0; tms_cstime = 0.0 }
-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|]
-
-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
-
-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"
-
-(* Sockets *)
-
-type socket_domain =
- PF_UNIX
- | PF_INET
-
-type socket_type =
- SOCK_STREAM
- | SOCK_DGRAM
- | SOCK_RAW
- | SOCK_SEQPACKET
-
-type sockaddr =
- ADDR_UNIX of string
- | ADDR_INET of inet_addr * int
-
-type shutdown_command =
- SHUTDOWN_RECEIVE
- | SHUTDOWN_SEND
- | SHUTDOWN_ALL
-
-type msg_flag =
- MSG_OOB
- | MSG_DONTROUTE
- | MSG_PEEK
-
-type socket_bool_option =
- SO_DEBUG
- | SO_BROADCAST
- | SO_REUSEADDR
- | SO_KEEPALIVE
- | SO_DONTROUTE
- | SO_OOBINLINE
- | SO_ACCEPTCONN
-
-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
-
-external socket : socket_domain -> socket_type -> int -> file_descr
- = "unix_socket"
-let socketpair dom ty proto = invalid_arg "Unix.socketpair not implemented"
-external accept : 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 -> string -> int -> int -> msg_flag list -> int
- = "unix_recv"
-external unsafe_recvfrom :
- file_descr -> string -> int -> int -> msg_flag list -> int * sockaddr
- = "unix_recvfrom"
-external unsafe_send :
- file_descr -> string -> int -> int -> msg_flag list -> int
- = "unix_send"
-external unsafe_sendto :
- file_descr -> string -> 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 > String.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 > String.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 > String.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 > String.length buf - len
- then invalid_arg "Unix.sendto"
- else unsafe_sendto fd buf ofs len flags addr
-
-external getsockopt : file_descr -> socket_bool_option -> bool
- = "unix_getsockopt_bool"
-external setsockopt : file_descr -> socket_bool_option -> bool -> unit
- = "unix_setsockopt_bool"
-external getsockopt_int : file_descr -> socket_int_option -> int
- = "unix_getsockopt_int"
-external setsockopt_int : file_descr -> socket_int_option -> int -> unit
- = "unix_setsockopt_int"
-external getsockopt_optint : file_descr -> socket_optint_option -> int option
- = "unix_getsockopt_optint"
-external setsockopt_optint : file_descr -> socket_optint_option -> int option -> unit
- = "unix_setsockopt_optint"
-external getsockopt_float : file_descr -> socket_float_option -> float
- = "unix_getsockopt_float"
-external setsockopt_float : file_descr -> socket_float_option -> float -> unit
- = "unix_setsockopt_float"
-
-(* 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"
-
-(* 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 create_process prog args fd1 fd2 fd3 =
- win_create_process prog (String.concat " " (Array.to_list args)) None
- fd1 fd2 fd3
-
-let create_process_env prog args env fd1 fd2 fd3 =
- win_create_process prog (String.concat " " (Array.to_list args))
- (Some(String.concat "\000" (Array.to_list env) ^ "\000"))
- 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() in
- set_close_on_exec in_read;
- let inchan = in_channel_of_descr in_read in
- open_proc cmd None (Process_in inchan) stdin in_write stderr;
- close in_write;
- inchan
-
-let open_process_out cmd =
- let (out_read, out_write) = pipe() in
- set_close_on_exec out_write;
- let outchan = out_channel_of_descr out_write in
- open_proc cmd None (Process_out outchan) out_read stdout stderr;
- close out_read;
- outchan
-
-let open_process cmd =
- let (in_read, in_write) = pipe() in
- let (out_read, out_write) = pipe() in
- set_close_on_exec in_read;
- set_close_on_exec out_write;
- let inchan = in_channel_of_descr in_read in
- let outchan = out_channel_of_descr out_write in
- open_proc cmd None (Process(inchan, outchan)) out_read in_write stderr;
- close out_read; close in_write;
- (inchan, outchan)
-
-let open_process_full cmd env =
- let (in_read, in_write) = pipe() in
- let (out_read, out_write) = pipe() in
- let (err_read, err_write) = pipe() in
- set_close_on_exec in_read;
- set_close_on_exec out_write;
- set_close_on_exec err_read;
- 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
- open_proc cmd (Some(String.concat "\000" (Array.to_list env) ^ "\000"))
- (Process_full(inchan, outchan, errchan))
- out_read in_write err_write;
- 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 domain =
- match sockaddr with ADDR_UNIX _ -> PF_UNIX | ADDR_INET(_,_) -> PF_INET in
- let sock =
- socket domain SOCK_STREAM 0 in
- connect sock sockaddr;
- (in_channel_of_descr sock, out_channel_of_descr sock)
-
-let shutdown_connection inchan =
- shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND
-
-let establish_server server_fun sockaddr =
- invalid_arg "Unix.establish_server not implmented"
-
-(* 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
deleted file mode 100644
index a8558f8164..0000000000
--- a/otherlibs/win32unix/unixsupport.c
+++ /dev/null
@@ -1,259 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <stddef.h>
-#include <mlvalues.h>
-#include <callback.h>
-#include <alloc.h>
-#include <memory.h>
-#include <fail.h>
-#include <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 long win_handle_hash(value v)
-{
- return (long) 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
-};
-
-value win_alloc_handle(HANDLE h)
-{
- value res = 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;
- return res;
-}
-
-value win_alloc_socket(SOCKET s)
-{
- value res = alloc_custom(&win_handle_ops, sizeof(struct filedescr), 0, 1);
- Socket_val(res) = s;
- Descr_kind_val(res) = KIND_SOCKET;
- return res;
-}
-
-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;
-}
-
-/* Mapping of Windows error codes to POSIX error codes */
-
-struct error_entry { unsigned long 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_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(unsigned long 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 */
-
-#define EWOULDBLOCK -WSAEWOULDBLOCK
-#define EINPROGRESS -WSAEINPROGRESS
-#define EALREADY -WSAEALREADY
-#define ENOTSOCK -WSAENOTSOCK
-#define EDESTADDRREQ -WSAEDESTADDRREQ
-#define EMSGSIZE -WSAEMSGSIZE
-#define EPROTOTYPE -WSAEPROTOTYPE
-#define ENOPROTOOPT -WSAENOPROTOOPT
-#define EPROTONOSUPPORT -WSAEPROTONOSUPPORT
-#define ESOCKTNOSUPPORT -WSAESOCKTNOSUPPORT
-#define EOPNOTSUPP -WSAEOPNOTSUPP
-#define EPFNOSUPPORT -WSAEPFNOSUPPORT
-#define EAFNOSUPPORT -WSAEAFNOSUPPORT
-#define EADDRINUSE -WSAEADDRINUSE
-#define EADDRNOTAVAIL -WSAEADDRNOTAVAIL
-#define ENETDOWN -WSAENETDOWN
-#define ENETUNREACH -WSAENETUNREACH
-#define ENETRESET -WSAENETRESET
-#define ECONNABORTED -WSAECONNABORTED
-#define ECONNRESET -WSAECONNRESET
-#define ENOBUFS -WSAENOBUFS
-#define EISCONN -WSAEISCONN
-#define ENOTCONN -WSAENOTCONN
-#define ESHUTDOWN -WSAESHUTDOWN
-#define ETOOMANYREFS -WSAETOOMANYREFS
-#define ETIMEDOUT -WSAETIMEDOUT
-#define ECONNREFUSED -WSAECONNREFUSED
-#define ELOOP -WSAELOOP
-#define EHOSTDOWN -WSAEHOSTDOWN
-#define EHOSTUNREACH -WSAEHOSTUNREACH
-#define EPROCLIM -WSAEPROCLIM
-#define EUSERS -WSAEUSERS
-#define EDQUOT -WSAEDQUOT
-#define ESTALE -WSAESTALE
-#define EREMOTE -WSAEREMOTE
-
-#define EOVERFLOW -ERROR_ARITHMETIC_OVERFLOW
-#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;
-
-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 ? copy_string("") : cmdarg;
- name = copy_string(cmdname);
- errconstr =
- cst_to_constr(errcode, error_table, sizeof(error_table)/sizeof(int), -1);
- if (errconstr == Val_int(-1)) {
- err = alloc_small(1, 0);
- Field(err, 0) = Val_int(errcode);
- } else {
- err = errconstr;
- }
- if (unix_error_exn == NULL) {
- unix_error_exn = caml_named_value("Unix.Unix_error");
- if (unix_error_exn == NULL)
- invalid_argument("Exception Unix.Unix_error not initialized, please link unix.cma");
- }
- res = alloc_small(4, 0);
- Field(res, 0) = *unix_error_exn;
- Field(res, 1) = err;
- Field(res, 2) = name;
- Field(res, 3) = arg;
- End_roots();
- mlraise(res);
-}
-
-void uerror(cmdname, cmdarg)
- char * cmdname;
- value cmdarg;
-{
- unix_error(errno, cmdname, cmdarg);
-}
diff --git a/otherlibs/win32unix/unixsupport.h b/otherlibs/win32unix/unixsupport.h
deleted file mode 100644
index 2b1ff71eaf..0000000000
--- a/otherlibs/win32unix/unixsupport.h
+++ /dev/null
@@ -1,54 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#define WIN32_LEAN_AND_MEAN
-#include <wtypes.h>
-#include <winbase.h>
-#include <stdlib.h>
-/* Include io.h in current dir, which is a copy of the system's io.h,
- not io.h from ../../byterun */
-/*#include "io.h"*/
-#include <direct.h>
-#include <process.h>
-#include <sys/types.h>
-#include <winsock.h>
-
-struct filedescr {
- union {
- HANDLE handle;
- SOCKET socket;
- } fd;
- enum { KIND_HANDLE, KIND_SOCKET } kind;
- int crt_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)
-
-extern value win_alloc_handle_or_socket(HANDLE);
-extern value win_alloc_handle(HANDLE);
-extern value win_alloc_socket(SOCKET);
-
-#define NO_CRT_FD (-1)
-#define Nothing ((value) 0)
-
-extern void win32_maperr(unsigned long errcode);
-extern void unix_error (int errcode, char * cmdname, value arg);
-extern void uerror (char * cmdname, value arg);
-extern value unix_freeze_buffer (value);
-
-#define UNIX_BUFFER_SIZE 16384
diff --git a/otherlibs/win32unix/windir.c b/otherlibs/win32unix/windir.c
deleted file mode 100644
index 0a681e76ce..0000000000
--- a/otherlibs/win32unix/windir.c
+++ /dev/null
@@ -1,80 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <mlvalues.h>
-#include <memory.h>
-#include <errno.h>
-#include <alloc.h>
-#include <fail.h>
-#include "unixsupport.h"
-
-CAMLprim value win_findfirst(name)
- value name;
-{
- HANDLE h;
- value v;
- WIN32_FIND_DATA fileinfo;
- value valname = Val_unit;
- value valh = Val_unit;
-
- Begin_roots2 (valname,valh);
- h = FindFirstFile(String_val(name),&fileinfo);
- if (h == INVALID_HANDLE_VALUE) {
- DWORD err = GetLastError();
- if (err == ERROR_NO_MORE_FILES)
- raise_end_of_file();
- else {
- win32_maperr(err);
- uerror("opendir", Nothing);
- }
- }
- valname = copy_string(fileinfo.cFileName);
- valh = win_alloc_handle(h);
- v = alloc_small(2, 0);
- Field(v,0) = valname;
- Field(v,1) = valh;
- End_roots();
- return v;
-}
-
-CAMLprim value win_findnext(valh)
- 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)
- raise_end_of_file();
- else {
- win32_maperr(err);
- uerror("readdir", Nothing);
- }
- }
- return copy_string(fileinfo.cFileName);
-}
-
-CAMLprim value win_findclose(valh)
- value valh;
-{
- if (! FindClose(Handle_val(valh))) {
- win32_maperr(GetLastError());
- uerror("closedir", Nothing);
- }
- return Val_unit;
-}
-
diff --git a/otherlibs/win32unix/winwait.c b/otherlibs/win32unix/winwait.c
deleted file mode 100644
index db3a62dde5..0000000000
--- a/otherlibs/win32unix/winwait.c
+++ /dev/null
@@ -1,62 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* 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 Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <windows.h>
-#include <mlvalues.h>
-#include <alloc.h>
-#include <memory.h>
-#include "unixsupport.h"
-#include <sys/types.h>
-
-static value alloc_process_status(HANDLE pid, int status)
-{
- value res, st;
-
- st = alloc(1, 0);
- Field(st, 0) = Val_int(status);
- Begin_root (st);
- res = alloc_small(2, 0);
- Field(res, 0) = Val_long((long) 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;
- HANDLE pid_req = (HANDLE) Long_val(vpid_req);
-
- flags = convert_flag_list(vflags, wait_flag_table);
- if ((flags & CAML_WNOHANG) == 0) {
- if (WaitForSingleObject(pid_req, INFINITE) == WAIT_FAILED) {
- win32_maperr(GetLastError());
- 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
- return alloc_process_status(pid_req, status);
-}
diff --git a/otherlibs/win32unix/write.c b/otherlibs/win32unix/write.c
deleted file mode 100644
index 8571ff6794..0000000000
--- a/otherlibs/win32unix/write.c
+++ /dev/null
@@ -1,64 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <errno.h>
-#include <string.h>
-#include <mlvalues.h>
-#include <memory.h>
-#include <signals.h>
-#include "unixsupport.h"
-
-CAMLprim value unix_write(value fd, value buf, value vofs, value vlen)
-{
- long ofs, len, written;
- DWORD numbytes, numwritten;
- char iobuf[UNIX_BUFFER_SIZE];
-
- Begin_root (buf);
- ofs = Long_val(vofs);
- len = Long_val(vlen);
- written = 0;
- 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);
- enter_blocking_section();
- ret = send(s, iobuf, numbytes, 0);
- leave_blocking_section();
- if (ret == SOCKET_ERROR) {
- win32_maperr(WSAGetLastError());
- uerror("write", Nothing);
- }
- numwritten = ret;
- } else {
- BOOL ret;
- HANDLE h = Handle_val(fd);
- enter_blocking_section();
- ret = WriteFile(h, iobuf, numbytes, &numwritten, NULL);
- leave_blocking_section();
- if (! ret) {
- win32_maperr(GetLastError());
- uerror("write", Nothing);
- }
- }
- written += numwritten;
- ofs += numwritten;
- len -= numwritten;
- }
- End_roots();
- return Val_long(written);
-}
diff --git a/parsing/.cvsignore b/parsing/.cvsignore
deleted file mode 100644
index 260727a789..0000000000
--- a/parsing/.cvsignore
+++ /dev/null
@@ -1,7 +0,0 @@
-parser.ml
-parser.mli
-lexer.ml
-lexer_tmp.mll
-lexer_tmp.ml
-linenum.ml
-parser.output
diff --git a/parsing/asttypes.mli b/parsing/asttypes.mli
deleted file mode 100644
index f9824d0590..0000000000
--- a/parsing/asttypes.mli
+++ /dev/null
@@ -1,36 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Auxiliary a.s.t. types used by parsetree and typedtree. *)
-
-type constant =
- Const_int of int
- | Const_char of char
- | Const_string of string
- | Const_float of string
- | Const_int32 of int32
- | Const_int64 of int64
- | Const_nativeint of nativeint
-
-type rec_flag = Nonrecursive | Recursive | Default
-
-type direction_flag = Upto | Downto
-
-type private_flag = Private | Public
-
-type mutable_flag = Immutable | Mutable
-
-type virtual_flag = Virtual | Concrete
-
-type label = string
diff --git a/parsing/lexer.mli b/parsing/lexer.mli
deleted file mode 100644
index 3ddb5dde7c..0000000000
--- a/parsing/lexer.mli
+++ /dev/null
@@ -1,36 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* The lexical analyzer *)
-
-val token: Lexing.lexbuf -> Parser.token
-val skip_sharp_bang: Lexing.lexbuf -> unit
-
-type error =
- | Illegal_character of char
- | Illegal_escape of string
- | Unterminated_comment
- | Unterminated_string
- | Unterminated_string_in_comment
- | Keyword_as_label of string
- | Literal_overflow of string
-;;
-
-exception Error of error * Location.t
-
-open Format
-
-val report_error: formatter -> error -> unit
-
-val in_comment : unit -> bool;;
diff --git a/parsing/lexer.mll b/parsing/lexer.mll
deleted file mode 100644
index c388575150..0000000000
--- a/parsing/lexer.mll
+++ /dev/null
@@ -1,514 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* The lexer definition *)
-
-{
-open Lexing
-open Misc
-open Parser
-
-type error =
- | Illegal_character of char
- | Illegal_escape of string
- | Unterminated_comment
- | Unterminated_string
- | Unterminated_string_in_comment
- | Keyword_as_label of string
- | Literal_overflow of string
-;;
-
-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;
- "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 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 <> [];;
-
-(* To translate escape sequences *)
-
-let char_for_backslash =
- match Sys.os_type with
- | "Unix" | "Win32" | "Cygwin" ->
- begin function
- | 'n' -> '\010'
- | 'r' -> '\013'
- | 'b' -> '\008'
- | 't' -> '\009'
- | c -> c
- end
- | "MacOS" ->
- begin function
- | 'n' -> '\013'
- | 'r' -> '\010'
- | 'b' -> '\008'
- | 't' -> '\009'
- | c -> c
- end
- | x -> fatal_error "Lexer: unknown system type"
-
-let char_for_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) && not (in_comment ())
- then raise (Error(Illegal_escape (Lexing.lexeme lexbuf),
- Location.curr lexbuf))
- else 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)
-
-(* Remove underscores from float literals *)
-
-let remove_underscores s =
- let l = String.length s in
- let rec remove src dst =
- if src >= l then
- if dst >= l then s else String.sub s 0 dst
- else
- match s.[src] with
- '_' -> remove (src + 1) dst
- | c -> s.[dst] <- c; remove (src + 1) (dst + 1)
- in remove 0 0
-
-(* 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;
- }
-;;
-
-(* 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 ->
- fprintf ppf "This comment contains an unterminated string literal"
- | Keyword_as_label kwd ->
- fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd
- | Literal_overflow ty ->
- fprintf ppf "Integer literal exceeds the range of representable integers of type %s" ty
-;;
-
-}
-
-let newline = ('\010' | '\013' | "\013\010")
-let blank = [' ' '\009' '\012']
-let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_']
-let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222']
-let identchar =
- ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
-let 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' '_']*)?
-
-rule token = parse
- | newline
- { update_loc lexbuf None 1 false 0;
- token lexbuf
- }
- | 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, Location.curr lexbuf));
- LABEL name }
- | "?" { QUESTION }
- | "??" { QUESTIONQUESTION }
- | "?" 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, Location.curr 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 *)
- | int_literal
- { try
- INT (int_of_string(Lexing.lexeme lexbuf))
- with Failure _ ->
- raise (Error(Literal_overflow "int", Location.curr lexbuf))
- }
- | float_literal
- { FLOAT (remove_underscores(Lexing.lexeme lexbuf)) }
- | int_literal "l"
- { let s = Lexing.lexeme lexbuf in
- try
- INT32 (Int32.of_string(String.sub s 0 (String.length s - 1)))
- with Failure _ ->
- raise (Error(Literal_overflow "int32", Location.curr lexbuf)) }
- | int_literal "L"
- { let s = Lexing.lexeme lexbuf in
- try
- INT64 (Int64.of_string(String.sub s 0 (String.length s - 1)))
- with Failure _ ->
- raise (Error(Literal_overflow "int64", Location.curr lexbuf)) }
- | int_literal "n"
- { let s = Lexing.lexeme lexbuf in
- try
- NATIVEINT
- (Nativeint.of_string(String.sub s 0 (String.length s - 1)))
- with Failure _ ->
- raise (Error(Literal_overflow "nativeint", Location.curr lexbuf)) }
- | "\""
- { reset_string_buffer();
- let string_start = lexbuf.lex_start_p in
- string_start_loc := Location.curr lexbuf;
- string lexbuf;
- lexbuf.lex_start_p <- string_start;
- STRING (get_stored_string()) }
- | "'" 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) }
- | "'\\" '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))
- }
- | "(*"
- { comment_start_loc := [Location.curr lexbuf];
- comment lexbuf;
- token lexbuf }
- | "(*)"
- { let loc = Location.curr lexbuf in
- Location.prerr_warning loc (Warnings.Comment "the start of a comment");
- comment_start_loc := [Location.curr lexbuf];
- comment lexbuf;
- token lexbuf
- }
- | "*)"
- { let loc = Location.curr lexbuf in
- let warn = Warnings.Comment "not the end of a comment" in
- Location.prerr_warning loc warn;
- 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) "\"")?
- [^ '\010' '\013'] * newline
- { update_loc lexbuf name (int_of_string num) true 0;
- token lexbuf
- }
- | "#" { SHARP }
- | "&" { AMPERSAND }
- | "&&" { AMPERAMPER }
- | "`" { BACKQUOTE }
- | "'" { QUOTE }
- | "(" { LPAREN }
- | ")" { RPAREN }
- | "*" { STAR }
- | "," { COMMA }
- | "->" { 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_char lexbuf 0),
- Location.curr lexbuf))
- }
-
-and comment = parse
- "(*"
- { comment_start_loc := (Location.curr lexbuf) :: !comment_start_loc;
- comment lexbuf;
- }
- | "*)"
- { match !comment_start_loc with
- | [] -> assert false
- | [x] -> comment_start_loc := [];
- | _ :: l -> comment_start_loc := l;
- comment lexbuf;
- }
- | "\""
- { reset_string_buffer();
- string_start_loc := Location.curr lexbuf;
- begin try string lexbuf
- with Error (Unterminated_string, _) ->
- match !comment_start_loc with
- | [] -> assert false
- | loc :: _ -> comment_start_loc := [];
- raise (Error (Unterminated_string_in_comment, loc))
- end;
- reset_string_buffer ();
- comment lexbuf }
- | "''"
- { comment lexbuf }
- | "'" newline "'"
- { update_loc lexbuf None 1 false 1;
- comment lexbuf
- }
- | "'" [^ '\\' '\'' '\010' '\013' ] "'"
- { comment lexbuf }
- | "'\\" ['\\' '"' '\'' 'n' 't' 'b' 'r'] "'"
- { comment lexbuf }
- | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
- { comment lexbuf }
- | "'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "'"
- { comment lexbuf }
- | eof
- { match !comment_start_loc with
- | [] -> assert false
- | loc :: _ -> comment_start_loc := [];
- raise (Error (Unterminated_comment, loc))
- }
- | newline
- { update_loc lexbuf None 1 false 0;
- comment lexbuf
- }
- | _
- { comment lexbuf }
-
-and string = parse
- '"'
- { () }
- | '\\' newline ([' ' '\t'] * as space)
- { update_loc lexbuf None 1 false (String.length space);
- 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 }
- | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F']
- { store_string_char(char_for_hexadecimal_code lexbuf 2);
- string lexbuf }
- | '\\' _
- { if in_comment ()
- then string lexbuf
- else 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
- let warn = Warnings.Other "Illegal backslash escape in string" in
- Location.prerr_warning loc warn;
- store_string_char (Lexing.lexeme_char lexbuf 0);
- store_string_char (Lexing.lexeme_char lexbuf 1);
- string lexbuf
- end
- }
- | newline
- { update_loc lexbuf None 1 false 0;
- let s = Lexing.lexeme lexbuf in
- for i = 0 to String.length s - 1 do
- store_string_char s.[i];
- done;
- string lexbuf
- }
- | eof
- { raise (Error (Unterminated_string, !string_start_loc)) }
- | _
- { store_string_char(Lexing.lexeme_char lexbuf 0);
- string lexbuf }
-
-and skip_sharp_bang = parse
- | "#!" [^ '\n']* '\n' [^ '\n']* "\n!#\n"
- { update_loc lexbuf None 3 false 0 }
- | "#!" [^ '\n']* '\n'
- { update_loc lexbuf None 1 false 0 }
- | "" { () }
diff --git a/parsing/linenum.mli b/parsing/linenum.mli
deleted file mode 100644
index 50cc57e8ee..0000000000
--- a/parsing/linenum.mli
+++ /dev/null
@@ -1,23 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1997 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* An auxiliary lexer for determining the line number corresponding to
- a file position, honoring the directives # linenum "filename" *)
-
-val for_position: string -> int -> string * int * int
- (* [Linenum.for_position file loc] returns a triple describing
- the location [loc] in the file named [file].
- First result is name of actual source file.
- Second result is line number in that source file.
- Third result is position of beginning of that line in [file]. *)
diff --git a/parsing/linenum.mll b/parsing/linenum.mll
deleted file mode 100644
index 32f54d5ffb..0000000000
--- a/parsing/linenum.mll
+++ /dev/null
@@ -1,74 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1997 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* An auxiliary lexer for determining the line number corresponding to
- a file position, honoring the directives # linenum "filename" *)
-
-{
-let filename = ref ""
-let linenum = ref 0
-let linebeg = ref 0
-
-let parse_sharp_line s =
- try
- (* Update the line number and file name *)
- let l1 = ref 0 in
- while let c = s.[!l1] in c < '0' || c > '9' do incr l1 done;
- let l2 = ref (!l1 + 1) in
- while let c = s.[!l2] in c >= '0' && c <= '9' do incr l2 done;
- linenum := int_of_string(String.sub s !l1 (!l2 - !l1));
- let f1 = ref (!l2 + 1) in
- while !f1 < String.length s && s.[!f1] <> '"' do incr f1 done;
- let f2 = ref (!f1 + 1) in
- while !f2 < String.length s && s.[!f2] <> '"' do incr f2 done;
- if !f1 < String.length s then
- filename := String.sub s (!f1 + 1) (!f2 - !f1 - 1)
- with Failure _ | Invalid_argument _ ->
- Misc.fatal_error "Linenum.parse_sharp_line"
-}
-
-rule skip_line = parse
- "#" [' ' '\t']* ['0'-'9']+ [' ' '\t']*
- ("\"" [^ '\n' '\r' '"' (* '"' *) ] * "\"")?
- [^ '\n' '\r'] *
- ('\n' | '\r' | "\r\n")
- { parse_sharp_line(Lexing.lexeme lexbuf);
- linebeg := Lexing.lexeme_start lexbuf;
- Lexing.lexeme_end lexbuf }
- | [^ '\n' '\r'] *
- ('\n' | '\r' | "\r\n")
- { incr linenum;
- linebeg := Lexing.lexeme_start lexbuf;
- Lexing.lexeme_end lexbuf }
- | [^ '\n' '\r'] * eof
- { incr linenum;
- linebeg := Lexing.lexeme_start lexbuf;
- raise End_of_file }
-
-{
-
-let for_position file loc =
- let ic = open_in_bin file in
- let lb = Lexing.from_channel ic in
- filename := file;
- linenum := 1;
- linebeg := 0;
- begin try
- while skip_line lb <= loc do () done
- with End_of_file -> ()
- end;
- close_in ic;
- (!filename, !linenum - 1, !linebeg)
-
-}
diff --git a/parsing/location.ml b/parsing/location.ml
deleted file mode 100644
index 806754d779..0000000000
--- a/parsing/location.ml
+++ /dev/null
@@ -1,239 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Lexing
-
-type t = { loc_start: position; loc_end: position; loc_ghost: bool };;
-
-let none = { loc_start = dummy_pos; loc_end = dummy_pos; loc_ghost = true };;
-
-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 ""
-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 *)
-
-(* Highlight the location using standout mode. *)
-
-let highlight_terminfo ppf num_lines lb loc1 loc2 =
- (* 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 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 pos = loc1.loc_start.pos_cnum || pos = loc2.loc_start.pos_cnum then
- Terminfo.standout true;
- if pos = loc1.loc_end.pos_cnum || pos = loc2.loc_end.pos_cnum then
- Terminfo.standout false;
- let c = 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 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 *)
- print_string " ";
- let line = ref 0 in
- let pos_at_bol = ref 0 in
- for pos = 0 to end_pos do
- let c = lb.lex_buffer.[pos + pos0] in
- if c <> '\n' then begin
- if !line = !line_start && !line = !line_end then
- (* loc is on one line: print whole line *)
- print_char c
- else if !line = !line_start then
- (* first line of multiline loc: print ... before loc_start *)
- if pos < loc.loc_start.pos_cnum
- then print_char '.'
- else print_char c
- else if !line = !line_end then
- (* last line of multiline loc: print ... after loc_end *)
- if pos < loc.loc_end.pos_cnum
- then print_char c
- else print_char '.'
- else if !line > !line_start && !line < !line_end then
- (* intermediate line of multiline loc: print whole line *)
- print_char c
- end else begin
- if !line = !line_start && !line = !line_end then begin
- (* loc is on one line: underline location *)
- print_string "\n ";
- for i = !pos_at_bol to loc.loc_start.pos_cnum - 1 do
- print_char ' '
- done;
- for i = loc.loc_start.pos_cnum to loc.loc_end.pos_cnum - 1 do
- print_char '^'
- done
- end;
- if !line >= !line_start && !line <= !line_end then begin
- print_char '\n';
- if pos < loc.loc_end.pos_cnum then print_string " "
- end;
- incr line;
- pos_at_bol := pos + 1;
- end
- done
-
-(* Highlight the location using one of the supported modes. *)
-
-let rec highlight_locations ppf loc1 loc2 =
- match !status with
- Terminfo.Uninitialised ->
- status := Terminfo.setup stdout; highlight_locations ppf loc1 loc2
- | 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
- 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 loc1 loc2; true
- with Exit -> false
- end
-
-(* Print the location in some way or another *)
-
-open Format
-
-let reset () =
- num_loc_lines := 0
-
-let (msg_file, msg_line, msg_chars, msg_to, msg_colon, msg_head) =
- match Sys.os_type with
- | "MacOS" -> ("File \"", "\"; line ", "; characters ", " to ", "", "### ")
- | _ -> ("File \"", "\", line ", ", characters ", "-", ":", "")
-
-(* return file, line, char from the given position *)
-let get_pos_info pos =
- let (filename, linenum, linebeg) =
- if pos.pos_fname = "" && !input_name = "" then
- ("", -1, 0)
- else if pos.pos_fname = "" then
- Linenum.for_position !input_name pos.pos_cnum
- else
- (pos.pos_fname, pos.pos_lnum, pos.pos_bol)
- in
- (filename, linenum, pos.pos_cnum - linebeg)
-;;
-
-let print ppf loc =
- 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 = "" then begin
- if highlight_locations ppf loc none then () else
- fprintf ppf "Characters %i-%i:@."
- loc.loc_start.pos_cnum loc.loc_end.pos_cnum
- end else begin
- fprintf ppf "%s%s%s%i" msg_file file msg_line line;
- fprintf ppf "%s%i" msg_chars startchar;
- fprintf ppf "%s%i%s@.%s" msg_to endchar msg_colon msg_head;
- end
-
-let print_warning loc ppf w =
- if Warnings.is_active w then begin
- let printw ppf w =
- let n = Warnings.print ppf w in
- num_loc_lines := !num_loc_lines + n
- in
- fprintf ppf "%a" print loc;
- fprintf ppf "Warning: %a@." printw w;
- pp_print_flush ppf ();
- incr num_loc_lines;
- end
-;;
-
-let prerr_warning loc w = print_warning loc err_formatter w;;
-
-let echo_eof () =
- print_newline ();
- incr num_loc_lines
diff --git a/parsing/location.mli b/parsing/location.mli
deleted file mode 100644
index 25b1a88e1d..0000000000
--- a/parsing/location.mli
+++ /dev/null
@@ -1,54 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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 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
-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: formatter -> t -> unit
-val print_warning: t -> formatter -> Warnings.t -> unit
-val prerr_warning: t -> Warnings.t -> unit
-val echo_eof: unit -> unit
-val reset: unit -> unit
-
-val highlight_locations: formatter -> t -> t -> bool
diff --git a/parsing/longident.ml b/parsing/longident.ml
deleted file mode 100644
index 57652ea1af..0000000000
--- a/parsing/longident.ml
+++ /dev/null
@@ -1,38 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-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(l1, l2) -> Misc.fatal_error "Longident.flat"
-
-let flatten lid = flat [] lid
-
-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
deleted file mode 100644
index 7b4e943bff..0000000000
--- a/parsing/longident.mli
+++ /dev/null
@@ -1,23 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Long identifiers, used in parsetree. *)
-
-type t =
- Lident of string
- | Ldot of t * string
- | Lapply of t * t
-
-val flatten: t -> string list
-val parse: string -> t
diff --git a/parsing/parse.ml b/parsing/parse.ml
deleted file mode 100644
index ee91bea84e..0000000000
--- a/parsing/parse.ml
+++ /dev/null
@@ -1,64 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Entry points in the parser *)
-
-open Location
-
-(* 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
- let ast = parsing_fun Lexer.token lexbuf in
- Parsing.clear_parser();
- ast
- with
- | Lexer.Error(Lexer.Unterminated_comment, _) as err -> raise err
- | Lexer.Error(Lexer.Unterminated_string, _) as err -> raise err
- | Lexer.Error(Lexer.Unterminated_string_in_comment, _) as err -> raise err
- | Lexer.Error(Lexer.Illegal_character _, _) as err ->
- if !Location.input_name = "" then skip_phrase lexbuf;
- raise err
- | Syntaxerr.Error _ as err ->
- if !Location.input_name = "" then maybe_skip_phrase lexbuf;
- raise err
- | Parsing.Parse_error | Syntaxerr.Escape_error ->
- let loc = Location.curr lexbuf in
- if !Location.input_name = ""
- 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
diff --git a/parsing/parse.mli b/parsing/parse.mli
deleted file mode 100644
index 6b1a14c32d..0000000000
--- a/parsing/parse.mli
+++ /dev/null
@@ -1,21 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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
-
diff --git a/parsing/parser.mly b/parsing/parser.mly
deleted file mode 100644
index 67a815f4e3..0000000000
--- a/parsing/parser.mly
+++ /dev/null
@@ -1,1505 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* The parser definition */
-
-%{
-open Location
-open Asttypes
-open Longident
-open Parsetree
-
-let mktyp d =
- { ptyp_desc = d; ptyp_loc = symbol_rloc() }
-let mkpat d =
- { ppat_desc = d; ppat_loc = symbol_rloc() }
-let mkexp d =
- { pexp_desc = d; pexp_loc = symbol_rloc() }
-let mkmty d =
- { pmty_desc = d; pmty_loc = symbol_rloc() }
-let mksig d =
- { psig_desc = d; psig_loc = symbol_rloc() }
-let mkmod d =
- { pmod_desc = d; pmod_loc = symbol_rloc() }
-let mkstr d =
- { pstr_desc = d; pstr_loc = symbol_rloc() }
-let mkfield d =
- { pfield_desc = d; pfield_loc = symbol_rloc() }
-let mkclass d =
- { pcl_desc = d; pcl_loc = symbol_rloc() }
-let mkcty d =
- { pcty_desc = d; pcty_loc = symbol_rloc() }
-
-let reloc_pat x = { x with ppat_loc = symbol_rloc () };;
-let reloc_exp x = { x with pexp_loc = symbol_rloc () };;
-
-let mkoperator name pos =
- { pexp_desc = Pexp_ident(Lident name); pexp_loc = rhs_loc pos }
-
-(*
- Ghost expressions and patterns:
- expressions and patterns that do not appear explicitely in the
- source file they have the loc_ghost flag set to true.
- Then the profiler will not try to instrument them and the
- -stypes 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 = { pexp_desc = d; pexp_loc = symbol_gloc () };;
-let ghpat d = { ppat_desc = d; ppat_loc = symbol_gloc () };;
-let ghtyp d = { ptyp_desc = d; ptyp_loc = symbol_gloc () };;
-
-let mkassert e =
- match e with
- | {pexp_desc = Pexp_construct (Lident "false", None, false) } ->
- mkexp (Pexp_assertfalse)
- | _ -> mkexp (Pexp_assert (e))
-;;
-
-let mkinfix arg1 name arg2 =
- mkexp(Pexp_apply(mkoperator name 2, ["", arg1; "", arg2]))
-
-let neg_float_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(Const_int n) ->
- mkexp(Pexp_constant(Const_int(-n)))
- | "-", Pexp_constant(Const_int32 n) ->
- mkexp(Pexp_constant(Const_int32(Int32.neg n)))
- | "-", Pexp_constant(Const_int64 n) ->
- mkexp(Pexp_constant(Const_int64(Int64.neg n)))
- | "-", Pexp_constant(Const_nativeint n) ->
- mkexp(Pexp_constant(Const_nativeint(Nativeint.neg n)))
- | _, Pexp_constant(Const_float f) ->
- mkexp(Pexp_constant(Const_float(neg_float_string f)))
- | _ ->
- mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, ["", arg]))
-
-let rec mktailexp = function
- [] ->
- ghexp(Pexp_construct(Lident "[]", None, false))
- | e1 :: el ->
- let exp_el = mktailexp el in
- let l = {loc_start = e1.pexp_loc.loc_start;
- loc_end = exp_el.pexp_loc.loc_end;
- loc_ghost = true}
- in
- let arg = {pexp_desc = Pexp_tuple [e1; exp_el]; pexp_loc = l} in
- {pexp_desc = Pexp_construct(Lident "::", Some arg, false); pexp_loc = l}
-
-let rec mktailpat = function
- [] ->
- ghpat(Ppat_construct(Lident "[]", None, false))
- | p1 :: pl ->
- let pat_pl = mktailpat pl in
- let l = {loc_start = p1.ppat_loc.loc_start;
- loc_end = pat_pl.ppat_loc.loc_end;
- loc_ghost = true}
- in
- let arg = {ppat_desc = Ppat_tuple [p1; pat_pl]; ppat_loc = l} in
- {ppat_desc = Ppat_construct(Lident "::", Some arg, false); ppat_loc = l}
-
-let ghstrexp e =
- { pstr_desc = Pstr_eval e; pstr_loc = {e.pexp_loc with loc_ghost = true} }
-
-let array_function str name =
- Ldot(Lident str, (if !Clflags.fast then "unsafe_" ^ name else name))
-
-let rec deep_mkrangepat c1 c2 =
- if c1 = c2 then ghpat(Ppat_constant(Const_char c1)) else
- ghpat(Ppat_or(ghpat(Ppat_constant(Const_char c1)),
- deep_mkrangepat (Char.chr(Char.code c1 + 1)) c2))
-
-let rec mkrangepat c1 c2 =
- if c1 > c2 then mkrangepat c2 c1 else
- if c1 = c2 then mkpat(Ppat_constant(Const_char c1)) else
- reloc_pat (deep_mkrangepat c1 c2)
-
-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 bigarray_function str name =
- Ldot(Ldot(Lident "Bigarray", str), name)
-
-let bigarray_untuplify = function
- { pexp_desc = Pexp_tuple explist} -> explist
- | exp -> [exp]
-
-let bigarray_get arr arg =
- match bigarray_untuplify arg with
- [c1] ->
- mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" "get")),
- ["", arr; "", c1]))
- | [c1;c2] ->
- mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" "get")),
- ["", arr; "", c1; "", c2]))
- | [c1;c2;c3] ->
- mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" "get")),
- ["", arr; "", c1; "", c2; "", c3]))
- | coords ->
- mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "get")),
- ["", arr; "", ghexp(Pexp_array coords)]))
-
-let bigarray_set arr arg newval =
- match bigarray_untuplify arg with
- [c1] ->
- mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" "set")),
- ["", arr; "", c1; "", newval]))
- | [c1;c2] ->
- mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" "set")),
- ["", arr; "", c1; "", c2; "", newval]))
- | [c1;c2;c3] ->
- mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" "set")),
- ["", arr; "", c1; "", c2; "", c3; "", newval]))
- | coords ->
- mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "set")),
- ["", arr;
- "", ghexp(Pexp_array coords);
- "", newval]))
-%}
-
-/* Tokens */
-
-%token AMPERAMPER
-%token AMPERSAND
-%token AND
-%token AS
-%token ASSERT
-%token BACKQUOTE
-%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> 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 <int> INT
-%token <int32> INT32
-%token <int64> INT64
-%token <string> LABEL
-%token LAZY
-%token LBRACE
-%token LBRACELESS
-%token LBRACKET
-%token LBRACKETBAR
-%token LBRACKETLESS
-%token LESS
-%token LESSMINUS
-%token LET
-%token <string> LIDENT
-%token LPAREN
-%token MATCH
-%token METHOD
-%token MINUS
-%token MINUSDOT
-%token MINUSGREATER
-%token MODULE
-%token MUTABLE
-%token <nativeint> NATIVEINT
-%token NEW
-%token OBJECT
-%token OF
-%token OPEN
-%token <string> OPTLABEL
-%token OR
-/* %token PARSER */
-%token PLUS
-%token <string> PREFIXOP
-%token PRIVATE
-%token QUESTION
-%token QUESTIONQUESTION
-%token QUOTE
-%token RBRACE
-%token RBRACKET
-%token REC
-%token RPAREN
-%token SEMI
-%token SEMISEMI
-%token SHARP
-%token SIG
-%token STAR
-%token <string> 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
-
-/* 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) */
-%right COLONCOLON /* expr (e :: e :: e) */
-%left INFIXOP2 PLUS MINUS MINUSDOT /* expr (e OP e OP e) */
-%left INFIXOP3 STAR /* expr (e OP e OP e) */
-%right INFIXOP4 /* expr (e OP e OP e) */
-%nonassoc prec_unary_minus /* unary - */
-%nonassoc prec_constant_constructor /* cf. simple_expr (C versus C x) */
-%nonassoc prec_constr_appl /* above AS BAR COLONCOLON COMMA */
-%nonassoc below_SHARP
-%nonassoc SHARP /* simple_expr/toplevel_directive */
-%nonassoc below_DOT
-%nonassoc DOT
-/* Finally, the first tokens of simple_expr are above everything else. */
-%nonassoc BACKQUOTE BEGIN CHAR FALSE FLOAT INT INT32 INT64
- LBRACE LBRACELESS LBRACKET LBRACKETBAR LIDENT LPAREN
- NEW NATIVEINT PREFIXOP STRING TRUE UIDENT
-
-
-/* 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
-
-%%
-
-/* Entry points */
-
-implementation:
- structure EOF { $1 }
-;
-interface:
- signature EOF { List.rev $1 }
-;
-toplevel_phrase:
- top_structure SEMISEMI { Ptop_def $1 }
- | seq_expr SEMISEMI { Ptop_def[ghstrexp $1] }
- | toplevel_directive SEMISEMI { $1 }
- | EOF { raise End_of_file }
-;
-top_structure:
- structure_item { [$1] }
- | structure_item top_structure { $1 :: $2 }
-;
-use_file:
- use_file_tail { $1 }
- | seq_expr use_file_tail { Ptop_def[ghstrexp $1] :: $2 }
-;
-use_file_tail:
- EOF { [] }
- | SEMISEMI EOF { [] }
- | SEMISEMI seq_expr use_file_tail { Ptop_def[ghstrexp $2] :: $3 }
- | SEMISEMI structure_item use_file_tail { Ptop_def[$2] :: $3 }
- | SEMISEMI toplevel_directive use_file_tail { $2 :: $3 }
- | structure_item use_file_tail { Ptop_def[$1] :: $2 }
- | toplevel_directive use_file_tail { $1 :: $2 }
-;
-
-/* Module expressions */
-
-module_expr:
- mod_longident
- { mkmod(Pmod_ident $1) }
- | STRUCT structure END
- { mkmod(Pmod_structure($2)) }
- | STRUCT structure error
- { unclosed "struct" 1 "end" 3 }
- | FUNCTOR LPAREN UIDENT COLON module_type RPAREN MINUSGREATER module_expr
- { mkmod(Pmod_functor($3, $5, $8)) }
- | module_expr LPAREN module_expr RPAREN
- { mkmod(Pmod_apply($1, $3)) }
- | module_expr LPAREN module_expr error
- { unclosed "(" 2 ")" 4 }
- | 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 }
-;
-structure:
- structure_tail { $1 }
- | seq_expr structure_tail { ghstrexp $1 :: $2 }
-;
-structure_tail:
- /* empty */ { [] }
- | SEMISEMI { [] }
- | SEMISEMI seq_expr structure_tail { ghstrexp $2 :: $3 }
- | SEMISEMI structure_item structure_tail { $2 :: $3 }
- | structure_item structure_tail { $1 :: $2 }
-;
-structure_item:
- LET rec_flag let_bindings
- { match $3 with
- [{ppat_desc = Ppat_any}, exp] -> mkstr(Pstr_eval exp)
- | _ -> mkstr(Pstr_value($2, List.rev $3)) }
- | EXTERNAL val_ident_colon core_type EQUAL primitive_declaration
- { mkstr(Pstr_primitive($2, {pval_type = $3; pval_prim = $5})) }
- | TYPE type_declarations
- { mkstr(Pstr_type(List.rev $2)) }
- | EXCEPTION UIDENT constructor_arguments
- { mkstr(Pstr_exception($2, $3)) }
- | EXCEPTION UIDENT EQUAL constr_longident
- { mkstr(Pstr_exn_rebind($2, $4)) }
- | MODULE UIDENT module_binding
- { mkstr(Pstr_module($2, $3)) }
- | MODULE REC module_rec_bindings
- { mkstr(Pstr_recmodule(List.rev $3)) }
- | MODULE TYPE ident EQUAL module_type
- { mkstr(Pstr_modtype($3, $5)) }
- | OPEN mod_longident
- { mkstr(Pstr_open $2) }
- | CLASS class_declarations
- { mkstr(Pstr_class (List.rev $2)) }
- | CLASS TYPE class_type_declarations
- { mkstr(Pstr_class_type (List.rev $3)) }
- | INCLUDE module_expr
- { mkstr(Pstr_include $2) }
-;
-module_binding:
- EQUAL module_expr
- { $2 }
- | COLON module_type EQUAL module_expr
- { mkmod(Pmod_constraint($4, $2)) }
- | LPAREN UIDENT COLON module_type RPAREN module_binding
- { mkmod(Pmod_functor($2, $4, $6)) }
-;
-module_rec_bindings:
- module_rec_binding { [$1] }
- | module_rec_bindings AND module_rec_binding { $3 :: $1 }
-;
-module_rec_binding:
- UIDENT COLON module_type EQUAL module_expr { ($1, $3, $5) }
-;
-
-/* Module types */
-
-module_type:
- mty_longident
- { mkmty(Pmty_ident $1) }
- | SIG signature END
- { mkmty(Pmty_signature(List.rev $2)) }
- | SIG signature error
- { unclosed "sig" 1 "end" 3 }
- | FUNCTOR LPAREN UIDENT COLON module_type RPAREN MINUSGREATER module_type
- %prec below_WITH
- { mkmty(Pmty_functor($3, $5, $8)) }
- | module_type WITH with_constraints
- { mkmty(Pmty_with($1, List.rev $3)) }
- | LPAREN module_type RPAREN
- { $2 }
- | LPAREN module_type error
- { unclosed "(" 1 ")" 3 }
-;
-signature:
- /* empty */ { [] }
- | signature signature_item { $2 :: $1 }
- | signature signature_item SEMISEMI { $2 :: $1 }
-;
-signature_item:
- VAL val_ident_colon core_type
- { mksig(Psig_value($2, {pval_type = $3; pval_prim = []})) }
- | EXTERNAL val_ident_colon core_type EQUAL primitive_declaration
- { mksig(Psig_value($2, {pval_type = $3; pval_prim = $5})) }
- | TYPE type_declarations
- { mksig(Psig_type(List.rev $2)) }
- | EXCEPTION UIDENT constructor_arguments
- { mksig(Psig_exception($2, $3)) }
- | MODULE UIDENT module_declaration
- { mksig(Psig_module($2, $3)) }
- | MODULE REC module_rec_declarations
- { mksig(Psig_recmodule(List.rev $3)) }
- | MODULE TYPE ident
- { mksig(Psig_modtype($3, Pmodtype_abstract)) }
- | MODULE TYPE ident EQUAL module_type
- { mksig(Psig_modtype($3, Pmodtype_manifest $5)) }
- | OPEN mod_longident
- { mksig(Psig_open $2) }
- | INCLUDE module_type
- { mksig(Psig_include $2) }
- | CLASS class_descriptions
- { mksig(Psig_class (List.rev $2)) }
- | CLASS TYPE class_type_declarations
- { mksig(Psig_class_type (List.rev $3)) }
-;
-
-module_declaration:
- COLON module_type
- { $2 }
- | LPAREN UIDENT COLON module_type RPAREN module_declaration
- { mkmty(Pmty_functor($2, $4, $6)) }
-;
-module_rec_declarations:
- module_rec_declaration { [$1] }
- | module_rec_declarations AND module_rec_declaration { $3 :: $1 }
-;
-module_rec_declaration:
- UIDENT COLON module_type { ($1, $3) }
-;
-
-/* Class expressions */
-
-class_declarations:
- class_declarations AND class_declaration { $3 :: $1 }
- | class_declaration { [$1] }
-;
-class_declaration:
- virtual_flag class_type_parameters LIDENT class_fun_binding
- { let params, variance = List.split (fst $2) in
- {pci_virt = $1; pci_params = params, snd $2;
- pci_name = $3; pci_expr = $4; pci_variance = variance;
- pci_loc = symbol_rloc ()} }
-;
-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*/ { [], symbol_gloc () }
- | LBRACKET type_parameter_list RBRACKET { List.rev $2, symbol_rloc () }
-;
-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 class_fun_def
- { $2 }
- | class_simple_expr simple_labeled_expr_list
- { mkclass(Pcl_apply($1, List.rev $2)) }
- | LET rec_flag let_bindings IN class_expr
- { mkclass(Pcl_let ($2, List.rev $3, $5)) }
-;
-class_simple_expr:
- LBRACKET core_type_comma_list RBRACKET class_longident
- { mkclass(Pcl_constr($4, List.rev $2)) }
- | class_longident
- { mkclass(Pcl_constr($1, [])) }
- | OBJECT class_structure END
- { mkclass(Pcl_structure($2)) }
- | OBJECT class_structure error
- { unclosed "object" 1 "end" 3 }
- | 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
- { $1, 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 INHERIT class_expr parent_binder
- { Pcf_inher ($3, $4) :: $1 }
- | class_fields VAL value
- { Pcf_val $3 :: $1 }
- | class_fields virtual_method
- { Pcf_virt $2 :: $1 }
- | class_fields concrete_method
- { Pcf_meth $2 :: $1 }
- | class_fields CONSTRAINT constrain
- { Pcf_cstr $3 :: $1 }
- | class_fields INITIALIZER seq_expr
- { Pcf_init $3 :: $1 }
-;
-parent_binder:
- AS LIDENT
- { Some $2 }
- | /* empty */
- {None}
-;
-value:
- mutable_flag label EQUAL seq_expr
- { $2, $1, $4, symbol_rloc () }
- | mutable_flag label type_constraint EQUAL seq_expr
- { $2, $1, (let (t, t') = $3 in ghexp(Pexp_constraint($5, t, t'))),
- symbol_rloc () }
-;
-virtual_method:
- METHOD PRIVATE VIRTUAL label COLON poly_type
- { $4, Private, $6, symbol_rloc () }
- | METHOD VIRTUAL private_flag label COLON poly_type
- { $4, $3, $6, symbol_rloc () }
-;
-concrete_method :
- METHOD private_flag label strict_binding
- { $3, $2, ghexp(Pexp_poly ($4, None)), symbol_rloc () }
- | METHOD private_flag label COLON poly_type EQUAL seq_expr
- { $3, $2, ghexp(Pexp_poly($7,Some $5)), symbol_rloc () }
- | METHOD private_flag LABEL poly_type EQUAL seq_expr
- { $3, $2, ghexp(Pexp_poly($6,Some $4)), symbol_rloc () }
-;
-
-/* Class types */
-
-class_type:
- class_signature
- { $1 }
- | QUESTION LIDENT COLON simple_core_type_or_tuple MINUSGREATER class_type
- { mkcty(Pcty_fun("?" ^ $2 ,
- {ptyp_desc = Ptyp_constr(Lident "option", [$4]);
- ptyp_loc = $4.ptyp_loc},
- $6)) }
- | OPTLABEL simple_core_type_or_tuple MINUSGREATER class_type
- { mkcty(Pcty_fun("?" ^ $1 ,
- {ptyp_desc = Ptyp_constr(Lident "option", [$2]);
- ptyp_loc = $2.ptyp_loc},
- $4)) }
- | LIDENT COLON simple_core_type_or_tuple MINUSGREATER class_type
- { mkcty(Pcty_fun($1, $3, $5)) }
- | simple_core_type_or_tuple MINUSGREATER class_type
- { mkcty(Pcty_fun("", $1, $3)) }
-;
-class_signature:
- LBRACKET core_type_comma_list RBRACKET clty_longident
- { mkcty(Pcty_constr ($4, List.rev $2)) }
- | clty_longident
- { mkcty(Pcty_constr ($1, [])) }
- | OBJECT class_sig_body END
- { mkcty(Pcty_signature $2) }
- | OBJECT class_sig_body error
- { unclosed "object" 1 "end" 3 }
-;
-class_sig_body:
- class_self_type class_sig_fields
- { $1, List.rev $2 }
-;
-class_self_type:
- LPAREN core_type RPAREN
- { $2 }
- | /* empty */
- { mktyp(Ptyp_any) }
-;
-class_sig_fields:
- /* empty */ { [] }
- | class_sig_fields INHERIT class_signature { Pctf_inher $3 :: $1 }
- | class_sig_fields VAL value_type { Pctf_val $3 :: $1 }
- | class_sig_fields virtual_method { Pctf_virt $2 :: $1 }
- | class_sig_fields method_type { Pctf_meth $2 :: $1 }
- | class_sig_fields CONSTRAINT constrain { Pctf_cstr $3 :: $1 }
-;
-value_type:
- mutable_flag label COLON core_type
- { $2, $1, Some $4, symbol_rloc () }
-;
-method_type:
- METHOD private_flag label COLON poly_type
- { $3, $2, $5, symbol_rloc () }
-;
-constrain:
- core_type EQUAL core_type { $1, $3, symbol_rloc () }
-;
-class_descriptions:
- class_descriptions AND class_description { $3 :: $1 }
- | class_description { [$1] }
-;
-class_description:
- virtual_flag class_type_parameters LIDENT COLON class_type
- { let params, variance = List.split (fst $2) in
- {pci_virt = $1; pci_params = params, snd $2;
- pci_name = $3; pci_expr = $5; pci_variance = variance;
- pci_loc = symbol_rloc ()} }
-;
-class_type_declarations:
- class_type_declarations AND class_type_declaration { $3 :: $1 }
- | class_type_declaration { [$1] }
-;
-class_type_declaration:
- virtual_flag class_type_parameters LIDENT EQUAL class_signature
- { let params, variance = List.split (fst $2) in
- {pci_virt = $1; pci_params = params, snd $2;
- pci_name = $3; pci_expr = $5; pci_variance = variance;
- pci_loc = symbol_rloc ()} }
-;
-
-/* Core expressions */
-
-seq_expr:
- | expr %prec below_SEMI { $1 }
- | expr SEMI { reloc_exp $1 }
- | expr SEMI seq_expr { mkexp(Pexp_sequence($1, $3)) }
-;
-labeled_simple_pattern:
- QUESTION LPAREN label_let_pattern opt_default RPAREN
- { ("?" ^ fst $3, $4, snd $3) }
- | QUESTION label_var
- { ("?" ^ fst $2, None, snd $2) }
- | OPTLABEL LPAREN let_pattern opt_default RPAREN
- { ("?" ^ $1, $4, $3) }
- | OPTLABEL pattern_var
- { ("?" ^ $1, None, $2) }
- | TILDE LPAREN label_let_pattern RPAREN
- { (fst $3, None, snd $3) }
- | TILDE label_var
- { (fst $2, None, snd $2) }
- | LABEL simple_pattern
- { ($1, None, $2) }
- | simple_pattern
- { ("", None, $1) }
-;
-pattern_var:
- LIDENT { mkpat(Ppat_var $1) }
-;
-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 $1)) }
-;
-let_pattern:
- pattern
- { $1 }
- | pattern COLON core_type
- { mkpat(Ppat_constraint($1, $3)) }
-;
-expr:
- simple_expr %prec below_SHARP
- { $1 }
- | simple_expr simple_labeled_expr_list
- { mkexp(Pexp_apply($1, List.rev $2)) }
- | LET rec_flag let_bindings IN seq_expr
- { mkexp(Pexp_let($2, List.rev $3, $5)) }
- | LET MODULE UIDENT module_binding IN seq_expr
- { mkexp(Pexp_letmodule($3, $4, $6)) }
- | FUNCTION opt_bar match_cases
- { mkexp(Pexp_function("", None, List.rev $3)) }
- | FUN labeled_simple_pattern fun_def
- { let (l,o,p) = $2 in mkexp(Pexp_function(l, o, [p, $3])) }
- | MATCH seq_expr WITH opt_bar match_cases
- { mkexp(Pexp_match($2, List.rev $5)) }
- | TRY seq_expr WITH opt_bar match_cases
- { mkexp(Pexp_try($2, List.rev $5)) }
- | TRY seq_expr WITH error
- { syntax_error() }
- | expr_comma_list %prec below_COMMA
- { mkexp(Pexp_tuple(List.rev $1)) }
- | constr_longident simple_expr %prec below_SHARP
- { mkexp(Pexp_construct($1, Some $2, false)) }
- | name_tag simple_expr %prec below_SHARP
- { mkexp(Pexp_variant($1, Some $2)) }
- | IF seq_expr THEN expr ELSE expr
- { mkexp(Pexp_ifthenelse($2, $4, Some $6)) }
- | IF seq_expr THEN expr
- { mkexp(Pexp_ifthenelse($2, $4, None)) }
- | WHILE seq_expr DO seq_expr DONE
- { mkexp(Pexp_while($2, $4)) }
- | FOR val_ident EQUAL seq_expr direction_flag seq_expr DO seq_expr DONE
- { mkexp(Pexp_for($2, $4, $6, $5, $8)) }
- | expr COLONCOLON expr
- { mkexp(Pexp_construct(Lident "::",
- Some(ghexp(Pexp_tuple[$1;$3])),
- false)) }
- | 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 MINUS expr
- { mkinfix $1 "-" $3 }
- | expr MINUSDOT expr
- { mkinfix $1 "-." $3 }
- | expr STAR 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 }
- | simple_expr DOT label_longident LESSMINUS expr
- { mkexp(Pexp_setfield($1, $3, $5)) }
- | simple_expr DOT LPAREN seq_expr RPAREN LESSMINUS expr
- { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "Array" "set")),
- ["",$1; "",$4; "",$7])) }
- | simple_expr DOT LBRACKET seq_expr RBRACKET LESSMINUS expr
- { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "String" "set")),
- ["",$1; "",$4; "",$7])) }
- | simple_expr DOT LBRACE expr RBRACE LESSMINUS expr
- { bigarray_set $1 $4 $7 }
- | label LESSMINUS expr
- { mkexp(Pexp_setinstvar($1, $3)) }
- | ASSERT simple_expr %prec below_SHARP
- { mkassert $2 }
- | LAZY simple_expr %prec below_SHARP
- { mkexp (Pexp_lazy ($2)) }
- | OBJECT class_structure END
- { mkexp (Pexp_object($2)) }
- | OBJECT class_structure error
- { unclosed "object" 1 "end" 3 }
-;
-simple_expr:
- val_longident
- { mkexp(Pexp_ident $1) }
- | constant
- { mkexp(Pexp_constant $1) }
- | constr_longident %prec prec_constant_constructor
- { mkexp(Pexp_construct($1, None, false)) }
- | 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 seq_expr END
- { reloc_exp $2 }
- | BEGIN END
- { mkexp (Pexp_construct (Lident "()", None, false)) }
- | BEGIN seq_expr error
- { unclosed "begin" 1 "end" 3 }
- | LPAREN seq_expr type_constraint RPAREN
- { let (t, t') = $3 in mkexp(Pexp_constraint($2, t, t')) }
- | simple_expr DOT label_longident
- { mkexp(Pexp_field($1, $3)) }
- | simple_expr DOT LPAREN seq_expr RPAREN
- { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "Array" "get")),
- ["",$1; "",$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")),
- ["",$1; "",$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 "}" 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 []) }
- | LBRACKET expr_semi_list opt_semi RBRACKET
- { reloc_exp (mktailexp (List.rev $2)) }
- | LBRACKET expr_semi_list opt_semi error
- { unclosed "[" 1 "]" 4 }
- | PREFIXOP simple_expr
- { mkexp(Pexp_apply(mkoperator $1 1, ["",$2])) }
- | NEW class_longident
- { mkexp(Pexp_new($2)) }
- | LBRACELESS field_expr_list opt_semi GREATERRBRACE
- { mkexp(Pexp_override(List.rev $2)) }
- | LBRACELESS field_expr_list opt_semi error
- { unclosed "{<" 1 ">}" 4 }
- | LBRACELESS GREATERRBRACE
- { mkexp(Pexp_override []) }
- | simple_expr SHARP label
- { mkexp(Pexp_send($1, $3)) }
-;
-simple_labeled_expr_list:
- labeled_simple_expr
- { [$1] }
- | simple_labeled_expr_list labeled_simple_expr
- { $2 :: $1 }
-;
-labeled_simple_expr:
- simple_expr %prec below_SHARP
- { ("", $1) }
- | label_expr
- { $1 }
-;
-label_expr:
- LABEL simple_expr %prec below_SHARP
- { ($1, $2) }
- | TILDE label_ident
- { $2 }
- | QUESTION label_ident
- { ("?" ^ fst $2, snd $2) }
- | OPTLABEL simple_expr %prec below_SHARP
- { ("?" ^ $1, $2) }
-;
-label_ident:
- LIDENT { ($1, mkexp(Pexp_ident(Lident $1))) }
-;
-let_bindings:
- let_binding { [$1] }
- | let_bindings AND let_binding { $3 :: $1 }
-;
-let_binding:
- val_ident fun_binding
- { ({ppat_desc = Ppat_var $1; ppat_loc = rhs_loc 1}, $2) }
- | pattern EQUAL seq_expr
- { ($1, $3) }
-;
-fun_binding:
- strict_binding
- { $1 }
- | type_constraint EQUAL seq_expr
- { let (t, t') = $1 in ghexp(Pexp_constraint($3, t, t')) }
-;
-strict_binding:
- EQUAL seq_expr
- { $2 }
- | labeled_simple_pattern fun_binding
- { let (l, o, p) = $1 in ghexp(Pexp_function(l, o, [p, $2])) }
-;
-match_cases:
- pattern match_action { [$1, $2] }
- | match_cases BAR pattern match_action { ($3, $4) :: $1 }
-;
-fun_def:
- match_action { $1 }
- | labeled_simple_pattern fun_def
- { let (l,o,p) = $1 in ghexp(Pexp_function(l, o, [p, $2])) }
-;
-match_action:
- MINUSGREATER seq_expr { $2 }
- | WHEN seq_expr MINUSGREATER seq_expr { mkexp(Pexp_when($2, $4)) }
-;
-expr_comma_list:
- expr_comma_list COMMA expr { $3 :: $1 }
- | expr COMMA expr { [$3; $1] }
-;
-record_expr:
- simple_expr WITH lbl_expr_list opt_semi { (Some $1, List.rev $3) }
- | lbl_expr_list opt_semi { (None, List.rev $1) }
-;
-lbl_expr_list:
- label_longident EQUAL expr
- { [$1,$3] }
- | lbl_expr_list SEMI label_longident EQUAL expr
- { ($3, $5) :: $1 }
-;
-field_expr_list:
- label EQUAL expr
- { [$1,$3] }
- | field_expr_list SEMI label EQUAL expr
- { ($3, $5) :: $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() }
-;
-
-/* Patterns */
-
-pattern:
- simple_pattern
- { $1 }
- | pattern AS val_ident
- { mkpat(Ppat_alias($1, $3)) }
- | pattern_comma_list %prec below_COMMA
- { mkpat(Ppat_tuple(List.rev $1)) }
- | constr_longident pattern %prec prec_constr_appl
- { mkpat(Ppat_construct($1, Some $2, false)) }
- | name_tag pattern %prec prec_constr_appl
- { mkpat(Ppat_variant($1, Some $2)) }
- | pattern COLONCOLON pattern
- { mkpat(Ppat_construct(Lident "::", Some(ghpat(Ppat_tuple[$1;$3])),
- false)) }
- | pattern BAR pattern
- { mkpat(Ppat_or($1, $3)) }
-;
-simple_pattern:
- val_ident %prec below_EQUAL
- { mkpat(Ppat_var $1) }
- | UNDERSCORE
- { mkpat(Ppat_any) }
- | signed_constant
- { mkpat(Ppat_constant $1) }
- | CHAR DOTDOT CHAR
- { mkrangepat $1 $3 }
- | constr_longident
- { mkpat(Ppat_construct($1, None, false)) }
- | name_tag
- { mkpat(Ppat_variant($1, None)) }
- | SHARP type_longident
- { mkpat(Ppat_type $2) }
- | LBRACE lbl_pattern_list opt_semi RBRACE
- { mkpat(Ppat_record(List.rev $2)) }
- | LBRACE lbl_pattern_list opt_semi error
- { unclosed "{" 1 "}" 4 }
- | LBRACKET pattern_semi_list opt_semi RBRACKET
- { reloc_pat (mktailpat (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 }
- | 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 }
-;
-
-pattern_comma_list:
- pattern_comma_list COMMA pattern { $3 :: $1 }
- | pattern COMMA pattern { [$3; $1] }
-;
-pattern_semi_list:
- pattern { [$1] }
- | pattern_semi_list SEMI pattern { $3 :: $1 }
-;
-lbl_pattern_list:
- label_longident EQUAL pattern { [($1, $3)] }
- | lbl_pattern_list SEMI label_longident EQUAL pattern { ($3, $5) :: $1 }
-;
-
-/* Primitive declarations */
-
-primitive_declaration:
- STRING { [$1] }
- | STRING primitive_declaration { $1 :: $2 }
-;
-
-/* Type declarations */
-
-type_declarations:
- type_declaration { [$1] }
- | type_declarations AND type_declaration { $3 :: $1 }
-;
-
-type_declaration:
- type_parameters LIDENT type_kind constraints
- { let (params, variance) = List.split $1 in
- let (kind, manifest) = $3 in
- ($2, {ptype_params = params;
- ptype_cstrs = List.rev $4;
- ptype_kind = kind;
- ptype_manifest = manifest;
- ptype_variance = variance;
- ptype_loc = symbol_rloc()}) }
-;
-constraints:
- constraints CONSTRAINT constrain { $3 :: $1 }
- | /* empty */ { [] }
-;
-type_kind:
- /*empty*/
- { (Ptype_abstract, None) }
- | EQUAL core_type
- { (Ptype_abstract, Some $2) }
- | EQUAL constructor_declarations
- { (Ptype_variant(List.rev $2, Public), None) }
- | EQUAL PRIVATE constructor_declarations
- { (Ptype_variant(List.rev $3, Private), None) }
- | EQUAL private_flag BAR constructor_declarations
- { (Ptype_variant(List.rev $4, $2), None) }
- | EQUAL private_flag LBRACE label_declarations opt_semi RBRACE
- { (Ptype_record(List.rev $4, $2), None) }
- | EQUAL core_type EQUAL private_flag opt_bar constructor_declarations
- { (Ptype_variant(List.rev $6, $4), Some $2) }
- | EQUAL core_type EQUAL private_flag LBRACE label_declarations opt_semi RBRACE
- { (Ptype_record(List.rev $6, $4), Some $2) }
-;
-type_parameters:
- /*empty*/ { [] }
- | type_parameter { [$1] }
- | LPAREN type_parameter_list RPAREN { List.rev $2 }
-;
-type_parameter:
- type_variance QUOTE ident { $3, $1 }
-;
-type_variance:
- /* empty */ { false, false }
- | PLUS { true, false }
- | MINUS { false, true }
-;
-type_parameter_list:
- type_parameter { [$1] }
- | type_parameter_list COMMA type_parameter { $3 :: $1 }
-;
-constructor_declarations:
- constructor_declaration { [$1] }
- | constructor_declarations BAR constructor_declaration { $3 :: $1 }
-;
-constructor_declaration:
- constr_ident constructor_arguments { ($1, $2) }
-;
-constructor_arguments:
- /*empty*/ { [] }
- | OF core_type_list { List.rev $2 }
-;
-label_declarations:
- label_declaration { [$1] }
- | label_declarations SEMI label_declaration { $3 :: $1 }
-;
-label_declaration:
- mutable_flag label COLON poly_type { ($2, $1, $4) }
-;
-
-/* "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 EQUAL core_type constraints
- { let params, variance = List.split $2 in
- ($3, Pwith_type {ptype_params = params;
- ptype_cstrs = List.rev $6;
- ptype_kind = Ptype_abstract;
- ptype_manifest = Some $5;
- ptype_variance = variance;
- ptype_loc = symbol_rloc()}) }
- /* used label_longident instead of type_longident to disallow
- functor applications in type path */
- | MODULE mod_longident EQUAL mod_ext_longident
- { ($2, Pwith_module $4) }
-;
-
-/* Polymorphic types */
-
-typevar_list:
- QUOTE ident { [$2] }
- | typevar_list QUOTE ident { $3 :: $1 }
-;
-poly_type:
- core_type
- { mktyp(Ptyp_poly([], $1)) }
- | typevar_list DOT core_type
- { mktyp(Ptyp_poly(List.rev $1, $3)) }
-;
-
-/* Core types */
-
-core_type:
- core_type2
- { $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
- { mktyp(Ptyp_arrow("?" ^ $2 ,
- {ptyp_desc = Ptyp_constr(Lident "option", [$4]);
- ptyp_loc = $4.ptyp_loc}, $6)) }
- | OPTLABEL core_type2 MINUSGREATER core_type2
- { mktyp(Ptyp_arrow("?" ^ $1 ,
- {ptyp_desc = Ptyp_constr(Lident "option", [$2]);
- ptyp_loc = $2.ptyp_loc}, $4)) }
- | LIDENT COLON core_type2 MINUSGREATER core_type2
- { mktyp(Ptyp_arrow($1, $3, $5)) }
- | core_type2 MINUSGREATER core_type2
- { mktyp(Ptyp_arrow("", $1, $3)) }
-;
-
-simple_core_type:
- simple_core_type2 %prec below_SHARP
- { $1 }
- | LPAREN core_type_comma_list RPAREN %prec below_SHARP
- { 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($1, [])) }
- | simple_core_type2 type_longident
- { mktyp(Ptyp_constr($2, [$1])) }
- | LPAREN core_type_comma_list RPAREN type_longident
- { mktyp(Ptyp_constr($4, List.rev $2)) }
- | LESS meth_list GREATER
- { mktyp(Ptyp_object $2) }
- | LESS GREATER
- { mktyp(Ptyp_object []) }
- | SHARP class_longident opt_present
- { mktyp(Ptyp_class($2, [], $3)) }
- | simple_core_type2 SHARP class_longident opt_present
- { mktyp(Ptyp_class($3, [$1], $4)) }
- | LPAREN core_type_comma_list RPAREN SHARP class_longident opt_present
- { mktyp(Ptyp_class($5, List.rev $2, $6)) }
- | LBRACKET tag_field RBRACKET
- { mktyp(Ptyp_variant([$2], true, None)) }
- | LBRACKET BAR row_field_list RBRACKET
- { mktyp(Ptyp_variant(List.rev $3, true, None)) }
- | LBRACKET row_field BAR row_field_list RBRACKET
- { mktyp(Ptyp_variant($2 :: List.rev $4, true, None)) }
- | LBRACKET GREATER opt_bar row_field_list RBRACKET
- { mktyp(Ptyp_variant(List.rev $4, false, None)) }
- | LBRACKET GREATER RBRACKET
- { mktyp(Ptyp_variant([], false, None)) }
- | LBRACKETLESS opt_bar row_field_list RBRACKET
- { mktyp(Ptyp_variant(List.rev $3, true, Some [])) }
- | LBRACKETLESS opt_bar row_field_list GREATER name_tag_list RBRACKET
- { mktyp(Ptyp_variant(List.rev $3, true, Some (List.rev $5))) }
-;
-row_field_list:
- row_field { [$1] }
- | row_field_list BAR row_field { $3 :: $1 }
-;
-row_field:
- tag_field { $1 }
- | simple_core_type2 { Rinherit $1 }
-;
-tag_field:
- name_tag OF opt_ampersand amper_type_list
- { Rtag ($1, $3, List.rev $4) }
- | name_tag
- { Rtag ($1, true, []) }
-;
-opt_ampersand:
- AMPERSAND { true }
- | /* empty */ { false }
-;
-amper_type_list:
- core_type { [$1] }
- | amper_type_list AMPERSAND core_type { $3 :: $1 }
-;
-opt_present:
- LBRACKET GREATER name_tag_list RBRACKET { List.rev $3 }
- | /* empty */ { [] }
-;
-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 { $1 :: $3 }
- | field opt_semi { [$1] }
- | DOTDOT { [mkfield Pfield_var] }
-;
-field:
- label COLON poly_type { mkfield(Pfield($1, $3)) }
-;
-label:
- LIDENT { $1 }
-;
-
-/* Constants */
-
-constant:
- INT { Const_int $1 }
- | CHAR { Const_char $1 }
- | STRING { Const_string $1 }
- | FLOAT { Const_float $1 }
- | INT32 { Const_int32 $1 }
- | INT64 { Const_int64 $1 }
- | NATIVEINT { Const_nativeint $1 }
-;
-signed_constant:
- constant { $1 }
- | MINUS INT { Const_int(- $2) }
- | MINUS FLOAT { Const_float("-" ^ $2) }
- | MINUS INT32 { Const_int32(Int32.neg $2) }
- | MINUS INT64 { Const_int64(Int64.neg $2) }
- | MINUS NATIVEINT { Const_nativeint(Nativeint.neg $2) }
-;
-/* Identifiers and long identifiers */
-
-ident:
- UIDENT { $1 }
- | LIDENT { $1 }
-;
-val_ident:
- LIDENT { $1 }
- | LPAREN operator RPAREN { $2 }
-;
-val_ident_colon:
- LIDENT COLON { $1 }
- | LPAREN operator RPAREN COLON { $2 }
- | LABEL { $1 }
-;
-operator:
- PREFIXOP { $1 }
- | INFIXOP0 { $1 }
- | INFIXOP1 { $1 }
- | INFIXOP2 { $1 }
- | INFIXOP3 { $1 }
- | INFIXOP4 { $1 }
- | PLUS { "+" }
- | MINUS { "-" }
- | MINUSDOT { "-." }
- | STAR { "*" }
- | EQUAL { "=" }
- | LESS { "<" }
- | GREATER { ">" }
- | OR { "or" }
- | BARBAR { "||" }
- | AMPERSAND { "&" }
- | AMPERAMPER { "&&" }
- | COLONEQUAL { ":=" }
-;
-constr_ident:
- UIDENT { $1 }
-/* | LBRACKET RBRACKET { "[]" } */
- | LPAREN RPAREN { "()" }
- | COLONCOLON { "::" }
- | 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:
- SHARP ident { Ptop_dir($2, Pdir_none) }
- | SHARP ident STRING { Ptop_dir($2, Pdir_string $3) }
- | SHARP ident INT { Ptop_dir($2, Pdir_int $3) }
- | SHARP ident val_longident { Ptop_dir($2, Pdir_ident $3) }
- | SHARP ident FALSE { Ptop_dir($2, Pdir_bool false) }
- | SHARP ident TRUE { Ptop_dir($2, Pdir_bool true) }
-;
-
-/* Miscellaneous */
-
-name_tag:
- BACKQUOTE ident { $2 }
-;
-rec_flag:
- /* empty */ { Nonrecursive }
- | REC { Recursive }
-;
-direction_flag:
- TO { Upto }
- | DOWNTO { Downto }
-;
-private_flag:
- /* empty */ { Public }
- | PRIVATE { Private }
-;
-mutable_flag:
- /* empty */ { Immutable }
- | MUTABLE { Mutable }
-;
-virtual_flag:
- /* empty */ { Concrete }
- | VIRTUAL { Virtual }
-;
-opt_bar:
- /* empty */ { () }
- | BAR { () }
-;
-opt_semi:
- | /* empty */ { () }
- | SEMI { () }
-;
-subtractive:
- | MINUS { "-" }
- | MINUSDOT { "-." }
-;
-%%
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
deleted file mode 100644
index d0db6b8483..0000000000
--- a/parsing/parsetree.mli
+++ /dev/null
@@ -1,272 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Abstract syntax tree produced by parsing *)
-
-open Asttypes
-
-(* Type expressions for the core language *)
-
-type core_type =
- { ptyp_desc: core_type_desc;
- ptyp_loc: Location.t }
-
-and core_type_desc =
- Ptyp_any
- | Ptyp_var of string
- | Ptyp_arrow of label * core_type * core_type
- | Ptyp_tuple of core_type list
- | Ptyp_constr of Longident.t * core_type list
- | Ptyp_object of core_field_type list
- | Ptyp_class of Longident.t * core_type list * label list
- | Ptyp_alias of core_type * string
- | Ptyp_variant of row_field list * bool * label list option
- | Ptyp_poly of string list * core_type
-
-and core_field_type =
- { pfield_desc: core_field_desc;
- pfield_loc: Location.t }
-
-and core_field_desc =
- Pfield of string * core_type
- | Pfield_var
-
-and row_field =
- Rtag of label * bool * core_type list
- | Rinherit of core_type
-
-(* XXX Type expressions for the class language *)
-
-type 'a class_infos =
- { pci_virt: virtual_flag;
- pci_params: string list * Location.t;
- pci_name: string;
- pci_expr: 'a;
- pci_variance: (bool * bool) list;
- pci_loc: Location.t }
-
-(* Value expressions for the core language *)
-
-type pattern =
- { ppat_desc: pattern_desc;
- ppat_loc: Location.t }
-
-and pattern_desc =
- Ppat_any
- | Ppat_var of string
- | Ppat_alias of pattern * string
- | Ppat_constant of constant
- | Ppat_tuple of pattern list
- | Ppat_construct of Longident.t * pattern option * bool
- | Ppat_variant of label * pattern option
- | Ppat_record of (Longident.t * pattern) list
- | Ppat_array of pattern list
- | Ppat_or of pattern * pattern
- | Ppat_constraint of pattern * core_type
- | Ppat_type of Longident.t
-
-type expression =
- { pexp_desc: expression_desc;
- pexp_loc: Location.t }
-
-and expression_desc =
- Pexp_ident of Longident.t
- | Pexp_constant of constant
- | Pexp_let of rec_flag * (pattern * expression) list * expression
- | Pexp_function of label * expression option * (pattern * expression) list
- | Pexp_apply of expression * (label * expression) list
- | Pexp_match of expression * (pattern * expression) list
- | Pexp_try of expression * (pattern * expression) list
- | Pexp_tuple of expression list
- | Pexp_construct of Longident.t * expression option * bool
- | Pexp_variant of label * expression option
- | Pexp_record of (Longident.t * expression) list * expression option
- | Pexp_field of expression * Longident.t
- | Pexp_setfield of expression * Longident.t * expression
- | Pexp_array of expression list
- | Pexp_ifthenelse of expression * expression * expression option
- | Pexp_sequence of expression * expression
- | Pexp_while of expression * expression
- | Pexp_for of string * expression * expression * direction_flag * expression
- | Pexp_constraint of expression * core_type option * core_type option
- | Pexp_when of expression * expression
- | Pexp_send of expression * string
- | Pexp_new of Longident.t
- | Pexp_setinstvar of string * expression
- | Pexp_override of (string * expression) list
- | Pexp_letmodule of string * module_expr * expression
- | Pexp_assert of expression
- | Pexp_assertfalse
- | Pexp_lazy of expression
- | Pexp_poly of expression * core_type option
- | Pexp_object of class_structure
-
-(* Value descriptions *)
-
-and value_description =
- { pval_type: core_type;
- pval_prim: string list }
-
-(* Type declarations *)
-
-and type_declaration =
- { ptype_params: string list;
- ptype_cstrs: (core_type * core_type * Location.t) list;
- ptype_kind: type_kind;
- ptype_manifest: core_type option;
- ptype_variance: (bool * bool) list;
- ptype_loc: Location.t }
-
-and type_kind =
- Ptype_abstract
- | Ptype_variant of (string * core_type list) list * private_flag
- | Ptype_record of (string * mutable_flag * core_type) list * private_flag
-
-and exception_declaration = core_type list
-
-(* Type expressions for the class language *)
-
-and class_type =
- { pcty_desc: class_type_desc;
- pcty_loc: Location.t }
-
-and class_type_desc =
- Pcty_constr of Longident.t * core_type list
- | Pcty_signature of class_signature
- | Pcty_fun of label * core_type * class_type
-
-and class_signature = core_type * class_type_field list
-
-and class_type_field =
- Pctf_inher of class_type
- | Pctf_val of (string * mutable_flag * core_type option * Location.t)
- | Pctf_virt of (string * private_flag * core_type * Location.t)
- | Pctf_meth of (string * private_flag * core_type * Location.t)
- | Pctf_cstr of (core_type * core_type * Location.t)
-
-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 }
-
-and class_expr_desc =
- Pcl_constr of Longident.t * core_type list
- | Pcl_structure of class_structure
- | Pcl_fun of label * expression option * pattern * class_expr
- | Pcl_apply of class_expr * (label * expression) list
- | Pcl_let of rec_flag * (pattern * expression) list * class_expr
- | Pcl_constraint of class_expr * class_type
-
-and class_structure = pattern * class_field list
-
-and class_field =
- Pcf_inher of class_expr * string option
- | Pcf_val of (string * mutable_flag * expression * Location.t)
- | Pcf_virt of (string * private_flag * core_type * Location.t)
- | Pcf_meth of (string * private_flag * expression * Location.t)
- | Pcf_cstr of (core_type * core_type * Location.t)
- | Pcf_let of rec_flag * (pattern * expression) list * Location.t
- | Pcf_init of expression
-
-and class_declaration = class_expr class_infos
-
-(* Type expressions for the module language *)
-
-and module_type =
- { pmty_desc: module_type_desc;
- pmty_loc: Location.t }
-
-and module_type_desc =
- Pmty_ident of Longident.t
- | Pmty_signature of signature
- | Pmty_functor of string * module_type * module_type
- | Pmty_with of module_type * (Longident.t * with_constraint) list
-
-and signature = signature_item list
-
-and signature_item =
- { psig_desc: signature_item_desc;
- psig_loc: Location.t }
-
-and signature_item_desc =
- Psig_value of string * value_description
- | Psig_type of (string * type_declaration) list
- | Psig_exception of string * exception_declaration
- | Psig_module of string * module_type
- | Psig_recmodule of (string * module_type) list
- | Psig_modtype of string * modtype_declaration
- | Psig_open of Longident.t
- | Psig_include of module_type
- | Psig_class of class_description list
- | Psig_class_type of class_type_declaration list
-
-and modtype_declaration =
- Pmodtype_abstract
- | Pmodtype_manifest of module_type
-
-and with_constraint =
- Pwith_type of type_declaration
- | Pwith_module of Longident.t
-
-(* Value expressions for the module language *)
-
-and module_expr =
- { pmod_desc: module_expr_desc;
- pmod_loc: Location.t }
-
-and module_expr_desc =
- Pmod_ident of Longident.t
- | Pmod_structure of structure
- | Pmod_functor of string * module_type * module_expr
- | Pmod_apply of module_expr * module_expr
- | Pmod_constraint of module_expr * module_type
-
-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
- | Pstr_value of rec_flag * (pattern * expression) list
- | Pstr_primitive of string * value_description
- | Pstr_type of (string * type_declaration) list
- | Pstr_exception of string * exception_declaration
- | Pstr_exn_rebind of string * Longident.t
- | Pstr_module of string * module_expr
- | Pstr_recmodule of (string * module_type * module_expr) list
- | Pstr_modtype of string * module_type
- | Pstr_open of Longident.t
- | Pstr_class of class_declaration list
- | Pstr_class_type of class_type_declaration list
- | Pstr_include of module_expr
-
-(* Toplevel phrases *)
-
-type toplevel_phrase =
- Ptop_def of structure
- | Ptop_dir of string * directive_argument
-
-and directive_argument =
- Pdir_none
- | Pdir_string of string
- | Pdir_int of int
- | Pdir_ident of Longident.t
- | Pdir_bool of bool
diff --git a/parsing/printast.ml b/parsing/printast.ml
deleted file mode 100644
index 340917155f..0000000000
--- a/parsing/printast.ml
+++ /dev/null
@@ -1,684 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Damien Doligez, projet Para, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Asttypes;;
-open Format;;
-open Lexing;;
-open Location;;
-open Parsetree;;
-
-let fmt_position f l =
- if l.pos_fname = "" && l.pos_lnum = 1
- then fprintf f "%d" l.pos_cnum
- else 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;;
-
-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) -> fprintf f "Const_string %S" s;
- | 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_rec_flag f x =
- match x with
- | Nonrecursive -> fprintf f "Nonrec";
- | Recursive -> fprintf f "Rec";
- | Default -> fprintf f "Default";
-;;
-
-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 = List.iter (f i ppf) l;;
-
-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 bool i ppf x = line i ppf "%s\n" (string_of_bool x);;
-let label i ppf x = line i ppf "label=\"%s\"\n" x;;
-
-let rec core_type i ppf x =
- line i ppf "core_type %a\n" fmt_location x.ptyp_loc;
- 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";
- string 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 li;
- list i core_type ppf l;
- | Ptyp_variant (l, closed, low) ->
- line i ppf "Ptyp_variant closed=%s\n" (string_of_bool closed);
- list i label_x_bool_x_core_type_list ppf l;
- option i (fun i -> list i string) ppf low
- | Ptyp_object (l) ->
- line i ppf "Ptyp_object\n";
- list i core_field_type ppf l;
- | Ptyp_class (li, l, low) ->
- line i ppf "Ptyp_class %a\n" fmt_longident li;
- list i core_type ppf l;
- list i string ppf low
- | 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)) sl;
- core_type i ppf ct;
-
-and core_field_type i ppf x =
- line i ppf "core_field_type %a\n" fmt_location x.pfield_loc;
- let i = i+1 in
- match x.pfield_desc with
- | Pfield (s, ct) ->
- line i ppf "Pfield \"%s\"\n" s;
- core_type i ppf ct;
- | Pfield_var -> line i ppf "Pfield_var\n";
-
-and pattern i ppf x =
- line i ppf "pattern %a\n" fmt_location x.ppat_loc;
- 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 \"%s\"\n" s;
- | Ppat_alias (p, s) ->
- line i ppf "Ppat_alias \"%s\"\n" s;
- pattern i ppf p;
- | Ppat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c;
- | Ppat_tuple (l) ->
- line i ppf "Ppat_tuple\n";
- list i pattern ppf l;
- | Ppat_construct (li, po, b) ->
- line i ppf "Ppat_construct %a\n" fmt_longident li;
- option i pattern ppf po;
- bool i ppf b;
- | Ppat_variant (l, po) ->
- line i ppf "Ppat_variant \"%s\"\n" l;
- option i pattern ppf po;
- | Ppat_record (l) ->
- line i ppf "Ppat_record\n";
- 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_constraint (p, ct) ->
- line i ppf "Ppat_constraint";
- pattern i ppf p;
- core_type i ppf ct;
- | Ppat_type li ->
- line i ppf "PPat_type";
- longident i ppf li
-
-and expression i ppf x =
- line i ppf "expression %a\n" fmt_location x.pexp_loc;
- let i = i+1 in
- match x.pexp_desc with
- | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident 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 pattern_x_expression_def ppf l;
- expression i ppf e;
- | Pexp_function (p, eo, l) ->
- line i ppf "Pexp_function \"%s\"\n" p;
- option i expression ppf eo;
- list i pattern_x_expression_case ppf l;
- | 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 pattern_x_expression_case ppf l;
- | Pexp_try (e, l) ->
- line i ppf "Pexp_try\n";
- expression i ppf e;
- list i pattern_x_expression_case ppf l;
- | Pexp_tuple (l) ->
- line i ppf "Pexp_tuple\n";
- list i expression ppf l;
- | Pexp_construct (li, eo, b) ->
- line i ppf "Pexp_construct %a\n" fmt_longident li;
- option i expression ppf eo;
- bool i ppf b;
- | 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 i ppf li;
- | Pexp_setfield (e1, li, e2) ->
- line i ppf "Pexp_setfield\n";
- expression i ppf e1;
- longident 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 (s, e1, e2, df, e3) ->
- line i ppf "Pexp_for \"%s\" %a\n" s fmt_direction_flag df;
- expression i ppf e1;
- expression i ppf e2;
- expression i ppf e3;
- | Pexp_constraint (e, cto1, cto2) ->
- line i ppf "Pexp_constraint\n";
- expression i ppf e;
- option i core_type ppf cto1;
- option i core_type ppf cto2;
- | Pexp_when (e1, e2) ->
- line i ppf "Pexp_when\n";
- expression i ppf e1;
- expression i ppf e2;
- | Pexp_send (e, s) ->
- line i ppf "Pexp_send \"%s\"\n" s;
- expression i ppf e;
- | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident li;
- | Pexp_setinstvar (s, e) ->
- line i ppf "Pexp_setinstvar \"%s\"\n" 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 \"%s\"\n" s;
- module_expr i ppf me;
- expression i ppf e;
- | Pexp_assert (e) ->
- line i ppf "Pexp_assert";
- expression i ppf e;
- | Pexp_assertfalse ->
- line i ppf "Pexp_assertfalse";
- | Pexp_lazy (e) ->
- line i ppf "Pexp_lazy";
- 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";
- class_structure i ppf s
-
-and value_description i ppf x =
- line i ppf "value_description\n";
- core_type (i+1) ppf x.pval_type;
- list (i+1) string ppf x.pval_prim;
-
-and type_declaration i ppf x =
- line i ppf "type_declaration %a\n" fmt_location x.ptype_loc;
- let i = i+1 in
- line i ppf "ptype_params =\n";
- list (i+1) string 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_manifest =\n";
- option (i+1) core_type ppf x.ptype_manifest;
-
-and type_kind i ppf x =
- match x with
- | Ptype_abstract ->
- line i ppf "Ptype_abstract\n"
- | Ptype_variant (l, priv) ->
- line i ppf "Ptype_variant %a\n" fmt_private_flag priv;
- list (i+1) string_x_core_type_list ppf l;
- | Ptype_record (l, priv) ->
- line i ppf "Ptype_record %a\n" fmt_private_flag priv;
- list (i+1) string_x_mutable_flag_x_core_type ppf l;
-
-and exception_declaration i ppf x = list i core_type ppf x
-
-and class_type i ppf x =
- line i ppf "class_type %a\n" fmt_location x.pcty_loc;
- let i = i+1 in
- match x.pcty_desc with
- | Pcty_constr (li, l) ->
- line i ppf "Pcty_constr %a\n" fmt_longident li;
- list i core_type ppf l;
- | Pcty_signature (cs) ->
- line i ppf "Pcty_signature\n";
- class_signature i ppf cs;
- | Pcty_fun (l, co, cl) ->
- line i ppf "Pcty_fun \"%s\"\n" l;
- core_type i ppf co;
- class_type i ppf cl;
-
-and class_signature i ppf (ct, 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 =
- match x with
- | Pctf_inher (ct) ->
- line i ppf "Pctf_inher\n";
- class_type i ppf ct;
- | Pctf_val (s, mf, cto, loc) ->
- line i ppf
- "Pctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
- option i core_type ppf cto;
- | Pctf_virt (s, pf, ct, loc) ->
- line i ppf
- "Pctf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
- | Pctf_meth (s, pf, ct, loc) ->
- line i ppf
- "Pctf_meth \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
- | Pctf_cstr (ct1, ct2, loc) ->
- line i ppf "Pctf_cstr %a\n" fmt_location loc;
- core_type i ppf ct1;
- core_type i ppf ct2;
-
-and class_description i ppf x =
- line i ppf "class_description %a\n" fmt_location x.pci_loc;
- let i = i+1 in
- line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
- line i ppf "pci_params =\n";
- string_list_x_location (i+1) ppf x.pci_params;
- line i ppf "pci_name = \"%s\"\n" 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;
- let i = i+1 in
- line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
- line i ppf "pci_params =\n";
- string_list_x_location (i+1) ppf x.pci_params;
- line i ppf "pci_name = \"%s\"\n" 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;
- let i = i+1 in
- match x.pcl_desc with
- | Pcl_constr (li, l) ->
- line i ppf "Pcl_constr %a\n" fmt_longident 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";
- 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 pattern_x_expression_def 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;
-
-and class_structure i ppf (p, 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 =
- match x with
- | Pcf_inher (ce, so) ->
- printf "Pcf_inher\n";
- class_expr (i+1) ppf ce;
- option (i+1) string ppf so;
- | Pcf_val (s, mf, e, loc) ->
- line i ppf
- "Pcf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
- expression (i+1) ppf e;
- | Pcf_virt (s, pf, ct, loc) ->
- line i ppf
- "Pcf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
- core_type (i+1) ppf ct;
- | Pcf_meth (s, pf, e, loc) ->
- line i ppf
- "Pcf_meth \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
- expression (i+1) ppf e;
- | Pcf_cstr (ct1, ct2, loc) ->
- line i ppf "Pcf_cstr %a\n" fmt_location loc;
- core_type (i+1) ppf ct1;
- core_type (i+1) ppf ct2;
- | Pcf_let (rf, l, loc) ->
- line i ppf "Pcf_let %a %a\n" fmt_rec_flag rf fmt_location loc;
- list (i+1) pattern_x_expression_def ppf l;
- | Pcf_init (e) ->
- line i ppf "Pcf_init\n";
- expression (i+1) ppf e;
-
-and class_declaration i ppf x =
- line i ppf "class_declaration %a\n" fmt_location x.pci_loc;
- let i = i+1 in
- line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
- line i ppf "pci_params =\n";
- string_list_x_location (i+1) ppf x.pci_params;
- line i ppf "pci_name = \"%s\"\n" 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;
- let i = i+1 in
- match x.pmty_desc with
- | Pmty_ident (li) -> line i ppf "Pmty_ident %a\n" fmt_longident li;
- | Pmty_signature (s) ->
- line i ppf "Pmty_signature\n";
- signature i ppf s;
- | Pmty_functor (s, mt1, mt2) ->
- line i ppf "Pmty_functor \"%s\"\n" s;
- 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 longident_x_with_constraint ppf l;
-
-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 (s, vd) ->
- line i ppf "Psig_value \"%s\"\n" s;
- value_description i ppf vd;
- | Psig_type (l) ->
- line i ppf "Psig_type\n";
- list i string_x_type_declaration ppf l;
- | Psig_exception (s, ed) ->
- line i ppf "Psig_exception \"%s\"\n" s;
- exception_declaration i ppf ed;
- | Psig_module (s, mt) ->
- line i ppf "Psig_module \"%s\"\n" s;
- module_type i ppf mt;
- | Psig_recmodule decls ->
- line i ppf "Psig_recmodule\n";
- list i string_x_module_type ppf decls;
- | Psig_modtype (s, md) ->
- line i ppf "Psig_modtype \"%s\"\n" s;
- modtype_declaration i ppf md;
- | Psig_open (li) -> line i ppf "Psig_open %a\n" fmt_longident li;
- | Psig_include (mt) ->
- line i ppf "Psig_include\n";
- module_type i ppf mt;
- | 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;
-
-and modtype_declaration i ppf x =
- match x with
- | Pmodtype_abstract -> line i ppf "Pmodtype_abstract\n";
- | Pmodtype_manifest (mt) ->
- line i ppf "Pmodtype_manifest\n";
- module_type (i+1) ppf mt;
-
-and with_constraint i ppf x =
- match x with
- | Pwith_type (td) ->
- line i ppf "Pwith_type\n";
- type_declaration (i+1) ppf td;
- | Pwith_module (li) -> line i ppf "Pwith_module %a\n" fmt_longident li;
-
-and module_expr i ppf x =
- line i ppf "module_expr %a\n" fmt_location x.pmod_loc;
- let i = i+1 in
- match x.pmod_desc with
- | Pmod_ident (li) -> line i ppf "Pmod_ident %a\n" fmt_longident li;
- | Pmod_structure (s) ->
- line i ppf "Pmod_structure\n";
- structure i ppf s;
- | Pmod_functor (s, mt, me) ->
- line i ppf "Pmod_functor \"%s\"\n" s;
- 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;
-
-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) ->
- line i ppf "Pstr_eval\n";
- expression i ppf e;
- | Pstr_value (rf, l) ->
- line i ppf "Pstr_value %a\n" fmt_rec_flag rf;
- list i pattern_x_expression_def ppf l;
- | Pstr_primitive (s, vd) ->
- line i ppf "Pstr_primitive \"%s\"\n" s;
- value_description i ppf vd;
- | Pstr_type (l) ->
- line i ppf "Pstr_type\n";
- list i string_x_type_declaration ppf l;
- | Pstr_exception (s, ed) ->
- line i ppf "Pstr_exception \"%s\"\n" s;
- exception_declaration i ppf ed;
- | Pstr_exn_rebind (s, li) ->
- line i ppf "Pstr_exn_rebind \"%s\" %a\n" s fmt_longident li;
- | Pstr_module (s, me) ->
- line i ppf "Pstr_module \"%s\"\n" s;
- module_expr i ppf me;
- | Pstr_recmodule bindings ->
- line i ppf "Pstr_recmodule\n";
- list i string_x_modtype_x_module ppf bindings;
- | Pstr_modtype (s, mt) ->
- line i ppf "Pstr_modtype \"%s\"\n" s;
- module_type i ppf mt;
- | Pstr_open (li) -> line i ppf "Pstr_open %a\n" fmt_longident li;
- | 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 me ->
- line i ppf "Pstr_include";
- module_expr i ppf me
-
-and string_x_type_declaration i ppf (s, td) =
- string i ppf s;
- type_declaration (i+1) ppf td;
-
-and string_x_module_type i ppf (s, mty) =
- string i ppf s;
- module_type (i+1) ppf mty;
-
-and string_x_modtype_x_module i ppf (s, mty, modl) =
- string i ppf s;
- module_type (i+1) ppf mty;
- module_expr (i+1) ppf modl;
-
-and longident_x_with_constraint i ppf (li, wc) =
- line i ppf "%a\n" fmt_longident li;
- with_constraint (i+1) ppf wc;
-
-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 string_x_core_type_list i ppf (s, l) =
- string i ppf s;
- list (i+1) core_type ppf l;
-
-and string_x_mutable_flag_x_core_type i ppf (s, mf, ct) =
- line i ppf "\"%s\" %a\n" s fmt_mutable_flag mf;
- core_type (i+1) ppf ct;
-
-and string_list_x_location i ppf (l, loc) =
- line i ppf "<params> %a\n" fmt_location loc;
- list (i+1) string ppf l;
-
-and longident_x_pattern i ppf (li, p) =
- line i ppf "%a\n" fmt_longident li;
- pattern (i+1) ppf p;
-
-and pattern_x_expression_case i ppf (p, e) =
- line i ppf "<case>\n";
- pattern (i+1) ppf p;
- expression (i+1) ppf e;
-
-and pattern_x_expression_def i ppf (p, e) =
- line i ppf "<def>\n";
- pattern (i+1) ppf p;
- expression (i+1) ppf e;
-
-and string_x_expression i ppf (s, e) =
- line i ppf "<override> \"%s\"\n" s;
- expression (i+1) ppf e;
-
-and longident_x_expression i ppf (li, e) =
- line i ppf "%a\n" fmt_longident li;
- expression (i+1) ppf e;
-
-and label_x_expression i ppf (l,e) =
- line i ppf "<label> \"%s\"\n" l;
- expression (i+1) ppf e;
-
-and label_x_bool_x_core_type_list i ppf x =
- match x with
- Rtag (l, b, ctl) ->
- line i ppf "Rtag \"%s\" %s\n" l (string_of_bool b);
- 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 (i) -> line i ppf "Pdir_int %d\n" i;
- | 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
deleted file mode 100644
index 7ea148678d..0000000000
--- a/parsing/printast.mli
+++ /dev/null
@@ -1,20 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Damien Doligez, projet Para, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-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;;
diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml
deleted file mode 100644
index 182863f132..0000000000
--- a/parsing/syntaxerr.ml
+++ /dev/null
@@ -1,41 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1997 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Auxiliary type for reporting syntax errors *)
-
-open Format
-
-type error =
- Unclosed of Location.t * string * Location.t * string
- | Other of Location.t
-
-exception Error of error
-exception Escape_error
-
-let report_error ppf = function
- | Unclosed(opening_loc, opening, closing_loc, closing) ->
- if String.length !Location.input_name = 0
- && Location.highlight_locations ppf opening_loc closing_loc
- then fprintf ppf "Syntax error: '%s' expected, \
- the highlighted '%s' might be unmatched" closing opening
- else begin
- fprintf ppf "%aSyntax error: '%s' expected@."
- Location.print closing_loc closing;
- fprintf ppf "%aThis '%s' might be unmatched"
- Location.print opening_loc opening
- end
- | Other loc ->
- fprintf ppf "%aSyntax error" Location.print loc
-
-
diff --git a/parsing/syntaxerr.mli b/parsing/syntaxerr.mli
deleted file mode 100644
index dba7f29022..0000000000
--- a/parsing/syntaxerr.mli
+++ /dev/null
@@ -1,26 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1997 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Auxiliary type for reporting syntax errors *)
-
-open Format
-
-type error =
- Unclosed of Location.t * string * Location.t * string
- | Other of Location.t
-
-exception Error of error
-exception Escape_error
-
-val report_error: formatter -> error -> unit
diff --git a/test/.cvsignore b/test/.cvsignore
deleted file mode 100644
index 66d34d7336..0000000000
--- a/test/.cvsignore
+++ /dev/null
@@ -1,2 +0,0 @@
-*.byt
-*.out
diff --git a/test/.depend b/test/.depend
deleted file mode 100644
index ac5de61e8e..0000000000
--- a/test/.depend
+++ /dev/null
@@ -1,28 +0,0 @@
-KB/equations.cmi: KB/terms.cmi
-KB/kb.cmi: KB/equations.cmi KB/terms.cmi
-KB/orderings.cmi: KB/terms.cmi
-KB/equations.cmo: KB/equations.cmi KB/terms.cmi
-KB/equations.cmx: KB/equations.cmi KB/terms.cmx
-KB/kb.cmo: KB/kb.cmi KB/equations.cmi KB/terms.cmi
-KB/kb.cmx: KB/kb.cmi KB/equations.cmx KB/terms.cmx
-KB/kbmain.cmo: KB/kb.cmi KB/orderings.cmi KB/equations.cmi KB/terms.cmi
-KB/kbmain.cmx: KB/kb.cmx KB/orderings.cmx KB/equations.cmx KB/terms.cmx
-KB/orderings.cmo: KB/orderings.cmi KB/terms.cmi
-KB/orderings.cmx: KB/orderings.cmi KB/terms.cmx
-KB/terms.cmo: KB/terms.cmi
-KB/terms.cmx: KB/terms.cmi
-Lex/grammar.cmi: Lex/syntax.cmo
-Lex/gram_aux.cmo: Lex/syntax.cmo
-Lex/gram_aux.cmx: Lex/syntax.cmx
-Lex/grammar.cmo: Lex/grammar.cmi Lex/gram_aux.cmo Lex/syntax.cmo
-Lex/grammar.cmx: Lex/grammar.cmi Lex/gram_aux.cmx Lex/syntax.cmx
-Lex/lexgen.cmo: Lex/syntax.cmo
-Lex/lexgen.cmx: Lex/syntax.cmx
-Lex/main.cmo: Lex/lexgen.cmo Lex/output.cmo Lex/grammar.cmi \
- Lex/scanner.cmo Lex/syntax.cmo Lex/scan_aux.cmo
-Lex/main.cmx: Lex/lexgen.cmx Lex/output.cmx Lex/grammar.cmx \
- Lex/scanner.cmx Lex/syntax.cmx Lex/scan_aux.cmx
-Lex/output.cmo: Lex/syntax.cmo
-Lex/output.cmx: Lex/syntax.cmx
-Lex/scanner.cmo: Lex/syntax.cmo Lex/scan_aux.cmo Lex/grammar.cmi
-Lex/scanner.cmx: Lex/syntax.cmx Lex/scan_aux.cmx Lex/grammar.cmx
diff --git a/test/KB/equations.ml b/test/KB/equations.ml
deleted file mode 100644
index a7ea9a03b6..0000000000
--- a/test/KB/equations.ml
+++ /dev/null
@@ -1,115 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(****************** Equation manipulations *************)
-
-open Terms
-
-type rule =
- { number: int;
- numvars: int;
- lhs: term;
- rhs: term }
-
-(* standardizes an equation so its variables are 1,2,... *)
-
-let mk_rule num m n =
- let all_vars = union (vars m) (vars n) in
- let counter = ref 0 in
- let subst =
- List.map (fun v -> incr counter; (v, Var !counter)) (List.rev all_vars) in
- { number = num;
- numvars = !counter;
- lhs = substitute subst m;
- rhs = substitute subst n }
-
-
-(* checks that rules are numbered in sequence and returns their number *)
-
-let check_rules rules =
- let counter = ref 0 in
- List.iter (fun r -> incr counter;
- if r.number <> !counter
- then failwith "Rule numbers not in sequence")
- rules;
- !counter
-
-
-let pretty_rule rule =
- print_int rule.number; print_string " : ";
- pretty_term rule.lhs; print_string " = "; pretty_term rule.rhs;
- print_newline()
-
-
-let pretty_rules rules = List.iter pretty_rule rules
-
-(****************** Rewriting **************************)
-
-(* Top-level rewriting. Let eq:L=R be an equation, M be a term such that L<=M.
- With sigma = matching L M, we define the image of M by eq as sigma(R) *)
-let reduce l m r =
- substitute (matching l m) r
-
-(* Test whether m can be reduced by l, i.e. m contains an instance of l. *)
-
-let can_match l m =
- try let _ = matching l m in true
- with Failure _ -> false
-
-let rec reducible l m =
- can_match l m ||
- (match m with
- | Term(_,sons) -> List.exists (reducible l) sons
- | _ -> false)
-
-(* Top-level rewriting with multiple rules. *)
-
-let rec mreduce rules m =
- match rules with
- [] -> failwith "mreduce"
- | rule::rest ->
- try
- reduce rule.lhs m rule.rhs
- with Failure _ ->
- mreduce rest m
-
-
-(* One step of rewriting in leftmost-outermost strategy,
- with multiple rules. Fails if no redex is found *)
-
-let rec mrewrite1 rules m =
- try
- mreduce rules m
- with Failure _ ->
- match m with
- Var n -> failwith "mrewrite1"
- | Term(f, sons) -> Term(f, mrewrite1_sons rules sons)
-
-and mrewrite1_sons rules = function
- [] -> failwith "mrewrite1"
- | son::rest ->
- try
- mrewrite1 rules son :: rest
- with Failure _ ->
- son :: mrewrite1_sons rules rest
-
-
-(* Iterating rewrite1. Returns a normal form. May loop forever *)
-
-let rec mrewrite_all rules m =
- try
- mrewrite_all rules (mrewrite1 rules m)
- with Failure _ ->
- m
-
diff --git a/test/KB/equations.mli b/test/KB/equations.mli
deleted file mode 100644
index 45d790260f..0000000000
--- a/test/KB/equations.mli
+++ /dev/null
@@ -1,32 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Terms
-
-type rule =
- { number: int;
- numvars: int;
- lhs: term;
- rhs: term }
-
-val mk_rule: int -> term -> term -> rule
-val check_rules: rule list -> int
-val pretty_rule: rule -> unit
-val pretty_rules: rule list -> unit
-val reduce: term -> term -> term -> term
-val reducible: term -> term -> bool
-val mreduce: rule list -> term -> term
-val mrewrite1: rule list -> term -> term
-val mrewrite1_sons: rule list -> term list -> term list
-val mrewrite_all: rule list -> term -> term
diff --git a/test/KB/kb.ml b/test/KB/kb.ml
deleted file mode 100644
index 590f4cd5d0..0000000000
--- a/test/KB/kb.ml
+++ /dev/null
@@ -1,188 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Terms
-open Equations
-
-(****************** Critical pairs *********************)
-
-(* All (u,subst) such that N/u (&var) unifies with M,
- with principal unifier subst *)
-
-let rec super m = function
- Term(_,sons) as n ->
- let rec collate n = function
- [] -> []
- | son::rest ->
- List.map (fun (u, subst) -> (n::u, subst)) (super m son)
- @ collate (n+1) rest in
- let insides = collate 1 sons in
- begin try
- ([], unify m n) :: insides
- with Failure _ ->
- insides
- end
- | _ -> []
-
-
-(* Ex :
-let (m,_) = <<F(A,B)>>
-and (n,_) = <<H(F(A,x),F(x,y))>> in super m n
-==> [[1],[2,Term ("B",[])]; x <- B
- [2],[2,Term ("A",[]); 1,Term ("B",[])]] x <- A y <- B
-*)
-
-(* All (u,subst), u&[], such that n/u unifies with m *)
-
-let super_strict m = function
- Term(_,sons) ->
- let rec collate n = function
- [] -> []
- | son::rest ->
- List.map (fun (u, subst) -> (n::u, subst)) (super m son)
- @ collate (n+1) rest in
- collate 1 sons
- | _ -> []
-
-
-(* Critical pairs of l1=r1 with l2=r2 *)
-(* critical_pairs : term_pair -> term_pair -> term_pair list *)
-let critical_pairs (l1,r1) (l2,r2) =
- let mk_pair (u,subst) =
- substitute subst (replace l2 u r1), substitute subst r2 in
- List.map mk_pair (super l1 l2)
-
-(* Strict critical pairs of l1=r1 with l2=r2 *)
-(* strict_critical_pairs : term_pair -> term_pair -> term_pair list *)
-let strict_critical_pairs (l1,r1) (l2,r2) =
- let mk_pair (u,subst) =
- substitute subst (replace l2 u r1), substitute subst r2 in
- List.map mk_pair (super_strict l1 l2)
-
-
-(* All critical pairs of eq1 with eq2 *)
-let mutual_critical_pairs eq1 eq2 =
- (strict_critical_pairs eq1 eq2) @ (critical_pairs eq2 eq1)
-
-(* Renaming of variables *)
-
-let rename n (t1,t2) =
- let rec ren_rec = function
- Var k -> Var(k+n)
- | Term(op,sons) -> Term(op, List.map ren_rec sons) in
- (ren_rec t1, ren_rec t2)
-
-
-(************************ Completion ******************************)
-
-let deletion_message rule =
- print_string "Rule ";print_int rule.number; print_string " deleted";
- print_newline()
-
-
-(* Generate failure message *)
-let non_orientable (m,n) =
- pretty_term m; print_string " = "; pretty_term n; print_newline()
-
-
-let rec partition p = function
- [] -> ([], [])
- | x::l -> let (l1, l2) = partition p l in
- if p x then (x::l1, l2) else (l1, x::l2)
-
-
-let rec get_rule n = function
- [] -> raise Not_found
- | r::l -> if n = r.number then r else get_rule n l
-
-
-(* Improved Knuth-Bendix completion procedure *)
-
-let kb_completion greater =
- let rec kbrec j rules =
- let rec process failures (k,l) eqs =
-(****
- print_string "***kb_completion "; print_int j; print_newline();
- pretty_rules rules;
- List.iter non_orientable failures;
- print_int k; print_string " "; print_int l; print_newline();
- List.iter non_orientable eqs;
-***)
- match eqs with
- [] ->
- if k<l then next_criticals failures (k+1,l) else
- if l<j then next_criticals failures (1,l+1) else
- begin match failures with
- [] -> rules (* successful completion *)
- | _ -> print_string "Non-orientable equations :"; print_newline();
- List.iter non_orientable failures;
- failwith "kb_completion"
- end
- | (m,n)::eqs ->
- let m' = mrewrite_all rules m
- and n' = mrewrite_all rules n
- and enter_rule(left,right) =
- let new_rule = mk_rule (j+1) left right in
- pretty_rule new_rule;
- let left_reducible rule = reducible left rule.lhs in
- let (redl,irredl) = partition left_reducible rules in
- List.iter deletion_message redl;
- let right_reduce rule =
- mk_rule rule.number rule.lhs
- (mrewrite_all (new_rule::rules) rule.rhs) in
- let irreds = List.map right_reduce irredl in
- let eqs' = List.map (fun rule -> (rule.lhs, rule.rhs)) redl in
- kbrec (j+1) (new_rule::irreds) [] (k,l) (eqs @ eqs' @ failures) in
-(***
- print_string "--- Considering "; non_orientable (m', n');
-***)
- if m' = n' then process failures (k,l) eqs else
- if greater(m',n') then enter_rule(m',n') else
- if greater(n',m') then enter_rule(n',m') else
- process ((m',n')::failures) (k,l) eqs
-
- and next_criticals failures (k,l) =
-(****
- print_string "***next_criticals ";
- print_int k; print_string " "; print_int l ; print_newline();
-****)
- try
- let rl = get_rule l rules in
- let el = (rl.lhs, rl.rhs) in
- if k=l then
- process failures (k,l)
- (strict_critical_pairs el (rename rl.numvars el))
- else
- try
- let rk = get_rule k rules in
- let ek = (rk.lhs, rk.rhs) in
- process failures (k,l)
- (mutual_critical_pairs el (rename rl.numvars ek))
- with Not_found -> next_criticals failures (k+1,l)
- with Not_found -> next_criticals failures (1,l+1)
- in process
- in kbrec
-
-
-(* complete_rules is assumed locally confluent, and checked Noetherian with
- ordering greater, rules is any list of rules *)
-
-let kb_complete greater complete_rules rules =
- let n = check_rules complete_rules
- and eqs = List.map (fun rule -> (rule.lhs, rule.rhs)) rules in
- let completed_rules =
- kb_completion greater n complete_rules [] (n,n) eqs in
- print_string "Canonical set found :"; print_newline();
- pretty_rules (List.rev completed_rules)
-
diff --git a/test/KB/kb.mli b/test/KB/kb.mli
deleted file mode 100644
index 59b60e4ea2..0000000000
--- a/test/KB/kb.mli
+++ /dev/null
@@ -1,29 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Terms
-open Equations
-
-val super: term -> term -> (int list * (int * term) list) list
-val super_strict: term -> term -> (int list * (int * term) list) list
-val critical_pairs: term * term -> term * term -> (term * term) list
-val strict_critical_pairs: term * term -> term * term -> (term * term) list
-val mutual_critical_pairs: term * term -> term * term -> (term * term) list
-val rename: int -> term * term -> term * term
-val deletion_message: rule -> unit
-val non_orientable: term * term -> unit
-val partition: ('a -> bool) -> 'a list -> 'a list * 'a list
-val get_rule: int -> rule list -> rule
-val kb_completion: (term * term -> bool) -> int -> rule list -> (term * term) list -> int * int -> (term * term) list -> rule list
-val kb_complete: (term * term -> bool) -> rule list -> rule list -> unit
diff --git a/test/KB/kbmain.ml b/test/KB/kbmain.ml
deleted file mode 100644
index 63ebf4b8f3..0000000000
--- a/test/KB/kbmain.ml
+++ /dev/null
@@ -1,81 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Terms
-open Equations
-open Orderings
-open Kb
-
-(****
-let group_rules = [
- { number = 1; numvars = 1;
- lhs = Term("*", [Term("U",[]); Var 1]); rhs = Var 1 };
- { number = 2; numvars = 1;
- lhs = Term("*", [Term("I",[Var 1]); Var 1]); rhs = Term("U",[]) };
- { number = 3; numvars = 3;
- lhs = Term("*", [Term("*", [Var 1; Var 2]); Var 3]);
- rhs = Term("*", [Var 1; Term("*", [Var 2; Var 3])]) }
-]
-****)
-
-let geom_rules = [
- { number = 1; numvars = 1;
- lhs = Term ("*",[(Term ("U",[])); (Var 1)]);
- rhs = Var 1 };
- { number = 2; numvars = 1;
- lhs = Term ("*",[(Term ("I",[(Var 1)])); (Var 1)]);
- rhs = Term ("U",[]) };
- { number = 3; numvars = 3;
- lhs = Term ("*",[(Term ("*",[(Var 1); (Var 2)])); (Var 3)]);
- rhs = Term ("*",[(Var 1); (Term ("*",[(Var 2); (Var 3)]))]) };
- { number = 4; numvars = 0;
- lhs = Term ("*",[(Term ("A",[])); (Term ("B",[]))]);
- rhs = Term ("*",[(Term ("B",[])); (Term ("A",[]))]) };
- { number = 5; numvars = 0;
- lhs = Term ("*",[(Term ("C",[])); (Term ("C",[]))]);
- rhs = Term ("U",[]) };
- { number = 6; numvars = 0;
- lhs = Term("*",
- [(Term ("C",[]));
- (Term ("*",[(Term ("A",[])); (Term ("I",[(Term ("C",[]))]))]))]);
- rhs = Term ("I",[(Term ("A",[]))]) };
- { number = 7; numvars = 0;
- lhs = Term("*",
- [(Term ("C",[]));
- (Term ("*",[(Term ("B",[])); (Term ("I",[(Term ("C",[]))]))]))]);
- rhs = Term ("B",[]) }
-]
-
-let group_rank = function
- "U" -> 0
- | "*" -> 1
- | "I" -> 2
- | "B" -> 3
- | "C" -> 4
- | "A" -> 5
- | _ -> assert false
-
-let group_precedence op1 op2 =
- let r1 = group_rank op1
- and r2 = group_rank op2 in
- if r1 = r2 then Equal else
- if r1 > r2 then Greater else NotGE
-
-let group_order = rpo group_precedence lex_ext
-
-let greater pair =
- match group_order pair with Greater -> true | _ -> false
-
-let _ = kb_complete greater [] geom_rules
-
diff --git a/test/KB/orderings.ml b/test/KB/orderings.ml
deleted file mode 100644
index 11a776ba7c..0000000000
--- a/test/KB/orderings.ml
+++ /dev/null
@@ -1,99 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(*********************** Recursive Path Ordering ****************************)
-
-open Terms
-
-type ordering =
- Greater
- | Equal
- | NotGE
-
-let ge_ord order pair = match order pair with NotGE -> false | _ -> true
-and gt_ord order pair = match order pair with Greater -> true | _ -> false
-and eq_ord order pair = match order pair with Equal -> true | _ -> false
-
-
-let rec rem_eq equiv x = function
- [] -> failwith "rem_eq"
- | y::l -> if equiv (x,y) then l else y :: rem_eq equiv x l
-
-
-let diff_eq equiv (x,y) =
- let rec diffrec = function
- ([],_) as p -> p
- | (h::t, y) -> try
- diffrec (t, rem_eq equiv h y)
- with Failure _ ->
- let (x',y') = diffrec (t,y) in (h::x',y') in
- if List.length x > List.length y then diffrec(y,x) else diffrec(x,y)
-
-
-(* Multiset extension of order *)
-
-let mult_ext order = function
- Term(_,sons1), Term(_,sons2) ->
- begin match diff_eq (eq_ord order) (sons1,sons2) with
- ([],[]) -> Equal
- | (l1,l2) ->
- if List.for_all
- (fun n -> List.exists (fun m -> gt_ord order (m,n)) l1) l2
- then Greater else NotGE
- end
- | _ -> failwith "mult_ext"
-
-
-(* Lexicographic extension of order *)
-
-let lex_ext order = function
- (Term(_,sons1) as m), (Term(_,sons2) as n) ->
- let rec lexrec = function
- ([] , []) -> Equal
- | ([] , _ ) -> NotGE
- | ( _ , []) -> Greater
- | (x1::l1, x2::l2) ->
- match order (x1,x2) with
- Greater -> if List.for_all (fun n' -> gt_ord order (m,n')) l2
- then Greater else NotGE
- | Equal -> lexrec (l1,l2)
- | NotGE -> if List.exists (fun m' -> ge_ord order (m',n)) l1
- then Greater else NotGE in
- lexrec (sons1, sons2)
- | _ -> failwith "lex_ext"
-
-
-(* Recursive path ordering *)
-
-let rpo op_order ext =
- let rec rporec (m,n) =
- if m = n then Equal else
- match m with
- Var vm -> NotGE
- | Term(op1,sons1) ->
- match n with
- Var vn ->
- if occurs vn m then Greater else NotGE
- | Term(op2,sons2) ->
- match (op_order op1 op2) with
- Greater ->
- if List.for_all (fun n' -> gt_ord rporec (m,n')) sons2
- then Greater else NotGE
- | Equal ->
- ext rporec (m,n)
- | NotGE ->
- if List.exists (fun m' -> ge_ord rporec (m',n)) sons1
- then Greater else NotGE
- in rporec
-
diff --git a/test/KB/orderings.mli b/test/KB/orderings.mli
deleted file mode 100644
index d7abfd5645..0000000000
--- a/test/KB/orderings.mli
+++ /dev/null
@@ -1,31 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Terms
-
-type ordering =
- Greater
- | Equal
- | NotGE
-
-val ge_ord: ('a -> ordering) -> 'a -> bool
-val gt_ord: ('a -> ordering) -> 'a -> bool
-val eq_ord: ('a -> ordering) -> 'a -> bool
-val rem_eq: ('a * 'b -> bool) -> 'a -> 'b list -> 'b list
-val diff_eq: ('a * 'a -> bool) -> 'a list * 'a list -> 'a list * 'a list
-val mult_ext: (term * term -> ordering) -> term * term -> ordering
-val lex_ext: (term * term -> ordering) -> term * term -> ordering
-val rpo: (string -> string -> ordering) ->
- ((term * term -> ordering) -> term * term -> ordering) ->
- term * term -> ordering
diff --git a/test/KB/terms.ml b/test/KB/terms.ml
deleted file mode 100644
index dba7000646..0000000000
--- a/test/KB/terms.ml
+++ /dev/null
@@ -1,137 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(****************** Term manipulations *****************)
-
-type term =
- Var of int
- | Term of string * term list
-
-let rec union l1 l2 =
- match l1 with
- [] -> l2
- | a::r -> if List.mem a l2 then union r l2 else a :: union r l2
-
-
-let rec vars = function
- Var n -> [n]
- | Term(_,l) -> vars_of_list l
-and vars_of_list = function
- [] -> []
- | t::r -> union (vars t) (vars_of_list r)
-
-
-let rec substitute subst = function
- Term(oper,sons) -> Term(oper, List.map (substitute subst) sons)
- | Var(n) as t -> try List.assoc n subst with Not_found -> t
-
-
-(* Term replacement: replace M u N is M[u<-N]. *)
-
-let rec replace m u n =
- match (u, m) with
- [], _ -> n
- | i::u, Term(oper, sons) -> Term(oper, replace_nth i sons u n)
- | _ -> failwith "replace"
-
-and replace_nth i sons u n =
- match sons with
- s::r -> if i = 1
- then replace s u n :: r
- else s :: replace_nth (i-1) r u n
- | [] -> failwith "replace_nth"
-
-
-(* Term matching. *)
-
-let matching term1 term2 =
- let rec match_rec subst t1 t2 =
- match (t1, t2) with
- Var v, _ ->
- if List.mem_assoc v subst then
- if t2 = List.assoc v subst then subst else failwith "matching"
- else
- (v, t2) :: subst
- | Term(op1,sons1), Term(op2,sons2) ->
- if op1 = op2
- then List.fold_left2 match_rec subst sons1 sons2
- else failwith "matching"
- | _ -> failwith "matching" in
- match_rec [] term1 term2
-
-
-(* A naive unification algorithm. *)
-
-let compsubst subst1 subst2 =
- (List.map (fun (v,t) -> (v, substitute subst1 t)) subst2) @ subst1
-
-
-let rec occurs n = function
- Var m -> m = n
- | Term(_,sons) -> List.exists (occurs n) sons
-
-
-let rec unify term1 term2 =
- match (term1, term2) with
- Var n1, _ ->
- if term1 = term2 then []
- else if occurs n1 term2 then failwith "unify"
- else [n1, term2]
- | term1, Var n2 ->
- if occurs n2 term1 then failwith "unify"
- else [n2, term1]
- | Term(op1,sons1), Term(op2,sons2) ->
- if op1 = op2 then
- List.fold_left2 (fun s t1 t2 -> compsubst (unify (substitute s t1)
- (substitute s t2)) s)
- [] sons1 sons2
- else failwith "unify"
-
-
-(* We need to print terms with variables independently from input terms
- obtained by parsing. We give arbitrary names v1,v2,... to their variables.
-*)
-
-let infixes = ["+";"*"]
-
-let rec pretty_term = function
- Var n ->
- print_string "v"; print_int n
- | Term (oper,sons) ->
- if List.mem oper infixes then begin
- match sons with
- [s1;s2] ->
- pretty_close s1; print_string oper; pretty_close s2
- | _ ->
- failwith "pretty_term : infix arity <> 2"
- end else begin
- print_string oper;
- match sons with
- [] -> ()
- | t::lt -> print_string "(";
- pretty_term t;
- List.iter (fun t -> print_string ","; pretty_term t) lt;
- print_string ")"
- end
-
-and pretty_close = function
- Term(oper, _) as m ->
- if List.mem oper infixes then begin
- print_string "("; pretty_term m; print_string ")"
- end else
- pretty_term m
- | m ->
- pretty_term m
-
-
diff --git a/test/KB/terms.mli b/test/KB/terms.mli
deleted file mode 100644
index 7d22e9cb00..0000000000
--- a/test/KB/terms.mli
+++ /dev/null
@@ -1,31 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-type term =
- Var of int
- | Term of string * term list
-
-val union: 'a list -> 'a list -> 'a list
-val vars: term -> int list
-val vars_of_list: term list -> int list
-val substitute: (int * term) list -> term -> term
-val replace: term -> int list -> term -> term
-val replace_nth: int -> term list -> int list -> term -> term list
-val matching: term -> term -> (int * term) list
-val compsubst: (int * term) list -> (int * term) list -> (int * term) list
-val occurs: int -> term -> bool
-val unify: term -> term -> (int * term) list
-val infixes: string list
-val pretty_term: term -> unit
-val pretty_close: term -> unit
diff --git a/test/Lex/.cvsignore b/test/Lex/.cvsignore
deleted file mode 100644
index ed941f64ff..0000000000
--- a/test/Lex/.cvsignore
+++ /dev/null
@@ -1,5 +0,0 @@
-grammar.ml
-grammar.mli
-scanner.ml
-testscanner.ml
-grammar.output
diff --git a/test/Lex/gram_aux.ml b/test/Lex/gram_aux.ml
deleted file mode 100644
index b84d8588a6..0000000000
--- a/test/Lex/gram_aux.ml
+++ /dev/null
@@ -1,47 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Auxiliaries for the parser. *)
-
-open Syntax
-
-let regexp_for_string s =
- let l = String.length s in
- if l = 0 then
- Epsilon
- else begin
- let re = ref(Characters [String.get s (l - 1)]) in
- for i = l - 2 downto 0 do
- re := Sequence(Characters [String.get s i], !re)
- done;
- !re
- end
-
-
-let char_class c1 c2 =
- let cl = ref [] in
- for i = Char.code c2 downto Char.code c1 do
- cl := Char.chr i :: !cl
- done;
- !cl
-
-
-let all_chars = char_class '\001' '\255'
-
-
-let rec subtract l1 l2 =
- match l1 with
- [] -> []
- | a::l -> if List.mem a l2 then subtract l l2 else a :: subtract l l2
-
diff --git a/test/Lex/grammar.mly b/test/Lex/grammar.mly
deleted file mode 100644
index 8c1e4db943..0000000000
--- a/test/Lex/grammar.mly
+++ /dev/null
@@ -1,114 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* The grammar for lexer definitions */
-
-%{
-open Syntax
-open Gram_aux
-%}
-
-%token <string> Tident
-%token <char> Tchar
-%token <string> Tstring
-%token <Syntax.location> Taction
-%token Trule Tparse Tand Tequal Tend Tor Tunderscore Teof Tlbracket Trbracket
-%token Tstar Tmaybe Tplus Tlparen Trparen Tcaret Tdash
-
-%left Tor
-%left CONCAT
-%nonassoc Tmaybe
-%left Tstar
-%left Tplus
-
-%start lexer_definition
-%type <Syntax.lexer_definition> lexer_definition
-
-%%
-
-lexer_definition:
- header Trule definition other_definitions Tend
- { Lexdef($1, $3::(List.rev $4)) }
-;
-header:
- Taction
- { $1 }
- |
- { Location(0,0) }
-;
-other_definitions:
- other_definitions Tand definition
- { $3::$1 }
- |
- { [] }
-;
-definition:
- Tident Tequal entry
- { ($1,$3) }
-;
-entry:
- Tparse case rest_of_entry
- { $2 :: List.rev $3 }
-;
-rest_of_entry:
- rest_of_entry Tor case
- { $3::$1 }
- |
- { [] }
-;
-case:
- regexp Taction
- { ($1,$2) }
-;
-regexp:
- Tunderscore
- { Characters all_chars }
- | Teof
- { Characters ['\000'] }
- | Tchar
- { Characters [$1] }
- | Tstring
- { regexp_for_string $1 }
- | Tlbracket char_class Trbracket
- { Characters $2 }
- | regexp Tstar
- { Repetition $1 }
- | regexp Tmaybe
- { Alternative($1, Epsilon) }
- | regexp Tplus
- { Sequence($1, Repetition $1) }
- | regexp Tor regexp
- { Alternative($1,$3) }
- | regexp regexp %prec CONCAT
- { Sequence($1,$2) }
- | Tlparen regexp Trparen
- { $2 }
-;
-char_class:
- Tcaret char_class1
- { subtract all_chars $2 }
- | char_class1
- { $1 }
-;
-char_class1:
- Tchar Tdash Tchar
- { char_class $1 $3 }
- | Tchar
- { [$1] }
- | char_class char_class %prec CONCAT
- { $1 @ $2 }
-;
-
-%%
-
diff --git a/test/Lex/lexgen.ml b/test/Lex/lexgen.ml
deleted file mode 100644
index 42ff47c57c..0000000000
--- a/test/Lex/lexgen.ml
+++ /dev/null
@@ -1,266 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Compiling a lexer definition *)
-
-open Syntax
-
-(* Deep abstract syntax for regular expressions *)
-
-type regexp =
- Empty
- | Chars of int
- | Action of int
- | Seq of regexp * regexp
- | Alt of regexp * regexp
- | Star of regexp
-
-(* From shallow to deep syntax *)
-
-(***
-
-let print_char_class c =
- let print_interval low high =
- prerr_int low;
- if high - 1 > low then begin
- prerr_char '-';
- prerr_int (high-1)
- end;
- prerr_char ' ' in
- let rec print_class first next = function
- [] -> print_interval first next
- | c::l ->
- if char.code c = next
- then print_class first (next+1) l
- else begin
- print_interval first next;
- print_class (char.code c) (char.code c + 1) l
- end in
- match c with
- [] -> prerr_newline()
- | c::l -> print_class (char.code c) (char.code c + 1) l; prerr_newline()
-
-
-let rec print_regexp = function
- Empty -> prerr_string "Empty"
- | Chars n -> prerr_string "Chars "; prerr_int n
- | Action n -> prerr_string "Action "; prerr_int n
- | Seq(r1,r2) -> print_regexp r1; prerr_string "; "; print_regexp r2
- | Alt(r1,r2) -> prerr_string "("; print_regexp r1; prerr_string " | "; print_regexp r2; prerr_string ")"
- | Star r -> prerr_string "("; print_regexp r; prerr_string ")*"
-
-***)
-
-let chars = ref ([] : char list list)
-let chars_count = ref 0
-let actions = ref ([] : (int * location) list)
-let actions_count = ref 0
-
-let rec encode_regexp = function
- Epsilon -> Empty
- | Characters cl ->
- let n = !chars_count in
-(*** prerr_int n; prerr_char ' '; print_char_class cl; ***)
- chars := cl :: !chars;
- chars_count := !chars_count + 1;
- Chars(n)
- | Sequence(r1,r2) ->
- Seq(encode_regexp r1, encode_regexp r2)
- | Alternative(r1,r2) ->
- Alt(encode_regexp r1, encode_regexp r2)
- | Repetition r ->
- Star (encode_regexp r)
-
-
-let encode_casedef =
- List.fold_left
- (fun reg (expr,act) ->
- let act_num = !actions_count in
- actions_count := !actions_count + 1;
- actions := (act_num, act) :: !actions;
- Alt(reg, Seq(encode_regexp expr, Action act_num)))
- Empty
-
-
-let encode_lexdef (Lexdef(_, ld)) =
- chars := [];
- chars_count := 0;
- actions := [];
- actions_count := 0;
- let name_regexp_list =
- List.map (fun (name, casedef) -> (name, encode_casedef casedef)) ld in
-(* List.iter print_char_class chars; *)
- let chr = Array.of_list (List.rev !chars)
- and act = !actions in
- chars := [];
- actions := [];
- (chr, name_regexp_list, act)
-
-
-(* To generate directly a NFA from a regular expression.
- Confer Aho-Sethi-Ullman, dragon book, chap. 3 *)
-
-type transition =
- OnChars of int
- | ToAction of int
-
-
-let rec merge_trans l1 l2 =
- match (l1, l2) with
- ([], s2) -> s2
- | (s1, []) -> s1
- | ((OnChars n1 as t1) :: r1 as s1), ((OnChars n2 as t2) :: r2 as s2) ->
- if n1 = n2 then t1 :: merge_trans r1 r2 else
- if n1 < n2 then t1 :: merge_trans r1 s2 else
- t2 :: merge_trans s1 r2
- | ((ToAction n1 as t1) :: r1 as s1), ((ToAction n2 as t2) :: r2 as s2) ->
- if n1 = n2 then t1 :: merge_trans r1 r2 else
- if n1 < n2 then t1 :: merge_trans r1 s2 else
- t2 :: merge_trans s1 r2
- | ((OnChars n1 as t1) :: r1 as s1), ((ToAction n2 as t2) :: r2 as s2) ->
- t1 :: merge_trans r1 s2
- | ((ToAction n1 as t1) :: r1 as s1), ((OnChars n2 as t2) :: r2 as s2) ->
- t2 :: merge_trans s1 r2
-
-
-let rec nullable = function
- Empty -> true
- | Chars _ -> false
- | Action _ -> false
- | Seq(r1,r2) -> nullable r1 && nullable r2
- | Alt(r1,r2) -> nullable r1 || nullable r2
- | Star r -> true
-
-
-let rec firstpos = function
- Empty -> []
- | Chars pos -> [OnChars pos]
- | Action act -> [ToAction act]
- | Seq(r1,r2) -> if nullable r1
- then merge_trans (firstpos r1) (firstpos r2)
- else firstpos r1
- | Alt(r1,r2) -> merge_trans (firstpos r1) (firstpos r2)
- | Star r -> firstpos r
-
-
-let rec lastpos = function
- Empty -> []
- | Chars pos -> [OnChars pos]
- | Action act -> [ToAction act]
- | Seq(r1,r2) -> if nullable r2
- then merge_trans (lastpos r1) (lastpos r2)
- else lastpos r2
- | Alt(r1,r2) -> merge_trans (lastpos r1) (lastpos r2)
- | Star r -> lastpos r
-
-
-let followpos size name_regexp_list =
- let v = Array.create size [] in
- let fill_pos first = function
- OnChars pos -> v.(pos) <- merge_trans first v.(pos); ()
- | ToAction _ -> () in
- let rec fill = function
- Seq(r1,r2) ->
- fill r1; fill r2;
- List.iter (fill_pos (firstpos r2)) (lastpos r1)
- | Alt(r1,r2) ->
- fill r1; fill r2
- | Star r ->
- fill r;
- List.iter (fill_pos (firstpos r)) (lastpos r)
- | _ -> () in
- List.iter (fun (name, regexp) -> fill regexp) name_regexp_list;
- v
-
-
-let no_action = 0x3FFFFFFF
-
-let split_trans_set =
- List.fold_left
- (fun (act, pos_set as act_pos_set) trans ->
- match trans with
- OnChars pos -> (act, pos :: pos_set)
- | ToAction act1 -> if act1 < act then (act1, pos_set)
- else act_pos_set)
- (no_action, [])
-
-
-let memory = (Hashtbl.create 131 : (transition list, int) Hashtbl.t)
-let todo = ref ([] : (transition list * int) list)
-let next = ref 0
-
-let get_state st =
- try
- Hashtbl.find memory st
- with Not_found ->
- let nbr = !next in
- next := !next + 1;
- Hashtbl.add memory st nbr;
- todo := (st, nbr) :: !todo;
- nbr
-
-let rec map_on_states f =
- match !todo with
- [] -> []
- | (st,i)::r -> todo := r; let res = f st in (res,i) :: map_on_states f
-
-let number_of_states () = !next
-
-let goto_state = function
- [] -> Backtrack
- | ps -> Goto (get_state ps)
-
-
-let transition_from chars follow pos_set =
- let tr = Array.create 256 []
- and shift = Array.create 256 Backtrack in
- List.iter
- (fun pos ->
- List.iter
- (fun c ->
- tr.(Char.code c) <-
- merge_trans tr.(Char.code c) follow.(pos))
- chars.(pos))
- pos_set;
- for i = 0 to 255 do
- shift.(i) <- goto_state tr.(i)
- done;
- shift
-
-
-let translate_state chars follow state =
- match split_trans_set state with
- n, [] -> Perform n
- | n, ps -> Shift( (if n = no_action then No_remember else Remember n),
- transition_from chars follow ps)
-
-
-let make_dfa lexdef =
- let (chars, name_regexp_list, actions) =
- encode_lexdef lexdef in
-(**
- List.iter (fun (name, regexp) -> prerr_string name; prerr_string " = "; print_regexp regexp; prerr_newline()) name_regexp_list;
-**)
- let follow =
- followpos (Array.length chars) name_regexp_list in
- let initial_states =
- List.map (fun (name, regexp) -> (name, get_state(firstpos regexp)))
- name_regexp_list in
- let states =
- map_on_states (translate_state chars follow) in
- let v =
- Array.create (number_of_states()) (Perform 0) in
- List.iter (fun (auto, i) -> v.(i) <- auto) states;
- (initial_states, v, actions)
-
diff --git a/test/Lex/main.ml b/test/Lex/main.ml
deleted file mode 100644
index 6382401e2b..0000000000
--- a/test/Lex/main.ml
+++ /dev/null
@@ -1,118 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* The lexer generator. Command-line parsing. *)
-
-open Syntax
-open Scanner
-open Grammar
-open Lexgen
-open Output
-
-let main () =
- if Array.length Sys.argv <> 2 then begin
- prerr_string "Usage: camllex <input file>\n";
- exit 2
- end;
- let source_name = Sys.argv.(1) in
- let dest_name =
- if Filename.check_suffix source_name ".mll" then
- Filename.chop_suffix source_name ".mll" ^ ".ml"
- else
- source_name ^ ".ml" in
- ic := open_in source_name;
- oc := open_out dest_name;
- let lexbuf = Lexing.from_channel !ic in
- let (Lexdef(header,_) as def) =
- try
- Grammar.lexer_definition Scanner.main lexbuf
- with
- Parsing.Parse_error ->
- prerr_string "Syntax error around char ";
- prerr_int (Lexing.lexeme_start lexbuf);
- prerr_endline ".";
- exit 2
- | Scan_aux.Lexical_error s ->
- prerr_string "Lexical error around char ";
- prerr_int (Lexing.lexeme_start lexbuf);
- prerr_string ": ";
- prerr_string s;
- prerr_endline ".";
- exit 2 in
- let ((init, states, acts) as dfa) = make_dfa def in
- output_lexdef header dfa;
- close_in !ic;
- close_out !oc
-
-let _ = main(); exit 0
-
-
-(*****
-let main () =
- ic := stdin;
- oc := stdout;
- let lexbuf = lexing.from_channel ic in
- let (Lexdef(header,_) as def) =
- try
- grammar.lexer_definition scanner.main lexbuf
- with
- parsing.Parse_error x ->
- prerr_string "Syntax error around char ";
- prerr_int (lexing.lexeme_start lexbuf);
- prerr_endline ".";
- sys.exit 2
- | scan_aux.Lexical_error s ->
- prerr_string "Lexical error around char ";
- prerr_int (lexing.lexeme_start lexbuf);
- prerr_string ": ";
- prerr_string s;
- prerr_endline ".";
- sys.exit 2 in
- let ((init, states, acts) as dfa) = make_dfa def in
- output_lexdef header dfa
-
-****)
-
-(****
-let debug_scanner lexbuf =
- let tok = scanner.main lexbuf in
- begin match tok with
- Tident s -> prerr_string "Tident "; prerr_string s
- | Tchar c -> prerr_string "Tchar "; prerr_char c
- | Tstring s -> prerr_string "Tstring "; prerr_string s
- | Taction(Location(i1,i2)) ->
- prerr_string "Taction "; prerr_int i1; prerr_string "-";
- prerr_int i2
- | Trule -> prerr_string "Trule"
- | Tparse -> prerr_string "Tparse"
- | Tand -> prerr_string "Tand"
- | Tequal -> prerr_string "Tequal"
- | Tend -> prerr_string "Tend"
- | Tor -> prerr_string "Tor"
- | Tunderscore -> prerr_string "Tunderscore"
- | Teof -> prerr_string "Teof"
- | Tlbracket -> prerr_string "Tlbracket"
- | Trbracket -> prerr_string "Trbracket"
- | Tstar -> prerr_string "Tstar"
- | Tmaybe -> prerr_string "Tmaybe"
- | Tplus -> prerr_string "Tplus"
- | Tlparen -> prerr_string "Tlparen"
- | Trparen -> prerr_string "Trparen"
- | Tcaret -> prerr_string "Tcaret"
- | Tdash -> prerr_string "Tdash"
- end;
- prerr_newline();
- tok
-
-****)
diff --git a/test/Lex/output.ml b/test/Lex/output.ml
deleted file mode 100644
index 97d757771f..0000000000
--- a/test/Lex/output.ml
+++ /dev/null
@@ -1,169 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Generating a DFA as a set of mutually recursive functions *)
-
-open Syntax
-
-let ic = ref stdin
-let oc = ref stdout
-
-(* 1- Generating the actions *)
-
-let copy_buffer = String.create 1024
-
-let copy_chunk (Location(start,stop)) =
- seek_in !ic start;
- let tocopy = ref(stop - start) in
- while !tocopy > 0 do
- let m =
- input !ic copy_buffer 0 (min !tocopy (String.length copy_buffer)) in
- output !oc copy_buffer 0 m;
- tocopy := !tocopy - m
- done
-
-
-let output_action (i,act) =
- output_string !oc ("action_" ^ string_of_int i ^ " lexbuf = (\n");
- copy_chunk act;
- output_string !oc ")\nand "
-
-
-(* 2- Generating the states *)
-
-let states = ref ([||] : automata array)
-
-type occurrence =
- { mutable pos: int list;
- mutable freq: int }
-
-let enumerate_vect v =
- let env = ref [] in
- for pos = 0 to Array.length v - 1 do
- try
- let occ = List.assoc v.(pos) !env in
- occ.pos <- pos :: occ.pos;
- occ.freq <- occ.freq + 1
- with Not_found ->
- env := (v.(pos), {pos = [pos]; freq = 1 }) :: !env
- done;
- Sort.list (fun (e1, occ1) (e2, occ2) -> occ1.freq >= occ2.freq) !env
-
-
-let output_move = function
- Backtrack ->
- output_string !oc "lexing.backtrack lexbuf"
- | Goto dest ->
- match !states.(dest) with
- Perform act_num ->
- output_string !oc ("action_" ^ string_of_int act_num ^ " lexbuf")
- | _ ->
- output_string !oc ("state_" ^ string_of_int dest ^ " lexbuf")
-
-
-(* Cannot use standard char_for_read because the characters to escape
- are not the same in CL6 and CL1999. *)
-
-let output_char_lit oc = function
- '\'' -> output_string oc "\\'"
- | '\\' -> output_string oc "\\\\"
- | '\n' -> output_string oc "\\n"
- | '\t' -> output_string oc "\\t"
- | c -> if Char.code c >= 32 && Char.code c < 128 then
- output_char oc c
- else begin
- let n = Char.code c in
- output_char oc '\\';
- output_char oc (Char.chr (48 + n / 100));
- output_char oc (Char.chr (48 + (n / 10) mod 10));
- output_char oc (Char.chr (48 + n mod 10))
- end
-
-let rec output_chars = function
- [] ->
- failwith "output_chars"
- | [c] ->
- output_string !oc "'";
- output_char_lit !oc (Char.chr c);
- output_string !oc "'"
- | c::cl ->
- output_string !oc "'";
- output_char_lit !oc (Char.chr c);
- output_string !oc "'|";
- output_chars cl
-
-let output_one_trans (dest, occ) =
- output_chars occ.pos;
- output_string !oc " -> ";
- output_move dest;
- output_string !oc "\n | "
-
-let output_all_trans trans =
- output_string !oc " match lexing.next_char lexbuf with\n ";
- match enumerate_vect trans with
- [] ->
- failwith "output_all_trans"
- | (default, _) :: rest ->
- List.iter output_one_trans rest;
- output_string !oc "_ -> ";
- output_move default;
- output_string !oc "\nand "
-
-let output_state state_num = function
- Perform i ->
- ()
- | Shift(what_to_do, moves) ->
- output_string !oc
- ("state_" ^ string_of_int state_num ^ " lexbuf =\n");
- begin match what_to_do with
- No_remember -> ()
- | Remember i ->
- output_string !oc
- (" Lexing.set_backtrack lexbuf action_" ^
- string_of_int i ^ ";\n")
- end;
- output_all_trans moves
-
-
-(* 3- Generating the entry points *)
-
-let rec output_entries = function
- [] -> failwith "output_entries"
- | (name,state_num) :: rest ->
- output_string !oc (name ^ " lexbuf =\n");
- output_string !oc " Lexing.init lexbuf;\n";
- output_string !oc (" state_" ^ string_of_int state_num ^
- " lexbuf\n");
- match rest with
- [] -> output_string !oc "\n"; ()
- | _ -> output_string !oc "\nand "; output_entries rest
-
-
-(* All together *)
-
-let output_lexdef header (initial_st, st, actions) =
- prerr_int (Array.length st); prerr_string " states, ";
- prerr_int (List.length actions); prerr_string " actions.";
- prerr_newline();
- copy_chunk header;
- output_string !oc "\nlet rec ";
- states := st;
- List.iter output_action actions;
- for i = 0 to Array.length st - 1 do
- output_state i st.(i)
- done;
- output_entries initial_st
-
-
-
diff --git a/test/Lex/scan_aux.ml b/test/Lex/scan_aux.ml
deleted file mode 100644
index c449b13a59..0000000000
--- a/test/Lex/scan_aux.ml
+++ /dev/null
@@ -1,60 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Auxiliaries for the lexical analyzer *)
-
-let brace_depth = ref 0
-let comment_depth = ref 0
-
-exception Lexical_error of string
-
-let initial_string_buffer = String.create 256
-let string_buff = ref initial_string_buffer
-let string_index = ref 0
-
-let reset_string_buffer () =
- string_buff := initial_string_buffer;
- string_index := 0
-
-
-let store_string_char c =
- begin
- if !string_index >= String.length !string_buff then begin
- let new_buff = String.create (String.length !string_buff * 2) in
- String.blit new_buff 0 !string_buff 0 (String.length !string_buff);
- string_buff := new_buff
- end
- end;
- String.unsafe_set !string_buff !string_index c;
- incr string_index
-
-let get_stored_string () =
- let s = String.sub !string_buff 0 !string_index in
- string_buff := initial_string_buffer;
- s
-
-
-let char_for_backslash = function
- 'n' -> '\010' (* '\n' when bootstrapped *)
- | 't' -> '\009' (* '\t' *)
- | 'b' -> '\008' (* '\b' *)
- | 'r' -> '\013' (* '\r' *)
- | c -> c
-
-
-let char_for_decimal_code lexbuf i =
- Char.chr(100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) +
- 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) +
- (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48))
-
diff --git a/test/Lex/scanner.mll b/test/Lex/scanner.mll
deleted file mode 100644
index 131272fdd4..0000000000
--- a/test/Lex/scanner.mll
+++ /dev/null
@@ -1,132 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* The lexical analyzer for lexer definitions. *)
-
-{
-open Syntax
-open Grammar
-open Scan_aux
-}
-
-rule main = parse
- [' ' '\010' '\013' '\009' ] +
- { main lexbuf }
- | "(*"
- { comment_depth := 1;
- comment lexbuf;
- main lexbuf }
- | (['A'-'Z' 'a'-'z'] | '_' ['A'-'Z' 'a'-'z' '\'' '0'-'9'])
- ( '_' ? ['A'-'Z' 'a'-'z' ''' '0'-'9'] ) *
- { match Lexing.lexeme lexbuf with
- "rule" -> Trule
- | "parse" -> Tparse
- | "and" -> Tand
- | "eof" -> Teof
- | s -> Tident s }
- | '"'
- { reset_string_buffer();
- string lexbuf;
- Tstring(get_stored_string()) }
- | "'"
- { Tchar(char lexbuf) }
- | '{'
- { let n1 = Lexing.lexeme_end lexbuf in
- brace_depth := 1;
- let n2 = action lexbuf in
- Taction(Location(n1, n2)) }
- | '=' { Tequal }
- | ";;" { Tend }
- | '|' { Tor }
- | '_' { Tunderscore }
- | "eof" { Teof }
- | '[' { Tlbracket }
- | ']' { Trbracket }
- | '*' { Tstar }
- | '?' { Tmaybe }
- | '+' { Tplus }
- | '(' { Tlparen }
- | ')' { Trparen }
- | '^' { Tcaret }
- | '-' { Tdash }
- | eof
- { raise(Lexical_error "unterminated lexer definition") }
- | _
- { raise(Lexical_error("illegal character " ^ Lexing.lexeme lexbuf)) }
-
-and action = parse
- '{'
- { incr brace_depth;
- action lexbuf }
- | '}'
- { decr brace_depth;
- if !brace_depth = 0 then Lexing.lexeme_start lexbuf else action lexbuf }
- | '"'
- { reset_string_buffer();
- string lexbuf;
- reset_string_buffer();
- action lexbuf }
- | '\''
- { let _ = char lexbuf in action lexbuf }
- | "(*"
- { comment_depth := 1;
- comment lexbuf;
- action lexbuf }
- | eof
- { raise (Lexical_error "unterminated action") }
- | _
- { action lexbuf }
-
-and string = parse
- '"'
- { () }
- | '\\' [' ' '\010' '\013' '\009' '\026' '\012'] +
- { string lexbuf }
- | '\\' ['\\' '"' 'n' 't' 'b' 'r']
- { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1));
- string lexbuf }
- | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9']
- { store_string_char(char_for_decimal_code lexbuf 1);
- string lexbuf }
- | eof
- { raise(Lexical_error "unterminated string") }
- | _
- { store_string_char(Lexing.lexeme_char lexbuf 0);
- string lexbuf }
-
-and char = parse
- [^ '\\'] "'"
- { Lexing.lexeme_char lexbuf 0 }
- | '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'"
- { char_for_backslash (Lexing.lexeme_char lexbuf 1) }
- | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
- { char_for_decimal_code lexbuf 1 }
- | _
- { raise(Lexical_error "bad character constant") }
-
-and comment = parse
- "(*"
- { incr comment_depth; comment lexbuf }
- | "*)"
- { decr comment_depth;
- if !comment_depth = 0 then () else comment lexbuf }
- | '"'
- { reset_string_buffer();
- string lexbuf;
- reset_string_buffer();
- comment lexbuf }
- | eof
- { raise(Lexical_error "unterminated comment") }
- | _
- { comment lexbuf }
diff --git a/test/Lex/syntax.ml b/test/Lex/syntax.ml
deleted file mode 100644
index ff704cd2f0..0000000000
--- a/test/Lex/syntax.ml
+++ /dev/null
@@ -1,40 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* The shallow abstract syntax *)
-
-type location =
- Location of int * int
-
-type regular_expression =
- Epsilon
- | Characters of char list
- | Sequence of regular_expression * regular_expression
- | Alternative of regular_expression * regular_expression
- | Repetition of regular_expression
-
-type lexer_definition =
- Lexdef of location * (string * (regular_expression * location) list) list
-
-(* Representation of automata *)
-
-type automata =
- Perform of int
- | Shift of automata_trans * automata_move array
-and automata_trans =
- No_remember
- | Remember of int
-and automata_move =
- Backtrack
- | Goto of int
diff --git a/test/Lex/testmain.ml b/test/Lex/testmain.ml
deleted file mode 100644
index 96d10a4533..0000000000
--- a/test/Lex/testmain.ml
+++ /dev/null
@@ -1,48 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* The lexer generator. Command-line parsing. *)
-
-#open "syntax";;
-#open "testscanner";;
-#open "grammar";;
-#open "lexgen";;
-#open "output";;
-
-let main () =
- ic := stdin;
- oc := stdout;
- let lexbuf = lexing.from_channel ic in
- let (Lexdef(header,_) as def) =
- try
- grammar.lexer_definition testscanner.main lexbuf
- with
- parsing.Parse_error x ->
- prerr_string "Syntax error around char ";
- prerr_int (lexing.lexeme_start lexbuf);
- prerr_endline ".";
- sys.exit 2
- | scan_aux.Lexical_error s ->
- prerr_string "Lexical error around char ";
- prerr_int (lexing.lexeme_start lexbuf);
- prerr_string ": ";
- prerr_string s;
- prerr_endline ".";
- sys.exit 2 in
- let ((init, states, acts) as dfa) = make_dfa def in
- output_lexdef header dfa
-;;
-
-main(); sys.exit 0
-;;
diff --git a/test/Lex/testscanner.mll b/test/Lex/testscanner.mll
deleted file mode 100644
index 3f1f0f34f4..0000000000
--- a/test/Lex/testscanner.mll
+++ /dev/null
@@ -1,135 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* The lexical analyzer for lexer definitions. *)
-
-{
-#open "syntax";;
-#open "grammar";;
-#open "scan_aux";;
-}
-
-rule main = parse
- _ * "qwertyuiopasdfghjklzxcvbnm0123456789!@#$%^&*()"
- { main lexbuf }
- | [' ' '\010' '\013' '\009' ] +
- { main lexbuf }
- | "(*"
- { comment_depth := 1;
- comment lexbuf;
- main lexbuf }
- | (['A'-'Z' 'a'-'z'] | '_' ['A'-'Z' 'a'-'z' '\'' '0'-'9'])
- ( '_' ? ['A'-'Z' 'a'-'z' ''' '0'-'9'] ) *
- { match lexing.lexeme lexbuf with
- "rule" -> Trule
- | "parse" -> Tparse
- | "and" -> Tand
- | "eof" -> Teof
- | s -> Tident s }
- | '"'
- { reset_string_buffer();
- string lexbuf;
- Tstring(get_stored_string()) }
- | "'"
- { Tchar(char lexbuf) }
- | '{'
- { let n1 = lexing.lexeme_end lexbuf in
- brace_depth := 1;
- let n2 = action lexbuf in
- Taction(Location(n1, n2)) }
- | '=' { Tequal }
- | ";;" { Tend }
- | '|' { Tor }
- | '_' { Tunderscore }
- | "eof" { Teof }
- | '[' { Tlbracket }
- | ']' { Trbracket }
- | '*' { Tstar }
- | '?' { Tmaybe }
- | '+' { Tplus }
- | '(' { Tlparen }
- | ')' { Trparen }
- | '^' { Tcaret }
- | '-' { Tdash }
- | eof
- { raise(Lexical_error "unterminated lexer definition") }
- | _
- { raise(Lexical_error("illegal character " ^ lexing.lexeme lexbuf)) }
-
-and action = parse
- '{'
- { brace_depth := brace_depth + 1;
- action lexbuf }
- | '}'
- { brace_depth := brace_depth - 1;
- if brace_depth = 0 then lexing.lexeme_start lexbuf else action lexbuf }
- | '"'
- { reset_string_buffer();
- string lexbuf;
- reset_string_buffer();
- action lexbuf }
- | '\''
- { char lexbuf; action lexbuf }
- | "(*"
- { comment_depth := 1;
- comment lexbuf;
- action lexbuf }
- | eof
- { raise (Lexical_error "unterminated action") }
- | _
- { action lexbuf }
-
-and string = parse
- '"'
- { () }
- | '\\' [' ' '\010' '\013' '\009' '\026' '\012'] +
- { string lexbuf }
- | '\\' ['\\' '"' 'n' 't' 'b' 'r']
- { store_string_char(char_for_backslash(lexing.lexeme_char lexbuf 1));
- string lexbuf }
- | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9']
- { store_string_char(char_for_decimal_code lexbuf 1);
- string lexbuf }
- | eof
- { raise(Lexical_error "unterminated string") }
- | _
- { store_string_char(lexing.lexeme_char lexbuf 0);
- string lexbuf }
-
-and char = parse
- [^ '\\'] "'"
- { lexing.lexeme_char lexbuf 0 }
- | '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'"
- { char_for_backslash (lexing.lexeme_char lexbuf 1) }
- | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
- { char_for_decimal_code lexbuf 1 }
- | _
- { raise(Lexical_error "bad character constant") }
-
-and comment = parse
- "(*"
- { comment_depth := comment_depth + 1; comment lexbuf }
- | "*)"
- { comment_depth := comment_depth - 1;
- if comment_depth = 0 then () else comment lexbuf }
- | '"'
- { reset_string_buffer();
- string lexbuf;
- reset_string_buffer();
- comment lexbuf }
- | eof
- { raise(Lexical_error "unterminated comment") }
- | _
- { comment lexbuf }
-;;
diff --git a/test/Makefile b/test/Makefile
deleted file mode 100644
index 395740d1a3..0000000000
--- a/test/Makefile
+++ /dev/null
@@ -1,195 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-include ../config/Makefile
-
-CAMLC=../boot/ocamlrun ../ocamlc
-CAMLOPT=../boot/ocamlrun ../ocamlopt
-COMPFLAGS=-nostdlib -I ../stdlib -I KB -I Lex
-OPTFLAGS=-S
-CAMLYACC=../yacc/ocamlyacc
-YACCFLAGS=-v
-CAMLLEX=../boot/ocamlrun ../lex/ocamllex
-CAMLDEP=../boot/ocamlrun ../tools/ocamldep
-CAMLRUN=../byterun/ocamlrun
-CODERUNPARAMS=OCAMLRUNPARAM='o=100'
-
-BYTE_EXE=fib.byt takc.byt taku.byt sieve.byt quicksort.byt quicksort.fast.byt \
- fft.byt fft.fast.byt soli.byt soli.fast.byt boyer.byt kb.byt \
- nucleic.byt genlex.byt bdd.byt hamming.byt sorts.byt \
- almabench.byt almabench.fast.byt
-
-CODE_EXE=$(BYTE_EXE:.byt=.out)
-
-default: all codetest bytetest
-
-all: $(BYTE_EXE) $(CODE_EXE)
-
-# Nucleic
-
-nucleic.out: nucleic.ml
- case $(ARCH) in \
- i386) sed -e '/<HAND_CSE>/,/<\/HAND_CSE>/d' -e '/NO_CSE>/d' \
- nucleic.ml > nucleic.mlt; \
- $(CAMLOPT) $(COMPFLAGS) $(OPTFLAGS) -o nucleic.out nucleic.mlt;\
- rm -f nucleic.mlt;; \
- *) $(CAMLOPT) $(COMPFLAGS) $(OPTFLAGS) -o nucleic.out nucleic.ml; \
- esac
-
-# KB
-
-BYTE_KB=KB/terms.cmo KB/equations.cmo KB/kb.cmo KB/orderings.cmo KB/kbmain.cmo
-CODE_KB=$(BYTE_KB:.cmo=.cmx)
-
-kb.byt: $(BYTE_KB)
- $(CAMLC) $(COMPFLAGS) $(BYTE_KB) -o kb.byt
-kb.out: $(CODE_KB)
- $(CAMLOPT) $(COMPFLAGS) $(OPTFLAGS) $(CODE_KB) -o kb.out
-
-clean::
- rm -f KB/*.cm[iox] KB/*.[os]
- rm -f KB/*~
-
-# Genlex
-
-BYTE_GENLEX=Lex/syntax.cmo Lex/scan_aux.cmo Lex/scanner.cmo Lex/gram_aux.cmo \
- Lex/grammar.cmo Lex/lexgen.cmo Lex/output.cmo Lex/main.cmo
-CODE_GENLEX=$(BYTE_GENLEX:.cmo=.cmx)
-
-genlex.byt: $(BYTE_GENLEX)
- $(CAMLC) $(COMPFLAGS) $(BYTE_GENLEX) -o genlex.byt
-genlex.out: $(CODE_GENLEX)
- $(CAMLOPT) $(COMPFLAGS) $(OPTFLAGS) $(CODE_GENLEX) -o genlex.out
-
-clean::
- rm -f Lex/*.cm[iox] Lex/*.[os]
- rm -f Lex/*~
- rm -f Lex/grammar.output
-
-Lex/grammar.ml Lex/grammar.mli: Lex/grammar.mly ../yacc/ocamlyacc$(EXE)
- $(CAMLYACC) $(YACCFLAGS) Lex/grammar.mly
-
-clean::
- rm -f Lex/grammar.ml Lex/grammar.mli
-beforedepend:: Lex/grammar.ml Lex/grammar.mli
-
-Lex/scanner.ml: Lex/scanner.mll ../lex/ocamllex
- $(CAMLLEX) Lex/scanner.mll
-
-clean::
- rm -f Lex/scanner.ml
-beforedepend:: Lex/scanner.ml
-
-# Common rules
-
-.SUFFIXES:
-.SUFFIXES: .mli .ml .cmi .cmo .cmx .byt .fast.byt .out .fast.out
-
-.ml.byt:
- $(CAMLC) $(COMPFLAGS) -o $*.byt $<
-
-.ml.fast.byt:
- cp $*.ml $*_fast.ml
- $(CAMLC) $(COMPFLAGS) -unsafe -o $*.fast.byt $*_fast.ml
- rm -f $*_fast.ml
-
-.ml.out:
- $(CAMLOPT) $(COMPFLAGS) $(OPTFLAGS) -o $*.out $<
-
-.ml.fast.out:
- cp $*.ml $*_fast.ml
- $(CAMLOPT) $(COMPFLAGS) $(OPTFLAGS) -unsafe -o $*.fast.out $*_fast.ml
- rm -f $*_fast.ml
-
-.mli.cmi:
- $(CAMLC) $(COMPFLAGS) -c $<
-
-.ml.cmo:
- $(CAMLC) $(COMPFLAGS) -c $<
-
-.ml.cmx:
- $(CAMLOPT) $(COMPFLAGS) $(OPTFLAGS) -c $<
-
-$(BYTE_EXE) $(BYTE_KB) $(BYTE_GENLEX): ../ocamlc
-$(BYTE_EXE): ../stdlib/stdlib.cma
-$(CODE_EXE) $(CODE_KB) $(CODE_GENLEX): ../ocamlopt
-$(CODE_EXE): ../stdlib/stdlib.cmxa ../stdlib/libasmrun.a
-
-clean::
- rm -f *.byt *.out
- rm -f *.cm[iox] *.[os]
- rm -f *~
-
-# Regression test
-
-test: codetest
-
-bytetest:
- set -e; \
- for prog in $(BYTE_EXE:.byt=); do \
- echo $$prog; \
- if test -f Results/$$prog.runtest; then \
- sh Results/$$prog.runtest test $(CAMLRUN) $$prog.byt; \
- else \
- $(CAMLRUN) $$prog.byt | cmp - Results/$$prog.out; \
- fi; \
- done
-
-codetest:
- set -e; \
- for prog in $(CODE_EXE:.out=); do \
- echo $$prog; \
- if test -f Results/$$prog.runtest; then \
- sh Results/$$prog.runtest test ./$$prog.out; \
- else \
- ./$$prog.out | cmp - Results/$$prog.out; \
- fi; \
- done
-
-clean::
- rm -f Lex/testscanner.ml
-
-# Benchmark
-
-bench: codebench
-
-bytebench:
- set -e; \
- for prog in $(BYTE_EXE:.byt=); do \
- echo "$$prog " | cut -c 1-16 | tr -d '\012'; \
- if test -f Results/$$prog.runtest; then \
- sh Results/$$prog.runtest bench $(CAMLRUN) $$prog.byt; \
- else \
- xtime -o /dev/null -e /dev/null $(CAMLRUN) $$prog.byt; \
- fi; \
- done
-
-codebench:
- set -e; \
- for prog in $(CODE_EXE:.out=); do \
- echo "$$prog " | cut -c 1-16 | tr -d '\012'; \
- if test -f Results/$$prog.runtest; then \
- $(CODERUNPARAMS) sh Results/$$prog.runtest bench ./$$prog.out; \
- else \
- $(CODERUNPARAMS) xtime -repeat 3 -o /dev/null -e /dev/null ./$$prog.out; \
- fi; \
- done
-
-# Dependencies
-
-depend: beforedepend
- $(CAMLDEP) -I KB -I Lex *.mli *.ml KB/*.mli KB/*.ml Lex/*.mli Lex/*.ml > .depend
-
-include .depend
-
diff --git a/test/Makefile.Mac b/test/Makefile.Mac
deleted file mode 100644
index 61153dfbee..0000000000
--- a/test/Makefile.Mac
+++ /dev/null
@@ -1,125 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-CAMLC = ::boot:ocamlrun ::ocamlc -I ::stdlib: -I :KB: -I :Lex:
-CAMLYACC = ::yacc:ocamlyacc
-CAMLLEX = ::boot:ocamlrun ::lex:ocamllex
-CAMLDEP = ::boot:ocamlrun ::tools:ocamldep
-CAMLRUN = ::byterun:ocamlrun
-
-BYTE_EXE = fib.byt takc.byt taku.byt sieve.byt quicksort.byt ¶
- quicksort.fast.byt ¶
- fft.byt fft.fast.byt soli.byt soli.fast.byt boyer.byt kb.byt ¶
- nucleic.byt genlex.byt bdd.byt
-
-all Ä test
-
-# KB
-
-BYTE_KB = :KB:terms.cmo :KB:equations.cmo :KB:kb.cmo :KB:orderings.cmo ¶
- :KB:kbmain.cmo
-
-kb.byt Ä {BYTE_KB}
- {CAMLC} {BYTE_KB} -o kb.byt
-
-clean ÄÄ
- delete -i :KB:Å.cm[io] || set status 0
-
-# Genlex
-
-BYTE_GENLEX = :Lex:syntax.cmo :Lex:scan_aux.cmo :Lex:scanner.cmo ¶
- :Lex:gram_aux.cmo :Lex:grammar.cmo :Lex:lexgen.cmo :Lex:output.cmo :Lex:main.cmo
-
-genlex.byt Ä {BYTE_GENLEX}
- {CAMLC} {BYTE_GENLEX} -o genlex.byt
-
-clean ÄÄ
- delete -i :Lex:Å.cm[io] || set status 0
-
-:Lex:grammar.mli Ä :Lex:grammar.ml
- echo -n
-
-:Lex:grammar.ml Ä :Lex:grammar.mly ::yacc:ocamlyacc
- {CAMLYACC} {YACCFLAGS} :Lex:grammar.mly
-
-clean ÄÄ
- delete -i :Lex:grammar.ml :Lex:grammar.mli
-
-beforedepend ÄÄ :Lex:grammar.ml :Lex:grammar.mli
-
-:Lex:scanner.ml Ä :Lex:scanner.mll ::lex:ocamllex
- {CAMLLEX} :Lex:scanner.mll
-
-clean ÄÄ
- delete -i :Lex:scanner.ml
-
-beforedepend ÄÄ :Lex:scanner.ml
-
-# Common rules
-
-.byt Ä .ml
- {CAMLC} -o {targdir}{default}.byt {depdir}{default}.ml
-
-.fast.byt Ä .ml
- {CAMLC} -unsafe -o {targdir}{default}.fast.byt {depdir}{default}.ml
-
-.cmi Ä .mli
- {CAMLC} -c {depdir}{default}.mli
-
-.cmo Ä .ml
- {CAMLC} -c {depdir}{default}.ml
-
-{BYTE_EXE} {BYTE_KB} {BYTE_GENLEX} Ä ::ocamlc
-{BYTE_EXE} Ä ::stdlib:stdlib.cma
-
-clean ÄÄ
- delete -i Å.byt || set status 0
- delete -i Å.cm[io] || set status 0
- directory :Moretest; domake clean; directory ::
-
-# Regression test
-
-test Ä {BYTE_EXE}
- set echo 0
- for prog in `echo {BYTE_EXE} | streamedit -e '1 replace /.byt/ "" -c °'`
- echo {prog}
- if "`exists :Results:{prog}.runtest.Mac`"
- :Results:{prog}.runtest.Mac test {CAMLRUN} {prog}.byt
- else
- {CAMLRUN} {prog}.byt > "{tempfolder}ocaml-test"
- equal -d "{tempfolder}ocaml-test" :Results:{prog}.out
- end
- end
-
-clean ÄÄ
- delete -i :Lex:testscanner.ml "{tempfolder}ocaml-test"
-
-# Benchmark
-
-bench Ä {BYTE_EXE}
- set echo 0
- for prog in `echo {BYTE_EXE} | streamedit -e '1 replace /.byt/ "" -c °'`
- echo {prog}
- if "`exists :Results:{prog}.runtest.Mac`"
- :Results:{prog}.runtest.Mac bench {CAMLRUN} {prog}.byt
- else
- time "{CAMLRUN} {prog}.byt ·dev:null"
- end
- end
-
-# Dependencies
-
-depend Ä beforedepend
- {CAMLDEP} -I :KB: -I :Lex: Å.ml :KB:Å.mli :KB:Å.ml :Lex:Å.mli ¶
- :Lex:Å.ml > Makefile.Mac.depend
diff --git a/test/Makefile.Mac.depend b/test/Makefile.Mac.depend
deleted file mode 100644
index 23f2bd5954..0000000000
--- a/test/Makefile.Mac.depend
+++ /dev/null
@@ -1,28 +0,0 @@
-:KB:equations.cmiÄ :KB:terms.cmi
-:KB:kb.cmiÄ :KB:equations.cmi :KB:terms.cmi
-:KB:orderings.cmiÄ :KB:terms.cmi
-:KB:equations.cmoÄ :KB:terms.cmi :KB:equations.cmi
-:KB:equations.cmxÄ :KB:terms.cmx :KB:equations.cmi
-:KB:kb.cmoÄ :KB:equations.cmi :KB:terms.cmi :KB:kb.cmi
-:KB:kb.cmxÄ :KB:equations.cmx :KB:terms.cmx :KB:kb.cmi
-:KB:kbmain.cmoÄ :KB:equations.cmi :KB:kb.cmi :KB:orderings.cmi :KB:terms.cmi
-:KB:kbmain.cmxÄ :KB:equations.cmx :KB:kb.cmx :KB:orderings.cmx :KB:terms.cmx
-:KB:orderings.cmoÄ :KB:terms.cmi :KB:orderings.cmi
-:KB:orderings.cmxÄ :KB:terms.cmx :KB:orderings.cmi
-:KB:terms.cmoÄ :KB:terms.cmi
-:KB:terms.cmxÄ :KB:terms.cmi
-:Lex:grammar.cmiÄ :Lex:syntax.cmo
-:Lex:gram_aux.cmoÄ :Lex:syntax.cmo
-:Lex:gram_aux.cmxÄ :Lex:syntax.cmx
-:Lex:grammar.cmoÄ :Lex:gram_aux.cmo :Lex:syntax.cmo :Lex:grammar.cmi
-:Lex:grammar.cmxÄ :Lex:gram_aux.cmx :Lex:syntax.cmx :Lex:grammar.cmi
-:Lex:lexgen.cmoÄ :Lex:syntax.cmo
-:Lex:lexgen.cmxÄ :Lex:syntax.cmx
-:Lex:main.cmoÄ :Lex:grammar.cmi :Lex:lexgen.cmo :Lex:output.cmo ¶
- :Lex:scan_aux.cmo :Lex:scanner.cmo :Lex:syntax.cmo
-:Lex:main.cmxÄ :Lex:grammar.cmx :Lex:lexgen.cmx :Lex:output.cmx ¶
- :Lex:scan_aux.cmx :Lex:scanner.cmx :Lex:syntax.cmx
-:Lex:output.cmoÄ :Lex:syntax.cmo
-:Lex:output.cmxÄ :Lex:syntax.cmx
-:Lex:scanner.cmoÄ :Lex:grammar.cmi :Lex:scan_aux.cmo :Lex:syntax.cmo
-:Lex:scanner.cmxÄ :Lex:grammar.cmx :Lex:scan_aux.cmx :Lex:syntax.cmx
diff --git a/test/Moretest/.cvsignore b/test/Moretest/.cvsignore
deleted file mode 100644
index 55c27ce02e..0000000000
--- a/test/Moretest/.cvsignore
+++ /dev/null
@@ -1,2 +0,0 @@
-*.out
-*.byt
diff --git a/test/Moretest/.depend b/test/Moretest/.depend
deleted file mode 100644
index e749398f46..0000000000
--- a/test/Moretest/.depend
+++ /dev/null
@@ -1,6 +0,0 @@
-multdef.cmo: multdef.cmi
-multdef.cmx: multdef.cmi
-structinit2.cmo: structinit1.cmo
-structinit2.cmx: structinit1.cmx
-usemultdef.cmo: multdef.cmi
-usemultdef.cmx: multdef.cmx
diff --git a/test/Moretest/Makefile b/test/Moretest/Makefile
deleted file mode 100644
index e2b69441b0..0000000000
--- a/test/Moretest/Makefile
+++ /dev/null
@@ -1,177 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-include ../../config/Makefile
-
-CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib
-CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib
-OPTFLAGS=-S
-CAMLDEP=../../boot/ocamlrun ../../tools/ocamldep
-CAMLRUN=../../byterun/ocamlrun
-CODERUNPARAMS=OCAMLRUNPARAM='o=100'
-
-callback.byt: callback.cmo callbackprim.o
- $(CAMLC) -o callback.byt -custom callback.cmo callbackprim.o ../../otherlibs/unix/libunix.a
-callback.out: callback.cmx callbackprim.o
- $(CAMLOPT) -o callback.out callback.cmx callbackprim.o ../../otherlibs/unix/libunix.a
-
-manyargs.byt: manyargs.cmo manyargsprim.o
- $(CAMLC) -o manyargs.byt -custom manyargs.cmo manyargsprim.o
-manyargs.out: manyargs.cmx manyargsprim.o
- $(CAMLOPT) -o manyargs.out manyargs.cmx manyargsprim.o
-
-multdef.out: multdef.cmx usemultdef.cmx
- $(CAMLOPT) -o multdef.out multdef.cmx usemultdef.cmx
-
-cm.byt: cmcaml.ml cmstub.c cmmain.c
- $(CAMLC) -custom -o cm.byt cmcaml.ml cmstub.c cmmain.c
-
-cmlinked.out: cmcaml.ml cmstub.c cmmain.c
- $(CAMLC) -output-obj -o cm.o cmcaml.ml
- $(BYTECC) -g -o cmlinked.out cm.o -I../../byterun -DNO_BYTECODE_FILE cmstub.c cmmain.c ../../byterun/libcamlrun.a $(BYTECCLIBS)
-
-cm.out: cmcaml.ml cmstub.c cmmain.c
- $(CAMLOPT) -output-obj -o cm.o cmcaml.ml
- $(NATIVECC) -g -o cm.out cm.o -I$(LIBDIR) -DNO_BYTECODE_FILE cmstub.c cmmain.c ../../asmrun/libasmrun.a $(NATIVECCLIBS)
-
-bigarrays.byt: ../../otherlibs/bigarray/bigarray.cma \
- ../../otherlibs/bigarray/libbigarray.a bigarrays.ml
- $(CAMLC) -custom -o bigarrays.byt \
- -I ../../otherlibs/bigarray \
- -I ../../otherlibs/unix \
- unix.cma bigarray.cma bigarrays.ml
-
-bigarrays.out: ../../otherlibs/bigarray/bigarray.cmxa \
- ../../otherlibs/bigarray/libbigarray.a bigarrays.ml
- $(CAMLOPT) $(OPTFLAGS) -o bigarrays.out \
- -I ../../otherlibs/bigarray \
- -I ../../otherlibs/unix \
- unix.cmxa bigarray.cmxa bigarrays.ml
-
-bigarrf.byt: bigarrf.o bigarrfstub.o \
- ../../otherlibs/bigarray/bigarray.cma \
- ../../otherlibs/bigarray/libbigarray.a bigarrfml.ml
- $(CAMLC) -custom -o bigarrf.byt \
- -I ../../otherlibs/bigarray \
- -I ../../otherlibs/unix \
- unix.cma bigarray.cma bigarrf.ml \
- bigarrf.o bigarrfstub.o \
- ../../byterun/libcamlrun.a -cclib -lg2c
-
-bigarrf.out: bigarrf.o bigarrfstub.o \
- ../../otherlibs/bigarray/bigarray.cma \
- ../../otherlibs/bigarray/libbigarray.a bigarrfml.ml
- $(CAMLOPT) $(OPTFLAGS) -o bigarrf.out \
- -I ../../otherlibs/bigarray \
- -I ../../otherlibs/unix \
- unix.cma bigarray.cma bigarrf.ml \
- bigarrf.o bigarrfstub.o \
- ../../byterun/libcamlrun.a -cclib -lg2c
-
-bigarrf.o: bigarrf.f
- g77 -c bigarrf.f
-
-bigarrfstub.o: bigarrfstub.c
- $(NATIVECC) $(NATIVECCCOMPOPTS) -I../../byterun -I../../otherlibs/bigarray -c bigarrfstub.c
-
-fftba.byt: fftba.ml
- $(CAMLC) -o fftba.byt -I ../../otherlibs/bigarray \
- bigarray.cma fftba.ml
-
-fftba.out: fftba.ml
- $(CAMLOPT) $(OPTFLAGS) -o fftba.out -I ../../otherlibs/bigarray \
- bigarray.cmxa fftba.ml
-
-globroots.byt: globroots.ml globrootsprim.o
- $(CAMLC) -custom -o globroots.byt globroots.ml globrootsprim.o
-
-globroots.out: globroots.ml globrootsprim.o
- $(CAMLOPT) -o globroots.out globroots.ml globrootsprim.o
-
-globrootsprim.o: globrootsprim.c
- $(BYTECC) $(BYTECCCOMPOPTS) -I../../byterun -c globrootsprim.c
-
-float.byt: float.cmo
- ${CAMLC} -o float.byt float.cmo
-float.out: float.cmx
- ${CAMLOPT} -o float.out float.cmx
-
-intext.byt: intext.cmo intextaux.o
- ${CAMLC} -o intext.byt -custom intext.cmo intextaux.o
-intext.out: intext.cmx intextaux.o
- ${CAMLOPT} -o intext.out intext.cmx intextaux.o
-
-tscanf.byt: tscanf.cmo
- ${CAMLC} -o tscanf.byt tscanf.cmo
-tscanf.out: tscanf.cmx
- ${CAMLOPT} -o tscanf.out tscanf.cmx
-
-scanf: tscanf.byt tscanf.out
- ./tscanf.byt
- ./tscanf.out
-
-regexp.byt: ../../otherlibs/str/str.cma regexp.ml
- $(CAMLC) -custom -I ../../otherlibs/str -o regexp.byt str.cma regexp.ml
-regexp.opt: ../../otherlibs/str/str.cmxa regexp.ml
- $(CAMLOPT) -I ../../otherlibs/str -o regexp.opt str.cmxa regexp.ml
-
-md5.out: md5.ml
- $(CAMLOPT) -unsafe -inline 100 -o md5.out md5.ml
-
-# Common rules
-
-.SUFFIXES:
-.SUFFIXES: .mli .ml .cmi .cmo .cmx .byt .fast.byt .out .fast.out .c .o
-
-.ml.byt:
- $(CAMLC) -o $*.byt $<
-
-.ml.fast.byt:
- cp $*.ml $*_fast.ml
- $(CAMLC) -unsafe -o $*.fast.byt $*_fast.ml
- rm -f $*_fast.ml
-
-.ml.out:
- $(CAMLOPT) $(OPTFLAGS) -o $*.out $<
-
-.ml.fast.out:
- cp $*.ml $*_fast.ml
- $(CAMLOPT) $(OPTFLAGS) -unsafe -o $*.fast.out $*_fast.ml
- rm -f $*_fast.ml
-
-.mli.cmi:
- $(CAMLC) -c $<
-
-.ml.cmo:
- $(CAMLC) -c $<
-
-.ml.cmx:
- $(CAMLOPT) $(OPTFLAGS) -c $<
-
-.c.o:
- $(NATIVECC) $(NATIVECCCOMPOPTS) -I../../byterun -c $<
-
-clean::
- rm -f *.byt *.out
- rm -f *.cm[iox] *.[os]
- rm -f *~
- rm -f intext.data
-
-# Dependencies
-
-depend:
- $(CAMLDEP) *.mli *.ml > .depend
-
-include .depend
-
diff --git a/test/Moretest/Makefile.Mac b/test/Moretest/Makefile.Mac
deleted file mode 100644
index 0ebb0f0f62..0000000000
--- a/test/Moretest/Makefile.Mac
+++ /dev/null
@@ -1,76 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-CAMLC = :::boot:ocamlrun :::ocamlc -I :::stdlib:
-CAMLDEP = :::boot:ocamlrun :::tools:ocamldep
-CAMLRUN = :::byterun:ocamlrun
-
-FILES = arrays.byt callback.byt equality.byt intext.byt io.byt manyargs.byt ¶
- multdef.byt patmatch.byt recvalues.byt sets.byt signals.byt syserror.byt ¶
- testrandom.byt usemultdef.byt wc.byt tscanf.byt
-
-all Ä {FILES}
- duplicate -y :::ocaml ":/vmunix"
- duplicate -y :::byterun:interp.a ":/etc/hosts"
- set -e ocamlcommands "{tempfolder}ocamlcommands"
- set exit 0
- for i in {FILES}
- :{i}
- end
- delete -i ":/etc/hosts" ":/vmunix" "{tempfolder}ocamlcommands"
-
-callback.byt Ä callback.cmo callbackprim.c.o callbackprim.c.x
- alias ocamlc "{CAMLC}"
- :::tools:ocamlc-custom -o callback.byt callback.cmo callbackprim.c.[ox]
-
-manyargs.byt Ä manyargs.cmo manyargsprim.c.o manyargsprim.c.x
- alias ocamlc "{CAMLC}"
- :::tools:ocamlc-custom -o manyargs.byt manyargs.cmo manyargsprim.c.[ox]
-
-usemultdef.byt Ä multdef.cmo usemultdef.cmo
- {CAMLC} -o usemultdef.byt multdef.cmo usemultdef.cmo
-
-# Common rules
-
-.byt Ä .cmo
- {CAMLC} -o {default}.byt {default}.cmo
-
-.fast.byt Ä .ml
- {CAMLC} -unsafe -o {default}.fast.byt {default}.fast.cmo
-
-.cmi Ä .mli
- {CAMLC} -c {default}.mli
-
-.cmo Ä .ml
- {CAMLC} -c {default}.ml
-
-.fast.cmo Ä .ml
- {CAMLC} -unsafe -c {default}.ml
-
-.c.o Ä .c
- sc -w 7 -i :::byterun: {default}.c -o {default}.c.o
-
-.c.x Ä .c
- mrc -w 7 -w 35 -i :::byterun: {default}.c -o {default}.c.x
-
-clean ÄÄ
- delete -i Å.byt || set status 0
- delete -i Å.cm[io] || set status 0
- delete -i Å.c.[ox] || set status 0
- delete -i intext.data
-
-# Dependencies
-
-depend Ä
- {CAMLDEP} Å.mli Å.ml > Makefile.Mac.depend
diff --git a/test/Moretest/Makefile.Mac.depend b/test/Moretest/Makefile.Mac.depend
deleted file mode 100644
index 288ebb9fdf..0000000000
--- a/test/Moretest/Makefile.Mac.depend
+++ /dev/null
@@ -1,4 +0,0 @@
-multdef.cmoÄ multdef.cmi
-multdef.cmxÄ multdef.cmi
-usemultdef.cmoÄ multdef.cmi
-usemultdef.cmxÄ multdef.cmx
diff --git a/test/Moretest/arrays.ml b/test/Moretest/arrays.ml
deleted file mode 100644
index bbe8be3279..0000000000
--- a/test/Moretest/arrays.ml
+++ /dev/null
@@ -1,86 +0,0 @@
-let bigarray n = [|
-n+0; n+1; n+2; n+3; n+4; n+5; n+6; n+7; n+8; n+9; n+10; n+11; n+12;
-n+13; n+14; n+15; n+16; n+17; n+18; n+19; n+20; n+21; n+22; n+23;
-n+24; n+25; n+26; n+27; n+28; n+29; n+30; n+31; n+32; n+33; n+34;
-n+35; n+36; n+37; n+38; n+39; n+40; n+41; n+42; n+43; n+44; n+45;
-n+46; n+47; n+48; n+49; n+50; n+51; n+52; n+53; n+54; n+55; n+56;
-n+57; n+58; n+59; n+60; n+61; n+62; n+63; n+64; n+65; n+66; n+67;
-n+68; n+69; n+70; n+71; n+72; n+73; n+74; n+75; n+76; n+77; n+78;
-n+79; n+80; n+81; n+82; n+83; n+84; n+85; n+86; n+87; n+88; n+89;
-n+90; n+91; n+92; n+93; n+94; n+95; n+96; n+97; n+98; n+99; n+100;
-n+101; n+102; n+103; n+104; n+105; n+106; n+107; n+108; n+109; n+110;
-n+111; n+112; n+113; n+114; n+115; n+116; n+117; n+118; n+119; n+120;
-n+121; n+122; n+123; n+124; n+125; n+126; n+127; n+128; n+129; n+130;
-n+131; n+132; n+133; n+134; n+135; n+136; n+137; n+138; n+139; n+140;
-n+141; n+142; n+143; n+144; n+145; n+146; n+147; n+148; n+149; n+150;
-n+151; n+152; n+153; n+154; n+155; n+156; n+157; n+158; n+159; n+160;
-n+161; n+162; n+163; n+164; n+165; n+166; n+167; n+168; n+169; n+170;
-n+171; n+172; n+173; n+174; n+175; n+176; n+177; n+178; n+179; n+180;
-n+181; n+182; n+183; n+184; n+185; n+186; n+187; n+188; n+189; n+190;
-n+191; n+192; n+193; n+194; n+195; n+196; n+197; n+198; n+199; n+200;
-n+201; n+202; n+203; n+204; n+205; n+206; n+207; n+208; n+209; n+210;
-n+211; n+212; n+213; n+214; n+215; n+216; n+217; n+218; n+219; n+220;
-n+221; n+222; n+223; n+224; n+225; n+226; n+227; n+228; n+229; n+230;
-n+231; n+232; n+233; n+234; n+235; n+236; n+237; n+238; n+239; n+240;
-n+241; n+242; n+243; n+244; n+245; n+246; n+247; n+248; n+249; n+250;
-n+251; n+252; n+253; n+254; n+255; n+256; n+257; n+258; n+259; n+260;
-n+261; n+262; n+263; n+264; n+265; n+266; n+267; n+268; n+269; n+270;
-n+271; n+272; n+273; n+274; n+275; n+276; n+277; n+278; n+279; n+280;
-n+281; n+282; n+283; n+284; n+285; n+286; n+287; n+288; n+289; n+290;
-n+291; n+292; n+293; n+294; n+295; n+296; n+297; n+298; n+299
-|]
-
-let test1 () =
- let a = bigarray 12345 in
- Gc.full_major();
- for i = 0 to Array.length a - 1 do
- if a.(i) <> 12345 + i then print_string "Test1: error\n"
- done
-
-let testcopy a =
- Array.copy a = a
-
-let test2 () =
- if not (testcopy [|1;2;3;4;5|]) then
- print_string "Test2: failed on int array\n";
- if not (testcopy [|1.2;2.3;3.4;4.5|]) then
- print_string "Test2: failed on float array\n";
- if not (testcopy [|"un"; "deux"; "trois"|]) then
- print_string "Test2: failed on string array\n"
-
-module AbstractFloat =
- (struct
- type t = float
- let to_float x = x
- let from_float x = x
- end :
- sig
- type t
- val to_float: t -> float
- val from_float: float -> t
- end)
-
-let test3 () =
- let t1 = AbstractFloat.from_float 1.0
- and t2 = AbstractFloat.from_float 2.0
- and t3 = AbstractFloat.from_float 3.0 in
- let v = [|t1;t2;t3|] in
- let w = Array.create 2 t1 in
- let u = Array.copy v in
- if not (AbstractFloat.to_float v.(0) = 1.0 &&
- AbstractFloat.to_float v.(1) = 2.0 &&
- AbstractFloat.to_float v.(2) = 3.0) then
- print_string "Test3: failed on v\n";
- if not (AbstractFloat.to_float w.(0) = 1.0 &&
- AbstractFloat.to_float w.(1) = 1.0) then
- print_string "Test3: failed on w\n";
- if not (AbstractFloat.to_float u.(0) = 1.0 &&
- AbstractFloat.to_float u.(1) = 2.0 &&
- AbstractFloat.to_float u.(2) = 3.0) then
- print_string "Test3: failed on u\n"
-
-let _ =
- test1();
- test2();
- test3();
- exit 0
diff --git a/test/Moretest/bigarrays.ml b/test/Moretest/bigarrays.ml
deleted file mode 100644
index 302ade999f..0000000000
--- a/test/Moretest/bigarrays.ml
+++ /dev/null
@@ -1,720 +0,0 @@
-open Bigarray
-open Printf
-open Complex
-
-(* Test harness *)
-
-let error_occurred = ref false
-
-let function_tested = ref ""
-
-let testing_function s =
- function_tested := s;
- print_newline();
- print_string s;
- print_newline()
-
-let test test_number answer correct_answer =
- flush stdout;
- flush stderr;
- if answer <> correct_answer then begin
- eprintf "*** Bad result (%s, test %d)\n" !function_tested test_number;
- flush stderr;
- error_occurred := true
- end else begin
- printf " %d..." test_number
- end
-
-(* One-dimensional arrays *)
-
-let _ =
- testing_function "------ Array1 --------";
- testing_function "create/set/get";
- let test_setget kind vals =
- let rec set a i = function
- [] -> ()
- | (v1, v2) :: tl -> a.{i} <- v1; set a (i+1) tl in
- let rec test a i = function
- [] -> true
- | (v1, v2) :: tl -> a.{i} = v2 && test a (i+1) tl in
- let ca = Array1.create kind c_layout (List.length vals) in
- let fa = Array1.create kind fortran_layout (List.length vals) in
- set ca 0 vals;
- set fa 1 vals;
- test ca 0 vals && test fa 1 vals in
- test 1 true
- (test_setget int8_signed
- [0, 0;
- 123, 123;
- -123, -123;
- 456, -56;
- 0x101, 1]);
- test 2 true
- (test_setget int8_unsigned
- [0, 0;
- 123, 123;
- -123, 133;
- 456, 0xc8;
- 0x101, 1]);
- test 3 true
- (test_setget int16_signed
- [0, 0;
- 123, 123;
- -123, -123;
- 31456, 31456;
- -31456, -31456;
- 65432, -104;
- 0x10001, 1]);
- test 4 true
- (test_setget int16_unsigned
- [0, 0;
- 123, 123;
- -123, 65413;
- 31456, 31456;
- -31456, 34080;
- 65432, 65432;
- 0x10001, 1]);
- test 5 true
- (test_setget int
- [0, 0;
- 123, 123;
- -456, -456;
- max_int, max_int;
- min_int, min_int;
- 0x12345678, 0x12345678;
- -0x12345678, -0x12345678]);
- test 6 true
- (test_setget int32
- [Int32.zero, Int32.zero;
- Int32.of_int 123, Int32.of_int 123;
- Int32.of_int (-456), Int32.of_int (-456);
- Int32.max_int, Int32.max_int;
- Int32.min_int, Int32.min_int;
- Int32.of_string "0x12345678", Int32.of_string "0x12345678"]);
- test 7 true
- (test_setget int64
- [Int64.zero, Int64.zero;
- Int64.of_int 123, Int64.of_int 123;
- Int64.of_int (-456), Int64.of_int (-456);
- Int64.max_int, Int64.max_int;
- Int64.min_int, Int64.min_int;
- Int64.of_string "0x123456789ABCDEF0",
- Int64.of_string "0x123456789ABCDEF0"]);
- test 8 true
- (test_setget nativeint
- [Nativeint.zero, Nativeint.zero;
- Nativeint.of_int 123, Nativeint.of_int 123;
- Nativeint.of_int (-456), Nativeint.of_int (-456);
- Nativeint.max_int, Nativeint.max_int;
- Nativeint.min_int, Nativeint.min_int;
- Nativeint.of_string "0x12345678",
- Nativeint.of_string "0x12345678"]);
- test 9 true
- (test_setget float32
- [0.0, 0.0;
- 4.0, 4.0;
- -0.5, -0.5;
- 655360.0, 655360.0]);
- test 10 true
- (test_setget float64
- [0.0, 0.0;
- 4.0, 4.0;
- -0.5, -0.5;
- 1.2345678, 1.2345678;
- 3.1415e10, 3.1415e10]);
- test 11 true
- (test_setget complex32
- [Complex.zero, Complex.zero;
- Complex.one, Complex.one;
- Complex.i, Complex.i;
- {im = 0.5; re = -2.0}, {im = 0.5; re = -2.0}]);
- test 12 true
- (test_setget complex64
- [Complex.zero, Complex.zero;
- Complex.one, Complex.one;
- Complex.i, Complex.i;
- {im=0.5;re= -2.0}, {im=0.5;re= -2.0};
- {im=3.1415;re=1.2345678}, {im=3.1415;re=1.2345678}]);
-
- let from_list kind vals =
- let a = Array1.create kind c_layout (List.length vals) in
- let rec set i = function
- [] -> ()
- | hd :: tl -> a.{i} <- hd; set (i+1) tl in
- set 0 vals;
- a in
- let from_list_fortran kind vals =
- let a = Array1.create kind fortran_layout (List.length vals) in
- let rec set i = function
- [] -> ()
- | hd :: tl -> a.{i} <- hd; set (i+1) tl in
- set 1 vals;
- a in
-
- testing_function "set/get (specialized)";
- let a = Array1.create int c_layout 3 in
- for i = 0 to 2 do a.{i} <- i done;
- for i = 0 to 2 do test (i+1) a.{i} i done;
- test 4 true (try a.{3}; false with Invalid_argument _ -> true);
- test 5 true (try a.{-1}; false with Invalid_argument _ -> true);
-
- let b = Array1.create float64 fortran_layout 3 in
- for i = 1 to 3 do b.{i} <- float i done;
- for i = 1 to 3 do test (5 + i) b.{i} (float i) done;
- test 8 true (try b.{4}; false with Invalid_argument _ -> true);
- test 9 true (try b.{0}; false with Invalid_argument _ -> true);
-
- let c = Array1.create complex64 c_layout 3 in
- for i = 0 to 2 do c.{i} <- {re=float i; im=0.0} done;
- for i = 0 to 2 do test (10 + i) c.{i} {re=float i; im=0.0} done;
- test 13 true (try c.{3}; false with Invalid_argument _ -> true);
- test 14 true (try c.{-1}; false with Invalid_argument _ -> true);
-
- let d = Array1.create complex32 fortran_layout 3 in
- for i = 1 to 3 do d.{i} <- {re=float i; im=0.0} done;
- for i = 1 to 3 do test (14 + i) d.{i} {re=float i; im=0.0} done;
- test 18 true (try d.{4}; false with Invalid_argument _ -> true);
- test 19 true (try d.{0}; false with Invalid_argument _ -> true);
-
- testing_function "comparisons";
- let normalize_comparison n =
- if n = 0 then 0 else if n < 0 then -1 else 1 in
- test 1 0 (normalize_comparison (compare
- (from_list int8_signed [1;2;3;-4;127;-128])
- (from_list int8_signed [1;2;3;-4;127;-128])));
- test 2 (-1) (normalize_comparison (compare
- (from_list int8_signed [1;2;3;-4;127;-128])
- (from_list int8_signed [1;2;3;4;127;-128])));
- test 3 1 (normalize_comparison (compare
- (from_list int8_signed [1;2;3;-4;127;-128])
- (from_list int8_signed [1;2;3;-4;42;-128])));
- test 4 (-1) (normalize_comparison (compare
- (from_list int8_signed [1;2;3;-4])
- (from_list int8_signed [1;2;3;4;127;-128])));
- test 5 1 (normalize_comparison (compare
- (from_list int8_signed [1;2;3;4;127;-128])
- (from_list int8_signed [1;2;3;-4])));
-
- test 6 0 (normalize_comparison (compare
- (from_list int8_unsigned [1;2;3;-4;127;-128])
- (from_list int8_unsigned [1;2;3;-4;127;-128])));
- test 7 1 (normalize_comparison (compare
- (from_list int8_unsigned [1;2;3;-4;127;-128])
- (from_list int8_unsigned [1;2;3;4;127;-128])));
- test 8 1 (normalize_comparison (compare
- (from_list int8_unsigned [1;2;3;-4;127;-128])
- (from_list int8_unsigned [1;2;3;-4;42;-128])));
-
- test 9 0 (normalize_comparison (compare
- (from_list int16_signed [1;2;3;-4;127;-128])
- (from_list int16_signed [1;2;3;-4;127;-128])));
- test 10 (-1) (normalize_comparison (compare
- (from_list int16_signed [1;2;3;-4;127;-128])
- (from_list int16_signed [1;2;3;4;127;-128])));
- test 11 1 (normalize_comparison (compare
- (from_list int16_signed [1;2;3;-4;127;-128])
- (from_list int16_signed [1;2;3;-4;42;-128])));
-
- test 12 0 (normalize_comparison (compare
- (from_list int16_unsigned [1;2;3;-4;127;-128])
- (from_list int16_unsigned [1;2;3;-4;127;-128])));
- test 13 (-1) (normalize_comparison (compare
- (from_list int16_unsigned [1;2;3;4;127;-128])
- (from_list int16_unsigned [1;2;3;0xFFFF;127;-128])));
- test 14 1 (normalize_comparison (compare
- (from_list int16_unsigned [1;2;3;-4;127;-128])
- (from_list int16_unsigned [1;2;3;-4;42;-128])));
-
- test 15 0 (normalize_comparison (compare
- (from_list int [1;2;3;-4;127;-128])
- (from_list int [1;2;3;-4;127;-128])));
- test 16 (-1) (normalize_comparison (compare
- (from_list int [1;2;3;-4;127;-128])
- (from_list int [1;2;3;4;127;-128])));
- test 17 1 (normalize_comparison (compare
- (from_list int [1;2;3;-4;127;-128])
- (from_list int [1;2;3;-4;42;-128])));
-
- test 18 0 (normalize_comparison (compare
- (from_list int32 (List.map Int32.of_int [1;2;3;-4;127;-128]))
- (from_list int32 (List.map Int32.of_int [1;2;3;-4;127;-128]))));
- test 19 (-1) (normalize_comparison (compare
- (from_list int32 (List.map Int32.of_int [1;2;3;-4;127;-128]))
- (from_list int32 (List.map Int32.of_int [1;2;3;4;127;-128]))));
- test 20 1 (normalize_comparison (compare
- (from_list int32 (List.map Int32.of_int [1;2;3;-4;127;-128]))
- (from_list int32 (List.map Int32.of_int [1;2;3;-4;42;-128]))));
-
- test 21 0 (normalize_comparison (compare
- (from_list int64 (List.map Int64.of_int [1;2;3;-4;127;-128]))
- (from_list int64 (List.map Int64.of_int [1;2;3;-4;127;-128]))));
- test 22 (-1) (normalize_comparison (compare
- (from_list int64 (List.map Int64.of_int [1;2;3;-4;127;-128]))
- (from_list int64 (List.map Int64.of_int [1;2;3;4;127;-128]))));
- test 23 1 (normalize_comparison (compare
- (from_list int64 (List.map Int64.of_int [1;2;3;-4;127;-128]))
- (from_list int64 (List.map Int64.of_int [1;2;3;-4;42;-128]))));
-
- test 24 0 (normalize_comparison (compare
- (from_list nativeint (List.map Nativeint.of_int [1;2;3;-4;127;-128]))
- (from_list nativeint (List.map Nativeint.of_int [1;2;3;-4;127;-128]))));
- test 25 (-1) (normalize_comparison (compare
- (from_list nativeint (List.map Nativeint.of_int [1;2;3;-4;127;-128]))
- (from_list nativeint (List.map Nativeint.of_int [1;2;3;4;127;-128]))));
- test 26 1 (normalize_comparison (compare
- (from_list nativeint (List.map Nativeint.of_int [1;2;3;-4;127;-128]))
- (from_list nativeint (List.map Nativeint.of_int [1;2;3;-4;42;-128]))));
-
- test 27 0 (normalize_comparison (compare
- (from_list float32 [0.0; 0.25; -4.0; 3.141592654])
- (from_list float32 [0.0; 0.25; -4.0; 3.141592654])));
- test 28 (-1) (normalize_comparison (compare
- (from_list float32 [0.0; 0.25; -4.0])
- (from_list float32 [0.0; 0.25; 3.14159])));
- test 29 1 (normalize_comparison (compare
- (from_list float32 [0.0; 2.718; -4.0])
- (from_list float32 [0.0; 0.25; 3.14159])));
-
- test 30 0 (normalize_comparison (compare
- (from_list float64 [0.0; 0.25; -4.0; 3.141592654])
- (from_list float64 [0.0; 0.25; -4.0; 3.141592654])));
- test 31 (-1) (normalize_comparison (compare
- (from_list float64 [0.0; 0.25; -4.0])
- (from_list float64 [0.0; 0.25; 3.14159])));
- test 32 1 (normalize_comparison (compare
- (from_list float64 [0.0; 2.718; -4.0])
- (from_list float64 [0.0; 0.25; 3.14159])));
-
- test 44 0 (normalize_comparison (compare
- (from_list complex32 [Complex.zero; Complex.one; Complex.i])
- (from_list complex32 [Complex.zero; Complex.one; Complex.i])));
- test 45 (-1) (normalize_comparison (compare
- (from_list complex32 [Complex.zero; Complex.one; Complex.i])
- (from_list complex32 [Complex.zero; Complex.one; Complex.one])));
- test 46 1 (normalize_comparison (compare
- (from_list complex32 [Complex.zero; Complex.one; Complex.one])
- (from_list complex32 [Complex.zero; Complex.one; Complex.i])));
-
- test 47 0 (normalize_comparison (compare
- (from_list complex64 [Complex.zero; Complex.one; Complex.i])
- (from_list complex64 [Complex.zero; Complex.one; Complex.i])));
- test 48 (-1) (normalize_comparison (compare
- (from_list complex64 [Complex.zero; Complex.one; Complex.i])
- (from_list complex64 [Complex.zero; Complex.one; Complex.one])));
- test 49 1 (normalize_comparison (compare
- (from_list complex64 [Complex.zero; Complex.one; Complex.one])
- (from_list complex64 [Complex.zero; Complex.one; Complex.i])));
-
- testing_function "dim";
- test 1 (Array1.dim (from_list int [1;2;3;4;5])) 5;
- test 2 (Array1.dim (from_list_fortran int [1;2;3])) 3;
-
- testing_function "kind & layout";
- let a = from_list int [1;2;3] in
- test 1 (Array1.kind a) int;
- test 2 (Array1.layout a) c_layout;
- let a = from_list_fortran float32 [1.0;2.0;3.0] in
- test 1 (Array1.kind a) float32;
- test 2 (Array1.layout a) fortran_layout;
-
- testing_function "sub";
- let a = from_list int [1;2;3;4;5;6;7;8] in
- test 1 (Array1.sub a 2 5)
- (from_list int [3;4;5;6;7]);
- test 2 (Array1.sub a 0 2)
- (from_list int [1;2]);
- test 3 (Array1.sub a 0 8)
- (from_list int [1;2;3;4;5;6;7;8]);
- let a = from_list float64 [1.0;2.0;3.0;4.0;5.0;6.0;7.0;8.0] in
- test 4 (Array1.sub a 2 5)
- (from_list float64 [3.0;4.0;5.0;6.0;7.0]);
- test 5 (Array1.sub a 0 2)
- (from_list float64 [1.0;2.0]);
- test 6 (Array1.sub a 0 8)
- (from_list float64 [1.0;2.0;3.0;4.0;5.0;6.0;7.0;8.0]);
- let a = from_list_fortran float64 [1.0;2.0;3.0;4.0;5.0;6.0;7.0;8.0] in
- test 7 (Array1.sub a 2 5)
- (from_list_fortran float64 [2.0;3.0;4.0;5.0;6.0]);
- test 8 (Array1.sub a 1 2)
- (from_list_fortran float64 [1.0;2.0]);
- test 9 (Array1.sub a 1 8)
- (from_list_fortran float64 [1.0;2.0;3.0;4.0;5.0;6.0;7.0;8.0]);
- Gc.full_major(); (* test GC of proxies *)
-
- testing_function "blit, fill";
- let test_blit_fill kind data initval ofs len =
- let a = from_list kind data in
- let b = Array1.create kind c_layout (List.length data) in
- Array1.blit a b;
- (a = b) &&
- (Array1.fill (Array1.sub b ofs len) initval;
- let rec check i = function
- [] -> true
- | hd :: tl -> b.{i} = (if i >= ofs && i < ofs + len
- then initval else hd)
- && check (i+1) tl
- in check 0 data) in
- test 1 true (test_blit_fill int8_signed [1;2;5;8;-100;127] 7 3 2);
- test 2 true (test_blit_fill int8_unsigned [1;2;5;8;-100;212] 7 3 2);
- test 3 true (test_blit_fill int16_signed [1;2;5;8;-100;212] 7 3 2);
- test 4 true (test_blit_fill int16_unsigned [1;2;5;8;-100;212] 7 3 2);
- test 5 true (test_blit_fill int [1;2;5;8;-100;212] 7 3 2);
- test 6 true (test_blit_fill int32 (List.map Int32.of_int [1;2;5;8;-100;212])
- (Int32.of_int 7) 3 2);
- test 7 true (test_blit_fill int64 (List.map Int64.of_int [1;2;5;8;-100;212])
- (Int64.of_int 7) 3 2);
- test 8 true (test_blit_fill nativeint
- (List.map Nativeint.of_int [1;2;5;8;-100;212])
- (Nativeint.of_int 7) 3 2);
- test 9 true (test_blit_fill float32 [1.0;2.0;0.5;0.125;256.0;512.0]
- 0.25 3 2);
- test 10 true (test_blit_fill float64 [1.0;2.0;5.0;8.123;-100.456;212e19]
- 3.1415 3 2);
- test 11 true (test_blit_fill complex32 [Complex.zero; Complex.one; Complex.i]
- Complex.i 1 1);
- test 12 true (test_blit_fill complex64 [Complex.zero; Complex.one; Complex.i]
- Complex.i 1 1);
-
-(* Bi-dimensional arrays *)
-
- print_newline();
- testing_function "------ Array2 --------";
- testing_function "create/set/get";
- let make_array2 kind layout ind0 dim1 dim2 fromint =
- let a = Array2.create kind layout dim1 dim2 in
- for i = ind0 to dim1 - 1 + ind0 do
- for j = ind0 to dim2 - 1 + ind0 do
- a.{i,j} <- (fromint (i * 1000 + j))
- done
- done;
- a in
- let check_array2 a ind0 dim1 dim2 fromint =
- try
- for i = ind0 to dim1 - 1 + ind0 do
- for j = ind0 to dim2 - 1 + ind0 do
- if a.{i,j} <> (fromint (i * 1000 + j)) then raise Exit
- done
- done;
- true
- with Exit -> false in
- let id x = x in
- test 1 true
- (check_array2 (make_array2 int16_signed c_layout 0 10 20 id) 0 10 20 id);
- test 2 true
- (check_array2 (make_array2 int c_layout 0 10 20 id) 0 10 20 id);
- test 3 true
- (check_array2 (make_array2 int32 c_layout 0 10 20 Int32.of_int)
- 0 10 20 Int32.of_int);
- test 4 true
- (check_array2 (make_array2 float32 c_layout 0 10 20 float)
- 0 10 20 float);
- test 5 true
- (check_array2 (make_array2 float64 c_layout 0 10 20 float)
- 0 10 20 float);
- test 6 true
- (check_array2 (make_array2 int16_signed fortran_layout 1 10 20 id) 1 10 20 id);
- test 7 true
- (check_array2 (make_array2 int fortran_layout 1 10 20 id) 1 10 20 id);
- test 8 true
- (check_array2 (make_array2 int32 fortran_layout 1 10 20 Int32.of_int)
- 1 10 20 Int32.of_int);
- test 9 true
- (check_array2 (make_array2 float32 fortran_layout 1 10 20 float)
- 1 10 20 float);
- test 10 true
- (check_array2 (make_array2 float64 fortran_layout 1 10 20 float)
- 1 10 20 float);
- let makecomplex i = {re = float i; im = float (-i)} in
- test 11 true
- (check_array2 (make_array2 complex32 c_layout 0 10 20 makecomplex)
- 0 10 20 makecomplex);
- test 12 true
- (check_array2 (make_array2 complex64 c_layout 0 10 20 makecomplex)
- 0 10 20 makecomplex);
- test 13 true
- (check_array2 (make_array2 complex32 fortran_layout 1 10 20 makecomplex)
- 1 10 20 makecomplex);
- test 14 true
- (check_array2 (make_array2 complex64 fortran_layout 1 10 20 makecomplex)
- 1 10 20 makecomplex);
-
- testing_function "set/get (specialized)";
- let a = Array2.create int16_signed c_layout 3 3 in
- for i = 0 to 2 do for j = 0 to 2 do a.{i,j} <- i-j done done;
- let ok = ref true in
- for i = 0 to 2 do
- for j = 0 to 2 do if a.{i,j} <> i-j then ok := false done
- done;
- test 1 true !ok;
- test 2 true (try a.{3,0}; false with Invalid_argument _ -> true);
- test 3 true (try a.{-1,0}; false with Invalid_argument _ -> true);
- test 4 true (try a.{0,3}; false with Invalid_argument _ -> true);
- test 5 true (try a.{0,-1}; false with Invalid_argument _ -> true);
-
- let b = Array2.create float32 fortran_layout 3 3 in
- for i = 1 to 3 do for j = 1 to 3 do b.{i,j} <- float(i-j) done done;
- let ok = ref true in
- for i = 1 to 3 do
- for j = 1 to 3 do if b.{i,j} <> float(i-j) then ok := false done
- done;
- test 6 true !ok;
- test 7 true (try b.{4,1}; false with Invalid_argument _ -> true);
- test 8 true (try b.{0,1}; false with Invalid_argument _ -> true);
- test 9 true (try b.{1,4}; false with Invalid_argument _ -> true);
- test 10 true (try b.{1,0}; false with Invalid_argument _ -> true);
-
- testing_function "dim";
- let a = (make_array2 int c_layout 0 4 6 id) in
- test 1 (Array2.dim1 a) 4;
- test 2 (Array2.dim2 a) 6;
- let b = (make_array2 int fortran_layout 1 4 6 id) in
- test 3 (Array2.dim1 b) 4;
- test 4 (Array2.dim2 b) 6;
-
- testing_function "sub";
- let a = make_array2 int c_layout 0 5 3 id in
- let b = Array2.sub_left a 2 2 in
- test 1 true
- (b.{0,0} = 2000 &&
- b.{0,1} = 2001 &&
- b.{0,2} = 2002 &&
- b.{1,0} = 3000 &&
- b.{1,1} = 3001 &&
- b.{1,2} = 3002);
- let a = make_array2 int fortran_layout 1 5 3 id in
- let b = Array2.sub_right a 2 2 in
- test 2 true
- (b.{1,1} = 1002 &&
- b.{1,2} = 1003 &&
- b.{2,1} = 2002 &&
- b.{2,2} = 2003 &&
- b.{3,1} = 3002 &&
- b.{3,2} = 3003 &&
- b.{4,1} = 4002 &&
- b.{4,2} = 4003 &&
- b.{5,1} = 5002 &&
- b.{5,2} = 5003);
-
- testing_function "slice";
- let a = make_array2 int c_layout 0 5 3 id in
- test 1 (Array2.slice_left a 0) (from_list int [0;1;2]);
- test 2 (Array2.slice_left a 1) (from_list int [1000;1001;1002]);
- test 3 (Array2.slice_left a 2) (from_list int [2000;2001;2002]);
- test 4 (Array2.slice_left a 3) (from_list int [3000;3001;3002]);
- test 5 (Array2.slice_left a 4) (from_list int [4000;4001;4002]);
- let a = make_array2 int fortran_layout 1 5 3 id in
- test 6 (Array2.slice_right a 1) (from_list_fortran int [1001;2001;3001;4001;5001]);
- test 7 (Array2.slice_right a 2) (from_list_fortran int [1002;2002;3002;4002;5002]);
- test 8 (Array2.slice_right a 3) (from_list_fortran int [1003;2003;3003;4003;5003]);
-
-(* Tri-dimensional arrays *)
-
- print_newline();
- testing_function "------ Array3 --------";
- testing_function "create/set/get";
- let make_array3 kind layout ind0 dim1 dim2 dim3 fromint =
- let a = Array3.create kind layout dim1 dim2 dim3 in
- for i = ind0 to dim1 - 1 + ind0 do
- for j = ind0 to dim2 - 1 + ind0 do
- for k = ind0 to dim3 - 1 + ind0 do
- a.{i, j, k} <- (fromint (i * 100 + j * 10 + k))
- done
- done
- done;
- a in
- let check_array3 a ind0 dim1 dim2 dim3 fromint =
- try
- for i = ind0 to dim1 - 1 + ind0 do
- for j = ind0 to dim2 - 1 + ind0 do
- for k = ind0 to dim3 - 1 + ind0 do
- if a.{i, j, k} <> (fromint (i * 100 + j * 10 + k))
- then raise Exit
- done
- done
- done;
- true
- with Exit -> false in
- let id x = x in
- test 1 true
- (check_array3 (make_array3 int16_signed c_layout 0 4 5 6 id) 0 4 5 6 id);
- test 2 true
- (check_array3 (make_array3 int c_layout 0 4 5 6 id) 0 4 5 6 id);
- test 3 true
- (check_array3 (make_array3 int32 c_layout 0 4 5 6 Int32.of_int)
- 0 4 5 6 Int32.of_int);
- test 4 true
- (check_array3 (make_array3 float32 c_layout 0 4 5 6 float)
- 0 4 5 6 float);
- test 5 true
- (check_array3 (make_array3 float64 c_layout 0 4 5 6 float)
- 0 4 5 6 float);
- test 6 true
- (check_array3 (make_array3 int16_signed fortran_layout 1 4 5 6 id) 1 4 5 6 id);
- test 7 true
- (check_array3 (make_array3 int fortran_layout 1 4 5 6 id) 1 4 5 6 id);
- test 8 true
- (check_array3 (make_array3 int32 fortran_layout 1 4 5 6 Int32.of_int)
- 1 4 5 6 Int32.of_int);
- test 9 true
- (check_array3 (make_array3 float32 fortran_layout 1 4 5 6 float)
- 1 4 5 6 float);
- test 10 true
- (check_array3 (make_array3 float64 fortran_layout 1 4 5 6 float)
- 1 4 5 6 float);
- test 11 true
- (check_array3 (make_array3 complex32 c_layout 0 4 5 6 makecomplex)
- 0 4 5 6 makecomplex);
- test 12 true
- (check_array3 (make_array3 complex64 c_layout 0 4 5 6 makecomplex)
- 0 4 5 6 makecomplex);
- test 13 true
- (check_array3 (make_array3 complex32 fortran_layout 1 4 5 6 makecomplex)
- 1 4 5 6 makecomplex);
- test 14 true
- (check_array3 (make_array3 complex64 fortran_layout 1 4 5 6 makecomplex)
- 1 4 5 6 makecomplex);
-
-
- testing_function "set/get (specialized)";
- let a = Array3.create int32 c_layout 2 3 4 in
- for i = 0 to 1 do for j = 0 to 2 do for k = 0 to 3 do
- a.{i,j,k} <- Int32.of_int((i lsl 4) + (j lsl 2) + k)
- done done done;
- let ok = ref true in
- for i = 0 to 1 do for j = 0 to 2 do for k = 0 to 3 do
- if Int32.to_int a.{i,j,k} <> (i lsl 4) + (j lsl 2) + k then ok := false
- done done done;
- test 1 true !ok;
-
- let b = Array3.create int64 fortran_layout 2 3 4 in
- for i = 1 to 2 do for j = 1 to 3 do for k = 1 to 4 do
- b.{i,j,k} <- Int64.of_int((i lsl 4) + (j lsl 2) + k)
- done done done;
- let ok = ref true in
- for i = 1 to 2 do for j = 1 to 3 do for k = 1 to 4 do
- if Int64.to_int b.{i,j,k} <> (i lsl 4) + (j lsl 2) + k then ok := false
- done done done;
- test 2 true !ok;
-
- testing_function "dim";
- let a = (make_array3 int c_layout 0 4 5 6 id) in
- test 1 (Array3.dim1 a) 4;
- test 2 (Array3.dim2 a) 5;
- test 3 (Array3.dim3 a) 6;
- let b = (make_array3 int fortran_layout 1 4 5 6 id) in
- test 4 (Array3.dim1 b) 4;
- test 5 (Array3.dim2 b) 5;
- test 6 (Array3.dim3 b) 6;
-
- testing_function "slice1";
- let a = make_array3 int c_layout 0 3 3 3 id in
- test 1 (Array3.slice_left_1 a 0 0) (from_list int [0;1;2]);
- test 2 (Array3.slice_left_1 a 0 1) (from_list int [10;11;12]);
- test 3 (Array3.slice_left_1 a 0 2) (from_list int [20;21;22]);
- test 4 (Array3.slice_left_1 a 1 1) (from_list int [110;111;112]);
- test 5 (Array3.slice_left_1 a 2 1) (from_list int [210;211;212]);
- let a = make_array3 int fortran_layout 1 3 3 3 id in
- test 6 (Array3.slice_right_1 a 1 2) (from_list_fortran int [112;212;312]);
- test 7 (Array3.slice_right_1 a 3 1) (from_list_fortran int [131;231;331]);
-
-(* Reshaping *)
- print_newline();
- testing_function "------ Reshaping --------";
- testing_function "reshape_1";
- let a = make_array2 int c_layout 0 3 4 id in
- let b = make_array2 int fortran_layout 1 3 4 id in
- let c = reshape_1 (genarray_of_array2 a) 12 in
- test 1 c (from_list int [0;1;2;3;1000;1001;1002;1003;2000;2001;2002;2003]);
- let d = reshape_1 (genarray_of_array2 b) 12 in
- test 2 d (from_list_fortran int [1001;2001;3001;1002;2002;3002;1003;2003;3003;1004;2004;3004]);
- testing_function "reshape_2";
- let c = reshape_2 (genarray_of_array2 a) 4 3 in
- test 1 (Array2.slice_left c 0) (from_list int [0;1;2]);
- test 2 (Array2.slice_left c 1) (from_list int [3;1000;1001]);
- test 3 (Array2.slice_left c 2) (from_list int [1002;1003;2000]);
- test 4 (Array2.slice_left c 3) (from_list int [2001;2002;2003]);
- let d = reshape_2 (genarray_of_array2 b) 4 3 in
- test 5 (Array2.slice_right d 1) (from_list_fortran int [1001;2001;3001;1002]);
- test 6 (Array2.slice_right d 2) (from_list_fortran int [2002;3002;1003;2003]);
- test 7 (Array2.slice_right d 3) (from_list_fortran int [3003;1004;2004;3004]);
-
-(* I/O *)
-
- print_newline();
- testing_function "------ I/O --------";
- testing_function "output_value/input_value";
- let test_structured_io testno value =
- let tmp = Filename.temp_file "bigarray" ".data" in
- let oc = open_out_bin tmp in
- output_value oc value;
- close_out oc;
- let ic = open_in_bin tmp in
- let value' = input_value ic in
- close_in ic;
- Sys.remove tmp;
- test testno value value' in
- test_structured_io 1 (from_list int8_signed [1;2;3;-4;127;-128]);
- test_structured_io 2 (from_list int16_signed [1;2;3;-4;127;-128]);
- test_structured_io 3 (from_list int [1;2;3;-4;127;-128]);
- test_structured_io 4
- (from_list int32 (List.map Int32.of_int [1;2;3;-4;127;-128]));
- test_structured_io 5
- (from_list int64 (List.map Int64.of_int [1;2;3;-4;127;-128]));
- test_structured_io 6
- (from_list nativeint (List.map Nativeint.of_int [1;2;3;-4;127;-128]));
- test_structured_io 7 (from_list float32 [0.0; 0.25; -4.0; 3.141592654]);
- test_structured_io 8 (from_list float64 [0.0; 0.25; -4.0; 3.141592654]);
- test_structured_io 9 (make_array2 int c_layout 0 100 100 id);
- test_structured_io 10 (make_array2 float64 fortran_layout 1 200 200 float);
- test_structured_io 11 (make_array3 int32 c_layout 0 20 30 40 Int32.of_int);
- test_structured_io 12 (make_array3 float32 fortran_layout 1 10 50 100 float);
- test_structured_io 13 (make_array2 complex32 c_layout 0 100 100 makecomplex);
- test_structured_io 14 (make_array3 complex64 fortran_layout 1 10 20 30 makecomplex);
-
- testing_function "map_file";
- let mapped_file = Filename.temp_file "bigarray" ".data" in
- begin
- let fd =
- Unix.openfile mapped_file
- [Unix.O_RDWR; Unix.O_TRUNC; Unix.O_CREAT] 0o666 in
- let a = Array1.map_file fd float64 c_layout true 10000 in
- Unix.close fd;
- for i = 0 to 9999 do a.{i} <- float i done;
- let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
- let b = Array2.map_file fd float64 fortran_layout false 100 (-1) in
- Unix.close fd;
- let ok = ref true in
- for i = 0 to 99 do
- for j = 0 to 99 do
- if b.{j+1,i+1} <> float (100 * i + j) then ok := false
- done
- done;
- test 1 !ok true;
- b.{50,50} <- (-1.0);
- let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
- let c = Array2.map_file fd float64 c_layout false (-1) 100 in
- Unix.close fd;
- let ok = ref true in
- for i = 0 to 99 do
- for j = 0 to 99 do
- if c.{i,j} <> float (100 * i + j) then ok := false
- done
- done;
- test 2 !ok true
- end;
- (* Force garbage collection of the mapped bigarrays above, otherwise
- Win32 doesn't let us erase the file. Notice the begin...end above
- so that the VM doesn't keep stack references to the mapped bigarrays. *)
- Gc.full_major();
- Sys.remove mapped_file;
-
- ()
-
-(********* End of test *********)
-
-let _ =
- print_newline();
- if !error_occurred then begin
- prerr_endline "************* TEST FAILED ****************"; exit 2
- end else
- exit 0
diff --git a/test/Moretest/bigarrf.f b/test/Moretest/bigarrf.f
deleted file mode 100644
index 734863a016..0000000000
--- a/test/Moretest/bigarrf.f
+++ /dev/null
@@ -1,26 +0,0 @@
- subroutine filltab()
-
- parameter (dimx = 8, dimy = 6)
- real ftab(dimx, dimy)
- common /ftab/ ftab
- integer x, y
-
- do 100 x = 1, dimx
- do 110 y = 1, dimy
- ftab(x, y) = x * 100 + y
- 110 continue
- 100 continue
- end
-
- subroutine printtab(tab, dimx, dimy)
-
- integer dimx, dimy
- real tab(dimx, dimy)
- integer x, y
-
- do 200 x = 1, dimx
- print 300, x, (tab(x, y), y = 1, dimy)
- 300 format(/1X, I3, 2X, 10F6.1/)
- 200 continue
- end
-
diff --git a/test/Moretest/bigarrfml.ml b/test/Moretest/bigarrfml.ml
deleted file mode 100644
index c915622840..0000000000
--- a/test/Moretest/bigarrfml.ml
+++ /dev/null
@@ -1,63 +0,0 @@
-open Bigarray
-open Printf
-
-(* Test harness *)
-
-let error_occurred = ref false
-
-let function_tested = ref ""
-
-let testing_function s =
- function_tested := s;
- print_newline();
- print_string s;
- print_newline()
-
-let test test_number answer correct_answer =
- flush stdout;
- flush stderr;
- if answer <> correct_answer then begin
- eprintf "*** Bad result (%s, test %d)\n" !function_tested test_number;
- flush stderr;
- error_occurred := true
- end else begin
- printf " %d..." test_number
- end
-
-(* External C and Fortran functions *)
-
-external c_filltab : unit -> (float, float64_elt, c_layout) Array2.t = "c_filltab"
-external c_printtab : (float, float64_elt, c_layout) Array2.t -> unit = "c_printtab"
-external fortran_filltab : unit -> (float, float32_elt, fortran_layout) Array2.t = "fortran_filltab"
-external fortran_printtab : (float, float32_elt, fortran_layout) Array2.t -> unit = "fortran_printtab"
-
-let _ =
-
- let make_array2 kind layout ind0 dim1 dim2 fromint =
- let a = Array2.create kind layout dim1 dim2 in
- for i = ind0 to dim1 - 1 + ind0 do
- for j = ind0 to dim2 - 1 + ind0 do
- a.{i,j} <- (fromint (i * 1000 + j))
- done
- done;
- a in
-
- print_newline();
- testing_function "------ Foreign function interface --------";
- testing_function "Passing an array to C";
- c_printtab (make_array2 float64 c_layout 0 6 8 float);
- testing_function "Accessing a C array";
- let a = c_filltab () in
- test 1 a.{0,0} 0.0;
- test 2 a.{1,0} 100.0;
- test 3 a.{0,1} 1.0;
- test 4 a.{5,4} 504.0;
- testing_function "Passing an array to Fortran";
- fortran_printtab (make_array2 float32 fortran_layout 1 5 4 float);
- testing_function "Accessing a Fortran array";
- let a = fortran_filltab () in
- test 1 a.{1,1} 101.0;
- test 2 a.{2,1} 201.0;
- test 3 a.{1,2} 102.0;
- test 4 a.{5,4} 504.0;
-
diff --git a/test/Moretest/bigarrfstub.c b/test/Moretest/bigarrfstub.c
deleted file mode 100644
index 87bd67b7bc..0000000000
--- a/test/Moretest/bigarrfstub.c
+++ /dev/null
@@ -1,60 +0,0 @@
-#include <stdio.h>
-#include <mlvalues.h>
-#include <bigarray.h>
-
-extern void filltab_(void);
-extern void printtab_(float * data, int * dimx, int * dimy);
-extern float ftab_[];
-
-#define DIMX 6
-#define DIMY 8
-
-double ctab[DIMX][DIMY];
-
-void filltab(void)
-{
- int x, y;
- for (x = 0; x < DIMX; x++)
- for (y = 0; y < DIMY; y++)
- ctab[x][y] = x * 100 + y;
-}
-
-void printtab(double tab[DIMX][DIMY])
-{
- int x, y;
- for (x = 0; x < DIMX; x++) {
- printf("%3d", x);
- for (y = 0; y < DIMY; y++)
- printf(" %6.1f", tab[x][y]);
- printf("\n");
- }
-}
-
-value c_filltab(value unit)
-{
- filltab();
- return alloc_bigarray_dims(BIGARRAY_FLOAT64 | BIGARRAY_C_LAYOUT,
- 2, ctab, DIMX, DIMY);
-}
-
-value c_printtab(value ba)
-{
- printtab(Data_bigarray_val(ba));
- return Val_unit;
-}
-
-value fortran_filltab(value unit)
-{
- filltab_();
- return alloc_bigarray_dims(BIGARRAY_FLOAT32 | BIGARRAY_FORTRAN_LAYOUT,
- 2, ftab_, 8, 6);
-}
-
-value fortran_printtab(value ba)
-{
- int dimx = Bigarray_val(ba)->dim[0];
- int dimy = Bigarray_val(ba)->dim[1];
- printtab_(Data_bigarray_val(ba), &dimx, &dimy);
- return Val_unit;
-}
-
diff --git a/test/Moretest/bigints.ml b/test/Moretest/bigints.ml
deleted file mode 100644
index 0b101ffa1f..0000000000
--- a/test/Moretest/bigints.ml
+++ /dev/null
@@ -1,12 +0,0 @@
-let _ =
- print_int 1000000000; print_newline();
- print_int 10000000000; print_newline();
- print_int 100000000000; print_newline();
- print_int 1000000000000; print_newline();
- print_int 10000000000000; print_newline();
- print_int 100000000000000; print_newline();
- print_int 1000000000000000; print_newline();
- print_int 10000000000000000; print_newline();
- print_int 100000000000000000; print_newline();
- print_int 1000000000000000000; print_newline()
-
diff --git a/test/Moretest/bounds.ml b/test/Moretest/bounds.ml
deleted file mode 100644
index a785c3c46c..0000000000
--- a/test/Moretest/bounds.ml
+++ /dev/null
@@ -1,28 +0,0 @@
-(* Test bound checks with ocamlopt *)
-
-let a = [| 0; 1; 2 |]
-
-let trail = ref []
-
-let test n =
- let result =
- try
- trail := n :: !trail; a.(n); "doesn't fail"
- with Invalid_argument s ->
- (* Check well-formedness of s *)
- if String.length s = 19
- && s = "index out of bounds"
- then "fails"
- else "bad Invalid_argument"
- | _ -> "bad exception"
- in
- print_int n; print_string ": "; print_string result; print_newline()
-
-let _ =
- test 0; test 1; test 2; test 3; test 4; test (-1);
- Gc.full_major();
- print_string "Trail:";
- List.iter (fun n -> print_string " "; print_int n) !trail;
- print_newline()
-
-
diff --git a/test/Moretest/boxedints.ml b/test/Moretest/boxedints.ml
deleted file mode 100644
index d5a1d5ba73..0000000000
--- a/test/Moretest/boxedints.ml
+++ /dev/null
@@ -1,569 +0,0 @@
-(* Test the types nativeint, int32, int64 *)
-
-open Printf
-
-let error_occurred = ref false
-
-let function_tested = ref ""
-
-let testing_function s =
- function_tested := s;
- print_newline();
- print_string s;
- print_newline()
-
-let test test_number answer correct_answer =
- flush stdout;
- flush stderr;
- if answer <> correct_answer then begin
- eprintf "*** Bad result (%s, test %d)\n" !function_tested test_number;
- flush stderr;
- error_occurred := true
- end else begin
- printf " %d..." test_number
- end
-
-(***** Tests on 32 bit arithmetic *****)
-
-module type TESTSIG = sig
- type t
- module Ops : sig
- val neg: t -> t
- val add: t -> t -> t
- val sub: t -> t -> t
- val mul: t -> t -> t
- val div: t -> t -> t
- val rem: t -> t -> t
- val logand: t -> t -> t
- val logor: t -> t -> t
- val logxor: t -> t -> t
- val shift_left: t -> int -> t
- val shift_right: t -> int -> t
- val shift_right_logical: t -> int -> t
- val of_int: int -> t
- val to_int: t -> int
- val of_float: float -> t
- val to_float: t -> float
- val zero: t
- val one: t
- val minus_one: t
- val min_int: t
- val max_int: t
- val format : string -> t -> string
- val to_string: t -> string
- val of_string: string -> t
- end
- val testcomp: t -> t -> bool*bool*bool*bool*bool*bool*int
-end
-
-module Test32(M: TESTSIG) =
-struct
- open M
- open Ops
-
- let _ =
- testing_function "of_int, to_int";
- test 1 (to_int (of_int 0)) 0;
- test 2 (to_int (of_int 123)) 123;
- test 3 (to_int (of_int (-456))) (-456);
- test 4 (to_int (of_int 0x3FFFFFFF)) 0x3FFFFFFF;
- test 5 (to_int (of_int (-0x40000000))) (-0x40000000);
-
- testing_function "of_string";
- test 1 (of_string "0") (of_int 0);
- test 2 (of_string "123") (of_int 123);
- test 3 (of_string "-456") (of_int (-456));
- test 4 (of_string "123456789") (of_int 123456789);
- test 5 (of_string "0xABCDEF") (of_int 0xABCDEF);
- test 6 (of_string "-0o1234567012") (of_int (- 0o1234567012));
- test 7 (of_string "0b01010111111000001100")
- (of_int 0b01010111111000001100);
- test 8 (of_string "0x7FFFFFFF") max_int;
- test 9 (of_string "-0x80000000") min_int;
- test 10 (of_string "0x80000000") min_int;
- test 11 (of_string "0xFFFFFFFF") minus_one;
-
- testing_function "to_string, format";
- List.iter (fun (n, s) -> test n (to_string (of_string s)) s)
- [1, "0"; 2, "123"; 3, "-456"; 4, "1234567890";
- 5, "2147483647"; 6, "-2147483648"];
- List.iter (fun (n, s) -> test n (format "0x%X" (of_string s)) s)
- [7, "0x0"; 8, "0x123"; 9, "0xABCDEF"; 10, "0x12345678";
- 11, "0x7FFFFFFF"; 12, "0x80000000"; 13, "0xFFFFFFFF"];
- test 14 (to_string max_int) "2147483647";
- test 15 (to_string min_int) "-2147483648";
- test 16 (to_string zero) "0";
- test 17 (to_string one) "1";
- test 18 (to_string minus_one) "-1";
-
- testing_function "neg";
- test 1 (neg (of_int 0)) (of_int 0);
- test 2 (neg (of_int 123)) (of_int (-123));
- test 3 (neg (of_int (-456))) (of_int 456);
- test 4 (neg (of_int 123456789)) (of_int (-123456789));
- test 5 (neg max_int) (of_string "-0x7FFFFFFF");
- test 6 (neg min_int) min_int;
-
- testing_function "add";
- test 1 (add (of_int 0) (of_int 0)) (of_int 0);
- test 2 (add (of_int 123) (of_int 0)) (of_int 123);
- test 3 (add (of_int 0) (of_int 456)) (of_int 456);
- test 4 (add (of_int 123) (of_int 456)) (of_int 579);
- test 5 (add (of_int (-123)) (of_int 456)) (of_int 333);
- test 6 (add (of_int 123) (of_int (-456))) (of_int (-333));
- test 7 (add (of_int (-123)) (of_int (-456))) (of_int (-579));
- test 8 (add (of_string "0x12345678") (of_string "0x9ABCDEF"))
- (of_string "0x1be02467");
- test 9 (add max_int max_int) (of_int (-2));
- test 10 (add min_int min_int) zero;
- test 11 (add max_int one) min_int;
- test 12 (add min_int minus_one) max_int;
- test 13 (add max_int min_int) minus_one;
-
- testing_function "sub";
- test 1 (sub (of_int 0) (of_int 0)) (of_int 0);
- test 2 (sub (of_int 123) (of_int 0)) (of_int 123);
- test 3 (sub (of_int 0) (of_int 456)) (of_int (-456));
- test 4 (sub (of_int 123) (of_int 456)) (of_int (-333));
- test 5 (sub (of_int (-123)) (of_int 456)) (of_int (-579));
- test 6 (sub (of_int 123) (of_int (-456))) (of_int 579);
- test 7 (sub (of_int (-123)) (of_int (-456))) (of_int 333);
- test 8 (sub (of_string "0x12345678") (of_string "0x9ABCDEF"))
- (of_string "0x8888889");
- test 9 (sub max_int min_int) minus_one;
- test 10 (sub min_int max_int) one;
- test 11 (sub min_int one) max_int;
- test 12 (sub max_int minus_one) min_int;
-
- testing_function "mul";
- test 1 (mul (of_int 0) (of_int 0)) (of_int 0);
- test 2 (mul (of_int 123) (of_int 0)) (of_int 0);
- test 3 (mul (of_int 0) (of_int (-456))) (of_int 0);
- test 4 (mul (of_int 123) (of_int 1)) (of_int 123);
- test 5 (mul (of_int 1) (of_int (-456))) (of_int (-456));
- test 6 (mul (of_int 123) (of_int (-1))) (of_int (-123));
- test 7 (mul (of_int (-1)) (of_int (-456))) (of_int 456);
- test 8 (mul (of_int 123) (of_int 456)) (of_int 56088);
- test 9 (mul (of_int (-123)) (of_int 456)) (of_int (-56088));
- test 10 (mul (of_int 123) (of_int (-456))) (of_int (-56088));
- test 11 (mul (of_int (-123)) (of_int (-456))) (of_int 56088);
- test 12 (mul (of_string "0x12345678") (of_string "0x9ABCDEF"))
- (of_string "0xe242d208");
- test 13 (mul max_int max_int) one;
-
- testing_function "div";
- List.iter
- (fun (n, a, b) -> test n (div (of_int a) (of_int b)) (of_int (a / b)))
- [1, 0, 2;
- 2, 123, 1;
- 3, -123, 1;
- 4, 123, -1;
- 5, -123, -1;
- 6, 1275312364, 365;
- 7, 16384, 256;
- 8, -1275312364, 365;
- 9, 1275312364, -365;
- 10, 1234567, 12345678;
- 11, 1234567, -12345678];
-
- testing_function "mod";
- List.iter
- (fun (n, a, b) -> test n (rem (of_int a) (of_int b)) (of_int (a mod b)))
- [1, 0, 2;
- 2, 123, 1;
- 3, -123, 1;
- 4, 123, -1;
- 5, -123, -1;
- 6, 1275312364, 365;
- 7, 16384, 256;
- 8, -1275312364, 365;
- 9, 1275312364, -365;
- 10, 1234567, 12345678;
- 11, 1234567, -12345678];
-
- testing_function "and";
- List.iter
- (fun (n, a, b, c) -> test n (logand (of_string a) (of_string b))
- (of_string c))
- [1, "0x12345678", "0x9abcdef0", "0x12345670";
- 2, "0x12345678", "0x0fedcba9", "0x2244228";
- 3, "0xFFFFFFFF", "0x12345678", "0x12345678";
- 4, "0", "0x12345678", "0";
- 5, "0x55555555", "0xAAAAAAAA", "0"];
-
- testing_function "or";
- List.iter
- (fun (n, a, b, c) -> test n (logor (of_string a) (of_string b))
- (of_string c))
- [1, "0x12345678", "0x9abcdef0", "0x9abcdef8";
- 2, "0x12345678", "0x0fedcba9", "0x1ffddff9";
- 3, "0xFFFFFFFF", "0x12345678", "0xFFFFFFFF";
- 4, "0", "0x12345678", "0x12345678";
- 5, "0x55555555", "0xAAAAAAAA", "0xFFFFFFFF"];
-
- testing_function "xor";
- List.iter
- (fun (n, a, b, c) -> test n (logxor (of_string a) (of_string b))
- (of_string c))
- [1, "0x12345678", "0x9abcdef0", "0x88888888";
- 2, "0x12345678", "0x0fedcba9", "0x1dd99dd1";
- 3, "0xFFFFFFFF", "0x12345678", "0xedcba987";
- 4, "0", "0x12345678", "0x12345678";
- 5, "0x55555555", "0xAAAAAAAA", "0xFFFFFFFF"];
-
- testing_function "shift_left";
- List.iter
- (fun (n, a, b, c) -> test n (shift_left (of_string a) b) (of_string c))
- [1, "1", 1, "2";
- 2, "1", 2, "4";
- 3, "1", 4, "0x10";
- 4, "1", 30, "0x40000000";
- 5, "1", 31, "0x80000000";
- 6, "0x16236", 7, "0xb11b00";
- 7, "0x10", 27, "0x80000000";
- 8, "0x10", 28, "0"];
-
- testing_function "shift_right";
- List.iter
- (fun (n, a, b, c) -> test n (shift_right (of_string a) b) (of_string c))
- [1, "2", 1, "1";
- 2, "4", 2, "1";
- 3, "0x10", 4, "1";
- 4, "0x40000000", 10, "0x100000";
- 5, "0x80000000", 31, "-1";
- 6, "0xb11b00", 7, "0x16236";
- 7, "-0xb11b00", 7, "-90678"];
-
- testing_function "shift_right_logical";
- List.iter
- (fun (n, a, b, c) -> test n (shift_right_logical (of_string a) b)
- (of_string c))
- [1, "2", 1, "1";
- 2, "4", 2, "1";
- 3, "0x10", 4, "1";
- 4, "0x40000000", 10, "0x100000";
- 5, "0x80000000", 31, "1";
- 6, "0xb11b00", 7, "0x16236";
- 7, "-0xb11b00", 7, "0x1fe9dca"];
-
- testing_function "of_float";
- test 1 (of_float 0.0) (of_int 0);
- test 2 (of_float 123.0) (of_int 123);
- test 3 (of_float 123.456) (of_int 123);
- test 4 (of_float 123.999) (of_int 123);
- test 5 (of_float (-456.0)) (of_int (-456));
- test 6 (of_float (-456.123)) (of_int (-456));
- test 7 (of_float (-456.789)) (of_int (-456));
-
- testing_function "to_float";
- test 1 (to_float (of_int 0)) 0.0;
- test 2 (to_float (of_int 123)) 123.0;
- test 3 (to_float (of_int (-456))) (-456.0);
- test 4 (to_float (of_int 0x3FFFFFFF)) 1073741823.0;
- test 5 (to_float (of_int (-0x40000000))) (-1073741824.0);
-
- testing_function "Comparisons";
- test 1 (testcomp (of_int 0) (of_int 0))
- (true,false,false,false,true,true,0);
- test 2 (testcomp (of_int 1234567) (of_int 1234567))
- (true,false,false,false,true,true,0);
- test 3 (testcomp (of_int 0) (of_int 1))
- (false,true,true,false,true,false,-1);
- test 4 (testcomp (of_int (-1)) (of_int 0))
- (false,true,true,false,true,false,-1);
- test 5 (testcomp (of_int 1) (of_int 0))
- (false,true,false,true,false,true,1);
- test 6 (testcomp (of_int 0) (of_int (-1)))
- (false,true,false,true,false,true,1);
- test 7 (testcomp max_int min_int)
- (false,true,false,true,false,true,1);
-
- ()
-end
-
-(********* Tests on 64-bit arithmetic ***********)
-
-module Test64(M: TESTSIG) =
-struct
- open M
- open Ops
-
- let _ =
- testing_function "of_int, to_int";
- test 1 (to_int (of_int 0)) 0;
- test 2 (to_int (of_int 123)) 123;
- test 3 (to_int (of_int (-456))) (-456);
- test 4 (to_int (of_int 0x3FFFFFFF)) 0x3FFFFFFF;
- test 5 (to_int (of_int (-0x40000000))) (-0x40000000);
-
- testing_function "of_string";
- test 1 (of_string "0") (of_int 0);
- test 2 (of_string "123") (of_int 123);
- test 3 (of_string "-456") (of_int (-456));
- test 4 (of_string "123456789") (of_int 123456789);
- test 5 (of_string "0xABCDEF") (of_int 0xABCDEF);
- test 6 (of_string "-0o1234567012") (of_int (- 0o1234567012));
- test 7 (of_string "0b01010111111000001100")
- (of_int 0b01010111111000001100);
- test 8 (of_string "0x7FFFFFFFFFFFFFFF") max_int;
- test 9 (of_string "-0x8000000000000000") min_int;
- test 10 (of_string "0x8000000000000000") min_int;
- test 11 (of_string "0xFFFFFFFFFFFFFFFF") minus_one;
-
- testing_function "to_string, format";
- List.iter (fun (n, s) -> test n (to_string (of_string s)) s)
- [1, "0"; 2, "123"; 3, "-456"; 4, "1234567890";
- 5, "1234567890123456789";
- 6, "9223372036854775807";
- 7, "-9223372036854775808"];
- List.iter (fun (n, s) -> test n ("0x" ^ format "%X" (of_string s)) s)
- [7, "0x0"; 8, "0x123"; 9, "0xABCDEF"; 10, "0x1234567812345678";
- 11, "0x7FFFFFFFFFFFFFFF"; 12, "0x8000000000000000";
- 13, "0xFFFFFFFFFFFFFFFF"];
- test 14 (to_string max_int) "9223372036854775807";
- test 15 (to_string min_int) "-9223372036854775808";
- test 16 (to_string zero) "0";
- test 17 (to_string one) "1";
- test 18 (to_string minus_one) "-1";
-
- testing_function "neg";
- test 1 (neg (of_int 0)) (of_int 0);
- test 2 (neg (of_int 123)) (of_int (-123));
- test 3 (neg (of_int (-456))) (of_int 456);
- test 4 (neg (of_int 123456789)) (of_int (-123456789));
- test 5 (neg max_int) (of_string "-0x7FFFFFFFFFFFFFFF");
- test 6 (neg min_int) min_int;
-
- testing_function "add";
- test 1 (add (of_int 0) (of_int 0)) (of_int 0);
- test 2 (add (of_int 123) (of_int 0)) (of_int 123);
- test 3 (add (of_int 0) (of_int 456)) (of_int 456);
- test 4 (add (of_int 123) (of_int 456)) (of_int 579);
- test 5 (add (of_int (-123)) (of_int 456)) (of_int 333);
- test 6 (add (of_int 123) (of_int (-456))) (of_int (-333));
- test 7 (add (of_int (-123)) (of_int (-456))) (of_int (-579));
- test 8 (add (of_string "0x1234567812345678")
- (of_string "0x9ABCDEF09ABCDEF"))
- (of_string "0x1be024671be02467");
- test 9 (add max_int max_int) (of_int (-2));
- test 10 (add min_int min_int) zero;
- test 11 (add max_int one) min_int;
- test 12 (add min_int minus_one) max_int;
- test 13 (add max_int min_int) minus_one;
-
- testing_function "sub";
- test 1 (sub (of_int 0) (of_int 0)) (of_int 0);
- test 2 (sub (of_int 123) (of_int 0)) (of_int 123);
- test 3 (sub (of_int 0) (of_int 456)) (of_int (-456));
- test 4 (sub (of_int 123) (of_int 456)) (of_int (-333));
- test 5 (sub (of_int (-123)) (of_int 456)) (of_int (-579));
- test 6 (sub (of_int 123) (of_int (-456))) (of_int 579);
- test 7 (sub (of_int (-123)) (of_int (-456))) (of_int 333);
- test 8 (sub (of_string "0x1234567812345678")
- (of_string "0x9ABCDEF09ABCDEF"))
- (of_string "0x888888908888889");
- test 9 (sub max_int min_int) minus_one;
- test 10 (sub min_int max_int) one;
- test 11 (sub min_int one) max_int;
- test 12 (sub max_int minus_one) min_int;
-
- testing_function "mul";
- test 1 (mul (of_int 0) (of_int 0)) (of_int 0);
- test 2 (mul (of_int 123) (of_int 0)) (of_int 0);
- test 3 (mul (of_int 0) (of_int (-456))) (of_int 0);
- test 4 (mul (of_int 123) (of_int 1)) (of_int 123);
- test 5 (mul (of_int 1) (of_int (-456))) (of_int (-456));
- test 6 (mul (of_int 123) (of_int (-1))) (of_int (-123));
- test 7 (mul (of_int (-1)) (of_int (-456))) (of_int 456);
- test 8 (mul (of_int 123) (of_int 456)) (of_int 56088);
- test 9 (mul (of_int (-123)) (of_int 456)) (of_int (-56088));
- test 10 (mul (of_int 123) (of_int (-456))) (of_int (-56088));
- test 11 (mul (of_int (-123)) (of_int (-456))) (of_int 56088);
- test 12 (mul (of_string "0x12345678") (of_string "0x9ABCDEF"))
- (of_string "0xb00ea4e242d208");
- test 13 (mul max_int max_int) one;
-
- testing_function "div";
- List.iter
- (fun (n, a, b) -> test n (div (of_int a) (of_int b)) (of_int (a / b)))
- [1, 0, 2;
- 2, 123, 1;
- 3, -123, 1;
- 4, 123, -1;
- 5, -123, -1;
- 6, 1275312364, 365;
- 7, 16384, 256;
- 8, -1275312364, 365;
- 9, 1275312364, -365;
- 10, 1234567, 12345678;
- 11, 1234567, -12345678];
-
- testing_function "mod";
- List.iter
- (fun (n, a, b) -> test n (rem (of_int a) (of_int b)) (of_int (a mod b)))
- [1, 0, 2;
- 2, 123, 1;
- 3, -123, 1;
- 4, 123, -1;
- 5, -123, -1;
- 6, 1275312364, 365;
- 7, 16384, 256;
- 8, -1275312364, 365;
- 9, 1275312364, -365;
- 10, 1234567, 12345678;
- 11, 1234567, -12345678];
-
- testing_function "and";
- List.iter
- (fun (n, a, b, c) -> test n (logand (of_string a) (of_string b))
- (of_string c))
- [1, "0x1234567812345678", "0x9abcdef09abcdef0", "0x1234567012345670";
- 2, "0x1234567812345678", "0x0fedcba90fedcba9", "0x224422802244228";
- 3, "0xFFFFFFFFFFFFFFFF", "0x1234000012345678", "0x1234000012345678";
- 4, "0", "0x1234567812345678", "0";
- 5, "0x5555555555555555", "0xAAAAAAAAAAAAAAAA", "0"];
-
- testing_function "or";
- List.iter
- (fun (n, a, b, c) -> test n (logor (of_string a) (of_string b))
- (of_string c))
- [1, "0x1234567812345678", "0x9abcdef09abcdef0", "0x9abcdef89abcdef8";
- 2, "0x1234567812345678", "0x0fedcba90fedcba9", "0x1ffddff91ffddff9";
- 3, "0xFFFFFFFFFFFFFFFF", "0x12345678", "0xFFFFFFFFFFFFFFFF";
- 4, "0", "0x1234567812340000", "0x1234567812340000";
- 5, "0x5555555555555555", "0xAAAAAAAAAAAAAAAA", "0xFFFFFFFFFFFFFFFF"];
-
- testing_function "xor";
- List.iter
- (fun (n, a, b, c) -> test n (logxor (of_string a) (of_string b))
- (of_string c))
- [1, "0x1234567812345678", "0x9abcdef09abcdef0", "0x8888888888888888";
- 2, "0x1234567812345678", "0x0fedcba90fedcba9", "0x1dd99dd11dd99dd1";
- 3, "0xFFFFFFFFFFFFFFFF", "0x123456789ABCDEF", "0xfedcba9876543210";
- 4, "0", "0x1234567812340000", "0x1234567812340000";
- 5, "0x5555555555555555", "0xAAAAAAAAAAAAAAAA", "0xFFFFFFFFFFFFFFFF"];
-
- testing_function "shift_left";
- List.iter
- (fun (n, a, b, c) -> test n (shift_left (of_string a) b) (of_string c))
- [1, "1", 1, "2";
- 2, "1", 2, "4";
- 3, "1", 4, "0x10";
- 4, "1", 62, "0x4000000000000000";
- 5, "1", 63, "0x8000000000000000";
- 6, "0x16236ABD45673", 7, "0xb11b55ea2b3980";
- 7, "0x10", 59, "0x8000000000000000";
- 8, "0x10", 60, "0"];
-
- testing_function "shift_right";
- List.iter
- (fun (n, a, b, c) -> test n (shift_right (of_string a) b) (of_string c))
- [1, "2", 1, "1";
- 2, "4", 2, "1";
- 3, "0x10", 4, "1";
- 4, "0x40000000", 10, "0x100000";
- 5, "0x8000000000000000", 63, "-1";
- 6, "0xb11b55ea2b3980", 7, "0x16236ABD45673";
- 7, "-0xb11b55ea2b3980", 7, "-389461927286387"];
-
- testing_function "shift_right_logical";
- List.iter
- (fun (n, a, b, c) -> test n (shift_right_logical (of_string a) b)
- (of_string c))
- [1, "2", 1, "1";
- 2, "4", 2, "1";
- 3, "0x10", 4, "1";
- 4, "0x40000000", 10, "0x100000";
- 5, "0x8000000000000000", 63, "1";
- 6, "0xb11b55ea2b3980", 7, "0x16236ABD45673";
- 7, "-0xb11b55ea2b3980", 7, "0x1fe9dc9542ba98d"];
-
- testing_function "Comparisons";
- test 1 (testcomp (of_int 0) (of_int 0))
- (true,false,false,false,true,true,0);
- test 2 (testcomp (of_int 1234567) (of_int 1234567))
- (true,false,false,false,true,true,0);
- test 3 (testcomp (of_int 0) (of_int 1))
- (false,true,true,false,true,false,-1);
- test 4 (testcomp (of_int (-1)) (of_int 0))
- (false,true,true,false,true,false,-1);
- test 5 (testcomp (of_int 1) (of_int 0))
- (false,true,false,true,false,true,1);
- test 6 (testcomp (of_int 0) (of_int (-1)))
- (false,true,false,true,false,true,1);
- test 7 (testcomp max_int min_int)
- (false,true,false,true,false,true,1);
-
- ()
-end
-
-(******** The test proper **********)
-
-let testcomp_int32 (a : int32) (b : int32) =
- (a = b, a <> b, a < b, a > b, a <= b, a >= b, compare a b)
-let testcomp_int64 (a : int64) (b : int64) =
- (a = b, a <> b, a < b, a > b, a <= b, a >= b, compare a b)
-let testcomp_nativeint (a : nativeint) (b : nativeint) =
- (a = b, a <> b, a < b, a > b, a <= b, a >= b, compare a b)
-
-let _ =
- testing_function "-------- Int32 --------";
- let module A = Test32(struct type t = int32
- module Ops = Int32
- let testcomp = testcomp_int32 end) in
- print_newline(); testing_function "-------- Int64 --------";
- let module B = Test64(struct type t = int64
- module Ops = Int64
- let testcomp = testcomp_int64 end) in
- print_newline(); testing_function "-------- Nativeint --------";
- begin match Sys.word_size with
- 32 ->
- let module C =
- Test32(struct type t = nativeint
- module Ops = Nativeint
- let testcomp = testcomp_nativeint end)
- in ()
- | 64 ->
- let module C =
- Test64(struct type t = nativeint
- module Ops = Nativeint
- let testcomp = testcomp_nativeint end)
- in ()
- | _ ->
- assert false
- end;
- print_newline(); testing_function "--------- Conversions -----------";
- testing_function "nativeint of/to int32";
- test 1 (Nativeint.of_int32 (Int32.of_string "0x12345678"))
- (Nativeint.of_string "0x12345678");
- test 2 (Nativeint.to_int32 (Nativeint.of_string "0x12345678"))
- (Int32.of_string "0x12345678");
- test 3 (Nativeint.to_int32 (Nativeint.of_string "0x123456789ABCDEF0"))
- (Int32.of_string "0x9ABCDEF0");
- testing_function "int64 of/to int32";
- test 1 (Int64.of_int32 (Int32.of_string "-0x12345678"))
- (Int64.of_string "-0x12345678");
- test 2 (Int64.to_int32 (Int64.of_string "-0x12345678"))
- (Int32.of_string "-0x12345678");
- test 3 (Int64.to_int32 (Int64.of_string "0x123456789ABCDEF0"))
- (Int32.of_string "0x9ABCDEF0");
- testing_function "int64 of/to nativeint";
- test 1 (Int64.of_nativeint (Nativeint.of_string "0x12345678"))
- (Int64.of_string "0x12345678");
- test 2 (Int64.to_nativeint (Int64.of_string "-0x12345678"))
- (Nativeint.of_string "-0x12345678");
- test 3 (Int64.to_nativeint (Int64.of_string "0x123456789ABCDEF0"))
- (Nativeint.of_string "0x123456789ABCDEF0");
- test 4 (Int64.of_nativeint (Nativeint.of_string "0x9ABCDEF012345678"))
- (if Sys.word_size = 64
- then Int64.of_string "0x9ABCDEF012345678"
- else Int64.of_string "0x12345678")
-
-(********* End of test *********)
-
-let _ =
- print_newline();
- if !error_occurred then begin
- prerr_endline "************* TEST FAILED ****************"; exit 2
- end else
- exit 0
diff --git a/test/Moretest/callbackprim.c b/test/Moretest/callbackprim.c
deleted file mode 100644
index f1a4ccfa14..0000000000
--- a/test/Moretest/callbackprim.c
+++ /dev/null
@@ -1,54 +0,0 @@
-#include "mlvalues.h"
-#include "memory.h"
-#include "callback.h"
-
-value mycallback1(value fun, value arg)
-{
- value res;
- res = callback(fun, arg);
- return res;
-}
-
-value mycallback2(value fun, value arg1, value arg2)
-{
- value res;
- res = callback2(fun, arg1, arg2);
- return res;
-}
-
-value mycallback3(value fun, value arg1, value arg2, value arg3)
-{
- value res;
- res = callback3(fun, arg1, arg2, arg3);
- return res;
-}
-
-value mycallback4(value fun, value arg1, value arg2, value arg3, value arg4)
-{
- value args[4];
- value res;
- args[0] = arg1;
- args[1] = arg2;
- args[2] = arg3;
- args[3] = arg4;
- res = callbackN(fun, 4, args);
- return res;
-}
-
-value mypushroot(value v, value fun, value arg)
-{
- Begin_root(v)
- callback(fun, arg);
- End_roots();
- return v;
-}
-
-value mycamlparam (value v, value fun, value arg)
-{
- CAMLparam3 (v, fun, arg);
- CAMLlocal2 (x, y);
- x = v;
- y = callback (fun, arg);
- v = x;
- CAMLreturn (v);
-}
diff --git a/test/Moretest/cmcaml.ml b/test/Moretest/cmcaml.ml
deleted file mode 100644
index a7e1cf55ef..0000000000
--- a/test/Moretest/cmcaml.ml
+++ /dev/null
@@ -1,17 +0,0 @@
-(* Caml part of the code *)
-
-let rec fib n =
- if n < 2 then 1 else fib(n-1) + fib(n-2)
-
-let format_result n =
- let r = "Result = " ^ string_of_int n in
- (* Allocate gratuitously to test GC *)
- for i = 1 to 1500 do String.create 256 done;
- r
-
-(* Registration *)
-
-let _ =
- Callback.register "fib" fib;
- Callback.register "format_result" format_result
-
diff --git a/test/Moretest/cmmain.c b/test/Moretest/cmmain.c
deleted file mode 100644
index 4894361b2b..0000000000
--- a/test/Moretest/cmmain.c
+++ /dev/null
@@ -1,21 +0,0 @@
-/* Main program -- in C */
-
-#include <stdlib.h>
-#include <caml/callback.h>
-
-extern int fib(int n);
-extern char * format_result(int n);
-
-int main(int argc, char ** argv)
-{
- printf("Initializing Caml code...\n");
-#ifdef NO_BYTECODE_FILE
- caml_startup(argv);
-#else
- caml_main(argv);
-#endif
- printf("Back in C code...\n");
- printf("Computing fib(20)...\n");
- printf("%s\n", format_result(fib(20)));
- return 0;
-}
diff --git a/test/Moretest/cmstub.c b/test/Moretest/cmstub.c
deleted file mode 100644
index 56cd694431..0000000000
--- a/test/Moretest/cmstub.c
+++ /dev/null
@@ -1,17 +0,0 @@
-#include <string.h>
-#include <caml/mlvalues.h>
-#include <caml/callback.h>
-
-/* Functions callable directly from C */
-
-int fib(int n)
-{
- value * fib_closure = caml_named_value("fib");
- return Int_val(callback(*fib_closure, Val_int(n)));
-}
-
-char * format_result(int n)
-{
- value * format_result_closure = caml_named_value("format_result");
- return strdup(String_val(callback(*format_result_closure, Val_int(n))));
-}
diff --git a/test/Moretest/equality.ml b/test/Moretest/equality.ml
deleted file mode 100644
index 05e6512363..0000000000
--- a/test/Moretest/equality.ml
+++ /dev/null
@@ -1,71 +0,0 @@
-let test n exp res =
- prerr_string "Test "; prerr_int n;
- if exp = res then prerr_string " passed.\n" else prerr_string " FAILED.\n";
- flush stderr
-
-let x = [1;2;3]
-
-let f x = 1 :: 2 :: 3 :: x
-
-let mklist len =
- let l = ref [] in
- for i = 1 to len do l := i :: !l done;
- !l
-
-type tree = Dummy | Leaf | Node of tree * tree
-
-let rec mktree depth =
- if depth <= 0 then Leaf else Node(mktree(depth - 1), mktree(depth - 1))
-
-type 'a leftlist = Nil | Cons of 'a leftlist * 'a
-
-let mkleftlist len =
- let l = ref Nil in
- for i = 1 to len do l := Cons(!l, i) done;
- !l
-
-let _ =
- test 1 0 (compare 0 0);
- test 2 (-1) (compare 0 1);
- test 3 1 (compare 1 0);
- test 4 0 (compare max_int max_int);
- test 5 (-1) (compare min_int max_int);
- test 6 1 (compare max_int min_int);
- test 7 0 (compare "foo" "foo");
- test 8 (-1) (compare "foo" "zorglub");
- test 9 (-1) (compare "abcdef" "foo");
- test 10 (-1) (compare "abcdefghij" "abcdefghijkl");
- test 11 1 (compare "abcdefghij" "abcdefghi");
- test 12 0 (compare (0,1) (0,1));
- test 13 (-1) (compare (0,1) (0,2));
- test 14 (-1) (compare (0,1) (1,0));
- test 15 1 (compare (0,1) (0,0));
- test 16 1 (compare (1,0) (0,1));
- test 17 0 (compare 0.0 0.0);
- test 18 (-1) (compare 0.0 1.0);
- test 19 (-1) (compare (-1.0) 0.0);
- test 20 0 (compare [| 0.0; 1.0; 2.0 |] [| 0.0; 1.0; 2.0 |]);
- test 21 (-1) (compare [| 0.0; 1.0; 2.0 |] [| 0.0; 1.0; 3.0 |]);
- test 22 1 (compare [| 0.0; 5.0; 2.0 |] [| 0.0; 1.0; 2.0 |]);
- test 23 0 (compare [1;2;3;4] [1;2;3;4]);
- test 24 (-1) (compare [1;2;3;4] [1;2;5;6]);
- test 25 (-1) (compare [1;2;3;4] [1;2;3;4;5]);
- test 26 1 (compare [1;2;3;4] [1;2;3]);
- test 27 1 (compare [1;2;3;4] [1;2;0;4]);
- test 28 0 (compare (mklist 1000) (mklist 1000));
- test 29 0 (compare (mkleftlist 1000) (mkleftlist 1000));
- test 30 0 (compare (mktree 12) (mktree 12));
- test 31 true (x = f []);
- test 32 true (stdout <> stderr);
- test 33 (-1) (compare nan 0.0);
- test 34 (-1) (compare nan neg_infinity);
- test 35 0 (compare nan nan);
- test 36 (-1) (compare (0.0, nan) (0.0, 0.0));
- test 37 (-1) (compare (0.0, nan) (0.0, neg_infinity));
- test 38 0 (compare (nan, 0.0) (nan, 0.0));
- let cmpgen x y = (x=y, x<>y, x<y, x<=y, x>y, x>=y) in
- let cmpfloat (x:float) (y:float) = (x=y, x<>y, x<y, x<=y, x>y, x>=y) in
- test 39 (false,true,false,false,false,false) (cmpgen nan nan);
- test 40 (false,true,false,false,false,false) (cmpgen nan 0.0);
- test 41 (false,true,false,false,false,false) (cmpfloat nan nan);
- test 42 (false,true,false,false,false,false) (cmpfloat nan 0.0)
diff --git a/test/Moretest/fftba.ml b/test/Moretest/fftba.ml
deleted file mode 100644
index 0bbd2d4071..0000000000
--- a/test/Moretest/fftba.ml
+++ /dev/null
@@ -1,191 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Bigarray
-
-let pi = 3.14159265358979323846
-
-let tpi = 2.0 *. pi
-
-let fft (px : (float, float64_elt, c_layout) Array1.t)
- (py : (float, float64_elt, c_layout) Array1.t) np =
- let i = ref 2 in
- let m = ref 1 in
-
- while (!i < np) do
- i := !i + !i;
- m := !m + 1
- done;
-
- let n = !i in
-
- if n <> np then begin
- for i = np+1 to n do
- px.{i} <- 0.0;
- py.{i} <- 0.0
- done;
- print_string "Use "; print_int n;
- print_string " point fft"; print_newline()
- end;
-
- let n2 = ref(n+n) in
- for k = 1 to !m-1 do
- n2 := !n2 / 2;
- let n4 = !n2 / 4 in
- let e = tpi /. float !n2 in
-
- for j = 1 to n4 do
- let a = e *. float(j - 1) in
- let a3 = 3.0 *. a in
- let cc1 = cos(a) in
- let ss1 = sin(a) in
- let cc3 = cos(a3) in
- let ss3 = sin(a3) in
- let is = ref j in
- let id = ref(2 * !n2) in
-
- while !is < n do
- let i0r = ref !is in
- while !i0r < n do
- let i0 = !i0r in
- let i1 = i0 + n4 in
- let i2 = i1 + n4 in
- let i3 = i2 + n4 in
- let r1 = px.{i0} -. px.{i2} in
- px.{i0} <- px.{i0} +. px.{i2};
- let r2 = px.{i1} -. px.{i3} in
- px.{i1} <- px.{i1} +. px.{i3};
- let s1 = py.{i0} -. py.{i2} in
- py.{i0} <- py.{i0} +. py.{i2};
- let s2 = py.{i1} -. py.{i3} in
- py.{i1} <- py.{i1} +. py.{i3};
- let s3 = r1 -. s2 in
- let r1 = r1 +. s2 in
- let s2 = r2 -. s1 in
- let r2 = r2 +. s1 in
- px.{i2} <- r1*.cc1 -. s2*.ss1;
- py.{i2} <- -.s2*.cc1 -. r1*.ss1;
- px.{i3} <- s3*.cc3 +. r2*.ss3;
- py.{i3} <- r2*.cc3 -. s3*.ss3;
- i0r := i0 + !id
- done;
- is := 2 * !id - !n2 + j;
- id := 4 * !id
- done
- done
- done;
-
-(************************************)
-(* Last stage, length=2 butterfly *)
-(************************************)
-
- let is = ref 1 in
- let id = ref 4 in
-
- while !is < n do
- let i0r = ref !is in
- while !i0r <= n do
- let i0 = !i0r in
- let i1 = i0 + 1 in
- let r1 = px.{i0} in
- px.{i0} <- r1 +. px.{i1};
- px.{i1} <- r1 -. px.{i1};
- let r1 = py.{i0} in
- py.{i0} <- r1 +. py.{i1};
- py.{i1} <- r1 -. py.{i1};
- i0r := i0 + !id
- done;
- is := 2 * !id - 1;
- id := 4 * !id
- done;
-
-(*************************)
-(* Bit reverse counter *)
-(*************************)
-
- let j = ref 1 in
-
- for i = 1 to n - 1 do
- if i < !j then begin
- let xt = px.{!j} in
- px.{!j} <- px.{i};
- px.{i} <- xt;
- let xt = py.{!j} in
- py.{!j} <- py.{i};
- py.{i} <- xt
- end;
- let k = ref(n / 2) in
- while !k < !j do
- j := !j - !k;
- k := !k / 2
- done;
- j := !j + !k
- done;
-
- n
-
-
-let test np =
- print_int np; print_string "... "; flush stdout;
- let enp = float np in
- let npm = np / 2 - 1 in
- let pxr = Array1.create float64 c_layout (np+2)
- and pxi = Array1.create float64 c_layout (np+2) in
- let t = pi /. enp in
- pxr.{1} <- (enp -. 1.0) *. 0.5;
- pxi.{1} <- 0.0;
- let n2 = np / 2 in
- pxr.{n2+1} <- -0.5;
- pxi.{n2+1} <- 0.0;
-
- for i = 1 to npm do
- let j = np - i in
- pxr.{i+1} <- -0.5;
- pxr.{j+1} <- -0.5;
- let z = t *. float i in
- let y = -0.5 *. (cos(z)/.sin(z)) in
- pxi.{i+1} <- y;
- pxi.{j+1} <- -.y
- done;
-(**
- print_newline();
- for i=0 to 15 do Printf.printf "%d %f %f\n" i pxr.{i+1} pxi.{i+1} done;
-**)
- let _ = fft pxr pxi np in
-(**
- for i=0 to 15 do Printf.printf "%d %f %f\n" i pxr.{i+1} pxi.{i+1} done;
-**)
- let zr = ref 0.0 in
- let zi = ref 0.0 in
- let kr = ref 0 in
- let ki = ref 0 in
- for i = 0 to np-1 do
- let a = abs_float(pxr.{i+1} -. float i) in
- if !zr < a then begin
- zr := a;
- kr := i
- end;
- let a = abs_float(pxi.{i+1}) in
- if !zi < a then begin
- zi := a;
- ki := i
- end
- done;
- let zm = if abs_float !zr < abs_float !zi then !zi else !zr in
- print_float zm; print_newline()
-
-
-let _ =
- let np = ref 16 in for i = 1 to 13 do test !np; np := !np*2 done
-
diff --git a/test/Moretest/float.ml b/test/Moretest/float.ml
deleted file mode 100644
index 9ebabbc4b6..0000000000
--- a/test/Moretest/float.ml
+++ /dev/null
@@ -1 +0,0 @@
-Printf.printf "1./.0. = %f\n" (1.0 /. 0.0);;
diff --git a/test/Moretest/globroots.ml b/test/Moretest/globroots.ml
deleted file mode 100644
index 4d1ba4d4a5..0000000000
--- a/test/Moretest/globroots.ml
+++ /dev/null
@@ -1,25 +0,0 @@
-type t
-
-external register: string -> t = "gb_register"
-external get: t -> string = "gb_get"
-external remove: t -> unit = "gb_remove"
-
-let size = 1024
-
-let _ =
- let a = Array.init size (fun i -> register (string_of_int i)) in
- while true do
- (* Check data *)
- for i = 0 to size - 1 do
- if get a.(i) <> string_of_int i then begin
- print_string "Error on "; print_int i; print_string ": ";
- print_string (String.escaped (get a.(i))); print_newline()
- end
- done;
- (* Change it randomly *)
- let i = Random.int size in
- remove a.(i);
- a.(i) <- register (string_of_int i);
- Gc.full_major();
- print_string "."; flush stdout
- done
diff --git a/test/Moretest/globrootsprim.c b/test/Moretest/globrootsprim.c
deleted file mode 100644
index 711f47a4de..0000000000
--- a/test/Moretest/globrootsprim.c
+++ /dev/null
@@ -1,29 +0,0 @@
-/* For testing global root registration */
-
-#include "mlvalues.h"
-#include "memory.h"
-#include "alloc.h"
-
-struct block { value v; };
-
-#define Block_val(v) ((struct block *) (v))
-
-value gb_register(value v)
-{
- struct block * b = stat_alloc(sizeof(struct block));
- b->v = v;
- register_global_root(&(b->v));
- return (value) b;
-}
-
-value gb_get(value vblock)
-{
- return Block_val(vblock)->v;
-}
-
-value gb_remove(value vblock)
-{
- remove_global_root(&(Block_val(vblock)->v));
- return Val_unit;
-}
-
diff --git a/test/Moretest/graph_example.ml b/test/Moretest/graph_example.ml
deleted file mode 100644
index 6fbe988ce3..0000000000
--- a/test/Moretest/graph_example.ml
+++ /dev/null
@@ -1,131 +0,0 @@
-(* To run this example:
- ********************
- 1. Select all the text in this window.
- 2. Drag it to the toplevel window.
- 3. Watch the colors.
- 4. Drag the mouse over the graphics window and click here and there.
- 5. Type any key to the graphics window to stop the program.
-*)
-
-open Graphics;;
-open_graph " 480x270";;
-
-let xr = size_x () / 2 - 30
-and yr = size_y () / 2 - 26
-and xg = size_x () / 2 + 30
-and yg = size_y () / 2 - 26
-and xb = size_x () / 2
-and yb = size_y () / 2 + 26
-;;
-
-let point x y =
- let dr = (x-xr)*(x-xr) + (y-yr)*(y-yr)
- and dg = (x-xg)*(x-xg) + (y-yg)*(y-yg)
- and db = (x-xb)*(x-xb) + (y-yb)*(y-yb)
- in
- if dr > dg && dr > db then set_color (rgb 255 (255*dg/dr) (255*db/dr))
- else if dg > db then set_color (rgb (255*dr/dg) 255 (255*db/dg))
- else set_color (rgb (255*dr/db) (255*dg/db) 255);
- fill_rect x y 2 2;
-;;
-
-for y = (size_y () - 1) / 2 downto 0 do
- for x = 0 to (size_x () - 1) / 2 do
- point (2*x) (2*y);
- done
-done
-;;
-
-let n = 0x000000
-and w = 0xFFFFFF
-and b = 0xFFCC99
-and y = 0xFFFF00
-and o = 0xCC9966
-and v = 0x00BB00
-and g = 0x888888
-and c = 0xDDDDDD
-and t = transp
-;;
-
-let caml = make_image [|
- [|t;t;t;t;t;t;t;t;t;t;t;n;n;n;n;n;n;t;t;t;t;t;t;t;t;t;t;t;t;t;t;t;|];
- [|t;t;t;t;t;t;t;t;t;t;n;n;n;n;n;n;n;n;n;t;t;t;t;t;t;t;t;t;t;t;t;t;|];
- [|t;t;t;t;t;t;t;t;n;n;n;n;n;n;n;n;n;n;n;n;t;t;t;t;t;t;t;t;t;t;t;t;|];
- [|n;n;n;n;n;n;t;n;n;n;n;n;b;b;b;b;b;b;b;n;n;t;t;t;t;t;n;n;n;n;n;t;|];
- [|n;o;o;o;o;o;n;n;n;n;b;b;b;b;b;b;b;b;b;b;b;n;n;n;n;n;n;n;n;n;n;t;|];
- [|n;o;o;o;o;o;o;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;t;|];
- [|n;o;o;o;o;o;o;o;n;n;n;g;g;g;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;t;t;|];
- [|n;n;o;o;o;o;o;o;o;n;n;n;c;c;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;t;t;|];
- [|t;n;n;o;o;o;o;o;o;o;n;n;n;c;n;n;n;n;n;n;n;b;b;n;n;n;n;n;n;t;t;t;|];
- [|t;t;n;n;n;o;o;o;o;o;o;n;n;n;n;n;n;n;n;n;b;b;b;b;n;n;n;n;t;t;t;t;|];
- [|t;t;t;t;n;n;o;o;o;o;o;o;n;n;n;n;n;n;n;n;b;b;b;b;b;b;n;n;t;t;t;t;|];
- [|t;t;t;t;t;n;n;o;o;o;o;o;o;n;n;n;n;n;n;o;o;b;b;b;b;b;b;n;n;t;t;t;|];
- [|t;t;t;t;t;n;n;o;o;o;o;o;o;b;b;b;b;b;n;n;o;o;b;b;b;b;b;b;n;n;t;t;|];
- [|t;t;t;t;n;n;n;o;o;o;o;o;b;b;b;b;b;b;b;n;n;o;o;b;b;b;b;b;b;n;n;t;|];
- [|t;t;t;t;n;n;n;o;o;o;o;b;b;b;b;b;b;b;b;b;n;n;o;o;b;b;b;b;b;b;n;n;|];
- [|t;t;t;t;n;n;n;o;o;o;o;b;b;b;b;b;n;n;b;b;b;n;n;o;o;b;b;b;b;b;n;n;|];
- [|t;t;t;t;n;n;n;o;o;o;o;b;b;b;b;b;n;n;b;b;b;b;n;n;o;o;b;o;b;b;n;n;|];
- [|t;t;t;t;n;n;n;o;o;o;o;b;b;b;b;b;n;n;b;b;b;b;b;n;n;o;o;o;o;o;n;n;|];
- [|t;t;t;t;n;n;n;o;o;o;o;b;b;b;b;b;n;n;b;b;b;b;b;b;n;n;o;o;o;o;n;n;|];
- [|t;t;t;t;n;n;n;o;o;o;o;o;b;b;b;b;n;n;b;b;b;b;b;b;b;n;n;o;o;n;n;n;|];
- [|t;t;t;t;n;n;n;n;o;o;o;o;o;b;b;b;n;n;n;b;b;b;b;b;b;b;n;n;o;n;b;n;|];
- [|t;t;t;t;t;n;n;n;o;o;o;o;o;o;b;b;n;n;n;b;b;b;b;b;b;b;b;n;n;n;b;n;|];
- [|t;t;t;t;t;t;n;n;o;o;o;o;o;o;o;y;v;y;n;b;b;b;b;b;b;b;b;n;n;b;b;n;|];
- [|t;t;t;t;t;t;t;n;o;o;o;o;o;v;y;o;o;n;n;n;b;b;b;b;b;b;b;n;n;b;b;n;|];
- [|t;t;t;t;t;t;t;n;o;o;o;y;v;o;o;o;o;n;n;n;n;b;b;b;b;b;b;n;n;b;b;n;|];
- [|t;t;t;t;t;t;n;n;o;v;y;o;y;o;o;o;o;o;o;n;n;n;b;b;b;b;b;n;n;b;b;n;|];
- [|t;t;t;t;t;t;n;o;y;y;o;o;v;o;o;o;o;o;o;o;n;n;n;b;b;b;n;n;n;b;n;t;|];
- [|t;t;t;t;t;n;n;v;o;v;o;o;o;o;o;o;o;o;o;o;o;n;n;n;b;n;n;n;n;b;n;t;|];
- [|t;t;t;t;t;n;v;o;o;v;o;o;o;o;o;o;o;o;o;o;o;o;n;n;n;n;n;n;n;n;t;t;|];
- [|t;t;t;t;n;n;o;o;o;o;o;o;o;o;o;o;o;o;o;o;o;n;n;n;n;n;n;t;t;t;t;t;|];
- [|t;t;t;t;n;o;o;o;o;o;o;o;o;o;o;o;o;o;o;o;n;n;t;t;t;t;t;t;t;t;t;t;|];
- [|t;t;t;t;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;t;t;t;t;t;t;t;t;t;t;t;|];
-|];;
-
-(*
-let x = ref 0 and y = ref 0;;
-let bg = get_image !x !y 32 32;;
-while true do
- let st = wait_next_event [Mouse_motion; Button_down] in
- if not st.button then draw_image bg !x !y;
- x := st.mouse_x;
- y := st.mouse_y;
- blit_image bg !x !y;
- draw_image caml !x !y;
-done;;
-*)
-set_color (rgb 0 0 0);
-remember_mode false;
-try while true do
- let st = wait_next_event [Mouse_motion; Button_down; Key_pressed] in
- synchronize ();
- if st.keypressed then raise Exit;
- if st.button then begin
- remember_mode true;
- draw_image caml st.mouse_x st.mouse_y;
- remember_mode false;
- end;
- let x = st.mouse_x + 16 and y = st.mouse_y + 16 in
-
- moveto 0 y;
- lineto (x - 25) y;
- moveto 10000 y;
- lineto (x + 25) y;
-
- moveto x 0;
- lineto x (y - 25);
- moveto x 10000;
- lineto x (y + 25);
-
- draw_image caml st.mouse_x st.mouse_y;
-done with Exit -> ()
-;;
-
-(* To run this example:
- ********************
- 1. Select all the text in this window.
- 2. Drag it to the toplevel window.
- 3. Watch the colors.
- 4. Drag the mouse over the graphics window and click here and there.
- 5. Type any key to the graphics window to stop the program.
-*)
diff --git a/test/Moretest/graph_test.ml b/test/Moretest/graph_test.ml
deleted file mode 100644
index cd4c0813db..0000000000
--- a/test/Moretest/graph_test.ml
+++ /dev/null
@@ -1,288 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Pierre Weis, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2000 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* graph_test.ml : tests various drawing and filling primitives of the
- Graphics library. *)
-
-(* To run this example just load this file into a suitable toplevel.
- Alternatively execute
- ocamlc graphics.cma graph_test.ml *)
-
-open Graphics;;
-
-auto_synchronize false;;
-display_mode false;;
-remember_mode true;;
-
-let sz = 450;;
-
-open_graph (Printf.sprintf " %ix%i" sz sz);;
-
-(* To be defined for older versions of O'Caml
- Lineto, moveto and draw_rect.
-
-let rlineto x y =
- let xc, yc = current_point () in
- lineto (x + xc) (y + yc);;
-
-let rmoveto x y =
- let xc, yc = current_point () in
- moveto (x + xc) (y + yc);;
-
-let draw_rect x y w h =
- let x0, y0 = current_point () in
- moveto x y;
- rlineto w 0;
- rlineto 0 h;
- rlineto (- w) 0;
- rlineto 0 (-h);
- moveto x0 y0;;
-*)
-
-(* A set of points. *)
-
-set_color foreground;;
-
-let dashes y =
- for i = 1 to 100 do
- plot y (2 * i);
- plot y (3 * i);
- plot y (4 * i);
- done;;
-
-dashes 3;;
-
-set_line_width 20;;
-dashes (sz - 20);;
-
-(* Drawing chars *)
-
-draw_char 'C';
-draw_char 'a';
-draw_char 'm';
-draw_char 'l';;
-
-(* More and more red enlarging squares *)
-moveto 10 10;;
-set_line_width 5;;
-
-let carre c =
- rlineto 0 c;
- rlineto c 0;
- rlineto 0 (- c);
- rlineto (- c) 0;;
-
-for i = 1 to 10 do
- moveto (10 * i) (10 * i);
- set_color (rgb (155 + 10 * i) 0 0);
- carre (10 * i)
-done;;
-
-(* Blue squares in arithmetic progression *)
-moveto 10 210;;
-set_color blue;;
-set_line_width 1;;
-
-for i = 1 to 10 do
- carre (10 * i)
-done;;
-
-(* Tiny circles filled or not *)
-rmoveto 0 120;;
-(* Must not change the current point *)
-fill_circle 20 190 10;;
-set_color green;;
-rlineto 0 10;;
-rmoveto 50 10;;
-let x, y = current_point () in
-(* Must not change the current point *)
-draw_circle x y 20;;
-set_color black;;
-rlineto 0 20;;
-
-(* Cyan rectangles as a kind of graphical representation *)
-set_color cyan;;
-
-let lw = 15;;
-set_line_width lw;;
-let go_caption l = moveto 210 (130 - lw + l);;
-let go_legend () = go_caption (- 3 * lw);;
-
-go_caption 0;;
-fill_rect 210 130 5 10;;
-fill_rect 220 130 10 20;;
-fill_rect 235 130 15 40;;
-fill_rect 255 130 20 80;;
-fill_rect 280 130 25 160;;
-(* A green rectangle below the graph. *)
-set_color green;;
-rlineto 50 0;;
-
-(* A black frame for each of our rectangles *)
-set_color black;;
-set_line_width (lw / 4);;
-
-draw_rect 210 130 5 10;;
-draw_rect 220 130 10 20;;
-draw_rect 235 130 15 40;;
-draw_rect 255 130 20 80;;
-draw_rect 280 130 25 160;;
-
-(* A black rectangle after the green one, below the graph. *)
-set_line_width lw;;
-rlineto 50 0;;
-
-(* Write a text in yellow on a blue background. *)
-(* x = 210, y = 70 *)
-go_legend ();;
-set_text_size 10;;
-set_color (rgb 150 100 250);;
-let x,y = current_point () in
-fill_rect x (y - 5) (8 * 20) 25;;
-set_color yellow;;
-go_legend ();;
-draw_string "Graphics (Caml)";;
-
-(* Pie parts in different colors. *)
-let draw_green_string s = set_color green; draw_string s;;
-let draw_red_string s = set_color red; draw_string s;;
-
-moveto 120 210;;
-set_color red;;
-fill_arc 150 260 25 25 60 300;
-draw_green_string "A ";
-draw_red_string "red";
-draw_green_string " pie.";
-
-set_text_size 5;
-moveto 180 240;
-draw_red_string "A "; draw_green_string "green"; draw_red_string " slice.";;
-set_color green;
-fill_arc 200 260 25 25 0 60;
-set_color black;
-set_line_width 2;
-draw_arc 200 260 27 27 0 60;;
-
-(* Should do nothing since this is a line *)
-set_color red;;
-fill_poly [| (40, 10); (150, 70); (150, 10); (40, 10) |];;
-set_color blue;;
-
-(* Drawing polygones. *)
-(* Redefining the draw_poly primitive for the usual library. *)
-let draw_poly v =
- let l = Array.length v in
- if l > 0 then begin
- let x0, y0 = current_point () in
- let p0 = v.(0) in
- let x, y = p0 in moveto x y;
- for i = 1 to l - 1 do
- let x, y = v.(i) in lineto x y
- done;
- lineto x y;
- moveto x0 y0
- end;;
-
-draw_poly [| (150, 10); (150, 70); (260, 10); (150, 10) |];;
-
-(* Filling polygones. *)
-(* Two equilateral triangles, one red and one blue, and their inside
- filled in black. *)
-let equi x y l =
- [| (x - l / 2, y);
- (x, y + int_of_float (float_of_int l *. (sqrt 3.0 /. 2.0)));
- (x + l / 2, y) |];;
-
-set_color black;;
-fill_poly (Array.append (equi 300 20 40) (equi 300 44 (- 40)));;
-
-set_line_width 1;;
-set_color cyan;;
-draw_poly (equi 300 20 40);;
-set_color red;;
-draw_poly (equi 300 44 (- 40));;
-
-(* Drawing and filling ellipses. *)
-let x, y = current_point () in
-rlineto 10 10; moveto x y;
-
-moveto 395 100;;
-
-let x, y = current_point () in
-fill_ellipse x y 25 15;;
-
-set_color (rgb 0xFF 0x00 0xFF);;
-rmoveto 0 (- 50);;
-
-let x, y = current_point () in
-fill_ellipse x y 15 30;;
-
-rmoveto (- 45) 0;;
-let x, y = current_point () in
-draw_ellipse x y 25 10;;
-
-(* Drawing and filling arcs. *)
-
-let draw_arc_ellipse x y r1 r2 =
- set_color green;
- draw_arc x y r1 r2 60 120;
- set_color black;
- draw_arc x y r1 r2 120 420;;
-
-set_line_width 3;;
-
-let draw_arc_ellipses x y r1 r2 =
- let step = 5 in
- for i = 0 to (r1 - step) / (2 * step) do
- for j = 0 to (r2 - step) / (2 * step) do
- draw_arc_ellipse x y (3 * i * step) (3 * j * step)
- done
- done;;
-
-draw_arc_ellipses 20 128 15 50;;
-
-let fill_arc_ellipse x y r1 r2 c1 c2 =
- set_color c1;
- fill_arc x y r1 r2 60 120;
- set_color c2;
- fill_arc x y r1 r2 120 420;;
-
-let fill_arc_ellipses x y r1 r2 =
- let step = 3 in
- let c1 = ref black
- and c2 = ref yellow in
- let exchange r1 r2 = let tmp = !r1 in r1 := !r2; r2 := tmp in
- for i = r1 / (2 * step) downto 10 do
- for j = r2 / (2 * step) downto 30 do
- exchange c1 c2;
- fill_arc_ellipse x y (3 * i) (3 * j) !c1 !c2
- done
- done;;
-
-fill_arc_ellipses 400 240 150 200;;
-
-
-synchronize ();;
-
-(* transparent color drawing *)
-set_color transp;;
-draw_circle 400 240 50;;
-draw_circle 400 240 40;;
-draw_circle 400 240 30;;
-(* try to go back a normal color *)
-set_color red;;
-draw_circle 400 240 20;;
-
-synchronize ();;
-
-input_line stdin;;
diff --git a/test/Moretest/includestruct.ml b/test/Moretest/includestruct.ml
deleted file mode 100644
index 182272c1ba..0000000000
--- a/test/Moretest/includestruct.ml
+++ /dev/null
@@ -1,92 +0,0 @@
-(* Test for "include <module-expr>" inside structures *)
-
-module A =
- struct
- type t = int
- let x = (1 : t)
- let y = (2 : t)
- let f (z : t) = (x + z : t)
- end
-
-module B =
- struct
- include A
- type u = t * t
- let p = ((x, y) : u)
- let g ((x, y) : u) = ((f x, f y) : u)
- end
-
-let _ =
- let print_pair (x,y) =
- print_int x; print_string ", "; print_int y; print_newline() in
- print_pair B.p;
- print_pair (B.g B.p);
- print_pair (B.g (123, 456))
-
-module H =
- struct
- include A
- let f (z : t) = (x - 1 : t)
- end
-
-let _ =
- print_int (H.f H.x); print_newline()
-
-module C =
- struct
- include (A : sig type t val f : t -> int val x : t end)
- let z = f x
- end
-
-let _ =
- print_int C.z; print_newline();
- print_int (C.f C.x); print_newline()
-
-(* Toplevel inclusion *)
-
-include A
-
-let _ =
- print_int x; print_newline();
- print_int (f y); print_newline()
-
-(* With a functor *)
-
-module F(X: sig end) =
- struct
- let _ = print_string "F is called"; print_newline()
- type t = A | B of int
- let print_t = function A -> print_string "A"
- | B x -> print_int x
- end
-
-module D =
- struct
- include F(struct end)
- let test() = print_t A; print_newline(); print_t (B 42); print_newline()
- end
-
-let _ =
- D.test();
- D.print_t D.A; print_newline(); D.print_t (D.B 42); print_newline()
-
-(* Exceptions and classes *)
-
-module E =
- struct
- exception Exn of string
- class c = object method m = 1 end
- end
-
-module G =
- struct
- include E
- let _ =
- begin try raise (Exn "foo") with Exn s -> print_string s end;
- print_int ((new c)#m); print_newline()
- end
-
-let _ =
- begin try raise (G.Exn "foo") with G.Exn s -> print_string s end;
- print_int ((new G.c)#m); print_newline()
-
diff --git a/test/Moretest/intext.ml b/test/Moretest/intext.ml
deleted file mode 100644
index 375419108c..0000000000
--- a/test/Moretest/intext.ml
+++ /dev/null
@@ -1,452 +0,0 @@
-(* Test for output_value / input_value *)
-
-type t = A | B of int | C of float | D of string | E of char
- | F of t | G of t * t | H of int * t | I of t * float | J
-
-let longstring =
-"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
-let verylongstring =
-"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\
- 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\
- 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\
- 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\
- 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\
- 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\
- 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\
- 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
-
-let 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 0x123456789ABCDEF0;
- output_value oc "foobargeebuz";
- output_value oc longstring;
- output_value oc verylongstring;
- output_value oc 3.141592654;
- output_value oc ();
- output_value oc A;
- output_value oc (B 1);
- output_value oc (C 2.718);
- output_value oc (D "hello, world!");
- output_value oc (E 'l');
- output_value oc (F(B 1));
- output_value oc (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e')))));
- output_value oc (H(1, A));
- output_value oc (I(B 2, 1e-6));
- let x = D "sharing" in
- let y = G(x, x) in
- let z = G(y, G(x, y)) in
- output_value oc z;
- output_value oc [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|];
- let rec big n = if n <= 0 then A else H(n, big(n-1)) in
- output_value oc (big 1000);
- Marshal.to_channel oc y [Marshal.No_sharing];
- Marshal.to_channel oc fib [Marshal.Closures];
- output_value oc (Int32.of_string "0");
- output_value oc (Int32.of_string "123456");
- output_value oc (Int32.of_string "-123456");
- output_value oc (Int64.of_string "0");
- output_value oc (Int64.of_string "123456789123456");
- output_value oc (Int64.of_string "-123456789123456");
- output_value oc (Nativeint.of_string "0");
- output_value oc (Nativeint.of_string "123456");
- output_value oc (Nativeint.of_string "-123456");
- output_value oc (Nativeint.shift_left (Nativeint.of_string "123456789") 32);
- output_value oc (Nativeint.shift_left (Nativeint.of_string "-123456789") 32);
- let i = Int64.of_string "123456789123456" in output_value oc (i,i);
- close_out oc
-
-
-let test n b =
- prerr_string "Test "; prerr_int n;
- if b then prerr_string " passed.\n" else prerr_string " FAILED.\n";
- flush stderr
-
-let test_in filename =
- let ic = open_in_bin filename in
- test 1 (input_value ic = 1);
- test 2 (input_value ic = (-1));
- test 3 (input_value ic = 258);
- test 4 (input_value ic = 20000);
- test 5 (input_value ic = 0x12345678);
- test 6 (input_value ic = 0x123456789ABCDEF0);
- test 7 (input_value ic = "foobargeebuz");
- test 8 (input_value ic = longstring);
- test 9 (input_value ic = verylongstring);
- test 10 (input_value ic = 3.141592654);
- test 11 (input_value ic = ());
- test 12 (match input_value ic with
- A -> true
- | _ -> false);
- test 13 (match input_value ic with
- (B 1) -> true
- | _ -> false);
- test 14 (match input_value ic with
- (C f) -> f = 2.718
- | _ -> false);
- test 15 (match input_value ic with
- (D "hello, world!") -> true
- | _ -> false);
- test 16 (match input_value ic with
- (E 'l') -> true
- | _ -> false);
- test 17 (match input_value ic with
- (F(B 1)) -> true
- | _ -> false);
- test 18 (match input_value ic with
- (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) -> true
- | _ -> false);
- test 19 (match input_value ic with
- (H(1, A)) -> true
- | _ -> false);
- test 20 (match input_value ic with
- (I(B 2, 1e-6)) -> true
- | _ -> false);
- test 21 (match input_value ic with
- G((G((D "sharing" as t1), t2) as t3), G(t4, t5)) ->
- t1 == t2 && t3 == t5 && t4 == t1
- | _ -> false);
- test 22 (input_value ic = [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]);
- let rec check_big n t =
- if n <= 0 then
- test 23 (match t with A -> true | _ -> false)
- else
- match t with H(m, s) -> if m = n then check_big (n-1) s
- else test 23 false
- | _ -> test 23 false
- in
- check_big 1000 (input_value ic);
- test 24 (match input_value ic with
- G((D "sharing" as t1), (D "sharing" as t2)) -> t1 != t2
- | _ -> false);
- test 25 (let fib = input_value ic in fib 5 = 8 && fib 10 = 89);
- test 26 (input_value ic = Int32.of_string "0");
- test 27 (input_value ic = Int32.of_string "123456");
- test 28 (input_value ic = Int32.of_string "-123456");
- test 29 (input_value ic = Int64.of_string "0");
- test 30 (input_value ic = Int64.of_string "123456789123456");
- test 31 (input_value ic = Int64.of_string "-123456789123456");
- test 32 (input_value ic = Nativeint.of_string "0");
- test 33 (input_value ic = Nativeint.of_string "123456");
- test 34 (input_value ic = Nativeint.of_string "-123456");
- test 35 (input_value ic =
- Nativeint.shift_left (Nativeint.of_string "123456789") 32);
- test 36 (input_value ic =
- Nativeint.shift_left (Nativeint.of_string "-123456789") 32);
- let ((i, j) : int64 * int64) = input_value ic in
- test 37 (i = Int64.of_string "123456789123456");
- test 38 (j = Int64.of_string "123456789123456");
- test 39 (i == j);
- close_in ic
-
-let test_string () =
- let s = Marshal.to_string 1 [] in
- test 101 (Marshal.from_string s 0 = 1);
- let s = Marshal.to_string (-1) [] in
- test 102 (Marshal.from_string s 0 = (-1));
- let s = Marshal.to_string 258 [] in
- test 103 (Marshal.from_string s 0 = 258);
- let s = Marshal.to_string 20000 [] in
- test 104 (Marshal.from_string s 0 = 20000);
- let s = Marshal.to_string 0x12345678 [] in
- test 105 (Marshal.from_string s 0 = 0x12345678);
- let s = Marshal.to_string 0x123456789ABCDEF0 [] in
- test 106 (Marshal.from_string s 0 = 0x123456789ABCDEF0);
- let s = Marshal.to_string "foobargeebuz" [] in
- test 107 (Marshal.from_string s 0 = "foobargeebuz");
- let s = Marshal.to_string longstring [] in
- test 108 (Marshal.from_string s 0 = longstring);
- let s = Marshal.to_string verylongstring [] in
- test 109 (Marshal.from_string s 0 = verylongstring);
- let s = Marshal.to_string 3.141592654 [] in
- test 110 (Marshal.from_string s 0 = 3.141592654);
- let s = Marshal.to_string () [] in
- test 111 (Marshal.from_string s 0 = ());
- let s = Marshal.to_string A [] in
- test 112 (match Marshal.from_string s 0 with
- A -> true
- | _ -> false);
- let s = Marshal.to_string (B 1) [] in
- test 113 (match Marshal.from_string s 0 with
- (B 1) -> true
- | _ -> false);
- let s = Marshal.to_string (C 2.718) [] in
- test 114 (match Marshal.from_string s 0 with
- (C f) -> f = 2.718
- | _ -> false);
- let s = Marshal.to_string (D "hello, world!") [] in
- test 115 (match Marshal.from_string s 0 with
- (D "hello, world!") -> true
- | _ -> false);
- let s = Marshal.to_string (E 'l') [] in
- test 116 (match Marshal.from_string s 0 with
- (E 'l') -> true
- | _ -> false);
- let s = Marshal.to_string (F(B 1)) [] in
- test 117 (match Marshal.from_string s 0 with
- (F(B 1)) -> true
- | _ -> false);
- let s = Marshal.to_string (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) [] in
- test 118 (match Marshal.from_string s 0 with
- (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) -> true
- | _ -> false);
- let s = Marshal.to_string (H(1, A)) [] in
- test 119 (match Marshal.from_string s 0 with
- (H(1, A)) -> true
- | _ -> false);
- let s = Marshal.to_string (I(B 2, 1e-6)) [] in
- test 120 (match Marshal.from_string s 0 with
- (I(B 2, 1e-6)) -> true
- | _ -> false);
- let x = D "sharing" in
- let y = G(x, x) in
- let z = G(y, G(x, y)) in
- let s = Marshal.to_string z [] in
- test 121 (match Marshal.from_string s 0 with
- G((G((D "sharing" as t1), t2) as t3), G(t4, t5)) ->
- t1 == t2 && t3 == t5 && t4 == t1
- | _ -> false);
- let s = Marshal.to_string [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|] [] in
- test 122 (Marshal.from_string s 0 = [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]);
- let rec big n = if n <= 0 then A else H(n, big(n-1)) in
- let s = Marshal.to_string (big 1000) [] in
- let rec check_big n t =
- if n <= 0 then
- test 123 (match t with A -> true | _ -> false)
- else
- match t with H(m, s) -> if m = n then check_big (n-1) s
- else test 123 false
- | _ -> test 123 false
- in
- check_big 1000 (Marshal.from_string s 0)
-
-let test_buffer () =
- let s = String.create 512 in
- Marshal.to_buffer s 0 512 1 [];
- test 201 (Marshal.from_string s 0 = 1);
- Marshal.to_buffer s 0 512 (-1) [];
- test 202 (Marshal.from_string s 0 = (-1));
- Marshal.to_buffer s 0 512 258 [];
- test 203 (Marshal.from_string s 0 = 258);
- Marshal.to_buffer s 0 512 20000 [];
- test 204 (Marshal.from_string s 0 = 20000);
- Marshal.to_buffer s 0 512 0x12345678 [];
- test 205 (Marshal.from_string s 0 = 0x12345678);
- Marshal.to_buffer s 0 512 0x123456789ABCDEF0 [];
- test 206 (Marshal.from_string s 0 = 0x123456789ABCDEF0);
- Marshal.to_buffer s 0 512 "foobargeebuz" [];
- test 207 (Marshal.from_string s 0 = "foobargeebuz");
- Marshal.to_buffer s 0 512 longstring [];
- test 208 (Marshal.from_string s 0 = longstring);
- test 209
- (try Marshal.to_buffer s 0 512 verylongstring []; false
- with Failure "Marshal.to_buffer: buffer overflow" -> true);
- Marshal.to_buffer s 0 512 3.141592654 [];
- test 210 (Marshal.from_string s 0 = 3.141592654);
- Marshal.to_buffer s 0 512 () [];
- test 211 (Marshal.from_string s 0 = ());
- Marshal.to_buffer s 0 512 A [];
- test 212 (match Marshal.from_string s 0 with
- A -> true
- | _ -> false);
- Marshal.to_buffer s 0 512 (B 1) [];
- test 213 (match Marshal.from_string s 0 with
- (B 1) -> true
- | _ -> false);
- Marshal.to_buffer s 0 512 (C 2.718) [];
- test 214 (match Marshal.from_string s 0 with
- (C f) -> f = 2.718
- | _ -> false);
- Marshal.to_buffer s 0 512 (D "hello, world!") [];
- test 215 (match Marshal.from_string s 0 with
- (D "hello, world!") -> true
- | _ -> false);
- Marshal.to_buffer s 0 512 (E 'l') [];
- test 216 (match Marshal.from_string s 0 with
- (E 'l') -> true
- | _ -> false);
- Marshal.to_buffer s 0 512 (F(B 1)) [];
- test 217 (match Marshal.from_string s 0 with
- (F(B 1)) -> true
- | _ -> false);
- Marshal.to_buffer s 0 512 (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) [];
- test 218 (match Marshal.from_string s 0 with
- (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) -> true
- | _ -> false);
- Marshal.to_buffer s 0 512 (H(1, A)) [];
- test 219 (match Marshal.from_string s 0 with
- (H(1, A)) -> true
- | _ -> false);
- Marshal.to_buffer s 0 512 (I(B 2, 1e-6)) [];
- test 220 (match Marshal.from_string s 0 with
- (I(B 2, 1e-6)) -> true
- | _ -> false);
- let x = D "sharing" in
- let y = G(x, x) in
- let z = G(y, G(x, y)) in
- Marshal.to_buffer s 0 512 z [];
- test 221 (match Marshal.from_string s 0 with
- G((G((D "sharing" as t1), t2) as t3), G(t4, t5)) ->
- t1 == t2 && t3 == t5 && t4 == t1
- | _ -> false);
- Marshal.to_buffer s 0 512 [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|] [];
- test 222 (Marshal.from_string s 0 = [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]);
- let rec big n = if n <= 0 then A else H(n, big(n-1)) in
- test 223
- (try Marshal.to_buffer s 0 512 (big 1000) []; false
- with Failure "Marshal.to_buffer: buffer overflow" -> true)
-
-let test_size() =
- let s = Marshal.to_string (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) [] in
- test 300 (Marshal.header_size + Marshal.data_size s 0 = String.length s)
-
-external marshal_to_block
- : string -> int -> 'a -> Marshal.extern_flags list -> unit
- = "marshal_to_block"
-external marshal_from_block : string -> int -> 'a = "marshal_from_block"
-external static_alloc : int -> string = "static_alloc"
-
-let test_block () =
- let s = static_alloc 512 in
- marshal_to_block s 512 1 [];
- test 401 (marshal_from_block s 512 = 1);
- marshal_to_block s 512 (-1) [];
- test 402 (marshal_from_block s 512 = (-1));
- marshal_to_block s 512 258 [];
- test 403 (marshal_from_block s 512 = 258);
- marshal_to_block s 512 20000 [];
- test 404 (marshal_from_block s 512 = 20000);
- marshal_to_block s 512 0x12345678 [];
- test 405 (marshal_from_block s 512 = 0x12345678);
- marshal_to_block s 512 0x123456789ABCDEF0 [];
- test 406 (marshal_from_block s 512 = 0x123456789ABCDEF0);
- marshal_to_block s 512 "foobargeebuz" [];
- test 407 (marshal_from_block s 512 = "foobargeebuz");
- marshal_to_block s 512 longstring [];
- test 408 (marshal_from_block s 512 = longstring);
- test 409
- (try marshal_to_block s 512 verylongstring []; false
- with Failure "Marshal.to_buffer: buffer overflow" -> true);
- marshal_to_block s 512 3.141592654 [];
- test 410 (marshal_from_block s 512 = 3.141592654);
- marshal_to_block s 512 () [];
- test 411 (marshal_from_block s 512 = ());
- marshal_to_block s 512 A [];
- test 412 (match marshal_from_block s 512 with
- A -> true
- | _ -> false);
- marshal_to_block s 512 (B 1) [];
- test 413 (match marshal_from_block s 512 with
- (B 1) -> true
- | _ -> false);
- marshal_to_block s 512 (C 2.718) [];
- test 414 (match marshal_from_block s 512 with
- (C f) -> f = 2.718
- | _ -> false);
- marshal_to_block s 512 (D "hello, world!") [];
- test 415 (match marshal_from_block s 512 with
- (D "hello, world!") -> true
- | _ -> false);
- marshal_to_block s 512 (E 'l') [];
- test 416 (match marshal_from_block s 512 with
- (E 'l') -> true
- | _ -> false);
- marshal_to_block s 512 (F(B 1)) [];
- test 417 (match marshal_from_block s 512 with
- (F(B 1)) -> true
- | _ -> false);
- marshal_to_block s 512 (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) [];
- test 418 (match marshal_from_block s 512 with
- (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) -> true
- | _ -> false);
- marshal_to_block s 512 (H(1, A)) [];
- test 419 (match marshal_from_block s 512 with
- (H(1, A)) -> true
- | _ -> false);
- marshal_to_block s 512 (I(B 2, 1e-6)) [];
- test 420 (match marshal_from_block s 512 with
- (I(B 2, 1e-6)) -> true
- | _ -> false);
- let x = D "sharing" in
- let y = G(x, x) in
- let z = G(y, G(x, y)) in
- marshal_to_block s 512 z [];
- test 421 (match marshal_from_block s 512 with
- G((G((D "sharing" as t1), t2) as t3), G(t4, t5)) ->
- t1 == t2 && t3 == t5 && t4 == t1
- | _ -> false);
- marshal_to_block s 512 [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|] [];
- test 422 (marshal_from_block s 512 = [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]);
- let rec big n = if n <= 0 then A else H(n, big(n-1)) in
- test 423
- (try marshal_to_block s 512 (big 1000) []; false
- with Failure _ -> true);
- test 424
- (try marshal_to_block s 512 "Hello, world!" [];
- marshal_from_block s 8;
- false
- with Failure _ -> true)
-
-(* Test for really big objects *)
-
-let counter = ref 0
-
-let rec make_big n =
- if n <= 0 then begin
- incr counter; B !counter
- end else begin
- let l = make_big (n-1) in
- let r = make_big (n-1) in
- G(l, r)
- end
-
-let rec check_big n x =
- if n <= 0 then begin
- match x with
- B k -> incr counter; k = !counter
- | _ -> false
- end else begin
- match x with
- G(l, r) -> check_big (n-1) l && check_big (n-1) r
- | _ -> false
- end
-
-let main() =
- if Array.length Sys.argv <= 2 then begin
- test_out "intext.data"; test_in "intext.data";
- test_out "intext.data"; test_in "intext.data";
- Sys.remove "intext.data";
- test_string();
- test_buffer();
- test_size();
- test_block()
- end else
- if Sys.argv.(1) = "make" then begin
- let n = int_of_string Sys.argv.(2) in
- let oc = open_out_bin "intext.data" in
- counter := 0;
- output_value oc (make_big n);
- close_out oc
- end else
- if Sys.argv.(1) = "test" then begin
- let n = int_of_string Sys.argv.(2) in
- let ic = open_in_bin "intext.data" in
- let b = (input_value ic : t) in
- Gc.full_major();
- close_in ic;
- counter := 0;
- if check_big n b then
- Printf.printf "Test big %d passed" n
- else
- Printf.printf "Test big %d FAILED" n;
- print_newline()
- end
-
-let _ = Printexc.catch main (); exit 0
diff --git a/test/Moretest/intextaux.c b/test/Moretest/intextaux.c
deleted file mode 100644
index 9225b90bc2..0000000000
--- a/test/Moretest/intextaux.c
+++ /dev/null
@@ -1,13 +0,0 @@
-#include <mlvalues.h>
-#include <intext.h>
-
-value marshal_to_block(value vbuf, value vlen, value v, value vflags)
-{
- return Val_long(output_value_to_block(v, vflags,
- (char *) vbuf, Long_val(vlen)));
-}
-
-value marshal_from_block(value vbuf, value vlen)
-{
- return input_value_from_block((char *) vbuf, Long_val(vlen));
-}
diff --git a/test/Moretest/io.ml b/test/Moretest/io.ml
deleted file mode 100644
index 2fb2c99937..0000000000
--- a/test/Moretest/io.ml
+++ /dev/null
@@ -1,101 +0,0 @@
-(* Test a file copy function *)
-
-let test msg funct f1 f2 =
- print_string msg; print_newline();
- funct f1 f2;
- if Sys.command ("cmp " ^ f1 ^ " " ^ f2) = 0
- then print_string "passed"
- else print_string "FAILED";
- print_newline()
-
-(* File copy with constant-sized chunks *)
-
-let copy_file sz infile ofile =
- let ic = open_in infile in
- let oc = open_out ofile in
- let buffer = String.create sz in
- let rec copy () =
- let n = input ic buffer 0 sz in
- if n = 0 then () else begin
- output oc buffer 0 n;
- copy ()
- end in
- copy();
- close_in ic;
- close_out oc
-
-(* File copy with random-sized chunks *)
-
-let copy_random sz infile ofile =
- let ic = open_in infile in
- let oc = open_out ofile in
- let buffer = String.create sz in
- let rec copy () =
- let s = 1 + Random.int sz in
- let n = input ic buffer 0 s in
- if n = 0 then () else begin
- output oc buffer 0 n;
- copy ()
- end in
- copy();
- close_in ic;
- close_out oc
-
-(* File copy line per line *)
-
-let copy_line infile ofile =
- let ic = open_in infile in
- let oc = open_out ofile in
- try
- while true do
- output_string oc (input_line ic); output_char oc '\n'
- done
- with End_of_file ->
- close_in ic;
- close_out oc
-
-(* Backward copy, with lots of seeks *)
-
-let copy_seek chunksize infile ofile =
- let ic = open_in_bin infile in
- let oc = open_out_bin ofile in
- let size = in_channel_length ic in
- let buffer = String.create chunksize in
- for i = (size - 1) / chunksize downto 0 do
- seek_in ic (i * chunksize);
- seek_out oc (i * chunksize);
- let n = input ic buffer 0 chunksize in
- output oc buffer 0 n
- done;
- close_in ic;
- close_out oc
-
-(* Create long lines of text *)
-
-let make_lines ofile =
- let oc = open_out ofile in
- for i = 1 to 256 do
- output_string oc (String.make (i*64) '.'); output_char oc '\n'
- done;
- close_out oc
-
-(* The test *)
-
-let _ =
- let src = Sys.argv.(1) in
- test "16-byte chunks" (copy_file 16) src "/tmp/testio";
- test "256-byte chunks" (copy_file 256) src "/tmp/testio";
- test "4096-byte chunks" (copy_file 4096) src "/tmp/testio";
- test "65536-byte chunks" (copy_file 65536) src "/tmp/testio";
- test "19-byte chunks" (copy_file 19) src "/tmp/testio";
- test "263-byte chunks" (copy_file 263) src "/tmp/testio";
- test "4011-byte chunks" (copy_file 4011) src "/tmp/testio";
- test "0...8192 byte chunks" (copy_random 8192) src "/tmp/testio";
- test "line per line, short lines" copy_line "/etc/hosts" "/tmp/testio";
- make_lines "/tmp/lines";
- test "line per line, short and long lines" copy_line "/tmp/lines" "/tmp/testio";
- test "backwards, 4096-byte chunks" (copy_seek 4096) src "/tmp/testio";
- test "backwards, 64-byte chunks" (copy_seek 64) src "/tmp/testio";
- Sys.remove "/tmp/lines";
- Sys.remove "/tmp/testio";
- exit 0
diff --git a/test/Moretest/manyargs.ml b/test/Moretest/manyargs.ml
deleted file mode 100644
index 0a1271ae0d..0000000000
--- a/test/Moretest/manyargs.ml
+++ /dev/null
@@ -1,18 +0,0 @@
-let manyargs a b c d e f g h i j k =
- print_string "a = "; print_int a; print_newline();
- print_string "b = "; print_int b; print_newline();
- print_string "c = "; print_int c; print_newline();
- print_string "d = "; print_int d; print_newline();
- print_string "e = "; print_int e; print_newline();
- print_string "f = "; print_int f; print_newline();
- print_string "g = "; print_int g; print_newline();
- print_string "h = "; print_int h; print_newline();
- print_string "i = "; print_int i; print_newline();
- print_string "j = "; print_int j; print_newline();
- print_string "k = "; print_int k; print_newline()
-
-let _ = manyargs 1 2 3 4 5 6 7 8 9 10 11
-
-external manyargs_ext: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "manyargs_argv" "manyargs"
-
-let _ = manyargs_ext 1 2 3 4 5 6 7 8 9 10 11
diff --git a/test/Moretest/manyargsprim.c b/test/Moretest/manyargsprim.c
deleted file mode 100644
index c80e5346de..0000000000
--- a/test/Moretest/manyargsprim.c
+++ /dev/null
@@ -1,24 +0,0 @@
-#include "mlvalues.h"
-
-value manyargs(value a, value b, value c, value d, value e, value f,
- value g, value h, value i, value j, value k)
-{
- printf("a = %d\n", Int_val(a));
- printf("b = %d\n", Int_val(b));
- printf("c = %d\n", Int_val(c));
- printf("d = %d\n", Int_val(d));
- printf("e = %d\n", Int_val(e));
- printf("f = %d\n", Int_val(f));
- printf("g = %d\n", Int_val(g));
- printf("h = %d\n", Int_val(h));
- printf("i = %d\n", Int_val(i));
- printf("j = %d\n", Int_val(j));
- printf("k = %d\n", Int_val(k));
- return Val_unit;
-}
-
-value manyargs_argv(value *argv, int argc)
-{
- return manyargs(argv[0], argv[1], argv[2], argv[3], argv[4],
- argv[5], argv[6], argv[7], argv[8], argv[9], argv[10]);
-}
diff --git a/test/Moretest/md5.ml b/test/Moretest/md5.ml
deleted file mode 100644
index 46d8a10a42..0000000000
--- a/test/Moretest/md5.ml
+++ /dev/null
@@ -1,219 +0,0 @@
-(* Test int32 arithmetic and optimizations using the MD5 algorithm *)
-
-open Printf
-
-type context =
- { buf: string;
- mutable pos: int;
- mutable a: int32;
- mutable b: int32;
- mutable c: int32;
- mutable d: int32;
- mutable bits: int64 }
-
-let step1 w x y z data s =
- let w =
- Int32.add (Int32.add w data)
- (Int32.logxor z (Int32.logand x (Int32.logxor y z))) in
- Int32.add x
- (Int32.logor (Int32.shift_left w s) (Int32.shift_right_logical w (32-s)))
-
-let step2 w x y z data s =
- let w =
- Int32.add (Int32.add w data)
- (Int32.logxor y (Int32.logand z (Int32.logxor x y))) in
- Int32.add x
- (Int32.logor (Int32.shift_left w s) (Int32.shift_right_logical w (32-s)))
-
-let step3 w x y z data s =
- let w =
- Int32.add (Int32.add w data)
- (Int32.logxor x (Int32.logxor y z)) in
- Int32.add x
- (Int32.logor (Int32.shift_left w s) (Int32.shift_right_logical w (32-s)))
-
-let step4 w x y z data s =
- let w =
- Int32.add (Int32.add w data)
- (Int32.logxor y (Int32.logor x (Int32.logxor z (-1l)))) in
- Int32.add x
- (Int32.logor (Int32.shift_left w s) (Int32.shift_right_logical w (32-s)))
-
-let transform ctx data =
- let a = ctx.a and b = ctx.b and c = ctx.c and d = ctx.d in
-
- let a = step1 a b c d (Int32.add data.(0) 0xd76aa478l) 7 in
- let d = step1 d a b c (Int32.add data.(1) 0xe8c7b756l) 12 in
- let c = step1 c d a b (Int32.add data.(2) 0x242070dbl) 17 in
- let b = step1 b c d a (Int32.add data.(3) 0xc1bdceeel) 22 in
- let a = step1 a b c d (Int32.add data.(4) 0xf57c0fafl) 7 in
- let d = step1 d a b c (Int32.add data.(5) 0x4787c62al) 12 in
- let c = step1 c d a b (Int32.add data.(6) 0xa8304613l) 17 in
- let b = step1 b c d a (Int32.add data.(7) 0xfd469501l) 22 in
- let a = step1 a b c d (Int32.add data.(8) 0x698098d8l) 7 in
- let d = step1 d a b c (Int32.add data.(9) 0x8b44f7afl) 12 in
- let c = step1 c d a b (Int32.add data.(10) 0xffff5bb1l) 17 in
- let b = step1 b c d a (Int32.add data.(11) 0x895cd7bel) 22 in
- let a = step1 a b c d (Int32.add data.(12) 0x6b901122l) 7 in
- let d = step1 d a b c (Int32.add data.(13) 0xfd987193l) 12 in
- let c = step1 c d a b (Int32.add data.(14) 0xa679438el) 17 in
- let b = step1 b c d a (Int32.add data.(15) 0x49b40821l) 22 in
-
- let a = step2 a b c d (Int32.add data.(1) 0xf61e2562l) 5 in
- let d = step2 d a b c (Int32.add data.(6) 0xc040b340l) 9 in
- let c = step2 c d a b (Int32.add data.(11) 0x265e5a51l) 14 in
- let b = step2 b c d a (Int32.add data.(0) 0xe9b6c7aal) 20 in
- let a = step2 a b c d (Int32.add data.(5) 0xd62f105dl) 5 in
- let d = step2 d a b c (Int32.add data.(10) 0x02441453l) 9 in
- let c = step2 c d a b (Int32.add data.(15) 0xd8a1e681l) 14 in
- let b = step2 b c d a (Int32.add data.(4) 0xe7d3fbc8l) 20 in
- let a = step2 a b c d (Int32.add data.(9) 0x21e1cde6l) 5 in
- let d = step2 d a b c (Int32.add data.(14) 0xc33707d6l) 9 in
- let c = step2 c d a b (Int32.add data.(3) 0xf4d50d87l) 14 in
- let b = step2 b c d a (Int32.add data.(8) 0x455a14edl) 20 in
- let a = step2 a b c d (Int32.add data.(13) 0xa9e3e905l) 5 in
- let d = step2 d a b c (Int32.add data.(2) 0xfcefa3f8l) 9 in
- let c = step2 c d a b (Int32.add data.(7) 0x676f02d9l) 14 in
- let b = step2 b c d a (Int32.add data.(12) 0x8d2a4c8al) 20 in
-
- let a = step3 a b c d (Int32.add data.(5) 0xfffa3942l) 4 in
- let d = step3 d a b c (Int32.add data.(8) 0x8771f681l) 11 in
- let c = step3 c d a b (Int32.add data.(11) 0x6d9d6122l) 16 in
- let b = step3 b c d a (Int32.add data.(14) 0xfde5380cl) 23 in
- let a = step3 a b c d (Int32.add data.(1) 0xa4beea44l) 4 in
- let d = step3 d a b c (Int32.add data.(4) 0x4bdecfa9l) 11 in
- let c = step3 c d a b (Int32.add data.(7) 0xf6bb4b60l) 16 in
- let b = step3 b c d a (Int32.add data.(10) 0xbebfbc70l) 23 in
- let a = step3 a b c d (Int32.add data.(13) 0x289b7ec6l) 4 in
- let d = step3 d a b c (Int32.add data.(0) 0xeaa127fal) 11 in
- let c = step3 c d a b (Int32.add data.(3) 0xd4ef3085l) 16 in
- let b = step3 b c d a (Int32.add data.(6) 0x04881d05l) 23 in
- let a = step3 a b c d (Int32.add data.(9) 0xd9d4d039l) 4 in
- let d = step3 d a b c (Int32.add data.(12) 0xe6db99e5l) 11 in
- let c = step3 c d a b (Int32.add data.(15) 0x1fa27cf8l) 16 in
- let b = step3 b c d a (Int32.add data.(2) 0xc4ac5665l) 23 in
-
- let a = step4 a b c d (Int32.add data.(0) 0xf4292244l) 6 in
- let d = step4 d a b c (Int32.add data.(7) 0x432aff97l) 10 in
- let c = step4 c d a b (Int32.add data.(14) 0xab9423a7l) 15 in
- let b = step4 b c d a (Int32.add data.(5) 0xfc93a039l) 21 in
- let a = step4 a b c d (Int32.add data.(12) 0x655b59c3l) 6 in
- let d = step4 d a b c (Int32.add data.(3) 0x8f0ccc92l) 10 in
- let c = step4 c d a b (Int32.add data.(10) 0xffeff47dl) 15 in
- let b = step4 b c d a (Int32.add data.(1) 0x85845dd1l) 21 in
- let a = step4 a b c d (Int32.add data.(8) 0x6fa87e4fl) 6 in
- let d = step4 d a b c (Int32.add data.(15) 0xfe2ce6e0l) 10 in
- let c = step4 c d a b (Int32.add data.(6) 0xa3014314l) 15 in
- let b = step4 b c d a (Int32.add data.(13) 0x4e0811a1l) 21 in
- let a = step4 a b c d (Int32.add data.(4) 0xf7537e82l) 6 in
- let d = step4 d a b c (Int32.add data.(11) 0xbd3af235l) 10 in
- let c = step4 c d a b (Int32.add data.(2) 0x2ad7d2bbl) 15 in
- let b = step4 b c d a (Int32.add data.(9) 0xeb86d391l) 21 in
-
- ctx.a <- Int32.add ctx.a a;
- ctx.b <- Int32.add ctx.b b;
- ctx.c <- Int32.add ctx.c c;
- ctx.d <- Int32.add ctx.d d
-
-let string_to_data s =
- let data = Array.make 16 0l in
- for i = 0 to 15 do
- let j = i lsl 2 in
- data.(i) <-
- Int32.logor (Int32.shift_left (Int32.of_int (Char.code s.[j+3])) 24)
- (Int32.logor (Int32.shift_left (Int32.of_int (Char.code s.[j+2])) 16)
- (Int32.logor (Int32.shift_left (Int32.of_int (Char.code s.[j+1])) 8)
- (Int32.of_int (Char.code s.[j]))))
- done;
- data
-
-let int32_to_string n s i =
- s.[i+3] <- Char.chr (Int32.to_int (Int32.shift_right n 24) land 0xFF);
- s.[i+2] <- Char.chr (Int32.to_int (Int32.shift_right n 16) land 0xFF);
- s.[i+1] <- Char.chr (Int32.to_int (Int32.shift_right n 8) land 0xFF);
- s.[i] <- Char.chr (Int32.to_int n land 0xFF)
-
-let init () =
- { buf = String.create 64;
- pos = 0;
- a = 0x67452301l;
- b = 0xefcdab89l;
- c = 0x98badcfel;
- d = 0x10325476l;
- bits = 0L }
-
-let update ctx input ofs len =
- let rec upd ofs len =
- if len <= 0 then () else
- if ctx.pos + len < 64 then begin
- (* Just buffer the data *)
- String.blit input ofs ctx.buf ctx.pos len;
- ctx.pos <- ctx.pos + len
- end else begin
- (* Fill the buffer *)
- let len' = 64 - ctx.pos in
- if len' > 0 then String.blit input ofs ctx.buf ctx.pos len';
- (* Transform 64 bytes *)
- transform ctx (string_to_data ctx.buf);
- ctx.pos <- 0;
- upd (ofs + len') (len - len')
- end in
- upd ofs len;
- ctx.bits <- Int64.add ctx.bits (Int64.of_int (len lsl 3))
-
-
-let finish ctx =
- let padding = String.make 64 '\000' in
- padding.[0] <- '\x80';
- let numbits = ctx.bits in
- if ctx.pos < 56 then begin
- update ctx padding 0 (56 - ctx.pos)
- end else begin
- update ctx padding 0 (64 + 56 - ctx.pos)
- end;
- assert (ctx.pos = 56);
- let data = string_to_data ctx.buf in
- data.(14) <- (Int64.to_int32 numbits);
- data.(15) <- (Int64.to_int32 (Int64.shift_right_logical numbits 32));
- transform ctx data;
- let res = String.create 16 in
- int32_to_string ctx.a res 0;
- int32_to_string ctx.b res 4;
- int32_to_string ctx.c res 8;
- int32_to_string ctx.d res 12;
- res
-
-let test s =
- let ctx = init() in
- update ctx s 0 (String.length s);
- let res = finish ctx in
- let exp = Digest.string s in
- let ok = (res = exp) in
- if not ok then Printf.printf "Failure for '%s'\n" s;
- ok
-
-let time msg iter fn =
- let start = Sys.time() in
- for i = 1 to iter do fn () done;
- let stop = Sys.time() in
- printf "%s: %.2f s\n" msg (stop -. start)
-
-let _ =
- (* Test *)
- if test ""
- && test "a"
- && test "abc"
- && test "message digest"
- && test "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
- then printf "Test vectors passed.\n";
- flush stdout;
- (* Benchmark *)
- let s = String.make 50000 'a' in
- let num_iter = 1000 in
- time "Caml implementation" num_iter
- (fun () ->
- let ctx = init() in
- update ctx s 0 (String.length s);
- ignore (finish ctx));
- time "C implementation" num_iter
- (fun () -> ignore (Digest.string s))
diff --git a/test/Moretest/morematch.ml b/test/Moretest/morematch.ml
deleted file mode 100644
index b8f00b81f1..0000000000
--- a/test/Moretest/morematch.ml
+++ /dev/null
@@ -1,1107 +0,0 @@
-(**************************************************************)
-(* This suite tests the pattern-matching compiler *)
-(* it should just compile and run. *)
-(* While compiling the following messages are normal: *)
-(**************************************************************)
-
-(*
-File "morematch.ml", line 38, characters 10-93:
-Warning: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-0
-File "morematch.ml", line 376, characters 2-15:
-Warning: this match case is unused.
-File "morematch.ml", line 443, characters 2-7:
-Warning: this match case is unused.
-*)
-
-let test msg f arg r =
- if f arg <> r then begin
- prerr_endline msg ;
- failwith "Malaise"
- end
-;;
-
-type t = A | B | C | D | E | F
- ;;
-
-let f x = match x with
-| A | B | C -> 1
-| D | E -> 2
-| F -> 3;;
-
-test "un" f C 1 ;
-test "un" f D 2 ;
-test "un" f F 3 ; ()
-;;
-
-let g x = match x with
- 1 -> 1
-| 2 -> 2
-| 3 -> 3
-| 4 | 5 -> 4
-| 6 -> 5
-| 7 | 8 -> 6
-| 9 -> 7
-;;
-
-test "deux" g 5 4 ;
-test "deux" g 6 5 ;
-test "deux" g 9 7 ; ()
-;;
-
-
-let g x = match x with
- 1 -> 1
-| 2 -> 2
-| 3 -> 3
-| 4 | 5 -> 4
-| 6 -> 5
-| 7 | 8 -> 6
-| 9 -> 7
-| _ -> 8;;
-
-test "trois" g 10 8
-;;
-
-let g x= match x with
- 1 -> 1
-| 2 -> 2
-| 3 -> 3
-| 4 | 5 -> 4
-| 6 -> 5
-| 4|5|7 -> 100
-| 7 | 8 -> 6
-| 9 -> 7
-| _ -> 8;;
-test "quatre" g 4 4 ;
-test "quatre" g 7 100 ; ()
-;;
-
-
-let h x =
- match x with
- (1,1) -> 1
-| (2|3), 1 -> 2
-| 2,(2|3) -> 3
-| (4,4) -> 5
-| _ -> 100
-;;
-
-test "cinq" h (2,2) 3 ;
-test "cinq" h (2,1) 2 ;
-test "cinq" h (2,4) 100 ; ()
-;;
-
-(* idem hh (2,5) *)
-
-let hh x = match x with
-| 1,1 -> 1
-| 2,1 -> 2
-| (2|3),(1|2|3|4) -> 3
-| 2,5 -> 4
-| (4,4) -> 5
-| _ -> 100
-;;
-
-let hhh x = match x with
-| 1,1 -> 1
-| (2|3),1 -> 2
-| 2,2 -> 3
-| _ -> 100
-;;
-
-let h x =
- match x with
- (1,1) -> 1
-| 3,1 -> 2
-| 2,(2|3) -> 3
-| (4,4) -> 5
-| _ -> 100
-;;
-
-let h x = match x with
- 1 -> 1
-| 2|3 -> 2
-| 4 -> 4
-| 5 -> 5
-| 6|7 -> 6
-| 8 -> 8
-| _ -> 100
-;;
-let f x = match x with
-| ((1|2),(3|4))|((3|4),(1|2)) -> 1
-| (3,(5|6)) -> 2
-| _ -> 3
-;;
-
-test "six" f (1,3) 1 ;
-test "six" f (3,2) 1 ;
-test "six" f (3,5) 2 ;
-test "six" f (3,7) 3 ; ()
-;;
-
-type tt = {a : bool list ; b : bool}
-
-let f = function
- | {a=([]|[true])} -> 1
- | {a=false::_}|{b=(true|false)} -> 2
-;;
-
-test "sept" f {a=[] ; b = true} 1 ;
-test "sept" f {a=[true] ; b = false} 1 ;
-test "sept" f {a=[false ; true] ; b = true} 2 ;
-test "sept" f {a=[false] ; b = false} 2 ; ()
-;;
-
-let f = function
- | (([]|[true]),_) -> 1
- | (false::_,_)|(_,(true|false)) -> 2
-;;
-
-test "huit" f ([],true) 1 ;
-test "huit" f ([true],false) 1 ;
-test "huit" f ([false ; true], true) 2 ;
-test "huit" f ([false], false) 2 ; ()
-;;
-
-
-let split_cases = function
- | `Nil | `Cons _ as x -> `A x
- | `Snoc _ as x -> `B x
-;;
-
-test "oubli" split_cases `Nil (`A `Nil);
-test "oubli" split_cases (`Cons 1) (`A (`Cons 1));
-test "oubli" split_cases (`Snoc 1) (`B (`Snoc 1)) ; ()
-;;
-
-type t1 = A of int | B of int
-let f1 = function
- | (A x | B x) -> x
-;;
-
-test "neuf" f1 (A 1) 1 ;
-test "neuf" f1 (B 1) 1 ;
-;;
-
-type coucou = A of int | B of int * int | C
-;;
-
-
-let g = function
- | (A x | B (_,x)) -> x
- | C -> 0
-;;
-
-
-test "dix" g (A 1) 1 ;
-test "dix" g (B (1,2)) 2 ;
-;;
-
-
-
-let h = function
- | ([x]|[1 ; x ]|[1 ; 2 ; x]) -> x
- | _ -> 0
-;;
-
-test "encore" h [1] 1 ;
-test "encore" h [1;2] 2 ;
-test "encore" h [1;2;3] 3 ;
-test "encore" h [0 ; 0] 0 ; ()
-;;
-
-let f = function
-| (x,(0 as y)) | (y,x) -> y-x
-;;
-
-test "foo1" f (1,0) (-1);
-test "foo1" f (1,2) (-1)
-;;
-
-
-let f = function (([]|[_]) as x)|(_::([] as x))|(_::_::x) -> x
-;;
-
-test "zob" f [] [] ;
-test "zob" f [1] [1] ;
-test "zob" f [1;2;3] [3]
-;;
-
-
-type zob = A | B | C | D of zob * int | E of zob * zob
-
-let rec f = function
- | (A | B | C) -> A
- | D (x,i) -> D (f x,i)
- | E (x,_) -> D (f x,0)
-;;
-
-
-test "fin" f B A ;
-test "fin" f (D (C,1)) (D (A,1)) ;
-test "fin" f (E (C,A)) (D (A,0)) ; ()
-;;
-
-type length =
- Char of int | Pixel of int | Percent of int | No of string | Default
-
-let length = function
- | Char n -> n | Pixel n -> n
- | _ -> 0
-;;
-
-test "length" length (Char 10) 10 ;
-test "length" length (Pixel 20) 20 ;
-test "length" length Default 0 ;
-test "length" length (Percent 100) 0 ; ()
-;;
-
-let length2 = function
- | Char n -> n | Percent n -> n
- | _ -> 0
-;;
-
-test "length2" length2 (Char 10) 10 ;
-test "length2" length2 (Pixel 20) 0 ;
-test "length2" length2 Default 0 ;
-test "length2" length2(Percent 100) 100 ; ()
-;;
-
-let length3 = function
- | Char _ | No _ -> true
- | _ -> false
-;;
-
-test "length3" length3 (Char 10) true ;
-test "length3" length3 (No "") true ;
-test "length3" length3 (Pixel 20) false ;
-test "length3" length3 Default false ;
-test "length3" length3(Percent 100) false ; ()
-;;
-
-type hevea = A | B | C
-
-let h x = match x with
-| A -> 1
-| B|C -> 2
-;;
-
-test "hevea" h A 1 ;
-test "hevea" h B 2 ;
-test "hevea" h B 2 ; ()
-;;
-type lambda =
- Lvar of int
- | Lconst of int
- | Lapply of lambda * lambda list
- | Lfunction of bool * int list * lambda
- | Llet of bool * int * lambda * lambda
- | Lletrec of (int * lambda) list * lambda
- | Lprim of string * lambda list
- | Lswitch of lambda * lambda_switch
- | Lstaticfail
- | Lcatch of lambda * lambda
- | Lstaticraise of int * lambda list
- | Lstaticcatch of lambda * (int * int list) * lambda
- | Ltrywith of lambda * int * lambda
- | Lifthenelse of lambda * lambda * lambda
- | Lsequence of lambda * lambda
- | Lwhile of lambda * lambda
- | Lfor of int * lambda * lambda * bool * lambda
- | Lassign of int * lambda
- | Lsend of lambda * lambda * lambda list
- | Levent of lambda * lambda_event
- | Lifused of int * lambda
-and lambda_switch =
- { sw_numconsts: int; (* Number of integer cases *)
- sw_consts: (int * lambda) list; (* Integer cases *)
- sw_numblocks: int; (* Number of tag block cases *)
- sw_blocks: (int * lambda) list; (* Tag block cases *)
- sw_checked: bool ; (* True if bound checks needed *)
- sw_nofail: bool} (* True if should not fail *)
-and lambda_event =
- { lev_loc: int;
- lev_kind: bool ;
- lev_repr: int ref option;
- lev_env: int list }
-
-let rec approx_present v l = true
-
-let rec lower_bind v arg lam = match lam with
-| Lifthenelse (cond, ifso, ifnot) -> 1
-| Lswitch (ls,({sw_consts=[i,act] ; sw_blocks = []} as sw))
- when not (approx_present v ls) -> 2
-| Lswitch (ls,({sw_consts=[] ; sw_blocks = [i,act]} as sw))
- when not (approx_present v ls) -> 3
-| Llet (true , vv, lv, l) -> 4
-| _ -> 5
-;;
-
-test "lower_bind" (lower_bind 0 0) (Llet (true,0, Lvar 1, Lvar 2)) 4 ;
-test "lower_bind" (lower_bind 0 0) (Lvar 0) 5 ;
-test "lower_bind" (lower_bind 0 0) (Lifthenelse (Lvar 0, Lvar 1, Lvar 2)) 1
-;;
-
-
-type field_kind =
- Fvar of field_kind option ref
- | Fpresent
- | Fabsent
-
-let unify_kind (k1, k2) = match k1, k2 with
- (Fvar r, (Fvar _ | Fpresent)) -> 1
- | (Fpresent, Fvar r) -> 2
- | (Fpresent, Fpresent) -> 3
- | _ -> 4
-
-
-let r = ref (Some Fpresent)
-;;
-
-test "unify" unify_kind (Fvar r, Fpresent) 1 ;
-test "unify" unify_kind (Fvar r, Fvar r) 1 ;
-test "unify" unify_kind (Fvar r, Fabsent) 4 ;
-test "unify" unify_kind (Fpresent, Fvar r) 2 ;
-test "unify" unify_kind (Fpresent, Fpresent) 3 ;
-test "unify" unify_kind (Fabsent, Fpresent) 4 ; ()
-;;
-
-
-type youyou = A | B | C | D of youyou
-
-let foo (k1, k2) = match k1,k2 with
-| D _, (A|D _) -> 1
-| (A|B),D _ -> 2
-| C,_ -> 3
-| _, (A|B|C) -> 4
-;;
-
-test "foo2" foo (D A,A) 1 ;
-test "foo2" foo (D A,B) 4 ;
-test "foo2" foo (A,A) 4 ; ()
-;;
-
-type yaya = A | B
-;;
-
-let yaya = function
-| A,_,_ -> 1
-| _,A,_ -> 2
-| B,B,_ -> 3
-| A,_,(100|103) -> 5
-;;
-
-test "yaya" yaya (A,A,0) 1 ;
-test "yaya" yaya (B,A,0) 2 ;
-test "yaya" yaya (B,B,100) 3 ; ()
-;;
-
-(*
-let yoyo = function
-| [],_,_ -> 1
-| _,[],_ -> 2
-| _::_,_::_,_ -> 3
-| [],_,(100|103|104) -> 5
-| [],_,(100|103) -> 6
-| [],_,(1000|1001|1002|20000) -> 7
-;;
-
-test "yoyo" yoyo ([],[],0) 1 ;
-test "yoyo" yoyo ([1],[],0) 2 ;
-test "yoyo" yoyo ([1],[1],100) 3 ; ()
-;;
-
-let youyou = function
- | (100|103|104) -> 1
- | (100|103|101) -> 2
- | (1000|1001|1002|20000) -> 3
- | _ -> -1
-;;
-
-test "youyou" youyou 100 1 ;
-test "youyou" youyou 101 2 ;
-test "youyou" youyou 1000 3
-;;
-*)
-type autre =
- | C | D | E of autre | F of autre * autre | H of autre | I | J | K of string
-
-let rec autre = function
-| C,_,_ -> 1
-| _,C,_ -> 2
-| D,D,_ -> 3
-| (D|F (_,_)|H _|K _),_,_ -> 4
-| (_, (D|I|E _|F (_, _)|H _|K _), _) -> 8
-| (J,J,((C|D) as x |E x|F (_,x))) | (J,_,((C|J) as x)) -> autre (x,x,x)
-| (J, J, (I|H _|K _)) -> 9
-| I,_,_ -> 6
-| E _,_,_ -> 7
-;;
-
-test "autre" autre (J,J,F (D,D)) 3 ;
-test "autre" autre (J,J,D) 3 ;
-test "autre" autre (J,J,I) 9 ;
-test "autre" autre (H I,I,I) 4 ;
-test "autre" autre (J,J,H I) 9 ; ()
-;;
-
-
-type youpi = YA | YB | YC
-and hola = X | Y | Z | T of hola | U of hola | V of hola
-
-let xyz = function
-| YA,_,_ -> 1
-| _,YA,_ -> 2
-| YB,YB,_ -> 3
-| ((YB|YC), (YB|YC), (X|Y|Z|V _|T _)) -> 6
-| _,_,(X|U _) -> 8
-| _,_,Y -> 5
-;;
-
-test "xyz" xyz (YC,YC,X) 6 ;
-test "xyz" xyz (YC,YB,U X) 8 ;
-test "xyz" xyz (YB,YC,X) 6 ; ()
-;;
-
-
-(* Ce test est pour le compilo lui-meme *)
-let eq (x,y) = x=y
-;;
-
-test "eq" eq ("coucou", "coucou") true ; ()
-;;
-
-(* Test des gardes, non trivial *)
-
-let is_none = function
- | None -> true
- | _ -> false
-
-let garde x = match x with
-| (Some _, _) when is_none (snd x) -> 1
-| (Some (pc, _), Some pc') when pc = pc' -> 2
-| _ -> 3
-;;
-
-test "garde" garde (Some (1,1),None) 1 ;
-test "garde" garde (Some (1,1),Some 1) 2 ;
-test "garde" garde (Some (2,1),Some 1) 3 ; ()
-;;
-
-let orstring = function
- | ("A"|"B"|"C") -> 2
- | "D" -> 3
- | _ -> 4
-;;
-
-test "orstring" orstring "A" 2 ;
-test "orstring" orstring "B" 2 ;
-test "orstring" orstring "C" 2 ;
-test "orstring" orstring "D" 3 ;
-test "orstring" orstring "E" 4 ; ()
-;;
-
-type var_t = [`Variant of [ `Some of string | `None | `Foo] ]
-
-let crash (pat:var_t) =
- match pat with
- | `Variant (`Some tag) -> tag
- | `Variant (`None) -> "none"
- | _ -> "foo"
-
-;;
-
-test "crash" crash (`Variant `None) "none" ;
-test "crash" crash (`Variant (`Some "coucou")) "coucou" ;
-test "crash" crash (`Variant (`Foo)) "foo" ; ()
-;;
-
-let flatgarde c =
-let x,y = c in
-match x,y with
-| (1,2)|(2,3) when y=2 -> 1
-| (1,_)|(_,3) -> 2
-| _ -> 3
-;;
-
-test "flatgarde" flatgarde (1,2) 1 ;
-test "flatgarde" flatgarde (1,3) 2 ;
-test "flatgarde" flatgarde (2,3) 2 ;
-test "flatgarde" flatgarde (2,4) 3 ; ()
-;;
-
-
-(* Les bugs de jerome *)
-type f =
- | ABSENT
- | FILE
- | SYMLINK
- | DIRECTORY
-
-type r =
- | Unchanged
- | Deleted
- | Modified
- | PropsChanged
- | Created
-
-let replicaContent2shortString rc =
- let (typ, status) = rc in
- match typ, status with
- _, Unchanged -> " "
- | ABSENT, Deleted -> "deleted "
- | FILE, Created -> "new file"
- | FILE, Modified -> "changed "
- | FILE, PropsChanged -> "props "
- | SYMLINK, Created -> "new link"
- | SYMLINK, Modified -> "chgd lnk"
- | DIRECTORY, Created -> "new dir "
- | DIRECTORY, Modified -> "chgd dir"
- | DIRECTORY, PropsChanged -> "props "
- (* Cases that can't happen... *)
-
- | ABSENT, (Created | Modified | PropsChanged)
- | SYMLINK, PropsChanged
- | (FILE|SYMLINK|DIRECTORY), Deleted
- -> "assert false"
-;;
-
-
-test "jerome_constr"
- replicaContent2shortString (ABSENT, Unchanged) " " ;
-test "jerome_constr"
- replicaContent2shortString (ABSENT, Deleted) "deleted " ;
-test "jerome_constr"
- replicaContent2shortString (FILE, Modified) "changed " ;
-test "jerome_constr"
- replicaContent2shortString (DIRECTORY, PropsChanged) "props " ;
-test "jerome_constr"
- replicaContent2shortString (FILE, Deleted) "assert false" ;
-test "jerome_constr"
- replicaContent2shortString (SYMLINK, Deleted) "assert false" ;
-test "jerome_constr"
- replicaContent2shortString (SYMLINK, PropsChanged) "assert false" ;
-test "jerome_constr"
- replicaContent2shortString (DIRECTORY, Deleted) "assert false" ;
-test "jerome_constr"
- replicaContent2shortString (ABSENT, Created) "assert false" ;
-test "jerome_constr"
- replicaContent2shortString (ABSENT, Modified) "assert false" ;
-test "jerome_constr"
- replicaContent2shortString (ABSENT, PropsChanged) "assert false" ;
-;;
-
-
-let replicaContent2shortString rc =
- let (typ, status) = rc in
- match typ, status with
- _, `Unchanged -> " "
- | `ABSENT, `Deleted -> "deleted "
- | `FILE, `Created -> "new file"
- | `FILE, `Modified -> "changed "
- | `FILE, `PropsChanged -> "props "
- | `SYMLINK, `Created -> "new link"
- | `SYMLINK, `Modified -> "chgd lnk"
- | `DIRECTORY, `Created -> "new dir "
- | `DIRECTORY, `Modified -> "chgd dir"
- | `DIRECTORY, `PropsChanged -> "props "
- (* Cases that can't happen... *)
-
- | `ABSENT, (`Created | `Modified | `PropsChanged)
- | `SYMLINK, `PropsChanged
- | (`FILE|`SYMLINK|`DIRECTORY), `Deleted
- -> "assert false"
-;;
-
-
-test "jerome_constr"
- replicaContent2shortString (`ABSENT, `Unchanged) " " ;
-test "jerome_constr"
- replicaContent2shortString (`ABSENT, `Deleted) "deleted " ;
-test "jerome_constr"
- replicaContent2shortString (`FILE, `Modified) "changed " ;
-test "jerome_constr"
- replicaContent2shortString (`DIRECTORY, `PropsChanged) "props " ;
-test "jerome_constr"
- replicaContent2shortString (`FILE, `Deleted) "assert false" ;
-test "jerome_constr"
- replicaContent2shortString (`SYMLINK, `Deleted) "assert false" ;
-test "jerome_constr"
- replicaContent2shortString (`SYMLINK, `PropsChanged) "assert false" ;
-test "jerome_constr"
- replicaContent2shortString (`DIRECTORY, `Deleted) "assert false" ;
-test "jerome_constr"
- replicaContent2shortString (`ABSENT, `Created) "assert false" ;
-test "jerome_constr"
- replicaContent2shortString (`ABSENT, `Modified) "assert false" ;
-test "jerome_constr"
- replicaContent2shortString (`ABSENT, `PropsChanged) "assert false" ;
-;;
-
-(* bug 319 *)
-
-type ab = A of int | B of int
-type cd = C | D
-
-let ohl = function
- | (A (p) | B (p)), C -> p
- | (A (p) | B (p)), D -> p
-;;
-
-test "ohl" ohl (A 0,C) 0 ;
-test "ohl" ohl (B 0,D) 0 ; ()
-;;
-
-(* bug 324 *)
-type pottier =
- | A
- | B
-;;
-
-let pottier x =
- match x with
- | (( (A, 1) | (B, 2)),A) -> false
- | _ -> true
-;;
-
-test "pottier" pottier ((B,2),A) false ;
-test "pottier" pottier ((B,2),B) true ;
-test "pottier" pottier ((A,2),A) true ; ()
-;;
-
-(* bug 325 in bytecode compiler *)
-let coquery q = match q with
-| y,0,([modu;defs]| [defs;modu;_]) -> y+defs-modu
-| _ -> 0
-;;
-
-test "coquery" coquery (1,0,[1 ; 2 ; 3]) 0 ;
-test "coquery" coquery (1,0,[1 ; 2]) 2 ; ()
-;;
-
-(*
- Two other variable in or-pat tests
-*)
-type vars = A of int | B of (int * int) | C
-;;
-
-
-let vars1 = function
- | (A x | B (_,x)) -> x
- | C -> 0
-;;
-
-test "vars1" vars1 (A 1) 1 ;
-test "vars1" vars1 (B (1,2)) 2 ; ()
-;;
-
-let vars2 = function
- | ([x]|[1 ; x ]|[1 ; 2 ; x]) -> x
- | _ -> 0
-;;
-
-test"vars2" vars2 [1] 1 ;
-test"vars2" vars2 [1;2] 2 ;
-test"vars2" vars2 [1;2;3] 3 ;
-test"vars2" vars2 [0 ; 0] 0 ; ()
-;;
-
-(* Bug 342 *)
-type eber = {x:int; y: int; z:bool}
-
-let eber = function
- | {x=a; z=true}
- | {y=a; z=false} -> a
-;;
-
-test "eber" eber {x=0 ; y=1 ; z=true} 0 ;
-test "eber" eber {x=1 ; y=0 ; z=false} 0 ; ()
-;;
-
-
-(* Enchainement des test d'intervalle *)
-
-let escaped = function
- | '"' | '\\' | '\n' | '\t' -> 2
- | c -> 1
-;;
-
-test "escaped" escaped '"' 2 ;
-test "escaped" escaped '\\' 2 ;
-test "escaped" escaped '\n' 2 ;
-test "escaped" escaped '\t' 2 ;
-test "escaped" escaped '\000' 1 ;
-test "escaped" escaped ' ' 1 ;
-test "escaped" escaped '\000' 1 ;
-test "escaped" escaped '[' 1 ;
-test "escaped" escaped ']' 1 ;
-test "escaped" escaped '!' 1 ;
-test "escaped" escaped '#' 1 ;
-()
-;;
-
-(* For compilation speed (due to J. Garigue) *)
-exception Unknown_Reply of int
-
-type command_reply =
- RPL_TRYAGAIN
- | RPL_TRACEEND
- | RPL_TRACELOG
- | RPL_ADMINEMAIL
- | RPL_ADMINLOC2
- | RPL_ADMINLOC1
- | RPL_ADMINME
- | RPL_LUSERME
- | RPL_LUSERCHANNELS
- | RPL_LUSERUNKNOWN
- | RPL_LUSEROP
- | RPL_LUSERCLIENT
- | RPL_STATSDLINE
- | RPL_STATSDEBUG
- | RPL_STATSDEFINE
- | RPL_STATSBLINE
- | RPL_STATSPING
- | RPL_STATSSLINE
- | RPL_STATSHLINE
- | RPL_STATSOLINE
- | RPL_STATSUPTIME
- | RPL_STATSLLINE
- | RPL_STATSVLINE
- | RPL_SERVLISTEND
- | RPL_SERVLIST
- | RPL_SERVICE
- | RPL_ENDOFSERVICES
- | RPL_SERVICEINFO
- | RPL_UMODEIS
- | RPL_ENDOFSTATS
- | RPL_STATSYLINE
- | RPL_STATSQLINE
- | RPL_STATSKLINE
- | RPL_STATSILINE
- | RPL_STATSNLINE
- | RPL_STATSCLINE
- | RPL_STATSCOMMANDS
- | RPL_STATSLINKINFO
- | RPL_TRACERECONNECT
- | RPL_TRACECLASS
- | RPL_TRACENEWTYPE
- | RPL_TRACESERVICE
- | RPL_TRACESERVER
- | RPL_TRACEUSER
- | RPL_TRACEOPERATOR
- | RPL_TRACEUNKNOWN
- | RPL_TRACEHANDSHAKE
- | RPL_TRACECONNECTING
- | RPL_TRACELINK
- | RPL_NOUSERS
- | RPL_ENDOFUSERS
- | RPL_USERS
- | RPL_USERSSTART
- | RPL_TIME
- | RPL_NOTOPERANYMORE
- | RPL_MYPORTIS
- | RPL_YOURESERVICE
- | RPL_REHASHING
- | RPL_YOUREOPER
- | RPL_ENDOFMOTD
- | RPL_MOTDSTART
- | RPL_ENDOFINFO
- | RPL_INFOSTART
- | RPL_MOTD
- | RPL_INFO
- | RPL_ENDOFBANLIST
- | RPL_BANLIST
- | RPL_ENDOFLINKS
- | RPL_LINKS
- | RPL_CLOSEEND
- | RPL_CLOSING
- | RPL_KILLDONE
- | RPL_ENDOFNAMES
- | RPL_NAMREPLY
- | RPL_ENDOFWHO
- | RPL_WHOREPLY
- | RPL_VERSION
- | RPL_SUMMONING
- | RPL_INVITING
- | RPL_TOPIC
- | RPL_NOTOPIC
- | RPL_CHANNELMODEIS
- | RPL_LISTEND
- | RPL_LIST
- | RPL_LISTSTART
- | RPL_WHOISCHANNELS
- | RPL_ENDOFWHOIS
- | RPL_WHOISIDLE
- | RPL_WHOISCHANOP
- | RPL_ENDOFWHOWAS
- | RPL_WHOWASUSER
- | RPL_WHOISOPERATOR
- | RPL_WHOISSERVER
- | RPL_WHOISUSER
- | RPL_NOWAWAY
- | RPL_UNAWAY
- | RPL_TEXT
- | RPL_ISON
- | RPL_USERHOST
- | RPL_AWAY
- | RPL_NONE
-
-let get_command_reply n =
-match n with
- 263 -> RPL_TRYAGAIN
- | 319 -> RPL_WHOISCHANNELS
- | 318 -> RPL_ENDOFWHOIS
- | 317 -> RPL_WHOISIDLE
- | 316 -> RPL_WHOISCHANOP
- | 369 -> RPL_ENDOFWHOWAS
- | 314 -> RPL_WHOWASUSER
- | 313 -> RPL_WHOISOPERATOR
- | 312 -> RPL_WHOISSERVER
- | 311 -> RPL_WHOISUSER
- | 262 -> RPL_TRACEEND
- | 261 -> RPL_TRACELOG
- | 259 -> RPL_ADMINEMAIL
- | 258 -> RPL_ADMINLOC2
- | 257 -> RPL_ADMINLOC1
- | 256 -> RPL_ADMINME
- | 255 -> RPL_LUSERME
- | 254 -> RPL_LUSERCHANNELS
- | 253 -> RPL_LUSERUNKNOWN
- | 252 -> RPL_LUSEROP
- | 251 -> RPL_LUSERCLIENT
- | 250 -> RPL_STATSDLINE
- | 249 -> RPL_STATSDEBUG
- | 248 -> RPL_STATSDEFINE
- | 247 -> RPL_STATSBLINE
- | 246 -> RPL_STATSPING
- | 245 -> RPL_STATSSLINE
- | 244 -> RPL_STATSHLINE
- | 243 -> RPL_STATSOLINE
- | 242 -> RPL_STATSUPTIME
- | 241 -> RPL_STATSLLINE
- | 240 -> RPL_STATSVLINE
- | 235 -> RPL_SERVLISTEND
- | 234 -> RPL_SERVLIST
- | 233 -> RPL_SERVICE
- | 232 -> RPL_ENDOFSERVICES
- | 231 -> RPL_SERVICEINFO
- | 221 -> RPL_UMODEIS
- | 219 -> RPL_ENDOFSTATS
- | 218 -> RPL_STATSYLINE
- | 217 -> RPL_STATSQLINE
- | 216 -> RPL_STATSKLINE
- | 215 -> RPL_STATSILINE
- | 214 -> RPL_STATSNLINE
- | 213 -> RPL_STATSCLINE
- | 212 -> RPL_STATSCOMMANDS
- | 211 -> RPL_STATSLINKINFO
- | 210 -> RPL_TRACERECONNECT
- | 209 -> RPL_TRACECLASS
- | 208 -> RPL_TRACENEWTYPE
- | 207 -> RPL_TRACESERVICE
- | 206 -> RPL_TRACESERVER
- | 205 -> RPL_TRACEUSER
- | 204 -> RPL_TRACEOPERATOR
- | 203 -> RPL_TRACEUNKNOWN
- | 202 -> RPL_TRACEHANDSHAKE
- | 201 -> RPL_TRACECONNECTING
- | 200 -> RPL_TRACELINK
- | 395 -> RPL_NOUSERS
- | 394 -> RPL_ENDOFUSERS
- | 393 -> RPL_USERS
- | 392 -> RPL_USERSSTART
- | 391 -> RPL_TIME
- | 385 -> RPL_NOTOPERANYMORE
- | 384 -> RPL_MYPORTIS
- | 383 -> RPL_YOURESERVICE
- | 382 -> RPL_REHASHING
- | 381 -> RPL_YOUREOPER
- | 376 -> RPL_ENDOFMOTD
- | 375 -> RPL_MOTDSTART
- | 374 -> RPL_ENDOFINFO
- | 373 -> RPL_INFOSTART
- | 372 -> RPL_MOTD
- | 371 -> RPL_INFO
- | 368 -> RPL_ENDOFBANLIST
- | 367 -> RPL_BANLIST
- | 365 -> RPL_ENDOFLINKS
- | 364 -> RPL_LINKS
- | 363 -> RPL_CLOSEEND
- | 362 -> RPL_CLOSING
- | 361 -> RPL_KILLDONE
- | 366 -> RPL_ENDOFNAMES
- | 353 -> RPL_NAMREPLY
- | 315 -> RPL_ENDOFWHO
- | 352 -> RPL_WHOREPLY
- | 351 -> RPL_VERSION
- | 342 -> RPL_SUMMONING
- | 341 -> RPL_INVITING
- | 332 -> RPL_TOPIC
- | 331 -> RPL_NOTOPIC
- | 324 -> RPL_CHANNELMODEIS
- | 323 -> RPL_LISTEND
- | 322 -> RPL_LIST
- | 321 -> RPL_LISTSTART
- | 306 -> RPL_NOWAWAY
- | 305 -> RPL_UNAWAY
- | 304 -> RPL_TEXT
- | 303 -> RPL_ISON
- | 302 -> RPL_USERHOST
- | 301 -> RPL_AWAY
- | 300 -> RPL_NONE
- | _ -> raise (Unknown_Reply n)
-
-(* Bug 454 *)
-type habert_a=
- | A of habert_c
- | B of habert_c
-
-and habert_c= {lvar:int; lassoc: habert_c;lnb:int}
-
-
-let habert=function
- | (A {lnb=i}|B {lnb=i}) when i=0 -> 1
- | A {lassoc=({lnb=j});lnb=i} -> 2
- | _ -> 3
-;;
-
-let rec ex0 = {lvar=0 ; lnb=0 ; lassoc=ex1}
-and ex1 = {lvar=1 ; lnb=1 ; lassoc=ex0} in
-
-test "habert" habert (A ex0) 1 ;
-test "habert" habert (B ex0) 1 ;
-test "habert" habert (A ex1) 2 ;
-test "habert" habert (B ex1) 3 ;
-
-(* Problems with interval test in arithmetic mod 2^31, bug #359 *)
-(* From manuel Fahndrich *)
-
-type type_expr = [
- | `TTuple of type_expr list
- | `TConstr of type_expr list
- | `TVar of string
- | `TVariant of string list
- | `TBlock of int
- | `TCopy of type_expr
- ]
-
-and recurs_type_expr = [
- | `TTuple of type_expr list
- | `TConstr of type_expr list
- | `TVariant of string list
- ]
-
-
-let rec maf te =
- match te with
- | `TCopy te -> 1
- | `TVar _ -> 2
- | `TBlock _ -> 2
- | #recurs_type_expr as desc ->
-
- let te =
- (match desc with
- `TTuple tl ->
- 4
- | `TConstr tl ->
- 5
- | `TVariant (row) ->
- 6
- )
- in
-
- te
-;;
-
-let base = `TBlock 0
-;;
-
-test "maf" maf (`TCopy base) 1 ;
-test "maf" maf (`TVar "test") 2 ;
-test "maf" maf (`TBlock 0) 2 ;
-test "maf" maf (`TTuple []) 4 ;
-test "maf" maf (`TConstr []) 5 ;
-test "maf" maf (`TVariant []) 6
-;;
-
-(* PR#1310
- Using ``get_args'' in place or an ad-hoc ``matcher'' function for tuples.
- Has made the compiler [3.05] to fail.
-*)
-type t_seb = Uin | Uout
-;;
-
-let rec seb = function
- | ((i, Uin) | (i, Uout)), Uout -> 1
- | ((j, Uin) | (j, Uout)), Uin -> 2
-;;
-
-test "seb" seb ((0,Uin),Uout) 1 ;
-test "seb" seb ((0,Uout),Uin) 2 ;
-()
-;;
-
-(* Talk with Jacques
- - type 'b is still open ??
- - better case generation, accept intervals of size 1 when ok_inter is
- false (in Switch)
-*)
-
-(*
-File "morematch.ml", line 1060, characters 8-65:
-Warning: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-A `D
-*)
-type ('a, 'b) t_j = A of 'a | B of 'b * 'a | C
-
-let f = function
- | A (`A|`C) -> 0
- | B (`B,`D) -> 1
- | C -> 2
-
-let g x = try f x with Match_failure _ -> 3
-
-let _ =
- test "jacques" g (A `A) 0 ;
- test "jacques" g (A `C) 0 ;
- test "jacques" g (B (`B,`D)) 1 ;
- test "jacaues" g C 2 ;
-(* test "jacques" g (B (`A,`D)) 3 ; (* type incorrect expected behavior ? *)*)
- ()
-
-(*
- Compilation bug, segfault, because of incorrect compilation
- of unused match case .. -> "11"
-*)
-
-type t_l = A | B
-
-let f = function
- | _, _, _, _, _, _, _, _, _, _, _, _, _, B, _, _ -> "0"
- | _, _, _, B, A, _, _, _, _, _, _, _, _, _, _, _ -> "1"
- | _, _, _, B, _, A, _, _, A, _, _, _, _, _, _, _ -> "2"
- | _, _, _, _, _, _, _, _, _, _, B, A, _, A, _, _ -> "3"
- | _, _, _, _, _, _, _, B, _, _, _, _, B, _, A, A -> "4"
- | A, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _ -> "5"
- | _, _, _, _, _, _, _, B, _, B, _, _, _, _, _, _ -> "6"
- | _, B, _, _, _, _, _, _, _, _, _, _, _, _, _, _ -> "7"
- | _, A, A, _, A, _, B, _, _, _, _, _, _, _, _, B -> "8"
- | _, _, _, _, B, _, _, _, _, _, _, _, _, _, B, _ -> "9"
- | _, _, _, _, _, _, _, _, _, _, _, B, _, _, _, _ -> "10"
- | _, _, _, _, _, A, _, _, _, _, B, _, _, _, _, _ -> "11"
- | B, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _ -> "12"
- | _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _ -> "13"
-
-(*
-File "morematch.ml", line 1094, characters 5-51:
-Warning: this match case is unused.
-File "morematch.ml", line 1096, characters 5-51:
-Warning: this match case is unused.
-*)
-let _ =
- test "luc" f (B, A, A, A, A, A, A, A, A, A, A, B, A, A, A, A) "10" ;
- test "luc" f (B, A, A, A, A, A, A, A, A, A, A, A, A, A, A, A) "12" ;
- ()
diff --git a/test/Moretest/multdef.ml b/test/Moretest/multdef.ml
deleted file mode 100644
index ac5f488f7e..0000000000
--- a/test/Moretest/multdef.ml
+++ /dev/null
@@ -1,2 +0,0 @@
-let f x = x + 1
-external g : string -> int = "int_of_string"
diff --git a/test/Moretest/multdef.mli b/test/Moretest/multdef.mli
deleted file mode 100644
index 8d67a548f6..0000000000
--- a/test/Moretest/multdef.mli
+++ /dev/null
@@ -1,3 +0,0 @@
-val f : int -> int
-val f : int -> int
-val g : string -> int
diff --git a/test/Moretest/patmatch.ml b/test/Moretest/patmatch.ml
deleted file mode 100644
index 0077e775a2..0000000000
--- a/test/Moretest/patmatch.ml
+++ /dev/null
@@ -1,78 +0,0 @@
-(* Tests for matchings on integers and characters *)
-
-(* Dense integer switch *)
-
-let f = function 1 -> 1 | 2 -> 2 | 3 -> 3 | 4 -> 4 | 5 -> 5 | 6 -> 6 | _ -> 0
-
-(* Sparse integer switch *)
-
-let g = function 303 -> 1 | 401 -> 2 | _ -> 0
-
-(* Very sparse integer switch *)
-
-let iszero = function 0 -> true | _ -> false
-
-(* Simple matching on characters *)
-
-let h = function
- 'a' -> "a"
- | 'e' -> "e"
- | 'i' -> "i"
- | 'o' -> "o"
- | 'u' -> "u"
- | _ -> "?"
-
-(* Matching with orpats *)
-
-let k = function
- ' ' | '\t' | '\n' | '\r' -> "blk"
- | 'A'..'Z' | 'a'..'z' | '\192'..'\255' -> "letr"
- | '0'..'9' -> "dig"
- | '!'|'%'|'&'|'$'|'#'|'+'|'/'|':'|'<'|'='|'>'|'?'|'@'|'\\'|
- '~'|'^'|'|'|'*' -> "oper"
- | _ -> "othr"
-
-(* Matching on arrays *)
-
-let p = function [| x |] -> x | _ -> assert false
-
-let q = function [| x |] -> x | _ -> 0
-
-let r = function [| x |] -> x | _ -> 0.0
-
-let l = function
- [||] -> 0
- | [|x|] -> x + 1
- | [|x;y|] -> x + y
- | [|x;y;z|] -> x + y + z
-
-(* The test *)
-
-open Printf
-
-let _ =
- for i = -5 to 10 do printf "f(%d) = %d\n" i (f i) done;
- List.iter (fun i -> printf "g(%d) = %d\n" i (g i))
- [0;300;303;305;400;401;402;999];
- for i = -2 to 2 do printf "iszero(%d) = %B\n" i (iszero i) done;
- for i = 97 to 126 do
- let c = Char.chr i in
- printf "h(%c) = %s\n" c (h c)
- done;
- for i = 0 to 255 do
- let c = Char.chr i in
- printf "k(%s) = %s\t" (Char.escaped c) (k c)
- done;
- printf "\n";
- printf "p([|\"hello\"|]) = %s\n" (p [|"hello"|]);
- printf "p([|1.0|]) = %f\n" (p [|1.0|]);
- printf "q([|2|]) = %d\n" (q [|2|]);
- printf "r([|3.0|]) = %f\n" (r [|3.0|]);
- printf "l([||]) = %d\n" (l [||]);
- printf "l([|1|]) = %d\n" (l [|1|]);
- printf "l([|2;3|]) = %d\n" (l [|2;3|]);
- printf "l([|4;5;6|]) = %d\n" (l [|4;5;6|]);
- exit 0
-
-
-
diff --git a/test/Moretest/recvalues.ml b/test/Moretest/recvalues.ml
deleted file mode 100644
index c00ced8273..0000000000
--- a/test/Moretest/recvalues.ml
+++ /dev/null
@@ -1,38 +0,0 @@
-(* Recursive value definitions *)
-
-let _ =
- let rec x = 1 :: x in
- if match x with
- 1 :: x' -> x == x'
- | _ -> false
- then print_string "Test 1: passed\n"
- else print_string "Test 1: FAILED\n";
- let one = 1 in
- let rec y = (one, one+1) :: y in
- if match y with
- (1,2) :: y' -> y == y'
- | _ -> false
- then print_string "Test 2: passed\n"
- else print_string "Test 2: FAILED\n";
- let rec z = (Gc.minor(); (one, one+1)) :: z in
- (* Trash the minor generation *)
- for i = 0 to 50000 do ignore (ref 0) done;
- if match z with
- (1,2) :: z' -> z == z'
- | _ -> false
- then print_string "Test 3: passed\n"
- else print_string "Test 3: FAILED\n";
-;;
-
-let rec s = "bar"
-and idx = 1
-and x1 = let f x = Printf.printf "%s\n" x in f "foo"; s, x4
-and x2 = [| x1; x1 |]
-and x3 = (fun () -> fst (x2.(idx))) :: x3
-and x4 = {contents = x3}
-;;
-
-Gc.minor ();;
-if (List.hd (!(snd (x2.(0))))) () == s
-then print_string "Test 4: passed\n"
-else print_string "Test 4: FAILED\n"
diff --git a/test/Moretest/regexp.ml b/test/Moretest/regexp.ml
deleted file mode 100644
index a932b74c89..0000000000
--- a/test/Moretest/regexp.ml
+++ /dev/null
@@ -1,975 +0,0 @@
-open Printf
-
-let build_result ngroups input =
- let res = Array.make (ngroups + 1) "~" in
- for i = 0 to ngroups do
- try
- res.(i) <- Str.matched_group i input
- with Not_found -> ()
- done;
- res
-
-let search_forward re ng input start =
- try
- ignore(Str.search_forward re input start);
- build_result ng input
- with Not_found ->
- [||]
-
-let search_backward re ng input start =
- try
- ignore(Str.search_backward re input start);
- build_result ng input
- with Not_found ->
- [||]
-
-let partial_match re ng input start =
- if Str.string_partial_match re input start
- then build_result ng input
- else [||]
-
-let start_test msg =
- print_newline(); printf "%s\n " msg
-
-let num_failures = ref 0
-
-let test res1 res2 =
- if res1 = res2
- then print_char '.'
- else begin print_string " FAIL "; incr num_failures end
-
-let test_search_forward r ng s exp =
- test (search_forward r ng s 0) exp
-
-let test_search_backward r ng s exp =
- test (search_backward r ng s (String.length s)) exp
-
-let test_partial_match r ng s exp =
- test (partial_match r ng s 0) exp
-
-let end_test () =
- print_newline();
- if !num_failures = 0 then
- printf "All tests passed\n"
- else begin
- printf "TEST FAILED: %d failure(s)\n" !num_failures;
- exit 2
- end
-
-let automated_test() =
-
- (** Forward searches *)
- start_test "Search for /the quick brown fox/";
- let r = Str.regexp "the quick brown fox" in
- let n = 0 in
- test_search_forward r n "the quick brown fox"
- [|"the quick brown fox"|];
- test_search_forward r n "What do you know about the quick brown fox?"
- [|"the quick brown fox"|];
- test_search_forward r n "The quick brown FOX"
- [||];
- test_search_forward r n "What do you know about THE QUICK BROWN FOX?"
- [||];
-
- start_test "Search for /the quick brown fox/";
- let r = Str.regexp_case_fold "the quick brown fox" in
- let n = 0 in
- test_search_forward r n "the quick brown fox"
- [|"the quick brown fox"|];
- test_search_forward r n "What do you know about the quick brown fox?"
- [|"the quick brown fox"|];
- test_search_forward r n "The quick brown FOX"
- [|"The quick brown FOX"|];
- test_search_forward r n "What do you know about THE QUICK BROWN FOX?"
- [|"THE QUICK BROWN FOX"|];
- test_search_forward r n "The slow white snail"
- [||];
-
- start_test "Search for /a*abc?xyz+pqrrrabbb*xyyyyy?pq?q?q?q?q?q?AB*zz/";
- let r = Str.regexp "a*abc?xyz+pqrrrabbb*xyyyyy?pq?q?q?q?q?q?AB*zz" in
- let n = 0 in
- test_search_forward r n "abxyzpqrrrabbxyyyypqAzz"
- [|"abxyzpqrrrabbxyyyypqAzz"|];
- test_search_forward r n "abxyzpqrrrabbxyyyypqAzz"
- [|"abxyzpqrrrabbxyyyypqAzz"|];
- test_search_forward r n "aabxyzpqrrrabbxyyyypqAzz"
- [|"aabxyzpqrrrabbxyyyypqAzz"|];
- test_search_forward r n "aaabxyzpqrrrabbxyyyypqAzz"
- [|"aaabxyzpqrrrabbxyyyypqAzz"|];
- test_search_forward r n "aaaabxyzpqrrrabbxyyyypqAzz"
- [|"aaaabxyzpqrrrabbxyyyypqAzz"|];
- test_search_forward r n "abcxyzpqrrrabbxyyyypqAzz"
- [|"abcxyzpqrrrabbxyyyypqAzz"|];
- test_search_forward r n "aabcxyzpqrrrabbxyyyypqAzz"
- [|"aabcxyzpqrrrabbxyyyypqAzz"|];
- test_search_forward r n "aaabcxyzpqrrrabbxyyyypAzz"
- [|"aaabcxyzpqrrrabbxyyyypAzz"|];
- test_search_forward r n "aaabcxyzpqrrrabbxyyyypqAzz"
- [|"aaabcxyzpqrrrabbxyyyypqAzz"|];
- test_search_forward r n "aaabcxyzpqrrrabbxyyyypqqAzz"
- [|"aaabcxyzpqrrrabbxyyyypqqAzz"|];
- test_search_forward r n "aaabcxyzpqrrrabbxyyyypqqqAzz"
- [|"aaabcxyzpqrrrabbxyyyypqqqAzz"|];
- test_search_forward r n "aaabcxyzpqrrrabbxyyyypqqqqAzz"
- [|"aaabcxyzpqrrrabbxyyyypqqqqAzz"|];
- test_search_forward r n "aaabcxyzpqrrrabbxyyyypqqqqqAzz"
- [|"aaabcxyzpqrrrabbxyyyypqqqqqAzz"|];
- test_search_forward r n "aaabcxyzpqrrrabbxyyyypqqqqqqAzz"
- [|"aaabcxyzpqrrrabbxyyyypqqqqqqAzz"|];
- test_search_forward r n "aaaabcxyzpqrrrabbxyyyypqAzz"
- [|"aaaabcxyzpqrrrabbxyyyypqAzz"|];
- test_search_forward r n "abxyzzpqrrrabbxyyyypqAzz"
- [|"abxyzzpqrrrabbxyyyypqAzz"|];
- test_search_forward r n "aabxyzzzpqrrrabbxyyyypqAzz"
- [|"aabxyzzzpqrrrabbxyyyypqAzz"|];
- test_search_forward r n "aaabxyzzzzpqrrrabbxyyyypqAzz"
- [|"aaabxyzzzzpqrrrabbxyyyypqAzz"|];
- test_search_forward r n "aaaabxyzzzzpqrrrabbxyyyypqAzz"
- [|"aaaabxyzzzzpqrrrabbxyyyypqAzz"|];
- test_search_forward r n "abcxyzzpqrrrabbxyyyypqAzz"
- [|"abcxyzzpqrrrabbxyyyypqAzz"|];
- test_search_forward r n "aabcxyzzzpqrrrabbxyyyypqAzz"
- [|"aabcxyzzzpqrrrabbxyyyypqAzz"|];
- test_search_forward r n "aaabcxyzzzzpqrrrabbxyyyypqAzz"
- [|"aaabcxyzzzzpqrrrabbxyyyypqAzz"|];
- test_search_forward r n "aaaabcxyzzzzpqrrrabbxyyyypqAzz"
- [|"aaaabcxyzzzzpqrrrabbxyyyypqAzz"|];
- test_search_forward r n "aaaabcxyzzzzpqrrrabbbxyyyypqAzz"
- [|"aaaabcxyzzzzpqrrrabbbxyyyypqAzz"|];
- test_search_forward r n "aaaabcxyzzzzpqrrrabbbxyyyyypqAzz"
- [|"aaaabcxyzzzzpqrrrabbbxyyyyypqAzz"|];
- test_search_forward r n "aaabcxyzpqrrrabbxyyyypABzz"
- [|"aaabcxyzpqrrrabbxyyyypABzz"|];
- test_search_forward r n "aaabcxyzpqrrrabbxyyyypABBzz"
- [|"aaabcxyzpqrrrabbxyyyypABBzz"|];
- test_search_forward r n ">>>aaabxyzpqrrrabbxyyyypqAzz"
- [|"aaabxyzpqrrrabbxyyyypqAzz"|];
- test_search_forward r n ">aaaabxyzpqrrrabbxyyyypqAzz"
- [|"aaaabxyzpqrrrabbxyyyypqAzz"|];
- test_search_forward r n ">>>>abcxyzpqrrrabbxyyyypqAzz"
- [|"abcxyzpqrrrabbxyyyypqAzz"|];
- test_search_forward r n "abxyzpqrrabbxyyyypqAzz"
- [||];
- test_search_forward r n "abxyzpqrrrrabbxyyyypqAzz"
- [||];
- test_search_forward r n "abxyzpqrrrabxyyyypqAzz"
- [||];
- test_search_forward r n "aaaabcxyzzzzpqrrrabbbxyyyyyypqAzz"
- [||];
- test_search_forward r n "aaaabcxyzzzzpqrrrabbbxyyypqAzz"
- [||];
- test_search_forward r n "aaabcxyzpqrrrabbxyyyypqqqqqqqAzz"
- [||];
-
- start_test "Search for /^abc\\(abc\\)?zz/";
- let r = Str.regexp "^abc\\(abc\\)?zz" in
- let n = 1 in
- test_search_forward r n "abczz"
- [|"abczz"; "~"|];
- test_search_forward r n "abcabczz"
- [|"abcabczz"; "abc"|];
- test_search_forward r n "zz"
- [||];
- test_search_forward r n "abcabcabczz"
- [||];
- test_search_forward r n ">>abczz"
- [||];
-
- start_test "Search for /^\\(b+\\|a\\)\\(b+\\|a\\)?c/";
- let r = Str.regexp "^\\(b+\\|a\\)\\(b+\\|a\\)?c" in
- let n = 2 in
- test_search_forward r n "bc"
- [|"bc"; "b"; "~"|];
- test_search_forward r n "bbc"
- [|"bbc"; "bb"; "~"|];
- test_search_forward r n "bbbc"
- [|"bbbc"; "bbb"; "~"|];
- test_search_forward r n "bac"
- [|"bac"; "b"; "a"|];
- test_search_forward r n "bbac"
- [|"bbac"; "bb"; "a"|];
- test_search_forward r n "aac"
- [|"aac"; "a"; "a"|];
- test_search_forward r n "abbbbbbbbbbbc"
- [|"abbbbbbbbbbbc"; "a"; "bbbbbbbbbbb"|];
- test_search_forward r n "bbbbbbbbbbbac"
- [|"bbbbbbbbbbbac"; "bbbbbbbbbbb"; "a"|];
- test_search_forward r n "aaac"
- [||];
- test_search_forward r n "abbbbbbbbbbbac"
- [||];
-
- start_test "Search for /r\\(\\(g*\\|k\\)y?\\)*A/";
- let r = Str.regexp "r\\(\\(g*\\|k\\)y?\\)*A" in
- let n = 2 in
- test_search_forward r n "ArA"
- [|"rA"; "~"; "~"|];
- test_search_forward r n "ArkA"
- [|"rkA"; "k"; "k"|];
- test_search_forward r n "AryA"
- [|"ryA"; "y"; ""|];
- test_search_forward r n "ArgggkyggkA"
- [|"rgggkyggkA"; "k"; "k"|];
-
- start_test "Search for /A\\(\\(t\\|v\\)\\(q?\\|n\\)\\)*A/";
- let r = Str.regexp "A\\(\\(t\\|v\\)\\(q?\\|n\\)\\)*A" in
- let n = 3 in
- test_search_forward r n "AvA"
- [|"AvA"; "v"; "v"; ""|];
-
- start_test "Search for /A\\(\\(b\\(\\(d\\|l*\\)?\\|w\\)\\)*a\\)A/";
- let r = Str.regexp "A\\(\\(b\\(\\(d\\|l*\\)?\\|w\\)\\)*a\\)A" in
- let n = 4 in
- test_search_forward r n "AbbaA"
- [|"AbbaA"; "bba"; "b"; ""; ""|];
-
- start_test "Search for /\\(\\|f\\)*x/";
- let r = Str.regexp "\\(\\|f\\)*x" in
- let n = 1 in
- test_search_forward r n "abcd"
- [||];
- test_search_forward r n "fffff"
- [||];
- test_search_forward r n "fffxab"
- [|"fffx"; "f"|];
- test_search_forward r n "zzzxab"
- [|"x"; "~"|];
-
- start_test "Search for /\\(\\|f\\)+x/";
- let r = Str.regexp "\\(\\|f\\)+x" in
- let n = 1 in
- test_search_forward r n "abcd"
- [||];
- test_search_forward r n "fffff"
- [||];
- test_search_forward r n "fffxab"
- [|"fffx"; "f"|];
- test_search_forward r n "zzzxab"
- [|"x"; ""|];
-
- start_test "Search for /A\\(.?\\)*A/";
- let r = Str.regexp "A\\(.?\\)*A" in
- let n = 1 in
- test_search_forward r n "AA"
- [|"AA"; "~"|];
- test_search_forward r n "AAA"
- [|"AAA"; "A"|];
- test_search_forward r n "AbA"
- [|"AbA"; "b"|];
- test_search_forward r n "A"
- [||];
-
- start_test "Search for /\\([ab]*\\)\\1+c/";
- let r = Str.regexp "\\([ab]*\\)\\1+c" in
- let n = 1 in
- test_search_forward r n "abababc"
- [| "abababc"; "ab" |];
- test_search_forward r n "abbc"
- [| "bbc"; "b" |];
- test_search_forward r n "abc"
- [| "c"; "" |];
-
- start_test "Search for /^\\(\\(b+\\|a\\)\\(b+\\|a\\)?\\)?bc/";
- let r = Str.regexp "^\\(\\(b+\\|a\\)\\(b+\\|a\\)?\\)?bc" in
- let n = 3 in
- test_search_forward r n "bbc"
- [|"bbc"; "b"; "b"; "~"|];
-
- start_test "Search for /^\\(\\(b*\\|ba\\)\\(b*\\|ba\\)?\\)?bc/";
- let r = Str.regexp "^\\(\\(b*\\|ba\\)\\(b*\\|ba\\)?\\)?bc" in
- let n = 3 in
- test_search_forward r n "babc"
- [|"babc"; "ba"; ""; "ba"|];
- test_search_forward r n "bbabc"
- [|"bbabc"; "bba"; "b"; "ba"|];
- test_search_forward r n "bababc"
- [|"bababc"; "baba"; "ba"; "ba"|];
- test_search_forward r n "bababbc"
- [||];
- test_search_forward r n "babababc"
- [||];
-
- start_test "Search for /^[]abcde]/";
- let r = Str.regexp "^[]abcde]" in
- let n = 0 in
- test_search_forward r n "athing"
- [|"a"|];
- test_search_forward r n "bthing"
- [|"b"|];
- test_search_forward r n "]thing"
- [|"]"|];
- test_search_forward r n "cthing"
- [|"c"|];
- test_search_forward r n "dthing"
- [|"d"|];
- test_search_forward r n "ething"
- [|"e"|];
- test_search_forward r n "fthing"
- [||];
- test_search_forward r n "[thing"
- [||];
- test_search_forward r n "\\\\thing"
- [||];
-
- start_test "Search for /^[]cde]/";
- let r = Str.regexp "^[]cde]" in
- let n = 0 in
- test_search_forward r n "]thing"
- [|"]"|];
- test_search_forward r n "cthing"
- [|"c"|];
- test_search_forward r n "dthing"
- [|"d"|];
- test_search_forward r n "ething"
- [|"e"|];
- test_search_forward r n "athing"
- [||];
- test_search_forward r n "fthing"
- [||];
-
- start_test "Search for /^[^]abcde]/";
- let r = Str.regexp "^[^]abcde]" in
- let n = 0 in
- test_search_forward r n "fthing"
- [|"f"|];
- test_search_forward r n "[thing"
- [|"["|];
- test_search_forward r n "\\\\thing"
- [|"\\"|];
- test_search_forward r n "athing"
- [||];
- test_search_forward r n "bthing"
- [||];
- test_search_forward r n "]thing"
- [||];
- test_search_forward r n "cthing"
- [||];
- test_search_forward r n "dthing"
- [||];
- test_search_forward r n "ething"
- [||];
-
- start_test "Search for /^[^]cde]/";
- let r = Str.regexp "^[^]cde]" in
- let n = 0 in
- test_search_forward r n "athing"
- [|"a"|];
- test_search_forward r n "fthing"
- [|"f"|];
- test_search_forward r n "]thing"
- [||];
- test_search_forward r n "cthing"
- [||];
- test_search_forward r n "dthing"
- [||];
- test_search_forward r n "ething"
- [||];
-
- start_test "Search for /^ÿ/";
- let r = Str.regexp "^ÿ" in
- let n = 0 in
- test_search_forward r n "ÿ"
- [|"ÿ"|];
-
- start_test "Search for /^[0-9]+$/";
- let r = Str.regexp "^[0-9]+$" in
- let n = 0 in
- test_search_forward r n "0"
- [|"0"|];
- test_search_forward r n "1"
- [|"1"|];
- test_search_forward r n "2"
- [|"2"|];
- test_search_forward r n "3"
- [|"3"|];
- test_search_forward r n "4"
- [|"4"|];
- test_search_forward r n "5"
- [|"5"|];
- test_search_forward r n "6"
- [|"6"|];
- test_search_forward r n "7"
- [|"7"|];
- test_search_forward r n "8"
- [|"8"|];
- test_search_forward r n "9"
- [|"9"|];
- test_search_forward r n "10"
- [|"10"|];
- test_search_forward r n "100"
- [|"100"|];
- test_search_forward r n "abc"
- [||];
-
- start_test "Search for /^.*nter/";
- let r = Str.regexp "^.*nter" in
- let n = 0 in
- test_search_forward r n "enter"
- [|"enter"|];
- test_search_forward r n "inter"
- [|"inter"|];
- test_search_forward r n "uponter"
- [|"uponter"|];
-
- start_test "Search for /^xxx[0-9]+$/";
- let r = Str.regexp "^xxx[0-9]+$" in
- let n = 0 in
- test_search_forward r n "xxx0"
- [|"xxx0"|];
- test_search_forward r n "xxx1234"
- [|"xxx1234"|];
- test_search_forward r n "xxx"
- [||];
-
- start_test "Search for /^.+[0-9][0-9][0-9]$/";
- let r = Str.regexp "^.+[0-9][0-9][0-9]$" in
- let n = 0 in
- test_search_forward r n "x123"
- [|"x123"|];
- test_search_forward r n "xx123"
- [|"xx123"|];
- test_search_forward r n "123456"
- [|"123456"|];
- test_search_forward r n "123"
- [||];
- test_search_forward r n "x123x"
- [||];
-
- start_test "Search for /^\\([^!]+\\)!\\(.+\\)=apquxz\\.ixr\\.zzz\\.ac\\.uk$/";
- let r = Str.regexp "^\\([^!]+\\)!\\(.+\\)=apquxz\\.ixr\\.zzz\\.ac\\.uk$" in
- let n = 2 in
- test_search_forward r n "abc!pqr=apquxz.ixr.zzz.ac.uk"
- [|"abc!pqr=apquxz.ixr.zzz.ac.uk"; "abc"; "pqr"|];
- test_search_forward r n "!pqr=apquxz.ixr.zzz.ac.uk"
- [||];
- test_search_forward r n "abc!=apquxz.ixr.zzz.ac.uk"
- [||];
- test_search_forward r n "abc!pqr=apquxz:ixr.zzz.ac.uk"
- [||];
- test_search_forward r n "abc!pqr=apquxz.ixr.zzz.ac.ukk"
- [||];
-
- start_test "Search for /\\([0-9a-f:]+\\)$/";
- let r = Str.regexp_case_fold "\\([0-9a-f:]+\\)$" in
- let n = 1 in
- test_search_forward r n "0abc"
- [|"0abc"; "0abc"|];
- test_search_forward r n "abc"
- [|"abc"; "abc"|];
- test_search_forward r n "fed"
- [|"fed"; "fed"|];
- test_search_forward r n "E"
- [|"E"; "E"|];
- test_search_forward r n "::"
- [|"::"; "::"|];
- test_search_forward r n "5f03:12C0::932e"
- [|"5f03:12C0::932e"; "5f03:12C0::932e"|];
- test_search_forward r n "fed def"
- [|"def"; "def"|];
- test_search_forward r n "Any old stuff"
- [|"ff"; "ff"|];
- test_search_forward r n "0zzz"
- [||];
- test_search_forward r n "gzzz"
- [||];
- test_search_forward r n "fed "
- [||];
- test_search_forward r n "Any old rubbish"
- [||];
-
- start_test "Search for /^[a-z0-9][a-z0-9-]*\\(\\.[a-z0-9][A-Z0-9-]*\\)*\\.$/";
- let r = Str.regexp_case_fold "^[a-z0-9][a-z0-9-]*\\(\\.[a-z0-9][A-Z0-9-]*\\)*\\.$" in
- let n = 1 in
- test_search_forward r n "a."
- [|"a."; "~"|];
- test_search_forward r n "Z."
- [|"Z."; "~"|];
- test_search_forward r n "2."
- [|"2."; "~"|];
- test_search_forward r n "ab-c."
- [|"ab-c."; "~"|];
- test_search_forward r n "ab-c.pq-r."
- [|"ab-c.pq-r."; ".pq-r"|];
- test_search_forward r n "sxk.zzz.ac.uk."
- [|"sxk.zzz.ac.uk."; ".uk"|];
- test_search_forward r n "sxk.ZZZ.ac.UK."
- [|"sxk.ZZZ.ac.UK."; ".UK"|];
- test_search_forward r n "x-.y-."
- [|"x-.y-."; ".y-"|];
- test_search_forward r n "-abc.peq."
- [||];
-
- start_test "Search for /^\\*\\.[a-z]\\([a-z0-9-]*[a-z0-9]+\\)?\\(\\.[a-z]\\([a-z0-9-]*[a-z0-9]+\\)?\\)*$/";
- let r = Str.regexp "^\\*\\.[a-z]\\([a-z0-9-]*[a-z0-9]+\\)?\\(\\.[a-z]\\([a-z0-9-]*[a-z0-9]+\\)?\\)*$" in
- let n = 3 in
- test_search_forward r n "*.a"
- [|"*.a"; "~"; "~"; "~"|];
- test_search_forward r n "*.b0-a"
- [|"*.b0-a"; "0-a"; "~"; "~"|];
- test_search_forward r n "*.c3-b.c"
- [|"*.c3-b.c"; "3-b"; ".c"; "~"|];
- test_search_forward r n "*.c-a.b-c"
- [|"*.c-a.b-c"; "-a"; ".b-c"; "-c"|];
- test_search_forward r n "*.0"
- [||];
- test_search_forward r n "*.a-"
- [||];
- test_search_forward r n "*.a-b.c-"
- [||];
- test_search_forward r n "*.c-a.0-c"
- [||];
-
- start_test "Search for /^[0-9a-fA-F]\\(\\.[0-9a-fA-F]\\)*$/";
- let r = Str.regexp "^[0-9a-fA-F]\\(\\.[0-9a-fA-F]\\)*$" in
- let n = 1 in
- test_search_forward r n "a.b.c.d"
- [|"a.b.c.d"; ".d"|];
- test_search_forward r n "A.B.C.D"
- [|"A.B.C.D"; ".D"|];
- test_search_forward r n "a.b.c.1.2.3.C"
- [|"a.b.c.1.2.3.C"; ".C"|];
- test_search_forward r n "a.b.c.dz"
- [||];
- test_search_forward r n "za"
- [||];
-
- start_test "Search for /^\\\".*\\\" *\\(;.*\\)?$/";
- let r = Str.regexp "^\\\".*\\\" *\\(;.*\\)?$" in
- let n = 1 in
- test_search_forward r n "\"1234\""
- [|"\"1234\""; "~"|];
- test_search_forward r n "\"abcd\" ;"
- [|"\"abcd\" ;"; ";"|];
- test_search_forward r n "\"\" ; rhubarb"
- [|"\"\" ; rhubarb"; "; rhubarb"|];
- test_search_forward r n "\"1234\" : things"
- [||];
-
- start_test "Search for /^\\(a\\(b\\(c\\)\\)\\)\\(d\\(e\\(f\\)\\)\\)\\(h\\(i\\(j\\)\\)\\)$/";
- let r = Str.regexp "^\\(a\\(b\\(c\\)\\)\\)\\(d\\(e\\(f\\)\\)\\)\\(h\\(i\\(j\\)\\)\\)$" in
- let n = 9 in
- test_search_forward r n "abcdefhij"
- [|"abcdefhij"; "abc"; "bc"; "c"; "def"; "ef"; "f"; "hij"; "ij"; "j"|];
-
- start_test "Search for /^[.^$|()*+?{,}]+/";
- let r = Str.regexp "^[.^$|()*+?{,}]+" in
- let n = 0 in
- test_search_forward r n ".^$*(+)|{?,?}"
- [|".^$*(+)|{?,?}"|];
-
- start_test "Search for /\\(cat\\(a\\(ract\\|tonic\\)\\|erpillar\\)\\) \\1\\(\\)2\\(3\\)/";
- let r = Str.regexp "\\(cat\\(a\\(ract\\|tonic\\)\\|erpillar\\)\\) \\1\\(\\)2\\(3\\)" in
- let n = 5 in
- test_search_forward r n "cataract cataract23"
- [|"cataract cataract23"; "cataract"; "aract"; "ract"; ""; "3"|];
- test_search_forward r n "catatonic catatonic23"
- [|"catatonic catatonic23"; "catatonic"; "atonic"; "tonic"; ""; "3"|];
- test_search_forward r n "caterpillar caterpillar23"
- [|"caterpillar caterpillar23"; "caterpillar"; "erpillar"; "~"; ""; "3"|];
-
- start_test "Search for /^From +\\([^ ]+\\) +[a-zA-Z][a-zA-Z][a-zA-Z] +[a-zA-Z][a-zA-Z][a-zA-Z] +[0-9]?[0-9] +[0-9][0-9]:[0-9][0-9]/";
- let r = Str.regexp "^From +\\([^ ]+\\) +[a-zA-Z][a-zA-Z][a-zA-Z] +[a-zA-Z][a-zA-Z][a-zA-Z] +[0-9]?[0-9] +[0-9][0-9]:[0-9][0-9]" in
- let n = 1 in
- test_search_forward r n "From abcd Mon Sep 01 12:33:02 1997"
- [|"From abcd Mon Sep 01 12:33"; "abcd"|];
-
- start_test "Search for /\\ba/";
- let r = Str.regexp "\\ba" in
- let n = 0 in
- test_search_forward r n "abcd"
- [|"a"|];
- test_search_forward r n "the a"
- [|"a"|];
- test_search_forward r n ".ab"
- [|"a"|];
- test_search_forward r n "bad"
- [||];
- test_search_forward r n "the ba"
- [||];
- test_search_forward r n "ba."
- [||];
-
- start_test "Search for /a\\b/";
- let r = Str.regexp "a\\b" in
- let n = 0 in
- test_search_forward r n "a"
- [|"a"|];
- test_search_forward r n "bcda"
- [|"a"|];
- test_search_forward r n "a foo"
- [|"a"|];
- test_search_forward r n "a."
- [|"a"|];
- test_search_forward r n "bad"
- [||];
- test_search_forward r n "ab"
- [||];
-
- start_test "Search for /\\([a-z]*\\)b/";
- let r = Str.regexp "\\([a-z]*\\)b" in
- let n = 1 in
- test_search_forward r n "abbb"
- [|"abbb"; "abb"|];
-
- start_test "Search for /\\([a-z]+\\)b/";
- let r = Str.regexp "\\([a-z]+\\)b" in
- let n = 1 in
- test_search_forward r n "abbb"
- [|"abbb"; "abb"|];
-
- start_test "Search for /\\([a-z]?\\)b/";
- let r = Str.regexp "\\([a-z]?\\)b" in
- let n = 1 in
- test_search_forward r n "bbbb"
- [|"bb"; "b"|];
-
- start_test "Search for /^a/";
- let r = Str.regexp "^a" in
- let n = 0 in
- test_search_forward r n "abcdef"
- [|"a"|];
- test_search_forward r n "zzzz\nabcdef"
- [|"a"|];
-
- start_test "Search for /a$/";
- let r = Str.regexp "a$" in
- let n = 0 in
- test_search_forward r n "xyza"
- [|"a"|];
- test_search_forward r n "xyza\nbcdef"
- [|"a"|];
-
- start_test "Null characters in regexps";
- let r = Str.regexp "ab\000cd" in
- let n = 0 in
- test_search_forward r n "qerpoiuab\000cdwerltkh"
- [| "ab\000cd" |];
- let r = Str.regexp "\000cd" in
- let n = 0 in
- test_search_forward r n "qerpoiuab\000cdwerltkh"
- [| "\000cd" |];
-
- (** Backward searches *)
- start_test "Backward search for /the quick/";
- let r = Str.regexp "the quick" in
- let n = 0 in
- test_search_backward r n "the quick brown fox"
- [|"the quick"|];
- test_search_backward r n "What do you know about the quick brown fox?"
- [|"the quick"|];
- test_search_backward r n "The quick brown FOX"
- [||];
- test_search_backward r n "What do you know about THE QUICK BROWN FOX?"
- [||];
-
- start_test "Backward search for /a\\([0-9]+\\)/";
- let r = Str.regexp "a\\([0-9]+\\)" in
- let n = 1 in
- test_search_backward r n "a123 a456zzzz"
- [|"a456"; "456"|];
- test_search_backward r n "ab123"
- [||];
-
- (** Partial match searches *)
-
- start_test "Partial match for /partial match/";
- let r = Str.regexp "partial match" in
- let n = 0 in
- test_partial_match r n ""
- [|""|];
- test_partial_match r n "partial matching"
- [|"partial match"|];
- test_partial_match r n "partial m"
- [|"partial m"|];
-
- start_test "Partial match for /\\(partial\\)\\|\\(match\\)/";
- let r = Str.regexp "\\(partial\\)\\|\\(match\\)" in
- let n = 2 in
- test_partial_match r n ""
- [|""; "~"; "~"|];
- test_partial_match r n "part"
- [|"part"; "~"; "~"|];
- test_partial_match r n "partial"
- [|"partial"; "partial"; "~"|];
- test_partial_match r n "matching"
- [|"match"; "~"; "match"|];
- test_partial_match r n "mat"
- [|"mat"; "~"; "~"|];
- test_partial_match r n "zorglub"
- [||];
-
- (** Replacement *)
- start_test "Global replacement";
- test (Str.global_replace (Str.regexp "[aeiou]") ".."
- "abcdefghijklmnopqrstuvwxyz")
- "..bcd..fgh..jklmn..pqrst..vwxyz";
- test (Str.global_replace (Str.regexp "[0-9]\\([0-9]*\\)") "-\\0-\\1-"
- "abc012def3ghi45")
- "abc-012-12-def-3--ghi-45-5-";
- test (Str.global_replace (Str.regexp "[0-9]?") "."
- "abc012def3ghi45")
- ".a.b.c....d.e.f..g.h.i...";
-
- start_test "First replacement";
- test (Str.replace_first (Str.regexp "[eiou]") ".."
- "abcdefghijklmnopqrstuvwxyz")
- "abcd..fghijklmnopqrstuvwxyz";
- test (Str.replace_first (Str.regexp "[0-9]\\([0-9]*\\)") "-\\0-\\1-"
- "abc012def3ghi45")
- "abc-012-12-def3ghi45";
-
- (** XML tokenization *)
- (* See "REX: XML Shallow Parsing with Regular Expressions",
- Robert D. Cameron, Simon Fraser University, CMPT TR 1998-17. *)
- start_test "XML tokenization";
- begin
- let _TextSE = "[^<]+" in
- let _UntilHyphen = "[^-]*-" in
- let _Until2Hyphens = _UntilHyphen ^ "\\([^-]" ^ _UntilHyphen ^ "\\)*-" in
- let _CommentCE = _Until2Hyphens ^ ">?" in
- let _UntilRSBs = "[^]]*]\\([^]]+]\\)*]+" in
- let _CDATA_CE = _UntilRSBs ^ "\\([^]>]" ^ _UntilRSBs ^ "\\)*>" in
- let _S = "[ \n\t\r]+" in
- let _NameStrt = "[A-Za-z_:]\\|[^\x00-\x7F]" in
- let _NameChar = "[A-Za-z0-9_:.-]\\|[^\x00-\x7F]" in
- let _Name = "\\(" ^ _NameStrt ^ "\\)\\(" ^ _NameChar ^ "\\)*" in
- let _QuoteSE = "\"[^\"]*\"\\|'[^']*'" in
- let _DT_IdentSE = _S ^ _Name ^ "\\(" ^ _S ^ "\\(" ^ _Name ^ "\\|" ^ _QuoteSE ^ "\\)\\)*" in
- let _MarkupDeclCE = "\\([^]\"'><]\\|" ^ _QuoteSE ^ "\\)*>" in
- let _S1 = "[\n\r\t ]" in
- let _UntilQMs = "[^?]*\\?+" in
- let _PI_Tail = "\\?>\\|" ^ _S1 ^ _UntilQMs ^ "\\([^>?]" ^ _UntilQMs ^ "\\)*>" in
- let _DT_ItemSE = "<\\(!\\(--" ^ _Until2Hyphens ^ ">\\|[^-]" ^ _MarkupDeclCE ^ "\\)\\|\\?" ^ _Name ^ "\\(" ^ _PI_Tail ^ "\\)\\)\\|%" ^ _Name ^ ";\\|" ^ _S1 in
- let _DocTypeCE = _DT_IdentSE ^ "\\(" ^ _S ^ "\\)?\\(\\[\\(" ^ _DT_ItemSE ^ "\\)*]\\(" ^ _S ^ "\\)?\\)?>?" in
- let _DeclCE = "--\\(" ^ _CommentCE ^ "\\)?\\|\\[_CDATA\\[\\(" ^ _CDATA_CE ^ "\\)?\\|_DOCTYPE\\(" ^ _DocTypeCE ^ "\\)?" in
- let _PI_CE = _Name ^ "\\(" ^ _PI_Tail ^ "\\)?" in
- let _EndTagCE = _Name ^ "\\(" ^ _S ^ "\\)?>?" in
- let _AttValSE = "\"[^<\"]*\"\\|'[^<']*'" in
- let _ElemTagCE = _Name ^ "\\(" ^ _S ^ _Name ^ "\\(" ^ _S ^ "\\)?=\\(" ^ _S ^ "\\)?\\(" ^ _AttValSE ^ "\\)\\)*\\(" ^ _S ^ "\\)?/?>?" in
- let _MarkupSPE = "<\\(!\\(" ^ _DeclCE ^ "\\)?\\|\\?\\(" ^ _PI_CE ^ "\\)?\\|/\\(" ^ _EndTagCE ^ "\\)?\\|\\(" ^ _ElemTagCE ^ "\\)?\\)" in
- let _XML_SPE = _TextSE ^ "\\|" ^ _MarkupSPE in
- let input = "\
-<?xml version=\"1.0\"?>
-<?xml-stylesheet type=\"text/css\" href=\"nutrition.css\"?>
-<!DOCTYPE root [
- <!ELEMENT root (stem)>
- <!ELEMENT stem EMPTY>
-]>
-<!ELEMENT name (#PCDATA)>
-<![CDATA[my
-escaped text]]>
-<nutrition>
-<daily-values>
- <total-fat units=\"g\">65</total-fat>
- <saturated-fat units=\"g\">20</saturated-fat>
- <cholesterol units=\"mg\">300</cholesterol>
- <sodium units=\"mg\">2400</sodium>
- <carb units=\"g\">300</carb>
- <fiber units=\"g\">25</fiber>
- <protein units=\"g\">50</protein>
-</daily-values>
-<food>
- <name>Avocado Dip</name>
- <mfr>Sunnydale</mfr>
- <serving units=\"g\">29</serving>
- <calories total=\"110\" fat=\"100\"/>
- <total-fat>11</total-fat>
- <saturated-fat>3</saturated-fat>
- <cholesterol>5</cholesterol>
- <sodium>210</sodium>
- <carb>2</carb>
- <fiber>0</fiber>
- <protein>1</protein>
- <vitamins>
- <a>0</a>
- <c>0</c>
- </vitamins>
- <minerals>
- <ca>0</ca>
- <fe>0</fe>
- </minerals>
-</food>
-<!--
-<food>
- <name></name>
- <mfr></mfr>
- <serving units=\"g\"></serving>
- <calories total=\"\" fat=\"\"/>
- <total-fat></total-fat>
- <saturated-fat></saturated-fat>
- <cholesterol></cholesterol>
- <sodium></sodium>
- <carb></carb>
- <fiber></fiber>
- <protein></protein>
- <vitamins>
- <a></a>
- <c></c>
- </vitamins>
- <minerals>
- <ca></ca>
- <fe></fe>
- </minerals>
-</food>
--->
-" in
- let result = [
- "<?xml version=\"1.0\"?>";
- "\n";
- "<?xml-stylesheet type=\"text/css\" href=\"nutrition.css\"?>";
- "\n";
- "<!";
- "DOCTYPE root [\n ";
- "<!";
- "ELEMENT root (stem)>\n ";
- "<!";
- "ELEMENT stem EMPTY>\n]>\n";
- "<!";
- "ELEMENT name (#PCDATA)>\n";
- "<!";
- "[CDATA[my\nescaped text]]> \n";
- "<nutrition>";
- "\n";
- "<daily-values>";
- "\n\t";
- "<total-fat units=\"g\">";
- "65";
- "</total-fat>";
- "\n\t";
- "<saturated-fat units=\"g\">";
- "20";
- "</saturated-fat>";
- "\n\t";
- "<cholesterol units=\"mg\">";
- "300";
- "</cholesterol>";
- "\n\t";
- "<sodium units=\"mg\">";
- "2400";
- "</sodium>";
- "\n\t";
- "<carb units=\"g\">";
- "300";
- "</carb>";
- "\n\t";
- "<fiber units=\"g\">";
- "25";
- "</fiber>";
- "\n\t";
- "<protein units=\"g\">";
- "50";
- "</protein>";
- "\n";
- "</daily-values>";
- "\n";
- "<food>";
- "\n\t";
- "<name>";
- "Avocado Dip";
- "</name>";
- "\n\t";
- "<mfr>";
- "Sunnydale";
- "</mfr>";
- "\n\t";
- "<serving units=\"g\">";
- "29";
- "</serving>";
- "\n\t";
- "<calories total=\"110\" fat=\"100\"/>";
- "\n\t";
- "<total-fat>";
- "11";
- "</total-fat>";
- "\n\t";
- "<saturated-fat>";
- "3";
- "</saturated-fat>";
- "\n\t";
- "<cholesterol>";
- "5";
- "</cholesterol>";
- "\n\t";
- "<sodium>";
- "210";
- "</sodium>";
- "\n\t";
- "<carb>";
- "2";
- "</carb>";
- "\n\t";
- "<fiber>";
- "0";
- "</fiber>";
- "\n\t";
- "<protein>";
- "1";
- "</protein>";
- "\n\t";
- "<vitamins>";
- "\n\t\t";
- "<a>";
- "0";
- "</a>";
- "\n\t\t";
- "<c>";
- "0";
- "</c>";
- "\n\t";
- "</vitamins>";
- "\n\t";
- "<minerals>";
- "\n\t\t";
- "<ca>";
- "0";
- "</ca>";
- "\n\t\t";
- "<fe>";
- "0";
- "</fe>";
- "\n\t";
- "</minerals>";
- "\n";
- "</food>";
- "\n";
- "<!--\n<food>\n\t<name></name>\n\t<mfr></mfr>\n\t<serving units=\"g\"></serving>\n\t<calories total=\"\" fat=\"\"/>\n\t<total-fat></total-fat>\n\t<saturated-fat></saturated-fat>\n\t<cholesterol></cholesterol>\n\t<sodium></sodium>\n\t<carb></carb>\n\t<fiber></fiber>\n\t<protein></protein>\n\t<vitamins>\n\t\t<a></a>\n\t\t<c></c>\n\t</vitamins>\n\t<minerals>\n\t\t<ca></ca>\n\t\t<fe></fe>\n\t</minerals>\n</food>\n-->";
- "\n"] in
- let re = Str.regexp _XML_SPE in
- let rec process i l =
- let j = try Str.search_forward re input i with Not_found -> (-1) in
- if j < 0 then begin
- test l []
- end else begin
- match l with
- [] -> test 0 1 (* failure *)
- | hd :: tl ->
- test (Str.matched_string input) hd; process (Str.match_end()) tl
- end in
- process 0 result
- end;
-
- end_test()
-
-let manual_test regexp text =
- try
- ignore (Str.search_forward (Str.regexp regexp) text 0);
- printf "Matched,";
- begin try
- for i = 0 to 31 do
- try
- let s = Str.matched_group i text in
- printf " \\%d=%s" i s
- with Not_found ->
- ()
- done
- with Invalid_argument "Str.matched_group" -> (*yuck*)
- ()
- end;
- print_newline()
- with Not_found ->
- printf "Not matched\n"
-
-let _ =
- if Array.length Sys.argv >= 3
- then manual_test Sys.argv.(1) Sys.argv.(2)
- else automated_test()
diff --git a/test/Moretest/sets.ml b/test/Moretest/sets.ml
deleted file mode 100644
index 983145ee48..0000000000
--- a/test/Moretest/sets.ml
+++ /dev/null
@@ -1,39 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-module IntSet = Set.Make(struct type t = int let compare x y = x-y end)
-
-let even = List.fold_right IntSet.add [0; -2; 2; 4; 6; -10] IntSet.empty
-
-let odd = List.fold_right IntSet.add [9; -7; 5; 1; -3] IntSet.empty
-
-let _ =
- for i = -10 to 10 do
- Printf.printf "%d %B %B\n" i (IntSet.mem i even) (IntSet.mem i odd)
- done
-
-module PowerSet(BaseSet: Set.S)
- (SetOrd: functor(S: Set.S) -> Set.OrderedType) =
- Set.Make(SetOrd(BaseSet))
-
-module IntSetSet = PowerSet(IntSet)(functor (S: Set.S) -> S)
-
-let setofset = List.fold_right IntSetSet.add [even; odd] IntSetSet.empty
-
-let _ =
- List.iter
- (fun s -> Printf.printf "%B\n" (IntSetSet.mem s setofset))
- [IntSet.empty; even; odd; IntSet.union even odd]
-
-let _ = exit 0
diff --git a/test/Moretest/signals.ml b/test/Moretest/signals.ml
deleted file mode 100644
index 5451d8e5ba..0000000000
--- a/test/Moretest/signals.ml
+++ /dev/null
@@ -1,32 +0,0 @@
-let rec tak (x, y, z as tuple) =
- if x > y then tak(tak (x-1, y, z), tak (y-1, z, x), tak (z-1, x, y))
- else z
-
-let break_handler _ =
- print_string "Thank you for pressing ctrl-C."; print_newline();
- print_string "Allocating a bit..."; flush stdout;
- tak(18,12,6); print_string "done."; print_newline()
-
-let stop_handler _ =
- print_string "Thank you for pressing ctrl-Z."; print_newline();
- print_string "Now raising an exception..."; print_newline();
- raise Exit
-
-let _ =
- Sys.signal Sys.sigint (Sys.Signal_handle break_handler);
- Sys.signal Sys.sigtstp (Sys.Signal_handle stop_handler);
- begin try
- print_string "Computing like crazy..."; print_newline();
- for i = 1 to 100 do tak(18,12,6) done;
- print_string "Reading on input..."; print_newline();
- for i = 1 to 5 do
- try
- let s = read_line () in
- print_string ">> "; print_string s; print_newline()
- with Exit ->
- print_string "Got Exit, continuing."; print_newline()
- done
- with Exit ->
- print_string "Got Exit, exiting."; print_newline()
- end;
- exit 0
diff --git a/test/Moretest/stackoverflow.ml b/test/Moretest/stackoverflow.ml
deleted file mode 100644
index 4d211bc828..0000000000
--- a/test/Moretest/stackoverflow.ml
+++ /dev/null
@@ -1,15 +0,0 @@
-let rec f x =
- if x land 0xFFFF <> 0
- then 1 + f (x + 1)
- else
- try
- 1 + f (x + 1)
- with Stack_overflow ->
- print_string "x = "; print_int x; print_newline();
- raise Stack_overflow
-
-let _ =
- try
- ignore(f 0)
- with Stack_overflow ->
- print_string "Stack overflow caught"; print_newline()
diff --git a/test/Moretest/syserror.ml b/test/Moretest/syserror.ml
deleted file mode 100644
index 46f62eadb0..0000000000
--- a/test/Moretest/syserror.ml
+++ /dev/null
@@ -1 +0,0 @@
-let channel = open_out "titi:/toto"
diff --git a/test/Moretest/tailcalls.ml b/test/Moretest/tailcalls.ml
deleted file mode 100644
index 23b7353598..0000000000
--- a/test/Moretest/tailcalls.ml
+++ /dev/null
@@ -1,28 +0,0 @@
-let rec tailcall4 a b c d =
- if a < 0
- then b
- else tailcall4 (a-1) (b+1) (c+2) (d+3)
-
-let rec tailcall8 a b c d e f g h =
- if a < 0
- then b
- else tailcall8 (a-1) (b+1) (c+2) (d+3) (e+4) (f+5) (g+6) (h+7)
-
-let rec tailcall16 a b c d e f g h i j k l m n o p =
- if a < 0
- then b
- else tailcall16 (a-1) (b+1) (c+2) (d+3) (e+4) (f+5) (g+6) (h+7)
- (i+8) (j+9) (k+10) (l+11) (m+12) (n+13) (o+14) (p+15)
-
-let indtailcall8 fn a b c d e f g h =
- fn a b c d e f g h
-
-let indtailcall16 fn a b c d e f g h i j k l m n o p =
- fn a b c d e f g h i j k l m n o p
-
-let _ =
- print_int (tailcall4 10000000 0 0 0); print_newline();
- print_int (tailcall8 10000000 0 0 0 0 0 0 0); print_newline();
- print_int (tailcall16 10000000 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0); print_newline();
- print_int (indtailcall8 tailcall8 10 0 0 0 0 0 0 0); print_newline();
- print_int (indtailcall16 tailcall16 10 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0); print_newline()
diff --git a/test/Moretest/tcallback.ml b/test/Moretest/tcallback.ml
deleted file mode 100644
index 025c7a46cf..0000000000
--- a/test/Moretest/tcallback.ml
+++ /dev/null
@@ -1,69 +0,0 @@
-external mycallback1 : ('a -> 'b) -> 'a -> 'b = "mycallback1"
-external mycallback2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c = "mycallback2"
-external mycallback3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd = "mycallback3"
-external mycallback4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e = "mycallback4"
-
-let rec tak (x, y, z as tuple) =
- if x > y then tak(tak (x-1, y, z), tak (y-1, z, x), tak (z-1, x, y))
- else z
-
-let tak2 x (y, z) = tak (x, y, z)
-
-let tak3 x y z = tak (x, y, z)
-
-let tak4 x y z u = tak (x, y, z + u)
-
-let raise_exit () = (raise Exit : unit)
-
-let trapexit () =
- begin try
- mycallback1 raise_exit ()
- with Exit ->
- ()
- end;
- tak (18, 12, 6)
-
-external mypushroot : 'a -> ('b -> 'c) -> 'b -> 'a = "mypushroot"
-external mycamlparam : 'a -> ('b -> 'c) -> 'b -> 'a = "mycamlparam"
-
-let tripwire f =
- let s = String.make 5 'a' in
- f s trapexit ()
-
-(* Test callbacks performed to handle signals *)
-
-let sighandler signo =
-(*
- print_string "Got signal, triggering garbage collection...";
- print_newline();
-*)
- (* Thoroughly wipe the minor heap *)
- tak (18, 12, 6);
- ()
-
-external unix_getpid : unit -> int = "unix_getpid" "noalloc"
-external unix_kill : int -> int -> unit = "unix_kill" "noalloc"
-
-let callbacksig () =
- let pid = unix_getpid() in
- (* Allocate a block in the minor heap *)
- let s = String.make 5 'b' in
- (* Send a signal to self. We want s to remain in a register and
- not be spilled on the stack, hence we declare unix_kill
- "noalloc". *)
- unix_kill pid Sys.sigusr1;
- (* Allocate some more so that the signal will be tested *)
- let u = (s, s) in
- fst u
-
-let _ =
- print_int(mycallback1 tak (18, 12, 6)); print_newline();
- print_int(mycallback2 tak2 18 (12, 6)); print_newline();
- print_int(mycallback3 tak3 18 12 6); print_newline();
- print_int(mycallback4 tak4 18 12 3 3); print_newline();
- print_int(trapexit ()); print_newline();
- print_string(tripwire mypushroot); print_newline();
- print_string(tripwire mycamlparam); print_newline();
- Sys.signal Sys.sigusr1 (Sys.Signal_handle sighandler);
- print_string(callbacksig ()); print_newline()
-
diff --git a/test/Moretest/testrandom.ml b/test/Moretest/testrandom.ml
deleted file mode 100644
index 150d408898..0000000000
--- a/test/Moretest/testrandom.ml
+++ /dev/null
@@ -1,13 +0,0 @@
-open Random
-
-let _ =
- for i = 0 to 20 do
- print_float (float 1000.); print_char ' '
- done;
- print_newline (); print_newline ();
- for i = 0 to 20 do
- print_int (int 1000); print_char ' '
- done
-
-let _ = exit 0
-
diff --git a/test/Moretest/tscanf.ml b/test/Moretest/tscanf.ml
deleted file mode 100644
index 38605fe5fc..0000000000
--- a/test/Moretest/tscanf.ml
+++ /dev/null
@@ -1,826 +0,0 @@
-open Scanf;;
-
-(* Auxilliaries. *)
-let all_tests_ok = ref true;;
-
-let finish () =
- match !all_tests_ok with
- | true ->
- prerr_endline "\nAll tests succeeded."
- | _ ->
- prerr_endline "\n\n********* Test suit failed. ***********\n";;
-
-at_exit finish;;
-
-let test_num = ref (-1);;
-
-let print_test_number () =
- print_int !test_num; print_string " "; flush stdout;;
-
-let next_test () =
- incr test_num;
- print_test_number ();;
-
-let print_test_fail () =
- all_tests_ok := false;
- print_string
- (Printf.sprintf "\n********* Test number %i failed ***********\n"
- !test_num);;
-
-let print_failure_test_fail () =
- all_tests_ok := false;
- print_string
- (Printf.sprintf
- "\n********* Failure Test number %i incorrectly failed ***********\n"
- !test_num);;
-
-let print_failure_test_succeed () =
- all_tests_ok := false;
- print_string
- (Printf.sprintf
- "\n********* Failure Test number %i failed to fail ***********\n"
- !test_num);;
-
-let test b =
- next_test ();
- if not b then print_test_fail ();;
-
-(* Applies f to x and checks that the evaluation indeed
- raises an exception that verifies the predicate [pred]. *)
-let test_raises_exc_p pred f x =
- next_test ();
- try
- let b = f x in
- print_failure_test_succeed ();
- false
- with
- | x ->
- pred x || (print_failure_test_fail (); false);;
-
-(* Applies f to x and checks that the evaluation indeed
- raises some exception. *)
-let test_raises_some_exc f = test_raises_exc_p (fun _ -> true) f;;
-let test_raises_this_exc exc = test_raises_exc_p (fun x -> x = exc);;
-
-(* Applies f to x and checks that the evaluation indeed
- raises exception Failure s. *)
-
-let test_raises_this_failure s f x =
- test_raises_exc_p (fun x -> x = Failure s) f x;;
-
-(* Applies f to x and checks that the evaluation indeed
- raises the exception Failure. *)
-let test_raises_some_failure f x =
- test_raises_exc_p (function Failure _ -> true | _ -> false) f x;;
-
-let failure_test f x s = test_raises_this_failure s f x;;
-let any_failure_test = test_raises_some_failure;;
-
-let scan_failure_test f x =
- test_raises_exc_p (function Scan_failure _ -> true | _ -> false) f x;;
-
-(* The ``continuation'' that returns the scanned value. *)
-let void x = x;;
-
-(* Testing space scanning. *)
-let test0 () =
- (sscanf "" "" void) 1 +
- (sscanf "" " " void) 2 +
- (sscanf " " " " void) 3 +
- (sscanf "\t" " " void) 4 +
- (sscanf "\n" " " void) 5 +
- (sscanf "\n\t 6" " %d" void)
-;;
-test (test0 () = 21);;
-
-(* Testing integer scanning %i and %d. *)
-let test1 () =
- sscanf "1" "%d" void +
- sscanf " 2" " %d" void +
- sscanf " -2" " %d" void +
- sscanf " +2" " %d" void +
- sscanf " 2a " " %da" void;;
-
-test (test1 () = 5);;
-
-let test2 () =
- sscanf "123" "%2i" void +
- sscanf "245" "%d" void +
- sscanf " 2a " " %1da" void;;
-
-test (test2 () = 259);;
-
-let test3 () =
- sscanf "0xff" "%3i" void +
- sscanf "0XEF" "%3i" void +
- sscanf "x=-245" " x = %d" void +
- sscanf " 2a " " %1da" void;;
-
-test (test3 () = -214);;
-
-(* Testing float scanning. *)
-(* f style. *)
-let test4 () =
- bscanf (Scanning.from_string "1")
- "%f" (fun b0 -> b0 = 1.0) &&
- bscanf (Scanning.from_string "-1")
- "%f" (fun b0 -> b0 = -1.0) &&
- bscanf (Scanning.from_string "+1")
- "%f" (fun b0 -> b0 = 1.0) &&
- bscanf (Scanning.from_string "1.")
- "%f" (fun b0 -> b0 = 1.0) &&
- bscanf (Scanning.from_string ".1")
- "%f" (fun b0 -> b0 = 0.1) &&
- bscanf (Scanning.from_string "-.1")
- "%f" (fun b0 -> b0 = -0.1) &&
- bscanf (Scanning.from_string "+.1")
- "%f" (fun b0 -> b0 = 0.1) &&
- bscanf (Scanning.from_string "+1.")
- "%f" (fun b0 -> b0 = 1.0) &&
- bscanf (Scanning.from_string "-1.")
- "%f" (fun b0 -> b0 = -1.0) &&
- bscanf (Scanning.from_string "0 1. 1.3")
- "%f %f %f" (fun b0 b1 b2 -> b0 = 0.0 && b1 = 1.0 && b2 = 1.3) &&
- bscanf (Scanning.from_string "0.113")
- "%4f" (fun b0 -> b0 = 0.11) &&
- bscanf (Scanning.from_string "0.113")
- "%5f" (fun b0 -> b0 = 0.113) &&
- bscanf (Scanning.from_string "000.113")
- "%15f" (fun b0 -> b0 = 0.113) &&
- bscanf (Scanning.from_string "+000.113")
- "%15f" (fun b0 -> b0 = 0.113) &&
- bscanf (Scanning.from_string "-000.113")
- "%15f" (fun b0 -> b0 = -0.113);;
-test (test4 ());;
-
-(* e style. *)
-let test5 () =
- bscanf (Scanning.from_string "1e1")
- "%e" (fun b -> b = 10.0) &&
- bscanf (Scanning.from_string "1e+1")
- "%e" (fun b -> b = 10.0) &&
- bscanf (Scanning.from_string "10e-1")
- "%e" (fun b -> b = 1.0) &&
- bscanf (Scanning.from_string "10.e-1")
- "%e" (fun b -> b = 1.0) &&
- bscanf (Scanning.from_string "1e1 1.e+1 1.3e-1")
- "%e %e %e" (fun b1 b2 b3 -> b1 = 10.0 && b2 = b1 && b3 = 0.13) &&
-
-(* g style. *)
- bscanf (Scanning.from_string "1 1.1 0e+1 1.3e-1")
- "%g %g %g %g" (fun b1 b2 b3 b4 ->
- b1 = 1.0 && b2 = 1.1 && b3 = 0.0 && b4 = 0.13);;
-
-test (test5 ());;
-
-(* Testing boolean scanning. *)
-let test6 () =
- bscanf (Scanning.from_string "truetrue") "%B%B"
- (fun b1 b2 -> (b1, b2) = (true, true)) &&
- bscanf (Scanning.from_string "truefalse") "%B%B"
- (fun b1 b2 -> (b1, b2) = (true, false)) &&
- bscanf (Scanning.from_string "falsetrue") "%B%B"
- (fun b1 b2 -> (b1, b2) = (false, true)) &&
- bscanf (Scanning.from_string "falsefalse") "%B%B"
- (fun b1 b2 -> (b1, b2) = (false, false)) &&
- bscanf (Scanning.from_string "true false") "%B %B"
- (fun b1 b2 -> (b1, b2) = (true, false));;
-
-test (test6 ());;
-
-(* Testing char scanning. *)
-
-let test7 () =
- bscanf (Scanning.from_string "'a' '\n' '\t' '\000' '\032'")
- "%C %C %C %C %C"
- (fun c1 c2 c3 c4 c5 ->
- c1 = 'a' && c2 = '\n' && c3 = '\t' && c4 = '\000' && c5 = '\032') &&
-
-(* Here \n, \t, and \032 are skipped due to the space semantics of scanf. *)
- bscanf (Scanning.from_string "a \n \t \000 \032b")
- "%c %c %c "
- (fun c1 c2 c3 ->
- c1 = 'a' && c2 = '\000' && c3 = 'b');;
-
-test (test7 ());;
-
-let verify_read c =
- let s = Printf.sprintf "%C" c in
- let ib = Scanning.from_string s in
- assert (bscanf ib "%C" void = c);;
-
-let verify_scan_Chars () =
- for i = 0 to 255 do verify_read (char_of_int i) done;;
-
-let test8 () = verify_scan_Chars () = ();;
-
-test (test8 ());;
-
-(* Testing string scanning. *)
-
-(* %S and %s styles. *)
-let unit fmt s =
- let ib = Scanning.from_string (Printf.sprintf "%S" s) in
- Scanf.bscanf ib fmt void;;
-
-let test_fmt fmt s = unit fmt s = s;;
-
-let test_S = test_fmt "%S";;
-let test9 () =
- test_S "poi" &&
- test_S "a\"b" &&
- test_S "a\nb" &&
- test_S "a\010b" &&
- test_S "a\\\n\
- b \\\n\
- c\010\\\n\
- b" &&
- test_S "a\\\n\
- \\\n\
- \\\n\
- b \\\n\
- c\010\\\n\
- b"
-;;
-test (test9 ());;
-
-let test10 () =
- let res = sscanf "Une chaîne: \"celle-ci\" et \"celle-là\"!"
- "%s %s %S %s %S %s"
- (fun s1 s2 s3 s4 s5 s6 -> s1 ^ s2 ^ s3 ^ s4 ^ s5 ^ s6) in
- res = "Unechaîne:celle-cietcelle-là!";;
-
-test (test10 ());;
-
-(* %[] style *)
-let test11 () =
- sscanf "Pierre Weis 70" "%s %s %s"
- (fun prenom nom poids ->
- prenom = "Pierre" && nom = "Weis" && int_of_string poids = 70)
- &&
- sscanf "Jean-Luc de Léage 68" "%[^ ] %[^ ] %d"
- (fun prenom nom poids ->
- prenom = "Jean-Luc" && nom = "de Léage" && poids = 68)
- &&
- sscanf "Daniel de Rauglaudre 66" "%s@\t %s@\t %d"
- (fun prenom nom poids ->
- prenom = "Daniel" && nom = "de Rauglaudre" && poids = 66)
-;;
-
-let test110 () =
- sscanf "" " " (fun x -> x) "" = "" &&
- sscanf "" "%[^\n]" (fun x -> x) = "" &&
- sscanf "" "%[^\n] " (fun x -> x) = "";;
-
-let test111 () =
- try (sscanf "" "%[^\n]@\n") (fun x -> false) with
- | End_of_file -> true;;
-
-test (test11 () && test110 () && test111 ());;
-
-(* Scanning lists. *)
-let ib () = Scanning.from_string "[1;2;3;4; ]";;
-
-(* Statically known lists can be scanned directly. *)
-let f ib =
- bscanf ib " [" ();
- bscanf ib " %i ;" (fun i ->
- bscanf ib " %i ;" (fun j ->
- bscanf ib " %i ;" (fun k ->
- bscanf ib " %i ;" (fun l ->
- bscanf ib " ]" ();
- [i; j; k; l]))));;
-
-let test12 () = f (ib ()) = [1; 2; 3; 4];;
-
-test (test12 ());;
-
-(* A general list scanner that always fails to succeed. *)
-let rec scan_elems ib accu =
- try bscanf ib " %i ;" (fun i -> scan_elems ib (i :: accu))
- with _ -> accu;;
-
-let g ib = bscanf ib "[ " (); List.rev (scan_elems ib []);;
-
-let test13 () = g (ib ()) = [1; 2; 3; 4];;
-
-test (test13 ());;
-
-(* A general int list scanner. *)
-let rec scan_int_list ib =
- bscanf ib "[ " ();
- let accu = scan_elems ib [] in
- bscanf ib " ]" ();
- List.rev accu;;
-
-let test14 () = scan_int_list (ib ()) = [1; 2; 3; 4];;
-
-test (test14 ());;
-
-(* A general list scanner that always succeeds. *)
-let rec scan_elems ib accu =
- bscanf ib " %i %c"
- (fun i -> function
- | ';' -> scan_elems ib (i :: accu)
- | ']' -> List.rev (i :: accu)
- | c -> failwith "scan_elems");;
-
-let rec scan_int_list ib =
- bscanf ib "[ " ();
- scan_elems ib [];;
-
-let test15 () =
- scan_int_list (Scanning.from_string "[1;2;3;4]") = [1; 2; 3; 4];;
-
-test (test15 ());;
-
-let rec scan_elems ib accu =
- try
- bscanf ib "%c %i"
- (fun c i ->
- match c with
- | ';' -> scan_elems ib (i :: accu)
- | ']' -> List.rev (i :: accu)
- | '[' when accu = [] -> scan_elems ib (i :: accu)
- | c -> prerr_endline (String.make 1 c); failwith "scan_elems")
- with
- | Scan_failure _ -> bscanf ib "]" (); accu
- | End_of_file -> accu;;
-
-let scan_int_list ib = scan_elems ib [];;
-
-let test16 () =
- scan_int_list (Scanning.from_string "[]") = List.rev [] &&
- scan_int_list (Scanning.from_string "[1;2;3;4]") = List.rev [1;2;3;4] &&
- scan_int_list (Scanning.from_string "[1;2;3;4; ]") = List.rev [1;2;3;4] &&
- (* Should fail but succeeds! *)
- scan_int_list (Scanning.from_string "[1;2;3;4") = List.rev [1;2;3;4]
-;;
-
-test (test16 ());;
-
-let rec scan_elems ib accu =
- bscanf ib " %i%[]; \t\n\r]"
- (fun i s ->
- match s with
- | ";" -> scan_elems ib (i :: accu)
- | "]" -> List.rev (i :: accu)
- | s -> List.rev (i :: accu));;
-
-let scan_int_list ib =
- bscanf ib " [" ();
- scan_elems ib [];;
-
-let test17 () =
- scan_int_list (Scanning.from_string "[1;2;3;4]") = [1;2;3;4] &&
- scan_int_list (Scanning.from_string "[1;2;3;4; ]") = [1;2;3;4] &&
- (* Should fail but succeeds! *)
- scan_int_list (Scanning.from_string "[1;2;3;4 5]") = [1;2;3;4]
-;;
-
-test (test17 ());;
-
-let rec scan_elems ib accu =
- bscanf ib " %c " (fun c ->
- match c with
- | '[' when accu = [] ->
- (* begginning of list: could find either
- - an int, if the list is not empty,
- - the char ], if the list is empt *)
- bscanf ib "%[]]"
- (function
- | "]" -> accu
- | _ ->
- bscanf ib " %i " (fun i ->
- scan_rest ib (i :: accu)))
- | _ -> failwith "scan_elems")
-
-and scan_rest ib accu =
- bscanf ib " %c " (fun c ->
- match c with
- | ';' ->
- bscanf ib "%[]]"
- (function
- | "]" -> accu
- | _ ->
- bscanf ib " %i " (fun i ->
- scan_rest ib (i :: accu)))
- | ']' -> accu
- | _ -> failwith "scan_rest");;
-
-
-let scan_int_list ib = List.rev (scan_elems ib []);;
-
-let test18 () =
- scan_int_list (Scanning.from_string "[]") = [] &&
- scan_int_list (Scanning.from_string "[ ]") = [] &&
- scan_int_list (Scanning.from_string "[1;2;3;4]") = [1;2;3;4] &&
- scan_int_list (Scanning.from_string "[1;2;3;4; ]") = [1;2;3;4]
-;;
-
-test (test18 ());;
-
-(* Those properly fail *)
-
-let test19 () =
- failure_test
- scan_int_list (Scanning.from_string "[1;2;3;4 5]")
- "scan_rest";;
-
-(test19 ());;
-
-let test20 () =
- scan_failure_test
- scan_int_list (Scanning.from_string "[1;2;3;4; ; 5]");;
-
-(test20 ());;
-
-let test21 () =
- scan_failure_test
- scan_int_list (Scanning.from_string "[1;2;3;4;;");;
-
-(test21 ());;
-
-let rec scan_elems ib accu =
- bscanf ib "%1[];]" (function
- | "]" -> accu
- | ";" -> scan_rest ib accu
- | _ ->
- failwith
- (Printf.sprintf "scan_int_list" (*
- "scan_int_list: char %i waiting for ']' or ';' but found %c"
- (Scanning.char_count ib) (Scanning.peek_char ib)*)))
-
-and scan_rest ib accu =
- bscanf ib "%[]]" (function
- | "]" -> accu
- | _ -> scan_elem ib accu)
-
-and scan_elem ib accu =
- bscanf ib " %i " (fun i -> scan_elems ib (i :: accu));;
-
-let scan_int_list ib =
- bscanf ib " [ " ();
- List.rev (scan_rest ib []);;
-
-let test22 () =
- scan_int_list (Scanning.from_string "[]") = [] &&
- scan_int_list (Scanning.from_string "[ ]") = [] &&
- scan_int_list (Scanning.from_string "[1]") = [1] &&
- scan_int_list (Scanning.from_string "[1;2;3;4]") = [1;2;3;4] &&
- scan_int_list (Scanning.from_string "[1;2;3;4;]") = [1;2;3;4];;
-
-test (test22 ());;
-
-(* Should work and does not with this version of scan_int_list!
-scan_int_list (Scanning.from_string "[1;2;3;4; ]");;
-(* Should lead to a bad input error. *)
-scan_int_list (Scanning.from_string "[1;2;3;4 5]");;
-scan_int_list (Scanning.from_string "[1;2;3;4;;");;
-scan_int_list (Scanning.from_string "[1;2;3;4; ; 5]");;
-scan_int_list (Scanning.from_string "[1;2;3;4;; 23]");;
-*)
-
-let rec scan_elems ib accu =
- try bscanf ib " %i %1[;]" (fun i s ->
- if s = "" then i :: accu else scan_elems ib (i :: accu))
- with Scan_failure _ -> accu;;
-
-(* The general int list scanner. *)
-let rec scan_int_list ib =
- bscanf ib "[ " ();
- let accu = scan_elems ib [] in
- bscanf ib " ]" ();
- List.rev accu;;
-
-(* The general HO list scanner. *)
-let rec scan_elems ib scan_elem accu =
- try scan_elem ib (fun i s ->
- let accu = i :: accu in
- if s = "" then accu else scan_elems ib scan_elem accu)
- with Scan_failure _ -> accu;;
-
-let scan_list scan_elem ib =
- bscanf ib "[ " ();
- let accu = scan_elems ib scan_elem [] in
- bscanf ib " ]" ();
- List.rev accu;;
-
-(* Deriving particular list scanners from the HO list scanner. *)
-let scan_int_elem ib = bscanf ib " %i %1[;]";;
-let scan_int_list = scan_list scan_int_elem;;
-
-let test23 () =
- scan_int_list (Scanning.from_string "[]") = [] &&
- scan_int_list (Scanning.from_string "[ ]") = [] &&
- scan_int_list (Scanning.from_string "[1]") = [1] &&
- scan_int_list (Scanning.from_string "[1;2;3;4]") = [1;2;3;4] &&
- scan_int_list (Scanning.from_string "[1;2;3;4;]") = [1;2;3;4]
-;;
-
-test (test23 ());;
-
-let test24 () =
- scan_failure_test scan_int_list (Scanning.from_string "[1;2;3;4 5]")
-and test25 () =
- scan_failure_test scan_int_list (Scanning.from_string "[1;2;3;4;;")
-and test26 () =
- scan_failure_test scan_int_list (Scanning.from_string "[1;2;3;4; ; 5]")
-and test27 () =
- scan_failure_test scan_int_list (Scanning.from_string "[1;2;3;4;; 23]");;
-
- (test24 ()) &&
- (test25 ()) &&
- (test26 ()) &&
- (test27 ());;
-
-(* To scan a Caml string:
- the format is "\"%s@\"".
- A better way would be to add a %S (String.escaped), a %C (Char.escaped).
- This is now available. *)
-let scan_string_elem ib = bscanf ib " \"%s@\" %1[;]";;
-let scan_string_list = scan_list scan_string_elem;;
-
-let scan_String_elem ib = bscanf ib " %S %1[;]";;
-let scan_String_list = scan_list scan_String_elem;;
-
-let test28 () =
- scan_string_list (Scanning.from_string "[]") = [] &&
- scan_string_list (Scanning.from_string "[\"Le\"]") = ["Le"] &&
- scan_string_list
- (Scanning.from_string "[\"Le\";\"langage\";\"Objective\";\"Caml\"]") =
- ["Le"; "langage"; "Objective"; "Caml"] &&
- scan_string_list
- (Scanning.from_string "[\"Le\";\"langage\";\"Objective\";\"Caml\"; ]") =
- ["Le"; "langage"; "Objective"; "Caml"] &&
-
- scan_String_list (Scanning.from_string "[]") = [] &&
- scan_String_list (Scanning.from_string "[\"Le\"]") = ["Le"] &&
- scan_String_list
- (Scanning.from_string "[\"Le\";\"langage\";\"Objective\";\"Caml\"]") =
- ["Le"; "langage"; "Objective"; "Caml"] &&
- scan_String_list
- (Scanning.from_string "[\"Le\";\"langage\";\"Objective\";\"Caml\"; ]") =
- ["Le"; "langage"; "Objective"; "Caml"]
-;;
-
-test (test28 ());;
-
-(* The general HO list scanner with continuations. *)
-let rec scan_elems ib scan_elem accu =
- scan_elem ib
- (fun i s ->
- let accu = i :: accu in
- if s = "" then accu else scan_elems ib scan_elem accu)
- (fun ib exc -> accu);;
-
-let scan_list scan_elem ib =
- bscanf ib "[ " ();
- let accu = scan_elems ib scan_elem [] in
- bscanf ib " ]" ();
- List.rev accu;;
-
-(* Deriving particular list scanners from the HO list scanner. *)
-let scan_int_elem ib f ek = kscanf ib ek " %i %1[;]" f;;
-let scan_int_list = scan_list scan_int_elem;;
-
-let test29 () =
- scan_int_list (Scanning.from_string "[]") = [] &&
- scan_int_list (Scanning.from_string "[ ]") = [] &&
- scan_int_list (Scanning.from_string "[1]") = [1] &&
- scan_int_list (Scanning.from_string "[1;2;3;4]") = [1;2;3;4] &&
- scan_int_list (Scanning.from_string "[1;2;3;4;]") = [1;2;3;4]
-;;
-
-test (test29 ());;
-
-let scan_string_elem ib f ek = kscanf ib ek " %S %1[;]" f;;
-let scan_string_list = scan_list scan_string_elem;;
-
-let test30 () =
- scan_string_list (Scanning.from_string "[]") = [] &&
- scan_string_list (Scanning.from_string "[ ]") = [] &&
- scan_string_list (Scanning.from_string "[ \"1\" ]") = ["1"] &&
- scan_string_list
- (Scanning.from_string "[\"1\"; \"2\"; \"3\"; \"4\"]") =
- ["1"; "2"; "3"; "4"] &&
- scan_string_list
- (Scanning.from_string "[\"1\"; \"2\"; \"3\"; \"4\";]") =
- ["1"; "2"; "3"; "4"]
-;;
-
-test (test30 ());;
-
-(* A generic scan_elem, *)
-let scan_elem fmt ib f ek = kscanf ib ek fmt f;;
-
-(* Derivation of list scanners from the generic polymorphic scanners. *)
-let scan_int_list = scan_list (scan_elem " %i %1[;]");;
-let scan_string_list = scan_list (scan_elem " %S %1[;]");;
-let scan_bool_list = scan_list (scan_elem " %B %1[;]");;
-let scan_char_list = scan_list (scan_elem " %C %1[;]");;
-let scan_float_list = scan_list (scan_elem " %f %1[;]");;
-
-let rec scan_elems ib scan_elem accu =
- scan_elem ib
- (fun i ->
- let accu = i :: accu in
- kscanf ib
- (fun ib exc -> accu)
- " %1[;]"
- (fun s -> if s = "" then accu else scan_elems ib scan_elem accu))
- (fun ib exc -> accu);;
-
-let scan_list scan_elem ib =
- bscanf ib "[ " ();
- let accu = scan_elems ib scan_elem [] in
- bscanf ib " ]" ();
- List.rev accu;;
-
-let scan_int_list = scan_list (scan_elem " %i");;
-let scan_string_list = scan_list (scan_elem " %S");;
-let scan_bool_list = scan_list (scan_elem " %B");;
-let scan_char_list = scan_list (scan_elem " %C");;
-let scan_float_list = scan_list (scan_elem " %f");;
-
-let test31 () =
- scan_int_list (Scanning.from_string "[]") = [] &&
- scan_int_list (Scanning.from_string "[ ]") = [] &&
- scan_int_list (Scanning.from_string "[1]") = [1] &&
- scan_int_list (Scanning.from_string "[1;2;3;4]") = [1;2;3;4] &&
- scan_int_list (Scanning.from_string "[1;2;3;4;]") = [1;2;3;4]
-;;
-
-test (test31 ());;
-
-let test32 () =
- scan_string_list (Scanning.from_string "[]") = [] &&
- scan_string_list (Scanning.from_string "[ ]") = [] &&
- scan_string_list (Scanning.from_string "[ \"1\" ]") = ["1"] &&
- scan_string_list
- (Scanning.from_string "[\"1\"; \"2\"; \"3\"; \"4\"]") =
- ["1"; "2"; "3"; "4"] &&
- scan_string_list
- (Scanning.from_string "[\"1\"; \"2\"; \"3\"; \"4\";]") =
- ["1"; "2"; "3"; "4"]
-;;
-
-test (test32 ());;
-
-(* Using kscanf only. *)
-let rec scan_elems ib scan_elem accu =
- kscanf ib (fun ib exc -> accu)
- scan_elem
- (fun i ->
- let accu = i :: accu in
- kscanf ib (fun ib exc -> accu)
- " %1[;] "
- (fun s -> if s = "" then accu else scan_elems ib scan_elem accu))
-;;
-
-let scan_list scan_elem ib =
- bscanf ib "[ " ();
- let accu = scan_elems ib scan_elem [] in
- bscanf ib " ]" ();
- List.rev accu
-;;
-
-let scan_int_list = scan_list "%i";;
-let scan_string_list = scan_list "%S";;
-let scan_bool_list = scan_list "%B";;
-let scan_char_list = scan_list "%C";;
-let scan_float_list = scan_list "%f";;
-
-let test33 () =
- scan_int_list (Scanning.from_string "[]") = [] &&
- scan_int_list (Scanning.from_string "[ ]") = [] &&
- scan_int_list (Scanning.from_string "[ 1 ]") = [1] &&
- scan_int_list (Scanning.from_string "[ 1 ; 2 ; 3 ; 4 ]") = [1; 2; 3; 4] &&
- scan_int_list (Scanning.from_string "[1 ;2 ;3 ;4;]") = [1; 2; 3; 4]
-;;
-
-test (test33 ());;
-
-let test34 () =
- scan_string_list (Scanning.from_string "[]") = [] &&
- scan_string_list (Scanning.from_string "[ ]") = [] &&
- scan_string_list (Scanning.from_string "[ \"1\" ]") = ["1"] &&
- scan_string_list
- (Scanning.from_string "[\"1\"; \"2\"; \"3\"; \"4\"]") =
- ["1"; "2"; "3"; "4"] &&
- scan_string_list
- (Scanning.from_string "[\"1\"; \"2\"; \"3\"; \"4\";]") =
- ["1"; "2"; "3"; "4"]
-;;
-
-test (test34 ());;
-
-(* Testing the %N format. *)
-let test35 () =
- sscanf "" "%N" (fun x -> x) = 0 &&
- sscanf "456" "%N" (fun x -> x) = 0 &&
- sscanf "456" "%d%N" (fun x y -> x, y) = (456, 1) &&
- sscanf " " "%N%s%N" (fun x s y -> x, s, y) = (0, "", 1)
-;;
-
-test (test35 ());;
-
-(* Testing the %n format. *)
-let test36 () =
- sscanf "" "%n" (fun x -> x) = 0 &&
- sscanf "456" "%n" (fun x -> x) = 0 &&
- sscanf "456" "%d%n" (fun x y -> x, y) = (456, 3) &&
- sscanf " " "%n%s%n" (fun x s y -> x, s, y) = (0, "", 1)
-;;
-
-test (test36 ());;
-
-(* Weird tests to empty strings or formats. *)
-let test37 () =
- sscanf "" "" true &&
- sscanf "" "" (fun x -> x) 1 = 1 &&
- sscanf "123" "" (fun x -> x) 1 = 1
-;;
-
-test (test37 ());;
-
-(* Testing end of input condition. *)
-let test38 () =
- sscanf " " " %!" true &&
- sscanf "" " %!" true &&
- sscanf "" "%!" true;;
-
-test (test38 ());;
-
-(* Weird tests on empty buffers. *)
-let test39 () =
- let is_empty_buff ib =
- Scanning.beginning_of_input ib &&
- Scanning.end_of_input ib in
-
- let ib = Scanning.from_string "" in
- is_empty_buff ib &&
- (* Do it twice since testing empty buff could incorrectly
- thraw an exception or wrongly change the beginning_of_input condition. *)
- is_empty_buff ib;;
-
-test (test39 ());;
-
-(* Testing ranges. *)
-let test40 () =
- let s = "cba" in
- let ib = Scanning.from_string s in
- bscanf ib "%[^ab]%s%!" (fun s1 s2 -> s1 = "c" && s2 = "ba");;
-
-test (test40 ());;
-
-let test41 () =
- let s = "cba" in
- let ib = Scanning.from_string s in
- bscanf ib "%[^abc]%[cba]%!" (fun s1 s2 -> s1 = "" && s2 = "cba");;
-
-test (test41 ());;
-
-let test42 () =
- let s = "defcbaaghi" in
- let ib = Scanning.from_string s in
- bscanf ib "%[^abc]%[cba]%s%!" (fun s1 s2 s3 ->
- s1 = "def" && s2 = "cbaa" && s3 = "ghi");;
-
-test (test42 ());;
-
-(*******
-
-print_string "Test number is ";
-print_int !test_num; print_string ". It should be 42.";
-print_newline();;
-
-To be continued.
-
-let digest () =
- let scan_line f = Scanf.scanf "%[^\n\r]@\n" f in
- let digest s = String.uppercase (Digest.to_hex (Digest.string s)) in
- let digest_line s = print_endline (s ^ "#" ^ digest s) in
- try
- while true do scan_line digest_line done
- with End_of_file -> ()
-;;
-
-(* Trying to scan records. *)
-let rec scan_fields ib scan_field accu =
- kscanf ib (fun ib exc -> accu)
- scan_field
- (fun i ->
- let accu = i :: accu in
- kscanf ib (fun ib exc -> accu)
- " %1[;] "
- (fun s -> if s = "" then accu else scan_fields ib scan_field accu))
-;;
-
-let scan_record scan_field ib =
- bscanf ib "{ " ();
- let accu = scan_fields ib scan_field [] in
- bscanf ib " }" ();
- List.rev accu
-;;
-***********)
diff --git a/test/Moretest/usemultdef.ml b/test/Moretest/usemultdef.ml
deleted file mode 100644
index 2bccabb693..0000000000
--- a/test/Moretest/usemultdef.ml
+++ /dev/null
@@ -1 +0,0 @@
-let _ = print_int(Multdef.f 1); print_newline(); exit 0
diff --git a/test/Moretest/warnings.ml b/test/Moretest/warnings.ml
deleted file mode 100644
index 08e2f29108..0000000000
--- a/test/Moretest/warnings.ml
+++ /dev/null
@@ -1,44 +0,0 @@
-
-(* C *)
-
-let foo = ( *);;
-
-
-(* F *)
-
-let f x y = x;;
-f 1; f 1;;
-
-
-(* M *)
-
-(* duh *)
-
-
-(* P *)
-
-let 1 = 1;;
-
-
-(* S *)
-
-1; 1;;
-
-
-(* U *)
-
-match 1 with
-| 1 -> ()
-| 1 -> ()
-| _ -> ()
-;;
-
-
-(* V *)
-
-(* re-duh *)
-
-
-(* X *)
-
-(* re-re *)
diff --git a/test/Moretest/wc.ml b/test/Moretest/wc.ml
deleted file mode 100644
index dbe46d9a26..0000000000
--- a/test/Moretest/wc.ml
+++ /dev/null
@@ -1,54 +0,0 @@
-(* Counts characters, lines and words in one or several files. *)
-
-let chars = ref 0
-and words = ref 0
-and lines = ref 0
-
-type state = Inside_word | Outside_word
-
-let count_channel in_channel =
- let rec count status =
- let c = input_char in_channel in
- incr chars;
- match c with
- '\n' ->
- incr lines; count Outside_word
- | ' ' | '\t' ->
- count Outside_word
- | _ ->
- if status = Outside_word then begin incr words; () end;
- count Inside_word
- in
- try
- count Outside_word
- with End_of_file ->
- ()
-
-let count_file name =
- let ic = open_in name in
- count_channel ic;
- close_in ic
-
-let print_result () =
- print_int !chars; print_string " characters, ";
- print_int !words; print_string " words, ";
- print_int !lines; print_string " lines";
- print_newline()
-
-let count name =
- count_file name;
- print_result ()
-
-let _ =
-try
- if Array.length Sys.argv <= 1 then
- count_channel stdin (* No command-line arguments *)
- else
- for i = 1 to Array.length Sys.argv - 1 do
- count_file Sys.argv.(i)
- done;
- print_result ()
-with Sys_error s ->
- print_string "I/O error: ";
- print_string s;
- print_newline()
diff --git a/test/Results/almabench.fast.out b/test/Results/almabench.fast.out
deleted file mode 100644
index 5c1d8b89c4..0000000000
--- a/test/Results/almabench.fast.out
+++ /dev/null
@@ -1,8 +0,0 @@
-0 17.00 -26.06
-1 12.34 1.29
-2 6.83 22.95
-3 0.04 -1.26
-4 2.30 12.54
-5 2.93 14.35
-6 21.27 -16.57
-7 20.41 -19.04
diff --git a/test/Results/almabench.out b/test/Results/almabench.out
deleted file mode 100644
index 5c1d8b89c4..0000000000
--- a/test/Results/almabench.out
+++ /dev/null
@@ -1,8 +0,0 @@
-0 17.00 -26.06
-1 12.34 1.29
-2 6.83 22.95
-3 0.04 -1.26
-4 2.30 12.54
-5 2.93 14.35
-6 21.27 -16.57
-7 20.41 -19.04
diff --git a/test/Results/bdd.out b/test/Results/bdd.out
deleted file mode 100644
index d86bac9de5..0000000000
--- a/test/Results/bdd.out
+++ /dev/null
@@ -1 +0,0 @@
-OK
diff --git a/test/Results/boyer.out b/test/Results/boyer.out
deleted file mode 100644
index f38e3263b1..0000000000
--- a/test/Results/boyer.out
+++ /dev/null
@@ -1 +0,0 @@
-Proved!
diff --git a/test/Results/fft.fast.runtest b/test/Results/fft.fast.runtest
deleted file mode 100644
index 16f24bdb99..0000000000
--- a/test/Results/fft.fast.runtest
+++ /dev/null
@@ -1,4 +0,0 @@
-case $1 in
- test) shift; $* | awk '$2 >= 1e-9 { exit 2; }';;
- bench) shift; xtime -o /dev/null $*;;
-esac \ No newline at end of file
diff --git a/test/Results/fft.fast.runtest.Mac b/test/Results/fft.fast.runtest.Mac
deleted file mode 100644
index d54a175ac9..0000000000
--- a/test/Results/fft.fast.runtest.Mac
+++ /dev/null
@@ -1,12 +0,0 @@
-set echo 0
-
-if "{1}" == test
- shift
- set exit 0
- {"parameters"} | search -r /e-[1-9][0-9]+°/
- exit 0 if {status}
- exit 2
-else if "{1}" == bench
- shift
- time {"parameters"} ">dev:null"
-end
diff --git a/test/Results/fft.runtest b/test/Results/fft.runtest
deleted file mode 100644
index 16f24bdb99..0000000000
--- a/test/Results/fft.runtest
+++ /dev/null
@@ -1,4 +0,0 @@
-case $1 in
- test) shift; $* | awk '$2 >= 1e-9 { exit 2; }';;
- bench) shift; xtime -o /dev/null $*;;
-esac \ No newline at end of file
diff --git a/test/Results/fft.runtest.Mac b/test/Results/fft.runtest.Mac
deleted file mode 100644
index d54a175ac9..0000000000
--- a/test/Results/fft.runtest.Mac
+++ /dev/null
@@ -1,12 +0,0 @@
-set echo 0
-
-if "{1}" == test
- shift
- set exit 0
- {"parameters"} | search -r /e-[1-9][0-9]+°/
- exit 0 if {status}
- exit 2
-else if "{1}" == bench
- shift
- time {"parameters"} ">dev:null"
-end
diff --git a/test/Results/fib.out b/test/Results/fib.out
deleted file mode 100644
index 08c2ab3e02..0000000000
--- a/test/Results/fib.out
+++ /dev/null
@@ -1 +0,0 @@
-1346269
diff --git a/test/Results/genlex.runtest b/test/Results/genlex.runtest
deleted file mode 100644
index b9638e1f1b..0000000000
--- a/test/Results/genlex.runtest
+++ /dev/null
@@ -1,5 +0,0 @@
-case $1 in
- test) shift; $* Lex/testscanner.mll;;
- bench) shift; xtime -o /dev/null -e /dev/null -repeat 3 $* Lex/testscanner.mll;;
-esac
-
diff --git a/test/Results/genlex.runtest.Mac b/test/Results/genlex.runtest.Mac
deleted file mode 100644
index 26a11620b2..0000000000
--- a/test/Results/genlex.runtest.Mac
+++ /dev/null
@@ -1,7 +0,0 @@
-if "{1}" == test
- shift
- {parameters} :Lex:testscanner.mll
-else if "{1}" == bench
- shift
- time {"parameters"} :Lex:testscanner.mll "·dev:null"
-end
diff --git a/test/Results/hamming.out b/test/Results/hamming.out
deleted file mode 100644
index af1339ef5e..0000000000
--- a/test/Results/hamming.out
+++ /dev/null
@@ -1,100 +0,0 @@
-6726050156250000000000000000000000000
-6729216728661136606575523242669244416
-6730293634611118019721084375000000000
-6731430439413948088320000000000000000
-6733644878411293029785156250000000000
-6736815026358904613608094481682268160
-6739031236724077363200000000000000000
-6743282904874568941599068856042651648
-6744421903677486140423997176256921600
-6746640616477458432000000000000000000
-6750000000000000000000000000000000000
-6750897085400702945836103937453588480
-6752037370304563380023474956271616000
-6754258588364960445000000000000000000
-6755399441055744000000000000000000000
-6757621765136718750000000000000000000
-6758519863481752323552044362431792300
-6759661435938757375539248533340160000
-6761885162088395001166534423828125000
-6763027302973440000000000000000000000
-6765252136392518877983093261718750000
-6767294110289640371843415775641600000
-6768437164792816653010961694720000000
-6770663777894400000000000000000000000
-6774935403077748181101173538816000000
-6776079748261363229431903027200000000
-6778308875544000000000000000000000000
-6782585324034592562287109312160000000
-6783730961356018699387011072000000000
-6785962605658597412109375000000000000
-6789341568946838378906250000000000000
-6791390813820928754681118720000000000
-6794772480000000000000000000000000000
-6799059315411241693033267200000000000
-6800207735332289107722240000000000000
-6802444800000000000000000000000000000
-6806736475893120841673472000000000000
-6807886192552970708582400000000000000
-6810125783203125000000000000000000000
-6814422305043756994967597929687500000
-6815573319906622439424000000000000000
-6817815439391434192657470703125000000
-6821025214188390921278195662703296512
-6821210263296961784362792968750000000
-6823269127183128330240000000000000000
-6828727177473454717179297140960133120
-6830973624183426662400000000000000000
-6834375000000000000000000000000000000
-6835283298968211732659055236671758336
-6836437837433370422273768393225011200
-6838686820719522450562500000000000000
-6839841934068940800000000000000000000
-6842092037200927734375000000000000000
-6844157203887991842733489140006912000
-6845313241232438768082197309030400000
-6847565144260608000000000000000000000
-6849817788097425363957881927490234375
-6851885286668260876491458472837120000
-6853042629352726861173598715904000000
-6855297075118080000000000000000000000
-6859622095616220033364938208051200000
-6860780745114630269799801815040000000
-6863037736488300000000000000000000000
-6866455078125000000000000000000000000
-6867367640585024969315698178562000000
-6868527598372968933129348710400000000
-6870787138229329879760742187500000000
-6871947673600000000000000000000000000
-6874208338558673858642578125000000000
-6876283198993690364114632704000000000
-6879707136000000000000000000000000000
-6884047556853882214196183040000000000
-6885210332023942721568768000000000000
-6887475360000000000000000000000000000
-6891820681841784852194390400000000000
-6892984769959882842439680000000000000
-6895252355493164062500000000000000000
-6899602583856803957404692903808593750
-6900767986405455219916800000000000000
-6903038132383827120065689086914062500
-6906475391588173806667327880859375000
-6908559991272917434368000000000000000
-6912000000000000000000000000000000000
-6914086267191872901144038355222134784
-6916360794485719495680000000000000000
-6917529027641081856000000000000000000
-6919804687500000000000000000000000000
-6921893310401287552552190498140323840
-6924170405978516481194531250000000000
-6925339958244802560000000000000000000
-6927618187665939331054687500000000000
-6929709168936591740767657754256998400
-6930879656747844252683224775393280000
-6933159708563865600000000000000000000
-6937533852751614137447601703747584000
-6938705662219635946938268699852800000
-6940988288557056000000000000000000000
-6945367371811422783781999935651840000
-6946540504428563148172299337728000000
-6948825708194403750000000000000000000
diff --git a/test/Results/kb.out b/test/Results/kb.out
deleted file mode 100644
index 758a0b4d60..0000000000
--- a/test/Results/kb.out
+++ /dev/null
@@ -1,273 +0,0 @@
-1 : U*v1 = v1
-2 : I(v1)*v1 = U
-3 : (v3*v2)*v1 = v3*(v2*v1)
-4 : A*B = B*A
-5 : C*C = U
-6 : I(A) = C*(A*I(C))
-7 : C*(B*I(C)) = B
-8 : I(v2)*(v2*v1) = v1
-9 : A*(B*v1) = B*(A*v1)
-10 : C*(C*v1) = v1
-11 : C*(A*(I(C)*A)) = U
-12 : C*(B*(I(C)*v1)) = B*v1
-13 : I(U)*v1 = v1
-14 : I(I(v1))*U = v1
-15 : I(v3*v2)*(v3*(v2*v1)) = v1
-16 : C*(A*(I(C)*(B*A))) = B
-17 : I(C)*U = C
-18 : C*(A*(I(C)*(A*v1))) = v1
-19 : I(C)*B = B*I(C)
-20 : I(I(v2))*v1 = v2*v1
-Rule 14 deleted
-21 : v1*U = v1
-Rule 17 deleted
-22 : I(C) = C
-Rule 19 deleted
-Rule 18 deleted
-Rule 16 deleted
-Rule 12 deleted
-Rule 11 deleted
-Rule 7 deleted
-23 : C*B = B*C
-24 : C*(A*(C*(A*v1))) = v1
-25 : C*(A*(C*(B*A))) = B
-26 : C*(B*(C*v1)) = B*v1
-27 : C*(A*(C*A)) = U
-28 : C*(B*C) = B
-29 : C*(A*(C*(B*(A*v1)))) = B*v1
-30 : I(I(v2*v1)*v2) = v1
-31 : I(v2*I(v1))*v2 = v1
-32 : I(v4*(v3*v2))*(v4*(v3*(v2*v1))) = v1
-33 : I(v1*A)*(v1*(B*A)) = B
-34 : I(v1*C)*v1 = C
-35 : I(v3*I(v2))*(v3*v1) = v2*v1
-36 : I(v2*A)*(v2*(B*(A*v1))) = B*v1
-37 : I(v2*C)*(v2*v1) = C*v1
-38 : v1*I(v1) = U
-39 : I(C*(A*C))*v1 = A*v1
-40 : v2*(I(v2)*v1) = v1
-41 : I(U) = U
-Rule 13 deleted
-42 : I(I(v1)) = v1
-Rule 20 deleted
-43 : C*(B*v1) = B*(C*v1)
-Rule 29 deleted
-Rule 28 deleted
-Rule 26 deleted
-Rule 25 deleted
-44 : A*(C*(A*v1)) = C*v1
-Rule 24 deleted
-45 : A*(C*A) = C
-Rule 27 deleted
-46 : v2*(I(v1*v2)*v1) = U
-47 : I(I(v3*(v2*v1))*(v3*v2)) = v1
-48 : I(I(B*A)*A) = B
-49 : v3*(I(v2*v3)*(v2*v1)) = v1
-50 : I(I(v1)*I(v2)) = v2*v1
-51 : I(I(B*(A*v1))*A) = B*v1
-52 : I(I(v1)*C) = C*v1
-53 : I(v2*I(v1*v2)) = v1
-54 : I(v3*(v2*I(v1)))*(v3*v2) = v1
-55 : I(v1*(C*(A*C)))*v1 = A
-56 : v2*I(I(v1)*v2) = v1
-57 : I(v2*(I(v3*v1)*v3))*v2 = v1
-58 : I(v5*(v4*(v3*v2)))*(v5*(v4*(v3*(v2*v1)))) = v1
-59 : I(v2*(v1*A))*(v2*(v1*(B*A))) = B
-60 : I(v2*(v1*C))*(v2*v1) = C
-61 : I(v4*(v3*I(v2)))*(v4*(v3*v1)) = v2*v1
-62 : I(v3*(v2*A))*(v3*(v2*(B*(A*v1)))) = B*v1
-63 : I(v3*(v2*C))*(v3*(v2*v1)) = C*v1
-64 : I(v3*(I(v4*v2)*v4))*(v3*v1) = v2*v1
-65 : v4*(I(v3*(v2*v4))*(v3*(v2*v1))) = v1
-66 : I(I(B)*A)*A = B
-67 : I(A*A)*(B*(A*A)) = B
-68 : v1*(I(A*v1)*(B*A)) = B
-69 : I(I(v1*A)*(v1*B))*B = A
-70 : v1*I(C*v1) = C
-71 : I(A*I(v1))*(B*A) = v1*B
-72 : I(C*I(v1)) = v1*C
-73 : I(v2*(C*(A*C)))*(v2*v1) = A*v1
-74 : I(A*I(v2))*(B*(A*v1)) = v2*(B*v1)
-75 : v3*(I(I(v2)*v3)*v1) = v2*v1
-76 : I(I(B*I(v1))*A)*(v1*A) = B
-77 : I(v1*A)*(v1*(B*(B*A))) = B*B
-78 : I(I(B)*A)*(A*v1) = B*v1
-79 : I(A*A)*(B*(A*(A*v1))) = B*v1
-80 : I(v2*A)*(v2*(B*(B*(A*v1)))) = B*(B*v1)
-81 : v2*(I(A*v2)*(B*(A*v1))) = B*v1
-82 : I(I(v2*A)*(v2*B))*(B*v1) = A*v1
-83 : I(I(B*I(v2))*A)*(v2*(A*v1)) = B*v1
-84 : I(A*C)*(B*A) = B*C
-85 : I(A*C)*(B*(A*v1)) = B*(C*v1)
-86 : v2*(I(C*v2)*v1) = C*v1
-87 : I(I(B*C)*A)*(C*A) = B
-88 : I(I(B*C)*A)*(C*(A*v1)) = B*v1
-89 : v2*(v1*I(v2*v1)) = U
-90 : B*(A*I(B)) = A
-91 : I(v2*v1)*v2 = I(v1)
-Rule 64 deleted
-Rule 57 deleted
-Rule 55 deleted
-Rule 46 deleted
-Rule 34 deleted
-Rule 31 deleted
-Rule 30 deleted
-92 : I(C*(A*C)) = A
-Rule 39 deleted
-93 : I(v3*(v2*v1))*(v3*v2) = I(v1)
-Rule 60 deleted
-Rule 54 deleted
-Rule 47 deleted
-94 : I(v1*I(v2)) = v2*I(v1)
-Rule 83 deleted
-Rule 76 deleted
-Rule 74 deleted
-Rule 72 deleted
-Rule 71 deleted
-Rule 53 deleted
-Rule 50 deleted
-Rule 35 deleted
-95 : I(v2*(I(B)*A))*(v2*(A*v1)) = B*v1
-96 : I(v1*(I(B)*A))*(v1*A) = B
-97 : I(v1*A)*(v1*B) = B*(C*(A*C))
-Rule 82 deleted
-Rule 69 deleted
-98 : I(v1*C) = C*I(v1)
-Rule 88 deleted
-Rule 87 deleted
-Rule 85 deleted
-Rule 84 deleted
-Rule 52 deleted
-Rule 37 deleted
-99 : v3*(v2*(I(v3*v2)*v1)) = v1
-100 : B*(A*(I(B)*v1)) = A*v1
-101 : I(v3*v2)*(v3*v1) = I(v2)*v1
-Rule 97 deleted
-Rule 96 deleted
-Rule 95 deleted
-Rule 93 deleted
-Rule 80 deleted
-Rule 77 deleted
-Rule 73 deleted
-Rule 65 deleted
-Rule 63 deleted
-Rule 62 deleted
-Rule 61 deleted
-Rule 59 deleted
-Rule 58 deleted
-Rule 49 deleted
-Rule 36 deleted
-Rule 33 deleted
-Rule 32 deleted
-Rule 15 deleted
-102 : B*(C*I(B)) = C
-103 : B*(C*(I(B)*v1)) = C*v1
-104 : B*(I(B*A)*A) = U
-105 : B*(I(B*A)*(A*v1)) = v1
-106 : I(B*A)*A = I(B)
-Rule 104 deleted
-Rule 48 deleted
-107 : B*(v1*(I(B*(A*v1))*A)) = U
-108 : I(I(B*(B*A))*A) = B*B
-109 : B*(v2*(I(B*(A*v2))*(A*v1))) = v1
-110 : I(I(B*(B*(A*v1)))*A) = B*(B*v1)
-111 : I(I(B)*A) = B*(C*(A*C))
-Rule 78 deleted
-Rule 66 deleted
-112 : I(I(B*v1)*A) = B*(C*(A*(C*v1)))
-Rule 110 deleted
-Rule 108 deleted
-Rule 51 deleted
-113 : v3*(v2*I(I(v1)*(v3*v2))) = v1
-114 : v1*I(C*(A*(C*v1))) = A
-115 : I(I(v1)*v2) = I(v2)*v1
-Rule 113 deleted
-Rule 112 deleted
-Rule 111 deleted
-Rule 75 deleted
-Rule 56 deleted
-116 : v2*(v1*(I(A*(v2*v1))*(B*A))) = B
-117 : I(A*v1)*(B*A) = I(v1)*B
-Rule 116 deleted
-Rule 68 deleted
-118 : v2*(v1*I(C*(v2*v1))) = C
-119 : I(C*v1) = I(v1)*C
-Rule 118 deleted
-Rule 114 deleted
-Rule 92 deleted
-Rule 86 deleted
-Rule 70 deleted
-120 : v1*(I(A*(C*v1))*C) = A
-121 : I(A*A)*(B*(B*(A*A))) = B*B
-122 : I(A*A)*(B*(B*(A*(A*v1)))) = B*(B*v1)
-123 : I(A*A)*(B*(A*v1)) = B*(C*(A*(C*v1)))
-Rule 79 deleted
-Rule 67 deleted
-124 : v3*(v2*(I(A*(v3*v2))*(B*(A*v1)))) = B*v1
-125 : v1*(I(A*v1)*(B*(B*A))) = B*B
-126 : I(A*v2)*(B*(A*v1)) = I(v2)*(B*v1)
-Rule 124 deleted
-Rule 123 deleted
-Rule 81 deleted
-127 : v3*(v2*(v1*I(v3*(v2*v1)))) = U
-128 : v2*I(v1*v2) = I(v1)
-Rule 89 deleted
-129 : A*I(B) = I(B)*A
-Rule 90 deleted
-130 : I(v1*v2) = I(v2)*I(v1)
-Rule 128 deleted
-Rule 127 deleted
-Rule 126 deleted
-Rule 125 deleted
-Rule 122 deleted
-Rule 121 deleted
-Rule 120 deleted
-Rule 119 deleted
-Rule 117 deleted
-Rule 115 deleted
-Rule 109 deleted
-Rule 107 deleted
-Rule 106 deleted
-Rule 105 deleted
-Rule 101 deleted
-Rule 99 deleted
-Rule 98 deleted
-Rule 94 deleted
-Rule 91 deleted
-131 : B*(C*(A*(C*(I(B)*(A*v1))))) = v1
-132 : B*(C*(A*(C*(I(B)*A)))) = U
-133 : C*(A*(C*(I(B)*A))) = I(B)
-Rule 132 deleted
-134 : A*(I(B)*v1) = I(B)*(A*v1)
-Rule 100 deleted
-135 : C*I(B) = I(B)*C
-Rule 102 deleted
-136 : C*(I(B)*v1) = I(B)*(C*v1)
-Rule 133 deleted
-Rule 131 deleted
-Rule 103 deleted
-Canonical set found :
-1 : U*v1 = v1
-2 : I(v1)*v1 = U
-3 : (v3*v2)*v1 = v3*(v2*v1)
-4 : A*B = B*A
-5 : C*C = U
-6 : I(A) = C*(A*C)
-8 : I(v2)*(v2*v1) = v1
-9 : A*(B*v1) = B*(A*v1)
-10 : C*(C*v1) = v1
-21 : v1*U = v1
-22 : I(C) = C
-23 : C*B = B*C
-38 : v1*I(v1) = U
-40 : v2*(I(v2)*v1) = v1
-41 : I(U) = U
-42 : I(I(v1)) = v1
-43 : C*(B*v1) = B*(C*v1)
-44 : A*(C*(A*v1)) = C*v1
-45 : A*(C*A) = C
-129 : A*I(B) = I(B)*A
-130 : I(v1*v2) = I(v2)*I(v1)
-134 : A*(I(B)*v1) = I(B)*(A*v1)
-135 : C*I(B) = I(B)*C
-136 : C*(I(B)*v1) = I(B)*(C*v1)
diff --git a/test/Results/nucleic.out b/test/Results/nucleic.out
deleted file mode 100644
index 14689cdb97..0000000000
--- a/test/Results/nucleic.out
+++ /dev/null
@@ -1 +0,0 @@
-33.7976
diff --git a/test/Results/quicksort.fast.out b/test/Results/quicksort.fast.out
deleted file mode 100644
index 2c94e48371..0000000000
--- a/test/Results/quicksort.fast.out
+++ /dev/null
@@ -1,2 +0,0 @@
-OK
-OK
diff --git a/test/Results/quicksort.out b/test/Results/quicksort.out
deleted file mode 100644
index 2c94e48371..0000000000
--- a/test/Results/quicksort.out
+++ /dev/null
@@ -1,2 +0,0 @@
-OK
-OK
diff --git a/test/Results/runtest b/test/Results/runtest
deleted file mode 100644
index 08ccb468ff..0000000000
--- a/test/Results/runtest
+++ /dev/null
@@ -1 +0,0 @@
-$camlrun $1 | cmp - Results/$1.out
diff --git a/test/Results/sieve.out b/test/Results/sieve.out
deleted file mode 100644
index 8ca674d46f..0000000000
--- a/test/Results/sieve.out
+++ /dev/null
@@ -1 +0,0 @@
-2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 101 103 107 109 113 127 131 137 139 149 151 157 163 167 173 179 181 191 193 197 199 211 223 227 229 233 239 241 251 257 263 269 271 277 281 283 293 307 311 313 317 331 337 347 349 353 359 367 373 379 383 389 397 401 409 419 421 431 433 439 443 449 457 461 463 467 479 487 491 499 503 509 521 523 541 547 557 563 569 571 577 587 593 599 601 607 613 617 619 631 641 643 647 653 659 661 673 677 683 691 701 709 719 727 733 739 743 751 757 761 769 773 787 797 809 811 821 823 827 829 839 853 857 859 863 877 881 883 887 907 911 919 929 937 941 947 953 967 971 977 983 991 997 1009 1013 1019 1021 1031 1033 1039 1049 1051 1061 1063 1069 1087 1091 1093 1097 1103 1109 1117 1123 1129 1151 1153 1163 1171 1181 1187 1193 1201 1213 1217 1223 1229 1231 1237 1249 1259 1277 1279 1283 1289 1291 1297 1301 1303 1307 1319 1321 1327 1361 1367 1373 1381 1399 1409 1423 1427 1429 1433 1439 1447 1451 1453 1459 1471 1481 1483 1487 1489 1493 1499 1511 1523 1531 1543 1549 1553 1559 1567 1571 1579 1583 1597 1601 1607 1609 1613 1619 1621 1627 1637 1657 1663 1667 1669 1693 1697 1699 1709 1721 1723 1733 1741 1747 1753 1759 1777 1783 1787 1789 1801 1811 1823 1831 1847 1861 1867 1871 1873 1877 1879 1889 1901 1907 1913 1931 1933 1949 1951 1973 1979 1987 1993 1997 1999 2003 2011 2017 2027 2029 2039 2053 2063 2069 2081 2083 2087 2089 2099 2111 2113 2129 2131 2137 2141 2143 2153 2161 2179 2203 2207 2213 2221 2237 2239 2243 2251 2267 2269 2273 2281 2287 2293 2297 2309 2311 2333 2339 2341 2347 2351 2357 2371 2377 2381 2383 2389 2393 2399 2411 2417 2423 2437 2441 2447 2459 2467 2473 2477 2503 2521 2531 2539 2543 2549 2551 2557 2579 2591 2593 2609 2617 2621 2633 2647 2657 2659 2663 2671 2677 2683 2687 2689 2693 2699 2707 2711 2713 2719 2729 2731 2741 2749 2753 2767 2777 2789 2791 2797 2801 2803 2819 2833 2837 2843 2851 2857 2861 2879 2887 2897 2903 2909 2917 2927 2939 2953 2957 2963 2969 2971 2999 3001 3011 3019 3023 3037 3041 3049 3061 3067 3079 3083 3089 3109 3119 3121 3137 3163 3167 3169 3181 3187 3191 3203 3209 3217 3221 3229 3251 3253 3257 3259 3271 3299 3301 3307 3313 3319 3323 3329 3331 3343 3347 3359 3361 3371 3373 3389 3391 3407 3413 3433 3449 3457 3461 3463 3467 3469 3491 3499 3511 3517 3527 3529 3533 3539 3541 3547 3557 3559 3571 3581 3583 3593 3607 3613 3617 3623 3631 3637 3643 3659 3671 3673 3677 3691 3697 3701 3709 3719 3727 3733 3739 3761 3767 3769 3779 3793 3797 3803 3821 3823 3833 3847 3851 3853 3863 3877 3881 3889 3907 3911 3917 3919 3923 3929 3931 3943 3947 3967 3989 4001 4003 4007 4013 4019 4021 4027 4049 4051 4057 4073 4079 4091 4093 4099 4111 4127 4129 4133 4139 4153 4157 4159 4177 4201 4211 4217 4219 4229 4231 4241 4243 4253 4259 4261 4271 4273 4283 4289 4297 4327 4337 4339 4349 4357 4363 4373 4391 4397 4409 4421 4423 4441 4447 4451 4457 4463 4481 4483 4493 4507 4513 4517 4519 4523 4547 4549 4561 4567 4583 4591 4597 4603 4621 4637 4639 4643 4649 4651 4657 4663 4673 4679 4691 4703 4721 4723 4729 4733 4751 4759 4783 4787 4789 4793 4799 4801 4813 4817 4831 4861 4871 4877 4889 4903 4909 4919 4931 4933 4937 4943 4951 4957 4967 4969 4973 4987 4993 4999 5003 5009 5011 5021 5023 5039 5051 5059 5077 5081 5087 5099 5101 5107 5113 5119 5147 5153 5167 5171 5179 5189 5197 5209 5227 5231 5233 5237 5261 5273 5279 5281 5297 5303 5309 5323 5333 5347 5351 5381 5387 5393 5399 5407 5413 5417 5419 5431 5437 5441 5443 5449 5471 5477 5479 5483 5501 5503 5507 5519 5521 5527 5531 5557 5563 5569 5573 5581 5591 5623 5639 5641 5647 5651 5653 5657 5659 5669 5683 5689 5693 5701 5711 5717 5737 5741 5743 5749 5779 5783 5791 5801 5807 5813 5821 5827 5839 5843 5849 5851 5857 5861 5867 5869 5879 5881 5897 5903 5923 5927 5939 5953 5981 5987 6007 6011 6029 6037 6043 6047 6053 6067 6073 6079 6089 6091 6101 6113 6121 6131 6133 6143 6151 6163 6173 6197 6199 6203 6211 6217 6221 6229 6247 6257 6263 6269 6271 6277 6287 6299 6301 6311 6317 6323 6329 6337 6343 6353 6359 6361 6367 6373 6379 6389 6397 6421 6427 6449 6451 6469 6473 6481 6491 6521 6529 6547 6551 6553 6563 6569 6571 6577 6581 6599 6607 6619 6637 6653 6659 6661 6673 6679 6689 6691 6701 6703 6709 6719 6733 6737 6761 6763 6779 6781 6791 6793 6803 6823 6827 6829 6833 6841 6857 6863 6869 6871 6883 6899 6907 6911 6917 6947 6949 6959 6961 6967 6971 6977 6983 6991 6997 7001 7013 7019 7027 7039 7043 7057 7069 7079 7103 7109 7121 7127 7129 7151 7159 7177 7187 7193 7207 7211 7213 7219 7229 7237 7243 7247 7253 7283 7297 7307 7309 7321 7331 7333 7349 7351 7369 7393 7411 7417 7433 7451 7457 7459 7477 7481 7487 7489 7499 7507 7517 7523 7529 7537 7541 7547 7549 7559 7561 7573 7577 7583 7589 7591 7603 7607 7621 7639 7643 7649 7669 7673 7681 7687 7691 7699 7703 7717 7723 7727 7741 7753 7757 7759 7789 7793 7817 7823 7829 7841 7853 7867 7873 7877 7879 7883 7901 7907 7919 7927 7933 7937 7949 7951 7963 7993 8009 8011 8017 8039 8053 8059 8069 8081 8087 8089 8093 8101 8111 8117 8123 8147 8161 8167 8171 8179 8191 8209 8219 8221 8231 8233 8237 8243 8263 8269 8273 8287 8291 8293 8297 8311 8317 8329 8353 8363 8369 8377 8387 8389 8419 8423 8429 8431 8443 8447 8461 8467 8501 8513 8521 8527 8537 8539 8543 8563 8573 8581 8597 8599 8609 8623 8627 8629 8641 8647 8663 8669 8677 8681 8689 8693 8699 8707 8713 8719 8731 8737 8741 8747 8753 8761 8779 8783 8803 8807 8819 8821 8831 8837 8839 8849 8861 8863 8867 8887 8893 8923 8929 8933 8941 8951 8963 8969 8971 8999 9001 9007 9011 9013 9029 9041 9043 9049 9059 9067 9091 9103 9109 9127 9133 9137 9151 9157 9161 9173 9181 9187 9199 9203 9209 9221 9227 9239 9241 9257 9277 9281 9283 9293 9311 9319 9323 9337 9341 9343 9349 9371 9377 9391 9397 9403 9413 9419 9421 9431 9433 9437 9439 9461 9463 9467 9473 9479 9491 9497 9511 9521 9533 9539 9547 9551 9587 9601 9613 9619 9623 9629 9631 9643 9649 9661 9677 9679 9689 9697 9719 9721 9733 9739 9743 9749 9767 9769 9781 9787 9791 9803 9811 9817 9829 9833 9839 9851 9857 9859 9871 9883 9887 9901 9907 9923 9929 9931 9941 9949 9967 9973 10007 10009 10037 10039 10061 10067 10069 10079 10091 10093 10099 10103 10111 10133 10139 10141 10151 10159 10163 10169 10177 10181 10193 10211 10223 10243 10247 10253 10259 10267 10271 10273 10289 10301 10303 10313 10321 10331 10333 10337 10343 10357 10369 10391 10399 10427 10429 10433 10453 10457 10459 10463 10477 10487 10499 10501 10513 10529 10531 10559 10567 10589 10597 10601 10607 10613 10627 10631 10639 10651 10657 10663 10667 10687 10691 10709 10711 10723 10729 10733 10739 10753 10771 10781 10789 10799 10831 10837 10847 10853 10859 10861 10867 10883 10889 10891 10903 10909 10937 10939 10949 10957 10973 10979 10987 10993 11003 11027 11047 11057 11059 11069 11071 11083 11087 11093 11113 11117 11119 11131 11149 11159 11161 11171 11173 11177 11197 11213 11239 11243 11251 11257 11261 11273 11279 11287 11299 11311 11317 11321 11329 11351 11353 11369 11383 11393 11399 11411 11423 11437 11443 11447 11467 11471 11483 11489 11491 11497 11503 11519 11527 11549 11551 11579 11587 11593 11597 11617 11621 11633 11657 11677 11681 11689 11699 11701 11717 11719 11731 11743 11777 11779 11783 11789 11801 11807 11813 11821 11827 11831 11833 11839 11863 11867 11887 11897 11903 11909 11923 11927 11933 11939 11941 11953 11959 11969 11971 11981 11987 12007 12011 12037 12041 12043 12049 12071 12073 12097 12101 12107 12109 12113 12119 12143 12149 12157 12161 12163 12197 12203 12211 12227 12239 12241 12251 12253 12263 12269 12277 12281 12289 12301 12323 12329 12343 12347 12373 12377 12379 12391 12401 12409 12413 12421 12433 12437 12451 12457 12473 12479 12487 12491 12497 12503 12511 12517 12527 12539 12541 12547 12553 12569 12577 12583 12589 12601 12611 12613 12619 12637 12641 12647 12653 12659 12671 12689 12697 12703 12713 12721 12739 12743 12757 12763 12781 12791 12799 12809 12821 12823 12829 12841 12853 12889 12893 12899 12907 12911 12917 12919 12923 12941 12953 12959 12967 12973 12979 12983 13001 13003 13007 13009 13033 13037 13043 13049 13063 13093 13099 13103 13109 13121 13127 13147 13151 13159 13163 13171 13177 13183 13187 13217 13219 13229 13241 13249 13259 13267 13291 13297 13309 13313 13327 13331 13337 13339 13367 13381 13397 13399 13411 13417 13421 13441 13451 13457 13463 13469 13477 13487 13499 13513 13523 13537 13553 13567 13577 13591 13597 13613 13619 13627 13633 13649 13669 13679 13681 13687 13691 13693 13697 13709 13711 13721 13723 13729 13751 13757 13759 13763 13781 13789 13799 13807 13829 13831 13841 13859 13873 13877 13879 13883 13901 13903 13907 13913 13921 13931 13933 13963 13967 13997 13999 14009 14011 14029 14033 14051 14057 14071 14081 14083 14087 14107 14143 14149 14153 14159 14173 14177 14197 14207 14221 14243 14249 14251 14281 14293 14303 14321 14323 14327 14341 14347 14369 14387 14389 14401 14407 14411 14419 14423 14431 14437 14447 14449 14461 14479 14489 14503 14519 14533 14537 14543 14549 14551 14557 14561 14563 14591 14593 14621 14627 14629 14633 14639 14653 14657 14669 14683 14699 14713 14717 14723 14731 14737 14741 14747 14753 14759 14767 14771 14779 14783 14797 14813 14821 14827 14831 14843 14851 14867 14869 14879 14887 14891 14897 14923 14929 14939 14947 14951 14957 14969 14983 15013 15017 15031 15053 15061 15073 15077 15083 15091 15101 15107 15121 15131 15137 15139 15149 15161 15173 15187 15193 15199 15217 15227 15233 15241 15259 15263 15269 15271 15277 15287 15289 15299 15307 15313 15319 15329 15331 15349 15359 15361 15373 15377 15383 15391 15401 15413 15427 15439 15443 15451 15461 15467 15473 15493 15497 15511 15527 15541 15551 15559 15569 15581 15583 15601 15607 15619 15629 15641 15643 15647 15649 15661 15667 15671 15679 15683 15727 15731 15733 15737 15739 15749 15761 15767 15773 15787 15791 15797 15803 15809 15817 15823 15859 15877 15881 15887 15889 15901 15907 15913 15919 15923 15937 15959 15971 15973 15991 16001 16007 16033 16057 16061 16063 16067 16069 16073 16087 16091 16097 16103 16111 16127 16139 16141 16183 16187 16189 16193 16217 16223 16229 16231 16249 16253 16267 16273 16301 16319 16333 16339 16349 16361 16363 16369 16381 16411 16417 16421 16427 16433 16447 16451 16453 16477 16481 16487 16493 16519 16529 16547 16553 16561 16567 16573 16603 16607 16619 16631 16633 16649 16651 16657 16661 16673 16691 16693 16699 16703 16729 16741 16747 16759 16763 16787 16811 16823 16829 16831 16843 16871 16879 16883 16889 16901 16903 16921 16927 16931 16937 16943 16963 16979 16981 16987 16993 17011 17021 17027 17029 17033 17041 17047 17053 17077 17093 17099 17107 17117 17123 17137 17159 17167 17183 17189 17191 17203 17207 17209 17231 17239 17257 17291 17293 17299 17317 17321 17327 17333 17341 17351 17359 17377 17383 17387 17389 17393 17401 17417 17419 17431 17443 17449 17467 17471 17477 17483 17489 17491 17497 17509 17519 17539 17551 17569 17573 17579 17581 17597 17599 17609 17623 17627 17657 17659 17669 17681 17683 17707 17713 17729 17737 17747 17749 17761 17783 17789 17791 17807 17827 17837 17839 17851 17863 17881 17891 17903 17909 17911 17921 17923 17929 17939 17957 17959 17971 17977 17981 17987 17989 18013 18041 18043 18047 18049 18059 18061 18077 18089 18097 18119 18121 18127 18131 18133 18143 18149 18169 18181 18191 18199 18211 18217 18223 18229 18233 18251 18253 18257 18269 18287 18289 18301 18307 18311 18313 18329 18341 18353 18367 18371 18379 18397 18401 18413 18427 18433 18439 18443 18451 18457 18461 18481 18493 18503 18517 18521 18523 18539 18541 18553 18583 18587 18593 18617 18637 18661 18671 18679 18691 18701 18713 18719 18731 18743 18749 18757 18773 18787 18793 18797 18803 18839 18859 18869 18899 18911 18913 18917 18919 18947 18959 18973 18979 19001 19009 19013 19031 19037 19051 19069 19073 19079 19081 19087 19121 19139 19141 19157 19163 19181 19183 19207 19211 19213 19219 19231 19237 19249 19259 19267 19273 19289 19301 19309 19319 19333 19373 19379 19381 19387 19391 19403 19417 19421 19423 19427 19429 19433 19441 19447 19457 19463 19469 19471 19477 19483 19489 19501 19507 19531 19541 19543 19553 19559 19571 19577 19583 19597 19603 19609 19661 19681 19687 19697 19699 19709 19717 19727 19739 19751 19753 19759 19763 19777 19793 19801 19813 19819 19841 19843 19853 19861 19867 19889 19891 19913 19919 19927 19937 19949 19961 19963 19973 19979 19991 19993 19997 20011 20021 20023 20029 20047 20051 20063 20071 20089 20101 20107 20113 20117 20123 20129 20143 20147 20149 20161 20173 20177 20183 20201 20219 20231 20233 20249 20261 20269 20287 20297 20323 20327 20333 20341 20347 20353 20357 20359 20369 20389 20393 20399 20407 20411 20431 20441 20443 20477 20479 20483 20507 20509 20521 20533 20543 20549 20551 20563 20593 20599 20611 20627 20639 20641 20663 20681 20693 20707 20717 20719 20731 20743 20747 20749 20753 20759 20771 20773 20789 20807 20809 20849 20857 20873 20879 20887 20897 20899 20903 20921 20929 20939 20947 20959 20963 20981 20983 21001 21011 21013 21017 21019 21023 21031 21059 21061 21067 21089 21101 21107 21121 21139 21143 21149 21157 21163 21169 21179 21187 21191 21193 21211 21221 21227 21247 21269 21277 21283 21313 21317 21319 21323 21341 21347 21377 21379 21383 21391 21397 21401 21407 21419 21433 21467 21481 21487 21491 21493 21499 21503 21517 21521 21523 21529 21557 21559 21563 21569 21577 21587 21589 21599 21601 21611 21613 21617 21647 21649 21661 21673 21683 21701 21713 21727 21737 21739 21751 21757 21767 21773 21787 21799 21803 21817 21821 21839 21841 21851 21859 21863 21871 21881 21893 21911 21929 21937 21943 21961 21977 21991 21997 22003 22013 22027 22031 22037 22039 22051 22063 22067 22073 22079 22091 22093 22109 22111 22123 22129 22133 22147 22153 22157 22159 22171 22189 22193 22229 22247 22259 22271 22273 22277 22279 22283 22291 22303 22307 22343 22349 22367 22369 22381 22391 22397 22409 22433 22441 22447 22453 22469 22481 22483 22501 22511 22531 22541 22543 22549 22567 22571 22573 22613 22619 22621 22637 22639 22643 22651 22669 22679 22691 22697 22699 22709 22717 22721 22727 22739 22741 22751 22769 22777 22783 22787 22807 22811 22817 22853 22859 22861 22871 22877 22901 22907 22921 22937 22943 22961 22963 22973 22993 23003 23011 23017 23021 23027 23029 23039 23041 23053 23057 23059 23063 23071 23081 23087 23099 23117 23131 23143 23159 23167 23173 23189 23197 23201 23203 23209 23227 23251 23269 23279 23291 23293 23297 23311 23321 23327 23333 23339 23357 23369 23371 23399 23417 23431 23447 23459 23473 23497 23509 23531 23537 23539 23549 23557 23561 23563 23567 23581 23593 23599 23603 23609 23623 23627 23629 23633 23663 23669 23671 23677 23687 23689 23719 23741 23743 23747 23753 23761 23767 23773 23789 23801 23813 23819 23827 23831 23833 23857 23869 23873 23879 23887 23893 23899 23909 23911 23917 23929 23957 23971 23977 23981 23993 24001 24007 24019 24023 24029 24043 24049 24061 24071 24077 24083 24091 24097 24103 24107 24109 24113 24121 24133 24137 24151 24169 24179 24181 24197 24203 24223 24229 24239 24247 24251 24281 24317 24329 24337 24359 24371 24373 24379 24391 24407 24413 24419 24421 24439 24443 24469 24473 24481 24499 24509 24517 24527 24533 24547 24551 24571 24593 24611 24623 24631 24659 24671 24677 24683 24691 24697 24709 24733 24749 24763 24767 24781 24793 24799 24809 24821 24841 24847 24851 24859 24877 24889 24907 24917 24919 24923 24943 24953 24967 24971 24977 24979 24989 25013 25031 25033 25037 25057 25073 25087 25097 25111 25117 25121 25127 25147 25153 25163 25169 25171 25183 25189 25219 25229 25237 25243 25247 25253 25261 25301 25303 25307 25309 25321 25339 25343 25349 25357 25367 25373 25391 25409 25411 25423 25439 25447 25453 25457 25463 25469 25471 25523 25537 25541 25561 25577 25579 25583 25589 25601 25603 25609 25621 25633 25639 25643 25657 25667 25673 25679 25693 25703 25717 25733 25741 25747 25759 25763 25771 25793 25799 25801 25819 25841 25847 25849 25867 25873 25889 25903 25913 25919 25931 25933 25939 25943 25951 25969 25981 25997 25999 26003 26017 26021 26029 26041 26053 26083 26099 26107 26111 26113 26119 26141 26153 26161 26171 26177 26183 26189 26203 26209 26227 26237 26249 26251 26261 26263 26267 26293 26297 26309 26317 26321 26339 26347 26357 26371 26387 26393 26399 26407 26417 26423 26431 26437 26449 26459 26479 26489 26497 26501 26513 26539 26557 26561 26573 26591 26597 26627 26633 26641 26647 26669 26681 26683 26687 26693 26699 26701 26711 26713 26717 26723 26729 26731 26737 26759 26777 26783 26801 26813 26821 26833 26839 26849 26861 26863 26879 26881 26891 26893 26903 26921 26927 26947 26951 26953 26959 26981 26987 26993 27011 27017 27031 27043 27059 27061 27067 27073 27077 27091 27103 27107 27109 27127 27143 27179 27191 27197 27211 27239 27241 27253 27259 27271 27277 27281 27283 27299 27329 27337 27361 27367 27397 27407 27409 27427 27431 27437 27449 27457 27479 27481 27487 27509 27527 27529 27539 27541 27551 27581 27583 27611 27617 27631 27647 27653 27673 27689 27691 27697 27701 27733 27737 27739 27743 27749 27751 27763 27767 27773 27779 27791 27793 27799 27803 27809 27817 27823 27827 27847 27851 27883 27893 27901 27917 27919 27941 27943 27947 27953 27961 27967 27983 27997 28001 28019 28027 28031 28051 28057 28069 28081 28087 28097 28099 28109 28111 28123 28151 28163 28181 28183 28201 28211 28219 28229 28277 28279 28283 28289 28297 28307 28309 28319 28349 28351 28387 28393 28403 28409 28411 28429 28433 28439 28447 28463 28477 28493 28499 28513 28517 28537 28541 28547 28549 28559 28571 28573 28579 28591 28597 28603 28607 28619 28621 28627 28631 28643 28649 28657 28661 28663 28669 28687 28697 28703 28711 28723 28729 28751 28753 28759 28771 28789 28793 28807 28813 28817 28837 28843 28859 28867 28871 28879 28901 28909 28921 28927 28933 28949 28961 28979 29009 29017 29021 29023 29027 29033 29059 29063 29077 29101 29123 29129 29131 29137 29147 29153 29167 29173 29179 29191 29201 29207 29209 29221 29231 29243 29251 29269 29287 29297 29303 29311 29327 29333 29339 29347 29363 29383 29387 29389 29399 29401 29411 29423 29429 29437 29443 29453 29473 29483 29501 29527 29531 29537 29567 29569 29573 29581 29587 29599 29611 29629 29633 29641 29663 29669 29671 29683 29717 29723 29741 29753 29759 29761 29789 29803 29819 29833 29837 29851 29863 29867 29873 29879 29881 29917 29921 29927 29947 29959 29983 29989 30011 30013 30029 30047 30059 30071 30089 30091 30097 30103 30109 30113 30119 30133 30137 30139 30161 30169 30181 30187 30197 30203 30211 30223 30241 30253 30259 30269 30271 30293 30307 30313 30319 30323 30341 30347 30367 30389 30391 30403 30427 30431 30449 30467 30469 30491 30493 30497 30509 30517 30529 30539 30553 30557 30559 30577 30593 30631 30637 30643 30649 30661 30671 30677 30689 30697 30703 30707 30713 30727 30757 30763 30773 30781 30803 30809 30817 30829 30839 30841 30851 30853 30859 30869 30871 30881 30893 30911 30931 30937 30941 30949 30971 30977 30983 31013 31019 31033 31039 31051 31063 31069 31079 31081 31091 31121 31123 31139 31147 31151 31153 31159 31177 31181 31183 31189 31193 31219 31223 31231 31237 31247 31249 31253 31259 31267 31271 31277 31307 31319 31321 31327 31333 31337 31357 31379 31387 31391 31393 31397 31469 31477 31481 31489 31511 31513 31517 31531 31541 31543 31547 31567 31573 31583 31601 31607 31627 31643 31649 31657 31663 31667 31687 31699 31721 31723 31727 31729 31741 31751 31769 31771 31793 31799 31817 31847 31849 31859 31873 31883 31891 31907 31957 31963 31973 31981 31991 32003 32009 32027 32029 32051 32057 32059 32063 32069 32077 32083 32089 32099 32117 32119 32141 32143 32159 32173 32183 32189 32191 32203 32213 32233 32237 32251 32257 32261 32297 32299 32303 32309 32321 32323 32327 32341 32353 32359 32363 32369 32371 32377 32381 32401 32411 32413 32423 32429 32441 32443 32467 32479 32491 32497 32503 32507 32531 32533 32537 32561 32563 32569 32573 32579 32587 32603 32609 32611 32621 32633 32647 32653 32687 32693 32707 32713 32717 32719 32749 32771 32779 32783 32789 32797 32801 32803 32831 32833 32839 32843 32869 32887 32909 32911 32917 32933 32939 32941 32957 32969 32971 32983 32987 32993 32999 33013 33023 33029 33037 33049 33053 33071 33073 33083 33091 33107 33113 33119 33149 33151 33161 33179 33181 33191 33199 33203 33211 33223 33247 33287 33289 33301 33311 33317 33329 33331 33343 33347 33349 33353 33359 33377 33391 33403 33409 33413 33427 33457 33461 33469 33479 33487 33493 33503 33521 33529 33533 33547 33563 33569 33577 33581 33587 33589 33599 33601 33613 33617 33619 33623 33629 33637 33641 33647 33679 33703 33713 33721 33739 33749 33751 33757 33767 33769 33773 33791 33797 33809 33811 33827 33829 33851 33857 33863 33871 33889 33893 33911 33923 33931 33937 33941 33961 33967 33997 34019 34031 34033 34039 34057 34061 34123 34127 34129 34141 34147 34157 34159 34171 34183 34211 34213 34217 34231 34253 34259 34261 34267 34273 34283 34297 34301 34303 34313 34319 34327 34337 34351 34361 34367 34369 34381 34403 34421 34429 34439 34457 34469 34471 34483 34487 34499 34501 34511 34513 34519 34537 34543 34549 34583 34589 34591 34603 34607 34613 34631 34649 34651 34667 34673 34679 34687 34693 34703 34721 34729 34739 34747 34757 34759 34763 34781 34807 34819 34841 34843 34847 34849 34871 34877 34883 34897 34913 34919 34939 34949 34961 34963 34981 35023 35027 35051 35053 35059 35069 35081 35083 35089 35099 35107 35111 35117 35129 35141 35149 35153 35159 35171 35201 35221 35227 35251 35257 35267 35279 35281 35291 35311 35317 35323 35327 35339 35353 35363 35381 35393 35401 35407 35419 35423 35437 35447 35449 35461 35491 35507 35509 35521 35527 35531 35533 35537 35543 35569 35573 35591 35593 35597 35603 35617 35671 35677 35729 35731 35747 35753 35759 35771 35797 35801 35803 35809 35831 35837 35839 35851 35863 35869 35879 35897 35899 35911 35923 35933 35951 35963 35969 35977 35983 35993 35999 36007 36011 36013 36017 36037 36061 36067 36073 36083 36097 36107 36109 36131 36137 36151 36161 36187 36191 36209 36217 36229 36241 36251 36263 36269 36277 36293 36299 36307 36313 36319 36341 36343 36353 36373 36383 36389 36433 36451 36457 36467 36469 36473 36479 36493 36497 36523 36527 36529 36541 36551 36559 36563 36571 36583 36587 36599 36607 36629 36637 36643 36653 36671 36677 36683 36691 36697 36709 36713 36721 36739 36749 36761 36767 36779 36781 36787 36791 36793 36809 36821 36833 36847 36857 36871 36877 36887 36899 36901 36913 36919 36923 36929 36931 36943 36947 36973 36979 36997 37003 37013 37019 37021 37039 37049 37057 37061 37087 37097 37117 37123 37139 37159 37171 37181 37189 37199 37201 37217 37223 37243 37253 37273 37277 37307 37309 37313 37321 37337 37339 37357 37361 37363 37369 37379 37397 37409 37423 37441 37447 37463 37483 37489 37493 37501 37507 37511 37517 37529 37537 37547 37549 37561 37567 37571 37573 37579 37589 37591 37607 37619 37633 37643 37649 37657 37663 37691 37693 37699 37717 37747 37781 37783 37799 37811 37813 37831 37847 37853 37861 37871 37879 37889 37897 37907 37951 37957 37963 37967 37987 37991 37993 37997 38011 38039 38047 38053 38069 38083 38113 38119 38149 38153 38167 38177 38183 38189 38197 38201 38219 38231 38237 38239 38261 38273 38281 38287 38299 38303 38317 38321 38327 38329 38333 38351 38371 38377 38393 38431 38447 38449 38453 38459 38461 38501 38543 38557 38561 38567 38569 38593 38603 38609 38611 38629 38639 38651 38653 38669 38671 38677 38693 38699 38707 38711 38713 38723 38729 38737 38747 38749 38767 38783 38791 38803 38821 38833 38839 38851 38861 38867 38873 38891 38903 38917 38921 38923 38933 38953 38959 38971 38977 38993 39019 39023 39041 39043 39047 39079 39089 39097 39103 39107 39113 39119 39133 39139 39157 39161 39163 39181 39191 39199 39209 39217 39227 39229 39233 39239 39241 39251 39293 39301 39313 39317 39323 39341 39343 39359 39367 39371 39373 39383 39397 39409 39419 39439 39443 39451 39461 39499 39503 39509 39511 39521 39541 39551 39563 39569 39581 39607 39619 39623 39631 39659 39667 39671 39679 39703 39709 39719 39727 39733 39749 39761 39769 39779 39791 39799 39821 39827 39829 39839 39841 39847 39857 39863 39869 39877 39883 39887 39901 39929 39937 39953 39971 39979 39983 39989
diff --git a/test/Results/soli.fast.out b/test/Results/soli.fast.out
deleted file mode 100644
index b94045c39f..0000000000
--- a/test/Results/soli.fast.out
+++ /dev/null
@@ -1,50 +0,0 @@
-500
-1000
-1500
-2000
-2500
-3000
-3500
-4000
-4500
-5000
-5500
-6000
-6500
-7000
-7500
-8000
-8500
-9000
-9500
-10000
-10500
-11000
-11500
-12000
-12500
-13000
-13500
-14000
-14500
-15000
-15500
-16000
-16500
-17000
-17500
-18000
-18500
-19000
-19500
-20000
-
-.........
-... ...
-... ...
-. .
-. $ .
-. .
-... ...
-... ...
-.........
diff --git a/test/Results/soli.out b/test/Results/soli.out
deleted file mode 100644
index b94045c39f..0000000000
--- a/test/Results/soli.out
+++ /dev/null
@@ -1,50 +0,0 @@
-500
-1000
-1500
-2000
-2500
-3000
-3500
-4000
-4500
-5000
-5500
-6000
-6500
-7000
-7500
-8000
-8500
-9000
-9500
-10000
-10500
-11000
-11500
-12000
-12500
-13000
-13500
-14000
-14500
-15000
-15500
-16000
-16500
-17000
-17500
-18000
-18500
-19000
-19500
-20000
-
-.........
-... ...
-... ...
-. .
-. $ .
-. .
-... ...
-... ...
-.........
diff --git a/test/Results/sorts.out b/test/Results/sorts.out
deleted file mode 100644
index fa0cc04806..0000000000
--- a/test/Results/sorts.out
+++ /dev/null
@@ -1,198 +0,0 @@
-Command line arguments are:
-Testing List.sort...
- List.sort with constant ints
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- List.sort with sorted ints
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- List.sort with reverse-sorted ints
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- List.sort with random ints (many dups)
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- List.sort with random ints (few dups)
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- List.sort with records (str)
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- List.sort with records (int[1])
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- List.sort with records (int[10])
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- List.sort with records (int[100])
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- List.sort with records (int[1000])
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
-Testing List.stable_sort...
- List.stable_sort with constant ints
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- List.stable_sort with sorted ints
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- List.stable_sort with reverse-sorted ints
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- List.stable_sort with random ints (many dups)
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- List.stable_sort with random ints (few dups)
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- List.stable_sort with records (str)
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- List.stable_sort with records (int[1])
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- List.stable_sort with records (int[10])
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- List.stable_sort with records (int[100])
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- List.stable_sort with records (int[1000])
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- List.stable_sort with records (int[1]) [stable]
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- List.stable_sort with records (int[10]) [stable]
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- List.stable_sort with records (int[100]) [stable]
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- List.stable_sort with records (int[1000]) [stable]
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
-Testing Array.sort...
- Array.sort with constant ints
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- Array.sort with sorted ints
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- Array.sort with reverse-sorted ints
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- Array.sort with random ints (many dups)
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- Array.sort with random ints (few dups)
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- Array.sort with records (str)
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- Array.sort with records (int[1])
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- Array.sort with records (int[10])
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- Array.sort with records (int[100])
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- Array.sort with records (int[1000])
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
-Testing Array.stable_sort...
- Array.stable_sort with constant ints
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- Array.stable_sort with sorted ints
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- Array.stable_sort with reverse-sorted ints
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- Array.stable_sort with random ints (many dups)
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- Array.stable_sort with random ints (few dups)
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- Array.stable_sort with records (str)
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- Array.stable_sort with records (int[1])
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- Array.stable_sort with records (int[10])
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- Array.stable_sort with records (int[100])
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- Array.stable_sort with records (int[1000])
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- Array.stable_sort with records (int[1]) [stable]
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- Array.stable_sort with records (int[10]) [stable]
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- Array.stable_sort with records (int[100]) [stable]
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
- Array.stable_sort with records (int[1000]) [stable]
- 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11.
- 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000.
- 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
-Number of tests failed: 0
diff --git a/test/Results/takc.out b/test/Results/takc.out
deleted file mode 100644
index 0fecf6533b..0000000000
--- a/test/Results/takc.out
+++ /dev/null
@@ -1 +0,0 @@
-350
diff --git a/test/Results/taku.out b/test/Results/taku.out
deleted file mode 100644
index 0fecf6533b..0000000000
--- a/test/Results/taku.out
+++ /dev/null
@@ -1 +0,0 @@
-350
diff --git a/test/alloc.ml b/test/alloc.ml
deleted file mode 100644
index ea103e42af..0000000000
--- a/test/alloc.ml
+++ /dev/null
@@ -1,51 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Damien Doligez, projet Para, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Random allocation test *)
-
-(*
- Allocate arrays of strings, of random sizes in [0..1000[, and put them
- into an array of 32768. Replace a randomly-selected array with a new
- random-length array. Reiterate ad infinitum.
-*)
-
-let l = 32768;;
-let m = 1000;;
-
-let ar = Array.create l "";;
-
-Random.init 1234;;
-
-let compact_flag = ref false;;
-
-let main () =
- while true do
- for i = 1 to 100000 do
- ar.(Random.int l) <- String.create (Random.int m);
- done;
- if !compact_flag then Gc.compact () else Gc.full_major ();
- print_newline ();
- Gc.print_stat stdout;
- flush stdout;
- done
-;;
-
-let argspecs = [
- "-c", Arg.Set compact_flag, "do heap compactions";
-];;
-
-Arg.parse argspecs (fun _ -> ()) "Usage: alloc [-c]";;
-
-main ();;
-
diff --git a/test/almabench.ml b/test/almabench.ml
deleted file mode 100644
index f1dd10c909..0000000000
--- a/test/almabench.ml
+++ /dev/null
@@ -1,324 +0,0 @@
-(*
- * ALMABENCH 1.0.1
- * Objective Caml version
- *
- * A number-crunching benchmark designed for cross-language and vendor
- * comparisons.
- *
- * Written by Shawn Wagner, from Scott Robert Ladd's versions for
- * C++ and java.
- *
- * No rights reserved. This is public domain software, for use by anyone.
- *
- * This program calculates the daily ephemeris (at noon) for the years
- * 2000-2099 using an algorithm developed by J.L. Simon, P. Bretagnon, J.
- * Chapront, M. Chapront-Touze, G. Francou and J. Laskar of the Bureau des
- * Longitudes, Paris, France), as detailed in Astronomy & Astrophysics
- * 282, 663 (1994)
- *
- * Note that the code herein is design for the purpose of testing
- * computational performance; error handling and other such "niceties"
- * is virtually non-existent.
- *
- * Actual (and oft-updated) benchmark results can be found at:
- * http://www.coyotegulch.com
- *
- * Please do not use this information or algorithm in any way that might
- * upset the balance of the universe or otherwise cause planets to impact
- * upon one another.
- *)
-
-let pic = 3.14159265358979323846
-and j2000 = 2451545.0
-and jcentury = 36525.0
-and jmillenia = 365250.0
-
-let twopi = 2.0 *. pic
-and a2r = pic /. 648000.0
-and r2h = 12.0 /. pic
-and r2d = 180.0 /. pic
-and gaussk = 0.01720209895
-
-(* number of days to include in test *)
-let test_loops = 5 (* was: 20 *)
-and test_length = 36525
-
-(* sin and cos of j2000 mean obliquity (iau 1976) *)
-and sineps = 0.3977771559319137
-and coseps = 0.9174820620691818
-
-and amas = [| 6023600.0; 408523.5; 328900.5; 3098710.0; 1047.355; 3498.5; 22869.0; 19314.0 |]
-
-(*
- * tables giving the mean keplerian elements, limited to t**2 terms:
- * a semi-major axis (au)
- * dlm mean longitude (degree and arcsecond)
- * e eccentricity
- * pi longitude of the perihelion (degree and arcsecond)
- * dinc inclination (degree and arcsecond)
- * omega longitude of the ascending node (degree and arcsecond)
- *)
-and a = [|
- [| 0.3870983098; 0.0; 0.0 |];
- [| 0.7233298200; 0.0; 0.0 |];
- [| 1.0000010178; 0.0; 0.0 |];
- [| 1.5236793419; 3e-10; 0.0 |];
- [| 5.2026032092; 19132e-10; -39e-10 |];
- [| 9.5549091915; -0.0000213896; 444e-10 |];
- [| 19.2184460618; -3716e-10; 979e-10 |];
- [| 30.1103868694; -16635e-10; 686e-10 |] |]
-
-and dlm =
- [| [| 252.25090552; 5381016286.88982; -1.92789 |];
- [| 181.97980085; 2106641364.33548; 0.59381 |];
- [| 100.46645683; 1295977422.83429; -2.04411 |];
- [| 355.43299958; 689050774.93988; 0.94264 |];
- [| 34.35151874; 109256603.77991; -30.60378 |];
- [| 50.07744430; 43996098.55732; 75.61614 |];
- [| 314.05500511; 15424811.93933; -1.75083 |];
- [| 304.34866548; 7865503.20744; 0.21103 |] |]
-
-and e =
- [| [| 0.2056317526; 0.0002040653; -28349e-10 |];
- [| 0.0067719164; -0.0004776521; 98127e-10 |];
- [| 0.0167086342; -0.0004203654; -0.0000126734 |];
- [| 0.0934006477; 0.0009048438; -80641e-10 |];
- [| 0.0484979255; 0.0016322542; -0.0000471366 |];
- [| 0.0555481426; -0.0034664062; -0.0000643639 |];
- [| 0.0463812221; -0.0002729293; 0.0000078913 |];
- [| 0.0094557470; 0.0000603263; 0.0 |] |]
-
-and pi =
- [| [| 77.45611904; 5719.11590; -4.83016 |];
- [| 131.56370300; 175.48640; -498.48184 |];
- [| 102.93734808; 11612.35290; 53.27577 |];
- [| 336.06023395; 15980.45908; -62.32800 |];
- [| 14.33120687; 7758.75163; 259.95938 |];
- [| 93.05723748; 20395.49439; 190.25952 |];
- [| 173.00529106; 3215.56238; -34.09288 |];
- [| 48.12027554; 1050.71912; 27.39717 |] |]
-and dinc =
- [| [| 7.00498625; -214.25629; 0.28977 |];
- [| 3.39466189; -30.84437; -11.67836 |];
- [| 0.0; 469.97289; -3.35053 |];
- [| 1.84972648; -293.31722; -8.11830 |];
- [| 1.30326698; -71.55890; 11.95297 |];
- [| 2.48887878; 91.85195; -17.66225 |];
- [| 0.77319689; -60.72723; 1.25759 |];
- [| 1.76995259; 8.12333; 0.08135 |] |]
-
-and omega =
- [| [| 48.33089304; -4515.21727; -31.79892 |];
- [| 76.67992019; -10008.48154; -51.32614 |];
- [| 174.87317577; -8679.27034; 15.34191 |];
- [| 49.55809321; -10620.90088; -230.57416 |];
- [| 100.46440702; 6362.03561; 326.52178 |];
- [| 113.66550252; -9240.19942; -66.23743 |];
- [| 74.00595701; 2669.15033; 145.93964 |];
- [| 131.78405702; -221.94322; -0.78728 |] |]
-
-(* tables for trigonometric terms to be added to the mean elements
- of the semi-major axes. *)
-and kp =
- [| [| 69613.0; 75645.0; 88306.0; 59899.0; 15746.0; 71087.0; 142173.0; 3086.0; 0.0 |];
- [| 21863.0; 32794.0; 26934.0; 10931.0; 26250.0; 43725.0; 53867.0; 28939.0; 0.0 |];
- [| 16002.0; 21863.0; 32004.0; 10931.0; 14529.0; 16368.0; 15318.0; 32794.0; 0.0 |];
- [| 6345.0; 7818.0; 15636.0; 7077.0; 8184.0; 14163.0; 1107.0; 4872.0; 0.0 |];
- [| 1760.0; 1454.0; 1167.0; 880.0; 287.0; 2640.0; 19.0; 2047.0; 1454.0 |];
- [| 574.0; 0.0; 880.0; 287.0; 19.0; 1760.0; 1167.0; 306.0; 574.0 |];
- [| 204.0; 0.0; 177.0; 1265.0; 4.0; 385.0; 200.0; 208.0; 204.0 |];
- [| 0.0; 102.0; 106.0; 4.0; 98.0; 1367.0; 487.0; 204.0; 0.0 |] |]
-
-and ca =
- [| [| 4.0; -13.0; 11.0; -9.0; -9.0; -3.0; -1.0; 4.0; 0.0 |];
- [| -156.0; 59.0; -42.0; 6.0; 19.0; -20.0; -10.0; -12.0; 0.0 |];
- [| 64.0; -152.0; 62.0; -8.0; 32.0; -41.0; 19.0; -11.0; 0.0 |];
- [| 124.0; 621.0; -145.0; 208.0; 54.0; -57.0; 30.0; 15.0; 0.0 |];
- [| -23437.0; -2634.0; 6601.0; 6259.0; -1507.0; -1821.0; 2620.0; -2115.0;-1489.0 |];
- [| 62911.0;-119919.0; 79336.0; 17814.0;-24241.0; 12068.0; 8306.0; -4893.0; 8902.0 |];
- [| 389061.0;-262125.0;-44088.0; 8387.0;-22976.0; -2093.0; -615.0; -9720.0; 6633.0 |];
- [| -412235.0;-157046.0;-31430.0; 37817.0; -9740.0; -13.0; -7449.0; 9644.0; 0.0 |] |]
-
-and sa =
- [| [| -29.0; -1.0; 9.0; 6.0; -6.0; 5.0; 4.0; 0.0; 0.0 |];
- [| -48.0; -125.0; -26.0; -37.0; 18.0; -13.0; -20.0; -2.0; 0.0 |];
- [| -150.0; -46.0; 68.0; 54.0; 14.0; 24.0; -28.0; 22.0; 0.0 |];
- [| -621.0; 532.0; -694.0; -20.0; 192.0; -94.0; 71.0; -73.0; 0.0 |];
- [| -14614.0;-19828.0; -5869.0; 1881.0; -4372.0; -2255.0; 782.0; 930.0; 913.0 |];
- [| 139737.0; 0.0; 24667.0; 51123.0; -5102.0; 7429.0; -4095.0; -1976.0;-9566.0 |];
- [| -138081.0; 0.0; 37205.0;-49039.0;-41901.0;-33872.0;-27037.0;-12474.0;18797.0 |];
- [| 0.0; 28492.0;133236.0; 69654.0; 52322.0;-49577.0;-26430.0; -3593.0; 0.0 |] |]
-
-(* tables giving the trigonometric terms to be added to the mean elements of
- the mean longitudes . *)
-and kq =
- [| [| 3086.0; 15746.0; 69613.0; 59899.0; 75645.0; 88306.0; 12661.0; 2658.0; 0.0; 0.0 |];
- [| 21863.0; 32794.0; 10931.0; 73.0; 4387.0; 26934.0; 1473.0; 2157.0; 0.0; 0.0 |];
- [| 10.0; 16002.0; 21863.0; 10931.0; 1473.0; 32004.0; 4387.0; 73.0; 0.0; 0.0 |];
- [| 10.0; 6345.0; 7818.0; 1107.0; 15636.0; 7077.0; 8184.0; 532.0; 10.0; 0.0 |];
- [| 19.0; 1760.0; 1454.0; 287.0; 1167.0; 880.0; 574.0; 2640.0; 19.0;1454.0 |];
- [| 19.0; 574.0; 287.0; 306.0; 1760.0; 12.0; 31.0; 38.0; 19.0; 574.0 |];
- [| 4.0; 204.0; 177.0; 8.0; 31.0; 200.0; 1265.0; 102.0; 4.0; 204.0 |];
- [| 4.0; 102.0; 106.0; 8.0; 98.0; 1367.0; 487.0; 204.0; 4.0; 102.0 |] |]
-
-and cl =
- [| [| 21.0; -95.0; -157.0; 41.0; -5.0; 42.0; 23.0; 30.0; 0.0; 0.0 |];
- [| -160.0; -313.0; -235.0; 60.0; -74.0; -76.0; -27.0; 34.0; 0.0; 0.0 |];
- [| -325.0; -322.0; -79.0; 232.0; -52.0; 97.0; 55.0; -41.0; 0.0; 0.0 |];
- [| 2268.0; -979.0; 802.0; 602.0; -668.0; -33.0; 345.0; 201.0; -55.0; 0.0 |];
- [| 7610.0; -4997.0;-7689.0;-5841.0;-2617.0; 1115.0; -748.0; -607.0; 6074.0; 354.0 |];
- [| -18549.0; 30125.0;20012.0; -730.0; 824.0; 23.0; 1289.0; -352.0;-14767.0;-2062.0 |];
- [| -135245.0;-14594.0; 4197.0;-4030.0;-5630.0;-2898.0; 2540.0; -306.0; 2939.0; 1986.0 |];
- [| 89948.0; 2103.0; 8963.0; 2695.0; 3682.0; 1648.0; 866.0; -154.0; -1963.0; -283.0 |] |]
-
-and sl =
- [| [| -342.0; 136.0; -23.0; 62.0; 66.0; -52.0; -33.0; 17.0; 0.0; 0.0 |];
- [| 524.0; -149.0; -35.0; 117.0; 151.0; 122.0; -71.0; -62.0; 0.0; 0.0 |];
- [| -105.0; -137.0; 258.0; 35.0; -116.0; -88.0; -112.0; -80.0; 0.0; 0.0 |];
- [| 854.0; -205.0; -936.0; -240.0; 140.0; -341.0; -97.0; -232.0; 536.0; 0.0 |];
- [| -56980.0; 8016.0; 1012.0; 1448.0;-3024.0;-3710.0; 318.0; 503.0; 3767.0; 577.0 |];
- [| 138606.0;-13478.0;-4964.0; 1441.0;-1319.0;-1482.0; 427.0; 1236.0; -9167.0;-1918.0 |];
- [| 71234.0;-41116.0; 5334.0;-4935.0;-1848.0; 66.0; 434.0;-1748.0; 3780.0; -701.0 |];
- [| -47645.0; 11647.0; 2166.0; 3194.0; 679.0; 0.0; -244.0; -419.0; -2531.0; 48.0 |] |]
-
-
-(* Normalize angle into the range -pi <= A < +pi. *)
-let anpm a =
- let w = mod_float a twopi in
- if abs_float w >= pic then begin
- if a < 0.0 then
- w +. twopi
- else
- w -. twopi
- end else
- w
-
-(* The reference frame is equatorial and is with respect to the
- * mean equator and equinox of epoch j2000. *)
-let planetpv epoch np pv =
- (* time: julian millennia since j2000. *)
- let t = ((epoch.(0) -. j2000) +. epoch.(1)) /. jmillenia in
- (* compute the mean elements. *)
- let da = ref (a.(np).(0) +. (a.(np).(1) +. a.(np).(2) *. t ) *. t)
- and dl = ref ((3600.0 *. dlm.(np).(0) +. (dlm.(np).(1) +. dlm.(np).(2) *. t ) *. t) *. a2r)
- and de = e.(np).(0) +. (e.(np).(1) +. e.(np).(2) *. t ) *. t
- and dp = anpm ((3600.0 *. pi.(np).(0) +. (pi.(np).(1) +. pi.(np).(2) *. t ) *. t ) *. a2r )
- and di = (3600.0 *. dinc.(np).(0) +. (dinc.(np).(1) +. dinc.(np).(2) *. t ) *. t ) *. a2r
- and doh = anpm ((3600.0 *. omega.(np).(0) +. (omega.(np).(1) +. omega.(np).(2) *. t ) *. t ) *. a2r )
- (* apply the trigonometric terms. *)
- and dmu = 0.35953620 *. t in
-
- (* loop invariant *)
- let kp = kp.(np) and kq = kq.(np) and ca = ca.(np) and sa = sa.(np)
- and cl = cl.(np) and sl = sl.(np) in
- for k = 0 to 7 do
- let arga = kp.(k) *. dmu
- and argl = kq.(k) *. dmu in
- da := !da +. (ca.(k) *. cos arga +. sa.(k) *. sin arga) *. 0.0000001;
- dl := !dl +. (cl.(k) *. cos argl +. sl.(k) *. sin argl) *. 0.0000001
- done;
- begin let arga = kp.(8) *. dmu in
- da := !da +. t *. (ca.(8) *. cos arga +. sa.(8) *. sin arga ) *. 0.0000001;
- for k = 8 to 9 do
- let argl = kq.(k) *. dmu in
- dl := !dl +. t *. ( cl.(k) *. cos argl +. sl.(k) *. sin argl ) *. 0.0000001
- done;
- end;
-
-
- dl := mod_float !dl twopi;
-
- (* iterative solution of kepler's equation to get eccentric anomaly. *)
- let am = !dl -. dp in
- let ae = ref (am +. de *. sin am)
- and k = ref 0 in
- let dae = ref ((am -. !ae +. de *. sin !ae) /. (1.0 -. de *. cos !ae)) in
- ae := !ae +. !dae;
- incr k;
- while !k < 10 or abs_float !dae >= 1e-12 do
- dae := (am -. !ae +. de *. sin !ae) /. (1.0 -. de *. cos !ae);
- ae := !ae +. !dae;
- incr k
- done;
-
- (* true anomaly. *)
- let ae2 = !ae /. 2.0 in
- let at = 2.0 *. atan2 (sqrt ((1.0 +. de) /. (1.0 -. de)) *. sin ae2) (cos ae2)
- (* distance (au) and speed (radians per day). *)
- and r = !da *. (1.0 -. de *. cos !ae)
- and v = gaussk *. sqrt ((1.0 +. 1.0 /. amas.(np) ) /. (!da *. !da *. !da))
- and si2 = sin (di /. 2.0) in
- let xq = si2 *. cos doh
- and xp = si2 *. sin doh
- and tl = at +. dp in
- let xsw = sin tl
- and xcw = cos tl in
- let xm2 = 2.0 *. (xp *. xcw -. xq *. xsw )
- and xf = !da /. sqrt (1.0 -. de *. de)
- and ci2 = cos (di /. 2.0) in
- let xms = (de *. sin dp +. xsw) *. xf
- and xmc = (de *. cos dp +. xcw) *. xf
- and xpxq2 = 2.0 *. xp *. xq in
-
- (* position (j2000 ecliptic x,y,z in au). *)
- let x = r *. (xcw -. xm2 *. xp)
- and y = r *. (xsw +. xm2 *. xq)
- and z = r *. (-.xm2 *. ci2) in
-
- (* rotate to equatorial. *)
- pv.(0).(0) <- x;
- pv.(0).(1) <- y *. coseps -. z *. sineps;
- pv.(0).(2) <- y *. sineps +. z *. coseps;
-
- (* velocity (j2000 ecliptic xdot,ydot,zdot in au/d). *)
- let x = v *. ((-1.0 +. 2.0 *. xp *. xp) *. xms +. xpxq2 *. xmc)
- and y = v *. (( 1.0 -. 2.0 *. xq *. xq ) *. xmc -. xpxq2 *. xms)
- and z = v *. (2.0 *. ci2 *. (xp *. xms +. xq *. xmc)) in
-
- (* rotate to equatorial *)
- pv.(1).(0) <- x;
- pv.(1).(1) <- y *. coseps -. z *. sineps;
- pv.(1).(2) <- y *. sineps +. z *. coseps
-
-
-(* Computes RA, Declination, and distance from a state vector returned by
- * planetpv. *)
-let radecdist state rdd =
- (* Distance *)
- rdd.(2) <- sqrt (state.(0).(0) *. state.(0).(0)
- +. state.(0).(1) *. state.(0).(1)
- +. state.(0).(2) *. state.(0).(2));
- (* RA *)
- rdd.(0) <- atan2 state.(0).(1) state.(0).(0) *. r2h;
- if rdd.(0) < 0.0 then rdd.(0) <- rdd.(0) +. 24.0;
-
- (* Declination *)
- rdd.(1) <- asin (state.(0).(2) /. rdd.(2)) *. r2d
-
-
-
-(* Entry point. Calculate RA and Dec for noon on every day in 1900-2100 *)
-let _ =
- let jd = [| 0.0; 0.0 |]
- and pv = [| [| 0.0; 0.0; 0.0 |]; [| 0.0; 0.0; 0.0 |] |]
- and position = [| 0.0; 0.0; 0.0 |] in
- (* Test *)
- jd.(0) <- j2000;
- jd.(1) <- 1.0;
- for p = 0 to 7 do
- planetpv jd p pv;
- radecdist pv position;
- Printf.printf "%d %.2f %.2f\n" p position.(0) position.(1)
- done;
- (* Benchmark *)
- for i = 0 to test_loops - 1 do
- jd.(0) <- j2000;
- jd.(1) <- 0.0;
- for n = 0 to test_length - 1 do
- jd.(0) <- jd.(0) +. 1.0;
- for p = 0 to 7 do
- planetpv jd p pv;
- radecdist pv position;
- done
- done
- done
diff --git a/test/bdd.ml b/test/bdd.ml
deleted file mode 100644
index f47d51a2ee..0000000000
--- a/test/bdd.ml
+++ /dev/null
@@ -1,231 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Translated to Caml by Xavier Leroy *)
-(* Original code written in SML by ... *)
-
-type bdd = One | Zero | Node of bdd * int * int * bdd
-
-let rec eval bdd vars =
- match bdd with
- Zero -> false
- | One -> true
- | Node(l, v, _, h) ->
- if vars.(v) then eval h vars else eval l vars
-
-let getId bdd =
- match bdd with
- Node(_,_,id,_) -> id
- | Zero -> 0
- | One -> 1
-
-let initSize_1 = 8*1024 - 1
-let nodeC = ref 1
-let sz_1 = ref initSize_1
-let htab = ref(Array.create (!sz_1+1) [])
-let n_items = ref 0
-let hashVal x y v = x lsl 1 + y + v lsl 2
-
-let resize newSize =
- let arr = !htab in
- let newSz_1 = newSize-1 in
- let newArr = Array.create newSize [] in
- let rec copyBucket bucket =
- match bucket with
- [] -> ()
- | n :: ns ->
- match n with
- | Node(l,v,_,h) ->
- let ind = hashVal (getId l) (getId h) v land newSz_1
- in
- newArr.(ind) <- (n :: newArr.(ind));
- copyBucket ns
- | _ -> assert false
- in
- for n = 0 to !sz_1 do
- copyBucket(arr.(n))
- done;
- htab := newArr;
- sz_1 := newSz_1
-
-
-let rec insert idl idh v ind bucket newNode =
- if !n_items <= !sz_1
- then ( (!htab).(ind) <- (newNode :: bucket);
- incr n_items )
- else ( resize(!sz_1 + !sz_1 + 2);
- let ind = hashVal idl idh v land (!sz_1)
- in
- (!htab).(ind) <- newNode :: (!htab).(ind)
- )
-
-
-let resetUnique () = (
- sz_1 := initSize_1;
- htab := Array.create (!sz_1+1) [];
- n_items := 0;
- nodeC := 1
- )
-
-let mkNode low v high =
- let idl = getId low in
- let idh = getId high
- in
- if idl = idh
- then low
- else let ind = hashVal idl idh v land (!sz_1) in
- let bucket = (!htab).(ind) in
- let rec lookup b =
- match b with
- [] -> let n = Node(low, v, (incr nodeC; !nodeC), high)
- in
- insert (getId low) (getId high) v ind bucket n; n
- | n :: ns ->
- match n with
- | Node(l,v',id,h) ->
- if v = v' && idl = getId l && idh = getId h
- then n else lookup ns
- | _ -> assert false
- in
- lookup bucket
-
-
-type ordering = LESS | EQUAL | GREATER
-
-let cmpVar (x : int) (y : int) =
- if x<y then LESS else if x>y then GREATER else EQUAL
-
-let zero = Zero
-let one = One
-
-let mkVar x = mkNode zero x one
-
-
-let cacheSize = 1999
-let andslot1 = Array.create cacheSize 0
-let andslot2 = Array.create cacheSize 0
-let andslot3 = Array.create cacheSize zero
-let xorslot1 = Array.create cacheSize 0
-let xorslot2 = Array.create cacheSize 0
-let xorslot3 = Array.create cacheSize zero
-let notslot1 = Array.create cacheSize 0
-let notslot2 = Array.create cacheSize one
-let hash x y = ((x lsl 1)+y) mod cacheSize
-
-let rec not n =
-match n with
- Zero -> One
-| One -> Zero
-| Node(l, v, id, r) -> let h = id mod cacheSize
- in
- if id=notslot1.(h) then notslot2.(h)
- else let f = mkNode (not l) v (not r)
- in
- notslot1.(h) <- id; notslot2.(h) <- f; f
-
-let rec and2 n1 n2 =
-match n1 with
- Node(l1, v1, i1, r1)
- -> (match n2 with
- Node(l2, v2, i2, r2)
- -> let h = hash i1 i2
- in
- if i1=andslot1.(h) && i2=andslot2.(h) then andslot3.(h)
- else let f = match cmpVar v1 v2 with
- EQUAL -> mkNode (and2 l1 l2) v1 (and2 r1 r2)
- | LESS -> mkNode (and2 l1 n2) v1 (and2 r1 n2)
- | GREATER -> mkNode (and2 n1 l2) v2 (and2 n1 r2)
- in
- andslot1.(h) <- i1;
- andslot2.(h) <- i2;
- andslot3.(h) <- f;
- f
- | Zero -> Zero
- | One -> n1)
-| Zero -> Zero
-| One -> n2
-
-
-let rec xor n1 n2 =
-match n1 with
- Node(l1, v1, i1, r1)
- -> (match n2 with
- Node(l2, v2, i2, r2)
- -> let h = hash i1 i2
- in
- if i1=andslot1.(h) && i2=andslot2.(h) then andslot3.(h)
- else let f = match cmpVar v1 v2 with
- EQUAL -> mkNode (xor l1 l2) v1 (xor r1 r2)
- | LESS -> mkNode (xor l1 n2) v1 (xor r1 n2)
- | GREATER -> mkNode (xor n1 l2) v2 (xor n1 r2)
- in
- andslot1.(h) <- i1;
- andslot2.(h) <- i2;
- andslot3.(h) <- f;
- f
- | Zero -> n1
- | One -> not n1)
-| Zero -> n2
-| One -> not n2
-
-let hwb n =
- let rec h i j = if i=j
- then mkVar i
- else xor (and2 (not(mkVar j)) (h i (j-1)))
- (and2 (mkVar j) (g i (j-1)))
- and g i j = if i=j
- then mkVar i
- else xor (and2 (not(mkVar i)) (h (i+1) j))
- (and2 (mkVar i) (g (i+1) j))
- in
- h 0 (n-1)
-
-(* Testing *)
-let seed = ref 0
-
-let random() =
- seed := !seed * 25173 + 17431; !seed land 1 > 0
-
-let random_vars n =
- let vars = Array.create n false in
- for i = 0 to n - 1 do vars.(i) <- random() done;
- vars
-
-let test_hwb bdd vars =
- (* We should have
- eval bdd vars = vars.(n-1) if n > 0
- eval bdd vars = false if n = 0
- where n is the number of "true" elements in vars. *)
- let ntrue = ref 0 in
- for i = 0 to Array.length vars - 1 do
- if vars.(i) then incr ntrue
- done;
- eval bdd vars = (if !ntrue > 0 then vars.(!ntrue-1) else false)
-
-let main () =
- let n =
- if Array.length Sys.argv >= 2 then int_of_string Sys.argv.(1) else 20 in
- let ntests =
- if Array.length Sys.argv >= 3 then int_of_string Sys.argv.(2) else 50 in
- let bdd = hwb n in
- let succeeded = ref true in
- for i = 1 to ntests do
- succeeded := !succeeded && test_hwb bdd (random_vars n)
- done;
- if !succeeded
- then print_string "OK\n"
- else print_string "FAILED\n";
- exit 0
-
-let _ = main()
diff --git a/test/boyer.ml b/test/boyer.ml
deleted file mode 100644
index 3a55e03c17..0000000000
--- a/test/boyer.ml
+++ /dev/null
@@ -1,907 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Manipulations over terms *)
-
-type term =
- Var of int
- | Prop of head * term list
-and head =
- { name: string;
- mutable props: (term * term) list }
-
-let rec print_term = function
- Var v ->
- print_string "v"; print_int v
- | Prop (head,argl) ->
- print_string "(";
- print_string head.name;
- List.iter (fun t -> print_string " "; print_term t) argl;
- print_string ")"
-
-let lemmas = ref ([] : head list)
-
-(* Replacement for property lists *)
-
-let get name =
- let rec get_rec = function
- hd1::hdl ->
- if hd1.name = name then hd1 else get_rec hdl
- | [] ->
- let entry = {name = name; props = []} in
- lemmas := entry :: !lemmas;
- entry
- in get_rec !lemmas
-
-let add_lemma = function
- | Prop(_, [(Prop(headl,_) as left); right]) ->
- headl.props <- (left, right) :: headl.props
- | _ -> assert false
-
-(* Substitutions *)
-
-type subst = Bind of int * term
-
-let get_binding v list =
- let rec get_rec = function
- [] -> failwith "unbound"
- | Bind(w,t)::rest -> if v = w then t else get_rec rest
- in get_rec list
-
-let apply_subst alist term =
- let rec as_rec = function
- Var v -> begin try get_binding v alist with Failure _ -> term end
- | Prop (head,argl) -> Prop (head, List.map as_rec argl)
- in as_rec term
-
-exception Unify
-
-let rec unify term1 term2 =
- unify1 term1 term2 []
-
-and unify1 term1 term2 unify_subst =
- match term2 with
- Var v ->
- begin try
- if get_binding v unify_subst = term1
- then unify_subst
- else raise Unify
- with Failure _ ->
- Bind(v,term1) :: unify_subst
- end
- | Prop (head2, argl2) ->
- match term1 with
- Var _ -> raise Unify
- | Prop (head1,argl1) ->
- if head1 == head2
- then unify1_lst argl1 argl2 unify_subst
- else raise Unify
-
-and unify1_lst l1 l2 unify_subst =
- match (l1, l2) with
- ([], []) -> unify_subst
- | (h1::r1, h2::r2) -> unify1_lst r1 r2 (unify1 h1 h2 unify_subst)
- | _ -> raise Unify
-
-
-let rec rewrite = function
- Var _ as term -> term
- | Prop (head, argl) ->
- rewrite_with_lemmas (Prop (head, List.map rewrite argl)) head.props
-and rewrite_with_lemmas term lemmas =
- match lemmas with
- [] ->
- term
- | (t1,t2)::rest ->
- try
- rewrite (apply_subst (unify term t1) t2)
- with Unify ->
- rewrite_with_lemmas term rest
-
-type cterm = CVar of int | CProp of string * cterm list
-
-let rec cterm_to_term = function
- CVar v -> Var v
- | CProp(p, l) -> Prop(get p, List.map cterm_to_term l)
-
-let add t = add_lemma (cterm_to_term t)
-
-let _ =
-add (CProp
-("equal",
- [CProp ("compile",[CVar 5]);
- CProp
- ("reverse",
- [CProp ("codegen",[CProp ("optimize",[CVar 5]); CProp ("nil",[])])])]));
-add (CProp
-("equal",
- [CProp ("eqp",[CVar 23; CVar 24]);
- CProp ("equal",[CProp ("fix",[CVar 23]); CProp ("fix",[CVar 24])])]));
-add (CProp
-("equal",
- [CProp ("gt",[CVar 23; CVar 24]); CProp ("lt",[CVar 24; CVar 23])]));
-add (CProp
-("equal",
- [CProp ("le",[CVar 23; CVar 24]); CProp ("ge",[CVar 24; CVar 23])]));
-add (CProp
-("equal",
- [CProp ("ge",[CVar 23; CVar 24]); CProp ("le",[CVar 24; CVar 23])]));
-add (CProp
-("equal",
- [CProp ("boolean",[CVar 23]);
- CProp
- ("or",
- [CProp ("equal",[CVar 23; CProp ("true",[])]);
- CProp ("equal",[CVar 23; CProp ("false",[])])])]));
-add (CProp
-("equal",
- [CProp ("iff",[CVar 23; CVar 24]);
- CProp
- ("and",
- [CProp ("implies",[CVar 23; CVar 24]);
- CProp ("implies",[CVar 24; CVar 23])])]));
-add (CProp
-("equal",
- [CProp ("even1",[CVar 23]);
- CProp
- ("if",
- [CProp ("zerop",[CVar 23]); CProp ("true",[]);
- CProp ("odd",[CProp ("sub1",[CVar 23])])])]));
-add (CProp
-("equal",
- [CProp ("countps_",[CVar 11; CVar 15]);
- CProp ("countps_loop",[CVar 11; CVar 15; CProp ("zero",[])])]));
-add (CProp
-("equal",
- [CProp ("fact_",[CVar 8]);
- CProp ("fact_loop",[CVar 8; CProp ("one",[])])]));
-add (CProp
-("equal",
- [CProp ("reverse_",[CVar 23]);
- CProp ("reverse_loop",[CVar 23; CProp ("nil",[])])]));
-add (CProp
-("equal",
- [CProp ("divides",[CVar 23; CVar 24]);
- CProp ("zerop",[CProp ("remainder",[CVar 24; CVar 23])])]));
-add (CProp
-("equal",
- [CProp ("assume_true",[CVar 21; CVar 0]);
- CProp ("cons",[CProp ("cons",[CVar 21; CProp ("true",[])]); CVar 0])]));
-add (CProp
-("equal",
- [CProp ("assume_false",[CVar 21; CVar 0]);
- CProp ("cons",[CProp ("cons",[CVar 21; CProp ("false",[])]); CVar 0])]));
-add (CProp
-("equal",
- [CProp ("tautology_checker",[CVar 23]);
- CProp ("tautologyp",[CProp ("normalize",[CVar 23]); CProp ("nil",[])])]));
-add (CProp
-("equal",
- [CProp ("falsify",[CVar 23]);
- CProp ("falsify1",[CProp ("normalize",[CVar 23]); CProp ("nil",[])])]));
-add (CProp
-("equal",
- [CProp ("prime",[CVar 23]);
- CProp
- ("and",
- [CProp ("not",[CProp ("zerop",[CVar 23])]);
- CProp
- ("not",
- [CProp ("equal",[CVar 23; CProp ("add1",[CProp ("zero",[])])])]);
- CProp ("prime1",[CVar 23; CProp ("sub1",[CVar 23])])])]));
-add (CProp
-("equal",
- [CProp ("and",[CVar 15; CVar 16]);
- CProp
- ("if",
- [CVar 15;
- CProp ("if",[CVar 16; CProp ("true",[]); CProp ("false",[])]);
- CProp ("false",[])])]));
-add (CProp
-("equal",
- [CProp ("or",[CVar 15; CVar 16]);
- CProp
- ("if",
- [CVar 15; CProp ("true",[]);
- CProp ("if",[CVar 16; CProp ("true",[]); CProp ("false",[])]);
- CProp ("false",[])])]));
-add (CProp
-("equal",
- [CProp ("not",[CVar 15]);
- CProp ("if",[CVar 15; CProp ("false",[]); CProp ("true",[])])]));
-add (CProp
-("equal",
- [CProp ("implies",[CVar 15; CVar 16]);
- CProp
- ("if",
- [CVar 15;
- CProp ("if",[CVar 16; CProp ("true",[]); CProp ("false",[])]);
- CProp ("true",[])])]));
-add (CProp
-("equal",
- [CProp ("fix",[CVar 23]);
- CProp ("if",[CProp ("numberp",[CVar 23]); CVar 23; CProp ("zero",[])])]));
-add (CProp
-("equal",
- [CProp ("if",[CProp ("if",[CVar 0; CVar 1; CVar 2]); CVar 3; CVar 4]);
- CProp
- ("if",
- [CVar 0; CProp ("if",[CVar 1; CVar 3; CVar 4]);
- CProp ("if",[CVar 2; CVar 3; CVar 4])])]));
-add (CProp
-("equal",
- [CProp ("zerop",[CVar 23]);
- CProp
- ("or",
- [CProp ("equal",[CVar 23; CProp ("zero",[])]);
- CProp ("not",[CProp ("numberp",[CVar 23])])])]));
-add (CProp
-("equal",
- [CProp ("plus",[CProp ("plus",[CVar 23; CVar 24]); CVar 25]);
- CProp ("plus",[CVar 23; CProp ("plus",[CVar 24; CVar 25])])]));
-add (CProp
-("equal",
- [CProp ("equal",[CProp ("plus",[CVar 0; CVar 1]); CProp ("zero",[])]);
- CProp ("and",[CProp ("zerop",[CVar 0]); CProp ("zerop",[CVar 1])])]));
-add (CProp
-("equal",[CProp ("difference",[CVar 23; CVar 23]); CProp ("zero",[])]));
-add (CProp
-("equal",
- [CProp
- ("equal",
- [CProp ("plus",[CVar 0; CVar 1]); CProp ("plus",[CVar 0; CVar 2])]);
- CProp ("equal",[CProp ("fix",[CVar 1]); CProp ("fix",[CVar 2])])]));
-add (CProp
-("equal",
- [CProp
- ("equal",[CProp ("zero",[]); CProp ("difference",[CVar 23; CVar 24])]);
- CProp ("not",[CProp ("gt",[CVar 24; CVar 23])])]));
-add (CProp
-("equal",
- [CProp ("equal",[CVar 23; CProp ("difference",[CVar 23; CVar 24])]);
- CProp
- ("and",
- [CProp ("numberp",[CVar 23]);
- CProp
- ("or",
- [CProp ("equal",[CVar 23; CProp ("zero",[])]);
- CProp ("zerop",[CVar 24])])])]));
-add (CProp
-("equal",
- [CProp
- ("meaning",
- [CProp ("plus_tree",[CProp ("append",[CVar 23; CVar 24])]); CVar 0]);
- CProp
- ("plus",
- [CProp ("meaning",[CProp ("plus_tree",[CVar 23]); CVar 0]);
- CProp ("meaning",[CProp ("plus_tree",[CVar 24]); CVar 0])])]));
-add (CProp
-("equal",
- [CProp
- ("meaning",
- [CProp ("plus_tree",[CProp ("plus_fringe",[CVar 23])]); CVar 0]);
- CProp ("fix",[CProp ("meaning",[CVar 23; CVar 0])])]));
-add (CProp
-("equal",
- [CProp ("append",[CProp ("append",[CVar 23; CVar 24]); CVar 25]);
- CProp ("append",[CVar 23; CProp ("append",[CVar 24; CVar 25])])]));
-add (CProp
-("equal",
- [CProp ("reverse",[CProp ("append",[CVar 0; CVar 1])]);
- CProp
- ("append",[CProp ("reverse",[CVar 1]); CProp ("reverse",[CVar 0])])]));
-add (CProp
-("equal",
- [CProp ("times",[CVar 23; CProp ("plus",[CVar 24; CVar 25])]);
- CProp
- ("plus",
- [CProp ("times",[CVar 23; CVar 24]);
- CProp ("times",[CVar 23; CVar 25])])]));
-add (CProp
-("equal",
- [CProp ("times",[CProp ("times",[CVar 23; CVar 24]); CVar 25]);
- CProp ("times",[CVar 23; CProp ("times",[CVar 24; CVar 25])])]));
-add (CProp
-("equal",
- [CProp
- ("equal",[CProp ("times",[CVar 23; CVar 24]); CProp ("zero",[])]);
- CProp ("or",[CProp ("zerop",[CVar 23]); CProp ("zerop",[CVar 24])])]));
-add (CProp
-("equal",
- [CProp ("exec",[CProp ("append",[CVar 23; CVar 24]); CVar 15; CVar 4]);
- CProp
- ("exec",[CVar 24; CProp ("exec",[CVar 23; CVar 15; CVar 4]); CVar 4])]));
-add (CProp
-("equal",
- [CProp ("mc_flatten",[CVar 23; CVar 24]);
- CProp ("append",[CProp ("flatten",[CVar 23]); CVar 24])]));
-add (CProp
-("equal",
- [CProp ("member",[CVar 23; CProp ("append",[CVar 0; CVar 1])]);
- CProp
- ("or",
- [CProp ("member",[CVar 23; CVar 0]);
- CProp ("member",[CVar 23; CVar 1])])]));
-add (CProp
-("equal",
- [CProp ("member",[CVar 23; CProp ("reverse",[CVar 24])]);
- CProp ("member",[CVar 23; CVar 24])]));
-add (CProp
-("equal",
- [CProp ("length",[CProp ("reverse",[CVar 23])]);
- CProp ("length",[CVar 23])]));
-add (CProp
-("equal",
- [CProp ("member",[CVar 0; CProp ("intersect",[CVar 1; CVar 2])]);
- CProp
- ("and",
- [CProp ("member",[CVar 0; CVar 1]); CProp ("member",[CVar 0; CVar 2])])]));
-add (CProp
-("equal",[CProp ("nth",[CProp ("zero",[]); CVar 8]); CProp ("zero",[])]));
-add (CProp
-("equal",
- [CProp ("exp",[CVar 8; CProp ("plus",[CVar 9; CVar 10])]);
- CProp
- ("times",
- [CProp ("exp",[CVar 8; CVar 9]); CProp ("exp",[CVar 8; CVar 10])])]));
-add (CProp
-("equal",
- [CProp ("exp",[CVar 8; CProp ("times",[CVar 9; CVar 10])]);
- CProp ("exp",[CProp ("exp",[CVar 8; CVar 9]); CVar 10])]));
-add (CProp
-("equal",
- [CProp ("reverse_loop",[CVar 23; CVar 24]);
- CProp ("append",[CProp ("reverse",[CVar 23]); CVar 24])]));
-add (CProp
-("equal",
- [CProp ("reverse_loop",[CVar 23; CProp ("nil",[])]);
- CProp ("reverse",[CVar 23])]));
-add (CProp
-("equal",
- [CProp ("count_list",[CVar 25; CProp ("sort_lp",[CVar 23; CVar 24])]);
- CProp
- ("plus",
- [CProp ("count_list",[CVar 25; CVar 23]);
- CProp ("count_list",[CVar 25; CVar 24])])]));
-add (CProp
-("equal",
- [CProp
- ("equal",
- [CProp ("append",[CVar 0; CVar 1]); CProp ("append",[CVar 0; CVar 2])]);
- CProp ("equal",[CVar 1; CVar 2])]));
-add (CProp
-("equal",
- [CProp
- ("plus",
- [CProp ("remainder",[CVar 23; CVar 24]);
- CProp ("times",[CVar 24; CProp ("quotient",[CVar 23; CVar 24])])]);
- CProp ("fix",[CVar 23])]));
-add (CProp
-("equal",
- [CProp
- ("power_eval",[CProp ("big_plus",[CVar 11; CVar 8; CVar 1]); CVar 1]);
- CProp ("plus",[CProp ("power_eval",[CVar 11; CVar 1]); CVar 8])]));
-add (CProp
-("equal",
- [CProp
- ("power_eval",
- [CProp ("big_plus",[CVar 23; CVar 24; CVar 8; CVar 1]); CVar 1]);
- CProp
- ("plus",
- [CVar 8;
- CProp
- ("plus",
- [CProp ("power_eval",[CVar 23; CVar 1]);
- CProp ("power_eval",[CVar 24; CVar 1])])])]));
-add (CProp
-("equal",
- [CProp ("remainder",[CVar 24; CProp ("one",[])]); CProp ("zero",[])]));
-add (CProp
-("equal",
- [CProp ("lt",[CProp ("remainder",[CVar 23; CVar 24]); CVar 24]);
- CProp ("not",[CProp ("zerop",[CVar 24])])]));
-add (CProp
-("equal",[CProp ("remainder",[CVar 23; CVar 23]); CProp ("zero",[])]));
-add (CProp
-("equal",
- [CProp ("lt",[CProp ("quotient",[CVar 8; CVar 9]); CVar 8]);
- CProp
- ("and",
- [CProp ("not",[CProp ("zerop",[CVar 8])]);
- CProp
- ("or",
- [CProp ("zerop",[CVar 9]);
- CProp ("not",[CProp ("equal",[CVar 9; CProp ("one",[])])])])])]));
-add (CProp
-("equal",
- [CProp ("lt",[CProp ("remainder",[CVar 23; CVar 24]); CVar 23]);
- CProp
- ("and",
- [CProp ("not",[CProp ("zerop",[CVar 24])]);
- CProp ("not",[CProp ("zerop",[CVar 23])]);
- CProp ("not",[CProp ("lt",[CVar 23; CVar 24])])])]));
-add (CProp
-("equal",
- [CProp ("power_eval",[CProp ("power_rep",[CVar 8; CVar 1]); CVar 1]);
- CProp ("fix",[CVar 8])]));
-add (CProp
-("equal",
- [CProp
- ("power_eval",
- [CProp
- ("big_plus",
- [CProp ("power_rep",[CVar 8; CVar 1]);
- CProp ("power_rep",[CVar 9; CVar 1]); CProp ("zero",[]);
- CVar 1]);
- CVar 1]);
- CProp ("plus",[CVar 8; CVar 9])]));
-add (CProp
-("equal",
- [CProp ("gcd",[CVar 23; CVar 24]); CProp ("gcd",[CVar 24; CVar 23])]));
-add (CProp
-("equal",
- [CProp ("nth",[CProp ("append",[CVar 0; CVar 1]); CVar 8]);
- CProp
- ("append",
- [CProp ("nth",[CVar 0; CVar 8]);
- CProp
- ("nth",
- [CVar 1; CProp ("difference",[CVar 8; CProp ("length",[CVar 0])])])])]));
-add (CProp
-("equal",
- [CProp ("difference",[CProp ("plus",[CVar 23; CVar 24]); CVar 23]);
- CProp ("fix",[CVar 24])]));
-add (CProp
-("equal",
- [CProp ("difference",[CProp ("plus",[CVar 24; CVar 23]); CVar 23]);
- CProp ("fix",[CVar 24])]));
-add (CProp
-("equal",
- [CProp
- ("difference",
- [CProp ("plus",[CVar 23; CVar 24]); CProp ("plus",[CVar 23; CVar 25])]);
- CProp ("difference",[CVar 24; CVar 25])]));
-add (CProp
-("equal",
- [CProp ("times",[CVar 23; CProp ("difference",[CVar 2; CVar 22])]);
- CProp
- ("difference",
- [CProp ("times",[CVar 2; CVar 23]);
- CProp ("times",[CVar 22; CVar 23])])]));
-add (CProp
-("equal",
- [CProp ("remainder",[CProp ("times",[CVar 23; CVar 25]); CVar 25]);
- CProp ("zero",[])]));
-add (CProp
-("equal",
- [CProp
- ("difference",
- [CProp ("plus",[CVar 1; CProp ("plus",[CVar 0; CVar 2])]); CVar 0]);
- CProp ("plus",[CVar 1; CVar 2])]));
-add (CProp
-("equal",
- [CProp
- ("difference",
- [CProp ("add1",[CProp ("plus",[CVar 24; CVar 25])]); CVar 25]);
- CProp ("add1",[CVar 24])]));
-add (CProp
-("equal",
- [CProp
- ("lt",
- [CProp ("plus",[CVar 23; CVar 24]); CProp ("plus",[CVar 23; CVar 25])]);
- CProp ("lt",[CVar 24; CVar 25])]));
-add (CProp
-("equal",
- [CProp
- ("lt",
- [CProp ("times",[CVar 23; CVar 25]);
- CProp ("times",[CVar 24; CVar 25])]);
- CProp
- ("and",
- [CProp ("not",[CProp ("zerop",[CVar 25])]);
- CProp ("lt",[CVar 23; CVar 24])])]));
-add (CProp
-("equal",
- [CProp ("lt",[CVar 24; CProp ("plus",[CVar 23; CVar 24])]);
- CProp ("not",[CProp ("zerop",[CVar 23])])]));
-add (CProp
-("equal",
- [CProp
- ("gcd",
- [CProp ("times",[CVar 23; CVar 25]);
- CProp ("times",[CVar 24; CVar 25])]);
- CProp ("times",[CVar 25; CProp ("gcd",[CVar 23; CVar 24])])]));
-add (CProp
-("equal",
- [CProp ("value",[CProp ("normalize",[CVar 23]); CVar 0]);
- CProp ("value",[CVar 23; CVar 0])]));
-add (CProp
-("equal",
- [CProp
- ("equal",
- [CProp ("flatten",[CVar 23]);
- CProp ("cons",[CVar 24; CProp ("nil",[])])]);
- CProp
- ("and",
- [CProp ("nlistp",[CVar 23]); CProp ("equal",[CVar 23; CVar 24])])]));
-add (CProp
-("equal",
- [CProp ("listp",[CProp ("gother",[CVar 23])]);
- CProp ("listp",[CVar 23])]));
-add (CProp
-("equal",
- [CProp ("samefringe",[CVar 23; CVar 24]);
- CProp
- ("equal",[CProp ("flatten",[CVar 23]); CProp ("flatten",[CVar 24])])]));
-add (CProp
-("equal",
- [CProp
- ("equal",
- [CProp ("greatest_factor",[CVar 23; CVar 24]); CProp ("zero",[])]);
- CProp
- ("and",
- [CProp
- ("or",
- [CProp ("zerop",[CVar 24]);
- CProp ("equal",[CVar 24; CProp ("one",[])])]);
- CProp ("equal",[CVar 23; CProp ("zero",[])])])]));
-add (CProp
-("equal",
- [CProp
- ("equal",
- [CProp ("greatest_factor",[CVar 23; CVar 24]); CProp ("one",[])]);
- CProp ("equal",[CVar 23; CProp ("one",[])])]));
-add (CProp
-("equal",
- [CProp ("numberp",[CProp ("greatest_factor",[CVar 23; CVar 24])]);
- CProp
- ("not",
- [CProp
- ("and",
- [CProp
- ("or",
- [CProp ("zerop",[CVar 24]);
- CProp ("equal",[CVar 24; CProp ("one",[])])]);
- CProp ("not",[CProp ("numberp",[CVar 23])])])])]));
-add (CProp
-("equal",
- [CProp ("times_list",[CProp ("append",[CVar 23; CVar 24])]);
- CProp
- ("times",
- [CProp ("times_list",[CVar 23]); CProp ("times_list",[CVar 24])])]));
-add (CProp
-("equal",
- [CProp ("prime_list",[CProp ("append",[CVar 23; CVar 24])]);
- CProp
- ("and",
- [CProp ("prime_list",[CVar 23]); CProp ("prime_list",[CVar 24])])]));
-add (CProp
-("equal",
- [CProp ("equal",[CVar 25; CProp ("times",[CVar 22; CVar 25])]);
- CProp
- ("and",
- [CProp ("numberp",[CVar 25]);
- CProp
- ("or",
- [CProp ("equal",[CVar 25; CProp ("zero",[])]);
- CProp ("equal",[CVar 22; CProp ("one",[])])])])]));
-add (CProp
-("equal",
- [CProp ("ge",[CVar 23; CVar 24]);
- CProp ("not",[CProp ("lt",[CVar 23; CVar 24])])]));
-add (CProp
-("equal",
- [CProp ("equal",[CVar 23; CProp ("times",[CVar 23; CVar 24])]);
- CProp
- ("or",
- [CProp ("equal",[CVar 23; CProp ("zero",[])]);
- CProp
- ("and",
- [CProp ("numberp",[CVar 23]);
- CProp ("equal",[CVar 24; CProp ("one",[])])])])]));
-add (CProp
-("equal",
- [CProp ("remainder",[CProp ("times",[CVar 24; CVar 23]); CVar 24]);
- CProp ("zero",[])]));
-add (CProp
-("equal",
- [CProp ("equal",[CProp ("times",[CVar 0; CVar 1]); CProp ("one",[])]);
- CProp
- ("and",
- [CProp ("not",[CProp ("equal",[CVar 0; CProp ("zero",[])])]);
- CProp ("not",[CProp ("equal",[CVar 1; CProp ("zero",[])])]);
- CProp ("numberp",[CVar 0]); CProp ("numberp",[CVar 1]);
- CProp ("equal",[CProp ("sub1",[CVar 0]); CProp ("zero",[])]);
- CProp ("equal",[CProp ("sub1",[CVar 1]); CProp ("zero",[])])])]));
-add (CProp
-("equal",
- [CProp
- ("lt",
- [CProp ("length",[CProp ("delete",[CVar 23; CVar 11])]);
- CProp ("length",[CVar 11])]);
- CProp ("member",[CVar 23; CVar 11])]));
-add (CProp
-("equal",
- [CProp ("sort2",[CProp ("delete",[CVar 23; CVar 11])]);
- CProp ("delete",[CVar 23; CProp ("sort2",[CVar 11])])]));
-add (CProp ("equal",[CProp ("dsort",[CVar 23]); CProp ("sort2",[CVar 23])]));
-add (CProp
-("equal",
- [CProp
- ("length",
- [CProp
- ("cons",
- [CVar 0;
- CProp
- ("cons",
- [CVar 1;
- CProp
- ("cons",
- [CVar 2;
- CProp
- ("cons",
- [CVar 3;
- CProp ("cons",[CVar 4; CProp ("cons",[CVar 5; CVar 6])])])])])])])
- ; CProp ("plus",[CProp ("six",[]); CProp ("length",[CVar 6])])]));
-add (CProp
-("equal",
- [CProp
- ("difference",
- [CProp ("add1",[CProp ("add1",[CVar 23])]); CProp ("two",[])]);
- CProp ("fix",[CVar 23])]));
-add (CProp
-("equal",
- [CProp
- ("quotient",
- [CProp ("plus",[CVar 23; CProp ("plus",[CVar 23; CVar 24])]);
- CProp ("two",[])]);
- CProp
- ("plus",[CVar 23; CProp ("quotient",[CVar 24; CProp ("two",[])])])]));
-add (CProp
-("equal",
- [CProp ("sigma",[CProp ("zero",[]); CVar 8]);
- CProp
- ("quotient",
- [CProp ("times",[CVar 8; CProp ("add1",[CVar 8])]); CProp ("two",[])])]));
-add (CProp
-("equal",
- [CProp ("plus",[CVar 23; CProp ("add1",[CVar 24])]);
- CProp
- ("if",
- [CProp ("numberp",[CVar 24]);
- CProp ("add1",[CProp ("plus",[CVar 23; CVar 24])]);
- CProp ("add1",[CVar 23])])]));
-add (CProp
-("equal",
- [CProp
- ("equal",
- [CProp ("difference",[CVar 23; CVar 24]);
- CProp ("difference",[CVar 25; CVar 24])]);
- CProp
- ("if",
- [CProp ("lt",[CVar 23; CVar 24]);
- CProp ("not",[CProp ("lt",[CVar 24; CVar 25])]);
- CProp
- ("if",
- [CProp ("lt",[CVar 25; CVar 24]);
- CProp ("not",[CProp ("lt",[CVar 24; CVar 23])]);
- CProp ("equal",[CProp ("fix",[CVar 23]); CProp ("fix",[CVar 25])])])])])
-);
-add (CProp
-("equal",
- [CProp
- ("meaning",
- [CProp ("plus_tree",[CProp ("delete",[CVar 23; CVar 24])]); CVar 0]);
- CProp
- ("if",
- [CProp ("member",[CVar 23; CVar 24]);
- CProp
- ("difference",
- [CProp ("meaning",[CProp ("plus_tree",[CVar 24]); CVar 0]);
- CProp ("meaning",[CVar 23; CVar 0])]);
- CProp ("meaning",[CProp ("plus_tree",[CVar 24]); CVar 0])])]));
-add (CProp
-("equal",
- [CProp ("times",[CVar 23; CProp ("add1",[CVar 24])]);
- CProp
- ("if",
- [CProp ("numberp",[CVar 24]);
- CProp
- ("plus",
- [CVar 23; CProp ("times",[CVar 23; CVar 24]);
- CProp ("fix",[CVar 23])])])]));
-add (CProp
-("equal",
- [CProp ("nth",[CProp ("nil",[]); CVar 8]);
- CProp
- ("if",[CProp ("zerop",[CVar 8]); CProp ("nil",[]); CProp ("zero",[])])]));
-add (CProp
-("equal",
- [CProp ("last",[CProp ("append",[CVar 0; CVar 1])]);
- CProp
- ("if",
- [CProp ("listp",[CVar 1]); CProp ("last",[CVar 1]);
- CProp
- ("if",
- [CProp ("listp",[CVar 0]);
- CProp ("cons",[CProp ("car",[CProp ("last",[CVar 0])]); CVar 1]);
- CVar 1])])]));
-add (CProp
-("equal",
- [CProp ("equal",[CProp ("lt",[CVar 23; CVar 24]); CVar 25]);
- CProp
- ("if",
- [CProp ("lt",[CVar 23; CVar 24]);
- CProp ("equal",[CProp ("true",[]); CVar 25]);
- CProp ("equal",[CProp ("false",[]); CVar 25])])]));
-add (CProp
-("equal",
- [CProp ("assignment",[CVar 23; CProp ("append",[CVar 0; CVar 1])]);
- CProp
- ("if",
- [CProp ("assignedp",[CVar 23; CVar 0]);
- CProp ("assignment",[CVar 23; CVar 0]);
- CProp ("assignment",[CVar 23; CVar 1])])]));
-add (CProp
-("equal",
- [CProp ("car",[CProp ("gother",[CVar 23])]);
- CProp
- ("if",
- [CProp ("listp",[CVar 23]);
- CProp ("car",[CProp ("flatten",[CVar 23])]); CProp ("zero",[])])]));
-add (CProp
-("equal",
- [CProp ("flatten",[CProp ("cdr",[CProp ("gother",[CVar 23])])]);
- CProp
- ("if",
- [CProp ("listp",[CVar 23]);
- CProp ("cdr",[CProp ("flatten",[CVar 23])]);
- CProp ("cons",[CProp ("zero",[]); CProp ("nil",[])])])]));
-add (CProp
-("equal",
- [CProp ("quotient",[CProp ("times",[CVar 24; CVar 23]); CVar 24]);
- CProp
- ("if",
- [CProp ("zerop",[CVar 24]); CProp ("zero",[]);
- CProp ("fix",[CVar 23])])]));
-add (CProp
-("equal",
- [CProp ("get",[CVar 9; CProp ("set",[CVar 8; CVar 21; CVar 12])]);
- CProp
- ("if",
- [CProp ("eqp",[CVar 9; CVar 8]); CVar 21;
- CProp ("get",[CVar 9; CVar 12])])]))
-
-(* Tautology checker *)
-
-let truep x lst =
- match x with
- Prop(head, _) ->
- head.name = "true" || List.mem x lst
- | _ ->
- List.mem x lst
-
-and falsep x lst =
- match x with
- Prop(head, _) ->
- head.name = "false" || List.mem x lst
- | _ ->
- List.mem x lst
-
-
-let rec tautologyp x true_lst false_lst =
- if truep x true_lst then true else
- if falsep x false_lst then false else begin
-(*
- print_term x; print_newline();
-*)
- match x with
- Var _ -> false
- | Prop (head,[test; yes; no]) as p ->
- if head.name = "if" then
- if truep test true_lst then
- tautologyp yes true_lst false_lst
- else if falsep test false_lst then
- tautologyp no true_lst false_lst
- else tautologyp yes (test::true_lst) false_lst &&
- tautologyp no true_lst (test::false_lst)
- else
- false
- | _ -> assert false
- end
-
-
-let tautp x =
-(* print_term x; print_string"\n"; *)
- let y = rewrite x in
-(* print_term y; print_string "\n"; *)
- tautologyp y [] []
-
-(* the benchmark *)
-
-let subst =
-[Bind(23, cterm_to_term(
- CProp
- ("f",
- [CProp
- ("plus",
- [CProp ("plus",[CVar 0; CVar 1]);
- CProp ("plus",[CVar 2; CProp ("zero",[])])])])));
- Bind(24, cterm_to_term(
- CProp
- ("f",
- [CProp
- ("times",
- [CProp ("times",[CVar 0; CVar 1]);
- CProp ("plus",[CVar 2; CVar 3])])])));
- Bind(25, cterm_to_term(
- CProp
- ("f",
- [CProp
- ("reverse",
- [CProp
- ("append",
- [CProp ("append",[CVar 0; CVar 1]);
- CProp ("nil",[])])])])));
- Bind(20, cterm_to_term(
- CProp
- ("equal",
- [CProp ("plus",[CVar 0; CVar 1]);
- CProp ("difference",[CVar 23; CVar 24])])));
- Bind(22, cterm_to_term(
- CProp
- ("lt",
- [CProp ("remainder",[CVar 0; CVar 1]);
- CProp ("member",[CVar 0; CProp ("length",[CVar 1])])])))]
-
-let term = cterm_to_term(
- CProp
- ("implies",
- [CProp
- ("and",
- [CProp ("implies",[CVar 23; CVar 24]);
- CProp
- ("and",
- [CProp ("implies",[CVar 24; CVar 25]);
- CProp
- ("and",
- [CProp ("implies",[CVar 25; CVar 20]);
- CProp ("implies",[CVar 20; CVar 22])])])]);
- CProp ("implies",[CVar 23; CVar 22])]))
-
-let _ =
- if tautp (apply_subst subst term) then
- print_string "Proved!\n"
- else
- print_string "Cannot prove!\n";
- exit 0
-
-(*********
-with
- failure s ->
- print_string "Exception failure("; print_string s; print_string ")\n"
- | Unify ->
- print_string "Exception Unify\n"
- | match_failure(file,start,stop) ->
- print_string "Exception match_failure(";
- print_string file;
- print_string ",";
- print_int start;
- print_string ",";
- print_int stop;
- print_string ")\n"
- | _ ->
- print_string "Exception ?\n"
-
-**********)
diff --git a/test/fft.ml b/test/fft.ml
deleted file mode 100644
index 242c006719..0000000000
--- a/test/fft.ml
+++ /dev/null
@@ -1,188 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-let pi = 3.14159265358979323846
-
-let tpi = 2.0 *. pi
-
-let fft px py np =
- let i = ref 2 in
- let m = ref 1 in
-
- while (!i < np) do
- i := !i + !i;
- m := !m + 1
- done;
-
- let n = !i in
-
- if n <> np then begin
- for i = np+1 to n do
- px.(i) <- 0.0;
- py.(i) <- 0.0
- done;
- print_string "Use "; print_int n;
- print_string " point fft"; print_newline()
- end;
-
- let n2 = ref(n+n) in
- for k = 1 to !m-1 do
- n2 := !n2 / 2;
- let n4 = !n2 / 4 in
- let e = tpi /. float !n2 in
-
- for j = 1 to n4 do
- let a = e *. float(j - 1) in
- let a3 = 3.0 *. a in
- let cc1 = cos(a) in
- let ss1 = sin(a) in
- let cc3 = cos(a3) in
- let ss3 = sin(a3) in
- let is = ref j in
- let id = ref(2 * !n2) in
-
- while !is < n do
- let i0r = ref !is in
- while !i0r < n do
- let i0 = !i0r in
- let i1 = i0 + n4 in
- let i2 = i1 + n4 in
- let i3 = i2 + n4 in
- let r1 = px.(i0) -. px.(i2) in
- px.(i0) <- px.(i0) +. px.(i2);
- let r2 = px.(i1) -. px.(i3) in
- px.(i1) <- px.(i1) +. px.(i3);
- let s1 = py.(i0) -. py.(i2) in
- py.(i0) <- py.(i0) +. py.(i2);
- let s2 = py.(i1) -. py.(i3) in
- py.(i1) <- py.(i1) +. py.(i3);
- let s3 = r1 -. s2 in
- let r1 = r1 +. s2 in
- let s2 = r2 -. s1 in
- let r2 = r2 +. s1 in
- px.(i2) <- r1*.cc1 -. s2*.ss1;
- py.(i2) <- -.s2*.cc1 -. r1*.ss1;
- px.(i3) <- s3*.cc3 +. r2*.ss3;
- py.(i3) <- r2*.cc3 -. s3*.ss3;
- i0r := i0 + !id
- done;
- is := 2 * !id - !n2 + j;
- id := 4 * !id
- done
- done
- done;
-
-(************************************)
-(* Last stage, length=2 butterfly *)
-(************************************)
-
- let is = ref 1 in
- let id = ref 4 in
-
- while !is < n do
- let i0r = ref !is in
- while !i0r <= n do
- let i0 = !i0r in
- let i1 = i0 + 1 in
- let r1 = px.(i0) in
- px.(i0) <- r1 +. px.(i1);
- px.(i1) <- r1 -. px.(i1);
- let r1 = py.(i0) in
- py.(i0) <- r1 +. py.(i1);
- py.(i1) <- r1 -. py.(i1);
- i0r := i0 + !id
- done;
- is := 2 * !id - 1;
- id := 4 * !id
- done;
-
-(*************************)
-(* Bit reverse counter *)
-(*************************)
-
- let j = ref 1 in
-
- for i = 1 to n - 1 do
- if i < !j then begin
- let xt = px.(!j) in
- px.(!j) <- px.(i);
- px.(i) <- xt;
- let xt = py.(!j) in
- py.(!j) <- py.(i);
- py.(i) <- xt
- end;
- let k = ref(n / 2) in
- while !k < !j do
- j := !j - !k;
- k := !k / 2
- done;
- j := !j + !k
- done;
-
- n
-
-
-let test np =
- print_int np; print_string "... "; flush stdout;
- let enp = float np in
- let npm = np / 2 - 1 in
- let pxr = Array.create (np+2) 0.0
- and pxi = Array.create (np+2) 0.0 in
- let t = pi /. enp in
- pxr.(1) <- (enp -. 1.0) *. 0.5;
- pxi.(1) <- 0.0;
- let n2 = np / 2 in
- pxr.(n2+1) <- -0.5;
- pxi.(n2+1) <- 0.0;
-
- for i = 1 to npm do
- let j = np - i in
- pxr.(i+1) <- -0.5;
- pxr.(j+1) <- -0.5;
- let z = t *. float i in
- let y = -0.5*.(cos(z)/.sin(z)) in
- pxi.(i+1) <- y;
- pxi.(j+1) <- -.y
- done;
-(**
- print_newline();
- for i=0 to 15 do Printf.printf "%d %f %f\n" i pxr.(i+1) pxi.(i+1) done;
-**)
- let _ = fft pxr pxi np in
-(**
- for i=0 to 15 do Printf.printf "%d %f %f\n" i pxr.(i+1) pxi.(i+1) done;
-**)
- let zr = ref 0.0 in
- let zi = ref 0.0 in
- let kr = ref 0 in
- let ki = ref 0 in
- for i = 0 to np-1 do
- let a = abs_float(pxr.(i+1) -. float i) in
- if !zr < a then begin
- zr := a;
- kr := i
- end;
- let a = abs_float(pxi.(i+1)) in
- if !zi < a then begin
- zi := a;
- ki := i
- end
- done;
- let zm = if abs_float !zr < abs_float !zi then !zi else !zr in
- print_float zm; print_newline()
-
-
-let _ =
- let np = ref 16 in for i = 1 to 13 do test !np; np := !np*2 done
-
diff --git a/test/fib.ml b/test/fib.ml
deleted file mode 100644
index d113be5f77..0000000000
--- a/test/fib.ml
+++ /dev/null
@@ -1,24 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-let rec fib n =
- if n < 2 then 1 else fib(n-1) + fib(n-2)
-
-let _ =
- let n =
- if Array.length Sys.argv >= 2
- then int_of_string Sys.argv.(1)
- else 30 in
- print_int(fib n); print_newline(); exit 0
-
diff --git a/test/hamming.ml b/test/hamming.ml
deleted file mode 100644
index 7216ddb0d9..0000000000
--- a/test/hamming.ml
+++ /dev/null
@@ -1,105 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Damien Doligez, projet Moscova, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* We cannot use bignums because we don't do custom runtimes, but
- int64 is a bit short, so we roll our own 37-digit numbers...
-*)
-
-let n0 = Int64.of_int 0;;
-let n1 = Int64.of_int 1;;
-let n2 = Int64.of_int 2;;
-let n3 = Int64.of_int 3;;
-let n5 = Int64.of_int 5;;
-
-let ( % ) = Int64.rem;;
-let ( * ) = Int64.mul;;
-let ( / ) = Int64.div;;
-let ( + ) = Int64.add;;
-let digit = Int64.of_string "1000000000000000000";;
-
-let mul n (pl, ph) = ((n * pl) % digit, n * ph + (n * pl) / digit);;
-let cmp (nl, nh) (pl, ph) =
- if nh < ph then -1
- else if nh > ph then 1
- else if nl < pl then -1
- else if nl > pl then 1
- else 0
-;;
-
-let x2 = fun p -> mul n2 p;;
-let x3 = fun p -> mul n3 p;;
-let x5 = fun p -> mul n5 p;;
-
-let nn1 = (n1, n0);;
-
-let pr (nl, nh) =
- if compare nh n0 = 0
- then Printf.printf "%Ld\n" nl
- else Printf.printf "%Ld%018Ld\n" nh nl
-;;
-
-(*
- (* bignum version *)
-open Num;;
-let nn1 = num_of_int 1;;
-let x2 = fun p -> (num_of_int 2) */ p;;
-let x3 = fun p -> (num_of_int 3) */ p;;
-let x5 = fun p -> (num_of_int 5) */ p;;
-let cmp n p = sign_num (n -/ p);;
-let pr n = Printf.printf "%s\n" (string_of_num n);;
-*)
-
-
-(* This is where the interesting stuff begins. *)
-
-open Lazy;;
-
-type 'a lcons = Cons of 'a * 'a lcons Lazy.t;;
-type 'a llist = 'a lcons Lazy.t;;
-
-let rec map f l =
- lazy (
- match force l with
- | Cons (x, ll) -> Cons (f x, map f ll)
- )
-;;
-
-let rec merge cmp l1 l2 =
- lazy (
- match force l1, force l2 with
- | Cons (x1, ll1), Cons (x2, ll2)
- -> let c = cmp x1 x2 in
- if c = 0
- then Cons (x1, merge cmp ll1 ll2)
- else if c < 0
- then Cons (x1, merge cmp ll1 l2)
- else Cons (x2, merge cmp l1 ll2)
- )
-;;
-
-let rec iter_interval f l (start, stop) =
- if stop = 0 then ()
- else match force l with
- | Cons (x, ll)
- -> if start <= 0 then f x;
- iter_interval f ll (start-1, stop-1)
-;;
-
-let rec hamming = lazy (Cons (nn1, merge cmp ham2 (merge cmp ham3 ham5)))
- and ham2 = lazy (force (map x2 hamming))
- and ham3 = lazy (force (map x3 hamming))
- and ham5 = lazy (force (map x5 hamming))
-;;
-
-iter_interval pr hamming (88000, 88100);;
diff --git a/test/nucleic.ml b/test/nucleic.ml
deleted file mode 100644
index 7a9dcc637b..0000000000
--- a/test/nucleic.ml
+++ /dev/null
@@ -1,3236 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Use floating-point arithmetic *)
-
-external (+) : float -> float -> float = "%addfloat"
-external (-) : float -> float -> float = "%subfloat"
-external ( * ) : float -> float -> float = "%mulfloat"
-external (/) : float -> float -> float = "%divfloat"
-
-(* -- MATH UTILITIES --------------------------------------------------------*)
-
-let constant_pi = 3.14159265358979323846
-let constant_minus_pi = -3.14159265358979323846
-let constant_pi2 = 1.57079632679489661923
-let constant_minus_pi2 = -1.57079632679489661923
-
-(* -- POINTS ----------------------------------------------------------------*)
-
-type pt = { x : float; y : float; z : float }
-
-let
-pt_sub p1 p2
- = { x = p1.x - p2.x; y = p1.y - p2.y; z = p1.z - p2.z }
-
-let
-pt_dist p1 p2
- = let dx = p1.x - p2.x
- and dy = p1.y - p2.y
- and dz = p1.z - p2.z
- in
- sqrt ((dx * dx) + (dy * dy) + (dz * dz))
-
-let
-pt_phi p
- = let b = atan2 p.x p.z
- in
- atan2 ((cos b) * p.z + (sin b) * p.x) p.y
-
-let
-pt_theta p
- = atan2 p.x p.z
-
-(* -- COORDINATE TRANSFORMATIONS --------------------------------------------*)
-
-(*
- The notation for the transformations follows "Paul, R.P. (1981) Robot
- Manipulators. MIT Press." with the exception that our transformation
- matrices don't have the perspective terms and are the transpose of
- Paul's one. See also "M\"antyl\"a, M. (1985) An Introduction to
- Solid Modeling, Computer Science Press" Appendix A.
-
- The components of a transformation matrix are named like this:
-
- a b c
- d e f
- g h i
- tx ty tz
-
- The components tx, ty, and tz are the translation vector.
-*)
-
-type tfo =
- {a: float; b: float; c: float;
- d: float; e: float; f: float;
- g: float; h: float; i: float;
- tx: float; ty: float; tz: float}
-
-let tfo_id =
- {a=1.0; b=0.0; c=0.0;
- d=0.0; e=1.0; f=0.0;
- g=0.0; h=0.0; i=1.0;
- tx=0.0; ty=0.0; tz=0.0}
-
-(*
- The function "tfo-apply" multiplies a transformation matrix, tfo, by a
- point vector, p. The result is a new point.
-*)
-
-let
-tfo_apply t p
- = { x = ((p.x * t.a) + (p.y * t.d) + (p.z * t.g) + t.tx);
- y = ((p.x * t.b) + (p.y * t.e) + (p.z * t.h) + t.ty);
- z = ((p.x * t.c) + (p.y * t.f) + (p.z * t.i) + t.tz) }
-
-(*
- The function "tfo-combine" multiplies two transformation matrices A and B.
- The result is a new matrix which cumulates the transformations described
- by A and B.
-*)
-
-let
-tfo_combine a b =
-(* <HAND_CSE> *)
- (* Hand elimination of common subexpressions.
- Assumes lots of float registers (32 is perfect, 16 still OK).
- Loses on the I386, of course. *)
- let a_a = a.a and a_b = a.b and a_c = a.c and a_d = a.d
- and a_e = a.e and a_f = a.f and a_g = a.g and a_h = a.h
- and a_i = a.i and a_tx = a.tx and a_ty = a.ty and a_tz = a.tz
- and b_a = b.a and b_b = b.b and b_c = b.c and b_d = b.d
- and b_e = b.e and b_f = b.f and b_g = b.g and b_h = b.h
- and b_i = b.i and b_tx = b.tx and b_ty = b.ty and b_tz = b.tz in
- { a = ((a_a * b_a) + (a_b * b_d) + (a_c * b_g));
- b = ((a_a * b_b) + (a_b * b_e) + (a_c * b_h));
- c = ((a_a * b_c) + (a_b * b_f) + (a_c * b_i));
- d = ((a_d * b_a) + (a_e * b_d) + (a_f * b_g));
- e = ((a_d * b_b) + (a_e * b_e) + (a_f * b_h));
- f = ((a_d * b_c) + (a_e * b_f) + (a_f * b_i));
- g = ((a_g * b_a) + (a_h * b_d) + (a_i * b_g));
- h = ((a_g * b_b) + (a_h * b_e) + (a_i * b_h));
- i = ((a_g * b_c) + (a_h * b_f) + (a_i * b_i));
- tx = ((a_tx * b_a) + (a_ty * b_d) + (a_tz * b_g) + b_tx);
- ty = ((a_tx * b_b) + (a_ty * b_e) + (a_tz * b_h) + b_ty);
- tz = ((a_tx * b_c) + (a_ty * b_f) + (a_tz * b_i) + b_tz)
- }
-(* </HAND_CSE> *)
- (* Original without CSE *)
-(* <NO_CSE> *) (***
- { a = ((a.a * b.a) + (a.b * b.d) + (a.c * b.g));
- b = ((a.a * b.b) + (a.b * b.e) + (a.c * b.h));
- c = ((a.a * b.c) + (a.b * b.f) + (a.c * b.i));
- d = ((a.d * b.a) + (a.e * b.d) + (a.f * b.g));
- e = ((a.d * b.b) + (a.e * b.e) + (a.f * b.h));
- f = ((a.d * b.c) + (a.e * b.f) + (a.f * b.i));
- g = ((a.g * b.a) + (a.h * b.d) + (a.i * b.g));
- h = ((a.g * b.b) + (a.h * b.e) + (a.i * b.h));
- i = ((a.g * b.c) + (a.h * b.f) + (a.i * b.i));
- tx = ((a.tx * b.a) + (a.ty * b.d) + (a.tz * b.g) + b.tx);
- ty = ((a.tx * b.b) + (a.ty * b.e) + (a.tz * b.h) + b.ty);
- tz = ((a.tx * b.c) + (a.ty * b.f) + (a.tz * b.i) + b.tz)
- }
- ***) (* </NO_CSE> *)
-
-(*
- The function "tfo-inv-ortho" computes the inverse of a homogeneous
- transformation matrix.
-*)
-
-let
-tfo_inv_ortho t =
- { a = t.a; b = t.d; c = t.g;
- d = t.b; e = t.e; f = t.h;
- g = t.c; h = t.f; i = t.i;
- tx = (-.((t.a * t.tx) + (t.b * t.ty) + (t.c * t.tz)));
- ty = (-.((t.d * t.tx) + (t.e * t.ty) + (t.f * t.tz)));
- tz = (-.((t.g * t.tx) + (t.h * t.ty) + (t.i * t.tz)))
- }
-
-(*
- Given three points p1, p2, and p3, the function "tfo-align" computes
- a transformation matrix such that point p1 gets mapped to (0,0,0), p2 gets
- mapped to the Y axis and p3 gets mapped to the YZ plane.
-*)
-
-let
-tfo_align p1 p2 p3
- = let x31 = p3.x - p1.x in
- let y31 = p3.y - p1.y in
- let z31 = p3.z - p1.z in
- let rotpy = pt_sub p2 p1 in
- let phi = pt_phi rotpy in
- let theta = pt_theta rotpy in
- let sinp = sin phi in
- let sint = sin theta in
- let cosp = cos phi in
- let cost = cos theta in
- let sinpsint = sinp * sint in
- let sinpcost = sinp * cost in
- let cospsint = cosp * sint in
- let cospcost = cosp * cost in
- let rotpz =
- { x = ((cost * x31) - (sint * z31));
- y = ((sinpsint * x31) + (cosp * y31) + (sinpcost * z31));
- z = ((cospsint * x31) + (-.(sinp * y31)) + (cospcost * z31)) } in
- let rho = pt_theta rotpz in
- let cosr = cos rho in
- let sinr = sin rho in
- let x = (-.(p1.x * cost)) + (p1.z * sint) in
- let y = ((-.(p1.x * sinpsint)) - (p1.y * cosp)) - (p1.z * sinpcost) in
- let z = ((-.(p1.x * cospsint) + (p1.y * sinp))) - (p1.z * cospcost) in
- { a = ((cost * cosr) - (cospsint * sinr));
- b = sinpsint;
- c = ((cost * sinr) + (cospsint * cosr));
- d = (sinp * sinr);
- e = cosp;
- f = (-.(sinp * cosr));
- g = ((-.(sint * cosr)) - (cospcost * sinr));
- h = sinpcost;
- i = ((-.(sint * sinr) + (cospcost * cosr)));
- tx = ((x * cosr) - (z * sinr));
- ty = y;
- tz = ((x * sinr + (z * cosr)))
- }
-
-(* -- NUCLEIC ACID CONFORMATIONS DATA BASE ----------------------------------*)
-
-(*
- Numbering of atoms follows the paper:
-
- IUPAC-IUB Joint Commission on Biochemical Nomenclature (JCBN)
- (1983) Abbreviations and Symbols for the Description of
- Conformations of Polynucleotide Chains. Eur. J. Biochem 131,
- 9-15.
-*)
-
-(* Define remaining atoms for each nucleotide type. *)
-
-type nuc_specific =
- A of pt*pt*pt*pt*pt*pt*pt*pt
-| C of pt*pt*pt*pt*pt*pt
-| G of pt*pt*pt*pt*pt*pt*pt*pt*pt
-| U of pt*pt*pt*pt*pt
-
-(*
- A n6 n7 n9 c8 h2 h61 h62 h8
- C n4 o2 h41 h42 h5 h6
- G n2 n7 n9 c8 o6 h1 h21 h22 h8
- U o2 o4 h3 h5 h6
-*)
-
-(* Define part common to all 4 nucleotide types. *)
-
-type nuc =
- N of tfo*tfo*tfo*tfo*
- pt*pt*pt*pt*pt*pt*pt*pt*pt*pt*pt*pt*
- pt*pt*pt*pt*pt*pt*pt*pt*pt*pt*pt*pt*
- pt*nuc_specific
-
-(*
- dgf_base_tfo ; defines the standard position for wc and wc_dumas
- p_o3'_275_tfo ; defines the standard position for the connect function
- p_o3'_180_tfo
- p_o3'_60_tfo
- p o1p o2p o5' c5' h5' h5'' c4' h4' o4' c1' h1' c2' h2'' o2' h2' c3'
- h3' o3' n1 n3 c2 c4 c5 c6
-*)
-
-let is_A = function
- N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
- p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
- c3',h3',o3',n1,n3,c2,c4,c5,c6,A(_,_,_,_,_,_,_,_)) -> true
- | _ -> false
-
-let is_C = function
- N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
- p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
- c3',h3',o3',n1,n3,c2,c4,c5,c6,C(_,_,_,_,_,_)) -> true
- | _ -> false
-
-let is_G = function
- N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
- p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
- c3',h3',o3',n1,n3,c2,c4,c5,c6,G(_,_,_,_,_,_,_,_,_)) -> true
- | _ -> false
-
-let
-nuc_C1'
-(N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
- p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
- c3',h3',o3',n1,n3,c2,c4,c5,c6,_))
- = c1'
-
-let
-nuc_C2
-(N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
- p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
- c3',h3',o3',n1,n3,c2,c4,c5,c6,_))
- = c2
-
-let
-nuc_C3'
-(N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
- p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
- c3',h3',o3',n1,n3,c2,c4,c5,c6,_))
- = c3'
-
-let
-nuc_C4
-(N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
- p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
- c3',h3',o3',n1,n3,c2,c4,c5,c6,_))
- = c4
-
-let
-nuc_C4'
-(N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
- p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
- c3',h3',o3',n1,n3,c2,c4,c5,c6,_))
- = c4'
-
-let
-nuc_N1
-(N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
- p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
- c3',h3',o3',n1,n3,c2,c4,c5,c6,_))
- = n1
-
-let
-nuc_O3'
-(N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
- p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
- c3',h3',o3',n1,n3,c2,c4,c5,c6,_))
- = o3'
-
-let
-nuc_P
-(N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
- p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
- c3',h3',o3',n1,n3,c2,c4,c5,c6,_))
- = p
-
-let
-nuc_dgf_base_tfo
-(N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
- p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
- c3',h3',o3',n1,n3,c2,c4,c5,c6,_))
- = dgf_base_tfo
-
-let
-nuc_p_o3'_180_tfo
-(N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
- p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
- c3',h3',o3',n1,n3,c2,c4,c5,c6,_))
- = p_o3'_180_tfo
-
-let
-nuc_p_o3'_275_tfo
-(N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
- p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
- c3',h3',o3',n1,n3,c2,c4,c5,c6,_))
- = p_o3'_275_tfo
-
-let
-nuc_p_o3'_60_tfo
-(N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
- p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
- c3',h3',o3',n1,n3,c2,c4,c5,c6,_))
- = p_o3'_60_tfo
-
-let
-rA_N9 = function
-| (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
- p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
- c3',h3',o3',n1,n3,c2,c4,c5,c6,A (n6,n7,n9,c8,h2,h61,h62,h8))) -> n9
-| _ -> assert false
-
-
-let
-rG_N9 = function
-| (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
- p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
- c3',h3',o3',n1,n3,c2,c4,c5,c6,G (n2,n7,n9,c8,o6,h1,h21,h22,h8))) -> n9
-| _ -> assert false
-
-(* Database of nucleotide conformations: *)
-
-let rA
- = N(
- { a= -0.0018; b= -0.8207; c=0.5714; (* dgf_base_tfo *)
- d=0.2679; e= -0.5509; f= -0.7904;
- g=0.9634; h=0.1517; i=0.2209;
- tx=0.0073; ty=8.4030; tz=0.6232 },
- { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
- d= -0.0433; e= -0.4257; f=0.9038;
- g= -0.5788; h=0.7480; i=0.3246;
- tx=1.5227; ty=6.9114; tz= -7.0765 },
- { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
- d=0.4552; e=0.6637; f=0.5935;
- g= -0.8042; h=0.0203; i=0.5941;
- tx= -6.9472; ty= -4.1186; tz= -5.9108 },
- { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
- d= -0.8247; e=0.5587; f= -0.0878;
- g=0.0426; h=0.2162; i=0.9754;
- tx=6.2694; ty= -7.0540; tz=3.3316 },
- { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *)
- { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *)
- { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *)
- { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *)
- { x = 5.4550; y = 8.2120; z = -2.8810 }, (* C5' *)
- { x = 5.4546; y = 8.8508; z = -1.9978 }, (* H5' *)
- { x = 5.7588; y = 8.6625; z = -3.8259 }, (* H5'' *)
- { x = 6.4970; y = 7.1480; z = -2.5980 }, (* C4' *)
- { x = 7.4896; y = 7.5919; z = -2.5214 }, (* H4' *)
- { x = 6.1630; y = 6.4860; z = -1.3440 }, (* O4' *)
- { x = 6.5400; y = 5.1200; z = -1.4190 }, (* C1' *)
- { x = 7.2763; y = 4.9681; z = -0.6297 }, (* H1' *)
- { x = 7.1940; y = 4.8830; z = -2.7770 }, (* C2' *)
- { x = 6.8667; y = 3.9183; z = -3.1647 }, (* H2'' *)
- { x = 8.5860; y = 5.0910; z = -2.6140 }, (* O2' *)
- { x = 8.9510; y = 4.7626; z = -1.7890 }, (* H2' *)
- { x = 6.5720; y = 6.0040; z = -3.6090 }, (* C3' *)
- { x = 5.5636; y = 5.7066; z = -3.8966 }, (* H3' *)
- { x = 7.3801; y = 6.3562; z = -4.7350 }, (* O3' *)
- { x = 4.7150; y = 0.4910; z = -0.1360 }, (* N1 *)
- { x = 6.3490; y = 2.1730; z = -0.6020 }, (* N3 *)
- { x = 5.9530; y = 0.9650; z = -0.2670 }, (* C2 *)
- { x = 5.2900; y = 2.9790; z = -0.8260 }, (* C4 *)
- { x = 3.9720; y = 2.6390; z = -0.7330 }, (* C5 *)
- { x = 3.6770; y = 1.3160; z = -0.3660 }, (* C6 *)
- (A (
- { x = 2.4280; y = 0.8450; z = -0.2360 }, (* N6 *)
- { x = 3.1660; y = 3.7290; z = -1.0360 }, (* N7 *)
- { x = 5.3170; y = 4.2990; z = -1.1930 }, (* N9 *)
- { x = 4.0100; y = 4.6780; z = -1.2990 }, (* C8 *)
- { x = 6.6890; y = 0.1903; z = -0.0518 }, (* H2 *)
- { x = 1.6470; y = 1.4460; z = -0.4040 }, (* H61 *)
- { x = 2.2780; y = -0.1080; z = -0.0280 }, (* H62 *)
- { x = 3.4421; y = 5.5744; z = -1.5482 }) (* H8 *)
- )
- )
-
-let rA01
- = N(
- { a= -0.0043; b= -0.8175; c=0.5759; (* dgf_base_tfo *)
- d=0.2617; e= -0.5567; f= -0.7884;
- g=0.9651; h=0.1473; i=0.2164;
- tx=0.0359; ty=8.3929; tz=0.5532 },
- { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
- d= -0.0433; e= -0.4257; f=0.9038;
- g= -0.5788; h=0.7480; i=0.3246;
- tx=1.5227; ty=6.9114; tz= -7.0765 },
- { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
- d=0.4552; e=0.6637; f=0.5935;
- g= -0.8042; h=0.0203; i=0.5941;
- tx= -6.9472; ty= -4.1186; tz= -5.9108 },
- { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
- d= -0.8247; e=0.5587; f= -0.0878;
- g=0.0426; h=0.2162; i=0.9754;
- tx=6.2694; ty= -7.0540; tz=3.3316 },
- { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *)
- { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *)
- { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *)
- { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *)
- { x = 5.4352; y = 8.2183; z = -2.7757 }, (* C5' *)
- { x = 5.3830; y = 8.7883; z = -1.8481 }, (* H5' *)
- { x = 5.7729; y = 8.7436; z = -3.6691 }, (* H5'' *)
- { x = 6.4830; y = 7.1518; z = -2.5252 }, (* C4' *)
- { x = 7.4749; y = 7.5972; z = -2.4482 }, (* H4' *)
- { x = 6.1626; y = 6.4620; z = -1.2827 }, (* O4' *)
- { x = 6.5431; y = 5.0992; z = -1.3905 }, (* C1' *)
- { x = 7.2871; y = 4.9328; z = -0.6114 }, (* H1' *)
- { x = 7.1852; y = 4.8935; z = -2.7592 }, (* C2' *)
- { x = 6.8573; y = 3.9363; z = -3.1645 }, (* H2'' *)
- { x = 8.5780; y = 5.1025; z = -2.6046 }, (* O2' *)
- { x = 8.9516; y = 4.7577; z = -1.7902 }, (* H2' *)
- { x = 6.5522; y = 6.0300; z = -3.5612 }, (* C3' *)
- { x = 5.5420; y = 5.7356; z = -3.8459 }, (* H3' *)
- { x = 7.3487; y = 6.4089; z = -4.6867 }, (* O3' *)
- { x = 4.7442; y = 0.4514; z = -0.1390 }, (* N1 *)
- { x = 6.3687; y = 2.1459; z = -0.5926 }, (* N3 *)
- { x = 5.9795; y = 0.9335; z = -0.2657 }, (* C2 *)
- { x = 5.3052; y = 2.9471; z = -0.8125 }, (* C4 *)
- { x = 3.9891; y = 2.5987; z = -0.7230 }, (* C5 *)
- { x = 3.7016; y = 1.2717; z = -0.3647 }, (* C6 *)
- (A (
- { x = 2.4553; y = 0.7925; z = -0.2390 }, (* N6 *)
- { x = 3.1770; y = 3.6859; z = -1.0198 }, (* N7 *)
- { x = 5.3247; y = 4.2695; z = -1.1710 }, (* N9 *)
- { x = 4.0156; y = 4.6415; z = -1.2759 }, (* C8 *)
- { x = 6.7198; y = 0.1618; z = -0.0547 }, (* H2 *)
- { x = 1.6709; y = 1.3900; z = -0.4039 }, (* H61 *)
- { x = 2.3107; y = -0.1627; z = -0.0373 }, (* H62 *)
- { x = 3.4426; y = 5.5361; z = -1.5199 }) (* H8 *)
- )
- )
-
-let rA02
- = N(
- { a=0.5566; b=0.0449; c=0.8296; (* dgf_base_tfo *)
- d=0.5125; e=0.7673; f= -0.3854;
- g= -0.6538; h=0.6397; i=0.4041;
- tx= -9.1161; ty= -3.7679; tz= -2.9968 },
- { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
- d= -0.0433; e= -0.4257; f=0.9038;
- g= -0.5788; h=0.7480; i=0.3246;
- tx=1.5227; ty=6.9114; tz= -7.0765 },
- { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
- d=0.4552; e=0.6637; f=0.5935;
- g= -0.8042; h=0.0203; i=0.5941;
- tx= -6.9472; ty= -4.1186; tz= -5.9108 },
- { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
- d= -0.8247; e=0.5587; f= -0.0878;
- g=0.0426; h=0.2162; i=0.9754;
- tx=6.2694; ty= -7.0540; tz=3.3316 },
- { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *)
- { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *)
- { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *)
- { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *)
- { x = 4.5778; y = 6.6594; z = -4.0364 }, (* C5' *)
- { x = 4.9220; y = 7.1963; z = -4.9204 }, (* H5' *)
- { x = 3.7996; y = 5.9091; z = -4.1764 }, (* H5'' *)
- { x = 5.7873; y = 5.8869; z = -3.5482 }, (* C4' *)
- { x = 6.0405; y = 5.0875; z = -4.2446 }, (* H4' *)
- { x = 6.9135; y = 6.8036; z = -3.4310 }, (* O4' *)
- { x = 7.7293; y = 6.4084; z = -2.3392 }, (* C1' *)
- { x = 8.7078; y = 6.1815; z = -2.7624 }, (* H1' *)
- { x = 7.1305; y = 5.1418; z = -1.7347 }, (* C2' *)
- { x = 7.2040; y = 5.1982; z = -0.6486 }, (* H2'' *)
- { x = 7.7417; y = 4.0392; z = -2.3813 }, (* O2' *)
- { x = 8.6785; y = 4.1443; z = -2.5630 }, (* H2' *)
- { x = 5.6666; y = 5.2728; z = -2.1536 }, (* C3' *)
- { x = 5.1747; y = 5.9805; z = -1.4863 }, (* H3' *)
- { x = 4.9997; y = 4.0086; z = -2.1973 }, (* O3' *)
- { x = 10.3245; y = 8.5459; z = 1.5467 }, (* N1 *)
- { x = 9.8051; y = 6.9432; z = -0.1497 }, (* N3 *)
- { x = 10.5175; y = 7.4328; z = 0.8408 }, (* C2 *)
- { x = 8.7523; y = 7.7422; z = -0.4228 }, (* C4 *)
- { x = 8.4257; y = 8.9060; z = 0.2099 }, (* C5 *)
- { x = 9.2665; y = 9.3242; z = 1.2540 }, (* C6 *)
- (A (
- { x = 9.0664; y = 10.4462; z = 1.9610 }, (* N6 *)
- { x = 7.2750; y = 9.4537; z = -0.3428 }, (* N7 *)
- { x = 7.7962; y = 7.5519; z = -1.3859 }, (* N9 *)
- { x = 6.9479; y = 8.6157; z = -1.2771 }, (* C8 *)
- { x = 11.4063; y = 6.9047; z = 1.1859 }, (* H2 *)
- { x = 8.2845; y = 11.0341; z = 1.7552 }, (* H61 *)
- { x = 9.6584; y = 10.6647; z = 2.7198 }, (* H62 *)
- { x = 6.0430; y = 8.9853; z = -1.7594 }) (* H8 *)
- )
- )
-let rA03
- = N(
- { a= -0.5021; b=0.0731; c=0.8617; (* dgf_base_tfo *)
- d= -0.8112; e=0.3054; f= -0.4986;
- g= -0.2996; h= -0.9494; i= -0.0940;
- tx=6.4273; ty= -5.1944; tz= -3.7807 },
- { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
- d= -0.0433; e= -0.4257; f=0.9038;
- g= -0.5788; h=0.7480; i=0.3246;
- tx=1.5227; ty=6.9114; tz= -7.0765 },
- { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
- d=0.4552; e=0.6637; f=0.5935;
- g= -0.8042; h=0.0203; i=0.5941;
- tx= -6.9472; ty= -4.1186; tz= -5.9108 },
- { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
- d= -0.8247; e=0.5587; f= -0.0878;
- g=0.0426; h=0.2162; i=0.9754;
- tx=6.2694; ty= -7.0540; tz=3.3316 },
- { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *)
- { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *)
- { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *)
- { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *)
- { x = 4.1214; y = 6.7116; z = -1.9049 }, (* C5' *)
- { x = 3.3465; y = 5.9610; z = -2.0607 }, (* H5' *)
- { x = 4.0789; y = 7.2928; z = -0.9837 }, (* H5'' *)
- { x = 5.4170; y = 5.9293; z = -1.8186 }, (* C4' *)
- { x = 5.4506; y = 5.3400; z = -0.9023 }, (* H4' *)
- { x = 5.5067; y = 5.0417; z = -2.9703 }, (* O4' *)
- { x = 6.8650; y = 4.9152; z = -3.3612 }, (* C1' *)
- { x = 7.1090; y = 3.8577; z = -3.2603 }, (* H1' *)
- { x = 7.7152; y = 5.7282; z = -2.3894 }, (* C2' *)
- { x = 8.5029; y = 6.2356; z = -2.9463 }, (* H2'' *)
- { x = 8.1036; y = 4.8568; z = -1.3419 }, (* O2' *)
- { x = 8.3270; y = 3.9651; z = -1.6184 }, (* H2' *)
- { x = 6.7003; y = 6.7565; z = -1.8911 }, (* C3' *)
- { x = 6.5898; y = 7.5329; z = -2.6482 }, (* H3' *)
- { x = 7.0505; y = 7.2878; z = -0.6105 }, (* O3' *)
- { x = 9.6740; y = 4.7656; z = -7.6614 }, (* N1 *)
- { x = 9.0739; y = 4.3013; z = -5.3941 }, (* N3 *)
- { x = 9.8416; y = 4.2192; z = -6.4581 }, (* C2 *)
- { x = 7.9885; y = 5.0632; z = -5.6446 }, (* C4 *)
- { x = 7.6822; y = 5.6856; z = -6.8194 }, (* C5 *)
- { x = 8.5831; y = 5.5215; z = -7.8840 }, (* C6 *)
- (A (
- { x = 8.4084; y = 6.0747; z = -9.0933 }, (* N6 *)
- { x = 6.4857; y = 6.3816; z = -6.7035 }, (* N7 *)
- { x = 6.9740; y = 5.3703; z = -4.7760 }, (* N9 *)
- { x = 6.1133; y = 6.1613; z = -5.4808 }, (* C8 *)
- { x = 10.7627; y = 3.6375; z = -6.4220 }, (* H2 *)
- { x = 7.6031; y = 6.6390; z = -9.2733 }, (* H61 *)
- { x = 9.1004; y = 5.9708; z = -9.7893 }, (* H62 *)
- { x = 5.1705; y = 6.6830; z = -5.3167 }) (* H8 *)
- )
- )
-
-let rA04
- = N(
- { a= -0.5426; b= -0.8175; c=0.1929; (* dgf_base_tfo *)
- d=0.8304; e= -0.5567; f= -0.0237;
- g=0.1267; h=0.1473; i=0.9809;
- tx= -0.5075; ty=8.3929; tz=0.2229 },
- { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
- d= -0.0433; e= -0.4257; f=0.9038;
- g= -0.5788; h=0.7480; i=0.3246;
- tx=1.5227; ty=6.9114; tz= -7.0765 },
- { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
- d=0.4552; e=0.6637; f=0.5935;
- g= -0.8042; h=0.0203; i=0.5941;
- tx= -6.9472; ty= -4.1186; tz= -5.9108 },
- { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
- d= -0.8247; e=0.5587; f= -0.0878;
- g=0.0426; h=0.2162; i=0.9754;
- tx=6.2694; ty= -7.0540; tz=3.3316 },
- { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *)
- { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *)
- { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *)
- { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *)
- { x = 5.4352; y = 8.2183; z = -2.7757 }, (* C5' *)
- { x = 5.3830; y = 8.7883; z = -1.8481 }, (* H5' *)
- { x = 5.7729; y = 8.7436; z = -3.6691 }, (* H5'' *)
- { x = 6.4830; y = 7.1518; z = -2.5252 }, (* C4' *)
- { x = 7.4749; y = 7.5972; z = -2.4482 }, (* H4' *)
- { x = 6.1626; y = 6.4620; z = -1.2827 }, (* O4' *)
- { x = 6.5431; y = 5.0992; z = -1.3905 }, (* C1' *)
- { x = 7.2871; y = 4.9328; z = -0.6114 }, (* H1' *)
- { x = 7.1852; y = 4.8935; z = -2.7592 }, (* C2' *)
- { x = 6.8573; y = 3.9363; z = -3.1645 }, (* H2'' *)
- { x = 8.5780; y = 5.1025; z = -2.6046 }, (* O2' *)
- { x = 8.9516; y = 4.7577; z = -1.7902 }, (* H2' *)
- { x = 6.5522; y = 6.0300; z = -3.5612 }, (* C3' *)
- { x = 5.5420; y = 5.7356; z = -3.8459 }, (* H3' *)
- { x = 7.3487; y = 6.4089; z = -4.6867 }, (* O3' *)
- { x = 3.6343; y = 2.6680; z = 2.0783 }, (* N1 *)
- { x = 5.4505; y = 3.9805; z = 1.2446 }, (* N3 *)
- { x = 4.7540; y = 3.3816; z = 2.1851 }, (* C2 *)
- { x = 4.8805; y = 3.7951; z = 0.0354 }, (* C4 *)
- { x = 3.7416; y = 3.0925; z = -0.2305 }, (* C5 *)
- { x = 3.0873; y = 2.4980; z = 0.8606 }, (* C6 *)
- (A (
- { x = 1.9600; y = 1.7805; z = 0.7462 }, (* N6 *)
- { x = 3.4605; y = 3.1184; z = -1.5906 }, (* N7 *)
- { x = 5.3247; y = 4.2695; z = -1.1710 }, (* N9 *)
- { x = 4.4244; y = 3.8244; z = -2.0953 }, (* C8 *)
- { x = 5.0814; y = 3.4352; z = 3.2234 }, (* H2 *)
- { x = 1.5423; y = 1.6454; z = -0.1520 }, (* H61 *)
- { x = 1.5716; y = 1.3398; z = 1.5392 }, (* H62 *)
- { x = 4.2675; y = 3.8876; z = -3.1721 }) (* H8 *)
- )
- )
-
-let rA05
- = N(
- { a= -0.5891; b=0.0449; c=0.8068; (* dgf_base_tfo *)
- d=0.5375; e=0.7673; f=0.3498;
- g= -0.6034; h=0.6397; i= -0.4762;
- tx= -0.3019; ty= -3.7679; tz= -9.5913 },
- { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
- d= -0.0433; e= -0.4257; f=0.9038;
- g= -0.5788; h=0.7480; i=0.3246;
- tx=1.5227; ty=6.9114; tz= -7.0765 },
- { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
- d=0.4552; e=0.6637; f=0.5935;
- g= -0.8042; h=0.0203; i=0.5941;
- tx= -6.9472; ty= -4.1186; tz= -5.9108 },
- { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
- d= -0.8247; e=0.5587; f= -0.0878;
- g=0.0426; h=0.2162; i=0.9754;
- tx=6.2694; ty= -7.0540; tz=3.3316 },
- { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *)
- { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *)
- { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *)
- { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *)
- { x = 4.5778; y = 6.6594; z = -4.0364 }, (* C5' *)
- { x = 4.9220; y = 7.1963; z = -4.9204 }, (* H5' *)
- { x = 3.7996; y = 5.9091; z = -4.1764 }, (* H5'' *)
- { x = 5.7873; y = 5.8869; z = -3.5482 }, (* C4' *)
- { x = 6.0405; y = 5.0875; z = -4.2446 }, (* H4' *)
- { x = 6.9135; y = 6.8036; z = -3.4310 }, (* O4' *)
- { x = 7.7293; y = 6.4084; z = -2.3392 }, (* C1' *)
- { x = 8.7078; y = 6.1815; z = -2.7624 }, (* H1' *)
- { x = 7.1305; y = 5.1418; z = -1.7347 }, (* C2' *)
- { x = 7.2040; y = 5.1982; z = -0.6486 }, (* H2'' *)
- { x = 7.7417; y = 4.0392; z = -2.3813 }, (* O2' *)
- { x = 8.6785; y = 4.1443; z = -2.5630 }, (* H2' *)
- { x = 5.6666; y = 5.2728; z = -2.1536 }, (* C3' *)
- { x = 5.1747; y = 5.9805; z = -1.4863 }, (* H3' *)
- { x = 4.9997; y = 4.0086; z = -2.1973 }, (* O3' *)
- { x = 10.2594; y = 10.6774; z = -1.0056 }, (* N1 *)
- { x = 9.7528; y = 8.7080; z = -2.2631 }, (* N3 *)
- { x = 10.4471; y = 9.7876; z = -1.9791 }, (* C2 *)
- { x = 8.7271; y = 8.5575; z = -1.3991 }, (* C4 *)
- { x = 8.4100; y = 9.3803; z = -0.3580 }, (* C5 *)
- { x = 9.2294; y = 10.5030; z = -0.1574 }, (* C6 *)
- (A (
- { x = 9.0349; y = 11.3951; z = 0.8250 }, (* N6 *)
- { x = 7.2891; y = 8.9068; z = 0.3121 }, (* N7 *)
- { x = 7.7962; y = 7.5519; z = -1.3859 }, (* N9 *)
- { x = 6.9702; y = 7.8292; z = -0.3353 }, (* C8 *)
- { x = 11.3132; y = 10.0537; z = -2.5851 }, (* H2 *)
- { x = 8.2741; y = 11.2784; z = 1.4629 }, (* H61 *)
- { x = 9.6733; y = 12.1368; z = 0.9529 }, (* H62 *)
- { x = 6.0888; y = 7.3990; z = 0.1403 }) (* H8 *)
- )
- )
-
-let rA06
- = N(
- { a= -0.9815; b=0.0731; c= -0.1772; (* dgf_base_tfo *)
- d=0.1912; e=0.3054; f= -0.9328;
- g= -0.0141; h= -0.9494; i= -0.3137;
- tx=5.7506; ty= -5.1944; tz=4.7470 },
- { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
- d= -0.0433; e= -0.4257; f=0.9038;
- g= -0.5788; h=0.7480; i=0.3246;
- tx=1.5227; ty=6.9114; tz= -7.0765 },
- { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
- d=0.4552; e=0.6637; f=0.5935;
- g= -0.8042; h=0.0203; i=0.5941;
- tx= -6.9472; ty= -4.1186; tz= -5.9108 },
- { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
- d= -0.8247; e=0.5587; f= -0.0878;
- g=0.0426; h=0.2162; i=0.9754;
- tx=6.2694; ty= -7.0540; tz=3.3316 },
- { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *)
- { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *)
- { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *)
- { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *)
- { x = 4.1214; y = 6.7116; z = -1.9049 }, (* C5' *)
- { x = 3.3465; y = 5.9610; z = -2.0607 }, (* H5' *)
- { x = 4.0789; y = 7.2928; z = -0.9837 }, (* H5'' *)
- { x = 5.4170; y = 5.9293; z = -1.8186 }, (* C4' *)
- { x = 5.4506; y = 5.3400; z = -0.9023 }, (* H4' *)
- { x = 5.5067; y = 5.0417; z = -2.9703 }, (* O4' *)
- { x = 6.8650; y = 4.9152; z = -3.3612 }, (* C1' *)
- { x = 7.1090; y = 3.8577; z = -3.2603 }, (* H1' *)
- { x = 7.7152; y = 5.7282; z = -2.3894 }, (* C2' *)
- { x = 8.5029; y = 6.2356; z = -2.9463 }, (* H2'' *)
- { x = 8.1036; y = 4.8568; z = -1.3419 }, (* O2' *)
- { x = 8.3270; y = 3.9651; z = -1.6184 }, (* H2' *)
- { x = 6.7003; y = 6.7565; z = -1.8911 }, (* C3' *)
- { x = 6.5898; y = 7.5329; z = -2.6482 }, (* H3' *)
- { x = 7.0505; y = 7.2878; z = -0.6105 }, (* O3' *)
- { x = 6.6624; y = 3.5061; z = -8.2986 }, (* N1 *)
- { x = 6.5810; y = 3.2570; z = -5.9221 }, (* N3 *)
- { x = 6.5151; y = 2.8263; z = -7.1625 }, (* C2 *)
- { x = 6.8364; y = 4.5817; z = -5.8882 }, (* C4 *)
- { x = 7.0116; y = 5.4064; z = -6.9609 }, (* C5 *)
- { x = 6.9173; y = 4.8260; z = -8.2361 }, (* C6 *)
- (A (
- { x = 7.0668; y = 5.5163; z = -9.3763 }, (* N6 *)
- { x = 7.2573; y = 6.7070; z = -6.5394 }, (* N7 *)
- { x = 6.9740; y = 5.3703; z = -4.7760 }, (* N9 *)
- { x = 7.2238; y = 6.6275; z = -5.2453 }, (* C8 *)
- { x = 6.3146; y = 1.7741; z = -7.3641 }, (* H2 *)
- { x = 7.2568; y = 6.4972; z = -9.3456 }, (* H61 *)
- { x = 7.0437; y = 5.0478; z = -10.2446 }, (* H62 *)
- { x = 7.4108; y = 7.6227; z = -4.8418 }) (* H8 *)
- )
- )
-
-let rA07
- = N(
- { a=0.2379; b=0.1310; c= -0.9624; (* dgf_base_tfo *)
- d= -0.5876; e= -0.7696; f= -0.2499;
- g= -0.7734; h=0.6249; i= -0.1061;
- tx=30.9870; ty= -26.9344; tz=42.6416 },
- { a=0.7529; b=0.1548; c=0.6397; (* P_O3'_275_tfo *)
- d=0.2952; e= -0.9481; f= -0.1180;
- g=0.5882; h=0.2777; i= -0.7595;
- tx= -58.8919; ty= -11.3095; tz=6.0866 },
- { a= -0.0239; b=0.9667; c= -0.2546; (* P_O3'_180_tfo *)
- d=0.9731; e= -0.0359; f= -0.2275;
- g= -0.2290; h= -0.2532; i= -0.9399;
- tx=3.5401; ty= -29.7913; tz=52.2796 },
- { a= -0.8912; b= -0.4531; c=0.0242; (* P_O3'_60_tfo *)
- d= -0.1183; e=0.1805; f= -0.9764;
- g=0.4380; h= -0.8730; i= -0.2145;
- tx=19.9023; ty=54.8054; tz=15.2799 },
- { x = 41.8210; y = 8.3880; z = 43.5890 }, (* P *)
- { x = 42.5400; y = 8.0450; z = 44.8330 }, (* O1P *)
- { x = 42.2470; y = 9.6920; z = 42.9910 }, (* O2P *)
- { x = 40.2550; y = 8.2030; z = 43.7340 }, (* O5' *)
- { x = 39.3505; y = 8.4697; z = 42.6565 }, (* C5' *)
- { x = 39.1377; y = 7.5433; z = 42.1230 }, (* H5' *)
- { x = 39.7203; y = 9.3119; z = 42.0717 }, (* H5'' *)
- { x = 38.0405; y = 8.9195; z = 43.2869 }, (* C4' *)
- { x = 37.3687; y = 9.3036; z = 42.5193 }, (* H4' *)
- { x = 37.4319; y = 7.8146; z = 43.9387 }, (* O4' *)
- { x = 37.1959; y = 8.1354; z = 45.3237 }, (* C1' *)
- { x = 36.1788; y = 8.5202; z = 45.3970 }, (* H1' *)
- { x = 38.1721; y = 9.2328; z = 45.6504 }, (* C2' *)
- { x = 39.1555; y = 8.7939; z = 45.8188 }, (* H2'' *)
- { x = 37.7862; y = 10.0617; z = 46.7013 }, (* O2' *)
- { x = 37.3087; y = 9.6229; z = 47.4092 }, (* H2' *)
- { x = 38.1844; y = 10.0268; z = 44.3367 }, (* C3' *)
- { x = 39.1578; y = 10.5054; z = 44.2289 }, (* H3' *)
- { x = 37.0547; y = 10.9127; z = 44.3441 }, (* O3' *)
- { x = 34.8811; y = 4.2072; z = 47.5784 }, (* N1 *)
- { x = 35.1084; y = 6.1336; z = 46.1818 }, (* N3 *)
- { x = 34.4108; y = 5.1360; z = 46.7207 }, (* C2 *)
- { x = 36.3908; y = 6.1224; z = 46.6053 }, (* C4 *)
- { x = 36.9819; y = 5.2334; z = 47.4697 }, (* C5 *)
- { x = 36.1786; y = 4.1985; z = 48.0035 }, (* C6 *)
- (A (
- { x = 36.6103; y = 3.2749; z = 48.8452 }, (* N6 *)
- { x = 38.3236; y = 5.5522; z = 47.6595 }, (* N7 *)
- { x = 37.3887; y = 7.0024; z = 46.2437 }, (* N9 *)
- { x = 38.5055; y = 6.6096; z = 46.9057 }, (* C8 *)
- { x = 33.3553; y = 5.0152; z = 46.4771 }, (* H2 *)
- { x = 37.5730; y = 3.2804; z = 49.1507 }, (* H61 *)
- { x = 35.9775; y = 2.5638; z = 49.1828 }, (* H62 *)
- { x = 39.5461; y = 6.9184; z = 47.0041 }) (* H8 *)
- )
- )
-
-let rA08
- = N(
- { a=0.1084; b= -0.0895; c= -0.9901; (* dgf_base_tfo *)
- d=0.9789; e= -0.1638; f=0.1220;
- g= -0.1731; h= -0.9824; i=0.0698;
- tx= -2.9039; ty=47.2655; tz=33.0094 },
- { a=0.7529; b=0.1548; c=0.6397; (* P_O3'_275_tfo *)
- d=0.2952; e= -0.9481; f= -0.1180;
- g=0.5882; h=0.2777; i= -0.7595;
- tx= -58.8919; ty= -11.3095; tz=6.0866 },
- { a= -0.0239; b=0.9667; c= -0.2546; (* P_O3'_180_tfo *)
- d=0.9731; e= -0.0359; f= -0.2275;
- g= -0.2290; h= -0.2532; i= -0.9399;
- tx=3.5401; ty= -29.7913; tz=52.2796 },
- { a= -0.8912; b= -0.4531; c=0.0242; (* P_O3'_60_tfo *)
- d= -0.1183; e=0.1805; f= -0.9764;
- g=0.4380; h= -0.8730; i= -0.2145;
- tx=19.9023; ty=54.8054; tz=15.2799 },
- { x = 41.8210; y = 8.3880; z = 43.5890 }, (* P *)
- { x = 42.5400; y = 8.0450; z = 44.8330 }, (* O1P *)
- { x = 42.2470; y = 9.6920; z = 42.9910 }, (* O2P *)
- { x = 40.2550; y = 8.2030; z = 43.7340 }, (* O5' *)
- { x = 39.4850; y = 8.9301; z = 44.6977 }, (* C5' *)
- { x = 39.0638; y = 9.8199; z = 44.2296 }, (* H5' *)
- { x = 40.0757; y = 9.0713; z = 45.6029 }, (* H5'' *)
- { x = 38.3102; y = 8.0414; z = 45.0789 }, (* C4' *)
- { x = 37.7842; y = 8.4637; z = 45.9351 }, (* H4' *)
- { x = 37.4200; y = 7.9453; z = 43.9769 }, (* O4' *)
- { x = 37.2249; y = 6.5609; z = 43.6273 }, (* C1' *)
- { x = 36.3360; y = 6.2168; z = 44.1561 }, (* H1' *)
- { x = 38.4347; y = 5.8414; z = 44.1590 }, (* C2' *)
- { x = 39.2688; y = 5.9974; z = 43.4749 }, (* H2'' *)
- { x = 38.2344; y = 4.4907; z = 44.4348 }, (* O2' *)
- { x = 37.6374; y = 4.0386; z = 43.8341 }, (* H2' *)
- { x = 38.6926; y = 6.6079; z = 45.4637 }, (* C3' *)
- { x = 39.7585; y = 6.5640; z = 45.6877 }, (* H3' *)
- { x = 37.8238; y = 6.0705; z = 46.4723 }, (* O3' *)
- { x = 33.9162; y = 6.2598; z = 39.7758 }, (* N1 *)
- { x = 34.6709; y = 6.5759; z = 42.0215 }, (* N3 *)
- { x = 33.7257; y = 6.5186; z = 41.0858 }, (* C2 *)
- { x = 35.8935; y = 6.3324; z = 41.5018 }, (* C4 *)
- { x = 36.2105; y = 6.0601; z = 40.1932 }, (* C5 *)
- { x = 35.1538; y = 6.0151; z = 39.2537 }, (* C6 *)
- (A (
- { x = 35.3088; y = 5.7642; z = 37.9649 }, (* N6 *)
- { x = 37.5818; y = 5.8677; z = 40.0507 }, (* N7 *)
- { x = 37.0932; y = 6.3197; z = 42.1810 }, (* N9 *)
- { x = 38.0509; y = 6.0354; z = 41.2635 }, (* C8 *)
- { x = 32.6830; y = 6.6898; z = 41.3532 }, (* H2 *)
- { x = 36.2305; y = 5.5855; z = 37.5925 }, (* H61 *)
- { x = 34.5056; y = 5.7512; z = 37.3528 }, (* H62 *)
- { x = 39.1318; y = 5.8993; z = 41.2285 }) (* H8 *)
- )
- )
-
-let rA09
- = N(
- { a=0.8467; b=0.4166; c= -0.3311; (* dgf_base_tfo *)
- d= -0.3962; e=0.9089; f=0.1303;
- g=0.3552; h=0.0209; i=0.9346;
- tx= -42.7319; ty= -26.6223; tz= -29.8163 },
- { a=0.7529; b=0.1548; c=0.6397; (* P_O3'_275_tfo *)
- d=0.2952; e= -0.9481; f= -0.1180;
- g=0.5882; h=0.2777; i= -0.7595;
- tx= -58.8919; ty= -11.3095; tz=6.0866 },
- { a= -0.0239; b=0.9667; c= -0.2546; (* P_O3'_180_tfo *)
- d=0.9731; e= -0.0359; f= -0.2275;
- g= -0.2290; h= -0.2532; i= -0.9399;
- tx=3.5401; ty= -29.7913; tz=52.2796 },
- { a= -0.8912; b= -0.4531; c=0.0242; (* P_O3'_60_tfo *)
- d= -0.1183; e=0.1805; f= -0.9764;
- g=0.4380; h= -0.8730; i= -0.2145;
- tx=19.9023; ty=54.8054; tz=15.2799 },
- { x = 41.8210; y = 8.3880; z = 43.5890 }, (* P *)
- { x = 42.5400; y = 8.0450; z = 44.8330 }, (* O1P *)
- { x = 42.2470; y = 9.6920; z = 42.9910 }, (* O2P *)
- { x = 40.2550; y = 8.2030; z = 43.7340 }, (* O5' *)
- { x = 39.3505; y = 8.4697; z = 42.6565 }, (* C5' *)
- { x = 39.1377; y = 7.5433; z = 42.1230 }, (* H5' *)
- { x = 39.7203; y = 9.3119; z = 42.0717 }, (* H5'' *)
- { x = 38.0405; y = 8.9195; z = 43.2869 }, (* C4' *)
- { x = 37.6479; y = 8.1347; z = 43.9335 }, (* H4' *)
- { x = 38.2691; y = 10.0933; z = 44.0524 }, (* O4' *)
- { x = 37.3999; y = 11.1488; z = 43.5973 }, (* C1' *)
- { x = 36.5061; y = 11.1221; z = 44.2206 }, (* H1' *)
- { x = 37.0364; y = 10.7838; z = 42.1836 }, (* C2' *)
- { x = 37.8636; y = 11.0489; z = 41.5252 }, (* H2'' *)
- { x = 35.8275; y = 11.3133; z = 41.7379 }, (* O2' *)
- { x = 35.6214; y = 12.1896; z = 42.0714 }, (* H2' *)
- { x = 36.9316; y = 9.2556; z = 42.2837 }, (* C3' *)
- { x = 37.1778; y = 8.8260; z = 41.3127 }, (* H3' *)
- { x = 35.6285; y = 8.9334; z = 42.7926 }, (* O3' *)
- { x = 38.1482; y = 15.2833; z = 46.4641 }, (* N1 *)
- { x = 37.3641; y = 13.0968; z = 45.9007 }, (* N3 *)
- { x = 37.5032; y = 14.1288; z = 46.7300 }, (* C2 *)
- { x = 37.9570; y = 13.3377; z = 44.7113 }, (* C4 *)
- { x = 38.6397; y = 14.4660; z = 44.3267 }, (* C5 *)
- { x = 38.7473; y = 15.5229; z = 45.2609 }, (* C6 *)
- (A (
- { x = 39.3720; y = 16.6649; z = 45.0297 }, (* N6 *)
- { x = 39.1079; y = 14.3351; z = 43.0223 }, (* N7 *)
- { x = 38.0132; y = 12.4868; z = 43.6280 }, (* N9 *)
- { x = 38.7058; y = 13.1402; z = 42.6620 }, (* C8 *)
- { x = 37.0731; y = 14.0857; z = 47.7306 }, (* H2 *)
- { x = 39.8113; y = 16.8281; z = 44.1350 }, (* H61 *)
- { x = 39.4100; y = 17.3741; z = 45.7478 }, (* H62 *)
- { x = 39.0412; y = 12.9660; z = 41.6397 }) (* H8 *)
- )
- )
-
-let rA10
- = N(
- { a=0.7063; b=0.6317; c= -0.3196; (* dgf_base_tfo *)
- d= -0.0403; e= -0.4149; f= -0.9090;
- g= -0.7068; h=0.6549; i= -0.2676;
- tx=6.4402; ty= -52.1496; tz=30.8246 },
- { a=0.7529; b=0.1548; c=0.6397; (* P_O3'_275_tfo *)
- d=0.2952; e= -0.9481; f= -0.1180;
- g=0.5882; h=0.2777; i= -0.7595;
- tx= -58.8919; ty= -11.3095; tz=6.0866 },
- { a= -0.0239; b=0.9667; c= -0.2546; (* P_O3'_180_tfo *)
- d=0.9731; e= -0.0359; f= -0.2275;
- g= -0.2290; h= -0.2532; i= -0.9399;
- tx=3.5401; ty= -29.7913; tz=52.2796 },
- { a= -0.8912; b= -0.4531; c=0.0242; (* P_O3'_60_tfo *)
- d= -0.1183; e=0.1805; f= -0.9764;
- g=0.4380; h= -0.8730; i= -0.2145;
- tx=19.9023; ty=54.8054; tz=15.2799 },
- { x = 41.8210; y = 8.3880; z = 43.5890 }, (* P *)
- { x = 42.5400; y = 8.0450; z = 44.8330 }, (* O1P *)
- { x = 42.2470; y = 9.6920; z = 42.9910 }, (* O2P *)
- { x = 40.2550; y = 8.2030; z = 43.7340 }, (* O5' *)
- { x = 39.4850; y = 8.9301; z = 44.6977 }, (* C5' *)
- { x = 39.0638; y = 9.8199; z = 44.2296 }, (* H5' *)
- { x = 40.0757; y = 9.0713; z = 45.6029 }, (* H5'' *)
- { x = 38.3102; y = 8.0414; z = 45.0789 }, (* C4' *)
- { x = 37.7099; y = 7.8166; z = 44.1973 }, (* H4' *)
- { x = 38.8012; y = 6.8321; z = 45.6380 }, (* O4' *)
- { x = 38.2431; y = 6.6413; z = 46.9529 }, (* C1' *)
- { x = 37.3505; y = 6.0262; z = 46.8385 }, (* H1' *)
- { x = 37.8484; y = 8.0156; z = 47.4214 }, (* C2' *)
- { x = 38.7381; y = 8.5406; z = 47.7690 }, (* H2'' *)
- { x = 36.8286; y = 8.0368; z = 48.3701 }, (* O2' *)
- { x = 36.8392; y = 7.3063; z = 48.9929 }, (* H2' *)
- { x = 37.3576; y = 8.6512; z = 46.1132 }, (* C3' *)
- { x = 37.5207; y = 9.7275; z = 46.1671 }, (* H3' *)
- { x = 35.9985; y = 8.2392; z = 45.9032 }, (* O3' *)
- { x = 39.9117; y = 2.2278; z = 48.8527 }, (* N1 *)
- { x = 38.6207; y = 3.6941; z = 47.4757 }, (* N3 *)
- { x = 38.9872; y = 2.4888; z = 47.9057 }, (* C2 *)
- { x = 39.2961; y = 4.6720; z = 48.1174 }, (* C4 *)
- { x = 40.2546; y = 4.5307; z = 49.0912 }, (* C5 *)
- { x = 40.5932; y = 3.2189; z = 49.4985 }, (* C6 *)
- (A (
- { x = 41.4938; y = 2.9317; z = 50.4229 }, (* N6 *)
- { x = 40.7195; y = 5.7755; z = 49.5060 }, (* N7 *)
- { x = 39.1730; y = 6.0305; z = 47.9170 }, (* N9 *)
- { x = 40.0413; y = 6.6250; z = 48.7728 }, (* C8 *)
- { x = 38.5257; y = 1.5960; z = 47.4838 }, (* H2 *)
- { x = 41.9907; y = 3.6753; z = 50.8921 }, (* H61 *)
- { x = 41.6848; y = 1.9687; z = 50.6599 }, (* H62 *)
- { x = 40.3571; y = 7.6321; z = 49.0452 }) (* H8 *)
- )
- )
-
-let rAs = [rA01;rA02;rA03;rA04;rA05;rA06;rA07;rA08;rA09;rA10]
-
-let rC
- = N(
- { a= -0.0359; b= -0.8071; c=0.5894; (* dgf_base_tfo *)
- d= -0.2669; e=0.5761; f=0.7726;
- g= -0.9631; h= -0.1296; i= -0.2361;
- tx=0.1584; ty=8.3434; tz=0.5434 },
- { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
- d=0.0649; e=0.4366; f= -0.8973;
- g=0.5521; h= -0.7648; i= -0.3322;
- tx=1.6833; ty=6.8060; tz= -7.0011 },
- { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
- d= -0.4628; e= -0.6450; f= -0.6082;
- g=0.8168; h= -0.0436; i= -0.5753;
- tx= -6.8179; ty= -3.9778; tz= -5.9887 },
- { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
- d=0.8103; e= -0.5790; f=0.0906;
- g= -0.0255; h= -0.1894; i= -0.9816;
- tx=6.1203; ty= -7.1051; tz=3.1984 },
- { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *)
- { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *)
- { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *)
- { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *)
- { x = 5.2430; y = -8.2420; z = 2.8260 }, (* C5' *)
- { x = 5.1974; y = -8.8497; z = 1.9223 }, (* H5' *)
- { x = 5.5548; y = -8.7348; z = 3.7469 }, (* H5'' *)
- { x = 6.3140; y = -7.2060; z = 2.5510 }, (* C4' *)
- { x = 7.2954; y = -7.6762; z = 2.4898 }, (* H4' *)
- { x = 6.0140; y = -6.5420; z = 1.2890 }, (* O4' *)
- { x = 6.4190; y = -5.1840; z = 1.3620 }, (* C1' *)
- { x = 7.1608; y = -5.0495; z = 0.5747 }, (* H1' *)
- { x = 7.0760; y = -4.9560; z = 2.7270 }, (* C2' *)
- { x = 6.7770; y = -3.9803; z = 3.1099 }, (* H2'' *)
- { x = 8.4500; y = -5.1930; z = 2.5810 }, (* O2' *)
- { x = 8.8309; y = -4.8755; z = 1.7590 }, (* H2' *)
- { x = 6.4060; y = -6.0590; z = 3.5580 }, (* C3' *)
- { x = 5.4021; y = -5.7313; z = 3.8281 }, (* H3' *)
- { x = 7.1570; y = -6.4240; z = 4.7070 }, (* O3' *)
- { x = 5.2170; y = -4.3260; z = 1.1690 }, (* N1 *)
- { x = 4.2960; y = -2.2560; z = 0.6290 }, (* N3 *)
- { x = 5.4330; y = -3.0200; z = 0.7990 }, (* C2 *)
- { x = 2.9930; y = -2.6780; z = 0.7940 }, (* C4 *)
- { x = 2.8670; y = -4.0630; z = 1.1830 }, (* C5 *)
- { x = 3.9570; y = -4.8300; z = 1.3550 }, (* C6 *)
- (C (
- { x = 2.0187; y = -1.8047; z = 0.5874 }, (* N4 *)
- { x = 6.5470; y = -2.5560; z = 0.6290 }, (* O2 *)
- { x = 1.0684; y = -2.1236; z = 0.7109 }, (* H41 *)
- { x = 2.2344; y = -0.8560; z = 0.3162 }, (* H42 *)
- { x = 1.8797; y = -4.4972; z = 1.3404 }, (* H5 *)
- { x = 3.8479; y = -5.8742; z = 1.6480 }) (* H6 *)
- )
- )
-
-let rC01
- = N(
- { a= -0.0137; b= -0.8012; c=0.5983; (* dgf_base_tfo *)
- d= -0.2523; e=0.5817; f=0.7733;
- g= -0.9675; h= -0.1404; i= -0.2101;
- tx=0.2031; ty=8.3874; tz=0.4228 },
- { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
- d=0.0649; e=0.4366; f= -0.8973;
- g=0.5521; h= -0.7648; i= -0.3322;
- tx=1.6833; ty=6.8060; tz= -7.0011 },
- { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
- d= -0.4628; e= -0.6450; f= -0.6082;
- g=0.8168; h= -0.0436; i= -0.5753;
- tx= -6.8179; ty= -3.9778; tz= -5.9887 },
- { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
- d=0.8103; e= -0.5790; f=0.0906;
- g= -0.0255; h= -0.1894; i= -0.9816;
- tx=6.1203; ty= -7.1051; tz=3.1984 },
- { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *)
- { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *)
- { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *)
- { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *)
- { x = 5.2416; y = -8.2422; z = 2.8181 }, (* C5' *)
- { x = 5.2050; y = -8.8128; z = 1.8901 }, (* H5' *)
- { x = 5.5368; y = -8.7738; z = 3.7227 }, (* H5'' *)
- { x = 6.3232; y = -7.2037; z = 2.6002 }, (* C4' *)
- { x = 7.3048; y = -7.6757; z = 2.5577 }, (* H4' *)
- { x = 6.0635; y = -6.5092; z = 1.3456 }, (* O4' *)
- { x = 6.4697; y = -5.1547; z = 1.4629 }, (* C1' *)
- { x = 7.2354; y = -5.0043; z = 0.7018 }, (* H1' *)
- { x = 7.0856; y = -4.9610; z = 2.8521 }, (* C2' *)
- { x = 6.7777; y = -3.9935; z = 3.2487 }, (* H2'' *)
- { x = 8.4627; y = -5.1992; z = 2.7423 }, (* O2' *)
- { x = 8.8693; y = -4.8638; z = 1.9399 }, (* H2' *)
- { x = 6.3877; y = -6.0809; z = 3.6362 }, (* C3' *)
- { x = 5.3770; y = -5.7562; z = 3.8834 }, (* H3' *)
- { x = 7.1024; y = -6.4754; z = 4.7985 }, (* O3' *)
- { x = 5.2764; y = -4.2883; z = 1.2538 }, (* N1 *)
- { x = 4.3777; y = -2.2062; z = 0.7229 }, (* N3 *)
- { x = 5.5069; y = -2.9779; z = 0.9088 }, (* C2 *)
- { x = 3.0693; y = -2.6246; z = 0.8500 }, (* C4 *)
- { x = 2.9279; y = -4.0146; z = 1.2149 }, (* C5 *)
- { x = 4.0101; y = -4.7892; z = 1.4017 }, (* C6 *)
- (C (
- { x = 2.1040; y = -1.7437; z = 0.6331 }, (* N4 *)
- { x = 6.6267; y = -2.5166; z = 0.7728 }, (* O2 *)
- { x = 1.1496; y = -2.0600; z = 0.7287 }, (* H41 *)
- { x = 2.3303; y = -0.7921; z = 0.3815 }, (* H42 *)
- { x = 1.9353; y = -4.4465; z = 1.3419 }, (* H5 *)
- { x = 3.8895; y = -5.8371; z = 1.6762 }) (* H6 *)
- )
- )
-
-let rC02
- = N(
- { a=0.5141; b=0.0246; c=0.8574; (* dgf_base_tfo *)
- d= -0.5547; e= -0.7529; f=0.3542;
- g=0.6542; h= -0.6577; i= -0.3734;
- tx= -9.1111; ty= -3.4598; tz= -3.2939 },
- { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
- d=0.0649; e=0.4366; f= -0.8973;
- g=0.5521; h= -0.7648; i= -0.3322;
- tx=1.6833; ty=6.8060; tz= -7.0011 },
- { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
- d= -0.4628; e= -0.6450; f= -0.6082;
- g=0.8168; h= -0.0436; i= -0.5753;
- tx= -6.8179; ty= -3.9778; tz= -5.9887 },
- { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
- d=0.8103; e= -0.5790; f=0.0906;
- g= -0.0255; h= -0.1894; i= -0.9816;
- tx=6.1203; ty= -7.1051; tz=3.1984 },
- { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *)
- { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *)
- { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *)
- { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *)
- { x = 4.3825; y = -6.6585; z = 4.0489 }, (* C5' *)
- { x = 4.6841; y = -7.2019; z = 4.9443 }, (* H5' *)
- { x = 3.6189; y = -5.8889; z = 4.1625 }, (* H5'' *)
- { x = 5.6255; y = -5.9175; z = 3.5998 }, (* C4' *)
- { x = 5.8732; y = -5.1228; z = 4.3034 }, (* H4' *)
- { x = 6.7337; y = -6.8605; z = 3.5222 }, (* O4' *)
- { x = 7.5932; y = -6.4923; z = 2.4548 }, (* C1' *)
- { x = 8.5661; y = -6.2983; z = 2.9064 }, (* H1' *)
- { x = 7.0527; y = -5.2012; z = 1.8322 }, (* C2' *)
- { x = 7.1627; y = -5.2525; z = 0.7490 }, (* H2'' *)
- { x = 7.6666; y = -4.1249; z = 2.4880 }, (* O2' *)
- { x = 8.5944; y = -4.2543; z = 2.6981 }, (* H2' *)
- { x = 5.5661; y = -5.3029; z = 2.2009 }, (* C3' *)
- { x = 5.0841; y = -6.0018; z = 1.5172 }, (* H3' *)
- { x = 4.9062; y = -4.0452; z = 2.2042 }, (* O3' *)
- { x = 7.6298; y = -7.6136; z = 1.4752 }, (* N1 *)
- { x = 8.6945; y = -8.7046; z = -0.2857 }, (* N3 *)
- { x = 8.6943; y = -7.6514; z = 0.6066 }, (* C2 *)
- { x = 7.7426; y = -9.6987; z = -0.3801 }, (* C4 *)
- { x = 6.6642; y = -9.5742; z = 0.5722 }, (* C5 *)
- { x = 6.6391; y = -8.5592; z = 1.4526 }, (* C6 *)
- (C (
- { x = 7.9033; y = -10.6371; z = -1.3010 }, (* N4 *)
- { x = 9.5840; y = -6.8186; z = 0.6136 }, (* O2 *)
- { x = 7.2009; y = -11.3604; z = -1.3619 }, (* H41 *)
- { x = 8.7058; y = -10.6168; z = -1.9140 }, (* H42 *)
- { x = 5.8585; y = -10.3083; z = 0.5822 }, (* H5 *)
- { x = 5.8197; y = -8.4773; z = 2.1667 }) (* H6 *)
- )
- )
-
-let rC03
- = N(
- { a= -0.4993; b=0.0476; c=0.8651; (* dgf_base_tfo *)
- d=0.8078; e= -0.3353; f=0.4847;
- g=0.3132; h=0.9409; i=0.1290;
- tx=6.2989; ty= -5.2303; tz= -3.8577 },
- { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
- d=0.0649; e=0.4366; f= -0.8973;
- g=0.5521; h= -0.7648; i= -0.3322;
- tx=1.6833; ty=6.8060; tz= -7.0011 },
- { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
- d= -0.4628; e= -0.6450; f= -0.6082;
- g=0.8168; h= -0.0436; i= -0.5753;
- tx= -6.8179; ty= -3.9778; tz= -5.9887 },
- { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
- d=0.8103; e= -0.5790; f=0.0906;
- g= -0.0255; h= -0.1894; i= -0.9816;
- tx=6.1203; ty= -7.1051; tz=3.1984 },
- { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *)
- { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *)
- { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *)
- { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *)
- { x = 3.9938; y = -6.7042; z = 1.9023 }, (* C5' *)
- { x = 3.2332; y = -5.9343; z = 2.0319 }, (* H5' *)
- { x = 3.9666; y = -7.2863; z = 0.9812 }, (* H5'' *)
- { x = 5.3098; y = -5.9546; z = 1.8564 }, (* C4' *)
- { x = 5.3863; y = -5.3702; z = 0.9395 }, (* H4' *)
- { x = 5.3851; y = -5.0642; z = 3.0076 }, (* O4' *)
- { x = 6.7315; y = -4.9724; z = 3.4462 }, (* C1' *)
- { x = 7.0033; y = -3.9202; z = 3.3619 }, (* H1' *)
- { x = 7.5997; y = -5.8018; z = 2.4948 }, (* C2' *)
- { x = 8.3627; y = -6.3254; z = 3.0707 }, (* H2'' *)
- { x = 8.0410; y = -4.9501; z = 1.4724 }, (* O2' *)
- { x = 8.2781; y = -4.0644; z = 1.7570 }, (* H2' *)
- { x = 6.5701; y = -6.8129; z = 1.9714 }, (* C3' *)
- { x = 6.4186; y = -7.5809; z = 2.7299 }, (* H3' *)
- { x = 6.9357; y = -7.3841; z = 0.7235 }, (* O3' *)
- { x = 6.8024; y = -5.4718; z = 4.8475 }, (* N1 *)
- { x = 7.9218; y = -5.5700; z = 6.8877 }, (* N3 *)
- { x = 7.8908; y = -5.0886; z = 5.5944 }, (* C2 *)
- { x = 6.9789; y = -6.3827; z = 7.4823 }, (* C4 *)
- { x = 5.8742; y = -6.7319; z = 6.6202 }, (* C5 *)
- { x = 5.8182; y = -6.2769; z = 5.3570 }, (* C6 *)
- (C (
- { x = 7.1702; y = -6.7511; z = 8.7402 }, (* N4 *)
- { x = 8.7747; y = -4.3728; z = 5.1568 }, (* O2 *)
- { x = 6.4741; y = -7.3461; z = 9.1662 }, (* H41 *)
- { x = 7.9889; y = -6.4396; z = 9.2429 }, (* H42 *)
- { x = 5.0736; y = -7.3713; z = 6.9922 }, (* H5 *)
- { x = 4.9784; y = -6.5473; z = 4.7170 }) (* H6 *)
- )
- )
-
-let rC04
- = N(
- { a= -0.5669; b= -0.8012; c=0.1918; (* dgf_base_tfo *)
- d= -0.8129; e=0.5817; f=0.0273;
- g= -0.1334; h= -0.1404; i= -0.9811;
- tx= -0.3279; ty=8.3874; tz=0.3355 },
- { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
- d=0.0649; e=0.4366; f= -0.8973;
- g=0.5521; h= -0.7648; i= -0.3322;
- tx=1.6833; ty=6.8060; tz= -7.0011 },
- { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
- d= -0.4628; e= -0.6450; f= -0.6082;
- g=0.8168; h= -0.0436; i= -0.5753;
- tx= -6.8179; ty= -3.9778; tz= -5.9887 },
- { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
- d=0.8103; e= -0.5790; f=0.0906;
- g= -0.0255; h= -0.1894; i= -0.9816;
- tx=6.1203; ty= -7.1051; tz=3.1984 },
- { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *)
- { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *)
- { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *)
- { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *)
- { x = 5.2416; y = -8.2422; z = 2.8181 }, (* C5' *)
- { x = 5.2050; y = -8.8128; z = 1.8901 }, (* H5' *)
- { x = 5.5368; y = -8.7738; z = 3.7227 }, (* H5'' *)
- { x = 6.3232; y = -7.2037; z = 2.6002 }, (* C4' *)
- { x = 7.3048; y = -7.6757; z = 2.5577 }, (* H4' *)
- { x = 6.0635; y = -6.5092; z = 1.3456 }, (* O4' *)
- { x = 6.4697; y = -5.1547; z = 1.4629 }, (* C1' *)
- { x = 7.2354; y = -5.0043; z = 0.7018 }, (* H1' *)
- { x = 7.0856; y = -4.9610; z = 2.8521 }, (* C2' *)
- { x = 6.7777; y = -3.9935; z = 3.2487 }, (* H2'' *)
- { x = 8.4627; y = -5.1992; z = 2.7423 }, (* O2' *)
- { x = 8.8693; y = -4.8638; z = 1.9399 }, (* H2' *)
- { x = 6.3877; y = -6.0809; z = 3.6362 }, (* C3' *)
- { x = 5.3770; y = -5.7562; z = 3.8834 }, (* H3' *)
- { x = 7.1024; y = -6.4754; z = 4.7985 }, (* O3' *)
- { x = 5.2764; y = -4.2883; z = 1.2538 }, (* N1 *)
- { x = 3.8961; y = -3.0896; z = -0.1893 }, (* N3 *)
- { x = 5.0095; y = -3.8907; z = -0.0346 }, (* C2 *)
- { x = 3.0480; y = -2.6632; z = 0.8116 }, (* C4 *)
- { x = 3.4093; y = -3.1310; z = 2.1292 }, (* C5 *)
- { x = 4.4878; y = -3.9124; z = 2.3088 }, (* C6 *)
- (C (
- { x = 2.0216; y = -1.8941; z = 0.4804 }, (* N4 *)
- { x = 5.7005; y = -4.2164; z = -0.9842 }, (* O2 *)
- { x = 1.4067; y = -1.5873; z = 1.2205 }, (* H41 *)
- { x = 1.8721; y = -1.6319; z = -0.4835 }, (* H42 *)
- { x = 2.8048; y = -2.8507; z = 2.9918 }, (* H5 *)
- { x = 4.7491; y = -4.2593; z = 3.3085 }) (* H6 *)
- )
- )
-
-let rC05
- = N(
- { a= -0.6298; b=0.0246; c=0.7763; (* dgf_base_tfo *)
- d= -0.5226; e= -0.7529; f= -0.4001;
- g=0.5746; h= -0.6577; i=0.4870;
- tx= -0.0208; ty= -3.4598; tz= -9.6882 },
- { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
- d=0.0649; e=0.4366; f= -0.8973;
- g=0.5521; h= -0.7648; i= -0.3322;
- tx=1.6833; ty=6.8060; tz= -7.0011 },
- { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
- d= -0.4628; e= -0.6450; f= -0.6082;
- g=0.8168; h= -0.0436; i= -0.5753;
- tx= -6.8179; ty= -3.9778; tz= -5.9887 },
- { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
- d=0.8103; e= -0.5790; f=0.0906;
- g= -0.0255; h= -0.1894; i= -0.9816;
- tx=6.1203; ty= -7.1051; tz=3.1984 },
- { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *)
- { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *)
- { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *)
- { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *)
- { x = 4.3825; y = -6.6585; z = 4.0489 }, (* C5' *)
- { x = 4.6841; y = -7.2019; z = 4.9443 }, (* H5' *)
- { x = 3.6189; y = -5.8889; z = 4.1625 }, (* H5'' *)
- { x = 5.6255; y = -5.9175; z = 3.5998 }, (* C4' *)
- { x = 5.8732; y = -5.1228; z = 4.3034 }, (* H4' *)
- { x = 6.7337; y = -6.8605; z = 3.5222 }, (* O4' *)
- { x = 7.5932; y = -6.4923; z = 2.4548 }, (* C1' *)
- { x = 8.5661; y = -6.2983; z = 2.9064 }, (* H1' *)
- { x = 7.0527; y = -5.2012; z = 1.8322 }, (* C2' *)
- { x = 7.1627; y = -5.2525; z = 0.7490 }, (* H2'' *)
- { x = 7.6666; y = -4.1249; z = 2.4880 }, (* O2' *)
- { x = 8.5944; y = -4.2543; z = 2.6981 }, (* H2' *)
- { x = 5.5661; y = -5.3029; z = 2.2009 }, (* C3' *)
- { x = 5.0841; y = -6.0018; z = 1.5172 }, (* H3' *)
- { x = 4.9062; y = -4.0452; z = 2.2042 }, (* O3' *)
- { x = 7.6298; y = -7.6136; z = 1.4752 }, (* N1 *)
- { x = 8.5977; y = -9.5977; z = 0.7329 }, (* N3 *)
- { x = 8.5951; y = -8.5745; z = 1.6594 }, (* C2 *)
- { x = 7.7372; y = -9.7371; z = -0.3364 }, (* C4 *)
- { x = 6.7596; y = -8.6801; z = -0.4476 }, (* C5 *)
- { x = 6.7338; y = -7.6721; z = 0.4408 }, (* C6 *)
- (C (
- { x = 7.8849; y = -10.7881; z = -1.1289 }, (* N4 *)
- { x = 9.3993; y = -8.5377; z = 2.5743 }, (* O2 *)
- { x = 7.2499; y = -10.8809; z = -1.9088 }, (* H41 *)
- { x = 8.6122; y = -11.4649; z = -0.9468 }, (* H42 *)
- { x = 6.0317; y = -8.6941; z = -1.2588 }, (* H5 *)
- { x = 5.9901; y = -6.8809; z = 0.3459 }) (* H6 *)
- )
- )
-
-let rC06
- = N(
- { a= -0.9837; b=0.0476; c= -0.1733; (* dgf_base_tfo *)
- d= -0.1792; e= -0.3353; f=0.9249;
- g= -0.0141; h=0.9409; i=0.3384;
- tx=5.7793; ty= -5.2303; tz=4.5997 },
- { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
- d=0.0649; e=0.4366; f= -0.8973;
- g=0.5521; h= -0.7648; i= -0.3322;
- tx=1.6833; ty=6.8060; tz= -7.0011 },
- { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
- d= -0.4628; e= -0.6450; f= -0.6082;
- g=0.8168; h= -0.0436; i= -0.5753;
- tx= -6.8179; ty= -3.9778; tz= -5.9887 },
- { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
- d=0.8103; e= -0.5790; f=0.0906;
- g= -0.0255; h= -0.1894; i= -0.9816;
- tx=6.1203; ty= -7.1051; tz=3.1984 },
- { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *)
- { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *)
- { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *)
- { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *)
- { x = 3.9938; y = -6.7042; z = 1.9023 }, (* C5' *)
- { x = 3.2332; y = -5.9343; z = 2.0319 }, (* H5' *)
- { x = 3.9666; y = -7.2863; z = 0.9812 }, (* H5'' *)
- { x = 5.3098; y = -5.9546; z = 1.8564 }, (* C4' *)
- { x = 5.3863; y = -5.3702; z = 0.9395 }, (* H4' *)
- { x = 5.3851; y = -5.0642; z = 3.0076 }, (* O4' *)
- { x = 6.7315; y = -4.9724; z = 3.4462 }, (* C1' *)
- { x = 7.0033; y = -3.9202; z = 3.3619 }, (* H1' *)
- { x = 7.5997; y = -5.8018; z = 2.4948 }, (* C2' *)
- { x = 8.3627; y = -6.3254; z = 3.0707 }, (* H2'' *)
- { x = 8.0410; y = -4.9501; z = 1.4724 }, (* O2' *)
- { x = 8.2781; y = -4.0644; z = 1.7570 }, (* H2' *)
- { x = 6.5701; y = -6.8129; z = 1.9714 }, (* C3' *)
- { x = 6.4186; y = -7.5809; z = 2.7299 }, (* H3' *)
- { x = 6.9357; y = -7.3841; z = 0.7235 }, (* O3' *)
- { x = 6.8024; y = -5.4718; z = 4.8475 }, (* N1 *)
- { x = 6.6920; y = -5.0495; z = 7.1354 }, (* N3 *)
- { x = 6.6201; y = -4.5500; z = 5.8506 }, (* C2 *)
- { x = 6.9254; y = -6.3614; z = 7.4926 }, (* C4 *)
- { x = 7.1046; y = -7.2543; z = 6.3718 }, (* C5 *)
- { x = 7.0391; y = -6.7951; z = 5.1106 }, (* C6 *)
- (C (
- { x = 6.9614; y = -6.6648; z = 8.7815 }, (* N4 *)
- { x = 6.4083; y = -3.3696; z = 5.6340 }, (* O2 *)
- { x = 7.1329; y = -7.6280; z = 9.0324 }, (* H41 *)
- { x = 6.8204; y = -5.9469; z = 9.4777 }, (* H42 *)
- { x = 7.2954; y = -8.3135; z = 6.5440 }, (* H5 *)
- { x = 7.1753; y = -7.4798; z = 4.2735 }) (* H6 *)
- )
- )
-
-let rC07
- = N(
- { a=0.0033; b=0.2720; c= -0.9623; (* dgf_base_tfo *)
- d=0.3013; e= -0.9179; f= -0.2584;
- g= -0.9535; h= -0.2891; i= -0.0850;
- tx=43.0403; ty=13.7233; tz=34.5710 },
- { a=0.9187; b=0.2887; c=0.2694; (* P_O3'_275_tfo *)
- d=0.0302; e= -0.7316; f=0.6811;
- g=0.3938; h= -0.6176; i= -0.6808;
- tx= -48.4330; ty=26.3254; tz=13.6383 },
- { a= -0.1504; b=0.7744; c= -0.6145; (* P_O3'_180_tfo *)
- d=0.7581; e=0.4893; f=0.4311;
- g=0.6345; h= -0.4010; i= -0.6607;
- tx= -31.9784; ty= -13.4285; tz=44.9650 },
- { a= -0.6236; b= -0.7810; c= -0.0337; (* P_O3'_60_tfo *)
- d= -0.6890; e=0.5694; f= -0.4484;
- g=0.3694; h= -0.2564; i= -0.8932;
- tx=12.1105; ty=30.8774; tz=46.0946 },
- { x = 33.3400; y = 11.0980; z = 46.1750 }, (* P *)
- { x = 34.5130; y = 10.2320; z = 46.4660 }, (* O1P *)
- { x = 33.4130; y = 12.3960; z = 46.9340 }, (* O2P *)
- { x = 31.9810; y = 10.3390; z = 46.4820 }, (* O5' *)
- { x = 30.8152; y = 11.1619; z = 46.2003 }, (* C5' *)
- { x = 30.4519; y = 10.9454; z = 45.1957 }, (* H5' *)
- { x = 31.0379; y = 12.2016; z = 46.4400 }, (* H5'' *)
- { x = 29.7081; y = 10.7448; z = 47.1428 }, (* C4' *)
- { x = 28.8710; y = 11.4416; z = 47.0982 }, (* H4' *)
- { x = 29.2550; y = 9.4394; z = 46.8162 }, (* O4' *)
- { x = 29.3907; y = 8.5625; z = 47.9460 }, (* C1' *)
- { x = 28.4416; y = 8.5669; z = 48.4819 }, (* H1' *)
- { x = 30.4468; y = 9.2031; z = 48.7952 }, (* C2' *)
- { x = 31.4222; y = 8.9651; z = 48.3709 }, (* H2'' *)
- { x = 30.3701; y = 8.9157; z = 50.1624 }, (* O2' *)
- { x = 30.0652; y = 8.0304; z = 50.3740 }, (* H2' *)
- { x = 30.1622; y = 10.6879; z = 48.6120 }, (* C3' *)
- { x = 31.0952; y = 11.2399; z = 48.7254 }, (* H3' *)
- { x = 29.1076; y = 11.1535; z = 49.4702 }, (* O3' *)
- { x = 29.7883; y = 7.2209; z = 47.5235 }, (* N1 *)
- { x = 29.1825; y = 5.0438; z = 46.8275 }, (* N3 *)
- { x = 28.8008; y = 6.2912; z = 47.2263 }, (* C2 *)
- { x = 30.4888; y = 4.6890; z = 46.7186 }, (* C4 *)
- { x = 31.5034; y = 5.6405; z = 47.0249 }, (* C5 *)
- { x = 31.1091; y = 6.8691; z = 47.4156 }, (* C6 *)
- (C (
- { x = 30.8109; y = 3.4584; z = 46.3336 }, (* N4 *)
- { x = 27.6171; y = 6.5989; z = 47.3189 }, (* O2 *)
- { x = 31.7923; y = 3.2301; z = 46.2638 }, (* H41 *)
- { x = 30.0880; y = 2.7857; z = 46.1215 }, (* H42 *)
- { x = 32.5542; y = 5.3634; z = 46.9395 }, (* H5 *)
- { x = 31.8523; y = 7.6279; z = 47.6603 }) (* H6 *)
- )
- )
-
-let rC08
- = N(
- { a=0.0797; b= -0.6026; c= -0.7941; (* dgf_base_tfo *)
- d=0.7939; e=0.5201; f= -0.3150;
- g=0.6028; h= -0.6054; i=0.5198;
- tx= -36.8341; ty=41.5293; tz=1.6628 },
- { a=0.9187; b=0.2887; c=0.2694; (* P_O3'_275_tfo *)
- d=0.0302; e= -0.7316; f=0.6811;
- g=0.3938; h= -0.6176; i= -0.6808;
- tx= -48.4330; ty=26.3254; tz=13.6383 },
- { a= -0.1504; b=0.7744; c= -0.6145; (* P_O3'_180_tfo *)
- d=0.7581; e=0.4893; f=0.4311;
- g=0.6345; h= -0.4010; i= -0.6607;
- tx= -31.9784; ty= -13.4285; tz=44.9650 },
- { a= -0.6236; b= -0.7810; c= -0.0337; (* P_O3'_60_tfo *)
- d= -0.6890; e=0.5694; f= -0.4484;
- g=0.3694; h= -0.2564; i= -0.8932;
- tx=12.1105; ty=30.8774; tz=46.0946 },
- { x = 33.3400; y = 11.0980; z = 46.1750 }, (* P *)
- { x = 34.5130; y = 10.2320; z = 46.4660 }, (* O1P *)
- { x = 33.4130; y = 12.3960; z = 46.9340 }, (* O2P *)
- { x = 31.9810; y = 10.3390; z = 46.4820 }, (* O5' *)
- { x = 31.8779; y = 9.9369; z = 47.8760 }, (* C5' *)
- { x = 31.3239; y = 10.6931; z = 48.4322 }, (* H5' *)
- { x = 32.8647; y = 9.6624; z = 48.2489 }, (* H5'' *)
- { x = 31.0429; y = 8.6773; z = 47.9401 }, (* C4' *)
- { x = 31.0779; y = 8.2331; z = 48.9349 }, (* H4' *)
- { x = 29.6956; y = 8.9669; z = 47.5983 }, (* O4' *)
- { x = 29.2784; y = 8.1700; z = 46.4782 }, (* C1' *)
- { x = 28.8006; y = 7.2731; z = 46.8722 }, (* H1' *)
- { x = 30.5544; y = 7.7940; z = 45.7875 }, (* C2' *)
- { x = 30.8837; y = 8.6410; z = 45.1856 }, (* H2'' *)
- { x = 30.5100; y = 6.6007; z = 45.0582 }, (* O2' *)
- { x = 29.6694; y = 6.4168; z = 44.6326 }, (* H2' *)
- { x = 31.5146; y = 7.5954; z = 46.9527 }, (* C3' *)
- { x = 32.5255; y = 7.8261; z = 46.6166 }, (* H3' *)
- { x = 31.3876; y = 6.2951; z = 47.5516 }, (* O3' *)
- { x = 28.3976; y = 8.9302; z = 45.5933 }, (* N1 *)
- { x = 26.2155; y = 9.6135; z = 44.9910 }, (* N3 *)
- { x = 27.0281; y = 8.8961; z = 45.8192 }, (* C2 *)
- { x = 26.7044; y = 10.3489; z = 43.9595 }, (* C4 *)
- { x = 28.1088; y = 10.3837; z = 43.7247 }, (* C5 *)
- { x = 28.8978; y = 9.6708; z = 44.5535 }, (* C6 *)
- (C (
- { x = 25.8715; y = 11.0249; z = 43.1749 }, (* N4 *)
- { x = 26.5733; y = 8.2371; z = 46.7484 }, (* O2 *)
- { x = 26.2707; y = 11.5609; z = 42.4177 }, (* H41 *)
- { x = 24.8760; y = 10.9939; z = 43.3427 }, (* H42 *)
- { x = 28.5089; y = 10.9722; z = 42.8990 }, (* H5 *)
- { x = 29.9782; y = 9.6687; z = 44.4097 }) (* H6 *)
- )
- )
-
-let rC09
- = N(
- { a=0.8727; b=0.4760; c= -0.1091; (* dgf_base_tfo *)
- d= -0.4188; e=0.6148; f= -0.6682;
- g= -0.2510; h=0.6289; i=0.7359;
- tx= -8.1687; ty= -52.0761; tz= -25.0726 },
- { a=0.9187; b=0.2887; c=0.2694; (* P_O3'_275_tfo *)
- d=0.0302; e= -0.7316; f=0.6811;
- g=0.3938; h= -0.6176; i= -0.6808;
- tx= -48.4330; ty=26.3254; tz=13.6383 },
- { a= -0.1504; b=0.7744; c= -0.6145; (* P_O3'_180_tfo *)
- d=0.7581; e=0.4893; f=0.4311;
- g=0.6345; h= -0.4010; i= -0.6607;
- tx= -31.9784; ty= -13.4285; tz=44.9650 },
- { a= -0.6236; b= -0.7810; c= -0.0337; (* P_O3'_60_tfo *)
- d= -0.6890; e=0.5694; f= -0.4484;
- g=0.3694; h= -0.2564; i= -0.8932;
- tx=12.1105; ty=30.8774; tz=46.0946 },
- { x = 33.3400; y = 11.0980; z = 46.1750 }, (* P *)
- { x = 34.5130; y = 10.2320; z = 46.4660 }, (* O1P *)
- { x = 33.4130; y = 12.3960; z = 46.9340 }, (* O2P *)
- { x = 31.9810; y = 10.3390; z = 46.4820 }, (* O5' *)
- { x = 30.8152; y = 11.1619; z = 46.2003 }, (* C5' *)
- { x = 30.4519; y = 10.9454; z = 45.1957 }, (* H5' *)
- { x = 31.0379; y = 12.2016; z = 46.4400 }, (* H5'' *)
- { x = 29.7081; y = 10.7448; z = 47.1428 }, (* C4' *)
- { x = 29.4506; y = 9.6945; z = 47.0059 }, (* H4' *)
- { x = 30.1045; y = 10.9634; z = 48.4885 }, (* O4' *)
- { x = 29.1794; y = 11.8418; z = 49.1490 }, (* C1' *)
- { x = 28.4388; y = 11.2210; z = 49.6533 }, (* H1' *)
- { x = 28.5211; y = 12.6008; z = 48.0367 }, (* C2' *)
- { x = 29.1947; y = 13.3949; z = 47.7147 }, (* H2'' *)
- { x = 27.2316; y = 13.0683; z = 48.3134 }, (* O2' *)
- { x = 27.0851; y = 13.3391; z = 49.2227 }, (* H2' *)
- { x = 28.4131; y = 11.5507; z = 46.9391 }, (* C3' *)
- { x = 28.4451; y = 12.0512; z = 45.9713 }, (* H3' *)
- { x = 27.2707; y = 10.6955; z = 47.1097 }, (* O3' *)
- { x = 29.8751; y = 12.7405; z = 50.0682 }, (* N1 *)
- { x = 30.7172; y = 13.1841; z = 52.2328 }, (* N3 *)
- { x = 30.0617; y = 12.3404; z = 51.3847 }, (* C2 *)
- { x = 31.1834; y = 14.3941; z = 51.8297 }, (* C4 *)
- { x = 30.9913; y = 14.8074; z = 50.4803 }, (* C5 *)
- { x = 30.3434; y = 13.9610; z = 49.6548 }, (* C6 *)
- (C (
- { x = 31.8090; y = 15.1847; z = 52.6957 }, (* N4 *)
- { x = 29.6470; y = 11.2494; z = 51.7616 }, (* O2 *)
- { x = 32.1422; y = 16.0774; z = 52.3606 }, (* H41 *)
- { x = 31.9392; y = 14.8893; z = 53.6527 }, (* H42 *)
- { x = 31.3632; y = 15.7771; z = 50.1491 }, (* H5 *)
- { x = 30.1742; y = 14.2374; z = 48.6141 }) (* H6 *)
- )
- )
-
-let rC10
- = N(
- { a=0.1549; b=0.8710; c= -0.4663; (* dgf_base_tfo *)
- d=0.6768; e= -0.4374; f= -0.5921;
- g= -0.7197; h= -0.2239; i= -0.6572;
- tx=25.2447; ty= -14.1920; tz=50.3201 },
- { a=0.9187; b=0.2887; c=0.2694; (* P_O3'_275_tfo *)
- d=0.0302; e= -0.7316; f=0.6811;
- g=0.3938; h= -0.6176; i= -0.6808;
- tx= -48.4330; ty=26.3254; tz=13.6383 },
- { a= -0.1504; b=0.7744; c= -0.6145; (* P_O3'_180_tfo *)
- d=0.7581; e=0.4893; f=0.4311;
- g=0.6345; h= -0.4010; i= -0.6607;
- tx= -31.9784; ty= -13.4285; tz=44.9650 },
- { a= -0.6236; b= -0.7810; c= -0.0337; (* P_O3'_60_tfo *)
- d= -0.6890; e=0.5694; f= -0.4484;
- g=0.3694; h= -0.2564; i= -0.8932;
- tx=12.1105; ty=30.8774; tz=46.0946 },
- { x = 33.3400; y = 11.0980; z = 46.1750 }, (* P *)
- { x = 34.5130; y = 10.2320; z = 46.4660 }, (* O1P *)
- { x = 33.4130; y = 12.3960; z = 46.9340 }, (* O2P *)
- { x = 31.9810; y = 10.3390; z = 46.4820 }, (* O5' *)
- { x = 31.8779; y = 9.9369; z = 47.8760 }, (* C5' *)
- { x = 31.3239; y = 10.6931; z = 48.4322 }, (* H5' *)
- { x = 32.8647; y = 9.6624; z = 48.2489 }, (* H5'' *)
- { x = 31.0429; y = 8.6773; z = 47.9401 }, (* C4' *)
- { x = 30.0440; y = 8.8473; z = 47.5383 }, (* H4' *)
- { x = 31.6749; y = 7.6351; z = 47.2119 }, (* O4' *)
- { x = 31.9159; y = 6.5022; z = 48.0616 }, (* C1' *)
- { x = 31.0691; y = 5.8243; z = 47.9544 }, (* H1' *)
- { x = 31.9300; y = 7.0685; z = 49.4493 }, (* C2' *)
- { x = 32.9024; y = 7.5288; z = 49.6245 }, (* H2'' *)
- { x = 31.5672; y = 6.1750; z = 50.4632 }, (* O2' *)
- { x = 31.8416; y = 5.2663; z = 50.3200 }, (* H2' *)
- { x = 30.8618; y = 8.1514; z = 49.3749 }, (* C3' *)
- { x = 31.1122; y = 8.9396; z = 50.0850 }, (* H3' *)
- { x = 29.5351; y = 7.6245; z = 49.5409 }, (* O3' *)
- { x = 33.1890; y = 5.8629; z = 47.7343 }, (* N1 *)
- { x = 34.4004; y = 4.2636; z = 46.4828 }, (* N3 *)
- { x = 33.2062; y = 4.8497; z = 46.7851 }, (* C2 *)
- { x = 35.5600; y = 4.6374; z = 47.0822 }, (* C4 *)
- { x = 35.5444; y = 5.6751; z = 48.0577 }, (* C5 *)
- { x = 34.3565; y = 6.2450; z = 48.3432 }, (* C6 *)
- (C (
- { x = 36.6977; y = 4.0305; z = 46.7598 }, (* N4 *)
- { x = 32.1661; y = 4.5034; z = 46.2348 }, (* O2 *)
- { x = 37.5405; y = 4.3347; z = 47.2259 }, (* H41 *)
- { x = 36.7033; y = 3.2923; z = 46.0706 }, (* H42 *)
- { x = 36.4713; y = 5.9811; z = 48.5428 }, (* H5 *)
- { x = 34.2986; y = 7.0426; z = 49.0839 }) (* H6 *)
- )
- )
-
-let rCs = [rC01;rC02;rC03;rC04;rC05;rC06;rC07;rC08;rC09;rC10]
-
-let rG
- = N(
- { a= -0.0018; b= -0.8207; c=0.5714; (* dgf_base_tfo *)
- d=0.2679; e= -0.5509; f= -0.7904;
- g=0.9634; h=0.1517; i=0.2209;
- tx=0.0073; ty=8.4030; tz=0.6232 },
- { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
- d= -0.0433; e= -0.4257; f=0.9038;
- g= -0.5788; h=0.7480; i=0.3246;
- tx=1.5227; ty=6.9114; tz= -7.0765 },
- { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
- d=0.4552; e=0.6637; f=0.5935;
- g= -0.8042; h=0.0203; i=0.5941;
- tx= -6.9472; ty= -4.1186; tz= -5.9108 },
- { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
- d= -0.8247; e=0.5587; f= -0.0878;
- g=0.0426; h=0.2162; i=0.9754;
- tx=6.2694; ty= -7.0540; tz=3.3316 },
- { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *)
- { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *)
- { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *)
- { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *)
- { x = 5.4550; y = 8.2120; z = -2.8810 }, (* C5' *)
- { x = 5.4546; y = 8.8508; z = -1.9978 }, (* H5' *)
- { x = 5.7588; y = 8.6625; z = -3.8259 }, (* H5'' *)
- { x = 6.4970; y = 7.1480; z = -2.5980 }, (* C4' *)
- { x = 7.4896; y = 7.5919; z = -2.5214 }, (* H4' *)
- { x = 6.1630; y = 6.4860; z = -1.3440 }, (* O4' *)
- { x = 6.5400; y = 5.1200; z = -1.4190 }, (* C1' *)
- { x = 7.2763; y = 4.9681; z = -0.6297 }, (* H1' *)
- { x = 7.1940; y = 4.8830; z = -2.7770 }, (* C2' *)
- { x = 6.8667; y = 3.9183; z = -3.1647 }, (* H2'' *)
- { x = 8.5860; y = 5.0910; z = -2.6140 }, (* O2' *)
- { x = 8.9510; y = 4.7626; z = -1.7890 }, (* H2' *)
- { x = 6.5720; y = 6.0040; z = -3.6090 }, (* C3' *)
- { x = 5.5636; y = 5.7066; z = -3.8966 }, (* H3' *)
- { x = 7.3801; y = 6.3562; z = -4.7350 }, (* O3' *)
- { x = 4.7150; y = 0.4910; z = -0.1360 }, (* N1 *)
- { x = 6.3490; y = 2.1730; z = -0.6020 }, (* N3 *)
- { x = 5.9530; y = 0.9650; z = -0.2670 }, (* C2 *)
- { x = 5.2900; y = 2.9790; z = -0.8260 }, (* C4 *)
- { x = 3.9720; y = 2.6390; z = -0.7330 }, (* C5 *)
- { x = 3.6770; y = 1.3160; z = -0.3660 }, (* C6 *)
- (G (
- { x = 6.8426; y = 0.0056; z = -0.0019 }, (* N2 *)
- { x = 3.1660; y = 3.7290; z = -1.0360 }, (* N7 *)
- { x = 5.3170; y = 4.2990; z = -1.1930 }, (* N9 *)
- { x = 4.0100; y = 4.6780; z = -1.2990 }, (* C8 *)
- { x = 2.4280; y = 0.8450; z = -0.2360 }, (* O6 *)
- { x = 4.6151; y = -0.4677; z = 0.1305 }, (* H1 *)
- { x = 6.6463; y = -0.9463; z = 0.2729 }, (* H21 *)
- { x = 7.8170; y = 0.2642; z = -0.0640 }, (* H22 *)
- { x = 3.4421; y = 5.5744; z = -1.5482 }) (* H8 *)
- )
- )
-
-let rG01
- = N(
- { a= -0.0043; b= -0.8175; c=0.5759; (* dgf_base_tfo *)
- d=0.2617; e= -0.5567; f= -0.7884;
- g=0.9651; h=0.1473; i=0.2164;
- tx=0.0359; ty=8.3929; tz=0.5532 },
- { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
- d= -0.0433; e= -0.4257; f=0.9038;
- g= -0.5788; h=0.7480; i=0.3246;
- tx=1.5227; ty=6.9114; tz= -7.0765 },
- { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
- d=0.4552; e=0.6637; f=0.5935;
- g= -0.8042; h=0.0203; i=0.5941;
- tx= -6.9472; ty= -4.1186; tz= -5.9108 },
- { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
- d= -0.8247; e=0.5587; f= -0.0878;
- g=0.0426; h=0.2162; i=0.9754;
- tx=6.2694; ty= -7.0540; tz=3.3316 },
- { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *)
- { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *)
- { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *)
- { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *)
- { x = 5.4352; y = 8.2183; z = -2.7757 }, (* C5' *)
- { x = 5.3830; y = 8.7883; z = -1.8481 }, (* H5' *)
- { x = 5.7729; y = 8.7436; z = -3.6691 }, (* H5'' *)
- { x = 6.4830; y = 7.1518; z = -2.5252 }, (* C4' *)
- { x = 7.4749; y = 7.5972; z = -2.4482 }, (* H4' *)
- { x = 6.1626; y = 6.4620; z = -1.2827 }, (* O4' *)
- { x = 6.5431; y = 5.0992; z = -1.3905 }, (* C1' *)
- { x = 7.2871; y = 4.9328; z = -0.6114 }, (* H1' *)
- { x = 7.1852; y = 4.8935; z = -2.7592 }, (* C2' *)
- { x = 6.8573; y = 3.9363; z = -3.1645 }, (* H2'' *)
- { x = 8.5780; y = 5.1025; z = -2.6046 }, (* O2' *)
- { x = 8.9516; y = 4.7577; z = -1.7902 }, (* H2' *)
- { x = 6.5522; y = 6.0300; z = -3.5612 }, (* C3' *)
- { x = 5.5420; y = 5.7356; z = -3.8459 }, (* H3' *)
- { x = 7.3487; y = 6.4089; z = -4.6867 }, (* O3' *)
- { x = 4.7442; y = 0.4514; z = -0.1390 }, (* N1 *)
- { x = 6.3687; y = 2.1459; z = -0.5926 }, (* N3 *)
- { x = 5.9795; y = 0.9335; z = -0.2657 }, (* C2 *)
- { x = 5.3052; y = 2.9471; z = -0.8125 }, (* C4 *)
- { x = 3.9891; y = 2.5987; z = -0.7230 }, (* C5 *)
- { x = 3.7016; y = 1.2717; z = -0.3647 }, (* C6 *)
- (G (
- { x = 6.8745; y = -0.0224; z = -0.0058 }, (* N2 *)
- { x = 3.1770; y = 3.6859; z = -1.0198 }, (* N7 *)
- { x = 5.3247; y = 4.2695; z = -1.1710 }, (* N9 *)
- { x = 4.0156; y = 4.6415; z = -1.2759 }, (* C8 *)
- { x = 2.4553; y = 0.7925; z = -0.2390 }, (* O6 *)
- { x = 4.6497; y = -0.5095; z = 0.1212 }, (* H1 *)
- { x = 6.6836; y = -0.9771; z = 0.2627 }, (* H21 *)
- { x = 7.8474; y = 0.2424; z = -0.0653 }, (* H22 *)
- { x = 3.4426; y = 5.5361; z = -1.5199 }) (* H8 *)
- )
- )
-
-let rG02
- = N(
- { a=0.5566; b=0.0449; c=0.8296; (* dgf_base_tfo *)
- d=0.5125; e=0.7673; f= -0.3854;
- g= -0.6538; h=0.6397; i=0.4041;
- tx= -9.1161; ty= -3.7679; tz= -2.9968 },
- { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
- d= -0.0433; e= -0.4257; f=0.9038;
- g= -0.5788; h=0.7480; i=0.3246;
- tx=1.5227; ty=6.9114; tz= -7.0765 },
- { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
- d=0.4552; e=0.6637; f=0.5935;
- g= -0.8042; h=0.0203; i=0.5941;
- tx= -6.9472; ty= -4.1186; tz= -5.9108 },
- { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
- d= -0.8247; e=0.5587; f= -0.0878;
- g=0.0426; h=0.2162; i=0.9754;
- tx=6.2694; ty= -7.0540; tz=3.3316 },
- { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *)
- { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *)
- { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *)
- { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *)
- { x = 4.5778; y = 6.6594; z = -4.0364 }, (* C5' *)
- { x = 4.9220; y = 7.1963; z = -4.9204 }, (* H5' *)
- { x = 3.7996; y = 5.9091; z = -4.1764 }, (* H5'' *)
- { x = 5.7873; y = 5.8869; z = -3.5482 }, (* C4' *)
- { x = 6.0405; y = 5.0875; z = -4.2446 }, (* H4' *)
- { x = 6.9135; y = 6.8036; z = -3.4310 }, (* O4' *)
- { x = 7.7293; y = 6.4084; z = -2.3392 }, (* C1' *)
- { x = 8.7078; y = 6.1815; z = -2.7624 }, (* H1' *)
- { x = 7.1305; y = 5.1418; z = -1.7347 }, (* C2' *)
- { x = 7.2040; y = 5.1982; z = -0.6486 }, (* H2'' *)
- { x = 7.7417; y = 4.0392; z = -2.3813 }, (* O2' *)
- { x = 8.6785; y = 4.1443; z = -2.5630 }, (* H2' *)
- { x = 5.6666; y = 5.2728; z = -2.1536 }, (* C3' *)
- { x = 5.1747; y = 5.9805; z = -1.4863 }, (* H3' *)
- { x = 4.9997; y = 4.0086; z = -2.1973 }, (* O3' *)
- { x = 10.3245; y = 8.5459; z = 1.5467 }, (* N1 *)
- { x = 9.8051; y = 6.9432; z = -0.1497 }, (* N3 *)
- { x = 10.5175; y = 7.4328; z = 0.8408 }, (* C2 *)
- { x = 8.7523; y = 7.7422; z = -0.4228 }, (* C4 *)
- { x = 8.4257; y = 8.9060; z = 0.2099 }, (* C5 *)
- { x = 9.2665; y = 9.3242; z = 1.2540 }, (* C6 *)
- (G (
- { x = 11.6077; y = 6.7966; z = 1.2752 }, (* N2 *)
- { x = 7.2750; y = 9.4537; z = -0.3428 }, (* N7 *)
- { x = 7.7962; y = 7.5519; z = -1.3859 }, (* N9 *)
- { x = 6.9479; y = 8.6157; z = -1.2771 }, (* C8 *)
- { x = 9.0664; y = 10.4462; z = 1.9610 }, (* O6 *)
- { x = 10.9838; y = 8.7524; z = 2.2697 }, (* H1 *)
- { x = 12.2274; y = 7.0896; z = 2.0170 }, (* H21 *)
- { x = 11.8502; y = 5.9398; z = 0.7984 }, (* H22 *)
- { x = 6.0430; y = 8.9853; z = -1.7594 }) (* H8 *)
- )
- )
-
-let rG03
- = N(
- { a= -0.5021; b=0.0731; c=0.8617; (* dgf_base_tfo *)
- d= -0.8112; e=0.3054; f= -0.4986;
- g= -0.2996; h= -0.9494; i= -0.0940;
- tx=6.4273; ty= -5.1944; tz= -3.7807 },
- { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
- d= -0.0433; e= -0.4257; f=0.9038;
- g= -0.5788; h=0.7480; i=0.3246;
- tx=1.5227; ty=6.9114; tz= -7.0765 },
- { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
- d=0.4552; e=0.6637; f=0.5935;
- g= -0.8042; h=0.0203; i=0.5941;
- tx= -6.9472; ty= -4.1186; tz= -5.9108 },
- { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
- d= -0.8247; e=0.5587; f= -0.0878;
- g=0.0426; h=0.2162; i=0.9754;
- tx=6.2694; ty= -7.0540; tz=3.3316 },
- { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *)
- { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *)
- { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *)
- { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *)
- { x = 4.1214; y = 6.7116; z = -1.9049 }, (* C5' *)
- { x = 3.3465; y = 5.9610; z = -2.0607 }, (* H5' *)
- { x = 4.0789; y = 7.2928; z = -0.9837 }, (* H5'' *)
- { x = 5.4170; y = 5.9293; z = -1.8186 }, (* C4' *)
- { x = 5.4506; y = 5.3400; z = -0.9023 }, (* H4' *)
- { x = 5.5067; y = 5.0417; z = -2.9703 }, (* O4' *)
- { x = 6.8650; y = 4.9152; z = -3.3612 }, (* C1' *)
- { x = 7.1090; y = 3.8577; z = -3.2603 }, (* H1' *)
- { x = 7.7152; y = 5.7282; z = -2.3894 }, (* C2' *)
- { x = 8.5029; y = 6.2356; z = -2.9463 }, (* H2'' *)
- { x = 8.1036; y = 4.8568; z = -1.3419 }, (* O2' *)
- { x = 8.3270; y = 3.9651; z = -1.6184 }, (* H2' *)
- { x = 6.7003; y = 6.7565; z = -1.8911 }, (* C3' *)
- { x = 6.5898; y = 7.5329; z = -2.6482 }, (* H3' *)
- { x = 7.0505; y = 7.2878; z = -0.6105 }, (* O3' *)
- { x = 9.6740; y = 4.7656; z = -7.6614 }, (* N1 *)
- { x = 9.0739; y = 4.3013; z = -5.3941 }, (* N3 *)
- { x = 9.8416; y = 4.2192; z = -6.4581 }, (* C2 *)
- { x = 7.9885; y = 5.0632; z = -5.6446 }, (* C4 *)
- { x = 7.6822; y = 5.6856; z = -6.8194 }, (* C5 *)
- { x = 8.5831; y = 5.5215; z = -7.8840 }, (* C6 *)
- (G (
- { x = 10.9733; y = 3.5117; z = -6.4286 }, (* N2 *)
- { x = 6.4857; y = 6.3816; z = -6.7035 }, (* N7 *)
- { x = 6.9740; y = 5.3703; z = -4.7760 }, (* N9 *)
- { x = 6.1133; y = 6.1613; z = -5.4808 }, (* C8 *)
- { x = 8.4084; y = 6.0747; z = -9.0933 }, (* O6 *)
- { x = 10.3759; y = 4.5855; z = -8.3504 }, (* H1 *)
- { x = 11.6254; y = 3.3761; z = -7.1879 }, (* H21 *)
- { x = 11.1917; y = 3.0460; z = -5.5593 }, (* H22 *)
- { x = 5.1705; y = 6.6830; z = -5.3167 }) (* H8 *)
- )
- )
-
-let rG04
- = N(
- { a= -0.5426; b= -0.8175; c=0.1929; (* dgf_base_tfo *)
- d=0.8304; e= -0.5567; f= -0.0237;
- g=0.1267; h=0.1473; i=0.9809;
- tx= -0.5075; ty=8.3929; tz=0.2229 },
- { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
- d= -0.0433; e= -0.4257; f=0.9038;
- g= -0.5788; h=0.7480; i=0.3246;
- tx=1.5227; ty=6.9114; tz= -7.0765 },
- { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
- d=0.4552; e=0.6637; f=0.5935;
- g= -0.8042; h=0.0203; i=0.5941;
- tx= -6.9472; ty= -4.1186; tz= -5.9108 },
- { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
- d= -0.8247; e=0.5587; f= -0.0878;
- g=0.0426; h=0.2162; i=0.9754;
- tx=6.2694; ty= -7.0540; tz=3.3316 },
- { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *)
- { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *)
- { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *)
- { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *)
- { x = 5.4352; y = 8.2183; z = -2.7757 }, (* C5' *)
- { x = 5.3830; y = 8.7883; z = -1.8481 }, (* H5' *)
- { x = 5.7729; y = 8.7436; z = -3.6691 }, (* H5'' *)
- { x = 6.4830; y = 7.1518; z = -2.5252 }, (* C4' *)
- { x = 7.4749; y = 7.5972; z = -2.4482 }, (* H4' *)
- { x = 6.1626; y = 6.4620; z = -1.2827 }, (* O4' *)
- { x = 6.5431; y = 5.0992; z = -1.3905 }, (* C1' *)
- { x = 7.2871; y = 4.9328; z = -0.6114 }, (* H1' *)
- { x = 7.1852; y = 4.8935; z = -2.7592 }, (* C2' *)
- { x = 6.8573; y = 3.9363; z = -3.1645 }, (* H2'' *)
- { x = 8.5780; y = 5.1025; z = -2.6046 }, (* O2' *)
- { x = 8.9516; y = 4.7577; z = -1.7902 }, (* H2' *)
- { x = 6.5522; y = 6.0300; z = -3.5612 }, (* C3' *)
- { x = 5.5420; y = 5.7356; z = -3.8459 }, (* H3' *)
- { x = 7.3487; y = 6.4089; z = -4.6867 }, (* O3' *)
- { x = 3.6343; y = 2.6680; z = 2.0783 }, (* N1 *)
- { x = 5.4505; y = 3.9805; z = 1.2446 }, (* N3 *)
- { x = 4.7540; y = 3.3816; z = 2.1851 }, (* C2 *)
- { x = 4.8805; y = 3.7951; z = 0.0354 }, (* C4 *)
- { x = 3.7416; y = 3.0925; z = -0.2305 }, (* C5 *)
- { x = 3.0873; y = 2.4980; z = 0.8606 }, (* C6 *)
- (G (
- { x = 5.1433; y = 3.4373; z = 3.4609 }, (* N2 *)
- { x = 3.4605; y = 3.1184; z = -1.5906 }, (* N7 *)
- { x = 5.3247; y = 4.2695; z = -1.1710 }, (* N9 *)
- { x = 4.4244; y = 3.8244; z = -2.0953 }, (* C8 *)
- { x = 1.9600; y = 1.7805; z = 0.7462 }, (* O6 *)
- { x = 3.2489; y = 2.2879; z = 2.9191 }, (* H1 *)
- { x = 4.6785; y = 3.0243; z = 4.2568 }, (* H21 *)
- { x = 5.9823; y = 3.9654; z = 3.6539 }, (* H22 *)
- { x = 4.2675; y = 3.8876; z = -3.1721 }) (* H8 *)
- )
- )
-
-let rG05
- = N(
- { a= -0.5891; b=0.0449; c=0.8068; (* dgf_base_tfo *)
- d=0.5375; e=0.7673; f=0.3498;
- g= -0.6034; h=0.6397; i= -0.4762;
- tx= -0.3019; ty= -3.7679; tz= -9.5913 },
- { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
- d= -0.0433; e= -0.4257; f=0.9038;
- g= -0.5788; h=0.7480; i=0.3246;
- tx=1.5227; ty=6.9114; tz= -7.0765 },
- { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
- d=0.4552; e=0.6637; f=0.5935;
- g= -0.8042; h=0.0203; i=0.5941;
- tx= -6.9472; ty= -4.1186; tz= -5.9108 },
- { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
- d= -0.8247; e=0.5587; f= -0.0878;
- g=0.0426; h=0.2162; i=0.9754;
- tx=6.2694; ty= -7.0540; tz=3.3316 },
- { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *)
- { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *)
- { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *)
- { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *)
- { x = 4.5778; y = 6.6594; z = -4.0364 }, (* C5' *)
- { x = 4.9220; y = 7.1963; z = -4.9204 }, (* H5' *)
- { x = 3.7996; y = 5.9091; z = -4.1764 }, (* H5'' *)
- { x = 5.7873; y = 5.8869; z = -3.5482 }, (* C4' *)
- { x = 6.0405; y = 5.0875; z = -4.2446 }, (* H4' *)
- { x = 6.9135; y = 6.8036; z = -3.4310 }, (* O4' *)
- { x = 7.7293; y = 6.4084; z = -2.3392 }, (* C1' *)
- { x = 8.7078; y = 6.1815; z = -2.7624 }, (* H1' *)
- { x = 7.1305; y = 5.1418; z = -1.7347 }, (* C2' *)
- { x = 7.2040; y = 5.1982; z = -0.6486 }, (* H2'' *)
- { x = 7.7417; y = 4.0392; z = -2.3813 }, (* O2' *)
- { x = 8.6785; y = 4.1443; z = -2.5630 }, (* H2' *)
- { x = 5.6666; y = 5.2728; z = -2.1536 }, (* C3' *)
- { x = 5.1747; y = 5.9805; z = -1.4863 }, (* H3' *)
- { x = 4.9997; y = 4.0086; z = -2.1973 }, (* O3' *)
- { x = 10.2594; y = 10.6774; z = -1.0056 }, (* N1 *)
- { x = 9.7528; y = 8.7080; z = -2.2631 }, (* N3 *)
- { x = 10.4471; y = 9.7876; z = -1.9791 }, (* C2 *)
- { x = 8.7271; y = 8.5575; z = -1.3991 }, (* C4 *)
- { x = 8.4100; y = 9.3803; z = -0.3580 }, (* C5 *)
- { x = 9.2294; y = 10.5030; z = -0.1574 }, (* C6 *)
- (G (
- { x = 11.5110; y = 10.1256; z = -2.7114 }, (* N2 *)
- { x = 7.2891; y = 8.9068; z = 0.3121 }, (* N7 *)
- { x = 7.7962; y = 7.5519; z = -1.3859 }, (* N9 *)
- { x = 6.9702; y = 7.8292; z = -0.3353 }, (* C8 *)
- { x = 9.0349; y = 11.3951; z = 0.8250 }, (* O6 *)
- { x = 10.9013; y = 11.4422; z = -0.9512 }, (* H1 *)
- { x = 12.1031; y = 10.9341; z = -2.5861 }, (* H21 *)
- { x = 11.7369; y = 9.5180; z = -3.4859 }, (* H22 *)
- { x = 6.0888; y = 7.3990; z = 0.1403 }) (* H8 *)
- )
- )
-
-let rG06
- = N(
- { a= -0.9815; b=0.0731; c= -0.1772; (* dgf_base_tfo *)
- d=0.1912; e=0.3054; f= -0.9328;
- g= -0.0141; h= -0.9494; i= -0.3137;
- tx=5.7506; ty= -5.1944; tz=4.7470 },
- { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
- d= -0.0433; e= -0.4257; f=0.9038;
- g= -0.5788; h=0.7480; i=0.3246;
- tx=1.5227; ty=6.9114; tz= -7.0765 },
- { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
- d=0.4552; e=0.6637; f=0.5935;
- g= -0.8042; h=0.0203; i=0.5941;
- tx= -6.9472; ty= -4.1186; tz= -5.9108 },
- { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
- d= -0.8247; e=0.5587; f= -0.0878;
- g=0.0426; h=0.2162; i=0.9754;
- tx=6.2694; ty= -7.0540; tz=3.3316 },
- { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *)
- { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *)
- { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *)
- { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *)
- { x = 4.1214; y = 6.7116; z = -1.9049 }, (* C5' *)
- { x = 3.3465; y = 5.9610; z = -2.0607 }, (* H5' *)
- { x = 4.0789; y = 7.2928; z = -0.9837 }, (* H5'' *)
- { x = 5.4170; y = 5.9293; z = -1.8186 }, (* C4' *)
- { x = 5.4506; y = 5.3400; z = -0.9023 }, (* H4' *)
- { x = 5.5067; y = 5.0417; z = -2.9703 }, (* O4' *)
- { x = 6.8650; y = 4.9152; z = -3.3612 }, (* C1' *)
- { x = 7.1090; y = 3.8577; z = -3.2603 }, (* H1' *)
- { x = 7.7152; y = 5.7282; z = -2.3894 }, (* C2' *)
- { x = 8.5029; y = 6.2356; z = -2.9463 }, (* H2'' *)
- { x = 8.1036; y = 4.8568; z = -1.3419 }, (* O2' *)
- { x = 8.3270; y = 3.9651; z = -1.6184 }, (* H2' *)
- { x = 6.7003; y = 6.7565; z = -1.8911 }, (* C3' *)
- { x = 6.5898; y = 7.5329; z = -2.6482 }, (* H3' *)
- { x = 7.0505; y = 7.2878; z = -0.6105 }, (* O3' *)
- { x = 6.6624; y = 3.5061; z = -8.2986 }, (* N1 *)
- { x = 6.5810; y = 3.2570; z = -5.9221 }, (* N3 *)
- { x = 6.5151; y = 2.8263; z = -7.1625 }, (* C2 *)
- { x = 6.8364; y = 4.5817; z = -5.8882 }, (* C4 *)
- { x = 7.0116; y = 5.4064; z = -6.9609 }, (* C5 *)
- { x = 6.9173; y = 4.8260; z = -8.2361 }, (* C6 *)
- (G (
- { x = 6.2717; y = 1.5402; z = -7.4250 }, (* N2 *)
- { x = 7.2573; y = 6.7070; z = -6.5394 }, (* N7 *)
- { x = 6.9740; y = 5.3703; z = -4.7760 }, (* N9 *)
- { x = 7.2238; y = 6.6275; z = -5.2453 }, (* C8 *)
- { x = 7.0668; y = 5.5163; z = -9.3763 }, (* O6 *)
- { x = 6.5754; y = 2.9964; z = -9.1545 }, (* H1 *)
- { x = 6.1908; y = 1.1105; z = -8.3354 }, (* H21 *)
- { x = 6.1346; y = 0.9352; z = -6.6280 }, (* H22 *)
- { x = 7.4108; y = 7.6227; z = -4.8418 }) (* H8 *)
- )
- )
-
-let rG07
- = N(
- { a=0.0894; b= -0.6059; c=0.7905; (* dgf_base_tfo *)
- d= -0.6810; e=0.5420; f=0.4924;
- g= -0.7268; h= -0.5824; i= -0.3642;
- tx=34.1424; ty=45.9610; tz= -11.8600 },
- { a= -0.8644; b= -0.4956; c= -0.0851; (* P_O3'_275_tfo *)
- d= -0.0427; e=0.2409; f= -0.9696;
- g=0.5010; h= -0.8345; i= -0.2294;
- tx=4.0167; ty=54.5377; tz=12.4779 },
- { a=0.3706; b= -0.6167; c=0.6945; (* P_O3'_180_tfo *)
- d= -0.2867; e= -0.7872; f= -0.5460;
- g=0.8834; h=0.0032; i= -0.4686;
- tx= -52.9020; ty=18.6313; tz= -0.6709 },
- { a=0.4155; b=0.9025; c= -0.1137; (* P_O3'_60_tfo *)
- d=0.9040; e= -0.4236; f= -0.0582;
- g= -0.1007; h= -0.0786; i= -0.9918;
- tx= -7.6624; ty= -25.2080; tz=49.5181 },
- { x = 31.3810; y = 0.1400; z = 47.5810 }, (* P *)
- { x = 29.9860; y = 0.6630; z = 47.6290 }, (* O1P *)
- { x = 31.7210; y = -0.6460; z = 48.8090 }, (* O2P *)
- { x = 32.4940; y = 1.2540; z = 47.2740 }, (* O5' *)
- { x = 33.8709; y = 0.7918; z = 47.2113 }, (* C5' *)
- { x = 34.1386; y = 0.5870; z = 46.1747 }, (* H5' *)
- { x = 34.0186; y = -0.0095; z = 47.9353 }, (* H5'' *)
- { x = 34.7297; y = 1.9687; z = 47.6685 }, (* C4' *)
- { x = 35.7723; y = 1.6845; z = 47.8113 }, (* H4' *)
- { x = 34.6455; y = 2.9768; z = 46.6660 }, (* O4' *)
- { x = 34.1690; y = 4.1829; z = 47.2627 }, (* C1' *)
- { x = 35.0437; y = 4.7633; z = 47.5560 }, (* H1' *)
- { x = 33.4145; y = 3.7532; z = 48.4954 }, (* C2' *)
- { x = 32.4340; y = 3.3797; z = 48.2001 }, (* H2'' *)
- { x = 33.3209; y = 4.6953; z = 49.5217 }, (* O2' *)
- { x = 33.2374; y = 5.6059; z = 49.2295 }, (* H2' *)
- { x = 34.2724; y = 2.5970; z = 48.9773 }, (* C3' *)
- { x = 33.6373; y = 1.8935; z = 49.5157 }, (* H3' *)
- { x = 35.3453; y = 3.1884; z = 49.7285 }, (* O3' *)
- { x = 34.0511; y = 7.8930; z = 43.7791 }, (* N1 *)
- { x = 34.9937; y = 6.3369; z = 45.3199 }, (* N3 *)
- { x = 35.0882; y = 7.3126; z = 44.4200 }, (* C2 *)
- { x = 33.7190; y = 5.9650; z = 45.5374 }, (* C4 *)
- { x = 32.5845; y = 6.4770; z = 44.9458 }, (* C5 *)
- { x = 32.7430; y = 7.5179; z = 43.9914 }, (* C6 *)
- (G (
- { x = 36.3030; y = 7.7827; z = 44.1036 }, (* N2 *)
- { x = 31.4499; y = 5.8335; z = 45.4368 }, (* N7 *)
- { x = 33.2760; y = 4.9817; z = 46.4043 }, (* N9 *)
- { x = 31.9235; y = 4.9639; z = 46.2934 }, (* C8 *)
- { x = 31.8602; y = 8.1000; z = 43.3695 }, (* O6 *)
- { x = 34.2623; y = 8.6223; z = 43.1283 }, (* H1 *)
- { x = 36.5188; y = 8.5081; z = 43.4347 }, (* H21 *)
- { x = 37.0888; y = 7.3524; z = 44.5699 }, (* H22 *)
- { x = 31.0815; y = 4.4201; z = 46.7218 }) (* H8 *)
- )
- )
-
-let rG08
- = N(
- { a=0.2224; b=0.6335; c=0.7411; (* dgf_base_tfo *)
- d= -0.3644; e= -0.6510; f=0.6659;
- g=0.9043; h= -0.4181; i=0.0861;
- tx= -47.6824; ty= -0.5823; tz= -31.7554 },
- { a= -0.8644; b= -0.4956; c= -0.0851; (* P_O3'_275_tfo *)
- d= -0.0427; e=0.2409; f= -0.9696;
- g=0.5010; h= -0.8345; i= -0.2294;
- tx=4.0167; ty=54.5377; tz=12.4779 },
- { a=0.3706; b= -0.6167; c=0.6945; (* P_O3'_180_tfo *)
- d= -0.2867; e= -0.7872; f= -0.5460;
- g=0.8834; h=0.0032; i= -0.4686;
- tx= -52.9020; ty=18.6313; tz= -0.6709 },
- { a=0.4155; b=0.9025; c= -0.1137; (* P_O3'_60_tfo *)
- d=0.9040; e= -0.4236; f= -0.0582;
- g= -0.1007; h= -0.0786; i= -0.9918;
- tx= -7.6624; ty= -25.2080; tz=49.5181 },
- { x = 31.3810; y = 0.1400; z = 47.5810 }, (* P *)
- { x = 29.9860; y = 0.6630; z = 47.6290 }, (* O1P *)
- { x = 31.7210; y = -0.6460; z = 48.8090 }, (* O2P *)
- { x = 32.4940; y = 1.2540; z = 47.2740 }, (* O5' *)
- { x = 32.5924; y = 2.3488; z = 48.2255 }, (* C5' *)
- { x = 33.3674; y = 2.1246; z = 48.9584 }, (* H5' *)
- { x = 31.5994; y = 2.5917; z = 48.6037 }, (* H5'' *)
- { x = 33.0722; y = 3.5577; z = 47.4258 }, (* C4' *)
- { x = 33.0310; y = 4.4778; z = 48.0089 }, (* H4' *)
- { x = 34.4173; y = 3.3055; z = 47.0316 }, (* O4' *)
- { x = 34.5056; y = 3.3910; z = 45.6094 }, (* C1' *)
- { x = 34.7881; y = 4.4152; z = 45.3663 }, (* H1' *)
- { x = 33.1122; y = 3.1198; z = 45.1010 }, (* C2' *)
- { x = 32.9230; y = 2.0469; z = 45.1369 }, (* H2'' *)
- { x = 32.7946; y = 3.6590; z = 43.8529 }, (* O2' *)
- { x = 33.5170; y = 3.6707; z = 43.2207 }, (* H2' *)
- { x = 32.2730; y = 3.8173; z = 46.1566 }, (* C3' *)
- { x = 31.3094; y = 3.3123; z = 46.2244 }, (* H3' *)
- { x = 32.2391; y = 5.2039; z = 45.7807 }, (* O3' *)
- { x = 39.3337; y = 2.7157; z = 44.1441 }, (* N1 *)
- { x = 37.4430; y = 3.8242; z = 45.0824 }, (* N3 *)
- { x = 38.7276; y = 3.7646; z = 44.7403 }, (* C2 *)
- { x = 36.7791; y = 2.6963; z = 44.7704 }, (* C4 *)
- { x = 37.2860; y = 1.5653; z = 44.1678 }, (* C5 *)
- { x = 38.6647; y = 1.5552; z = 43.8235 }, (* C6 *)
- (G (
- { x = 39.5123; y = 4.8216; z = 44.9936 }, (* N2 *)
- { x = 36.2829; y = 0.6110; z = 44.0078 }, (* N7 *)
- { x = 35.4394; y = 2.4314; z = 44.9931 }, (* N9 *)
- { x = 35.2180; y = 1.1815; z = 44.5128 }, (* C8 *)
- { x = 39.2907; y = 0.6514; z = 43.2796 }, (* O6 *)
- { x = 40.3076; y = 2.8048; z = 43.9352 }, (* H1 *)
- { x = 40.4994; y = 4.9066; z = 44.7977 }, (* H21 *)
- { x = 39.0738; y = 5.6108; z = 45.4464 }, (* H22 *)
- { x = 34.3856; y = 0.4842; z = 44.4185 }) (* H8 *)
- )
- )
-
-let rG09
- = N(
- { a= -0.9699; b= -0.1688; c= -0.1753; (* dgf_base_tfo *)
- d= -0.1050; e= -0.3598; f=0.9271;
- g= -0.2196; h=0.9176; i=0.3312;
- tx=45.6217; ty= -38.9484; tz= -12.3208 },
- { a= -0.8644; b= -0.4956; c= -0.0851; (* P_O3'_275_tfo *)
- d= -0.0427; e=0.2409; f= -0.9696;
- g=0.5010; h= -0.8345; i= -0.2294;
- tx=4.0167; ty=54.5377; tz=12.4779 },
- { a=0.3706; b= -0.6167; c=0.6945; (* P_O3'_180_tfo *)
- d= -0.2867; e= -0.7872; f= -0.5460;
- g=0.8834; h=0.0032; i= -0.4686;
- tx= -52.9020; ty=18.6313; tz= -0.6709 },
- { a=0.4155; b=0.9025; c= -0.1137; (* P_O3'_60_tfo *)
- d=0.9040; e= -0.4236; f= -0.0582;
- g= -0.1007; h= -0.0786; i= -0.9918;
- tx= -7.6624; ty= -25.2080; tz=49.5181 },
- { x = 31.3810; y = 0.1400; z = 47.5810 }, (* P *)
- { x = 29.9860; y = 0.6630; z = 47.6290 }, (* O1P *)
- { x = 31.7210; y = -0.6460; z = 48.8090 }, (* O2P *)
- { x = 32.4940; y = 1.2540; z = 47.2740 }, (* O5' *)
- { x = 33.8709; y = 0.7918; z = 47.2113 }, (* C5' *)
- { x = 34.1386; y = 0.5870; z = 46.1747 }, (* H5' *)
- { x = 34.0186; y = -0.0095; z = 47.9353 }, (* H5'' *)
- { x = 34.7297; y = 1.9687; z = 47.6685 }, (* C4' *)
- { x = 34.5880; y = 2.8482; z = 47.0404 }, (* H4' *)
- { x = 34.3575; y = 2.2770; z = 49.0081 }, (* O4' *)
- { x = 35.5157; y = 2.1993; z = 49.8389 }, (* C1' *)
- { x = 35.9424; y = 3.2010; z = 49.8893 }, (* H1' *)
- { x = 36.4701; y = 1.2820; z = 49.1169 }, (* C2' *)
- { x = 36.1545; y = 0.2498; z = 49.2683 }, (* H2'' *)
- { x = 37.8262; y = 1.4547; z = 49.4008 }, (* O2' *)
- { x = 38.0227; y = 1.6945; z = 50.3094 }, (* H2' *)
- { x = 36.2242; y = 1.6797; z = 47.6725 }, (* C3' *)
- { x = 36.4297; y = 0.8197; z = 47.0351 }, (* H3' *)
- { x = 37.0289; y = 2.8480; z = 47.4426 }, (* O3' *)
- { x = 34.3005; y = 3.5042; z = 54.6070 }, (* N1 *)
- { x = 34.7693; y = 3.7936; z = 52.2874 }, (* N3 *)
- { x = 34.4484; y = 4.2541; z = 53.4939 }, (* C2 *)
- { x = 34.9354; y = 2.4584; z = 52.2785 }, (* C4 *)
- { x = 34.8092; y = 1.5915; z = 53.3422 }, (* C5 *)
- { x = 34.4646; y = 2.1367; z = 54.6085 }, (* C6 *)
- (G (
- { x = 34.2514; y = 5.5708; z = 53.6503 }, (* N2 *)
- { x = 35.0641; y = 0.2835; z = 52.9337 }, (* N7 *)
- { x = 35.2669; y = 1.6690; z = 51.1915 }, (* N9 *)
- { x = 35.3288; y = 0.3954; z = 51.6563 }, (* C8 *)
- { x = 34.3151; y = 1.5317; z = 55.6650 }, (* O6 *)
- { x = 34.0623; y = 3.9797; z = 55.4539 }, (* H1 *)
- { x = 33.9950; y = 6.0502; z = 54.5016 }, (* H21 *)
- { x = 34.3512; y = 6.1432; z = 52.8242 }, (* H22 *)
- { x = 35.5414; y = -0.6006; z = 51.2679 }) (* H8 *)
- )
- )
-
-let rG10
- = N(
- { a= -0.0980; b= -0.9723; c=0.2122; (* dgf_base_tfo *)
- d= -0.9731; e=0.1383; f=0.1841;
- g= -0.2083; h= -0.1885; i= -0.9597;
- tx=17.8469; ty=38.8265; tz=37.0475 },
- { a= -0.8644; b= -0.4956; c= -0.0851; (* P_O3'_275_tfo *)
- d= -0.0427; e=0.2409; f= -0.9696;
- g=0.5010; h= -0.8345; i= -0.2294;
- tx=4.0167; ty=54.5377; tz=12.4779 },
- { a=0.3706; b= -0.6167; c=0.6945; (* P_O3'_180_tfo *)
- d= -0.2867; e= -0.7872; f= -0.5460;
- g=0.8834; h=0.0032; i= -0.4686;
- tx= -52.9020; ty=18.6313; tz= -0.6709 },
- { a=0.4155; b=0.9025; c= -0.1137; (* P_O3'_60_tfo *)
- d=0.9040; e= -0.4236; f= -0.0582;
- g= -0.1007; h= -0.0786; i= -0.9918;
- tx= -7.6624; ty= -25.2080; tz=49.5181 },
- { x = 31.3810; y = 0.1400; z = 47.5810 }, (* P *)
- { x = 29.9860; y = 0.6630; z = 47.6290 }, (* O1P *)
- { x = 31.7210; y = -0.6460; z = 48.8090 }, (* O2P *)
- { x = 32.4940; y = 1.2540; z = 47.2740 }, (* O5' *)
- { x = 32.5924; y = 2.3488; z = 48.2255 }, (* C5' *)
- { x = 33.3674; y = 2.1246; z = 48.9584 }, (* H5' *)
- { x = 31.5994; y = 2.5917; z = 48.6037 }, (* H5'' *)
- { x = 33.0722; y = 3.5577; z = 47.4258 }, (* C4' *)
- { x = 34.0333; y = 3.3761; z = 46.9447 }, (* H4' *)
- { x = 32.0890; y = 3.8338; z = 46.4332 }, (* O4' *)
- { x = 31.6377; y = 5.1787; z = 46.5914 }, (* C1' *)
- { x = 32.2499; y = 5.8016; z = 45.9392 }, (* H1' *)
- { x = 31.9167; y = 5.5319; z = 48.0305 }, (* C2' *)
- { x = 31.1507; y = 5.0820; z = 48.6621 }, (* H2'' *)
- { x = 32.0865; y = 6.8890; z = 48.3114 }, (* O2' *)
- { x = 31.5363; y = 7.4819; z = 47.7942 }, (* H2' *)
- { x = 33.2398; y = 4.8224; z = 48.2563 }, (* C3' *)
- { x = 33.3166; y = 4.5570; z = 49.3108 }, (* H3' *)
- { x = 34.2528; y = 5.7056; z = 47.7476 }, (* O3' *)
- { x = 28.2782; y = 6.3049; z = 42.9364 }, (* N1 *)
- { x = 30.4001; y = 5.8547; z = 43.9258 }, (* N3 *)
- { x = 29.6195; y = 6.1568; z = 42.8913 }, (* C2 *)
- { x = 29.7005; y = 5.7006; z = 45.0649 }, (* C4 *)
- { x = 28.3383; y = 5.8221; z = 45.2343 }, (* C5 *)
- { x = 27.5519; y = 6.1461; z = 44.0958 }, (* C6 *)
- (G (
- { x = 30.1838; y = 6.3385; z = 41.6890 }, (* N2 *)
- { x = 27.9936; y = 5.5926; z = 46.5651 }, (* N7 *)
- { x = 30.2046; y = 5.3825; z = 46.3136 }, (* N9 *)
- { x = 29.1371; y = 5.3398; z = 47.1506 }, (* C8 *)
- { x = 26.3361; y = 6.3024; z = 44.0495 }, (* O6 *)
- { x = 27.8122; y = 6.5394; z = 42.0833 }, (* H1 *)
- { x = 29.7125; y = 6.5595; z = 40.8235 }, (* H21 *)
- { x = 31.1859; y = 6.2231; z = 41.6389 }, (* H22 *)
- { x = 28.9406; y = 5.1504; z = 48.2059 }) (* H8 *)
- )
- )
-
-let rGs = [rG01;rG02;rG03;rG04;rG05;rG06;rG07;rG08;rG09;rG10]
-
-let rU
- = N(
- { a= -0.0359; b= -0.8071; c=0.5894; (* dgf_base_tfo *)
- d= -0.2669; e=0.5761; f=0.7726;
- g= -0.9631; h= -0.1296; i= -0.2361;
- tx=0.1584; ty=8.3434; tz=0.5434 },
- { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
- d=0.0649; e=0.4366; f= -0.8973;
- g=0.5521; h= -0.7648; i= -0.3322;
- tx=1.6833; ty=6.8060; tz= -7.0011 },
- { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
- d= -0.4628; e= -0.6450; f= -0.6082;
- g=0.8168; h= -0.0436; i= -0.5753;
- tx= -6.8179; ty= -3.9778; tz= -5.9887 },
- { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
- d=0.8103; e= -0.5790; f=0.0906;
- g= -0.0255; h= -0.1894; i= -0.9816;
- tx=6.1203; ty= -7.1051; tz=3.1984 },
- { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *)
- { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *)
- { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *)
- { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *)
- { x = 5.2430; y = -8.2420; z = 2.8260 }, (* C5' *)
- { x = 5.1974; y = -8.8497; z = 1.9223 }, (* H5' *)
- { x = 5.5548; y = -8.7348; z = 3.7469 }, (* H5'' *)
- { x = 6.3140; y = -7.2060; z = 2.5510 }, (* C4' *)
- { x = 7.2954; y = -7.6762; z = 2.4898 }, (* H4' *)
- { x = 6.0140; y = -6.5420; z = 1.2890 }, (* O4' *)
- { x = 6.4190; y = -5.1840; z = 1.3620 }, (* C1' *)
- { x = 7.1608; y = -5.0495; z = 0.5747 }, (* H1' *)
- { x = 7.0760; y = -4.9560; z = 2.7270 }, (* C2' *)
- { x = 6.7770; y = -3.9803; z = 3.1099 }, (* H2'' *)
- { x = 8.4500; y = -5.1930; z = 2.5810 }, (* O2' *)
- { x = 8.8309; y = -4.8755; z = 1.7590 }, (* H2' *)
- { x = 6.4060; y = -6.0590; z = 3.5580 }, (* C3' *)
- { x = 5.4021; y = -5.7313; z = 3.8281 }, (* H3' *)
- { x = 7.1570; y = -6.4240; z = 4.7070 }, (* O3' *)
- { x = 5.2170; y = -4.3260; z = 1.1690 }, (* N1 *)
- { x = 4.2960; y = -2.2560; z = 0.6290 }, (* N3 *)
- { x = 5.4330; y = -3.0200; z = 0.7990 }, (* C2 *)
- { x = 2.9930; y = -2.6780; z = 0.7940 }, (* C4 *)
- { x = 2.8670; y = -4.0630; z = 1.1830 }, (* C5 *)
- { x = 3.9570; y = -4.8300; z = 1.3550 }, (* C6 *)
- (U (
- { x = 6.5470; y = -2.5560; z = 0.6290 }, (* O2 *)
- { x = 2.0540; y = -1.9000; z = 0.6130 }, (* O4 *)
- { x = 4.4300; y = -1.3020; z = 0.3600 }, (* H3 *)
- { x = 1.9590; y = -4.4570; z = 1.3250 }, (* H5 *)
- { x = 3.8460; y = -5.7860; z = 1.6240 }) (* H6 *)
- )
- )
-
-let rU01
- = N(
- { a= -0.0137; b= -0.8012; c=0.5983; (* dgf_base_tfo *)
- d= -0.2523; e=0.5817; f=0.7733;
- g= -0.9675; h= -0.1404; i= -0.2101;
- tx=0.2031; ty=8.3874; tz=0.4228 },
- { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
- d=0.0649; e=0.4366; f= -0.8973;
- g=0.5521; h= -0.7648; i= -0.3322;
- tx=1.6833; ty=6.8060; tz= -7.0011 },
- { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
- d= -0.4628; e= -0.6450; f= -0.6082;
- g=0.8168; h= -0.0436; i= -0.5753;
- tx= -6.8179; ty= -3.9778; tz= -5.9887 },
- { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
- d=0.8103; e= -0.5790; f=0.0906;
- g= -0.0255; h= -0.1894; i= -0.9816;
- tx=6.1203; ty= -7.1051; tz=3.1984 },
- { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *)
- { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *)
- { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *)
- { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *)
- { x = 5.2416; y = -8.2422; z = 2.8181 }, (* C5' *)
- { x = 5.2050; y = -8.8128; z = 1.8901 }, (* H5' *)
- { x = 5.5368; y = -8.7738; z = 3.7227 }, (* H5'' *)
- { x = 6.3232; y = -7.2037; z = 2.6002 }, (* C4' *)
- { x = 7.3048; y = -7.6757; z = 2.5577 }, (* H4' *)
- { x = 6.0635; y = -6.5092; z = 1.3456 }, (* O4' *)
- { x = 6.4697; y = -5.1547; z = 1.4629 }, (* C1' *)
- { x = 7.2354; y = -5.0043; z = 0.7018 }, (* H1' *)
- { x = 7.0856; y = -4.9610; z = 2.8521 }, (* C2' *)
- { x = 6.7777; y = -3.9935; z = 3.2487 }, (* H2'' *)
- { x = 8.4627; y = -5.1992; z = 2.7423 }, (* O2' *)
- { x = 8.8693; y = -4.8638; z = 1.9399 }, (* H2' *)
- { x = 6.3877; y = -6.0809; z = 3.6362 }, (* C3' *)
- { x = 5.3770; y = -5.7562; z = 3.8834 }, (* H3' *)
- { x = 7.1024; y = -6.4754; z = 4.7985 }, (* O3' *)
- { x = 5.2764; y = -4.2883; z = 1.2538 }, (* N1 *)
- { x = 4.3777; y = -2.2062; z = 0.7229 }, (* N3 *)
- { x = 5.5069; y = -2.9779; z = 0.9088 }, (* C2 *)
- { x = 3.0693; y = -2.6246; z = 0.8500 }, (* C4 *)
- { x = 2.9279; y = -4.0146; z = 1.2149 }, (* C5 *)
- { x = 4.0101; y = -4.7892; z = 1.4017 }, (* C6 *)
- (U (
- { x = 6.6267; y = -2.5166; z = 0.7728 }, (* O2 *)
- { x = 2.1383; y = -1.8396; z = 0.6581 }, (* O4 *)
- { x = 4.5223; y = -1.2489; z = 0.4716 }, (* H3 *)
- { x = 2.0151; y = -4.4065; z = 1.3290 }, (* H5 *)
- { x = 3.8886; y = -5.7486; z = 1.6535 }) (* H6 *)
- )
- )
-
-let rU02
- = N(
- { a=0.5141; b=0.0246; c=0.8574; (* dgf_base_tfo *)
- d= -0.5547; e= -0.7529; f=0.3542;
- g=0.6542; h= -0.6577; i= -0.3734;
- tx= -9.1111; ty= -3.4598; tz= -3.2939 },
- { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
- d=0.0649; e=0.4366; f= -0.8973;
- g=0.5521; h= -0.7648; i= -0.3322;
- tx=1.6833; ty=6.8060; tz= -7.0011 },
- { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
- d= -0.4628; e= -0.6450; f= -0.6082;
- g=0.8168; h= -0.0436; i= -0.5753;
- tx= -6.8179; ty= -3.9778; tz= -5.9887 },
- { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
- d=0.8103; e= -0.5790; f=0.0906;
- g= -0.0255; h= -0.1894; i= -0.9816;
- tx=6.1203; ty= -7.1051; tz=3.1984 },
- { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *)
- { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *)
- { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *)
- { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *)
- { x = 4.3825; y = -6.6585; z = 4.0489 }, (* C5' *)
- { x = 4.6841; y = -7.2019; z = 4.9443 }, (* H5' *)
- { x = 3.6189; y = -5.8889; z = 4.1625 }, (* H5'' *)
- { x = 5.6255; y = -5.9175; z = 3.5998 }, (* C4' *)
- { x = 5.8732; y = -5.1228; z = 4.3034 }, (* H4' *)
- { x = 6.7337; y = -6.8605; z = 3.5222 }, (* O4' *)
- { x = 7.5932; y = -6.4923; z = 2.4548 }, (* C1' *)
- { x = 8.5661; y = -6.2983; z = 2.9064 }, (* H1' *)
- { x = 7.0527; y = -5.2012; z = 1.8322 }, (* C2' *)
- { x = 7.1627; y = -5.2525; z = 0.7490 }, (* H2'' *)
- { x = 7.6666; y = -4.1249; z = 2.4880 }, (* O2' *)
- { x = 8.5944; y = -4.2543; z = 2.6981 }, (* H2' *)
- { x = 5.5661; y = -5.3029; z = 2.2009 }, (* C3' *)
- { x = 5.0841; y = -6.0018; z = 1.5172 }, (* H3' *)
- { x = 4.9062; y = -4.0452; z = 2.2042 }, (* O3' *)
- { x = 7.6298; y = -7.6136; z = 1.4752 }, (* N1 *)
- { x = 8.6945; y = -8.7046; z = -0.2857 }, (* N3 *)
- { x = 8.6943; y = -7.6514; z = 0.6066 }, (* C2 *)
- { x = 7.7426; y = -9.6987; z = -0.3801 }, (* C4 *)
- { x = 6.6642; y = -9.5742; z = 0.5722 }, (* C5 *)
- { x = 6.6391; y = -8.5592; z = 1.4526 }, (* C6 *)
- (U (
- { x = 9.5840; y = -6.8186; z = 0.6136 }, (* O2 *)
- { x = 7.8505; y = -10.5925; z = -1.2223 }, (* O4 *)
- { x = 9.4601; y = -8.7514; z = -0.9277 }, (* H3 *)
- { x = 5.9281; y = -10.2509; z = 0.5782 }, (* H5 *)
- { x = 5.8831; y = -8.4931; z = 2.1028 }) (* H6 *)
- )
- )
-
-let rU03
- = N(
- { a= -0.4993; b=0.0476; c=0.8651; (* dgf_base_tfo *)
- d=0.8078; e= -0.3353; f=0.4847;
- g=0.3132; h=0.9409; i=0.1290;
- tx=6.2989; ty= -5.2303; tz= -3.8577 },
- { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
- d=0.0649; e=0.4366; f= -0.8973;
- g=0.5521; h= -0.7648; i= -0.3322;
- tx=1.6833; ty=6.8060; tz= -7.0011 },
- { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
- d= -0.4628; e= -0.6450; f= -0.6082;
- g=0.8168; h= -0.0436; i= -0.5753;
- tx= -6.8179; ty= -3.9778; tz= -5.9887 },
- { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
- d=0.8103; e= -0.5790; f=0.0906;
- g= -0.0255; h= -0.1894; i= -0.9816;
- tx=6.1203; ty= -7.1051; tz=3.1984 },
- { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *)
- { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *)
- { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *)
- { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *)
- { x = 3.9938; y = -6.7042; z = 1.9023 }, (* C5' *)
- { x = 3.2332; y = -5.9343; z = 2.0319 }, (* H5' *)
- { x = 3.9666; y = -7.2863; z = 0.9812 }, (* H5'' *)
- { x = 5.3098; y = -5.9546; z = 1.8564 }, (* C4' *)
- { x = 5.3863; y = -5.3702; z = 0.9395 }, (* H4' *)
- { x = 5.3851; y = -5.0642; z = 3.0076 }, (* O4' *)
- { x = 6.7315; y = -4.9724; z = 3.4462 }, (* C1' *)
- { x = 7.0033; y = -3.9202; z = 3.3619 }, (* H1' *)
- { x = 7.5997; y = -5.8018; z = 2.4948 }, (* C2' *)
- { x = 8.3627; y = -6.3254; z = 3.0707 }, (* H2'' *)
- { x = 8.0410; y = -4.9501; z = 1.4724 }, (* O2' *)
- { x = 8.2781; y = -4.0644; z = 1.7570 }, (* H2' *)
- { x = 6.5701; y = -6.8129; z = 1.9714 }, (* C3' *)
- { x = 6.4186; y = -7.5809; z = 2.7299 }, (* H3' *)
- { x = 6.9357; y = -7.3841; z = 0.7235 }, (* O3' *)
- { x = 6.8024; y = -5.4718; z = 4.8475 }, (* N1 *)
- { x = 7.9218; y = -5.5700; z = 6.8877 }, (* N3 *)
- { x = 7.8908; y = -5.0886; z = 5.5944 }, (* C2 *)
- { x = 6.9789; y = -6.3827; z = 7.4823 }, (* C4 *)
- { x = 5.8742; y = -6.7319; z = 6.6202 }, (* C5 *)
- { x = 5.8182; y = -6.2769; z = 5.3570 }, (* C6 *)
- (U (
- { x = 8.7747; y = -4.3728; z = 5.1568 }, (* O2 *)
- { x = 7.1154; y = -6.7509; z = 8.6509 }, (* O4 *)
- { x = 8.7055; y = -5.3037; z = 7.4491 }, (* H3 *)
- { x = 5.1416; y = -7.3178; z = 6.9665 }, (* H5 *)
- { x = 5.0441; y = -6.5310; z = 4.7784 }) (* H6 *)
- )
- )
-
-let rU04
- = N(
- { a= -0.5669; b= -0.8012; c=0.1918; (* dgf_base_tfo *)
- d= -0.8129; e=0.5817; f=0.0273;
- g= -0.1334; h= -0.1404; i= -0.9811;
- tx= -0.3279; ty=8.3874; tz=0.3355 },
- { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
- d=0.0649; e=0.4366; f= -0.8973;
- g=0.5521; h= -0.7648; i= -0.3322;
- tx=1.6833; ty=6.8060; tz= -7.0011 },
- { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
- d= -0.4628; e= -0.6450; f= -0.6082;
- g=0.8168; h= -0.0436; i= -0.5753;
- tx= -6.8179; ty= -3.9778; tz= -5.9887 },
- { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
- d=0.8103; e= -0.5790; f=0.0906;
- g= -0.0255; h= -0.1894; i= -0.9816;
- tx=6.1203; ty= -7.1051; tz=3.1984 },
- { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *)
- { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *)
- { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *)
- { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *)
- { x = 5.2416; y = -8.2422; z = 2.8181 }, (* C5' *)
- { x = 5.2050; y = -8.8128; z = 1.8901 }, (* H5' *)
- { x = 5.5368; y = -8.7738; z = 3.7227 }, (* H5'' *)
- { x = 6.3232; y = -7.2037; z = 2.6002 }, (* C4' *)
- { x = 7.3048; y = -7.6757; z = 2.5577 }, (* H4' *)
- { x = 6.0635; y = -6.5092; z = 1.3456 }, (* O4' *)
- { x = 6.4697; y = -5.1547; z = 1.4629 }, (* C1' *)
- { x = 7.2354; y = -5.0043; z = 0.7018 }, (* H1' *)
- { x = 7.0856; y = -4.9610; z = 2.8521 }, (* C2' *)
- { x = 6.7777; y = -3.9935; z = 3.2487 }, (* H2'' *)
- { x = 8.4627; y = -5.1992; z = 2.7423 }, (* O2' *)
- { x = 8.8693; y = -4.8638; z = 1.9399 }, (* H2' *)
- { x = 6.3877; y = -6.0809; z = 3.6362 }, (* C3' *)
- { x = 5.3770; y = -5.7562; z = 3.8834 }, (* H3' *)
- { x = 7.1024; y = -6.4754; z = 4.7985 }, (* O3' *)
- { x = 5.2764; y = -4.2883; z = 1.2538 }, (* N1 *)
- { x = 3.8961; y = -3.0896; z = -0.1893 }, (* N3 *)
- { x = 5.0095; y = -3.8907; z = -0.0346 }, (* C2 *)
- { x = 3.0480; y = -2.6632; z = 0.8116 }, (* C4 *)
- { x = 3.4093; y = -3.1310; z = 2.1292 }, (* C5 *)
- { x = 4.4878; y = -3.9124; z = 2.3088 }, (* C6 *)
- (U (
- { x = 5.7005; y = -4.2164; z = -0.9842 }, (* O2 *)
- { x = 2.0800; y = -1.9458; z = 0.5503 }, (* O4 *)
- { x = 3.6834; y = -2.7882; z = -1.1190 }, (* H3 *)
- { x = 2.8508; y = -2.8721; z = 2.9172 }, (* H5 *)
- { x = 4.7188; y = -4.2247; z = 3.2295 }) (* H6 *)
- )
- )
-
-let rU05
- = N(
- { a= -0.6298; b=0.0246; c=0.7763; (* dgf_base_tfo *)
- d= -0.5226; e= -0.7529; f= -0.4001;
- g=0.5746; h= -0.6577; i=0.4870;
- tx= -0.0208; ty= -3.4598; tz= -9.6882 },
- { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
- d=0.0649; e=0.4366; f= -0.8973;
- g=0.5521; h= -0.7648; i= -0.3322;
- tx=1.6833; ty=6.8060; tz= -7.0011 },
- { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
- d= -0.4628; e= -0.6450; f= -0.6082;
- g=0.8168; h= -0.0436; i= -0.5753;
- tx= -6.8179; ty= -3.9778; tz= -5.9887 },
- { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
- d=0.8103; e= -0.5790; f=0.0906;
- g= -0.0255; h= -0.1894; i= -0.9816;
- tx=6.1203; ty= -7.1051; tz=3.1984 },
- { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *)
- { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *)
- { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *)
- { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *)
- { x = 4.3825; y = -6.6585; z = 4.0489 }, (* C5' *)
- { x = 4.6841; y = -7.2019; z = 4.9443 }, (* H5' *)
- { x = 3.6189; y = -5.8889; z = 4.1625 }, (* H5'' *)
- { x = 5.6255; y = -5.9175; z = 3.5998 }, (* C4' *)
- { x = 5.8732; y = -5.1228; z = 4.3034 }, (* H4' *)
- { x = 6.7337; y = -6.8605; z = 3.5222 }, (* O4' *)
- { x = 7.5932; y = -6.4923; z = 2.4548 }, (* C1' *)
- { x = 8.5661; y = -6.2983; z = 2.9064 }, (* H1' *)
- { x = 7.0527; y = -5.2012; z = 1.8322 }, (* C2' *)
- { x = 7.1627; y = -5.2525; z = 0.7490 }, (* H2'' *)
- { x = 7.6666; y = -4.1249; z = 2.4880 }, (* O2' *)
- { x = 8.5944; y = -4.2543; z = 2.6981 }, (* H2' *)
- { x = 5.5661; y = -5.3029; z = 2.2009 }, (* C3' *)
- { x = 5.0841; y = -6.0018; z = 1.5172 }, (* H3' *)
- { x = 4.9062; y = -4.0452; z = 2.2042 }, (* O3' *)
- { x = 7.6298; y = -7.6136; z = 1.4752 }, (* N1 *)
- { x = 8.5977; y = -9.5977; z = 0.7329 }, (* N3 *)
- { x = 8.5951; y = -8.5745; z = 1.6594 }, (* C2 *)
- { x = 7.7372; y = -9.7371; z = -0.3364 }, (* C4 *)
- { x = 6.7596; y = -8.6801; z = -0.4476 }, (* C5 *)
- { x = 6.7338; y = -7.6721; z = 0.4408 }, (* C6 *)
- (U (
- { x = 9.3993; y = -8.5377; z = 2.5743 }, (* O2 *)
- { x = 7.8374; y = -10.6990; z = -1.1008 }, (* O4 *)
- { x = 9.2924; y = -10.3081; z = 0.8477 }, (* H3 *)
- { x = 6.0932; y = -8.6982; z = -1.1929 }, (* H5 *)
- { x = 6.0481; y = -6.9515; z = 0.3446 }) (* H6 *)
- )
- )
-
-let rU06
- = N(
- { a= -0.9837; b=0.0476; c= -0.1733; (* dgf_base_tfo *)
- d= -0.1792; e= -0.3353; f=0.9249;
- g= -0.0141; h=0.9409; i=0.3384;
- tx=5.7793; ty= -5.2303; tz=4.5997 },
- { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
- d=0.0649; e=0.4366; f= -0.8973;
- g=0.5521; h= -0.7648; i= -0.3322;
- tx=1.6833; ty=6.8060; tz= -7.0011 },
- { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
- d= -0.4628; e= -0.6450; f= -0.6082;
- g=0.8168; h= -0.0436; i= -0.5753;
- tx= -6.8179; ty= -3.9778; tz= -5.9887 },
- { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
- d=0.8103; e= -0.5790; f=0.0906;
- g= -0.0255; h= -0.1894; i= -0.9816;
- tx=6.1203; ty= -7.1051; tz=3.1984 },
- { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *)
- { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *)
- { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *)
- { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *)
- { x = 3.9938; y = -6.7042; z = 1.9023 }, (* C5' *)
- { x = 3.2332; y = -5.9343; z = 2.0319 }, (* H5' *)
- { x = 3.9666; y = -7.2863; z = 0.9812 }, (* H5'' *)
- { x = 5.3098; y = -5.9546; z = 1.8564 }, (* C4' *)
- { x = 5.3863; y = -5.3702; z = 0.9395 }, (* H4' *)
- { x = 5.3851; y = -5.0642; z = 3.0076 }, (* O4' *)
- { x = 6.7315; y = -4.9724; z = 3.4462 }, (* C1' *)
- { x = 7.0033; y = -3.9202; z = 3.3619 }, (* H1' *)
- { x = 7.5997; y = -5.8018; z = 2.4948 }, (* C2' *)
- { x = 8.3627; y = -6.3254; z = 3.0707 }, (* H2'' *)
- { x = 8.0410; y = -4.9501; z = 1.4724 }, (* O2' *)
- { x = 8.2781; y = -4.0644; z = 1.7570 }, (* H2' *)
- { x = 6.5701; y = -6.8129; z = 1.9714 }, (* C3' *)
- { x = 6.4186; y = -7.5809; z = 2.7299 }, (* H3' *)
- { x = 6.9357; y = -7.3841; z = 0.7235 }, (* O3' *)
- { x = 6.8024; y = -5.4718; z = 4.8475 }, (* N1 *)
- { x = 6.6920; y = -5.0495; z = 7.1354 }, (* N3 *)
- { x = 6.6201; y = -4.5500; z = 5.8506 }, (* C2 *)
- { x = 6.9254; y = -6.3614; z = 7.4926 }, (* C4 *)
- { x = 7.1046; y = -7.2543; z = 6.3718 }, (* C5 *)
- { x = 7.0391; y = -6.7951; z = 5.1106 }, (* C6 *)
- (U (
- { x = 6.4083; y = -3.3696; z = 5.6340 }, (* O2 *)
- { x = 6.9679; y = -6.6901; z = 8.6800 }, (* O4 *)
- { x = 6.5626; y = -4.3957; z = 7.8812 }, (* H3 *)
- { x = 7.2781; y = -8.2254; z = 6.5350 }, (* H5 *)
- { x = 7.1657; y = -7.4312; z = 4.3503 }) (* H6 *)
- )
- )
-
-let rU07
- = N(
- { a= -0.9434; b=0.3172; c=0.0971; (* dgf_base_tfo *)
- d=0.2294; e=0.4125; f=0.8816;
- g=0.2396; h=0.8539; i= -0.4619;
- tx=8.3625; ty= -52.7147; tz=1.3745 },
- { a=0.2765; b= -0.1121; c= -0.9545; (* P_O3'_275_tfo *)
- d= -0.8297; e=0.4733; f= -0.2959;
- g=0.4850; h=0.8737; i=0.0379;
- tx= -14.7774; ty= -45.2464; tz=21.9088 },
- { a=0.1063; b= -0.6334; c= -0.7665; (* P_O3'_180_tfo *)
- d= -0.5932; e= -0.6591; f=0.4624;
- g= -0.7980; h=0.4055; i= -0.4458;
- tx=43.7634; ty=4.3296; tz=28.4890 },
- { a=0.7136; b= -0.5032; c= -0.4873; (* P_O3'_60_tfo *)
- d=0.6803; e=0.3317; f=0.6536;
- g= -0.1673; h= -0.7979; i=0.5791;
- tx= -17.1858; ty=41.4390; tz= -27.0751 },
- { x = 21.3880; y = 15.0780; z = 45.5770 }, (* P *)
- { x = 21.9980; y = 14.5500; z = 46.8210 }, (* O1P *)
- { x = 21.1450; y = 14.0270; z = 44.5420 }, (* O2P *)
- { x = 22.1250; y = 16.3600; z = 44.9460 }, (* O5' *)
- { x = 21.5037; y = 16.8594; z = 43.7323 }, (* C5' *)
- { x = 20.8147; y = 17.6663; z = 43.9823 }, (* H5' *)
- { x = 21.1086; y = 16.0230; z = 43.1557 }, (* H5'' *)
- { x = 22.5654; y = 17.4874; z = 42.8616 }, (* C4' *)
- { x = 22.1584; y = 17.7243; z = 41.8785 }, (* H4' *)
- { x = 23.0557; y = 18.6826; z = 43.4751 }, (* O4' *)
- { x = 24.4788; y = 18.6151; z = 43.6455 }, (* C1' *)
- { x = 24.9355; y = 19.0840; z = 42.7739 }, (* H1' *)
- { x = 24.7958; y = 17.1427; z = 43.6474 }, (* C2' *)
- { x = 24.5652; y = 16.7400; z = 44.6336 }, (* H2'' *)
- { x = 26.1041; y = 16.8773; z = 43.2455 }, (* O2' *)
- { x = 26.7516; y = 17.5328; z = 43.5149 }, (* H2' *)
- { x = 23.8109; y = 16.5979; z = 42.6377 }, (* C3' *)
- { x = 23.5756; y = 15.5686; z = 42.9084 }, (* H3' *)
- { x = 24.2890; y = 16.7447; z = 41.2729 }, (* O3' *)
- { x = 24.9420; y = 19.2174; z = 44.8923 }, (* N1 *)
- { x = 25.2655; y = 20.5636; z = 44.8883 }, (* N3 *)
- { x = 25.1663; y = 21.2219; z = 43.8561 }, (* C2 *)
- { x = 25.6911; y = 21.1219; z = 46.0494 }, (* C4 *)
- { x = 25.8051; y = 20.4068; z = 47.2048 }, (* C5 *)
- { x = 26.2093; y = 20.9962; z = 48.2534 }, (* C6 *)
- (U (
- { x = 25.4692; y = 19.0221; z = 47.2053 }, (* O2 *)
- { x = 25.0502; y = 18.4827; z = 46.0370 }, (* O4 *)
- { x = 25.9599; y = 22.1772; z = 46.0966 }, (* H3 *)
- { x = 25.5545; y = 18.4409; z = 48.1234 }, (* H5 *)
- { x = 24.7854; y = 17.4265; z = 45.9883 }) (* H6 *)
- )
- )
-
-let rU08
- = N(
- { a= -0.0080; b= -0.7928; c=0.6094; (* dgf_base_tfo *)
- d= -0.7512; e=0.4071; f=0.5197;
- g= -0.6601; h= -0.4536; i= -0.5988;
- tx=44.1482; ty=30.7036; tz=2.1088 },
- { a=0.2765; b= -0.1121; c= -0.9545; (* P_O3'_275_tfo *)
- d= -0.8297; e=0.4733; f= -0.2959;
- g=0.4850; h=0.8737; i=0.0379;
- tx= -14.7774; ty= -45.2464; tz=21.9088 },
- { a=0.1063; b= -0.6334; c= -0.7665; (* P_O3'_180_tfo *)
- d= -0.5932; e= -0.6591; f=0.4624;
- g= -0.7980; h=0.4055; i= -0.4458;
- tx=43.7634; ty=4.3296; tz=28.4890 },
- { a=0.7136; b= -0.5032; c= -0.4873; (* P_O3'_60_tfo *)
- d=0.6803; e=0.3317; f=0.6536;
- g= -0.1673; h= -0.7979; i=0.5791;
- tx= -17.1858; ty=41.4390; tz= -27.0751 },
- { x = 21.3880; y = 15.0780; z = 45.5770 }, (* P *)
- { x = 21.9980; y = 14.5500; z = 46.8210 }, (* O1P *)
- { x = 21.1450; y = 14.0270; z = 44.5420 }, (* O2P *)
- { x = 22.1250; y = 16.3600; z = 44.9460 }, (* O5' *)
- { x = 23.5096; y = 16.1227; z = 44.5783 }, (* C5' *)
- { x = 23.5649; y = 15.8588; z = 43.5222 }, (* H5' *)
- { x = 23.9621; y = 15.4341; z = 45.2919 }, (* H5'' *)
- { x = 24.2805; y = 17.4138; z = 44.7151 }, (* C4' *)
- { x = 25.3492; y = 17.2309; z = 44.6030 }, (* H4' *)
- { x = 23.8497; y = 18.3471; z = 43.7208 }, (* O4' *)
- { x = 23.4090; y = 19.5681; z = 44.3321 }, (* C1' *)
- { x = 24.2595; y = 20.2496; z = 44.3524 }, (* H1' *)
- { x = 23.0418; y = 19.1813; z = 45.7407 }, (* C2' *)
- { x = 22.0532; y = 18.7224; z = 45.7273 }, (* H2'' *)
- { x = 23.1307; y = 20.2521; z = 46.6291 }, (* O2' *)
- { x = 22.8888; y = 21.1051; z = 46.2611 }, (* H2' *)
- { x = 24.0799; y = 18.1326; z = 46.0700 }, (* C3' *)
- { x = 23.6490; y = 17.4370; z = 46.7900 }, (* H3' *)
- { x = 25.3329; y = 18.7227; z = 46.5109 }, (* O3' *)
- { x = 22.2515; y = 20.1624; z = 43.6698 }, (* N1 *)
- { x = 22.4760; y = 21.0609; z = 42.6406 }, (* N3 *)
- { x = 23.6229; y = 21.3462; z = 42.3061 }, (* C2 *)
- { x = 21.3986; y = 21.6081; z = 42.0236 }, (* C4 *)
- { x = 20.1189; y = 21.3012; z = 42.3804 }, (* C5 *)
- { x = 19.1599; y = 21.8516; z = 41.7578 }, (* C6 *)
- (U (
- { x = 19.8919; y = 20.3745; z = 43.4387 }, (* O2 *)
- { x = 20.9790; y = 19.8423; z = 44.0440 }, (* O4 *)
- { x = 21.5235; y = 22.3222; z = 41.2097 }, (* H3 *)
- { x = 18.8732; y = 20.1200; z = 43.7312 }, (* H5 *)
- { x = 20.8545; y = 19.1313; z = 44.8608 }) (* H6 *)
- )
- )
-
-let rU09
- = N(
- { a= -0.0317; b=0.1374; c=0.9900; (* dgf_base_tfo *)
- d= -0.3422; e= -0.9321; f=0.1184;
- g=0.9391; h= -0.3351; i=0.0765;
- tx= -32.1929; ty=25.8198; tz= -28.5088 },
- { a=0.2765; b= -0.1121; c= -0.9545; (* P_O3'_275_tfo *)
- d= -0.8297; e=0.4733; f= -0.2959;
- g=0.4850; h=0.8737; i=0.0379;
- tx= -14.7774; ty= -45.2464; tz=21.9088 },
- { a=0.1063; b= -0.6334; c= -0.7665; (* P_O3'_180_tfo *)
- d= -0.5932; e= -0.6591; f=0.4624;
- g= -0.7980; h=0.4055; i= -0.4458;
- tx=43.7634; ty=4.3296; tz=28.4890 },
- { a=0.7136; b= -0.5032; c= -0.4873; (* P_O3'_60_tfo *)
- d=0.6803; e=0.3317; f=0.6536;
- g= -0.1673; h= -0.7979; i=0.5791;
- tx= -17.1858; ty=41.4390; tz= -27.0751 },
- { x = 21.3880; y = 15.0780; z = 45.5770 }, (* P *)
- { x = 21.9980; y = 14.5500; z = 46.8210 }, (* O1P *)
- { x = 21.1450; y = 14.0270; z = 44.5420 }, (* O2P *)
- { x = 22.1250; y = 16.3600; z = 44.9460 }, (* O5' *)
- { x = 21.5037; y = 16.8594; z = 43.7323 }, (* C5' *)
- { x = 20.8147; y = 17.6663; z = 43.9823 }, (* H5' *)
- { x = 21.1086; y = 16.0230; z = 43.1557 }, (* H5'' *)
- { x = 22.5654; y = 17.4874; z = 42.8616 }, (* C4' *)
- { x = 23.0565; y = 18.3036; z = 43.3915 }, (* H4' *)
- { x = 23.5375; y = 16.5054; z = 42.4925 }, (* O4' *)
- { x = 23.6574; y = 16.4257; z = 41.0649 }, (* C1' *)
- { x = 24.4701; y = 17.0882; z = 40.7671 }, (* H1' *)
- { x = 22.3525; y = 16.9643; z = 40.5396 }, (* C2' *)
- { x = 21.5993; y = 16.1799; z = 40.6133 }, (* H2'' *)
- { x = 22.4693; y = 17.4849; z = 39.2515 }, (* O2' *)
- { x = 23.0899; y = 17.0235; z = 38.6827 }, (* H2' *)
- { x = 22.0341; y = 18.0633; z = 41.5279 }, (* C3' *)
- { x = 20.9509; y = 18.1709; z = 41.5846 }, (* H3' *)
- { x = 22.7249; y = 19.3020; z = 41.2100 }, (* O3' *)
- { x = 23.8580; y = 15.0648; z = 40.5757 }, (* N1 *)
- { x = 25.1556; y = 14.5982; z = 40.4523 }, (* N3 *)
- { x = 26.1047; y = 15.3210; z = 40.7448 }, (* C2 *)
- { x = 25.3391; y = 13.3315; z = 40.0020 }, (* C4 *)
- { x = 24.2974; y = 12.5148; z = 39.6749 }, (* C5 *)
- { x = 24.5450; y = 11.3410; z = 39.2610 }, (* C6 *)
- (U (
- { x = 22.9633; y = 12.9979; z = 39.8053 }, (* O2 *)
- { x = 22.8009; y = 14.2648; z = 40.2524 }, (* O4 *)
- { x = 26.3414; y = 12.9194; z = 39.8855 }, (* H3 *)
- { x = 22.1227; y = 12.3533; z = 39.5486 }, (* H5 *)
- { x = 21.7989; y = 14.6788; z = 40.3650 }) (* H6 *)
- )
- )
-
-let rU10
- = N(
- { a= -0.9674; b=0.1021; c= -0.2318; (* dgf_base_tfo *)
- d= -0.2514; e= -0.2766; f=0.9275;
- g=0.0306; h=0.9555; i=0.2933;
- tx=27.8571; ty= -42.1305; tz= -24.4563 },
- { a=0.2765; b= -0.1121; c= -0.9545; (* P_O3'_275_tfo *)
- d= -0.8297; e=0.4733; f= -0.2959;
- g=0.4850; h=0.8737; i=0.0379;
- tx= -14.7774; ty= -45.2464; tz=21.9088 },
- { a=0.1063; b= -0.6334; c= -0.7665; (* P_O3'_180_tfo *)
- d= -0.5932; e= -0.6591; f=0.4624;
- g= -0.7980; h=0.4055; i= -0.4458;
- tx=43.7634; ty=4.3296; tz=28.4890 },
- { a=0.7136; b= -0.5032; c= -0.4873; (* P_O3'_60_tfo *)
- d=0.6803; e=0.3317; f=0.6536;
- g= -0.1673; h= -0.7979; i=0.5791;
- tx= -17.1858; ty=41.4390; tz= -27.0751 },
- { x = 21.3880; y = 15.0780; z = 45.5770 }, (* P *)
- { x = 21.9980; y = 14.5500; z = 46.8210 }, (* O1P *)
- { x = 21.1450; y = 14.0270; z = 44.5420 }, (* O2P *)
- { x = 22.1250; y = 16.3600; z = 44.9460 }, (* O5' *)
- { x = 23.5096; y = 16.1227; z = 44.5783 }, (* C5' *)
- { x = 23.5649; y = 15.8588; z = 43.5222 }, (* H5' *)
- { x = 23.9621; y = 15.4341; z = 45.2919 }, (* H5'' *)
- { x = 24.2805; y = 17.4138; z = 44.7151 }, (* C4' *)
- { x = 23.8509; y = 18.1819; z = 44.0720 }, (* H4' *)
- { x = 24.2506; y = 17.8583; z = 46.0741 }, (* O4' *)
- { x = 25.5830; y = 18.0320; z = 46.5775 }, (* C1' *)
- { x = 25.8569; y = 19.0761; z = 46.4256 }, (* H1' *)
- { x = 26.4410; y = 17.1555; z = 45.7033 }, (* C2' *)
- { x = 26.3459; y = 16.1253; z = 46.0462 }, (* H2'' *)
- { x = 27.7649; y = 17.5888; z = 45.6478 }, (* O2' *)
- { x = 28.1004; y = 17.9719; z = 46.4616 }, (* H2' *)
- { x = 25.7796; y = 17.2997; z = 44.3513 }, (* C3' *)
- { x = 25.9478; y = 16.3824; z = 43.7871 }, (* H3' *)
- { x = 26.2154; y = 18.4984; z = 43.6541 }, (* O3' *)
- { x = 25.7321; y = 17.6281; z = 47.9726 }, (* N1 *)
- { x = 25.5136; y = 18.5779; z = 48.9560 }, (* N3 *)
- { x = 25.2079; y = 19.7276; z = 48.6503 }, (* C2 *)
- { x = 25.6482; y = 18.1987; z = 50.2518 }, (* C4 *)
- { x = 25.9847; y = 16.9266; z = 50.6092 }, (* C5 *)
- { x = 26.0918; y = 16.6439; z = 51.8416 }, (* C6 *)
- (U (
- { x = 26.2067; y = 15.9515; z = 49.5943 }, (* O2 *)
- { x = 26.0713; y = 16.3497; z = 48.3080 }, (* O4 *)
- { x = 25.4890; y = 18.9105; z = 51.0618 }, (* H3 *)
- { x = 26.4742; y = 14.9310; z = 49.8682 }, (* H5 *)
- { x = 26.2346; y = 15.6394; z = 47.4975 }) (* H6 *)
- )
- )
-
-let rUs = [rU01;rU02;rU03;rU04;rU05;rU06;rU07;rU08;rU09;rU10]
-
-let rG'
- = N(
- { a= -0.2067; b= -0.0264; c=0.9780; (* dgf_base_tfo *)
- d=0.9770; e= -0.0586; f=0.2049;
- g=0.0519; h=0.9979; i=0.0379;
- tx=1.0331; ty= -46.8078; tz= -36.4742 },
- { a= -0.8644; b= -0.4956; c= -0.0851; (* P_O3'_275_tfo *)
- d= -0.0427; e=0.2409; f= -0.9696;
- g=0.5010; h= -0.8345; i= -0.2294;
- tx=4.0167; ty=54.5377; tz=12.4779 },
- { a=0.3706; b= -0.6167; c=0.6945; (* P_O3'_180_tfo *)
- d= -0.2867; e= -0.7872; f= -0.5460;
- g=0.8834; h=0.0032; i= -0.4686;
- tx= -52.9020; ty=18.6313; tz= -0.6709 },
- { a=0.4155; b=0.9025; c= -0.1137; (* P_O3'_60_tfo *)
- d=0.9040; e= -0.4236; f= -0.0582;
- g= -0.1007; h= -0.0786; i= -0.9918;
- tx= -7.6624; ty= -25.2080; tz=49.5181 },
- { x = 31.3810; y = 0.1400; z = 47.5810 }, (* P *)
- { x = 29.9860; y = 0.6630; z = 47.6290 }, (* O1P *)
- { x = 31.7210; y = -0.6460; z = 48.8090 }, (* O2P *)
- { x = 32.4940; y = 1.2540; z = 47.2740 }, (* O5' *)
- { x = 32.1610; y = 2.2370; z = 46.2560 }, (* C5' *)
- { x = 31.2986; y = 2.8190; z = 46.5812 }, (* H5' *)
- { x = 32.0980; y = 1.7468; z = 45.2845 }, (* H5'' *)
- { x = 33.3476; y = 3.1959; z = 46.1947 }, (* C4' *)
- { x = 33.2668; y = 3.8958; z = 45.3630 }, (* H4' *)
- { x = 33.3799; y = 3.9183; z = 47.4216 }, (* O4' *)
- { x = 34.6515; y = 3.7222; z = 48.0398 }, (* C1' *)
- { x = 35.2947; y = 4.5412; z = 47.7180 }, (* H1' *)
- { x = 35.1756; y = 2.4228; z = 47.4827 }, (* C2' *)
- { x = 34.6778; y = 1.5937; z = 47.9856 }, (* H2'' *)
- { x = 36.5631; y = 2.2672; z = 47.4798 }, (* O2' *)
- { x = 37.0163; y = 2.6579; z = 48.2305 }, (* H2' *)
- { x = 34.6953; y = 2.5043; z = 46.0448 }, (* C3' *)
- { x = 34.5444; y = 1.4917; z = 45.6706 }, (* H3' *)
- { x = 35.6679; y = 3.3009; z = 45.3487 }, (* O3' *)
- { x = 37.4804; y = 4.0914; z = 52.2559 }, (* N1 *)
- { x = 36.9670; y = 4.1312; z = 49.9281 }, (* N3 *)
- { x = 37.8045; y = 4.2519; z = 50.9550 }, (* C2 *)
- { x = 35.7171; y = 3.8264; z = 50.3222 }, (* C4 *)
- { x = 35.2668; y = 3.6420; z = 51.6115 }, (* C5 *)
- { x = 36.2037; y = 3.7829; z = 52.6706 }, (* C6 *)
- (G (
- { x = 39.0869; y = 4.5552; z = 50.7092 }, (* N2 *)
- { x = 33.9075; y = 3.3338; z = 51.6102 }, (* N7 *)
- { x = 34.6126; y = 3.6358; z = 49.5108 }, (* N9 *)
- { x = 33.5805; y = 3.3442; z = 50.3425 }, (* C8 *)
- { x = 35.9958; y = 3.6512; z = 53.8724 }, (* O6 *)
- { x = 38.2106; y = 4.2053; z = 52.9295 }, (* H1 *)
- { x = 39.8218; y = 4.6863; z = 51.3896 }, (* H21 *)
- { x = 39.3420; y = 4.6857; z = 49.7407 }, (* H22 *)
- { x = 32.5194; y = 3.1070; z = 50.2664 }) (* H8 *)
- )
- )
-
-let rU'
- = N(
- { a= -0.0109; b=0.5907; c=0.8068; (* dgf_base_tfo *)
- d=0.2217; e= -0.7853; f=0.5780;
- g=0.9751; h=0.1852; i= -0.1224;
- tx= -1.4225; ty= -11.0956; tz= -2.5217 },
- { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
- d=0.0649; e=0.4366; f= -0.8973;
- g=0.5521; h= -0.7648; i= -0.3322;
- tx=1.6833; ty=6.8060; tz= -7.0011 },
- { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
- d= -0.4628; e= -0.6450; f= -0.6082;
- g=0.8168; h= -0.0436; i= -0.5753;
- tx= -6.8179; ty= -3.9778; tz= -5.9887 },
- { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
- d=0.8103; e= -0.5790; f=0.0906;
- g= -0.0255; h= -0.1894; i= -0.9816;
- tx=6.1203; ty= -7.1051; tz=3.1984 },
- { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *)
- { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *)
- { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *)
- { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *)
- { x = 5.2430; y = -8.2420; z = 2.8260 }, (* C5' *)
- { x = 5.1974; y = -8.8497; z = 1.9223 }, (* H5' *)
- { x = 5.5548; y = -8.7348; z = 3.7469 }, (* H5'' *)
- { x = 6.3140; y = -7.2060; z = 2.5510 }, (* C4' *)
- { x = 5.8744; y = -6.2116; z = 2.4731 }, (* H4' *)
- { x = 7.2798; y = -7.2260; z = 3.6420 }, (* O4' *)
- { x = 8.5733; y = -6.9410; z = 3.1329 }, (* C1' *)
- { x = 8.9047; y = -6.0374; z = 3.6446 }, (* H1' *)
- { x = 8.4429; y = -6.6596; z = 1.6327 }, (* C2' *)
- { x = 9.2880; y = -7.1071; z = 1.1096 }, (* H2'' *)
- { x = 8.2502; y = -5.2799; z = 1.4754 }, (* O2' *)
- { x = 8.7676; y = -4.7284; z = 2.0667 }, (* H2' *)
- { x = 7.1642; y = -7.4416; z = 1.3021 }, (* C3' *)
- { x = 7.4125; y = -8.5002; z = 1.2260 }, (* H3' *)
- { x = 6.5160; y = -6.9772; z = 0.1267 }, (* O3' *)
- { x = 9.4531; y = -8.1107; z = 3.4087 }, (* N1 *)
- { x = 11.5931; y = -9.0015; z = 3.6357 }, (* N3 *)
- { x = 10.8101; y = -7.8950; z = 3.3748 }, (* C2 *)
- { x = 11.1439; y = -10.2744; z = 3.9206 }, (* C4 *)
- { x = 9.7056; y = -10.4026; z = 3.9332 }, (* C5 *)
- { x = 8.9192; y = -9.3419; z = 3.6833 }, (* C6 *)
- (U (
- { x = 11.3013; y = -6.8063; z = 3.1326 }, (* O2 *)
- { x = 11.9431; y = -11.1876; z = 4.1375 }, (* O4 *)
- { x = 12.5840; y = -8.8673; z = 3.6158 }, (* H3 *)
- { x = 9.2891; y = -11.2898; z = 4.1313 }, (* H5 *)
- { x = 7.9263; y = -9.4537; z = 3.6977 }) (* H6 *)
- )
- )
-
-(* -- PARTIAL INSTANTIATIONS ------------------------------------------------*)
-
-type variable =
- { id : int;
- t : tfo;
- n : nuc }
-
-let mk_var i t n = { id = i; t = t; n = n }
-
-let absolute_pos v p = tfo_apply v.t p
-
-let atom_pos atom v = absolute_pos v (atom v.n)
-
-let rec get_var id = function
- | (v::lst) -> if id = v.id then v else get_var id lst
- | _ -> assert false
-
-(* -- SEARCH ----------------------------------------------------------------*)
-
-(* Sequential backtracking algorithm *)
-
-let rec search (partial_inst : variable list) l constr =
- match l with
- [] -> [partial_inst]
- | (h::t) ->
- let rec try_assignments = function
- [] -> []
- | v::vs ->
- if constr v partial_inst then
- (search (v::partial_inst) t constr) @ (try_assignments vs)
- else
- try_assignments vs
- in
- try_assignments (h partial_inst)
-
-
-(* -- DOMAINS ---------------------------------------------------------------*)
-
-(* Primary structure: strand A CUGCCACGUCUG, strand B CAGACGUGGCAG
-
- Secondary structure: strand A CUGCCACGUCUG
- ||||||||||||
- GACGGUGCAGAC strand B
-
- Tertiary structure:
-
- 5' end of strand A C1----G12 3' end of strand B
- U2-------A11
- G3-------C10
- C4-----G9
- C5---G8
- A6
- G6-C7
- C5----G8
- A4-------U9
- G3--------C10
- A2-------U11
- 5' end of strand B C1----G12 3' end of strand A
-
- "helix", "stacked" and "connected" describe the spatial relationship
- between two consecutive nucleotides. E.g. the nucleotides C1 and U2
- from the strand A.
-
- "wc" (stands for Watson-Crick and is a type of base-pairing),
- and "wc-dumas" describe the spatial relationship between
- nucleotides from two chains that are growing in opposite directions.
- E.g. the nucleotides C1 from strand A and G12 from strand B.
-*)
-
-(* Dynamic Domains *)
-
-(* Given,
- "refnuc" a nucleotide which is already positioned,
- "nucl" the nucleotide to be placed,
- and "tfo" a transformation matrix which expresses the desired
- relationship between "refnuc" and "nucl",
- the function "dgf-base" computes the transformation matrix that
- places the nucleotide "nucl" in the given relationship to "refnuc".
-*)
-
-let
-dgf_base tfo v nucl
- = let x = if is_A v.n then
- tfo_align (atom_pos nuc_C1' v)
- (atom_pos rA_N9 v)
- (atom_pos nuc_C4 v)
- else if is_C v.n then
- tfo_align (atom_pos nuc_C1' v)
- (atom_pos nuc_N1 v)
- (atom_pos nuc_C2 v)
- else if is_G v.n then
- tfo_align (atom_pos nuc_C1' v)
- (atom_pos rG_N9 v)
- (atom_pos nuc_C4 v)
- else
- tfo_align (atom_pos nuc_C1' v)
- (atom_pos nuc_N1 v)
- (atom_pos nuc_C2 v)
- in
- tfo_combine (nuc_dgf_base_tfo nucl)
- (tfo_combine tfo (tfo_inv_ortho x))
-
-(* Placement of first nucleotide. *)
-
-let
-reference n i partial_inst = [ mk_var i tfo_id n ]
-
-(* The transformation matrix for wc is from:
-
- Chandrasekaran R. et al (1989) A Re-Examination of the Crystal
- Structure of A-DNA Using Fiber Diffraction Data. J. Biomol.
- Struct. & Dynamics 6(6):1189-1202.
-*)
-
-let wc_tfo
- = (
- { a= -1.0000; b=0.0028; c= -0.0019;
- d=0.0028; e=0.3468; f= -0.9379;
- g= -0.0019; h= -0.9379; i= -0.3468;
- tx= -0.0080; ty=6.0730; tz=8.7208 }
- )
-
-let
-wc nucl i j partial_inst
- = [ mk_var i (dgf_base wc_tfo (get_var j partial_inst) nucl) nucl ]
-
-let wc_dumas_tfo
- = (
- { a= -0.9737; b= -0.1834; c=0.1352;
- d= -0.1779; e=0.2417; f= -0.9539;
- g=0.1422; h= -0.9529; i= -0.2679;
- tx=0.4837; ty=6.2649; tz=8.0285 }
- )
-
-let
-wc_dumas nucl i j partial_inst
- = [ mk_var i (dgf_base wc_dumas_tfo (get_var j partial_inst) nucl) nucl ]
-
-let helix5'_tfo
- = (
- { a=0.9886; b= -0.0961; c=0.1156;
- d=0.1424; e=0.8452; f= -0.5152;
- g= -0.0482; h=0.5258; i=0.8492;
- tx= -3.8737; ty=0.5480; tz=3.8024 }
- )
-
-let
-helix5' nucl i j partial_inst
- = [ mk_var i (dgf_base helix5'_tfo (get_var j partial_inst) nucl) nucl ]
-
-let helix3'_tfo
- = (
- { a=0.9886; b=0.1424; c= -0.0482;
- d= -0.0961; e=0.8452; f=0.5258;
- g=0.1156; h= -0.5152; i=0.8492;
- tx=3.4426; ty=2.0474; tz= -3.7042 }
- )
-
-let
-helix3' nucl i j partial_inst
- = [ mk_var i (dgf_base helix3'_tfo (get_var j partial_inst) nucl) nucl ]
-
-let g37_a38_tfo
- = (
- { a=0.9991; b=0.0164; c= -0.0387;
- d= -0.0375; e=0.7616; f= -0.6470;
- g=0.0189; h=0.6478; i=0.7615;
- tx= -3.3018; ty=0.9975; tz=2.5585 }
- )
-
-let
-g37_a38 nucl i j partial_inst
- = mk_var i (dgf_base g37_a38_tfo (get_var j partial_inst) nucl) nucl
-
-let
-stacked5' nucl i j partial_inst
- = (g37_a38 nucl i j partial_inst) :: (helix5' nucl i j partial_inst)
-
-let a38_g37_tfo
- = (
- { a=0.9991; b= -0.0375; c=0.0189;
- d=0.0164; e=0.7616; f=0.6478;
- g= -0.0387; h= -0.6470; i=0.7615;
- tx=3.3819; ty=0.7718; tz= -2.5321 }
- )
-
-let
-a38_g37 nucl i j partial_inst
- = mk_var i (dgf_base a38_g37_tfo (get_var j partial_inst) nucl) nucl
-
-let
-stacked3' nucl i j partial_inst
- = (a38_g37 nucl i j partial_inst) :: (helix3' nucl i j partial_inst)
-
-let
-p_o3' nucls i j partial_inst
- = let refnuc = get_var j partial_inst in
- let align = tfo_inv_ortho
- (tfo_align (atom_pos nuc_O3' refnuc)
- (atom_pos nuc_C3' refnuc)
- (atom_pos nuc_C4' refnuc)) in
- let rec generate domains = function
- [] -> domains
- | n::ns ->
- generate
- ((mk_var i (tfo_combine (nuc_p_o3'_60_tfo n) align) n)::
- (mk_var i (tfo_combine (nuc_p_o3'_180_tfo n) align) n)::
- (mk_var i (tfo_combine (nuc_p_o3'_275_tfo n) align) n)::domains)
- ns
- in
- generate [] nucls
-
-(* -- PROBLEM STATEMENT -----------------------------------------------------*)
-
-(* Define anticodon problem -- Science 253:1255 Figure 3a, 3b and 3c *)
-
-let
-anticodon_domains
- = [
- reference rC 27;
- helix5' rC 28 27;
- helix5' rA 29 28;
- helix5' rG 30 29;
- helix5' rA 31 30;
- wc rU 39 31;
- helix5' rC 40 39;
- helix5' rU 41 40;
- helix5' rG 42 41;
- helix5' rG 43 42;
- stacked3' rA 38 39;
- stacked3' rG 37 38;
- stacked3' rA 36 37;
- stacked3' rA 35 36;
- stacked3' rG 34 35; (* <-. Distance *)
- p_o3' rCs 32 31; (* | Constraint *)
- p_o3' rUs 33 32 (* <-' 3.0 Angstroms *)
- ]
-
-(* Anticodon constraint *)
-
-let
-anticodon_constraint v partial_inst =
- let rec dist j = let p = atom_pos nuc_P (get_var j partial_inst) in
- let o3' = atom_pos nuc_O3' v in
- pt_dist p o3'
- in
- if v.id = 33 then
- (dist 34) <= 3.0
- else
- true
-
-let
-anticodon () = search [] anticodon_domains anticodon_constraint
-
-(* Define pseudoknot problem -- Science 253:1255 Figure 4a and 4b *)
-
-let
-pseudoknot_domains
- = [
- reference rA 23;
- wc_dumas rU 8 23;
- helix3' rG 22 23;
- wc_dumas rC 9 22;
- helix3' rG 21 22;
- wc_dumas rC 10 21;
- helix3' rC 20 21;
- wc_dumas rG 11 20;
- helix3' rU' 19 20; (* <-. *)
- wc_dumas rA 12 19; (* | Distance *)
-(* | Constraint *)
-(* Helix 1 | 4.0 Angstroms *)
- helix3' rC 3 19; (* | *)
- wc_dumas rG 13 3; (* | *)
- helix3' rC 2 3; (* | *)
- wc_dumas rG 14 2; (* | *)
- helix3' rC 1 2; (* | *)
- wc_dumas rG' 15 1; (* | *)
-(* | *)
-(* L2 LOOP | *)
- p_o3' rUs 16 15; (* | *)
- p_o3' rCs 17 16; (* | *)
- p_o3' rAs 18 17; (* <-' *)
-(* *)
-(* L1 LOOP *)
- helix3' rU 7 8; (* <-. *)
- p_o3' rCs 4 3; (* | Constraint *)
- stacked5' rU 5 4; (* | 4.5 Angstroms *)
- stacked5' rC 6 5 (* <-' *)
- ]
-
-(* Pseudoknot constraint *)
-
-let
-pseudoknot_constraint v partial_inst =
- let rec dist j =
- let p = atom_pos nuc_P (get_var j partial_inst) in
- let o3' = atom_pos nuc_O3' v in
- pt_dist p o3'
- in
- if v.id = 18 then
- (dist 19) <= 4.0
- else if v.id = 6 then
- (dist 7) <= 4.5
- else
- true
-
-let
-pseudoknot () = search [] pseudoknot_domains pseudoknot_constraint
-
-(* -- TESTING ---------------------------------------------------------------*)
-
-let list_of_atoms = function
- (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
- p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
- c3',h3',o3',n1,n3,c2,c4,c5,c6,
- A (n6,n7,n9,c8,h2,h61,h62,h8)))
- -> [|p;o1p;o2p;o5';c5';h5';h5'';c4';h4';o4';c1';h1';c2';h2'';o2';h2';c3';
- h3';o3';n1;n3;c2;c4;c5;c6;n6;n7;n9;c8;h2;h61;h62;h8|]
-
-| (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
- p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
- c3',h3',o3',n1,n3,c2,c4,c5,c6,
- C (n4,o2,h41,h42,h5,h6)))
- -> [|p;o1p;o2p;o5';c5';h5';h5'';c4';h4';o4';c1';h1';c2';h2'';o2';h2';c3';
- h3';o3';n1;n3;c2;c4;c5;c6;n4;o2;h41;h42;h5;h6|]
-
-| (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
- p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
- c3',h3',o3',n1,n3,c2,c4,c5,c6,
- G (n2,n7,n9,c8,o6,h1,h21,h22,h8)))
- -> [|p;o1p;o2p;o5';c5';h5';h5'';c4';h4';o4';c1';h1';c2';h2'';o2';h2';c3';
- h3';o3';n1;n3;c2;c4;c5;c6;n2;n7;n9;c8;o6;h1;h21;h22;h8|]
-
-| (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
- p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
- c3',h3',o3',n1,n3,c2,c4,c5,c6,
- U (o2,o4,h3,h5,h6)))
- -> [|p;o1p;o2p;o5';c5';h5';h5'';c4';h4';o4';c1';h1';c2';h2'';o2';h2';c3';
- h3';o3';n1;n3;c2;c4;c5;c6;o2;o4;h3;h5;h6|]
-
-let maximum = function
- | x::xs ->
- let rec iter m = function
- [] -> m
- | (a::b) -> iter (if a > m then a else m) b
- in
- iter x xs
- | _ -> assert false
-
-let
-var_most_distant_atom v =
- let atoms = list_of_atoms v.n in
- let max_dist = ref 0.0 in
- for i = 0 to pred (Array.length atoms) do
- let p = atoms.(i) in
- let distance =
- let pos = absolute_pos v p
- in sqrt ((pos.x * pos.x) + (pos.y * pos.y) + (pos.z * pos.z)) in
- if distance > !max_dist then max_dist := distance
- done;
- !max_dist
-
-let
-sol_most_distant_atom s = maximum (List.map var_most_distant_atom s)
-
-let
-most_distant_atom sols = maximum (List.map sol_most_distant_atom sols)
-
-let
-check () = List.length (pseudoknot ())
-
-let
-run () = most_distant_atom (pseudoknot ())
-
-let main () = Printf.printf "%.4f" (run ()); print_newline()
-
-let _ = main ()
diff --git a/test/quicksort.ml b/test/quicksort.ml
deleted file mode 100644
index 9ec223823d..0000000000
--- a/test/quicksort.ml
+++ /dev/null
@@ -1,92 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Good test for loops. Best compiled with -unsafe. *)
-
-let rec qsort lo hi (a : int array) =
- if lo < hi then begin
- let i = ref lo in
- let j = ref hi in
- let pivot = a.(hi) in
- while !i < !j do
- while !i < hi && a.(!i) <= pivot do incr i done;
- while !j > lo && a.(!j) >= pivot do decr j done;
- if !i < !j then begin
- let temp = a.(!i) in a.(!i) <- a.(!j); a.(!j) <- temp
- end
- done;
- let temp = a.(!i) in a.(!i) <- a.(hi); a.(hi) <- temp;
- qsort lo (!i-1) a;
- qsort (!i+1) hi a
- end
-
-
-(* Same but abstract over the comparison to force spilling *)
-
-let cmp i j = i - j
-
-let rec qsort2 lo hi (a : int array) =
- if lo < hi then begin
- let i = ref lo in
- let j = ref hi in
- let pivot = a.(hi) in
- while !i < !j do
- while !i < hi && cmp a.(!i) pivot <= 0 do incr i done;
- while !j > lo && cmp a.(!j) pivot >= 0 do decr j done;
- if !i < !j then begin
- let temp = a.(!i) in a.(!i) <- a.(!j); a.(!j) <- temp
- end
- done;
- let temp = a.(!i) in a.(!i) <- a.(hi); a.(hi) <- temp;
- qsort2 lo (!i-1) a;
- qsort2 (!i+1) hi a
- end
-
-
-(* Test *)
-
-let seed = ref 0
-
-let random() =
- seed := !seed * 25173 + 17431; !seed land 0xFFF
-
-
-exception Failed
-
-let test_sort sort_fun size =
- let a = Array.create size 0 in
- let check = Array.create 4096 0 in
- for i = 0 to size-1 do
- let n = random() in a.(i) <- n; check.(n) <- check.(n)+1
- done;
- sort_fun 0 (size-1) a;
- try
- check.(a.(0)) <- check.(a.(0)) - 1;
- for i = 1 to size-1 do
- if a.(i-1) > a.(i) then raise Failed;
- check.(a.(i)) <- check.(a.(i)) - 1
- done;
- for i = 0 to 4095 do
- if check.(i) <> 0 then raise Failed
- done;
- print_string "OK"; print_newline()
- with Failed ->
- print_string "failed"; print_newline()
-
-
-let main () =
- test_sort qsort 50000;
- test_sort qsort2 50000
-
-let _ = main(); exit 0
diff --git a/test/sieve.ml b/test/sieve.ml
deleted file mode 100644
index 63873a35cd..0000000000
--- a/test/sieve.ml
+++ /dev/null
@@ -1,56 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Eratosthene's sieve *)
-
-(* interval min max = [min; min+1; ...; max-1; max] *)
-
-let rec interval min max =
- if min > max then [] else min :: interval (min + 1) max
-
-
-(* filter p L returns the list of the elements in list L
- that satisfy predicate p *)
-
-let rec filter p = function
- [] -> []
- | a::r -> if p a then a :: filter p r else filter p r
-
-
-(* Application: removing all numbers multiple of n from a list of integers *)
-
-let remove_multiples_of n =
- filter (fun m -> m mod n <> 0)
-
-
-(* The sieve itself *)
-
-let sieve max =
- let rec filter_again = function
- [] -> []
- | n::r as l ->
- if n*n > max then l else n :: filter_again (remove_multiples_of n r)
- in
- filter_again (interval 2 max)
-
-
-let rec do_list f = function
- [] -> ()
- | a::l -> f a; do_list f l
-
-
-let _ =
- do_list (fun n -> print_int n; print_string " ") (sieve 40000);
- print_newline();
- exit 0
diff --git a/test/soli.ml b/test/soli.ml
deleted file mode 100644
index aba79b15b8..0000000000
--- a/test/soli.ml
+++ /dev/null
@@ -1,111 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-
-type peg = Out | Empty | Peg
-
-let board = [|
- [| Out; Out; Out; Out; Out; Out; Out; Out; Out|];
- [| Out; Out; Out; Peg; Peg; Peg; Out; Out; Out|];
- [| Out; Out; Out; Peg; Peg; Peg; Out; Out; Out|];
- [| Out; Peg; Peg; Peg; Peg; Peg; Peg; Peg; Out|];
- [| Out; Peg; Peg; Peg; Empty; Peg; Peg; Peg; Out|];
- [| Out; Peg; Peg; Peg; Peg; Peg; Peg; Peg; Out|];
- [| Out; Out; Out; Peg; Peg; Peg; Out; Out; Out|];
- [| Out; Out; Out; Peg; Peg; Peg; Out; Out; Out|];
- [| Out; Out; Out; Out; Out; Out; Out; Out; Out|]
-|]
-
-
-let print_peg = function
- Out -> print_string "."
- | Empty -> print_string " "
- | Peg -> print_string "$"
-
-
-let print_board board =
- for i=0 to 8 do
- for j=0 to 8 do
- print_peg board.(i).(j)
- done;
- print_newline()
- done
-
-
-type direction = { dx: int; dy: int }
-
-let dir = [| {dx = 0; dy = 1}; {dx = 1; dy = 0};
- {dx = 0; dy = -1}; {dx = -1; dy = 0} |]
-
-type move = { x1: int; y1: int; x2: int; y2: int }
-
-let moves = Array.create 31 {x1=0;y1=0;x2=0;y2=0}
-
-let counter = ref 0
-
-exception Found
-
-let rec solve m =
- counter := !counter + 1;
- if m = 31 then
- begin match board.(4).(4) with Peg -> true | _ -> false end
- else
- try
- if !counter mod 500 = 0 then begin
- print_int !counter; print_newline()
- end;
- for i=1 to 7 do
- for j=1 to 7 do
- match board.(i).(j) with
- Peg ->
- for k=0 to 3 do
- let d1 = dir.(k).dx in
- let d2 = dir.(k).dy in
- let i1 = i+d1 in
- let i2 = i1+d1 in
- let j1 = j+d2 in
- let j2 = j1+d2 in
- match board.(i1).(j1) with
- Peg ->
- begin match board.(i2).(j2) with
- Empty ->
-(*
- print_int i; print_string ", ";
- print_int j; print_string ") dir ";
- print_int k; print_string "\n";
-*)
- board.(i).(j) <- Empty;
- board.(i1).(j1) <- Empty;
- board.(i2).(j2) <- Peg;
- if solve(m+1) then begin
- moves.(m) <- { x1=i; y1=j; x2=i2; y2=j2 };
- raise Found
- end;
- board.(i).(j) <- Peg;
- board.(i1).(j1) <- Peg;
- board.(i2).(j2) <- Empty
- | _ -> ()
- end
- | _ -> ()
- done
- | _ ->
- ()
- done
- done;
- false
- with Found ->
- true
-
-
-let _ = if solve 0 then (print_string "\n"; print_board board)
diff --git a/test/sorts.ml b/test/sorts.ml
deleted file mode 100644
index d9b9d00899..0000000000
--- a/test/sorts.ml
+++ /dev/null
@@ -1,4477 +0,0 @@
-(* Test bench for sorting algorithms. *)
-
-
-(*
- ocamlopt -noassert sorts.ml -cclib -lunix
-*)
-
-open Printf;;
-
-(*
- Criteres:
- 0. overhead en pile: doit etre logn au maximum.
- 1. stable ou non.
- 2. overhead en espace.
- 3. vitesse.
-*)
-
-(************************************************************************)
-(* auxiliary functions *)
-
-let rec exp2 n = if n <= 0 then 1 else 2 * exp2 (n-1);;
-let id x = x;;
-let postl x y = Array.of_list y;;
-let posta x y = x;;
-
-let mkconst n = Array.make n 0;;
-let chkconst _ n a = (a = mkconst n);;
-
-let mksorted n =
- let a = Array.make n 0 in
- for i = 0 to n - 1 do
- a.(i) <- i;
- done;
- a
-;;
-let chksorted _ n a = (a = mksorted n);;
-
-let mkrev n =
- let a = Array.make n 0 in
- for i = 0 to n - 1 do
- a.(i) <- n - 1 - i;
- done;
- a
-;;
-let chkrev _ n a = (a = mksorted n);;
-
-let seed = ref 0;;
-let random_reinit () = Random.init !seed;;
-
-let random_get_state () =
- let a = Array.make 55 0 in
- for i = 0 to 54 do a.(i) <- Random.bits (); done;
- Random.full_init a;
- a
-;;
-let random_set_state a = Random.full_init a;;
-
-let chkgen mke cmp rstate n a =
- let marks = Array.make n (-1) in
- let skipmarks l =
- if marks.(l) = -1 then l else begin
- let m = ref marks.(l) in
- while marks.(!m) <> -1 do incr m; done;
- marks.(l) <- !m;
- !m
- end
- in
- let linear e l =
- let l = skipmarks l in
- let rec loop l =
- if cmp a.(l) e > 0 then raise Exit
- else if e = a.(l) then marks.(l) <- l+1
- else loop (l+1)
- in loop l
- in
- let rec dicho e l r =
- if l = r then linear e l
- else begin
- assert (l < r);
- let m = (l + r) / 2 in
- if cmp a.(m) e >= 0 then dicho e l m else dicho e (m + 1) r
- end
- in
- try
- for i = 0 to n-2 do if cmp a.(i) a.(i+1) > 0 then raise Exit; done;
- random_set_state rstate;
- for i = 0 to n-1 do dicho (mke i) 0 (Array.length a - 1); done;
- true
- with Exit | Invalid_argument _ -> false;
-;;
-
-let mkrand_dup n =
- let a = Array.make n 0 in
- for i = 0 to (n-1) do a.(i) <- Random.int n; done;
- a
-;;
-
-let chkrand_dup rstate n a =
- chkgen (fun i -> Random.int n) compare rstate n a
-;;
-
-let mkrand_nodup n =
- let a = Array.make n 0 in
- for i = 0 to (n-1) do a.(i) <- Random.bits (); done;
- a
-;;
-
-let chkrand_nodup rstate n a =
- chkgen (fun i -> Random.bits ()) compare rstate n a
-;;
-
-let mkfloats n =
- let a = Array.make n 0.0 in
- for i = 0 to (n-1) do a.(i) <- Random.float 1.0; done;
- a
-;;
-
-let chkfloats rstate n a =
- chkgen (fun i -> Random.float 1.0) compare rstate n a
-;;
-
-type record = {
- s1 : string;
- s2 : string;
- i1 : int;
- i2 : int;
-};;
-
-let rand_string () =
- let len = Random.int 10 in
- let s = String.create len in
- for i = 0 to len-1 do
- s.[i] <- Char.chr (Random.int 256);
- done;
- s
-;;
-
-let mkrec1 b i = {
- s1 = rand_string ();
- s2 = rand_string ();
- i1 = Random.int b;
- i2 = i;
-};;
-
-let mkrecs b n = Array.init n (mkrec1 b);;
-
-let mkrec1_rev b i = {
- s1 = rand_string ();
- s2 = rand_string ();
- i1 = - i;
- i2 = i;
-};;
-
-let mkrecs_rev n = Array.init n (mkrec1_rev 0);;
-
-let cmpstr r1 r2 =
- let c1 = compare r1.s1 r2.s1 in
- if c1 = 0 then compare r1.s2 r2.s2 else c1
-;;
-let lestr r1 r2 =
- let c1 = compare r1.s1 r2.s1 in
- if c1 = 0 then r1.s2 <= r2.s2 else (c1 < 0)
-;;
-let chkstr b rstate n a = chkgen (mkrec1 b) cmpstr rstate n a;;
-
-let cmpint r1 r2 = compare r1.i1 r2.i1;;
-let leint r1 r2 = r1.i1 <= r2.i1;;
-let chkint b rstate n a = chkgen (mkrec1 b) cmpint rstate n a;;
-
-let cmplex r1 r2 =
- let c1 = compare r1.i1 r2.i1 in
- if c1 = 0 then compare r1.i2 r2.i2 else c1
-;;
-let lelex r1 r2 =
- let c1 = compare r1.i1 r2.i1 in
- if c1 = 0 then r1.i2 <= r2.i2 else (c1 < 0)
-;;
-let chklex b rstate n a = chkgen (mkrec1 b) cmplex rstate n a;;
-
-(************************************************************************)
-
-let lens = [
- 0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 28;
- 100; 127; 128; 129; 191; 192; 193; 506;
- 1000; 1023; 1024; 1025; 1535; 1536; 1537; 2323;
- 4000; 4094; 4096; 4098; 5123;
-];;
-
-type ('a, 'b, 'c, 'd) aux = {
- prepf : ('a -> 'a -> int) -> ('a -> 'a -> bool) -> 'b;
- prepd : 'a array -> 'c;
- postd : 'a array -> 'd -> 'a array;
-};;
-
-let ll = { prepf = (fun x y -> y); prepd = Array.to_list; postd = postl };;
-let lc = { prepf = (fun x y -> x); prepd = Array.to_list; postd = postl };;
-let al = { prepf = (fun x y -> y); prepd = id; postd = posta };;
-let ac = { prepf = (fun x y -> x); prepd = id; postd = posta };;
-
-type 'a outcome = Value of 'a | Exception of exn;;
-
-let numfailed = ref 0;;
-
-let test1 name f prepdata postdata cmp desc mk chk =
- random_reinit ();
- printf " %s with %s" name desc;
- let i = ref 0 in
- List.iter (fun n ->
- if !i = 0 then printf "\n "; incr i; if !i > 11 then i := 0;
- printf "%5d" n; flush stdout;
- let rstate = random_get_state () in
- let a = mk n in
- let input = prepdata a in
- let output = try Value (f cmp input) with e -> Exception e in
- printf "."; flush stdout;
- begin match output with
- | Value v ->
- if not (chk rstate n (postdata a v))
- then (incr numfailed; printf "\n*** FAIL\n")
- | Exception e ->
- incr numfailed; printf "\n*** %s\n" (Printexc.to_string e)
- end;
- flush stdout;
- ) lens;
- printf "\n";
-;;
-
-let test name stable f1 f2 aux1 aux2 =
- printf "Testing %s...\n" name;
- let t a b c d = test1 name f1 aux1.prepd aux1.postd a b c d in
- let cmp = aux1.prepf compare (<=) in
- t cmp "constant ints" mkconst chkconst;
- t cmp "sorted ints" mksorted chksorted;
- t cmp "reverse-sorted ints" mkrev chkrev;
- t cmp "random ints (many dups)" mkrand_dup chkrand_dup;
- t cmp "random ints (few dups)" mkrand_nodup chkrand_nodup;
-(*
- let t a b c d = test1 name f3 aux3.prepd aux3.postd a b c d in
- t cmp "random floats" mkfloats chkfloats;
-*)
- let t a b c d = test1 name f2 aux2.prepd aux2.postd a b c d in
- let cmp = aux2.prepf cmpstr lestr in
- t cmp "records (str)" (mkrecs 1) (chkstr 1);
- let cmp = aux2.prepf cmpint leint in
- List.iter (fun m -> t cmp (sprintf "records (int[%d])" m) (mkrecs m)
- (chkint m)
- ) [1; 10; 100; 1000];
- if stable then
- List.iter (fun m -> t cmp (sprintf "records (int[%d]) [stable]" m)
- (mkrecs m) (chklex m)
- ) [1; 10; 100; 1000];
-;;
-
-(************************************************************************)
-
-(* Warning: rpt_timer cannot be used for the array sorts because
- the sorting functions have effects.
-*)
-
-let rpt_timer1 repeat f x =
- Gc.compact ();
- ignore (f x);
- let st = Sys.time () in
- for i = 1 to repeat do ignore (f x); done;
- let en = Sys.time () in
- en -. st
-;;
-
-let rpt_timer f x =
- let repeat = ref 1 in
- let t = ref (rpt_timer1 !repeat f x) in
- while !t < 0.2 do
- repeat := 10 * !repeat;
- t := rpt_timer1 !repeat f x;
- done;
- if !t < 2.0 then begin
- repeat := (int_of_float (10. *. (float !repeat) /. !t) + 1);
- t := rpt_timer1 !repeat f x;
- end;
- !t /. (float !repeat)
-;;
-
-let timer f x =
- let st = Sys.time () in
- ignore (f x);
- let en = Sys.time () in
- (en -. st)
-;;
-
-let table1 limit f mkarg =
- printf " %10s %9s %9s %9s %9s %9s\n" "n" "t1" "t2" "t3" "t4" "t5";
- let sz = ref 49151 in
- while !sz < int_of_float (2. ** float limit) do
- begin try
- printf " %10d " !sz; flush stdout;
- for i = 0 to 4 do
- let arg = mkarg !sz in
- let t = timer f arg in
- printf " %.2e " t; flush stdout;
- done;
- printf "\n";
- with e -> printf "*** %s\n" (Printexc.to_string e);
- end;
- flush stdout;
- sz := 2 * !sz + 1;
- done;
-;;
-
-let table2 limit f mkarg =
- printf " %10s %9s %9s %9s %9s %9s\n"
- " n" "t" "t/n" "t/nlogn" "t/nlog^2n" "t/n^2";
- let sz = ref 49151 in
- while float !sz < 2. ** float limit do
- begin try
- printf " %10d " !sz; flush stdout;
- Gc.compact ();
- let arg = mkarg !sz in
- let t = timer f arg in
- let n = float !sz in
- let logn = log (float !sz) /. log 2. in
- printf "%.2e %.2e %.2e %.2e %.2e\n"
- t (t/.n) (t/.n/.logn) (t/.n/.logn/.logn) (t/.n/.n);
- with e -> printf "*** %s\n" (Printexc.to_string e);
- end;
- flush stdout;
- sz := 2 * !sz + 1;
- done;
-;;
-
-let table3 limit f mkarg =
- printf " %10s %9s %9s %9s %9s %9s\n" "n" "t1" "t2" "t3" "t4" "t5";
- let sz = ref 2 in
- while float !sz < 2. ** float limit do
- begin try
- printf " %10d " !sz; flush stdout;
- for i = 0 to 4 do
- let arg = mkarg !sz in
- let t = rpt_timer f arg in
- printf " %.2e " t; flush stdout;
- done;
- printf "\n";
- with e -> printf "*** %s\n" (Printexc.to_string e);
- end;
- flush stdout;
- sz := 2 * !sz + 1;
- done;
-;;
-
-(************************************************************************)
-
-(* benchmarks:
- 1a. random records, sorted with two keys
- 1b. random integers
- 1c. random floats
-
- 2a. integers, constant
- 2b. integers, already sorted
- 2c. integers, reverse sorted
-
- only for short lists:
- 3a. random records, sorted with two keys
- 3b. random integers
- 3c. random floats
-*)
-let bench1a limit name f aux =
-
- (* Don't do benchmarks with assertions enabled. *)
- assert (not true);
-
- random_reinit ();
-
- printf "\n%s with random records [10]:\n" name;
- let cmp = aux.prepf cmplex lelex in
- table1 limit (f cmp) (fun n -> aux.prepd (mkrecs 10 n));
-;;
-
-let bench1b limit name f aux =
-
- (* Don't do benchmarks with assertions enabled. *)
- assert (not true);
-
- random_reinit ();
-
- printf "\n%s with random integers:\n" name;
- let cmp = aux.prepf (-) (<=) in
- table1 limit (f cmp) (fun n -> aux.prepd (mkrand_nodup n));
-;;
-
-let bench1c limit name f aux =
-
- (* Don't do benchmarks with assertions enabled. *)
- assert (not true);
-
- random_reinit ();
-
- printf "\n%s with random floats:\n" name;
- let cmp = aux.prepf compare (<=) in
- table1 limit (f cmp) (fun n -> aux.prepd (mkfloats n));
-;;
-
-let bench2 limit name f aux =
-
- (* Don't do benchmarks with assertions enabled. *)
- assert (not true);
-
- printf "\n%s with constant integers:\n" name;
- let cmp = aux.prepf compare (<=) in
- table2 limit (f cmp) (fun n -> aux.prepd (mkconst n));
-
- printf "\n%s with sorted integers:\n" name;
- let cmp = aux.prepf compare (<=) in
- table2 limit (f cmp) (fun n -> aux.prepd (mksorted n));
-
- printf "\n%s with reverse-sorted integers:\n" name;
- let cmp = aux.prepf compare (<=) in
- table2 limit (f cmp) (fun n -> aux.prepd (mkrev n));
-;;
-
-let bench3a limit name f aux =
-
- (* Don't do benchmarks with assertions enabled. *)
- assert (not true);
-
- random_reinit ();
-
- printf "\n%s with random records [10]:\n" name;
- let cmp = aux.prepf cmplex lelex in
- table3 limit (f cmp) (fun n -> aux.prepd (mkrecs 10 n));
-;;
-
-let bench3b limit name f aux =
-
- (* Don't do benchmarks with assertions enabled. *)
- assert (not true);
-
- random_reinit ();
-
- printf "\n%s with random integers:\n" name;
- let cmp = aux.prepf (-) (<=) in
- table3 limit (f cmp) (fun n -> aux.prepd (mkrand_nodup n));
-;;
-
-let bench3c limit name f aux =
-
- (* Don't do benchmarks with assertions enabled. *)
- assert (not true);
-
- random_reinit ();
-
- printf "\n%s with random floats:\n" name;
- let cmp = aux.prepf compare (<=) in
- table3 limit (f cmp) (fun n -> aux.prepd (mkfloats n));
-;;
-
-(************************************************************************)
-(* merge sort on lists *)
-
-(* FIXME to do: cutoff
- to do: cascader les pattern-matchings (enlever les paires)
- to do: fermeture intermediaire pour merge
-*)
-let (@@) = List.rev_append;;
-
-let lmerge_1a cmp l =
- let rec init accu = function
- | [] -> accu
- | e::rest -> init ([e] :: accu) rest
- in
- let rec merge rest accu2 accu l1 l2 = (* l1,l2,rest are forward;
- accu,accu2 are rev *)
- match l1, l2 with
- | [] , _ -> mergepairs ((l2 @@ accu)::accu2) rest
- | _ , [] -> mergepairs ((l1 @@ accu)::accu2) rest
- | h1::t1, h2::t2 -> if cmp h1 h2 <= 0
- then merge rest accu2 (h1::accu) t1 l2
- else merge rest accu2 (h2::accu) l1 t2
- and merge_rev rest accu2 accu l1 l2 = (* accu, accu2 are forward;
- l1,l2,rest are rev *)
- match l1, l2 with
- | [] , _ -> mergepairs_rev ((l2 @@ accu)::accu2) rest
- | _ , [] -> mergepairs_rev ((l1 @@ accu)::accu2) rest
- | h1::t1, h2::t2 -> if cmp h2 h1 <= 0
- then merge_rev rest accu2 (h1::accu) t1 l2
- else merge_rev rest accu2 (h2::accu) l1 t2
- and mergepairs accu = function (* accu is rev, arg is forward *)
- | [] -> mergeall_rev accu
- | [l] -> mergeall_rev ((List.rev l)::accu)
- | l1::l2::rest -> merge rest accu [] l1 l2
- and mergepairs_rev accu = function (* accu is forward, arg is rev *)
- | [] -> mergeall accu
- | [l] -> mergeall ((List.rev l)::accu)
- | l1::l2::rest -> merge_rev rest accu [] l1 l2
- and mergeall = function (* arg is forward *)
- | [] -> []
- | [l] -> l
- | llist -> mergepairs [] llist
- and mergeall_rev = function (* arg is rev *)
- | [] -> []
- | [l] -> List.rev l
- | llist -> mergepairs_rev [] llist
- in
- mergeall_rev (init [] l)
-;;
-
-let lmerge_1b cmp l =
- let rec init accu = function
- | [] -> accu
- | [e] -> [e] :: accu
- | e1::e2::rest ->
- init ((if cmp e1 e2 <= 0 then [e2;e1] else [e1;e2])::accu) rest
- in
- let rec merge rest accu2 accu l1 l2 = (* l1,l2,rest are forward;
- accu,accu2 are rev *)
- match l1, l2 with
- | [] , _ -> mergepairs ((l2 @@ accu)::accu2) rest
- | _ , [] -> mergepairs ((l1 @@ accu)::accu2) rest
- | h1::t1, h2::t2 -> if cmp h1 h2 <= 0
- then merge rest accu2 (h1::accu) t1 l2
- else merge rest accu2 (h2::accu) l1 t2
- and merge_rev rest accu2 accu l1 l2 = (* accu, accu2 are forward;
- l1,l2,rest are rev *)
- match l1, l2 with
- | [] , _ -> mergepairs_rev ((l2 @@ accu)::accu2) rest
- | _ , [] -> mergepairs_rev ((l1 @@ accu)::accu2) rest
- | h1::t1, h2::t2 -> if cmp h2 h1 <= 0
- then merge_rev rest accu2 (h1::accu) t1 l2
- else merge_rev rest accu2 (h2::accu) l1 t2
- and mergepairs accu = function (* accu is rev, arg is forward *)
- | [] -> mergeall_rev accu
- | [l] -> mergeall_rev ((List.rev l)::accu)
- | l1::l2::rest -> merge rest accu [] l1 l2
- and mergepairs_rev accu = function (* accu is forward, arg is rev *)
- | [] -> mergeall accu
- | [l] -> mergeall ((List.rev l)::accu)
- | l1::l2::rest -> merge_rev rest accu [] l1 l2
- and mergeall = function (* arg is forward *)
- | [] -> []
- | [l] -> l
- | llist -> mergepairs [] llist
- and mergeall_rev = function (* arg is rev *)
- | [] -> []
- | [l] -> List.rev l
- | llist -> mergepairs_rev [] llist
- in
- mergeall_rev (init [] l)
-;;
-
-let lmerge_1c cmp l =
- let rec init accu = function
- | [] -> accu
- | [e] -> [e] :: accu
- | e1::e2::rest ->
- init ((if cmp e1 e2 <= 0 then [e2;e1] else [e1;e2])::accu) rest
- in
- let rec merge rest accu2 accu l1 l2 = (* l1,l2,rest are forward;
- accu,accu2 are rev *)
- match l1 with
- | [] -> mergepairs ((l2 @@ accu)::accu2) rest
- | h1::t1 ->
- match l2 with
- | [] -> mergepairs ((l1 @@ accu)::accu2) rest
- | h2::t2 -> if cmp h1 h2 <= 0
- then merge rest accu2 (h1::accu) t1 l2
- else merge rest accu2 (h2::accu) l1 t2
- and merge_rev rest accu2 accu l1 l2 = (* accu, accu2 are forward;
- l1,l2,rest are rev *)
- match l1 with
- | [] -> mergepairs_rev ((l2 @@ accu)::accu2) rest
- | h1::t1 ->
- match l2 with
- | [] -> mergepairs_rev ((l1 @@ accu)::accu2) rest
- | h2::t2 -> if cmp h2 h1 <= 0
- then merge_rev rest accu2 (h1::accu) t1 l2
- else merge_rev rest accu2 (h2::accu) l1 t2
- and mergepairs accu = function (* accu is rev, arg is forward *)
- | [] -> mergeall_rev accu
- | [l] -> mergeall_rev ((List.rev l)::accu)
- | l1::l2::rest -> merge rest accu [] l1 l2
- and mergepairs_rev accu = function (* accu is forward, arg is rev *)
- | [] -> mergeall accu
- | [l] -> mergeall ((List.rev l)::accu)
- | l1::l2::rest -> merge_rev rest accu [] l1 l2
- and mergeall = function (* arg is forward *)
- | [] -> []
- | [l] -> l
- | llist -> mergepairs [] llist
- and mergeall_rev = function (* arg is rev *)
- | [] -> []
- | [l] -> List.rev l
- | llist -> mergepairs_rev [] llist
- in
- mergeall_rev (init [] l)
-;;
-
-let lmerge_1d cmp l =
- let rec init accu = function
- | [] -> accu
- | [e] -> [e] :: accu
- | e1::e2::rest ->
- init ((if cmp e1 e2 <= 0 then [e2;e1] else [e1;e2])::accu) rest
- in
- let rec merge rest accu2 accu l1 l2 = (* l1,l2,rest are forward;
- accu,accu2 are rev *)
- let merge_rest_accu2 accu l1 l2 =
- match l1 with
- | [] -> mergepairs ((l2 @@ accu)::accu2) rest
- | h1::t1 ->
- match l2 with
- | [] -> mergepairs ((l1 @@ accu)::accu2) rest
- | h2::t2 -> if cmp h1 h2 <= 0
- then merge rest accu2 (h1::accu) t1 l2
- else merge rest accu2 (h2::accu) l1 t2
- in merge_rest_accu2 accu l1 l2
- and merge_rev rest accu2 accu l1 l2 = (* accu, accu2 are forward;
- l1,l2,rest are rev *)
- let merge_rev_rest_accu2 accu l1 l2 =
- match l1 with
- | [] -> mergepairs_rev ((l2 @@ accu)::accu2) rest
- | h1::t1 ->
- match l2 with
- | [] -> mergepairs_rev ((l1 @@ accu)::accu2) rest
- | h2::t2 -> if cmp h2 h1 <= 0
- then merge_rev rest accu2 (h1::accu) t1 l2
- else merge_rev rest accu2 (h2::accu) l1 t2
- in merge_rev_rest_accu2 accu l1 l2
- and mergepairs accu = function (* accu is rev, arg is forward *)
- | [] -> mergeall_rev accu
- | [l] -> mergeall_rev ((List.rev l)::accu)
- | l1::l2::rest -> merge rest accu [] l1 l2
- and mergepairs_rev accu = function (* accu is forward, arg is rev *)
- | [] -> mergeall accu
- | [l] -> mergeall ((List.rev l)::accu)
- | l1::l2::rest -> merge_rev rest accu [] l1 l2
- and mergeall = function (* arg is forward *)
- | [] -> []
- | [l] -> l
- | llist -> mergepairs [] llist
- and mergeall_rev = function (* arg is rev *)
- | [] -> []
- | [l] -> List.rev l
- | llist -> mergepairs_rev [] llist
- in
- mergeall_rev (init [] l)
-;;
-
-(************************************************************************)
-(* merge sort on lists, user-contributed (NOT STABLE) *)
-
-(* BEGIN code contributed by Yann Coscoy *)
-
- let rec rev_merge_append order l1 l2 acc =
- match l1 with
- [] -> List.rev_append l2 acc
- | h1 :: t1 ->
- match l2 with
- [] -> List.rev_append l1 acc
- | h2 :: t2 ->
- if order h1 h2
- then rev_merge_append order t1 l2 (h1::acc)
- else rev_merge_append order l1 t2 (h2::acc)
-
- let rev_merge order l1 l2 = rev_merge_append order l1 l2 []
-
- let rec rev_merge_append' order l1 l2 acc =
- match l1 with
- | [] -> List.rev_append l2 acc
- | h1 :: t1 ->
- match l2 with
- | [] -> List.rev_append l1 acc
- | h2 :: t2 ->
- if order h2 h1
- then rev_merge_append' order t1 l2 (h1::acc)
- else rev_merge_append' order l1 t2 (h2::acc)
-
- let rev_merge' order l1 l2 = rev_merge_append' order l1 l2 []
-
- let lmerge_3 order l =
- let rec initlist l acc = match l with
- | e1::e2::rest ->
- initlist rest
- ((if order e1 e2 then [e1;e2] else [e2;e1])::acc)
- | [e] -> [e]::acc
- | [] -> acc
- in
- let rec merge2 ll acc = match ll with
- | [] -> acc
- | [l] -> [List.rev l]@acc
- | l1::l2::rest ->
- merge2 rest (rev_merge order l1 l2::acc)
- in
- let rec merge2' ll acc = match ll with
- | [] -> acc
- | [l] -> [List.rev l]@acc
- | l1::l2::rest ->
- merge2' rest (rev_merge' order l1 l2::acc)
- in
- let rec mergeall rev = function
- | [] -> []
- | [l] -> if rev then List.rev l else l
- | llist ->
- mergeall
- (not rev) ((if rev then merge2' else merge2) llist [])
- in
- mergeall false (initlist l [])
-
-(* END code contributed by Yann Coscoy *)
-
-(************************************************************************)
-(* merge sort on short lists, Francois Pottier *)
-
-(* BEGIN code contributed by Francois Pottier *)
-
- (* [chop k l] returns the list [l] deprived of its [k] first
- elements. The length of the list [l] must be [k] at least. *)
-
- let rec chop k l =
- match k, l with
- | 0, _ -> l
- | _, x :: l -> chop (k-1) l
- | _, _ -> assert false
- ;;
-
- let rec merge order l1 l2 =
- match l1 with
- [] -> l2
- | h1 :: t1 ->
- match l2 with
- [] -> l1
- | h2 :: t2 ->
- if order h1 h2
- then h1 :: merge order t1 l2
- else h2 :: merge order l1 t2
- ;;
-
- let rec lmerge_4a order l =
- match l with
- | []
- | [ _ ] -> l
- | _ ->
- let rec sort k l = (* k > 1 *)
- match k, l with
- | 2, x1 :: x2 :: _ ->
- if order x1 x2 then [ x1; x2 ] else [ x2; x1 ]
- | 3, x1 :: x2 :: x3 :: _ ->
- if order x1 x2 then
- if order x2 x3 then
- [ x1 ; x2 ; x3 ]
- else
- if order x1 x3 then [ x1 ; x3 ; x2 ] else [ x3; x1; x2 ]
- else
- if order x1 x3 then
- [ x2; x1; x3 ]
- else
- if order x2 x3 then [ x2; x3; x1 ] else [ x3; x2; x1 ]
- | _, _ ->
- let k1 = k / 2 in
- let k2 = k - k1 in
- merge order (sort k1 l) (sort k2 (chop k1 l))
- in
- sort (List.length l) l
- ;;
-(* END code contributed by Francois Pottier *)
-
-(************************************************************************)
-(* merge sort on short lists, Francois Pottier,
- adapted to new-style interface *)
-
-(* BEGIN code contributed by Francois Pottier *)
-
- (* [chop k l] returns the list [l] deprived of its [k] first
- elements. The length of the list [l] must be [k] at least. *)
-
- let rec chop k l =
- match k, l with
- | 0, _ -> l
- | _, x :: l -> chop (k-1) l
- | _, _ -> assert false
- ;;
-
- let rec merge order l1 l2 =
- match l1 with
- [] -> l2
- | h1 :: t1 ->
- match l2 with
- [] -> l1
- | h2 :: t2 ->
- if order h1 h2 <= 0
- then h1 :: merge order t1 l2
- else h2 :: merge order l1 t2
- ;;
-
- let rec lmerge_4b order l =
- match l with
- | []
- | [ _ ] -> l
- | _ ->
- let rec sort k l = (* k > 1 *)
- match k, l with
- | 2, x1 :: x2 :: _ ->
- if order x1 x2 <= 0 then [ x1; x2 ] else [ x2; x1 ]
- | 3, x1 :: x2 :: x3 :: _ ->
- if order x1 x2 <= 0 then
- if order x2 x3 <= 0 then
- [ x1 ; x2 ; x3 ]
- else
- if order x1 x3 <= 0 then [ x1 ; x3 ; x2 ] else [ x3; x1; x2 ]
- else
- if order x1 x3 <= 0 then
- [ x2; x1; x3 ]
- else
- if order x2 x3 <= 0 then [ x2; x3; x1 ] else [ x3; x2; x1 ]
- | _, _ ->
- let k1 = k / 2 in
- let k2 = k - k1 in
- merge order (sort k1 l) (sort k2 (chop k1 l))
- in
- sort (List.length l) l
- ;;
-(* END code contributed by Francois Pottier *)
-
-(************************************************************************)
-(* merge sort on short lists a la Pottier, modified merge *)
-
-let rec chop k l =
- if k = 0 then l else begin
- match l with
- | x::t -> chop (k-1) t
- | _ -> assert false
- end
-;;
-
-let lmerge_4c cmp l =
- let rec merge1 h1 t1 l2 =
- match l2 with
- | [] -> h1 :: t1
- | h2 :: t2 ->
- if cmp h1 h2 <= 0
- then h1 :: (merge2 t1 h2 t2)
- else h2 :: (merge1 h1 t1 t2)
- and merge2 l1 h2 t2 =
- match l1 with
- | [] -> h2 :: t2
- | h1 :: t1 ->
- if cmp h1 h2 <= 0
- then h1 :: (merge2 t1 h2 t2)
- else h2 :: (merge1 h1 t1 t2)
- in
- let merge l1 = function
- | [] -> l1
- | h2 :: t2 -> merge2 l1 h2 t2
- in
- let rec sort n l =
- match n, l with
- | 2, x1 :: x2 :: _ ->
- if cmp x1 x2 <= 0 then [x1; x2] else [x2; x1]
- | 3, x1 :: x2 :: x3 :: _ ->
- if cmp x1 x2 <= 0 then begin
- if cmp x2 x3 <= 0 then [x1; x2; x3]
- else if cmp x1 x3 <= 0 then [x1; x3; x2]
- else [x3; x1; x2]
- end else begin
- if cmp x1 x3 <= 0 then [x2; x1; x3]
- else if cmp x2 x3 <= 0 then [x2; x3; x1]
- else [x3; x2; x1]
- end
- | n, l ->
- let n1 = n asr 1 in
- let n2 = n - n1 in
- merge (sort n1 l) (sort n2 (chop n1 l))
- in
- let len = List.length l in
- if len < 2 then l else sort len l
-;;
-
-(************************************************************************)
-(* merge sort on short lists a la Pottier, logarithmic stack space *)
-
-let rec chop k l =
- if k = 0 then l else begin
- match l with
- | x::t -> chop (k-1) t
- | _ -> assert false
- end
-;;
-
-let lmerge_4d cmp l =
- let rec rev_merge l1 l2 accu =
- match l1, l2 with
- | [], l2 -> l2 @@ accu
- | l1, [] -> l1 @@ accu
- | h1::t1, h2::t2 ->
- if cmp h1 h2 <= 0
- then rev_merge t1 l2 (h1::accu)
- else rev_merge l1 t2 (h2::accu)
- in
- let rec rev_merge_rev l1 l2 accu =
- match l1, l2 with
- | [], l2 -> l2 @@ accu
- | l1, [] -> l1 @@ accu
- | h1::t1, h2::t2 ->
- if cmp h1 h2 > 0
- then rev_merge_rev t1 l2 (h1::accu)
- else rev_merge_rev l1 t2 (h2::accu)
- in
- let rec sort n l =
- match n, l with
- | 2, x1 :: x2 :: _ ->
- if cmp x1 x2 <= 0 then [x1; x2] else [x2; x1]
- | 3, x1 :: x2 :: x3 :: _ ->
- if cmp x1 x2 <= 0 then begin
- if cmp x2 x3 <= 0 then [x1; x2; x3]
- else if cmp x1 x3 <= 0 then [x1; x3; x2]
- else [x3; x1; x2]
- end else begin
- if cmp x1 x3 <= 0 then [x2; x1; x3]
- else if cmp x2 x3 <= 0 then [x2; x3; x1]
- else [x3; x2; x1]
- end
- | n, l ->
- let n1 = n asr 1 in
- let n2 = n - n1 in
- rev_merge_rev (rev_sort n1 l) (rev_sort n2 (chop n1 l)) []
- and rev_sort n l =
- match n, l with
- | 2, x1 :: x2 :: _ ->
- if cmp x1 x2 > 0 then [x1; x2] else [x2; x1]
- | 3, x1 :: x2 :: x3 :: _ ->
- if cmp x1 x2 > 0 then begin
- if cmp x2 x3 > 0 then [x1; x2; x3]
- else if cmp x1 x3 > 0 then [x1; x3; x2]
- else [x3; x1; x2]
- end else begin
- if cmp x1 x3 > 0 then [x2; x1; x3]
- else if cmp x2 x3 > 0 then [x2; x3; x1]
- else [x3; x2; x1]
- end
- | n, l ->
- let n1 = n asr 1 in
- let n2 = n - n1 in
- rev_merge (sort n1 l) (sort n2 (chop n1 l)) []
- in
- let len = List.length l in
- if len < 2 then l else sort len l
-;;
-
-
-(************************************************************************)
-(* merge sort on short lists a la Pottier, logarithmic stack space,
- in place: input list is freed as the output is being computed. *)
-
-let rec chop k l =
- if k = 0 then l else begin
- match l with
- | x::t -> chop (k-1) t
- | _ -> assert false
- end
-;;
-
-let lmerge_4e cmp l =
- let rec rev_merge l1 l2 accu =
- match l1, l2 with
- | [], l2 -> l2 @@ accu
- | l1, [] -> l1 @@ accu
- | h1::t1, h2::t2 ->
- if cmp h1 h2 <= 0
- then rev_merge t1 l2 (h1::accu)
- else rev_merge l1 t2 (h2::accu)
- in
- let rec rev_merge_rev l1 l2 accu =
- match l1, l2 with
- | [], l2 -> l2 @@ accu
- | l1, [] -> l1 @@ accu
- | h1::t1, h2::t2 ->
- if cmp h1 h2 > 0
- then rev_merge_rev t1 l2 (h1::accu)
- else rev_merge_rev l1 t2 (h2::accu)
- in
- let rec sort n l =
- match n, l with
- | 2, x1 :: x2 :: _ ->
- if cmp x1 x2 <= 0 then [x1; x2] else [x2; x1]
- | 3, x1 :: x2 :: x3 :: _ ->
- if cmp x1 x2 <= 0 then begin
- if cmp x2 x3 <= 0 then [x1; x2; x3]
- else if cmp x1 x3 <= 0 then [x1; x3; x2]
- else [x3; x1; x2]
- end else begin
- if cmp x1 x3 <= 0 then [x2; x1; x3]
- else if cmp x2 x3 <= 0 then [x2; x3; x1]
- else [x3; x2; x1]
- end
- | n, l ->
- let n1 = n asr 1 in
- let n2 = n - n1 in
- let l2 = chop n1 l in
- let s1 = rev_sort n1 l in
- let s2 = rev_sort n2 l2 in
- rev_merge_rev s1 s2 []
- and rev_sort n l =
- match n, l with
- | 2, x1 :: x2 :: _ ->
- if cmp x1 x2 > 0 then [x1; x2] else [x2; x1]
- | 3, x1 :: x2 :: x3 :: _ ->
- if cmp x1 x2 > 0 then begin
- if cmp x2 x3 > 0 then [x1; x2; x3]
- else if cmp x1 x3 > 0 then [x1; x3; x2]
- else [x3; x1; x2]
- end else begin
- if cmp x1 x3 > 0 then [x2; x1; x3]
- else if cmp x2 x3 > 0 then [x2; x3; x1]
- else [x3; x2; x1]
- end
- | n, l ->
- let n1 = n asr 1 in
- let n2 = n - n1 in
- let l2 = chop n1 l in
- let s1 = sort n1 l in
- let s2 = sort n2 l2 in
- rev_merge s1 s2 []
- in
- let len = List.length l in
- if len < 2 then l else sort len l
-;;
-
-(************************************************************************)
-(* chop-free version of Pottier's code, binary version *)
-
-let rec merge cmp l1 l2 =
- match l1, l2 with
- | [], l2 -> l2
- | l1, [] -> l1
- | h1 :: t1, h2 :: t2 ->
- if cmp h1 h2 <= 0
- then h1 :: merge cmp t1 l2
- else h2 :: merge cmp l1 t2
-;;
-
-let lmerge_5a cmp l =
- let rem = ref l in
- let rec sort_prefix n =
- if n <= 1 then begin
- match !rem with
- | [] -> []
- | [x] as l -> rem := []; l
- | x::y::t -> rem := t; if cmp x y <= 0 then [x;y] else [y;x]
- end else if !rem = [] then []
- else begin
- let l1 = sort_prefix (n-1) in
- let l2 = sort_prefix (n-1) in
- merge cmp l1 l2
- end
- in
- let len = ref (List.length l) in
- let i = ref 0 in
- while !len > 0 do incr i; len := !len lsr 1; done;
- sort_prefix !i
-;;
-
-(************************************************************************)
-(* chop-free version of Pottier's code, dichotomic version,
- ground cases 1 & 2 *)
-
-let rec merge cmp l1 l2 =
- match l1, l2 with
- | [], l2 -> l2
- | l1, [] -> l1
- | h1 :: t1, h2 :: t2 ->
- if cmp h1 h2 <= 0
- then h1 :: merge cmp t1 l2
- else h2 :: merge cmp l1 t2
-;;
-
-let lmerge_5b cmp l =
- let rem = ref l in
- let rec sort_prefix n =
- match n, !rem with
- | 1, x::t -> rem := t; [x]
- | 2, x::y::t -> rem := t; if cmp x y <= 0 then [x;y] else [y;x]
- | n, _ ->
- let n1 = n/2 in
- let n2 = n - n1 in
- let l1 = sort_prefix n1 in
- let l2 = sort_prefix n2 in
- merge cmp l1 l2
- in
- let len = List.length l in
- if len <= 1 then l else sort_prefix len
-;;
-
-(************************************************************************)
-(* chop-free version of Pottier's code, dichotomic version,
- ground cases 2 & 3 *)
-
-let rec merge cmp l1 l2 =
- match l1, l2 with
- | [], l2 -> l2
- | l1, [] -> l1
- | h1 :: t1, h2 :: t2 ->
- if cmp h1 h2 <= 0
- then h1 :: merge cmp t1 l2
- else h2 :: merge cmp l1 t2
-;;
-
-let lmerge_5c cmp l =
- let rem = ref l in
- let rec sort_prefix n =
- match n, !rem with
- | 2, x::y::t -> rem := t; if cmp x y <= 0 then [x;y] else [y;x]
- | 3, x::y::z::t ->
- rem := t;
- if cmp x y <= 0 then
- if cmp y z <= 0 then [x; y; z]
- else if cmp x z <= 0 then [x; z; y]
- else [z; x; y]
- else
- if cmp x z <= 0 then [y; x; z]
- else if cmp y z <= 0 then [y; z; x]
- else [z; y; x]
- | n, _ ->
- let n1 = n/2 in
- let n2 = n - n1 in
- let l1 = sort_prefix n1 in
- let l2 = sort_prefix n2 in
- merge cmp l1 l2
- in
- let len = List.length l in
- if len <= 1 then l else sort_prefix len
-;;
-
-(************************************************************************)
-(* chop-free, ref-free version of Pottier's code, dichotomic version,
- ground cases 2 & 3, modified merge *)
-
-let lmerge_5d cmp l =
- let rec merge1 h1 t1 l2 =
- match l2 with
- | [] -> h1::t1
- | h2 :: t2 ->
- if cmp h1 h2 <= 0
- then h1 :: merge2 t1 h2 t2
- else h2 :: merge1 h1 t1 t2
- and merge2 l1 h2 t2 =
- match l1 with
- | [] -> h2::t2
- | h1 :: t1 ->
- if cmp h1 h2 <= 0
- then h1 :: merge2 t1 h2 t2
- else h2 :: merge1 h1 t1 t2
- in
- let rec sort_prefix n l =
- match n, l with
- | 2, x::y::t -> ((if cmp x y <= 0 then [x;y] else [y;x]), t)
- | 3, x::y::z::t ->
- ((if cmp x y <= 0 then
- if cmp y z <= 0 then [x; y; z]
- else if cmp x z <= 0 then [x; z; y]
- else [z; x; y]
- else
- if cmp x z <= 0 then [y; x; z]
- else if cmp y z <= 0 then [y; z; x]
- else [z; y; x]),
- t)
- | n, _ ->
- let n1 = n/2 in
- let n2 = n - n1 in
- let (l1, rest1) = sort_prefix n1 l in
- match sort_prefix n2 rest1 with
- | (h2::t2, rest2) -> ((merge2 l1 h2 t2), rest2)
- | _ -> assert false
- in
- let len = List.length l in
- if len <= 1 then l else fst (sort_prefix len l)
-;;
-
-(************************************************************************)
-(* merge sort on arrays, merge with tail-rec function *)
-
-let amerge_1a cmp a =
- let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
- let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
- let rec loop i1 s1 i2 s2 d =
- if cmp s1 s2 <= 0 then begin
- dst.(d) <- s1;
- let i1 = i1 + 1 in
- if i1 < src1r then
- loop i1 a.(i1) i2 s2 (d + 1)
- else
- Array.blit src2 i2 dst (d + 1) (src2r - i2)
- end else begin
- dst.(d) <- s2;
- let i2 = i2 + 1 in
- if i2 < src2r then
- loop i1 s1 i2 src2.(i2) (d + 1)
- else
- Array.blit a i1 dst (d + 1) (src1r - i1)
- end
- in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
- in
- let rec sortto srcofs dst dstofs len =
- assert (len > 0);
- if len = 1 then dst.(dstofs) <- a.(srcofs)
- else begin
- let l1 = len / 2 in
- let l2 = len - l1 in
- sortto (srcofs + l1) dst (dstofs + l1) l2;
- sortto srcofs a (srcofs + l2) l1;
- merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
- end;
- in
- let l = Array.length a in
- if l <= 1 then ()
- else begin
- let l1 = l / 2 in
- let l2 = l - l1 in
- let t = Array.make l2 a.(0) in
- sortto l1 t 0 l2;
- sortto 0 a l2 l1;
- merge l2 l1 t 0 l2 a 0;
- end;
-;;
-
-let amerge_1b cmp a =
- let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
- let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
- let rec loop i1 s1 i2 s2 d =
- if cmp s1 s2 <= 0 then begin
- dst.(d) <- s1;
- let i1 = i1 + 1 in
- if i1 < src1r then
- loop i1 a.(i1) i2 s2 (d + 1)
- else
- Array.blit src2 i2 dst (d + 1) (src2r - i2)
- end else begin
- dst.(d) <- s2;
- let i2 = i2 + 1 in
- if i2 < src2r then
- loop i1 s1 i2 src2.(i2) (d + 1)
- else
- Array.blit a i1 dst (d + 1) (src1r - i1)
- end
- in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
- in
- let rec sortto srcofs dst dstofs len =
- assert (len > 0);
- if len = 1 then dst.(dstofs) <- a.(srcofs)
- else if len = 2 then begin
- if cmp a.(srcofs) a.(srcofs+1) <= 0 then begin
- dst.(dstofs) <- a.(srcofs);
- dst.(dstofs+1) <- a.(srcofs+1);
- end else begin
- dst.(dstofs) <- a.(srcofs+1);
- dst.(dstofs+1) <- a.(srcofs);
- end;
- end else begin
- let l1 = len / 2 in
- let l2 = len - l1 in
- sortto (srcofs + l1) dst (dstofs + l1) l2;
- sortto srcofs a (srcofs + l2) l1;
- merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
- end;
- in
- let l = Array.length a in
- if l <= 1 then ()
- else if l = 2 then begin
- if cmp a.(0) a.(1) > 0 then begin
- let e = a.(0) in
- a.(0) <- a.(1);
- a.(1) <- e;
- end;
- end else begin
- let l1 = l / 2 in
- let l2 = l - l1 in
- let t = Array.make l2 a.(0) in
- sortto l1 t 0 l2;
- sortto 0 a l2 l1;
- merge l2 l1 t 0 l2 a 0;
- end;
-;;
-
-let cutoff = 3;;
-let amerge_1c cmp a =
- let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
- let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
- let rec loop i1 s1 i2 s2 d =
- if cmp s1 s2 <= 0 then begin
- dst.(d) <- s1;
- let i1 = i1 + 1 in
- if i1 < src1r then
- loop i1 a.(i1) i2 s2 (d + 1)
- else
- Array.blit src2 i2 dst (d + 1) (src2r - i2)
- end else begin
- dst.(d) <- s2;
- let i2 = i2 + 1 in
- if i2 < src2r then
- loop i1 s1 i2 src2.(i2) (d + 1)
- else
- Array.blit a i1 dst (d + 1) (src1r - i1)
- end
- in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
- in
- let isortto srcofs dst dstofs len =
- for i = 0 to len - 1 do
- let e = a.(srcofs + i) in
- let j = ref (dstofs + i - 1) in
- while (!j >= dstofs && cmp dst.(!j) e > 0) do
- dst.(!j + 1) <- dst.(!j);
- decr j;
- done;
- dst.(!j + 1) <- e;
- done;
- in
- let rec sortto srcofs dst dstofs len =
- if len <= cutoff then isortto srcofs dst dstofs len else begin
- let l1 = len / 2 in
- let l2 = len - l1 in
- sortto (srcofs + l1) dst (dstofs + l1) l2;
- sortto srcofs a (srcofs + l2) l1;
- merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
- end;
- in
- let l = Array.length a in
- if l <= cutoff then isortto 0 a 0 l else begin
- let l1 = l / 2 in
- let l2 = l - l1 in
- let t = Array.make l2 a.(0) in
- sortto l1 t 0 l2;
- sortto 0 a l2 l1;
- merge l2 l1 t 0 l2 a 0;
- end;
-;;
-
-let cutoff = 4;;
-let amerge_1d cmp a =
- let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
- let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
- let rec loop i1 s1 i2 s2 d =
- if cmp s1 s2 <= 0 then begin
- dst.(d) <- s1;
- let i1 = i1 + 1 in
- if i1 < src1r then
- loop i1 a.(i1) i2 s2 (d + 1)
- else
- Array.blit src2 i2 dst (d + 1) (src2r - i2)
- end else begin
- dst.(d) <- s2;
- let i2 = i2 + 1 in
- if i2 < src2r then
- loop i1 s1 i2 src2.(i2) (d + 1)
- else
- Array.blit a i1 dst (d + 1) (src1r - i1)
- end
- in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
- in
- let isortto srcofs dst dstofs len =
- for i = 0 to len - 1 do
- let e = a.(srcofs + i) in
- let j = ref (dstofs + i - 1) in
- while (!j >= dstofs && cmp dst.(!j) e > 0) do
- dst.(!j + 1) <- dst.(!j);
- decr j;
- done;
- dst.(!j + 1) <- e;
- done;
- in
- let rec sortto srcofs dst dstofs len =
- if len <= cutoff then isortto srcofs dst dstofs len else begin
- let l1 = len / 2 in
- let l2 = len - l1 in
- sortto (srcofs + l1) dst (dstofs + l1) l2;
- sortto srcofs a (srcofs + l2) l1;
- merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
- end;
- in
- let l = Array.length a in
- if l <= cutoff then isortto 0 a 0 l else begin
- let l1 = l / 2 in
- let l2 = l - l1 in
- let t = Array.make l2 a.(0) in
- sortto l1 t 0 l2;
- sortto 0 a l2 l1;
- merge l2 l1 t 0 l2 a 0;
- end;
-;;
-
-let cutoff = 5;;
-let amerge_1e cmp a =
- let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
- let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
- let rec loop i1 s1 i2 s2 d =
- if cmp s1 s2 <= 0 then begin
- dst.(d) <- s1;
- let i1 = i1 + 1 in
- if i1 < src1r then
- loop i1 a.(i1) i2 s2 (d + 1)
- else
- Array.blit src2 i2 dst (d + 1) (src2r - i2)
- end else begin
- dst.(d) <- s2;
- let i2 = i2 + 1 in
- if i2 < src2r then
- loop i1 s1 i2 src2.(i2) (d + 1)
- else
- Array.blit a i1 dst (d + 1) (src1r - i1)
- end
- in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
- in
- let isortto srcofs dst dstofs len =
- for i = 0 to len - 1 do
- let e = a.(srcofs + i) in
- let j = ref (dstofs + i - 1) in
- while (!j >= dstofs && cmp dst.(!j) e > 0) do
- dst.(!j + 1) <- dst.(!j);
- decr j;
- done;
- dst.(!j + 1) <- e;
- done;
- in
- let rec sortto srcofs dst dstofs len =
- if len <= cutoff then isortto srcofs dst dstofs len else begin
- let l1 = len / 2 in
- let l2 = len - l1 in
- sortto (srcofs + l1) dst (dstofs + l1) l2;
- sortto srcofs a (srcofs + l2) l1;
- merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
- end;
- in
- let l = Array.length a in
- if l <= cutoff then isortto 0 a 0 l else begin
- let l1 = l / 2 in
- let l2 = l - l1 in
- let t = Array.make l2 a.(0) in
- sortto l1 t 0 l2;
- sortto 0 a l2 l1;
- merge l2 l1 t 0 l2 a 0;
- end;
-;;
-
-let cutoff = 6;;
-let amerge_1f cmp a =
- let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
- let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
- let rec loop i1 s1 i2 s2 d =
- if cmp s1 s2 <= 0 then begin
- dst.(d) <- s1;
- let i1 = i1 + 1 in
- if i1 < src1r then
- loop i1 a.(i1) i2 s2 (d + 1)
- else
- Array.blit src2 i2 dst (d + 1) (src2r - i2)
- end else begin
- dst.(d) <- s2;
- let i2 = i2 + 1 in
- if i2 < src2r then
- loop i1 s1 i2 src2.(i2) (d + 1)
- else
- Array.blit a i1 dst (d + 1) (src1r - i1)
- end
- in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
- in
- let isortto srcofs dst dstofs len =
- for i = 0 to len - 1 do
- let e = a.(srcofs + i) in
- let j = ref (dstofs + i - 1) in
- while (!j >= dstofs && cmp dst.(!j) e > 0) do
- dst.(!j + 1) <- dst.(!j);
- decr j;
- done;
- dst.(!j + 1) <- e;
- done;
- in
- let rec sortto srcofs dst dstofs len =
- if len <= cutoff then isortto srcofs dst dstofs len else begin
- let l1 = len / 2 in
- let l2 = len - l1 in
- sortto (srcofs + l1) dst (dstofs + l1) l2;
- sortto srcofs a (srcofs + l2) l1;
- merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
- end;
- in
- let l = Array.length a in
- if l <= cutoff then isortto 0 a 0 l else begin
- let l1 = l / 2 in
- let l2 = l - l1 in
- let t = Array.make l2 a.(0) in
- sortto l1 t 0 l2;
- sortto 0 a l2 l1;
- merge l2 l1 t 0 l2 a 0;
- end;
-;;
-
-let cutoff = 7;;
-let amerge_1g cmp a =
- let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
- let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
- let rec loop i1 s1 i2 s2 d =
- if cmp s1 s2 <= 0 then begin
- dst.(d) <- s1;
- let i1 = i1 + 1 in
- if i1 < src1r then
- loop i1 a.(i1) i2 s2 (d + 1)
- else
- Array.blit src2 i2 dst (d + 1) (src2r - i2)
- end else begin
- dst.(d) <- s2;
- let i2 = i2 + 1 in
- if i2 < src2r then
- loop i1 s1 i2 src2.(i2) (d + 1)
- else
- Array.blit a i1 dst (d + 1) (src1r - i1)
- end
- in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
- in
- let isortto srcofs dst dstofs len =
- for i = 0 to len - 1 do
- let e = a.(srcofs + i) in
- let j = ref (dstofs + i - 1) in
- while (!j >= dstofs && cmp dst.(!j) e > 0) do
- dst.(!j + 1) <- dst.(!j);
- decr j;
- done;
- dst.(!j + 1) <- e;
- done;
- in
- let rec sortto srcofs dst dstofs len =
- if len <= cutoff then isortto srcofs dst dstofs len else begin
- let l1 = len / 2 in
- let l2 = len - l1 in
- sortto (srcofs + l1) dst (dstofs + l1) l2;
- sortto srcofs a (srcofs + l2) l1;
- merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
- end;
- in
- let l = Array.length a in
- if l <= cutoff then isortto 0 a 0 l else begin
- let l1 = l / 2 in
- let l2 = l - l1 in
- let t = Array.make l2 a.(0) in
- sortto l1 t 0 l2;
- sortto 0 a l2 l1;
- merge l2 l1 t 0 l2 a 0;
- end;
-;;
-
-let cutoff = 8;;
-let amerge_1h cmp a =
- let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
- let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
- let rec loop i1 s1 i2 s2 d =
- if cmp s1 s2 <= 0 then begin
- dst.(d) <- s1;
- let i1 = i1 + 1 in
- if i1 < src1r then
- loop i1 a.(i1) i2 s2 (d + 1)
- else
- Array.blit src2 i2 dst (d + 1) (src2r - i2)
- end else begin
- dst.(d) <- s2;
- let i2 = i2 + 1 in
- if i2 < src2r then
- loop i1 s1 i2 src2.(i2) (d + 1)
- else
- Array.blit a i1 dst (d + 1) (src1r - i1)
- end
- in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
- in
- let isortto srcofs dst dstofs len =
- for i = 0 to len - 1 do
- let e = a.(srcofs + i) in
- let j = ref (dstofs + i - 1) in
- while (!j >= dstofs && cmp dst.(!j) e > 0) do
- dst.(!j + 1) <- dst.(!j);
- decr j;
- done;
- dst.(!j + 1) <- e;
- done;
- in
- let rec sortto srcofs dst dstofs len =
- if len <= cutoff then isortto srcofs dst dstofs len else begin
- let l1 = len / 2 in
- let l2 = len - l1 in
- sortto (srcofs + l1) dst (dstofs + l1) l2;
- sortto srcofs a (srcofs + l2) l1;
- merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
- end;
- in
- let l = Array.length a in
- if l <= cutoff then isortto 0 a 0 l else begin
- let l1 = l / 2 in
- let l2 = l - l1 in
- let t = Array.make l2 a.(0) in
- sortto l1 t 0 l2;
- sortto 0 a l2 l1;
- merge l2 l1 t 0 l2 a 0;
- end;
-;;
-
-let cutoff = 9;;
-let amerge_1i cmp a =
- let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
- let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
- let rec loop i1 s1 i2 s2 d =
- if cmp s1 s2 <= 0 then begin
- dst.(d) <- s1;
- let i1 = i1 + 1 in
- if i1 < src1r then
- loop i1 a.(i1) i2 s2 (d + 1)
- else
- Array.blit src2 i2 dst (d + 1) (src2r - i2)
- end else begin
- dst.(d) <- s2;
- let i2 = i2 + 1 in
- if i2 < src2r then
- loop i1 s1 i2 src2.(i2) (d + 1)
- else
- Array.blit a i1 dst (d + 1) (src1r - i1)
- end
- in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
- in
- let isortto srcofs dst dstofs len =
- for i = 0 to len - 1 do
- let e = a.(srcofs + i) in
- let j = ref (dstofs + i - 1) in
- while (!j >= dstofs && cmp dst.(!j) e > 0) do
- dst.(!j + 1) <- dst.(!j);
- decr j;
- done;
- dst.(!j + 1) <- e;
- done;
- in
- let rec sortto srcofs dst dstofs len =
- if len <= cutoff then isortto srcofs dst dstofs len else begin
- let l1 = len / 2 in
- let l2 = len - l1 in
- sortto (srcofs + l1) dst (dstofs + l1) l2;
- sortto srcofs a (srcofs + l2) l1;
- merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
- end;
- in
- let l = Array.length a in
- if l <= cutoff then isortto 0 a 0 l else begin
- let l1 = l / 2 in
- let l2 = l - l1 in
- let t = Array.make l2 a.(0) in
- sortto l1 t 0 l2;
- sortto 0 a l2 l1;
- merge l2 l1 t 0 l2 a 0;
- end;
-;;
-
-let cutoff = 10;;
-let amerge_1j cmp a =
- let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
- let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
- let rec loop i1 s1 i2 s2 d =
- if cmp s1 s2 <= 0 then begin
- dst.(d) <- s1;
- let i1 = i1 + 1 in
- if i1 < src1r then
- loop i1 a.(i1) i2 s2 (d + 1)
- else
- Array.blit src2 i2 dst (d + 1) (src2r - i2)
- end else begin
- dst.(d) <- s2;
- let i2 = i2 + 1 in
- if i2 < src2r then
- loop i1 s1 i2 src2.(i2) (d + 1)
- else
- Array.blit a i1 dst (d + 1) (src1r - i1)
- end
- in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
- in
- let isortto srcofs dst dstofs len =
- for i = 0 to len - 1 do
- let e = a.(srcofs + i) in
- let j = ref (dstofs + i - 1) in
- while (!j >= dstofs && cmp dst.(!j) e > 0) do
- dst.(!j + 1) <- dst.(!j);
- decr j;
- done;
- dst.(!j + 1) <- e;
- done;
- in
- let rec sortto srcofs dst dstofs len =
- if len <= cutoff then isortto srcofs dst dstofs len else begin
- let l1 = len / 2 in
- let l2 = len - l1 in
- sortto (srcofs + l1) dst (dstofs + l1) l2;
- sortto srcofs a (srcofs + l2) l1;
- merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
- end;
- in
- let l = Array.length a in
- if l <= cutoff then isortto 0 a 0 l else begin
- let l1 = l / 2 in
- let l2 = l - l1 in
- let t = Array.make l2 a.(0) in
- sortto l1 t 0 l2;
- sortto 0 a l2 l1;
- merge l2 l1 t 0 l2 a 0;
- end;
-;;
-
-(* FIXME a essayer: *)
-(* list->array->list direct et array->list->array direct *)
-(* overhead = 1/3, 1/4, etc. *)
-(* overhead = sqrt (n) *)
-(* overhead = n/3 jusqu'a 30k, 30k jusqu'a 900M, sqrt (n) au-dela *)
-
-(************************************************************************)
-(* merge sort on arrays, merge with loop *)
-
-(* cutoff = 1 *)
-let amerge_3a cmp a =
- let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
- let i1 = ref src1ofs
- and i2 = ref src2ofs
- and d = ref dstofs
- and src1r = src1ofs + src1len
- and src2r = src2ofs + src2len
- in
- while !i1 < src1r && !i2 < src2r do
- let s1 = a.(!i1) and s2 = src2.(!i2) in
- if cmp s1 s2 <= 0 then begin
- dst.(!d) <- s1;
- incr i1;
- end else begin
- dst.(!d) <- s2;
- incr i2;
- end;
- incr d;
- done;
- if !i1 < src1r then
- Array.blit a !i1 dst !d (src1r - !i1)
- else
- Array.blit src2 !i2 dst !d (src2r - !i2)
- in
- let rec sortto srcofs dst dstofs len =
- assert (len > 0);
- if len = 1 then dst.(dstofs) <- a.(srcofs) else
- let l1 = len / 2 in
- let l2 = len - l1 in
- sortto (srcofs+l1) dst (dstofs+l1) l2;
- sortto srcofs a (srcofs+l2) l1;
- merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
- in
- let l = Array.length a in
- if l <= 1 then () else begin
- let l1 = l / 2 in
- let l2 = l - l1 in
- let t = Array.make l2 a.(0) in
- sortto l1 t 0 l2;
- sortto 0 a l2 l1;
- merge l2 l1 t 0 l2 a 0;
- end;
-;;
-
-let amerge_3b cmp a =
- let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
- let i1 = ref src1ofs
- and i2 = ref src2ofs
- and d = ref dstofs
- and src1r = src1ofs + src1len
- and src2r = src2ofs + src2len
- in
- while !i1 < src1r && !i2 < src2r do
- let s1 = a.(!i1) and s2 = src2.(!i2) in
- if cmp s1 s2 <= 0 then begin
- dst.(!d) <- s1;
- incr i1;
- end else begin
- dst.(!d) <- s2;
- incr i2;
- end;
- incr d;
- done;
- if !i1 < src1r then
- Array.blit a !i1 dst !d (src1r - !i1)
- else
- Array.blit src2 !i2 dst !d (src2r - !i2)
- in
- let rec sortto srcofs dst dstofs len =
- assert (len > 0);
- if len = 1 then dst.(dstofs) <- a.(srcofs)
- else if len = 2 then begin
- if cmp a.(srcofs) a.(srcofs+1) <= 0 then begin
- dst.(dstofs) <- a.(srcofs);
- dst.(dstofs+1) <- a.(srcofs+1);
- end else begin
- dst.(dstofs) <- a.(srcofs+1);
- dst.(dstofs+1) <- a.(srcofs);
- end
- end else begin
- let l1 = len / 2 in
- let l2 = len - l1 in
- sortto (srcofs+l1) dst (dstofs+l1) l2;
- sortto srcofs a (srcofs+l2) l1;
- merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
- end
- in
- let l = Array.length a in
- if l <= 1 then ()
- else if l = 2 then begin
- if cmp a.(0) a.(1) > 0 then begin
- let e = a.(0) in
- a.(0) <- a.(1);
- a.(1) <- e;
- end;
- end else begin
- let l1 = l / 2 in
- let l2 = l - l1 in
- let t = Array.make l2 a.(0) in
- sortto l1 t 0 l2;
- sortto 0 a l2 l1;
- merge l2 l1 t 0 l2 a 0;
- end;
-;;
-
-let cutoff = 3;;
-let amerge_3c cmp a =
- let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
- let i1 = ref src1ofs
- and i2 = ref src2ofs
- and d = ref dstofs
- and src1r = src1ofs + src1len
- and src2r = src2ofs + src2len
- in
- while !i1 < src1r && !i2 < src2r do
- let s1 = a.(!i1) and s2 = src2.(!i2) in
- if cmp s1 s2 <= 0 then begin
- dst.(!d) <- s1;
- incr i1;
- end else begin
- dst.(!d) <- s2;
- incr i2;
- end;
- incr d;
- done;
- if !i1 < src1r then
- Array.blit a !i1 dst !d (src1r - !i1)
- else
- Array.blit src2 !i2 dst !d (src2r - !i2)
- in
- let isortto srcofs dst dstofs len =
- for i = 0 to len-1 do
- let e = a.(srcofs+i) in
- let j = ref (dstofs+i-1) in
- while (!j >= dstofs && cmp dst.(!j) e > 0) do
- dst.(!j + 1) <- dst.(!j);
- decr j;
- done;
- dst.(!j + 1) <- e;
- done;
- in
- let rec sortto srcofs dst dstofs len =
- if len <= cutoff then isortto srcofs dst dstofs len else
- let l1 = len / 2 in
- let l2 = len - l1 in
- sortto (srcofs+l1) dst (dstofs+l1) l2;
- sortto srcofs a (srcofs+l2) l1;
- merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
- in
- let l = Array.length a in
- if l <= cutoff then isortto 0 a 0 l else begin
- let l1 = l / 2 in
- let l2 = l - l1 in
- let t = Array.make l2 a.(0) in
- sortto l1 t 0 l2;
- sortto 0 a l2 l1;
- merge l2 l1 t 0 l2 a 0;
- end;
-;;
-
-let cutoff = 4;;
-let amerge_3d cmp a =
- let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
- let i1 = ref src1ofs
- and i2 = ref src2ofs
- and d = ref dstofs
- and src1r = src1ofs + src1len
- and src2r = src2ofs + src2len
- in
- while !i1 < src1r && !i2 < src2r do
- let s1 = a.(!i1) and s2 = src2.(!i2) in
- if cmp s1 s2 <= 0 then begin
- dst.(!d) <- s1;
- incr i1;
- end else begin
- dst.(!d) <- s2;
- incr i2;
- end;
- incr d;
- done;
- if !i1 < src1r then
- Array.blit a !i1 dst !d (src1r - !i1)
- else
- Array.blit src2 !i2 dst !d (src2r - !i2)
- in
- let isortto srcofs dst dstofs len =
- for i = 0 to len-1 do
- let e = a.(srcofs+i) in
- let j = ref (dstofs+i-1) in
- while (!j >= dstofs && cmp dst.(!j) e > 0) do
- dst.(!j + 1) <- dst.(!j);
- decr j;
- done;
- dst.(!j + 1) <- e;
- done;
- in
- let rec sortto srcofs dst dstofs len =
- if len <= cutoff then isortto srcofs dst dstofs len else
- let l1 = len / 2 in
- let l2 = len - l1 in
- sortto (srcofs+l1) dst (dstofs+l1) l2;
- sortto srcofs a (srcofs+l2) l1;
- merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
- in
- let l = Array.length a in
- if l <= cutoff then isortto 0 a 0 l else begin
- let l1 = l / 2 in
- let l2 = l - l1 in
- let t = Array.make l2 a.(0) in
- sortto l1 t 0 l2;
- sortto 0 a l2 l1;
- merge l2 l1 t 0 l2 a 0;
- end;
-;;
-
-let cutoff = 5;;
-let amerge_3e cmp a =
- let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
- let i1 = ref src1ofs
- and i2 = ref src2ofs
- and d = ref dstofs
- and src1r = src1ofs + src1len
- and src2r = src2ofs + src2len
- in
- while !i1 < src1r && !i2 < src2r do
- let s1 = a.(!i1) and s2 = src2.(!i2) in
- if cmp s1 s2 <= 0 then begin
- dst.(!d) <- s1;
- incr i1;
- end else begin
- dst.(!d) <- s2;
- incr i2;
- end;
- incr d;
- done;
- if !i1 < src1r then
- Array.blit a !i1 dst !d (src1r - !i1)
- else
- Array.blit src2 !i2 dst !d (src2r - !i2)
- in
- let isortto srcofs dst dstofs len =
- for i = 0 to len-1 do
- let e = a.(srcofs+i) in
- let j = ref (dstofs+i-1) in
- while (!j >= dstofs && cmp dst.(!j) e > 0) do
- dst.(!j + 1) <- dst.(!j);
- decr j;
- done;
- dst.(!j + 1) <- e;
- done;
- in
- let rec sortto srcofs dst dstofs len =
- if len <= cutoff then isortto srcofs dst dstofs len else
- let l1 = len / 2 in
- let l2 = len - l1 in
- sortto (srcofs+l1) dst (dstofs+l1) l2;
- sortto srcofs a (srcofs+l2) l1;
- merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
- in
- let l = Array.length a in
- if l <= cutoff then isortto 0 a 0 l else begin
- let l1 = l / 2 in
- let l2 = l - l1 in
- let t = Array.make l2 a.(0) in
- sortto l1 t 0 l2;
- sortto 0 a l2 l1;
- merge l2 l1 t 0 l2 a 0;
- end;
-;;
-
-let cutoff = 6;;
-let amerge_3f cmp a =
- let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
- let i1 = ref src1ofs
- and i2 = ref src2ofs
- and d = ref dstofs
- and src1r = src1ofs + src1len
- and src2r = src2ofs + src2len
- in
- while !i1 < src1r && !i2 < src2r do
- let s1 = a.(!i1) and s2 = src2.(!i2) in
- if cmp s1 s2 <= 0 then begin
- dst.(!d) <- s1;
- incr i1;
- end else begin
- dst.(!d) <- s2;
- incr i2;
- end;
- incr d;
- done;
- if !i1 < src1r then
- Array.blit a !i1 dst !d (src1r - !i1)
- else
- Array.blit src2 !i2 dst !d (src2r - !i2)
- in
- let isortto srcofs dst dstofs len =
- for i = 0 to len-1 do
- let e = a.(srcofs+i) in
- let j = ref (dstofs+i-1) in
- while (!j >= dstofs && cmp dst.(!j) e > 0) do
- dst.(!j + 1) <- dst.(!j);
- decr j;
- done;
- dst.(!j + 1) <- e;
- done;
- in
- let rec sortto srcofs dst dstofs len =
- if len <= cutoff then isortto srcofs dst dstofs len else
- let l1 = len / 2 in
- let l2 = len - l1 in
- sortto (srcofs+l1) dst (dstofs+l1) l2;
- sortto srcofs a (srcofs+l2) l1;
- merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
- in
- let l = Array.length a in
- if l <= cutoff then isortto 0 a 0 l else begin
- let l1 = l / 2 in
- let l2 = l - l1 in
- let t = Array.make l2 a.(0) in
- sortto l1 t 0 l2;
- sortto 0 a l2 l1;
- merge l2 l1 t 0 l2 a 0;
- end;
-;;
-
-let cutoff = 7;;
-let amerge_3g cmp a =
- let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
- let i1 = ref src1ofs
- and i2 = ref src2ofs
- and d = ref dstofs
- and src1r = src1ofs + src1len
- and src2r = src2ofs + src2len
- in
- while !i1 < src1r && !i2 < src2r do
- let s1 = a.(!i1) and s2 = src2.(!i2) in
- if cmp s1 s2 <= 0 then begin
- dst.(!d) <- s1;
- incr i1;
- end else begin
- dst.(!d) <- s2;
- incr i2;
- end;
- incr d;
- done;
- if !i1 < src1r then
- Array.blit a !i1 dst !d (src1r - !i1)
- else
- Array.blit src2 !i2 dst !d (src2r - !i2)
- in
- let isortto srcofs dst dstofs len =
- for i = 0 to len-1 do
- let e = a.(srcofs+i) in
- let j = ref (dstofs+i-1) in
- while (!j >= dstofs && cmp dst.(!j) e > 0) do
- dst.(!j + 1) <- dst.(!j);
- decr j;
- done;
- dst.(!j + 1) <- e;
- done;
- in
- let rec sortto srcofs dst dstofs len =
- if len <= cutoff then isortto srcofs dst dstofs len else
- let l1 = len / 2 in
- let l2 = len - l1 in
- sortto (srcofs+l1) dst (dstofs+l1) l2;
- sortto srcofs a (srcofs+l2) l1;
- merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
- in
- let l = Array.length a in
- if l <= cutoff then isortto 0 a 0 l else begin
- let l1 = l / 2 in
- let l2 = l - l1 in
- let t = Array.make l2 a.(0) in
- sortto l1 t 0 l2;
- sortto 0 a l2 l1;
- merge l2 l1 t 0 l2 a 0;
- end;
-;;
-
-let cutoff = 8;;
-let amerge_3h cmp a =
- let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
- let i1 = ref src1ofs
- and i2 = ref src2ofs
- and d = ref dstofs
- and src1r = src1ofs + src1len
- and src2r = src2ofs + src2len
- in
- while !i1 < src1r && !i2 < src2r do
- let s1 = a.(!i1) and s2 = src2.(!i2) in
- if cmp s1 s2 <= 0 then begin
- dst.(!d) <- s1;
- incr i1;
- end else begin
- dst.(!d) <- s2;
- incr i2;
- end;
- incr d;
- done;
- if !i1 < src1r then
- Array.blit a !i1 dst !d (src1r - !i1)
- else
- Array.blit src2 !i2 dst !d (src2r - !i2)
- in
- let isortto srcofs dst dstofs len =
- for i = 0 to len-1 do
- let e = a.(srcofs+i) in
- let j = ref (dstofs+i-1) in
- while (!j >= dstofs && cmp dst.(!j) e > 0) do
- dst.(!j + 1) <- dst.(!j);
- decr j;
- done;
- dst.(!j + 1) <- e;
- done;
- in
- let rec sortto srcofs dst dstofs len =
- if len <= cutoff then isortto srcofs dst dstofs len else
- let l1 = len / 2 in
- let l2 = len - l1 in
- sortto (srcofs+l1) dst (dstofs+l1) l2;
- sortto srcofs a (srcofs+l2) l1;
- merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
- in
- let l = Array.length a in
- if l <= cutoff then isortto 0 a 0 l else begin
- let l1 = l / 2 in
- let l2 = l - l1 in
- let t = Array.make l2 a.(0) in
- sortto l1 t 0 l2;
- sortto 0 a l2 l1;
- merge l2 l1 t 0 l2 a 0;
- end;
-;;
-
-let cutoff = 9;;
-let amerge_3i cmp a =
- let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
- let i1 = ref src1ofs
- and i2 = ref src2ofs
- and d = ref dstofs
- and src1r = src1ofs + src1len
- and src2r = src2ofs + src2len
- in
- while !i1 < src1r && !i2 < src2r do
- let s1 = a.(!i1) and s2 = src2.(!i2) in
- if cmp s1 s2 <= 0 then begin
- dst.(!d) <- s1;
- incr i1;
- end else begin
- dst.(!d) <- s2;
- incr i2;
- end;
- incr d;
- done;
- if !i1 < src1r then
- Array.blit a !i1 dst !d (src1r - !i1)
- else
- Array.blit src2 !i2 dst !d (src2r - !i2)
- in
- let isortto srcofs dst dstofs len =
- for i = 0 to len-1 do
- let e = a.(srcofs+i) in
- let j = ref (dstofs+i-1) in
- while (!j >= dstofs && cmp dst.(!j) e > 0) do
- dst.(!j + 1) <- dst.(!j);
- decr j;
- done;
- dst.(!j + 1) <- e;
- done;
- in
- let rec sortto srcofs dst dstofs len =
- if len <= cutoff then isortto srcofs dst dstofs len else
- let l1 = len / 2 in
- let l2 = len - l1 in
- sortto (srcofs+l1) dst (dstofs+l1) l2;
- sortto srcofs a (srcofs+l2) l1;
- merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
- in
- let l = Array.length a in
- if l <= cutoff then isortto 0 a 0 l else begin
- let l1 = l / 2 in
- let l2 = l - l1 in
- let t = Array.make l2 a.(0) in
- sortto l1 t 0 l2;
- sortto 0 a l2 l1;
- merge l2 l1 t 0 l2 a 0;
- end;
-;;
-
-let cutoff = 10;;
-let amerge_3j cmp a =
- let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
- let i1 = ref src1ofs
- and i2 = ref src2ofs
- and d = ref dstofs
- and src1r = src1ofs + src1len
- and src2r = src2ofs + src2len
- in
- while !i1 < src1r && !i2 < src2r do
- let s1 = a.(!i1) and s2 = src2.(!i2) in
- if cmp s1 s2 <= 0 then begin
- dst.(!d) <- s1;
- incr i1;
- end else begin
- dst.(!d) <- s2;
- incr i2;
- end;
- incr d;
- done;
- if !i1 < src1r then
- Array.blit a !i1 dst !d (src1r - !i1)
- else
- Array.blit src2 !i2 dst !d (src2r - !i2)
- in
- let isortto srcofs dst dstofs len =
- for i = 0 to len-1 do
- let e = a.(srcofs+i) in
- let j = ref (dstofs+i-1) in
- while (!j >= dstofs && cmp dst.(!j) e > 0) do
- dst.(!j + 1) <- dst.(!j);
- decr j;
- done;
- dst.(!j + 1) <- e;
- done;
- in
- let rec sortto srcofs dst dstofs len =
- if len <= cutoff then isortto srcofs dst dstofs len else
- let l1 = len / 2 in
- let l2 = len - l1 in
- sortto (srcofs+l1) dst (dstofs+l1) l2;
- sortto srcofs a (srcofs+l2) l1;
- merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
- in
- let l = Array.length a in
- if l <= cutoff then isortto 0 a 0 l else begin
- let l1 = l / 2 in
- let l2 = l - l1 in
- let t = Array.make l2 a.(0) in
- sortto l1 t 0 l2;
- sortto 0 a l2 l1;
- merge l2 l1 t 0 l2 a 0;
- end;
-;;
-
-(* FIXME essayer bottom-up merge on arrays ? *)
-
-(************************************************************************)
-(* Shell sort on arrays *)
-
-let ashell_1 cmp a =
- let l = Array.length a in
- let step = ref 1 in
- while !step < l do step := !step * 3 + 1; done;
- step := !step / 3;
- while !step > 0 do
- for j = !step to l-1 do
- let e = a.(j) in
- let k = ref (j - !step) in
- let k1 = ref j in
- while !k >= 0 && cmp a.(!k) e > 0 do
- a.(!k1) <- a.(!k);
- k1 := !k;
- k := !k - !step;
- done;
- a.(!k1) <- e;
- done;
- step := !step / 3;
- done;
-;;
-
-let ashell_2 cmp a =
- let l = Array.length a in
- let step = ref 1 in
- while !step < l do step := !step * 3 + 1; done;
- step := !step / 3;
- while !step > 0 do
- for j = !step to l-1 do
- let e = a.(j) in
- let k = ref (j - !step) in
- while !k >= 0 && cmp a.(!k) e > 0 do
- a.(!k + !step) <- a.(!k);
- k := !k - !step;
- done;
- a.(!k + !step) <- e;
- done;
- step := !step / 3;
- done;
-;;
-
-let ashell_3 cmp a =
- let l = Array.length a in
- let step = ref 1 in
- while !step < l do step := !step * 3 + 1; done;
- step := !step / 3;
- while !step > 0 do
- for i = 0 to !step - 1 do
- let j = ref (i + !step) in
- while !j < l do
- let e = ref a.(!j) in
- let k = ref (!j - !step) in
- if cmp !e a.(i) < 0 then begin
- let x = !e in e := a.(i); a.(i) <- x;
- end;
- while cmp a.(!k) !e > 0 do
- a.(!k + !step) <- a.(!k);
- k := !k - !step;
- done;
- a.(!k + !step) <- !e;
- j := !j + !step;
- done;
- done;
- step := !step / 3;
- done;
-;;
-
-let force = Lazy.force;;
-
-type iilist = Cons of int * iilist Lazy.t;;
-
-let rec mult n (Cons (x,l)) = Cons (n*x, lazy (mult n (force l)))
-
-let rec merge (Cons (x1, t1) as l1) (Cons (x2, t2) as l2) =
- if x1 = x2 then Cons (x1, lazy (merge (force t1) (force t2)))
- else if x1 < x2 then Cons (x1, lazy (merge (force t1) l2))
- else Cons (x2, lazy (merge l1 (force t2)))
-;;
-
-let rec scale = Cons (1, lazy (merge (mult 2 scale) (mult 3 scale)));;
-
-let ashell_4 cmp a =
- let l = Array.length a in
- let rec loop1 accu (Cons (x, t)) =
- if x > l then accu else loop1 (x::accu) (force t)
- in
- let sc = loop1 [] scale in
- let rec loop2 = function
- | [] -> ()
- | step::t ->
- for i = 0 to step - 1 do
- let j = ref (i + step) in
- while !j < l do
- let e = a.(!j) in
- let k = ref (!j - step) in
- while !k >= 0 && cmp a.(!k) e > 0 do
- a.(!k + step) <- a.(!k);
- k := !k - step;
- done;
- a.(!k + step) <- e;
- j := !j + step;
- done;
- done;
- loop2 t;
- in
- loop2 sc;
-;;
-
-(************************************************************************)
-(* Quicksort on arrays *)
-let cutoff = 1;;
-let aquick_1a cmp a =
- let rec qsort l r = (* ASSUMES r - l >= 2 *)
- let m = (l + r) / 2 in
- let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
- let pivot = if cmp al am <= 0 then
- if cmp am ar <= 0 then am
- else if cmp al ar <= 0 then ar
- else al
- else
- if cmp al ar <= 0 then al
- else if cmp am ar <= 0 then ar
- else am
- in
- let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in
- while !p2 <= !p3 do
- let e = a.(!p3) in
- let c = cmp e pivot in
- if c > 0 then begin
- decr p3;
- end else if c < 0 then begin
- a.(!p3) <- a.(!p2);
- a.(!p2) <- a.(!p1);
- a.(!p1) <- e;
- incr p1;
- incr p2;
- end else begin
- a.(!p3) <- a.(!p2);
- a.(!p2) <- e;
- incr p2;
- end;
- done;
- incr p3;
- let len1 = !p1 - l and len2 = r - !p3 in
- if len1 > cutoff then
- if len2 > cutoff then begin
- if len1 < len2
- then (qsort l !p1; qsort !p3 r)
- else (qsort !p3 r; qsort l !p1)
- end else qsort l !p1
- else if len2 > cutoff then qsort !p3 r;
- in
- let l = Array.length a in
- if l > 1 then begin
- qsort 0 l;
- let mini = ref 0 in
- for i = 1 to (min l cutoff) - 1 do
- if cmp a.(i) a.(!mini) < 0 then mini := i;
- done;
- let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
- for i = 1 to l - 1 do
- let e = a.(i) in
- let j = ref (i - 1) in
- while cmp a.(!j) e > 0 do
- a.(!j + 1) <- a.(!j);
- decr j;
- done;
- a.(!j + 1) <- e;
- done;
- end;
-;;
-
-let cutoff = 2;;
-let aquick_1b cmp a =
- let rec qsort l r = (* ASSUMES r - l >= 2 *)
- let m = (l + r) / 2 in
- let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
- let pivot = if cmp al am <= 0 then
- if cmp am ar <= 0 then am
- else if cmp al ar <= 0 then ar
- else al
- else
- if cmp al ar <= 0 then al
- else if cmp am ar <= 0 then ar
- else am
- in
- let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in
- while !p2 <= !p3 do
- let e = a.(!p3) in
- let c = cmp e pivot in
- if c > 0 then begin
- decr p3;
- end else if c < 0 then begin
- a.(!p3) <- a.(!p2);
- a.(!p2) <- a.(!p1);
- a.(!p1) <- e;
- incr p1;
- incr p2;
- end else begin
- a.(!p3) <- a.(!p2);
- a.(!p2) <- e;
- incr p2;
- end;
- done;
- incr p3;
- let len1 = !p1 - l and len2 = r - !p3 in
- if len1 > cutoff then
- if len2 > cutoff then begin
- if len1 < len2
- then (qsort l !p1; qsort !p3 r)
- else (qsort !p3 r; qsort l !p1)
- end else qsort l !p1
- else if len2 > cutoff then qsort !p3 r;
- in
- let l = Array.length a in
- if l > 1 then begin
- qsort 0 l;
- let mini = ref 0 in
- for i = 1 to (min l cutoff) - 1 do
- if cmp a.(i) a.(!mini) < 0 then mini := i;
- done;
- let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
- for i = 1 to l - 1 do
- let e = a.(i) in
- let j = ref (i - 1) in
- while cmp a.(!j) e > 0 do
- a.(!j + 1) <- a.(!j);
- decr j;
- done;
- a.(!j + 1) <- e;
- done;
- end;
-;;
-
-let cutoff = 3;;
-let aquick_1c cmp a =
- let rec qsort l r = (* ASSUMES r - l >= 2 *)
- let m = (l + r) / 2 in
- let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
- let pivot = if cmp al am <= 0 then
- if cmp am ar <= 0 then am
- else if cmp al ar <= 0 then ar
- else al
- else
- if cmp al ar <= 0 then al
- else if cmp am ar <= 0 then ar
- else am
- in
- let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in
- while !p2 <= !p3 do
- let e = a.(!p3) in
- let c = cmp e pivot in
- if c > 0 then begin
- decr p3;
- end else if c < 0 then begin
- a.(!p3) <- a.(!p2);
- a.(!p2) <- a.(!p1);
- a.(!p1) <- e;
- incr p1;
- incr p2;
- end else begin
- a.(!p3) <- a.(!p2);
- a.(!p2) <- e;
- incr p2;
- end;
- done;
- incr p3;
- let len1 = !p1 - l and len2 = r - !p3 in
- if len1 > cutoff then
- if len2 > cutoff then begin
- if len1 < len2
- then (qsort l !p1; qsort !p3 r)
- else (qsort !p3 r; qsort l !p1)
- end else qsort l !p1
- else if len2 > cutoff then qsort !p3 r;
- in
- let l = Array.length a in
- if l > 1 then begin
- qsort 0 l;
- let mini = ref 0 in
- for i = 1 to (min l cutoff) - 1 do
- if cmp a.(i) a.(!mini) < 0 then mini := i;
- done;
- let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
- for i = 1 to l - 1 do
- let e = a.(i) in
- let j = ref (i - 1) in
- while cmp a.(!j) e > 0 do
- a.(!j + 1) <- a.(!j);
- decr j;
- done;
- a.(!j + 1) <- e;
- done;
- end;
-;;
-
-let cutoff = 4;;
-let aquick_1d cmp a =
- let rec qsort l r = (* ASSUMES r - l >= 2 *)
- let m = (l + r) / 2 in
- let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
- let pivot = if cmp al am <= 0 then
- if cmp am ar <= 0 then am
- else if cmp al ar <= 0 then ar
- else al
- else
- if cmp al ar <= 0 then al
- else if cmp am ar <= 0 then ar
- else am
- in
- let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in
- while !p2 <= !p3 do
- let e = a.(!p3) in
- let c = cmp e pivot in
- if c > 0 then begin
- decr p3;
- end else if c < 0 then begin
- a.(!p3) <- a.(!p2);
- a.(!p2) <- a.(!p1);
- a.(!p1) <- e;
- incr p1;
- incr p2;
- end else begin
- a.(!p3) <- a.(!p2);
- a.(!p2) <- e;
- incr p2;
- end;
- done;
- incr p3;
- let len1 = !p1 - l and len2 = r - !p3 in
- if len1 > cutoff then
- if len2 > cutoff then begin
- if len1 < len2
- then (qsort l !p1; qsort !p3 r)
- else (qsort !p3 r; qsort l !p1)
- end else qsort l !p1
- else if len2 > cutoff then qsort !p3 r;
- in
- let l = Array.length a in
- if l > 1 then begin
- qsort 0 l;
- let mini = ref 0 in
- for i = 1 to (min l cutoff) - 1 do
- if cmp a.(i) a.(!mini) < 0 then mini := i;
- done;
- let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
- for i = 1 to l - 1 do
- let e = a.(i) in
- let j = ref (i - 1) in
- while cmp a.(!j) e > 0 do
- a.(!j + 1) <- a.(!j);
- decr j;
- done;
- a.(!j + 1) <- e;
- done;
- end;
-;;
-
-let cutoff = 5;;
-let aquick_1e cmp a =
- let rec qsort l r = (* ASSUMES r - l >= 2 *)
- let m = (l + r) / 2 in
- let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
- let pivot = if cmp al am <= 0 then
- if cmp am ar <= 0 then am
- else if cmp al ar <= 0 then ar
- else al
- else
- if cmp al ar <= 0 then al
- else if cmp am ar <= 0 then ar
- else am
- in
- let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in
- while !p2 <= !p3 do
- let e = a.(!p3) in
- let c = cmp e pivot in
- if c > 0 then begin
- decr p3;
- end else if c < 0 then begin
- a.(!p3) <- a.(!p2);
- a.(!p2) <- a.(!p1);
- a.(!p1) <- e;
- incr p1;
- incr p2;
- end else begin
- a.(!p3) <- a.(!p2);
- a.(!p2) <- e;
- incr p2;
- end;
- done;
- incr p3;
- let len1 = !p1 - l and len2 = r - !p3 in
- if len1 > cutoff then
- if len2 > cutoff then begin
- if len1 < len2
- then (qsort l !p1; qsort !p3 r)
- else (qsort !p3 r; qsort l !p1)
- end else qsort l !p1
- else if len2 > cutoff then qsort !p3 r;
- in
- let l = Array.length a in
- if l > 1 then begin
- qsort 0 l;
- let mini = ref 0 in
- for i = 1 to (min l cutoff) - 1 do
- if cmp a.(i) a.(!mini) < 0 then mini := i;
- done;
- let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
- for i = 1 to l - 1 do
- let e = a.(i) in
- let j = ref (i - 1) in
- while cmp a.(!j) e > 0 do
- a.(!j + 1) <- a.(!j);
- decr j;
- done;
- a.(!j + 1) <- e;
- done;
- end;
-;;
-
-let cutoff = 6;;
-let aquick_1f cmp a =
- let rec qsort l r = (* ASSUMES r - l >= 2 *)
- let m = (l + r) / 2 in
- let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
- let pivot = if cmp al am <= 0 then
- if cmp am ar <= 0 then am
- else if cmp al ar <= 0 then ar
- else al
- else
- if cmp al ar <= 0 then al
- else if cmp am ar <= 0 then ar
- else am
- in
- let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in
- while !p2 <= !p3 do
- let e = a.(!p3) in
- let c = cmp e pivot in
- if c > 0 then begin
- decr p3;
- end else if c < 0 then begin
- a.(!p3) <- a.(!p2);
- a.(!p2) <- a.(!p1);
- a.(!p1) <- e;
- incr p1;
- incr p2;
- end else begin
- a.(!p3) <- a.(!p2);
- a.(!p2) <- e;
- incr p2;
- end;
- done;
- incr p3;
- let len1 = !p1 - l and len2 = r - !p3 in
- if len1 > cutoff then
- if len2 > cutoff then begin
- if len1 < len2
- then (qsort l !p1; qsort !p3 r)
- else (qsort !p3 r; qsort l !p1)
- end else qsort l !p1
- else if len2 > cutoff then qsort !p3 r;
- in
- let l = Array.length a in
- if l > 1 then begin
- qsort 0 l;
- let mini = ref 0 in
- for i = 1 to (min l cutoff) - 1 do
- if cmp a.(i) a.(!mini) < 0 then mini := i;
- done;
- let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
- for i = 1 to l - 1 do
- let e = a.(i) in
- let j = ref (i - 1) in
- while cmp a.(!j) e > 0 do
- a.(!j + 1) <- a.(!j);
- decr j;
- done;
- a.(!j + 1) <- e;
- done;
- end;
-;;
-
-let cutoff = 7;;
-let aquick_1g cmp a =
- let rec qsort l r = (* ASSUMES r - l >= 2 *)
- let m = (l + r) / 2 in
- let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
- let pivot = if cmp al am <= 0 then
- if cmp am ar <= 0 then am
- else if cmp al ar <= 0 then ar
- else al
- else
- if cmp al ar <= 0 then al
- else if cmp am ar <= 0 then ar
- else am
- in
- let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in
- while !p2 <= !p3 do
- let e = a.(!p3) in
- let c = cmp e pivot in
- if c > 0 then begin
- decr p3;
- end else if c < 0 then begin
- a.(!p3) <- a.(!p2);
- a.(!p2) <- a.(!p1);
- a.(!p1) <- e;
- incr p1;
- incr p2;
- end else begin
- a.(!p3) <- a.(!p2);
- a.(!p2) <- e;
- incr p2;
- end;
- done;
- incr p3;
- let len1 = !p1 - l and len2 = r - !p3 in
- if len1 > cutoff then
- if len2 > cutoff then begin
- if len1 < len2
- then (qsort l !p1; qsort !p3 r)
- else (qsort !p3 r; qsort l !p1)
- end else qsort l !p1
- else if len2 > cutoff then qsort !p3 r;
- in
- let l = Array.length a in
- if l > 1 then begin
- qsort 0 l;
- let mini = ref 0 in
- for i = 1 to (min l cutoff) - 1 do
- if cmp a.(i) a.(!mini) < 0 then mini := i;
- done;
- let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
- for i = 1 to l - 1 do
- let e = a.(i) in
- let j = ref (i - 1) in
- while cmp a.(!j) e > 0 do
- a.(!j + 1) <- a.(!j);
- decr j;
- done;
- a.(!j + 1) <- e;
- done;
- end;
-;;
-
-let cutoff = 1;;
-let aquick_2a cmp a =
- let rec qsort l r = (* ASSUMES r - l >= 2 *)
- let m = (l + r) / 2 in
- let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
- let pivot = if cmp al am <= 0 then
- if cmp am ar <= 0 then am
- else if cmp al ar <= 0 then ar
- else al
- else
- if cmp al ar <= 0 then al
- else if cmp am ar <= 0 then ar
- else am
- in
- let p1 = ref l and p2 = ref l and p3 = ref r in
- while !p2 < !p3 do
- let e = a.(!p2) in
- let c = cmp e pivot in
- if c > 0 then begin
- decr p3;
- a.(!p2) <- a.(!p3);
- a.(!p3) <- e;
- end else if c < 0 then begin
- a.(!p2) <- a.(!p1);
- a.(!p1) <- e;
- incr p1;
- incr p2;
- end else begin
- incr p2;
- end;
- done;
- let len1 = !p1 - l and len2 = r - !p3 in
- if len1 > cutoff then
- if len2 > cutoff then begin
- if len1 < len2
- then (qsort l !p1; qsort !p3 r)
- else (qsort !p3 r; qsort l !p1)
- end else qsort l !p1
- else if len2 > cutoff then qsort !p3 r;
- in
- let l = Array.length a in
- if l > 1 then begin
- qsort 0 l;
- let mini = ref 0 in
- for i = 0 to (min l cutoff) - 1 do
- if cmp a.(i) a.(!mini) < 0 then mini := i;
- done;
- let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
- for i = 1 to l - 1 do
- let e = a.(i) in
- let j = ref (i - 1) in
- while cmp a.(!j) e > 0 do
- a.(!j + 1) <- a.(!j);
- decr j;
- done;
- a.(!j + 1) <- e;
- done;
- end;
-;;
-
-let cutoff = 2;;
-let aquick_2b cmp a =
- let rec qsort l r = (* ASSUMES r - l >= 2 *)
- let m = (l + r) / 2 in
- let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
- let pivot = if cmp al am <= 0 then
- if cmp am ar <= 0 then am
- else if cmp al ar <= 0 then ar
- else al
- else
- if cmp al ar <= 0 then al
- else if cmp am ar <= 0 then ar
- else am
- in
- let p1 = ref l and p2 = ref l and p3 = ref r in
- while !p2 < !p3 do
- let e = a.(!p2) in
- let c = cmp e pivot in
- if c > 0 then begin
- decr p3;
- a.(!p2) <- a.(!p3);
- a.(!p3) <- e;
- end else if c < 0 then begin
- a.(!p2) <- a.(!p1);
- a.(!p1) <- e;
- incr p1;
- incr p2;
- end else begin
- incr p2;
- end;
- done;
- let len1 = !p1 - l and len2 = r - !p3 in
- if len1 > cutoff then
- if len2 > cutoff then begin
- if len1 < len2
- then (qsort l !p1; qsort !p3 r)
- else (qsort !p3 r; qsort l !p1)
- end else qsort l !p1
- else if len2 > cutoff then qsort !p3 r;
- in
- let l = Array.length a in
- if l > 1 then begin
- qsort 0 l;
- let mini = ref 0 in
- for i = 0 to (min l cutoff) - 1 do
- if cmp a.(i) a.(!mini) < 0 then mini := i;
- done;
- let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
- for i = 1 to l - 1 do
- let e = a.(i) in
- let j = ref (i - 1) in
- while cmp a.(!j) e > 0 do
- a.(!j + 1) <- a.(!j);
- decr j;
- done;
- a.(!j + 1) <- e;
- done;
- end;
-;;
-
-let cutoff = 3;;
-let aquick_2c cmp a =
- let rec qsort l r = (* ASSUMES r - l >= 2 *)
- let m = (l + r) / 2 in
- let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
- let pivot = if cmp al am <= 0 then
- if cmp am ar <= 0 then am
- else if cmp al ar <= 0 then ar
- else al
- else
- if cmp al ar <= 0 then al
- else if cmp am ar <= 0 then ar
- else am
- in
- let p1 = ref l and p2 = ref l and p3 = ref r in
- while !p2 < !p3 do
- let e = a.(!p2) in
- let c = cmp e pivot in
- if c > 0 then begin
- decr p3;
- a.(!p2) <- a.(!p3);
- a.(!p3) <- e;
- end else if c < 0 then begin
- a.(!p2) <- a.(!p1);
- a.(!p1) <- e;
- incr p1;
- incr p2;
- end else begin
- incr p2;
- end;
- done;
- let len1 = !p1 - l and len2 = r - !p3 in
- if len1 > cutoff then
- if len2 > cutoff then begin
- if len1 < len2
- then (qsort l !p1; qsort !p3 r)
- else (qsort !p3 r; qsort l !p1)
- end else qsort l !p1
- else if len2 > cutoff then qsort !p3 r;
- in
- let l = Array.length a in
- if l > 1 then begin
- qsort 0 l;
- let mini = ref 0 in
- for i = 0 to (min l cutoff) - 1 do
- if cmp a.(i) a.(!mini) < 0 then mini := i;
- done;
- let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
- for i = 1 to l - 1 do
- let e = a.(i) in
- let j = ref (i - 1) in
- while cmp a.(!j) e > 0 do
- a.(!j + 1) <- a.(!j);
- decr j;
- done;
- a.(!j + 1) <- e;
- done;
- end;
-;;
-
-let cutoff = 4;;
-let aquick_2d cmp a =
- let rec qsort l r = (* ASSUMES r - l >= 2 *)
- let m = (l + r) / 2 in
- let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
- let pivot = if cmp al am <= 0 then
- if cmp am ar <= 0 then am
- else if cmp al ar <= 0 then ar
- else al
- else
- if cmp al ar <= 0 then al
- else if cmp am ar <= 0 then ar
- else am
- in
- let p1 = ref l and p2 = ref l and p3 = ref r in
- while !p2 < !p3 do
- let e = a.(!p2) in
- let c = cmp e pivot in
- if c > 0 then begin
- decr p3;
- a.(!p2) <- a.(!p3);
- a.(!p3) <- e;
- end else if c < 0 then begin
- a.(!p2) <- a.(!p1);
- a.(!p1) <- e;
- incr p1;
- incr p2;
- end else begin
- incr p2;
- end;
- done;
- let len1 = !p1 - l and len2 = r - !p3 in
- if len1 > cutoff then
- if len2 > cutoff then begin
- if len1 < len2
- then (qsort l !p1; qsort !p3 r)
- else (qsort !p3 r; qsort l !p1)
- end else qsort l !p1
- else if len2 > cutoff then qsort !p3 r;
- in
- let l = Array.length a in
- if l > 1 then begin
- qsort 0 l;
- let mini = ref 0 in
- for i = 0 to (min l cutoff) - 1 do
- if cmp a.(i) a.(!mini) < 0 then mini := i;
- done;
- let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
- for i = 1 to l - 1 do
- let e = a.(i) in
- let j = ref (i - 1) in
- while cmp a.(!j) e > 0 do
- a.(!j + 1) <- a.(!j);
- decr j;
- done;
- a.(!j + 1) <- e;
- done;
- end;
-;;
-
-let cutoff = 5;;
-let aquick_2e cmp a =
- let rec qsort l r = (* ASSUMES r - l >= 2 *)
- let m = (l + r) / 2 in
- let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
- let pivot = if cmp al am <= 0 then
- if cmp am ar <= 0 then am
- else if cmp al ar <= 0 then ar
- else al
- else
- if cmp al ar <= 0 then al
- else if cmp am ar <= 0 then ar
- else am
- in
- let p1 = ref l and p2 = ref l and p3 = ref r in
- while !p2 < !p3 do
- let e = a.(!p2) in
- let c = cmp e pivot in
- if c > 0 then begin
- decr p3;
- a.(!p2) <- a.(!p3);
- a.(!p3) <- e;
- end else if c < 0 then begin
- a.(!p2) <- a.(!p1);
- a.(!p1) <- e;
- incr p1;
- incr p2;
- end else begin
- incr p2;
- end;
- done;
- let len1 = !p1 - l and len2 = r - !p3 in
- if len1 > cutoff then
- if len2 > cutoff then begin
- if len1 < len2
- then (qsort l !p1; qsort !p3 r)
- else (qsort !p3 r; qsort l !p1)
- end else qsort l !p1
- else if len2 > cutoff then qsort !p3 r;
- in
- let l = Array.length a in
- if l > 1 then begin
- qsort 0 l;
- let mini = ref 0 in
- for i = 0 to (min l cutoff) - 1 do
- if cmp a.(i) a.(!mini) < 0 then mini := i;
- done;
- let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
- for i = 1 to l - 1 do
- let e = a.(i) in
- let j = ref (i - 1) in
- while cmp a.(!j) e > 0 do
- a.(!j + 1) <- a.(!j);
- decr j;
- done;
- a.(!j + 1) <- e;
- done;
- end;
-;;
-
-let cutoff = 6;;
-let aquick_2f cmp a =
- let rec qsort l r = (* ASSUMES r - l >= 2 *)
- let m = (l + r) / 2 in
- let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
- let pivot = if cmp al am <= 0 then
- if cmp am ar <= 0 then am
- else if cmp al ar <= 0 then ar
- else al
- else
- if cmp al ar <= 0 then al
- else if cmp am ar <= 0 then ar
- else am
- in
- let p1 = ref l and p2 = ref l and p3 = ref r in
- while !p2 < !p3 do
- let e = a.(!p2) in
- let c = cmp e pivot in
- if c > 0 then begin
- decr p3;
- a.(!p2) <- a.(!p3);
- a.(!p3) <- e;
- end else if c < 0 then begin
- a.(!p2) <- a.(!p1);
- a.(!p1) <- e;
- incr p1;
- incr p2;
- end else begin
- incr p2;
- end;
- done;
- let len1 = !p1 - l and len2 = r - !p3 in
- if len1 > cutoff then
- if len2 > cutoff then begin
- if len1 < len2
- then (qsort l !p1; qsort !p3 r)
- else (qsort !p3 r; qsort l !p1)
- end else qsort l !p1
- else if len2 > cutoff then qsort !p3 r;
- in
- let l = Array.length a in
- if l > 1 then begin
- qsort 0 l;
- let mini = ref 0 in
- for i = 0 to (min l cutoff) - 1 do
- if cmp a.(i) a.(!mini) < 0 then mini := i;
- done;
- let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
- for i = 1 to l - 1 do
- let e = a.(i) in
- let j = ref (i - 1) in
- while cmp a.(!j) e > 0 do
- a.(!j + 1) <- a.(!j);
- decr j;
- done;
- a.(!j + 1) <- e;
- done;
- end;
-;;
-
-let cutoff = 7;;
-let aquick_2g cmp a =
- let rec qsort l r = (* ASSUMES r - l >= 2 *)
- let m = (l + r) / 2 in
- let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
- let pivot = if cmp al am <= 0 then
- if cmp am ar <= 0 then am
- else if cmp al ar <= 0 then ar
- else al
- else
- if cmp al ar <= 0 then al
- else if cmp am ar <= 0 then ar
- else am
- in
- let p1 = ref l and p2 = ref l and p3 = ref r in
- while !p2 < !p3 do
- let e = a.(!p2) in
- let c = cmp e pivot in
- if c > 0 then begin
- decr p3;
- a.(!p2) <- a.(!p3);
- a.(!p3) <- e;
- end else if c < 0 then begin
- a.(!p2) <- a.(!p1);
- a.(!p1) <- e;
- incr p1;
- incr p2;
- end else begin
- incr p2;
- end;
- done;
- let len1 = !p1 - l and len2 = r - !p3 in
- if len1 > cutoff then
- if len2 > cutoff then begin
- if len1 < len2
- then (qsort l !p1; qsort !p3 r)
- else (qsort !p3 r; qsort l !p1)
- end else qsort l !p1
- else if len2 > cutoff then qsort !p3 r;
- in
- let l = Array.length a in
- if l > 1 then begin
- qsort 0 l;
- let mini = ref 0 in
- for i = 0 to (min l cutoff) - 1 do
- if cmp a.(i) a.(!mini) < 0 then mini := i;
- done;
- let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
- for i = 1 to l - 1 do
- let e = a.(i) in
- let j = ref (i - 1) in
- while cmp a.(!j) e > 0 do
- a.(!j + 1) <- a.(!j);
- decr j;
- done;
- a.(!j + 1) <- e;
- done;
- end;
-;;
-
-let cutoff = 1;;
-let aquick_3a cmp a =
- let rec qsort l r = (* ASSUMES r - l >= 2 *)
- let m = (l + r) / 2 in
- let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
- let pivot = if cmp al am <= 0 then
- if cmp am ar <= 0 then am
- else if cmp al ar <= 0 then ar
- else al
- else
- if cmp al ar <= 0 then al
- else if cmp am ar <= 0 then ar
- else am
- in
- let p1 = ref l and p2 = ref l and p3 = ref r in
- while !p2 < !p3 do
- let e = a.(!p2) in
- let c = cmp e pivot in
- if c > 0 then begin
- decr p3;
- a.(!p2) <- a.(!p3);
- a.(!p3) <- e;
- end else if c < 0 then begin
- incr p2;
- end else begin
- a.(!p2) <- a.(!p1);
- a.(!p1) <- e;
- incr p1;
- incr p2;
- end
- done;
- while !p1 > l do
- decr p1;
- decr p2;
- let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
- done;
- let len1 = !p2 - l and len2 = r - !p3 in
- if len1 > cutoff then
- if len2 > cutoff then begin
- if len1 < len2
- then (qsort l !p2; qsort !p3 r)
- else (qsort !p3 r; qsort l !p2)
- end else qsort l !p2
- else if len2 > cutoff then qsort !p3 r;
- in
- let l = Array.length a in
- if l > 1 then begin
- qsort 0 l;
- let mini = ref 0 in
- for i = 0 to (min l cutoff) - 1 do
- if cmp a.(i) a.(!mini) < 0 then mini := i;
- done;
- let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
- for i = 1 to l - 1 do
- let e = a.(i) in
- let j = ref (i - 1) in
- while cmp a.(!j) e > 0 do
- a.(!j + 1) <- a.(!j);
- decr j;
- done;
- a.(!j + 1) <- e;
- done;
- end;
-;;
-
-let cutoff = 2;;
-let aquick_3b cmp a =
- let rec qsort l r = (* ASSUMES r - l >= 2 *)
- let m = (l + r) / 2 in
- let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
- let pivot = if cmp al am <= 0 then
- if cmp am ar <= 0 then am
- else if cmp al ar <= 0 then ar
- else al
- else
- if cmp al ar <= 0 then al
- else if cmp am ar <= 0 then ar
- else am
- in
- let p1 = ref l and p2 = ref l and p3 = ref r in
- while !p2 < !p3 do
- let e = a.(!p2) in
- let c = cmp e pivot in
- if c > 0 then begin
- decr p3;
- a.(!p2) <- a.(!p3);
- a.(!p3) <- e;
- end else if c < 0 then begin
- incr p2;
- end else begin
- a.(!p2) <- a.(!p1);
- a.(!p1) <- e;
- incr p1;
- incr p2;
- end
- done;
- while !p1 > l do
- decr p1;
- decr p2;
- let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
- done;
- let len1 = !p2 - l and len2 = r - !p3 in
- if len1 > cutoff then
- if len2 > cutoff then begin
- if len1 < len2
- then (qsort l !p2; qsort !p3 r)
- else (qsort !p3 r; qsort l !p2)
- end else qsort l !p2
- else if len2 > cutoff then qsort !p3 r;
- in
- let l = Array.length a in
- if l > 1 then begin
- qsort 0 l;
- let mini = ref 0 in
- for i = 0 to (min l cutoff) - 1 do
- if cmp a.(i) a.(!mini) < 0 then mini := i;
- done;
- let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
- for i = 1 to l - 1 do
- let e = a.(i) in
- let j = ref (i - 1) in
- while cmp a.(!j) e > 0 do
- a.(!j + 1) <- a.(!j);
- decr j;
- done;
- a.(!j + 1) <- e;
- done;
- end;
-;;
-
-let cutoff = 3;;
-let aquick_3c cmp a =
- let rec qsort l r = (* ASSUMES r - l >= 2 *)
- let m = (l + r) / 2 in
- let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
- let pivot = if cmp al am <= 0 then
- if cmp am ar <= 0 then am
- else if cmp al ar <= 0 then ar
- else al
- else
- if cmp al ar <= 0 then al
- else if cmp am ar <= 0 then ar
- else am
- in
- let p1 = ref l and p2 = ref l and p3 = ref r in
- while !p2 < !p3 do
- let e = a.(!p2) in
- let c = cmp e pivot in
- if c > 0 then begin
- decr p3;
- a.(!p2) <- a.(!p3);
- a.(!p3) <- e;
- end else if c < 0 then begin
- incr p2;
- end else begin
- a.(!p2) <- a.(!p1);
- a.(!p1) <- e;
- incr p1;
- incr p2;
- end
- done;
- while !p1 > l do
- decr p1;
- decr p2;
- let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
- done;
- let len1 = !p2 - l and len2 = r - !p3 in
- if len1 > cutoff then
- if len2 > cutoff then begin
- if len1 < len2
- then (qsort l !p2; qsort !p3 r)
- else (qsort !p3 r; qsort l !p2)
- end else qsort l !p2
- else if len2 > cutoff then qsort !p3 r;
- in
- let l = Array.length a in
- if l > 1 then begin
- qsort 0 l;
- let mini = ref 0 in
- for i = 0 to (min l cutoff) - 1 do
- if cmp a.(i) a.(!mini) < 0 then mini := i;
- done;
- let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
- for i = 1 to l - 1 do
- let e = a.(i) in
- let j = ref (i - 1) in
- while cmp a.(!j) e > 0 do
- a.(!j + 1) <- a.(!j);
- decr j;
- done;
- a.(!j + 1) <- e;
- done;
- end;
-;;
-
-let cutoff = 4;;
-let aquick_3d cmp a =
- let rec qsort l r = (* ASSUMES r - l >= 2 *)
- let m = (l + r) / 2 in
- let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
- let pivot = if cmp al am <= 0 then
- if cmp am ar <= 0 then am
- else if cmp al ar <= 0 then ar
- else al
- else
- if cmp al ar <= 0 then al
- else if cmp am ar <= 0 then ar
- else am
- in
- let p1 = ref l and p2 = ref l and p3 = ref r in
- while !p2 < !p3 do
- let e = a.(!p2) in
- let c = cmp e pivot in
- if c > 0 then begin
- decr p3;
- a.(!p2) <- a.(!p3);
- a.(!p3) <- e;
- end else if c < 0 then begin
- incr p2;
- end else begin
- a.(!p2) <- a.(!p1);
- a.(!p1) <- e;
- incr p1;
- incr p2;
- end
- done;
- while !p1 > l do
- decr p1;
- decr p2;
- let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
- done;
- let len1 = !p2 - l and len2 = r - !p3 in
- if len1 > cutoff then
- if len2 > cutoff then begin
- if len1 < len2
- then (qsort l !p2; qsort !p3 r)
- else (qsort !p3 r; qsort l !p2)
- end else qsort l !p2
- else if len2 > cutoff then qsort !p3 r;
- in
- let l = Array.length a in
- if l > 1 then begin
- qsort 0 l;
- let mini = ref 0 in
- for i = 0 to (min l cutoff) - 1 do
- if cmp a.(i) a.(!mini) < 0 then mini := i;
- done;
- let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
- for i = 1 to l - 1 do
- let e = a.(i) in
- let j = ref (i - 1) in
- while cmp a.(!j) e > 0 do
- a.(!j + 1) <- a.(!j);
- decr j;
- done;
- a.(!j + 1) <- e;
- done;
- end;
-;;
-
-let cutoff = 5;;
-let aquick_3e cmp a =
- let rec qsort l r = (* ASSUMES r - l >= 2 *)
- let m = (l + r) / 2 in
- let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
- let pivot = if cmp al am <= 0 then
- if cmp am ar <= 0 then am
- else if cmp al ar <= 0 then ar
- else al
- else
- if cmp al ar <= 0 then al
- else if cmp am ar <= 0 then ar
- else am
- in
- let p1 = ref l and p2 = ref l and p3 = ref r in
- while !p2 < !p3 do
- let e = a.(!p2) in
- let c = cmp e pivot in
- if c > 0 then begin
- decr p3;
- a.(!p2) <- a.(!p3);
- a.(!p3) <- e;
- end else if c < 0 then begin
- incr p2;
- end else begin
- a.(!p2) <- a.(!p1);
- a.(!p1) <- e;
- incr p1;
- incr p2;
- end
- done;
- while !p1 > l do
- decr p1;
- decr p2;
- let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
- done;
- let len1 = !p2 - l and len2 = r - !p3 in
- if len1 > cutoff then
- if len2 > cutoff then begin
- if len1 < len2
- then (qsort l !p2; qsort !p3 r)
- else (qsort !p3 r; qsort l !p2)
- end else qsort l !p2
- else if len2 > cutoff then qsort !p3 r;
- in
- let l = Array.length a in
- if l > 1 then begin
- qsort 0 l;
- let mini = ref 0 in
- for i = 0 to (min l cutoff) - 1 do
- if cmp a.(i) a.(!mini) < 0 then mini := i;
- done;
- let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
- for i = 1 to l - 1 do
- let e = a.(i) in
- let j = ref (i - 1) in
- while cmp a.(!j) e > 0 do
- a.(!j + 1) <- a.(!j);
- decr j;
- done;
- a.(!j + 1) <- e;
- done;
- end;
-;;
-
-let cutoff = 6;;
-let aquick_3f cmp a =
- let rec qsort l r = (* ASSUMES r - l >= 2 *)
- let m = (l + r) / 2 in
- let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
- let pivot = if cmp al am <= 0 then
- if cmp am ar <= 0 then am
- else if cmp al ar <= 0 then ar
- else al
- else
- if cmp al ar <= 0 then al
- else if cmp am ar <= 0 then ar
- else am
- in
- let p1 = ref l and p2 = ref l and p3 = ref r in
- while !p2 < !p3 do
- let e = a.(!p2) in
- let c = cmp e pivot in
- if c > 0 then begin
- decr p3;
- a.(!p2) <- a.(!p3);
- a.(!p3) <- e;
- end else if c < 0 then begin
- incr p2;
- end else begin
- a.(!p2) <- a.(!p1);
- a.(!p1) <- e;
- incr p1;
- incr p2;
- end
- done;
- while !p1 > l do
- decr p1;
- decr p2;
- let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
- done;
- let len1 = !p2 - l and len2 = r - !p3 in
- if len1 > cutoff then
- if len2 > cutoff then begin
- if len1 < len2
- then (qsort l !p2; qsort !p3 r)
- else (qsort !p3 r; qsort l !p2)
- end else qsort l !p2
- else if len2 > cutoff then qsort !p3 r;
- in
- let l = Array.length a in
- if l > 1 then begin
- qsort 0 l;
- let mini = ref 0 in
- for i = 0 to (min l cutoff) - 1 do
- if cmp a.(i) a.(!mini) < 0 then mini := i;
- done;
- let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
- for i = 1 to l - 1 do
- let e = a.(i) in
- let j = ref (i - 1) in
- while cmp a.(!j) e > 0 do
- a.(!j + 1) <- a.(!j);
- decr j;
- done;
- a.(!j + 1) <- e;
- done;
- end;
-;;
-
-let cutoff = 7;;
-let aquick_3g cmp a =
- let rec qsort l r = (* ASSUMES r - l >= 2 *)
- let m = (l + r) / 2 in
- let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
- let pivot = if cmp al am <= 0 then
- if cmp am ar <= 0 then am
- else if cmp al ar <= 0 then ar
- else al
- else
- if cmp al ar <= 0 then al
- else if cmp am ar <= 0 then ar
- else am
- in
- let p1 = ref l and p2 = ref l and p3 = ref r in
- while !p2 < !p3 do
- let e = a.(!p2) in
- let c = cmp e pivot in
- if c > 0 then begin
- decr p3;
- a.(!p2) <- a.(!p3);
- a.(!p3) <- e;
- end else if c < 0 then begin
- incr p2;
- end else begin
- a.(!p2) <- a.(!p1);
- a.(!p1) <- e;
- incr p1;
- incr p2;
- end
- done;
- while !p1 > l do
- decr p1;
- decr p2;
- let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
- done;
- let len1 = !p2 - l and len2 = r - !p3 in
- if len1 > cutoff then
- if len2 > cutoff then begin
- if len1 < len2
- then (qsort l !p2; qsort !p3 r)
- else (qsort !p3 r; qsort l !p2)
- end else qsort l !p2
- else if len2 > cutoff then qsort !p3 r;
- in
- let l = Array.length a in
- if l > 1 then begin
- qsort 0 l;
- let mini = ref 0 in
- for i = 0 to (min l cutoff) - 1 do
- if cmp a.(i) a.(!mini) < 0 then mini := i;
- done;
- let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
- for i = 1 to l - 1 do
- let e = a.(i) in
- let j = ref (i - 1) in
- while cmp a.(!j) e > 0 do
- a.(!j + 1) <- a.(!j);
- decr j;
- done;
- a.(!j + 1) <- e;
- done;
- end;
-;;
-
-let cutoff = 8;;
-let aquick_3h cmp a =
- let rec qsort l r = (* ASSUMES r - l >= 2 *)
- let m = (l + r) / 2 in
- let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
- let pivot = if cmp al am <= 0 then
- if cmp am ar <= 0 then am
- else if cmp al ar <= 0 then ar
- else al
- else
- if cmp al ar <= 0 then al
- else if cmp am ar <= 0 then ar
- else am
- in
- let p1 = ref l and p2 = ref l and p3 = ref r in
- while !p2 < !p3 do
- let e = a.(!p2) in
- let c = cmp e pivot in
- if c > 0 then begin
- decr p3;
- a.(!p2) <- a.(!p3);
- a.(!p3) <- e;
- end else if c < 0 then begin
- incr p2;
- end else begin
- a.(!p2) <- a.(!p1);
- a.(!p1) <- e;
- incr p1;
- incr p2;
- end
- done;
- while !p1 > l do
- decr p1;
- decr p2;
- let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
- done;
- let len1 = !p2 - l and len2 = r - !p3 in
- if len1 > cutoff then
- if len2 > cutoff then begin
- if len1 < len2
- then (qsort l !p2; qsort !p3 r)
- else (qsort !p3 r; qsort l !p2)
- end else qsort l !p2
- else if len2 > cutoff then qsort !p3 r;
- in
- let l = Array.length a in
- if l > 1 then begin
- qsort 0 l;
- let mini = ref 0 in
- for i = 0 to (min l cutoff) - 1 do
- if cmp a.(i) a.(!mini) < 0 then mini := i;
- done;
- let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
- for i = 1 to l - 1 do
- let e = a.(i) in
- let j = ref (i - 1) in
- while cmp a.(!j) e > 0 do
- a.(!j + 1) <- a.(!j);
- decr j;
- done;
- a.(!j + 1) <- e;
- done;
- end;
-;;
-
-let cutoff = 9;;
-let aquick_3i cmp a =
- let rec qsort l r = (* ASSUMES r - l >= 2 *)
- let m = (l + r) / 2 in
- let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
- let pivot = if cmp al am <= 0 then
- if cmp am ar <= 0 then am
- else if cmp al ar <= 0 then ar
- else al
- else
- if cmp al ar <= 0 then al
- else if cmp am ar <= 0 then ar
- else am
- in
- let p1 = ref l and p2 = ref l and p3 = ref r in
- while !p2 < !p3 do
- let e = a.(!p2) in
- let c = cmp e pivot in
- if c > 0 then begin
- decr p3;
- a.(!p2) <- a.(!p3);
- a.(!p3) <- e;
- end else if c < 0 then begin
- incr p2;
- end else begin
- a.(!p2) <- a.(!p1);
- a.(!p1) <- e;
- incr p1;
- incr p2;
- end
- done;
- while !p1 > l do
- decr p1;
- decr p2;
- let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
- done;
- let len1 = !p2 - l and len2 = r - !p3 in
- if len1 > cutoff then
- if len2 > cutoff then begin
- if len1 < len2
- then (qsort l !p2; qsort !p3 r)
- else (qsort !p3 r; qsort l !p2)
- end else qsort l !p2
- else if len2 > cutoff then qsort !p3 r;
- in
- let l = Array.length a in
- if l > 1 then begin
- qsort 0 l;
- let mini = ref 0 in
- for i = 0 to (min l cutoff) - 1 do
- if cmp a.(i) a.(!mini) < 0 then mini := i;
- done;
- let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
- for i = 1 to l - 1 do
- let e = a.(i) in
- let j = ref (i - 1) in
- while cmp a.(!j) e > 0 do
- a.(!j + 1) <- a.(!j);
- decr j;
- done;
- a.(!j + 1) <- e;
- done;
- end;
-;;
-
-let cutoff = 10;;
-let aquick_3j cmp a =
- let rec qsort l r = (* ASSUMES r - l >= 2 *)
- let m = (l + r) / 2 in
- let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
- let pivot = if cmp al am <= 0 then
- if cmp am ar <= 0 then am
- else if cmp al ar <= 0 then ar
- else al
- else
- if cmp al ar <= 0 then al
- else if cmp am ar <= 0 then ar
- else am
- in
- let p1 = ref l and p2 = ref l and p3 = ref r in
- while !p2 < !p3 do
- let e = a.(!p2) in
- let c = cmp e pivot in
- if c > 0 then begin
- decr p3;
- a.(!p2) <- a.(!p3);
- a.(!p3) <- e;
- end else if c < 0 then begin
- incr p2;
- end else begin
- a.(!p2) <- a.(!p1);
- a.(!p1) <- e;
- incr p1;
- incr p2;
- end
- done;
- while !p1 > l do
- decr p1;
- decr p2;
- let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
- done;
- let len1 = !p2 - l and len2 = r - !p3 in
- if len1 > cutoff then
- if len2 > cutoff then begin
- if len1 < len2
- then (qsort l !p2; qsort !p3 r)
- else (qsort !p3 r; qsort l !p2)
- end else qsort l !p2
- else if len2 > cutoff then qsort !p3 r;
- in
- let l = Array.length a in
- if l > 1 then begin
- qsort 0 l;
- let mini = ref 0 in
- for i = 0 to (min l cutoff) - 1 do
- if cmp a.(i) a.(!mini) < 0 then mini := i;
- done;
- let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
- for i = 1 to l - 1 do
- let e = a.(i) in
- let j = ref (i - 1) in
- while cmp a.(!j) e > 0 do
- a.(!j + 1) <- a.(!j);
- decr j;
- done;
- a.(!j + 1) <- e;
- done;
- end;
-;;
-
-(************************************************************************)
-(* Heap sort on arrays (top-down, ternary) *)
-
-let aheap_1 cmp a =
- let l = ref (Array.length a) in
- let l3 = ref ((!l + 1) / 3) in (* l3 is the first element without sons *)
- let maxson i = (* ASSUMES i < !l3 *)
- let i31 = i+i+i+1 in
- let x = ref i31 in
- if i31+2 < !l then begin
- if cmp a.(i31) a.(i31+1) < 0 then x := i31+1;
- if cmp a.(!x) a.(i31+2) < 0 then x := i31+2;
- !x
- end else begin
- if i31+1 < !l && cmp a.(i31) a.(i31+1) < 0
- then i31+1
- else i31
- end
- in
- let rec trickledown i e = (* ASSUMES i < !l3 *)
- let j = maxson i in
- if cmp a.(j) e > 0 then begin
- a.(i) <- a.(j);
- if j < !l3 then trickledown j e else a.(j) <- e;
- end else begin
- a.(i) <- e;
- end;
- in
- for i = !l3 - 1 downto 0 do trickledown i a.(i); done;
- let m = ref (!l + 1 - 3 * !l3) in
- while !l > 2 do
- decr l;
- if !m = 0 then (m := 2; decr l3) else decr m;
- let e = a.(!l) in
- a.(!l) <- a.(0);
- trickledown 0 e;
- done;
- if !l > 1 then begin let e = a.(1) in a.(1) <- a.(0); a.(0) <- e; end;
-;;
-
-(************************************************************************)
-(* Heap sort on arrays (top-down, binary) *)
-
-(* FIXME essayer application partielle de trickledown (merge avec down) *)
-(* FIXME essayer expanser maxson dans trickledown; supprimer l'exception. *)
-
-let aheap_2 cmp a =
- let maxson l i e =
- let i21 = i + i + 1 in
- if i21 + 1 < l && cmp a.(i21) a.(i21+1) < 0
- then i21 + 1
- else if i21 < l then i21 else (a.(i) <- e; raise Exit)
- in
- let rec trickledown l i e =
- let j = maxson l i e in
- if cmp a.(j) e > 0 then begin
- a.(i) <- a.(j);
- trickledown l j e;
- end else begin
- a.(i) <- e;
- end;
- in
- let down l i e = try trickledown l i e with Exit -> () in
- let l = Array.length a in
- for i = l / 2 -1 downto 0 do down l i a.(i); done;
- for i = l - 1 downto 1 do
- let e = a.(i) in
- a.(i) <- a.(0);
- down i 0 e;
- done;
-;;
-
-(************************************************************************)
-(* Heap sort on arrays (bottom-up, ternary) *)
-
-exception Bottom of int;;
-
-let aheap_3 cmp a =
- let maxson l i =
- let i31 = i+i+i+1 in
- let x = ref i31 in
- if i31+2 < l then begin
- if cmp a.(i31) a.(i31+1) < 0 then x := i31+1;
- if cmp a.(!x) a.(i31+2) < 0 then x := i31+2;
- !x
- end else
- if i31+1 < l && cmp a.(i31) a.(i31+1) < 0
- then i31+1
- else if i31 < l then i31 else raise (Bottom i)
- in
- let rec trickledown l i e =
- let j = maxson l i in
- if cmp a.(j) e > 0 then begin
- a.(i) <- a.(j);
- trickledown l j e;
- end else begin
- a.(i) <- e;
- end;
- in
- let rec trickle l i e = try trickledown l i e with Bottom i -> a.(i) <- e in
- let rec bubbledown l i =
- let j = maxson l i in
- a.(i) <- a.(j);
- bubbledown l j;
- in
- let bubble l i = try bubbledown l i with Bottom i -> i in
- let rec trickleup i e =
- let father = (i - 1) / 3 in
- assert (i <> father);
- if cmp a.(father) e < 0 then begin
- a.(i) <- a.(father);
- if father > 0 then trickleup father e else a.(0) <- e;
- end else begin
- a.(i) <- e;
- end;
- in
- let l = Array.length a in
- for i = (l + 1) / 3 - 1 downto 0 do trickle l i a.(i); done;
- for i = l - 1 downto 2 do
- let e = a.(i) in
- a.(i) <- a.(0);
- trickleup (bubble i 0) e;
- done;
- if l > 1 then (let e = a.(1) in a.(1) <- a.(0); a.(0) <- e);
-;;
-
-(************************************************************************)
-(* Heap sort on arrays (bottom-up, binary) *)
-
-let aheap_4 cmp a =
- let maxson l i =
- let i21 = i + i + 1 in
- if i21 + 1 < l && cmp a.(i21) a.(i21 + 1) < 0
- then i21 + 1
- else if i21 < l then i21 else raise (Bottom i)
- in
- let rec trickledown l i e =
- let j = maxson l i in
- if cmp a.(j) e > 0 then begin
- a.(i) <- a.(j);
- trickledown l j e;
- end else begin
- a.(i) <- e;
- end;
- in
- let trickle l i e = try trickledown l i e with Bottom i -> a.(i) <- e in
- let rec bubbledown l i =
- let j = maxson l i in
- a.(i) <- a.(j);
- bubbledown l j;
- in
- let bubble l i = try bubbledown l i with Bottom i -> i in
- let rec trickleup i e =
- let father = (i - 1) / 2 in
- assert (i <> father);
- if cmp a.(father) e < 0 then begin
- a.(i) <- a.(father);
- if father > 0 then trickleup father e else a.(0) <- e;
- end else begin
- a.(i) <- e;
- end;
- in
- let l = Array.length a in
- for i = l / 2 - 1 downto 0 do trickle l i a.(i); done;
- for i = l - 1 downto 2 do
- let e = a.(i) in
- a.(i) <- a.(0);
- trickleup (bubble i 0) e;
- done;
- if l > 1 then (let e = a.(1) in a.(1) <- a.(0); a.(0) <- e);
-;;
-
-(************************************************************************)
-(* heap sort, top-down, ternary, recursive final loop *)
-
-let aheap_5 cmp a =
- let maxson l i = (* ASSUMES i < (l+1)/3 *)
- let i31 = i+i+i+1 in
- let x = ref i31 in
- if i31+2 < l then begin
- if cmp a.(i31) a.(i31+1) < 0 then x := i31+1;
- if cmp a.(!x) a.(i31+2) < 0 then x := i31+2;
- !x
- end else begin
- if i31+1 < l && cmp a.(i31) a.(i31+1) < 0
- then i31+1
- else i31
- end
- in
- let rec trickledown l l3 i e = (* ASSUMES i < l3 *)
- let j = maxson l i in
- if cmp a.(j) e > 0 then begin
- a.(i) <- a.(j);
- if j < l3 then trickledown l l3 j e else a.(j) <- e;
- end else begin
- a.(i) <- e;
- end;
- in
- let l = Array.length a in
- let l3 = (l + 1) / 3 in
- for i = l3 - 1 downto 0 do trickledown l l3 i a.(i); done;
- let rec loop0 l l3 =
- let e = a.(l) in
- a.(l) <- a.(0);
- trickledown l l3 0 e;
- loop2 (l-1) (l3-1);
- and loop1 l l3 =
- let e = a.(l) in
- a.(l) <- a.(0);
- trickledown l l3 0 e;
- loop0 (l-1) l3;
- and loop2 l l3 =
- if l > 1 then begin
- let e = a.(l) in
- a.(l) <- a.(0);
- trickledown l l3 0 e;
- loop1 (l-1) l3;
- end else begin
- let e = a.(1) in a.(1) <- a.(0); a.(0) <- e;
- end;
- in
- if l > 1 then
- match l + 1 - 3 * l3 with
- | 0 -> loop2 (l-1) (l3-1);
- | 1 -> loop0 (l-1) l3;
- | 2 -> loop1 (l-1) l3;
- | _ -> assert false;
-;;
-
-(************************************************************************)
-(* heap sort, top-down, ternary, with exception *)
-
-let aheap_6 cmp a =
- let maxson e l i =
- let i31 = i + i + i + 1 in
- let x = ref i31 in
- if i31+2 < l then begin
- if cmp a.(i31) a.(i31+1) < 0 then x := i31+1;
- if cmp a.(!x) a.(i31+2) < 0 then x := i31+2;
- !x
- end else begin
- if i31+1 < l && cmp a.(i31) a.(i31+1) < 0
- then i31+1
- else if i31 < l then i31 else (a.(i) <- e; raise Exit)
- end
- in
- let rec trickledown e l i =
- let j = maxson e l i in
- if cmp a.(j) e > 0 then begin
- a.(i) <- a.(j);
- trickledown e l j;
- end else begin
- a.(i) <- e;
- end;
- in
- let down e l i = try trickledown e l i with Exit -> (); in
- let l = Array.length a in
- for i = (l + 1) / 3 - 1 downto 0 do down a.(i) l i; done;
- for i = l - 1 downto 2 do
- let e = a.(i) in
- a.(i) <- a.(0);
- down e i 0;
- done;
- if l > 1 then (let e = a.(1) in a.(1) <- a.(0); a.(0) <- e);
-;;
-
-(* FIXME essayer cutoff pour heapsort *)
-
-(************************************************************************)
-(* Insertion sort with dichotomic search *)
-
-let ainsertion_1 cmp a =
- let rec dicho l r e =
- if l = r then l else begin
- let m = (l + r) / 2 in
- if cmp a.(m) e <= 0
- then dicho (m+1) r e
- else dicho l m e
- end
- in
- for i = 1 to Array.length a - 1 do
- let e = a.(i) in
- let j = dicho 0 i e in
- Array.blit a j a (j + 1) (i - j);
- a.(j) <- e;
- done;
-;;
-
-(************************************************************************)
-(* merge sort on lists via arrays *)
-
-let array_to_list_in_place a =
- let l = Array.length a in
- let rec loop accu n p =
- if p <= 0 then accu else begin
- if p = n then begin
- Obj.truncate (Obj.repr a) p;
- loop (a.(p-1) :: accu) (n-1000) (p-1)
- end else begin
- loop (a.(p-1) :: accu) n (p-1)
- end
- end
- in
- loop [] l l
-;;
-
-let array_of_list l len =
- match l with
- | [] -> [| |]
- | h::t ->
- let a = Array.make len h in
- let rec loop i l =
- match l with
- | [] -> ()
- | h::t -> a.(i) <- h; loop (i+1) t
- in
- loop 1 t;
- a
-;;
-
-let lmerge_0a cmp l =
- let a = Array.of_list l in
- amerge_1e cmp a;
- array_to_list_in_place a
-;;
-
-let lmerge_0b cmp l =
- let len = List.length l in
- if len > 256 then Gc.minor ();
- let a = array_of_list l len in
- amerge_1e cmp a;
- array_to_list_in_place a
-;;
-
-let lshell_0 cmp l =
- let a = Array.of_list l in
- ashell_2 cmp a;
- array_to_list_in_place a
-;;
-
-let lquick_0 cmp l =
- let a = Array.of_list l in
- aquick_3f cmp a;
- array_to_list_in_place a
-;;
-
-(************************************************************************)
-(* merge sort on arrays via lists *)
-
-let amerge_0 cmp a = (* cutoff is not yet used *)
- let l = lmerge_4e cmp (Array.to_list a) in
- let rec loop i = function
- | [] -> ()
- | h::t -> a.(i) <- h; loop (i + 1) t
- in
- loop 0 l
-;;
-
-(************************************************************************)
-
-let lold = [
- "Sort.list", Sort.list, true;
- "lmerge_3", lmerge_3, false;
- "lmerge_4a", lmerge_4a, true;
-];;
-
-let lnew = [
- "List.stable_sort", List.stable_sort, true;
-
- "lmerge_0a", lmerge_0a, true;
- "lmerge_0b", lmerge_0b, true;
- "lshell_0", lshell_0, false;
- "lquick_0", lquick_0, false;
-
- "lmerge_1a", lmerge_1a, true;
- "lmerge_1b", lmerge_1b, true;
- "lmerge_1c", lmerge_1c, true;
- "lmerge_1d", lmerge_1d, true;
-
- "lmerge_4b", lmerge_4b, true;
- "lmerge_4c", lmerge_4c, true;
- "lmerge_4d", lmerge_4d, true;
- "lmerge_4e", lmerge_4e, true;
-
- "lmerge_5a", lmerge_5a, true;
- "lmerge_5b", lmerge_5b, true;
- "lmerge_5c", lmerge_5c, true;
- "lmerge_5d", lmerge_5d, true;
-];;
-let anew = [
- "Array.stable_sort", Array.stable_sort, true;
- "Array.sort", Array.sort, false;
-
- "amerge_0", amerge_0, true;
-
- "amerge_1a", amerge_1a, true;
- "amerge_1b", amerge_1b, true;
- "amerge_1c", amerge_1c, true;
- "amerge_1d", amerge_1d, true;
- "amerge_1e", amerge_1e, true;
- "amerge_1f", amerge_1f, true;
- "amerge_1g", amerge_1g, true;
- "amerge_1h", amerge_1h, true;
- "amerge_1i", amerge_1i, true;
- "amerge_1j", amerge_1j, true;
-
- "amerge_3a", amerge_3a, true;
- "amerge_3b", amerge_3b, true;
- "amerge_3c", amerge_3c, true;
- "amerge_3d", amerge_3d, true;
- "amerge_3e", amerge_3e, true;
- "amerge_3f", amerge_3f, true;
- "amerge_3g", amerge_3g, true;
- "amerge_3h", amerge_3h, true;
- "amerge_3i", amerge_3i, true;
- "amerge_3j", amerge_3j, true;
-
- "ashell_1", ashell_1, false;
- "ashell_2", ashell_2, false;
- "ashell_3", ashell_3, false;
- "ashell_4", ashell_4, false;
-
- "aquick_1a", aquick_1a, false;
- "aquick_1b", aquick_1b, false;
- "aquick_1c", aquick_1c, false;
- "aquick_1d", aquick_1d, false;
- "aquick_1e", aquick_1e, false;
- "aquick_1f", aquick_1f, false;
- "aquick_1g", aquick_1g, false;
-
- "aquick_2a", aquick_2a, false;
- "aquick_2b", aquick_2b, false;
- "aquick_2c", aquick_2c, false;
- "aquick_2d", aquick_2d, false;
- "aquick_2e", aquick_2e, false;
- "aquick_2f", aquick_2f, false;
- "aquick_2g", aquick_2g, false;
-
- "aquick_3a", aquick_3a, false;
- "aquick_3b", aquick_3b, false;
- "aquick_3c", aquick_3c, false;
- "aquick_3d", aquick_3d, false;
- "aquick_3e", aquick_3e, false;
- "aquick_3f", aquick_3f, false;
- "aquick_3g", aquick_3g, false;
- "aquick_3h", aquick_3h, false;
- "aquick_3i", aquick_3i, false;
- "aquick_3j", aquick_3j, false;
-
- "aheap_1", aheap_1, false;
- "aheap_2", aheap_2, false;
- "aheap_3", aheap_3, false;
- "aheap_4", aheap_4, false;
- "aheap_5", aheap_5, false;
- "aheap_6", aheap_6, false;
-
- "ainsertion_1", ainsertion_1, true;
-];;
-
-(************************************************************************)
-(* main program *)
-
-type mode = Test_std | Test | Bench1 | Bench2 | Bench3;;
-
-let size = ref 22
-and mem = ref 0
-and mode = ref Test_std
-and only = ref []
-;;
-
-let usage = "Usage: sorts [-size <table size>] [-mem <memory size>]\n\
- \032 [-seed <random seed>] [-test|-bench]"
-;;
-
-let options = [
- "-size", Arg.Int ((:=) size), " Maximum size for benchmarks (default 22)";
- "-meg",Arg.Int ((:=) mem)," How many megabytes to preallocate (default 0)";
- "-seed", Arg.Int ((:=) seed), " PRNG seed (default 0)";
- "-teststd", Arg.Unit (fun () -> mode := Test_std), " Test stdlib (default)";
- "-test", Arg.Unit (fun () -> mode := Test), " Select test mode";
- "-bench1", Arg.Unit (fun () -> mode := Bench1), " Select bench mode 1";
- "-bench2", Arg.Unit (fun () -> mode := Bench2), " Select bench mode 2";
- "-bench3", Arg.Unit (fun () -> mode := Bench3), " Select bench mode 3";
- "-fn", Arg.String (fun x -> only := x :: !only),
- " <function> Test/Bench this function (default all)";
-];;
-let anonymous x = raise (Arg.Bad ("unrecognised option "^x));;
-
-let main () =
- Arg.parse options anonymous usage;
-
- Printf.printf "Command line arguments are:";
- for i = 1 to Array.length Sys.argv - 1 do
- Printf.printf " %s" Sys.argv.(i);
- done;
- Printf.printf "\n";
-
- ignore (String.create (1048576 * !mem));
- Gc.full_major ();
- let a2l = Array.to_list in
- let l2ak x y = Array.of_list x in
- let id = fun x -> x in
- let fst x y = x in
- let snd x y = y in
- let benchonly f x y z t =
- match !only with
- | [] -> f x y z t
- | l -> if List.mem y l then f x y z t
- in
- let testonly x1 x2 x3 x4 x5 x6 =
- match !only with
- | [] -> test x1 x2 x3 x4 x5 x6
- | l -> if List.mem x1 l then test x1 x2 x3 x4 x5 x6
- in
-
- match !mode with
- | Test_std -> begin
- testonly "List.sort" false List.sort List.sort lc lc;
- testonly "List.stable_sort" true List.stable_sort List.stable_sort lc lc;
- testonly "Array.sort" false Array.sort Array.sort ac ac;
- testonly "Array.stable_sort" true Array.stable_sort Array.stable_sort
- ac ac;
- printf "Number of tests failed: %d\n" !numfailed;
- end;
- | Test -> begin
- for i = 0 to List.length lold - 1 do
- let (name, f1, stable) = List.nth lold i in
- let (_, f2, _) = List.nth lold i in
- testonly name stable f1 f2 ll ll;
- done;
- testonly "Sort.array" false Sort.array Sort.array al al;
- for i = 0 to List.length lnew - 1 do
- let (name, f1, stable) = List.nth lnew i in
- let (_, f2, _) = List.nth lnew i in
- testonly name stable f1 f2 lc lc;
- done;
- for i = 0 to List.length anew - 1 do
- let (name, f1, stable) = List.nth anew i in
- let (_, f2, _) = List.nth anew i in
- testonly name stable f1 f2 ac ac;
- done;
- printf "Number of tests failed: %d\n" !numfailed;
- end;
- | Bench1 -> begin
- let ba = fun x y z -> benchonly bench1a !size x y z
- and bb = fun x y z -> benchonly bench1b !size x y z
- and bc = fun x y z -> benchonly bench1c !size x y z
- in
- for i = 0 to List.length lold - 1 do
- let (name, f, stable) = List.nth lold i in ba name f ll;
- let (name, f, stable) = List.nth lold i in bb name f ll;
- let (name, f, stable) = List.nth lold i in bc name f ll;
- done;
- ba "Sort.array" Sort.array al;
- bb "Sort.array" Sort.array al;
- bc "Sort.array" Sort.array al;
- for i = 0 to List.length lnew - 1 do
- let (name, f, stable) = List.nth lnew i in ba name f lc;
- let (name, f, stable) = List.nth lnew i in bb name f lc;
- let (name, f, stable) = List.nth lnew i in bc name f lc;
- done;
- for i = 0 to List.length anew - 1 do
- let (name, f, stable) = List.nth anew i in ba name f ac;
- let (name, f, stable) = List.nth anew i in bb name f ac;
- let (name, f, stable) = List.nth anew i in bc name f ac;
- done;
- end;
- | Bench2 -> begin
- let b = fun x y z -> benchonly bench2 !size x y z in
- for i = 0 to List.length lold - 1 do
- let (name, f, stable) = List.nth lold i in b name f ll;
- done;
- b "Sort.array" Sort.array al;
- for i = 0 to List.length lnew - 1 do
- let (name, f, stable) = List.nth lnew i in b name f lc;
- done;
- for i = 0 to List.length anew - 1 do
- let (name, f, stable) = List.nth anew i in b name f ac;
- done;
- end;
- | Bench3 -> begin
- let ba = fun x y z -> benchonly bench3a !size x y z
- and bb = fun x y z -> benchonly bench3b !size x y z
- and bc = fun x y z -> benchonly bench3c !size x y z
- in
- for i = 0 to List.length lold - 1 do
- let (name, f, stable) = List.nth lold i in ba name f ll;
- let (name, f, stable) = List.nth lold i in bb name f ll;
- let (name, f, stable) = List.nth lold i in bc name f ll;
- done;
- for i = 0 to List.length lnew - 1 do
- let (name, f, stable) = List.nth lnew i in ba name f lc;
- let (name, f, stable) = List.nth lnew i in bb name f lc;
- let (name, f, stable) = List.nth lnew i in bc name f lc;
- done;
- end;
-;;
-
-if not !Sys.interactive then Printexc.catch main ();;
-
-(* $Id$ *)
diff --git a/test/takc.ml b/test/takc.ml
deleted file mode 100644
index b5fea09a1f..0000000000
--- a/test/takc.ml
+++ /dev/null
@@ -1,23 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-let rec tak x y z =
- if x > y then tak (tak (x-1) y z) (tak (y-1) z x) (tak (z-1) x y)
- else z
-
-let rec repeat n =
- if n <= 0 then 0 else tak 18 12 6 + repeat(n-1)
-
-let _ = print_int (repeat 50); print_newline(); exit 0
-
diff --git a/test/taku.ml b/test/taku.ml
deleted file mode 100644
index 126b032899..0000000000
--- a/test/taku.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-let rec tak (x, y, z) =
- if x > y then tak(tak (x-1, y, z), tak (y-1, z, x), tak (z-1, x, y))
- else z
-
-let rec repeat n =
- if n <= 0 then 0 else tak(18,12,6) + repeat(n-1)
-
-let _ = print_int (repeat 50); print_newline(); exit 0
diff --git a/test/testinterp/.cvsignore b/test/testinterp/.cvsignore
deleted file mode 100644
index fdffd0fa26..0000000000
--- a/test/testinterp/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-a.out
-ocamlrun.68k
-ocamlrun.ppc
diff --git a/test/testinterp/Makefile.Mac b/test/testinterp/Makefile.Mac
deleted file mode 100644
index 16e00fdf50..0000000000
--- a/test/testinterp/Makefile.Mac
+++ /dev/null
@@ -1,37 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-start = 0
-
-default Ä ocamlrun.ppc ocamlrun.68k
- :runtest.mpw -start {start} -run ocamlrun.68k tÅ.ml
- #:runtest.mpw -start {start} -run ocamlrun.ppc tÅ.ml
-
-all Ä default
-test Ä default
-
-comments Ä
- runtest.mpw -bc tÅ.ml
-
-ocamlrun.ppc Ä :::byterun:ocamlrun no68k.rez
- duplicate -y :::byterun:ocamlrun ocamlrun.ppc
- rez -a no68k.rez -o ocamlrun.ppc
-
-ocamlrun.68k Ä :::byterun:ocamlrun noppc.rez
- duplicate -y :::byterun:ocamlrun ocamlrun.68k
- rez -a noppc.rez -o ocamlrun.68k
-
-clean Ä
- delete -i Å.cm[io] || set status 0
- delete -i a.out
diff --git a/test/testinterp/addbytecode.mpw b/test/testinterp/addbytecode.mpw
deleted file mode 100644
index 8d96ab2802..0000000000
--- a/test/testinterp/addbytecode.mpw
+++ /dev/null
@@ -1,42 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-set echo 0
-
-Set f "`Files -f -q "{1}"`" # get full pathnames
-
-exit if `evaluate "{f}" =~ /(Å)¨0.ml/` != 1
-set base "{¨0}"
-
-set _closeit 0
-Set _openWindows " ``Windows -q`` "
-If "{_openWindows}" !~ /Å [¶']*"{f}"[¶']* Å/
- Open "{f}"
- Set _closeit 1
-End
-
-ocamlc -unsafe -nopervasives "{f}"
-find ° "{f}"
-find Æ\'**)'\:\'(**'\Æ "{f}"
-echo >"{f}".¤
-ocamldumpobj a.out >>"{f}".¤
-find ¥ "{f}"
-
-format -t 8 "{f}"
-
-delete -i "{base}".cmi "{base}".cmo
-
-if {_closeit}
- close -y "{f}"
-end
diff --git a/test/testinterp/coverage b/test/testinterp/coverage
deleted file mode 100644
index 30a3243999..0000000000
--- a/test/testinterp/coverage
+++ /dev/null
@@ -1,133 +0,0 @@
-ACC0: 090
-ACC1: 090
-ACC2: 090
-ACC3: 090
-ACC4: 090
-ACC5: 090
-ACC6: 090
-ACC7: 090
-ACC: 091
-PUSH: 150
-PUSHACC0: 092
-PUSHACC1: 092
-PUSHACC2: 092
-PUSHACC3: 092
-PUSHACC4: 092
-PUSHACC5: 092
-PUSHACC6: 092
-PUSHACC7: 092
-PUSHACC: 093
-POP: 020
-ASSIGN: 220
-ENVACC1: 170
-ENVACC2: 170
-ENVACC3: 170
-ENVACC4: 170
-ENVACC: 171
-PUSHENVACC1: 172
-PUSHENVACC2: 172
-PUSHENVACC3: 172
-PUSHENVACC4: 172
-PUSHENVACC: 173
-PUSH_RETADDR: 270
-APPLY: 165
-APPLY1: 161
-APPLY2: 164
-APPLY3: 164
-APPTERM: 181
-APPTERM1: 180
-APPTERM2: 180
-APPTERM3: 180
-RETURN: 162
-RESTART: 163
-GRAB: 163
-CLOSURE: 160
-CLOSUREREC: 250
-OFFSETCLOSUREM2: 253
-OFFSETCLOSURE0: 253
-OFFSETCLOSURE2: 253
-OFFSETCLOSURE: 254
-PUSHOFFSETCLOSUREM2: 251
-PUSHOFFSETCLOSURE0: 251
-PUSHOFFSETCLOSURE2: 251
-PUSHOFFSETCLOSURE: 252
-GETGLOBAL: 050
-PUSHGETGLOBAL: 050
-GETGLOBALFIELD: 051
-PUSHGETGLOBALFIELD: 051
-SETGLOBAL: 000
-ATOM0: 000
-ATOM:
-PUSHATOM0:
-PUSHATOM:
-MAKEBLOCK: 041
-MAKEBLOCK1: 040
-MAKEBLOCK2: 040
-MAKEBLOCK3: 040
-MAKEFLOATBLOCK: 190
-GETFIELD0: 200
-GETFIELD1: 200
-GETFIELD2: 200
-GETFIELD3: 200
-GETFIELD: 201
-GETFLOATFIELD: 192
-SETFIELD0: 210
-SETFIELD1: 210
-SETFIELD2: 210
-SETFIELD3: 210
-SETFIELD: 211
-SETFLOATFIELD: 193
-VECTLENGTH: 130,191
-GETVECTITEM: 130
-SETVECTITEM: 131
-GETSTRINGCHAR: 120
-SETSTRINGCHAR: 121
-BRANCH: 070
-BRANCHIF: 070
-BRANCHIFNOT: 070
-SWITCH: 140,141,142
-BOOLNOT: 071
-PUSHTRAP: 100
-POPTRAP: 101
-RAISE: 060
-CHECK_SIGNALS: 230
-C_CALL1: 240
-C_CALL2: 240
-C_CALL3: 240
-C_CALL4: 240
-C_CALL5: 240
-C_CALLN:
-CONST0: 010
-CONST1: 010
-CONST2: 010
-CONST3: 010
-CONSTINT: 011
-PUSHCONST0: 020
-PUSHCONST1: 021
-PUSHCONST2: 021
-PUSHCONST3: 021
-PUSHCONSTINT: 022
-NEGINT: 110
-ADDINT: 110
-SUBINT: 110
-MULINT: 110
-DIVINT: 110
-MODINT: 110
-ANDINT: 110
-ORINT: 110
-XORINT: 110
-LSLINT: 110
-LSRINT: 110
-ASRINT: 110
-EQ: 080
-NEQ: 080
-LTINT: 080
-LEINT: 080
-GTINT: 080
-GEINT: 080
-OFFSETINT: 110
-OFFSETREF: 260
-GETMETHOD: 300
-STOP: 000
-EVENT:
-BREAK:
diff --git a/test/testinterp/lib.ml b/test/testinterp/lib.ml
deleted file mode 100644
index 967d713c9e..0000000000
--- a/test/testinterp/lib.ml
+++ /dev/null
@@ -1,42 +0,0 @@
-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 = "weak_create";;
-external weak_set : 'a weak_t -> int -> 'a option -> unit = "weak_set";;
-external weak_get: 'a weak_t -> int -> 'a option = "weak_get";;
-
-let x = 42;;
diff --git a/test/testinterp/no68k.rez b/test/testinterp/no68k.rez
deleted file mode 100644
index a6353ea6df..0000000000
--- a/test/testinterp/no68k.rez
+++ /dev/null
@@ -1 +0,0 @@
-data 'CODE' (0) { };
diff --git a/test/testinterp/noppc.rez b/test/testinterp/noppc.rez
deleted file mode 100644
index ecb9655fde..0000000000
--- a/test/testinterp/noppc.rez
+++ /dev/null
@@ -1 +0,0 @@
-data 'cfrg' (0) { };
diff --git a/test/testinterp/runtest.mpw b/test/testinterp/runtest.mpw
deleted file mode 100644
index b156043b6b..0000000000
--- a/test/testinterp/runtest.mpw
+++ /dev/null
@@ -1,105 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-# usage: runtest.mpw [-bc] [-run <runtime>] [-start <n>] <file>É
-
-set echo 0
-
-exit if {#} < 1
-
-set dobytecode 0
-set dorun 0
-set start 0
-
-loop
- if "{1}" == "-bc"
- set dobytecode 1
- else if "{1}" == "-run"
- set dorun 1
- set runtime "{2}"
- shift
- else if "{1}" == "-start"
- if "{2}" =~ /0*([0-9]+)¨0/
- shift
- set start {¨0}
- else
- echo "### runtest.mpw: option "-start" expects a number as argument" > dev:stderr
- exit 2
- end
- else
- break
- end
- shift
-end
-
-set _camlrunparam "{camlrunparam}"
-
-loop
- break if {#} == 0
- if "{1}" !~ /(t0*([0-9]+)¨1Å)¨0.ml/
- shift
- continue
- end
- set base "{¨0}"
-
- if {¨1} < {start}
- shift
- continue
- end
-
- if {¨1} >= 300
- set libs "lib.ml stdlib.cma"
- else if {¨1} >= 51
- set libs "lib.ml"
- else
- set libs ""
- end
-
- set -e camlrunparam v=0
- ocamlc -unsafe -nopervasives {libs} "{1}" || (shift; continue)
-
- if {dobytecode}
- Set f "`Files -f -q "{1}"`" # get full pathnames
- Set _openWindows " ``Windows -q`` "
- If "{_openWindows}" !~ /Å [¶']*"{f}"[¶']* Å/
- Open "{f}"
- Set _closeit 1
- else
- set _closeit 0
- End
-
- find ° "{f}"
- find Æ\'**)'\:\'(**'\Æ "{f}"
- echo >"{f}".¤
- ocamldumpobj a.out >>"{f}".¤
- find ¥ "{f}"
-
- if {_closeit}
- close -y "{f}"
- end
- end
-
- if {dorun}
- set -e camlrunparam "{_camlrunparam}"
- echo "{runtime} :a.out ### testing {1}"
- "{runtime}" :a.out || if "{1}" != "t060-raise.ml"; exit 3; end
- echo "### done"
- end
-
- delete -i "{base}".cmi "{base}".cmo
-
- shift
-end
-
-set -e camlrunparam "{_camlrunparam}"
diff --git a/test/testinterp/t000.ml b/test/testinterp/t000.ml
deleted file mode 100644
index fafa1c89fd..0000000000
--- a/test/testinterp/t000.ml
+++ /dev/null
@@ -1,7 +0,0 @@
-(* empty file *)
-
-(**
- 0 ATOM0
- 1 SETGLOBAL T000
- 3 STOP
-**)
diff --git a/test/testinterp/t010-const0.ml b/test/testinterp/t010-const0.ml
deleted file mode 100644
index 73ecbb1f18..0000000000
--- a/test/testinterp/t010-const0.ml
+++ /dev/null
@@ -1,8 +0,0 @@
-0;;
-
-(**
- 0 CONST0
- 1 ATOM0
- 2 SETGLOBAL T010-const0
- 4 STOP
-**)
diff --git a/test/testinterp/t010-const1.ml b/test/testinterp/t010-const1.ml
deleted file mode 100644
index 75a00d5787..0000000000
--- a/test/testinterp/t010-const1.ml
+++ /dev/null
@@ -1,8 +0,0 @@
-1;;
-
-(**
- 0 CONST1
- 1 ATOM0
- 2 SETGLOBAL T010-const1
- 4 STOP
-**)
diff --git a/test/testinterp/t010-const2.ml b/test/testinterp/t010-const2.ml
deleted file mode 100644
index f0ed8e7df1..0000000000
--- a/test/testinterp/t010-const2.ml
+++ /dev/null
@@ -1,8 +0,0 @@
-2;;
-
-(**
- 0 CONST2
- 1 ATOM0
- 2 SETGLOBAL T010-const2
- 4 STOP
-**)
diff --git a/test/testinterp/t010-const3.ml b/test/testinterp/t010-const3.ml
deleted file mode 100644
index 4f034c4b52..0000000000
--- a/test/testinterp/t010-const3.ml
+++ /dev/null
@@ -1,8 +0,0 @@
-3;;
-
-(**
- 0 CONST3
- 1 ATOM0
- 2 SETGLOBAL T010-const3
- 4 STOP
-**)
diff --git a/test/testinterp/t011-constint.ml b/test/testinterp/t011-constint.ml
deleted file mode 100644
index 9ece6c53bd..0000000000
--- a/test/testinterp/t011-constint.ml
+++ /dev/null
@@ -1,8 +0,0 @@
-4;;
-
-(**
- 0 CONSTINT 4
- 2 ATOM0
- 3 SETGLOBAL T011-constint
- 5 STOP
-**)
diff --git a/test/testinterp/t020.ml b/test/testinterp/t020.ml
deleted file mode 100644
index 5d6a3cfc9f..0000000000
--- a/test/testinterp/t020.ml
+++ /dev/null
@@ -1,10 +0,0 @@
-let _ = () in ();;
-
-(**
- 0 CONST0
- 1 PUSHCONST0
- 2 POP 1
- 4 ATOM0
- 5 SETGLOBAL T020
- 7 STOP
-**)
diff --git a/test/testinterp/t021-pushconst1.ml b/test/testinterp/t021-pushconst1.ml
deleted file mode 100644
index 075997a830..0000000000
--- a/test/testinterp/t021-pushconst1.ml
+++ /dev/null
@@ -1,10 +0,0 @@
-let _ = () in 1;;
-
-(**
- 0 CONST0
- 1 PUSHCONST1
- 2 POP 1
- 4 ATOM0
- 5 SETGLOBAL T021-pushconst1
- 7 STOP
-**)
diff --git a/test/testinterp/t021-pushconst2.ml b/test/testinterp/t021-pushconst2.ml
deleted file mode 100644
index 17adb5075b..0000000000
--- a/test/testinterp/t021-pushconst2.ml
+++ /dev/null
@@ -1,10 +0,0 @@
-let _ = () in 2;;
-
-(**
- 0 CONST0
- 1 PUSHCONST2
- 2 POP 1
- 4 ATOM0
- 5 SETGLOBAL T021-pushconst2
- 7 STOP
-**)
diff --git a/test/testinterp/t021-pushconst3.ml b/test/testinterp/t021-pushconst3.ml
deleted file mode 100644
index 563c609324..0000000000
--- a/test/testinterp/t021-pushconst3.ml
+++ /dev/null
@@ -1,10 +0,0 @@
-let _ = () in 3;;
-
-(**
- 0 CONST0
- 1 PUSHCONST3
- 2 POP 1
- 4 ATOM0
- 5 SETGLOBAL T021-pushconst3
- 7 STOP
-**)
diff --git a/test/testinterp/t022-pushconstint.ml b/test/testinterp/t022-pushconstint.ml
deleted file mode 100644
index 1b766a5723..0000000000
--- a/test/testinterp/t022-pushconstint.ml
+++ /dev/null
@@ -1,10 +0,0 @@
-let _ = () in -1;;
-
-(**
- 0 CONST0
- 1 PUSHCONSTINT -1
- 3 POP 1
- 5 ATOM0
- 6 SETGLOBAL T022-pushconstint
- 8 STOP
-**)
diff --git a/test/testinterp/t040-makeblock1.ml b/test/testinterp/t040-makeblock1.ml
deleted file mode 100644
index 71516606b6..0000000000
--- a/test/testinterp/t040-makeblock1.ml
+++ /dev/null
@@ -1,13 +0,0 @@
-type t = {
- mutable a : int;
-};;
-
-{ a = 0 };;
-
-(**
- 0 CONST0
- 1 MAKEBLOCK1 0
- 3 ATOM0
- 4 SETGLOBAL T040-makeblock1
- 6 STOP
-**)
diff --git a/test/testinterp/t040-makeblock2.ml b/test/testinterp/t040-makeblock2.ml
deleted file mode 100644
index e7c745b9c2..0000000000
--- a/test/testinterp/t040-makeblock2.ml
+++ /dev/null
@@ -1,15 +0,0 @@
-type t = {
- mutable a : int;
- mutable b : int;
-};;
-
-{ a = 0; b = 0 };;
-
-(**
- 0 CONST0
- 1 PUSHCONST0
- 2 MAKEBLOCK2 0
- 4 ATOM0
- 5 SETGLOBAL T040-makeblock2
- 7 STOP
-**)
diff --git a/test/testinterp/t040-makeblock3.ml b/test/testinterp/t040-makeblock3.ml
deleted file mode 100644
index 8fb56054e3..0000000000
--- a/test/testinterp/t040-makeblock3.ml
+++ /dev/null
@@ -1,17 +0,0 @@
-type t = {
- mutable a : int;
- mutable b : int;
- mutable c : int;
-};;
-
-{ a = 0; b = 0; c = 0 };;
-
-(**
- 0 CONST0
- 1 PUSHCONST0
- 2 PUSHCONST0
- 3 MAKEBLOCK3 0
- 5 ATOM0
- 6 SETGLOBAL T040-makeblock3
- 8 STOP
-**)
diff --git a/test/testinterp/t041-makeblock.ml b/test/testinterp/t041-makeblock.ml
deleted file mode 100644
index 5ae255d6ee..0000000000
--- a/test/testinterp/t041-makeblock.ml
+++ /dev/null
@@ -1,19 +0,0 @@
-type t = {
- mutable a : int;
- mutable b : int;
- mutable c : int;
- mutable d : int;
-};;
-
-{ a = 0; b = 0; c = 0; d = 0 };;
-
-(**
- 0 CONST0
- 1 PUSHCONST0
- 2 PUSHCONST0
- 3 PUSHCONST0
- 4 MAKEBLOCK 4, 0
- 7 ATOM0
- 8 SETGLOBAL T041-makeblock
- 10 STOP
-**)
diff --git a/test/testinterp/t050-getglobal.ml b/test/testinterp/t050-getglobal.ml
deleted file mode 100644
index f10393cf62..0000000000
--- a/test/testinterp/t050-getglobal.ml
+++ /dev/null
@@ -1,8 +0,0 @@
-[1];;
-
-(**
- 0 GETGLOBAL <0>(1, 0)
- 2 ATOM0
- 3 SETGLOBAL T050-getglobal
- 5 STOP
-**)
diff --git a/test/testinterp/t050-pushgetglobal.ml b/test/testinterp/t050-pushgetglobal.ml
deleted file mode 100644
index e1172cc350..0000000000
--- a/test/testinterp/t050-pushgetglobal.ml
+++ /dev/null
@@ -1,10 +0,0 @@
-let _ = () in 0.01;;
-
-(**
- 0 CONST0
- 1 PUSHGETGLOBAL 0.01
- 3 POP 1
- 5 ATOM0
- 6 SETGLOBAL T050-pushgetglobal
- 8 STOP
-**)
diff --git a/test/testinterp/t051-getglobalfield.ml b/test/testinterp/t051-getglobalfield.ml
deleted file mode 100644
index 45d9ccea22..0000000000
--- a/test/testinterp/t051-getglobalfield.ml
+++ /dev/null
@@ -1,13 +0,0 @@
-Lib.x;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 GETGLOBALFIELD Lib, 0
- 12 ATOM0
- 13 SETGLOBAL T051-getglobalfield
- 15 STOP
-**)
diff --git a/test/testinterp/t051-pushgetglobalfield.ml b/test/testinterp/t051-pushgetglobalfield.ml
deleted file mode 100644
index 2012a2573d..0000000000
--- a/test/testinterp/t051-pushgetglobalfield.ml
+++ /dev/null
@@ -1,15 +0,0 @@
-let _ = () in Lib.x;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST0
- 10 PUSHGETGLOBALFIELD Lib, 0
- 13 POP 1
- 15 ATOM0
- 16 SETGLOBAL T051-pushgetglobalfield
- 18 STOP
-**)
diff --git a/test/testinterp/t060-raise.ml b/test/testinterp/t060-raise.ml
deleted file mode 100644
index 1aa484667a..0000000000
--- a/test/testinterp/t060-raise.ml
+++ /dev/null
@@ -1,15 +0,0 @@
-open Lib;;
-raise End_of_file;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 GETGLOBAL End_of_file
- 11 MAKEBLOCK1 0
- 13 RAISE
- 14 SETGLOBAL T060-raise
- 16 STOP
-**)
diff --git a/test/testinterp/t070-branch.ml b/test/testinterp/t070-branch.ml
deleted file mode 100644
index 4fc52d426b..0000000000
--- a/test/testinterp/t070-branch.ml
+++ /dev/null
@@ -1,20 +0,0 @@
-open Lib;;
-if true then 0 else raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST1
- 10 BRANCHIFNOT 15
- 12 CONST0
- 13 BRANCH 20
- 15 GETGLOBAL Not_found
- 17 MAKEBLOCK1 0
- 19 RAISE
- 20 ATOM0
- 21 SETGLOBAL T070-branch
- 23 STOP
-**)
diff --git a/test/testinterp/t070-branchif.ml b/test/testinterp/t070-branchif.ml
deleted file mode 100644
index c256248c80..0000000000
--- a/test/testinterp/t070-branchif.ml
+++ /dev/null
@@ -1,20 +0,0 @@
-open Lib;;
-if not false then 0 else raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST0
- 10 BRANCHIF 15
- 12 CONST0
- 13 BRANCH 20
- 15 GETGLOBAL Not_found
- 17 MAKEBLOCK1 0
- 19 RAISE
- 20 ATOM0
- 21 SETGLOBAL T070-branchif
- 23 STOP
-**)
diff --git a/test/testinterp/t070-branchifnot.ml b/test/testinterp/t070-branchifnot.ml
deleted file mode 100644
index 9e6e4e8ba3..0000000000
--- a/test/testinterp/t070-branchifnot.ml
+++ /dev/null
@@ -1,18 +0,0 @@
-open Lib;;
-if false then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST0
- 10 BRANCHIFNOT 17
- 12 GETGLOBAL Not_found
- 14 MAKEBLOCK1 0
- 16 RAISE
- 17 ATOM0
- 18 SETGLOBAL T070-branchifnot
- 20 STOP
-**)
diff --git a/test/testinterp/t071-boolnot.ml b/test/testinterp/t071-boolnot.ml
deleted file mode 100644
index b4a81943c6..0000000000
--- a/test/testinterp/t071-boolnot.ml
+++ /dev/null
@@ -1,19 +0,0 @@
-open Lib;;
-if not true then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST1
- 10 BOOLNOT
- 11 BRANCHIFNOT 18
- 13 GETGLOBAL Not_found
- 15 MAKEBLOCK1 0
- 17 RAISE
- 18 ATOM0
- 19 SETGLOBAL T071-boolnot
- 21 STOP
-**)
diff --git a/test/testinterp/t080-eq.ml b/test/testinterp/t080-eq.ml
deleted file mode 100644
index 3ee735f088..0000000000
--- a/test/testinterp/t080-eq.ml
+++ /dev/null
@@ -1,21 +0,0 @@
-open Lib;;
-if not (0 = 0) then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST0
- 10 PUSHCONST0
- 11 EQ
- 12 BOOLNOT
- 13 BRANCHIFNOT 20
- 15 GETGLOBAL Not_found
- 17 MAKEBLOCK1 0
- 19 RAISE
- 20 ATOM0
- 21 SETGLOBAL T080-eq
- 23 STOP
-**)
diff --git a/test/testinterp/t080-geint.ml b/test/testinterp/t080-geint.ml
deleted file mode 100644
index a220b7e9a4..0000000000
--- a/test/testinterp/t080-geint.ml
+++ /dev/null
@@ -1,21 +0,0 @@
-open Lib;;
-if not (0 >= 0) then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST0
- 10 PUSHCONST0
- 11 GEINT
- 12 BOOLNOT
- 13 BRANCHIFNOT 20
- 15 GETGLOBAL Not_found
- 17 MAKEBLOCK1 0
- 19 RAISE
- 20 ATOM0
- 21 SETGLOBAL T080-geint
- 23 STOP
-**)
diff --git a/test/testinterp/t080-gtint.ml b/test/testinterp/t080-gtint.ml
deleted file mode 100644
index 32d573217f..0000000000
--- a/test/testinterp/t080-gtint.ml
+++ /dev/null
@@ -1,20 +0,0 @@
-open Lib;;
-if 0 > 0 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST0
- 10 PUSHCONST0
- 11 GTINT
- 12 BRANCHIFNOT 19
- 14 GETGLOBAL Not_found
- 16 MAKEBLOCK1 0
- 18 RAISE
- 19 ATOM0
- 20 SETGLOBAL T080-gtint
- 22 STOP
-**)
diff --git a/test/testinterp/t080-leint.ml b/test/testinterp/t080-leint.ml
deleted file mode 100644
index cc983a0836..0000000000
--- a/test/testinterp/t080-leint.ml
+++ /dev/null
@@ -1,21 +0,0 @@
-open Lib;;
-if not (0 <= 0) then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST0
- 10 PUSHCONST0
- 11 LEINT
- 12 BOOLNOT
- 13 BRANCHIFNOT 20
- 15 GETGLOBAL Not_found
- 17 MAKEBLOCK1 0
- 19 RAISE
- 20 ATOM0
- 21 SETGLOBAL T080-leint
- 23 STOP
-**)
diff --git a/test/testinterp/t080-ltint.ml b/test/testinterp/t080-ltint.ml
deleted file mode 100644
index ae7d240ae8..0000000000
--- a/test/testinterp/t080-ltint.ml
+++ /dev/null
@@ -1,20 +0,0 @@
-open Lib;;
-if 0 < 0 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST0
- 10 PUSHCONST0
- 11 LTINT
- 12 BRANCHIFNOT 19
- 14 GETGLOBAL Not_found
- 16 MAKEBLOCK1 0
- 18 RAISE
- 19 ATOM0
- 20 SETGLOBAL T080-ltint
- 22 STOP
-**)
diff --git a/test/testinterp/t080-neq.ml b/test/testinterp/t080-neq.ml
deleted file mode 100644
index 5066e9cbcc..0000000000
--- a/test/testinterp/t080-neq.ml
+++ /dev/null
@@ -1,20 +0,0 @@
-open Lib;;
-if 0 <> 0 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST0
- 10 PUSHCONST0
- 11 NEQ
- 12 BRANCHIFNOT 19
- 14 GETGLOBAL Not_found
- 16 MAKEBLOCK1 0
- 18 RAISE
- 19 ATOM0
- 20 SETGLOBAL T080-neq
- 22 STOP
-**)
diff --git a/test/testinterp/t090-acc0.ml b/test/testinterp/t090-acc0.ml
deleted file mode 100644
index 74accecad4..0000000000
--- a/test/testinterp/t090-acc0.ml
+++ /dev/null
@@ -1,25 +0,0 @@
-open Lib;;
-let x = true in
-();
-if not x then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST1
- 10 PUSHCONST0
- 11 ACC0
- 12 BOOLNOT
- 13 BRANCHIFNOT 20
- 15 GETGLOBAL Not_found
- 17 MAKEBLOCK1 0
- 19 RAISE
- 20 POP 1
- 22 ATOM0
- 23 SETGLOBAL T090-acc0
- 25 STOP
-**)
diff --git a/test/testinterp/t090-acc1.ml b/test/testinterp/t090-acc1.ml
deleted file mode 100644
index fc9b0254dd..0000000000
--- a/test/testinterp/t090-acc1.ml
+++ /dev/null
@@ -1,27 +0,0 @@
-open Lib;;
-let x = true in
-let y = false in
-();
-if not x then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST1
- 10 PUSHCONST0
- 11 PUSHCONST0
- 12 ACC1
- 13 BOOLNOT
- 14 BRANCHIFNOT 21
- 16 GETGLOBAL Not_found
- 18 MAKEBLOCK1 0
- 20 RAISE
- 21 POP 2
- 23 ATOM0
- 24 SETGLOBAL T090-acc1
- 26 STOP
-**)
diff --git a/test/testinterp/t090-acc2.ml b/test/testinterp/t090-acc2.ml
deleted file mode 100644
index 4865944938..0000000000
--- a/test/testinterp/t090-acc2.ml
+++ /dev/null
@@ -1,29 +0,0 @@
-open Lib;;
-let x = true in
-let y = false in
-let z = false in
-();
-if not x then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST1
- 10 PUSHCONST0
- 11 PUSHCONST0
- 12 PUSHCONST0
- 13 ACC2
- 14 BOOLNOT
- 15 BRANCHIFNOT 22
- 17 GETGLOBAL Not_found
- 19 MAKEBLOCK1 0
- 21 RAISE
- 22 POP 3
- 24 ATOM0
- 25 SETGLOBAL T090-acc2
- 27 STOP
-**)
diff --git a/test/testinterp/t090-acc3.ml b/test/testinterp/t090-acc3.ml
deleted file mode 100644
index 9622456a64..0000000000
--- a/test/testinterp/t090-acc3.ml
+++ /dev/null
@@ -1,31 +0,0 @@
-open Lib;;
-let x = true in
-let y = false in
-let z = false in
-let a = false in
-();
-if not x then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST1
- 10 PUSHCONST0
- 11 PUSHCONST0
- 12 PUSHCONST0
- 13 PUSHCONST0
- 14 ACC3
- 15 BOOLNOT
- 16 BRANCHIFNOT 23
- 18 GETGLOBAL Not_found
- 20 MAKEBLOCK1 0
- 22 RAISE
- 23 POP 4
- 25 ATOM0
- 26 SETGLOBAL T090-acc3
- 28 STOP
-**)
diff --git a/test/testinterp/t090-acc4.ml b/test/testinterp/t090-acc4.ml
deleted file mode 100644
index 992559b7da..0000000000
--- a/test/testinterp/t090-acc4.ml
+++ /dev/null
@@ -1,33 +0,0 @@
-open Lib;;
-let x = true in
-let y = false in
-let z = false in
-let a = false in
-let b = false in
-();
-if not x then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST1
- 10 PUSHCONST0
- 11 PUSHCONST0
- 12 PUSHCONST0
- 13 PUSHCONST0
- 14 PUSHCONST0
- 15 ACC4
- 16 BOOLNOT
- 17 BRANCHIFNOT 24
- 19 GETGLOBAL Not_found
- 21 MAKEBLOCK1 0
- 23 RAISE
- 24 POP 5
- 26 ATOM0
- 27 SETGLOBAL T090-acc4
- 29 STOP
-**)
diff --git a/test/testinterp/t090-acc5.ml b/test/testinterp/t090-acc5.ml
deleted file mode 100644
index 57f7453b1e..0000000000
--- a/test/testinterp/t090-acc5.ml
+++ /dev/null
@@ -1,35 +0,0 @@
-open Lib;;
-let x = true in
-let y = false in
-let z = false in
-let a = false in
-let b = false in
-let c = false in
-();
-if not x then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST1
- 10 PUSHCONST0
- 11 PUSHCONST0
- 12 PUSHCONST0
- 13 PUSHCONST0
- 14 PUSHCONST0
- 15 PUSHCONST0
- 16 ACC5
- 17 BOOLNOT
- 18 BRANCHIFNOT 25
- 20 GETGLOBAL Not_found
- 22 MAKEBLOCK1 0
- 24 RAISE
- 25 POP 6
- 27 ATOM0
- 28 SETGLOBAL T090-acc5
- 30 STOP
-**)
diff --git a/test/testinterp/t090-acc6.ml b/test/testinterp/t090-acc6.ml
deleted file mode 100644
index f9400282ea..0000000000
--- a/test/testinterp/t090-acc6.ml
+++ /dev/null
@@ -1,37 +0,0 @@
-open Lib;;
-let x = true in
-let y = false in
-let z = false in
-let a = false in
-let b = false in
-let c = false in
-let d = false in
-();
-if not x then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST1
- 10 PUSHCONST0
- 11 PUSHCONST0
- 12 PUSHCONST0
- 13 PUSHCONST0
- 14 PUSHCONST0
- 15 PUSHCONST0
- 16 PUSHCONST0
- 17 ACC6
- 18 BOOLNOT
- 19 BRANCHIFNOT 26
- 21 GETGLOBAL Not_found
- 23 MAKEBLOCK1 0
- 25 RAISE
- 26 POP 7
- 28 ATOM0
- 29 SETGLOBAL T090-acc6
- 31 STOP
-**)
diff --git a/test/testinterp/t090-acc7.ml b/test/testinterp/t090-acc7.ml
deleted file mode 100644
index 366191bf14..0000000000
--- a/test/testinterp/t090-acc7.ml
+++ /dev/null
@@ -1,39 +0,0 @@
-open Lib;;
-let x = true in
-let y = false in
-let z = false in
-let a = false in
-let b = false in
-let c = false in
-let d = false in
-let e = false in
-();
-if not x then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST1
- 10 PUSHCONST0
- 11 PUSHCONST0
- 12 PUSHCONST0
- 13 PUSHCONST0
- 14 PUSHCONST0
- 15 PUSHCONST0
- 16 PUSHCONST0
- 17 PUSHCONST0
- 18 ACC7
- 19 BOOLNOT
- 20 BRANCHIFNOT 27
- 22 GETGLOBAL Not_found
- 24 MAKEBLOCK1 0
- 26 RAISE
- 27 POP 8
- 29 ATOM0
- 30 SETGLOBAL T090-acc7
- 32 STOP
-**)
diff --git a/test/testinterp/t091-acc.ml b/test/testinterp/t091-acc.ml
deleted file mode 100644
index 26b003f668..0000000000
--- a/test/testinterp/t091-acc.ml
+++ /dev/null
@@ -1,41 +0,0 @@
-open Lib;;
-let x = true in
-let y = false in
-let z = false in
-let a = false in
-let b = false in
-let c = false in
-let d = false in
-let e = false in
-let f = false in
-();
-if not x then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST1
- 10 PUSHCONST0
- 11 PUSHCONST0
- 12 PUSHCONST0
- 13 PUSHCONST0
- 14 PUSHCONST0
- 15 PUSHCONST0
- 16 PUSHCONST0
- 17 PUSHCONST0
- 18 PUSHCONST0
- 19 ACC 8
- 21 BOOLNOT
- 22 BRANCHIFNOT 29
- 24 GETGLOBAL Not_found
- 26 MAKEBLOCK1 0
- 28 RAISE
- 29 POP 9
- 31 ATOM0
- 32 SETGLOBAL T091-acc
- 34 STOP
-**)
diff --git a/test/testinterp/t092-pushacc.ml b/test/testinterp/t092-pushacc.ml
deleted file mode 100644
index c21561ec04..0000000000
--- a/test/testinterp/t092-pushacc.ml
+++ /dev/null
@@ -1,38 +0,0 @@
-open Lib;;
-let x = false in
-let y = true in
-let z = true in
-let a = true in
-let b = true in
-let c = true in
-let d = true in
-let e = true in
-let f = true in
-if x then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST0
- 10 PUSHCONST1
- 11 PUSHCONST1
- 12 PUSHCONST1
- 13 PUSHCONST1
- 14 PUSHCONST1
- 15 PUSHCONST1
- 16 PUSHCONST1
- 17 PUSHCONST1
- 18 PUSHACC 8
- 20 BRANCHIFNOT 27
- 22 GETGLOBAL Not_found
- 24 MAKEBLOCK1 0
- 26 RAISE
- 27 POP 9
- 29 ATOM0
- 30 SETGLOBAL T092-pushacc
- 32 STOP
-**)
diff --git a/test/testinterp/t092-pushacc0.ml b/test/testinterp/t092-pushacc0.ml
deleted file mode 100644
index ffdc3b0404..0000000000
--- a/test/testinterp/t092-pushacc0.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-open Lib;;
-let x = false in
-if x then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST0
- 10 PUSHACC0
- 11 BRANCHIFNOT 18
- 13 GETGLOBAL Not_found
- 15 MAKEBLOCK1 0
- 17 RAISE
- 18 POP 1
- 20 ATOM0
- 21 SETGLOBAL T092-pushacc0
- 23 STOP
-**)
diff --git a/test/testinterp/t092-pushacc1.ml b/test/testinterp/t092-pushacc1.ml
deleted file mode 100644
index b923f4fc8c..0000000000
--- a/test/testinterp/t092-pushacc1.ml
+++ /dev/null
@@ -1,24 +0,0 @@
-open Lib;;
-let x = false in
-let y = true in
-if x then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST0
- 10 PUSHCONST1
- 11 PUSHACC1
- 12 BRANCHIFNOT 19
- 14 GETGLOBAL Not_found
- 16 MAKEBLOCK1 0
- 18 RAISE
- 19 POP 2
- 21 ATOM0
- 22 SETGLOBAL T092-pushacc1
- 24 STOP
-**)
diff --git a/test/testinterp/t092-pushacc2.ml b/test/testinterp/t092-pushacc2.ml
deleted file mode 100644
index f6249783ab..0000000000
--- a/test/testinterp/t092-pushacc2.ml
+++ /dev/null
@@ -1,26 +0,0 @@
-open Lib;;
-let x = false in
-let y = true in
-let z = true in
-if x then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST0
- 10 PUSHCONST1
- 11 PUSHCONST1
- 12 PUSHACC2
- 13 BRANCHIFNOT 20
- 15 GETGLOBAL Not_found
- 17 MAKEBLOCK1 0
- 19 RAISE
- 20 POP 3
- 22 ATOM0
- 23 SETGLOBAL T092-pushacc2
- 25 STOP
-**)
diff --git a/test/testinterp/t092-pushacc3.ml b/test/testinterp/t092-pushacc3.ml
deleted file mode 100644
index 5984fec733..0000000000
--- a/test/testinterp/t092-pushacc3.ml
+++ /dev/null
@@ -1,28 +0,0 @@
-open Lib;;
-let x = false in
-let y = true in
-let z = true in
-let a = true in
-if x then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST0
- 10 PUSHCONST1
- 11 PUSHCONST1
- 12 PUSHCONST1
- 13 PUSHACC3
- 14 BRANCHIFNOT 21
- 16 GETGLOBAL Not_found
- 18 MAKEBLOCK1 0
- 20 RAISE
- 21 POP 4
- 23 ATOM0
- 24 SETGLOBAL T092-pushacc3
- 26 STOP
-**)
diff --git a/test/testinterp/t092-pushacc4.ml b/test/testinterp/t092-pushacc4.ml
deleted file mode 100644
index ce20e0b9de..0000000000
--- a/test/testinterp/t092-pushacc4.ml
+++ /dev/null
@@ -1,30 +0,0 @@
-open Lib;;
-let x = false in
-let y = true in
-let z = true in
-let a = true in
-let b = true in
-if x then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST0
- 10 PUSHCONST1
- 11 PUSHCONST1
- 12 PUSHCONST1
- 13 PUSHCONST1
- 14 PUSHACC4
- 15 BRANCHIFNOT 22
- 17 GETGLOBAL Not_found
- 19 MAKEBLOCK1 0
- 21 RAISE
- 22 POP 5
- 24 ATOM0
- 25 SETGLOBAL T092-pushacc4
- 27 STOP
-**)
diff --git a/test/testinterp/t092-pushacc5.ml b/test/testinterp/t092-pushacc5.ml
deleted file mode 100644
index 030f3f04b0..0000000000
--- a/test/testinterp/t092-pushacc5.ml
+++ /dev/null
@@ -1,32 +0,0 @@
-open Lib;;
-let x = false in
-let y = true in
-let z = true in
-let a = true in
-let b = true in
-let c = true in
-if x then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST0
- 10 PUSHCONST1
- 11 PUSHCONST1
- 12 PUSHCONST1
- 13 PUSHCONST1
- 14 PUSHCONST1
- 15 PUSHACC5
- 16 BRANCHIFNOT 23
- 18 GETGLOBAL Not_found
- 20 MAKEBLOCK1 0
- 22 RAISE
- 23 POP 6
- 25 ATOM0
- 26 SETGLOBAL T092-pushacc5
- 28 STOP
-**)
diff --git a/test/testinterp/t092-pushacc6.ml b/test/testinterp/t092-pushacc6.ml
deleted file mode 100644
index 9c67b808e4..0000000000
--- a/test/testinterp/t092-pushacc6.ml
+++ /dev/null
@@ -1,34 +0,0 @@
-open Lib;;
-let x = false in
-let y = true in
-let z = true in
-let a = true in
-let b = true in
-let c = true in
-let d = true in
-if x then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST0
- 10 PUSHCONST1
- 11 PUSHCONST1
- 12 PUSHCONST1
- 13 PUSHCONST1
- 14 PUSHCONST1
- 15 PUSHCONST1
- 16 PUSHACC6
- 17 BRANCHIFNOT 24
- 19 GETGLOBAL Not_found
- 21 MAKEBLOCK1 0
- 23 RAISE
- 24 POP 7
- 26 ATOM0
- 27 SETGLOBAL T092-pushacc6
- 29 STOP
-**)
diff --git a/test/testinterp/t092-pushacc7.ml b/test/testinterp/t092-pushacc7.ml
deleted file mode 100644
index 09fbbcaff0..0000000000
--- a/test/testinterp/t092-pushacc7.ml
+++ /dev/null
@@ -1,36 +0,0 @@
-open Lib;;
-let x = false in
-let y = true in
-let z = true in
-let a = true in
-let b = true in
-let c = true in
-let d = true in
-let e = true in
-if x then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST0
- 10 PUSHCONST1
- 11 PUSHCONST1
- 12 PUSHCONST1
- 13 PUSHCONST1
- 14 PUSHCONST1
- 15 PUSHCONST1
- 16 PUSHCONST1
- 17 PUSHACC7
- 18 BRANCHIFNOT 25
- 20 GETGLOBAL Not_found
- 22 MAKEBLOCK1 0
- 24 RAISE
- 25 POP 8
- 27 ATOM0
- 28 SETGLOBAL T092-pushacc7
- 30 STOP
-**)
diff --git a/test/testinterp/t093-pushacc.ml b/test/testinterp/t093-pushacc.ml
deleted file mode 100644
index 00a969adbe..0000000000
--- a/test/testinterp/t093-pushacc.ml
+++ /dev/null
@@ -1,38 +0,0 @@
-open Lib;;
-let x = false in
-let y = true in
-let z = true in
-let a = true in
-let b = true in
-let c = true in
-let d = true in
-let e = true in
-let f = true in
-if x then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST0
- 10 PUSHCONST1
- 11 PUSHCONST1
- 12 PUSHCONST1
- 13 PUSHCONST1
- 14 PUSHCONST1
- 15 PUSHCONST1
- 16 PUSHCONST1
- 17 PUSHCONST1
- 18 PUSHACC 8
- 20 BRANCHIFNOT 27
- 22 GETGLOBAL Not_found
- 24 MAKEBLOCK1 0
- 26 RAISE
- 27 POP 9
- 29 ATOM0
- 30 SETGLOBAL T093-pushacc
- 32 STOP
-**)
diff --git a/test/testinterp/t100-pushtrap.ml b/test/testinterp/t100-pushtrap.ml
deleted file mode 100644
index 7b02a86276..0000000000
--- a/test/testinterp/t100-pushtrap.ml
+++ /dev/null
@@ -1,21 +0,0 @@
-open Lib;;
-try raise Not_found
-with _ -> ()
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 PUSHTRAP 16
- 11 GETGLOBAL Not_found
- 13 MAKEBLOCK1 0
- 15 RAISE
- 16 PUSHCONST0
- 17 POP 1
- 19 ATOM0
- 20 SETGLOBAL T100-pushtrap
- 22 STOP
-**)
diff --git a/test/testinterp/t101-poptrap.ml b/test/testinterp/t101-poptrap.ml
deleted file mode 100644
index 3a754a06fb..0000000000
--- a/test/testinterp/t101-poptrap.ml
+++ /dev/null
@@ -1,21 +0,0 @@
-open Lib;;
-try ()
-with _ -> ()
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 PUSHTRAP 15
- 11 CONST0
- 12 POPTRAP
- 13 BRANCH 18
- 15 PUSHCONST0
- 16 POP 1
- 18 ATOM0
- 19 SETGLOBAL T101-poptrap
- 21 STOP
-**)
diff --git a/test/testinterp/t110-addint.ml b/test/testinterp/t110-addint.ml
deleted file mode 100644
index 5d683c5735..0000000000
--- a/test/testinterp/t110-addint.ml
+++ /dev/null
@@ -1,26 +0,0 @@
-open Lib;;
-let x = 1 in
-if 1 + x <> 2 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST1
- 10 PUSHCONST2
- 11 PUSHACC1
- 12 PUSHCONST1
- 13 ADDINT
- 14 NEQ
- 15 BRANCHIFNOT 22
- 17 GETGLOBAL Not_found
- 19 MAKEBLOCK1 0
- 21 RAISE
- 22 POP 1
- 24 ATOM0
- 25 SETGLOBAL T110-addint
- 27 STOP
-**)
diff --git a/test/testinterp/t110-andint.ml b/test/testinterp/t110-andint.ml
deleted file mode 100644
index 016dc3cddd..0000000000
--- a/test/testinterp/t110-andint.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-open Lib;;
-if (3 land 6) <> 2 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST2
- 10 PUSHCONSTINT 6
- 12 PUSHCONST3
- 13 ANDINT
- 14 NEQ
- 15 BRANCHIFNOT 22
- 17 GETGLOBAL Not_found
- 19 MAKEBLOCK1 0
- 21 RAISE
- 22 ATOM0
- 23 SETGLOBAL T110-andint
- 25 STOP
-**)
diff --git a/test/testinterp/t110-asrint-1.ml b/test/testinterp/t110-asrint-1.ml
deleted file mode 100644
index 173bdca29d..0000000000
--- a/test/testinterp/t110-asrint-1.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-open Lib;;
-if (-2 asr 1) <> -1 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONSTINT -1
- 11 PUSHCONST1
- 12 PUSHCONSTINT -2
- 14 ASRINT
- 15 NEQ
- 16 BRANCHIFNOT 23
- 18 GETGLOBAL Not_found
- 20 MAKEBLOCK1 0
- 22 RAISE
- 23 ATOM0
- 24 SETGLOBAL T110-asrint-1
- 26 STOP
-**)
diff --git a/test/testinterp/t110-asrint-2.ml b/test/testinterp/t110-asrint-2.ml
deleted file mode 100644
index 386fc64cf8..0000000000
--- a/test/testinterp/t110-asrint-2.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-open Lib;;
-if (3 asr 1) <> 1 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST1
- 10 PUSHCONST1
- 11 PUSHCONST3
- 12 ASRINT
- 13 NEQ
- 14 BRANCHIFNOT 21
- 16 GETGLOBAL Not_found
- 18 MAKEBLOCK1 0
- 20 RAISE
- 21 ATOM0
- 22 SETGLOBAL T110-asrint-2
- 24 STOP
-**)
diff --git a/test/testinterp/t110-divint-1.ml b/test/testinterp/t110-divint-1.ml
deleted file mode 100644
index 5cde135d24..0000000000
--- a/test/testinterp/t110-divint-1.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-open Lib;;
-if 2 / 2 <> 1 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST1
- 10 PUSHCONST2
- 11 PUSHCONST2
- 12 DIVINT
- 13 NEQ
- 14 BRANCHIFNOT 21
- 16 GETGLOBAL Not_found
- 18 MAKEBLOCK1 0
- 20 RAISE
- 21 ATOM0
- 22 SETGLOBAL T110-divint-1
- 24 STOP
-**)
diff --git a/test/testinterp/t110-divint-2.ml b/test/testinterp/t110-divint-2.ml
deleted file mode 100644
index 34f5b00c66..0000000000
--- a/test/testinterp/t110-divint-2.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-open Lib;;
-if 3 / 2 <> 1 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST1
- 10 PUSHCONST2
- 11 PUSHCONST3
- 12 DIVINT
- 13 NEQ
- 14 BRANCHIFNOT 21
- 16 GETGLOBAL Not_found
- 18 MAKEBLOCK1 0
- 20 RAISE
- 21 ATOM0
- 22 SETGLOBAL T110-divint-2
- 24 STOP
-**)
diff --git a/test/testinterp/t110-divint-3.ml b/test/testinterp/t110-divint-3.ml
deleted file mode 100644
index cbb2bff1f5..0000000000
--- a/test/testinterp/t110-divint-3.ml
+++ /dev/null
@@ -1,33 +0,0 @@
-open Lib;;
-try
- ignore (3 / 0);
- raise Not_found;
-with Division_by_zero -> ()
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 PUSHTRAP 19
- 11 CONST0
- 12 PUSHCONST3
- 13 DIVINT
- 14 GETGLOBAL Not_found
- 16 MAKEBLOCK1 0
- 18 RAISE
- 19 PUSHGETGLOBAL Division_by_zero
- 21 PUSHACC1
- 22 GETFIELD0
- 23 EQ
- 24 BRANCHIFNOT 29
- 26 CONST0
- 27 BRANCH 31
- 29 ACC0
- 30 RAISE
- 31 POP 1
- 33 ATOM0
- 34 SETGLOBAL T110-divint-3
- 36 STOP
-**)
diff --git a/test/testinterp/t110-lslint.ml b/test/testinterp/t110-lslint.ml
deleted file mode 100644
index 9dd197b467..0000000000
--- a/test/testinterp/t110-lslint.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-open Lib;;
-if (3 lsl 2) <> 12 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONSTINT 12
- 11 PUSHCONST2
- 12 PUSHCONST3
- 13 LSLINT
- 14 NEQ
- 15 BRANCHIFNOT 22
- 17 GETGLOBAL Not_found
- 19 MAKEBLOCK1 0
- 21 RAISE
- 22 ATOM0
- 23 SETGLOBAL T110-lslint
- 25 STOP
-**)
diff --git a/test/testinterp/t110-lsrint.ml b/test/testinterp/t110-lsrint.ml
deleted file mode 100644
index 9777815ccc..0000000000
--- a/test/testinterp/t110-lsrint.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-open Lib;;
-if (14 lsr 2) <> 3 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST3
- 10 PUSHCONST2
- 11 PUSHCONSTINT 14
- 13 LSRINT
- 14 NEQ
- 15 BRANCHIFNOT 22
- 17 GETGLOBAL Not_found
- 19 MAKEBLOCK1 0
- 21 RAISE
- 22 ATOM0
- 23 SETGLOBAL T110-lsrint
- 25 STOP
-**)
diff --git a/test/testinterp/t110-modint-1.ml b/test/testinterp/t110-modint-1.ml
deleted file mode 100644
index 2a690c0896..0000000000
--- a/test/testinterp/t110-modint-1.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-open Lib;;
-if 20 mod 3 <> 2 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST2
- 10 PUSHCONST3
- 11 PUSHCONSTINT 20
- 13 MODINT
- 14 NEQ
- 15 BRANCHIFNOT 22
- 17 GETGLOBAL Not_found
- 19 MAKEBLOCK1 0
- 21 RAISE
- 22 ATOM0
- 23 SETGLOBAL T110-modint-1
- 25 STOP
-**)
diff --git a/test/testinterp/t110-modint-2.ml b/test/testinterp/t110-modint-2.ml
deleted file mode 100644
index 0bc3be0c3c..0000000000
--- a/test/testinterp/t110-modint-2.ml
+++ /dev/null
@@ -1,34 +0,0 @@
-open Lib;;
-try
- ignore (2 mod 0);
- raise Not_found;
-with Division_by_zero -> ()
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 PUSHTRAP 19
- 11 CONST0
- 12 PUSHCONST2
- 13 MODINT
- 14 GETGLOBAL Not_found
- 16 MAKEBLOCK1 0
- 18 RAISE
- 19 PUSHGETGLOBAL Division_by_zero
- 21 PUSHACC1
- 22 GETFIELD0
- 23 EQ
- 24 BRANCHIFNOT 29
- 26 CONST0
- 27 BRANCH 31
- 29 ACC0
- 30 RAISE
- 31 POP 1
- 33 ATOM0
- 34 SETGLOBAL T110-modint-2
- 36 STOP
-**)
diff --git a/test/testinterp/t110-mulint.ml b/test/testinterp/t110-mulint.ml
deleted file mode 100644
index 97c1cf1413..0000000000
--- a/test/testinterp/t110-mulint.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-open Lib;;
-if 2 * 2 <> 4 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONSTINT 4
- 11 PUSHCONST2
- 12 PUSHCONST2
- 13 MULINT
- 14 NEQ
- 15 BRANCHIFNOT 22
- 17 GETGLOBAL Not_found
- 19 MAKEBLOCK1 0
- 21 RAISE
- 22 ATOM0
- 23 SETGLOBAL T110-mulint
- 25 STOP
-**)
diff --git a/test/testinterp/t110-negint.ml b/test/testinterp/t110-negint.ml
deleted file mode 100644
index 069a34b200..0000000000
--- a/test/testinterp/t110-negint.ml
+++ /dev/null
@@ -1,25 +0,0 @@
-open Lib;;
-let x = 1 in
-if -x <> -1 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST1
- 10 PUSHCONSTINT -1
- 12 PUSHACC1
- 13 NEGINT
- 14 NEQ
- 15 BRANCHIFNOT 22
- 17 GETGLOBAL Not_found
- 19 MAKEBLOCK1 0
- 21 RAISE
- 22 POP 1
- 24 ATOM0
- 25 SETGLOBAL T110-negint
- 27 STOP
-**)
diff --git a/test/testinterp/t110-offsetint.ml b/test/testinterp/t110-offsetint.ml
deleted file mode 100644
index 925159e38d..0000000000
--- a/test/testinterp/t110-offsetint.ml
+++ /dev/null
@@ -1,21 +0,0 @@
-open Lib;;
-if 2 + 2 <> 4 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONSTINT 4
- 11 PUSHCONST2
- 12 OFFSETINT 2
- 14 NEQ
- 15 BRANCHIFNOT 22
- 17 GETGLOBAL Not_found
- 19 MAKEBLOCK1 0
- 21 RAISE
- 22 ATOM0
- 23 SETGLOBAL T110-offsetint
- 25 STOP
-**)
diff --git a/test/testinterp/t110-orint.ml b/test/testinterp/t110-orint.ml
deleted file mode 100644
index 56b63d80b1..0000000000
--- a/test/testinterp/t110-orint.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-open Lib;;
-if (3 lor 6) <> 7 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONSTINT 7
- 11 PUSHCONSTINT 6
- 13 PUSHCONST3
- 14 ORINT
- 15 NEQ
- 16 BRANCHIFNOT 23
- 18 GETGLOBAL Not_found
- 20 MAKEBLOCK1 0
- 22 RAISE
- 23 ATOM0
- 24 SETGLOBAL T110-orint
- 26 STOP
-**)
diff --git a/test/testinterp/t110-subint.ml b/test/testinterp/t110-subint.ml
deleted file mode 100644
index f626cd0d60..0000000000
--- a/test/testinterp/t110-subint.ml
+++ /dev/null
@@ -1,26 +0,0 @@
-open Lib;;
-let x = 1 in
-if 1 - x <> 0 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST1
- 10 PUSHCONST0
- 11 PUSHACC1
- 12 PUSHCONST1
- 13 SUBINT
- 14 NEQ
- 15 BRANCHIFNOT 22
- 17 GETGLOBAL Not_found
- 19 MAKEBLOCK1 0
- 21 RAISE
- 22 POP 1
- 24 ATOM0
- 25 SETGLOBAL T110-subint
- 27 STOP
-**)
diff --git a/test/testinterp/t110-xorint.ml b/test/testinterp/t110-xorint.ml
deleted file mode 100644
index dfb278b7a8..0000000000
--- a/test/testinterp/t110-xorint.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-open Lib;;
-if (3 lxor 6) <> 5 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONSTINT 5
- 11 PUSHCONSTINT 6
- 13 PUSHCONST3
- 14 XORINT
- 15 NEQ
- 16 BRANCHIFNOT 23
- 18 GETGLOBAL Not_found
- 20 MAKEBLOCK1 0
- 22 RAISE
- 23 ATOM0
- 24 SETGLOBAL T110-xorint
- 26 STOP
-**)
diff --git a/test/testinterp/t120-getstringchar.ml b/test/testinterp/t120-getstringchar.ml
deleted file mode 100644
index aaff2022d4..0000000000
--- a/test/testinterp/t120-getstringchar.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-open Lib;;
-if "foo".[2] <> 'o' then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONSTINT 111
- 11 PUSHCONST2
- 12 PUSHGETGLOBAL "foo"
- 14 GETSTRINGCHAR
- 15 NEQ
- 16 BRANCHIFNOT 23
- 18 GETGLOBAL Not_found
- 20 MAKEBLOCK1 0
- 22 RAISE
- 23 ATOM0
- 24 SETGLOBAL T120-getstringchar
- 26 STOP
-**)
diff --git a/test/testinterp/t121-setstringchar.ml b/test/testinterp/t121-setstringchar.ml
deleted file mode 100644
index 882d6e0812..0000000000
--- a/test/testinterp/t121-setstringchar.ml
+++ /dev/null
@@ -1,31 +0,0 @@
-open Lib;;
-let x = "foo" in
-x.[2] <- 'x';
-if x.[2] <> 'x' then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 GETGLOBAL "foo"
- 11 PUSHCONSTINT 120
- 13 PUSHCONST2
- 14 PUSHACC2
- 15 SETSTRINGCHAR
- 16 CONSTINT 120
- 18 PUSHCONST2
- 19 PUSHACC2
- 20 GETSTRINGCHAR
- 21 NEQ
- 22 BRANCHIFNOT 29
- 24 GETGLOBAL Not_found
- 26 MAKEBLOCK1 0
- 28 RAISE
- 29 POP 1
- 31 ATOM0
- 32 SETGLOBAL T121-setstringchar
- 34 STOP
-**)
diff --git a/test/testinterp/t130-getvectitem.ml b/test/testinterp/t130-getvectitem.ml
deleted file mode 100644
index d290379592..0000000000
--- a/test/testinterp/t130-getvectitem.ml
+++ /dev/null
@@ -1,24 +0,0 @@
-open Lib;;
-if [| 1; 2 |].(1) <> 2 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST2
- 10 PUSHCONST1
- 11 PUSHCONST2
- 12 PUSHCONST1
- 13 MAKEBLOCK2 0
- 15 GETVECTITEM
- 16 NEQ
- 17 BRANCHIFNOT 24
- 19 GETGLOBAL Not_found
- 21 MAKEBLOCK1 0
- 23 RAISE
- 24 ATOM0
- 25 SETGLOBAL T130-getvectitem
- 27 STOP
-**)
diff --git a/test/testinterp/t130-vectlength.ml b/test/testinterp/t130-vectlength.ml
deleted file mode 100644
index ce0da0e420..0000000000
--- a/test/testinterp/t130-vectlength.ml
+++ /dev/null
@@ -1,23 +0,0 @@
-open Lib;;
-if Array.length [| 1; 2 |] <> 2 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST2
- 10 PUSHCONST2
- 11 PUSHCONST1
- 12 MAKEBLOCK2 0
- 14 VECTLENGTH
- 15 NEQ
- 16 BRANCHIFNOT 23
- 18 GETGLOBAL Not_found
- 20 MAKEBLOCK1 0
- 22 RAISE
- 23 ATOM0
- 24 SETGLOBAL T130-vectlength
- 26 STOP
-**)
diff --git a/test/testinterp/t131-setvectitem.ml b/test/testinterp/t131-setvectitem.ml
deleted file mode 100644
index f544a3e0a1..0000000000
--- a/test/testinterp/t131-setvectitem.ml
+++ /dev/null
@@ -1,33 +0,0 @@
-open Lib;;
-let x = [| 1; 2 |] in
-x.(0) <- 3;
-if x.(0) <> 3 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST2
- 10 PUSHCONST1
- 11 MAKEBLOCK2 0
- 13 PUSHCONST3
- 14 PUSHCONST0
- 15 PUSHACC2
- 16 SETVECTITEM
- 17 CONST3
- 18 PUSHCONST0
- 19 PUSHACC2
- 20 GETVECTITEM
- 21 NEQ
- 22 BRANCHIFNOT 29
- 24 GETGLOBAL Not_found
- 26 MAKEBLOCK1 0
- 28 RAISE
- 29 POP 1
- 31 ATOM0
- 32 SETGLOBAL T131-setvectitem
- 34 STOP
-**)
diff --git a/test/testinterp/t140-switch-1.ml b/test/testinterp/t140-switch-1.ml
deleted file mode 100644
index b2d7352156..0000000000
--- a/test/testinterp/t140-switch-1.ml
+++ /dev/null
@@ -1,32 +0,0 @@
-open Lib;;
-match 0 with
-| 0 -> ()
-| 1 -> raise Not_found
-| _ -> raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST0
- 10 PUSHACC0
- 11 SWITCH
- int 0 -> 17
- int 1 -> 20
- 15 BRANCH 25
- 17 CONST0
- 18 BRANCH 30
- 20 GETGLOBAL Not_found
- 22 MAKEBLOCK1 0
- 24 RAISE
- 25 GETGLOBAL Not_found
- 27 MAKEBLOCK1 0
- 29 RAISE
- 30 POP 1
- 32 ATOM0
- 33 SETGLOBAL T140-switch-1
- 35 STOP
-**)
diff --git a/test/testinterp/t140-switch-2.ml b/test/testinterp/t140-switch-2.ml
deleted file mode 100644
index 9004fa66bb..0000000000
--- a/test/testinterp/t140-switch-2.ml
+++ /dev/null
@@ -1,32 +0,0 @@
-open Lib;;
-match 1 with
-| 0 -> raise Not_found
-| 1 -> ()
-| _ -> raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST1
- 10 PUSHACC0
- 11 SWITCH
- int 0 -> 17
- int 1 -> 22
- 15 BRANCH 25
- 17 GETGLOBAL Not_found
- 19 MAKEBLOCK1 0
- 21 RAISE
- 22 CONST0
- 23 BRANCH 30
- 25 GETGLOBAL Not_found
- 27 MAKEBLOCK1 0
- 29 RAISE
- 30 POP 1
- 32 ATOM0
- 33 SETGLOBAL T140-switch-2
- 35 STOP
-**)
diff --git a/test/testinterp/t140-switch-3.ml b/test/testinterp/t140-switch-3.ml
deleted file mode 100644
index b0c4bc8f75..0000000000
--- a/test/testinterp/t140-switch-3.ml
+++ /dev/null
@@ -1,31 +0,0 @@
-open Lib;;
-match 2 with
-| 0 -> raise Not_found
-| 1 -> raise Not_found
-| _ -> ()
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST2
- 10 PUSHACC0
- 11 SWITCH
- int 0 -> 17
- int 1 -> 22
- 15 BRANCH 27
- 17 GETGLOBAL Not_found
- 19 MAKEBLOCK1 0
- 21 RAISE
- 22 GETGLOBAL Not_found
- 24 MAKEBLOCK1 0
- 26 RAISE
- 27 CONST0
- 28 POP 1
- 30 ATOM0
- 31 SETGLOBAL T140-switch-3
- 33 STOP
-**)
diff --git a/test/testinterp/t140-switch-4.ml b/test/testinterp/t140-switch-4.ml
deleted file mode 100644
index 1826b09e5d..0000000000
--- a/test/testinterp/t140-switch-4.ml
+++ /dev/null
@@ -1,31 +0,0 @@
-open Lib;;
-match -1 with
-| 0 -> raise Not_found
-| 1 -> raise Not_found
-| _ -> ()
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONSTINT -1
- 11 PUSHACC0
- 12 SWITCH
- int 0 -> 18
- int 1 -> 23
- 16 BRANCH 28
- 18 GETGLOBAL Not_found
- 20 MAKEBLOCK1 0
- 22 RAISE
- 23 GETGLOBAL Not_found
- 25 MAKEBLOCK1 0
- 27 RAISE
- 28 CONST0
- 29 POP 1
- 31 ATOM0
- 32 SETGLOBAL T140-switch-4
- 34 STOP
-**)
diff --git a/test/testinterp/t141-switch-5.ml b/test/testinterp/t141-switch-5.ml
deleted file mode 100644
index ca44849e22..0000000000
--- a/test/testinterp/t141-switch-5.ml
+++ /dev/null
@@ -1,38 +0,0 @@
-open Lib;;
-type t =
- | A of int
- | B of int
- | C of int
-;;
-
-match A 0 with
-| A _ -> ()
-| B _ -> raise Not_found
-| _ -> raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 GETGLOBAL <0>(0)
- 11 PUSHACC0
- 12 SWITCH
- tag 0 -> 17
- tag 1 -> 20
- tag 2 -> 25
- 17 CONST0
- 18 BRANCH 30
- 20 GETGLOBAL Not_found
- 22 MAKEBLOCK1 0
- 24 RAISE
- 25 GETGLOBAL Not_found
- 27 MAKEBLOCK1 0
- 29 RAISE
- 30 POP 1
- 32 ATOM0
- 33 SETGLOBAL T141-switch-5
- 35 STOP
-**)
diff --git a/test/testinterp/t141-switch-6.ml b/test/testinterp/t141-switch-6.ml
deleted file mode 100644
index c48e80b5f7..0000000000
--- a/test/testinterp/t141-switch-6.ml
+++ /dev/null
@@ -1,38 +0,0 @@
-open Lib;;
-type t =
- | A of int
- | B of int
- | C of int
-;;
-
-match B 0 with
-| A _ -> raise Not_found
-| B _ -> ()
-| _ -> raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 GETGLOBAL <1>(0)
- 11 PUSHACC0
- 12 SWITCH
- tag 0 -> 17
- tag 1 -> 22
- tag 2 -> 25
- 17 GETGLOBAL Not_found
- 19 MAKEBLOCK1 0
- 21 RAISE
- 22 CONST0
- 23 BRANCH 30
- 25 GETGLOBAL Not_found
- 27 MAKEBLOCK1 0
- 29 RAISE
- 30 POP 1
- 32 ATOM0
- 33 SETGLOBAL T141-switch-6
- 35 STOP
-**)
diff --git a/test/testinterp/t141-switch-7.ml b/test/testinterp/t141-switch-7.ml
deleted file mode 100644
index 00f4873cdf..0000000000
--- a/test/testinterp/t141-switch-7.ml
+++ /dev/null
@@ -1,37 +0,0 @@
-open Lib;;
-type t =
- | A of int
- | B of int
- | C of int
-;;
-
-match C 0 with
-| A _ -> raise Not_found
-| B _ -> raise Not_found
-| _ -> ()
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 GETGLOBAL <2>(0)
- 11 PUSHACC0
- 12 SWITCH
- tag 0 -> 17
- tag 1 -> 22
- tag 2 -> 27
- 17 GETGLOBAL Not_found
- 19 MAKEBLOCK1 0
- 21 RAISE
- 22 GETGLOBAL Not_found
- 24 MAKEBLOCK1 0
- 26 RAISE
- 27 CONST0
- 28 POP 1
- 30 ATOM0
- 31 SETGLOBAL T141-switch-7
- 33 STOP
-**)
diff --git a/test/testinterp/t142-switch-8.ml b/test/testinterp/t142-switch-8.ml
deleted file mode 100644
index 51459130a5..0000000000
--- a/test/testinterp/t142-switch-8.ml
+++ /dev/null
@@ -1,34 +0,0 @@
-open Lib;;
-type t =
- | A
- | B of int
- | C of int
-;;
-
-match A with
-| A -> ()
-| _ -> raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST0
- 10 PUSHACC0
- 11 SWITCH
- int 0 -> 16
- tag 0 -> 19
- tag 1 -> 19
- 16 CONST0
- 17 BRANCH 24
- 19 GETGLOBAL Not_found
- 21 MAKEBLOCK1 0
- 23 RAISE
- 24 POP 1
- 26 ATOM0
- 27 SETGLOBAL T142-switch-8
- 29 STOP
-**)
diff --git a/test/testinterp/t142-switch-9.ml b/test/testinterp/t142-switch-9.ml
deleted file mode 100644
index a0e43d3217..0000000000
--- a/test/testinterp/t142-switch-9.ml
+++ /dev/null
@@ -1,34 +0,0 @@
-open Lib;;
-type t =
- | A
- | B of int
- | C of int
-;;
-
-match B 0 with
-| B _ -> ()
-| _ -> raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 GETGLOBAL <0>(0)
- 11 PUSHACC0
- 12 SWITCH
- int 0 -> 20
- tag 0 -> 17
- tag 1 -> 20
- 17 CONST0
- 18 BRANCH 25
- 20 GETGLOBAL Not_found
- 22 MAKEBLOCK1 0
- 24 RAISE
- 25 POP 1
- 27 ATOM0
- 28 SETGLOBAL T142-switch-9
- 30 STOP
-**)
diff --git a/test/testinterp/t142-switch-A.ml b/test/testinterp/t142-switch-A.ml
deleted file mode 100644
index 4f66aec587..0000000000
--- a/test/testinterp/t142-switch-A.ml
+++ /dev/null
@@ -1,34 +0,0 @@
-open Lib;;
-type t =
- | A
- | B of int
- | C of int
-;;
-
-match C 0 with
-| C _ -> ()
-| _ -> raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 GETGLOBAL <1>(0)
- 11 PUSHACC0
- 12 SWITCH
- int 0 -> 20
- tag 0 -> 20
- tag 1 -> 17
- 17 CONST0
- 18 BRANCH 25
- 20 GETGLOBAL Not_found
- 22 MAKEBLOCK1 0
- 24 RAISE
- 25 POP 1
- 27 ATOM0
- 28 SETGLOBAL T142-switch-A
- 30 STOP
-**)
diff --git a/test/testinterp/t150-push-1.ml b/test/testinterp/t150-push-1.ml
deleted file mode 100644
index 9264927777..0000000000
--- a/test/testinterp/t150-push-1.ml
+++ /dev/null
@@ -1,24 +0,0 @@
-open Lib;;
-let _ = 0 in
-try 0 with _ -> 0
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST0
- 10 PUSH
- 11 PUSHTRAP 17
- 13 CONST0
- 14 POPTRAP
- 15 BRANCH 20
- 17 PUSHCONST0
- 18 POP 1
- 20 POP 1
- 22 ATOM0
- 23 SETGLOBAL T150-push-1
- 25 STOP
-**)
diff --git a/test/testinterp/t150-push-2.ml b/test/testinterp/t150-push-2.ml
deleted file mode 100644
index d6f5107260..0000000000
--- a/test/testinterp/t150-push-2.ml
+++ /dev/null
@@ -1,39 +0,0 @@
-open Lib;;
-let x = 1 in
-try if x <> 1 then raise Not_found
-with End_of_file -> ()
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST1
- 10 PUSH
- 11 PUSHTRAP 26
- 13 CONST1
- 14 PUSHACC5
- 15 NEQ
- 16 BRANCHIFNOT 23
- 18 GETGLOBAL Not_found
- 20 MAKEBLOCK1 0
- 22 RAISE
- 23 POPTRAP
- 24 BRANCH 40
- 26 PUSHGETGLOBAL End_of_file
- 28 PUSHACC1
- 29 GETFIELD0
- 30 EQ
- 31 BRANCHIFNOT 36
- 33 CONST0
- 34 BRANCH 38
- 36 ACC0
- 37 RAISE
- 38 POP 1
- 40 POP 1
- 42 ATOM0
- 43 SETGLOBAL T150-push-2
- 45 STOP
-**)
diff --git a/test/testinterp/t160-closure.ml b/test/testinterp/t160-closure.ml
deleted file mode 100644
index 5eb612865a..0000000000
--- a/test/testinterp/t160-closure.ml
+++ /dev/null
@@ -1,19 +0,0 @@
-open Lib;;
-let f () = ();;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 14
- 11 CONST0
- 12 RETURN 1
- 14 CLOSURE 0, 11
- 17 PUSHACC0
- 18 MAKEBLOCK1 0
- 20 POP 1
- 22 SETGLOBAL T160-closure
- 24 STOP
-**)
diff --git a/test/testinterp/t161-apply1.ml b/test/testinterp/t161-apply1.ml
deleted file mode 100644
index 5138c5f581..0000000000
--- a/test/testinterp/t161-apply1.ml
+++ /dev/null
@@ -1,42 +0,0 @@
-open Lib;;
-let f _ = raise End_of_file in
-try
- f 0;
- raise Not_found;
-with End_of_file -> 0
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 16
- 11 GETGLOBAL End_of_file
- 13 MAKEBLOCK1 0
- 15 RAISE
- 16 CLOSURE 0, 11
- 19 PUSH
- 20 PUSHTRAP 30
- 22 CONST0
- 23 PUSHACC5
- 24 APPLY1
- 25 GETGLOBAL Not_found
- 27 MAKEBLOCK1 0
- 29 RAISE
- 30 PUSHGETGLOBAL End_of_file
- 32 PUSHACC1
- 33 GETFIELD0
- 34 EQ
- 35 BRANCHIFNOT 40
- 37 CONST0
- 38 BRANCH 42
- 40 ACC0
- 41 RAISE
- 42 POP 1
- 44 POP 1
- 46 ATOM0
- 47 SETGLOBAL T161-apply1
- 49 STOP
-**)
diff --git a/test/testinterp/t162-return.ml b/test/testinterp/t162-return.ml
deleted file mode 100644
index 1059c9fea2..0000000000
--- a/test/testinterp/t162-return.ml
+++ /dev/null
@@ -1,21 +0,0 @@
-open Lib;;
-let f _ = 0 in f 0;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 14
- 11 CONST0
- 12 RETURN 1
- 14 CLOSURE 0, 11
- 17 PUSHCONST0
- 18 PUSHACC1
- 19 APPLY1
- 20 POP 1
- 22 ATOM0
- 23 SETGLOBAL T162-return
- 25 STOP
-**)
diff --git a/test/testinterp/t163.ml b/test/testinterp/t163.ml
deleted file mode 100644
index 9ec7790c53..0000000000
--- a/test/testinterp/t163.ml
+++ /dev/null
@@ -1,23 +0,0 @@
-open Lib;;
-let f _ _ = 0 in f 0;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 17
- 11 RESTART
- 12 GRAB 1
- 14 CONST0
- 15 RETURN 2
- 17 CLOSURE 0, 12
- 20 PUSHCONST0
- 21 PUSHACC1
- 22 APPLY1
- 23 POP 1
- 25 ATOM0
- 26 SETGLOBAL T163
- 28 STOP
-**)
diff --git a/test/testinterp/t164-apply2.ml b/test/testinterp/t164-apply2.ml
deleted file mode 100644
index 7fbe7d9974..0000000000
--- a/test/testinterp/t164-apply2.ml
+++ /dev/null
@@ -1,24 +0,0 @@
-open Lib;;
-let f _ _ = 0 in f 0 0;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 17
- 11 RESTART
- 12 GRAB 1
- 14 CONST0
- 15 RETURN 2
- 17 CLOSURE 0, 12
- 20 PUSHCONST0
- 21 PUSHCONST0
- 22 PUSHACC2
- 23 APPLY2
- 24 POP 1
- 26 ATOM0
- 27 SETGLOBAL T164-apply2
- 29 STOP
-**)
diff --git a/test/testinterp/t164-apply3.ml b/test/testinterp/t164-apply3.ml
deleted file mode 100644
index e7ebc3a400..0000000000
--- a/test/testinterp/t164-apply3.ml
+++ /dev/null
@@ -1,25 +0,0 @@
-open Lib;;
-let f _ _ _ = 0 in f 0 0 0;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 17
- 11 RESTART
- 12 GRAB 2
- 14 CONST0
- 15 RETURN 3
- 17 CLOSURE 0, 12
- 20 PUSHCONST0
- 21 PUSHCONST0
- 22 PUSHCONST0
- 23 PUSHACC3
- 24 APPLY3
- 25 POP 1
- 27 ATOM0
- 28 SETGLOBAL T164-apply3
- 30 STOP
-**)
diff --git a/test/testinterp/t165-apply.ml b/test/testinterp/t165-apply.ml
deleted file mode 100644
index 9d66855061..0000000000
--- a/test/testinterp/t165-apply.ml
+++ /dev/null
@@ -1,28 +0,0 @@
-open Lib;;
-let f _ _ _ _ = 0 in f 0 0 0 0;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 17
- 11 RESTART
- 12 GRAB 3
- 14 CONST0
- 15 RETURN 4
- 17 CLOSURE 0, 12
- 20 PUSH
- 21 PUSH_RETADDR 30
- 23 CONST0
- 24 PUSHCONST0
- 25 PUSHCONST0
- 26 PUSHCONST0
- 27 PUSHACC7
- 28 APPLY 4
- 30 POP 1
- 32 ATOM0
- 33 SETGLOBAL T165-apply
- 35 STOP
-**)
diff --git a/test/testinterp/t170-envacc2.ml b/test/testinterp/t170-envacc2.ml
deleted file mode 100644
index 3a37366723..0000000000
--- a/test/testinterp/t170-envacc2.ml
+++ /dev/null
@@ -1,37 +0,0 @@
-open Lib;;
-let x = 5 in
-let y = 2 in
-let f _ = ignore x; y in
-if f 0 <> 2 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 16
- 11 ENVACC1
- 12 CONST0
- 13 ENVACC2
- 14 RETURN 1
- 16 CONSTINT 5
- 18 PUSHCONST2
- 19 PUSHACC0
- 20 PUSHACC2
- 21 CLOSURE 2, 11
- 24 PUSHCONST2
- 25 PUSHCONST0
- 26 PUSHACC2
- 27 APPLY1
- 28 NEQ
- 29 BRANCHIFNOT 36
- 31 GETGLOBAL Not_found
- 33 MAKEBLOCK1 0
- 35 RAISE
- 36 POP 3
- 38 ATOM0
- 39 SETGLOBAL T170-envacc2
- 41 STOP
-**)
diff --git a/test/testinterp/t170-envacc3.ml b/test/testinterp/t170-envacc3.ml
deleted file mode 100644
index 9a2b8b5a8f..0000000000
--- a/test/testinterp/t170-envacc3.ml
+++ /dev/null
@@ -1,42 +0,0 @@
-open Lib;;
-let x = 5 in
-let y = 2 in
-let z = 1 in
-let f _ = ignore x; ignore y; z in
-if f 0 <> 1 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 18
- 11 ENVACC1
- 12 CONST0
- 13 ENVACC2
- 14 CONST0
- 15 ENVACC3
- 16 RETURN 1
- 18 CONSTINT 5
- 20 PUSHCONST2
- 21 PUSHCONST1
- 22 PUSHACC0
- 23 PUSHACC2
- 24 PUSHACC4
- 25 CLOSURE 3, 11
- 28 PUSHCONST1
- 29 PUSHCONST0
- 30 PUSHACC2
- 31 APPLY1
- 32 NEQ
- 33 BRANCHIFNOT 40
- 35 GETGLOBAL Not_found
- 37 MAKEBLOCK1 0
- 39 RAISE
- 40 POP 4
- 42 ATOM0
- 43 SETGLOBAL T170-envacc3
- 45 STOP
-**)
diff --git a/test/testinterp/t170-envacc4.ml b/test/testinterp/t170-envacc4.ml
deleted file mode 100644
index 215e322078..0000000000
--- a/test/testinterp/t170-envacc4.ml
+++ /dev/null
@@ -1,47 +0,0 @@
-open Lib;;
-let x = 5 in
-let y = 2 in
-let z = 1 in
-let a = 4 in
-let f _ = ignore x; ignore y; ignore z; a in
-if f 0 <> 4 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 20
- 11 ENVACC1
- 12 CONST0
- 13 ENVACC2
- 14 CONST0
- 15 ENVACC3
- 16 CONST0
- 17 ENVACC4
- 18 RETURN 1
- 20 CONSTINT 5
- 22 PUSHCONST2
- 23 PUSHCONST1
- 24 PUSHCONSTINT 4
- 26 PUSHACC0
- 27 PUSHACC2
- 28 PUSHACC4
- 29 PUSHACC6
- 30 CLOSURE 4, 11
- 33 PUSHCONSTINT 4
- 35 PUSHCONST0
- 36 PUSHACC2
- 37 APPLY1
- 38 NEQ
- 39 BRANCHIFNOT 46
- 41 GETGLOBAL Not_found
- 43 MAKEBLOCK1 0
- 45 RAISE
- 46 POP 5
- 48 ATOM0
- 49 SETGLOBAL T170-envacc4
- 51 STOP
-**)
diff --git a/test/testinterp/t171-envacc.ml b/test/testinterp/t171-envacc.ml
deleted file mode 100644
index 4c4a3dfac9..0000000000
--- a/test/testinterp/t171-envacc.ml
+++ /dev/null
@@ -1,52 +0,0 @@
-open Lib;;
-let x = 5 in
-let y = 2 in
-let z = 1 in
-let a = 4 in
-let b = 3 in
-let f _ = ignore x; ignore y; ignore z; ignore a; b in
-if f 0 <> 3 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 23
- 11 ENVACC1
- 12 CONST0
- 13 ENVACC2
- 14 CONST0
- 15 ENVACC3
- 16 CONST0
- 17 ENVACC4
- 18 CONST0
- 19 ENVACC 5
- 21 RETURN 1
- 23 CONSTINT 5
- 25 PUSHCONST2
- 26 PUSHCONST1
- 27 PUSHCONSTINT 4
- 29 PUSHCONST3
- 30 PUSHACC0
- 31 PUSHACC2
- 32 PUSHACC4
- 33 PUSHACC6
- 34 PUSHACC 8
- 36 CLOSURE 5, 11
- 39 PUSHCONST3
- 40 PUSHCONST0
- 41 PUSHACC2
- 42 APPLY1
- 43 NEQ
- 44 BRANCHIFNOT 51
- 46 GETGLOBAL Not_found
- 48 MAKEBLOCK1 0
- 50 RAISE
- 51 POP 6
- 53 ATOM0
- 54 SETGLOBAL T171-envacc
- 56 STOP
-**)
diff --git a/test/testinterp/t172-pushenvacc1.ml b/test/testinterp/t172-pushenvacc1.ml
deleted file mode 100644
index 06c4011a01..0000000000
--- a/test/testinterp/t172-pushenvacc1.ml
+++ /dev/null
@@ -1,34 +0,0 @@
-open Lib;;
-let x = 5 in
-let f _ = x + x in
-if f 0 <> 10 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 16
- 11 ENVACC1
- 12 PUSHENVACC1
- 13 ADDINT
- 14 RETURN 1
- 16 CONSTINT 5
- 18 PUSHACC0
- 19 CLOSURE 1, 11
- 22 PUSHCONSTINT 10
- 24 PUSHCONST0
- 25 PUSHACC2
- 26 APPLY1
- 27 NEQ
- 28 BRANCHIFNOT 35
- 30 GETGLOBAL Not_found
- 32 MAKEBLOCK1 0
- 34 RAISE
- 35 POP 2
- 37 ATOM0
- 38 SETGLOBAL T172-pushenvacc1
- 40 STOP
-**)
diff --git a/test/testinterp/t172-pushenvacc2.ml b/test/testinterp/t172-pushenvacc2.ml
deleted file mode 100644
index c25e40a71a..0000000000
--- a/test/testinterp/t172-pushenvacc2.ml
+++ /dev/null
@@ -1,37 +0,0 @@
-open Lib;;
-let x = 5 in
-let y = 4 in
-let f _ = y + x in
-if f 0 <> 9 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 16
- 11 ENVACC1
- 12 PUSHENVACC2
- 13 ADDINT
- 14 RETURN 1
- 16 CONSTINT 5
- 18 PUSHCONSTINT 4
- 20 PUSHACC0
- 21 PUSHACC2
- 22 CLOSURE 2, 11
- 25 PUSHCONSTINT 9
- 27 PUSHCONST0
- 28 PUSHACC2
- 29 APPLY1
- 30 NEQ
- 31 BRANCHIFNOT 38
- 33 GETGLOBAL Not_found
- 35 MAKEBLOCK1 0
- 37 RAISE
- 38 POP 3
- 40 ATOM0
- 41 SETGLOBAL T172-pushenvacc2
- 43 STOP
-**)
diff --git a/test/testinterp/t172-pushenvacc3.ml b/test/testinterp/t172-pushenvacc3.ml
deleted file mode 100644
index 093f7f1e4e..0000000000
--- a/test/testinterp/t172-pushenvacc3.ml
+++ /dev/null
@@ -1,42 +0,0 @@
-open Lib;;
-let x = 5 in
-let y = 4 in
-let z = 3 in
-let f _ = z + y + x in
-if f 0 <> 12 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 18
- 11 ENVACC1
- 12 PUSHENVACC2
- 13 PUSHENVACC3
- 14 ADDINT
- 15 ADDINT
- 16 RETURN 1
- 18 CONSTINT 5
- 20 PUSHCONSTINT 4
- 22 PUSHCONST3
- 23 PUSHACC0
- 24 PUSHACC2
- 25 PUSHACC4
- 26 CLOSURE 3, 11
- 29 PUSHCONSTINT 12
- 31 PUSHCONST0
- 32 PUSHACC2
- 33 APPLY1
- 34 NEQ
- 35 BRANCHIFNOT 42
- 37 GETGLOBAL Not_found
- 39 MAKEBLOCK1 0
- 41 RAISE
- 42 POP 4
- 44 ATOM0
- 45 SETGLOBAL T172-pushenvacc3
- 47 STOP
-**)
diff --git a/test/testinterp/t172-pushenvacc4.ml b/test/testinterp/t172-pushenvacc4.ml
deleted file mode 100644
index 154c4a4715..0000000000
--- a/test/testinterp/t172-pushenvacc4.ml
+++ /dev/null
@@ -1,47 +0,0 @@
-open Lib;;
-let x = 5 in
-let y = 4 in
-let z = 3 in
-let a = 2 in
-let f _ = a + z + y + x in
-if f 0 <> 14 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 21
- 11 ENVACC1
- 12 PUSHENVACC2
- 13 PUSHENVACC3
- 14 PUSHENVACC 4
- 16 ADDINT
- 17 ADDINT
- 18 ADDINT
- 19 RETURN 1
- 21 CONSTINT 5
- 23 PUSHCONSTINT 4
- 25 PUSHCONST3
- 26 PUSHCONST2
- 27 PUSHACC0
- 28 PUSHACC2
- 29 PUSHACC4
- 30 PUSHACC6
- 31 CLOSURE 4, 11
- 34 PUSHCONSTINT 14
- 36 PUSHCONST0
- 37 PUSHACC2
- 38 APPLY1
- 39 NEQ
- 40 BRANCHIFNOT 47
- 42 GETGLOBAL Not_found
- 44 MAKEBLOCK1 0
- 46 RAISE
- 47 POP 5
- 49 ATOM0
- 50 SETGLOBAL T172-pushenvacc4
- 52 STOP
-**)
diff --git a/test/testinterp/t173-pushenvacc.ml b/test/testinterp/t173-pushenvacc.ml
deleted file mode 100644
index 0d858b4aa2..0000000000
--- a/test/testinterp/t173-pushenvacc.ml
+++ /dev/null
@@ -1,52 +0,0 @@
-open Lib;;
-let x = 5 in
-let y = 4 in
-let z = 3 in
-let a = 2 in
-let b = 1 in
-let f _ = b + a + z + y + x in
-if f 0 <> 15 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 24
- 11 ENVACC1
- 12 PUSHENVACC2
- 13 PUSHENVACC3
- 14 PUSHENVACC 4
- 16 PUSHENVACC 5
- 18 ADDINT
- 19 ADDINT
- 20 ADDINT
- 21 ADDINT
- 22 RETURN 1
- 24 CONSTINT 5
- 26 PUSHCONSTINT 4
- 28 PUSHCONST3
- 29 PUSHCONST2
- 30 PUSHCONST1
- 31 PUSHACC0
- 32 PUSHACC2
- 33 PUSHACC4
- 34 PUSHACC6
- 35 PUSHACC 8
- 37 CLOSURE 5, 11
- 40 PUSHCONSTINT 15
- 42 PUSHCONST0
- 43 PUSHACC2
- 44 APPLY1
- 45 NEQ
- 46 BRANCHIFNOT 53
- 48 GETGLOBAL Not_found
- 50 MAKEBLOCK1 0
- 52 RAISE
- 53 POP 6
- 55 ATOM0
- 56 SETGLOBAL T173-pushenvacc
- 58 STOP
-**)
diff --git a/test/testinterp/t180-appterm1.ml b/test/testinterp/t180-appterm1.ml
deleted file mode 100644
index 6b82f51b61..0000000000
--- a/test/testinterp/t180-appterm1.ml
+++ /dev/null
@@ -1,35 +0,0 @@
-open Lib;;
-let f _ = 12 in
-let g _ = f 0 in
-if g 0 <> 12 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 19
- 11 CONST0
- 12 PUSHENVACC1
- 13 APPTERM1 2
- 15 CONSTINT 12
- 17 RETURN 1
- 19 CLOSURE 0, 15
- 22 PUSHACC0
- 23 CLOSURE 1, 11
- 26 PUSHCONSTINT 12
- 28 PUSHCONST0
- 29 PUSHACC2
- 30 APPLY1
- 31 NEQ
- 32 BRANCHIFNOT 39
- 34 GETGLOBAL Not_found
- 36 MAKEBLOCK1 0
- 38 RAISE
- 39 POP 2
- 41 ATOM0
- 42 SETGLOBAL T180-appterm1
- 44 STOP
-**)
diff --git a/test/testinterp/t180-appterm2.ml b/test/testinterp/t180-appterm2.ml
deleted file mode 100644
index 28f32a9336..0000000000
--- a/test/testinterp/t180-appterm2.ml
+++ /dev/null
@@ -1,38 +0,0 @@
-open Lib;;
-let f _ _ = 12 in
-let g _ = f 0 0 in
-if g 0 <> 12 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 23
- 11 CONST0
- 12 PUSHCONST0
- 13 PUSHENVACC1
- 14 APPTERM2 3
- 16 RESTART
- 17 GRAB 1
- 19 CONSTINT 12
- 21 RETURN 2
- 23 CLOSURE 0, 17
- 26 PUSHACC0
- 27 CLOSURE 1, 11
- 30 PUSHCONSTINT 12
- 32 PUSHCONST0
- 33 PUSHACC2
- 34 APPLY1
- 35 NEQ
- 36 BRANCHIFNOT 43
- 38 GETGLOBAL Not_found
- 40 MAKEBLOCK1 0
- 42 RAISE
- 43 POP 2
- 45 ATOM0
- 46 SETGLOBAL T180-appterm2
- 48 STOP
-**)
diff --git a/test/testinterp/t180-appterm3.ml b/test/testinterp/t180-appterm3.ml
deleted file mode 100644
index fe8a0bd5cf..0000000000
--- a/test/testinterp/t180-appterm3.ml
+++ /dev/null
@@ -1,39 +0,0 @@
-open Lib;;
-let f _ _ _ = 13 in
-let g _ = f 0 0 0 in
-if g 0 <> 13 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 24
- 11 CONST0
- 12 PUSHCONST0
- 13 PUSHCONST0
- 14 PUSHENVACC1
- 15 APPTERM3 4
- 17 RESTART
- 18 GRAB 2
- 20 CONSTINT 13
- 22 RETURN 3
- 24 CLOSURE 0, 18
- 27 PUSHACC0
- 28 CLOSURE 1, 11
- 31 PUSHCONSTINT 13
- 33 PUSHCONST0
- 34 PUSHACC2
- 35 APPLY1
- 36 NEQ
- 37 BRANCHIFNOT 44
- 39 GETGLOBAL Not_found
- 41 MAKEBLOCK1 0
- 43 RAISE
- 44 POP 2
- 46 ATOM0
- 47 SETGLOBAL T180-appterm3
- 49 STOP
-**)
diff --git a/test/testinterp/t181-appterm.ml b/test/testinterp/t181-appterm.ml
deleted file mode 100644
index 03127bc8d3..0000000000
--- a/test/testinterp/t181-appterm.ml
+++ /dev/null
@@ -1,40 +0,0 @@
-open Lib;;
-let f _ _ _ _ = -10 in
-let g _ = f 0 0 0 0 in
-if g 0 <> -10 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 26
- 11 CONST0
- 12 PUSHCONST0
- 13 PUSHCONST0
- 14 PUSHCONST0
- 15 PUSHENVACC1
- 16 APPTERM 4, 5
- 19 RESTART
- 20 GRAB 3
- 22 CONSTINT -10
- 24 RETURN 4
- 26 CLOSURE 0, 20
- 29 PUSHACC0
- 30 CLOSURE 1, 11
- 33 PUSHCONSTINT -10
- 35 PUSHCONST0
- 36 PUSHACC2
- 37 APPLY1
- 38 NEQ
- 39 BRANCHIFNOT 46
- 41 GETGLOBAL Not_found
- 43 MAKEBLOCK1 0
- 45 RAISE
- 46 POP 2
- 48 ATOM0
- 49 SETGLOBAL T181-appterm
- 51 STOP
-**)
diff --git a/test/testinterp/t190-makefloatblock-1.ml b/test/testinterp/t190-makefloatblock-1.ml
deleted file mode 100644
index f63c6cd8f9..0000000000
--- a/test/testinterp/t190-makefloatblock-1.ml
+++ /dev/null
@@ -1,17 +0,0 @@
-open Lib;;
-let x = 0.0 in [| x |];;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 GETGLOBAL 0
- 11 PUSHACC0
- 12 MAKEFLOATBLOCK 1
- 14 POP 1
- 16 ATOM0
- 17 SETGLOBAL T190-makefloatblock-1
- 19 STOP
-**)
diff --git a/test/testinterp/t190-makefloatblock-2.ml b/test/testinterp/t190-makefloatblock-2.ml
deleted file mode 100644
index 53b97f5d51..0000000000
--- a/test/testinterp/t190-makefloatblock-2.ml
+++ /dev/null
@@ -1,18 +0,0 @@
-open Lib;;
-let x = 0.0 in [| x; x |];;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 GETGLOBAL 0
- 11 PUSHACC0
- 12 PUSHACC1
- 13 MAKEFLOATBLOCK 2
- 15 POP 1
- 17 ATOM0
- 18 SETGLOBAL T190-makefloatblock-2
- 20 STOP
-**)
diff --git a/test/testinterp/t190-makefloatblock-3.ml b/test/testinterp/t190-makefloatblock-3.ml
deleted file mode 100644
index cebccaa38d..0000000000
--- a/test/testinterp/t190-makefloatblock-3.ml
+++ /dev/null
@@ -1,19 +0,0 @@
-open Lib;;
-let x = 0.0 in [| x; x; x |];;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 GETGLOBAL 0
- 11 PUSHACC0
- 12 PUSHACC1
- 13 PUSHACC2
- 14 MAKEFLOATBLOCK 3
- 16 POP 1
- 18 ATOM0
- 19 SETGLOBAL T190-makefloatblock-3
- 21 STOP
-**)
diff --git a/test/testinterp/t191-vectlength.ml b/test/testinterp/t191-vectlength.ml
deleted file mode 100644
index 16f7d783b1..0000000000
--- a/test/testinterp/t191-vectlength.ml
+++ /dev/null
@@ -1,26 +0,0 @@
-open Lib;;
-let x = 0.0 in
-if Array.length [| x |] <> 1 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 GETGLOBAL 0
- 11 PUSHCONST1
- 12 PUSHACC1
- 13 MAKEFLOATBLOCK 1
- 15 VECTLENGTH
- 16 NEQ
- 17 BRANCHIFNOT 24
- 19 GETGLOBAL Not_found
- 21 MAKEBLOCK1 0
- 23 RAISE
- 24 POP 1
- 26 ATOM0
- 27 SETGLOBAL T191-vectlength
- 29 STOP
-**)
diff --git a/test/testinterp/t192-getfloatfield-1.ml b/test/testinterp/t192-getfloatfield-1.ml
deleted file mode 100644
index ba002b20b1..0000000000
--- a/test/testinterp/t192-getfloatfield-1.ml
+++ /dev/null
@@ -1,23 +0,0 @@
-open Lib;;
-type t = { a : float; b : float };;
-
-if { a = 0.1; b = 0.2 }.a <> 0.1 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 GETGLOBAL 0.1
- 11 PUSHGETGLOBAL [|0.1, 0.2|]
- 13 GETFLOATFIELD 0
- 15 C_CALL2 neq_float
- 17 BRANCHIFNOT 24
- 19 GETGLOBAL Not_found
- 21 MAKEBLOCK1 0
- 23 RAISE
- 24 ATOM0
- 25 SETGLOBAL T192-getfloatfield-1
- 27 STOP
-**)
diff --git a/test/testinterp/t192-getfloatfield-2.ml b/test/testinterp/t192-getfloatfield-2.ml
deleted file mode 100644
index 89230da397..0000000000
--- a/test/testinterp/t192-getfloatfield-2.ml
+++ /dev/null
@@ -1,23 +0,0 @@
-open Lib;;
-type t = { a : float; b : float };;
-
-if { a = 0.1; b = 0.2 }.b <> 0.2 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 GETGLOBAL 0.2
- 11 PUSHGETGLOBAL [|0.1, 0.2|]
- 13 GETFLOATFIELD 1
- 15 C_CALL2 neq_float
- 17 BRANCHIFNOT 24
- 19 GETGLOBAL Not_found
- 21 MAKEBLOCK1 0
- 23 RAISE
- 24 ATOM0
- 25 SETGLOBAL T192-getfloatfield-2
- 27 STOP
-**)
diff --git a/test/testinterp/t193-setfloatfield-1.ml b/test/testinterp/t193-setfloatfield-1.ml
deleted file mode 100644
index b488e7daad..0000000000
--- a/test/testinterp/t193-setfloatfield-1.ml
+++ /dev/null
@@ -1,36 +0,0 @@
-open Lib;;
-type t = {
- mutable a : float;
- mutable b : float;
-};;
-
-let x = { a = 0.1; b = 0.2 } in
-x.a <- 0.3;
-if x.a <> 0.3 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 GETGLOBAL 0.2
- 11 PUSHGETGLOBAL 0.1
- 13 MAKEFLOATBLOCK 2
- 15 PUSHGETGLOBAL 0.3
- 17 PUSHACC1
- 18 SETFLOATFIELD 0
- 20 GETGLOBAL 0.3
- 22 PUSHACC1
- 23 GETFLOATFIELD 0
- 25 C_CALL2 neq_float
- 27 BRANCHIFNOT 34
- 29 GETGLOBAL Not_found
- 31 MAKEBLOCK1 0
- 33 RAISE
- 34 POP 1
- 36 ATOM0
- 37 SETGLOBAL T193-setfloatfield-1
- 39 STOP
-**)
diff --git a/test/testinterp/t193-setfloatfield-2.ml b/test/testinterp/t193-setfloatfield-2.ml
deleted file mode 100644
index 7dde0a2cf5..0000000000
--- a/test/testinterp/t193-setfloatfield-2.ml
+++ /dev/null
@@ -1,36 +0,0 @@
-open Lib;;
-type t = {
- mutable a : float;
- mutable b : float;
-};;
-
-let x = { a = 0.1; b = 0.2 } in
-x.b <- 0.3;
-if x.b <> 0.3 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 GETGLOBAL 0.2
- 11 PUSHGETGLOBAL 0.1
- 13 MAKEFLOATBLOCK 2
- 15 PUSHGETGLOBAL 0.3
- 17 PUSHACC1
- 18 SETFLOATFIELD 1
- 20 GETGLOBAL 0.3
- 22 PUSHACC1
- 23 GETFLOATFIELD 1
- 25 C_CALL2 neq_float
- 27 BRANCHIFNOT 34
- 29 GETGLOBAL Not_found
- 31 MAKEBLOCK1 0
- 33 RAISE
- 34 POP 1
- 36 ATOM0
- 37 SETGLOBAL T193-setfloatfield-2
- 39 STOP
-**)
diff --git a/test/testinterp/t200-getfield0.ml b/test/testinterp/t200-getfield0.ml
deleted file mode 100644
index 14ce1d547d..0000000000
--- a/test/testinterp/t200-getfield0.ml
+++ /dev/null
@@ -1,25 +0,0 @@
-open Lib;;
-type t = {
- a : int;
-};;
-
-if { a = 7 }.a <> 7 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONSTINT 7
- 11 PUSHGETGLOBAL <0>(7)
- 13 GETFIELD0
- 14 NEQ
- 15 BRANCHIFNOT 22
- 17 GETGLOBAL Not_found
- 19 MAKEBLOCK1 0
- 21 RAISE
- 22 ATOM0
- 23 SETGLOBAL T200-getfield0
- 25 STOP
-**)
diff --git a/test/testinterp/t200-getfield1.ml b/test/testinterp/t200-getfield1.ml
deleted file mode 100644
index f4e2e01907..0000000000
--- a/test/testinterp/t200-getfield1.ml
+++ /dev/null
@@ -1,26 +0,0 @@
-open Lib;;
-type t = {
- a : int;
- b : int;
-};;
-
-if { a = 7; b = 6 }.b <> 6 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONSTINT 6
- 11 PUSHGETGLOBAL <0>(7, 6)
- 13 GETFIELD1
- 14 NEQ
- 15 BRANCHIFNOT 22
- 17 GETGLOBAL Not_found
- 19 MAKEBLOCK1 0
- 21 RAISE
- 22 ATOM0
- 23 SETGLOBAL T200-getfield1
- 25 STOP
-**)
diff --git a/test/testinterp/t200-getfield2.ml b/test/testinterp/t200-getfield2.ml
deleted file mode 100644
index df5c7172d0..0000000000
--- a/test/testinterp/t200-getfield2.ml
+++ /dev/null
@@ -1,27 +0,0 @@
-open Lib;;
-type t = {
- a : int;
- b : int;
- c : int;
-};;
-
-if { a = 7; b = 6; c = 5 }.c <> 5 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONSTINT 5
- 11 PUSHGETGLOBAL <0>(7, 6, 5)
- 13 GETFIELD2
- 14 NEQ
- 15 BRANCHIFNOT 22
- 17 GETGLOBAL Not_found
- 19 MAKEBLOCK1 0
- 21 RAISE
- 22 ATOM0
- 23 SETGLOBAL T200-getfield2
- 25 STOP
-**)
diff --git a/test/testinterp/t200-getfield3.ml b/test/testinterp/t200-getfield3.ml
deleted file mode 100644
index a0376a1fcf..0000000000
--- a/test/testinterp/t200-getfield3.ml
+++ /dev/null
@@ -1,28 +0,0 @@
-open Lib;;
-type t = {
- a : int;
- b : int;
- c : int;
- d : int;
-};;
-
-if { a = 7; b = 6; c = 5; d = 4 }.d <> 4 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONSTINT 4
- 11 PUSHGETGLOBAL <0>(7, 6, 5, 4)
- 13 GETFIELD3
- 14 NEQ
- 15 BRANCHIFNOT 22
- 17 GETGLOBAL Not_found
- 19 MAKEBLOCK1 0
- 21 RAISE
- 22 ATOM0
- 23 SETGLOBAL T200-getfield3
- 25 STOP
-**)
diff --git a/test/testinterp/t201-getfield.ml b/test/testinterp/t201-getfield.ml
deleted file mode 100644
index 0fbbc63fee..0000000000
--- a/test/testinterp/t201-getfield.ml
+++ /dev/null
@@ -1,29 +0,0 @@
-open Lib;;
-type t = {
- a : int;
- b : int;
- c : int;
- d : int;
- e : int;
-};;
-
-if { a = 7; b = 6; c = 5; d = 4; e = 3 }.e <> 3 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST3
- 10 PUSHGETGLOBAL <0>(7, 6, 5, 4, 3)
- 12 GETFIELD 4
- 14 NEQ
- 15 BRANCHIFNOT 22
- 17 GETGLOBAL Not_found
- 19 MAKEBLOCK1 0
- 21 RAISE
- 22 ATOM0
- 23 SETGLOBAL T201-getfield
- 25 STOP
-**)
diff --git a/test/testinterp/t210-setfield0.ml b/test/testinterp/t210-setfield0.ml
deleted file mode 100644
index aa31d41fe4..0000000000
--- a/test/testinterp/t210-setfield0.ml
+++ /dev/null
@@ -1,36 +0,0 @@
-open Lib;;
-type t = {
- mutable a : int;
-};;
-
-let x = {a = 7} in
-x.a <- 11;
-if x.a <> 11 then raise Not_found;
-x
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONSTINT 7
- 11 MAKEBLOCK1 0
- 13 PUSHCONSTINT 11
- 15 PUSHACC1
- 16 SETFIELD0
- 17 CONSTINT 11
- 19 PUSHACC1
- 20 GETFIELD0
- 21 NEQ
- 22 BRANCHIFNOT 29
- 24 GETGLOBAL Not_found
- 26 MAKEBLOCK1 0
- 28 RAISE
- 29 ACC0
- 30 POP 1
- 32 ATOM0
- 33 SETGLOBAL T210-setfield0
- 35 STOP
-**)
diff --git a/test/testinterp/t210-setfield1.ml b/test/testinterp/t210-setfield1.ml
deleted file mode 100644
index 0d8e16762c..0000000000
--- a/test/testinterp/t210-setfield1.ml
+++ /dev/null
@@ -1,38 +0,0 @@
-open Lib;;
-type t = {
- mutable a : int;
- mutable b : int;
-};;
-
-let x = {a = 7; b = 6} in
-x.b <- 11;
-if x.b <> 11 then raise Not_found;
-x
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONSTINT 6
- 11 PUSHCONSTINT 7
- 13 MAKEBLOCK2 0
- 15 PUSHCONSTINT 11
- 17 PUSHACC1
- 18 SETFIELD1
- 19 CONSTINT 11
- 21 PUSHACC1
- 22 GETFIELD1
- 23 NEQ
- 24 BRANCHIFNOT 31
- 26 GETGLOBAL Not_found
- 28 MAKEBLOCK1 0
- 30 RAISE
- 31 ACC0
- 32 POP 1
- 34 ATOM0
- 35 SETGLOBAL T210-setfield1
- 37 STOP
-**)
diff --git a/test/testinterp/t210-setfield2.ml b/test/testinterp/t210-setfield2.ml
deleted file mode 100644
index 727691d113..0000000000
--- a/test/testinterp/t210-setfield2.ml
+++ /dev/null
@@ -1,40 +0,0 @@
-open Lib;;
-type t = {
- mutable a : int;
- mutable b : int;
- mutable c : int;
-};;
-
-let x = {a = 7; b = 6; c = 5} in
-x.c <- 11;
-if x.c <> 11 then raise Not_found;
-x
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONSTINT 5
- 11 PUSHCONSTINT 6
- 13 PUSHCONSTINT 7
- 15 MAKEBLOCK3 0
- 17 PUSHCONSTINT 11
- 19 PUSHACC1
- 20 SETFIELD2
- 21 CONSTINT 11
- 23 PUSHACC1
- 24 GETFIELD2
- 25 NEQ
- 26 BRANCHIFNOT 33
- 28 GETGLOBAL Not_found
- 30 MAKEBLOCK1 0
- 32 RAISE
- 33 ACC0
- 34 POP 1
- 36 ATOM0
- 37 SETGLOBAL T210-setfield2
- 39 STOP
-**)
diff --git a/test/testinterp/t210-setfield3.ml b/test/testinterp/t210-setfield3.ml
deleted file mode 100644
index d50d2c2a63..0000000000
--- a/test/testinterp/t210-setfield3.ml
+++ /dev/null
@@ -1,42 +0,0 @@
-open Lib;;
-type t = {
- mutable a : int;
- mutable b : int;
- mutable c : int;
- mutable d : int;
-};;
-
-let x = {a = 7; b = 6; c = 5; d = 4} in
-x.d <- 11;
-if x.d <> 11 then raise Not_found;
-x
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONSTINT 4
- 11 PUSHCONSTINT 5
- 13 PUSHCONSTINT 6
- 15 PUSHCONSTINT 7
- 17 MAKEBLOCK 4, 0
- 20 PUSHCONSTINT 11
- 22 PUSHACC1
- 23 SETFIELD3
- 24 CONSTINT 11
- 26 PUSHACC1
- 27 GETFIELD3
- 28 NEQ
- 29 BRANCHIFNOT 36
- 31 GETGLOBAL Not_found
- 33 MAKEBLOCK1 0
- 35 RAISE
- 36 ACC0
- 37 POP 1
- 39 ATOM0
- 40 SETGLOBAL T210-setfield3
- 42 STOP
-**)
diff --git a/test/testinterp/t211-setfield.ml b/test/testinterp/t211-setfield.ml
deleted file mode 100644
index 69c445e10b..0000000000
--- a/test/testinterp/t211-setfield.ml
+++ /dev/null
@@ -1,44 +0,0 @@
-open Lib;;
-type t = {
- mutable a : int;
- mutable b : int;
- mutable c : int;
- mutable d : int;
- mutable e : int;
-};;
-
-let x = {a = 7; b = 6; c = 5; d = 4; e = 5} in
-x.e <- 11;
-if x.e <> 11 then raise Not_found;
-x
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONSTINT 5
- 11 PUSHCONSTINT 4
- 13 PUSHCONSTINT 5
- 15 PUSHCONSTINT 6
- 17 PUSHCONSTINT 7
- 19 MAKEBLOCK 5, 0
- 22 PUSHCONSTINT 11
- 24 PUSHACC1
- 25 SETFIELD 4
- 27 CONSTINT 11
- 29 PUSHACC1
- 30 GETFIELD 4
- 32 NEQ
- 33 BRANCHIFNOT 40
- 35 GETGLOBAL Not_found
- 37 MAKEBLOCK1 0
- 39 RAISE
- 40 ACC0
- 41 POP 1
- 43 ATOM0
- 44 SETGLOBAL T211-setfield
- 46 STOP
-**)
diff --git a/test/testinterp/t220-assign.ml b/test/testinterp/t220-assign.ml
deleted file mode 100644
index 769f8fb22c..0000000000
--- a/test/testinterp/t220-assign.ml
+++ /dev/null
@@ -1,27 +0,0 @@
-open Lib;;
-let x = ref 1 in
-x := 3;
-if !x <> 3 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST1
- 10 PUSHCONST3
- 11 ASSIGN 0
- 13 CONST3
- 14 PUSHACC1
- 15 NEQ
- 16 BRANCHIFNOT 23
- 18 GETGLOBAL Not_found
- 20 MAKEBLOCK1 0
- 22 RAISE
- 23 POP 1
- 25 ATOM0
- 26 SETGLOBAL T220-assign
- 28 STOP
-**)
diff --git a/test/testinterp/t230-check_signals.ml b/test/testinterp/t230-check_signals.ml
deleted file mode 100644
index 2c2b5d7731..0000000000
--- a/test/testinterp/t230-check_signals.ml
+++ /dev/null
@@ -1,28 +0,0 @@
-open Lib;;
-for i = 0 to 0 do () done;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST0
- 10 PUSHCONST0
- 11 PUSH
- 12 BRANCH 21
- 14 CHECK_SIGNALS
- 15 CONST0
- 16 ACC1
- 17 OFFSETINT 1
- 19 ASSIGN 1
- 21 ACC0
- 22 PUSHACC2
- 23 LEINT
- 24 BRANCHIF 14
- 26 CONST0
- 27 POP 2
- 29 ATOM0
- 30 SETGLOBAL T230-check_signals
- 32 STOP
-**)
diff --git a/test/testinterp/t240-c_call1.ml b/test/testinterp/t240-c_call1.ml
deleted file mode 100644
index 3c7508cbc0..0000000000
--- a/test/testinterp/t240-c_call1.ml
+++ /dev/null
@@ -1,21 +0,0 @@
-open Lib;;
-if Pervasives.int_of_string "123" <> 123 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONSTINT 123
- 11 PUSHGETGLOBAL "123"
- 13 C_CALL1 int_of_string
- 15 NEQ
- 16 BRANCHIFNOT 23
- 18 GETGLOBAL Not_found
- 20 MAKEBLOCK1 0
- 22 RAISE
- 23 ATOM0
- 24 SETGLOBAL T240-c_call1
- 26 STOP
-**)
diff --git a/test/testinterp/t240-c_call2.ml b/test/testinterp/t240-c_call2.ml
deleted file mode 100644
index 23c984369f..0000000000
--- a/test/testinterp/t240-c_call2.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-open Lib;;
-if Pervasives.compare 1 2 <> -1 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONSTINT -1
- 11 PUSHCONST2
- 12 PUSHCONST1
- 13 C_CALL2 compare
- 15 NEQ
- 16 BRANCHIFNOT 23
- 18 GETGLOBAL Not_found
- 20 MAKEBLOCK1 0
- 22 RAISE
- 23 ATOM0
- 24 SETGLOBAL T240-c_call2
- 26 STOP
-**)
diff --git a/test/testinterp/t240-c_call3.ml b/test/testinterp/t240-c_call3.ml
deleted file mode 100644
index 707bc7eec6..0000000000
--- a/test/testinterp/t240-c_call3.ml
+++ /dev/null
@@ -1,23 +0,0 @@
-open Lib;;
-if Hashtbl.hash_param 5 6 [1;2;3] <> 196799 then raise Not_found;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONSTINT 196799
- 11 PUSHGETGLOBAL <0>(1, <0>(2, <0>(3, 0)))
- 13 PUSHCONSTINT 6
- 15 PUSHCONSTINT 5
- 17 C_CALL3 hash_univ_param
- 19 NEQ
- 20 BRANCHIFNOT 27
- 22 GETGLOBAL Not_found
- 24 MAKEBLOCK1 0
- 26 RAISE
- 27 ATOM0
- 28 SETGLOBAL T240-c_call3
- 30 STOP
-**)
diff --git a/test/testinterp/t240-c_call4.ml b/test/testinterp/t240-c_call4.ml
deleted file mode 100644
index 2ab62d86e0..0000000000
--- a/test/testinterp/t240-c_call4.ml
+++ /dev/null
@@ -1,32 +0,0 @@
-open Lib;;
-let s = "abcdefgh" in
-String.unsafe_fill s 0 6 'x';
-if s.[5] <> 'x' then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 GETGLOBAL "abcdefgh"
- 11 PUSHCONSTINT 120
- 13 PUSHCONSTINT 6
- 15 PUSHCONST0
- 16 PUSHACC3
- 17 C_CALL4 fill_string
- 19 CONSTINT 120
- 21 PUSHCONSTINT 5
- 23 PUSHACC2
- 24 GETSTRINGCHAR
- 25 NEQ
- 26 BRANCHIFNOT 33
- 28 GETGLOBAL Not_found
- 30 MAKEBLOCK1 0
- 32 RAISE
- 33 POP 1
- 35 ATOM0
- 36 SETGLOBAL T240-c_call4
- 38 STOP
-**)
diff --git a/test/testinterp/t240-c_call5.ml b/test/testinterp/t240-c_call5.ml
deleted file mode 100644
index e817d55028..0000000000
--- a/test/testinterp/t240-c_call5.ml
+++ /dev/null
@@ -1,33 +0,0 @@
-open Lib;;
-let s = "abcdefgh" in
-String.unsafe_blit s 3 s 0 3;
-if s.[0] <> 'd' then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 GETGLOBAL "abcdefgh"
- 11 PUSHCONST3
- 12 PUSHCONST0
- 13 PUSHACC2
- 14 PUSHCONST3
- 15 PUSHACC4
- 16 C_CALL5 blit_string
- 18 CONSTINT 100
- 20 PUSHCONST0
- 21 PUSHACC2
- 22 GETSTRINGCHAR
- 23 NEQ
- 24 BRANCHIFNOT 31
- 26 GETGLOBAL Not_found
- 28 MAKEBLOCK1 0
- 30 RAISE
- 31 POP 1
- 33 ATOM0
- 34 SETGLOBAL T240-c_call5
- 36 STOP
-**)
diff --git a/test/testinterp/t250-closurerec-1.ml b/test/testinterp/t250-closurerec-1.ml
deleted file mode 100644
index ded5036e69..0000000000
--- a/test/testinterp/t250-closurerec-1.ml
+++ /dev/null
@@ -1,19 +0,0 @@
-open Lib;;
-let rec f _ = 0;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 14
- 11 CONST0
- 12 RETURN 1
- 14 CLOSUREREC 0, 11
- 18 ACC0
- 19 MAKEBLOCK1 0
- 21 POP 1
- 23 SETGLOBAL T250-closurerec-1
- 25 STOP
-**)
diff --git a/test/testinterp/t250-closurerec-2.ml b/test/testinterp/t250-closurerec-2.ml
deleted file mode 100644
index 97eac0c791..0000000000
--- a/test/testinterp/t250-closurerec-2.ml
+++ /dev/null
@@ -1,29 +0,0 @@
-open Lib;;
-let rec f _ = 23 in
-if f 0 <> 23 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 15
- 11 CONSTINT 23
- 13 RETURN 1
- 15 CLOSUREREC 0, 11
- 19 CONSTINT 23
- 21 PUSHCONST0
- 22 PUSHACC2
- 23 APPLY1
- 24 NEQ
- 25 BRANCHIFNOT 32
- 27 GETGLOBAL Not_found
- 29 MAKEBLOCK1 0
- 31 RAISE
- 32 POP 1
- 34 ATOM0
- 35 SETGLOBAL T250-closurerec-2
- 37 STOP
-**)
diff --git a/test/testinterp/t251-pushoffsetclosure0.ml b/test/testinterp/t251-pushoffsetclosure0.ml
deleted file mode 100644
index b1c25555ea..0000000000
--- a/test/testinterp/t251-pushoffsetclosure0.ml
+++ /dev/null
@@ -1,39 +0,0 @@
-open Lib;;
-let rec f = function
- | 0 -> 13
- | n -> f 0
-in
-if f 5 <> 13 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 24
- 11 CONST0
- 12 PUSHACC1
- 13 EQ
- 14 BRANCHIFNOT 20
- 16 CONSTINT 13
- 18 RETURN 1
- 20 CONST0
- 21 PUSHOFFSETCLOSURE0
- 22 APPTERM1 2
- 24 CLOSUREREC 0, 11
- 28 CONSTINT 13
- 30 PUSHCONSTINT 5
- 32 PUSHACC2
- 33 APPLY1
- 34 NEQ
- 35 BRANCHIFNOT 42
- 37 GETGLOBAL Not_found
- 39 MAKEBLOCK1 0
- 41 RAISE
- 42 POP 1
- 44 ATOM0
- 45 SETGLOBAL T251-pushoffsetclosure0
- 47 STOP
-**)
diff --git a/test/testinterp/t251-pushoffsetclosure2.ml b/test/testinterp/t251-pushoffsetclosure2.ml
deleted file mode 100644
index 0fbdd6eae7..0000000000
--- a/test/testinterp/t251-pushoffsetclosure2.ml
+++ /dev/null
@@ -1,34 +0,0 @@
-open Lib;;
-let rec f _ = g 0
- and g _ = 4
-in
-if f 5 <> 4 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 19
- 11 CONST0
- 12 PUSHOFFSETCLOSURE2
- 13 APPTERM1 2
- 15 CONSTINT 4
- 17 RETURN 1
- 19 CLOSUREREC 0, 11, 15
- 24 CONSTINT 4
- 26 PUSHCONSTINT 5
- 28 PUSHACC3
- 29 APPLY1
- 30 NEQ
- 31 BRANCHIFNOT 38
- 33 GETGLOBAL Not_found
- 35 MAKEBLOCK1 0
- 37 RAISE
- 38 POP 2
- 40 ATOM0
- 41 SETGLOBAL T251-pushoffsetclosure2
- 43 STOP
-**)
diff --git a/test/testinterp/t251-pushoffsetclosurem2.ml b/test/testinterp/t251-pushoffsetclosurem2.ml
deleted file mode 100644
index 41ec196c35..0000000000
--- a/test/testinterp/t251-pushoffsetclosurem2.ml
+++ /dev/null
@@ -1,34 +0,0 @@
-open Lib;;
-let rec f _ = 4
- and g _ = f 2
-in
-if g 5 <> 4 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 19
- 11 CONSTINT 4
- 13 RETURN 1
- 15 CONST2
- 16 PUSHOFFSETCLOSUREM2
- 17 APPTERM1 2
- 19 CLOSUREREC 0, 11, 15
- 24 CONSTINT 4
- 26 PUSHCONSTINT 5
- 28 PUSHACC2
- 29 APPLY1
- 30 NEQ
- 31 BRANCHIFNOT 38
- 33 GETGLOBAL Not_found
- 35 MAKEBLOCK1 0
- 37 RAISE
- 38 POP 2
- 40 ATOM0
- 41 SETGLOBAL T251-pushoffsetclosurem2
- 43 STOP
-**)
diff --git a/test/testinterp/t252-pushoffsetclosure.ml b/test/testinterp/t252-pushoffsetclosure.ml
deleted file mode 100644
index 1887133453..0000000000
--- a/test/testinterp/t252-pushoffsetclosure.ml
+++ /dev/null
@@ -1,38 +0,0 @@
-open Lib;;
-let rec f x = x
- and g _ = f 4
- and h _ = f 6
-in
-if h 1 <> 6 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 25
- 11 ACC0
- 12 RETURN 1
- 14 CONSTINT 4
- 16 PUSHOFFSETCLOSUREM2
- 17 APPTERM1 2
- 19 CONSTINT 6
- 21 PUSHOFFSETCLOSURE -4
- 23 APPTERM1 2
- 25 CLOSUREREC 0, 11, 14, 19
- 31 CONSTINT 6
- 33 PUSHCONST1
- 34 PUSHACC2
- 35 APPLY1
- 36 NEQ
- 37 BRANCHIFNOT 44
- 39 GETGLOBAL Not_found
- 41 MAKEBLOCK1 0
- 43 RAISE
- 44 POP 3
- 46 ATOM0
- 47 SETGLOBAL T252-pushoffsetclosure
- 49 STOP
-**)
diff --git a/test/testinterp/t253-offsetclosure0.ml b/test/testinterp/t253-offsetclosure0.ml
deleted file mode 100644
index f6d12c6db0..0000000000
--- a/test/testinterp/t253-offsetclosure0.ml
+++ /dev/null
@@ -1,34 +0,0 @@
-open Lib;;
-let rec f _ = g f
- and g _ = 10
-in
-if f 3 <> 10 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 19
- 11 OFFSETCLOSURE0
- 12 PUSHOFFSETCLOSURE2
- 13 APPTERM1 2
- 15 CONSTINT 10
- 17 RETURN 1
- 19 CLOSUREREC 0, 11, 15
- 24 CONSTINT 10
- 26 PUSHCONST3
- 27 PUSHACC3
- 28 APPLY1
- 29 NEQ
- 30 BRANCHIFNOT 37
- 32 GETGLOBAL Not_found
- 34 MAKEBLOCK1 0
- 36 RAISE
- 37 POP 2
- 39 ATOM0
- 40 SETGLOBAL T253-offsetclosure0
- 42 STOP
-**)
diff --git a/test/testinterp/t253-offsetclosure2.ml b/test/testinterp/t253-offsetclosure2.ml
deleted file mode 100644
index be940611fe..0000000000
--- a/test/testinterp/t253-offsetclosure2.ml
+++ /dev/null
@@ -1,34 +0,0 @@
-open Lib;;
-let rec f _ = g
- and g _ = 10
-in
-if f 3 4 <> 10 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 18
- 11 OFFSETCLOSURE2
- 12 RETURN 1
- 14 CONSTINT 10
- 16 RETURN 1
- 18 CLOSUREREC 0, 11, 14
- 23 CONSTINT 10
- 25 PUSHCONSTINT 4
- 27 PUSHCONST3
- 28 PUSHACC4
- 29 APPLY2
- 30 NEQ
- 31 BRANCHIFNOT 38
- 33 GETGLOBAL Not_found
- 35 MAKEBLOCK1 0
- 37 RAISE
- 38 POP 2
- 40 ATOM0
- 41 SETGLOBAL T253-offsetclosure2
- 43 STOP
-**)
diff --git a/test/testinterp/t253-offsetclosurem2.ml b/test/testinterp/t253-offsetclosurem2.ml
deleted file mode 100644
index cec37931e7..0000000000
--- a/test/testinterp/t253-offsetclosurem2.ml
+++ /dev/null
@@ -1,34 +0,0 @@
-open Lib;;
-let rec f _ = 11
- and g _ = f
-in
-if g 3 4 <> 11 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 18
- 11 CONSTINT 11
- 13 RETURN 1
- 15 OFFSETCLOSUREM2
- 16 RETURN 1
- 18 CLOSUREREC 0, 11, 15
- 23 CONSTINT 11
- 25 PUSHCONSTINT 4
- 27 PUSHCONST3
- 28 PUSHACC3
- 29 APPLY2
- 30 NEQ
- 31 BRANCHIFNOT 38
- 33 GETGLOBAL Not_found
- 35 MAKEBLOCK1 0
- 37 RAISE
- 38 POP 2
- 40 ATOM0
- 41 SETGLOBAL T253-offsetclosurem2
- 43 STOP
-**)
diff --git a/test/testinterp/t254-offsetclosure.ml b/test/testinterp/t254-offsetclosure.ml
deleted file mode 100644
index 6da8c28c90..0000000000
--- a/test/testinterp/t254-offsetclosure.ml
+++ /dev/null
@@ -1,37 +0,0 @@
-open Lib;;
-let rec f _ = 11
- and g _ = 0
- and h _ = f
-in
-if h 3 4 <> 11 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 22
- 11 CONSTINT 11
- 13 RETURN 1
- 15 CONST0
- 16 RETURN 1
- 18 OFFSETCLOSURE -4
- 20 RETURN 1
- 22 CLOSUREREC 0, 11, 15, 18
- 28 CONSTINT 11
- 30 PUSHCONSTINT 4
- 32 PUSHCONST3
- 33 PUSHACC3
- 34 APPLY2
- 35 NEQ
- 36 BRANCHIFNOT 43
- 38 GETGLOBAL Not_found
- 40 MAKEBLOCK1 0
- 42 RAISE
- 43 POP 3
- 45 ATOM0
- 46 SETGLOBAL T254-offsetclosure
- 48 STOP
-**)
diff --git a/test/testinterp/t260-offsetref.ml b/test/testinterp/t260-offsetref.ml
deleted file mode 100644
index 968892ef11..0000000000
--- a/test/testinterp/t260-offsetref.ml
+++ /dev/null
@@ -1,31 +0,0 @@
-open Lib;;
-let x = ref 32 in
-incr x;
-if !x <> 33 then raise Not_found;
-x
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONSTINT 32
- 11 MAKEBLOCK1 0
- 13 PUSHACC0
- 14 OFFSETREF 1
- 16 CONSTINT 33
- 18 PUSHACC1
- 19 GETFIELD0
- 20 NEQ
- 21 BRANCHIFNOT 28
- 23 GETGLOBAL Not_found
- 25 MAKEBLOCK1 0
- 27 RAISE
- 28 ACC0
- 29 POP 1
- 31 ATOM0
- 32 SETGLOBAL T260-offsetref
- 34 STOP
-**)
diff --git a/test/testinterp/t270-push_retaddr.ml b/test/testinterp/t270-push_retaddr.ml
deleted file mode 100644
index 0c7fb369bf..0000000000
--- a/test/testinterp/t270-push_retaddr.ml
+++ /dev/null
@@ -1,36 +0,0 @@
-open Lib;;
-let f a b c d = 123 in
-if f 0 1 2 3 <> 123 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 18
- 11 RESTART
- 12 GRAB 3
- 14 CONSTINT 123
- 16 RETURN 4
- 18 CLOSURE 0, 12
- 21 PUSHCONSTINT 123
- 23 PUSH
- 24 PUSH_RETADDR 34
- 26 CONST3
- 27 PUSHCONST2
- 28 PUSHCONST1
- 29 PUSHCONST0
- 30 PUSHACC 8
- 32 APPLY 4
- 34 NEQ
- 35 BRANCHIFNOT 42
- 37 GETGLOBAL Not_found
- 39 MAKEBLOCK1 0
- 41 RAISE
- 42 POP 1
- 44 ATOM0
- 45 SETGLOBAL T270-push_retaddr
- 47 STOP
-**)
diff --git a/test/testinterp/t300-getmethod.ml b/test/testinterp/t300-getmethod.ml
deleted file mode 100644
index e7894735c1..0000000000
--- a/test/testinterp/t300-getmethod.ml
+++ /dev/null
@@ -1,5885 +0,0 @@
-open Lib;;
-
-class c = object
- method m = 23
-end;;
-
-let o = new c in
-if o#m <> 23 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 746
- 11 RESTART
- 12 GRAB 1
- 14 ACC0
- 15 BRANCHIFNOT 28
- 17 ACC1
- 18 PUSHACC1
- 19 GETFIELD1
- 20 PUSHOFFSETCLOSURE0
- 21 APPLY2
- 22 PUSHACC1
- 23 GETFIELD0
- 24 MAKEBLOCK2 0
- 26 RETURN 2
- 28 ACC1
- 29 RETURN 2
- 31 RESTART
- 32 GRAB 3
- 34 CONST0
- 35 PUSHACC4
- 36 LEINT
- 37 BRANCHIFNOT 42
- 39 CONST0
- 40 RETURN 4
- 42 ACC3
- 43 PUSHACC3
- 44 PUSHACC3
- 45 PUSHACC3
- 46 C_CALL4 caml_input
- 48 PUSHCONST0
- 49 PUSHACC1
- 50 EQ
- 51 BRANCHIFNOT 58
- 53 GETGLOBAL End_of_file
- 55 MAKEBLOCK1 0
- 57 RAISE
- 58 ACC0
- 59 PUSHACC5
- 60 SUBINT
- 61 PUSHACC1
- 62 PUSHACC5
- 63 ADDINT
- 64 PUSHACC4
- 65 PUSHACC4
- 66 PUSHOFFSETCLOSURE0
- 67 APPTERM 4, 9
- 70 ACC0
- 71 C_CALL1 caml_input_scan_line
- 73 PUSHCONST0
- 74 PUSHACC1
- 75 EQ
- 76 BRANCHIFNOT 83
- 78 GETGLOBAL End_of_file
- 80 MAKEBLOCK1 0
- 82 RAISE
- 83 CONST0
- 84 PUSHACC1
- 85 GTINT
- 86 BRANCHIFNOT 107
- 88 ACC0
- 89 OFFSETINT -1
- 91 C_CALL1 create_string
- 93 PUSHACC1
- 94 OFFSETINT -1
- 96 PUSHCONST0
- 97 PUSHACC2
- 98 PUSHACC5
- 99 C_CALL4 caml_input
- 101 ACC2
- 102 C_CALL1 caml_input_char
- 104 ACC0
- 105 RETURN 3
- 107 ACC0
- 108 NEGINT
- 109 C_CALL1 create_string
- 111 PUSHACC1
- 112 NEGINT
- 113 PUSHCONST0
- 114 PUSHACC2
- 115 PUSHACC5
- 116 C_CALL4 caml_input
- 118 CONST0
- 119 PUSHTRAP 130
- 121 ACC6
- 122 PUSHOFFSETCLOSURE0
- 123 APPLY1
- 124 PUSHACC5
- 125 PUSHENVACC1
- 126 APPLY2
- 127 POPTRAP
- 128 RETURN 3
- 130 PUSHGETGLOBAL End_of_file
- 132 PUSHACC1
- 133 GETFIELD0
- 134 EQ
- 135 BRANCHIFNOT 140
- 137 ACC1
- 138 RETURN 4
- 140 ACC0
- 141 RAISE
- 142 ACC0
- 143 C_CALL1 caml_flush
- 145 RETURN 1
- 147 RESTART
- 148 GRAB 1
- 150 ACC1
- 151 PUSHACC1
- 152 C_CALL2 caml_output_char
- 154 RETURN 2
- 156 RESTART
- 157 GRAB 1
- 159 ACC1
- 160 PUSHACC1
- 161 C_CALL2 caml_output_char
- 163 RETURN 2
- 165 RESTART
- 166 GRAB 1
- 168 ACC1
- 169 PUSHACC1
- 170 C_CALL2 caml_output_int
- 172 RETURN 2
- 174 RESTART
- 175 GRAB 1
- 177 ACC1
- 178 PUSHACC1
- 179 C_CALL2 caml_seek_out
- 181 RETURN 2
- 183 ACC0
- 184 C_CALL1 caml_pos_out
- 186 RETURN 1
- 188 ACC0
- 189 C_CALL1 caml_channel_size
- 191 RETURN 1
- 193 RESTART
- 194 GRAB 1
- 196 ACC1
- 197 PUSHACC1
- 198 C_CALL2 caml_set_binary_mode
- 200 RETURN 2
- 202 ACC0
- 203 C_CALL1 caml_input_char
- 205 RETURN 1
- 207 ACC0
- 208 C_CALL1 caml_input_char
- 210 RETURN 1
- 212 ACC0
- 213 C_CALL1 caml_input_int
- 215 RETURN 1
- 217 ACC0
- 218 C_CALL1 input_value
- 220 RETURN 1
- 222 RESTART
- 223 GRAB 1
- 225 ACC1
- 226 PUSHACC1
- 227 C_CALL2 caml_seek_in
- 229 RETURN 2
- 231 ACC0
- 232 C_CALL1 caml_pos_in
- 234 RETURN 1
- 236 ACC0
- 237 C_CALL1 caml_channel_size
- 239 RETURN 1
- 241 ACC0
- 242 C_CALL1 caml_close_channel
- 244 RETURN 1
- 246 RESTART
- 247 GRAB 1
- 249 ACC1
- 250 PUSHACC1
- 251 C_CALL2 caml_set_binary_mode
- 253 RETURN 2
- 255 CONST0
- 256 PUSHENVACC1
- 257 APPLY1
- 258 ACC0
- 259 C_CALL1 sys_exit
- 261 RETURN 1
- 263 CONST0
- 264 PUSHENVACC1
- 265 GETFIELD0
- 266 APPTERM1 2
- 268 CONST0
- 269 PUSHENVACC1
- 270 APPLY1
- 271 CONST0
- 272 PUSHENVACC2
- 273 APPTERM1 2
- 275 ENVACC1
- 276 GETFIELD0
- 277 PUSHACC0
- 278 PUSHACC2
- 279 CLOSURE 2, 268
- 282 PUSHENVACC1
- 283 SETFIELD0
- 284 RETURN 2
- 286 ENVACC1
- 287 C_CALL1 caml_flush
- 289 ENVACC2
- 290 C_CALL1 caml_flush
- 292 RETURN 1
- 294 CONST0
- 295 PUSHENVACC1
- 296 APPLY1
- 297 C_CALL1 float_of_string
- 299 RETURN 1
- 301 CONST0
- 302 PUSHENVACC1
- 303 APPLY1
- 304 C_CALL1 int_of_string
- 306 RETURN 1
- 308 ENVACC2
- 309 C_CALL1 caml_flush
- 311 ENVACC1
- 312 PUSHENVACC3
- 313 APPTERM1 2
- 315 CONSTINT 13
- 317 PUSHENVACC1
- 318 C_CALL2 caml_output_char
- 320 ENVACC1
- 321 C_CALL1 caml_flush
- 323 RETURN 1
- 325 ACC0
- 326 PUSHENVACC1
- 327 PUSHENVACC2
- 328 APPLY2
- 329 CONSTINT 13
- 331 PUSHENVACC1
- 332 C_CALL2 caml_output_char
- 334 ENVACC1
- 335 C_CALL1 caml_flush
- 337 RETURN 1
- 339 ACC0
- 340 PUSHENVACC1
- 341 APPLY1
- 342 PUSHENVACC2
- 343 PUSHENVACC3
- 344 APPTERM2 3
- 346 ACC0
- 347 PUSHENVACC1
- 348 APPLY1
- 349 PUSHENVACC2
- 350 PUSHENVACC3
- 351 APPTERM2 3
- 353 ACC0
- 354 PUSHENVACC1
- 355 PUSHENVACC2
- 356 APPTERM2 3
- 358 ACC0
- 359 PUSHENVACC1
- 360 C_CALL2 caml_output_char
- 362 RETURN 1
- 364 CONSTINT 13
- 366 PUSHENVACC1
- 367 C_CALL2 caml_output_char
- 369 ENVACC1
- 370 C_CALL1 caml_flush
- 372 RETURN 1
- 374 ACC0
- 375 PUSHENVACC1
- 376 PUSHENVACC2
- 377 APPLY2
- 378 CONSTINT 13
- 380 PUSHENVACC1
- 381 C_CALL2 caml_output_char
- 383 RETURN 1
- 385 ACC0
- 386 PUSHENVACC1
- 387 APPLY1
- 388 PUSHENVACC2
- 389 PUSHENVACC3
- 390 APPTERM2 3
- 392 ACC0
- 393 PUSHENVACC1
- 394 APPLY1
- 395 PUSHENVACC2
- 396 PUSHENVACC3
- 397 APPTERM2 3
- 399 ACC0
- 400 PUSHENVACC1
- 401 PUSHENVACC2
- 402 APPTERM2 3
- 404 ACC0
- 405 PUSHENVACC1
- 406 C_CALL2 caml_output_char
- 408 RETURN 1
- 410 RESTART
- 411 GRAB 3
- 413 CONST0
- 414 PUSHACC3
- 415 LTINT
- 416 BRANCHIF 427
- 418 ACC1
- 419 C_CALL1 ml_string_length
- 421 PUSHACC4
- 422 PUSHACC4
- 423 ADDINT
- 424 GTINT
- 425 BRANCHIFNOT 432
- 427 GETGLOBAL "really_input"
- 429 PUSHENVACC1
- 430 APPTERM1 5
- 432 ACC3
- 433 PUSHACC3
- 434 PUSHACC3
- 435 PUSHACC3
- 436 PUSHENVACC2
- 437 APPTERM 4, 8
- 440 RESTART
- 441 GRAB 3
- 443 CONST0
- 444 PUSHACC3
- 445 LTINT
- 446 BRANCHIF 457
- 448 ACC1
- 449 C_CALL1 ml_string_length
- 451 PUSHACC4
- 452 PUSHACC4
- 453 ADDINT
- 454 GTINT
- 455 BRANCHIFNOT 462
- 457 GETGLOBAL "input"
- 459 PUSHENVACC1
- 460 APPTERM1 5
- 462 ACC3
- 463 PUSHACC3
- 464 PUSHACC3
- 465 PUSHACC3
- 466 C_CALL4 caml_input
- 468 RETURN 4
- 470 ACC0
- 471 PUSHCONST0
- 472 PUSHGETGLOBAL <0>(0, <0>(6, 0))
- 474 PUSHENVACC1
- 475 APPTERM3 4
- 477 ACC0
- 478 PUSHCONST0
- 479 PUSHGETGLOBAL <0>(0, <0>(7, 0))
- 481 PUSHENVACC1
- 482 APPTERM3 4
- 484 RESTART
- 485 GRAB 2
- 487 ACC1
- 488 PUSHACC1
- 489 PUSHACC4
- 490 C_CALL3 sys_open
- 492 C_CALL1 caml_open_descriptor
- 494 RETURN 3
- 496 ACC0
- 497 C_CALL1 caml_flush
- 499 ACC0
- 500 C_CALL1 caml_close_channel
- 502 RETURN 1
- 504 RESTART
- 505 GRAB 1
- 507 CONST0
- 508 PUSHACC2
- 509 PUSHACC2
- 510 C_CALL3 output_value
- 512 RETURN 2
- 514 RESTART
- 515 GRAB 3
- 517 CONST0
- 518 PUSHACC3
- 519 LTINT
- 520 BRANCHIF 531
- 522 ACC1
- 523 C_CALL1 ml_string_length
- 525 PUSHACC4
- 526 PUSHACC4
- 527 ADDINT
- 528 GTINT
- 529 BRANCHIFNOT 536
- 531 GETGLOBAL "output"
- 533 PUSHENVACC1
- 534 APPTERM1 5
- 536 ACC3
- 537 PUSHACC3
- 538 PUSHACC3
- 539 PUSHACC3
- 540 C_CALL4 caml_output
- 542 RETURN 4
- 544 RESTART
- 545 GRAB 1
- 547 ACC1
- 548 C_CALL1 ml_string_length
- 550 PUSHCONST0
- 551 PUSHACC3
- 552 PUSHACC3
- 553 C_CALL4 caml_output
- 555 RETURN 2
- 557 ACC0
- 558 PUSHCONSTINT 438
- 560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0))))
- 562 PUSHENVACC1
- 563 APPTERM3 4
- 565 ACC0
- 566 PUSHCONSTINT 438
- 568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0))))
- 570 PUSHENVACC1
- 571 APPTERM3 4
- 573 RESTART
- 574 GRAB 2
- 576 ACC1
- 577 PUSHACC1
- 578 PUSHACC4
- 579 C_CALL3 sys_open
- 581 C_CALL1 caml_open_descriptor
- 583 RETURN 3
- 585 ACC0
- 586 PUSHGETGLOBAL "%.12g"
- 588 C_CALL2 format_float
- 590 RETURN 1
- 592 ACC0
- 593 PUSHGETGLOBAL "%d"
- 595 C_CALL2 format_int
- 597 RETURN 1
- 599 GETGLOBAL "false"
- 601 PUSHACC1
- 602 C_CALL2 string_equal
- 604 BRANCHIFNOT 609
- 606 CONST0
- 607 RETURN 1
- 609 GETGLOBAL "true"
- 611 PUSHACC1
- 612 C_CALL2 string_equal
- 614 BRANCHIFNOT 619
- 616 CONST1
- 617 RETURN 1
- 619 GETGLOBAL "bool_of_string"
- 621 PUSHENVACC1
- 622 APPTERM1 2
- 624 ACC0
- 625 BRANCHIFNOT 631
- 627 GETGLOBAL "true"
- 629 RETURN 1
- 631 GETGLOBAL "false"
- 633 RETURN 1
- 635 CONST0
- 636 PUSHACC1
- 637 LTINT
- 638 BRANCHIF 646
- 640 CONSTINT 255
- 642 PUSHACC1
- 643 GTINT
- 644 BRANCHIFNOT 651
- 646 GETGLOBAL "char_of_int"
- 648 PUSHENVACC1
- 649 APPTERM1 2
- 651 ACC0
- 652 RETURN 1
- 654 RESTART
- 655 GRAB 1
- 657 ACC0
- 658 C_CALL1 ml_string_length
- 660 PUSHACC2
- 661 C_CALL1 ml_string_length
- 663 PUSHACC0
- 664 PUSHACC2
- 665 ADDINT
- 666 C_CALL1 create_string
- 668 PUSHACC2
- 669 PUSHCONST0
- 670 PUSHACC2
- 671 PUSHCONST0
- 672 PUSHACC7
- 673 C_CALL5 blit_string
- 675 ACC1
- 676 PUSHACC3
- 677 PUSHACC2
- 678 PUSHCONST0
- 679 PUSHACC 8
- 681 C_CALL5 blit_string
- 683 ACC0
- 684 RETURN 5
- 686 CONSTINT -1
- 688 PUSHACC1
- 689 XORINT
- 690 RETURN 1
- 692 CONST0
- 693 PUSHACC1
- 694 GEINT
- 695 BRANCHIFNOT 700
- 697 ACC0
- 698 RETURN 1
- 700 ACC0
- 701 NEGINT
- 702 RETURN 1
- 704 RESTART
- 705 GRAB 1
- 707 ACC1
- 708 PUSHACC1
- 709 C_CALL2 greaterequal
- 711 BRANCHIFNOT 716
- 713 ACC0
- 714 RETURN 2
- 716 ACC1
- 717 RETURN 2
- 719 RESTART
- 720 GRAB 1
- 722 ACC1
- 723 PUSHACC1
- 724 C_CALL2 lessequal
- 726 BRANCHIFNOT 731
- 728 ACC0
- 729 RETURN 2
- 731 ACC1
- 732 RETURN 2
- 734 ACC0
- 735 PUSHGETGLOBAL Invalid_argument
- 737 MAKEBLOCK2 0
- 739 RAISE
- 740 ACC0
- 741 PUSHGETGLOBAL Failure
- 743 MAKEBLOCK2 0
- 745 RAISE
- 746 CLOSURE 0, 740
- 749 PUSH
- 750 CLOSURE 0, 734
- 753 PUSHGETGLOBAL "Pervasives.Exit"
- 755 MAKEBLOCK1 0
- 757 PUSHGETGLOBAL "Pervasives.Assert_failure"
- 759 MAKEBLOCK1 0
- 761 PUSH
- 762 CLOSURE 0, 720
- 765 PUSH
- 766 CLOSURE 0, 705
- 769 PUSH
- 770 CLOSURE 0, 692
- 773 PUSH
- 774 CLOSURE 0, 686
- 777 PUSHCONST0
- 778 PUSHCONSTINT 31
- 780 PUSHCONST1
- 781 LSLINT
- 782 EQ
- 783 BRANCHIFNOT 789
- 785 CONSTINT 30
- 787 BRANCH 791
- 789 CONSTINT 62
- 791 PUSHCONST1
- 792 LSLINT
- 793 PUSHACC0
- 794 OFFSETINT -1
- 796 PUSH
- 797 CLOSURE 0, 655
- 800 PUSHACC 9
- 802 CLOSURE 1, 635
- 805 PUSH
- 806 CLOSURE 0, 624
- 809 PUSHACC 11
- 811 CLOSURE 1, 599
- 814 PUSH
- 815 CLOSURE 0, 592
- 818 PUSH
- 819 CLOSURE 0, 585
- 822 PUSH
- 823 CLOSUREREC 0, 12
- 827 CONST0
- 828 C_CALL1 caml_open_descriptor
- 830 PUSHCONST1
- 831 C_CALL1 caml_open_descriptor
- 833 PUSHCONST2
- 834 C_CALL1 caml_open_descriptor
- 836 PUSH
- 837 CLOSURE 0, 574
- 840 PUSHACC0
- 841 CLOSURE 1, 565
- 844 PUSHACC1
- 845 CLOSURE 1, 557
- 848 PUSH
- 849 CLOSURE 0, 545
- 852 PUSHACC 22
- 854 CLOSURE 1, 515
- 857 PUSH
- 858 CLOSURE 0, 505
- 861 PUSH
- 862 CLOSURE 0, 496
- 865 PUSH
- 866 CLOSURE 0, 485
- 869 PUSHACC0
- 870 CLOSURE 1, 477
- 873 PUSHACC1
- 874 CLOSURE 1, 470
- 877 PUSHACC 28
- 879 CLOSURE 1, 441
- 882 PUSH
- 883 CLOSUREREC 0, 32
- 887 ACC0
- 888 PUSHACC 31
- 890 CLOSURE 2, 411
- 893 PUSHACC 22
- 895 CLOSUREREC 1, 70
- 899 ACC 15
- 901 CLOSURE 1, 404
- 904 PUSHACC 11
- 906 PUSHACC 17
- 908 CLOSURE 2, 399
- 911 PUSHACC 12
- 913 PUSHACC 18
- 915 PUSHACC 23
- 917 CLOSURE 3, 392
- 920 PUSHACC 13
- 922 PUSHACC 19
- 924 PUSHACC 23
- 926 CLOSURE 3, 385
- 929 PUSHACC 14
- 931 PUSHACC 20
- 933 CLOSURE 2, 374
- 936 PUSHACC 20
- 938 CLOSURE 1, 364
- 941 PUSHACC 20
- 943 CLOSURE 1, 358
- 946 PUSHACC 17
- 948 PUSHACC 22
- 950 CLOSURE 2, 353
- 953 PUSHACC 18
- 955 PUSHACC 23
- 957 PUSHACC 29
- 959 CLOSURE 3, 346
- 962 PUSHACC 19
- 964 PUSHACC 24
- 966 PUSHACC 29
- 968 CLOSURE 3, 339
- 971 PUSHACC 20
- 973 PUSHACC 25
- 975 CLOSURE 2, 325
- 978 PUSHACC 25
- 980 CLOSURE 1, 315
- 983 PUSHACC 12
- 985 PUSHACC 28
- 987 PUSHACC 30
- 989 CLOSURE 3, 308
- 992 PUSHACC0
- 993 CLOSURE 1, 301
- 996 PUSHACC1
- 997 CLOSURE 1, 294
- 1000 PUSHACC 29
- 1002 PUSHACC 31
- 1004 CLOSURE 2, 286
- 1007 MAKEBLOCK1 0
- 1009 PUSHACC0
- 1010 CLOSURE 1, 275
- 1013 PUSHACC1
- 1014 CLOSURE 1, 263
- 1017 PUSHACC0
- 1018 CLOSURE 1, 255
- 1021 PUSHACC1
- 1022 PUSHACC 22
- 1024 PUSHACC4
- 1025 PUSHACC3
- 1026 PUSH
- 1027 CLOSURE 0, 247
- 1030 PUSH
- 1031 CLOSURE 0, 241
- 1034 PUSH
- 1035 CLOSURE 0, 236
- 1038 PUSH
- 1039 CLOSURE 0, 231
- 1042 PUSH
- 1043 CLOSURE 0, 223
- 1046 PUSH
- 1047 CLOSURE 0, 217
- 1050 PUSH
- 1051 CLOSURE 0, 212
- 1054 PUSH
- 1055 CLOSURE 0, 207
- 1058 PUSHACC 32
- 1060 PUSHACC 35
- 1062 PUSHACC 33
- 1064 PUSH
- 1065 CLOSURE 0, 202
- 1068 PUSHACC 41
- 1070 PUSHACC 40
- 1072 PUSHACC 42
- 1074 PUSH
- 1075 CLOSURE 0, 194
- 1078 PUSHACC 46
- 1080 PUSH
- 1081 CLOSURE 0, 188
- 1084 PUSH
- 1085 CLOSURE 0, 183
- 1088 PUSH
- 1089 CLOSURE 0, 175
- 1092 PUSHACC 51
- 1094 PUSH
- 1095 CLOSURE 0, 166
- 1098 PUSH
- 1099 CLOSURE 0, 157
- 1102 PUSHACC 55
- 1104 PUSHACC 57
- 1106 PUSH
- 1107 CLOSURE 0, 148
- 1110 PUSH
- 1111 CLOSURE 0, 142
- 1114 PUSHACC 63
- 1116 PUSHACC 62
- 1118 PUSHACC 64
- 1120 PUSHACC 38
- 1122 PUSHACC 40
- 1124 PUSHACC 42
- 1126 PUSHACC 44
- 1128 PUSHACC 46
- 1130 PUSHACC 48
- 1132 PUSHACC 50
- 1134 PUSHACC 52
- 1136 PUSHACC 54
- 1138 PUSHACC 56
- 1140 PUSHACC 58
- 1142 PUSHACC 60
- 1144 PUSHACC 62
- 1146 PUSHACC 64
- 1148 PUSHACC 66
- 1150 PUSHACC 82
- 1152 PUSHACC 84
- 1154 PUSHACC 86
- 1156 PUSHACC 88
- 1158 PUSHACC 90
- 1160 PUSHACC 92
- 1162 PUSHACC 94
- 1164 PUSHACC 96
- 1166 PUSHACC 98
- 1168 PUSHACC 100
- 1170 PUSHACC 104
- 1172 PUSHACC 104
- 1174 PUSHACC 104
- 1176 PUSHACC 108
- 1178 PUSHACC 110
- 1180 PUSHACC 112
- 1182 PUSHACC 117
- 1184 PUSHACC 117
- 1186 PUSHACC 117
- 1188 PUSHACC 117
- 1190 MAKEBLOCK 69, 0
- 1193 POP 53
- 1195 SETGLOBAL Pervasives
- 1197 BRANCH 2177
- 1199 RESTART
- 1200 GRAB 1
- 1202 ACC1
- 1203 BRANCHIFNOT 1213
- 1205 ACC1
- 1206 GETFIELD1
- 1207 PUSHACC1
- 1208 OFFSETINT 1
- 1210 PUSHOFFSETCLOSURE0
- 1211 APPTERM2 4
- 1213 ACC0
- 1214 RETURN 2
- 1216 RESTART
- 1217 GRAB 1
- 1219 ACC0
- 1220 BRANCHIFNOT 1251
- 1222 CONST0
- 1223 PUSHACC2
- 1224 EQ
- 1225 BRANCHIFNOT 1231
- 1227 ACC0
- 1228 GETFIELD0
- 1229 RETURN 2
- 1231 CONST0
- 1232 PUSHACC2
- 1233 GTINT
- 1234 BRANCHIFNOT 1244
- 1236 ACC1
- 1237 OFFSETINT -1
- 1239 PUSHACC1
- 1240 GETFIELD1
- 1241 PUSHOFFSETCLOSURE0
- 1242 APPTERM2 4
- 1244 GETGLOBAL "List.nth"
- 1246 PUSHGETGLOBALFIELD Pervasives, 2
- 1249 APPTERM1 3
- 1251 GETGLOBAL "nth"
- 1253 PUSHGETGLOBALFIELD Pervasives, 3
- 1256 APPTERM1 3
- 1258 RESTART
- 1259 GRAB 1
- 1261 ACC0
- 1262 BRANCHIFNOT 1274
- 1264 ACC1
- 1265 PUSHACC1
- 1266 GETFIELD0
- 1267 MAKEBLOCK2 0
- 1269 PUSHACC1
- 1270 GETFIELD1
- 1271 PUSHOFFSETCLOSURE0
- 1272 APPTERM2 4
- 1274 ACC1
- 1275 RETURN 2
- 1277 ACC0
- 1278 BRANCHIFNOT 1291
- 1280 ACC0
- 1281 GETFIELD1
- 1282 PUSHOFFSETCLOSURE0
- 1283 APPLY1
- 1284 PUSHACC1
- 1285 GETFIELD0
- 1286 PUSHGETGLOBALFIELD Pervasives, 16
- 1289 APPTERM2 3
- 1291 RETURN 1
- 1293 RESTART
- 1294 GRAB 1
- 1296 ACC1
- 1297 BRANCHIFNOT 1313
- 1299 ACC1
- 1300 GETFIELD0
- 1301 PUSHACC1
- 1302 APPLY1
- 1303 PUSHACC2
- 1304 GETFIELD1
- 1305 PUSHACC2
- 1306 PUSHOFFSETCLOSURE0
- 1307 APPLY2
- 1308 PUSHACC1
- 1309 MAKEBLOCK2 0
- 1311 POP 1
- 1313 RETURN 2
- 1315 RESTART
- 1316 GRAB 1
- 1318 ACC1
- 1319 BRANCHIFNOT 1331
- 1321 ACC1
- 1322 GETFIELD0
- 1323 PUSHACC1
- 1324 APPLY1
- 1325 ACC1
- 1326 GETFIELD1
- 1327 PUSHACC1
- 1328 PUSHOFFSETCLOSURE0
- 1329 APPTERM2 4
- 1331 RETURN 2
- 1333 RESTART
- 1334 GRAB 2
- 1336 ACC2
- 1337 BRANCHIFNOT 1350
- 1339 ACC2
- 1340 GETFIELD1
- 1341 PUSHACC3
- 1342 GETFIELD0
- 1343 PUSHACC3
- 1344 PUSHACC3
- 1345 APPLY2
- 1346 PUSHACC2
- 1347 PUSHOFFSETCLOSURE0
- 1348 APPTERM3 6
- 1350 ACC1
- 1351 RETURN 3
- 1353 RESTART
- 1354 GRAB 2
- 1356 ACC1
- 1357 BRANCHIFNOT 1370
- 1359 ACC2
- 1360 PUSHACC2
- 1361 GETFIELD1
- 1362 PUSHACC2
- 1363 PUSHOFFSETCLOSURE0
- 1364 APPLY3
- 1365 PUSHACC2
- 1366 GETFIELD0
- 1367 PUSHACC2
- 1368 APPTERM2 5
- 1370 ACC2
- 1371 RETURN 3
- 1373 RESTART
- 1374 GRAB 2
- 1376 ACC1
- 1377 BRANCHIFNOT 1400
- 1379 ACC2
- 1380 BRANCHIFNOT 1407
- 1382 ACC2
- 1383 GETFIELD0
- 1384 PUSHACC2
- 1385 GETFIELD0
- 1386 PUSHACC2
- 1387 APPLY2
- 1388 PUSHACC3
- 1389 GETFIELD1
- 1390 PUSHACC3
- 1391 GETFIELD1
- 1392 PUSHACC3
- 1393 PUSHOFFSETCLOSURE0
- 1394 APPLY3
- 1395 PUSHACC1
- 1396 MAKEBLOCK2 0
- 1398 RETURN 4
- 1400 ACC2
- 1401 BRANCHIFNOT 1405
- 1403 BRANCH 1407
- 1405 RETURN 3
- 1407 GETGLOBAL "List.map2"
- 1409 PUSHGETGLOBALFIELD Pervasives, 2
- 1412 APPTERM1 4
- 1414 RESTART
- 1415 GRAB 2
- 1417 ACC1
- 1418 BRANCHIFNOT 1437
- 1420 ACC2
- 1421 BRANCHIFNOT 1444
- 1423 ACC2
- 1424 GETFIELD0
- 1425 PUSHACC2
- 1426 GETFIELD0
- 1427 PUSHACC2
- 1428 APPLY2
- 1429 ACC2
- 1430 GETFIELD1
- 1431 PUSHACC2
- 1432 GETFIELD1
- 1433 PUSHACC2
- 1434 PUSHOFFSETCLOSURE0
- 1435 APPTERM3 6
- 1437 ACC2
- 1438 BRANCHIFNOT 1442
- 1440 BRANCH 1444
- 1442 RETURN 3
- 1444 GETGLOBAL "List.iter2"
- 1446 PUSHGETGLOBALFIELD Pervasives, 2
- 1449 APPTERM1 4
- 1451 RESTART
- 1452 GRAB 3
- 1454 ACC2
- 1455 BRANCHIFNOT 1476
- 1457 ACC3
- 1458 BRANCHIFNOT 1482
- 1460 ACC3
- 1461 GETFIELD1
- 1462 PUSHACC3
- 1463 GETFIELD1
- 1464 PUSHACC5
- 1465 GETFIELD0
- 1466 PUSHACC5
- 1467 GETFIELD0
- 1468 PUSHACC5
- 1469 PUSHACC5
- 1470 APPLY3
- 1471 PUSHACC3
- 1472 PUSHOFFSETCLOSURE0
- 1473 APPTERM 4, 8
- 1476 ACC3
- 1477 BRANCHIF 1482
- 1479 ACC1
- 1480 RETURN 4
- 1482 GETGLOBAL "List.fold_left2"
- 1484 PUSHGETGLOBALFIELD Pervasives, 2
- 1487 APPTERM1 5
- 1489 RESTART
- 1490 GRAB 3
- 1492 ACC1
- 1493 BRANCHIFNOT 1516
- 1495 ACC2
- 1496 BRANCHIFNOT 1522
- 1498 PUSH_RETADDR 1509
- 1500 ACC6
- 1501 PUSHACC6
- 1502 GETFIELD1
- 1503 PUSHACC6
- 1504 GETFIELD1
- 1505 PUSHACC6
- 1506 PUSHOFFSETCLOSURE0
- 1507 APPLY 4
- 1509 PUSHACC3
- 1510 GETFIELD0
- 1511 PUSHACC3
- 1512 GETFIELD0
- 1513 PUSHACC3
- 1514 APPTERM3 7
- 1516 ACC2
- 1517 BRANCHIF 1522
- 1519 ACC3
- 1520 RETURN 4
- 1522 GETGLOBAL "List.fold_right2"
- 1524 PUSHGETGLOBALFIELD Pervasives, 2
- 1527 APPTERM1 5
- 1529 RESTART
- 1530 GRAB 1
- 1532 ACC1
- 1533 BRANCHIFNOT 1549
- 1535 ACC1
- 1536 GETFIELD0
- 1537 PUSHACC1
- 1538 APPLY1
- 1539 BRANCHIFNOT 1547
- 1541 ACC1
- 1542 GETFIELD1
- 1543 PUSHACC1
- 1544 PUSHOFFSETCLOSURE0
- 1545 APPTERM2 4
- 1547 RETURN 2
- 1549 CONST1
- 1550 RETURN 2
- 1552 RESTART
- 1553 GRAB 1
- 1555 ACC1
- 1556 BRANCHIFNOT 1570
- 1558 ACC1
- 1559 GETFIELD0
- 1560 PUSHACC1
- 1561 APPLY1
- 1562 BRANCHIF 1570
- 1564 ACC1
- 1565 GETFIELD1
- 1566 PUSHACC1
- 1567 PUSHOFFSETCLOSURE0
- 1568 APPTERM2 4
- 1570 RETURN 2
- 1572 RESTART
- 1573 GRAB 2
- 1575 ACC1
- 1576 BRANCHIFNOT 1599
- 1578 ACC2
- 1579 BRANCHIFNOT 1605
- 1581 ACC2
- 1582 GETFIELD0
- 1583 PUSHACC2
- 1584 GETFIELD0
- 1585 PUSHACC2
- 1586 APPLY2
- 1587 BRANCHIFNOT 1597
- 1589 ACC2
- 1590 GETFIELD1
- 1591 PUSHACC2
- 1592 GETFIELD1
- 1593 PUSHACC2
- 1594 PUSHOFFSETCLOSURE0
- 1595 APPTERM3 6
- 1597 RETURN 3
- 1599 ACC2
- 1600 BRANCHIF 1605
- 1602 CONST1
- 1603 RETURN 3
- 1605 GETGLOBAL "List.for_all2"
- 1607 PUSHGETGLOBALFIELD Pervasives, 2
- 1610 APPTERM1 4
- 1612 RESTART
- 1613 GRAB 2
- 1615 ACC1
- 1616 BRANCHIFNOT 1639
- 1618 ACC2
- 1619 BRANCHIFNOT 1646
- 1621 ACC2
- 1622 GETFIELD0
- 1623 PUSHACC2
- 1624 GETFIELD0
- 1625 PUSHACC2
- 1626 APPLY2
- 1627 BRANCHIF 1637
- 1629 ACC2
- 1630 GETFIELD1
- 1631 PUSHACC2
- 1632 GETFIELD1
- 1633 PUSHACC2
- 1634 PUSHOFFSETCLOSURE0
- 1635 APPTERM3 6
- 1637 RETURN 3
- 1639 ACC2
- 1640 BRANCHIFNOT 1644
- 1642 BRANCH 1646
- 1644 RETURN 3
- 1646 GETGLOBAL "List.exists2"
- 1648 PUSHGETGLOBALFIELD Pervasives, 2
- 1651 APPTERM1 4
- 1653 RESTART
- 1654 GRAB 1
- 1656 ACC1
- 1657 BRANCHIFNOT 1672
- 1659 ACC0
- 1660 PUSHACC2
- 1661 GETFIELD0
- 1662 C_CALL2 equal
- 1664 BRANCHIF 1672
- 1666 ACC1
- 1667 GETFIELD1
- 1668 PUSHACC1
- 1669 PUSHOFFSETCLOSURE0
- 1670 APPTERM2 4
- 1672 RETURN 2
- 1674 RESTART
- 1675 GRAB 1
- 1677 ACC1
- 1678 BRANCHIFNOT 1692
- 1680 ACC0
- 1681 PUSHACC2
- 1682 GETFIELD0
- 1683 EQ
- 1684 BRANCHIF 1692
- 1686 ACC1
- 1687 GETFIELD1
- 1688 PUSHACC1
- 1689 PUSHOFFSETCLOSURE0
- 1690 APPTERM2 4
- 1692 RETURN 2
- 1694 RESTART
- 1695 GRAB 1
- 1697 ACC1
- 1698 BRANCHIFNOT 1719
- 1700 ACC1
- 1701 GETFIELD0
- 1702 PUSHACC1
- 1703 PUSHACC1
- 1704 GETFIELD0
- 1705 C_CALL2 equal
- 1707 BRANCHIFNOT 1713
- 1709 ACC0
- 1710 GETFIELD1
- 1711 RETURN 3
- 1713 ACC2
- 1714 GETFIELD1
- 1715 PUSHACC2
- 1716 PUSHOFFSETCLOSURE0
- 1717 APPTERM2 5
- 1719 GETGLOBAL Not_found
- 1721 MAKEBLOCK1 0
- 1723 RAISE
- 1724 RESTART
- 1725 GRAB 1
- 1727 ACC1
- 1728 BRANCHIFNOT 1748
- 1730 ACC1
- 1731 GETFIELD0
- 1732 PUSHACC1
- 1733 PUSHACC1
- 1734 GETFIELD0
- 1735 EQ
- 1736 BRANCHIFNOT 1742
- 1738 ACC0
- 1739 GETFIELD1
- 1740 RETURN 3
- 1742 ACC2
- 1743 GETFIELD1
- 1744 PUSHACC2
- 1745 PUSHOFFSETCLOSURE0
- 1746 APPTERM2 5
- 1748 GETGLOBAL Not_found
- 1750 MAKEBLOCK1 0
- 1752 RAISE
- 1753 RESTART
- 1754 GRAB 1
- 1756 ACC1
- 1757 BRANCHIFNOT 1773
- 1759 ACC0
- 1760 PUSHACC2
- 1761 GETFIELD0
- 1762 GETFIELD0
- 1763 C_CALL2 equal
- 1765 BRANCHIF 1773
- 1767 ACC1
- 1768 GETFIELD1
- 1769 PUSHACC1
- 1770 PUSHOFFSETCLOSURE0
- 1771 APPTERM2 4
- 1773 RETURN 2
- 1775 RESTART
- 1776 GRAB 1
- 1778 ACC1
- 1779 BRANCHIFNOT 1794
- 1781 ACC0
- 1782 PUSHACC2
- 1783 GETFIELD0
- 1784 GETFIELD0
- 1785 EQ
- 1786 BRANCHIF 1794
- 1788 ACC1
- 1789 GETFIELD1
- 1790 PUSHACC1
- 1791 PUSHOFFSETCLOSURE0
- 1792 APPTERM2 4
- 1794 RETURN 2
- 1796 RESTART
- 1797 GRAB 1
- 1799 ACC1
- 1800 BRANCHIFNOT 1825
- 1802 ACC1
- 1803 GETFIELD0
- 1804 PUSHACC2
- 1805 GETFIELD1
- 1806 PUSHACC2
- 1807 PUSHACC2
- 1808 GETFIELD0
- 1809 C_CALL2 equal
- 1811 BRANCHIFNOT 1816
- 1813 ACC0
- 1814 RETURN 4
- 1816 ACC0
- 1817 PUSHACC3
- 1818 PUSHOFFSETCLOSURE0
- 1819 APPLY2
- 1820 PUSHACC2
- 1821 MAKEBLOCK2 0
- 1823 POP 2
- 1825 RETURN 2
- 1827 RESTART
- 1828 GRAB 1
- 1830 ACC1
- 1831 BRANCHIFNOT 1855
- 1833 ACC1
- 1834 GETFIELD0
- 1835 PUSHACC2
- 1836 GETFIELD1
- 1837 PUSHACC2
- 1838 PUSHACC2
- 1839 GETFIELD0
- 1840 EQ
- 1841 BRANCHIFNOT 1846
- 1843 ACC0
- 1844 RETURN 4
- 1846 ACC0
- 1847 PUSHACC3
- 1848 PUSHOFFSETCLOSURE0
- 1849 APPLY2
- 1850 PUSHACC2
- 1851 MAKEBLOCK2 0
- 1853 POP 2
- 1855 RETURN 2
- 1857 RESTART
- 1858 GRAB 1
- 1860 ACC1
- 1861 BRANCHIFNOT 1879
- 1863 ACC1
- 1864 GETFIELD0
- 1865 PUSHACC0
- 1866 PUSHACC2
- 1867 APPLY1
- 1868 BRANCHIFNOT 1873
- 1870 ACC0
- 1871 RETURN 3
- 1873 ACC2
- 1874 GETFIELD1
- 1875 PUSHACC2
- 1876 PUSHOFFSETCLOSURE0
- 1877 APPTERM2 5
- 1879 GETGLOBAL Not_found
- 1881 MAKEBLOCK1 0
- 1883 RAISE
- 1884 RESTART
- 1885 GRAB 2
- 1887 ACC2
- 1888 BRANCHIFNOT 1917
- 1890 ACC2
- 1891 GETFIELD0
- 1892 PUSHACC3
- 1893 GETFIELD1
- 1894 PUSHACC1
- 1895 PUSHENVACC2
- 1896 APPLY1
- 1897 BRANCHIFNOT 1908
- 1899 ACC0
- 1900 PUSHACC4
- 1901 PUSHACC4
- 1902 PUSHACC4
- 1903 MAKEBLOCK2 0
- 1905 PUSHOFFSETCLOSURE0
- 1906 APPTERM3 8
- 1908 ACC0
- 1909 PUSHACC4
- 1910 PUSHACC3
- 1911 MAKEBLOCK2 0
- 1913 PUSHACC4
- 1914 PUSHOFFSETCLOSURE0
- 1915 APPTERM3 8
- 1917 ACC1
- 1918 PUSHENVACC1
- 1919 APPLY1
- 1920 PUSHACC1
- 1921 PUSHENVACC1
- 1922 APPLY1
- 1923 MAKEBLOCK2 0
- 1925 RETURN 3
- 1927 RESTART
- 1928 GRAB 1
- 1930 ACC0
- 1931 PUSHENVACC1
- 1932 CLOSUREREC 2, 1885
- 1936 ACC2
- 1937 PUSHCONST0
- 1938 PUSHCONST0
- 1939 PUSHACC3
- 1940 APPTERM3 6
- 1942 ACC0
- 1943 BRANCHIFNOT 1967
- 1945 ACC0
- 1946 GETFIELD0
- 1947 PUSHACC1
- 1948 GETFIELD1
- 1949 PUSHOFFSETCLOSURE0
- 1950 APPLY1
- 1951 PUSHACC0
- 1952 GETFIELD1
- 1953 PUSHACC2
- 1954 GETFIELD1
- 1955 MAKEBLOCK2 0
- 1957 PUSHACC1
- 1958 GETFIELD0
- 1959 PUSHACC3
- 1960 GETFIELD0
- 1961 MAKEBLOCK2 0
- 1963 MAKEBLOCK2 0
- 1965 RETURN 3
- 1967 GETGLOBAL <0>(0, 0)
- 1969 RETURN 1
- 1971 RESTART
- 1972 GRAB 1
- 1974 ACC0
- 1975 BRANCHIFNOT 1996
- 1977 ACC1
- 1978 BRANCHIFNOT 2003
- 1980 ACC1
- 1981 GETFIELD1
- 1982 PUSHACC1
- 1983 GETFIELD1
- 1984 PUSHOFFSETCLOSURE0
- 1985 APPLY2
- 1986 PUSHACC2
- 1987 GETFIELD0
- 1988 PUSHACC2
- 1989 GETFIELD0
- 1990 MAKEBLOCK2 0
- 1992 MAKEBLOCK2 0
- 1994 RETURN 2
- 1996 ACC1
- 1997 BRANCHIFNOT 2001
- 1999 BRANCH 2003
- 2001 RETURN 2
- 2003 GETGLOBAL "List.combine"
- 2005 PUSHGETGLOBALFIELD Pervasives, 2
- 2008 APPTERM1 3
- 2010 RESTART
- 2011 GRAB 1
- 2013 ACC1
- 2014 BRANCHIFNOT 2038
- 2016 ACC1
- 2017 GETFIELD0
- 2018 PUSHACC2
- 2019 GETFIELD1
- 2020 PUSHACC1
- 2021 PUSHENVACC2
- 2022 APPLY1
- 2023 BRANCHIFNOT 2033
- 2025 ACC0
- 2026 PUSHACC3
- 2027 PUSHACC3
- 2028 MAKEBLOCK2 0
- 2030 PUSHOFFSETCLOSURE0
- 2031 APPTERM2 6
- 2033 ACC0
- 2034 PUSHACC3
- 2035 PUSHOFFSETCLOSURE0
- 2036 APPTERM2 6
- 2038 ACC0
- 2039 PUSHENVACC1
- 2040 APPTERM1 3
- 2042 ACC0
- 2043 PUSHENVACC1
- 2044 CLOSUREREC 2, 2011
- 2048 CONST0
- 2049 PUSHACC1
- 2050 APPTERM1 3
- 2052 RESTART
- 2053 GRAB 2
- 2055 ACC1
- 2056 BRANCHIFNOT 2077
- 2058 ACC2
- 2059 BRANCHIFNOT 2084
- 2061 ACC2
- 2062 GETFIELD1
- 2063 PUSHACC2
- 2064 GETFIELD1
- 2065 PUSHACC2
- 2066 PUSHACC5
- 2067 GETFIELD0
- 2068 PUSHACC5
- 2069 GETFIELD0
- 2070 PUSHENVACC1
- 2071 APPLY2
- 2072 MAKEBLOCK2 0
- 2074 PUSHOFFSETCLOSURE0
- 2075 APPTERM3 6
- 2077 ACC2
- 2078 BRANCHIFNOT 2082
- 2080 BRANCH 2084
- 2082 RETURN 3
- 2084 GETGLOBAL "List.rev_map2"
- 2086 PUSHGETGLOBALFIELD Pervasives, 2
- 2089 APPTERM1 4
- 2091 RESTART
- 2092 GRAB 2
- 2094 ACC0
- 2095 CLOSUREREC 1, 2053
- 2099 ACC3
- 2100 PUSHACC3
- 2101 PUSHCONST0
- 2102 PUSHACC3
- 2103 APPTERM3 7
- 2105 RESTART
- 2106 GRAB 1
- 2108 ACC1
- 2109 BRANCHIFNOT 2123
- 2111 ACC1
- 2112 GETFIELD1
- 2113 PUSHACC1
- 2114 PUSHACC3
- 2115 GETFIELD0
- 2116 PUSHENVACC1
- 2117 APPLY1
- 2118 MAKEBLOCK2 0
- 2120 PUSHOFFSETCLOSURE0
- 2121 APPTERM2 4
- 2123 ACC0
- 2124 RETURN 2
- 2126 RESTART
- 2127 GRAB 1
- 2129 ACC0
- 2130 CLOSUREREC 1, 2106
- 2134 ACC2
- 2135 PUSHCONST0
- 2136 PUSHACC2
- 2137 APPTERM2 5
- 2139 CONST0
- 2140 PUSHACC1
- 2141 PUSHENVACC1
- 2142 APPTERM2 3
- 2144 ACC0
- 2145 BRANCHIFNOT 2151
- 2147 ACC0
- 2148 GETFIELD1
- 2149 RETURN 1
- 2151 GETGLOBAL "tl"
- 2153 PUSHGETGLOBALFIELD Pervasives, 3
- 2156 APPTERM1 2
- 2158 ACC0
- 2159 BRANCHIFNOT 2165
- 2161 ACC0
- 2162 GETFIELD0
- 2163 RETURN 1
- 2165 GETGLOBAL "hd"
- 2167 PUSHGETGLOBALFIELD Pervasives, 3
- 2170 APPTERM1 2
- 2172 ACC0
- 2173 PUSHCONST0
- 2174 PUSHENVACC1
- 2175 APPTERM2 3
- 2177 CLOSUREREC 0, 1200
- 2181 ACC0
- 2182 CLOSURE 1, 2172
- 2185 PUSH
- 2186 CLOSURE 0, 2158
- 2189 PUSH
- 2190 CLOSURE 0, 2144
- 2193 PUSH
- 2194 CLOSUREREC 0, 1217
- 2198 GETGLOBALFIELD Pervasives, 16
- 2201 PUSH
- 2202 CLOSUREREC 0, 1259
- 2206 ACC0
- 2207 CLOSURE 1, 2139
- 2210 PUSH
- 2211 CLOSUREREC 0, 1277
- 2215 CLOSUREREC 0, 1294
- 2219 CLOSURE 0, 2127
- 2222 PUSH
- 2223 CLOSUREREC 0, 1316
- 2227 CLOSUREREC 0, 1334
- 2231 CLOSUREREC 0, 1354
- 2235 CLOSUREREC 0, 1374
- 2239 CLOSURE 0, 2092
- 2242 PUSH
- 2243 CLOSUREREC 0, 1415
- 2247 CLOSUREREC 0, 1452
- 2251 CLOSUREREC 0, 1490
- 2255 CLOSUREREC 0, 1530
- 2259 CLOSUREREC 0, 1553
- 2263 CLOSUREREC 0, 1573
- 2267 CLOSUREREC 0, 1613
- 2271 CLOSUREREC 0, 1654
- 2275 CLOSUREREC 0, 1675
- 2279 CLOSUREREC 0, 1695
- 2283 CLOSUREREC 0, 1725
- 2287 CLOSUREREC 0, 1754
- 2291 CLOSUREREC 0, 1776
- 2295 CLOSUREREC 0, 1797
- 2299 CLOSUREREC 0, 1828
- 2303 CLOSUREREC 0, 1858
- 2307 ACC 24
- 2309 CLOSURE 1, 2042
- 2312 PUSHACC 25
- 2314 CLOSUREREC 1, 1928
- 2318 CLOSUREREC 0, 1942
- 2322 CLOSUREREC 0, 1972
- 2326 ACC0
- 2327 PUSHACC2
- 2328 PUSHACC7
- 2329 PUSHACC 9
- 2331 PUSHACC 11
- 2333 PUSHACC 13
- 2335 PUSHACC 15
- 2337 PUSHACC 17
- 2339 PUSHACC 10
- 2341 PUSHACC 12
- 2343 PUSHACC 13
- 2345 PUSHACC 15
- 2347 PUSHACC 23
- 2349 PUSHACC 25
- 2351 PUSHACC 27
- 2353 PUSHACC 29
- 2355 PUSHACC 31
- 2357 PUSHACC 33
- 2359 PUSHACC 35
- 2361 PUSHACC 37
- 2363 PUSHACC 40
- 2365 PUSHACC 42
- 2367 PUSHACC 41
- 2369 PUSHACC 45
- 2371 PUSHACC 47
- 2373 PUSHACC 50
- 2375 PUSHACC 52
- 2377 PUSHACC 51
- 2379 PUSHACC 55
- 2381 PUSHACC 56
- 2383 PUSHACC 59
- 2385 PUSHACC 61
- 2387 PUSHACC 60
- 2389 PUSHACC 64
- 2391 PUSHACC 66
- 2393 PUSHACC 68
- 2395 PUSHACC 70
- 2397 MAKEBLOCK 37, 0
- 2400 POP 36
- 2402 SETGLOBAL List
- 2404 BRANCH 3341
- 2406 RESTART
- 2407 GRAB 2
- 2409 ACC2
- 2410 PUSHACC2
- 2411 VECTLENGTH
- 2412 OFFSETINT -1
- 2414 PUSHCONST0
- 2415 PUSH
- 2416 BRANCH 2433
- 2418 CHECK_SIGNALS
- 2419 ACC2
- 2420 PUSHACC2
- 2421 PUSHACC6
- 2422 C_CALL2 array_unsafe_get
- 2424 PUSHACC5
- 2425 APPLY2
- 2426 ASSIGN 2
- 2428 ACC1
- 2429 OFFSETINT -1
- 2431 ASSIGN 1
- 2433 ACC0
- 2434 PUSHACC2
- 2435 GEINT
- 2436 BRANCHIF 2418
- 2438 CONST0
- 2439 POP 2
- 2441 ACC0
- 2442 RETURN 4
- 2444 RESTART
- 2445 GRAB 2
- 2447 ACC1
- 2448 PUSHCONST0
- 2449 PUSHACC4
- 2450 VECTLENGTH
- 2451 OFFSETINT -1
- 2453 PUSH
- 2454 BRANCH 2471
- 2456 CHECK_SIGNALS
- 2457 ACC1
- 2458 PUSHACC6
- 2459 C_CALL2 array_unsafe_get
- 2461 PUSHACC3
- 2462 PUSHACC5
- 2463 APPLY2
- 2464 ASSIGN 2
- 2466 ACC1
- 2467 OFFSETINT 1
- 2469 ASSIGN 1
- 2471 ACC0
- 2472 PUSHACC2
- 2473 LEINT
- 2474 BRANCHIF 2456
- 2476 CONST0
- 2477 POP 2
- 2479 ACC0
- 2480 RETURN 4
- 2482 RESTART
- 2483 GRAB 1
- 2485 ACC1
- 2486 BRANCHIFNOT 2502
- 2488 ACC1
- 2489 GETFIELD0
- 2490 PUSHACC1
- 2491 PUSHENVACC1
- 2492 C_CALL3 array_unsafe_set
- 2494 ACC1
- 2495 GETFIELD1
- 2496 PUSHACC1
- 2497 OFFSETINT 1
- 2499 PUSHOFFSETCLOSURE0
- 2500 APPTERM2 4
- 2502 ENVACC1
- 2503 RETURN 2
- 2505 ACC0
- 2506 BRANCHIFNOT 2531
- 2508 ACC0
- 2509 GETFIELD1
- 2510 PUSHACC1
- 2511 GETFIELD0
- 2512 PUSHACC1
- 2513 PUSHGETGLOBALFIELD List, 0
- 2516 APPLY1
- 2517 OFFSETINT 1
- 2519 C_CALL2 make_vect
- 2521 PUSHACC0
- 2522 CLOSUREREC 1, 2483
- 2526 ACC2
- 2527 PUSHCONST1
- 2528 PUSHACC2
- 2529 APPTERM2 6
- 2531 ATOM0
- 2532 RETURN 1
- 2534 RESTART
- 2535 GRAB 1
- 2537 CONST0
- 2538 PUSHACC1
- 2539 LTINT
- 2540 BRANCHIFNOT 2545
- 2542 ACC1
- 2543 RETURN 2
- 2545 ACC1
- 2546 PUSHACC1
- 2547 PUSHENVACC1
- 2548 C_CALL2 array_unsafe_get
- 2550 MAKEBLOCK2 0
- 2552 PUSHACC1
- 2553 OFFSETINT -1
- 2555 PUSHOFFSETCLOSURE0
- 2556 APPTERM2 4
- 2558 ACC0
- 2559 CLOSUREREC 1, 2535
- 2563 CONST0
- 2564 PUSHACC2
- 2565 VECTLENGTH
- 2566 OFFSETINT -1
- 2568 PUSHACC2
- 2569 APPTERM2 4
- 2571 RESTART
- 2572 GRAB 1
- 2574 ACC1
- 2575 VECTLENGTH
- 2576 PUSHCONST0
- 2577 PUSHACC1
- 2578 EQ
- 2579 BRANCHIFNOT 2584
- 2581 ATOM0
- 2582 RETURN 3
- 2584 CONST0
- 2585 PUSHACC3
- 2586 C_CALL2 array_unsafe_get
- 2588 PUSHCONST0
- 2589 PUSHACC3
- 2590 APPLY2
- 2591 PUSHACC1
- 2592 C_CALL2 make_vect
- 2594 PUSHCONST1
- 2595 PUSHACC2
- 2596 OFFSETINT -1
- 2598 PUSH
- 2599 BRANCH 2618
- 2601 CHECK_SIGNALS
- 2602 ACC1
- 2603 PUSHACC6
- 2604 C_CALL2 array_unsafe_get
- 2606 PUSHACC2
- 2607 PUSHACC6
- 2608 APPLY2
- 2609 PUSHACC2
- 2610 PUSHACC4
- 2611 C_CALL3 array_unsafe_set
- 2613 ACC1
- 2614 OFFSETINT 1
- 2616 ASSIGN 1
- 2618 ACC0
- 2619 PUSHACC2
- 2620 LEINT
- 2621 BRANCHIF 2601
- 2623 CONST0
- 2624 POP 2
- 2626 ACC0
- 2627 RETURN 4
- 2629 RESTART
- 2630 GRAB 1
- 2632 CONST0
- 2633 PUSHACC2
- 2634 VECTLENGTH
- 2635 OFFSETINT -1
- 2637 PUSH
- 2638 BRANCH 2653
- 2640 CHECK_SIGNALS
- 2641 ACC1
- 2642 PUSHACC4
- 2643 C_CALL2 array_unsafe_get
- 2645 PUSHACC2
- 2646 PUSHACC4
- 2647 APPLY2
- 2648 ACC1
- 2649 OFFSETINT 1
- 2651 ASSIGN 1
- 2653 ACC0
- 2654 PUSHACC2
- 2655 LEINT
- 2656 BRANCHIF 2640
- 2658 CONST0
- 2659 RETURN 4
- 2661 RESTART
- 2662 GRAB 1
- 2664 ACC1
- 2665 VECTLENGTH
- 2666 PUSHCONST0
- 2667 PUSHACC1
- 2668 EQ
- 2669 BRANCHIFNOT 2674
- 2671 ATOM0
- 2672 RETURN 3
- 2674 CONST0
- 2675 PUSHACC3
- 2676 C_CALL2 array_unsafe_get
- 2678 PUSHACC2
- 2679 APPLY1
- 2680 PUSHACC1
- 2681 C_CALL2 make_vect
- 2683 PUSHCONST1
- 2684 PUSHACC2
- 2685 OFFSETINT -1
- 2687 PUSH
- 2688 BRANCH 2706
- 2690 CHECK_SIGNALS
- 2691 ACC1
- 2692 PUSHACC6
- 2693 C_CALL2 array_unsafe_get
- 2695 PUSHACC5
- 2696 APPLY1
- 2697 PUSHACC2
- 2698 PUSHACC4
- 2699 C_CALL3 array_unsafe_set
- 2701 ACC1
- 2702 OFFSETINT 1
- 2704 ASSIGN 1
- 2706 ACC0
- 2707 PUSHACC2
- 2708 LEINT
- 2709 BRANCHIF 2690
- 2711 CONST0
- 2712 POP 2
- 2714 ACC0
- 2715 RETURN 4
- 2717 RESTART
- 2718 GRAB 1
- 2720 CONST0
- 2721 PUSHACC2
- 2722 VECTLENGTH
- 2723 OFFSETINT -1
- 2725 PUSH
- 2726 BRANCH 2740
- 2728 CHECK_SIGNALS
- 2729 ACC1
- 2730 PUSHACC4
- 2731 C_CALL2 array_unsafe_get
- 2733 PUSHACC3
- 2734 APPLY1
- 2735 ACC1
- 2736 OFFSETINT 1
- 2738 ASSIGN 1
- 2740 ACC0
- 2741 PUSHACC2
- 2742 LEINT
- 2743 BRANCHIF 2728
- 2745 CONST0
- 2746 RETURN 4
- 2748 RESTART
- 2749 GRAB 4
- 2751 CONST0
- 2752 PUSHACC5
- 2753 LTINT
- 2754 BRANCHIF 2782
- 2756 CONST0
- 2757 PUSHACC2
- 2758 LTINT
- 2759 BRANCHIF 2782
- 2761 ACC0
- 2762 VECTLENGTH
- 2763 PUSHACC5
- 2764 PUSHACC3
- 2765 ADDINT
- 2766 GTINT
- 2767 BRANCHIF 2782
- 2769 CONST0
- 2770 PUSHACC4
- 2771 LTINT
- 2772 BRANCHIF 2782
- 2774 ACC2
- 2775 VECTLENGTH
- 2776 PUSHACC5
- 2777 PUSHACC5
- 2778 ADDINT
- 2779 GTINT
- 2780 BRANCHIFNOT 2789
- 2782 GETGLOBAL "Array.blit"
- 2784 PUSHGETGLOBALFIELD Pervasives, 2
- 2787 APPTERM1 6
- 2789 ACC3
- 2790 PUSHACC2
- 2791 LTINT
- 2792 BRANCHIFNOT 2827
- 2794 ACC4
- 2795 OFFSETINT -1
- 2797 PUSHCONST0
- 2798 PUSH
- 2799 BRANCH 2819
- 2801 CHECK_SIGNALS
- 2802 ACC1
- 2803 PUSHACC4
- 2804 ADDINT
- 2805 PUSHACC3
- 2806 C_CALL2 array_unsafe_get
- 2808 PUSHACC2
- 2809 PUSHACC7
- 2810 ADDINT
- 2811 PUSHACC6
- 2812 C_CALL3 array_unsafe_set
- 2814 ACC1
- 2815 OFFSETINT -1
- 2817 ASSIGN 1
- 2819 ACC0
- 2820 PUSHACC2
- 2821 GEINT
- 2822 BRANCHIF 2801
- 2824 CONST0
- 2825 RETURN 7
- 2827 CONST0
- 2828 PUSHACC5
- 2829 OFFSETINT -1
- 2831 PUSH
- 2832 BRANCH 2852
- 2834 CHECK_SIGNALS
- 2835 ACC1
- 2836 PUSHACC4
- 2837 ADDINT
- 2838 PUSHACC3
- 2839 C_CALL2 array_unsafe_get
- 2841 PUSHACC2
- 2842 PUSHACC7
- 2843 ADDINT
- 2844 PUSHACC6
- 2845 C_CALL3 array_unsafe_set
- 2847 ACC1
- 2848 OFFSETINT 1
- 2850 ASSIGN 1
- 2852 ACC0
- 2853 PUSHACC2
- 2854 LEINT
- 2855 BRANCHIF 2834
- 2857 CONST0
- 2858 RETURN 7
- 2860 RESTART
- 2861 GRAB 3
- 2863 CONST0
- 2864 PUSHACC2
- 2865 LTINT
- 2866 BRANCHIF 2881
- 2868 CONST0
- 2869 PUSHACC3
- 2870 LTINT
- 2871 BRANCHIF 2881
- 2873 ACC0
- 2874 VECTLENGTH
- 2875 PUSHACC3
- 2876 PUSHACC3
- 2877 ADDINT
- 2878 GTINT
- 2879 BRANCHIFNOT 2888
- 2881 GETGLOBAL "Array.fill"
- 2883 PUSHGETGLOBALFIELD Pervasives, 2
- 2886 APPTERM1 5
- 2888 ACC1
- 2889 PUSHACC3
- 2890 PUSHACC3
- 2891 ADDINT
- 2892 OFFSETINT -1
- 2894 PUSH
- 2895 BRANCH 2908
- 2897 CHECK_SIGNALS
- 2898 ACC5
- 2899 PUSHACC2
- 2900 PUSHACC4
- 2901 C_CALL3 array_unsafe_set
- 2903 ACC1
- 2904 OFFSETINT 1
- 2906 ASSIGN 1
- 2908 ACC0
- 2909 PUSHACC2
- 2910 LEINT
- 2911 BRANCHIF 2897
- 2913 CONST0
- 2914 RETURN 6
- 2916 RESTART
- 2917 GRAB 2
- 2919 CONST0
- 2920 PUSHACC2
- 2921 LTINT
- 2922 BRANCHIF 2937
- 2924 CONST0
- 2925 PUSHACC3
- 2926 LTINT
- 2927 BRANCHIF 2937
- 2929 ACC0
- 2930 VECTLENGTH
- 2931 PUSHACC3
- 2932 PUSHACC3
- 2933 ADDINT
- 2934 GTINT
- 2935 BRANCHIFNOT 2944
- 2937 GETGLOBAL "Array.sub"
- 2939 PUSHGETGLOBALFIELD Pervasives, 2
- 2942 APPTERM1 4
- 2944 CONST0
- 2945 PUSHACC3
- 2946 EQ
- 2947 BRANCHIFNOT 2952
- 2949 ATOM0
- 2950 RETURN 3
- 2952 ACC1
- 2953 PUSHACC1
- 2954 C_CALL2 array_unsafe_get
- 2956 PUSHACC3
- 2957 C_CALL2 make_vect
- 2959 PUSHCONST1
- 2960 PUSHACC4
- 2961 OFFSETINT -1
- 2963 PUSH
- 2964 BRANCH 2982
- 2966 CHECK_SIGNALS
- 2967 ACC1
- 2968 PUSHACC5
- 2969 ADDINT
- 2970 PUSHACC4
- 2971 C_CALL2 array_unsafe_get
- 2973 PUSHACC2
- 2974 PUSHACC4
- 2975 C_CALL3 array_unsafe_set
- 2977 ACC1
- 2978 OFFSETINT 1
- 2980 ASSIGN 1
- 2982 ACC0
- 2983 PUSHACC2
- 2984 LEINT
- 2985 BRANCHIF 2966
- 2987 CONST0
- 2988 POP 2
- 2990 ACC0
- 2991 RETURN 4
- 2993 ACC0
- 2994 BRANCHIFNOT 3017
- 2996 ACC0
- 2997 GETFIELD0
- 2998 PUSHCONST0
- 2999 PUSHACC1
- 3000 VECTLENGTH
- 3001 GTINT
- 3002 BRANCHIFNOT 3012
- 3004 ENVACC2
- 3005 PUSHCONST0
- 3006 PUSHACC2
- 3007 C_CALL2 array_unsafe_get
- 3009 PUSHENVACC1
- 3010 APPTERM2 4
- 3012 ACC1
- 3013 GETFIELD1
- 3014 PUSHOFFSETCLOSURE0
- 3015 APPTERM1 3
- 3017 ATOM0
- 3018 RETURN 1
- 3020 ACC0
- 3021 PUSHENVACC1
- 3022 CLOSUREREC 2, 2993
- 3026 ACC1
- 3027 PUSHACC1
- 3028 APPTERM1 3
- 3030 CONST0
- 3031 PUSHACC1
- 3032 VECTLENGTH
- 3033 OFFSETINT -1
- 3035 PUSH
- 3036 BRANCH 3056
- 3038 CHECK_SIGNALS
- 3039 ACC1
- 3040 PUSHACC3
- 3041 C_CALL2 array_unsafe_get
- 3043 PUSHENVACC2
- 3044 GETFIELD0
- 3045 PUSHENVACC1
- 3046 C_CALL3 array_unsafe_set
- 3048 ENVACC2
- 3049 OFFSETREF 1
- 3051 ACC1
- 3052 OFFSETINT 1
- 3054 ASSIGN 1
- 3056 ACC0
- 3057 PUSHACC2
- 3058 LEINT
- 3059 BRANCHIF 3038
- 3061 CONST0
- 3062 RETURN 3
- 3064 RESTART
- 3065 GRAB 1
- 3067 ACC1
- 3068 VECTLENGTH
- 3069 PUSHACC1
- 3070 ADDINT
- 3071 RETURN 2
- 3073 RESTART
- 3074 GRAB 1
- 3076 ACC1
- 3077 PUSHCONST0
- 3078 PUSH
- 3079 CLOSURE 0, 3065
- 3082 PUSHGETGLOBALFIELD List, 12
- 3085 APPLY3
- 3086 PUSHACC1
- 3087 PUSHACC1
- 3088 C_CALL2 make_vect
- 3090 PUSHCONST0
- 3091 MAKEBLOCK1 0
- 3093 PUSHACC4
- 3094 PUSHACC1
- 3095 PUSHACC3
- 3096 CLOSURE 2, 3030
- 3099 PUSHGETGLOBALFIELD List, 9
- 3102 APPLY2
- 3103 ACC1
- 3104 RETURN 5
- 3106 RESTART
- 3107 GRAB 1
- 3109 ACC0
- 3110 VECTLENGTH
- 3111 PUSHACC2
- 3112 VECTLENGTH
- 3113 PUSHCONST0
- 3114 PUSHACC2
- 3115 EQ
- 3116 BRANCHIFNOT 3126
- 3118 CONST0
- 3119 PUSHACC1
- 3120 EQ
- 3121 BRANCHIFNOT 3126
- 3123 ATOM0
- 3124 RETURN 4
- 3126 CONST0
- 3127 PUSHCONST0
- 3128 PUSHACC3
- 3129 GTINT
- 3130 BRANCHIFNOT 3135
- 3132 ACC3
- 3133 BRANCH 3136
- 3135 ACC4
- 3136 C_CALL2 array_unsafe_get
- 3138 PUSHACC1
- 3139 PUSHACC3
- 3140 ADDINT
- 3141 C_CALL2 make_vect
- 3143 PUSHCONST0
- 3144 PUSHACC3
- 3145 OFFSETINT -1
- 3147 PUSH
- 3148 BRANCH 3164
- 3150 CHECK_SIGNALS
- 3151 ACC1
- 3152 PUSHACC6
- 3153 C_CALL2 array_unsafe_get
- 3155 PUSHACC2
- 3156 PUSHACC4
- 3157 C_CALL3 array_unsafe_set
- 3159 ACC1
- 3160 OFFSETINT 1
- 3162 ASSIGN 1
- 3164 ACC0
- 3165 PUSHACC2
- 3166 LEINT
- 3167 BRANCHIF 3150
- 3169 CONST0
- 3170 POP 2
- 3172 CONST0
- 3173 PUSHACC2
- 3174 OFFSETINT -1
- 3176 PUSH
- 3177 BRANCH 3195
- 3179 CHECK_SIGNALS
- 3180 ACC1
- 3181 PUSHACC7
- 3182 C_CALL2 array_unsafe_get
- 3184 PUSHACC5
- 3185 PUSHACC3
- 3186 ADDINT
- 3187 PUSHACC4
- 3188 C_CALL3 array_unsafe_set
- 3190 ACC1
- 3191 OFFSETINT 1
- 3193 ASSIGN 1
- 3195 ACC0
- 3196 PUSHACC2
- 3197 LEINT
- 3198 BRANCHIF 3179
- 3200 CONST0
- 3201 POP 2
- 3203 ACC0
- 3204 RETURN 5
- 3206 ACC0
- 3207 VECTLENGTH
- 3208 PUSHCONST0
- 3209 PUSHACC1
- 3210 EQ
- 3211 BRANCHIFNOT 3216
- 3213 ATOM0
- 3214 RETURN 2
- 3216 CONST0
- 3217 PUSHACC2
- 3218 C_CALL2 array_unsafe_get
- 3220 PUSHACC1
- 3221 C_CALL2 make_vect
- 3223 PUSHCONST1
- 3224 PUSHACC2
- 3225 OFFSETINT -1
- 3227 PUSH
- 3228 BRANCH 3244
- 3230 CHECK_SIGNALS
- 3231 ACC1
- 3232 PUSHACC5
- 3233 C_CALL2 array_unsafe_get
- 3235 PUSHACC2
- 3236 PUSHACC4
- 3237 C_CALL3 array_unsafe_set
- 3239 ACC1
- 3240 OFFSETINT 1
- 3242 ASSIGN 1
- 3244 ACC0
- 3245 PUSHACC2
- 3246 LEINT
- 3247 BRANCHIF 3230
- 3249 CONST0
- 3250 POP 2
- 3252 ACC0
- 3253 RETURN 3
- 3255 RESTART
- 3256 GRAB 2
- 3258 ATOM0
- 3259 PUSHACC1
- 3260 C_CALL2 make_vect
- 3262 PUSHCONST0
- 3263 PUSHACC2
- 3264 OFFSETINT -1
- 3266 PUSH
- 3267 BRANCH 3282
- 3269 CHECK_SIGNALS
- 3270 ACC5
- 3271 PUSHACC5
- 3272 C_CALL2 make_vect
- 3274 PUSHACC2
- 3275 PUSHACC4
- 3276 SETVECTITEM
- 3277 ACC1
- 3278 OFFSETINT 1
- 3280 ASSIGN 1
- 3282 ACC0
- 3283 PUSHACC2
- 3284 LEINT
- 3285 BRANCHIF 3269
- 3287 CONST0
- 3288 POP 2
- 3290 ACC0
- 3291 RETURN 4
- 3293 RESTART
- 3294 GRAB 1
- 3296 CONST0
- 3297 PUSHACC1
- 3298 EQ
- 3299 BRANCHIFNOT 3304
- 3301 ATOM0
- 3302 RETURN 2
- 3304 CONST0
- 3305 PUSHACC2
- 3306 APPLY1
- 3307 PUSHACC1
- 3308 C_CALL2 make_vect
- 3310 PUSHCONST1
- 3311 PUSHACC2
- 3312 OFFSETINT -1
- 3314 PUSH
- 3315 BRANCH 3330
- 3317 CHECK_SIGNALS
- 3318 ACC1
- 3319 PUSHACC5
- 3320 APPLY1
- 3321 PUSHACC2
- 3322 PUSHACC4
- 3323 C_CALL3 array_unsafe_set
- 3325 ACC1
- 3326 OFFSETINT 1
- 3328 ASSIGN 1
- 3330 ACC0
- 3331 PUSHACC2
- 3332 LEINT
- 3333 BRANCHIF 3317
- 3335 CONST0
- 3336 POP 2
- 3338 ACC0
- 3339 RETURN 3
- 3341 CLOSURE 0, 3294
- 3344 PUSH
- 3345 CLOSURE 0, 3256
- 3348 PUSH
- 3349 CLOSURE 0, 3206
- 3352 PUSH
- 3353 CLOSURE 0, 3107
- 3356 PUSH
- 3357 CLOSURE 0, 3074
- 3360 PUSHACC0
- 3361 CLOSURE 1, 3020
- 3364 PUSH
- 3365 CLOSURE 0, 2917
- 3368 PUSH
- 3369 CLOSURE 0, 2861
- 3372 PUSH
- 3373 CLOSURE 0, 2749
- 3376 PUSH
- 3377 CLOSURE 0, 2718
- 3380 PUSH
- 3381 CLOSURE 0, 2662
- 3384 PUSH
- 3385 CLOSURE 0, 2630
- 3388 PUSH
- 3389 CLOSURE 0, 2572
- 3392 PUSH
- 3393 CLOSURE 0, 2558
- 3396 PUSH
- 3397 CLOSURE 0, 2505
- 3400 PUSH
- 3401 CLOSURE 0, 2445
- 3404 PUSH
- 3405 CLOSURE 0, 2407
- 3408 PUSHACC0
- 3409 PUSHACC2
- 3410 PUSHACC6
- 3411 PUSHACC 8
- 3413 PUSHACC 10
- 3415 PUSHACC 12
- 3417 PUSHACC 8
- 3419 PUSHACC 10
- 3421 PUSHACC 16
- 3423 PUSHACC 18
- 3425 PUSHACC 24
- 3427 PUSHACC 21
- 3429 PUSHACC 23
- 3431 PUSHACC 26
- 3433 PUSHACC 29
- 3435 PUSHACC 30
- 3437 PUSHACC 32
- 3439 MAKEBLOCK 17, 0
- 3442 POP 17
- 3444 SETGLOBAL Array
- 3446 BRANCH 3480
- 3448 ENVACC1
- 3449 MAKEBLOCK1 0
- 3451 RAISE
- 3452 ACC0
- 3453 BRANCHIFNOT 3465
- 3455 ENVACC3
- 3456 CLOSURE 1, 3448
- 3459 MAKEBLOCK1 0
- 3461 PUSHENVACC2
- 3462 PUSHENVACC1
- 3463 APPTERM2 3
- 3465 CONST0
- 3466 PUSHENVACC2
- 3467 PUSHENVACC1
- 3468 APPTERM2 3
- 3470 RESTART
- 3471 GRAB 1
- 3473 ACC1
- 3474 PUSHACC1
- 3475 C_CALL2 install_signal_handler
- 3477 CONST0
- 3478 RETURN 2
- 3480 CONST0
- 3481 C_CALL1 sys_get_argv
- 3483 PUSHCONST0
- 3484 C_CALL1 sys_get_config
- 3486 PUSHACC0
- 3487 GETFIELD1
- 3488 PUSHACC0
- 3489 OFFSETINT -10
- 3491 PUSHCONST1
- 3492 LSLINT
- 3493 OFFSETINT -1
- 3495 PUSHACC0
- 3496 PUSHCONSTINT 8
- 3498 PUSHACC3
- 3499 DIVINT
- 3500 MULINT
- 3501 OFFSETINT -1
- 3503 PUSHCONST0
- 3504 MAKEBLOCK1 0
- 3506 PUSH
- 3507 CLOSURE 0, 3471
- 3510 PUSHCONSTINT -1
- 3512 PUSHCONSTINT -2
- 3514 PUSHCONSTINT -3
- 3516 PUSHCONSTINT -4
- 3518 PUSHCONSTINT -5
- 3520 PUSHCONSTINT -6
- 3522 PUSHCONSTINT -7
- 3524 PUSHCONSTINT -8
- 3526 PUSHCONSTINT -9
- 3528 PUSHCONSTINT -10
- 3530 PUSHCONSTINT -11
- 3532 PUSHCONSTINT -12
- 3534 PUSHCONSTINT -13
- 3536 PUSHCONSTINT -14
- 3538 PUSHCONSTINT -15
- 3540 PUSHCONSTINT -16
- 3542 PUSHCONSTINT -17
- 3544 PUSHCONSTINT -18
- 3546 PUSHCONSTINT -19
- 3548 PUSHCONSTINT -20
- 3550 PUSHCONSTINT -21
- 3552 PUSHGETGLOBAL "Sys.Break"
- 3554 MAKEBLOCK1 0
- 3556 PUSHACC0
- 3557 PUSHACC 17
- 3559 PUSHACC 24
- 3561 CLOSURE 3, 3452
- 3564 PUSHACC0
- 3565 PUSHACC2
- 3566 PUSHACC4
- 3567 PUSHACC6
- 3568 PUSHACC 8
- 3570 PUSHACC 10
- 3572 PUSHACC 12
- 3574 PUSHACC 14
- 3576 PUSHACC 16
- 3578 PUSHACC 18
- 3580 PUSHACC 20
- 3582 PUSHACC 22
- 3584 PUSHACC 24
- 3586 PUSHACC 26
- 3588 PUSHACC 28
- 3590 PUSHACC 30
- 3592 PUSHACC 32
- 3594 PUSHACC 34
- 3596 PUSHACC 36
- 3598 PUSHACC 38
- 3600 PUSHACC 40
- 3602 PUSHACC 42
- 3604 PUSHACC 44
- 3606 PUSHACC 46
- 3608 PUSHACC 50
- 3610 PUSHACC 50
- 3612 PUSHACC 53
- 3614 PUSHACC 55
- 3616 GETFIELD0
- 3617 PUSHACC 52
- 3619 PUSHACC 58
- 3621 MAKEBLOCK 30, 0
- 3624 POP 30
- 3626 SETGLOBAL Sys
- 3628 BRANCH 4510
- 3630 RESTART
- 3631 GRAB 1
- 3633 CONST0
- 3634 PUSHACC1
- 3635 LTINT
- 3636 BRANCHIFNOT 3641
- 3638 CONST1
- 3639 RETURN 2
- 3641 ACC1
- 3642 BRANCHIFNOT 3652
- 3644 ACC1
- 3645 GETFIELD2
- 3646 PUSHACC1
- 3647 OFFSETINT -1
- 3649 PUSHOFFSETCLOSURE0
- 3650 APPTERM2 4
- 3652 RETURN 2
- 3654 ACC0
- 3655 BRANCHIFNOT 3670
- 3657 ENVACC2
- 3658 PUSHACC1
- 3659 GETFIELD0
- 3660 PUSHENVACC1
- 3661 GETFIELD0
- 3662 APPLY2
- 3663 BRANCHIF 3670
- 3665 ACC0
- 3666 GETFIELD2
- 3667 PUSHOFFSETCLOSURE0
- 3668 APPTERM1 2
- 3670 RETURN 1
- 3672 RESTART
- 3673 GRAB 1
- 3675 ACC1
- 3676 PUSHENVACC1
- 3677 CLOSUREREC 2, 3654
- 3681 ACC1
- 3682 GETFIELD1
- 3683 VECTLENGTH
- 3684 PUSHACC3
- 3685 PUSHENVACC1
- 3686 GETFIELD1
- 3687 APPLY1
- 3688 MODINT
- 3689 PUSHACC2
- 3690 GETFIELD1
- 3691 C_CALL2 array_get_addr
- 3693 PUSHACC1
- 3694 APPTERM1 4
- 3696 ACC0
- 3697 BRANCHIFNOT 3722
- 3699 ACC0
- 3700 GETFIELD2
- 3701 PUSHENVACC2
- 3702 PUSHACC2
- 3703 GETFIELD0
- 3704 PUSHENVACC1
- 3705 GETFIELD0
- 3706 APPLY2
- 3707 BRANCHIFNOT 3718
- 3709 ACC0
- 3710 PUSHOFFSETCLOSURE0
- 3711 APPLY1
- 3712 PUSHACC2
- 3713 GETFIELD1
- 3714 MAKEBLOCK2 0
- 3716 RETURN 2
- 3718 ACC0
- 3719 PUSHOFFSETCLOSURE0
- 3720 APPTERM1 3
- 3722 RETURN 1
- 3724 RESTART
- 3725 GRAB 1
- 3727 ACC1
- 3728 PUSHENVACC1
- 3729 CLOSUREREC 2, 3696
- 3733 ACC1
- 3734 GETFIELD1
- 3735 VECTLENGTH
- 3736 PUSHACC3
- 3737 PUSHENVACC1
- 3738 GETFIELD1
- 3739 APPLY1
- 3740 MODINT
- 3741 PUSHACC2
- 3742 GETFIELD1
- 3743 C_CALL2 array_get_addr
- 3745 PUSHACC1
- 3746 APPTERM1 4
- 3748 ACC0
- 3749 BRANCHIFNOT 3768
- 3751 ACC0
- 3752 GETFIELD0
- 3753 PUSHENVACC2
- 3754 PUSHENVACC1
- 3755 GETFIELD0
- 3756 APPLY2
- 3757 BRANCHIFNOT 3763
- 3759 ACC0
- 3760 GETFIELD1
- 3761 RETURN 1
- 3763 ACC0
- 3764 GETFIELD2
- 3765 PUSHOFFSETCLOSURE0
- 3766 APPTERM1 2
- 3768 GETGLOBAL Not_found
- 3770 MAKEBLOCK1 0
- 3772 RAISE
- 3773 RESTART
- 3774 GRAB 1
- 3776 ACC0
- 3777 GETFIELD1
- 3778 VECTLENGTH
- 3779 PUSHACC2
- 3780 PUSHENVACC1
- 3781 GETFIELD1
- 3782 APPLY1
- 3783 MODINT
- 3784 PUSHACC1
- 3785 GETFIELD1
- 3786 C_CALL2 array_get_addr
- 3788 PUSHACC0
- 3789 BRANCHIFNOT 3858
- 3791 ACC0
- 3792 GETFIELD2
- 3793 PUSHACC1
- 3794 GETFIELD0
- 3795 PUSHACC4
- 3796 PUSHENVACC1
- 3797 GETFIELD0
- 3798 APPLY2
- 3799 BRANCHIFNOT 3805
- 3801 ACC1
- 3802 GETFIELD1
- 3803 RETURN 4
- 3805 ACC0
- 3806 BRANCHIFNOT 3853
- 3808 ACC0
- 3809 GETFIELD2
- 3810 PUSHACC1
- 3811 GETFIELD0
- 3812 PUSHACC5
- 3813 PUSHENVACC1
- 3814 GETFIELD0
- 3815 APPLY2
- 3816 BRANCHIFNOT 3822
- 3818 ACC1
- 3819 GETFIELD1
- 3820 RETURN 5
- 3822 ACC0
- 3823 BRANCHIFNOT 3848
- 3825 ACC0
- 3826 GETFIELD0
- 3827 PUSHACC5
- 3828 PUSHENVACC1
- 3829 GETFIELD0
- 3830 APPLY2
- 3831 BRANCHIFNOT 3837
- 3833 ACC0
- 3834 GETFIELD1
- 3835 RETURN 5
- 3837 ACC4
- 3838 PUSHENVACC1
- 3839 CLOSUREREC 2, 3748
- 3843 ACC1
- 3844 GETFIELD2
- 3845 PUSHACC1
- 3846 APPTERM1 7
- 3848 GETGLOBAL Not_found
- 3850 MAKEBLOCK1 0
- 3852 RAISE
- 3853 GETGLOBAL Not_found
- 3855 MAKEBLOCK1 0
- 3857 RAISE
- 3858 GETGLOBAL Not_found
- 3860 MAKEBLOCK1 0
- 3862 RAISE
- 3863 ACC0
- 3864 BRANCHIFNOT 3890
- 3866 ACC0
- 3867 GETFIELD0
- 3868 PUSHACC1
- 3869 GETFIELD2
- 3870 PUSHENVACC2
- 3871 PUSHACC2
- 3872 PUSHENVACC1
- 3873 GETFIELD0
- 3874 APPLY2
- 3875 BRANCHIFNOT 3880
- 3877 ACC0
- 3878 RETURN 3
- 3880 ACC0
- 3881 PUSHOFFSETCLOSURE0
- 3882 APPLY1
- 3883 PUSHACC3
- 3884 GETFIELD1
- 3885 PUSHACC3
- 3886 MAKEBLOCK3 0
- 3888 POP 2
- 3890 RETURN 1
- 3892 RESTART
- 3893 GRAB 1
- 3895 ACC1
- 3896 PUSHENVACC1
- 3897 CLOSUREREC 2, 3863
- 3901 ACC1
- 3902 GETFIELD1
- 3903 VECTLENGTH
- 3904 PUSHACC3
- 3905 PUSHENVACC1
- 3906 GETFIELD1
- 3907 APPLY1
- 3908 MODINT
- 3909 PUSHACC0
- 3910 PUSHACC3
- 3911 GETFIELD1
- 3912 C_CALL2 array_get_addr
- 3914 PUSHACC2
- 3915 APPLY1
- 3916 PUSHACC1
- 3917 PUSHACC4
- 3918 GETFIELD1
- 3919 C_CALL3 array_set_addr
- 3921 RETURN 4
- 3923 RESTART
- 3924 GRAB 2
- 3926 ACC0
- 3927 GETFIELD1
- 3928 VECTLENGTH
- 3929 PUSHACC2
- 3930 PUSHENVACC3
- 3931 GETFIELD1
- 3932 APPLY1
- 3933 MODINT
- 3934 PUSHACC0
- 3935 PUSHACC2
- 3936 GETFIELD1
- 3937 C_CALL2 array_get_addr
- 3939 PUSHACC4
- 3940 PUSHACC4
- 3941 MAKEBLOCK3 0
- 3943 PUSHACC0
- 3944 PUSHACC2
- 3945 PUSHACC4
- 3946 GETFIELD1
- 3947 C_CALL3 array_set_addr
- 3949 ACC0
- 3950 PUSHACC3
- 3951 GETFIELD0
- 3952 PUSHENVACC2
- 3953 APPLY2
- 3954 BRANCHIFNOT 3962
- 3956 ACC2
- 3957 PUSHENVACC3
- 3958 GETFIELD1
- 3959 PUSHENVACC1
- 3960 APPTERM2 7
- 3962 RETURN 5
- 3964 ACC0
- 3965 PUSHENVACC 4
- 3967 PUSHENVACC3
- 3968 CLOSURE 3, 3924
- 3971 PUSHACC1
- 3972 CLOSURE 1, 3893
- 3975 PUSHACC2
- 3976 CLOSURE 1, 3774
- 3979 PUSHACC3
- 3980 CLOSURE 1, 3725
- 3983 PUSHACC4
- 3984 CLOSURE 1, 3673
- 3987 PUSHENVACC 5
- 3989 PUSHACC1
- 3990 PUSHACC3
- 3991 PUSHACC5
- 3992 PUSHACC7
- 3993 PUSHACC 9
- 3995 PUSHENVACC2
- 3996 PUSHENVACC1
- 3997 MAKEBLOCK 8, 0
- 4000 RETURN 6
- 4002 ACC0
- 4003 BRANCHIFNOT 4016
- 4005 ACC0
- 4006 GETFIELD1
- 4007 PUSHACC1
- 4008 GETFIELD0
- 4009 PUSHENVACC1
- 4010 APPLY2
- 4011 ACC0
- 4012 GETFIELD2
- 4013 PUSHOFFSETCLOSURE0
- 4014 APPTERM1 2
- 4016 RETURN 1
- 4018 RESTART
- 4019 GRAB 1
- 4021 ACC0
- 4022 CLOSUREREC 1, 4002
- 4026 ACC2
- 4027 GETFIELD1
- 4028 PUSHCONST0
- 4029 PUSHACC1
- 4030 VECTLENGTH
- 4031 OFFSETINT -1
- 4033 PUSH
- 4034 BRANCH 4048
- 4036 CHECK_SIGNALS
- 4037 ACC1
- 4038 PUSHACC3
- 4039 C_CALL2 array_get_addr
- 4041 PUSHACC4
- 4042 APPLY1
- 4043 ACC1
- 4044 OFFSETINT 1
- 4046 ASSIGN 1
- 4048 ACC0
- 4049 PUSHACC2
- 4050 LEINT
- 4051 BRANCHIF 4036
- 4053 CONST0
- 4054 RETURN 6
- 4056 ACC0
- 4057 BRANCHIFNOT 4071
- 4059 ENVACC1
- 4060 PUSHACC1
- 4061 GETFIELD0
- 4062 C_CALL2 equal
- 4064 BRANCHIF 4071
- 4066 ACC0
- 4067 GETFIELD2
- 4068 PUSHOFFSETCLOSURE0
- 4069 APPTERM1 2
- 4071 RETURN 1
- 4073 RESTART
- 4074 GRAB 1
- 4076 ACC1
- 4077 CLOSUREREC 1, 4056
- 4081 ACC1
- 4082 GETFIELD1
- 4083 VECTLENGTH
- 4084 PUSHACC3
- 4085 PUSHENVACC1
- 4086 APPLY1
- 4087 MODINT
- 4088 PUSHACC2
- 4089 GETFIELD1
- 4090 C_CALL2 array_get_addr
- 4092 PUSHACC1
- 4093 APPTERM1 4
- 4095 ACC0
- 4096 BRANCHIFNOT 4120
- 4098 ACC0
- 4099 GETFIELD2
- 4100 PUSHENVACC1
- 4101 PUSHACC2
- 4102 GETFIELD0
- 4103 C_CALL2 equal
- 4105 BRANCHIFNOT 4116
- 4107 ACC0
- 4108 PUSHOFFSETCLOSURE0
- 4109 APPLY1
- 4110 PUSHACC2
- 4111 GETFIELD1
- 4112 MAKEBLOCK2 0
- 4114 RETURN 2
- 4116 ACC0
- 4117 PUSHOFFSETCLOSURE0
- 4118 APPTERM1 3
- 4120 RETURN 1
- 4122 RESTART
- 4123 GRAB 1
- 4125 ACC1
- 4126 CLOSUREREC 1, 4095
- 4130 ACC1
- 4131 GETFIELD1
- 4132 VECTLENGTH
- 4133 PUSHACC3
- 4134 PUSHENVACC1
- 4135 APPLY1
- 4136 MODINT
- 4137 PUSHACC2
- 4138 GETFIELD1
- 4139 C_CALL2 array_get_addr
- 4141 PUSHACC1
- 4142 APPTERM1 4
- 4144 ACC0
- 4145 BRANCHIFNOT 4163
- 4147 ACC0
- 4148 GETFIELD0
- 4149 PUSHENVACC1
- 4150 C_CALL2 equal
- 4152 BRANCHIFNOT 4158
- 4154 ACC0
- 4155 GETFIELD1
- 4156 RETURN 1
- 4158 ACC0
- 4159 GETFIELD2
- 4160 PUSHOFFSETCLOSURE0
- 4161 APPTERM1 2
- 4163 GETGLOBAL Not_found
- 4165 MAKEBLOCK1 0
- 4167 RAISE
- 4168 RESTART
- 4169 GRAB 1
- 4171 ACC0
- 4172 GETFIELD1
- 4173 VECTLENGTH
- 4174 PUSHACC2
- 4175 PUSHENVACC1
- 4176 APPLY1
- 4177 MODINT
- 4178 PUSHACC1
- 4179 GETFIELD1
- 4180 C_CALL2 array_get_addr
- 4182 PUSHACC0
- 4183 BRANCHIFNOT 4248
- 4185 ACC0
- 4186 GETFIELD2
- 4187 PUSHACC1
- 4188 GETFIELD0
- 4189 PUSHACC4
- 4190 C_CALL2 equal
- 4192 BRANCHIFNOT 4198
- 4194 ACC1
- 4195 GETFIELD1
- 4196 RETURN 4
- 4198 ACC0
- 4199 BRANCHIFNOT 4243
- 4201 ACC0
- 4202 GETFIELD2
- 4203 PUSHACC1
- 4204 GETFIELD0
- 4205 PUSHACC5
- 4206 C_CALL2 equal
- 4208 BRANCHIFNOT 4214
- 4210 ACC1
- 4211 GETFIELD1
- 4212 RETURN 5
- 4214 ACC0
- 4215 BRANCHIFNOT 4238
- 4217 ACC0
- 4218 GETFIELD0
- 4219 PUSHACC5
- 4220 C_CALL2 equal
- 4222 BRANCHIFNOT 4228
- 4224 ACC0
- 4225 GETFIELD1
- 4226 RETURN 5
- 4228 ACC4
- 4229 CLOSUREREC 1, 4144
- 4233 ACC1
- 4234 GETFIELD2
- 4235 PUSHACC1
- 4236 APPTERM1 7
- 4238 GETGLOBAL Not_found
- 4240 MAKEBLOCK1 0
- 4242 RAISE
- 4243 GETGLOBAL Not_found
- 4245 MAKEBLOCK1 0
- 4247 RAISE
- 4248 GETGLOBAL Not_found
- 4250 MAKEBLOCK1 0
- 4252 RAISE
- 4253 ACC0
- 4254 BRANCHIFNOT 4279
- 4256 ACC0
- 4257 GETFIELD0
- 4258 PUSHACC1
- 4259 GETFIELD2
- 4260 PUSHENVACC1
- 4261 PUSHACC2
- 4262 C_CALL2 equal
- 4264 BRANCHIFNOT 4269
- 4266 ACC0
- 4267 RETURN 3
- 4269 ACC0
- 4270 PUSHOFFSETCLOSURE0
- 4271 APPLY1
- 4272 PUSHACC3
- 4273 GETFIELD1
- 4274 PUSHACC3
- 4275 MAKEBLOCK3 0
- 4277 POP 2
- 4279 RETURN 1
- 4281 RESTART
- 4282 GRAB 1
- 4284 ACC1
- 4285 CLOSUREREC 1, 4253
- 4289 ACC1
- 4290 GETFIELD1
- 4291 VECTLENGTH
- 4292 PUSHACC3
- 4293 PUSHENVACC1
- 4294 APPLY1
- 4295 MODINT
- 4296 PUSHACC0
- 4297 PUSHACC3
- 4298 GETFIELD1
- 4299 C_CALL2 array_get_addr
- 4301 PUSHACC2
- 4302 APPLY1
- 4303 PUSHACC1
- 4304 PUSHACC4
- 4305 GETFIELD1
- 4306 C_CALL3 array_set_addr
- 4308 RETURN 4
- 4310 RESTART
- 4311 GRAB 2
- 4313 ACC0
- 4314 GETFIELD1
- 4315 VECTLENGTH
- 4316 PUSHACC2
- 4317 PUSHENVACC1
- 4318 APPLY1
- 4319 MODINT
- 4320 PUSHACC0
- 4321 PUSHACC2
- 4322 GETFIELD1
- 4323 C_CALL2 array_get_addr
- 4325 PUSHACC4
- 4326 PUSHACC4
- 4327 MAKEBLOCK3 0
- 4329 PUSHACC0
- 4330 PUSHACC2
- 4331 PUSHACC4
- 4332 GETFIELD1
- 4333 C_CALL3 array_set_addr
- 4335 ACC0
- 4336 PUSHACC3
- 4337 GETFIELD0
- 4338 PUSHENVACC3
- 4339 APPLY2
- 4340 BRANCHIFNOT 4347
- 4342 ACC2
- 4343 PUSHENVACC1
- 4344 PUSHENVACC2
- 4345 APPTERM2 7
- 4347 RETURN 5
- 4349 ACC0
- 4350 BRANCHIFNOT 4378
- 4352 ACC0
- 4353 GETFIELD0
- 4354 PUSHACC1
- 4355 GETFIELD2
- 4356 PUSHOFFSETCLOSURE0
- 4357 APPLY1
- 4358 ENVACC2
- 4359 PUSHACC1
- 4360 PUSHENVACC1
- 4361 APPLY1
- 4362 MODINT
- 4363 PUSHACC0
- 4364 PUSHENVACC3
- 4365 C_CALL2 array_get_addr
- 4367 PUSHACC3
- 4368 GETFIELD1
- 4369 PUSHACC3
- 4370 MAKEBLOCK3 0
- 4372 PUSHACC1
- 4373 PUSHENVACC3
- 4374 C_CALL3 array_set_addr
- 4376 POP 2
- 4378 RETURN 1
- 4380 RESTART
- 4381 GRAB 1
- 4383 ACC1
- 4384 GETFIELD1
- 4385 PUSHACC0
- 4386 VECTLENGTH
- 4387 PUSHACC0
- 4388 PUSHCONST2
- 4389 MULINT
- 4390 OFFSETINT 1
- 4392 PUSHCONST0
- 4393 PUSHACC1
- 4394 C_CALL2 make_vect
- 4396 PUSHACC0
- 4397 PUSHACC2
- 4398 PUSHACC6
- 4399 CLOSUREREC 3, 4349
- 4403 CONST0
- 4404 PUSHACC4
- 4405 OFFSETINT -1
- 4407 PUSH
- 4408 BRANCH 4422
- 4410 CHECK_SIGNALS
- 4411 ACC1
- 4412 PUSHACC7
- 4413 C_CALL2 array_get_addr
- 4415 PUSHACC3
- 4416 APPLY1
- 4417 ACC1
- 4418 OFFSETINT 1
- 4420 ASSIGN 1
- 4422 ACC0
- 4423 PUSHACC2
- 4424 LEINT
- 4425 BRANCHIF 4410
- 4427 CONST0
- 4428 POP 2
- 4430 ACC1
- 4431 PUSHACC7
- 4432 SETFIELD1
- 4433 ACC6
- 4434 GETFIELD0
- 4435 PUSHCONST2
- 4436 MULINT
- 4437 PUSHACC7
- 4438 SETFIELD0
- 4439 RETURN 7
- 4441 CONST0
- 4442 PUSHACC1
- 4443 GETFIELD1
- 4444 VECTLENGTH
- 4445 OFFSETINT -1
- 4447 PUSH
- 4448 BRANCH 4462
- 4450 CHECK_SIGNALS
- 4451 CONST0
- 4452 PUSHACC2
- 4453 PUSHACC4
- 4454 GETFIELD1
- 4455 C_CALL3 array_set_addr
- 4457 ACC1
- 4458 OFFSETINT 1
- 4460 ASSIGN 1
- 4462 ACC0
- 4463 PUSHACC2
- 4464 LEINT
- 4465 BRANCHIF 4450
- 4467 CONST0
- 4468 RETURN 3
- 4470 CONST1
- 4471 PUSHACC1
- 4472 LTINT
- 4473 BRANCHIFNOT 4478
- 4475 CONST1
- 4476 BRANCH 4479
- 4478 ACC0
- 4479 PUSHGETGLOBALFIELD Sys, 5
- 4482 PUSHACC1
- 4483 GTINT
- 4484 BRANCHIFNOT 4491
- 4486 GETGLOBALFIELD Sys, 5
- 4489 BRANCH 4492
- 4491 ACC0
- 4492 PUSHCONST0
- 4493 PUSHACC1
- 4494 C_CALL2 make_vect
- 4496 PUSHCONST3
- 4497 MAKEBLOCK2 0
- 4499 RETURN 3
- 4501 ACC0
- 4502 PUSHCONSTINT 100
- 4504 PUSHCONSTINT 10
- 4506 C_CALL3 hash_univ_param
- 4508 RETURN 1
- 4510 CLOSURE 0, 4501
- 4513 PUSH
- 4514 CLOSURE 0, 4470
- 4517 PUSH
- 4518 CLOSURE 0, 4441
- 4521 PUSH
- 4522 CLOSURE 0, 4381
- 4525 PUSH
- 4526 CLOSUREREC 0, 3631
- 4530 ACC0
- 4531 PUSHACC2
- 4532 PUSHACC6
- 4533 CLOSURE 3, 4311
- 4536 PUSHACC5
- 4537 CLOSURE 1, 4282
- 4540 PUSHACC6
- 4541 CLOSURE 1, 4169
- 4544 PUSHACC7
- 4545 CLOSURE 1, 4123
- 4548 PUSHACC 8
- 4550 CLOSURE 1, 4074
- 4553 PUSH
- 4554 CLOSURE 0, 4019
- 4557 PUSHACC0
- 4558 PUSHACC7
- 4559 PUSHACC 9
- 4561 PUSHACC 11
- 4563 PUSHACC 13
- 4565 CLOSURE 5, 3964
- 4568 PUSHACC 11
- 4570 PUSHACC1
- 4571 PUSHACC3
- 4572 PUSHACC 8
- 4574 PUSHACC6
- 4575 PUSHACC 8
- 4577 PUSHACC 10
- 4579 PUSHACC 13
- 4581 PUSHACC 17
- 4583 PUSHACC 19
- 4585 MAKEBLOCK 10, 0
- 4588 POP 12
- 4590 SETGLOBAL Hashtbl
- 4592 BRANCH 5073
- 4594 RESTART
- 4595 GRAB 2
- 4597 ACC1
- 4598 BRANCHIFNOT 4638
- 4600 ACC1
- 4601 GETFIELD0
- 4602 PUSHACC3
- 4603 BRANCHIFNOT 4635
- 4605 ACC3
- 4606 GETFIELD0
- 4607 PUSHACC0
- 4608 PUSHACC2
- 4609 PUSHACC4
- 4610 APPLY2
- 4611 BRANCHIFNOT 4624
- 4613 ACC4
- 4614 PUSHACC4
- 4615 GETFIELD1
- 4616 PUSHACC4
- 4617 PUSHOFFSETCLOSURE0
- 4618 APPLY3
- 4619 PUSHACC2
- 4620 MAKEBLOCK2 0
- 4622 RETURN 5
- 4624 ACC4
- 4625 GETFIELD1
- 4626 PUSHACC4
- 4627 PUSHACC4
- 4628 PUSHOFFSETCLOSURE0
- 4629 APPLY3
- 4630 PUSHACC1
- 4631 MAKEBLOCK2 0
- 4633 RETURN 5
- 4635 ACC2
- 4636 RETURN 4
- 4638 ACC2
- 4639 RETURN 3
- 4641 RESTART
- 4642 GRAB 1
- 4644 CONSTINT 6
- 4646 PUSHACC1
- 4647 PUSHACC3
- 4648 SUBINT
- 4649 GEINT
- 4650 BRANCHIFNOT 4809
- 4652 CONST1
- 4653 PUSHACC2
- 4654 PUSHACC2
- 4655 ADDINT
- 4656 LSRINT
- 4657 PUSHACC1
- 4658 PUSHENVACC3
- 4659 C_CALL2 array_unsafe_get
- 4661 PUSHACC1
- 4662 PUSHENVACC3
- 4663 C_CALL2 array_unsafe_get
- 4665 PUSHENVACC2
- 4666 APPLY2
- 4667 BRANCHIFNOT 4674
- 4669 ACC1
- 4670 PUSHACC1
- 4671 PUSHENVACC3
- 4672 PUSHENVACC1
- 4673 APPLY3
- 4674 ACC0
- 4675 PUSHENVACC3
- 4676 C_CALL2 array_unsafe_get
- 4678 PUSHACC3
- 4679 PUSHENVACC3
- 4680 C_CALL2 array_unsafe_get
- 4682 PUSHENVACC2
- 4683 APPLY2
- 4684 BRANCHIFNOT 4708
- 4686 ACC2
- 4687 PUSHACC1
- 4688 PUSHENVACC3
- 4689 PUSHENVACC1
- 4690 APPLY3
- 4691 ACC1
- 4692 PUSHENVACC3
- 4693 C_CALL2 array_unsafe_get
- 4695 PUSHACC1
- 4696 PUSHENVACC3
- 4697 C_CALL2 array_unsafe_get
- 4699 PUSHENVACC2
- 4700 APPLY2
- 4701 BRANCHIFNOT 4708
- 4703 ACC1
- 4704 PUSHACC1
- 4705 PUSHENVACC3
- 4706 PUSHENVACC1
- 4707 APPLY3
- 4708 ACC0
- 4709 PUSHENVACC3
- 4710 C_CALL2 array_unsafe_get
- 4712 PUSHACC2
- 4713 OFFSETINT 1
- 4715 PUSHACC4
- 4716 OFFSETINT -1
- 4718 PUSH
- 4719 BRANCH 4777
- 4721 CHECK_SIGNALS
- 4722 BRANCH 4730
- 4724 CHECK_SIGNALS
- 4725 ACC1
- 4726 OFFSETINT 1
- 4728 ASSIGN 1
- 4730 ACC1
- 4731 PUSHENVACC3
- 4732 C_CALL2 array_unsafe_get
- 4734 PUSHACC3
- 4735 PUSHENVACC2
- 4736 APPLY2
- 4737 BRANCHIFNOT 4724
- 4739 CONST0
- 4740 BRANCH 4748
- 4742 CHECK_SIGNALS
- 4743 ACC0
- 4744 OFFSETINT -1
- 4746 ASSIGN 0
- 4748 ACC2
- 4749 PUSHACC1
- 4750 PUSHENVACC3
- 4751 C_CALL2 array_unsafe_get
- 4753 PUSHENVACC2
- 4754 APPLY2
- 4755 BRANCHIFNOT 4742
- 4757 ACC0
- 4758 PUSHACC2
- 4759 LTINT
- 4760 BRANCHIFNOT 4767
- 4762 ACC0
- 4763 PUSHACC2
- 4764 PUSHENVACC3
- 4765 PUSHENVACC1
- 4766 APPLY3
- 4767 ACC1
- 4768 OFFSETINT 1
- 4770 ASSIGN 1
- 4772 ACC0
- 4773 OFFSETINT -1
- 4775 ASSIGN 0
- 4777 ACC0
- 4778 PUSHACC2
- 4779 LTINT
- 4780 BRANCHIF 4721
- 4782 ACC1
- 4783 PUSHACC6
- 4784 SUBINT
- 4785 PUSHACC5
- 4786 PUSHACC2
- 4787 SUBINT
- 4788 LEINT
- 4789 BRANCHIFNOT 4800
- 4791 ACC0
- 4792 PUSHACC5
- 4793 PUSHOFFSETCLOSURE0
- 4794 APPLY2
- 4795 ACC5
- 4796 PUSHACC2
- 4797 PUSHOFFSETCLOSURE0
- 4798 APPTERM2 8
- 4800 ACC5
- 4801 PUSHACC2
- 4802 PUSHOFFSETCLOSURE0
- 4803 APPLY2
- 4804 ACC0
- 4805 PUSHACC5
- 4806 PUSHOFFSETCLOSURE0
- 4807 APPTERM2 8
- 4809 RETURN 2
- 4811 RESTART
- 4812 GRAB 1
- 4814 ACC1
- 4815 PUSHACC1
- 4816 PUSHENVACC1
- 4817 CLOSUREREC 3, 4642
- 4821 ACC2
- 4822 VECTLENGTH
- 4823 OFFSETINT -1
- 4825 PUSHCONST0
- 4826 PUSHACC2
- 4827 APPLY2
- 4828 CONST1
- 4829 PUSHACC3
- 4830 VECTLENGTH
- 4831 OFFSETINT -1
- 4833 PUSH
- 4834 BRANCH 4918
- 4836 CHECK_SIGNALS
- 4837 ACC1
- 4838 PUSHACC5
- 4839 C_CALL2 array_unsafe_get
- 4841 PUSHACC0
- 4842 PUSHACC3
- 4843 OFFSETINT -1
- 4845 PUSHACC7
- 4846 C_CALL2 array_unsafe_get
- 4848 PUSHACC6
- 4849 APPLY2
- 4850 BOOLNOT
- 4851 BRANCHIFNOT 4911
- 4853 ACC2
- 4854 OFFSETINT -1
- 4856 PUSHACC6
- 4857 C_CALL2 array_unsafe_get
- 4859 PUSHACC3
- 4860 PUSHACC7
- 4861 C_CALL3 array_unsafe_set
- 4863 ACC2
- 4864 OFFSETINT -1
- 4866 PUSH
- 4867 BRANCH 4886
- 4869 CHECK_SIGNALS
- 4870 ACC0
- 4871 OFFSETINT -1
- 4873 PUSHACC7
- 4874 C_CALL2 array_unsafe_get
- 4876 PUSHACC1
- 4877 PUSHACC 8
- 4879 C_CALL3 array_unsafe_set
- 4881 ACC0
- 4882 OFFSETINT -1
- 4884 ASSIGN 0
- 4886 CONST1
- 4887 PUSHACC1
- 4888 GEINT
- 4889 BRANCHIFNOT 4903
- 4891 ACC1
- 4892 PUSHACC1
- 4893 OFFSETINT -1
- 4895 PUSHACC 8
- 4897 C_CALL2 array_unsafe_get
- 4899 PUSHACC7
- 4900 APPLY2
- 4901 BRANCHIFNOT 4869
- 4903 ACC1
- 4904 PUSHACC1
- 4905 PUSHACC 8
- 4907 C_CALL3 array_unsafe_set
- 4909 POP 1
- 4911 POP 1
- 4913 ACC1
- 4914 OFFSETINT 1
- 4916 ASSIGN 1
- 4918 ACC0
- 4919 PUSHACC2
- 4920 LEINT
- 4921 BRANCHIF 4836
- 4923 CONST0
- 4924 RETURN 5
- 4926 RESTART
- 4927 GRAB 2
- 4929 ACC1
- 4930 PUSHACC1
- 4931 C_CALL2 array_unsafe_get
- 4933 PUSHACC3
- 4934 PUSHACC2
- 4935 C_CALL2 array_unsafe_get
- 4937 PUSHACC3
- 4938 PUSHACC3
- 4939 C_CALL3 array_unsafe_set
- 4941 ACC0
- 4942 PUSHACC4
- 4943 PUSHACC3
- 4944 C_CALL3 array_unsafe_set
- 4946 RETURN 4
- 4948 ACC0
- 4949 BRANCHIFNOT 4999
- 4951 ACC0
- 4952 GETFIELD0
- 4953 PUSHACC1
- 4954 GETFIELD1
- 4955 PUSHACC0
- 4956 BRANCHIFNOT 4990
- 4958 ACC0
- 4959 GETFIELD0
- 4960 PUSHACC1
- 4961 GETFIELD1
- 4962 PUSHOFFSETCLOSURE0
- 4963 APPLY1
- 4964 PUSHACC1
- 4965 PUSHACC4
- 4966 PUSHENVACC1
- 4967 APPLY2
- 4968 BRANCHIFNOT 4979
- 4970 CONST0
- 4971 PUSHACC2
- 4972 MAKEBLOCK2 0
- 4974 PUSHACC4
- 4975 MAKEBLOCK2 0
- 4977 BRANCH 4986
- 4979 CONST0
- 4980 PUSHACC4
- 4981 MAKEBLOCK2 0
- 4983 PUSHACC2
- 4984 MAKEBLOCK2 0
- 4986 MAKEBLOCK2 0
- 4988 RETURN 4
- 4990 CONST0
- 4991 PUSHCONST0
- 4992 PUSHACC3
- 4993 MAKEBLOCK2 0
- 4995 MAKEBLOCK2 0
- 4997 POP 2
- 4999 RETURN 1
- 5001 ACC0
- 5002 BRANCHIFNOT 5028
- 5004 ACC0
- 5005 GETFIELD1
- 5006 PUSHACC0
- 5007 BRANCHIFNOT 5024
- 5009 ACC0
- 5010 GETFIELD1
- 5011 PUSHOFFSETCLOSURE0
- 5012 APPLY1
- 5013 PUSHACC1
- 5014 GETFIELD0
- 5015 PUSHACC3
- 5016 GETFIELD0
- 5017 PUSHENVACC2
- 5018 PUSHENVACC1
- 5019 APPLY3
- 5020 MAKEBLOCK2 0
- 5022 RETURN 2
- 5024 POP 1
- 5026 BRANCH 5028
- 5028 ACC0
- 5029 RETURN 1
- 5031 ACC0
- 5032 BRANCHIFNOT 5040
- 5034 ACC0
- 5035 GETFIELD1
- 5036 BRANCHIF 5042
- 5038 ACC0
- 5039 GETFIELD0
- 5040 RETURN 1
- 5042 ACC0
- 5043 PUSHENVACC1
- 5044 APPLY1
- 5045 PUSHOFFSETCLOSURE0
- 5046 APPTERM1 2
- 5048 RESTART
- 5049 GRAB 1
- 5051 ACC0
- 5052 CLOSUREREC 1, 4948
- 5056 ACC1
- 5057 PUSHENVACC1
- 5058 CLOSUREREC 2, 5001
- 5062 ACC0
- 5063 CLOSUREREC 1, 5031
- 5067 ACC4
- 5068 PUSHACC3
- 5069 APPLY1
- 5070 PUSHACC1
- 5071 APPTERM1 6
- 5073 CLOSUREREC 0, 4595
- 5077 ACC0
- 5078 CLOSURE 1, 5049
- 5081 PUSH
- 5082 CLOSURE 0, 4927
- 5085 PUSHACC0
- 5086 CLOSURE 1, 4812
- 5089 PUSHACC3
- 5090 PUSHACC1
- 5091 PUSHACC4
- 5092 MAKEBLOCK3 0
- 5094 POP 4
- 5096 SETGLOBAL Sort
- 5098 BRANCH 5847
- 5100 ACC0
- 5101 PUSHENVACC1
- 5102 APPLY1
- 5103 PUSHACC0
- 5104 GETFIELD 11
- 5106 PUSHACC1
- 5107 GETFIELD 10
- 5109 PUSHACC2
- 5110 GETFIELD 9
- 5112 PUSHACC3
- 5113 GETFIELD 6
- 5115 PUSHACC4
- 5116 GETFIELD 8
- 5118 PUSHACC5
- 5119 GETFIELD 5
- 5121 PUSHACC6
- 5122 GETFIELD 4
- 5124 PUSHACC7
- 5125 GETFIELD0
- 5126 MAKEBLOCK 8, 0
- 5129 RETURN 2
- 5131 RESTART
- 5132 GRAB 2
- 5134 ACC2
- 5135 BRANCHIFNOT 5201
- 5137 ACC2
- 5138 GETFIELD0
- 5139 PUSHACC3
- 5140 GETFIELD1
- 5141 PUSHACC4
- 5142 GETFIELD2
- 5143 PUSHACC5
- 5144 GETFIELD3
- 5145 PUSHACC2
- 5146 PUSHACC5
- 5147 PUSHENVACC1
- 5148 GETFIELD0
- 5149 APPLY2
- 5150 PUSHCONST0
- 5151 PUSHACC1
- 5152 EQ
- 5153 BRANCHIFNOT 5170
- 5155 ACC7
- 5156 GETFIELD 4
- 5158 PUSHACC2
- 5159 PUSHACC 8
- 5161 PUSHACC 8
- 5163 PUSHACC 8
- 5165 MAKEBLOCK 5, 0
- 5168 RETURN 8
- 5170 CONST0
- 5171 PUSHACC1
- 5172 LTINT
- 5173 BRANCHIFNOT 5189
- 5175 ACC1
- 5176 PUSHACC3
- 5177 PUSHACC5
- 5178 PUSHACC7
- 5179 PUSHACC 10
- 5181 PUSHACC 10
- 5183 PUSHOFFSETCLOSURE0
- 5184 APPLY3
- 5185 PUSHENVACC2
- 5186 APPTERM 4, 12
- 5189 ACC1
- 5190 PUSHACC7
- 5191 PUSHACC7
- 5192 PUSHOFFSETCLOSURE0
- 5193 APPLY3
- 5194 PUSHACC3
- 5195 PUSHACC5
- 5196 PUSHACC7
- 5197 PUSHENVACC2
- 5198 APPTERM 4, 12
- 5201 CONST1
- 5202 PUSHCONST0
- 5203 PUSHACC3
- 5204 PUSHACC3
- 5205 PUSHCONST0
- 5206 MAKEBLOCK 5, 0
- 5209 RETURN 3
- 5211 RESTART
- 5212 GRAB 1
- 5214 ACC1
- 5215 BRANCHIFNOT 5247
- 5217 ACC1
- 5218 GETFIELD1
- 5219 PUSHACC1
- 5220 PUSHENVACC1
- 5221 GETFIELD0
- 5222 APPLY2
- 5223 PUSHCONST0
- 5224 PUSHACC1
- 5225 EQ
- 5226 BRANCHIFNOT 5232
- 5228 ACC2
- 5229 GETFIELD2
- 5230 RETURN 3
- 5232 CONST0
- 5233 PUSHACC1
- 5234 LTINT
- 5235 BRANCHIFNOT 5241
- 5237 ACC2
- 5238 GETFIELD0
- 5239 BRANCH 5243
- 5241 ACC2
- 5242 GETFIELD3
- 5243 PUSHACC2
- 5244 PUSHOFFSETCLOSURE0
- 5245 APPTERM2 5
- 5247 GETGLOBAL Not_found
- 5249 MAKEBLOCK1 0
- 5251 RAISE
- 5252 RESTART
- 5253 GRAB 1
- 5255 ACC1
- 5256 BRANCHIFNOT 5286
- 5258 ACC1
- 5259 GETFIELD1
- 5260 PUSHACC1
- 5261 PUSHENVACC1
- 5262 GETFIELD0
- 5263 APPLY2
- 5264 PUSHCONST0
- 5265 PUSHACC1
- 5266 EQ
- 5267 BRANCHIF 5284
- 5269 CONST0
- 5270 PUSHACC1
- 5271 LTINT
- 5272 BRANCHIFNOT 5278
- 5274 ACC2
- 5275 GETFIELD0
- 5276 BRANCH 5280
- 5278 ACC2
- 5279 GETFIELD3
- 5280 PUSHACC2
- 5281 PUSHOFFSETCLOSURE0
- 5282 APPTERM2 5
- 5284 POP 1
- 5286 RETURN 2
- 5288 RESTART
- 5289 GRAB 1
- 5291 ACC0
- 5292 BRANCHIF 5297
- 5294 ACC1
- 5295 RETURN 2
- 5297 ACC1
- 5298 BRANCHIF 5303
- 5300 ACC0
- 5301 RETURN 2
- 5303 ACC0
- 5304 BRANCHIFNOT 5336
- 5306 ACC1
- 5307 BRANCHIFNOT 5336
- 5309 PUSH_RETADDR 5326
- 5311 ACC4
- 5312 GETFIELD3
- 5313 PUSHACC5
- 5314 GETFIELD2
- 5315 PUSHACC6
- 5316 GETFIELD1
- 5317 PUSHACC7
- 5318 GETFIELD0
- 5319 PUSHACC7
- 5320 GETFIELD3
- 5321 PUSHOFFSETCLOSURE0
- 5322 APPLY2
- 5323 PUSHENVACC1
- 5324 APPLY 4
- 5326 PUSHACC1
- 5327 GETFIELD2
- 5328 PUSHACC2
- 5329 GETFIELD1
- 5330 PUSHACC3
- 5331 GETFIELD0
- 5332 PUSHENVACC1
- 5333 APPTERM 4, 6
- 5336 GETGLOBAL <0>("map.ml", 3614, 3797)
- 5338 PUSHGETGLOBAL Match_failure
- 5340 MAKEBLOCK2 0
- 5342 RAISE
- 5343 RESTART
- 5344 GRAB 1
- 5346 ACC1
- 5347 BRANCHIFNOT 5400
- 5349 ACC1
- 5350 GETFIELD0
- 5351 PUSHACC2
- 5352 GETFIELD1
- 5353 PUSHACC3
- 5354 GETFIELD2
- 5355 PUSHACC4
- 5356 GETFIELD3
- 5357 PUSHACC2
- 5358 PUSHACC5
- 5359 PUSHENVACC1
- 5360 GETFIELD0
- 5361 APPLY2
- 5362 PUSHCONST0
- 5363 PUSHACC1
- 5364 EQ
- 5365 BRANCHIFNOT 5372
- 5367 ACC1
- 5368 PUSHACC5
- 5369 PUSHENVACC3
- 5370 APPTERM2 9
- 5372 CONST0
- 5373 PUSHACC1
- 5374 LTINT
- 5375 BRANCHIFNOT 5389
- 5377 ACC1
- 5378 PUSHACC3
- 5379 PUSHACC5
- 5380 PUSHACC7
- 5381 PUSHACC 9
- 5383 PUSHOFFSETCLOSURE0
- 5384 APPLY2
- 5385 PUSHENVACC2
- 5386 APPTERM 4, 11
- 5389 ACC1
- 5390 PUSHACC6
- 5391 PUSHOFFSETCLOSURE0
- 5392 APPLY2
- 5393 PUSHACC3
- 5394 PUSHACC5
- 5395 PUSHACC7
- 5396 PUSHENVACC2
- 5397 APPTERM 4, 11
- 5400 RETURN 2
- 5402 RESTART
- 5403 GRAB 1
- 5405 ACC1
- 5406 BRANCHIFNOT 5425
- 5408 ACC1
- 5409 GETFIELD0
- 5410 PUSHACC1
- 5411 PUSHOFFSETCLOSURE0
- 5412 APPLY2
- 5413 ACC1
- 5414 GETFIELD2
- 5415 PUSHACC2
- 5416 GETFIELD1
- 5417 PUSHACC2
- 5418 APPLY2
- 5419 ACC1
- 5420 GETFIELD3
- 5421 PUSHACC1
- 5422 PUSHOFFSETCLOSURE0
- 5423 APPTERM2 4
- 5425 RETURN 2
- 5427 RESTART
- 5428 GRAB 1
- 5430 ACC1
- 5431 BRANCHIFNOT 5455
- 5433 ACC1
- 5434 GETFIELD 4
- 5436 PUSHACC2
- 5437 GETFIELD3
- 5438 PUSHACC2
- 5439 PUSHOFFSETCLOSURE0
- 5440 APPLY2
- 5441 PUSHACC3
- 5442 GETFIELD2
- 5443 PUSHACC3
- 5444 APPLY1
- 5445 PUSHACC4
- 5446 GETFIELD1
- 5447 PUSHACC5
- 5448 GETFIELD0
- 5449 PUSHACC5
- 5450 PUSHOFFSETCLOSURE0
- 5451 APPLY2
- 5452 MAKEBLOCK 5, 0
- 5455 RETURN 2
- 5457 RESTART
- 5458 GRAB 2
- 5460 ACC1
- 5461 BRANCHIFNOT 5481
- 5463 ACC2
- 5464 PUSHACC2
- 5465 GETFIELD3
- 5466 PUSHACC2
- 5467 PUSHOFFSETCLOSURE0
- 5468 APPLY3
- 5469 PUSHACC2
- 5470 GETFIELD2
- 5471 PUSHACC3
- 5472 GETFIELD1
- 5473 PUSHACC3
- 5474 APPLY3
- 5475 PUSHACC2
- 5476 GETFIELD0
- 5477 PUSHACC2
- 5478 PUSHOFFSETCLOSURE0
- 5479 APPTERM3 6
- 5481 ACC2
- 5482 RETURN 3
- 5484 RESTART
- 5485 GRAB 3
- 5487 ACC0
- 5488 BRANCHIFNOT 5495
- 5490 ACC0
- 5491 GETFIELD 4
- 5493 BRANCH 5496
- 5495 CONST0
- 5496 PUSHACC4
- 5497 BRANCHIFNOT 5504
- 5499 ACC4
- 5500 GETFIELD 4
- 5502 BRANCH 5505
- 5504 CONST0
- 5505 PUSHACC0
- 5506 OFFSETINT 2
- 5508 PUSHACC2
- 5509 GTINT
- 5510 BRANCHIFNOT 5603
- 5512 ACC2
- 5513 BRANCHIFNOT 5596
- 5515 ACC2
- 5516 GETFIELD0
- 5517 PUSHACC3
- 5518 GETFIELD1
- 5519 PUSHACC4
- 5520 GETFIELD2
- 5521 PUSHACC5
- 5522 GETFIELD3
- 5523 PUSHACC0
- 5524 PUSHENVACC1
- 5525 APPLY1
- 5526 PUSHACC4
- 5527 PUSHENVACC1
- 5528 APPLY1
- 5529 GEINT
- 5530 BRANCHIFNOT 5551
- 5532 PUSH_RETADDR 5544
- 5534 ACC 12
- 5536 PUSHACC 12
- 5538 PUSHACC 12
- 5540 PUSHACC6
- 5541 PUSHENVACC2
- 5542 APPLY 4
- 5544 PUSHACC2
- 5545 PUSHACC4
- 5546 PUSHACC6
- 5547 PUSHENVACC2
- 5548 APPTERM 4, 14
- 5551 ACC0
- 5552 BRANCHIFNOT 5589
- 5554 PUSH_RETADDR 5567
- 5556 ACC 12
- 5558 PUSHACC 12
- 5560 PUSHACC 12
- 5562 PUSHACC6
- 5563 GETFIELD3
- 5564 PUSHENVACC2
- 5565 APPLY 4
- 5567 PUSHACC1
- 5568 GETFIELD2
- 5569 PUSHACC2
- 5570 GETFIELD1
- 5571 PUSH
- 5572 PUSH_RETADDR 5585
- 5574 ACC6
- 5575 GETFIELD0
- 5576 PUSHACC 8
- 5578 PUSHACC 10
- 5580 PUSHACC 12
- 5582 PUSHENVACC2
- 5583 APPLY 4
- 5585 PUSHENVACC2
- 5586 APPTERM 4, 14
- 5589 GETGLOBAL "Map.bal"
- 5591 PUSHGETGLOBALFIELD Pervasives, 2
- 5594 APPTERM1 11
- 5596 GETGLOBAL "Map.bal"
- 5598 PUSHGETGLOBALFIELD Pervasives, 2
- 5601 APPTERM1 7
- 5603 ACC1
- 5604 OFFSETINT 2
- 5606 PUSHACC1
- 5607 GTINT
- 5608 BRANCHIFNOT 5703
- 5610 ACC5
- 5611 BRANCHIFNOT 5696
- 5613 ACC5
- 5614 GETFIELD0
- 5615 PUSHACC6
- 5616 GETFIELD1
- 5617 PUSHACC7
- 5618 GETFIELD2
- 5619 PUSHACC 8
- 5621 GETFIELD3
- 5622 PUSHACC3
- 5623 PUSHENVACC1
- 5624 APPLY1
- 5625 PUSHACC1
- 5626 PUSHENVACC1
- 5627 APPLY1
- 5628 GEINT
- 5629 BRANCHIFNOT 5652
- 5631 ACC0
- 5632 PUSHACC2
- 5633 PUSHACC4
- 5634 PUSH
- 5635 PUSH_RETADDR 5648
- 5637 ACC 9
- 5639 PUSHACC 15
- 5641 PUSHACC 15
- 5643 PUSHACC 15
- 5645 PUSHENVACC2
- 5646 APPLY 4
- 5648 PUSHENVACC2
- 5649 APPTERM 4, 14
- 5652 ACC3
- 5653 BRANCHIFNOT 5689
- 5655 PUSH_RETADDR 5666
- 5657 ACC3
- 5658 PUSHACC5
- 5659 PUSHACC7
- 5660 PUSHACC 9
- 5662 GETFIELD3
- 5663 PUSHENVACC2
- 5664 APPLY 4
- 5666 PUSHACC4
- 5667 GETFIELD2
- 5668 PUSHACC5
- 5669 GETFIELD1
- 5670 PUSH
- 5671 PUSH_RETADDR 5685
- 5673 ACC 9
- 5675 GETFIELD0
- 5676 PUSHACC 15
- 5678 PUSHACC 15
- 5680 PUSHACC 15
- 5682 PUSHENVACC2
- 5683 APPLY 4
- 5685 PUSHENVACC2
- 5686 APPTERM 4, 14
- 5689 GETGLOBAL "Map.bal"
- 5691 PUSHGETGLOBALFIELD Pervasives, 2
- 5694 APPTERM1 11
- 5696 GETGLOBAL "Map.bal"
- 5698 PUSHGETGLOBALFIELD Pervasives, 2
- 5701 APPTERM1 7
- 5703 ACC0
- 5704 PUSHACC2
- 5705 GEINT
- 5706 BRANCHIFNOT 5713
- 5708 ACC1
- 5709 OFFSETINT 1
- 5711 BRANCH 5716
- 5713 ACC0
- 5714 OFFSETINT 1
- 5716 PUSHACC6
- 5717 PUSHACC6
- 5718 PUSHACC6
- 5719 PUSHACC6
- 5720 MAKEBLOCK 5, 0
- 5723 RETURN 6
- 5725 RESTART
- 5726 GRAB 3
- 5728 ACC0
- 5729 PUSHENVACC1
- 5730 APPLY1
- 5731 PUSHACC4
- 5732 PUSHENVACC1
- 5733 APPLY1
- 5734 PUSHACC0
- 5735 PUSHACC2
- 5736 GEINT
- 5737 BRANCHIFNOT 5744
- 5739 ACC1
- 5740 OFFSETINT 1
- 5742 BRANCH 5747
- 5744 ACC0
- 5745 OFFSETINT 1
- 5747 PUSHACC6
- 5748 PUSHACC6
- 5749 PUSHACC6
- 5750 PUSHACC6
- 5751 MAKEBLOCK 5, 0
- 5754 RETURN 6
- 5756 ACC0
- 5757 BRANCHIFNOT 5764
- 5759 ACC0
- 5760 GETFIELD 4
- 5762 RETURN 1
- 5764 CONST0
- 5765 RETURN 1
- 5767 CONST0
- 5768 PUSH
- 5769 CLOSURE 0, 5756
- 5772 PUSHACC0
- 5773 CLOSURE 1, 5726
- 5776 PUSHACC0
- 5777 PUSHACC2
- 5778 CLOSURE 2, 5485
- 5781 PUSHACC0
- 5782 PUSHACC5
- 5783 CLOSUREREC 2, 5132
- 5787 ACC5
- 5788 CLOSUREREC 1, 5212
- 5792 ACC6
- 5793 CLOSUREREC 1, 5253
- 5797 ACC3
- 5798 CLOSUREREC 1, 5289
- 5802 ACC0
- 5803 PUSHACC5
- 5804 PUSHACC 10
- 5806 CLOSUREREC 3, 5344
- 5810 CLOSUREREC 0, 5403
- 5814 CLOSUREREC 0, 5428
- 5818 CLOSUREREC 0, 5458
- 5822 ACC0
- 5823 PUSHACC2
- 5824 PUSHACC4
- 5825 PUSHACC6
- 5826 PUSHACC 8
- 5828 PUSHACC 10
- 5830 PUSHACC 12
- 5832 PUSHACC 14
- 5834 PUSHACC 16
- 5836 PUSHACC 18
- 5838 PUSHACC 20
- 5840 PUSHACC 22
- 5842 MAKEBLOCK 12, 0
- 5845 RETURN 13
- 5847 CLOSURE 0, 5767
- 5850 PUSHACC0
- 5851 CLOSURE 1, 5100
- 5854 MAKEBLOCK1 0
- 5856 POP 1
- 5858 SETGLOBAL Map
- 5860 BRANCH 5957
- 5862 CONSTINT 16
- 5864 C_CALL1 create_string
- 5866 PUSH
- 5867 PUSH_RETADDR 5879
- 5869 CONSTINT 16
- 5871 PUSHCONST0
- 5872 PUSHACC5
- 5873 PUSHACC7
- 5874 PUSHGETGLOBALFIELD Pervasives, 56
- 5877 APPLY 4
- 5879 ACC0
- 5880 RETURN 2
- 5882 RESTART
- 5883 GRAB 1
- 5885 CONSTINT 16
- 5887 PUSHCONST0
- 5888 PUSHACC3
- 5889 PUSHACC3
- 5890 PUSHGETGLOBALFIELD Pervasives, 41
- 5893 APPTERM 4, 6
- 5896 ACC0
- 5897 PUSHGETGLOBALFIELD Pervasives, 51
- 5900 APPLY1
- 5901 PUSHACC0
- 5902 PUSHGETGLOBALFIELD Pervasives, 62
- 5905 APPLY1
- 5906 PUSHACC1
- 5907 C_CALL2 md5_chan
- 5909 PUSHACC1
- 5910 PUSHGETGLOBALFIELD Pervasives, 63
- 5913 APPLY1
- 5914 ACC0
- 5915 RETURN 3
- 5917 RESTART
- 5918 GRAB 2
- 5920 CONST0
- 5921 PUSHACC2
- 5922 LTINT
- 5923 BRANCHIF 5934
- 5925 ACC0
- 5926 C_CALL1 ml_string_length
- 5928 PUSHACC3
- 5929 PUSHACC3
- 5930 ADDINT
- 5931 GTINT
- 5932 BRANCHIFNOT 5941
- 5934 GETGLOBAL "Digest.substring"
- 5936 PUSHGETGLOBALFIELD Pervasives, 2
- 5939 APPTERM1 4
- 5941 ACC2
- 5942 PUSHACC2
- 5943 PUSHACC2
- 5944 C_CALL3 md5_string
- 5946 RETURN 3
- 5948 ACC0
- 5949 C_CALL1 ml_string_length
- 5951 PUSHCONST0
- 5952 PUSHACC2
- 5953 C_CALL3 md5_string
- 5955 RETURN 1
- 5957 CLOSURE 0, 5948
- 5960 PUSH
- 5961 CLOSURE 0, 5918
- 5964 PUSH
- 5965 CLOSURE 0, 5896
- 5968 PUSH
- 5969 CLOSURE 0, 5883
- 5972 PUSH
- 5973 CLOSURE 0, 5862
- 5976 PUSHACC0
- 5977 PUSHACC2
- 5978 PUSHACC4
- 5979 PUSHACC6
- 5980 PUSHACC 8
- 5982 MAKEBLOCK 5, 0
- 5985 POP 5
- 5987 SETGLOBAL Digest
- 5989 BRANCH 6245
- 5991 CONST0
- 5992 PUSHENVACC1
- 5993 APPLY1
- 5994 PUSHACC1
- 5995 PUSHACC1
- 5996 GEINT
- 5997 BRANCHIFNOT 6003
- 5999 ACC1
- 6000 PUSHOFFSETCLOSURE0
- 6001 APPTERM1 3
- 6003 ACC0
- 6004 RETURN 2
- 6006 CONST0
- 6007 C_CALL1 sys_random_seed
- 6009 PUSHENVACC1
- 6010 APPTERM1 2
- 6012 CONSTINT 27182818
- 6014 PUSHENVACC2
- 6015 APPLY1
- 6016 CONST0
- 6017 PUSHACC1
- 6018 VECTLENGTH
- 6019 OFFSETINT -1
- 6021 PUSH
- 6022 BRANCH 6046
- 6024 CHECK_SIGNALS
- 6025 CONSTINT 55
- 6027 PUSHACC2
- 6028 MODINT
- 6029 PUSHACC2
- 6030 PUSHACC4
- 6031 GETVECTITEM
- 6032 PUSHACC1
- 6033 PUSHENVACC1
- 6034 GETVECTITEM
- 6035 ADDINT
- 6036 PUSHACC1
- 6037 PUSHENVACC1
- 6038 SETVECTITEM
- 6039 POP 1
- 6041 ACC1
- 6042 OFFSETINT 1
- 6044 ASSIGN 1
- 6046 ACC0
- 6047 PUSHACC2
- 6048 LEINT
- 6049 BRANCHIF 6024
- 6051 CONST0
- 6052 RETURN 3
- 6054 ENVACC1
- 6055 GETFIELD0
- 6056 OFFSETINT 1
- 6058 PUSHENVACC1
- 6059 SETFIELD0
- 6060 ENVACC1
- 6061 GETFIELD0
- 6062 PUSHGETGLOBALFIELD Pervasives, 14
- 6065 APPLY1
- 6066 PUSHGETGLOBALFIELD Digest, 0
- 6069 APPLY1
- 6070 PUSHCONSTINT 22
- 6072 PUSHCONST3
- 6073 PUSHACC2
- 6074 C_CALL2 string_get
- 6076 LSLINT
- 6077 PUSHCONSTINT 16
- 6079 PUSHCONST2
- 6080 PUSHACC3
- 6081 C_CALL2 string_get
- 6083 LSLINT
- 6084 PUSHCONSTINT 8
- 6086 PUSHCONST1
- 6087 PUSHACC4
- 6088 C_CALL2 string_get
- 6090 LSLINT
- 6091 PUSHCONST0
- 6092 PUSHACC4
- 6093 C_CALL2 string_get
- 6095 ADDINT
- 6096 ADDINT
- 6097 XORINT
- 6098 RETURN 2
- 6100 ACC0
- 6101 MAKEBLOCK1 0
- 6103 PUSHACC0
- 6104 CLOSURE 1, 6054
- 6107 PUSHCONST0
- 6108 PUSHCONSTINT 54
- 6110 PUSH
- 6111 BRANCH 6125
- 6113 CHECK_SIGNALS
- 6114 CONST0
- 6115 PUSHACC3
- 6116 APPLY1
- 6117 PUSHACC2
- 6118 PUSHENVACC1
- 6119 SETVECTITEM
- 6120 ACC1
- 6121 OFFSETINT 1
- 6123 ASSIGN 1
- 6125 ACC0
- 6126 PUSHACC2
- 6127 LEINT
- 6128 BRANCHIF 6113
- 6130 CONST0
- 6131 POP 2
- 6133 CONST0
- 6134 PUSHENVACC2
- 6135 SETFIELD0
- 6136 RETURN 3
- 6138 ACC0
- 6139 PUSHCONST0
- 6140 PUSHENVACC1
- 6141 APPLY1
- 6142 C_CALL2 mul_float
- 6144 RETURN 1
- 6146 CONSTINT 1073741823
- 6148 PUSHACC1
- 6149 GTINT
- 6150 BRANCHIF 6157
- 6152 CONST0
- 6153 PUSHACC1
- 6154 LEINT
- 6155 BRANCHIFNOT 6164
- 6157 GETGLOBAL "Random.int"
- 6159 PUSHGETGLOBALFIELD Pervasives, 2
- 6162 APPTERM1 2
- 6164 ACC0
- 6165 PUSHACC1
- 6166 PUSHACC2
- 6167 PUSHCONSTINT 1073741823
- 6169 DIVINT
- 6170 MULINT
- 6171 PUSHENVACC1
- 6172 APPLY1
- 6173 MODINT
- 6174 RETURN 1
- 6176 GETGLOBAL 1073741824
- 6178 PUSHCONST0
- 6179 PUSHENVACC1
- 6180 APPLY1
- 6181 C_CALL1 float_of_int
- 6183 PUSHCONST0
- 6184 PUSHENVACC1
- 6185 APPLY1
- 6186 C_CALL1 float_of_int
- 6188 PUSHCONST0
- 6189 PUSHENVACC1
- 6190 APPLY1
- 6191 C_CALL1 float_of_int
- 6193 PUSHACC3
- 6194 PUSHACC1
- 6195 PUSHACC5
- 6196 PUSHACC4
- 6197 PUSHACC7
- 6198 PUSHACC7
- 6199 C_CALL2 div_float
- 6201 C_CALL2 add_float
- 6203 C_CALL2 div_float
- 6205 C_CALL2 add_float
- 6207 C_CALL2 div_float
- 6209 RETURN 5
- 6211 CONSTINT 55
- 6213 PUSHENVACC2
- 6214 GETFIELD0
- 6215 OFFSETINT 1
- 6217 MODINT
- 6218 PUSHENVACC2
- 6219 SETFIELD0
- 6220 ENVACC2
- 6221 GETFIELD0
- 6222 PUSHENVACC1
- 6223 GETVECTITEM
- 6224 PUSHCONSTINT 55
- 6226 PUSHENVACC2
- 6227 GETFIELD0
- 6228 OFFSETINT 24
- 6230 MODINT
- 6231 PUSHENVACC1
- 6232 GETVECTITEM
- 6233 ADDINT
- 6234 PUSHACC0
- 6235 PUSHENVACC2
- 6236 GETFIELD0
- 6237 PUSHENVACC1
- 6238 SETVECTITEM
- 6239 CONSTINT 1073741823
- 6241 PUSHACC1
- 6242 ANDINT
- 6243 RETURN 2
- 6245 CONSTINT 440266690
- 6247 PUSHCONSTINT 124177607
- 6249 PUSHCONSTINT 414576093
- 6251 PUSHCONSTINT 180326017
- 6253 PUSHCONSTINT 33747835
- 6255 PUSHCONSTINT 896816596
- 6257 PUSHCONSTINT 21528564
- 6259 PUSHCONSTINT 414383108
- 6261 PUSHCONSTINT 514922558
- 6263 PUSHCONSTINT 979459837
- 6265 PUSHCONSTINT 146577263
- 6267 PUSHCONSTINT 714526560
- 6269 PUSHCONSTINT 187230644
- 6271 PUSHCONSTINT 22990936
- 6273 PUSHCONSTINT 310632349
- 6275 PUSHCONSTINT 781847598
- 6277 PUSHCONSTINT 854580894
- 6279 PUSHCONSTINT 804670393
- 6281 PUSHCONSTINT 268309077
- 6283 PUSHCONSTINT 4136554
- 6285 PUSHCONSTINT 567327260
- 6287 PUSHCONSTINT 768795410
- 6289 PUSHCONSTINT 868098973
- 6291 PUSHCONSTINT 462134267
- 6293 PUSHCONSTINT 32881167
- 6295 PUSHCONSTINT 708896334
- 6297 PUSHCONSTINT 572927557
- 6299 PUSHCONSTINT 933858406
- 6301 PUSHCONSTINT 965168955
- 6303 PUSHCONSTINT 233350272
- 6305 PUSHCONSTINT 878960411
- 6307 PUSHCONSTINT 971004788
- 6309 PUSHCONSTINT 762624501
- 6311 PUSHCONSTINT 796925167
- 6313 PUSHCONSTINT 206134737
- 6315 PUSHCONSTINT 281896889
- 6317 PUSHCONSTINT 814302728
- 6319 PUSHCONSTINT 477485839
- 6321 PUSHCONSTINT 998499212
- 6323 PUSHCONSTINT 473370118
- 6325 PUSHCONSTINT 66770770
- 6327 PUSHCONSTINT 337696531
- 6329 PUSHCONSTINT 848741663
- 6331 PUSHCONSTINT 71648846
- 6333 PUSHCONSTINT 869261341
- 6335 PUSHCONSTINT 951240904
- 6337 PUSHCONSTINT 147054819
- 6339 PUSHCONSTINT 486882977
- 6341 PUSHCONSTINT 552627506
- 6343 PUSHCONSTINT 615350359
- 6345 PUSHCONSTINT 1023641486
- 6347 PUSHCONSTINT 9858203
- 6349 PUSHCONSTINT 764306064
- 6351 PUSHCONSTINT 1051173471
- 6353 PUSHCONSTINT 561073064
- 6355 MAKEBLOCK 55, 0
- 6358 PUSHCONST0
- 6359 MAKEBLOCK1 0
- 6361 PUSHACC0
- 6362 PUSHACC2
- 6363 CLOSURE 2, 6211
- 6366 PUSHACC0
- 6367 CLOSURE 1, 6176
- 6370 PUSHACC1
- 6371 CLOSUREREC 1, 5991
- 6375 ACC0
- 6376 CLOSURE 1, 6146
- 6379 PUSHACC2
- 6380 CLOSURE 1, 6138
- 6383 PUSHACC5
- 6384 PUSHACC7
- 6385 CLOSURE 2, 6100
- 6388 PUSHACC0
- 6389 PUSHACC 8
- 6391 CLOSURE 2, 6012
- 6394 PUSHACC1
- 6395 CLOSURE 1, 6006
- 6398 PUSHACC3
- 6399 PUSHACC5
- 6400 PUSHACC 9
- 6402 PUSHACC3
- 6403 PUSHACC5
- 6404 PUSHACC7
- 6405 MAKEBLOCK 6, 0
- 6408 POP 10
- 6410 SETGLOBAL Random
- 6412 BRANCH 8038
- 6414 RESTART
- 6415 GRAB 1
- 6417 ACC1
- 6418 BRANCHIFNOT 6441
- 6420 ACC1
- 6421 GETFIELD0
- 6422 PUSHACC2
- 6423 GETFIELD1
- 6424 PUSHACC1
- 6425 PUSHACC3
- 6426 EQ
- 6427 BRANCHIFNOT 6432
- 6429 ACC0
- 6430 RETURN 4
- 6432 ACC0
- 6433 PUSHACC3
- 6434 PUSHOFFSETCLOSURE0
- 6435 APPLY2
- 6436 PUSHACC2
- 6437 MAKEBLOCK2 0
- 6439 POP 2
- 6441 RETURN 2
- 6443 RESTART
- 6444 GRAB 1
- 6446 CONST0
- 6447 PUSHACC2
- 6448 GTINT
- 6449 BRANCHIFNOT 6512
- 6451 CONST0
- 6452 PUSHENVACC2
- 6453 GETFIELD0
- 6454 GTINT
- 6455 BRANCHIFNOT 6512
- 6457 ENVACC2
- 6458 GETFIELD0
- 6459 PUSHGETGLOBALFIELD Random, 4
- 6462 APPLY1
- 6463 PUSHACC0
- 6464 PUSHENVACC1
- 6465 GETFIELD0
- 6466 C_CALL2 array_get_addr
- 6468 PUSHENVACC 5
- 6470 APPLY1
- 6471 BRANCHIF 6482
- 6473 ACC0
- 6474 PUSHENVACC 4
- 6476 APPLY1
- 6477 ACC2
- 6478 PUSHACC2
- 6479 PUSHOFFSETCLOSURE0
- 6480 APPTERM2 5
- 6482 PUSHTRAP 6496
- 6484 ACC5
- 6485 PUSHACC5
- 6486 PUSHENVACC1
- 6487 GETFIELD0
- 6488 C_CALL2 array_get_addr
- 6490 PUSHENVACC 7
- 6492 APPLY2
- 6493 POPTRAP
- 6494 RETURN 3
- 6496 PUSHENVACC 6
- 6498 PUSHACC1
- 6499 GETFIELD0
- 6500 EQ
- 6501 BRANCHIFNOT 6510
- 6503 ACC3
- 6504 OFFSETINT -1
- 6506 PUSHACC3
- 6507 PUSHOFFSETCLOSURE0
- 6508 APPTERM2 6
- 6510 ACC0
- 6511 RAISE
- 6512 ACC0
- 6513 PUSHENVACC3
- 6514 APPLY1
- 6515 ACC0
- 6516 RETURN 2
- 6518 RESTART
- 6519 GRAB 1
- 6521 ACC1
- 6522 BRANCHIFNOT 6534
- 6524 ACC0
- 6525 PUSHACC2
- 6526 GETFIELD0
- 6527 APPLY1
- 6528 ACC1
- 6529 GETFIELD1
- 6530 PUSHACC1
- 6531 PUSHOFFSETCLOSURE0
- 6532 APPTERM2 4
- 6534 RETURN 2
- 6536 CONST0
- 6537 PUSHENVACC1
- 6538 OFFSETINT -1
- 6540 PUSH
- 6541 BRANCH 6567
- 6543 CHECK_SIGNALS
- 6544 ENVACC2
- 6545 PUSHACC2
- 6546 PUSHACC4
- 6547 C_CALL2 array_get
- 6549 EQ
- 6550 BRANCHIFNOT 6556
- 6552 CONSTINT 46
- 6554 BRANCH 6558
- 6556 CONSTINT 42
- 6558 PUSHGETGLOBALFIELD Pervasives, 20
- 6561 APPLY1
- 6562 ACC1
- 6563 OFFSETINT 1
- 6565 ASSIGN 1
- 6567 ACC0
- 6568 PUSHACC2
- 6569 LEINT
- 6570 BRANCHIF 6543
- 6572 CONST0
- 6573 POP 2
- 6575 CONST0
- 6576 PUSHGETGLOBALFIELD Pervasives, 25
- 6579 APPTERM1 2
- 6581 ENVACC3
- 6582 GETFIELD0
- 6583 PUSHENVACC 4
- 6585 APPLY1
- 6586 PUSHENVACC2
- 6587 PUSHENVACC1
- 6588 CLOSURE 2, 6536
- 6591 PUSHGETGLOBALFIELD List, 9
- 6594 APPTERM2 3
- 6596 ACC0
- 6597 GETFIELD1
- 6598 RETURN 1
- 6600 RESTART
- 6601 GRAB 1
- 6603 ACC1
- 6604 GETFIELD0
- 6605 PUSHACC1
- 6606 GETFIELD0
- 6607 LEINT
- 6608 RETURN 2
- 6610 ACC0
- 6611 PUSHACC1
- 6612 PUSHENVACC1
- 6613 APPLY1
- 6614 MAKEBLOCK2 0
- 6616 RETURN 1
- 6618 ACC0
- 6619 PUSHENVACC1
- 6620 CLOSURE 1, 6610
- 6623 PUSHGETGLOBALFIELD List, 10
- 6626 APPLY2
- 6627 PUSH
- 6628 CLOSURE 0, 6601
- 6631 PUSHGETGLOBALFIELD Sort, 0
- 6634 APPLY2
- 6635 PUSH
- 6636 CLOSURE 0, 6596
- 6639 PUSHGETGLOBALFIELD List, 10
- 6642 APPTERM2 3
- 6644 ENVACC3
- 6645 GETFIELD0
- 6646 VECTLENGTH
- 6647 PUSHENVACC 4
- 6649 GETFIELD0
- 6650 PUSHCONST0
- 6651 PUSHENVACC 8
- 6653 APPLY1
- 6654 PUSHENVACC2
- 6655 GETFIELD0
- 6656 PUSHGETGLOBALFIELD List, 0
- 6659 APPLY1
- 6660 PUSHENVACC 7
- 6662 GETFIELD0
- 6663 PUSHENVACC 6
- 6665 GETFIELD0
- 6666 PUSHENVACC1
- 6667 GETFIELD0
- 6668 PUSHENVACC 5
- 6670 GETFIELD0
- 6671 MAKEBLOCK 8, 0
- 6674 RETURN 1
- 6676 ACC0
- 6677 PUSHENVACC1
- 6678 APPLY1
- 6679 PUSHACC0
- 6680 OFFSETINT -1
- 6682 PUSHENVACC2
- 6683 C_CALL2 array_get_addr
- 6685 OFFSETINT 1
- 6687 PUSHACC1
- 6688 OFFSETINT -1
- 6690 PUSHENVACC2
- 6691 C_CALL3 array_set_addr
- 6693 RETURN 2
- 6695 CONST0
- 6696 PUSHCONSTINT 32
- 6698 C_CALL2 make_vect
- 6700 PUSHENVACC1
- 6701 GETFIELD0
- 6702 PUSHACC1
- 6703 PUSHENVACC2
- 6704 CLOSURE 2, 6676
- 6707 PUSHGETGLOBALFIELD List, 9
- 6710 APPLY2
- 6711 ACC0
- 6712 RETURN 2
- 6714 RESTART
- 6715 GRAB 1
- 6717 ACC1
- 6718 PUSHENVACC1
- 6719 APPLY1
- 6720 PUSHACC1
- 6721 PUSHACC1
- 6722 GETFIELD1
- 6723 PUSHACC2
- 6724 GETFIELD0
- 6725 PUSHCONST0
- 6726 PUSHACC5
- 6727 C_CALL2 array_get_addr
- 6729 C_CALL2 array_get_addr
- 6731 C_CALL2 array_get_addr
- 6733 APPTERM1 4
- 6735 ACC0
- 6736 GETFIELD0
- 6737 C_CALL1 obj_dup
- 6739 PUSHENVACC1
- 6740 PUSHACC1
- 6741 PUSHENVACC2
- 6742 APPLY2
- 6743 ACC1
- 6744 GETFIELD2
- 6745 PUSHACC1
- 6746 PUSHENVACC3
- 6747 APPLY2
- 6748 ACC0
- 6749 RETURN 2
- 6751 RESTART
- 6752 GRAB 1
- 6754 ACC1
- 6755 GETFIELD 7
- 6757 PUSHCONST0
- 6758 PUSHACC1
- 6759 NEQ
- 6760 BRANCHIFNOT 6767
- 6762 ACC0
- 6763 PUSHACC2
- 6764 PUSHENVACC1
- 6765 APPTERM2 5
- 6767 RETURN 3
- 6769 ACC0
- 6770 GETFIELD0
- 6771 PUSHENVACC1
- 6772 C_CALL2 obj_block
- 6774 PUSHACC1
- 6775 GETFIELD1
- 6776 PUSHCONST0
- 6777 PUSHACC2
- 6778 C_CALL3 array_unsafe_set
- 6780 ENVACC2
- 6781 PUSHACC1
- 6782 PUSHENVACC3
- 6783 APPLY2
- 6784 ACC0
- 6785 RETURN 2
- 6787 ACC0
- 6788 GETFIELD0
- 6789 PUSHENVACC3
- 6790 GETFIELD0
- 6791 ADDINT
- 6792 OFFSETINT -1
- 6794 PUSHENVACC3
- 6795 SETFIELD0
- 6796 ENVACC1
- 6797 GETFIELD0
- 6798 BRANCHIFNOT 6804
- 6800 ACC0
- 6801 GETFIELD1
- 6802 PUSHENVACC2
- 6803 APPLY1
- 6804 ACC0
- 6805 GETFIELD 7
- 6807 PUSHGETGLOBALFIELD List, 4
- 6810 APPLY1
- 6811 PUSHACC1
- 6812 SETFIELD 7
- 6814 RETURN 1
- 6816 ACC0
- 6817 PUSHENVACC1
- 6818 APPLY1
- 6819 PUSHENVACC 4
- 6821 GETFIELD2
- 6822 PUSHACC1
- 6823 PUSHACC3
- 6824 PUSHENVACC2
- 6825 GETFIELD1
- 6826 APPLY3
- 6827 PUSHENVACC 4
- 6829 SETFIELD2
- 6830 ENVACC4
- 6831 GETFIELD3
- 6832 PUSHCONST1
- 6833 PUSHACC2
- 6834 PUSHENVACC3
- 6835 GETFIELD1
- 6836 APPLY3
- 6837 PUSHENVACC 4
- 6839 SETFIELD3
- 6840 RETURN 2
- 6842 CONST0
- 6843 PUSHENVACC 4
- 6845 APPLY1
- 6846 PUSHACC1
- 6847 PUSHACC1
- 6848 PUSHENVACC3
- 6849 PUSHENVACC2
- 6850 PUSHENVACC1
- 6851 CLOSURE 4, 6816
- 6854 PUSHGETGLOBALFIELD List, 9
- 6857 APPLY2
- 6858 ACC0
- 6859 RETURN 2
- 6861 RESTART
- 6862 GRAB 1
- 6864 ACC0
- 6865 GETFIELD 7
- 6867 PUSHACC2
- 6868 MAKEBLOCK2 0
- 6870 PUSHACC1
- 6871 SETFIELD 7
- 6873 RETURN 2
- 6875 ENVACC1
- 6876 PUSHENVACC3
- 6877 PUSH
- 6878 BRANCH 6895
- 6880 CHECK_SIGNALS
- 6881 ACC1
- 6882 PUSHENVACC2
- 6883 GETVECTITEM
- 6884 PUSHENVACC 4
- 6886 PUSHACC3
- 6887 ADDINT
- 6888 PUSHACC4
- 6889 SETVECTITEM
- 6890 ACC1
- 6891 OFFSETINT 1
- 6893 ASSIGN 1
- 6895 ACC0
- 6896 PUSHACC2
- 6897 LEINT
- 6898 BRANCHIF 6880
- 6900 CONST0
- 6901 RETURN 3
- 6903 ENVACC2
- 6904 GETFIELD0
- 6905 PUSHENVACC2
- 6906 GETFIELD2
- 6907 GETFIELD0
- 6908 OFFSETINT -1
- 6910 PUSHENVACC3
- 6911 GETFIELD0
- 6912 OFFSETINT -1
- 6914 PUSHACC1
- 6915 PUSHACC1
- 6916 SUBINT
- 6917 PUSHACC0
- 6918 PUSHACC3
- 6919 PUSHACC5
- 6920 PUSHENVACC1
- 6921 CLOSURE 4, 6875
- 6924 RETURN 5
- 6926 RESTART
- 6927 GRAB 1
- 6929 CONST0
- 6930 ACC1
- 6931 PUSHACC1
- 6932 PUSHENVACC1
- 6933 CLOSURE 3, 6903
- 6936 RETURN 2
- 6938 RESTART
- 6939 GRAB 1
- 6941 ACC0
- 6942 GETFIELD 6
- 6944 PUSHACC2
- 6945 PUSHENVACC1
- 6946 GETFIELD2
- 6947 APPTERM2 4
- 6949 RESTART
- 6950 GRAB 1
- 6952 ACC0
- 6953 PUSHENVACC2
- 6954 APPLY1
- 6955 PUSHACC1
- 6956 GETFIELD 6
- 6958 PUSHACC1
- 6959 PUSHACC4
- 6960 PUSHENVACC1
- 6961 GETFIELD1
- 6962 APPLY3
- 6963 PUSHACC2
- 6964 SETFIELD 6
- 6966 ACC0
- 6967 RETURN 3
- 6969 ACC0
- 6970 GETFIELD0
- 6971 PUSHACC0
- 6972 OFFSETINT 1
- 6974 PUSHACC2
- 6975 SETFIELD0
- 6976 ACC0
- 6977 RETURN 2
- 6979 RESTART
- 6980 GRAB 1
- 6982 CONST0
- 6983 PUSHACC1
- 6984 PUSHACC3
- 6985 GETFIELD1
- 6986 APPTERM2 4
- 6988 RESTART
- 6989 GRAB 1
- 6991 ENVACC1
- 6992 GETFIELD 4
- 6994 PUSHACC1
- 6995 GETFIELD0
- 6996 PUSHGETGLOBALFIELD List, 23
- 6999 APPLY2
- 7000 BRANCHIFNOT 7005
- 7002 ACC1
- 7003 RETURN 2
- 7005 ACC1
- 7006 PUSHACC1
- 7007 MAKEBLOCK2 0
- 7009 RETURN 2
- 7011 RESTART
- 7012 GRAB 1
- 7014 ACC0
- 7015 PUSHENVACC2
- 7016 GETFIELD 6
- 7018 PUSHACC3
- 7019 PUSHENVACC1
- 7020 GETFIELD2
- 7021 APPLY2
- 7022 PUSHACC3
- 7023 PUSHENVACC1
- 7024 GETFIELD1
- 7025 APPTERM3 5
- 7027 ACC0
- 7028 GETFIELD 4
- 7030 PUSHGETGLOBALFIELD List, 1
- 7033 APPLY1
- 7034 PUSHACC1
- 7035 GETFIELD 4
- 7037 PUSHGETGLOBALFIELD List, 2
- 7040 APPLY1
- 7041 PUSHACC2
- 7042 SETFIELD 4
- 7044 ACC0
- 7045 GETFIELD 5
- 7047 PUSHACC1
- 7048 GETFIELD3
- 7049 PUSHACC3
- 7050 PUSHENVACC1
- 7051 CLOSURE 2, 7012
- 7054 PUSHGETGLOBALFIELD List, 12
- 7057 APPLY3
- 7058 PUSHACC2
- 7059 SETFIELD 6
- 7061 ACC0
- 7062 GETFIELD0
- 7063 PUSHACC2
- 7064 SETFIELD2
- 7065 ACC0
- 7066 GETFIELD1
- 7067 PUSHACC2
- 7068 SETFIELD3
- 7069 ACC0
- 7070 GETFIELD2
- 7071 PUSHACC2
- 7072 GETFIELD 5
- 7074 PUSHACC2
- 7075 CLOSURE 1, 6989
- 7078 PUSHGETGLOBALFIELD List, 13
- 7081 APPLY3
- 7082 PUSHACC2
- 7083 SETFIELD 5
- 7085 RETURN 2
- 7087 RESTART
- 7088 GRAB 1
- 7090 ENVACC1
- 7091 PUSHACC1
- 7092 GETFIELD0
- 7093 PUSHGETGLOBALFIELD List, 23
- 7096 APPLY2
- 7097 BRANCHIFNOT 7102
- 7099 ACC1
- 7100 RETURN 2
- 7102 ACC1
- 7103 PUSHACC1
- 7104 MAKEBLOCK2 0
- 7106 RETURN 2
- 7108 RESTART
- 7109 GRAB 1
- 7111 ENVACC3
- 7112 GETFIELD0
- 7113 PUSHACC2
- 7114 PUSHACC2
- 7115 PUSHENVACC1
- 7116 GETFIELD1
- 7117 APPLY3
- 7118 PUSHENVACC3
- 7119 SETFIELD0
- 7120 ENVACC4
- 7121 GETFIELD0
- 7122 PUSHCONST0
- 7123 PUSHACC3
- 7124 PUSHENVACC2
- 7125 GETFIELD1
- 7126 APPLY3
- 7127 PUSHENVACC 4
- 7129 SETFIELD0
- 7130 RETURN 2
- 7132 ACC0
- 7133 PUSHENVACC 4
- 7135 PUSHENVACC3
- 7136 APPLY2
- 7137 PUSHENVACC 5
- 7139 GETFIELD0
- 7140 PUSHACC1
- 7141 PUSHACC3
- 7142 PUSHENVACC1
- 7143 GETFIELD1
- 7144 APPLY3
- 7145 PUSHENVACC 5
- 7147 SETFIELD0
- 7148 ENVACC 6
- 7150 GETFIELD0
- 7151 PUSH
- 7152 PUSHTRAP 7163
- 7154 ENVACC4
- 7155 GETFIELD3
- 7156 PUSHACC6
- 7157 PUSHENVACC2
- 7158 GETFIELD2
- 7159 APPLY2
- 7160 POPTRAP
- 7161 BRANCH 7177
- 7163 PUSHGETGLOBAL Not_found
- 7165 PUSHACC1
- 7166 GETFIELD0
- 7167 EQ
- 7168 BRANCHIFNOT 7173
- 7170 CONST1
- 7171 BRANCH 7175
- 7173 ACC0
- 7174 RAISE
- 7175 POP 1
- 7177 PUSHACC2
- 7178 PUSHENVACC2
- 7179 GETFIELD1
- 7180 APPLY3
- 7181 PUSHENVACC 6
- 7183 SETFIELD0
- 7184 RETURN 2
- 7186 RESTART
- 7187 GRAB 3
- 7189 ACC2
- 7190 PUSHACC1
- 7191 PUSHENVACC 4
- 7193 APPLY1
- 7194 PUSHGETGLOBALFIELD List, 10
- 7197 APPLY2
- 7198 PUSHACC1
- 7199 GETFIELD 4
- 7201 PUSHACC3
- 7202 PUSHACC2
- 7203 PUSHACC4
- 7204 GETFIELD 6
- 7206 PUSHACC5
- 7207 GETFIELD 5
- 7209 PUSHACC6
- 7210 GETFIELD3
- 7211 PUSHACC7
- 7212 GETFIELD2
- 7213 MAKEBLOCK 6, 0
- 7216 MAKEBLOCK2 0
- 7218 PUSHACC2
- 7219 SETFIELD 4
- 7221 ENVACC1
- 7222 GETFIELD0
- 7223 PUSHACC2
- 7224 SETFIELD 6
- 7226 ENVACC2
- 7227 GETFIELD0
- 7228 MAKEBLOCK1 0
- 7230 PUSHENVACC3
- 7231 GETFIELD0
- 7232 MAKEBLOCK1 0
- 7234 PUSHACC6
- 7235 PUSHACC1
- 7236 PUSHACC3
- 7237 PUSHACC6
- 7238 PUSHENVACC 4
- 7240 PUSHENVACC3
- 7241 PUSHENVACC2
- 7242 CLOSURE 6, 7132
- 7245 PUSHGETGLOBALFIELD List, 9
- 7248 APPLY2
- 7249 ACC2
- 7250 PUSHACC6
- 7251 PUSHACC2
- 7252 PUSHACC4
- 7253 PUSHENVACC3
- 7254 PUSHENVACC2
- 7255 CLOSURE 4, 7109
- 7258 PUSHGETGLOBALFIELD List, 14
- 7261 APPLY3
- 7262 ACC1
- 7263 GETFIELD0
- 7264 PUSHACC4
- 7265 SETFIELD2
- 7266 ACC0
- 7267 GETFIELD0
- 7268 PUSHACC4
- 7269 SETFIELD3
- 7270 CONST0
- 7271 PUSHACC4
- 7272 GETFIELD 5
- 7274 PUSHACC4
- 7275 CLOSURE 1, 7088
- 7278 PUSHGETGLOBALFIELD List, 13
- 7281 APPLY3
- 7282 PUSHACC4
- 7283 SETFIELD 5
- 7285 RETURN 7
- 7287 RESTART
- 7288 GRAB 1
- 7290 PUSHTRAP 7303
- 7292 ACC4
- 7293 GETFIELD 5
- 7295 PUSHACC6
- 7296 PUSHGETGLOBALFIELD List, 29
- 7299 APPLY2
- 7300 POPTRAP
- 7301 RETURN 2
- 7303 PUSHGETGLOBAL Not_found
- 7305 PUSHACC1
- 7306 GETFIELD0
- 7307 EQ
- 7308 BRANCHIFNOT 7325
- 7310 ACC2
- 7311 PUSHENVACC1
- 7312 APPLY1
- 7313 PUSHACC0
- 7314 GETFIELD1
- 7315 PUSHACC1
- 7316 GETFIELD0
- 7317 PUSHACC4
- 7318 GETFIELD1
- 7319 C_CALL2 array_get_addr
- 7321 C_CALL2 array_get
- 7323 RETURN 4
- 7325 ACC0
- 7326 RAISE
- 7327 RESTART
- 7328 GRAB 2
- 7330 ENVACC3
- 7331 OFFSETREF 1
- 7333 ACC0
- 7334 GETFIELD3
- 7335 PUSHACC2
- 7336 PUSHENVACC1
- 7337 GETFIELD2
- 7338 APPLY2
- 7339 BRANCHIFNOT 7347
- 7341 ACC2
- 7342 PUSHACC2
- 7343 PUSHACC2
- 7344 PUSHENVACC2
- 7345 APPTERM3 6
- 7347 ACC0
- 7348 GETFIELD 5
- 7350 PUSHACC3
- 7351 PUSHACC3
- 7352 MAKEBLOCK2 0
- 7354 MAKEBLOCK2 0
- 7356 PUSHACC1
- 7357 SETFIELD 5
- 7359 RETURN 3
- 7361 RESTART
- 7362 GRAB 1
- 7364 PUSHTRAP 7375
- 7366 ACC4
- 7367 GETFIELD2
- 7368 PUSHACC6
- 7369 PUSHENVACC2
- 7370 GETFIELD2
- 7371 APPLY2
- 7372 POPTRAP
- 7373 RETURN 2
- 7375 PUSHGETGLOBAL Not_found
- 7377 PUSHACC1
- 7378 GETFIELD0
- 7379 EQ
- 7380 BRANCHIFNOT 7406
- 7382 CONST0
- 7383 PUSHENVACC1
- 7384 APPLY1
- 7385 PUSHACC2
- 7386 GETFIELD2
- 7387 PUSHACC1
- 7388 PUSHACC5
- 7389 PUSHENVACC2
- 7390 GETFIELD1
- 7391 APPLY3
- 7392 PUSHACC3
- 7393 SETFIELD2
- 7394 ACC2
- 7395 GETFIELD3
- 7396 PUSHCONST1
- 7397 PUSHACC2
- 7398 PUSHENVACC3
- 7399 GETFIELD1
- 7400 APPLY3
- 7401 PUSHACC3
- 7402 SETFIELD3
- 7403 ACC0
- 7404 RETURN 4
- 7406 ACC0
- 7407 RAISE
- 7408 RESTART
- 7409 GRAB 2
- 7411 ACC1
- 7412 PUSHENVACC1
- 7413 APPLY1
- 7414 PUSHACC0
- 7415 GETFIELD0
- 7416 PUSHACC0
- 7417 OFFSETINT 1
- 7419 PUSHACC3
- 7420 PUSHENVACC 4
- 7422 APPLY2
- 7423 ACC0
- 7424 PUSHACC3
- 7425 GETFIELD1
- 7426 C_CALL2 array_get_addr
- 7428 PUSHENVACC2
- 7429 PUSHACC1
- 7430 EQ
- 7431 BRANCHIFNOT 7444
- 7433 CONST0
- 7434 PUSHENVACC3
- 7435 APPLY1
- 7436 ASSIGN 0
- 7438 ACC0
- 7439 PUSHACC2
- 7440 PUSHACC5
- 7441 GETFIELD1
- 7442 C_CALL3 array_set_addr
- 7444 ACC5
- 7445 PUSHACC3
- 7446 GETFIELD1
- 7447 PUSHACC2
- 7448 C_CALL3 array_set
- 7450 RETURN 6
- 7452 RESTART
- 7453 GRAB 1
- 7455 ACC0
- 7456 GETFIELD1
- 7457 VECTLENGTH
- 7458 PUSHACC0
- 7459 PUSHACC3
- 7460 GTINT
- 7461 BRANCHIFNOT 7487
- 7463 ENVACC1
- 7464 PUSHACC3
- 7465 C_CALL2 make_vect
- 7467 PUSH
- 7468 PUSH_RETADDR 7482
- 7470 ACC4
- 7471 PUSHCONST0
- 7472 PUSHACC5
- 7473 PUSHCONST0
- 7474 PUSHACC 9
- 7476 GETFIELD1
- 7477 PUSHGETGLOBALFIELD Array, 8
- 7480 APPLY 5
- 7482 ACC0
- 7483 PUSHACC3
- 7484 SETFIELD1
- 7485 POP 1
- 7487 RETURN 3
- 7489 ENVACC 5
- 7491 OFFSETREF 1
- 7493 CONST0
- 7494 PUSHENVACC2
- 7495 GETFIELD0
- 7496 PUSHCONST0
- 7497 PUSHCONST0
- 7498 PUSHENVACC 4
- 7500 GETFIELD0
- 7501 PUSHENVACC3
- 7502 GETFIELD0
- 7503 PUSH
- 7504 ATOM0
- 7505 PUSHENVACC1
- 7506 MAKEBLOCK 8, 0
- 7509 RETURN 1
- 7511 RESTART
- 7512 GRAB 1
- 7514 ACC1
- 7515 PUSHACC1
- 7516 C_CALL2 compare
- 7518 RETURN 2
- 7520 RESTART
- 7521 GRAB 1
- 7523 ACC1
- 7524 PUSHACC1
- 7525 C_CALL2 compare
- 7527 RETURN 2
- 7529 RESTART
- 7530 GRAB 1
- 7532 ACC1
- 7533 PUSHACC1
- 7534 C_CALL2 compare
- 7536 RETURN 2
- 7538 PUSHTRAP 7549
- 7540 ACC4
- 7541 PUSHENVACC1
- 7542 PUSHGETGLOBALFIELD Hashtbl, 3
- 7545 APPLY2
- 7546 POPTRAP
- 7547 RETURN 1
- 7549 PUSHGETGLOBAL Not_found
- 7551 PUSHACC1
- 7552 GETFIELD0
- 7553 EQ
- 7554 BRANCHIFNOT 7569
- 7556 CONST0
- 7557 PUSHENVACC2
- 7558 APPLY1
- 7559 PUSHACC0
- 7560 PUSHACC3
- 7561 PUSHENVACC1
- 7562 PUSHGETGLOBALFIELD Hashtbl, 2
- 7565 APPLY3
- 7566 ACC0
- 7567 RETURN 3
- 7569 ACC0
- 7570 RAISE
- 7571 ENVACC2
- 7572 GETFIELD0
- 7573 PUSHENVACC2
- 7574 GETFIELD0
- 7575 PUSHENVACC1
- 7576 APPLY1
- 7577 PUSHENVACC2
- 7578 SETFIELD0
- 7579 ACC0
- 7580 RETURN 2
- 7582 ENVACC1
- 7583 PUSHACC1
- 7584 VECTLENGTH
- 7585 OFFSETINT -1
- 7587 PUSH
- 7588 BRANCH 7606
- 7590 CHECK_SIGNALS
- 7591 ACC1
- 7592 PUSHACC3
- 7593 C_CALL2 array_get_addr
- 7595 PUSHENVACC2
- 7596 APPLY1
- 7597 PUSHACC2
- 7598 PUSHACC4
- 7599 C_CALL3 array_set_addr
- 7601 ACC1
- 7602 OFFSETINT 1
- 7604 ASSIGN 1
- 7606 ACC0
- 7607 PUSHACC2
- 7608 LEINT
- 7609 BRANCHIF 7590
- 7611 CONST0
- 7612 RETURN 3
- 7614 ENVACC4
- 7615 PUSHACC1
- 7616 NEQ
- 7617 BRANCHIFNOT 7640
- 7619 ENVACC2
- 7620 GETFIELD0
- 7621 PUSHACC1
- 7622 PUSHENVACC3
- 7623 APPLY1
- 7624 EQ
- 7625 BRANCHIFNOT 7640
- 7627 ACC0
- 7628 PUSHENVACC 5
- 7630 APPLY1
- 7631 BRANCHIFNOT 7640
- 7633 ENVACC1
- 7634 GETFIELD3
- 7635 PUSHACC1
- 7636 PUSHENVACC 6
- 7638 APPTERM2 3
- 7640 ACC0
- 7641 RETURN 1
- 7643 RESTART
- 7644 GRAB 1
- 7646 CONST0
- 7647 PUSHENVACC1
- 7648 OFFSETINT -1
- 7650 PUSH
- 7651 BRANCH 7690
- 7653 CHECK_SIGNALS
- 7654 ENVACC2
- 7655 PUSHACC2
- 7656 PUSHACC5
- 7657 C_CALL2 array_get
- 7659 NEQ
- 7660 BRANCHIFNOT 7679
- 7662 ENVACC2
- 7663 PUSHACC2
- 7664 PUSHACC4
- 7665 C_CALL2 array_get
- 7667 NEQ
- 7668 BRANCHIFNOT 7679
- 7670 ACC1
- 7671 PUSHACC3
- 7672 C_CALL2 array_get
- 7674 PUSHACC2
- 7675 PUSHACC5
- 7676 C_CALL2 array_get
- 7678 NEQ
- 7679 BRANCHIFNOT 7685
- 7681 ENVACC4
- 7682 MAKEBLOCK1 0
- 7684 RAISE
- 7685 ACC1
- 7686 OFFSETINT 1
- 7688 ASSIGN 1
- 7690 ACC0
- 7691 PUSHACC2
- 7692 LEINT
- 7693 BRANCHIF 7653
- 7695 CONST0
- 7696 POP 2
- 7698 CONST0
- 7699 PUSHENVACC1
- 7700 OFFSETINT -1
- 7702 PUSH
- 7703 BRANCH 7727
- 7705 CHECK_SIGNALS
- 7706 ENVACC2
- 7707 PUSHACC2
- 7708 PUSHACC5
- 7709 C_CALL2 array_get
- 7711 NEQ
- 7712 BRANCHIFNOT 7722
- 7714 ACC1
- 7715 PUSHACC4
- 7716 C_CALL2 array_get
- 7718 PUSHACC2
- 7719 PUSHACC4
- 7720 C_CALL3 array_set
- 7722 ACC1
- 7723 OFFSETINT 1
- 7725 ASSIGN 1
- 7727 ACC0
- 7728 PUSHACC2
- 7729 LEINT
- 7730 BRANCHIF 7705
- 7732 CONST0
- 7733 POP 2
- 7735 ENVACC3
- 7736 GETFIELD0
- 7737 PUSHACC2
- 7738 PUSHENVACC 5
- 7740 APPLY2
- 7741 PUSHENVACC3
- 7742 SETFIELD0
- 7743 ACC0
- 7744 RETURN 2
- 7746 ENVACC1
- 7747 GETFIELD 4
- 7749 PUSHACC1
- 7750 PUSHENVACC2
- 7751 APPLY1
- 7752 LEINT
- 7753 RETURN 1
- 7755 CONST0
- 7756 PUSHCONST0
- 7757 PUSHENVACC1
- 7758 OFFSETINT -1
- 7760 PUSH
- 7761 BRANCH 7782
- 7763 CHECK_SIGNALS
- 7764 ENVACC2
- 7765 PUSHACC2
- 7766 PUSHACC5
- 7767 C_CALL2 array_get
- 7769 NEQ
- 7770 BRANCHIFNOT 7777
- 7772 ACC2
- 7773 OFFSETINT 1
- 7775 ASSIGN 2
- 7777 ACC1
- 7778 OFFSETINT 1
- 7780 ASSIGN 1
- 7782 ACC0
- 7783 PUSHACC2
- 7784 LEINT
- 7785 BRANCHIF 7763
- 7787 CONST0
- 7788 POP 2
- 7790 ACC0
- 7791 RETURN 2
- 7793 ENVACC2
- 7794 GETFIELD0
- 7795 OFFSETINT -1
- 7797 PUSHENVACC1
- 7798 GETFIELD0
- 7799 C_CALL2 array_get_addr
- 7801 PUSHACC1
- 7802 PUSHENVACC1
- 7803 GETFIELD0
- 7804 C_CALL3 array_set_addr
- 7806 ENVACC2
- 7807 OFFSETREF -1
- 7809 RETURN 1
- 7811 ENVACC1
- 7812 GETFIELD0
- 7813 VECTLENGTH
- 7814 PUSHACC0
- 7815 PUSHENVACC2
- 7816 GETFIELD0
- 7817 GEINT
- 7818 BRANCHIFNOT 7845
- 7820 ATOM0
- 7821 PUSHACC1
- 7822 PUSHCONST2
- 7823 MULINT
- 7824 C_CALL2 make_vect
- 7826 PUSH
- 7827 PUSH_RETADDR 7840
- 7829 ACC4
- 7830 PUSHCONST0
- 7831 PUSHACC5
- 7832 PUSHCONST0
- 7833 PUSHENVACC1
- 7834 GETFIELD0
- 7835 PUSHGETGLOBALFIELD Array, 8
- 7838 APPLY 5
- 7840 ACC0
- 7841 PUSHENVACC1
- 7842 SETFIELD0
- 7843 POP 1
- 7845 ACC1
- 7846 PUSHENVACC2
- 7847 GETFIELD0
- 7848 PUSHENVACC1
- 7849 GETFIELD0
- 7850 C_CALL3 array_set_addr
- 7852 ENVACC2
- 7853 OFFSETREF 1
- 7855 RETURN 2
- 7857 ACC0
- 7858 GETFIELD0
- 7859 PUSHENVACC1
- 7860 APPLY1
- 7861 PUSHENVACC2
- 7862 PUSHACC1
- 7863 GETFIELD0
- 7864 EQ
- 7865 BRANCHIFNOT 7874
- 7867 ACC1
- 7868 GETFIELD1
- 7869 PUSHACC1
- 7870 GETFIELD1
- 7871 PUSHENVACC3
- 7872 C_CALL3 array_set
- 7874 RETURN 2
- 7876 RESTART
- 7877 GRAB 1
- 7879 CONST0
- 7880 PUSHENVACC2
- 7881 APPLY1
- 7882 PUSHACC2
- 7883 PUSHGETGLOBALFIELD List, 4
- 7886 APPLY1
- 7887 PUSHACC1
- 7888 PUSHACC3
- 7889 PUSHENVACC1
- 7890 CLOSURE 3, 7857
- 7893 PUSHGETGLOBALFIELD List, 9
- 7896 APPLY2
- 7897 ACC0
- 7898 RETURN 3
- 7900 ACC0
- 7901 PUSHGETGLOBALFIELD Array, 6
- 7904 APPLY1
- 7905 PUSHACC0
- 7906 PUSHENVACC3
- 7907 APPLY1
- 7908 ENVACC2
- 7909 GETFIELD0
- 7910 PUSHENVACC1
- 7911 PUSHACC2
- 7912 C_CALL3 array_set
- 7914 ENVACC4
- 7915 GETFIELD0
- 7916 PUSHACC1
- 7917 MAKEBLOCK2 0
- 7919 PUSHENVACC 4
- 7921 SETFIELD0
- 7922 ACC0
- 7923 RETURN 2
- 7925 ENVACC2
- 7926 PUSHENVACC1
- 7927 OFFSETINT 1
- 7929 C_CALL2 make_vect
- 7931 PUSHACC0
- 7932 PUSHENVACC3
- 7933 APPLY1
- 7934 ENVACC4
- 7935 GETFIELD0
- 7936 PUSHACC1
- 7937 MAKEBLOCK2 0
- 7939 PUSHENVACC 4
- 7941 SETFIELD0
- 7942 ACC0
- 7943 RETURN 2
- 7945 ENVACC1
- 7946 PUSHACC1
- 7947 C_CALL2 array_get
- 7949 RETURN 1
- 7951 ENVACC2
- 7952 GETFIELD0
- 7953 PUSHENVACC1
- 7954 PUSHACC2
- 7955 C_CALL3 array_set
- 7957 RETURN 1
- 7959 ENVACC1
- 7960 PUSHENVACC2
- 7961 PUSHENVACC1
- 7962 MULINT
- 7963 PUSHACC2
- 7964 MODINT
- 7965 DIVINT
- 7966 PUSHENVACC1
- 7967 PUSHCONSTINT 65536
- 7969 PUSHACC3
- 7970 DIVINT
- 7971 DIVINT
- 7972 MAKEBLOCK2 0
- 7974 RETURN 1
- 7976 ENVACC3
- 7977 OFFSETREF 1
- 7979 ENVACC1
- 7980 PUSHACC1
- 7981 ADDINT
- 7982 PUSHCONST0
- 7983 PUSHENVACC2
- 7984 PUSHENVACC1
- 7985 MULINT
- 7986 PUSHACC2
- 7987 MODINT
- 7988 EQ
- 7989 BRANCHIFNOT 8001
- 7991 ENVACC2
- 7992 PUSHCONSTINT 65536
- 7994 SUBINT
- 7995 PUSHENVACC1
- 7996 MULINT
- 7997 PUSHACC1
- 7998 ADDINT
- 7999 RETURN 2
- 8001 ACC0
- 8002 RETURN 2
- 8004 ACC0
- 8005 C_CALL1 obj_dup
- 8007 PUSHENVACC1
- 8008 PUSHACC1
- 8009 PUSHENVACC2
- 8010 APPLY2
- 8011 ACC0
- 8012 RETURN 2
- 8014 RESTART
- 8015 GRAB 1
- 8017 ACC1
- 8018 GETFIELD0
- 8019 PUSHACC0
- 8020 PUSHCONST1
- 8021 PUSHACC3
- 8022 SETVECTITEM
- 8023 ACC0
- 8024 OFFSETINT 1
- 8026 PUSHACC3
- 8027 SETFIELD0
- 8028 RETURN 3
- 8030 ENVACC1
- 8031 GETFIELD0
- 8032 PUSHENVACC1
- 8033 OFFSETREF 1
- 8035 ACC0
- 8036 RETURN 2
- 8038 CONSTINT 248
- 8040 PUSHCONST0
- 8041 MAKEBLOCK1 0
- 8043 PUSHACC0
- 8044 CLOSURE 1, 8030
- 8047 PUSH
- 8048 CLOSURE 0, 8015
- 8051 PUSHACC0
- 8052 PUSHACC3
- 8053 CLOSURE 2, 8004
- 8056 PUSHCONSTINT 16
- 8058 PUSHCONST3
- 8059 PUSHCONST1
- 8060 PUSHCONST1
- 8061 PUSHCONST1
- 8062 MAKEBLOCK 5, 0
- 8065 PUSHCONSTINT 16
- 8067 PUSHGETGLOBALFIELD Sys, 3
- 8070 DIVINT
- 8071 PUSHCONST0
- 8072 PUSHCONSTINT 32
- 8074 PUSHCONST2
- 8075 PUSHCONST0
- 8076 MAKEBLOCK1 0
- 8078 PUSHACC0
- 8079 PUSHACC3
- 8080 PUSHACC6
- 8081 CLOSURE 3, 7976
- 8084 PUSHACC3
- 8085 PUSHACC6
- 8086 CLOSURE 2, 7959
- 8089 PUSHCONST0
- 8090 PUSHCONST0
- 8091 MAKEBLOCK1 0
- 8093 PUSHACC0
- 8094 PUSHACC7
- 8095 CLOSURE 2, 7951
- 8098 PUSHACC7
- 8099 CLOSURE 1, 7945
- 8102 PUSHCONST0
- 8103 MAKEBLOCK1 0
- 8105 PUSH
- 8106 ATOM0
- 8107 PUSHACC1
- 8108 PUSHACC4
- 8109 PUSHACC7
- 8110 PUSHACC 13
- 8112 CLOSURE 4, 7925
- 8115 PUSHACC2
- 8116 PUSHACC5
- 8117 PUSHACC7
- 8118 PUSHACC 14
- 8120 CLOSURE 4, 7900
- 8123 PUSHACC1
- 8124 PUSHACC 9
- 8126 CLOSURE 2, 7877
- 8129 PUSH
- 8130 ATOM0
- 8131 PUSHCONSTINT 10
- 8133 C_CALL2 make_vect
- 8135 MAKEBLOCK1 0
- 8137 PUSHCONST0
- 8138 MAKEBLOCK1 0
- 8140 PUSHACC0
- 8141 PUSHACC2
- 8142 CLOSURE 2, 7811
- 8145 PUSHACC1
- 8146 PUSHACC3
- 8147 CLOSURE 2, 7793
- 8150 PUSHACC 12
- 8152 PUSHACC 18
- 8154 CLOSURE 2, 7755
- 8157 PUSHACC0
- 8158 PUSHACC 22
- 8160 CLOSURE 2, 7746
- 8163 PUSHGETGLOBAL "Oo.Failed"
- 8165 MAKEBLOCK1 0
- 8167 PUSH
- 8168 CLOSUREREC 0, 6415
- 8172 ACC0
- 8173 PUSHACC2
- 8174 PUSHACC 14
- 8176 PUSHACC 19
- 8178 PUSHACC 25
- 8180 CLOSURE 5, 7644
- 8183 PUSHACC0
- 8184 PUSHACC3
- 8185 PUSHACC5
- 8186 PUSHACC 8
- 8188 PUSHACC 10
- 8190 PUSHACC 12
- 8192 PUSHACC 14
- 8194 CLOSUREREC 7, 6444
- 8198 ACC0
- 8199 PUSHACC5
- 8200 PUSHACC 15
- 8202 PUSHACC 18
- 8204 PUSHACC 21
- 8206 PUSHACC 31
- 8208 CLOSURE 6, 7614
- 8211 PUSHACC0
- 8212 PUSHACC 26
- 8214 CLOSURE 2, 7582
- 8217 PUSHACC 27
- 8219 PUSHCONSTINT 65536
- 8221 PUSHACC 28
- 8223 MULINT
- 8224 MULINT
- 8225 PUSHACC0
- 8226 MAKEBLOCK1 0
- 8228 PUSHCONSTINT 101
- 8230 PUSHGETGLOBALFIELD Hashtbl, 0
- 8233 APPLY1
- 8234 PUSHACC1
- 8235 PUSHACC 26
- 8237 CLOSURE 2, 7571
- 8240 PUSHACC0
- 8241 PUSHACC2
- 8242 CLOSURE 2, 7538
- 8245 PUSH
- 8246 CLOSURE 0, 7530
- 8249 PUSHACC0
- 8250 MAKEBLOCK1 0
- 8252 POP 1
- 8254 PUSHGETGLOBALFIELD Map, 0
- 8257 APPLY1
- 8258 PUSH
- 8259 CLOSURE 0, 7521
- 8262 PUSHACC0
- 8263 MAKEBLOCK1 0
- 8265 POP 1
- 8267 PUSHGETGLOBALFIELD Map, 0
- 8270 APPLY1
- 8271 PUSH
- 8272 CLOSURE 0, 7512
- 8275 PUSHACC0
- 8276 MAKEBLOCK1 0
- 8278 POP 1
- 8280 PUSHGETGLOBALFIELD Map, 0
- 8283 APPLY1
- 8284 PUSHCONST0
- 8285 MAKEBLOCK1 0
- 8287 PUSHACC0
- 8288 PUSHACC2
- 8289 PUSHACC4
- 8290 PUSHACC6
- 8291 PUSHACC 37
- 8293 CLOSURE 5, 7489
- 8296 PUSHACC 25
- 8298 CLOSURE 1, 7453
- 8301 PUSHACC0
- 8302 PUSHACC 26
- 8304 PUSHACC 28
- 8306 PUSHACC 35
- 8308 CLOSURE 4, 7409
- 8311 PUSHCONST0
- 8312 MAKEBLOCK1 0
- 8314 PUSHCONST0
- 8315 MAKEBLOCK1 0
- 8317 PUSHACC6
- 8318 PUSHACC 8
- 8320 PUSHACC 12
- 8322 CLOSURE 3, 7362
- 8325 PUSHACC2
- 8326 PUSHACC4
- 8327 PUSHACC 9
- 8329 CLOSURE 3, 7328
- 8332 PUSHACC 37
- 8334 CLOSURE 1, 7288
- 8337 PUSHACC2
- 8338 PUSHACC 10
- 8340 PUSHACC 12
- 8342 PUSHACC 14
- 8344 CLOSURE 4, 7187
- 8347 PUSHACC 12
- 8349 CLOSURE 1, 7027
- 8352 PUSH
- 8353 CLOSURE 0, 6980
- 8356 PUSH
- 8357 CLOSURE 0, 6969
- 8360 PUSHACC0
- 8361 PUSHACC 16
- 8363 CLOSURE 2, 6950
- 8366 PUSHACC 16
- 8368 CLOSURE 1, 6939
- 8371 PUSHACC 47
- 8373 CLOSURE 1, 6927
- 8376 PUSH
- 8377 CLOSURE 0, 6862
- 8380 PUSHACC 15
- 8382 PUSHACC 18
- 8384 PUSHACC 20
- 8386 PUSHACC 23
- 8388 CLOSURE 4, 6842
- 8391 PUSHACC 12
- 8393 PUSHACC 27
- 8395 PUSHACC 56
- 8397 CLOSURE 3, 6787
- 8400 PUSHACC 57
- 8402 PUSHACC 60
- 8404 PUSHACC 62
- 8406 CLOSURE 3, 6769
- 8409 PUSH
- 8410 CLOSUREREC 0, 6519
- 8414 ACC0
- 8415 CLOSURE 1, 6752
- 8418 PUSHACC0
- 8419 PUSHACC 61
- 8421 PUSHACC 64
- 8423 CLOSURE 3, 6735
- 8426 PUSHACC 52
- 8428 CLOSURE 1, 6715
- 8431 PUSHACC 39
- 8433 PUSHACC 49
- 8435 CLOSURE 2, 6695
- 8438 PUSHACC0
- 8439 PUSHACC 20
- 8441 PUSHACC 22
- 8443 PUSHACC 27
- 8445 PUSHACC 47
- 8447 PUSHACC 49
- 8449 PUSHACC 55
- 8451 PUSHACC 63
- 8453 CLOSURE 8, 6644
- 8456 PUSHACC 41
- 8458 CLOSURE 1, 6618
- 8461 PUSHACC0
- 8462 PUSHACC 52
- 8464 PUSHACC 57
- 8466 PUSHACC 63
- 8468 CLOSURE 4, 6581
- 8471 PUSHACC0
- 8472 PUSHACC3
- 8473 PUSHACC 66
- 8475 PUSHACC7
- 8476 PUSHACC 9
- 8478 PUSHACC 11
- 8480 PUSHACC 14
- 8482 PUSHACC 16
- 8484 PUSHACC 18
- 8486 PUSHACC 20
- 8488 PUSHACC 27
- 8490 PUSHACC 29
- 8492 PUSHACC 32
- 8494 PUSHACC 32
- 8496 PUSHACC 35
- 8498 PUSHACC 27
- 8500 PUSHACC 29
- 8502 PUSHACC 31
- 8504 PUSHACC 34
- 8506 PUSHACC 50
- 8508 PUSHACC 85
- 8510 MAKEBLOCK 21, 0
- 8513 POP 70
- 8515 SETGLOBAL Oo
- 8517 BRANCH 8568
- 8519 ACC0
- 8520 BRANCHIFNOT 8525
- 8522 ACC0
- 8523 BRANCH 8530
- 8525 ENVACC1
- 8526 PUSHGETGLOBALFIELD Oo, 14
- 8529 APPLY1
- 8530 PUSHCONST0
- 8531 ACC1
- 8532 BRANCHIFNOT 8537
- 8534 CONST0
- 8535 BRANCH 8543
- 8537 ENVACC1
- 8538 PUSHACC1
- 8539 PUSHGETGLOBALFIELD Oo, 15
- 8542 APPLY2
- 8543 ACC0
- 8544 RETURN 2
- 8546 CONSTINT 23
- 8548 RETURN 1
- 8550 CLOSURE 0, 8546
- 8553 PUSHACC0
- 8554 POP 1
- 8556 PUSHENVACC1
- 8557 PUSHACC2
- 8558 PUSHGETGLOBALFIELD Oo, 8
- 8561 APPLY3
- 8562 ACC0
- 8563 CLOSURE 1, 8519
- 8566 RETURN 1
- 8568 GETGLOBALFIELD Oo, 1
- 8571 PUSHGETGLOBAL "m"
- 8573 PUSHACC1
- 8574 APPLY1
- 8575 PUSHCONST3
- 8576 C_CALL1 alloc_dummy
- 8578 PUSHGETGLOBAL <0>("m", 0)
- 8580 PUSHGETGLOBALFIELD Oo, 12
- 8583 APPLY1
- 8584 PUSHACC2
- 8585 CLOSURE 1, 8550
- 8588 PUSHACC1
- 8589 PUSHACC1
- 8590 APPLY1
- 8591 PUSHACC2
- 8592 PUSHGETGLOBALFIELD Oo, 13
- 8595 APPLY1
- 8596 ACC2
- 8597 PUSHACC2
- 8598 PUSHACC2
- 8599 MAKEBLOCK3 0
- 8601 POP 3
- 8603 PUSHACC1
- 8604 C_CALL2 update_dummy
- 8606 CONST0
- 8607 PUSHACC1
- 8608 GETFIELD0
- 8609 APPLY1
- 8610 PUSHCONSTINT 23
- 8612 PUSHACC1
- 8613 PUSHACC4
- 8614 GETMETHOD
- 8615 APPLY1
- 8616 NEQ
- 8617 BRANCHIFNOT 8624
- 8619 GETGLOBAL Not_found
- 8621 MAKEBLOCK1 0
- 8623 RAISE
- 8624 POP 1
- 8626 ACC0
- 8627 MAKEBLOCK1 0
- 8629 POP 3
- 8631 SETGLOBAL T300-getmethod
- 8633 STOP
-**)
diff --git a/test/testinterp/t310-alloc-1.ml b/test/testinterp/t310-alloc-1.ml
deleted file mode 100644
index c438cc972d..0000000000
--- a/test/testinterp/t310-alloc-1.ml
+++ /dev/null
@@ -1,1587 +0,0 @@
-open Lib;;
-let rec f a n =
- if n <= 0 then a
- else f (1::a) (n-1)
-in
-let l = f [] 30000 in
-if List.fold_left (+) 0 l <> 30000 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 746
- 11 RESTART
- 12 GRAB 1
- 14 ACC0
- 15 BRANCHIFNOT 28
- 17 ACC1
- 18 PUSHACC1
- 19 GETFIELD1
- 20 PUSHOFFSETCLOSURE0
- 21 APPLY2
- 22 PUSHACC1
- 23 GETFIELD0
- 24 MAKEBLOCK2 0
- 26 RETURN 2
- 28 ACC1
- 29 RETURN 2
- 31 RESTART
- 32 GRAB 3
- 34 CONST0
- 35 PUSHACC4
- 36 LEINT
- 37 BRANCHIFNOT 42
- 39 CONST0
- 40 RETURN 4
- 42 ACC3
- 43 PUSHACC3
- 44 PUSHACC3
- 45 PUSHACC3
- 46 C_CALL4 caml_input
- 48 PUSHCONST0
- 49 PUSHACC1
- 50 EQ
- 51 BRANCHIFNOT 58
- 53 GETGLOBAL End_of_file
- 55 MAKEBLOCK1 0
- 57 RAISE
- 58 ACC0
- 59 PUSHACC5
- 60 SUBINT
- 61 PUSHACC1
- 62 PUSHACC5
- 63 ADDINT
- 64 PUSHACC4
- 65 PUSHACC4
- 66 PUSHOFFSETCLOSURE0
- 67 APPTERM 4, 9
- 70 ACC0
- 71 C_CALL1 caml_input_scan_line
- 73 PUSHCONST0
- 74 PUSHACC1
- 75 EQ
- 76 BRANCHIFNOT 83
- 78 GETGLOBAL End_of_file
- 80 MAKEBLOCK1 0
- 82 RAISE
- 83 CONST0
- 84 PUSHACC1
- 85 GTINT
- 86 BRANCHIFNOT 107
- 88 ACC0
- 89 OFFSETINT -1
- 91 C_CALL1 create_string
- 93 PUSHACC1
- 94 OFFSETINT -1
- 96 PUSHCONST0
- 97 PUSHACC2
- 98 PUSHACC5
- 99 C_CALL4 caml_input
- 101 ACC2
- 102 C_CALL1 caml_input_char
- 104 ACC0
- 105 RETURN 3
- 107 ACC0
- 108 NEGINT
- 109 C_CALL1 create_string
- 111 PUSHACC1
- 112 NEGINT
- 113 PUSHCONST0
- 114 PUSHACC2
- 115 PUSHACC5
- 116 C_CALL4 caml_input
- 118 CONST0
- 119 PUSHTRAP 130
- 121 ACC6
- 122 PUSHOFFSETCLOSURE0
- 123 APPLY1
- 124 PUSHACC5
- 125 PUSHENVACC1
- 126 APPLY2
- 127 POPTRAP
- 128 RETURN 3
- 130 PUSHGETGLOBAL End_of_file
- 132 PUSHACC1
- 133 GETFIELD0
- 134 EQ
- 135 BRANCHIFNOT 140
- 137 ACC1
- 138 RETURN 4
- 140 ACC0
- 141 RAISE
- 142 ACC0
- 143 C_CALL1 caml_flush
- 145 RETURN 1
- 147 RESTART
- 148 GRAB 1
- 150 ACC1
- 151 PUSHACC1
- 152 C_CALL2 caml_output_char
- 154 RETURN 2
- 156 RESTART
- 157 GRAB 1
- 159 ACC1
- 160 PUSHACC1
- 161 C_CALL2 caml_output_char
- 163 RETURN 2
- 165 RESTART
- 166 GRAB 1
- 168 ACC1
- 169 PUSHACC1
- 170 C_CALL2 caml_output_int
- 172 RETURN 2
- 174 RESTART
- 175 GRAB 1
- 177 ACC1
- 178 PUSHACC1
- 179 C_CALL2 caml_seek_out
- 181 RETURN 2
- 183 ACC0
- 184 C_CALL1 caml_pos_out
- 186 RETURN 1
- 188 ACC0
- 189 C_CALL1 caml_channel_size
- 191 RETURN 1
- 193 RESTART
- 194 GRAB 1
- 196 ACC1
- 197 PUSHACC1
- 198 C_CALL2 caml_set_binary_mode
- 200 RETURN 2
- 202 ACC0
- 203 C_CALL1 caml_input_char
- 205 RETURN 1
- 207 ACC0
- 208 C_CALL1 caml_input_char
- 210 RETURN 1
- 212 ACC0
- 213 C_CALL1 caml_input_int
- 215 RETURN 1
- 217 ACC0
- 218 C_CALL1 input_value
- 220 RETURN 1
- 222 RESTART
- 223 GRAB 1
- 225 ACC1
- 226 PUSHACC1
- 227 C_CALL2 caml_seek_in
- 229 RETURN 2
- 231 ACC0
- 232 C_CALL1 caml_pos_in
- 234 RETURN 1
- 236 ACC0
- 237 C_CALL1 caml_channel_size
- 239 RETURN 1
- 241 ACC0
- 242 C_CALL1 caml_close_channel
- 244 RETURN 1
- 246 RESTART
- 247 GRAB 1
- 249 ACC1
- 250 PUSHACC1
- 251 C_CALL2 caml_set_binary_mode
- 253 RETURN 2
- 255 CONST0
- 256 PUSHENVACC1
- 257 APPLY1
- 258 ACC0
- 259 C_CALL1 sys_exit
- 261 RETURN 1
- 263 CONST0
- 264 PUSHENVACC1
- 265 GETFIELD0
- 266 APPTERM1 2
- 268 CONST0
- 269 PUSHENVACC1
- 270 APPLY1
- 271 CONST0
- 272 PUSHENVACC2
- 273 APPTERM1 2
- 275 ENVACC1
- 276 GETFIELD0
- 277 PUSHACC0
- 278 PUSHACC2
- 279 CLOSURE 2, 268
- 282 PUSHENVACC1
- 283 SETFIELD0
- 284 RETURN 2
- 286 ENVACC1
- 287 C_CALL1 caml_flush
- 289 ENVACC2
- 290 C_CALL1 caml_flush
- 292 RETURN 1
- 294 CONST0
- 295 PUSHENVACC1
- 296 APPLY1
- 297 C_CALL1 float_of_string
- 299 RETURN 1
- 301 CONST0
- 302 PUSHENVACC1
- 303 APPLY1
- 304 C_CALL1 int_of_string
- 306 RETURN 1
- 308 ENVACC2
- 309 C_CALL1 caml_flush
- 311 ENVACC1
- 312 PUSHENVACC3
- 313 APPTERM1 2
- 315 CONSTINT 13
- 317 PUSHENVACC1
- 318 C_CALL2 caml_output_char
- 320 ENVACC1
- 321 C_CALL1 caml_flush
- 323 RETURN 1
- 325 ACC0
- 326 PUSHENVACC1
- 327 PUSHENVACC2
- 328 APPLY2
- 329 CONSTINT 13
- 331 PUSHENVACC1
- 332 C_CALL2 caml_output_char
- 334 ENVACC1
- 335 C_CALL1 caml_flush
- 337 RETURN 1
- 339 ACC0
- 340 PUSHENVACC1
- 341 APPLY1
- 342 PUSHENVACC2
- 343 PUSHENVACC3
- 344 APPTERM2 3
- 346 ACC0
- 347 PUSHENVACC1
- 348 APPLY1
- 349 PUSHENVACC2
- 350 PUSHENVACC3
- 351 APPTERM2 3
- 353 ACC0
- 354 PUSHENVACC1
- 355 PUSHENVACC2
- 356 APPTERM2 3
- 358 ACC0
- 359 PUSHENVACC1
- 360 C_CALL2 caml_output_char
- 362 RETURN 1
- 364 CONSTINT 13
- 366 PUSHENVACC1
- 367 C_CALL2 caml_output_char
- 369 ENVACC1
- 370 C_CALL1 caml_flush
- 372 RETURN 1
- 374 ACC0
- 375 PUSHENVACC1
- 376 PUSHENVACC2
- 377 APPLY2
- 378 CONSTINT 13
- 380 PUSHENVACC1
- 381 C_CALL2 caml_output_char
- 383 RETURN 1
- 385 ACC0
- 386 PUSHENVACC1
- 387 APPLY1
- 388 PUSHENVACC2
- 389 PUSHENVACC3
- 390 APPTERM2 3
- 392 ACC0
- 393 PUSHENVACC1
- 394 APPLY1
- 395 PUSHENVACC2
- 396 PUSHENVACC3
- 397 APPTERM2 3
- 399 ACC0
- 400 PUSHENVACC1
- 401 PUSHENVACC2
- 402 APPTERM2 3
- 404 ACC0
- 405 PUSHENVACC1
- 406 C_CALL2 caml_output_char
- 408 RETURN 1
- 410 RESTART
- 411 GRAB 3
- 413 CONST0
- 414 PUSHACC3
- 415 LTINT
- 416 BRANCHIF 427
- 418 ACC1
- 419 C_CALL1 ml_string_length
- 421 PUSHACC4
- 422 PUSHACC4
- 423 ADDINT
- 424 GTINT
- 425 BRANCHIFNOT 432
- 427 GETGLOBAL "really_input"
- 429 PUSHENVACC1
- 430 APPTERM1 5
- 432 ACC3
- 433 PUSHACC3
- 434 PUSHACC3
- 435 PUSHACC3
- 436 PUSHENVACC2
- 437 APPTERM 4, 8
- 440 RESTART
- 441 GRAB 3
- 443 CONST0
- 444 PUSHACC3
- 445 LTINT
- 446 BRANCHIF 457
- 448 ACC1
- 449 C_CALL1 ml_string_length
- 451 PUSHACC4
- 452 PUSHACC4
- 453 ADDINT
- 454 GTINT
- 455 BRANCHIFNOT 462
- 457 GETGLOBAL "input"
- 459 PUSHENVACC1
- 460 APPTERM1 5
- 462 ACC3
- 463 PUSHACC3
- 464 PUSHACC3
- 465 PUSHACC3
- 466 C_CALL4 caml_input
- 468 RETURN 4
- 470 ACC0
- 471 PUSHCONST0
- 472 PUSHGETGLOBAL <0>(0, <0>(6, 0))
- 474 PUSHENVACC1
- 475 APPTERM3 4
- 477 ACC0
- 478 PUSHCONST0
- 479 PUSHGETGLOBAL <0>(0, <0>(7, 0))
- 481 PUSHENVACC1
- 482 APPTERM3 4
- 484 RESTART
- 485 GRAB 2
- 487 ACC1
- 488 PUSHACC1
- 489 PUSHACC4
- 490 C_CALL3 sys_open
- 492 C_CALL1 caml_open_descriptor
- 494 RETURN 3
- 496 ACC0
- 497 C_CALL1 caml_flush
- 499 ACC0
- 500 C_CALL1 caml_close_channel
- 502 RETURN 1
- 504 RESTART
- 505 GRAB 1
- 507 CONST0
- 508 PUSHACC2
- 509 PUSHACC2
- 510 C_CALL3 output_value
- 512 RETURN 2
- 514 RESTART
- 515 GRAB 3
- 517 CONST0
- 518 PUSHACC3
- 519 LTINT
- 520 BRANCHIF 531
- 522 ACC1
- 523 C_CALL1 ml_string_length
- 525 PUSHACC4
- 526 PUSHACC4
- 527 ADDINT
- 528 GTINT
- 529 BRANCHIFNOT 536
- 531 GETGLOBAL "output"
- 533 PUSHENVACC1
- 534 APPTERM1 5
- 536 ACC3
- 537 PUSHACC3
- 538 PUSHACC3
- 539 PUSHACC3
- 540 C_CALL4 caml_output
- 542 RETURN 4
- 544 RESTART
- 545 GRAB 1
- 547 ACC1
- 548 C_CALL1 ml_string_length
- 550 PUSHCONST0
- 551 PUSHACC3
- 552 PUSHACC3
- 553 C_CALL4 caml_output
- 555 RETURN 2
- 557 ACC0
- 558 PUSHCONSTINT 438
- 560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0))))
- 562 PUSHENVACC1
- 563 APPTERM3 4
- 565 ACC0
- 566 PUSHCONSTINT 438
- 568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0))))
- 570 PUSHENVACC1
- 571 APPTERM3 4
- 573 RESTART
- 574 GRAB 2
- 576 ACC1
- 577 PUSHACC1
- 578 PUSHACC4
- 579 C_CALL3 sys_open
- 581 C_CALL1 caml_open_descriptor
- 583 RETURN 3
- 585 ACC0
- 586 PUSHGETGLOBAL "%.12g"
- 588 C_CALL2 format_float
- 590 RETURN 1
- 592 ACC0
- 593 PUSHGETGLOBAL "%d"
- 595 C_CALL2 format_int
- 597 RETURN 1
- 599 GETGLOBAL "false"
- 601 PUSHACC1
- 602 C_CALL2 string_equal
- 604 BRANCHIFNOT 609
- 606 CONST0
- 607 RETURN 1
- 609 GETGLOBAL "true"
- 611 PUSHACC1
- 612 C_CALL2 string_equal
- 614 BRANCHIFNOT 619
- 616 CONST1
- 617 RETURN 1
- 619 GETGLOBAL "bool_of_string"
- 621 PUSHENVACC1
- 622 APPTERM1 2
- 624 ACC0
- 625 BRANCHIFNOT 631
- 627 GETGLOBAL "true"
- 629 RETURN 1
- 631 GETGLOBAL "false"
- 633 RETURN 1
- 635 CONST0
- 636 PUSHACC1
- 637 LTINT
- 638 BRANCHIF 646
- 640 CONSTINT 255
- 642 PUSHACC1
- 643 GTINT
- 644 BRANCHIFNOT 651
- 646 GETGLOBAL "char_of_int"
- 648 PUSHENVACC1
- 649 APPTERM1 2
- 651 ACC0
- 652 RETURN 1
- 654 RESTART
- 655 GRAB 1
- 657 ACC0
- 658 C_CALL1 ml_string_length
- 660 PUSHACC2
- 661 C_CALL1 ml_string_length
- 663 PUSHACC0
- 664 PUSHACC2
- 665 ADDINT
- 666 C_CALL1 create_string
- 668 PUSHACC2
- 669 PUSHCONST0
- 670 PUSHACC2
- 671 PUSHCONST0
- 672 PUSHACC7
- 673 C_CALL5 blit_string
- 675 ACC1
- 676 PUSHACC3
- 677 PUSHACC2
- 678 PUSHCONST0
- 679 PUSHACC 8
- 681 C_CALL5 blit_string
- 683 ACC0
- 684 RETURN 5
- 686 CONSTINT -1
- 688 PUSHACC1
- 689 XORINT
- 690 RETURN 1
- 692 CONST0
- 693 PUSHACC1
- 694 GEINT
- 695 BRANCHIFNOT 700
- 697 ACC0
- 698 RETURN 1
- 700 ACC0
- 701 NEGINT
- 702 RETURN 1
- 704 RESTART
- 705 GRAB 1
- 707 ACC1
- 708 PUSHACC1
- 709 C_CALL2 greaterequal
- 711 BRANCHIFNOT 716
- 713 ACC0
- 714 RETURN 2
- 716 ACC1
- 717 RETURN 2
- 719 RESTART
- 720 GRAB 1
- 722 ACC1
- 723 PUSHACC1
- 724 C_CALL2 lessequal
- 726 BRANCHIFNOT 731
- 728 ACC0
- 729 RETURN 2
- 731 ACC1
- 732 RETURN 2
- 734 ACC0
- 735 PUSHGETGLOBAL Invalid_argument
- 737 MAKEBLOCK2 0
- 739 RAISE
- 740 ACC0
- 741 PUSHGETGLOBAL Failure
- 743 MAKEBLOCK2 0
- 745 RAISE
- 746 CLOSURE 0, 740
- 749 PUSH
- 750 CLOSURE 0, 734
- 753 PUSHGETGLOBAL "Pervasives.Exit"
- 755 MAKEBLOCK1 0
- 757 PUSHGETGLOBAL "Pervasives.Assert_failure"
- 759 MAKEBLOCK1 0
- 761 PUSH
- 762 CLOSURE 0, 720
- 765 PUSH
- 766 CLOSURE 0, 705
- 769 PUSH
- 770 CLOSURE 0, 692
- 773 PUSH
- 774 CLOSURE 0, 686
- 777 PUSHCONST0
- 778 PUSHCONSTINT 31
- 780 PUSHCONST1
- 781 LSLINT
- 782 EQ
- 783 BRANCHIFNOT 789
- 785 CONSTINT 30
- 787 BRANCH 791
- 789 CONSTINT 62
- 791 PUSHCONST1
- 792 LSLINT
- 793 PUSHACC0
- 794 OFFSETINT -1
- 796 PUSH
- 797 CLOSURE 0, 655
- 800 PUSHACC 9
- 802 CLOSURE 1, 635
- 805 PUSH
- 806 CLOSURE 0, 624
- 809 PUSHACC 11
- 811 CLOSURE 1, 599
- 814 PUSH
- 815 CLOSURE 0, 592
- 818 PUSH
- 819 CLOSURE 0, 585
- 822 PUSH
- 823 CLOSUREREC 0, 12
- 827 CONST0
- 828 C_CALL1 caml_open_descriptor
- 830 PUSHCONST1
- 831 C_CALL1 caml_open_descriptor
- 833 PUSHCONST2
- 834 C_CALL1 caml_open_descriptor
- 836 PUSH
- 837 CLOSURE 0, 574
- 840 PUSHACC0
- 841 CLOSURE 1, 565
- 844 PUSHACC1
- 845 CLOSURE 1, 557
- 848 PUSH
- 849 CLOSURE 0, 545
- 852 PUSHACC 22
- 854 CLOSURE 1, 515
- 857 PUSH
- 858 CLOSURE 0, 505
- 861 PUSH
- 862 CLOSURE 0, 496
- 865 PUSH
- 866 CLOSURE 0, 485
- 869 PUSHACC0
- 870 CLOSURE 1, 477
- 873 PUSHACC1
- 874 CLOSURE 1, 470
- 877 PUSHACC 28
- 879 CLOSURE 1, 441
- 882 PUSH
- 883 CLOSUREREC 0, 32
- 887 ACC0
- 888 PUSHACC 31
- 890 CLOSURE 2, 411
- 893 PUSHACC 22
- 895 CLOSUREREC 1, 70
- 899 ACC 15
- 901 CLOSURE 1, 404
- 904 PUSHACC 11
- 906 PUSHACC 17
- 908 CLOSURE 2, 399
- 911 PUSHACC 12
- 913 PUSHACC 18
- 915 PUSHACC 23
- 917 CLOSURE 3, 392
- 920 PUSHACC 13
- 922 PUSHACC 19
- 924 PUSHACC 23
- 926 CLOSURE 3, 385
- 929 PUSHACC 14
- 931 PUSHACC 20
- 933 CLOSURE 2, 374
- 936 PUSHACC 20
- 938 CLOSURE 1, 364
- 941 PUSHACC 20
- 943 CLOSURE 1, 358
- 946 PUSHACC 17
- 948 PUSHACC 22
- 950 CLOSURE 2, 353
- 953 PUSHACC 18
- 955 PUSHACC 23
- 957 PUSHACC 29
- 959 CLOSURE 3, 346
- 962 PUSHACC 19
- 964 PUSHACC 24
- 966 PUSHACC 29
- 968 CLOSURE 3, 339
- 971 PUSHACC 20
- 973 PUSHACC 25
- 975 CLOSURE 2, 325
- 978 PUSHACC 25
- 980 CLOSURE 1, 315
- 983 PUSHACC 12
- 985 PUSHACC 28
- 987 PUSHACC 30
- 989 CLOSURE 3, 308
- 992 PUSHACC0
- 993 CLOSURE 1, 301
- 996 PUSHACC1
- 997 CLOSURE 1, 294
- 1000 PUSHACC 29
- 1002 PUSHACC 31
- 1004 CLOSURE 2, 286
- 1007 MAKEBLOCK1 0
- 1009 PUSHACC0
- 1010 CLOSURE 1, 275
- 1013 PUSHACC1
- 1014 CLOSURE 1, 263
- 1017 PUSHACC0
- 1018 CLOSURE 1, 255
- 1021 PUSHACC1
- 1022 PUSHACC 22
- 1024 PUSHACC4
- 1025 PUSHACC3
- 1026 PUSH
- 1027 CLOSURE 0, 247
- 1030 PUSH
- 1031 CLOSURE 0, 241
- 1034 PUSH
- 1035 CLOSURE 0, 236
- 1038 PUSH
- 1039 CLOSURE 0, 231
- 1042 PUSH
- 1043 CLOSURE 0, 223
- 1046 PUSH
- 1047 CLOSURE 0, 217
- 1050 PUSH
- 1051 CLOSURE 0, 212
- 1054 PUSH
- 1055 CLOSURE 0, 207
- 1058 PUSHACC 32
- 1060 PUSHACC 35
- 1062 PUSHACC 33
- 1064 PUSH
- 1065 CLOSURE 0, 202
- 1068 PUSHACC 41
- 1070 PUSHACC 40
- 1072 PUSHACC 42
- 1074 PUSH
- 1075 CLOSURE 0, 194
- 1078 PUSHACC 46
- 1080 PUSH
- 1081 CLOSURE 0, 188
- 1084 PUSH
- 1085 CLOSURE 0, 183
- 1088 PUSH
- 1089 CLOSURE 0, 175
- 1092 PUSHACC 51
- 1094 PUSH
- 1095 CLOSURE 0, 166
- 1098 PUSH
- 1099 CLOSURE 0, 157
- 1102 PUSHACC 55
- 1104 PUSHACC 57
- 1106 PUSH
- 1107 CLOSURE 0, 148
- 1110 PUSH
- 1111 CLOSURE 0, 142
- 1114 PUSHACC 63
- 1116 PUSHACC 62
- 1118 PUSHACC 64
- 1120 PUSHACC 38
- 1122 PUSHACC 40
- 1124 PUSHACC 42
- 1126 PUSHACC 44
- 1128 PUSHACC 46
- 1130 PUSHACC 48
- 1132 PUSHACC 50
- 1134 PUSHACC 52
- 1136 PUSHACC 54
- 1138 PUSHACC 56
- 1140 PUSHACC 58
- 1142 PUSHACC 60
- 1144 PUSHACC 62
- 1146 PUSHACC 64
- 1148 PUSHACC 66
- 1150 PUSHACC 82
- 1152 PUSHACC 84
- 1154 PUSHACC 86
- 1156 PUSHACC 88
- 1158 PUSHACC 90
- 1160 PUSHACC 92
- 1162 PUSHACC 94
- 1164 PUSHACC 96
- 1166 PUSHACC 98
- 1168 PUSHACC 100
- 1170 PUSHACC 104
- 1172 PUSHACC 104
- 1174 PUSHACC 104
- 1176 PUSHACC 108
- 1178 PUSHACC 110
- 1180 PUSHACC 112
- 1182 PUSHACC 117
- 1184 PUSHACC 117
- 1186 PUSHACC 117
- 1188 PUSHACC 117
- 1190 MAKEBLOCK 69, 0
- 1193 POP 53
- 1195 SETGLOBAL Pervasives
- 1197 BRANCH 2177
- 1199 RESTART
- 1200 GRAB 1
- 1202 ACC1
- 1203 BRANCHIFNOT 1213
- 1205 ACC1
- 1206 GETFIELD1
- 1207 PUSHACC1
- 1208 OFFSETINT 1
- 1210 PUSHOFFSETCLOSURE0
- 1211 APPTERM2 4
- 1213 ACC0
- 1214 RETURN 2
- 1216 RESTART
- 1217 GRAB 1
- 1219 ACC0
- 1220 BRANCHIFNOT 1251
- 1222 CONST0
- 1223 PUSHACC2
- 1224 EQ
- 1225 BRANCHIFNOT 1231
- 1227 ACC0
- 1228 GETFIELD0
- 1229 RETURN 2
- 1231 CONST0
- 1232 PUSHACC2
- 1233 GTINT
- 1234 BRANCHIFNOT 1244
- 1236 ACC1
- 1237 OFFSETINT -1
- 1239 PUSHACC1
- 1240 GETFIELD1
- 1241 PUSHOFFSETCLOSURE0
- 1242 APPTERM2 4
- 1244 GETGLOBAL "List.nth"
- 1246 PUSHGETGLOBALFIELD Pervasives, 2
- 1249 APPTERM1 3
- 1251 GETGLOBAL "nth"
- 1253 PUSHGETGLOBALFIELD Pervasives, 3
- 1256 APPTERM1 3
- 1258 RESTART
- 1259 GRAB 1
- 1261 ACC0
- 1262 BRANCHIFNOT 1274
- 1264 ACC1
- 1265 PUSHACC1
- 1266 GETFIELD0
- 1267 MAKEBLOCK2 0
- 1269 PUSHACC1
- 1270 GETFIELD1
- 1271 PUSHOFFSETCLOSURE0
- 1272 APPTERM2 4
- 1274 ACC1
- 1275 RETURN 2
- 1277 ACC0
- 1278 BRANCHIFNOT 1291
- 1280 ACC0
- 1281 GETFIELD1
- 1282 PUSHOFFSETCLOSURE0
- 1283 APPLY1
- 1284 PUSHACC1
- 1285 GETFIELD0
- 1286 PUSHGETGLOBALFIELD Pervasives, 16
- 1289 APPTERM2 3
- 1291 RETURN 1
- 1293 RESTART
- 1294 GRAB 1
- 1296 ACC1
- 1297 BRANCHIFNOT 1313
- 1299 ACC1
- 1300 GETFIELD0
- 1301 PUSHACC1
- 1302 APPLY1
- 1303 PUSHACC2
- 1304 GETFIELD1
- 1305 PUSHACC2
- 1306 PUSHOFFSETCLOSURE0
- 1307 APPLY2
- 1308 PUSHACC1
- 1309 MAKEBLOCK2 0
- 1311 POP 1
- 1313 RETURN 2
- 1315 RESTART
- 1316 GRAB 1
- 1318 ACC1
- 1319 BRANCHIFNOT 1331
- 1321 ACC1
- 1322 GETFIELD0
- 1323 PUSHACC1
- 1324 APPLY1
- 1325 ACC1
- 1326 GETFIELD1
- 1327 PUSHACC1
- 1328 PUSHOFFSETCLOSURE0
- 1329 APPTERM2 4
- 1331 RETURN 2
- 1333 RESTART
- 1334 GRAB 2
- 1336 ACC2
- 1337 BRANCHIFNOT 1350
- 1339 ACC2
- 1340 GETFIELD1
- 1341 PUSHACC3
- 1342 GETFIELD0
- 1343 PUSHACC3
- 1344 PUSHACC3
- 1345 APPLY2
- 1346 PUSHACC2
- 1347 PUSHOFFSETCLOSURE0
- 1348 APPTERM3 6
- 1350 ACC1
- 1351 RETURN 3
- 1353 RESTART
- 1354 GRAB 2
- 1356 ACC1
- 1357 BRANCHIFNOT 1370
- 1359 ACC2
- 1360 PUSHACC2
- 1361 GETFIELD1
- 1362 PUSHACC2
- 1363 PUSHOFFSETCLOSURE0
- 1364 APPLY3
- 1365 PUSHACC2
- 1366 GETFIELD0
- 1367 PUSHACC2
- 1368 APPTERM2 5
- 1370 ACC2
- 1371 RETURN 3
- 1373 RESTART
- 1374 GRAB 2
- 1376 ACC1
- 1377 BRANCHIFNOT 1400
- 1379 ACC2
- 1380 BRANCHIFNOT 1407
- 1382 ACC2
- 1383 GETFIELD0
- 1384 PUSHACC2
- 1385 GETFIELD0
- 1386 PUSHACC2
- 1387 APPLY2
- 1388 PUSHACC3
- 1389 GETFIELD1
- 1390 PUSHACC3
- 1391 GETFIELD1
- 1392 PUSHACC3
- 1393 PUSHOFFSETCLOSURE0
- 1394 APPLY3
- 1395 PUSHACC1
- 1396 MAKEBLOCK2 0
- 1398 RETURN 4
- 1400 ACC2
- 1401 BRANCHIFNOT 1405
- 1403 BRANCH 1407
- 1405 RETURN 3
- 1407 GETGLOBAL "List.map2"
- 1409 PUSHGETGLOBALFIELD Pervasives, 2
- 1412 APPTERM1 4
- 1414 RESTART
- 1415 GRAB 2
- 1417 ACC1
- 1418 BRANCHIFNOT 1437
- 1420 ACC2
- 1421 BRANCHIFNOT 1444
- 1423 ACC2
- 1424 GETFIELD0
- 1425 PUSHACC2
- 1426 GETFIELD0
- 1427 PUSHACC2
- 1428 APPLY2
- 1429 ACC2
- 1430 GETFIELD1
- 1431 PUSHACC2
- 1432 GETFIELD1
- 1433 PUSHACC2
- 1434 PUSHOFFSETCLOSURE0
- 1435 APPTERM3 6
- 1437 ACC2
- 1438 BRANCHIFNOT 1442
- 1440 BRANCH 1444
- 1442 RETURN 3
- 1444 GETGLOBAL "List.iter2"
- 1446 PUSHGETGLOBALFIELD Pervasives, 2
- 1449 APPTERM1 4
- 1451 RESTART
- 1452 GRAB 3
- 1454 ACC2
- 1455 BRANCHIFNOT 1476
- 1457 ACC3
- 1458 BRANCHIFNOT 1482
- 1460 ACC3
- 1461 GETFIELD1
- 1462 PUSHACC3
- 1463 GETFIELD1
- 1464 PUSHACC5
- 1465 GETFIELD0
- 1466 PUSHACC5
- 1467 GETFIELD0
- 1468 PUSHACC5
- 1469 PUSHACC5
- 1470 APPLY3
- 1471 PUSHACC3
- 1472 PUSHOFFSETCLOSURE0
- 1473 APPTERM 4, 8
- 1476 ACC3
- 1477 BRANCHIF 1482
- 1479 ACC1
- 1480 RETURN 4
- 1482 GETGLOBAL "List.fold_left2"
- 1484 PUSHGETGLOBALFIELD Pervasives, 2
- 1487 APPTERM1 5
- 1489 RESTART
- 1490 GRAB 3
- 1492 ACC1
- 1493 BRANCHIFNOT 1516
- 1495 ACC2
- 1496 BRANCHIFNOT 1522
- 1498 PUSH_RETADDR 1509
- 1500 ACC6
- 1501 PUSHACC6
- 1502 GETFIELD1
- 1503 PUSHACC6
- 1504 GETFIELD1
- 1505 PUSHACC6
- 1506 PUSHOFFSETCLOSURE0
- 1507 APPLY 4
- 1509 PUSHACC3
- 1510 GETFIELD0
- 1511 PUSHACC3
- 1512 GETFIELD0
- 1513 PUSHACC3
- 1514 APPTERM3 7
- 1516 ACC2
- 1517 BRANCHIF 1522
- 1519 ACC3
- 1520 RETURN 4
- 1522 GETGLOBAL "List.fold_right2"
- 1524 PUSHGETGLOBALFIELD Pervasives, 2
- 1527 APPTERM1 5
- 1529 RESTART
- 1530 GRAB 1
- 1532 ACC1
- 1533 BRANCHIFNOT 1549
- 1535 ACC1
- 1536 GETFIELD0
- 1537 PUSHACC1
- 1538 APPLY1
- 1539 BRANCHIFNOT 1547
- 1541 ACC1
- 1542 GETFIELD1
- 1543 PUSHACC1
- 1544 PUSHOFFSETCLOSURE0
- 1545 APPTERM2 4
- 1547 RETURN 2
- 1549 CONST1
- 1550 RETURN 2
- 1552 RESTART
- 1553 GRAB 1
- 1555 ACC1
- 1556 BRANCHIFNOT 1570
- 1558 ACC1
- 1559 GETFIELD0
- 1560 PUSHACC1
- 1561 APPLY1
- 1562 BRANCHIF 1570
- 1564 ACC1
- 1565 GETFIELD1
- 1566 PUSHACC1
- 1567 PUSHOFFSETCLOSURE0
- 1568 APPTERM2 4
- 1570 RETURN 2
- 1572 RESTART
- 1573 GRAB 2
- 1575 ACC1
- 1576 BRANCHIFNOT 1599
- 1578 ACC2
- 1579 BRANCHIFNOT 1605
- 1581 ACC2
- 1582 GETFIELD0
- 1583 PUSHACC2
- 1584 GETFIELD0
- 1585 PUSHACC2
- 1586 APPLY2
- 1587 BRANCHIFNOT 1597
- 1589 ACC2
- 1590 GETFIELD1
- 1591 PUSHACC2
- 1592 GETFIELD1
- 1593 PUSHACC2
- 1594 PUSHOFFSETCLOSURE0
- 1595 APPTERM3 6
- 1597 RETURN 3
- 1599 ACC2
- 1600 BRANCHIF 1605
- 1602 CONST1
- 1603 RETURN 3
- 1605 GETGLOBAL "List.for_all2"
- 1607 PUSHGETGLOBALFIELD Pervasives, 2
- 1610 APPTERM1 4
- 1612 RESTART
- 1613 GRAB 2
- 1615 ACC1
- 1616 BRANCHIFNOT 1639
- 1618 ACC2
- 1619 BRANCHIFNOT 1646
- 1621 ACC2
- 1622 GETFIELD0
- 1623 PUSHACC2
- 1624 GETFIELD0
- 1625 PUSHACC2
- 1626 APPLY2
- 1627 BRANCHIF 1637
- 1629 ACC2
- 1630 GETFIELD1
- 1631 PUSHACC2
- 1632 GETFIELD1
- 1633 PUSHACC2
- 1634 PUSHOFFSETCLOSURE0
- 1635 APPTERM3 6
- 1637 RETURN 3
- 1639 ACC2
- 1640 BRANCHIFNOT 1644
- 1642 BRANCH 1646
- 1644 RETURN 3
- 1646 GETGLOBAL "List.exists2"
- 1648 PUSHGETGLOBALFIELD Pervasives, 2
- 1651 APPTERM1 4
- 1653 RESTART
- 1654 GRAB 1
- 1656 ACC1
- 1657 BRANCHIFNOT 1672
- 1659 ACC0
- 1660 PUSHACC2
- 1661 GETFIELD0
- 1662 C_CALL2 equal
- 1664 BRANCHIF 1672
- 1666 ACC1
- 1667 GETFIELD1
- 1668 PUSHACC1
- 1669 PUSHOFFSETCLOSURE0
- 1670 APPTERM2 4
- 1672 RETURN 2
- 1674 RESTART
- 1675 GRAB 1
- 1677 ACC1
- 1678 BRANCHIFNOT 1692
- 1680 ACC0
- 1681 PUSHACC2
- 1682 GETFIELD0
- 1683 EQ
- 1684 BRANCHIF 1692
- 1686 ACC1
- 1687 GETFIELD1
- 1688 PUSHACC1
- 1689 PUSHOFFSETCLOSURE0
- 1690 APPTERM2 4
- 1692 RETURN 2
- 1694 RESTART
- 1695 GRAB 1
- 1697 ACC1
- 1698 BRANCHIFNOT 1719
- 1700 ACC1
- 1701 GETFIELD0
- 1702 PUSHACC1
- 1703 PUSHACC1
- 1704 GETFIELD0
- 1705 C_CALL2 equal
- 1707 BRANCHIFNOT 1713
- 1709 ACC0
- 1710 GETFIELD1
- 1711 RETURN 3
- 1713 ACC2
- 1714 GETFIELD1
- 1715 PUSHACC2
- 1716 PUSHOFFSETCLOSURE0
- 1717 APPTERM2 5
- 1719 GETGLOBAL Not_found
- 1721 MAKEBLOCK1 0
- 1723 RAISE
- 1724 RESTART
- 1725 GRAB 1
- 1727 ACC1
- 1728 BRANCHIFNOT 1748
- 1730 ACC1
- 1731 GETFIELD0
- 1732 PUSHACC1
- 1733 PUSHACC1
- 1734 GETFIELD0
- 1735 EQ
- 1736 BRANCHIFNOT 1742
- 1738 ACC0
- 1739 GETFIELD1
- 1740 RETURN 3
- 1742 ACC2
- 1743 GETFIELD1
- 1744 PUSHACC2
- 1745 PUSHOFFSETCLOSURE0
- 1746 APPTERM2 5
- 1748 GETGLOBAL Not_found
- 1750 MAKEBLOCK1 0
- 1752 RAISE
- 1753 RESTART
- 1754 GRAB 1
- 1756 ACC1
- 1757 BRANCHIFNOT 1773
- 1759 ACC0
- 1760 PUSHACC2
- 1761 GETFIELD0
- 1762 GETFIELD0
- 1763 C_CALL2 equal
- 1765 BRANCHIF 1773
- 1767 ACC1
- 1768 GETFIELD1
- 1769 PUSHACC1
- 1770 PUSHOFFSETCLOSURE0
- 1771 APPTERM2 4
- 1773 RETURN 2
- 1775 RESTART
- 1776 GRAB 1
- 1778 ACC1
- 1779 BRANCHIFNOT 1794
- 1781 ACC0
- 1782 PUSHACC2
- 1783 GETFIELD0
- 1784 GETFIELD0
- 1785 EQ
- 1786 BRANCHIF 1794
- 1788 ACC1
- 1789 GETFIELD1
- 1790 PUSHACC1
- 1791 PUSHOFFSETCLOSURE0
- 1792 APPTERM2 4
- 1794 RETURN 2
- 1796 RESTART
- 1797 GRAB 1
- 1799 ACC1
- 1800 BRANCHIFNOT 1825
- 1802 ACC1
- 1803 GETFIELD0
- 1804 PUSHACC2
- 1805 GETFIELD1
- 1806 PUSHACC2
- 1807 PUSHACC2
- 1808 GETFIELD0
- 1809 C_CALL2 equal
- 1811 BRANCHIFNOT 1816
- 1813 ACC0
- 1814 RETURN 4
- 1816 ACC0
- 1817 PUSHACC3
- 1818 PUSHOFFSETCLOSURE0
- 1819 APPLY2
- 1820 PUSHACC2
- 1821 MAKEBLOCK2 0
- 1823 POP 2
- 1825 RETURN 2
- 1827 RESTART
- 1828 GRAB 1
- 1830 ACC1
- 1831 BRANCHIFNOT 1855
- 1833 ACC1
- 1834 GETFIELD0
- 1835 PUSHACC2
- 1836 GETFIELD1
- 1837 PUSHACC2
- 1838 PUSHACC2
- 1839 GETFIELD0
- 1840 EQ
- 1841 BRANCHIFNOT 1846
- 1843 ACC0
- 1844 RETURN 4
- 1846 ACC0
- 1847 PUSHACC3
- 1848 PUSHOFFSETCLOSURE0
- 1849 APPLY2
- 1850 PUSHACC2
- 1851 MAKEBLOCK2 0
- 1853 POP 2
- 1855 RETURN 2
- 1857 RESTART
- 1858 GRAB 1
- 1860 ACC1
- 1861 BRANCHIFNOT 1879
- 1863 ACC1
- 1864 GETFIELD0
- 1865 PUSHACC0
- 1866 PUSHACC2
- 1867 APPLY1
- 1868 BRANCHIFNOT 1873
- 1870 ACC0
- 1871 RETURN 3
- 1873 ACC2
- 1874 GETFIELD1
- 1875 PUSHACC2
- 1876 PUSHOFFSETCLOSURE0
- 1877 APPTERM2 5
- 1879 GETGLOBAL Not_found
- 1881 MAKEBLOCK1 0
- 1883 RAISE
- 1884 RESTART
- 1885 GRAB 2
- 1887 ACC2
- 1888 BRANCHIFNOT 1917
- 1890 ACC2
- 1891 GETFIELD0
- 1892 PUSHACC3
- 1893 GETFIELD1
- 1894 PUSHACC1
- 1895 PUSHENVACC2
- 1896 APPLY1
- 1897 BRANCHIFNOT 1908
- 1899 ACC0
- 1900 PUSHACC4
- 1901 PUSHACC4
- 1902 PUSHACC4
- 1903 MAKEBLOCK2 0
- 1905 PUSHOFFSETCLOSURE0
- 1906 APPTERM3 8
- 1908 ACC0
- 1909 PUSHACC4
- 1910 PUSHACC3
- 1911 MAKEBLOCK2 0
- 1913 PUSHACC4
- 1914 PUSHOFFSETCLOSURE0
- 1915 APPTERM3 8
- 1917 ACC1
- 1918 PUSHENVACC1
- 1919 APPLY1
- 1920 PUSHACC1
- 1921 PUSHENVACC1
- 1922 APPLY1
- 1923 MAKEBLOCK2 0
- 1925 RETURN 3
- 1927 RESTART
- 1928 GRAB 1
- 1930 ACC0
- 1931 PUSHENVACC1
- 1932 CLOSUREREC 2, 1885
- 1936 ACC2
- 1937 PUSHCONST0
- 1938 PUSHCONST0
- 1939 PUSHACC3
- 1940 APPTERM3 6
- 1942 ACC0
- 1943 BRANCHIFNOT 1967
- 1945 ACC0
- 1946 GETFIELD0
- 1947 PUSHACC1
- 1948 GETFIELD1
- 1949 PUSHOFFSETCLOSURE0
- 1950 APPLY1
- 1951 PUSHACC0
- 1952 GETFIELD1
- 1953 PUSHACC2
- 1954 GETFIELD1
- 1955 MAKEBLOCK2 0
- 1957 PUSHACC1
- 1958 GETFIELD0
- 1959 PUSHACC3
- 1960 GETFIELD0
- 1961 MAKEBLOCK2 0
- 1963 MAKEBLOCK2 0
- 1965 RETURN 3
- 1967 GETGLOBAL <0>(0, 0)
- 1969 RETURN 1
- 1971 RESTART
- 1972 GRAB 1
- 1974 ACC0
- 1975 BRANCHIFNOT 1996
- 1977 ACC1
- 1978 BRANCHIFNOT 2003
- 1980 ACC1
- 1981 GETFIELD1
- 1982 PUSHACC1
- 1983 GETFIELD1
- 1984 PUSHOFFSETCLOSURE0
- 1985 APPLY2
- 1986 PUSHACC2
- 1987 GETFIELD0
- 1988 PUSHACC2
- 1989 GETFIELD0
- 1990 MAKEBLOCK2 0
- 1992 MAKEBLOCK2 0
- 1994 RETURN 2
- 1996 ACC1
- 1997 BRANCHIFNOT 2001
- 1999 BRANCH 2003
- 2001 RETURN 2
- 2003 GETGLOBAL "List.combine"
- 2005 PUSHGETGLOBALFIELD Pervasives, 2
- 2008 APPTERM1 3
- 2010 RESTART
- 2011 GRAB 1
- 2013 ACC1
- 2014 BRANCHIFNOT 2038
- 2016 ACC1
- 2017 GETFIELD0
- 2018 PUSHACC2
- 2019 GETFIELD1
- 2020 PUSHACC1
- 2021 PUSHENVACC2
- 2022 APPLY1
- 2023 BRANCHIFNOT 2033
- 2025 ACC0
- 2026 PUSHACC3
- 2027 PUSHACC3
- 2028 MAKEBLOCK2 0
- 2030 PUSHOFFSETCLOSURE0
- 2031 APPTERM2 6
- 2033 ACC0
- 2034 PUSHACC3
- 2035 PUSHOFFSETCLOSURE0
- 2036 APPTERM2 6
- 2038 ACC0
- 2039 PUSHENVACC1
- 2040 APPTERM1 3
- 2042 ACC0
- 2043 PUSHENVACC1
- 2044 CLOSUREREC 2, 2011
- 2048 CONST0
- 2049 PUSHACC1
- 2050 APPTERM1 3
- 2052 RESTART
- 2053 GRAB 2
- 2055 ACC1
- 2056 BRANCHIFNOT 2077
- 2058 ACC2
- 2059 BRANCHIFNOT 2084
- 2061 ACC2
- 2062 GETFIELD1
- 2063 PUSHACC2
- 2064 GETFIELD1
- 2065 PUSHACC2
- 2066 PUSHACC5
- 2067 GETFIELD0
- 2068 PUSHACC5
- 2069 GETFIELD0
- 2070 PUSHENVACC1
- 2071 APPLY2
- 2072 MAKEBLOCK2 0
- 2074 PUSHOFFSETCLOSURE0
- 2075 APPTERM3 6
- 2077 ACC2
- 2078 BRANCHIFNOT 2082
- 2080 BRANCH 2084
- 2082 RETURN 3
- 2084 GETGLOBAL "List.rev_map2"
- 2086 PUSHGETGLOBALFIELD Pervasives, 2
- 2089 APPTERM1 4
- 2091 RESTART
- 2092 GRAB 2
- 2094 ACC0
- 2095 CLOSUREREC 1, 2053
- 2099 ACC3
- 2100 PUSHACC3
- 2101 PUSHCONST0
- 2102 PUSHACC3
- 2103 APPTERM3 7
- 2105 RESTART
- 2106 GRAB 1
- 2108 ACC1
- 2109 BRANCHIFNOT 2123
- 2111 ACC1
- 2112 GETFIELD1
- 2113 PUSHACC1
- 2114 PUSHACC3
- 2115 GETFIELD0
- 2116 PUSHENVACC1
- 2117 APPLY1
- 2118 MAKEBLOCK2 0
- 2120 PUSHOFFSETCLOSURE0
- 2121 APPTERM2 4
- 2123 ACC0
- 2124 RETURN 2
- 2126 RESTART
- 2127 GRAB 1
- 2129 ACC0
- 2130 CLOSUREREC 1, 2106
- 2134 ACC2
- 2135 PUSHCONST0
- 2136 PUSHACC2
- 2137 APPTERM2 5
- 2139 CONST0
- 2140 PUSHACC1
- 2141 PUSHENVACC1
- 2142 APPTERM2 3
- 2144 ACC0
- 2145 BRANCHIFNOT 2151
- 2147 ACC0
- 2148 GETFIELD1
- 2149 RETURN 1
- 2151 GETGLOBAL "tl"
- 2153 PUSHGETGLOBALFIELD Pervasives, 3
- 2156 APPTERM1 2
- 2158 ACC0
- 2159 BRANCHIFNOT 2165
- 2161 ACC0
- 2162 GETFIELD0
- 2163 RETURN 1
- 2165 GETGLOBAL "hd"
- 2167 PUSHGETGLOBALFIELD Pervasives, 3
- 2170 APPTERM1 2
- 2172 ACC0
- 2173 PUSHCONST0
- 2174 PUSHENVACC1
- 2175 APPTERM2 3
- 2177 CLOSUREREC 0, 1200
- 2181 ACC0
- 2182 CLOSURE 1, 2172
- 2185 PUSH
- 2186 CLOSURE 0, 2158
- 2189 PUSH
- 2190 CLOSURE 0, 2144
- 2193 PUSH
- 2194 CLOSUREREC 0, 1217
- 2198 GETGLOBALFIELD Pervasives, 16
- 2201 PUSH
- 2202 CLOSUREREC 0, 1259
- 2206 ACC0
- 2207 CLOSURE 1, 2139
- 2210 PUSH
- 2211 CLOSUREREC 0, 1277
- 2215 CLOSUREREC 0, 1294
- 2219 CLOSURE 0, 2127
- 2222 PUSH
- 2223 CLOSUREREC 0, 1316
- 2227 CLOSUREREC 0, 1334
- 2231 CLOSUREREC 0, 1354
- 2235 CLOSUREREC 0, 1374
- 2239 CLOSURE 0, 2092
- 2242 PUSH
- 2243 CLOSUREREC 0, 1415
- 2247 CLOSUREREC 0, 1452
- 2251 CLOSUREREC 0, 1490
- 2255 CLOSUREREC 0, 1530
- 2259 CLOSUREREC 0, 1553
- 2263 CLOSUREREC 0, 1573
- 2267 CLOSUREREC 0, 1613
- 2271 CLOSUREREC 0, 1654
- 2275 CLOSUREREC 0, 1675
- 2279 CLOSUREREC 0, 1695
- 2283 CLOSUREREC 0, 1725
- 2287 CLOSUREREC 0, 1754
- 2291 CLOSUREREC 0, 1776
- 2295 CLOSUREREC 0, 1797
- 2299 CLOSUREREC 0, 1828
- 2303 CLOSUREREC 0, 1858
- 2307 ACC 24
- 2309 CLOSURE 1, 2042
- 2312 PUSHACC 25
- 2314 CLOSUREREC 1, 1928
- 2318 CLOSUREREC 0, 1942
- 2322 CLOSUREREC 0, 1972
- 2326 ACC0
- 2327 PUSHACC2
- 2328 PUSHACC7
- 2329 PUSHACC 9
- 2331 PUSHACC 11
- 2333 PUSHACC 13
- 2335 PUSHACC 15
- 2337 PUSHACC 17
- 2339 PUSHACC 10
- 2341 PUSHACC 12
- 2343 PUSHACC 13
- 2345 PUSHACC 15
- 2347 PUSHACC 23
- 2349 PUSHACC 25
- 2351 PUSHACC 27
- 2353 PUSHACC 29
- 2355 PUSHACC 31
- 2357 PUSHACC 33
- 2359 PUSHACC 35
- 2361 PUSHACC 37
- 2363 PUSHACC 40
- 2365 PUSHACC 42
- 2367 PUSHACC 41
- 2369 PUSHACC 45
- 2371 PUSHACC 47
- 2373 PUSHACC 50
- 2375 PUSHACC 52
- 2377 PUSHACC 51
- 2379 PUSHACC 55
- 2381 PUSHACC 56
- 2383 PUSHACC 59
- 2385 PUSHACC 61
- 2387 PUSHACC 60
- 2389 PUSHACC 64
- 2391 PUSHACC 66
- 2393 PUSHACC 68
- 2395 PUSHACC 70
- 2397 MAKEBLOCK 37, 0
- 2400 POP 36
- 2402 SETGLOBAL List
- 2404 BRANCH 2435
- 2406 RESTART
- 2407 GRAB 1
- 2409 CONST0
- 2410 PUSHACC2
- 2411 LEINT
- 2412 BRANCHIFNOT 2417
- 2414 ACC0
- 2415 RETURN 2
- 2417 ACC1
- 2418 OFFSETINT -1
- 2420 PUSHACC1
- 2421 PUSHCONST1
- 2422 MAKEBLOCK2 0
- 2424 PUSHOFFSETCLOSURE0
- 2425 APPTERM2 4
- 2427 RESTART
- 2428 GRAB 1
- 2430 ACC1
- 2431 PUSHACC1
- 2432 ADDINT
- 2433 RETURN 2
- 2435 CLOSUREREC 0, 2407
- 2439 CONSTINT 30000
- 2441 PUSHCONST0
- 2442 PUSHACC2
- 2443 APPLY2
- 2444 PUSHCONSTINT 30000
- 2446 PUSHACC1
- 2447 PUSHCONST0
- 2448 PUSH
- 2449 CLOSURE 0, 2428
- 2452 PUSHGETGLOBALFIELD List, 12
- 2455 APPLY3
- 2456 NEQ
- 2457 BRANCHIFNOT 2464
- 2459 GETGLOBAL Not_found
- 2461 MAKEBLOCK1 0
- 2463 RAISE
- 2464 POP 2
- 2466 ATOM0
- 2467 SETGLOBAL T310-alloc-1
- 2469 STOP
-**)
diff --git a/test/testinterp/t310-alloc-2.ml b/test/testinterp/t310-alloc-2.ml
deleted file mode 100644
index 81034e78ab..0000000000
--- a/test/testinterp/t310-alloc-2.ml
+++ /dev/null
@@ -1,2313 +0,0 @@
-open Lib;;
-let v = Array.make 200000 2 in
-let t = ref 0 in
-Array.iter (fun x -> t := !t + x) v;
-if !t <> 400000 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 746
- 11 RESTART
- 12 GRAB 1
- 14 ACC0
- 15 BRANCHIFNOT 28
- 17 ACC1
- 18 PUSHACC1
- 19 GETFIELD1
- 20 PUSHOFFSETCLOSURE0
- 21 APPLY2
- 22 PUSHACC1
- 23 GETFIELD0
- 24 MAKEBLOCK2 0
- 26 RETURN 2
- 28 ACC1
- 29 RETURN 2
- 31 RESTART
- 32 GRAB 3
- 34 CONST0
- 35 PUSHACC4
- 36 LEINT
- 37 BRANCHIFNOT 42
- 39 CONST0
- 40 RETURN 4
- 42 ACC3
- 43 PUSHACC3
- 44 PUSHACC3
- 45 PUSHACC3
- 46 C_CALL4 caml_input
- 48 PUSHCONST0
- 49 PUSHACC1
- 50 EQ
- 51 BRANCHIFNOT 58
- 53 GETGLOBAL End_of_file
- 55 MAKEBLOCK1 0
- 57 RAISE
- 58 ACC0
- 59 PUSHACC5
- 60 SUBINT
- 61 PUSHACC1
- 62 PUSHACC5
- 63 ADDINT
- 64 PUSHACC4
- 65 PUSHACC4
- 66 PUSHOFFSETCLOSURE0
- 67 APPTERM 4, 9
- 70 ACC0
- 71 C_CALL1 caml_input_scan_line
- 73 PUSHCONST0
- 74 PUSHACC1
- 75 EQ
- 76 BRANCHIFNOT 83
- 78 GETGLOBAL End_of_file
- 80 MAKEBLOCK1 0
- 82 RAISE
- 83 CONST0
- 84 PUSHACC1
- 85 GTINT
- 86 BRANCHIFNOT 107
- 88 ACC0
- 89 OFFSETINT -1
- 91 C_CALL1 create_string
- 93 PUSHACC1
- 94 OFFSETINT -1
- 96 PUSHCONST0
- 97 PUSHACC2
- 98 PUSHACC5
- 99 C_CALL4 caml_input
- 101 ACC2
- 102 C_CALL1 caml_input_char
- 104 ACC0
- 105 RETURN 3
- 107 ACC0
- 108 NEGINT
- 109 C_CALL1 create_string
- 111 PUSHACC1
- 112 NEGINT
- 113 PUSHCONST0
- 114 PUSHACC2
- 115 PUSHACC5
- 116 C_CALL4 caml_input
- 118 CONST0
- 119 PUSHTRAP 130
- 121 ACC6
- 122 PUSHOFFSETCLOSURE0
- 123 APPLY1
- 124 PUSHACC5
- 125 PUSHENVACC1
- 126 APPLY2
- 127 POPTRAP
- 128 RETURN 3
- 130 PUSHGETGLOBAL End_of_file
- 132 PUSHACC1
- 133 GETFIELD0
- 134 EQ
- 135 BRANCHIFNOT 140
- 137 ACC1
- 138 RETURN 4
- 140 ACC0
- 141 RAISE
- 142 ACC0
- 143 C_CALL1 caml_flush
- 145 RETURN 1
- 147 RESTART
- 148 GRAB 1
- 150 ACC1
- 151 PUSHACC1
- 152 C_CALL2 caml_output_char
- 154 RETURN 2
- 156 RESTART
- 157 GRAB 1
- 159 ACC1
- 160 PUSHACC1
- 161 C_CALL2 caml_output_char
- 163 RETURN 2
- 165 RESTART
- 166 GRAB 1
- 168 ACC1
- 169 PUSHACC1
- 170 C_CALL2 caml_output_int
- 172 RETURN 2
- 174 RESTART
- 175 GRAB 1
- 177 ACC1
- 178 PUSHACC1
- 179 C_CALL2 caml_seek_out
- 181 RETURN 2
- 183 ACC0
- 184 C_CALL1 caml_pos_out
- 186 RETURN 1
- 188 ACC0
- 189 C_CALL1 caml_channel_size
- 191 RETURN 1
- 193 RESTART
- 194 GRAB 1
- 196 ACC1
- 197 PUSHACC1
- 198 C_CALL2 caml_set_binary_mode
- 200 RETURN 2
- 202 ACC0
- 203 C_CALL1 caml_input_char
- 205 RETURN 1
- 207 ACC0
- 208 C_CALL1 caml_input_char
- 210 RETURN 1
- 212 ACC0
- 213 C_CALL1 caml_input_int
- 215 RETURN 1
- 217 ACC0
- 218 C_CALL1 input_value
- 220 RETURN 1
- 222 RESTART
- 223 GRAB 1
- 225 ACC1
- 226 PUSHACC1
- 227 C_CALL2 caml_seek_in
- 229 RETURN 2
- 231 ACC0
- 232 C_CALL1 caml_pos_in
- 234 RETURN 1
- 236 ACC0
- 237 C_CALL1 caml_channel_size
- 239 RETURN 1
- 241 ACC0
- 242 C_CALL1 caml_close_channel
- 244 RETURN 1
- 246 RESTART
- 247 GRAB 1
- 249 ACC1
- 250 PUSHACC1
- 251 C_CALL2 caml_set_binary_mode
- 253 RETURN 2
- 255 CONST0
- 256 PUSHENVACC1
- 257 APPLY1
- 258 ACC0
- 259 C_CALL1 sys_exit
- 261 RETURN 1
- 263 CONST0
- 264 PUSHENVACC1
- 265 GETFIELD0
- 266 APPTERM1 2
- 268 CONST0
- 269 PUSHENVACC1
- 270 APPLY1
- 271 CONST0
- 272 PUSHENVACC2
- 273 APPTERM1 2
- 275 ENVACC1
- 276 GETFIELD0
- 277 PUSHACC0
- 278 PUSHACC2
- 279 CLOSURE 2, 268
- 282 PUSHENVACC1
- 283 SETFIELD0
- 284 RETURN 2
- 286 ENVACC1
- 287 C_CALL1 caml_flush
- 289 ENVACC2
- 290 C_CALL1 caml_flush
- 292 RETURN 1
- 294 CONST0
- 295 PUSHENVACC1
- 296 APPLY1
- 297 C_CALL1 float_of_string
- 299 RETURN 1
- 301 CONST0
- 302 PUSHENVACC1
- 303 APPLY1
- 304 C_CALL1 int_of_string
- 306 RETURN 1
- 308 ENVACC2
- 309 C_CALL1 caml_flush
- 311 ENVACC1
- 312 PUSHENVACC3
- 313 APPTERM1 2
- 315 CONSTINT 13
- 317 PUSHENVACC1
- 318 C_CALL2 caml_output_char
- 320 ENVACC1
- 321 C_CALL1 caml_flush
- 323 RETURN 1
- 325 ACC0
- 326 PUSHENVACC1
- 327 PUSHENVACC2
- 328 APPLY2
- 329 CONSTINT 13
- 331 PUSHENVACC1
- 332 C_CALL2 caml_output_char
- 334 ENVACC1
- 335 C_CALL1 caml_flush
- 337 RETURN 1
- 339 ACC0
- 340 PUSHENVACC1
- 341 APPLY1
- 342 PUSHENVACC2
- 343 PUSHENVACC3
- 344 APPTERM2 3
- 346 ACC0
- 347 PUSHENVACC1
- 348 APPLY1
- 349 PUSHENVACC2
- 350 PUSHENVACC3
- 351 APPTERM2 3
- 353 ACC0
- 354 PUSHENVACC1
- 355 PUSHENVACC2
- 356 APPTERM2 3
- 358 ACC0
- 359 PUSHENVACC1
- 360 C_CALL2 caml_output_char
- 362 RETURN 1
- 364 CONSTINT 13
- 366 PUSHENVACC1
- 367 C_CALL2 caml_output_char
- 369 ENVACC1
- 370 C_CALL1 caml_flush
- 372 RETURN 1
- 374 ACC0
- 375 PUSHENVACC1
- 376 PUSHENVACC2
- 377 APPLY2
- 378 CONSTINT 13
- 380 PUSHENVACC1
- 381 C_CALL2 caml_output_char
- 383 RETURN 1
- 385 ACC0
- 386 PUSHENVACC1
- 387 APPLY1
- 388 PUSHENVACC2
- 389 PUSHENVACC3
- 390 APPTERM2 3
- 392 ACC0
- 393 PUSHENVACC1
- 394 APPLY1
- 395 PUSHENVACC2
- 396 PUSHENVACC3
- 397 APPTERM2 3
- 399 ACC0
- 400 PUSHENVACC1
- 401 PUSHENVACC2
- 402 APPTERM2 3
- 404 ACC0
- 405 PUSHENVACC1
- 406 C_CALL2 caml_output_char
- 408 RETURN 1
- 410 RESTART
- 411 GRAB 3
- 413 CONST0
- 414 PUSHACC3
- 415 LTINT
- 416 BRANCHIF 427
- 418 ACC1
- 419 C_CALL1 ml_string_length
- 421 PUSHACC4
- 422 PUSHACC4
- 423 ADDINT
- 424 GTINT
- 425 BRANCHIFNOT 432
- 427 GETGLOBAL "really_input"
- 429 PUSHENVACC1
- 430 APPTERM1 5
- 432 ACC3
- 433 PUSHACC3
- 434 PUSHACC3
- 435 PUSHACC3
- 436 PUSHENVACC2
- 437 APPTERM 4, 8
- 440 RESTART
- 441 GRAB 3
- 443 CONST0
- 444 PUSHACC3
- 445 LTINT
- 446 BRANCHIF 457
- 448 ACC1
- 449 C_CALL1 ml_string_length
- 451 PUSHACC4
- 452 PUSHACC4
- 453 ADDINT
- 454 GTINT
- 455 BRANCHIFNOT 462
- 457 GETGLOBAL "input"
- 459 PUSHENVACC1
- 460 APPTERM1 5
- 462 ACC3
- 463 PUSHACC3
- 464 PUSHACC3
- 465 PUSHACC3
- 466 C_CALL4 caml_input
- 468 RETURN 4
- 470 ACC0
- 471 PUSHCONST0
- 472 PUSHGETGLOBAL <0>(0, <0>(6, 0))
- 474 PUSHENVACC1
- 475 APPTERM3 4
- 477 ACC0
- 478 PUSHCONST0
- 479 PUSHGETGLOBAL <0>(0, <0>(7, 0))
- 481 PUSHENVACC1
- 482 APPTERM3 4
- 484 RESTART
- 485 GRAB 2
- 487 ACC1
- 488 PUSHACC1
- 489 PUSHACC4
- 490 C_CALL3 sys_open
- 492 C_CALL1 caml_open_descriptor
- 494 RETURN 3
- 496 ACC0
- 497 C_CALL1 caml_flush
- 499 ACC0
- 500 C_CALL1 caml_close_channel
- 502 RETURN 1
- 504 RESTART
- 505 GRAB 1
- 507 CONST0
- 508 PUSHACC2
- 509 PUSHACC2
- 510 C_CALL3 output_value
- 512 RETURN 2
- 514 RESTART
- 515 GRAB 3
- 517 CONST0
- 518 PUSHACC3
- 519 LTINT
- 520 BRANCHIF 531
- 522 ACC1
- 523 C_CALL1 ml_string_length
- 525 PUSHACC4
- 526 PUSHACC4
- 527 ADDINT
- 528 GTINT
- 529 BRANCHIFNOT 536
- 531 GETGLOBAL "output"
- 533 PUSHENVACC1
- 534 APPTERM1 5
- 536 ACC3
- 537 PUSHACC3
- 538 PUSHACC3
- 539 PUSHACC3
- 540 C_CALL4 caml_output
- 542 RETURN 4
- 544 RESTART
- 545 GRAB 1
- 547 ACC1
- 548 C_CALL1 ml_string_length
- 550 PUSHCONST0
- 551 PUSHACC3
- 552 PUSHACC3
- 553 C_CALL4 caml_output
- 555 RETURN 2
- 557 ACC0
- 558 PUSHCONSTINT 438
- 560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0))))
- 562 PUSHENVACC1
- 563 APPTERM3 4
- 565 ACC0
- 566 PUSHCONSTINT 438
- 568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0))))
- 570 PUSHENVACC1
- 571 APPTERM3 4
- 573 RESTART
- 574 GRAB 2
- 576 ACC1
- 577 PUSHACC1
- 578 PUSHACC4
- 579 C_CALL3 sys_open
- 581 C_CALL1 caml_open_descriptor
- 583 RETURN 3
- 585 ACC0
- 586 PUSHGETGLOBAL "%.12g"
- 588 C_CALL2 format_float
- 590 RETURN 1
- 592 ACC0
- 593 PUSHGETGLOBAL "%d"
- 595 C_CALL2 format_int
- 597 RETURN 1
- 599 GETGLOBAL "false"
- 601 PUSHACC1
- 602 C_CALL2 string_equal
- 604 BRANCHIFNOT 609
- 606 CONST0
- 607 RETURN 1
- 609 GETGLOBAL "true"
- 611 PUSHACC1
- 612 C_CALL2 string_equal
- 614 BRANCHIFNOT 619
- 616 CONST1
- 617 RETURN 1
- 619 GETGLOBAL "bool_of_string"
- 621 PUSHENVACC1
- 622 APPTERM1 2
- 624 ACC0
- 625 BRANCHIFNOT 631
- 627 GETGLOBAL "true"
- 629 RETURN 1
- 631 GETGLOBAL "false"
- 633 RETURN 1
- 635 CONST0
- 636 PUSHACC1
- 637 LTINT
- 638 BRANCHIF 646
- 640 CONSTINT 255
- 642 PUSHACC1
- 643 GTINT
- 644 BRANCHIFNOT 651
- 646 GETGLOBAL "char_of_int"
- 648 PUSHENVACC1
- 649 APPTERM1 2
- 651 ACC0
- 652 RETURN 1
- 654 RESTART
- 655 GRAB 1
- 657 ACC0
- 658 C_CALL1 ml_string_length
- 660 PUSHACC2
- 661 C_CALL1 ml_string_length
- 663 PUSHACC0
- 664 PUSHACC2
- 665 ADDINT
- 666 C_CALL1 create_string
- 668 PUSHACC2
- 669 PUSHCONST0
- 670 PUSHACC2
- 671 PUSHCONST0
- 672 PUSHACC7
- 673 C_CALL5 blit_string
- 675 ACC1
- 676 PUSHACC3
- 677 PUSHACC2
- 678 PUSHCONST0
- 679 PUSHACC 8
- 681 C_CALL5 blit_string
- 683 ACC0
- 684 RETURN 5
- 686 CONSTINT -1
- 688 PUSHACC1
- 689 XORINT
- 690 RETURN 1
- 692 CONST0
- 693 PUSHACC1
- 694 GEINT
- 695 BRANCHIFNOT 700
- 697 ACC0
- 698 RETURN 1
- 700 ACC0
- 701 NEGINT
- 702 RETURN 1
- 704 RESTART
- 705 GRAB 1
- 707 ACC1
- 708 PUSHACC1
- 709 C_CALL2 greaterequal
- 711 BRANCHIFNOT 716
- 713 ACC0
- 714 RETURN 2
- 716 ACC1
- 717 RETURN 2
- 719 RESTART
- 720 GRAB 1
- 722 ACC1
- 723 PUSHACC1
- 724 C_CALL2 lessequal
- 726 BRANCHIFNOT 731
- 728 ACC0
- 729 RETURN 2
- 731 ACC1
- 732 RETURN 2
- 734 ACC0
- 735 PUSHGETGLOBAL Invalid_argument
- 737 MAKEBLOCK2 0
- 739 RAISE
- 740 ACC0
- 741 PUSHGETGLOBAL Failure
- 743 MAKEBLOCK2 0
- 745 RAISE
- 746 CLOSURE 0, 740
- 749 PUSH
- 750 CLOSURE 0, 734
- 753 PUSHGETGLOBAL "Pervasives.Exit"
- 755 MAKEBLOCK1 0
- 757 PUSHGETGLOBAL "Pervasives.Assert_failure"
- 759 MAKEBLOCK1 0
- 761 PUSH
- 762 CLOSURE 0, 720
- 765 PUSH
- 766 CLOSURE 0, 705
- 769 PUSH
- 770 CLOSURE 0, 692
- 773 PUSH
- 774 CLOSURE 0, 686
- 777 PUSHCONST0
- 778 PUSHCONSTINT 31
- 780 PUSHCONST1
- 781 LSLINT
- 782 EQ
- 783 BRANCHIFNOT 789
- 785 CONSTINT 30
- 787 BRANCH 791
- 789 CONSTINT 62
- 791 PUSHCONST1
- 792 LSLINT
- 793 PUSHACC0
- 794 OFFSETINT -1
- 796 PUSH
- 797 CLOSURE 0, 655
- 800 PUSHACC 9
- 802 CLOSURE 1, 635
- 805 PUSH
- 806 CLOSURE 0, 624
- 809 PUSHACC 11
- 811 CLOSURE 1, 599
- 814 PUSH
- 815 CLOSURE 0, 592
- 818 PUSH
- 819 CLOSURE 0, 585
- 822 PUSH
- 823 CLOSUREREC 0, 12
- 827 CONST0
- 828 C_CALL1 caml_open_descriptor
- 830 PUSHCONST1
- 831 C_CALL1 caml_open_descriptor
- 833 PUSHCONST2
- 834 C_CALL1 caml_open_descriptor
- 836 PUSH
- 837 CLOSURE 0, 574
- 840 PUSHACC0
- 841 CLOSURE 1, 565
- 844 PUSHACC1
- 845 CLOSURE 1, 557
- 848 PUSH
- 849 CLOSURE 0, 545
- 852 PUSHACC 22
- 854 CLOSURE 1, 515
- 857 PUSH
- 858 CLOSURE 0, 505
- 861 PUSH
- 862 CLOSURE 0, 496
- 865 PUSH
- 866 CLOSURE 0, 485
- 869 PUSHACC0
- 870 CLOSURE 1, 477
- 873 PUSHACC1
- 874 CLOSURE 1, 470
- 877 PUSHACC 28
- 879 CLOSURE 1, 441
- 882 PUSH
- 883 CLOSUREREC 0, 32
- 887 ACC0
- 888 PUSHACC 31
- 890 CLOSURE 2, 411
- 893 PUSHACC 22
- 895 CLOSUREREC 1, 70
- 899 ACC 15
- 901 CLOSURE 1, 404
- 904 PUSHACC 11
- 906 PUSHACC 17
- 908 CLOSURE 2, 399
- 911 PUSHACC 12
- 913 PUSHACC 18
- 915 PUSHACC 23
- 917 CLOSURE 3, 392
- 920 PUSHACC 13
- 922 PUSHACC 19
- 924 PUSHACC 23
- 926 CLOSURE 3, 385
- 929 PUSHACC 14
- 931 PUSHACC 20
- 933 CLOSURE 2, 374
- 936 PUSHACC 20
- 938 CLOSURE 1, 364
- 941 PUSHACC 20
- 943 CLOSURE 1, 358
- 946 PUSHACC 17
- 948 PUSHACC 22
- 950 CLOSURE 2, 353
- 953 PUSHACC 18
- 955 PUSHACC 23
- 957 PUSHACC 29
- 959 CLOSURE 3, 346
- 962 PUSHACC 19
- 964 PUSHACC 24
- 966 PUSHACC 29
- 968 CLOSURE 3, 339
- 971 PUSHACC 20
- 973 PUSHACC 25
- 975 CLOSURE 2, 325
- 978 PUSHACC 25
- 980 CLOSURE 1, 315
- 983 PUSHACC 12
- 985 PUSHACC 28
- 987 PUSHACC 30
- 989 CLOSURE 3, 308
- 992 PUSHACC0
- 993 CLOSURE 1, 301
- 996 PUSHACC1
- 997 CLOSURE 1, 294
- 1000 PUSHACC 29
- 1002 PUSHACC 31
- 1004 CLOSURE 2, 286
- 1007 MAKEBLOCK1 0
- 1009 PUSHACC0
- 1010 CLOSURE 1, 275
- 1013 PUSHACC1
- 1014 CLOSURE 1, 263
- 1017 PUSHACC0
- 1018 CLOSURE 1, 255
- 1021 PUSHACC1
- 1022 PUSHACC 22
- 1024 PUSHACC4
- 1025 PUSHACC3
- 1026 PUSH
- 1027 CLOSURE 0, 247
- 1030 PUSH
- 1031 CLOSURE 0, 241
- 1034 PUSH
- 1035 CLOSURE 0, 236
- 1038 PUSH
- 1039 CLOSURE 0, 231
- 1042 PUSH
- 1043 CLOSURE 0, 223
- 1046 PUSH
- 1047 CLOSURE 0, 217
- 1050 PUSH
- 1051 CLOSURE 0, 212
- 1054 PUSH
- 1055 CLOSURE 0, 207
- 1058 PUSHACC 32
- 1060 PUSHACC 35
- 1062 PUSHACC 33
- 1064 PUSH
- 1065 CLOSURE 0, 202
- 1068 PUSHACC 41
- 1070 PUSHACC 40
- 1072 PUSHACC 42
- 1074 PUSH
- 1075 CLOSURE 0, 194
- 1078 PUSHACC 46
- 1080 PUSH
- 1081 CLOSURE 0, 188
- 1084 PUSH
- 1085 CLOSURE 0, 183
- 1088 PUSH
- 1089 CLOSURE 0, 175
- 1092 PUSHACC 51
- 1094 PUSH
- 1095 CLOSURE 0, 166
- 1098 PUSH
- 1099 CLOSURE 0, 157
- 1102 PUSHACC 55
- 1104 PUSHACC 57
- 1106 PUSH
- 1107 CLOSURE 0, 148
- 1110 PUSH
- 1111 CLOSURE 0, 142
- 1114 PUSHACC 63
- 1116 PUSHACC 62
- 1118 PUSHACC 64
- 1120 PUSHACC 38
- 1122 PUSHACC 40
- 1124 PUSHACC 42
- 1126 PUSHACC 44
- 1128 PUSHACC 46
- 1130 PUSHACC 48
- 1132 PUSHACC 50
- 1134 PUSHACC 52
- 1136 PUSHACC 54
- 1138 PUSHACC 56
- 1140 PUSHACC 58
- 1142 PUSHACC 60
- 1144 PUSHACC 62
- 1146 PUSHACC 64
- 1148 PUSHACC 66
- 1150 PUSHACC 82
- 1152 PUSHACC 84
- 1154 PUSHACC 86
- 1156 PUSHACC 88
- 1158 PUSHACC 90
- 1160 PUSHACC 92
- 1162 PUSHACC 94
- 1164 PUSHACC 96
- 1166 PUSHACC 98
- 1168 PUSHACC 100
- 1170 PUSHACC 104
- 1172 PUSHACC 104
- 1174 PUSHACC 104
- 1176 PUSHACC 108
- 1178 PUSHACC 110
- 1180 PUSHACC 112
- 1182 PUSHACC 117
- 1184 PUSHACC 117
- 1186 PUSHACC 117
- 1188 PUSHACC 117
- 1190 MAKEBLOCK 69, 0
- 1193 POP 53
- 1195 SETGLOBAL Pervasives
- 1197 BRANCH 2177
- 1199 RESTART
- 1200 GRAB 1
- 1202 ACC1
- 1203 BRANCHIFNOT 1213
- 1205 ACC1
- 1206 GETFIELD1
- 1207 PUSHACC1
- 1208 OFFSETINT 1
- 1210 PUSHOFFSETCLOSURE0
- 1211 APPTERM2 4
- 1213 ACC0
- 1214 RETURN 2
- 1216 RESTART
- 1217 GRAB 1
- 1219 ACC0
- 1220 BRANCHIFNOT 1251
- 1222 CONST0
- 1223 PUSHACC2
- 1224 EQ
- 1225 BRANCHIFNOT 1231
- 1227 ACC0
- 1228 GETFIELD0
- 1229 RETURN 2
- 1231 CONST0
- 1232 PUSHACC2
- 1233 GTINT
- 1234 BRANCHIFNOT 1244
- 1236 ACC1
- 1237 OFFSETINT -1
- 1239 PUSHACC1
- 1240 GETFIELD1
- 1241 PUSHOFFSETCLOSURE0
- 1242 APPTERM2 4
- 1244 GETGLOBAL "List.nth"
- 1246 PUSHGETGLOBALFIELD Pervasives, 2
- 1249 APPTERM1 3
- 1251 GETGLOBAL "nth"
- 1253 PUSHGETGLOBALFIELD Pervasives, 3
- 1256 APPTERM1 3
- 1258 RESTART
- 1259 GRAB 1
- 1261 ACC0
- 1262 BRANCHIFNOT 1274
- 1264 ACC1
- 1265 PUSHACC1
- 1266 GETFIELD0
- 1267 MAKEBLOCK2 0
- 1269 PUSHACC1
- 1270 GETFIELD1
- 1271 PUSHOFFSETCLOSURE0
- 1272 APPTERM2 4
- 1274 ACC1
- 1275 RETURN 2
- 1277 ACC0
- 1278 BRANCHIFNOT 1291
- 1280 ACC0
- 1281 GETFIELD1
- 1282 PUSHOFFSETCLOSURE0
- 1283 APPLY1
- 1284 PUSHACC1
- 1285 GETFIELD0
- 1286 PUSHGETGLOBALFIELD Pervasives, 16
- 1289 APPTERM2 3
- 1291 RETURN 1
- 1293 RESTART
- 1294 GRAB 1
- 1296 ACC1
- 1297 BRANCHIFNOT 1313
- 1299 ACC1
- 1300 GETFIELD0
- 1301 PUSHACC1
- 1302 APPLY1
- 1303 PUSHACC2
- 1304 GETFIELD1
- 1305 PUSHACC2
- 1306 PUSHOFFSETCLOSURE0
- 1307 APPLY2
- 1308 PUSHACC1
- 1309 MAKEBLOCK2 0
- 1311 POP 1
- 1313 RETURN 2
- 1315 RESTART
- 1316 GRAB 1
- 1318 ACC1
- 1319 BRANCHIFNOT 1331
- 1321 ACC1
- 1322 GETFIELD0
- 1323 PUSHACC1
- 1324 APPLY1
- 1325 ACC1
- 1326 GETFIELD1
- 1327 PUSHACC1
- 1328 PUSHOFFSETCLOSURE0
- 1329 APPTERM2 4
- 1331 RETURN 2
- 1333 RESTART
- 1334 GRAB 2
- 1336 ACC2
- 1337 BRANCHIFNOT 1350
- 1339 ACC2
- 1340 GETFIELD1
- 1341 PUSHACC3
- 1342 GETFIELD0
- 1343 PUSHACC3
- 1344 PUSHACC3
- 1345 APPLY2
- 1346 PUSHACC2
- 1347 PUSHOFFSETCLOSURE0
- 1348 APPTERM3 6
- 1350 ACC1
- 1351 RETURN 3
- 1353 RESTART
- 1354 GRAB 2
- 1356 ACC1
- 1357 BRANCHIFNOT 1370
- 1359 ACC2
- 1360 PUSHACC2
- 1361 GETFIELD1
- 1362 PUSHACC2
- 1363 PUSHOFFSETCLOSURE0
- 1364 APPLY3
- 1365 PUSHACC2
- 1366 GETFIELD0
- 1367 PUSHACC2
- 1368 APPTERM2 5
- 1370 ACC2
- 1371 RETURN 3
- 1373 RESTART
- 1374 GRAB 2
- 1376 ACC1
- 1377 BRANCHIFNOT 1400
- 1379 ACC2
- 1380 BRANCHIFNOT 1407
- 1382 ACC2
- 1383 GETFIELD0
- 1384 PUSHACC2
- 1385 GETFIELD0
- 1386 PUSHACC2
- 1387 APPLY2
- 1388 PUSHACC3
- 1389 GETFIELD1
- 1390 PUSHACC3
- 1391 GETFIELD1
- 1392 PUSHACC3
- 1393 PUSHOFFSETCLOSURE0
- 1394 APPLY3
- 1395 PUSHACC1
- 1396 MAKEBLOCK2 0
- 1398 RETURN 4
- 1400 ACC2
- 1401 BRANCHIFNOT 1405
- 1403 BRANCH 1407
- 1405 RETURN 3
- 1407 GETGLOBAL "List.map2"
- 1409 PUSHGETGLOBALFIELD Pervasives, 2
- 1412 APPTERM1 4
- 1414 RESTART
- 1415 GRAB 2
- 1417 ACC1
- 1418 BRANCHIFNOT 1437
- 1420 ACC2
- 1421 BRANCHIFNOT 1444
- 1423 ACC2
- 1424 GETFIELD0
- 1425 PUSHACC2
- 1426 GETFIELD0
- 1427 PUSHACC2
- 1428 APPLY2
- 1429 ACC2
- 1430 GETFIELD1
- 1431 PUSHACC2
- 1432 GETFIELD1
- 1433 PUSHACC2
- 1434 PUSHOFFSETCLOSURE0
- 1435 APPTERM3 6
- 1437 ACC2
- 1438 BRANCHIFNOT 1442
- 1440 BRANCH 1444
- 1442 RETURN 3
- 1444 GETGLOBAL "List.iter2"
- 1446 PUSHGETGLOBALFIELD Pervasives, 2
- 1449 APPTERM1 4
- 1451 RESTART
- 1452 GRAB 3
- 1454 ACC2
- 1455 BRANCHIFNOT 1476
- 1457 ACC3
- 1458 BRANCHIFNOT 1482
- 1460 ACC3
- 1461 GETFIELD1
- 1462 PUSHACC3
- 1463 GETFIELD1
- 1464 PUSHACC5
- 1465 GETFIELD0
- 1466 PUSHACC5
- 1467 GETFIELD0
- 1468 PUSHACC5
- 1469 PUSHACC5
- 1470 APPLY3
- 1471 PUSHACC3
- 1472 PUSHOFFSETCLOSURE0
- 1473 APPTERM 4, 8
- 1476 ACC3
- 1477 BRANCHIF 1482
- 1479 ACC1
- 1480 RETURN 4
- 1482 GETGLOBAL "List.fold_left2"
- 1484 PUSHGETGLOBALFIELD Pervasives, 2
- 1487 APPTERM1 5
- 1489 RESTART
- 1490 GRAB 3
- 1492 ACC1
- 1493 BRANCHIFNOT 1516
- 1495 ACC2
- 1496 BRANCHIFNOT 1522
- 1498 PUSH_RETADDR 1509
- 1500 ACC6
- 1501 PUSHACC6
- 1502 GETFIELD1
- 1503 PUSHACC6
- 1504 GETFIELD1
- 1505 PUSHACC6
- 1506 PUSHOFFSETCLOSURE0
- 1507 APPLY 4
- 1509 PUSHACC3
- 1510 GETFIELD0
- 1511 PUSHACC3
- 1512 GETFIELD0
- 1513 PUSHACC3
- 1514 APPTERM3 7
- 1516 ACC2
- 1517 BRANCHIF 1522
- 1519 ACC3
- 1520 RETURN 4
- 1522 GETGLOBAL "List.fold_right2"
- 1524 PUSHGETGLOBALFIELD Pervasives, 2
- 1527 APPTERM1 5
- 1529 RESTART
- 1530 GRAB 1
- 1532 ACC1
- 1533 BRANCHIFNOT 1549
- 1535 ACC1
- 1536 GETFIELD0
- 1537 PUSHACC1
- 1538 APPLY1
- 1539 BRANCHIFNOT 1547
- 1541 ACC1
- 1542 GETFIELD1
- 1543 PUSHACC1
- 1544 PUSHOFFSETCLOSURE0
- 1545 APPTERM2 4
- 1547 RETURN 2
- 1549 CONST1
- 1550 RETURN 2
- 1552 RESTART
- 1553 GRAB 1
- 1555 ACC1
- 1556 BRANCHIFNOT 1570
- 1558 ACC1
- 1559 GETFIELD0
- 1560 PUSHACC1
- 1561 APPLY1
- 1562 BRANCHIF 1570
- 1564 ACC1
- 1565 GETFIELD1
- 1566 PUSHACC1
- 1567 PUSHOFFSETCLOSURE0
- 1568 APPTERM2 4
- 1570 RETURN 2
- 1572 RESTART
- 1573 GRAB 2
- 1575 ACC1
- 1576 BRANCHIFNOT 1599
- 1578 ACC2
- 1579 BRANCHIFNOT 1605
- 1581 ACC2
- 1582 GETFIELD0
- 1583 PUSHACC2
- 1584 GETFIELD0
- 1585 PUSHACC2
- 1586 APPLY2
- 1587 BRANCHIFNOT 1597
- 1589 ACC2
- 1590 GETFIELD1
- 1591 PUSHACC2
- 1592 GETFIELD1
- 1593 PUSHACC2
- 1594 PUSHOFFSETCLOSURE0
- 1595 APPTERM3 6
- 1597 RETURN 3
- 1599 ACC2
- 1600 BRANCHIF 1605
- 1602 CONST1
- 1603 RETURN 3
- 1605 GETGLOBAL "List.for_all2"
- 1607 PUSHGETGLOBALFIELD Pervasives, 2
- 1610 APPTERM1 4
- 1612 RESTART
- 1613 GRAB 2
- 1615 ACC1
- 1616 BRANCHIFNOT 1639
- 1618 ACC2
- 1619 BRANCHIFNOT 1646
- 1621 ACC2
- 1622 GETFIELD0
- 1623 PUSHACC2
- 1624 GETFIELD0
- 1625 PUSHACC2
- 1626 APPLY2
- 1627 BRANCHIF 1637
- 1629 ACC2
- 1630 GETFIELD1
- 1631 PUSHACC2
- 1632 GETFIELD1
- 1633 PUSHACC2
- 1634 PUSHOFFSETCLOSURE0
- 1635 APPTERM3 6
- 1637 RETURN 3
- 1639 ACC2
- 1640 BRANCHIFNOT 1644
- 1642 BRANCH 1646
- 1644 RETURN 3
- 1646 GETGLOBAL "List.exists2"
- 1648 PUSHGETGLOBALFIELD Pervasives, 2
- 1651 APPTERM1 4
- 1653 RESTART
- 1654 GRAB 1
- 1656 ACC1
- 1657 BRANCHIFNOT 1672
- 1659 ACC0
- 1660 PUSHACC2
- 1661 GETFIELD0
- 1662 C_CALL2 equal
- 1664 BRANCHIF 1672
- 1666 ACC1
- 1667 GETFIELD1
- 1668 PUSHACC1
- 1669 PUSHOFFSETCLOSURE0
- 1670 APPTERM2 4
- 1672 RETURN 2
- 1674 RESTART
- 1675 GRAB 1
- 1677 ACC1
- 1678 BRANCHIFNOT 1692
- 1680 ACC0
- 1681 PUSHACC2
- 1682 GETFIELD0
- 1683 EQ
- 1684 BRANCHIF 1692
- 1686 ACC1
- 1687 GETFIELD1
- 1688 PUSHACC1
- 1689 PUSHOFFSETCLOSURE0
- 1690 APPTERM2 4
- 1692 RETURN 2
- 1694 RESTART
- 1695 GRAB 1
- 1697 ACC1
- 1698 BRANCHIFNOT 1719
- 1700 ACC1
- 1701 GETFIELD0
- 1702 PUSHACC1
- 1703 PUSHACC1
- 1704 GETFIELD0
- 1705 C_CALL2 equal
- 1707 BRANCHIFNOT 1713
- 1709 ACC0
- 1710 GETFIELD1
- 1711 RETURN 3
- 1713 ACC2
- 1714 GETFIELD1
- 1715 PUSHACC2
- 1716 PUSHOFFSETCLOSURE0
- 1717 APPTERM2 5
- 1719 GETGLOBAL Not_found
- 1721 MAKEBLOCK1 0
- 1723 RAISE
- 1724 RESTART
- 1725 GRAB 1
- 1727 ACC1
- 1728 BRANCHIFNOT 1748
- 1730 ACC1
- 1731 GETFIELD0
- 1732 PUSHACC1
- 1733 PUSHACC1
- 1734 GETFIELD0
- 1735 EQ
- 1736 BRANCHIFNOT 1742
- 1738 ACC0
- 1739 GETFIELD1
- 1740 RETURN 3
- 1742 ACC2
- 1743 GETFIELD1
- 1744 PUSHACC2
- 1745 PUSHOFFSETCLOSURE0
- 1746 APPTERM2 5
- 1748 GETGLOBAL Not_found
- 1750 MAKEBLOCK1 0
- 1752 RAISE
- 1753 RESTART
- 1754 GRAB 1
- 1756 ACC1
- 1757 BRANCHIFNOT 1773
- 1759 ACC0
- 1760 PUSHACC2
- 1761 GETFIELD0
- 1762 GETFIELD0
- 1763 C_CALL2 equal
- 1765 BRANCHIF 1773
- 1767 ACC1
- 1768 GETFIELD1
- 1769 PUSHACC1
- 1770 PUSHOFFSETCLOSURE0
- 1771 APPTERM2 4
- 1773 RETURN 2
- 1775 RESTART
- 1776 GRAB 1
- 1778 ACC1
- 1779 BRANCHIFNOT 1794
- 1781 ACC0
- 1782 PUSHACC2
- 1783 GETFIELD0
- 1784 GETFIELD0
- 1785 EQ
- 1786 BRANCHIF 1794
- 1788 ACC1
- 1789 GETFIELD1
- 1790 PUSHACC1
- 1791 PUSHOFFSETCLOSURE0
- 1792 APPTERM2 4
- 1794 RETURN 2
- 1796 RESTART
- 1797 GRAB 1
- 1799 ACC1
- 1800 BRANCHIFNOT 1825
- 1802 ACC1
- 1803 GETFIELD0
- 1804 PUSHACC2
- 1805 GETFIELD1
- 1806 PUSHACC2
- 1807 PUSHACC2
- 1808 GETFIELD0
- 1809 C_CALL2 equal
- 1811 BRANCHIFNOT 1816
- 1813 ACC0
- 1814 RETURN 4
- 1816 ACC0
- 1817 PUSHACC3
- 1818 PUSHOFFSETCLOSURE0
- 1819 APPLY2
- 1820 PUSHACC2
- 1821 MAKEBLOCK2 0
- 1823 POP 2
- 1825 RETURN 2
- 1827 RESTART
- 1828 GRAB 1
- 1830 ACC1
- 1831 BRANCHIFNOT 1855
- 1833 ACC1
- 1834 GETFIELD0
- 1835 PUSHACC2
- 1836 GETFIELD1
- 1837 PUSHACC2
- 1838 PUSHACC2
- 1839 GETFIELD0
- 1840 EQ
- 1841 BRANCHIFNOT 1846
- 1843 ACC0
- 1844 RETURN 4
- 1846 ACC0
- 1847 PUSHACC3
- 1848 PUSHOFFSETCLOSURE0
- 1849 APPLY2
- 1850 PUSHACC2
- 1851 MAKEBLOCK2 0
- 1853 POP 2
- 1855 RETURN 2
- 1857 RESTART
- 1858 GRAB 1
- 1860 ACC1
- 1861 BRANCHIFNOT 1879
- 1863 ACC1
- 1864 GETFIELD0
- 1865 PUSHACC0
- 1866 PUSHACC2
- 1867 APPLY1
- 1868 BRANCHIFNOT 1873
- 1870 ACC0
- 1871 RETURN 3
- 1873 ACC2
- 1874 GETFIELD1
- 1875 PUSHACC2
- 1876 PUSHOFFSETCLOSURE0
- 1877 APPTERM2 5
- 1879 GETGLOBAL Not_found
- 1881 MAKEBLOCK1 0
- 1883 RAISE
- 1884 RESTART
- 1885 GRAB 2
- 1887 ACC2
- 1888 BRANCHIFNOT 1917
- 1890 ACC2
- 1891 GETFIELD0
- 1892 PUSHACC3
- 1893 GETFIELD1
- 1894 PUSHACC1
- 1895 PUSHENVACC2
- 1896 APPLY1
- 1897 BRANCHIFNOT 1908
- 1899 ACC0
- 1900 PUSHACC4
- 1901 PUSHACC4
- 1902 PUSHACC4
- 1903 MAKEBLOCK2 0
- 1905 PUSHOFFSETCLOSURE0
- 1906 APPTERM3 8
- 1908 ACC0
- 1909 PUSHACC4
- 1910 PUSHACC3
- 1911 MAKEBLOCK2 0
- 1913 PUSHACC4
- 1914 PUSHOFFSETCLOSURE0
- 1915 APPTERM3 8
- 1917 ACC1
- 1918 PUSHENVACC1
- 1919 APPLY1
- 1920 PUSHACC1
- 1921 PUSHENVACC1
- 1922 APPLY1
- 1923 MAKEBLOCK2 0
- 1925 RETURN 3
- 1927 RESTART
- 1928 GRAB 1
- 1930 ACC0
- 1931 PUSHENVACC1
- 1932 CLOSUREREC 2, 1885
- 1936 ACC2
- 1937 PUSHCONST0
- 1938 PUSHCONST0
- 1939 PUSHACC3
- 1940 APPTERM3 6
- 1942 ACC0
- 1943 BRANCHIFNOT 1967
- 1945 ACC0
- 1946 GETFIELD0
- 1947 PUSHACC1
- 1948 GETFIELD1
- 1949 PUSHOFFSETCLOSURE0
- 1950 APPLY1
- 1951 PUSHACC0
- 1952 GETFIELD1
- 1953 PUSHACC2
- 1954 GETFIELD1
- 1955 MAKEBLOCK2 0
- 1957 PUSHACC1
- 1958 GETFIELD0
- 1959 PUSHACC3
- 1960 GETFIELD0
- 1961 MAKEBLOCK2 0
- 1963 MAKEBLOCK2 0
- 1965 RETURN 3
- 1967 GETGLOBAL <0>(0, 0)
- 1969 RETURN 1
- 1971 RESTART
- 1972 GRAB 1
- 1974 ACC0
- 1975 BRANCHIFNOT 1996
- 1977 ACC1
- 1978 BRANCHIFNOT 2003
- 1980 ACC1
- 1981 GETFIELD1
- 1982 PUSHACC1
- 1983 GETFIELD1
- 1984 PUSHOFFSETCLOSURE0
- 1985 APPLY2
- 1986 PUSHACC2
- 1987 GETFIELD0
- 1988 PUSHACC2
- 1989 GETFIELD0
- 1990 MAKEBLOCK2 0
- 1992 MAKEBLOCK2 0
- 1994 RETURN 2
- 1996 ACC1
- 1997 BRANCHIFNOT 2001
- 1999 BRANCH 2003
- 2001 RETURN 2
- 2003 GETGLOBAL "List.combine"
- 2005 PUSHGETGLOBALFIELD Pervasives, 2
- 2008 APPTERM1 3
- 2010 RESTART
- 2011 GRAB 1
- 2013 ACC1
- 2014 BRANCHIFNOT 2038
- 2016 ACC1
- 2017 GETFIELD0
- 2018 PUSHACC2
- 2019 GETFIELD1
- 2020 PUSHACC1
- 2021 PUSHENVACC2
- 2022 APPLY1
- 2023 BRANCHIFNOT 2033
- 2025 ACC0
- 2026 PUSHACC3
- 2027 PUSHACC3
- 2028 MAKEBLOCK2 0
- 2030 PUSHOFFSETCLOSURE0
- 2031 APPTERM2 6
- 2033 ACC0
- 2034 PUSHACC3
- 2035 PUSHOFFSETCLOSURE0
- 2036 APPTERM2 6
- 2038 ACC0
- 2039 PUSHENVACC1
- 2040 APPTERM1 3
- 2042 ACC0
- 2043 PUSHENVACC1
- 2044 CLOSUREREC 2, 2011
- 2048 CONST0
- 2049 PUSHACC1
- 2050 APPTERM1 3
- 2052 RESTART
- 2053 GRAB 2
- 2055 ACC1
- 2056 BRANCHIFNOT 2077
- 2058 ACC2
- 2059 BRANCHIFNOT 2084
- 2061 ACC2
- 2062 GETFIELD1
- 2063 PUSHACC2
- 2064 GETFIELD1
- 2065 PUSHACC2
- 2066 PUSHACC5
- 2067 GETFIELD0
- 2068 PUSHACC5
- 2069 GETFIELD0
- 2070 PUSHENVACC1
- 2071 APPLY2
- 2072 MAKEBLOCK2 0
- 2074 PUSHOFFSETCLOSURE0
- 2075 APPTERM3 6
- 2077 ACC2
- 2078 BRANCHIFNOT 2082
- 2080 BRANCH 2084
- 2082 RETURN 3
- 2084 GETGLOBAL "List.rev_map2"
- 2086 PUSHGETGLOBALFIELD Pervasives, 2
- 2089 APPTERM1 4
- 2091 RESTART
- 2092 GRAB 2
- 2094 ACC0
- 2095 CLOSUREREC 1, 2053
- 2099 ACC3
- 2100 PUSHACC3
- 2101 PUSHCONST0
- 2102 PUSHACC3
- 2103 APPTERM3 7
- 2105 RESTART
- 2106 GRAB 1
- 2108 ACC1
- 2109 BRANCHIFNOT 2123
- 2111 ACC1
- 2112 GETFIELD1
- 2113 PUSHACC1
- 2114 PUSHACC3
- 2115 GETFIELD0
- 2116 PUSHENVACC1
- 2117 APPLY1
- 2118 MAKEBLOCK2 0
- 2120 PUSHOFFSETCLOSURE0
- 2121 APPTERM2 4
- 2123 ACC0
- 2124 RETURN 2
- 2126 RESTART
- 2127 GRAB 1
- 2129 ACC0
- 2130 CLOSUREREC 1, 2106
- 2134 ACC2
- 2135 PUSHCONST0
- 2136 PUSHACC2
- 2137 APPTERM2 5
- 2139 CONST0
- 2140 PUSHACC1
- 2141 PUSHENVACC1
- 2142 APPTERM2 3
- 2144 ACC0
- 2145 BRANCHIFNOT 2151
- 2147 ACC0
- 2148 GETFIELD1
- 2149 RETURN 1
- 2151 GETGLOBAL "tl"
- 2153 PUSHGETGLOBALFIELD Pervasives, 3
- 2156 APPTERM1 2
- 2158 ACC0
- 2159 BRANCHIFNOT 2165
- 2161 ACC0
- 2162 GETFIELD0
- 2163 RETURN 1
- 2165 GETGLOBAL "hd"
- 2167 PUSHGETGLOBALFIELD Pervasives, 3
- 2170 APPTERM1 2
- 2172 ACC0
- 2173 PUSHCONST0
- 2174 PUSHENVACC1
- 2175 APPTERM2 3
- 2177 CLOSUREREC 0, 1200
- 2181 ACC0
- 2182 CLOSURE 1, 2172
- 2185 PUSH
- 2186 CLOSURE 0, 2158
- 2189 PUSH
- 2190 CLOSURE 0, 2144
- 2193 PUSH
- 2194 CLOSUREREC 0, 1217
- 2198 GETGLOBALFIELD Pervasives, 16
- 2201 PUSH
- 2202 CLOSUREREC 0, 1259
- 2206 ACC0
- 2207 CLOSURE 1, 2139
- 2210 PUSH
- 2211 CLOSUREREC 0, 1277
- 2215 CLOSUREREC 0, 1294
- 2219 CLOSURE 0, 2127
- 2222 PUSH
- 2223 CLOSUREREC 0, 1316
- 2227 CLOSUREREC 0, 1334
- 2231 CLOSUREREC 0, 1354
- 2235 CLOSUREREC 0, 1374
- 2239 CLOSURE 0, 2092
- 2242 PUSH
- 2243 CLOSUREREC 0, 1415
- 2247 CLOSUREREC 0, 1452
- 2251 CLOSUREREC 0, 1490
- 2255 CLOSUREREC 0, 1530
- 2259 CLOSUREREC 0, 1553
- 2263 CLOSUREREC 0, 1573
- 2267 CLOSUREREC 0, 1613
- 2271 CLOSUREREC 0, 1654
- 2275 CLOSUREREC 0, 1675
- 2279 CLOSUREREC 0, 1695
- 2283 CLOSUREREC 0, 1725
- 2287 CLOSUREREC 0, 1754
- 2291 CLOSUREREC 0, 1776
- 2295 CLOSUREREC 0, 1797
- 2299 CLOSUREREC 0, 1828
- 2303 CLOSUREREC 0, 1858
- 2307 ACC 24
- 2309 CLOSURE 1, 2042
- 2312 PUSHACC 25
- 2314 CLOSUREREC 1, 1928
- 2318 CLOSUREREC 0, 1942
- 2322 CLOSUREREC 0, 1972
- 2326 ACC0
- 2327 PUSHACC2
- 2328 PUSHACC7
- 2329 PUSHACC 9
- 2331 PUSHACC 11
- 2333 PUSHACC 13
- 2335 PUSHACC 15
- 2337 PUSHACC 17
- 2339 PUSHACC 10
- 2341 PUSHACC 12
- 2343 PUSHACC 13
- 2345 PUSHACC 15
- 2347 PUSHACC 23
- 2349 PUSHACC 25
- 2351 PUSHACC 27
- 2353 PUSHACC 29
- 2355 PUSHACC 31
- 2357 PUSHACC 33
- 2359 PUSHACC 35
- 2361 PUSHACC 37
- 2363 PUSHACC 40
- 2365 PUSHACC 42
- 2367 PUSHACC 41
- 2369 PUSHACC 45
- 2371 PUSHACC 47
- 2373 PUSHACC 50
- 2375 PUSHACC 52
- 2377 PUSHACC 51
- 2379 PUSHACC 55
- 2381 PUSHACC 56
- 2383 PUSHACC 59
- 2385 PUSHACC 61
- 2387 PUSHACC 60
- 2389 PUSHACC 64
- 2391 PUSHACC 66
- 2393 PUSHACC 68
- 2395 PUSHACC 70
- 2397 MAKEBLOCK 37, 0
- 2400 POP 36
- 2402 SETGLOBAL List
- 2404 BRANCH 3341
- 2406 RESTART
- 2407 GRAB 2
- 2409 ACC2
- 2410 PUSHACC2
- 2411 VECTLENGTH
- 2412 OFFSETINT -1
- 2414 PUSHCONST0
- 2415 PUSH
- 2416 BRANCH 2433
- 2418 CHECK_SIGNALS
- 2419 ACC2
- 2420 PUSHACC2
- 2421 PUSHACC6
- 2422 C_CALL2 array_unsafe_get
- 2424 PUSHACC5
- 2425 APPLY2
- 2426 ASSIGN 2
- 2428 ACC1
- 2429 OFFSETINT -1
- 2431 ASSIGN 1
- 2433 ACC0
- 2434 PUSHACC2
- 2435 GEINT
- 2436 BRANCHIF 2418
- 2438 CONST0
- 2439 POP 2
- 2441 ACC0
- 2442 RETURN 4
- 2444 RESTART
- 2445 GRAB 2
- 2447 ACC1
- 2448 PUSHCONST0
- 2449 PUSHACC4
- 2450 VECTLENGTH
- 2451 OFFSETINT -1
- 2453 PUSH
- 2454 BRANCH 2471
- 2456 CHECK_SIGNALS
- 2457 ACC1
- 2458 PUSHACC6
- 2459 C_CALL2 array_unsafe_get
- 2461 PUSHACC3
- 2462 PUSHACC5
- 2463 APPLY2
- 2464 ASSIGN 2
- 2466 ACC1
- 2467 OFFSETINT 1
- 2469 ASSIGN 1
- 2471 ACC0
- 2472 PUSHACC2
- 2473 LEINT
- 2474 BRANCHIF 2456
- 2476 CONST0
- 2477 POP 2
- 2479 ACC0
- 2480 RETURN 4
- 2482 RESTART
- 2483 GRAB 1
- 2485 ACC1
- 2486 BRANCHIFNOT 2502
- 2488 ACC1
- 2489 GETFIELD0
- 2490 PUSHACC1
- 2491 PUSHENVACC1
- 2492 C_CALL3 array_unsafe_set
- 2494 ACC1
- 2495 GETFIELD1
- 2496 PUSHACC1
- 2497 OFFSETINT 1
- 2499 PUSHOFFSETCLOSURE0
- 2500 APPTERM2 4
- 2502 ENVACC1
- 2503 RETURN 2
- 2505 ACC0
- 2506 BRANCHIFNOT 2531
- 2508 ACC0
- 2509 GETFIELD1
- 2510 PUSHACC1
- 2511 GETFIELD0
- 2512 PUSHACC1
- 2513 PUSHGETGLOBALFIELD List, 0
- 2516 APPLY1
- 2517 OFFSETINT 1
- 2519 C_CALL2 make_vect
- 2521 PUSHACC0
- 2522 CLOSUREREC 1, 2483
- 2526 ACC2
- 2527 PUSHCONST1
- 2528 PUSHACC2
- 2529 APPTERM2 6
- 2531 ATOM0
- 2532 RETURN 1
- 2534 RESTART
- 2535 GRAB 1
- 2537 CONST0
- 2538 PUSHACC1
- 2539 LTINT
- 2540 BRANCHIFNOT 2545
- 2542 ACC1
- 2543 RETURN 2
- 2545 ACC1
- 2546 PUSHACC1
- 2547 PUSHENVACC1
- 2548 C_CALL2 array_unsafe_get
- 2550 MAKEBLOCK2 0
- 2552 PUSHACC1
- 2553 OFFSETINT -1
- 2555 PUSHOFFSETCLOSURE0
- 2556 APPTERM2 4
- 2558 ACC0
- 2559 CLOSUREREC 1, 2535
- 2563 CONST0
- 2564 PUSHACC2
- 2565 VECTLENGTH
- 2566 OFFSETINT -1
- 2568 PUSHACC2
- 2569 APPTERM2 4
- 2571 RESTART
- 2572 GRAB 1
- 2574 ACC1
- 2575 VECTLENGTH
- 2576 PUSHCONST0
- 2577 PUSHACC1
- 2578 EQ
- 2579 BRANCHIFNOT 2584
- 2581 ATOM0
- 2582 RETURN 3
- 2584 CONST0
- 2585 PUSHACC3
- 2586 C_CALL2 array_unsafe_get
- 2588 PUSHCONST0
- 2589 PUSHACC3
- 2590 APPLY2
- 2591 PUSHACC1
- 2592 C_CALL2 make_vect
- 2594 PUSHCONST1
- 2595 PUSHACC2
- 2596 OFFSETINT -1
- 2598 PUSH
- 2599 BRANCH 2618
- 2601 CHECK_SIGNALS
- 2602 ACC1
- 2603 PUSHACC6
- 2604 C_CALL2 array_unsafe_get
- 2606 PUSHACC2
- 2607 PUSHACC6
- 2608 APPLY2
- 2609 PUSHACC2
- 2610 PUSHACC4
- 2611 C_CALL3 array_unsafe_set
- 2613 ACC1
- 2614 OFFSETINT 1
- 2616 ASSIGN 1
- 2618 ACC0
- 2619 PUSHACC2
- 2620 LEINT
- 2621 BRANCHIF 2601
- 2623 CONST0
- 2624 POP 2
- 2626 ACC0
- 2627 RETURN 4
- 2629 RESTART
- 2630 GRAB 1
- 2632 CONST0
- 2633 PUSHACC2
- 2634 VECTLENGTH
- 2635 OFFSETINT -1
- 2637 PUSH
- 2638 BRANCH 2653
- 2640 CHECK_SIGNALS
- 2641 ACC1
- 2642 PUSHACC4
- 2643 C_CALL2 array_unsafe_get
- 2645 PUSHACC2
- 2646 PUSHACC4
- 2647 APPLY2
- 2648 ACC1
- 2649 OFFSETINT 1
- 2651 ASSIGN 1
- 2653 ACC0
- 2654 PUSHACC2
- 2655 LEINT
- 2656 BRANCHIF 2640
- 2658 CONST0
- 2659 RETURN 4
- 2661 RESTART
- 2662 GRAB 1
- 2664 ACC1
- 2665 VECTLENGTH
- 2666 PUSHCONST0
- 2667 PUSHACC1
- 2668 EQ
- 2669 BRANCHIFNOT 2674
- 2671 ATOM0
- 2672 RETURN 3
- 2674 CONST0
- 2675 PUSHACC3
- 2676 C_CALL2 array_unsafe_get
- 2678 PUSHACC2
- 2679 APPLY1
- 2680 PUSHACC1
- 2681 C_CALL2 make_vect
- 2683 PUSHCONST1
- 2684 PUSHACC2
- 2685 OFFSETINT -1
- 2687 PUSH
- 2688 BRANCH 2706
- 2690 CHECK_SIGNALS
- 2691 ACC1
- 2692 PUSHACC6
- 2693 C_CALL2 array_unsafe_get
- 2695 PUSHACC5
- 2696 APPLY1
- 2697 PUSHACC2
- 2698 PUSHACC4
- 2699 C_CALL3 array_unsafe_set
- 2701 ACC1
- 2702 OFFSETINT 1
- 2704 ASSIGN 1
- 2706 ACC0
- 2707 PUSHACC2
- 2708 LEINT
- 2709 BRANCHIF 2690
- 2711 CONST0
- 2712 POP 2
- 2714 ACC0
- 2715 RETURN 4
- 2717 RESTART
- 2718 GRAB 1
- 2720 CONST0
- 2721 PUSHACC2
- 2722 VECTLENGTH
- 2723 OFFSETINT -1
- 2725 PUSH
- 2726 BRANCH 2740
- 2728 CHECK_SIGNALS
- 2729 ACC1
- 2730 PUSHACC4
- 2731 C_CALL2 array_unsafe_get
- 2733 PUSHACC3
- 2734 APPLY1
- 2735 ACC1
- 2736 OFFSETINT 1
- 2738 ASSIGN 1
- 2740 ACC0
- 2741 PUSHACC2
- 2742 LEINT
- 2743 BRANCHIF 2728
- 2745 CONST0
- 2746 RETURN 4
- 2748 RESTART
- 2749 GRAB 4
- 2751 CONST0
- 2752 PUSHACC5
- 2753 LTINT
- 2754 BRANCHIF 2782
- 2756 CONST0
- 2757 PUSHACC2
- 2758 LTINT
- 2759 BRANCHIF 2782
- 2761 ACC0
- 2762 VECTLENGTH
- 2763 PUSHACC5
- 2764 PUSHACC3
- 2765 ADDINT
- 2766 GTINT
- 2767 BRANCHIF 2782
- 2769 CONST0
- 2770 PUSHACC4
- 2771 LTINT
- 2772 BRANCHIF 2782
- 2774 ACC2
- 2775 VECTLENGTH
- 2776 PUSHACC5
- 2777 PUSHACC5
- 2778 ADDINT
- 2779 GTINT
- 2780 BRANCHIFNOT 2789
- 2782 GETGLOBAL "Array.blit"
- 2784 PUSHGETGLOBALFIELD Pervasives, 2
- 2787 APPTERM1 6
- 2789 ACC3
- 2790 PUSHACC2
- 2791 LTINT
- 2792 BRANCHIFNOT 2827
- 2794 ACC4
- 2795 OFFSETINT -1
- 2797 PUSHCONST0
- 2798 PUSH
- 2799 BRANCH 2819
- 2801 CHECK_SIGNALS
- 2802 ACC1
- 2803 PUSHACC4
- 2804 ADDINT
- 2805 PUSHACC3
- 2806 C_CALL2 array_unsafe_get
- 2808 PUSHACC2
- 2809 PUSHACC7
- 2810 ADDINT
- 2811 PUSHACC6
- 2812 C_CALL3 array_unsafe_set
- 2814 ACC1
- 2815 OFFSETINT -1
- 2817 ASSIGN 1
- 2819 ACC0
- 2820 PUSHACC2
- 2821 GEINT
- 2822 BRANCHIF 2801
- 2824 CONST0
- 2825 RETURN 7
- 2827 CONST0
- 2828 PUSHACC5
- 2829 OFFSETINT -1
- 2831 PUSH
- 2832 BRANCH 2852
- 2834 CHECK_SIGNALS
- 2835 ACC1
- 2836 PUSHACC4
- 2837 ADDINT
- 2838 PUSHACC3
- 2839 C_CALL2 array_unsafe_get
- 2841 PUSHACC2
- 2842 PUSHACC7
- 2843 ADDINT
- 2844 PUSHACC6
- 2845 C_CALL3 array_unsafe_set
- 2847 ACC1
- 2848 OFFSETINT 1
- 2850 ASSIGN 1
- 2852 ACC0
- 2853 PUSHACC2
- 2854 LEINT
- 2855 BRANCHIF 2834
- 2857 CONST0
- 2858 RETURN 7
- 2860 RESTART
- 2861 GRAB 3
- 2863 CONST0
- 2864 PUSHACC2
- 2865 LTINT
- 2866 BRANCHIF 2881
- 2868 CONST0
- 2869 PUSHACC3
- 2870 LTINT
- 2871 BRANCHIF 2881
- 2873 ACC0
- 2874 VECTLENGTH
- 2875 PUSHACC3
- 2876 PUSHACC3
- 2877 ADDINT
- 2878 GTINT
- 2879 BRANCHIFNOT 2888
- 2881 GETGLOBAL "Array.fill"
- 2883 PUSHGETGLOBALFIELD Pervasives, 2
- 2886 APPTERM1 5
- 2888 ACC1
- 2889 PUSHACC3
- 2890 PUSHACC3
- 2891 ADDINT
- 2892 OFFSETINT -1
- 2894 PUSH
- 2895 BRANCH 2908
- 2897 CHECK_SIGNALS
- 2898 ACC5
- 2899 PUSHACC2
- 2900 PUSHACC4
- 2901 C_CALL3 array_unsafe_set
- 2903 ACC1
- 2904 OFFSETINT 1
- 2906 ASSIGN 1
- 2908 ACC0
- 2909 PUSHACC2
- 2910 LEINT
- 2911 BRANCHIF 2897
- 2913 CONST0
- 2914 RETURN 6
- 2916 RESTART
- 2917 GRAB 2
- 2919 CONST0
- 2920 PUSHACC2
- 2921 LTINT
- 2922 BRANCHIF 2937
- 2924 CONST0
- 2925 PUSHACC3
- 2926 LTINT
- 2927 BRANCHIF 2937
- 2929 ACC0
- 2930 VECTLENGTH
- 2931 PUSHACC3
- 2932 PUSHACC3
- 2933 ADDINT
- 2934 GTINT
- 2935 BRANCHIFNOT 2944
- 2937 GETGLOBAL "Array.sub"
- 2939 PUSHGETGLOBALFIELD Pervasives, 2
- 2942 APPTERM1 4
- 2944 CONST0
- 2945 PUSHACC3
- 2946 EQ
- 2947 BRANCHIFNOT 2952
- 2949 ATOM0
- 2950 RETURN 3
- 2952 ACC1
- 2953 PUSHACC1
- 2954 C_CALL2 array_unsafe_get
- 2956 PUSHACC3
- 2957 C_CALL2 make_vect
- 2959 PUSHCONST1
- 2960 PUSHACC4
- 2961 OFFSETINT -1
- 2963 PUSH
- 2964 BRANCH 2982
- 2966 CHECK_SIGNALS
- 2967 ACC1
- 2968 PUSHACC5
- 2969 ADDINT
- 2970 PUSHACC4
- 2971 C_CALL2 array_unsafe_get
- 2973 PUSHACC2
- 2974 PUSHACC4
- 2975 C_CALL3 array_unsafe_set
- 2977 ACC1
- 2978 OFFSETINT 1
- 2980 ASSIGN 1
- 2982 ACC0
- 2983 PUSHACC2
- 2984 LEINT
- 2985 BRANCHIF 2966
- 2987 CONST0
- 2988 POP 2
- 2990 ACC0
- 2991 RETURN 4
- 2993 ACC0
- 2994 BRANCHIFNOT 3017
- 2996 ACC0
- 2997 GETFIELD0
- 2998 PUSHCONST0
- 2999 PUSHACC1
- 3000 VECTLENGTH
- 3001 GTINT
- 3002 BRANCHIFNOT 3012
- 3004 ENVACC2
- 3005 PUSHCONST0
- 3006 PUSHACC2
- 3007 C_CALL2 array_unsafe_get
- 3009 PUSHENVACC1
- 3010 APPTERM2 4
- 3012 ACC1
- 3013 GETFIELD1
- 3014 PUSHOFFSETCLOSURE0
- 3015 APPTERM1 3
- 3017 ATOM0
- 3018 RETURN 1
- 3020 ACC0
- 3021 PUSHENVACC1
- 3022 CLOSUREREC 2, 2993
- 3026 ACC1
- 3027 PUSHACC1
- 3028 APPTERM1 3
- 3030 CONST0
- 3031 PUSHACC1
- 3032 VECTLENGTH
- 3033 OFFSETINT -1
- 3035 PUSH
- 3036 BRANCH 3056
- 3038 CHECK_SIGNALS
- 3039 ACC1
- 3040 PUSHACC3
- 3041 C_CALL2 array_unsafe_get
- 3043 PUSHENVACC2
- 3044 GETFIELD0
- 3045 PUSHENVACC1
- 3046 C_CALL3 array_unsafe_set
- 3048 ENVACC2
- 3049 OFFSETREF 1
- 3051 ACC1
- 3052 OFFSETINT 1
- 3054 ASSIGN 1
- 3056 ACC0
- 3057 PUSHACC2
- 3058 LEINT
- 3059 BRANCHIF 3038
- 3061 CONST0
- 3062 RETURN 3
- 3064 RESTART
- 3065 GRAB 1
- 3067 ACC1
- 3068 VECTLENGTH
- 3069 PUSHACC1
- 3070 ADDINT
- 3071 RETURN 2
- 3073 RESTART
- 3074 GRAB 1
- 3076 ACC1
- 3077 PUSHCONST0
- 3078 PUSH
- 3079 CLOSURE 0, 3065
- 3082 PUSHGETGLOBALFIELD List, 12
- 3085 APPLY3
- 3086 PUSHACC1
- 3087 PUSHACC1
- 3088 C_CALL2 make_vect
- 3090 PUSHCONST0
- 3091 MAKEBLOCK1 0
- 3093 PUSHACC4
- 3094 PUSHACC1
- 3095 PUSHACC3
- 3096 CLOSURE 2, 3030
- 3099 PUSHGETGLOBALFIELD List, 9
- 3102 APPLY2
- 3103 ACC1
- 3104 RETURN 5
- 3106 RESTART
- 3107 GRAB 1
- 3109 ACC0
- 3110 VECTLENGTH
- 3111 PUSHACC2
- 3112 VECTLENGTH
- 3113 PUSHCONST0
- 3114 PUSHACC2
- 3115 EQ
- 3116 BRANCHIFNOT 3126
- 3118 CONST0
- 3119 PUSHACC1
- 3120 EQ
- 3121 BRANCHIFNOT 3126
- 3123 ATOM0
- 3124 RETURN 4
- 3126 CONST0
- 3127 PUSHCONST0
- 3128 PUSHACC3
- 3129 GTINT
- 3130 BRANCHIFNOT 3135
- 3132 ACC3
- 3133 BRANCH 3136
- 3135 ACC4
- 3136 C_CALL2 array_unsafe_get
- 3138 PUSHACC1
- 3139 PUSHACC3
- 3140 ADDINT
- 3141 C_CALL2 make_vect
- 3143 PUSHCONST0
- 3144 PUSHACC3
- 3145 OFFSETINT -1
- 3147 PUSH
- 3148 BRANCH 3164
- 3150 CHECK_SIGNALS
- 3151 ACC1
- 3152 PUSHACC6
- 3153 C_CALL2 array_unsafe_get
- 3155 PUSHACC2
- 3156 PUSHACC4
- 3157 C_CALL3 array_unsafe_set
- 3159 ACC1
- 3160 OFFSETINT 1
- 3162 ASSIGN 1
- 3164 ACC0
- 3165 PUSHACC2
- 3166 LEINT
- 3167 BRANCHIF 3150
- 3169 CONST0
- 3170 POP 2
- 3172 CONST0
- 3173 PUSHACC2
- 3174 OFFSETINT -1
- 3176 PUSH
- 3177 BRANCH 3195
- 3179 CHECK_SIGNALS
- 3180 ACC1
- 3181 PUSHACC7
- 3182 C_CALL2 array_unsafe_get
- 3184 PUSHACC5
- 3185 PUSHACC3
- 3186 ADDINT
- 3187 PUSHACC4
- 3188 C_CALL3 array_unsafe_set
- 3190 ACC1
- 3191 OFFSETINT 1
- 3193 ASSIGN 1
- 3195 ACC0
- 3196 PUSHACC2
- 3197 LEINT
- 3198 BRANCHIF 3179
- 3200 CONST0
- 3201 POP 2
- 3203 ACC0
- 3204 RETURN 5
- 3206 ACC0
- 3207 VECTLENGTH
- 3208 PUSHCONST0
- 3209 PUSHACC1
- 3210 EQ
- 3211 BRANCHIFNOT 3216
- 3213 ATOM0
- 3214 RETURN 2
- 3216 CONST0
- 3217 PUSHACC2
- 3218 C_CALL2 array_unsafe_get
- 3220 PUSHACC1
- 3221 C_CALL2 make_vect
- 3223 PUSHCONST1
- 3224 PUSHACC2
- 3225 OFFSETINT -1
- 3227 PUSH
- 3228 BRANCH 3244
- 3230 CHECK_SIGNALS
- 3231 ACC1
- 3232 PUSHACC5
- 3233 C_CALL2 array_unsafe_get
- 3235 PUSHACC2
- 3236 PUSHACC4
- 3237 C_CALL3 array_unsafe_set
- 3239 ACC1
- 3240 OFFSETINT 1
- 3242 ASSIGN 1
- 3244 ACC0
- 3245 PUSHACC2
- 3246 LEINT
- 3247 BRANCHIF 3230
- 3249 CONST0
- 3250 POP 2
- 3252 ACC0
- 3253 RETURN 3
- 3255 RESTART
- 3256 GRAB 2
- 3258 ATOM0
- 3259 PUSHACC1
- 3260 C_CALL2 make_vect
- 3262 PUSHCONST0
- 3263 PUSHACC2
- 3264 OFFSETINT -1
- 3266 PUSH
- 3267 BRANCH 3282
- 3269 CHECK_SIGNALS
- 3270 ACC5
- 3271 PUSHACC5
- 3272 C_CALL2 make_vect
- 3274 PUSHACC2
- 3275 PUSHACC4
- 3276 SETVECTITEM
- 3277 ACC1
- 3278 OFFSETINT 1
- 3280 ASSIGN 1
- 3282 ACC0
- 3283 PUSHACC2
- 3284 LEINT
- 3285 BRANCHIF 3269
- 3287 CONST0
- 3288 POP 2
- 3290 ACC0
- 3291 RETURN 4
- 3293 RESTART
- 3294 GRAB 1
- 3296 CONST0
- 3297 PUSHACC1
- 3298 EQ
- 3299 BRANCHIFNOT 3304
- 3301 ATOM0
- 3302 RETURN 2
- 3304 CONST0
- 3305 PUSHACC2
- 3306 APPLY1
- 3307 PUSHACC1
- 3308 C_CALL2 make_vect
- 3310 PUSHCONST1
- 3311 PUSHACC2
- 3312 OFFSETINT -1
- 3314 PUSH
- 3315 BRANCH 3330
- 3317 CHECK_SIGNALS
- 3318 ACC1
- 3319 PUSHACC5
- 3320 APPLY1
- 3321 PUSHACC2
- 3322 PUSHACC4
- 3323 C_CALL3 array_unsafe_set
- 3325 ACC1
- 3326 OFFSETINT 1
- 3328 ASSIGN 1
- 3330 ACC0
- 3331 PUSHACC2
- 3332 LEINT
- 3333 BRANCHIF 3317
- 3335 CONST0
- 3336 POP 2
- 3338 ACC0
- 3339 RETURN 3
- 3341 CLOSURE 0, 3294
- 3344 PUSH
- 3345 CLOSURE 0, 3256
- 3348 PUSH
- 3349 CLOSURE 0, 3206
- 3352 PUSH
- 3353 CLOSURE 0, 3107
- 3356 PUSH
- 3357 CLOSURE 0, 3074
- 3360 PUSHACC0
- 3361 CLOSURE 1, 3020
- 3364 PUSH
- 3365 CLOSURE 0, 2917
- 3368 PUSH
- 3369 CLOSURE 0, 2861
- 3372 PUSH
- 3373 CLOSURE 0, 2749
- 3376 PUSH
- 3377 CLOSURE 0, 2718
- 3380 PUSH
- 3381 CLOSURE 0, 2662
- 3384 PUSH
- 3385 CLOSURE 0, 2630
- 3388 PUSH
- 3389 CLOSURE 0, 2572
- 3392 PUSH
- 3393 CLOSURE 0, 2558
- 3396 PUSH
- 3397 CLOSURE 0, 2505
- 3400 PUSH
- 3401 CLOSURE 0, 2445
- 3404 PUSH
- 3405 CLOSURE 0, 2407
- 3408 PUSHACC0
- 3409 PUSHACC2
- 3410 PUSHACC6
- 3411 PUSHACC 8
- 3413 PUSHACC 10
- 3415 PUSHACC 12
- 3417 PUSHACC 8
- 3419 PUSHACC 10
- 3421 PUSHACC 16
- 3423 PUSHACC 18
- 3425 PUSHACC 24
- 3427 PUSHACC 21
- 3429 PUSHACC 23
- 3431 PUSHACC 26
- 3433 PUSHACC 29
- 3435 PUSHACC 30
- 3437 PUSHACC 32
- 3439 MAKEBLOCK 17, 0
- 3442 POP 17
- 3444 SETGLOBAL Array
- 3446 BRANCH 3456
- 3448 ACC0
- 3449 PUSHENVACC1
- 3450 GETFIELD0
- 3451 ADDINT
- 3452 PUSHENVACC1
- 3453 SETFIELD0
- 3454 RETURN 1
- 3456 CONST2
- 3457 PUSHCONSTINT 200000
- 3459 C_CALL2 make_vect
- 3461 PUSHCONST0
- 3462 MAKEBLOCK1 0
- 3464 PUSHACC1
- 3465 PUSHACC1
- 3466 CLOSURE 1, 3448
- 3469 PUSHGETGLOBALFIELD Array, 11
- 3472 APPLY2
- 3473 CONSTINT 400000
- 3475 PUSHACC1
- 3476 GETFIELD0
- 3477 NEQ
- 3478 BRANCHIFNOT 3485
- 3480 GETGLOBAL Not_found
- 3482 MAKEBLOCK1 0
- 3484 RAISE
- 3485 POP 2
- 3487 ATOM0
- 3488 SETGLOBAL T310-alloc-2
- 3490 STOP
-**)
diff --git a/test/testinterp/t320-gc-1.ml b/test/testinterp/t320-gc-1.ml
deleted file mode 100644
index 4d5d6d966d..0000000000
--- a/test/testinterp/t320-gc-1.ml
+++ /dev/null
@@ -1,1589 +0,0 @@
-open Lib;;
-let rec f n =
- if n <= 0 then []
- else n :: f (n-1)
-in
-let l = f 300 in
-Gc.minor ();
-if List.fold_left (+) 0 l <> 301 * 150 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 746
- 11 RESTART
- 12 GRAB 1
- 14 ACC0
- 15 BRANCHIFNOT 28
- 17 ACC1
- 18 PUSHACC1
- 19 GETFIELD1
- 20 PUSHOFFSETCLOSURE0
- 21 APPLY2
- 22 PUSHACC1
- 23 GETFIELD0
- 24 MAKEBLOCK2 0
- 26 RETURN 2
- 28 ACC1
- 29 RETURN 2
- 31 RESTART
- 32 GRAB 3
- 34 CONST0
- 35 PUSHACC4
- 36 LEINT
- 37 BRANCHIFNOT 42
- 39 CONST0
- 40 RETURN 4
- 42 ACC3
- 43 PUSHACC3
- 44 PUSHACC3
- 45 PUSHACC3
- 46 C_CALL4 caml_input
- 48 PUSHCONST0
- 49 PUSHACC1
- 50 EQ
- 51 BRANCHIFNOT 58
- 53 GETGLOBAL End_of_file
- 55 MAKEBLOCK1 0
- 57 RAISE
- 58 ACC0
- 59 PUSHACC5
- 60 SUBINT
- 61 PUSHACC1
- 62 PUSHACC5
- 63 ADDINT
- 64 PUSHACC4
- 65 PUSHACC4
- 66 PUSHOFFSETCLOSURE0
- 67 APPTERM 4, 9
- 70 ACC0
- 71 C_CALL1 caml_input_scan_line
- 73 PUSHCONST0
- 74 PUSHACC1
- 75 EQ
- 76 BRANCHIFNOT 83
- 78 GETGLOBAL End_of_file
- 80 MAKEBLOCK1 0
- 82 RAISE
- 83 CONST0
- 84 PUSHACC1
- 85 GTINT
- 86 BRANCHIFNOT 107
- 88 ACC0
- 89 OFFSETINT -1
- 91 C_CALL1 create_string
- 93 PUSHACC1
- 94 OFFSETINT -1
- 96 PUSHCONST0
- 97 PUSHACC2
- 98 PUSHACC5
- 99 C_CALL4 caml_input
- 101 ACC2
- 102 C_CALL1 caml_input_char
- 104 ACC0
- 105 RETURN 3
- 107 ACC0
- 108 NEGINT
- 109 C_CALL1 create_string
- 111 PUSHACC1
- 112 NEGINT
- 113 PUSHCONST0
- 114 PUSHACC2
- 115 PUSHACC5
- 116 C_CALL4 caml_input
- 118 CONST0
- 119 PUSHTRAP 130
- 121 ACC6
- 122 PUSHOFFSETCLOSURE0
- 123 APPLY1
- 124 PUSHACC5
- 125 PUSHENVACC1
- 126 APPLY2
- 127 POPTRAP
- 128 RETURN 3
- 130 PUSHGETGLOBAL End_of_file
- 132 PUSHACC1
- 133 GETFIELD0
- 134 EQ
- 135 BRANCHIFNOT 140
- 137 ACC1
- 138 RETURN 4
- 140 ACC0
- 141 RAISE
- 142 ACC0
- 143 C_CALL1 caml_flush
- 145 RETURN 1
- 147 RESTART
- 148 GRAB 1
- 150 ACC1
- 151 PUSHACC1
- 152 C_CALL2 caml_output_char
- 154 RETURN 2
- 156 RESTART
- 157 GRAB 1
- 159 ACC1
- 160 PUSHACC1
- 161 C_CALL2 caml_output_char
- 163 RETURN 2
- 165 RESTART
- 166 GRAB 1
- 168 ACC1
- 169 PUSHACC1
- 170 C_CALL2 caml_output_int
- 172 RETURN 2
- 174 RESTART
- 175 GRAB 1
- 177 ACC1
- 178 PUSHACC1
- 179 C_CALL2 caml_seek_out
- 181 RETURN 2
- 183 ACC0
- 184 C_CALL1 caml_pos_out
- 186 RETURN 1
- 188 ACC0
- 189 C_CALL1 caml_channel_size
- 191 RETURN 1
- 193 RESTART
- 194 GRAB 1
- 196 ACC1
- 197 PUSHACC1
- 198 C_CALL2 caml_set_binary_mode
- 200 RETURN 2
- 202 ACC0
- 203 C_CALL1 caml_input_char
- 205 RETURN 1
- 207 ACC0
- 208 C_CALL1 caml_input_char
- 210 RETURN 1
- 212 ACC0
- 213 C_CALL1 caml_input_int
- 215 RETURN 1
- 217 ACC0
- 218 C_CALL1 input_value
- 220 RETURN 1
- 222 RESTART
- 223 GRAB 1
- 225 ACC1
- 226 PUSHACC1
- 227 C_CALL2 caml_seek_in
- 229 RETURN 2
- 231 ACC0
- 232 C_CALL1 caml_pos_in
- 234 RETURN 1
- 236 ACC0
- 237 C_CALL1 caml_channel_size
- 239 RETURN 1
- 241 ACC0
- 242 C_CALL1 caml_close_channel
- 244 RETURN 1
- 246 RESTART
- 247 GRAB 1
- 249 ACC1
- 250 PUSHACC1
- 251 C_CALL2 caml_set_binary_mode
- 253 RETURN 2
- 255 CONST0
- 256 PUSHENVACC1
- 257 APPLY1
- 258 ACC0
- 259 C_CALL1 sys_exit
- 261 RETURN 1
- 263 CONST0
- 264 PUSHENVACC1
- 265 GETFIELD0
- 266 APPTERM1 2
- 268 CONST0
- 269 PUSHENVACC1
- 270 APPLY1
- 271 CONST0
- 272 PUSHENVACC2
- 273 APPTERM1 2
- 275 ENVACC1
- 276 GETFIELD0
- 277 PUSHACC0
- 278 PUSHACC2
- 279 CLOSURE 2, 268
- 282 PUSHENVACC1
- 283 SETFIELD0
- 284 RETURN 2
- 286 ENVACC1
- 287 C_CALL1 caml_flush
- 289 ENVACC2
- 290 C_CALL1 caml_flush
- 292 RETURN 1
- 294 CONST0
- 295 PUSHENVACC1
- 296 APPLY1
- 297 C_CALL1 float_of_string
- 299 RETURN 1
- 301 CONST0
- 302 PUSHENVACC1
- 303 APPLY1
- 304 C_CALL1 int_of_string
- 306 RETURN 1
- 308 ENVACC2
- 309 C_CALL1 caml_flush
- 311 ENVACC1
- 312 PUSHENVACC3
- 313 APPTERM1 2
- 315 CONSTINT 13
- 317 PUSHENVACC1
- 318 C_CALL2 caml_output_char
- 320 ENVACC1
- 321 C_CALL1 caml_flush
- 323 RETURN 1
- 325 ACC0
- 326 PUSHENVACC1
- 327 PUSHENVACC2
- 328 APPLY2
- 329 CONSTINT 13
- 331 PUSHENVACC1
- 332 C_CALL2 caml_output_char
- 334 ENVACC1
- 335 C_CALL1 caml_flush
- 337 RETURN 1
- 339 ACC0
- 340 PUSHENVACC1
- 341 APPLY1
- 342 PUSHENVACC2
- 343 PUSHENVACC3
- 344 APPTERM2 3
- 346 ACC0
- 347 PUSHENVACC1
- 348 APPLY1
- 349 PUSHENVACC2
- 350 PUSHENVACC3
- 351 APPTERM2 3
- 353 ACC0
- 354 PUSHENVACC1
- 355 PUSHENVACC2
- 356 APPTERM2 3
- 358 ACC0
- 359 PUSHENVACC1
- 360 C_CALL2 caml_output_char
- 362 RETURN 1
- 364 CONSTINT 13
- 366 PUSHENVACC1
- 367 C_CALL2 caml_output_char
- 369 ENVACC1
- 370 C_CALL1 caml_flush
- 372 RETURN 1
- 374 ACC0
- 375 PUSHENVACC1
- 376 PUSHENVACC2
- 377 APPLY2
- 378 CONSTINT 13
- 380 PUSHENVACC1
- 381 C_CALL2 caml_output_char
- 383 RETURN 1
- 385 ACC0
- 386 PUSHENVACC1
- 387 APPLY1
- 388 PUSHENVACC2
- 389 PUSHENVACC3
- 390 APPTERM2 3
- 392 ACC0
- 393 PUSHENVACC1
- 394 APPLY1
- 395 PUSHENVACC2
- 396 PUSHENVACC3
- 397 APPTERM2 3
- 399 ACC0
- 400 PUSHENVACC1
- 401 PUSHENVACC2
- 402 APPTERM2 3
- 404 ACC0
- 405 PUSHENVACC1
- 406 C_CALL2 caml_output_char
- 408 RETURN 1
- 410 RESTART
- 411 GRAB 3
- 413 CONST0
- 414 PUSHACC3
- 415 LTINT
- 416 BRANCHIF 427
- 418 ACC1
- 419 C_CALL1 ml_string_length
- 421 PUSHACC4
- 422 PUSHACC4
- 423 ADDINT
- 424 GTINT
- 425 BRANCHIFNOT 432
- 427 GETGLOBAL "really_input"
- 429 PUSHENVACC1
- 430 APPTERM1 5
- 432 ACC3
- 433 PUSHACC3
- 434 PUSHACC3
- 435 PUSHACC3
- 436 PUSHENVACC2
- 437 APPTERM 4, 8
- 440 RESTART
- 441 GRAB 3
- 443 CONST0
- 444 PUSHACC3
- 445 LTINT
- 446 BRANCHIF 457
- 448 ACC1
- 449 C_CALL1 ml_string_length
- 451 PUSHACC4
- 452 PUSHACC4
- 453 ADDINT
- 454 GTINT
- 455 BRANCHIFNOT 462
- 457 GETGLOBAL "input"
- 459 PUSHENVACC1
- 460 APPTERM1 5
- 462 ACC3
- 463 PUSHACC3
- 464 PUSHACC3
- 465 PUSHACC3
- 466 C_CALL4 caml_input
- 468 RETURN 4
- 470 ACC0
- 471 PUSHCONST0
- 472 PUSHGETGLOBAL <0>(0, <0>(6, 0))
- 474 PUSHENVACC1
- 475 APPTERM3 4
- 477 ACC0
- 478 PUSHCONST0
- 479 PUSHGETGLOBAL <0>(0, <0>(7, 0))
- 481 PUSHENVACC1
- 482 APPTERM3 4
- 484 RESTART
- 485 GRAB 2
- 487 ACC1
- 488 PUSHACC1
- 489 PUSHACC4
- 490 C_CALL3 sys_open
- 492 C_CALL1 caml_open_descriptor
- 494 RETURN 3
- 496 ACC0
- 497 C_CALL1 caml_flush
- 499 ACC0
- 500 C_CALL1 caml_close_channel
- 502 RETURN 1
- 504 RESTART
- 505 GRAB 1
- 507 CONST0
- 508 PUSHACC2
- 509 PUSHACC2
- 510 C_CALL3 output_value
- 512 RETURN 2
- 514 RESTART
- 515 GRAB 3
- 517 CONST0
- 518 PUSHACC3
- 519 LTINT
- 520 BRANCHIF 531
- 522 ACC1
- 523 C_CALL1 ml_string_length
- 525 PUSHACC4
- 526 PUSHACC4
- 527 ADDINT
- 528 GTINT
- 529 BRANCHIFNOT 536
- 531 GETGLOBAL "output"
- 533 PUSHENVACC1
- 534 APPTERM1 5
- 536 ACC3
- 537 PUSHACC3
- 538 PUSHACC3
- 539 PUSHACC3
- 540 C_CALL4 caml_output
- 542 RETURN 4
- 544 RESTART
- 545 GRAB 1
- 547 ACC1
- 548 C_CALL1 ml_string_length
- 550 PUSHCONST0
- 551 PUSHACC3
- 552 PUSHACC3
- 553 C_CALL4 caml_output
- 555 RETURN 2
- 557 ACC0
- 558 PUSHCONSTINT 438
- 560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0))))
- 562 PUSHENVACC1
- 563 APPTERM3 4
- 565 ACC0
- 566 PUSHCONSTINT 438
- 568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0))))
- 570 PUSHENVACC1
- 571 APPTERM3 4
- 573 RESTART
- 574 GRAB 2
- 576 ACC1
- 577 PUSHACC1
- 578 PUSHACC4
- 579 C_CALL3 sys_open
- 581 C_CALL1 caml_open_descriptor
- 583 RETURN 3
- 585 ACC0
- 586 PUSHGETGLOBAL "%.12g"
- 588 C_CALL2 format_float
- 590 RETURN 1
- 592 ACC0
- 593 PUSHGETGLOBAL "%d"
- 595 C_CALL2 format_int
- 597 RETURN 1
- 599 GETGLOBAL "false"
- 601 PUSHACC1
- 602 C_CALL2 string_equal
- 604 BRANCHIFNOT 609
- 606 CONST0
- 607 RETURN 1
- 609 GETGLOBAL "true"
- 611 PUSHACC1
- 612 C_CALL2 string_equal
- 614 BRANCHIFNOT 619
- 616 CONST1
- 617 RETURN 1
- 619 GETGLOBAL "bool_of_string"
- 621 PUSHENVACC1
- 622 APPTERM1 2
- 624 ACC0
- 625 BRANCHIFNOT 631
- 627 GETGLOBAL "true"
- 629 RETURN 1
- 631 GETGLOBAL "false"
- 633 RETURN 1
- 635 CONST0
- 636 PUSHACC1
- 637 LTINT
- 638 BRANCHIF 646
- 640 CONSTINT 255
- 642 PUSHACC1
- 643 GTINT
- 644 BRANCHIFNOT 651
- 646 GETGLOBAL "char_of_int"
- 648 PUSHENVACC1
- 649 APPTERM1 2
- 651 ACC0
- 652 RETURN 1
- 654 RESTART
- 655 GRAB 1
- 657 ACC0
- 658 C_CALL1 ml_string_length
- 660 PUSHACC2
- 661 C_CALL1 ml_string_length
- 663 PUSHACC0
- 664 PUSHACC2
- 665 ADDINT
- 666 C_CALL1 create_string
- 668 PUSHACC2
- 669 PUSHCONST0
- 670 PUSHACC2
- 671 PUSHCONST0
- 672 PUSHACC7
- 673 C_CALL5 blit_string
- 675 ACC1
- 676 PUSHACC3
- 677 PUSHACC2
- 678 PUSHCONST0
- 679 PUSHACC 8
- 681 C_CALL5 blit_string
- 683 ACC0
- 684 RETURN 5
- 686 CONSTINT -1
- 688 PUSHACC1
- 689 XORINT
- 690 RETURN 1
- 692 CONST0
- 693 PUSHACC1
- 694 GEINT
- 695 BRANCHIFNOT 700
- 697 ACC0
- 698 RETURN 1
- 700 ACC0
- 701 NEGINT
- 702 RETURN 1
- 704 RESTART
- 705 GRAB 1
- 707 ACC1
- 708 PUSHACC1
- 709 C_CALL2 greaterequal
- 711 BRANCHIFNOT 716
- 713 ACC0
- 714 RETURN 2
- 716 ACC1
- 717 RETURN 2
- 719 RESTART
- 720 GRAB 1
- 722 ACC1
- 723 PUSHACC1
- 724 C_CALL2 lessequal
- 726 BRANCHIFNOT 731
- 728 ACC0
- 729 RETURN 2
- 731 ACC1
- 732 RETURN 2
- 734 ACC0
- 735 PUSHGETGLOBAL Invalid_argument
- 737 MAKEBLOCK2 0
- 739 RAISE
- 740 ACC0
- 741 PUSHGETGLOBAL Failure
- 743 MAKEBLOCK2 0
- 745 RAISE
- 746 CLOSURE 0, 740
- 749 PUSH
- 750 CLOSURE 0, 734
- 753 PUSHGETGLOBAL "Pervasives.Exit"
- 755 MAKEBLOCK1 0
- 757 PUSHGETGLOBAL "Pervasives.Assert_failure"
- 759 MAKEBLOCK1 0
- 761 PUSH
- 762 CLOSURE 0, 720
- 765 PUSH
- 766 CLOSURE 0, 705
- 769 PUSH
- 770 CLOSURE 0, 692
- 773 PUSH
- 774 CLOSURE 0, 686
- 777 PUSHCONST0
- 778 PUSHCONSTINT 31
- 780 PUSHCONST1
- 781 LSLINT
- 782 EQ
- 783 BRANCHIFNOT 789
- 785 CONSTINT 30
- 787 BRANCH 791
- 789 CONSTINT 62
- 791 PUSHCONST1
- 792 LSLINT
- 793 PUSHACC0
- 794 OFFSETINT -1
- 796 PUSH
- 797 CLOSURE 0, 655
- 800 PUSHACC 9
- 802 CLOSURE 1, 635
- 805 PUSH
- 806 CLOSURE 0, 624
- 809 PUSHACC 11
- 811 CLOSURE 1, 599
- 814 PUSH
- 815 CLOSURE 0, 592
- 818 PUSH
- 819 CLOSURE 0, 585
- 822 PUSH
- 823 CLOSUREREC 0, 12
- 827 CONST0
- 828 C_CALL1 caml_open_descriptor
- 830 PUSHCONST1
- 831 C_CALL1 caml_open_descriptor
- 833 PUSHCONST2
- 834 C_CALL1 caml_open_descriptor
- 836 PUSH
- 837 CLOSURE 0, 574
- 840 PUSHACC0
- 841 CLOSURE 1, 565
- 844 PUSHACC1
- 845 CLOSURE 1, 557
- 848 PUSH
- 849 CLOSURE 0, 545
- 852 PUSHACC 22
- 854 CLOSURE 1, 515
- 857 PUSH
- 858 CLOSURE 0, 505
- 861 PUSH
- 862 CLOSURE 0, 496
- 865 PUSH
- 866 CLOSURE 0, 485
- 869 PUSHACC0
- 870 CLOSURE 1, 477
- 873 PUSHACC1
- 874 CLOSURE 1, 470
- 877 PUSHACC 28
- 879 CLOSURE 1, 441
- 882 PUSH
- 883 CLOSUREREC 0, 32
- 887 ACC0
- 888 PUSHACC 31
- 890 CLOSURE 2, 411
- 893 PUSHACC 22
- 895 CLOSUREREC 1, 70
- 899 ACC 15
- 901 CLOSURE 1, 404
- 904 PUSHACC 11
- 906 PUSHACC 17
- 908 CLOSURE 2, 399
- 911 PUSHACC 12
- 913 PUSHACC 18
- 915 PUSHACC 23
- 917 CLOSURE 3, 392
- 920 PUSHACC 13
- 922 PUSHACC 19
- 924 PUSHACC 23
- 926 CLOSURE 3, 385
- 929 PUSHACC 14
- 931 PUSHACC 20
- 933 CLOSURE 2, 374
- 936 PUSHACC 20
- 938 CLOSURE 1, 364
- 941 PUSHACC 20
- 943 CLOSURE 1, 358
- 946 PUSHACC 17
- 948 PUSHACC 22
- 950 CLOSURE 2, 353
- 953 PUSHACC 18
- 955 PUSHACC 23
- 957 PUSHACC 29
- 959 CLOSURE 3, 346
- 962 PUSHACC 19
- 964 PUSHACC 24
- 966 PUSHACC 29
- 968 CLOSURE 3, 339
- 971 PUSHACC 20
- 973 PUSHACC 25
- 975 CLOSURE 2, 325
- 978 PUSHACC 25
- 980 CLOSURE 1, 315
- 983 PUSHACC 12
- 985 PUSHACC 28
- 987 PUSHACC 30
- 989 CLOSURE 3, 308
- 992 PUSHACC0
- 993 CLOSURE 1, 301
- 996 PUSHACC1
- 997 CLOSURE 1, 294
- 1000 PUSHACC 29
- 1002 PUSHACC 31
- 1004 CLOSURE 2, 286
- 1007 MAKEBLOCK1 0
- 1009 PUSHACC0
- 1010 CLOSURE 1, 275
- 1013 PUSHACC1
- 1014 CLOSURE 1, 263
- 1017 PUSHACC0
- 1018 CLOSURE 1, 255
- 1021 PUSHACC1
- 1022 PUSHACC 22
- 1024 PUSHACC4
- 1025 PUSHACC3
- 1026 PUSH
- 1027 CLOSURE 0, 247
- 1030 PUSH
- 1031 CLOSURE 0, 241
- 1034 PUSH
- 1035 CLOSURE 0, 236
- 1038 PUSH
- 1039 CLOSURE 0, 231
- 1042 PUSH
- 1043 CLOSURE 0, 223
- 1046 PUSH
- 1047 CLOSURE 0, 217
- 1050 PUSH
- 1051 CLOSURE 0, 212
- 1054 PUSH
- 1055 CLOSURE 0, 207
- 1058 PUSHACC 32
- 1060 PUSHACC 35
- 1062 PUSHACC 33
- 1064 PUSH
- 1065 CLOSURE 0, 202
- 1068 PUSHACC 41
- 1070 PUSHACC 40
- 1072 PUSHACC 42
- 1074 PUSH
- 1075 CLOSURE 0, 194
- 1078 PUSHACC 46
- 1080 PUSH
- 1081 CLOSURE 0, 188
- 1084 PUSH
- 1085 CLOSURE 0, 183
- 1088 PUSH
- 1089 CLOSURE 0, 175
- 1092 PUSHACC 51
- 1094 PUSH
- 1095 CLOSURE 0, 166
- 1098 PUSH
- 1099 CLOSURE 0, 157
- 1102 PUSHACC 55
- 1104 PUSHACC 57
- 1106 PUSH
- 1107 CLOSURE 0, 148
- 1110 PUSH
- 1111 CLOSURE 0, 142
- 1114 PUSHACC 63
- 1116 PUSHACC 62
- 1118 PUSHACC 64
- 1120 PUSHACC 38
- 1122 PUSHACC 40
- 1124 PUSHACC 42
- 1126 PUSHACC 44
- 1128 PUSHACC 46
- 1130 PUSHACC 48
- 1132 PUSHACC 50
- 1134 PUSHACC 52
- 1136 PUSHACC 54
- 1138 PUSHACC 56
- 1140 PUSHACC 58
- 1142 PUSHACC 60
- 1144 PUSHACC 62
- 1146 PUSHACC 64
- 1148 PUSHACC 66
- 1150 PUSHACC 82
- 1152 PUSHACC 84
- 1154 PUSHACC 86
- 1156 PUSHACC 88
- 1158 PUSHACC 90
- 1160 PUSHACC 92
- 1162 PUSHACC 94
- 1164 PUSHACC 96
- 1166 PUSHACC 98
- 1168 PUSHACC 100
- 1170 PUSHACC 104
- 1172 PUSHACC 104
- 1174 PUSHACC 104
- 1176 PUSHACC 108
- 1178 PUSHACC 110
- 1180 PUSHACC 112
- 1182 PUSHACC 117
- 1184 PUSHACC 117
- 1186 PUSHACC 117
- 1188 PUSHACC 117
- 1190 MAKEBLOCK 69, 0
- 1193 POP 53
- 1195 SETGLOBAL Pervasives
- 1197 BRANCH 2177
- 1199 RESTART
- 1200 GRAB 1
- 1202 ACC1
- 1203 BRANCHIFNOT 1213
- 1205 ACC1
- 1206 GETFIELD1
- 1207 PUSHACC1
- 1208 OFFSETINT 1
- 1210 PUSHOFFSETCLOSURE0
- 1211 APPTERM2 4
- 1213 ACC0
- 1214 RETURN 2
- 1216 RESTART
- 1217 GRAB 1
- 1219 ACC0
- 1220 BRANCHIFNOT 1251
- 1222 CONST0
- 1223 PUSHACC2
- 1224 EQ
- 1225 BRANCHIFNOT 1231
- 1227 ACC0
- 1228 GETFIELD0
- 1229 RETURN 2
- 1231 CONST0
- 1232 PUSHACC2
- 1233 GTINT
- 1234 BRANCHIFNOT 1244
- 1236 ACC1
- 1237 OFFSETINT -1
- 1239 PUSHACC1
- 1240 GETFIELD1
- 1241 PUSHOFFSETCLOSURE0
- 1242 APPTERM2 4
- 1244 GETGLOBAL "List.nth"
- 1246 PUSHGETGLOBALFIELD Pervasives, 2
- 1249 APPTERM1 3
- 1251 GETGLOBAL "nth"
- 1253 PUSHGETGLOBALFIELD Pervasives, 3
- 1256 APPTERM1 3
- 1258 RESTART
- 1259 GRAB 1
- 1261 ACC0
- 1262 BRANCHIFNOT 1274
- 1264 ACC1
- 1265 PUSHACC1
- 1266 GETFIELD0
- 1267 MAKEBLOCK2 0
- 1269 PUSHACC1
- 1270 GETFIELD1
- 1271 PUSHOFFSETCLOSURE0
- 1272 APPTERM2 4
- 1274 ACC1
- 1275 RETURN 2
- 1277 ACC0
- 1278 BRANCHIFNOT 1291
- 1280 ACC0
- 1281 GETFIELD1
- 1282 PUSHOFFSETCLOSURE0
- 1283 APPLY1
- 1284 PUSHACC1
- 1285 GETFIELD0
- 1286 PUSHGETGLOBALFIELD Pervasives, 16
- 1289 APPTERM2 3
- 1291 RETURN 1
- 1293 RESTART
- 1294 GRAB 1
- 1296 ACC1
- 1297 BRANCHIFNOT 1313
- 1299 ACC1
- 1300 GETFIELD0
- 1301 PUSHACC1
- 1302 APPLY1
- 1303 PUSHACC2
- 1304 GETFIELD1
- 1305 PUSHACC2
- 1306 PUSHOFFSETCLOSURE0
- 1307 APPLY2
- 1308 PUSHACC1
- 1309 MAKEBLOCK2 0
- 1311 POP 1
- 1313 RETURN 2
- 1315 RESTART
- 1316 GRAB 1
- 1318 ACC1
- 1319 BRANCHIFNOT 1331
- 1321 ACC1
- 1322 GETFIELD0
- 1323 PUSHACC1
- 1324 APPLY1
- 1325 ACC1
- 1326 GETFIELD1
- 1327 PUSHACC1
- 1328 PUSHOFFSETCLOSURE0
- 1329 APPTERM2 4
- 1331 RETURN 2
- 1333 RESTART
- 1334 GRAB 2
- 1336 ACC2
- 1337 BRANCHIFNOT 1350
- 1339 ACC2
- 1340 GETFIELD1
- 1341 PUSHACC3
- 1342 GETFIELD0
- 1343 PUSHACC3
- 1344 PUSHACC3
- 1345 APPLY2
- 1346 PUSHACC2
- 1347 PUSHOFFSETCLOSURE0
- 1348 APPTERM3 6
- 1350 ACC1
- 1351 RETURN 3
- 1353 RESTART
- 1354 GRAB 2
- 1356 ACC1
- 1357 BRANCHIFNOT 1370
- 1359 ACC2
- 1360 PUSHACC2
- 1361 GETFIELD1
- 1362 PUSHACC2
- 1363 PUSHOFFSETCLOSURE0
- 1364 APPLY3
- 1365 PUSHACC2
- 1366 GETFIELD0
- 1367 PUSHACC2
- 1368 APPTERM2 5
- 1370 ACC2
- 1371 RETURN 3
- 1373 RESTART
- 1374 GRAB 2
- 1376 ACC1
- 1377 BRANCHIFNOT 1400
- 1379 ACC2
- 1380 BRANCHIFNOT 1407
- 1382 ACC2
- 1383 GETFIELD0
- 1384 PUSHACC2
- 1385 GETFIELD0
- 1386 PUSHACC2
- 1387 APPLY2
- 1388 PUSHACC3
- 1389 GETFIELD1
- 1390 PUSHACC3
- 1391 GETFIELD1
- 1392 PUSHACC3
- 1393 PUSHOFFSETCLOSURE0
- 1394 APPLY3
- 1395 PUSHACC1
- 1396 MAKEBLOCK2 0
- 1398 RETURN 4
- 1400 ACC2
- 1401 BRANCHIFNOT 1405
- 1403 BRANCH 1407
- 1405 RETURN 3
- 1407 GETGLOBAL "List.map2"
- 1409 PUSHGETGLOBALFIELD Pervasives, 2
- 1412 APPTERM1 4
- 1414 RESTART
- 1415 GRAB 2
- 1417 ACC1
- 1418 BRANCHIFNOT 1437
- 1420 ACC2
- 1421 BRANCHIFNOT 1444
- 1423 ACC2
- 1424 GETFIELD0
- 1425 PUSHACC2
- 1426 GETFIELD0
- 1427 PUSHACC2
- 1428 APPLY2
- 1429 ACC2
- 1430 GETFIELD1
- 1431 PUSHACC2
- 1432 GETFIELD1
- 1433 PUSHACC2
- 1434 PUSHOFFSETCLOSURE0
- 1435 APPTERM3 6
- 1437 ACC2
- 1438 BRANCHIFNOT 1442
- 1440 BRANCH 1444
- 1442 RETURN 3
- 1444 GETGLOBAL "List.iter2"
- 1446 PUSHGETGLOBALFIELD Pervasives, 2
- 1449 APPTERM1 4
- 1451 RESTART
- 1452 GRAB 3
- 1454 ACC2
- 1455 BRANCHIFNOT 1476
- 1457 ACC3
- 1458 BRANCHIFNOT 1482
- 1460 ACC3
- 1461 GETFIELD1
- 1462 PUSHACC3
- 1463 GETFIELD1
- 1464 PUSHACC5
- 1465 GETFIELD0
- 1466 PUSHACC5
- 1467 GETFIELD0
- 1468 PUSHACC5
- 1469 PUSHACC5
- 1470 APPLY3
- 1471 PUSHACC3
- 1472 PUSHOFFSETCLOSURE0
- 1473 APPTERM 4, 8
- 1476 ACC3
- 1477 BRANCHIF 1482
- 1479 ACC1
- 1480 RETURN 4
- 1482 GETGLOBAL "List.fold_left2"
- 1484 PUSHGETGLOBALFIELD Pervasives, 2
- 1487 APPTERM1 5
- 1489 RESTART
- 1490 GRAB 3
- 1492 ACC1
- 1493 BRANCHIFNOT 1516
- 1495 ACC2
- 1496 BRANCHIFNOT 1522
- 1498 PUSH_RETADDR 1509
- 1500 ACC6
- 1501 PUSHACC6
- 1502 GETFIELD1
- 1503 PUSHACC6
- 1504 GETFIELD1
- 1505 PUSHACC6
- 1506 PUSHOFFSETCLOSURE0
- 1507 APPLY 4
- 1509 PUSHACC3
- 1510 GETFIELD0
- 1511 PUSHACC3
- 1512 GETFIELD0
- 1513 PUSHACC3
- 1514 APPTERM3 7
- 1516 ACC2
- 1517 BRANCHIF 1522
- 1519 ACC3
- 1520 RETURN 4
- 1522 GETGLOBAL "List.fold_right2"
- 1524 PUSHGETGLOBALFIELD Pervasives, 2
- 1527 APPTERM1 5
- 1529 RESTART
- 1530 GRAB 1
- 1532 ACC1
- 1533 BRANCHIFNOT 1549
- 1535 ACC1
- 1536 GETFIELD0
- 1537 PUSHACC1
- 1538 APPLY1
- 1539 BRANCHIFNOT 1547
- 1541 ACC1
- 1542 GETFIELD1
- 1543 PUSHACC1
- 1544 PUSHOFFSETCLOSURE0
- 1545 APPTERM2 4
- 1547 RETURN 2
- 1549 CONST1
- 1550 RETURN 2
- 1552 RESTART
- 1553 GRAB 1
- 1555 ACC1
- 1556 BRANCHIFNOT 1570
- 1558 ACC1
- 1559 GETFIELD0
- 1560 PUSHACC1
- 1561 APPLY1
- 1562 BRANCHIF 1570
- 1564 ACC1
- 1565 GETFIELD1
- 1566 PUSHACC1
- 1567 PUSHOFFSETCLOSURE0
- 1568 APPTERM2 4
- 1570 RETURN 2
- 1572 RESTART
- 1573 GRAB 2
- 1575 ACC1
- 1576 BRANCHIFNOT 1599
- 1578 ACC2
- 1579 BRANCHIFNOT 1605
- 1581 ACC2
- 1582 GETFIELD0
- 1583 PUSHACC2
- 1584 GETFIELD0
- 1585 PUSHACC2
- 1586 APPLY2
- 1587 BRANCHIFNOT 1597
- 1589 ACC2
- 1590 GETFIELD1
- 1591 PUSHACC2
- 1592 GETFIELD1
- 1593 PUSHACC2
- 1594 PUSHOFFSETCLOSURE0
- 1595 APPTERM3 6
- 1597 RETURN 3
- 1599 ACC2
- 1600 BRANCHIF 1605
- 1602 CONST1
- 1603 RETURN 3
- 1605 GETGLOBAL "List.for_all2"
- 1607 PUSHGETGLOBALFIELD Pervasives, 2
- 1610 APPTERM1 4
- 1612 RESTART
- 1613 GRAB 2
- 1615 ACC1
- 1616 BRANCHIFNOT 1639
- 1618 ACC2
- 1619 BRANCHIFNOT 1646
- 1621 ACC2
- 1622 GETFIELD0
- 1623 PUSHACC2
- 1624 GETFIELD0
- 1625 PUSHACC2
- 1626 APPLY2
- 1627 BRANCHIF 1637
- 1629 ACC2
- 1630 GETFIELD1
- 1631 PUSHACC2
- 1632 GETFIELD1
- 1633 PUSHACC2
- 1634 PUSHOFFSETCLOSURE0
- 1635 APPTERM3 6
- 1637 RETURN 3
- 1639 ACC2
- 1640 BRANCHIFNOT 1644
- 1642 BRANCH 1646
- 1644 RETURN 3
- 1646 GETGLOBAL "List.exists2"
- 1648 PUSHGETGLOBALFIELD Pervasives, 2
- 1651 APPTERM1 4
- 1653 RESTART
- 1654 GRAB 1
- 1656 ACC1
- 1657 BRANCHIFNOT 1672
- 1659 ACC0
- 1660 PUSHACC2
- 1661 GETFIELD0
- 1662 C_CALL2 equal
- 1664 BRANCHIF 1672
- 1666 ACC1
- 1667 GETFIELD1
- 1668 PUSHACC1
- 1669 PUSHOFFSETCLOSURE0
- 1670 APPTERM2 4
- 1672 RETURN 2
- 1674 RESTART
- 1675 GRAB 1
- 1677 ACC1
- 1678 BRANCHIFNOT 1692
- 1680 ACC0
- 1681 PUSHACC2
- 1682 GETFIELD0
- 1683 EQ
- 1684 BRANCHIF 1692
- 1686 ACC1
- 1687 GETFIELD1
- 1688 PUSHACC1
- 1689 PUSHOFFSETCLOSURE0
- 1690 APPTERM2 4
- 1692 RETURN 2
- 1694 RESTART
- 1695 GRAB 1
- 1697 ACC1
- 1698 BRANCHIFNOT 1719
- 1700 ACC1
- 1701 GETFIELD0
- 1702 PUSHACC1
- 1703 PUSHACC1
- 1704 GETFIELD0
- 1705 C_CALL2 equal
- 1707 BRANCHIFNOT 1713
- 1709 ACC0
- 1710 GETFIELD1
- 1711 RETURN 3
- 1713 ACC2
- 1714 GETFIELD1
- 1715 PUSHACC2
- 1716 PUSHOFFSETCLOSURE0
- 1717 APPTERM2 5
- 1719 GETGLOBAL Not_found
- 1721 MAKEBLOCK1 0
- 1723 RAISE
- 1724 RESTART
- 1725 GRAB 1
- 1727 ACC1
- 1728 BRANCHIFNOT 1748
- 1730 ACC1
- 1731 GETFIELD0
- 1732 PUSHACC1
- 1733 PUSHACC1
- 1734 GETFIELD0
- 1735 EQ
- 1736 BRANCHIFNOT 1742
- 1738 ACC0
- 1739 GETFIELD1
- 1740 RETURN 3
- 1742 ACC2
- 1743 GETFIELD1
- 1744 PUSHACC2
- 1745 PUSHOFFSETCLOSURE0
- 1746 APPTERM2 5
- 1748 GETGLOBAL Not_found
- 1750 MAKEBLOCK1 0
- 1752 RAISE
- 1753 RESTART
- 1754 GRAB 1
- 1756 ACC1
- 1757 BRANCHIFNOT 1773
- 1759 ACC0
- 1760 PUSHACC2
- 1761 GETFIELD0
- 1762 GETFIELD0
- 1763 C_CALL2 equal
- 1765 BRANCHIF 1773
- 1767 ACC1
- 1768 GETFIELD1
- 1769 PUSHACC1
- 1770 PUSHOFFSETCLOSURE0
- 1771 APPTERM2 4
- 1773 RETURN 2
- 1775 RESTART
- 1776 GRAB 1
- 1778 ACC1
- 1779 BRANCHIFNOT 1794
- 1781 ACC0
- 1782 PUSHACC2
- 1783 GETFIELD0
- 1784 GETFIELD0
- 1785 EQ
- 1786 BRANCHIF 1794
- 1788 ACC1
- 1789 GETFIELD1
- 1790 PUSHACC1
- 1791 PUSHOFFSETCLOSURE0
- 1792 APPTERM2 4
- 1794 RETURN 2
- 1796 RESTART
- 1797 GRAB 1
- 1799 ACC1
- 1800 BRANCHIFNOT 1825
- 1802 ACC1
- 1803 GETFIELD0
- 1804 PUSHACC2
- 1805 GETFIELD1
- 1806 PUSHACC2
- 1807 PUSHACC2
- 1808 GETFIELD0
- 1809 C_CALL2 equal
- 1811 BRANCHIFNOT 1816
- 1813 ACC0
- 1814 RETURN 4
- 1816 ACC0
- 1817 PUSHACC3
- 1818 PUSHOFFSETCLOSURE0
- 1819 APPLY2
- 1820 PUSHACC2
- 1821 MAKEBLOCK2 0
- 1823 POP 2
- 1825 RETURN 2
- 1827 RESTART
- 1828 GRAB 1
- 1830 ACC1
- 1831 BRANCHIFNOT 1855
- 1833 ACC1
- 1834 GETFIELD0
- 1835 PUSHACC2
- 1836 GETFIELD1
- 1837 PUSHACC2
- 1838 PUSHACC2
- 1839 GETFIELD0
- 1840 EQ
- 1841 BRANCHIFNOT 1846
- 1843 ACC0
- 1844 RETURN 4
- 1846 ACC0
- 1847 PUSHACC3
- 1848 PUSHOFFSETCLOSURE0
- 1849 APPLY2
- 1850 PUSHACC2
- 1851 MAKEBLOCK2 0
- 1853 POP 2
- 1855 RETURN 2
- 1857 RESTART
- 1858 GRAB 1
- 1860 ACC1
- 1861 BRANCHIFNOT 1879
- 1863 ACC1
- 1864 GETFIELD0
- 1865 PUSHACC0
- 1866 PUSHACC2
- 1867 APPLY1
- 1868 BRANCHIFNOT 1873
- 1870 ACC0
- 1871 RETURN 3
- 1873 ACC2
- 1874 GETFIELD1
- 1875 PUSHACC2
- 1876 PUSHOFFSETCLOSURE0
- 1877 APPTERM2 5
- 1879 GETGLOBAL Not_found
- 1881 MAKEBLOCK1 0
- 1883 RAISE
- 1884 RESTART
- 1885 GRAB 2
- 1887 ACC2
- 1888 BRANCHIFNOT 1917
- 1890 ACC2
- 1891 GETFIELD0
- 1892 PUSHACC3
- 1893 GETFIELD1
- 1894 PUSHACC1
- 1895 PUSHENVACC2
- 1896 APPLY1
- 1897 BRANCHIFNOT 1908
- 1899 ACC0
- 1900 PUSHACC4
- 1901 PUSHACC4
- 1902 PUSHACC4
- 1903 MAKEBLOCK2 0
- 1905 PUSHOFFSETCLOSURE0
- 1906 APPTERM3 8
- 1908 ACC0
- 1909 PUSHACC4
- 1910 PUSHACC3
- 1911 MAKEBLOCK2 0
- 1913 PUSHACC4
- 1914 PUSHOFFSETCLOSURE0
- 1915 APPTERM3 8
- 1917 ACC1
- 1918 PUSHENVACC1
- 1919 APPLY1
- 1920 PUSHACC1
- 1921 PUSHENVACC1
- 1922 APPLY1
- 1923 MAKEBLOCK2 0
- 1925 RETURN 3
- 1927 RESTART
- 1928 GRAB 1
- 1930 ACC0
- 1931 PUSHENVACC1
- 1932 CLOSUREREC 2, 1885
- 1936 ACC2
- 1937 PUSHCONST0
- 1938 PUSHCONST0
- 1939 PUSHACC3
- 1940 APPTERM3 6
- 1942 ACC0
- 1943 BRANCHIFNOT 1967
- 1945 ACC0
- 1946 GETFIELD0
- 1947 PUSHACC1
- 1948 GETFIELD1
- 1949 PUSHOFFSETCLOSURE0
- 1950 APPLY1
- 1951 PUSHACC0
- 1952 GETFIELD1
- 1953 PUSHACC2
- 1954 GETFIELD1
- 1955 MAKEBLOCK2 0
- 1957 PUSHACC1
- 1958 GETFIELD0
- 1959 PUSHACC3
- 1960 GETFIELD0
- 1961 MAKEBLOCK2 0
- 1963 MAKEBLOCK2 0
- 1965 RETURN 3
- 1967 GETGLOBAL <0>(0, 0)
- 1969 RETURN 1
- 1971 RESTART
- 1972 GRAB 1
- 1974 ACC0
- 1975 BRANCHIFNOT 1996
- 1977 ACC1
- 1978 BRANCHIFNOT 2003
- 1980 ACC1
- 1981 GETFIELD1
- 1982 PUSHACC1
- 1983 GETFIELD1
- 1984 PUSHOFFSETCLOSURE0
- 1985 APPLY2
- 1986 PUSHACC2
- 1987 GETFIELD0
- 1988 PUSHACC2
- 1989 GETFIELD0
- 1990 MAKEBLOCK2 0
- 1992 MAKEBLOCK2 0
- 1994 RETURN 2
- 1996 ACC1
- 1997 BRANCHIFNOT 2001
- 1999 BRANCH 2003
- 2001 RETURN 2
- 2003 GETGLOBAL "List.combine"
- 2005 PUSHGETGLOBALFIELD Pervasives, 2
- 2008 APPTERM1 3
- 2010 RESTART
- 2011 GRAB 1
- 2013 ACC1
- 2014 BRANCHIFNOT 2038
- 2016 ACC1
- 2017 GETFIELD0
- 2018 PUSHACC2
- 2019 GETFIELD1
- 2020 PUSHACC1
- 2021 PUSHENVACC2
- 2022 APPLY1
- 2023 BRANCHIFNOT 2033
- 2025 ACC0
- 2026 PUSHACC3
- 2027 PUSHACC3
- 2028 MAKEBLOCK2 0
- 2030 PUSHOFFSETCLOSURE0
- 2031 APPTERM2 6
- 2033 ACC0
- 2034 PUSHACC3
- 2035 PUSHOFFSETCLOSURE0
- 2036 APPTERM2 6
- 2038 ACC0
- 2039 PUSHENVACC1
- 2040 APPTERM1 3
- 2042 ACC0
- 2043 PUSHENVACC1
- 2044 CLOSUREREC 2, 2011
- 2048 CONST0
- 2049 PUSHACC1
- 2050 APPTERM1 3
- 2052 RESTART
- 2053 GRAB 2
- 2055 ACC1
- 2056 BRANCHIFNOT 2077
- 2058 ACC2
- 2059 BRANCHIFNOT 2084
- 2061 ACC2
- 2062 GETFIELD1
- 2063 PUSHACC2
- 2064 GETFIELD1
- 2065 PUSHACC2
- 2066 PUSHACC5
- 2067 GETFIELD0
- 2068 PUSHACC5
- 2069 GETFIELD0
- 2070 PUSHENVACC1
- 2071 APPLY2
- 2072 MAKEBLOCK2 0
- 2074 PUSHOFFSETCLOSURE0
- 2075 APPTERM3 6
- 2077 ACC2
- 2078 BRANCHIFNOT 2082
- 2080 BRANCH 2084
- 2082 RETURN 3
- 2084 GETGLOBAL "List.rev_map2"
- 2086 PUSHGETGLOBALFIELD Pervasives, 2
- 2089 APPTERM1 4
- 2091 RESTART
- 2092 GRAB 2
- 2094 ACC0
- 2095 CLOSUREREC 1, 2053
- 2099 ACC3
- 2100 PUSHACC3
- 2101 PUSHCONST0
- 2102 PUSHACC3
- 2103 APPTERM3 7
- 2105 RESTART
- 2106 GRAB 1
- 2108 ACC1
- 2109 BRANCHIFNOT 2123
- 2111 ACC1
- 2112 GETFIELD1
- 2113 PUSHACC1
- 2114 PUSHACC3
- 2115 GETFIELD0
- 2116 PUSHENVACC1
- 2117 APPLY1
- 2118 MAKEBLOCK2 0
- 2120 PUSHOFFSETCLOSURE0
- 2121 APPTERM2 4
- 2123 ACC0
- 2124 RETURN 2
- 2126 RESTART
- 2127 GRAB 1
- 2129 ACC0
- 2130 CLOSUREREC 1, 2106
- 2134 ACC2
- 2135 PUSHCONST0
- 2136 PUSHACC2
- 2137 APPTERM2 5
- 2139 CONST0
- 2140 PUSHACC1
- 2141 PUSHENVACC1
- 2142 APPTERM2 3
- 2144 ACC0
- 2145 BRANCHIFNOT 2151
- 2147 ACC0
- 2148 GETFIELD1
- 2149 RETURN 1
- 2151 GETGLOBAL "tl"
- 2153 PUSHGETGLOBALFIELD Pervasives, 3
- 2156 APPTERM1 2
- 2158 ACC0
- 2159 BRANCHIFNOT 2165
- 2161 ACC0
- 2162 GETFIELD0
- 2163 RETURN 1
- 2165 GETGLOBAL "hd"
- 2167 PUSHGETGLOBALFIELD Pervasives, 3
- 2170 APPTERM1 2
- 2172 ACC0
- 2173 PUSHCONST0
- 2174 PUSHENVACC1
- 2175 APPTERM2 3
- 2177 CLOSUREREC 0, 1200
- 2181 ACC0
- 2182 CLOSURE 1, 2172
- 2185 PUSH
- 2186 CLOSURE 0, 2158
- 2189 PUSH
- 2190 CLOSURE 0, 2144
- 2193 PUSH
- 2194 CLOSUREREC 0, 1217
- 2198 GETGLOBALFIELD Pervasives, 16
- 2201 PUSH
- 2202 CLOSUREREC 0, 1259
- 2206 ACC0
- 2207 CLOSURE 1, 2139
- 2210 PUSH
- 2211 CLOSUREREC 0, 1277
- 2215 CLOSUREREC 0, 1294
- 2219 CLOSURE 0, 2127
- 2222 PUSH
- 2223 CLOSUREREC 0, 1316
- 2227 CLOSUREREC 0, 1334
- 2231 CLOSUREREC 0, 1354
- 2235 CLOSUREREC 0, 1374
- 2239 CLOSURE 0, 2092
- 2242 PUSH
- 2243 CLOSUREREC 0, 1415
- 2247 CLOSUREREC 0, 1452
- 2251 CLOSUREREC 0, 1490
- 2255 CLOSUREREC 0, 1530
- 2259 CLOSUREREC 0, 1553
- 2263 CLOSUREREC 0, 1573
- 2267 CLOSUREREC 0, 1613
- 2271 CLOSUREREC 0, 1654
- 2275 CLOSUREREC 0, 1675
- 2279 CLOSUREREC 0, 1695
- 2283 CLOSUREREC 0, 1725
- 2287 CLOSUREREC 0, 1754
- 2291 CLOSUREREC 0, 1776
- 2295 CLOSUREREC 0, 1797
- 2299 CLOSUREREC 0, 1828
- 2303 CLOSUREREC 0, 1858
- 2307 ACC 24
- 2309 CLOSURE 1, 2042
- 2312 PUSHACC 25
- 2314 CLOSUREREC 1, 1928
- 2318 CLOSUREREC 0, 1942
- 2322 CLOSUREREC 0, 1972
- 2326 ACC0
- 2327 PUSHACC2
- 2328 PUSHACC7
- 2329 PUSHACC 9
- 2331 PUSHACC 11
- 2333 PUSHACC 13
- 2335 PUSHACC 15
- 2337 PUSHACC 17
- 2339 PUSHACC 10
- 2341 PUSHACC 12
- 2343 PUSHACC 13
- 2345 PUSHACC 15
- 2347 PUSHACC 23
- 2349 PUSHACC 25
- 2351 PUSHACC 27
- 2353 PUSHACC 29
- 2355 PUSHACC 31
- 2357 PUSHACC 33
- 2359 PUSHACC 35
- 2361 PUSHACC 37
- 2363 PUSHACC 40
- 2365 PUSHACC 42
- 2367 PUSHACC 41
- 2369 PUSHACC 45
- 2371 PUSHACC 47
- 2373 PUSHACC 50
- 2375 PUSHACC 52
- 2377 PUSHACC 51
- 2379 PUSHACC 55
- 2381 PUSHACC 56
- 2383 PUSHACC 59
- 2385 PUSHACC 61
- 2387 PUSHACC 60
- 2389 PUSHACC 64
- 2391 PUSHACC 66
- 2393 PUSHACC 68
- 2395 PUSHACC 70
- 2397 MAKEBLOCK 37, 0
- 2400 POP 36
- 2402 SETGLOBAL List
- 2404 BRANCH 2432
- 2406 CONST0
- 2407 PUSHACC1
- 2408 LEINT
- 2409 BRANCHIFNOT 2414
- 2411 CONST0
- 2412 RETURN 1
- 2414 ACC0
- 2415 OFFSETINT -1
- 2417 PUSHOFFSETCLOSURE0
- 2418 APPLY1
- 2419 PUSHACC1
- 2420 MAKEBLOCK2 0
- 2422 RETURN 1
- 2424 RESTART
- 2425 GRAB 1
- 2427 ACC1
- 2428 PUSHACC1
- 2429 ADDINT
- 2430 RETURN 2
- 2432 CLOSUREREC 0, 2406
- 2436 CONSTINT 300
- 2438 PUSHACC1
- 2439 APPLY1
- 2440 PUSHCONST0
- 2441 C_CALL1 gc_minor
- 2443 CONSTINT 150
- 2445 PUSHCONSTINT 301
- 2447 MULINT
- 2448 PUSHACC1
- 2449 PUSHCONST0
- 2450 PUSH
- 2451 CLOSURE 0, 2425
- 2454 PUSHGETGLOBALFIELD List, 12
- 2457 APPLY3
- 2458 NEQ
- 2459 BRANCHIFNOT 2466
- 2461 GETGLOBAL Not_found
- 2463 MAKEBLOCK1 0
- 2465 RAISE
- 2466 POP 2
- 2468 ATOM0
- 2469 SETGLOBAL T320-gc-1
- 2471 STOP
-**)
diff --git a/test/testinterp/t320-gc-2.ml b/test/testinterp/t320-gc-2.ml
deleted file mode 100644
index f607f65125..0000000000
--- a/test/testinterp/t320-gc-2.ml
+++ /dev/null
@@ -1,1589 +0,0 @@
-open Lib;;
-let rec f n =
- if n <= 0 then []
- else n :: f (n-1)
-in
-let l = f 300 in
-Gc.major ();
-if List.fold_left (+) 0 l <> 301 * 150 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 746
- 11 RESTART
- 12 GRAB 1
- 14 ACC0
- 15 BRANCHIFNOT 28
- 17 ACC1
- 18 PUSHACC1
- 19 GETFIELD1
- 20 PUSHOFFSETCLOSURE0
- 21 APPLY2
- 22 PUSHACC1
- 23 GETFIELD0
- 24 MAKEBLOCK2 0
- 26 RETURN 2
- 28 ACC1
- 29 RETURN 2
- 31 RESTART
- 32 GRAB 3
- 34 CONST0
- 35 PUSHACC4
- 36 LEINT
- 37 BRANCHIFNOT 42
- 39 CONST0
- 40 RETURN 4
- 42 ACC3
- 43 PUSHACC3
- 44 PUSHACC3
- 45 PUSHACC3
- 46 C_CALL4 caml_input
- 48 PUSHCONST0
- 49 PUSHACC1
- 50 EQ
- 51 BRANCHIFNOT 58
- 53 GETGLOBAL End_of_file
- 55 MAKEBLOCK1 0
- 57 RAISE
- 58 ACC0
- 59 PUSHACC5
- 60 SUBINT
- 61 PUSHACC1
- 62 PUSHACC5
- 63 ADDINT
- 64 PUSHACC4
- 65 PUSHACC4
- 66 PUSHOFFSETCLOSURE0
- 67 APPTERM 4, 9
- 70 ACC0
- 71 C_CALL1 caml_input_scan_line
- 73 PUSHCONST0
- 74 PUSHACC1
- 75 EQ
- 76 BRANCHIFNOT 83
- 78 GETGLOBAL End_of_file
- 80 MAKEBLOCK1 0
- 82 RAISE
- 83 CONST0
- 84 PUSHACC1
- 85 GTINT
- 86 BRANCHIFNOT 107
- 88 ACC0
- 89 OFFSETINT -1
- 91 C_CALL1 create_string
- 93 PUSHACC1
- 94 OFFSETINT -1
- 96 PUSHCONST0
- 97 PUSHACC2
- 98 PUSHACC5
- 99 C_CALL4 caml_input
- 101 ACC2
- 102 C_CALL1 caml_input_char
- 104 ACC0
- 105 RETURN 3
- 107 ACC0
- 108 NEGINT
- 109 C_CALL1 create_string
- 111 PUSHACC1
- 112 NEGINT
- 113 PUSHCONST0
- 114 PUSHACC2
- 115 PUSHACC5
- 116 C_CALL4 caml_input
- 118 CONST0
- 119 PUSHTRAP 130
- 121 ACC6
- 122 PUSHOFFSETCLOSURE0
- 123 APPLY1
- 124 PUSHACC5
- 125 PUSHENVACC1
- 126 APPLY2
- 127 POPTRAP
- 128 RETURN 3
- 130 PUSHGETGLOBAL End_of_file
- 132 PUSHACC1
- 133 GETFIELD0
- 134 EQ
- 135 BRANCHIFNOT 140
- 137 ACC1
- 138 RETURN 4
- 140 ACC0
- 141 RAISE
- 142 ACC0
- 143 C_CALL1 caml_flush
- 145 RETURN 1
- 147 RESTART
- 148 GRAB 1
- 150 ACC1
- 151 PUSHACC1
- 152 C_CALL2 caml_output_char
- 154 RETURN 2
- 156 RESTART
- 157 GRAB 1
- 159 ACC1
- 160 PUSHACC1
- 161 C_CALL2 caml_output_char
- 163 RETURN 2
- 165 RESTART
- 166 GRAB 1
- 168 ACC1
- 169 PUSHACC1
- 170 C_CALL2 caml_output_int
- 172 RETURN 2
- 174 RESTART
- 175 GRAB 1
- 177 ACC1
- 178 PUSHACC1
- 179 C_CALL2 caml_seek_out
- 181 RETURN 2
- 183 ACC0
- 184 C_CALL1 caml_pos_out
- 186 RETURN 1
- 188 ACC0
- 189 C_CALL1 caml_channel_size
- 191 RETURN 1
- 193 RESTART
- 194 GRAB 1
- 196 ACC1
- 197 PUSHACC1
- 198 C_CALL2 caml_set_binary_mode
- 200 RETURN 2
- 202 ACC0
- 203 C_CALL1 caml_input_char
- 205 RETURN 1
- 207 ACC0
- 208 C_CALL1 caml_input_char
- 210 RETURN 1
- 212 ACC0
- 213 C_CALL1 caml_input_int
- 215 RETURN 1
- 217 ACC0
- 218 C_CALL1 input_value
- 220 RETURN 1
- 222 RESTART
- 223 GRAB 1
- 225 ACC1
- 226 PUSHACC1
- 227 C_CALL2 caml_seek_in
- 229 RETURN 2
- 231 ACC0
- 232 C_CALL1 caml_pos_in
- 234 RETURN 1
- 236 ACC0
- 237 C_CALL1 caml_channel_size
- 239 RETURN 1
- 241 ACC0
- 242 C_CALL1 caml_close_channel
- 244 RETURN 1
- 246 RESTART
- 247 GRAB 1
- 249 ACC1
- 250 PUSHACC1
- 251 C_CALL2 caml_set_binary_mode
- 253 RETURN 2
- 255 CONST0
- 256 PUSHENVACC1
- 257 APPLY1
- 258 ACC0
- 259 C_CALL1 sys_exit
- 261 RETURN 1
- 263 CONST0
- 264 PUSHENVACC1
- 265 GETFIELD0
- 266 APPTERM1 2
- 268 CONST0
- 269 PUSHENVACC1
- 270 APPLY1
- 271 CONST0
- 272 PUSHENVACC2
- 273 APPTERM1 2
- 275 ENVACC1
- 276 GETFIELD0
- 277 PUSHACC0
- 278 PUSHACC2
- 279 CLOSURE 2, 268
- 282 PUSHENVACC1
- 283 SETFIELD0
- 284 RETURN 2
- 286 ENVACC1
- 287 C_CALL1 caml_flush
- 289 ENVACC2
- 290 C_CALL1 caml_flush
- 292 RETURN 1
- 294 CONST0
- 295 PUSHENVACC1
- 296 APPLY1
- 297 C_CALL1 float_of_string
- 299 RETURN 1
- 301 CONST0
- 302 PUSHENVACC1
- 303 APPLY1
- 304 C_CALL1 int_of_string
- 306 RETURN 1
- 308 ENVACC2
- 309 C_CALL1 caml_flush
- 311 ENVACC1
- 312 PUSHENVACC3
- 313 APPTERM1 2
- 315 CONSTINT 13
- 317 PUSHENVACC1
- 318 C_CALL2 caml_output_char
- 320 ENVACC1
- 321 C_CALL1 caml_flush
- 323 RETURN 1
- 325 ACC0
- 326 PUSHENVACC1
- 327 PUSHENVACC2
- 328 APPLY2
- 329 CONSTINT 13
- 331 PUSHENVACC1
- 332 C_CALL2 caml_output_char
- 334 ENVACC1
- 335 C_CALL1 caml_flush
- 337 RETURN 1
- 339 ACC0
- 340 PUSHENVACC1
- 341 APPLY1
- 342 PUSHENVACC2
- 343 PUSHENVACC3
- 344 APPTERM2 3
- 346 ACC0
- 347 PUSHENVACC1
- 348 APPLY1
- 349 PUSHENVACC2
- 350 PUSHENVACC3
- 351 APPTERM2 3
- 353 ACC0
- 354 PUSHENVACC1
- 355 PUSHENVACC2
- 356 APPTERM2 3
- 358 ACC0
- 359 PUSHENVACC1
- 360 C_CALL2 caml_output_char
- 362 RETURN 1
- 364 CONSTINT 13
- 366 PUSHENVACC1
- 367 C_CALL2 caml_output_char
- 369 ENVACC1
- 370 C_CALL1 caml_flush
- 372 RETURN 1
- 374 ACC0
- 375 PUSHENVACC1
- 376 PUSHENVACC2
- 377 APPLY2
- 378 CONSTINT 13
- 380 PUSHENVACC1
- 381 C_CALL2 caml_output_char
- 383 RETURN 1
- 385 ACC0
- 386 PUSHENVACC1
- 387 APPLY1
- 388 PUSHENVACC2
- 389 PUSHENVACC3
- 390 APPTERM2 3
- 392 ACC0
- 393 PUSHENVACC1
- 394 APPLY1
- 395 PUSHENVACC2
- 396 PUSHENVACC3
- 397 APPTERM2 3
- 399 ACC0
- 400 PUSHENVACC1
- 401 PUSHENVACC2
- 402 APPTERM2 3
- 404 ACC0
- 405 PUSHENVACC1
- 406 C_CALL2 caml_output_char
- 408 RETURN 1
- 410 RESTART
- 411 GRAB 3
- 413 CONST0
- 414 PUSHACC3
- 415 LTINT
- 416 BRANCHIF 427
- 418 ACC1
- 419 C_CALL1 ml_string_length
- 421 PUSHACC4
- 422 PUSHACC4
- 423 ADDINT
- 424 GTINT
- 425 BRANCHIFNOT 432
- 427 GETGLOBAL "really_input"
- 429 PUSHENVACC1
- 430 APPTERM1 5
- 432 ACC3
- 433 PUSHACC3
- 434 PUSHACC3
- 435 PUSHACC3
- 436 PUSHENVACC2
- 437 APPTERM 4, 8
- 440 RESTART
- 441 GRAB 3
- 443 CONST0
- 444 PUSHACC3
- 445 LTINT
- 446 BRANCHIF 457
- 448 ACC1
- 449 C_CALL1 ml_string_length
- 451 PUSHACC4
- 452 PUSHACC4
- 453 ADDINT
- 454 GTINT
- 455 BRANCHIFNOT 462
- 457 GETGLOBAL "input"
- 459 PUSHENVACC1
- 460 APPTERM1 5
- 462 ACC3
- 463 PUSHACC3
- 464 PUSHACC3
- 465 PUSHACC3
- 466 C_CALL4 caml_input
- 468 RETURN 4
- 470 ACC0
- 471 PUSHCONST0
- 472 PUSHGETGLOBAL <0>(0, <0>(6, 0))
- 474 PUSHENVACC1
- 475 APPTERM3 4
- 477 ACC0
- 478 PUSHCONST0
- 479 PUSHGETGLOBAL <0>(0, <0>(7, 0))
- 481 PUSHENVACC1
- 482 APPTERM3 4
- 484 RESTART
- 485 GRAB 2
- 487 ACC1
- 488 PUSHACC1
- 489 PUSHACC4
- 490 C_CALL3 sys_open
- 492 C_CALL1 caml_open_descriptor
- 494 RETURN 3
- 496 ACC0
- 497 C_CALL1 caml_flush
- 499 ACC0
- 500 C_CALL1 caml_close_channel
- 502 RETURN 1
- 504 RESTART
- 505 GRAB 1
- 507 CONST0
- 508 PUSHACC2
- 509 PUSHACC2
- 510 C_CALL3 output_value
- 512 RETURN 2
- 514 RESTART
- 515 GRAB 3
- 517 CONST0
- 518 PUSHACC3
- 519 LTINT
- 520 BRANCHIF 531
- 522 ACC1
- 523 C_CALL1 ml_string_length
- 525 PUSHACC4
- 526 PUSHACC4
- 527 ADDINT
- 528 GTINT
- 529 BRANCHIFNOT 536
- 531 GETGLOBAL "output"
- 533 PUSHENVACC1
- 534 APPTERM1 5
- 536 ACC3
- 537 PUSHACC3
- 538 PUSHACC3
- 539 PUSHACC3
- 540 C_CALL4 caml_output
- 542 RETURN 4
- 544 RESTART
- 545 GRAB 1
- 547 ACC1
- 548 C_CALL1 ml_string_length
- 550 PUSHCONST0
- 551 PUSHACC3
- 552 PUSHACC3
- 553 C_CALL4 caml_output
- 555 RETURN 2
- 557 ACC0
- 558 PUSHCONSTINT 438
- 560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0))))
- 562 PUSHENVACC1
- 563 APPTERM3 4
- 565 ACC0
- 566 PUSHCONSTINT 438
- 568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0))))
- 570 PUSHENVACC1
- 571 APPTERM3 4
- 573 RESTART
- 574 GRAB 2
- 576 ACC1
- 577 PUSHACC1
- 578 PUSHACC4
- 579 C_CALL3 sys_open
- 581 C_CALL1 caml_open_descriptor
- 583 RETURN 3
- 585 ACC0
- 586 PUSHGETGLOBAL "%.12g"
- 588 C_CALL2 format_float
- 590 RETURN 1
- 592 ACC0
- 593 PUSHGETGLOBAL "%d"
- 595 C_CALL2 format_int
- 597 RETURN 1
- 599 GETGLOBAL "false"
- 601 PUSHACC1
- 602 C_CALL2 string_equal
- 604 BRANCHIFNOT 609
- 606 CONST0
- 607 RETURN 1
- 609 GETGLOBAL "true"
- 611 PUSHACC1
- 612 C_CALL2 string_equal
- 614 BRANCHIFNOT 619
- 616 CONST1
- 617 RETURN 1
- 619 GETGLOBAL "bool_of_string"
- 621 PUSHENVACC1
- 622 APPTERM1 2
- 624 ACC0
- 625 BRANCHIFNOT 631
- 627 GETGLOBAL "true"
- 629 RETURN 1
- 631 GETGLOBAL "false"
- 633 RETURN 1
- 635 CONST0
- 636 PUSHACC1
- 637 LTINT
- 638 BRANCHIF 646
- 640 CONSTINT 255
- 642 PUSHACC1
- 643 GTINT
- 644 BRANCHIFNOT 651
- 646 GETGLOBAL "char_of_int"
- 648 PUSHENVACC1
- 649 APPTERM1 2
- 651 ACC0
- 652 RETURN 1
- 654 RESTART
- 655 GRAB 1
- 657 ACC0
- 658 C_CALL1 ml_string_length
- 660 PUSHACC2
- 661 C_CALL1 ml_string_length
- 663 PUSHACC0
- 664 PUSHACC2
- 665 ADDINT
- 666 C_CALL1 create_string
- 668 PUSHACC2
- 669 PUSHCONST0
- 670 PUSHACC2
- 671 PUSHCONST0
- 672 PUSHACC7
- 673 C_CALL5 blit_string
- 675 ACC1
- 676 PUSHACC3
- 677 PUSHACC2
- 678 PUSHCONST0
- 679 PUSHACC 8
- 681 C_CALL5 blit_string
- 683 ACC0
- 684 RETURN 5
- 686 CONSTINT -1
- 688 PUSHACC1
- 689 XORINT
- 690 RETURN 1
- 692 CONST0
- 693 PUSHACC1
- 694 GEINT
- 695 BRANCHIFNOT 700
- 697 ACC0
- 698 RETURN 1
- 700 ACC0
- 701 NEGINT
- 702 RETURN 1
- 704 RESTART
- 705 GRAB 1
- 707 ACC1
- 708 PUSHACC1
- 709 C_CALL2 greaterequal
- 711 BRANCHIFNOT 716
- 713 ACC0
- 714 RETURN 2
- 716 ACC1
- 717 RETURN 2
- 719 RESTART
- 720 GRAB 1
- 722 ACC1
- 723 PUSHACC1
- 724 C_CALL2 lessequal
- 726 BRANCHIFNOT 731
- 728 ACC0
- 729 RETURN 2
- 731 ACC1
- 732 RETURN 2
- 734 ACC0
- 735 PUSHGETGLOBAL Invalid_argument
- 737 MAKEBLOCK2 0
- 739 RAISE
- 740 ACC0
- 741 PUSHGETGLOBAL Failure
- 743 MAKEBLOCK2 0
- 745 RAISE
- 746 CLOSURE 0, 740
- 749 PUSH
- 750 CLOSURE 0, 734
- 753 PUSHGETGLOBAL "Pervasives.Exit"
- 755 MAKEBLOCK1 0
- 757 PUSHGETGLOBAL "Pervasives.Assert_failure"
- 759 MAKEBLOCK1 0
- 761 PUSH
- 762 CLOSURE 0, 720
- 765 PUSH
- 766 CLOSURE 0, 705
- 769 PUSH
- 770 CLOSURE 0, 692
- 773 PUSH
- 774 CLOSURE 0, 686
- 777 PUSHCONST0
- 778 PUSHCONSTINT 31
- 780 PUSHCONST1
- 781 LSLINT
- 782 EQ
- 783 BRANCHIFNOT 789
- 785 CONSTINT 30
- 787 BRANCH 791
- 789 CONSTINT 62
- 791 PUSHCONST1
- 792 LSLINT
- 793 PUSHACC0
- 794 OFFSETINT -1
- 796 PUSH
- 797 CLOSURE 0, 655
- 800 PUSHACC 9
- 802 CLOSURE 1, 635
- 805 PUSH
- 806 CLOSURE 0, 624
- 809 PUSHACC 11
- 811 CLOSURE 1, 599
- 814 PUSH
- 815 CLOSURE 0, 592
- 818 PUSH
- 819 CLOSURE 0, 585
- 822 PUSH
- 823 CLOSUREREC 0, 12
- 827 CONST0
- 828 C_CALL1 caml_open_descriptor
- 830 PUSHCONST1
- 831 C_CALL1 caml_open_descriptor
- 833 PUSHCONST2
- 834 C_CALL1 caml_open_descriptor
- 836 PUSH
- 837 CLOSURE 0, 574
- 840 PUSHACC0
- 841 CLOSURE 1, 565
- 844 PUSHACC1
- 845 CLOSURE 1, 557
- 848 PUSH
- 849 CLOSURE 0, 545
- 852 PUSHACC 22
- 854 CLOSURE 1, 515
- 857 PUSH
- 858 CLOSURE 0, 505
- 861 PUSH
- 862 CLOSURE 0, 496
- 865 PUSH
- 866 CLOSURE 0, 485
- 869 PUSHACC0
- 870 CLOSURE 1, 477
- 873 PUSHACC1
- 874 CLOSURE 1, 470
- 877 PUSHACC 28
- 879 CLOSURE 1, 441
- 882 PUSH
- 883 CLOSUREREC 0, 32
- 887 ACC0
- 888 PUSHACC 31
- 890 CLOSURE 2, 411
- 893 PUSHACC 22
- 895 CLOSUREREC 1, 70
- 899 ACC 15
- 901 CLOSURE 1, 404
- 904 PUSHACC 11
- 906 PUSHACC 17
- 908 CLOSURE 2, 399
- 911 PUSHACC 12
- 913 PUSHACC 18
- 915 PUSHACC 23
- 917 CLOSURE 3, 392
- 920 PUSHACC 13
- 922 PUSHACC 19
- 924 PUSHACC 23
- 926 CLOSURE 3, 385
- 929 PUSHACC 14
- 931 PUSHACC 20
- 933 CLOSURE 2, 374
- 936 PUSHACC 20
- 938 CLOSURE 1, 364
- 941 PUSHACC 20
- 943 CLOSURE 1, 358
- 946 PUSHACC 17
- 948 PUSHACC 22
- 950 CLOSURE 2, 353
- 953 PUSHACC 18
- 955 PUSHACC 23
- 957 PUSHACC 29
- 959 CLOSURE 3, 346
- 962 PUSHACC 19
- 964 PUSHACC 24
- 966 PUSHACC 29
- 968 CLOSURE 3, 339
- 971 PUSHACC 20
- 973 PUSHACC 25
- 975 CLOSURE 2, 325
- 978 PUSHACC 25
- 980 CLOSURE 1, 315
- 983 PUSHACC 12
- 985 PUSHACC 28
- 987 PUSHACC 30
- 989 CLOSURE 3, 308
- 992 PUSHACC0
- 993 CLOSURE 1, 301
- 996 PUSHACC1
- 997 CLOSURE 1, 294
- 1000 PUSHACC 29
- 1002 PUSHACC 31
- 1004 CLOSURE 2, 286
- 1007 MAKEBLOCK1 0
- 1009 PUSHACC0
- 1010 CLOSURE 1, 275
- 1013 PUSHACC1
- 1014 CLOSURE 1, 263
- 1017 PUSHACC0
- 1018 CLOSURE 1, 255
- 1021 PUSHACC1
- 1022 PUSHACC 22
- 1024 PUSHACC4
- 1025 PUSHACC3
- 1026 PUSH
- 1027 CLOSURE 0, 247
- 1030 PUSH
- 1031 CLOSURE 0, 241
- 1034 PUSH
- 1035 CLOSURE 0, 236
- 1038 PUSH
- 1039 CLOSURE 0, 231
- 1042 PUSH
- 1043 CLOSURE 0, 223
- 1046 PUSH
- 1047 CLOSURE 0, 217
- 1050 PUSH
- 1051 CLOSURE 0, 212
- 1054 PUSH
- 1055 CLOSURE 0, 207
- 1058 PUSHACC 32
- 1060 PUSHACC 35
- 1062 PUSHACC 33
- 1064 PUSH
- 1065 CLOSURE 0, 202
- 1068 PUSHACC 41
- 1070 PUSHACC 40
- 1072 PUSHACC 42
- 1074 PUSH
- 1075 CLOSURE 0, 194
- 1078 PUSHACC 46
- 1080 PUSH
- 1081 CLOSURE 0, 188
- 1084 PUSH
- 1085 CLOSURE 0, 183
- 1088 PUSH
- 1089 CLOSURE 0, 175
- 1092 PUSHACC 51
- 1094 PUSH
- 1095 CLOSURE 0, 166
- 1098 PUSH
- 1099 CLOSURE 0, 157
- 1102 PUSHACC 55
- 1104 PUSHACC 57
- 1106 PUSH
- 1107 CLOSURE 0, 148
- 1110 PUSH
- 1111 CLOSURE 0, 142
- 1114 PUSHACC 63
- 1116 PUSHACC 62
- 1118 PUSHACC 64
- 1120 PUSHACC 38
- 1122 PUSHACC 40
- 1124 PUSHACC 42
- 1126 PUSHACC 44
- 1128 PUSHACC 46
- 1130 PUSHACC 48
- 1132 PUSHACC 50
- 1134 PUSHACC 52
- 1136 PUSHACC 54
- 1138 PUSHACC 56
- 1140 PUSHACC 58
- 1142 PUSHACC 60
- 1144 PUSHACC 62
- 1146 PUSHACC 64
- 1148 PUSHACC 66
- 1150 PUSHACC 82
- 1152 PUSHACC 84
- 1154 PUSHACC 86
- 1156 PUSHACC 88
- 1158 PUSHACC 90
- 1160 PUSHACC 92
- 1162 PUSHACC 94
- 1164 PUSHACC 96
- 1166 PUSHACC 98
- 1168 PUSHACC 100
- 1170 PUSHACC 104
- 1172 PUSHACC 104
- 1174 PUSHACC 104
- 1176 PUSHACC 108
- 1178 PUSHACC 110
- 1180 PUSHACC 112
- 1182 PUSHACC 117
- 1184 PUSHACC 117
- 1186 PUSHACC 117
- 1188 PUSHACC 117
- 1190 MAKEBLOCK 69, 0
- 1193 POP 53
- 1195 SETGLOBAL Pervasives
- 1197 BRANCH 2177
- 1199 RESTART
- 1200 GRAB 1
- 1202 ACC1
- 1203 BRANCHIFNOT 1213
- 1205 ACC1
- 1206 GETFIELD1
- 1207 PUSHACC1
- 1208 OFFSETINT 1
- 1210 PUSHOFFSETCLOSURE0
- 1211 APPTERM2 4
- 1213 ACC0
- 1214 RETURN 2
- 1216 RESTART
- 1217 GRAB 1
- 1219 ACC0
- 1220 BRANCHIFNOT 1251
- 1222 CONST0
- 1223 PUSHACC2
- 1224 EQ
- 1225 BRANCHIFNOT 1231
- 1227 ACC0
- 1228 GETFIELD0
- 1229 RETURN 2
- 1231 CONST0
- 1232 PUSHACC2
- 1233 GTINT
- 1234 BRANCHIFNOT 1244
- 1236 ACC1
- 1237 OFFSETINT -1
- 1239 PUSHACC1
- 1240 GETFIELD1
- 1241 PUSHOFFSETCLOSURE0
- 1242 APPTERM2 4
- 1244 GETGLOBAL "List.nth"
- 1246 PUSHGETGLOBALFIELD Pervasives, 2
- 1249 APPTERM1 3
- 1251 GETGLOBAL "nth"
- 1253 PUSHGETGLOBALFIELD Pervasives, 3
- 1256 APPTERM1 3
- 1258 RESTART
- 1259 GRAB 1
- 1261 ACC0
- 1262 BRANCHIFNOT 1274
- 1264 ACC1
- 1265 PUSHACC1
- 1266 GETFIELD0
- 1267 MAKEBLOCK2 0
- 1269 PUSHACC1
- 1270 GETFIELD1
- 1271 PUSHOFFSETCLOSURE0
- 1272 APPTERM2 4
- 1274 ACC1
- 1275 RETURN 2
- 1277 ACC0
- 1278 BRANCHIFNOT 1291
- 1280 ACC0
- 1281 GETFIELD1
- 1282 PUSHOFFSETCLOSURE0
- 1283 APPLY1
- 1284 PUSHACC1
- 1285 GETFIELD0
- 1286 PUSHGETGLOBALFIELD Pervasives, 16
- 1289 APPTERM2 3
- 1291 RETURN 1
- 1293 RESTART
- 1294 GRAB 1
- 1296 ACC1
- 1297 BRANCHIFNOT 1313
- 1299 ACC1
- 1300 GETFIELD0
- 1301 PUSHACC1
- 1302 APPLY1
- 1303 PUSHACC2
- 1304 GETFIELD1
- 1305 PUSHACC2
- 1306 PUSHOFFSETCLOSURE0
- 1307 APPLY2
- 1308 PUSHACC1
- 1309 MAKEBLOCK2 0
- 1311 POP 1
- 1313 RETURN 2
- 1315 RESTART
- 1316 GRAB 1
- 1318 ACC1
- 1319 BRANCHIFNOT 1331
- 1321 ACC1
- 1322 GETFIELD0
- 1323 PUSHACC1
- 1324 APPLY1
- 1325 ACC1
- 1326 GETFIELD1
- 1327 PUSHACC1
- 1328 PUSHOFFSETCLOSURE0
- 1329 APPTERM2 4
- 1331 RETURN 2
- 1333 RESTART
- 1334 GRAB 2
- 1336 ACC2
- 1337 BRANCHIFNOT 1350
- 1339 ACC2
- 1340 GETFIELD1
- 1341 PUSHACC3
- 1342 GETFIELD0
- 1343 PUSHACC3
- 1344 PUSHACC3
- 1345 APPLY2
- 1346 PUSHACC2
- 1347 PUSHOFFSETCLOSURE0
- 1348 APPTERM3 6
- 1350 ACC1
- 1351 RETURN 3
- 1353 RESTART
- 1354 GRAB 2
- 1356 ACC1
- 1357 BRANCHIFNOT 1370
- 1359 ACC2
- 1360 PUSHACC2
- 1361 GETFIELD1
- 1362 PUSHACC2
- 1363 PUSHOFFSETCLOSURE0
- 1364 APPLY3
- 1365 PUSHACC2
- 1366 GETFIELD0
- 1367 PUSHACC2
- 1368 APPTERM2 5
- 1370 ACC2
- 1371 RETURN 3
- 1373 RESTART
- 1374 GRAB 2
- 1376 ACC1
- 1377 BRANCHIFNOT 1400
- 1379 ACC2
- 1380 BRANCHIFNOT 1407
- 1382 ACC2
- 1383 GETFIELD0
- 1384 PUSHACC2
- 1385 GETFIELD0
- 1386 PUSHACC2
- 1387 APPLY2
- 1388 PUSHACC3
- 1389 GETFIELD1
- 1390 PUSHACC3
- 1391 GETFIELD1
- 1392 PUSHACC3
- 1393 PUSHOFFSETCLOSURE0
- 1394 APPLY3
- 1395 PUSHACC1
- 1396 MAKEBLOCK2 0
- 1398 RETURN 4
- 1400 ACC2
- 1401 BRANCHIFNOT 1405
- 1403 BRANCH 1407
- 1405 RETURN 3
- 1407 GETGLOBAL "List.map2"
- 1409 PUSHGETGLOBALFIELD Pervasives, 2
- 1412 APPTERM1 4
- 1414 RESTART
- 1415 GRAB 2
- 1417 ACC1
- 1418 BRANCHIFNOT 1437
- 1420 ACC2
- 1421 BRANCHIFNOT 1444
- 1423 ACC2
- 1424 GETFIELD0
- 1425 PUSHACC2
- 1426 GETFIELD0
- 1427 PUSHACC2
- 1428 APPLY2
- 1429 ACC2
- 1430 GETFIELD1
- 1431 PUSHACC2
- 1432 GETFIELD1
- 1433 PUSHACC2
- 1434 PUSHOFFSETCLOSURE0
- 1435 APPTERM3 6
- 1437 ACC2
- 1438 BRANCHIFNOT 1442
- 1440 BRANCH 1444
- 1442 RETURN 3
- 1444 GETGLOBAL "List.iter2"
- 1446 PUSHGETGLOBALFIELD Pervasives, 2
- 1449 APPTERM1 4
- 1451 RESTART
- 1452 GRAB 3
- 1454 ACC2
- 1455 BRANCHIFNOT 1476
- 1457 ACC3
- 1458 BRANCHIFNOT 1482
- 1460 ACC3
- 1461 GETFIELD1
- 1462 PUSHACC3
- 1463 GETFIELD1
- 1464 PUSHACC5
- 1465 GETFIELD0
- 1466 PUSHACC5
- 1467 GETFIELD0
- 1468 PUSHACC5
- 1469 PUSHACC5
- 1470 APPLY3
- 1471 PUSHACC3
- 1472 PUSHOFFSETCLOSURE0
- 1473 APPTERM 4, 8
- 1476 ACC3
- 1477 BRANCHIF 1482
- 1479 ACC1
- 1480 RETURN 4
- 1482 GETGLOBAL "List.fold_left2"
- 1484 PUSHGETGLOBALFIELD Pervasives, 2
- 1487 APPTERM1 5
- 1489 RESTART
- 1490 GRAB 3
- 1492 ACC1
- 1493 BRANCHIFNOT 1516
- 1495 ACC2
- 1496 BRANCHIFNOT 1522
- 1498 PUSH_RETADDR 1509
- 1500 ACC6
- 1501 PUSHACC6
- 1502 GETFIELD1
- 1503 PUSHACC6
- 1504 GETFIELD1
- 1505 PUSHACC6
- 1506 PUSHOFFSETCLOSURE0
- 1507 APPLY 4
- 1509 PUSHACC3
- 1510 GETFIELD0
- 1511 PUSHACC3
- 1512 GETFIELD0
- 1513 PUSHACC3
- 1514 APPTERM3 7
- 1516 ACC2
- 1517 BRANCHIF 1522
- 1519 ACC3
- 1520 RETURN 4
- 1522 GETGLOBAL "List.fold_right2"
- 1524 PUSHGETGLOBALFIELD Pervasives, 2
- 1527 APPTERM1 5
- 1529 RESTART
- 1530 GRAB 1
- 1532 ACC1
- 1533 BRANCHIFNOT 1549
- 1535 ACC1
- 1536 GETFIELD0
- 1537 PUSHACC1
- 1538 APPLY1
- 1539 BRANCHIFNOT 1547
- 1541 ACC1
- 1542 GETFIELD1
- 1543 PUSHACC1
- 1544 PUSHOFFSETCLOSURE0
- 1545 APPTERM2 4
- 1547 RETURN 2
- 1549 CONST1
- 1550 RETURN 2
- 1552 RESTART
- 1553 GRAB 1
- 1555 ACC1
- 1556 BRANCHIFNOT 1570
- 1558 ACC1
- 1559 GETFIELD0
- 1560 PUSHACC1
- 1561 APPLY1
- 1562 BRANCHIF 1570
- 1564 ACC1
- 1565 GETFIELD1
- 1566 PUSHACC1
- 1567 PUSHOFFSETCLOSURE0
- 1568 APPTERM2 4
- 1570 RETURN 2
- 1572 RESTART
- 1573 GRAB 2
- 1575 ACC1
- 1576 BRANCHIFNOT 1599
- 1578 ACC2
- 1579 BRANCHIFNOT 1605
- 1581 ACC2
- 1582 GETFIELD0
- 1583 PUSHACC2
- 1584 GETFIELD0
- 1585 PUSHACC2
- 1586 APPLY2
- 1587 BRANCHIFNOT 1597
- 1589 ACC2
- 1590 GETFIELD1
- 1591 PUSHACC2
- 1592 GETFIELD1
- 1593 PUSHACC2
- 1594 PUSHOFFSETCLOSURE0
- 1595 APPTERM3 6
- 1597 RETURN 3
- 1599 ACC2
- 1600 BRANCHIF 1605
- 1602 CONST1
- 1603 RETURN 3
- 1605 GETGLOBAL "List.for_all2"
- 1607 PUSHGETGLOBALFIELD Pervasives, 2
- 1610 APPTERM1 4
- 1612 RESTART
- 1613 GRAB 2
- 1615 ACC1
- 1616 BRANCHIFNOT 1639
- 1618 ACC2
- 1619 BRANCHIFNOT 1646
- 1621 ACC2
- 1622 GETFIELD0
- 1623 PUSHACC2
- 1624 GETFIELD0
- 1625 PUSHACC2
- 1626 APPLY2
- 1627 BRANCHIF 1637
- 1629 ACC2
- 1630 GETFIELD1
- 1631 PUSHACC2
- 1632 GETFIELD1
- 1633 PUSHACC2
- 1634 PUSHOFFSETCLOSURE0
- 1635 APPTERM3 6
- 1637 RETURN 3
- 1639 ACC2
- 1640 BRANCHIFNOT 1644
- 1642 BRANCH 1646
- 1644 RETURN 3
- 1646 GETGLOBAL "List.exists2"
- 1648 PUSHGETGLOBALFIELD Pervasives, 2
- 1651 APPTERM1 4
- 1653 RESTART
- 1654 GRAB 1
- 1656 ACC1
- 1657 BRANCHIFNOT 1672
- 1659 ACC0
- 1660 PUSHACC2
- 1661 GETFIELD0
- 1662 C_CALL2 equal
- 1664 BRANCHIF 1672
- 1666 ACC1
- 1667 GETFIELD1
- 1668 PUSHACC1
- 1669 PUSHOFFSETCLOSURE0
- 1670 APPTERM2 4
- 1672 RETURN 2
- 1674 RESTART
- 1675 GRAB 1
- 1677 ACC1
- 1678 BRANCHIFNOT 1692
- 1680 ACC0
- 1681 PUSHACC2
- 1682 GETFIELD0
- 1683 EQ
- 1684 BRANCHIF 1692
- 1686 ACC1
- 1687 GETFIELD1
- 1688 PUSHACC1
- 1689 PUSHOFFSETCLOSURE0
- 1690 APPTERM2 4
- 1692 RETURN 2
- 1694 RESTART
- 1695 GRAB 1
- 1697 ACC1
- 1698 BRANCHIFNOT 1719
- 1700 ACC1
- 1701 GETFIELD0
- 1702 PUSHACC1
- 1703 PUSHACC1
- 1704 GETFIELD0
- 1705 C_CALL2 equal
- 1707 BRANCHIFNOT 1713
- 1709 ACC0
- 1710 GETFIELD1
- 1711 RETURN 3
- 1713 ACC2
- 1714 GETFIELD1
- 1715 PUSHACC2
- 1716 PUSHOFFSETCLOSURE0
- 1717 APPTERM2 5
- 1719 GETGLOBAL Not_found
- 1721 MAKEBLOCK1 0
- 1723 RAISE
- 1724 RESTART
- 1725 GRAB 1
- 1727 ACC1
- 1728 BRANCHIFNOT 1748
- 1730 ACC1
- 1731 GETFIELD0
- 1732 PUSHACC1
- 1733 PUSHACC1
- 1734 GETFIELD0
- 1735 EQ
- 1736 BRANCHIFNOT 1742
- 1738 ACC0
- 1739 GETFIELD1
- 1740 RETURN 3
- 1742 ACC2
- 1743 GETFIELD1
- 1744 PUSHACC2
- 1745 PUSHOFFSETCLOSURE0
- 1746 APPTERM2 5
- 1748 GETGLOBAL Not_found
- 1750 MAKEBLOCK1 0
- 1752 RAISE
- 1753 RESTART
- 1754 GRAB 1
- 1756 ACC1
- 1757 BRANCHIFNOT 1773
- 1759 ACC0
- 1760 PUSHACC2
- 1761 GETFIELD0
- 1762 GETFIELD0
- 1763 C_CALL2 equal
- 1765 BRANCHIF 1773
- 1767 ACC1
- 1768 GETFIELD1
- 1769 PUSHACC1
- 1770 PUSHOFFSETCLOSURE0
- 1771 APPTERM2 4
- 1773 RETURN 2
- 1775 RESTART
- 1776 GRAB 1
- 1778 ACC1
- 1779 BRANCHIFNOT 1794
- 1781 ACC0
- 1782 PUSHACC2
- 1783 GETFIELD0
- 1784 GETFIELD0
- 1785 EQ
- 1786 BRANCHIF 1794
- 1788 ACC1
- 1789 GETFIELD1
- 1790 PUSHACC1
- 1791 PUSHOFFSETCLOSURE0
- 1792 APPTERM2 4
- 1794 RETURN 2
- 1796 RESTART
- 1797 GRAB 1
- 1799 ACC1
- 1800 BRANCHIFNOT 1825
- 1802 ACC1
- 1803 GETFIELD0
- 1804 PUSHACC2
- 1805 GETFIELD1
- 1806 PUSHACC2
- 1807 PUSHACC2
- 1808 GETFIELD0
- 1809 C_CALL2 equal
- 1811 BRANCHIFNOT 1816
- 1813 ACC0
- 1814 RETURN 4
- 1816 ACC0
- 1817 PUSHACC3
- 1818 PUSHOFFSETCLOSURE0
- 1819 APPLY2
- 1820 PUSHACC2
- 1821 MAKEBLOCK2 0
- 1823 POP 2
- 1825 RETURN 2
- 1827 RESTART
- 1828 GRAB 1
- 1830 ACC1
- 1831 BRANCHIFNOT 1855
- 1833 ACC1
- 1834 GETFIELD0
- 1835 PUSHACC2
- 1836 GETFIELD1
- 1837 PUSHACC2
- 1838 PUSHACC2
- 1839 GETFIELD0
- 1840 EQ
- 1841 BRANCHIFNOT 1846
- 1843 ACC0
- 1844 RETURN 4
- 1846 ACC0
- 1847 PUSHACC3
- 1848 PUSHOFFSETCLOSURE0
- 1849 APPLY2
- 1850 PUSHACC2
- 1851 MAKEBLOCK2 0
- 1853 POP 2
- 1855 RETURN 2
- 1857 RESTART
- 1858 GRAB 1
- 1860 ACC1
- 1861 BRANCHIFNOT 1879
- 1863 ACC1
- 1864 GETFIELD0
- 1865 PUSHACC0
- 1866 PUSHACC2
- 1867 APPLY1
- 1868 BRANCHIFNOT 1873
- 1870 ACC0
- 1871 RETURN 3
- 1873 ACC2
- 1874 GETFIELD1
- 1875 PUSHACC2
- 1876 PUSHOFFSETCLOSURE0
- 1877 APPTERM2 5
- 1879 GETGLOBAL Not_found
- 1881 MAKEBLOCK1 0
- 1883 RAISE
- 1884 RESTART
- 1885 GRAB 2
- 1887 ACC2
- 1888 BRANCHIFNOT 1917
- 1890 ACC2
- 1891 GETFIELD0
- 1892 PUSHACC3
- 1893 GETFIELD1
- 1894 PUSHACC1
- 1895 PUSHENVACC2
- 1896 APPLY1
- 1897 BRANCHIFNOT 1908
- 1899 ACC0
- 1900 PUSHACC4
- 1901 PUSHACC4
- 1902 PUSHACC4
- 1903 MAKEBLOCK2 0
- 1905 PUSHOFFSETCLOSURE0
- 1906 APPTERM3 8
- 1908 ACC0
- 1909 PUSHACC4
- 1910 PUSHACC3
- 1911 MAKEBLOCK2 0
- 1913 PUSHACC4
- 1914 PUSHOFFSETCLOSURE0
- 1915 APPTERM3 8
- 1917 ACC1
- 1918 PUSHENVACC1
- 1919 APPLY1
- 1920 PUSHACC1
- 1921 PUSHENVACC1
- 1922 APPLY1
- 1923 MAKEBLOCK2 0
- 1925 RETURN 3
- 1927 RESTART
- 1928 GRAB 1
- 1930 ACC0
- 1931 PUSHENVACC1
- 1932 CLOSUREREC 2, 1885
- 1936 ACC2
- 1937 PUSHCONST0
- 1938 PUSHCONST0
- 1939 PUSHACC3
- 1940 APPTERM3 6
- 1942 ACC0
- 1943 BRANCHIFNOT 1967
- 1945 ACC0
- 1946 GETFIELD0
- 1947 PUSHACC1
- 1948 GETFIELD1
- 1949 PUSHOFFSETCLOSURE0
- 1950 APPLY1
- 1951 PUSHACC0
- 1952 GETFIELD1
- 1953 PUSHACC2
- 1954 GETFIELD1
- 1955 MAKEBLOCK2 0
- 1957 PUSHACC1
- 1958 GETFIELD0
- 1959 PUSHACC3
- 1960 GETFIELD0
- 1961 MAKEBLOCK2 0
- 1963 MAKEBLOCK2 0
- 1965 RETURN 3
- 1967 GETGLOBAL <0>(0, 0)
- 1969 RETURN 1
- 1971 RESTART
- 1972 GRAB 1
- 1974 ACC0
- 1975 BRANCHIFNOT 1996
- 1977 ACC1
- 1978 BRANCHIFNOT 2003
- 1980 ACC1
- 1981 GETFIELD1
- 1982 PUSHACC1
- 1983 GETFIELD1
- 1984 PUSHOFFSETCLOSURE0
- 1985 APPLY2
- 1986 PUSHACC2
- 1987 GETFIELD0
- 1988 PUSHACC2
- 1989 GETFIELD0
- 1990 MAKEBLOCK2 0
- 1992 MAKEBLOCK2 0
- 1994 RETURN 2
- 1996 ACC1
- 1997 BRANCHIFNOT 2001
- 1999 BRANCH 2003
- 2001 RETURN 2
- 2003 GETGLOBAL "List.combine"
- 2005 PUSHGETGLOBALFIELD Pervasives, 2
- 2008 APPTERM1 3
- 2010 RESTART
- 2011 GRAB 1
- 2013 ACC1
- 2014 BRANCHIFNOT 2038
- 2016 ACC1
- 2017 GETFIELD0
- 2018 PUSHACC2
- 2019 GETFIELD1
- 2020 PUSHACC1
- 2021 PUSHENVACC2
- 2022 APPLY1
- 2023 BRANCHIFNOT 2033
- 2025 ACC0
- 2026 PUSHACC3
- 2027 PUSHACC3
- 2028 MAKEBLOCK2 0
- 2030 PUSHOFFSETCLOSURE0
- 2031 APPTERM2 6
- 2033 ACC0
- 2034 PUSHACC3
- 2035 PUSHOFFSETCLOSURE0
- 2036 APPTERM2 6
- 2038 ACC0
- 2039 PUSHENVACC1
- 2040 APPTERM1 3
- 2042 ACC0
- 2043 PUSHENVACC1
- 2044 CLOSUREREC 2, 2011
- 2048 CONST0
- 2049 PUSHACC1
- 2050 APPTERM1 3
- 2052 RESTART
- 2053 GRAB 2
- 2055 ACC1
- 2056 BRANCHIFNOT 2077
- 2058 ACC2
- 2059 BRANCHIFNOT 2084
- 2061 ACC2
- 2062 GETFIELD1
- 2063 PUSHACC2
- 2064 GETFIELD1
- 2065 PUSHACC2
- 2066 PUSHACC5
- 2067 GETFIELD0
- 2068 PUSHACC5
- 2069 GETFIELD0
- 2070 PUSHENVACC1
- 2071 APPLY2
- 2072 MAKEBLOCK2 0
- 2074 PUSHOFFSETCLOSURE0
- 2075 APPTERM3 6
- 2077 ACC2
- 2078 BRANCHIFNOT 2082
- 2080 BRANCH 2084
- 2082 RETURN 3
- 2084 GETGLOBAL "List.rev_map2"
- 2086 PUSHGETGLOBALFIELD Pervasives, 2
- 2089 APPTERM1 4
- 2091 RESTART
- 2092 GRAB 2
- 2094 ACC0
- 2095 CLOSUREREC 1, 2053
- 2099 ACC3
- 2100 PUSHACC3
- 2101 PUSHCONST0
- 2102 PUSHACC3
- 2103 APPTERM3 7
- 2105 RESTART
- 2106 GRAB 1
- 2108 ACC1
- 2109 BRANCHIFNOT 2123
- 2111 ACC1
- 2112 GETFIELD1
- 2113 PUSHACC1
- 2114 PUSHACC3
- 2115 GETFIELD0
- 2116 PUSHENVACC1
- 2117 APPLY1
- 2118 MAKEBLOCK2 0
- 2120 PUSHOFFSETCLOSURE0
- 2121 APPTERM2 4
- 2123 ACC0
- 2124 RETURN 2
- 2126 RESTART
- 2127 GRAB 1
- 2129 ACC0
- 2130 CLOSUREREC 1, 2106
- 2134 ACC2
- 2135 PUSHCONST0
- 2136 PUSHACC2
- 2137 APPTERM2 5
- 2139 CONST0
- 2140 PUSHACC1
- 2141 PUSHENVACC1
- 2142 APPTERM2 3
- 2144 ACC0
- 2145 BRANCHIFNOT 2151
- 2147 ACC0
- 2148 GETFIELD1
- 2149 RETURN 1
- 2151 GETGLOBAL "tl"
- 2153 PUSHGETGLOBALFIELD Pervasives, 3
- 2156 APPTERM1 2
- 2158 ACC0
- 2159 BRANCHIFNOT 2165
- 2161 ACC0
- 2162 GETFIELD0
- 2163 RETURN 1
- 2165 GETGLOBAL "hd"
- 2167 PUSHGETGLOBALFIELD Pervasives, 3
- 2170 APPTERM1 2
- 2172 ACC0
- 2173 PUSHCONST0
- 2174 PUSHENVACC1
- 2175 APPTERM2 3
- 2177 CLOSUREREC 0, 1200
- 2181 ACC0
- 2182 CLOSURE 1, 2172
- 2185 PUSH
- 2186 CLOSURE 0, 2158
- 2189 PUSH
- 2190 CLOSURE 0, 2144
- 2193 PUSH
- 2194 CLOSUREREC 0, 1217
- 2198 GETGLOBALFIELD Pervasives, 16
- 2201 PUSH
- 2202 CLOSUREREC 0, 1259
- 2206 ACC0
- 2207 CLOSURE 1, 2139
- 2210 PUSH
- 2211 CLOSUREREC 0, 1277
- 2215 CLOSUREREC 0, 1294
- 2219 CLOSURE 0, 2127
- 2222 PUSH
- 2223 CLOSUREREC 0, 1316
- 2227 CLOSUREREC 0, 1334
- 2231 CLOSUREREC 0, 1354
- 2235 CLOSUREREC 0, 1374
- 2239 CLOSURE 0, 2092
- 2242 PUSH
- 2243 CLOSUREREC 0, 1415
- 2247 CLOSUREREC 0, 1452
- 2251 CLOSUREREC 0, 1490
- 2255 CLOSUREREC 0, 1530
- 2259 CLOSUREREC 0, 1553
- 2263 CLOSUREREC 0, 1573
- 2267 CLOSUREREC 0, 1613
- 2271 CLOSUREREC 0, 1654
- 2275 CLOSUREREC 0, 1675
- 2279 CLOSUREREC 0, 1695
- 2283 CLOSUREREC 0, 1725
- 2287 CLOSUREREC 0, 1754
- 2291 CLOSUREREC 0, 1776
- 2295 CLOSUREREC 0, 1797
- 2299 CLOSUREREC 0, 1828
- 2303 CLOSUREREC 0, 1858
- 2307 ACC 24
- 2309 CLOSURE 1, 2042
- 2312 PUSHACC 25
- 2314 CLOSUREREC 1, 1928
- 2318 CLOSUREREC 0, 1942
- 2322 CLOSUREREC 0, 1972
- 2326 ACC0
- 2327 PUSHACC2
- 2328 PUSHACC7
- 2329 PUSHACC 9
- 2331 PUSHACC 11
- 2333 PUSHACC 13
- 2335 PUSHACC 15
- 2337 PUSHACC 17
- 2339 PUSHACC 10
- 2341 PUSHACC 12
- 2343 PUSHACC 13
- 2345 PUSHACC 15
- 2347 PUSHACC 23
- 2349 PUSHACC 25
- 2351 PUSHACC 27
- 2353 PUSHACC 29
- 2355 PUSHACC 31
- 2357 PUSHACC 33
- 2359 PUSHACC 35
- 2361 PUSHACC 37
- 2363 PUSHACC 40
- 2365 PUSHACC 42
- 2367 PUSHACC 41
- 2369 PUSHACC 45
- 2371 PUSHACC 47
- 2373 PUSHACC 50
- 2375 PUSHACC 52
- 2377 PUSHACC 51
- 2379 PUSHACC 55
- 2381 PUSHACC 56
- 2383 PUSHACC 59
- 2385 PUSHACC 61
- 2387 PUSHACC 60
- 2389 PUSHACC 64
- 2391 PUSHACC 66
- 2393 PUSHACC 68
- 2395 PUSHACC 70
- 2397 MAKEBLOCK 37, 0
- 2400 POP 36
- 2402 SETGLOBAL List
- 2404 BRANCH 2432
- 2406 CONST0
- 2407 PUSHACC1
- 2408 LEINT
- 2409 BRANCHIFNOT 2414
- 2411 CONST0
- 2412 RETURN 1
- 2414 ACC0
- 2415 OFFSETINT -1
- 2417 PUSHOFFSETCLOSURE0
- 2418 APPLY1
- 2419 PUSHACC1
- 2420 MAKEBLOCK2 0
- 2422 RETURN 1
- 2424 RESTART
- 2425 GRAB 1
- 2427 ACC1
- 2428 PUSHACC1
- 2429 ADDINT
- 2430 RETURN 2
- 2432 CLOSUREREC 0, 2406
- 2436 CONSTINT 300
- 2438 PUSHACC1
- 2439 APPLY1
- 2440 PUSHCONST0
- 2441 C_CALL1 gc_major
- 2443 CONSTINT 150
- 2445 PUSHCONSTINT 301
- 2447 MULINT
- 2448 PUSHACC1
- 2449 PUSHCONST0
- 2450 PUSH
- 2451 CLOSURE 0, 2425
- 2454 PUSHGETGLOBALFIELD List, 12
- 2457 APPLY3
- 2458 NEQ
- 2459 BRANCHIFNOT 2466
- 2461 GETGLOBAL Not_found
- 2463 MAKEBLOCK1 0
- 2465 RAISE
- 2466 POP 2
- 2468 ATOM0
- 2469 SETGLOBAL T320-gc-2
- 2471 STOP
-**)
diff --git a/test/testinterp/t320-gc-3.ml b/test/testinterp/t320-gc-3.ml
deleted file mode 100644
index 7c33d2fd16..0000000000
--- a/test/testinterp/t320-gc-3.ml
+++ /dev/null
@@ -1,1589 +0,0 @@
-open Lib;;
-let rec f n =
- if n <= 0 then []
- else n :: f (n-1)
-in
-let l = f 300 in
-Gc.full_major ();
-if List.fold_left (+) 0 l <> 301 * 150 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 746
- 11 RESTART
- 12 GRAB 1
- 14 ACC0
- 15 BRANCHIFNOT 28
- 17 ACC1
- 18 PUSHACC1
- 19 GETFIELD1
- 20 PUSHOFFSETCLOSURE0
- 21 APPLY2
- 22 PUSHACC1
- 23 GETFIELD0
- 24 MAKEBLOCK2 0
- 26 RETURN 2
- 28 ACC1
- 29 RETURN 2
- 31 RESTART
- 32 GRAB 3
- 34 CONST0
- 35 PUSHACC4
- 36 LEINT
- 37 BRANCHIFNOT 42
- 39 CONST0
- 40 RETURN 4
- 42 ACC3
- 43 PUSHACC3
- 44 PUSHACC3
- 45 PUSHACC3
- 46 C_CALL4 caml_input
- 48 PUSHCONST0
- 49 PUSHACC1
- 50 EQ
- 51 BRANCHIFNOT 58
- 53 GETGLOBAL End_of_file
- 55 MAKEBLOCK1 0
- 57 RAISE
- 58 ACC0
- 59 PUSHACC5
- 60 SUBINT
- 61 PUSHACC1
- 62 PUSHACC5
- 63 ADDINT
- 64 PUSHACC4
- 65 PUSHACC4
- 66 PUSHOFFSETCLOSURE0
- 67 APPTERM 4, 9
- 70 ACC0
- 71 C_CALL1 caml_input_scan_line
- 73 PUSHCONST0
- 74 PUSHACC1
- 75 EQ
- 76 BRANCHIFNOT 83
- 78 GETGLOBAL End_of_file
- 80 MAKEBLOCK1 0
- 82 RAISE
- 83 CONST0
- 84 PUSHACC1
- 85 GTINT
- 86 BRANCHIFNOT 107
- 88 ACC0
- 89 OFFSETINT -1
- 91 C_CALL1 create_string
- 93 PUSHACC1
- 94 OFFSETINT -1
- 96 PUSHCONST0
- 97 PUSHACC2
- 98 PUSHACC5
- 99 C_CALL4 caml_input
- 101 ACC2
- 102 C_CALL1 caml_input_char
- 104 ACC0
- 105 RETURN 3
- 107 ACC0
- 108 NEGINT
- 109 C_CALL1 create_string
- 111 PUSHACC1
- 112 NEGINT
- 113 PUSHCONST0
- 114 PUSHACC2
- 115 PUSHACC5
- 116 C_CALL4 caml_input
- 118 CONST0
- 119 PUSHTRAP 130
- 121 ACC6
- 122 PUSHOFFSETCLOSURE0
- 123 APPLY1
- 124 PUSHACC5
- 125 PUSHENVACC1
- 126 APPLY2
- 127 POPTRAP
- 128 RETURN 3
- 130 PUSHGETGLOBAL End_of_file
- 132 PUSHACC1
- 133 GETFIELD0
- 134 EQ
- 135 BRANCHIFNOT 140
- 137 ACC1
- 138 RETURN 4
- 140 ACC0
- 141 RAISE
- 142 ACC0
- 143 C_CALL1 caml_flush
- 145 RETURN 1
- 147 RESTART
- 148 GRAB 1
- 150 ACC1
- 151 PUSHACC1
- 152 C_CALL2 caml_output_char
- 154 RETURN 2
- 156 RESTART
- 157 GRAB 1
- 159 ACC1
- 160 PUSHACC1
- 161 C_CALL2 caml_output_char
- 163 RETURN 2
- 165 RESTART
- 166 GRAB 1
- 168 ACC1
- 169 PUSHACC1
- 170 C_CALL2 caml_output_int
- 172 RETURN 2
- 174 RESTART
- 175 GRAB 1
- 177 ACC1
- 178 PUSHACC1
- 179 C_CALL2 caml_seek_out
- 181 RETURN 2
- 183 ACC0
- 184 C_CALL1 caml_pos_out
- 186 RETURN 1
- 188 ACC0
- 189 C_CALL1 caml_channel_size
- 191 RETURN 1
- 193 RESTART
- 194 GRAB 1
- 196 ACC1
- 197 PUSHACC1
- 198 C_CALL2 caml_set_binary_mode
- 200 RETURN 2
- 202 ACC0
- 203 C_CALL1 caml_input_char
- 205 RETURN 1
- 207 ACC0
- 208 C_CALL1 caml_input_char
- 210 RETURN 1
- 212 ACC0
- 213 C_CALL1 caml_input_int
- 215 RETURN 1
- 217 ACC0
- 218 C_CALL1 input_value
- 220 RETURN 1
- 222 RESTART
- 223 GRAB 1
- 225 ACC1
- 226 PUSHACC1
- 227 C_CALL2 caml_seek_in
- 229 RETURN 2
- 231 ACC0
- 232 C_CALL1 caml_pos_in
- 234 RETURN 1
- 236 ACC0
- 237 C_CALL1 caml_channel_size
- 239 RETURN 1
- 241 ACC0
- 242 C_CALL1 caml_close_channel
- 244 RETURN 1
- 246 RESTART
- 247 GRAB 1
- 249 ACC1
- 250 PUSHACC1
- 251 C_CALL2 caml_set_binary_mode
- 253 RETURN 2
- 255 CONST0
- 256 PUSHENVACC1
- 257 APPLY1
- 258 ACC0
- 259 C_CALL1 sys_exit
- 261 RETURN 1
- 263 CONST0
- 264 PUSHENVACC1
- 265 GETFIELD0
- 266 APPTERM1 2
- 268 CONST0
- 269 PUSHENVACC1
- 270 APPLY1
- 271 CONST0
- 272 PUSHENVACC2
- 273 APPTERM1 2
- 275 ENVACC1
- 276 GETFIELD0
- 277 PUSHACC0
- 278 PUSHACC2
- 279 CLOSURE 2, 268
- 282 PUSHENVACC1
- 283 SETFIELD0
- 284 RETURN 2
- 286 ENVACC1
- 287 C_CALL1 caml_flush
- 289 ENVACC2
- 290 C_CALL1 caml_flush
- 292 RETURN 1
- 294 CONST0
- 295 PUSHENVACC1
- 296 APPLY1
- 297 C_CALL1 float_of_string
- 299 RETURN 1
- 301 CONST0
- 302 PUSHENVACC1
- 303 APPLY1
- 304 C_CALL1 int_of_string
- 306 RETURN 1
- 308 ENVACC2
- 309 C_CALL1 caml_flush
- 311 ENVACC1
- 312 PUSHENVACC3
- 313 APPTERM1 2
- 315 CONSTINT 13
- 317 PUSHENVACC1
- 318 C_CALL2 caml_output_char
- 320 ENVACC1
- 321 C_CALL1 caml_flush
- 323 RETURN 1
- 325 ACC0
- 326 PUSHENVACC1
- 327 PUSHENVACC2
- 328 APPLY2
- 329 CONSTINT 13
- 331 PUSHENVACC1
- 332 C_CALL2 caml_output_char
- 334 ENVACC1
- 335 C_CALL1 caml_flush
- 337 RETURN 1
- 339 ACC0
- 340 PUSHENVACC1
- 341 APPLY1
- 342 PUSHENVACC2
- 343 PUSHENVACC3
- 344 APPTERM2 3
- 346 ACC0
- 347 PUSHENVACC1
- 348 APPLY1
- 349 PUSHENVACC2
- 350 PUSHENVACC3
- 351 APPTERM2 3
- 353 ACC0
- 354 PUSHENVACC1
- 355 PUSHENVACC2
- 356 APPTERM2 3
- 358 ACC0
- 359 PUSHENVACC1
- 360 C_CALL2 caml_output_char
- 362 RETURN 1
- 364 CONSTINT 13
- 366 PUSHENVACC1
- 367 C_CALL2 caml_output_char
- 369 ENVACC1
- 370 C_CALL1 caml_flush
- 372 RETURN 1
- 374 ACC0
- 375 PUSHENVACC1
- 376 PUSHENVACC2
- 377 APPLY2
- 378 CONSTINT 13
- 380 PUSHENVACC1
- 381 C_CALL2 caml_output_char
- 383 RETURN 1
- 385 ACC0
- 386 PUSHENVACC1
- 387 APPLY1
- 388 PUSHENVACC2
- 389 PUSHENVACC3
- 390 APPTERM2 3
- 392 ACC0
- 393 PUSHENVACC1
- 394 APPLY1
- 395 PUSHENVACC2
- 396 PUSHENVACC3
- 397 APPTERM2 3
- 399 ACC0
- 400 PUSHENVACC1
- 401 PUSHENVACC2
- 402 APPTERM2 3
- 404 ACC0
- 405 PUSHENVACC1
- 406 C_CALL2 caml_output_char
- 408 RETURN 1
- 410 RESTART
- 411 GRAB 3
- 413 CONST0
- 414 PUSHACC3
- 415 LTINT
- 416 BRANCHIF 427
- 418 ACC1
- 419 C_CALL1 ml_string_length
- 421 PUSHACC4
- 422 PUSHACC4
- 423 ADDINT
- 424 GTINT
- 425 BRANCHIFNOT 432
- 427 GETGLOBAL "really_input"
- 429 PUSHENVACC1
- 430 APPTERM1 5
- 432 ACC3
- 433 PUSHACC3
- 434 PUSHACC3
- 435 PUSHACC3
- 436 PUSHENVACC2
- 437 APPTERM 4, 8
- 440 RESTART
- 441 GRAB 3
- 443 CONST0
- 444 PUSHACC3
- 445 LTINT
- 446 BRANCHIF 457
- 448 ACC1
- 449 C_CALL1 ml_string_length
- 451 PUSHACC4
- 452 PUSHACC4
- 453 ADDINT
- 454 GTINT
- 455 BRANCHIFNOT 462
- 457 GETGLOBAL "input"
- 459 PUSHENVACC1
- 460 APPTERM1 5
- 462 ACC3
- 463 PUSHACC3
- 464 PUSHACC3
- 465 PUSHACC3
- 466 C_CALL4 caml_input
- 468 RETURN 4
- 470 ACC0
- 471 PUSHCONST0
- 472 PUSHGETGLOBAL <0>(0, <0>(6, 0))
- 474 PUSHENVACC1
- 475 APPTERM3 4
- 477 ACC0
- 478 PUSHCONST0
- 479 PUSHGETGLOBAL <0>(0, <0>(7, 0))
- 481 PUSHENVACC1
- 482 APPTERM3 4
- 484 RESTART
- 485 GRAB 2
- 487 ACC1
- 488 PUSHACC1
- 489 PUSHACC4
- 490 C_CALL3 sys_open
- 492 C_CALL1 caml_open_descriptor
- 494 RETURN 3
- 496 ACC0
- 497 C_CALL1 caml_flush
- 499 ACC0
- 500 C_CALL1 caml_close_channel
- 502 RETURN 1
- 504 RESTART
- 505 GRAB 1
- 507 CONST0
- 508 PUSHACC2
- 509 PUSHACC2
- 510 C_CALL3 output_value
- 512 RETURN 2
- 514 RESTART
- 515 GRAB 3
- 517 CONST0
- 518 PUSHACC3
- 519 LTINT
- 520 BRANCHIF 531
- 522 ACC1
- 523 C_CALL1 ml_string_length
- 525 PUSHACC4
- 526 PUSHACC4
- 527 ADDINT
- 528 GTINT
- 529 BRANCHIFNOT 536
- 531 GETGLOBAL "output"
- 533 PUSHENVACC1
- 534 APPTERM1 5
- 536 ACC3
- 537 PUSHACC3
- 538 PUSHACC3
- 539 PUSHACC3
- 540 C_CALL4 caml_output
- 542 RETURN 4
- 544 RESTART
- 545 GRAB 1
- 547 ACC1
- 548 C_CALL1 ml_string_length
- 550 PUSHCONST0
- 551 PUSHACC3
- 552 PUSHACC3
- 553 C_CALL4 caml_output
- 555 RETURN 2
- 557 ACC0
- 558 PUSHCONSTINT 438
- 560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0))))
- 562 PUSHENVACC1
- 563 APPTERM3 4
- 565 ACC0
- 566 PUSHCONSTINT 438
- 568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0))))
- 570 PUSHENVACC1
- 571 APPTERM3 4
- 573 RESTART
- 574 GRAB 2
- 576 ACC1
- 577 PUSHACC1
- 578 PUSHACC4
- 579 C_CALL3 sys_open
- 581 C_CALL1 caml_open_descriptor
- 583 RETURN 3
- 585 ACC0
- 586 PUSHGETGLOBAL "%.12g"
- 588 C_CALL2 format_float
- 590 RETURN 1
- 592 ACC0
- 593 PUSHGETGLOBAL "%d"
- 595 C_CALL2 format_int
- 597 RETURN 1
- 599 GETGLOBAL "false"
- 601 PUSHACC1
- 602 C_CALL2 string_equal
- 604 BRANCHIFNOT 609
- 606 CONST0
- 607 RETURN 1
- 609 GETGLOBAL "true"
- 611 PUSHACC1
- 612 C_CALL2 string_equal
- 614 BRANCHIFNOT 619
- 616 CONST1
- 617 RETURN 1
- 619 GETGLOBAL "bool_of_string"
- 621 PUSHENVACC1
- 622 APPTERM1 2
- 624 ACC0
- 625 BRANCHIFNOT 631
- 627 GETGLOBAL "true"
- 629 RETURN 1
- 631 GETGLOBAL "false"
- 633 RETURN 1
- 635 CONST0
- 636 PUSHACC1
- 637 LTINT
- 638 BRANCHIF 646
- 640 CONSTINT 255
- 642 PUSHACC1
- 643 GTINT
- 644 BRANCHIFNOT 651
- 646 GETGLOBAL "char_of_int"
- 648 PUSHENVACC1
- 649 APPTERM1 2
- 651 ACC0
- 652 RETURN 1
- 654 RESTART
- 655 GRAB 1
- 657 ACC0
- 658 C_CALL1 ml_string_length
- 660 PUSHACC2
- 661 C_CALL1 ml_string_length
- 663 PUSHACC0
- 664 PUSHACC2
- 665 ADDINT
- 666 C_CALL1 create_string
- 668 PUSHACC2
- 669 PUSHCONST0
- 670 PUSHACC2
- 671 PUSHCONST0
- 672 PUSHACC7
- 673 C_CALL5 blit_string
- 675 ACC1
- 676 PUSHACC3
- 677 PUSHACC2
- 678 PUSHCONST0
- 679 PUSHACC 8
- 681 C_CALL5 blit_string
- 683 ACC0
- 684 RETURN 5
- 686 CONSTINT -1
- 688 PUSHACC1
- 689 XORINT
- 690 RETURN 1
- 692 CONST0
- 693 PUSHACC1
- 694 GEINT
- 695 BRANCHIFNOT 700
- 697 ACC0
- 698 RETURN 1
- 700 ACC0
- 701 NEGINT
- 702 RETURN 1
- 704 RESTART
- 705 GRAB 1
- 707 ACC1
- 708 PUSHACC1
- 709 C_CALL2 greaterequal
- 711 BRANCHIFNOT 716
- 713 ACC0
- 714 RETURN 2
- 716 ACC1
- 717 RETURN 2
- 719 RESTART
- 720 GRAB 1
- 722 ACC1
- 723 PUSHACC1
- 724 C_CALL2 lessequal
- 726 BRANCHIFNOT 731
- 728 ACC0
- 729 RETURN 2
- 731 ACC1
- 732 RETURN 2
- 734 ACC0
- 735 PUSHGETGLOBAL Invalid_argument
- 737 MAKEBLOCK2 0
- 739 RAISE
- 740 ACC0
- 741 PUSHGETGLOBAL Failure
- 743 MAKEBLOCK2 0
- 745 RAISE
- 746 CLOSURE 0, 740
- 749 PUSH
- 750 CLOSURE 0, 734
- 753 PUSHGETGLOBAL "Pervasives.Exit"
- 755 MAKEBLOCK1 0
- 757 PUSHGETGLOBAL "Pervasives.Assert_failure"
- 759 MAKEBLOCK1 0
- 761 PUSH
- 762 CLOSURE 0, 720
- 765 PUSH
- 766 CLOSURE 0, 705
- 769 PUSH
- 770 CLOSURE 0, 692
- 773 PUSH
- 774 CLOSURE 0, 686
- 777 PUSHCONST0
- 778 PUSHCONSTINT 31
- 780 PUSHCONST1
- 781 LSLINT
- 782 EQ
- 783 BRANCHIFNOT 789
- 785 CONSTINT 30
- 787 BRANCH 791
- 789 CONSTINT 62
- 791 PUSHCONST1
- 792 LSLINT
- 793 PUSHACC0
- 794 OFFSETINT -1
- 796 PUSH
- 797 CLOSURE 0, 655
- 800 PUSHACC 9
- 802 CLOSURE 1, 635
- 805 PUSH
- 806 CLOSURE 0, 624
- 809 PUSHACC 11
- 811 CLOSURE 1, 599
- 814 PUSH
- 815 CLOSURE 0, 592
- 818 PUSH
- 819 CLOSURE 0, 585
- 822 PUSH
- 823 CLOSUREREC 0, 12
- 827 CONST0
- 828 C_CALL1 caml_open_descriptor
- 830 PUSHCONST1
- 831 C_CALL1 caml_open_descriptor
- 833 PUSHCONST2
- 834 C_CALL1 caml_open_descriptor
- 836 PUSH
- 837 CLOSURE 0, 574
- 840 PUSHACC0
- 841 CLOSURE 1, 565
- 844 PUSHACC1
- 845 CLOSURE 1, 557
- 848 PUSH
- 849 CLOSURE 0, 545
- 852 PUSHACC 22
- 854 CLOSURE 1, 515
- 857 PUSH
- 858 CLOSURE 0, 505
- 861 PUSH
- 862 CLOSURE 0, 496
- 865 PUSH
- 866 CLOSURE 0, 485
- 869 PUSHACC0
- 870 CLOSURE 1, 477
- 873 PUSHACC1
- 874 CLOSURE 1, 470
- 877 PUSHACC 28
- 879 CLOSURE 1, 441
- 882 PUSH
- 883 CLOSUREREC 0, 32
- 887 ACC0
- 888 PUSHACC 31
- 890 CLOSURE 2, 411
- 893 PUSHACC 22
- 895 CLOSUREREC 1, 70
- 899 ACC 15
- 901 CLOSURE 1, 404
- 904 PUSHACC 11
- 906 PUSHACC 17
- 908 CLOSURE 2, 399
- 911 PUSHACC 12
- 913 PUSHACC 18
- 915 PUSHACC 23
- 917 CLOSURE 3, 392
- 920 PUSHACC 13
- 922 PUSHACC 19
- 924 PUSHACC 23
- 926 CLOSURE 3, 385
- 929 PUSHACC 14
- 931 PUSHACC 20
- 933 CLOSURE 2, 374
- 936 PUSHACC 20
- 938 CLOSURE 1, 364
- 941 PUSHACC 20
- 943 CLOSURE 1, 358
- 946 PUSHACC 17
- 948 PUSHACC 22
- 950 CLOSURE 2, 353
- 953 PUSHACC 18
- 955 PUSHACC 23
- 957 PUSHACC 29
- 959 CLOSURE 3, 346
- 962 PUSHACC 19
- 964 PUSHACC 24
- 966 PUSHACC 29
- 968 CLOSURE 3, 339
- 971 PUSHACC 20
- 973 PUSHACC 25
- 975 CLOSURE 2, 325
- 978 PUSHACC 25
- 980 CLOSURE 1, 315
- 983 PUSHACC 12
- 985 PUSHACC 28
- 987 PUSHACC 30
- 989 CLOSURE 3, 308
- 992 PUSHACC0
- 993 CLOSURE 1, 301
- 996 PUSHACC1
- 997 CLOSURE 1, 294
- 1000 PUSHACC 29
- 1002 PUSHACC 31
- 1004 CLOSURE 2, 286
- 1007 MAKEBLOCK1 0
- 1009 PUSHACC0
- 1010 CLOSURE 1, 275
- 1013 PUSHACC1
- 1014 CLOSURE 1, 263
- 1017 PUSHACC0
- 1018 CLOSURE 1, 255
- 1021 PUSHACC1
- 1022 PUSHACC 22
- 1024 PUSHACC4
- 1025 PUSHACC3
- 1026 PUSH
- 1027 CLOSURE 0, 247
- 1030 PUSH
- 1031 CLOSURE 0, 241
- 1034 PUSH
- 1035 CLOSURE 0, 236
- 1038 PUSH
- 1039 CLOSURE 0, 231
- 1042 PUSH
- 1043 CLOSURE 0, 223
- 1046 PUSH
- 1047 CLOSURE 0, 217
- 1050 PUSH
- 1051 CLOSURE 0, 212
- 1054 PUSH
- 1055 CLOSURE 0, 207
- 1058 PUSHACC 32
- 1060 PUSHACC 35
- 1062 PUSHACC 33
- 1064 PUSH
- 1065 CLOSURE 0, 202
- 1068 PUSHACC 41
- 1070 PUSHACC 40
- 1072 PUSHACC 42
- 1074 PUSH
- 1075 CLOSURE 0, 194
- 1078 PUSHACC 46
- 1080 PUSH
- 1081 CLOSURE 0, 188
- 1084 PUSH
- 1085 CLOSURE 0, 183
- 1088 PUSH
- 1089 CLOSURE 0, 175
- 1092 PUSHACC 51
- 1094 PUSH
- 1095 CLOSURE 0, 166
- 1098 PUSH
- 1099 CLOSURE 0, 157
- 1102 PUSHACC 55
- 1104 PUSHACC 57
- 1106 PUSH
- 1107 CLOSURE 0, 148
- 1110 PUSH
- 1111 CLOSURE 0, 142
- 1114 PUSHACC 63
- 1116 PUSHACC 62
- 1118 PUSHACC 64
- 1120 PUSHACC 38
- 1122 PUSHACC 40
- 1124 PUSHACC 42
- 1126 PUSHACC 44
- 1128 PUSHACC 46
- 1130 PUSHACC 48
- 1132 PUSHACC 50
- 1134 PUSHACC 52
- 1136 PUSHACC 54
- 1138 PUSHACC 56
- 1140 PUSHACC 58
- 1142 PUSHACC 60
- 1144 PUSHACC 62
- 1146 PUSHACC 64
- 1148 PUSHACC 66
- 1150 PUSHACC 82
- 1152 PUSHACC 84
- 1154 PUSHACC 86
- 1156 PUSHACC 88
- 1158 PUSHACC 90
- 1160 PUSHACC 92
- 1162 PUSHACC 94
- 1164 PUSHACC 96
- 1166 PUSHACC 98
- 1168 PUSHACC 100
- 1170 PUSHACC 104
- 1172 PUSHACC 104
- 1174 PUSHACC 104
- 1176 PUSHACC 108
- 1178 PUSHACC 110
- 1180 PUSHACC 112
- 1182 PUSHACC 117
- 1184 PUSHACC 117
- 1186 PUSHACC 117
- 1188 PUSHACC 117
- 1190 MAKEBLOCK 69, 0
- 1193 POP 53
- 1195 SETGLOBAL Pervasives
- 1197 BRANCH 2177
- 1199 RESTART
- 1200 GRAB 1
- 1202 ACC1
- 1203 BRANCHIFNOT 1213
- 1205 ACC1
- 1206 GETFIELD1
- 1207 PUSHACC1
- 1208 OFFSETINT 1
- 1210 PUSHOFFSETCLOSURE0
- 1211 APPTERM2 4
- 1213 ACC0
- 1214 RETURN 2
- 1216 RESTART
- 1217 GRAB 1
- 1219 ACC0
- 1220 BRANCHIFNOT 1251
- 1222 CONST0
- 1223 PUSHACC2
- 1224 EQ
- 1225 BRANCHIFNOT 1231
- 1227 ACC0
- 1228 GETFIELD0
- 1229 RETURN 2
- 1231 CONST0
- 1232 PUSHACC2
- 1233 GTINT
- 1234 BRANCHIFNOT 1244
- 1236 ACC1
- 1237 OFFSETINT -1
- 1239 PUSHACC1
- 1240 GETFIELD1
- 1241 PUSHOFFSETCLOSURE0
- 1242 APPTERM2 4
- 1244 GETGLOBAL "List.nth"
- 1246 PUSHGETGLOBALFIELD Pervasives, 2
- 1249 APPTERM1 3
- 1251 GETGLOBAL "nth"
- 1253 PUSHGETGLOBALFIELD Pervasives, 3
- 1256 APPTERM1 3
- 1258 RESTART
- 1259 GRAB 1
- 1261 ACC0
- 1262 BRANCHIFNOT 1274
- 1264 ACC1
- 1265 PUSHACC1
- 1266 GETFIELD0
- 1267 MAKEBLOCK2 0
- 1269 PUSHACC1
- 1270 GETFIELD1
- 1271 PUSHOFFSETCLOSURE0
- 1272 APPTERM2 4
- 1274 ACC1
- 1275 RETURN 2
- 1277 ACC0
- 1278 BRANCHIFNOT 1291
- 1280 ACC0
- 1281 GETFIELD1
- 1282 PUSHOFFSETCLOSURE0
- 1283 APPLY1
- 1284 PUSHACC1
- 1285 GETFIELD0
- 1286 PUSHGETGLOBALFIELD Pervasives, 16
- 1289 APPTERM2 3
- 1291 RETURN 1
- 1293 RESTART
- 1294 GRAB 1
- 1296 ACC1
- 1297 BRANCHIFNOT 1313
- 1299 ACC1
- 1300 GETFIELD0
- 1301 PUSHACC1
- 1302 APPLY1
- 1303 PUSHACC2
- 1304 GETFIELD1
- 1305 PUSHACC2
- 1306 PUSHOFFSETCLOSURE0
- 1307 APPLY2
- 1308 PUSHACC1
- 1309 MAKEBLOCK2 0
- 1311 POP 1
- 1313 RETURN 2
- 1315 RESTART
- 1316 GRAB 1
- 1318 ACC1
- 1319 BRANCHIFNOT 1331
- 1321 ACC1
- 1322 GETFIELD0
- 1323 PUSHACC1
- 1324 APPLY1
- 1325 ACC1
- 1326 GETFIELD1
- 1327 PUSHACC1
- 1328 PUSHOFFSETCLOSURE0
- 1329 APPTERM2 4
- 1331 RETURN 2
- 1333 RESTART
- 1334 GRAB 2
- 1336 ACC2
- 1337 BRANCHIFNOT 1350
- 1339 ACC2
- 1340 GETFIELD1
- 1341 PUSHACC3
- 1342 GETFIELD0
- 1343 PUSHACC3
- 1344 PUSHACC3
- 1345 APPLY2
- 1346 PUSHACC2
- 1347 PUSHOFFSETCLOSURE0
- 1348 APPTERM3 6
- 1350 ACC1
- 1351 RETURN 3
- 1353 RESTART
- 1354 GRAB 2
- 1356 ACC1
- 1357 BRANCHIFNOT 1370
- 1359 ACC2
- 1360 PUSHACC2
- 1361 GETFIELD1
- 1362 PUSHACC2
- 1363 PUSHOFFSETCLOSURE0
- 1364 APPLY3
- 1365 PUSHACC2
- 1366 GETFIELD0
- 1367 PUSHACC2
- 1368 APPTERM2 5
- 1370 ACC2
- 1371 RETURN 3
- 1373 RESTART
- 1374 GRAB 2
- 1376 ACC1
- 1377 BRANCHIFNOT 1400
- 1379 ACC2
- 1380 BRANCHIFNOT 1407
- 1382 ACC2
- 1383 GETFIELD0
- 1384 PUSHACC2
- 1385 GETFIELD0
- 1386 PUSHACC2
- 1387 APPLY2
- 1388 PUSHACC3
- 1389 GETFIELD1
- 1390 PUSHACC3
- 1391 GETFIELD1
- 1392 PUSHACC3
- 1393 PUSHOFFSETCLOSURE0
- 1394 APPLY3
- 1395 PUSHACC1
- 1396 MAKEBLOCK2 0
- 1398 RETURN 4
- 1400 ACC2
- 1401 BRANCHIFNOT 1405
- 1403 BRANCH 1407
- 1405 RETURN 3
- 1407 GETGLOBAL "List.map2"
- 1409 PUSHGETGLOBALFIELD Pervasives, 2
- 1412 APPTERM1 4
- 1414 RESTART
- 1415 GRAB 2
- 1417 ACC1
- 1418 BRANCHIFNOT 1437
- 1420 ACC2
- 1421 BRANCHIFNOT 1444
- 1423 ACC2
- 1424 GETFIELD0
- 1425 PUSHACC2
- 1426 GETFIELD0
- 1427 PUSHACC2
- 1428 APPLY2
- 1429 ACC2
- 1430 GETFIELD1
- 1431 PUSHACC2
- 1432 GETFIELD1
- 1433 PUSHACC2
- 1434 PUSHOFFSETCLOSURE0
- 1435 APPTERM3 6
- 1437 ACC2
- 1438 BRANCHIFNOT 1442
- 1440 BRANCH 1444
- 1442 RETURN 3
- 1444 GETGLOBAL "List.iter2"
- 1446 PUSHGETGLOBALFIELD Pervasives, 2
- 1449 APPTERM1 4
- 1451 RESTART
- 1452 GRAB 3
- 1454 ACC2
- 1455 BRANCHIFNOT 1476
- 1457 ACC3
- 1458 BRANCHIFNOT 1482
- 1460 ACC3
- 1461 GETFIELD1
- 1462 PUSHACC3
- 1463 GETFIELD1
- 1464 PUSHACC5
- 1465 GETFIELD0
- 1466 PUSHACC5
- 1467 GETFIELD0
- 1468 PUSHACC5
- 1469 PUSHACC5
- 1470 APPLY3
- 1471 PUSHACC3
- 1472 PUSHOFFSETCLOSURE0
- 1473 APPTERM 4, 8
- 1476 ACC3
- 1477 BRANCHIF 1482
- 1479 ACC1
- 1480 RETURN 4
- 1482 GETGLOBAL "List.fold_left2"
- 1484 PUSHGETGLOBALFIELD Pervasives, 2
- 1487 APPTERM1 5
- 1489 RESTART
- 1490 GRAB 3
- 1492 ACC1
- 1493 BRANCHIFNOT 1516
- 1495 ACC2
- 1496 BRANCHIFNOT 1522
- 1498 PUSH_RETADDR 1509
- 1500 ACC6
- 1501 PUSHACC6
- 1502 GETFIELD1
- 1503 PUSHACC6
- 1504 GETFIELD1
- 1505 PUSHACC6
- 1506 PUSHOFFSETCLOSURE0
- 1507 APPLY 4
- 1509 PUSHACC3
- 1510 GETFIELD0
- 1511 PUSHACC3
- 1512 GETFIELD0
- 1513 PUSHACC3
- 1514 APPTERM3 7
- 1516 ACC2
- 1517 BRANCHIF 1522
- 1519 ACC3
- 1520 RETURN 4
- 1522 GETGLOBAL "List.fold_right2"
- 1524 PUSHGETGLOBALFIELD Pervasives, 2
- 1527 APPTERM1 5
- 1529 RESTART
- 1530 GRAB 1
- 1532 ACC1
- 1533 BRANCHIFNOT 1549
- 1535 ACC1
- 1536 GETFIELD0
- 1537 PUSHACC1
- 1538 APPLY1
- 1539 BRANCHIFNOT 1547
- 1541 ACC1
- 1542 GETFIELD1
- 1543 PUSHACC1
- 1544 PUSHOFFSETCLOSURE0
- 1545 APPTERM2 4
- 1547 RETURN 2
- 1549 CONST1
- 1550 RETURN 2
- 1552 RESTART
- 1553 GRAB 1
- 1555 ACC1
- 1556 BRANCHIFNOT 1570
- 1558 ACC1
- 1559 GETFIELD0
- 1560 PUSHACC1
- 1561 APPLY1
- 1562 BRANCHIF 1570
- 1564 ACC1
- 1565 GETFIELD1
- 1566 PUSHACC1
- 1567 PUSHOFFSETCLOSURE0
- 1568 APPTERM2 4
- 1570 RETURN 2
- 1572 RESTART
- 1573 GRAB 2
- 1575 ACC1
- 1576 BRANCHIFNOT 1599
- 1578 ACC2
- 1579 BRANCHIFNOT 1605
- 1581 ACC2
- 1582 GETFIELD0
- 1583 PUSHACC2
- 1584 GETFIELD0
- 1585 PUSHACC2
- 1586 APPLY2
- 1587 BRANCHIFNOT 1597
- 1589 ACC2
- 1590 GETFIELD1
- 1591 PUSHACC2
- 1592 GETFIELD1
- 1593 PUSHACC2
- 1594 PUSHOFFSETCLOSURE0
- 1595 APPTERM3 6
- 1597 RETURN 3
- 1599 ACC2
- 1600 BRANCHIF 1605
- 1602 CONST1
- 1603 RETURN 3
- 1605 GETGLOBAL "List.for_all2"
- 1607 PUSHGETGLOBALFIELD Pervasives, 2
- 1610 APPTERM1 4
- 1612 RESTART
- 1613 GRAB 2
- 1615 ACC1
- 1616 BRANCHIFNOT 1639
- 1618 ACC2
- 1619 BRANCHIFNOT 1646
- 1621 ACC2
- 1622 GETFIELD0
- 1623 PUSHACC2
- 1624 GETFIELD0
- 1625 PUSHACC2
- 1626 APPLY2
- 1627 BRANCHIF 1637
- 1629 ACC2
- 1630 GETFIELD1
- 1631 PUSHACC2
- 1632 GETFIELD1
- 1633 PUSHACC2
- 1634 PUSHOFFSETCLOSURE0
- 1635 APPTERM3 6
- 1637 RETURN 3
- 1639 ACC2
- 1640 BRANCHIFNOT 1644
- 1642 BRANCH 1646
- 1644 RETURN 3
- 1646 GETGLOBAL "List.exists2"
- 1648 PUSHGETGLOBALFIELD Pervasives, 2
- 1651 APPTERM1 4
- 1653 RESTART
- 1654 GRAB 1
- 1656 ACC1
- 1657 BRANCHIFNOT 1672
- 1659 ACC0
- 1660 PUSHACC2
- 1661 GETFIELD0
- 1662 C_CALL2 equal
- 1664 BRANCHIF 1672
- 1666 ACC1
- 1667 GETFIELD1
- 1668 PUSHACC1
- 1669 PUSHOFFSETCLOSURE0
- 1670 APPTERM2 4
- 1672 RETURN 2
- 1674 RESTART
- 1675 GRAB 1
- 1677 ACC1
- 1678 BRANCHIFNOT 1692
- 1680 ACC0
- 1681 PUSHACC2
- 1682 GETFIELD0
- 1683 EQ
- 1684 BRANCHIF 1692
- 1686 ACC1
- 1687 GETFIELD1
- 1688 PUSHACC1
- 1689 PUSHOFFSETCLOSURE0
- 1690 APPTERM2 4
- 1692 RETURN 2
- 1694 RESTART
- 1695 GRAB 1
- 1697 ACC1
- 1698 BRANCHIFNOT 1719
- 1700 ACC1
- 1701 GETFIELD0
- 1702 PUSHACC1
- 1703 PUSHACC1
- 1704 GETFIELD0
- 1705 C_CALL2 equal
- 1707 BRANCHIFNOT 1713
- 1709 ACC0
- 1710 GETFIELD1
- 1711 RETURN 3
- 1713 ACC2
- 1714 GETFIELD1
- 1715 PUSHACC2
- 1716 PUSHOFFSETCLOSURE0
- 1717 APPTERM2 5
- 1719 GETGLOBAL Not_found
- 1721 MAKEBLOCK1 0
- 1723 RAISE
- 1724 RESTART
- 1725 GRAB 1
- 1727 ACC1
- 1728 BRANCHIFNOT 1748
- 1730 ACC1
- 1731 GETFIELD0
- 1732 PUSHACC1
- 1733 PUSHACC1
- 1734 GETFIELD0
- 1735 EQ
- 1736 BRANCHIFNOT 1742
- 1738 ACC0
- 1739 GETFIELD1
- 1740 RETURN 3
- 1742 ACC2
- 1743 GETFIELD1
- 1744 PUSHACC2
- 1745 PUSHOFFSETCLOSURE0
- 1746 APPTERM2 5
- 1748 GETGLOBAL Not_found
- 1750 MAKEBLOCK1 0
- 1752 RAISE
- 1753 RESTART
- 1754 GRAB 1
- 1756 ACC1
- 1757 BRANCHIFNOT 1773
- 1759 ACC0
- 1760 PUSHACC2
- 1761 GETFIELD0
- 1762 GETFIELD0
- 1763 C_CALL2 equal
- 1765 BRANCHIF 1773
- 1767 ACC1
- 1768 GETFIELD1
- 1769 PUSHACC1
- 1770 PUSHOFFSETCLOSURE0
- 1771 APPTERM2 4
- 1773 RETURN 2
- 1775 RESTART
- 1776 GRAB 1
- 1778 ACC1
- 1779 BRANCHIFNOT 1794
- 1781 ACC0
- 1782 PUSHACC2
- 1783 GETFIELD0
- 1784 GETFIELD0
- 1785 EQ
- 1786 BRANCHIF 1794
- 1788 ACC1
- 1789 GETFIELD1
- 1790 PUSHACC1
- 1791 PUSHOFFSETCLOSURE0
- 1792 APPTERM2 4
- 1794 RETURN 2
- 1796 RESTART
- 1797 GRAB 1
- 1799 ACC1
- 1800 BRANCHIFNOT 1825
- 1802 ACC1
- 1803 GETFIELD0
- 1804 PUSHACC2
- 1805 GETFIELD1
- 1806 PUSHACC2
- 1807 PUSHACC2
- 1808 GETFIELD0
- 1809 C_CALL2 equal
- 1811 BRANCHIFNOT 1816
- 1813 ACC0
- 1814 RETURN 4
- 1816 ACC0
- 1817 PUSHACC3
- 1818 PUSHOFFSETCLOSURE0
- 1819 APPLY2
- 1820 PUSHACC2
- 1821 MAKEBLOCK2 0
- 1823 POP 2
- 1825 RETURN 2
- 1827 RESTART
- 1828 GRAB 1
- 1830 ACC1
- 1831 BRANCHIFNOT 1855
- 1833 ACC1
- 1834 GETFIELD0
- 1835 PUSHACC2
- 1836 GETFIELD1
- 1837 PUSHACC2
- 1838 PUSHACC2
- 1839 GETFIELD0
- 1840 EQ
- 1841 BRANCHIFNOT 1846
- 1843 ACC0
- 1844 RETURN 4
- 1846 ACC0
- 1847 PUSHACC3
- 1848 PUSHOFFSETCLOSURE0
- 1849 APPLY2
- 1850 PUSHACC2
- 1851 MAKEBLOCK2 0
- 1853 POP 2
- 1855 RETURN 2
- 1857 RESTART
- 1858 GRAB 1
- 1860 ACC1
- 1861 BRANCHIFNOT 1879
- 1863 ACC1
- 1864 GETFIELD0
- 1865 PUSHACC0
- 1866 PUSHACC2
- 1867 APPLY1
- 1868 BRANCHIFNOT 1873
- 1870 ACC0
- 1871 RETURN 3
- 1873 ACC2
- 1874 GETFIELD1
- 1875 PUSHACC2
- 1876 PUSHOFFSETCLOSURE0
- 1877 APPTERM2 5
- 1879 GETGLOBAL Not_found
- 1881 MAKEBLOCK1 0
- 1883 RAISE
- 1884 RESTART
- 1885 GRAB 2
- 1887 ACC2
- 1888 BRANCHIFNOT 1917
- 1890 ACC2
- 1891 GETFIELD0
- 1892 PUSHACC3
- 1893 GETFIELD1
- 1894 PUSHACC1
- 1895 PUSHENVACC2
- 1896 APPLY1
- 1897 BRANCHIFNOT 1908
- 1899 ACC0
- 1900 PUSHACC4
- 1901 PUSHACC4
- 1902 PUSHACC4
- 1903 MAKEBLOCK2 0
- 1905 PUSHOFFSETCLOSURE0
- 1906 APPTERM3 8
- 1908 ACC0
- 1909 PUSHACC4
- 1910 PUSHACC3
- 1911 MAKEBLOCK2 0
- 1913 PUSHACC4
- 1914 PUSHOFFSETCLOSURE0
- 1915 APPTERM3 8
- 1917 ACC1
- 1918 PUSHENVACC1
- 1919 APPLY1
- 1920 PUSHACC1
- 1921 PUSHENVACC1
- 1922 APPLY1
- 1923 MAKEBLOCK2 0
- 1925 RETURN 3
- 1927 RESTART
- 1928 GRAB 1
- 1930 ACC0
- 1931 PUSHENVACC1
- 1932 CLOSUREREC 2, 1885
- 1936 ACC2
- 1937 PUSHCONST0
- 1938 PUSHCONST0
- 1939 PUSHACC3
- 1940 APPTERM3 6
- 1942 ACC0
- 1943 BRANCHIFNOT 1967
- 1945 ACC0
- 1946 GETFIELD0
- 1947 PUSHACC1
- 1948 GETFIELD1
- 1949 PUSHOFFSETCLOSURE0
- 1950 APPLY1
- 1951 PUSHACC0
- 1952 GETFIELD1
- 1953 PUSHACC2
- 1954 GETFIELD1
- 1955 MAKEBLOCK2 0
- 1957 PUSHACC1
- 1958 GETFIELD0
- 1959 PUSHACC3
- 1960 GETFIELD0
- 1961 MAKEBLOCK2 0
- 1963 MAKEBLOCK2 0
- 1965 RETURN 3
- 1967 GETGLOBAL <0>(0, 0)
- 1969 RETURN 1
- 1971 RESTART
- 1972 GRAB 1
- 1974 ACC0
- 1975 BRANCHIFNOT 1996
- 1977 ACC1
- 1978 BRANCHIFNOT 2003
- 1980 ACC1
- 1981 GETFIELD1
- 1982 PUSHACC1
- 1983 GETFIELD1
- 1984 PUSHOFFSETCLOSURE0
- 1985 APPLY2
- 1986 PUSHACC2
- 1987 GETFIELD0
- 1988 PUSHACC2
- 1989 GETFIELD0
- 1990 MAKEBLOCK2 0
- 1992 MAKEBLOCK2 0
- 1994 RETURN 2
- 1996 ACC1
- 1997 BRANCHIFNOT 2001
- 1999 BRANCH 2003
- 2001 RETURN 2
- 2003 GETGLOBAL "List.combine"
- 2005 PUSHGETGLOBALFIELD Pervasives, 2
- 2008 APPTERM1 3
- 2010 RESTART
- 2011 GRAB 1
- 2013 ACC1
- 2014 BRANCHIFNOT 2038
- 2016 ACC1
- 2017 GETFIELD0
- 2018 PUSHACC2
- 2019 GETFIELD1
- 2020 PUSHACC1
- 2021 PUSHENVACC2
- 2022 APPLY1
- 2023 BRANCHIFNOT 2033
- 2025 ACC0
- 2026 PUSHACC3
- 2027 PUSHACC3
- 2028 MAKEBLOCK2 0
- 2030 PUSHOFFSETCLOSURE0
- 2031 APPTERM2 6
- 2033 ACC0
- 2034 PUSHACC3
- 2035 PUSHOFFSETCLOSURE0
- 2036 APPTERM2 6
- 2038 ACC0
- 2039 PUSHENVACC1
- 2040 APPTERM1 3
- 2042 ACC0
- 2043 PUSHENVACC1
- 2044 CLOSUREREC 2, 2011
- 2048 CONST0
- 2049 PUSHACC1
- 2050 APPTERM1 3
- 2052 RESTART
- 2053 GRAB 2
- 2055 ACC1
- 2056 BRANCHIFNOT 2077
- 2058 ACC2
- 2059 BRANCHIFNOT 2084
- 2061 ACC2
- 2062 GETFIELD1
- 2063 PUSHACC2
- 2064 GETFIELD1
- 2065 PUSHACC2
- 2066 PUSHACC5
- 2067 GETFIELD0
- 2068 PUSHACC5
- 2069 GETFIELD0
- 2070 PUSHENVACC1
- 2071 APPLY2
- 2072 MAKEBLOCK2 0
- 2074 PUSHOFFSETCLOSURE0
- 2075 APPTERM3 6
- 2077 ACC2
- 2078 BRANCHIFNOT 2082
- 2080 BRANCH 2084
- 2082 RETURN 3
- 2084 GETGLOBAL "List.rev_map2"
- 2086 PUSHGETGLOBALFIELD Pervasives, 2
- 2089 APPTERM1 4
- 2091 RESTART
- 2092 GRAB 2
- 2094 ACC0
- 2095 CLOSUREREC 1, 2053
- 2099 ACC3
- 2100 PUSHACC3
- 2101 PUSHCONST0
- 2102 PUSHACC3
- 2103 APPTERM3 7
- 2105 RESTART
- 2106 GRAB 1
- 2108 ACC1
- 2109 BRANCHIFNOT 2123
- 2111 ACC1
- 2112 GETFIELD1
- 2113 PUSHACC1
- 2114 PUSHACC3
- 2115 GETFIELD0
- 2116 PUSHENVACC1
- 2117 APPLY1
- 2118 MAKEBLOCK2 0
- 2120 PUSHOFFSETCLOSURE0
- 2121 APPTERM2 4
- 2123 ACC0
- 2124 RETURN 2
- 2126 RESTART
- 2127 GRAB 1
- 2129 ACC0
- 2130 CLOSUREREC 1, 2106
- 2134 ACC2
- 2135 PUSHCONST0
- 2136 PUSHACC2
- 2137 APPTERM2 5
- 2139 CONST0
- 2140 PUSHACC1
- 2141 PUSHENVACC1
- 2142 APPTERM2 3
- 2144 ACC0
- 2145 BRANCHIFNOT 2151
- 2147 ACC0
- 2148 GETFIELD1
- 2149 RETURN 1
- 2151 GETGLOBAL "tl"
- 2153 PUSHGETGLOBALFIELD Pervasives, 3
- 2156 APPTERM1 2
- 2158 ACC0
- 2159 BRANCHIFNOT 2165
- 2161 ACC0
- 2162 GETFIELD0
- 2163 RETURN 1
- 2165 GETGLOBAL "hd"
- 2167 PUSHGETGLOBALFIELD Pervasives, 3
- 2170 APPTERM1 2
- 2172 ACC0
- 2173 PUSHCONST0
- 2174 PUSHENVACC1
- 2175 APPTERM2 3
- 2177 CLOSUREREC 0, 1200
- 2181 ACC0
- 2182 CLOSURE 1, 2172
- 2185 PUSH
- 2186 CLOSURE 0, 2158
- 2189 PUSH
- 2190 CLOSURE 0, 2144
- 2193 PUSH
- 2194 CLOSUREREC 0, 1217
- 2198 GETGLOBALFIELD Pervasives, 16
- 2201 PUSH
- 2202 CLOSUREREC 0, 1259
- 2206 ACC0
- 2207 CLOSURE 1, 2139
- 2210 PUSH
- 2211 CLOSUREREC 0, 1277
- 2215 CLOSUREREC 0, 1294
- 2219 CLOSURE 0, 2127
- 2222 PUSH
- 2223 CLOSUREREC 0, 1316
- 2227 CLOSUREREC 0, 1334
- 2231 CLOSUREREC 0, 1354
- 2235 CLOSUREREC 0, 1374
- 2239 CLOSURE 0, 2092
- 2242 PUSH
- 2243 CLOSUREREC 0, 1415
- 2247 CLOSUREREC 0, 1452
- 2251 CLOSUREREC 0, 1490
- 2255 CLOSUREREC 0, 1530
- 2259 CLOSUREREC 0, 1553
- 2263 CLOSUREREC 0, 1573
- 2267 CLOSUREREC 0, 1613
- 2271 CLOSUREREC 0, 1654
- 2275 CLOSUREREC 0, 1675
- 2279 CLOSUREREC 0, 1695
- 2283 CLOSUREREC 0, 1725
- 2287 CLOSUREREC 0, 1754
- 2291 CLOSUREREC 0, 1776
- 2295 CLOSUREREC 0, 1797
- 2299 CLOSUREREC 0, 1828
- 2303 CLOSUREREC 0, 1858
- 2307 ACC 24
- 2309 CLOSURE 1, 2042
- 2312 PUSHACC 25
- 2314 CLOSUREREC 1, 1928
- 2318 CLOSUREREC 0, 1942
- 2322 CLOSUREREC 0, 1972
- 2326 ACC0
- 2327 PUSHACC2
- 2328 PUSHACC7
- 2329 PUSHACC 9
- 2331 PUSHACC 11
- 2333 PUSHACC 13
- 2335 PUSHACC 15
- 2337 PUSHACC 17
- 2339 PUSHACC 10
- 2341 PUSHACC 12
- 2343 PUSHACC 13
- 2345 PUSHACC 15
- 2347 PUSHACC 23
- 2349 PUSHACC 25
- 2351 PUSHACC 27
- 2353 PUSHACC 29
- 2355 PUSHACC 31
- 2357 PUSHACC 33
- 2359 PUSHACC 35
- 2361 PUSHACC 37
- 2363 PUSHACC 40
- 2365 PUSHACC 42
- 2367 PUSHACC 41
- 2369 PUSHACC 45
- 2371 PUSHACC 47
- 2373 PUSHACC 50
- 2375 PUSHACC 52
- 2377 PUSHACC 51
- 2379 PUSHACC 55
- 2381 PUSHACC 56
- 2383 PUSHACC 59
- 2385 PUSHACC 61
- 2387 PUSHACC 60
- 2389 PUSHACC 64
- 2391 PUSHACC 66
- 2393 PUSHACC 68
- 2395 PUSHACC 70
- 2397 MAKEBLOCK 37, 0
- 2400 POP 36
- 2402 SETGLOBAL List
- 2404 BRANCH 2432
- 2406 CONST0
- 2407 PUSHACC1
- 2408 LEINT
- 2409 BRANCHIFNOT 2414
- 2411 CONST0
- 2412 RETURN 1
- 2414 ACC0
- 2415 OFFSETINT -1
- 2417 PUSHOFFSETCLOSURE0
- 2418 APPLY1
- 2419 PUSHACC1
- 2420 MAKEBLOCK2 0
- 2422 RETURN 1
- 2424 RESTART
- 2425 GRAB 1
- 2427 ACC1
- 2428 PUSHACC1
- 2429 ADDINT
- 2430 RETURN 2
- 2432 CLOSUREREC 0, 2406
- 2436 CONSTINT 300
- 2438 PUSHACC1
- 2439 APPLY1
- 2440 PUSHCONST0
- 2441 C_CALL1 gc_full_major
- 2443 CONSTINT 150
- 2445 PUSHCONSTINT 301
- 2447 MULINT
- 2448 PUSHACC1
- 2449 PUSHCONST0
- 2450 PUSH
- 2451 CLOSURE 0, 2425
- 2454 PUSHGETGLOBALFIELD List, 12
- 2457 APPLY3
- 2458 NEQ
- 2459 BRANCHIFNOT 2466
- 2461 GETGLOBAL Not_found
- 2463 MAKEBLOCK1 0
- 2465 RAISE
- 2466 POP 2
- 2468 ATOM0
- 2469 SETGLOBAL T320-gc-3
- 2471 STOP
-**)
diff --git a/test/testinterp/t330-compact-1.ml b/test/testinterp/t330-compact-1.ml
deleted file mode 100644
index efa958fd29..0000000000
--- a/test/testinterp/t330-compact-1.ml
+++ /dev/null
@@ -1,15 +0,0 @@
-open Lib;;
-Gc.compact ();;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 CONST0
- 10 C_CALL1 gc_compaction
- 12 ATOM0
- 13 SETGLOBAL T330-compact-1
- 15 STOP
-**)
diff --git a/test/testinterp/t330-compact-2.ml b/test/testinterp/t330-compact-2.ml
deleted file mode 100644
index 62ab0141d5..0000000000
--- a/test/testinterp/t330-compact-2.ml
+++ /dev/null
@@ -1,755 +0,0 @@
-open Lib;;
-Gc.compact ();;
-let _ = Pervasives.do_at_exit();;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 746
- 11 RESTART
- 12 GRAB 1
- 14 ACC0
- 15 BRANCHIFNOT 28
- 17 ACC1
- 18 PUSHACC1
- 19 GETFIELD1
- 20 PUSHOFFSETCLOSURE0
- 21 APPLY2
- 22 PUSHACC1
- 23 GETFIELD0
- 24 MAKEBLOCK2 0
- 26 RETURN 2
- 28 ACC1
- 29 RETURN 2
- 31 RESTART
- 32 GRAB 3
- 34 CONST0
- 35 PUSHACC4
- 36 LEINT
- 37 BRANCHIFNOT 42
- 39 CONST0
- 40 RETURN 4
- 42 ACC3
- 43 PUSHACC3
- 44 PUSHACC3
- 45 PUSHACC3
- 46 C_CALL4 caml_input
- 48 PUSHCONST0
- 49 PUSHACC1
- 50 EQ
- 51 BRANCHIFNOT 58
- 53 GETGLOBAL End_of_file
- 55 MAKEBLOCK1 0
- 57 RAISE
- 58 ACC0
- 59 PUSHACC5
- 60 SUBINT
- 61 PUSHACC1
- 62 PUSHACC5
- 63 ADDINT
- 64 PUSHACC4
- 65 PUSHACC4
- 66 PUSHOFFSETCLOSURE0
- 67 APPTERM 4, 9
- 70 ACC0
- 71 C_CALL1 caml_input_scan_line
- 73 PUSHCONST0
- 74 PUSHACC1
- 75 EQ
- 76 BRANCHIFNOT 83
- 78 GETGLOBAL End_of_file
- 80 MAKEBLOCK1 0
- 82 RAISE
- 83 CONST0
- 84 PUSHACC1
- 85 GTINT
- 86 BRANCHIFNOT 107
- 88 ACC0
- 89 OFFSETINT -1
- 91 C_CALL1 create_string
- 93 PUSHACC1
- 94 OFFSETINT -1
- 96 PUSHCONST0
- 97 PUSHACC2
- 98 PUSHACC5
- 99 C_CALL4 caml_input
- 101 ACC2
- 102 C_CALL1 caml_input_char
- 104 ACC0
- 105 RETURN 3
- 107 ACC0
- 108 NEGINT
- 109 C_CALL1 create_string
- 111 PUSHACC1
- 112 NEGINT
- 113 PUSHCONST0
- 114 PUSHACC2
- 115 PUSHACC5
- 116 C_CALL4 caml_input
- 118 CONST0
- 119 PUSHTRAP 130
- 121 ACC6
- 122 PUSHOFFSETCLOSURE0
- 123 APPLY1
- 124 PUSHACC5
- 125 PUSHENVACC1
- 126 APPLY2
- 127 POPTRAP
- 128 RETURN 3
- 130 PUSHGETGLOBAL End_of_file
- 132 PUSHACC1
- 133 GETFIELD0
- 134 EQ
- 135 BRANCHIFNOT 140
- 137 ACC1
- 138 RETURN 4
- 140 ACC0
- 141 RAISE
- 142 ACC0
- 143 C_CALL1 caml_flush
- 145 RETURN 1
- 147 RESTART
- 148 GRAB 1
- 150 ACC1
- 151 PUSHACC1
- 152 C_CALL2 caml_output_char
- 154 RETURN 2
- 156 RESTART
- 157 GRAB 1
- 159 ACC1
- 160 PUSHACC1
- 161 C_CALL2 caml_output_char
- 163 RETURN 2
- 165 RESTART
- 166 GRAB 1
- 168 ACC1
- 169 PUSHACC1
- 170 C_CALL2 caml_output_int
- 172 RETURN 2
- 174 RESTART
- 175 GRAB 1
- 177 ACC1
- 178 PUSHACC1
- 179 C_CALL2 caml_seek_out
- 181 RETURN 2
- 183 ACC0
- 184 C_CALL1 caml_pos_out
- 186 RETURN 1
- 188 ACC0
- 189 C_CALL1 caml_channel_size
- 191 RETURN 1
- 193 RESTART
- 194 GRAB 1
- 196 ACC1
- 197 PUSHACC1
- 198 C_CALL2 caml_set_binary_mode
- 200 RETURN 2
- 202 ACC0
- 203 C_CALL1 caml_input_char
- 205 RETURN 1
- 207 ACC0
- 208 C_CALL1 caml_input_char
- 210 RETURN 1
- 212 ACC0
- 213 C_CALL1 caml_input_int
- 215 RETURN 1
- 217 ACC0
- 218 C_CALL1 input_value
- 220 RETURN 1
- 222 RESTART
- 223 GRAB 1
- 225 ACC1
- 226 PUSHACC1
- 227 C_CALL2 caml_seek_in
- 229 RETURN 2
- 231 ACC0
- 232 C_CALL1 caml_pos_in
- 234 RETURN 1
- 236 ACC0
- 237 C_CALL1 caml_channel_size
- 239 RETURN 1
- 241 ACC0
- 242 C_CALL1 caml_close_channel
- 244 RETURN 1
- 246 RESTART
- 247 GRAB 1
- 249 ACC1
- 250 PUSHACC1
- 251 C_CALL2 caml_set_binary_mode
- 253 RETURN 2
- 255 CONST0
- 256 PUSHENVACC1
- 257 APPLY1
- 258 ACC0
- 259 C_CALL1 sys_exit
- 261 RETURN 1
- 263 CONST0
- 264 PUSHENVACC1
- 265 GETFIELD0
- 266 APPTERM1 2
- 268 CONST0
- 269 PUSHENVACC1
- 270 APPLY1
- 271 CONST0
- 272 PUSHENVACC2
- 273 APPTERM1 2
- 275 ENVACC1
- 276 GETFIELD0
- 277 PUSHACC0
- 278 PUSHACC2
- 279 CLOSURE 2, 268
- 282 PUSHENVACC1
- 283 SETFIELD0
- 284 RETURN 2
- 286 ENVACC1
- 287 C_CALL1 caml_flush
- 289 ENVACC2
- 290 C_CALL1 caml_flush
- 292 RETURN 1
- 294 CONST0
- 295 PUSHENVACC1
- 296 APPLY1
- 297 C_CALL1 float_of_string
- 299 RETURN 1
- 301 CONST0
- 302 PUSHENVACC1
- 303 APPLY1
- 304 C_CALL1 int_of_string
- 306 RETURN 1
- 308 ENVACC2
- 309 C_CALL1 caml_flush
- 311 ENVACC1
- 312 PUSHENVACC3
- 313 APPTERM1 2
- 315 CONSTINT 13
- 317 PUSHENVACC1
- 318 C_CALL2 caml_output_char
- 320 ENVACC1
- 321 C_CALL1 caml_flush
- 323 RETURN 1
- 325 ACC0
- 326 PUSHENVACC1
- 327 PUSHENVACC2
- 328 APPLY2
- 329 CONSTINT 13
- 331 PUSHENVACC1
- 332 C_CALL2 caml_output_char
- 334 ENVACC1
- 335 C_CALL1 caml_flush
- 337 RETURN 1
- 339 ACC0
- 340 PUSHENVACC1
- 341 APPLY1
- 342 PUSHENVACC2
- 343 PUSHENVACC3
- 344 APPTERM2 3
- 346 ACC0
- 347 PUSHENVACC1
- 348 APPLY1
- 349 PUSHENVACC2
- 350 PUSHENVACC3
- 351 APPTERM2 3
- 353 ACC0
- 354 PUSHENVACC1
- 355 PUSHENVACC2
- 356 APPTERM2 3
- 358 ACC0
- 359 PUSHENVACC1
- 360 C_CALL2 caml_output_char
- 362 RETURN 1
- 364 CONSTINT 13
- 366 PUSHENVACC1
- 367 C_CALL2 caml_output_char
- 369 ENVACC1
- 370 C_CALL1 caml_flush
- 372 RETURN 1
- 374 ACC0
- 375 PUSHENVACC1
- 376 PUSHENVACC2
- 377 APPLY2
- 378 CONSTINT 13
- 380 PUSHENVACC1
- 381 C_CALL2 caml_output_char
- 383 RETURN 1
- 385 ACC0
- 386 PUSHENVACC1
- 387 APPLY1
- 388 PUSHENVACC2
- 389 PUSHENVACC3
- 390 APPTERM2 3
- 392 ACC0
- 393 PUSHENVACC1
- 394 APPLY1
- 395 PUSHENVACC2
- 396 PUSHENVACC3
- 397 APPTERM2 3
- 399 ACC0
- 400 PUSHENVACC1
- 401 PUSHENVACC2
- 402 APPTERM2 3
- 404 ACC0
- 405 PUSHENVACC1
- 406 C_CALL2 caml_output_char
- 408 RETURN 1
- 410 RESTART
- 411 GRAB 3
- 413 CONST0
- 414 PUSHACC3
- 415 LTINT
- 416 BRANCHIF 427
- 418 ACC1
- 419 C_CALL1 ml_string_length
- 421 PUSHACC4
- 422 PUSHACC4
- 423 ADDINT
- 424 GTINT
- 425 BRANCHIFNOT 432
- 427 GETGLOBAL "really_input"
- 429 PUSHENVACC1
- 430 APPTERM1 5
- 432 ACC3
- 433 PUSHACC3
- 434 PUSHACC3
- 435 PUSHACC3
- 436 PUSHENVACC2
- 437 APPTERM 4, 8
- 440 RESTART
- 441 GRAB 3
- 443 CONST0
- 444 PUSHACC3
- 445 LTINT
- 446 BRANCHIF 457
- 448 ACC1
- 449 C_CALL1 ml_string_length
- 451 PUSHACC4
- 452 PUSHACC4
- 453 ADDINT
- 454 GTINT
- 455 BRANCHIFNOT 462
- 457 GETGLOBAL "input"
- 459 PUSHENVACC1
- 460 APPTERM1 5
- 462 ACC3
- 463 PUSHACC3
- 464 PUSHACC3
- 465 PUSHACC3
- 466 C_CALL4 caml_input
- 468 RETURN 4
- 470 ACC0
- 471 PUSHCONST0
- 472 PUSHGETGLOBAL <0>(0, <0>(6, 0))
- 474 PUSHENVACC1
- 475 APPTERM3 4
- 477 ACC0
- 478 PUSHCONST0
- 479 PUSHGETGLOBAL <0>(0, <0>(7, 0))
- 481 PUSHENVACC1
- 482 APPTERM3 4
- 484 RESTART
- 485 GRAB 2
- 487 ACC1
- 488 PUSHACC1
- 489 PUSHACC4
- 490 C_CALL3 sys_open
- 492 C_CALL1 caml_open_descriptor
- 494 RETURN 3
- 496 ACC0
- 497 C_CALL1 caml_flush
- 499 ACC0
- 500 C_CALL1 caml_close_channel
- 502 RETURN 1
- 504 RESTART
- 505 GRAB 1
- 507 CONST0
- 508 PUSHACC2
- 509 PUSHACC2
- 510 C_CALL3 output_value
- 512 RETURN 2
- 514 RESTART
- 515 GRAB 3
- 517 CONST0
- 518 PUSHACC3
- 519 LTINT
- 520 BRANCHIF 531
- 522 ACC1
- 523 C_CALL1 ml_string_length
- 525 PUSHACC4
- 526 PUSHACC4
- 527 ADDINT
- 528 GTINT
- 529 BRANCHIFNOT 536
- 531 GETGLOBAL "output"
- 533 PUSHENVACC1
- 534 APPTERM1 5
- 536 ACC3
- 537 PUSHACC3
- 538 PUSHACC3
- 539 PUSHACC3
- 540 C_CALL4 caml_output
- 542 RETURN 4
- 544 RESTART
- 545 GRAB 1
- 547 ACC1
- 548 C_CALL1 ml_string_length
- 550 PUSHCONST0
- 551 PUSHACC3
- 552 PUSHACC3
- 553 C_CALL4 caml_output
- 555 RETURN 2
- 557 ACC0
- 558 PUSHCONSTINT 438
- 560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0))))
- 562 PUSHENVACC1
- 563 APPTERM3 4
- 565 ACC0
- 566 PUSHCONSTINT 438
- 568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0))))
- 570 PUSHENVACC1
- 571 APPTERM3 4
- 573 RESTART
- 574 GRAB 2
- 576 ACC1
- 577 PUSHACC1
- 578 PUSHACC4
- 579 C_CALL3 sys_open
- 581 C_CALL1 caml_open_descriptor
- 583 RETURN 3
- 585 ACC0
- 586 PUSHGETGLOBAL "%.12g"
- 588 C_CALL2 format_float
- 590 RETURN 1
- 592 ACC0
- 593 PUSHGETGLOBAL "%d"
- 595 C_CALL2 format_int
- 597 RETURN 1
- 599 GETGLOBAL "false"
- 601 PUSHACC1
- 602 C_CALL2 string_equal
- 604 BRANCHIFNOT 609
- 606 CONST0
- 607 RETURN 1
- 609 GETGLOBAL "true"
- 611 PUSHACC1
- 612 C_CALL2 string_equal
- 614 BRANCHIFNOT 619
- 616 CONST1
- 617 RETURN 1
- 619 GETGLOBAL "bool_of_string"
- 621 PUSHENVACC1
- 622 APPTERM1 2
- 624 ACC0
- 625 BRANCHIFNOT 631
- 627 GETGLOBAL "true"
- 629 RETURN 1
- 631 GETGLOBAL "false"
- 633 RETURN 1
- 635 CONST0
- 636 PUSHACC1
- 637 LTINT
- 638 BRANCHIF 646
- 640 CONSTINT 255
- 642 PUSHACC1
- 643 GTINT
- 644 BRANCHIFNOT 651
- 646 GETGLOBAL "char_of_int"
- 648 PUSHENVACC1
- 649 APPTERM1 2
- 651 ACC0
- 652 RETURN 1
- 654 RESTART
- 655 GRAB 1
- 657 ACC0
- 658 C_CALL1 ml_string_length
- 660 PUSHACC2
- 661 C_CALL1 ml_string_length
- 663 PUSHACC0
- 664 PUSHACC2
- 665 ADDINT
- 666 C_CALL1 create_string
- 668 PUSHACC2
- 669 PUSHCONST0
- 670 PUSHACC2
- 671 PUSHCONST0
- 672 PUSHACC7
- 673 C_CALL5 blit_string
- 675 ACC1
- 676 PUSHACC3
- 677 PUSHACC2
- 678 PUSHCONST0
- 679 PUSHACC 8
- 681 C_CALL5 blit_string
- 683 ACC0
- 684 RETURN 5
- 686 CONSTINT -1
- 688 PUSHACC1
- 689 XORINT
- 690 RETURN 1
- 692 CONST0
- 693 PUSHACC1
- 694 GEINT
- 695 BRANCHIFNOT 700
- 697 ACC0
- 698 RETURN 1
- 700 ACC0
- 701 NEGINT
- 702 RETURN 1
- 704 RESTART
- 705 GRAB 1
- 707 ACC1
- 708 PUSHACC1
- 709 C_CALL2 greaterequal
- 711 BRANCHIFNOT 716
- 713 ACC0
- 714 RETURN 2
- 716 ACC1
- 717 RETURN 2
- 719 RESTART
- 720 GRAB 1
- 722 ACC1
- 723 PUSHACC1
- 724 C_CALL2 lessequal
- 726 BRANCHIFNOT 731
- 728 ACC0
- 729 RETURN 2
- 731 ACC1
- 732 RETURN 2
- 734 ACC0
- 735 PUSHGETGLOBAL Invalid_argument
- 737 MAKEBLOCK2 0
- 739 RAISE
- 740 ACC0
- 741 PUSHGETGLOBAL Failure
- 743 MAKEBLOCK2 0
- 745 RAISE
- 746 CLOSURE 0, 740
- 749 PUSH
- 750 CLOSURE 0, 734
- 753 PUSHGETGLOBAL "Pervasives.Exit"
- 755 MAKEBLOCK1 0
- 757 PUSHGETGLOBAL "Pervasives.Assert_failure"
- 759 MAKEBLOCK1 0
- 761 PUSH
- 762 CLOSURE 0, 720
- 765 PUSH
- 766 CLOSURE 0, 705
- 769 PUSH
- 770 CLOSURE 0, 692
- 773 PUSH
- 774 CLOSURE 0, 686
- 777 PUSHCONST0
- 778 PUSHCONSTINT 31
- 780 PUSHCONST1
- 781 LSLINT
- 782 EQ
- 783 BRANCHIFNOT 789
- 785 CONSTINT 30
- 787 BRANCH 791
- 789 CONSTINT 62
- 791 PUSHCONST1
- 792 LSLINT
- 793 PUSHACC0
- 794 OFFSETINT -1
- 796 PUSH
- 797 CLOSURE 0, 655
- 800 PUSHACC 9
- 802 CLOSURE 1, 635
- 805 PUSH
- 806 CLOSURE 0, 624
- 809 PUSHACC 11
- 811 CLOSURE 1, 599
- 814 PUSH
- 815 CLOSURE 0, 592
- 818 PUSH
- 819 CLOSURE 0, 585
- 822 PUSH
- 823 CLOSUREREC 0, 12
- 827 CONST0
- 828 C_CALL1 caml_open_descriptor
- 830 PUSHCONST1
- 831 C_CALL1 caml_open_descriptor
- 833 PUSHCONST2
- 834 C_CALL1 caml_open_descriptor
- 836 PUSH
- 837 CLOSURE 0, 574
- 840 PUSHACC0
- 841 CLOSURE 1, 565
- 844 PUSHACC1
- 845 CLOSURE 1, 557
- 848 PUSH
- 849 CLOSURE 0, 545
- 852 PUSHACC 22
- 854 CLOSURE 1, 515
- 857 PUSH
- 858 CLOSURE 0, 505
- 861 PUSH
- 862 CLOSURE 0, 496
- 865 PUSH
- 866 CLOSURE 0, 485
- 869 PUSHACC0
- 870 CLOSURE 1, 477
- 873 PUSHACC1
- 874 CLOSURE 1, 470
- 877 PUSHACC 28
- 879 CLOSURE 1, 441
- 882 PUSH
- 883 CLOSUREREC 0, 32
- 887 ACC0
- 888 PUSHACC 31
- 890 CLOSURE 2, 411
- 893 PUSHACC 22
- 895 CLOSUREREC 1, 70
- 899 ACC 15
- 901 CLOSURE 1, 404
- 904 PUSHACC 11
- 906 PUSHACC 17
- 908 CLOSURE 2, 399
- 911 PUSHACC 12
- 913 PUSHACC 18
- 915 PUSHACC 23
- 917 CLOSURE 3, 392
- 920 PUSHACC 13
- 922 PUSHACC 19
- 924 PUSHACC 23
- 926 CLOSURE 3, 385
- 929 PUSHACC 14
- 931 PUSHACC 20
- 933 CLOSURE 2, 374
- 936 PUSHACC 20
- 938 CLOSURE 1, 364
- 941 PUSHACC 20
- 943 CLOSURE 1, 358
- 946 PUSHACC 17
- 948 PUSHACC 22
- 950 CLOSURE 2, 353
- 953 PUSHACC 18
- 955 PUSHACC 23
- 957 PUSHACC 29
- 959 CLOSURE 3, 346
- 962 PUSHACC 19
- 964 PUSHACC 24
- 966 PUSHACC 29
- 968 CLOSURE 3, 339
- 971 PUSHACC 20
- 973 PUSHACC 25
- 975 CLOSURE 2, 325
- 978 PUSHACC 25
- 980 CLOSURE 1, 315
- 983 PUSHACC 12
- 985 PUSHACC 28
- 987 PUSHACC 30
- 989 CLOSURE 3, 308
- 992 PUSHACC0
- 993 CLOSURE 1, 301
- 996 PUSHACC1
- 997 CLOSURE 1, 294
- 1000 PUSHACC 29
- 1002 PUSHACC 31
- 1004 CLOSURE 2, 286
- 1007 MAKEBLOCK1 0
- 1009 PUSHACC0
- 1010 CLOSURE 1, 275
- 1013 PUSHACC1
- 1014 CLOSURE 1, 263
- 1017 PUSHACC0
- 1018 CLOSURE 1, 255
- 1021 PUSHACC1
- 1022 PUSHACC 22
- 1024 PUSHACC4
- 1025 PUSHACC3
- 1026 PUSH
- 1027 CLOSURE 0, 247
- 1030 PUSH
- 1031 CLOSURE 0, 241
- 1034 PUSH
- 1035 CLOSURE 0, 236
- 1038 PUSH
- 1039 CLOSURE 0, 231
- 1042 PUSH
- 1043 CLOSURE 0, 223
- 1046 PUSH
- 1047 CLOSURE 0, 217
- 1050 PUSH
- 1051 CLOSURE 0, 212
- 1054 PUSH
- 1055 CLOSURE 0, 207
- 1058 PUSHACC 32
- 1060 PUSHACC 35
- 1062 PUSHACC 33
- 1064 PUSH
- 1065 CLOSURE 0, 202
- 1068 PUSHACC 41
- 1070 PUSHACC 40
- 1072 PUSHACC 42
- 1074 PUSH
- 1075 CLOSURE 0, 194
- 1078 PUSHACC 46
- 1080 PUSH
- 1081 CLOSURE 0, 188
- 1084 PUSH
- 1085 CLOSURE 0, 183
- 1088 PUSH
- 1089 CLOSURE 0, 175
- 1092 PUSHACC 51
- 1094 PUSH
- 1095 CLOSURE 0, 166
- 1098 PUSH
- 1099 CLOSURE 0, 157
- 1102 PUSHACC 55
- 1104 PUSHACC 57
- 1106 PUSH
- 1107 CLOSURE 0, 148
- 1110 PUSH
- 1111 CLOSURE 0, 142
- 1114 PUSHACC 63
- 1116 PUSHACC 62
- 1118 PUSHACC 64
- 1120 PUSHACC 38
- 1122 PUSHACC 40
- 1124 PUSHACC 42
- 1126 PUSHACC 44
- 1128 PUSHACC 46
- 1130 PUSHACC 48
- 1132 PUSHACC 50
- 1134 PUSHACC 52
- 1136 PUSHACC 54
- 1138 PUSHACC 56
- 1140 PUSHACC 58
- 1142 PUSHACC 60
- 1144 PUSHACC 62
- 1146 PUSHACC 64
- 1148 PUSHACC 66
- 1150 PUSHACC 82
- 1152 PUSHACC 84
- 1154 PUSHACC 86
- 1156 PUSHACC 88
- 1158 PUSHACC 90
- 1160 PUSHACC 92
- 1162 PUSHACC 94
- 1164 PUSHACC 96
- 1166 PUSHACC 98
- 1168 PUSHACC 100
- 1170 PUSHACC 104
- 1172 PUSHACC 104
- 1174 PUSHACC 104
- 1176 PUSHACC 108
- 1178 PUSHACC 110
- 1180 PUSHACC 112
- 1182 PUSHACC 117
- 1184 PUSHACC 117
- 1186 PUSHACC 117
- 1188 PUSHACC 117
- 1190 MAKEBLOCK 69, 0
- 1193 POP 53
- 1195 SETGLOBAL Pervasives
- 1197 CONST0
- 1198 C_CALL1 gc_compaction
- 1200 CONST0
- 1201 PUSHGETGLOBALFIELD Pervasives, 68
- 1204 APPLY1
- 1205 ATOM0
- 1206 SETGLOBAL T330-compact-2
- 1208 STOP
-**)
diff --git a/test/testinterp/t330-compact-3.ml b/test/testinterp/t330-compact-3.ml
deleted file mode 100644
index f25c64ef0a..0000000000
--- a/test/testinterp/t330-compact-3.ml
+++ /dev/null
@@ -1,1589 +0,0 @@
-open Lib;;
-let rec f n =
- if n <= 0 then []
- else n :: f (n-1)
-in
-let l = f 300 in
-Gc.compact ();
-if List.fold_left (+) 0 l <> 301 * 150 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 746
- 11 RESTART
- 12 GRAB 1
- 14 ACC0
- 15 BRANCHIFNOT 28
- 17 ACC1
- 18 PUSHACC1
- 19 GETFIELD1
- 20 PUSHOFFSETCLOSURE0
- 21 APPLY2
- 22 PUSHACC1
- 23 GETFIELD0
- 24 MAKEBLOCK2 0
- 26 RETURN 2
- 28 ACC1
- 29 RETURN 2
- 31 RESTART
- 32 GRAB 3
- 34 CONST0
- 35 PUSHACC4
- 36 LEINT
- 37 BRANCHIFNOT 42
- 39 CONST0
- 40 RETURN 4
- 42 ACC3
- 43 PUSHACC3
- 44 PUSHACC3
- 45 PUSHACC3
- 46 C_CALL4 caml_input
- 48 PUSHCONST0
- 49 PUSHACC1
- 50 EQ
- 51 BRANCHIFNOT 58
- 53 GETGLOBAL End_of_file
- 55 MAKEBLOCK1 0
- 57 RAISE
- 58 ACC0
- 59 PUSHACC5
- 60 SUBINT
- 61 PUSHACC1
- 62 PUSHACC5
- 63 ADDINT
- 64 PUSHACC4
- 65 PUSHACC4
- 66 PUSHOFFSETCLOSURE0
- 67 APPTERM 4, 9
- 70 ACC0
- 71 C_CALL1 caml_input_scan_line
- 73 PUSHCONST0
- 74 PUSHACC1
- 75 EQ
- 76 BRANCHIFNOT 83
- 78 GETGLOBAL End_of_file
- 80 MAKEBLOCK1 0
- 82 RAISE
- 83 CONST0
- 84 PUSHACC1
- 85 GTINT
- 86 BRANCHIFNOT 107
- 88 ACC0
- 89 OFFSETINT -1
- 91 C_CALL1 create_string
- 93 PUSHACC1
- 94 OFFSETINT -1
- 96 PUSHCONST0
- 97 PUSHACC2
- 98 PUSHACC5
- 99 C_CALL4 caml_input
- 101 ACC2
- 102 C_CALL1 caml_input_char
- 104 ACC0
- 105 RETURN 3
- 107 ACC0
- 108 NEGINT
- 109 C_CALL1 create_string
- 111 PUSHACC1
- 112 NEGINT
- 113 PUSHCONST0
- 114 PUSHACC2
- 115 PUSHACC5
- 116 C_CALL4 caml_input
- 118 CONST0
- 119 PUSHTRAP 130
- 121 ACC6
- 122 PUSHOFFSETCLOSURE0
- 123 APPLY1
- 124 PUSHACC5
- 125 PUSHENVACC1
- 126 APPLY2
- 127 POPTRAP
- 128 RETURN 3
- 130 PUSHGETGLOBAL End_of_file
- 132 PUSHACC1
- 133 GETFIELD0
- 134 EQ
- 135 BRANCHIFNOT 140
- 137 ACC1
- 138 RETURN 4
- 140 ACC0
- 141 RAISE
- 142 ACC0
- 143 C_CALL1 caml_flush
- 145 RETURN 1
- 147 RESTART
- 148 GRAB 1
- 150 ACC1
- 151 PUSHACC1
- 152 C_CALL2 caml_output_char
- 154 RETURN 2
- 156 RESTART
- 157 GRAB 1
- 159 ACC1
- 160 PUSHACC1
- 161 C_CALL2 caml_output_char
- 163 RETURN 2
- 165 RESTART
- 166 GRAB 1
- 168 ACC1
- 169 PUSHACC1
- 170 C_CALL2 caml_output_int
- 172 RETURN 2
- 174 RESTART
- 175 GRAB 1
- 177 ACC1
- 178 PUSHACC1
- 179 C_CALL2 caml_seek_out
- 181 RETURN 2
- 183 ACC0
- 184 C_CALL1 caml_pos_out
- 186 RETURN 1
- 188 ACC0
- 189 C_CALL1 caml_channel_size
- 191 RETURN 1
- 193 RESTART
- 194 GRAB 1
- 196 ACC1
- 197 PUSHACC1
- 198 C_CALL2 caml_set_binary_mode
- 200 RETURN 2
- 202 ACC0
- 203 C_CALL1 caml_input_char
- 205 RETURN 1
- 207 ACC0
- 208 C_CALL1 caml_input_char
- 210 RETURN 1
- 212 ACC0
- 213 C_CALL1 caml_input_int
- 215 RETURN 1
- 217 ACC0
- 218 C_CALL1 input_value
- 220 RETURN 1
- 222 RESTART
- 223 GRAB 1
- 225 ACC1
- 226 PUSHACC1
- 227 C_CALL2 caml_seek_in
- 229 RETURN 2
- 231 ACC0
- 232 C_CALL1 caml_pos_in
- 234 RETURN 1
- 236 ACC0
- 237 C_CALL1 caml_channel_size
- 239 RETURN 1
- 241 ACC0
- 242 C_CALL1 caml_close_channel
- 244 RETURN 1
- 246 RESTART
- 247 GRAB 1
- 249 ACC1
- 250 PUSHACC1
- 251 C_CALL2 caml_set_binary_mode
- 253 RETURN 2
- 255 CONST0
- 256 PUSHENVACC1
- 257 APPLY1
- 258 ACC0
- 259 C_CALL1 sys_exit
- 261 RETURN 1
- 263 CONST0
- 264 PUSHENVACC1
- 265 GETFIELD0
- 266 APPTERM1 2
- 268 CONST0
- 269 PUSHENVACC1
- 270 APPLY1
- 271 CONST0
- 272 PUSHENVACC2
- 273 APPTERM1 2
- 275 ENVACC1
- 276 GETFIELD0
- 277 PUSHACC0
- 278 PUSHACC2
- 279 CLOSURE 2, 268
- 282 PUSHENVACC1
- 283 SETFIELD0
- 284 RETURN 2
- 286 ENVACC1
- 287 C_CALL1 caml_flush
- 289 ENVACC2
- 290 C_CALL1 caml_flush
- 292 RETURN 1
- 294 CONST0
- 295 PUSHENVACC1
- 296 APPLY1
- 297 C_CALL1 float_of_string
- 299 RETURN 1
- 301 CONST0
- 302 PUSHENVACC1
- 303 APPLY1
- 304 C_CALL1 int_of_string
- 306 RETURN 1
- 308 ENVACC2
- 309 C_CALL1 caml_flush
- 311 ENVACC1
- 312 PUSHENVACC3
- 313 APPTERM1 2
- 315 CONSTINT 13
- 317 PUSHENVACC1
- 318 C_CALL2 caml_output_char
- 320 ENVACC1
- 321 C_CALL1 caml_flush
- 323 RETURN 1
- 325 ACC0
- 326 PUSHENVACC1
- 327 PUSHENVACC2
- 328 APPLY2
- 329 CONSTINT 13
- 331 PUSHENVACC1
- 332 C_CALL2 caml_output_char
- 334 ENVACC1
- 335 C_CALL1 caml_flush
- 337 RETURN 1
- 339 ACC0
- 340 PUSHENVACC1
- 341 APPLY1
- 342 PUSHENVACC2
- 343 PUSHENVACC3
- 344 APPTERM2 3
- 346 ACC0
- 347 PUSHENVACC1
- 348 APPLY1
- 349 PUSHENVACC2
- 350 PUSHENVACC3
- 351 APPTERM2 3
- 353 ACC0
- 354 PUSHENVACC1
- 355 PUSHENVACC2
- 356 APPTERM2 3
- 358 ACC0
- 359 PUSHENVACC1
- 360 C_CALL2 caml_output_char
- 362 RETURN 1
- 364 CONSTINT 13
- 366 PUSHENVACC1
- 367 C_CALL2 caml_output_char
- 369 ENVACC1
- 370 C_CALL1 caml_flush
- 372 RETURN 1
- 374 ACC0
- 375 PUSHENVACC1
- 376 PUSHENVACC2
- 377 APPLY2
- 378 CONSTINT 13
- 380 PUSHENVACC1
- 381 C_CALL2 caml_output_char
- 383 RETURN 1
- 385 ACC0
- 386 PUSHENVACC1
- 387 APPLY1
- 388 PUSHENVACC2
- 389 PUSHENVACC3
- 390 APPTERM2 3
- 392 ACC0
- 393 PUSHENVACC1
- 394 APPLY1
- 395 PUSHENVACC2
- 396 PUSHENVACC3
- 397 APPTERM2 3
- 399 ACC0
- 400 PUSHENVACC1
- 401 PUSHENVACC2
- 402 APPTERM2 3
- 404 ACC0
- 405 PUSHENVACC1
- 406 C_CALL2 caml_output_char
- 408 RETURN 1
- 410 RESTART
- 411 GRAB 3
- 413 CONST0
- 414 PUSHACC3
- 415 LTINT
- 416 BRANCHIF 427
- 418 ACC1
- 419 C_CALL1 ml_string_length
- 421 PUSHACC4
- 422 PUSHACC4
- 423 ADDINT
- 424 GTINT
- 425 BRANCHIFNOT 432
- 427 GETGLOBAL "really_input"
- 429 PUSHENVACC1
- 430 APPTERM1 5
- 432 ACC3
- 433 PUSHACC3
- 434 PUSHACC3
- 435 PUSHACC3
- 436 PUSHENVACC2
- 437 APPTERM 4, 8
- 440 RESTART
- 441 GRAB 3
- 443 CONST0
- 444 PUSHACC3
- 445 LTINT
- 446 BRANCHIF 457
- 448 ACC1
- 449 C_CALL1 ml_string_length
- 451 PUSHACC4
- 452 PUSHACC4
- 453 ADDINT
- 454 GTINT
- 455 BRANCHIFNOT 462
- 457 GETGLOBAL "input"
- 459 PUSHENVACC1
- 460 APPTERM1 5
- 462 ACC3
- 463 PUSHACC3
- 464 PUSHACC3
- 465 PUSHACC3
- 466 C_CALL4 caml_input
- 468 RETURN 4
- 470 ACC0
- 471 PUSHCONST0
- 472 PUSHGETGLOBAL <0>(0, <0>(6, 0))
- 474 PUSHENVACC1
- 475 APPTERM3 4
- 477 ACC0
- 478 PUSHCONST0
- 479 PUSHGETGLOBAL <0>(0, <0>(7, 0))
- 481 PUSHENVACC1
- 482 APPTERM3 4
- 484 RESTART
- 485 GRAB 2
- 487 ACC1
- 488 PUSHACC1
- 489 PUSHACC4
- 490 C_CALL3 sys_open
- 492 C_CALL1 caml_open_descriptor
- 494 RETURN 3
- 496 ACC0
- 497 C_CALL1 caml_flush
- 499 ACC0
- 500 C_CALL1 caml_close_channel
- 502 RETURN 1
- 504 RESTART
- 505 GRAB 1
- 507 CONST0
- 508 PUSHACC2
- 509 PUSHACC2
- 510 C_CALL3 output_value
- 512 RETURN 2
- 514 RESTART
- 515 GRAB 3
- 517 CONST0
- 518 PUSHACC3
- 519 LTINT
- 520 BRANCHIF 531
- 522 ACC1
- 523 C_CALL1 ml_string_length
- 525 PUSHACC4
- 526 PUSHACC4
- 527 ADDINT
- 528 GTINT
- 529 BRANCHIFNOT 536
- 531 GETGLOBAL "output"
- 533 PUSHENVACC1
- 534 APPTERM1 5
- 536 ACC3
- 537 PUSHACC3
- 538 PUSHACC3
- 539 PUSHACC3
- 540 C_CALL4 caml_output
- 542 RETURN 4
- 544 RESTART
- 545 GRAB 1
- 547 ACC1
- 548 C_CALL1 ml_string_length
- 550 PUSHCONST0
- 551 PUSHACC3
- 552 PUSHACC3
- 553 C_CALL4 caml_output
- 555 RETURN 2
- 557 ACC0
- 558 PUSHCONSTINT 438
- 560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0))))
- 562 PUSHENVACC1
- 563 APPTERM3 4
- 565 ACC0
- 566 PUSHCONSTINT 438
- 568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0))))
- 570 PUSHENVACC1
- 571 APPTERM3 4
- 573 RESTART
- 574 GRAB 2
- 576 ACC1
- 577 PUSHACC1
- 578 PUSHACC4
- 579 C_CALL3 sys_open
- 581 C_CALL1 caml_open_descriptor
- 583 RETURN 3
- 585 ACC0
- 586 PUSHGETGLOBAL "%.12g"
- 588 C_CALL2 format_float
- 590 RETURN 1
- 592 ACC0
- 593 PUSHGETGLOBAL "%d"
- 595 C_CALL2 format_int
- 597 RETURN 1
- 599 GETGLOBAL "false"
- 601 PUSHACC1
- 602 C_CALL2 string_equal
- 604 BRANCHIFNOT 609
- 606 CONST0
- 607 RETURN 1
- 609 GETGLOBAL "true"
- 611 PUSHACC1
- 612 C_CALL2 string_equal
- 614 BRANCHIFNOT 619
- 616 CONST1
- 617 RETURN 1
- 619 GETGLOBAL "bool_of_string"
- 621 PUSHENVACC1
- 622 APPTERM1 2
- 624 ACC0
- 625 BRANCHIFNOT 631
- 627 GETGLOBAL "true"
- 629 RETURN 1
- 631 GETGLOBAL "false"
- 633 RETURN 1
- 635 CONST0
- 636 PUSHACC1
- 637 LTINT
- 638 BRANCHIF 646
- 640 CONSTINT 255
- 642 PUSHACC1
- 643 GTINT
- 644 BRANCHIFNOT 651
- 646 GETGLOBAL "char_of_int"
- 648 PUSHENVACC1
- 649 APPTERM1 2
- 651 ACC0
- 652 RETURN 1
- 654 RESTART
- 655 GRAB 1
- 657 ACC0
- 658 C_CALL1 ml_string_length
- 660 PUSHACC2
- 661 C_CALL1 ml_string_length
- 663 PUSHACC0
- 664 PUSHACC2
- 665 ADDINT
- 666 C_CALL1 create_string
- 668 PUSHACC2
- 669 PUSHCONST0
- 670 PUSHACC2
- 671 PUSHCONST0
- 672 PUSHACC7
- 673 C_CALL5 blit_string
- 675 ACC1
- 676 PUSHACC3
- 677 PUSHACC2
- 678 PUSHCONST0
- 679 PUSHACC 8
- 681 C_CALL5 blit_string
- 683 ACC0
- 684 RETURN 5
- 686 CONSTINT -1
- 688 PUSHACC1
- 689 XORINT
- 690 RETURN 1
- 692 CONST0
- 693 PUSHACC1
- 694 GEINT
- 695 BRANCHIFNOT 700
- 697 ACC0
- 698 RETURN 1
- 700 ACC0
- 701 NEGINT
- 702 RETURN 1
- 704 RESTART
- 705 GRAB 1
- 707 ACC1
- 708 PUSHACC1
- 709 C_CALL2 greaterequal
- 711 BRANCHIFNOT 716
- 713 ACC0
- 714 RETURN 2
- 716 ACC1
- 717 RETURN 2
- 719 RESTART
- 720 GRAB 1
- 722 ACC1
- 723 PUSHACC1
- 724 C_CALL2 lessequal
- 726 BRANCHIFNOT 731
- 728 ACC0
- 729 RETURN 2
- 731 ACC1
- 732 RETURN 2
- 734 ACC0
- 735 PUSHGETGLOBAL Invalid_argument
- 737 MAKEBLOCK2 0
- 739 RAISE
- 740 ACC0
- 741 PUSHGETGLOBAL Failure
- 743 MAKEBLOCK2 0
- 745 RAISE
- 746 CLOSURE 0, 740
- 749 PUSH
- 750 CLOSURE 0, 734
- 753 PUSHGETGLOBAL "Pervasives.Exit"
- 755 MAKEBLOCK1 0
- 757 PUSHGETGLOBAL "Pervasives.Assert_failure"
- 759 MAKEBLOCK1 0
- 761 PUSH
- 762 CLOSURE 0, 720
- 765 PUSH
- 766 CLOSURE 0, 705
- 769 PUSH
- 770 CLOSURE 0, 692
- 773 PUSH
- 774 CLOSURE 0, 686
- 777 PUSHCONST0
- 778 PUSHCONSTINT 31
- 780 PUSHCONST1
- 781 LSLINT
- 782 EQ
- 783 BRANCHIFNOT 789
- 785 CONSTINT 30
- 787 BRANCH 791
- 789 CONSTINT 62
- 791 PUSHCONST1
- 792 LSLINT
- 793 PUSHACC0
- 794 OFFSETINT -1
- 796 PUSH
- 797 CLOSURE 0, 655
- 800 PUSHACC 9
- 802 CLOSURE 1, 635
- 805 PUSH
- 806 CLOSURE 0, 624
- 809 PUSHACC 11
- 811 CLOSURE 1, 599
- 814 PUSH
- 815 CLOSURE 0, 592
- 818 PUSH
- 819 CLOSURE 0, 585
- 822 PUSH
- 823 CLOSUREREC 0, 12
- 827 CONST0
- 828 C_CALL1 caml_open_descriptor
- 830 PUSHCONST1
- 831 C_CALL1 caml_open_descriptor
- 833 PUSHCONST2
- 834 C_CALL1 caml_open_descriptor
- 836 PUSH
- 837 CLOSURE 0, 574
- 840 PUSHACC0
- 841 CLOSURE 1, 565
- 844 PUSHACC1
- 845 CLOSURE 1, 557
- 848 PUSH
- 849 CLOSURE 0, 545
- 852 PUSHACC 22
- 854 CLOSURE 1, 515
- 857 PUSH
- 858 CLOSURE 0, 505
- 861 PUSH
- 862 CLOSURE 0, 496
- 865 PUSH
- 866 CLOSURE 0, 485
- 869 PUSHACC0
- 870 CLOSURE 1, 477
- 873 PUSHACC1
- 874 CLOSURE 1, 470
- 877 PUSHACC 28
- 879 CLOSURE 1, 441
- 882 PUSH
- 883 CLOSUREREC 0, 32
- 887 ACC0
- 888 PUSHACC 31
- 890 CLOSURE 2, 411
- 893 PUSHACC 22
- 895 CLOSUREREC 1, 70
- 899 ACC 15
- 901 CLOSURE 1, 404
- 904 PUSHACC 11
- 906 PUSHACC 17
- 908 CLOSURE 2, 399
- 911 PUSHACC 12
- 913 PUSHACC 18
- 915 PUSHACC 23
- 917 CLOSURE 3, 392
- 920 PUSHACC 13
- 922 PUSHACC 19
- 924 PUSHACC 23
- 926 CLOSURE 3, 385
- 929 PUSHACC 14
- 931 PUSHACC 20
- 933 CLOSURE 2, 374
- 936 PUSHACC 20
- 938 CLOSURE 1, 364
- 941 PUSHACC 20
- 943 CLOSURE 1, 358
- 946 PUSHACC 17
- 948 PUSHACC 22
- 950 CLOSURE 2, 353
- 953 PUSHACC 18
- 955 PUSHACC 23
- 957 PUSHACC 29
- 959 CLOSURE 3, 346
- 962 PUSHACC 19
- 964 PUSHACC 24
- 966 PUSHACC 29
- 968 CLOSURE 3, 339
- 971 PUSHACC 20
- 973 PUSHACC 25
- 975 CLOSURE 2, 325
- 978 PUSHACC 25
- 980 CLOSURE 1, 315
- 983 PUSHACC 12
- 985 PUSHACC 28
- 987 PUSHACC 30
- 989 CLOSURE 3, 308
- 992 PUSHACC0
- 993 CLOSURE 1, 301
- 996 PUSHACC1
- 997 CLOSURE 1, 294
- 1000 PUSHACC 29
- 1002 PUSHACC 31
- 1004 CLOSURE 2, 286
- 1007 MAKEBLOCK1 0
- 1009 PUSHACC0
- 1010 CLOSURE 1, 275
- 1013 PUSHACC1
- 1014 CLOSURE 1, 263
- 1017 PUSHACC0
- 1018 CLOSURE 1, 255
- 1021 PUSHACC1
- 1022 PUSHACC 22
- 1024 PUSHACC4
- 1025 PUSHACC3
- 1026 PUSH
- 1027 CLOSURE 0, 247
- 1030 PUSH
- 1031 CLOSURE 0, 241
- 1034 PUSH
- 1035 CLOSURE 0, 236
- 1038 PUSH
- 1039 CLOSURE 0, 231
- 1042 PUSH
- 1043 CLOSURE 0, 223
- 1046 PUSH
- 1047 CLOSURE 0, 217
- 1050 PUSH
- 1051 CLOSURE 0, 212
- 1054 PUSH
- 1055 CLOSURE 0, 207
- 1058 PUSHACC 32
- 1060 PUSHACC 35
- 1062 PUSHACC 33
- 1064 PUSH
- 1065 CLOSURE 0, 202
- 1068 PUSHACC 41
- 1070 PUSHACC 40
- 1072 PUSHACC 42
- 1074 PUSH
- 1075 CLOSURE 0, 194
- 1078 PUSHACC 46
- 1080 PUSH
- 1081 CLOSURE 0, 188
- 1084 PUSH
- 1085 CLOSURE 0, 183
- 1088 PUSH
- 1089 CLOSURE 0, 175
- 1092 PUSHACC 51
- 1094 PUSH
- 1095 CLOSURE 0, 166
- 1098 PUSH
- 1099 CLOSURE 0, 157
- 1102 PUSHACC 55
- 1104 PUSHACC 57
- 1106 PUSH
- 1107 CLOSURE 0, 148
- 1110 PUSH
- 1111 CLOSURE 0, 142
- 1114 PUSHACC 63
- 1116 PUSHACC 62
- 1118 PUSHACC 64
- 1120 PUSHACC 38
- 1122 PUSHACC 40
- 1124 PUSHACC 42
- 1126 PUSHACC 44
- 1128 PUSHACC 46
- 1130 PUSHACC 48
- 1132 PUSHACC 50
- 1134 PUSHACC 52
- 1136 PUSHACC 54
- 1138 PUSHACC 56
- 1140 PUSHACC 58
- 1142 PUSHACC 60
- 1144 PUSHACC 62
- 1146 PUSHACC 64
- 1148 PUSHACC 66
- 1150 PUSHACC 82
- 1152 PUSHACC 84
- 1154 PUSHACC 86
- 1156 PUSHACC 88
- 1158 PUSHACC 90
- 1160 PUSHACC 92
- 1162 PUSHACC 94
- 1164 PUSHACC 96
- 1166 PUSHACC 98
- 1168 PUSHACC 100
- 1170 PUSHACC 104
- 1172 PUSHACC 104
- 1174 PUSHACC 104
- 1176 PUSHACC 108
- 1178 PUSHACC 110
- 1180 PUSHACC 112
- 1182 PUSHACC 117
- 1184 PUSHACC 117
- 1186 PUSHACC 117
- 1188 PUSHACC 117
- 1190 MAKEBLOCK 69, 0
- 1193 POP 53
- 1195 SETGLOBAL Pervasives
- 1197 BRANCH 2177
- 1199 RESTART
- 1200 GRAB 1
- 1202 ACC1
- 1203 BRANCHIFNOT 1213
- 1205 ACC1
- 1206 GETFIELD1
- 1207 PUSHACC1
- 1208 OFFSETINT 1
- 1210 PUSHOFFSETCLOSURE0
- 1211 APPTERM2 4
- 1213 ACC0
- 1214 RETURN 2
- 1216 RESTART
- 1217 GRAB 1
- 1219 ACC0
- 1220 BRANCHIFNOT 1251
- 1222 CONST0
- 1223 PUSHACC2
- 1224 EQ
- 1225 BRANCHIFNOT 1231
- 1227 ACC0
- 1228 GETFIELD0
- 1229 RETURN 2
- 1231 CONST0
- 1232 PUSHACC2
- 1233 GTINT
- 1234 BRANCHIFNOT 1244
- 1236 ACC1
- 1237 OFFSETINT -1
- 1239 PUSHACC1
- 1240 GETFIELD1
- 1241 PUSHOFFSETCLOSURE0
- 1242 APPTERM2 4
- 1244 GETGLOBAL "List.nth"
- 1246 PUSHGETGLOBALFIELD Pervasives, 2
- 1249 APPTERM1 3
- 1251 GETGLOBAL "nth"
- 1253 PUSHGETGLOBALFIELD Pervasives, 3
- 1256 APPTERM1 3
- 1258 RESTART
- 1259 GRAB 1
- 1261 ACC0
- 1262 BRANCHIFNOT 1274
- 1264 ACC1
- 1265 PUSHACC1
- 1266 GETFIELD0
- 1267 MAKEBLOCK2 0
- 1269 PUSHACC1
- 1270 GETFIELD1
- 1271 PUSHOFFSETCLOSURE0
- 1272 APPTERM2 4
- 1274 ACC1
- 1275 RETURN 2
- 1277 ACC0
- 1278 BRANCHIFNOT 1291
- 1280 ACC0
- 1281 GETFIELD1
- 1282 PUSHOFFSETCLOSURE0
- 1283 APPLY1
- 1284 PUSHACC1
- 1285 GETFIELD0
- 1286 PUSHGETGLOBALFIELD Pervasives, 16
- 1289 APPTERM2 3
- 1291 RETURN 1
- 1293 RESTART
- 1294 GRAB 1
- 1296 ACC1
- 1297 BRANCHIFNOT 1313
- 1299 ACC1
- 1300 GETFIELD0
- 1301 PUSHACC1
- 1302 APPLY1
- 1303 PUSHACC2
- 1304 GETFIELD1
- 1305 PUSHACC2
- 1306 PUSHOFFSETCLOSURE0
- 1307 APPLY2
- 1308 PUSHACC1
- 1309 MAKEBLOCK2 0
- 1311 POP 1
- 1313 RETURN 2
- 1315 RESTART
- 1316 GRAB 1
- 1318 ACC1
- 1319 BRANCHIFNOT 1331
- 1321 ACC1
- 1322 GETFIELD0
- 1323 PUSHACC1
- 1324 APPLY1
- 1325 ACC1
- 1326 GETFIELD1
- 1327 PUSHACC1
- 1328 PUSHOFFSETCLOSURE0
- 1329 APPTERM2 4
- 1331 RETURN 2
- 1333 RESTART
- 1334 GRAB 2
- 1336 ACC2
- 1337 BRANCHIFNOT 1350
- 1339 ACC2
- 1340 GETFIELD1
- 1341 PUSHACC3
- 1342 GETFIELD0
- 1343 PUSHACC3
- 1344 PUSHACC3
- 1345 APPLY2
- 1346 PUSHACC2
- 1347 PUSHOFFSETCLOSURE0
- 1348 APPTERM3 6
- 1350 ACC1
- 1351 RETURN 3
- 1353 RESTART
- 1354 GRAB 2
- 1356 ACC1
- 1357 BRANCHIFNOT 1370
- 1359 ACC2
- 1360 PUSHACC2
- 1361 GETFIELD1
- 1362 PUSHACC2
- 1363 PUSHOFFSETCLOSURE0
- 1364 APPLY3
- 1365 PUSHACC2
- 1366 GETFIELD0
- 1367 PUSHACC2
- 1368 APPTERM2 5
- 1370 ACC2
- 1371 RETURN 3
- 1373 RESTART
- 1374 GRAB 2
- 1376 ACC1
- 1377 BRANCHIFNOT 1400
- 1379 ACC2
- 1380 BRANCHIFNOT 1407
- 1382 ACC2
- 1383 GETFIELD0
- 1384 PUSHACC2
- 1385 GETFIELD0
- 1386 PUSHACC2
- 1387 APPLY2
- 1388 PUSHACC3
- 1389 GETFIELD1
- 1390 PUSHACC3
- 1391 GETFIELD1
- 1392 PUSHACC3
- 1393 PUSHOFFSETCLOSURE0
- 1394 APPLY3
- 1395 PUSHACC1
- 1396 MAKEBLOCK2 0
- 1398 RETURN 4
- 1400 ACC2
- 1401 BRANCHIFNOT 1405
- 1403 BRANCH 1407
- 1405 RETURN 3
- 1407 GETGLOBAL "List.map2"
- 1409 PUSHGETGLOBALFIELD Pervasives, 2
- 1412 APPTERM1 4
- 1414 RESTART
- 1415 GRAB 2
- 1417 ACC1
- 1418 BRANCHIFNOT 1437
- 1420 ACC2
- 1421 BRANCHIFNOT 1444
- 1423 ACC2
- 1424 GETFIELD0
- 1425 PUSHACC2
- 1426 GETFIELD0
- 1427 PUSHACC2
- 1428 APPLY2
- 1429 ACC2
- 1430 GETFIELD1
- 1431 PUSHACC2
- 1432 GETFIELD1
- 1433 PUSHACC2
- 1434 PUSHOFFSETCLOSURE0
- 1435 APPTERM3 6
- 1437 ACC2
- 1438 BRANCHIFNOT 1442
- 1440 BRANCH 1444
- 1442 RETURN 3
- 1444 GETGLOBAL "List.iter2"
- 1446 PUSHGETGLOBALFIELD Pervasives, 2
- 1449 APPTERM1 4
- 1451 RESTART
- 1452 GRAB 3
- 1454 ACC2
- 1455 BRANCHIFNOT 1476
- 1457 ACC3
- 1458 BRANCHIFNOT 1482
- 1460 ACC3
- 1461 GETFIELD1
- 1462 PUSHACC3
- 1463 GETFIELD1
- 1464 PUSHACC5
- 1465 GETFIELD0
- 1466 PUSHACC5
- 1467 GETFIELD0
- 1468 PUSHACC5
- 1469 PUSHACC5
- 1470 APPLY3
- 1471 PUSHACC3
- 1472 PUSHOFFSETCLOSURE0
- 1473 APPTERM 4, 8
- 1476 ACC3
- 1477 BRANCHIF 1482
- 1479 ACC1
- 1480 RETURN 4
- 1482 GETGLOBAL "List.fold_left2"
- 1484 PUSHGETGLOBALFIELD Pervasives, 2
- 1487 APPTERM1 5
- 1489 RESTART
- 1490 GRAB 3
- 1492 ACC1
- 1493 BRANCHIFNOT 1516
- 1495 ACC2
- 1496 BRANCHIFNOT 1522
- 1498 PUSH_RETADDR 1509
- 1500 ACC6
- 1501 PUSHACC6
- 1502 GETFIELD1
- 1503 PUSHACC6
- 1504 GETFIELD1
- 1505 PUSHACC6
- 1506 PUSHOFFSETCLOSURE0
- 1507 APPLY 4
- 1509 PUSHACC3
- 1510 GETFIELD0
- 1511 PUSHACC3
- 1512 GETFIELD0
- 1513 PUSHACC3
- 1514 APPTERM3 7
- 1516 ACC2
- 1517 BRANCHIF 1522
- 1519 ACC3
- 1520 RETURN 4
- 1522 GETGLOBAL "List.fold_right2"
- 1524 PUSHGETGLOBALFIELD Pervasives, 2
- 1527 APPTERM1 5
- 1529 RESTART
- 1530 GRAB 1
- 1532 ACC1
- 1533 BRANCHIFNOT 1549
- 1535 ACC1
- 1536 GETFIELD0
- 1537 PUSHACC1
- 1538 APPLY1
- 1539 BRANCHIFNOT 1547
- 1541 ACC1
- 1542 GETFIELD1
- 1543 PUSHACC1
- 1544 PUSHOFFSETCLOSURE0
- 1545 APPTERM2 4
- 1547 RETURN 2
- 1549 CONST1
- 1550 RETURN 2
- 1552 RESTART
- 1553 GRAB 1
- 1555 ACC1
- 1556 BRANCHIFNOT 1570
- 1558 ACC1
- 1559 GETFIELD0
- 1560 PUSHACC1
- 1561 APPLY1
- 1562 BRANCHIF 1570
- 1564 ACC1
- 1565 GETFIELD1
- 1566 PUSHACC1
- 1567 PUSHOFFSETCLOSURE0
- 1568 APPTERM2 4
- 1570 RETURN 2
- 1572 RESTART
- 1573 GRAB 2
- 1575 ACC1
- 1576 BRANCHIFNOT 1599
- 1578 ACC2
- 1579 BRANCHIFNOT 1605
- 1581 ACC2
- 1582 GETFIELD0
- 1583 PUSHACC2
- 1584 GETFIELD0
- 1585 PUSHACC2
- 1586 APPLY2
- 1587 BRANCHIFNOT 1597
- 1589 ACC2
- 1590 GETFIELD1
- 1591 PUSHACC2
- 1592 GETFIELD1
- 1593 PUSHACC2
- 1594 PUSHOFFSETCLOSURE0
- 1595 APPTERM3 6
- 1597 RETURN 3
- 1599 ACC2
- 1600 BRANCHIF 1605
- 1602 CONST1
- 1603 RETURN 3
- 1605 GETGLOBAL "List.for_all2"
- 1607 PUSHGETGLOBALFIELD Pervasives, 2
- 1610 APPTERM1 4
- 1612 RESTART
- 1613 GRAB 2
- 1615 ACC1
- 1616 BRANCHIFNOT 1639
- 1618 ACC2
- 1619 BRANCHIFNOT 1646
- 1621 ACC2
- 1622 GETFIELD0
- 1623 PUSHACC2
- 1624 GETFIELD0
- 1625 PUSHACC2
- 1626 APPLY2
- 1627 BRANCHIF 1637
- 1629 ACC2
- 1630 GETFIELD1
- 1631 PUSHACC2
- 1632 GETFIELD1
- 1633 PUSHACC2
- 1634 PUSHOFFSETCLOSURE0
- 1635 APPTERM3 6
- 1637 RETURN 3
- 1639 ACC2
- 1640 BRANCHIFNOT 1644
- 1642 BRANCH 1646
- 1644 RETURN 3
- 1646 GETGLOBAL "List.exists2"
- 1648 PUSHGETGLOBALFIELD Pervasives, 2
- 1651 APPTERM1 4
- 1653 RESTART
- 1654 GRAB 1
- 1656 ACC1
- 1657 BRANCHIFNOT 1672
- 1659 ACC0
- 1660 PUSHACC2
- 1661 GETFIELD0
- 1662 C_CALL2 equal
- 1664 BRANCHIF 1672
- 1666 ACC1
- 1667 GETFIELD1
- 1668 PUSHACC1
- 1669 PUSHOFFSETCLOSURE0
- 1670 APPTERM2 4
- 1672 RETURN 2
- 1674 RESTART
- 1675 GRAB 1
- 1677 ACC1
- 1678 BRANCHIFNOT 1692
- 1680 ACC0
- 1681 PUSHACC2
- 1682 GETFIELD0
- 1683 EQ
- 1684 BRANCHIF 1692
- 1686 ACC1
- 1687 GETFIELD1
- 1688 PUSHACC1
- 1689 PUSHOFFSETCLOSURE0
- 1690 APPTERM2 4
- 1692 RETURN 2
- 1694 RESTART
- 1695 GRAB 1
- 1697 ACC1
- 1698 BRANCHIFNOT 1719
- 1700 ACC1
- 1701 GETFIELD0
- 1702 PUSHACC1
- 1703 PUSHACC1
- 1704 GETFIELD0
- 1705 C_CALL2 equal
- 1707 BRANCHIFNOT 1713
- 1709 ACC0
- 1710 GETFIELD1
- 1711 RETURN 3
- 1713 ACC2
- 1714 GETFIELD1
- 1715 PUSHACC2
- 1716 PUSHOFFSETCLOSURE0
- 1717 APPTERM2 5
- 1719 GETGLOBAL Not_found
- 1721 MAKEBLOCK1 0
- 1723 RAISE
- 1724 RESTART
- 1725 GRAB 1
- 1727 ACC1
- 1728 BRANCHIFNOT 1748
- 1730 ACC1
- 1731 GETFIELD0
- 1732 PUSHACC1
- 1733 PUSHACC1
- 1734 GETFIELD0
- 1735 EQ
- 1736 BRANCHIFNOT 1742
- 1738 ACC0
- 1739 GETFIELD1
- 1740 RETURN 3
- 1742 ACC2
- 1743 GETFIELD1
- 1744 PUSHACC2
- 1745 PUSHOFFSETCLOSURE0
- 1746 APPTERM2 5
- 1748 GETGLOBAL Not_found
- 1750 MAKEBLOCK1 0
- 1752 RAISE
- 1753 RESTART
- 1754 GRAB 1
- 1756 ACC1
- 1757 BRANCHIFNOT 1773
- 1759 ACC0
- 1760 PUSHACC2
- 1761 GETFIELD0
- 1762 GETFIELD0
- 1763 C_CALL2 equal
- 1765 BRANCHIF 1773
- 1767 ACC1
- 1768 GETFIELD1
- 1769 PUSHACC1
- 1770 PUSHOFFSETCLOSURE0
- 1771 APPTERM2 4
- 1773 RETURN 2
- 1775 RESTART
- 1776 GRAB 1
- 1778 ACC1
- 1779 BRANCHIFNOT 1794
- 1781 ACC0
- 1782 PUSHACC2
- 1783 GETFIELD0
- 1784 GETFIELD0
- 1785 EQ
- 1786 BRANCHIF 1794
- 1788 ACC1
- 1789 GETFIELD1
- 1790 PUSHACC1
- 1791 PUSHOFFSETCLOSURE0
- 1792 APPTERM2 4
- 1794 RETURN 2
- 1796 RESTART
- 1797 GRAB 1
- 1799 ACC1
- 1800 BRANCHIFNOT 1825
- 1802 ACC1
- 1803 GETFIELD0
- 1804 PUSHACC2
- 1805 GETFIELD1
- 1806 PUSHACC2
- 1807 PUSHACC2
- 1808 GETFIELD0
- 1809 C_CALL2 equal
- 1811 BRANCHIFNOT 1816
- 1813 ACC0
- 1814 RETURN 4
- 1816 ACC0
- 1817 PUSHACC3
- 1818 PUSHOFFSETCLOSURE0
- 1819 APPLY2
- 1820 PUSHACC2
- 1821 MAKEBLOCK2 0
- 1823 POP 2
- 1825 RETURN 2
- 1827 RESTART
- 1828 GRAB 1
- 1830 ACC1
- 1831 BRANCHIFNOT 1855
- 1833 ACC1
- 1834 GETFIELD0
- 1835 PUSHACC2
- 1836 GETFIELD1
- 1837 PUSHACC2
- 1838 PUSHACC2
- 1839 GETFIELD0
- 1840 EQ
- 1841 BRANCHIFNOT 1846
- 1843 ACC0
- 1844 RETURN 4
- 1846 ACC0
- 1847 PUSHACC3
- 1848 PUSHOFFSETCLOSURE0
- 1849 APPLY2
- 1850 PUSHACC2
- 1851 MAKEBLOCK2 0
- 1853 POP 2
- 1855 RETURN 2
- 1857 RESTART
- 1858 GRAB 1
- 1860 ACC1
- 1861 BRANCHIFNOT 1879
- 1863 ACC1
- 1864 GETFIELD0
- 1865 PUSHACC0
- 1866 PUSHACC2
- 1867 APPLY1
- 1868 BRANCHIFNOT 1873
- 1870 ACC0
- 1871 RETURN 3
- 1873 ACC2
- 1874 GETFIELD1
- 1875 PUSHACC2
- 1876 PUSHOFFSETCLOSURE0
- 1877 APPTERM2 5
- 1879 GETGLOBAL Not_found
- 1881 MAKEBLOCK1 0
- 1883 RAISE
- 1884 RESTART
- 1885 GRAB 2
- 1887 ACC2
- 1888 BRANCHIFNOT 1917
- 1890 ACC2
- 1891 GETFIELD0
- 1892 PUSHACC3
- 1893 GETFIELD1
- 1894 PUSHACC1
- 1895 PUSHENVACC2
- 1896 APPLY1
- 1897 BRANCHIFNOT 1908
- 1899 ACC0
- 1900 PUSHACC4
- 1901 PUSHACC4
- 1902 PUSHACC4
- 1903 MAKEBLOCK2 0
- 1905 PUSHOFFSETCLOSURE0
- 1906 APPTERM3 8
- 1908 ACC0
- 1909 PUSHACC4
- 1910 PUSHACC3
- 1911 MAKEBLOCK2 0
- 1913 PUSHACC4
- 1914 PUSHOFFSETCLOSURE0
- 1915 APPTERM3 8
- 1917 ACC1
- 1918 PUSHENVACC1
- 1919 APPLY1
- 1920 PUSHACC1
- 1921 PUSHENVACC1
- 1922 APPLY1
- 1923 MAKEBLOCK2 0
- 1925 RETURN 3
- 1927 RESTART
- 1928 GRAB 1
- 1930 ACC0
- 1931 PUSHENVACC1
- 1932 CLOSUREREC 2, 1885
- 1936 ACC2
- 1937 PUSHCONST0
- 1938 PUSHCONST0
- 1939 PUSHACC3
- 1940 APPTERM3 6
- 1942 ACC0
- 1943 BRANCHIFNOT 1967
- 1945 ACC0
- 1946 GETFIELD0
- 1947 PUSHACC1
- 1948 GETFIELD1
- 1949 PUSHOFFSETCLOSURE0
- 1950 APPLY1
- 1951 PUSHACC0
- 1952 GETFIELD1
- 1953 PUSHACC2
- 1954 GETFIELD1
- 1955 MAKEBLOCK2 0
- 1957 PUSHACC1
- 1958 GETFIELD0
- 1959 PUSHACC3
- 1960 GETFIELD0
- 1961 MAKEBLOCK2 0
- 1963 MAKEBLOCK2 0
- 1965 RETURN 3
- 1967 GETGLOBAL <0>(0, 0)
- 1969 RETURN 1
- 1971 RESTART
- 1972 GRAB 1
- 1974 ACC0
- 1975 BRANCHIFNOT 1996
- 1977 ACC1
- 1978 BRANCHIFNOT 2003
- 1980 ACC1
- 1981 GETFIELD1
- 1982 PUSHACC1
- 1983 GETFIELD1
- 1984 PUSHOFFSETCLOSURE0
- 1985 APPLY2
- 1986 PUSHACC2
- 1987 GETFIELD0
- 1988 PUSHACC2
- 1989 GETFIELD0
- 1990 MAKEBLOCK2 0
- 1992 MAKEBLOCK2 0
- 1994 RETURN 2
- 1996 ACC1
- 1997 BRANCHIFNOT 2001
- 1999 BRANCH 2003
- 2001 RETURN 2
- 2003 GETGLOBAL "List.combine"
- 2005 PUSHGETGLOBALFIELD Pervasives, 2
- 2008 APPTERM1 3
- 2010 RESTART
- 2011 GRAB 1
- 2013 ACC1
- 2014 BRANCHIFNOT 2038
- 2016 ACC1
- 2017 GETFIELD0
- 2018 PUSHACC2
- 2019 GETFIELD1
- 2020 PUSHACC1
- 2021 PUSHENVACC2
- 2022 APPLY1
- 2023 BRANCHIFNOT 2033
- 2025 ACC0
- 2026 PUSHACC3
- 2027 PUSHACC3
- 2028 MAKEBLOCK2 0
- 2030 PUSHOFFSETCLOSURE0
- 2031 APPTERM2 6
- 2033 ACC0
- 2034 PUSHACC3
- 2035 PUSHOFFSETCLOSURE0
- 2036 APPTERM2 6
- 2038 ACC0
- 2039 PUSHENVACC1
- 2040 APPTERM1 3
- 2042 ACC0
- 2043 PUSHENVACC1
- 2044 CLOSUREREC 2, 2011
- 2048 CONST0
- 2049 PUSHACC1
- 2050 APPTERM1 3
- 2052 RESTART
- 2053 GRAB 2
- 2055 ACC1
- 2056 BRANCHIFNOT 2077
- 2058 ACC2
- 2059 BRANCHIFNOT 2084
- 2061 ACC2
- 2062 GETFIELD1
- 2063 PUSHACC2
- 2064 GETFIELD1
- 2065 PUSHACC2
- 2066 PUSHACC5
- 2067 GETFIELD0
- 2068 PUSHACC5
- 2069 GETFIELD0
- 2070 PUSHENVACC1
- 2071 APPLY2
- 2072 MAKEBLOCK2 0
- 2074 PUSHOFFSETCLOSURE0
- 2075 APPTERM3 6
- 2077 ACC2
- 2078 BRANCHIFNOT 2082
- 2080 BRANCH 2084
- 2082 RETURN 3
- 2084 GETGLOBAL "List.rev_map2"
- 2086 PUSHGETGLOBALFIELD Pervasives, 2
- 2089 APPTERM1 4
- 2091 RESTART
- 2092 GRAB 2
- 2094 ACC0
- 2095 CLOSUREREC 1, 2053
- 2099 ACC3
- 2100 PUSHACC3
- 2101 PUSHCONST0
- 2102 PUSHACC3
- 2103 APPTERM3 7
- 2105 RESTART
- 2106 GRAB 1
- 2108 ACC1
- 2109 BRANCHIFNOT 2123
- 2111 ACC1
- 2112 GETFIELD1
- 2113 PUSHACC1
- 2114 PUSHACC3
- 2115 GETFIELD0
- 2116 PUSHENVACC1
- 2117 APPLY1
- 2118 MAKEBLOCK2 0
- 2120 PUSHOFFSETCLOSURE0
- 2121 APPTERM2 4
- 2123 ACC0
- 2124 RETURN 2
- 2126 RESTART
- 2127 GRAB 1
- 2129 ACC0
- 2130 CLOSUREREC 1, 2106
- 2134 ACC2
- 2135 PUSHCONST0
- 2136 PUSHACC2
- 2137 APPTERM2 5
- 2139 CONST0
- 2140 PUSHACC1
- 2141 PUSHENVACC1
- 2142 APPTERM2 3
- 2144 ACC0
- 2145 BRANCHIFNOT 2151
- 2147 ACC0
- 2148 GETFIELD1
- 2149 RETURN 1
- 2151 GETGLOBAL "tl"
- 2153 PUSHGETGLOBALFIELD Pervasives, 3
- 2156 APPTERM1 2
- 2158 ACC0
- 2159 BRANCHIFNOT 2165
- 2161 ACC0
- 2162 GETFIELD0
- 2163 RETURN 1
- 2165 GETGLOBAL "hd"
- 2167 PUSHGETGLOBALFIELD Pervasives, 3
- 2170 APPTERM1 2
- 2172 ACC0
- 2173 PUSHCONST0
- 2174 PUSHENVACC1
- 2175 APPTERM2 3
- 2177 CLOSUREREC 0, 1200
- 2181 ACC0
- 2182 CLOSURE 1, 2172
- 2185 PUSH
- 2186 CLOSURE 0, 2158
- 2189 PUSH
- 2190 CLOSURE 0, 2144
- 2193 PUSH
- 2194 CLOSUREREC 0, 1217
- 2198 GETGLOBALFIELD Pervasives, 16
- 2201 PUSH
- 2202 CLOSUREREC 0, 1259
- 2206 ACC0
- 2207 CLOSURE 1, 2139
- 2210 PUSH
- 2211 CLOSUREREC 0, 1277
- 2215 CLOSUREREC 0, 1294
- 2219 CLOSURE 0, 2127
- 2222 PUSH
- 2223 CLOSUREREC 0, 1316
- 2227 CLOSUREREC 0, 1334
- 2231 CLOSUREREC 0, 1354
- 2235 CLOSUREREC 0, 1374
- 2239 CLOSURE 0, 2092
- 2242 PUSH
- 2243 CLOSUREREC 0, 1415
- 2247 CLOSUREREC 0, 1452
- 2251 CLOSUREREC 0, 1490
- 2255 CLOSUREREC 0, 1530
- 2259 CLOSUREREC 0, 1553
- 2263 CLOSUREREC 0, 1573
- 2267 CLOSUREREC 0, 1613
- 2271 CLOSUREREC 0, 1654
- 2275 CLOSUREREC 0, 1675
- 2279 CLOSUREREC 0, 1695
- 2283 CLOSUREREC 0, 1725
- 2287 CLOSUREREC 0, 1754
- 2291 CLOSUREREC 0, 1776
- 2295 CLOSUREREC 0, 1797
- 2299 CLOSUREREC 0, 1828
- 2303 CLOSUREREC 0, 1858
- 2307 ACC 24
- 2309 CLOSURE 1, 2042
- 2312 PUSHACC 25
- 2314 CLOSUREREC 1, 1928
- 2318 CLOSUREREC 0, 1942
- 2322 CLOSUREREC 0, 1972
- 2326 ACC0
- 2327 PUSHACC2
- 2328 PUSHACC7
- 2329 PUSHACC 9
- 2331 PUSHACC 11
- 2333 PUSHACC 13
- 2335 PUSHACC 15
- 2337 PUSHACC 17
- 2339 PUSHACC 10
- 2341 PUSHACC 12
- 2343 PUSHACC 13
- 2345 PUSHACC 15
- 2347 PUSHACC 23
- 2349 PUSHACC 25
- 2351 PUSHACC 27
- 2353 PUSHACC 29
- 2355 PUSHACC 31
- 2357 PUSHACC 33
- 2359 PUSHACC 35
- 2361 PUSHACC 37
- 2363 PUSHACC 40
- 2365 PUSHACC 42
- 2367 PUSHACC 41
- 2369 PUSHACC 45
- 2371 PUSHACC 47
- 2373 PUSHACC 50
- 2375 PUSHACC 52
- 2377 PUSHACC 51
- 2379 PUSHACC 55
- 2381 PUSHACC 56
- 2383 PUSHACC 59
- 2385 PUSHACC 61
- 2387 PUSHACC 60
- 2389 PUSHACC 64
- 2391 PUSHACC 66
- 2393 PUSHACC 68
- 2395 PUSHACC 70
- 2397 MAKEBLOCK 37, 0
- 2400 POP 36
- 2402 SETGLOBAL List
- 2404 BRANCH 2432
- 2406 CONST0
- 2407 PUSHACC1
- 2408 LEINT
- 2409 BRANCHIFNOT 2414
- 2411 CONST0
- 2412 RETURN 1
- 2414 ACC0
- 2415 OFFSETINT -1
- 2417 PUSHOFFSETCLOSURE0
- 2418 APPLY1
- 2419 PUSHACC1
- 2420 MAKEBLOCK2 0
- 2422 RETURN 1
- 2424 RESTART
- 2425 GRAB 1
- 2427 ACC1
- 2428 PUSHACC1
- 2429 ADDINT
- 2430 RETURN 2
- 2432 CLOSUREREC 0, 2406
- 2436 CONSTINT 300
- 2438 PUSHACC1
- 2439 APPLY1
- 2440 PUSHCONST0
- 2441 C_CALL1 gc_compaction
- 2443 CONSTINT 150
- 2445 PUSHCONSTINT 301
- 2447 MULINT
- 2448 PUSHACC1
- 2449 PUSHCONST0
- 2450 PUSH
- 2451 CLOSURE 0, 2425
- 2454 PUSHGETGLOBALFIELD List, 12
- 2457 APPLY3
- 2458 NEQ
- 2459 BRANCHIFNOT 2466
- 2461 GETGLOBAL Not_found
- 2463 MAKEBLOCK1 0
- 2465 RAISE
- 2466 POP 2
- 2468 ATOM0
- 2469 SETGLOBAL T330-compact-3
- 2471 STOP
-**)
diff --git a/test/testinterp/t330-compact-4.ml b/test/testinterp/t330-compact-4.ml
deleted file mode 100644
index 1c190f7505..0000000000
--- a/test/testinterp/t330-compact-4.ml
+++ /dev/null
@@ -1,1589 +0,0 @@
-open Lib;;
-let rec f n =
- if n <= 0 then []
- else n :: f (n-1)
-in
-Gc.compact ();
-let l = f 300 in
-if List.fold_left (+) 0 l <> 301 * 150 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 746
- 11 RESTART
- 12 GRAB 1
- 14 ACC0
- 15 BRANCHIFNOT 28
- 17 ACC1
- 18 PUSHACC1
- 19 GETFIELD1
- 20 PUSHOFFSETCLOSURE0
- 21 APPLY2
- 22 PUSHACC1
- 23 GETFIELD0
- 24 MAKEBLOCK2 0
- 26 RETURN 2
- 28 ACC1
- 29 RETURN 2
- 31 RESTART
- 32 GRAB 3
- 34 CONST0
- 35 PUSHACC4
- 36 LEINT
- 37 BRANCHIFNOT 42
- 39 CONST0
- 40 RETURN 4
- 42 ACC3
- 43 PUSHACC3
- 44 PUSHACC3
- 45 PUSHACC3
- 46 C_CALL4 caml_input
- 48 PUSHCONST0
- 49 PUSHACC1
- 50 EQ
- 51 BRANCHIFNOT 58
- 53 GETGLOBAL End_of_file
- 55 MAKEBLOCK1 0
- 57 RAISE
- 58 ACC0
- 59 PUSHACC5
- 60 SUBINT
- 61 PUSHACC1
- 62 PUSHACC5
- 63 ADDINT
- 64 PUSHACC4
- 65 PUSHACC4
- 66 PUSHOFFSETCLOSURE0
- 67 APPTERM 4, 9
- 70 ACC0
- 71 C_CALL1 caml_input_scan_line
- 73 PUSHCONST0
- 74 PUSHACC1
- 75 EQ
- 76 BRANCHIFNOT 83
- 78 GETGLOBAL End_of_file
- 80 MAKEBLOCK1 0
- 82 RAISE
- 83 CONST0
- 84 PUSHACC1
- 85 GTINT
- 86 BRANCHIFNOT 107
- 88 ACC0
- 89 OFFSETINT -1
- 91 C_CALL1 create_string
- 93 PUSHACC1
- 94 OFFSETINT -1
- 96 PUSHCONST0
- 97 PUSHACC2
- 98 PUSHACC5
- 99 C_CALL4 caml_input
- 101 ACC2
- 102 C_CALL1 caml_input_char
- 104 ACC0
- 105 RETURN 3
- 107 ACC0
- 108 NEGINT
- 109 C_CALL1 create_string
- 111 PUSHACC1
- 112 NEGINT
- 113 PUSHCONST0
- 114 PUSHACC2
- 115 PUSHACC5
- 116 C_CALL4 caml_input
- 118 CONST0
- 119 PUSHTRAP 130
- 121 ACC6
- 122 PUSHOFFSETCLOSURE0
- 123 APPLY1
- 124 PUSHACC5
- 125 PUSHENVACC1
- 126 APPLY2
- 127 POPTRAP
- 128 RETURN 3
- 130 PUSHGETGLOBAL End_of_file
- 132 PUSHACC1
- 133 GETFIELD0
- 134 EQ
- 135 BRANCHIFNOT 140
- 137 ACC1
- 138 RETURN 4
- 140 ACC0
- 141 RAISE
- 142 ACC0
- 143 C_CALL1 caml_flush
- 145 RETURN 1
- 147 RESTART
- 148 GRAB 1
- 150 ACC1
- 151 PUSHACC1
- 152 C_CALL2 caml_output_char
- 154 RETURN 2
- 156 RESTART
- 157 GRAB 1
- 159 ACC1
- 160 PUSHACC1
- 161 C_CALL2 caml_output_char
- 163 RETURN 2
- 165 RESTART
- 166 GRAB 1
- 168 ACC1
- 169 PUSHACC1
- 170 C_CALL2 caml_output_int
- 172 RETURN 2
- 174 RESTART
- 175 GRAB 1
- 177 ACC1
- 178 PUSHACC1
- 179 C_CALL2 caml_seek_out
- 181 RETURN 2
- 183 ACC0
- 184 C_CALL1 caml_pos_out
- 186 RETURN 1
- 188 ACC0
- 189 C_CALL1 caml_channel_size
- 191 RETURN 1
- 193 RESTART
- 194 GRAB 1
- 196 ACC1
- 197 PUSHACC1
- 198 C_CALL2 caml_set_binary_mode
- 200 RETURN 2
- 202 ACC0
- 203 C_CALL1 caml_input_char
- 205 RETURN 1
- 207 ACC0
- 208 C_CALL1 caml_input_char
- 210 RETURN 1
- 212 ACC0
- 213 C_CALL1 caml_input_int
- 215 RETURN 1
- 217 ACC0
- 218 C_CALL1 input_value
- 220 RETURN 1
- 222 RESTART
- 223 GRAB 1
- 225 ACC1
- 226 PUSHACC1
- 227 C_CALL2 caml_seek_in
- 229 RETURN 2
- 231 ACC0
- 232 C_CALL1 caml_pos_in
- 234 RETURN 1
- 236 ACC0
- 237 C_CALL1 caml_channel_size
- 239 RETURN 1
- 241 ACC0
- 242 C_CALL1 caml_close_channel
- 244 RETURN 1
- 246 RESTART
- 247 GRAB 1
- 249 ACC1
- 250 PUSHACC1
- 251 C_CALL2 caml_set_binary_mode
- 253 RETURN 2
- 255 CONST0
- 256 PUSHENVACC1
- 257 APPLY1
- 258 ACC0
- 259 C_CALL1 sys_exit
- 261 RETURN 1
- 263 CONST0
- 264 PUSHENVACC1
- 265 GETFIELD0
- 266 APPTERM1 2
- 268 CONST0
- 269 PUSHENVACC1
- 270 APPLY1
- 271 CONST0
- 272 PUSHENVACC2
- 273 APPTERM1 2
- 275 ENVACC1
- 276 GETFIELD0
- 277 PUSHACC0
- 278 PUSHACC2
- 279 CLOSURE 2, 268
- 282 PUSHENVACC1
- 283 SETFIELD0
- 284 RETURN 2
- 286 ENVACC1
- 287 C_CALL1 caml_flush
- 289 ENVACC2
- 290 C_CALL1 caml_flush
- 292 RETURN 1
- 294 CONST0
- 295 PUSHENVACC1
- 296 APPLY1
- 297 C_CALL1 float_of_string
- 299 RETURN 1
- 301 CONST0
- 302 PUSHENVACC1
- 303 APPLY1
- 304 C_CALL1 int_of_string
- 306 RETURN 1
- 308 ENVACC2
- 309 C_CALL1 caml_flush
- 311 ENVACC1
- 312 PUSHENVACC3
- 313 APPTERM1 2
- 315 CONSTINT 13
- 317 PUSHENVACC1
- 318 C_CALL2 caml_output_char
- 320 ENVACC1
- 321 C_CALL1 caml_flush
- 323 RETURN 1
- 325 ACC0
- 326 PUSHENVACC1
- 327 PUSHENVACC2
- 328 APPLY2
- 329 CONSTINT 13
- 331 PUSHENVACC1
- 332 C_CALL2 caml_output_char
- 334 ENVACC1
- 335 C_CALL1 caml_flush
- 337 RETURN 1
- 339 ACC0
- 340 PUSHENVACC1
- 341 APPLY1
- 342 PUSHENVACC2
- 343 PUSHENVACC3
- 344 APPTERM2 3
- 346 ACC0
- 347 PUSHENVACC1
- 348 APPLY1
- 349 PUSHENVACC2
- 350 PUSHENVACC3
- 351 APPTERM2 3
- 353 ACC0
- 354 PUSHENVACC1
- 355 PUSHENVACC2
- 356 APPTERM2 3
- 358 ACC0
- 359 PUSHENVACC1
- 360 C_CALL2 caml_output_char
- 362 RETURN 1
- 364 CONSTINT 13
- 366 PUSHENVACC1
- 367 C_CALL2 caml_output_char
- 369 ENVACC1
- 370 C_CALL1 caml_flush
- 372 RETURN 1
- 374 ACC0
- 375 PUSHENVACC1
- 376 PUSHENVACC2
- 377 APPLY2
- 378 CONSTINT 13
- 380 PUSHENVACC1
- 381 C_CALL2 caml_output_char
- 383 RETURN 1
- 385 ACC0
- 386 PUSHENVACC1
- 387 APPLY1
- 388 PUSHENVACC2
- 389 PUSHENVACC3
- 390 APPTERM2 3
- 392 ACC0
- 393 PUSHENVACC1
- 394 APPLY1
- 395 PUSHENVACC2
- 396 PUSHENVACC3
- 397 APPTERM2 3
- 399 ACC0
- 400 PUSHENVACC1
- 401 PUSHENVACC2
- 402 APPTERM2 3
- 404 ACC0
- 405 PUSHENVACC1
- 406 C_CALL2 caml_output_char
- 408 RETURN 1
- 410 RESTART
- 411 GRAB 3
- 413 CONST0
- 414 PUSHACC3
- 415 LTINT
- 416 BRANCHIF 427
- 418 ACC1
- 419 C_CALL1 ml_string_length
- 421 PUSHACC4
- 422 PUSHACC4
- 423 ADDINT
- 424 GTINT
- 425 BRANCHIFNOT 432
- 427 GETGLOBAL "really_input"
- 429 PUSHENVACC1
- 430 APPTERM1 5
- 432 ACC3
- 433 PUSHACC3
- 434 PUSHACC3
- 435 PUSHACC3
- 436 PUSHENVACC2
- 437 APPTERM 4, 8
- 440 RESTART
- 441 GRAB 3
- 443 CONST0
- 444 PUSHACC3
- 445 LTINT
- 446 BRANCHIF 457
- 448 ACC1
- 449 C_CALL1 ml_string_length
- 451 PUSHACC4
- 452 PUSHACC4
- 453 ADDINT
- 454 GTINT
- 455 BRANCHIFNOT 462
- 457 GETGLOBAL "input"
- 459 PUSHENVACC1
- 460 APPTERM1 5
- 462 ACC3
- 463 PUSHACC3
- 464 PUSHACC3
- 465 PUSHACC3
- 466 C_CALL4 caml_input
- 468 RETURN 4
- 470 ACC0
- 471 PUSHCONST0
- 472 PUSHGETGLOBAL <0>(0, <0>(6, 0))
- 474 PUSHENVACC1
- 475 APPTERM3 4
- 477 ACC0
- 478 PUSHCONST0
- 479 PUSHGETGLOBAL <0>(0, <0>(7, 0))
- 481 PUSHENVACC1
- 482 APPTERM3 4
- 484 RESTART
- 485 GRAB 2
- 487 ACC1
- 488 PUSHACC1
- 489 PUSHACC4
- 490 C_CALL3 sys_open
- 492 C_CALL1 caml_open_descriptor
- 494 RETURN 3
- 496 ACC0
- 497 C_CALL1 caml_flush
- 499 ACC0
- 500 C_CALL1 caml_close_channel
- 502 RETURN 1
- 504 RESTART
- 505 GRAB 1
- 507 CONST0
- 508 PUSHACC2
- 509 PUSHACC2
- 510 C_CALL3 output_value
- 512 RETURN 2
- 514 RESTART
- 515 GRAB 3
- 517 CONST0
- 518 PUSHACC3
- 519 LTINT
- 520 BRANCHIF 531
- 522 ACC1
- 523 C_CALL1 ml_string_length
- 525 PUSHACC4
- 526 PUSHACC4
- 527 ADDINT
- 528 GTINT
- 529 BRANCHIFNOT 536
- 531 GETGLOBAL "output"
- 533 PUSHENVACC1
- 534 APPTERM1 5
- 536 ACC3
- 537 PUSHACC3
- 538 PUSHACC3
- 539 PUSHACC3
- 540 C_CALL4 caml_output
- 542 RETURN 4
- 544 RESTART
- 545 GRAB 1
- 547 ACC1
- 548 C_CALL1 ml_string_length
- 550 PUSHCONST0
- 551 PUSHACC3
- 552 PUSHACC3
- 553 C_CALL4 caml_output
- 555 RETURN 2
- 557 ACC0
- 558 PUSHCONSTINT 438
- 560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0))))
- 562 PUSHENVACC1
- 563 APPTERM3 4
- 565 ACC0
- 566 PUSHCONSTINT 438
- 568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0))))
- 570 PUSHENVACC1
- 571 APPTERM3 4
- 573 RESTART
- 574 GRAB 2
- 576 ACC1
- 577 PUSHACC1
- 578 PUSHACC4
- 579 C_CALL3 sys_open
- 581 C_CALL1 caml_open_descriptor
- 583 RETURN 3
- 585 ACC0
- 586 PUSHGETGLOBAL "%.12g"
- 588 C_CALL2 format_float
- 590 RETURN 1
- 592 ACC0
- 593 PUSHGETGLOBAL "%d"
- 595 C_CALL2 format_int
- 597 RETURN 1
- 599 GETGLOBAL "false"
- 601 PUSHACC1
- 602 C_CALL2 string_equal
- 604 BRANCHIFNOT 609
- 606 CONST0
- 607 RETURN 1
- 609 GETGLOBAL "true"
- 611 PUSHACC1
- 612 C_CALL2 string_equal
- 614 BRANCHIFNOT 619
- 616 CONST1
- 617 RETURN 1
- 619 GETGLOBAL "bool_of_string"
- 621 PUSHENVACC1
- 622 APPTERM1 2
- 624 ACC0
- 625 BRANCHIFNOT 631
- 627 GETGLOBAL "true"
- 629 RETURN 1
- 631 GETGLOBAL "false"
- 633 RETURN 1
- 635 CONST0
- 636 PUSHACC1
- 637 LTINT
- 638 BRANCHIF 646
- 640 CONSTINT 255
- 642 PUSHACC1
- 643 GTINT
- 644 BRANCHIFNOT 651
- 646 GETGLOBAL "char_of_int"
- 648 PUSHENVACC1
- 649 APPTERM1 2
- 651 ACC0
- 652 RETURN 1
- 654 RESTART
- 655 GRAB 1
- 657 ACC0
- 658 C_CALL1 ml_string_length
- 660 PUSHACC2
- 661 C_CALL1 ml_string_length
- 663 PUSHACC0
- 664 PUSHACC2
- 665 ADDINT
- 666 C_CALL1 create_string
- 668 PUSHACC2
- 669 PUSHCONST0
- 670 PUSHACC2
- 671 PUSHCONST0
- 672 PUSHACC7
- 673 C_CALL5 blit_string
- 675 ACC1
- 676 PUSHACC3
- 677 PUSHACC2
- 678 PUSHCONST0
- 679 PUSHACC 8
- 681 C_CALL5 blit_string
- 683 ACC0
- 684 RETURN 5
- 686 CONSTINT -1
- 688 PUSHACC1
- 689 XORINT
- 690 RETURN 1
- 692 CONST0
- 693 PUSHACC1
- 694 GEINT
- 695 BRANCHIFNOT 700
- 697 ACC0
- 698 RETURN 1
- 700 ACC0
- 701 NEGINT
- 702 RETURN 1
- 704 RESTART
- 705 GRAB 1
- 707 ACC1
- 708 PUSHACC1
- 709 C_CALL2 greaterequal
- 711 BRANCHIFNOT 716
- 713 ACC0
- 714 RETURN 2
- 716 ACC1
- 717 RETURN 2
- 719 RESTART
- 720 GRAB 1
- 722 ACC1
- 723 PUSHACC1
- 724 C_CALL2 lessequal
- 726 BRANCHIFNOT 731
- 728 ACC0
- 729 RETURN 2
- 731 ACC1
- 732 RETURN 2
- 734 ACC0
- 735 PUSHGETGLOBAL Invalid_argument
- 737 MAKEBLOCK2 0
- 739 RAISE
- 740 ACC0
- 741 PUSHGETGLOBAL Failure
- 743 MAKEBLOCK2 0
- 745 RAISE
- 746 CLOSURE 0, 740
- 749 PUSH
- 750 CLOSURE 0, 734
- 753 PUSHGETGLOBAL "Pervasives.Exit"
- 755 MAKEBLOCK1 0
- 757 PUSHGETGLOBAL "Pervasives.Assert_failure"
- 759 MAKEBLOCK1 0
- 761 PUSH
- 762 CLOSURE 0, 720
- 765 PUSH
- 766 CLOSURE 0, 705
- 769 PUSH
- 770 CLOSURE 0, 692
- 773 PUSH
- 774 CLOSURE 0, 686
- 777 PUSHCONST0
- 778 PUSHCONSTINT 31
- 780 PUSHCONST1
- 781 LSLINT
- 782 EQ
- 783 BRANCHIFNOT 789
- 785 CONSTINT 30
- 787 BRANCH 791
- 789 CONSTINT 62
- 791 PUSHCONST1
- 792 LSLINT
- 793 PUSHACC0
- 794 OFFSETINT -1
- 796 PUSH
- 797 CLOSURE 0, 655
- 800 PUSHACC 9
- 802 CLOSURE 1, 635
- 805 PUSH
- 806 CLOSURE 0, 624
- 809 PUSHACC 11
- 811 CLOSURE 1, 599
- 814 PUSH
- 815 CLOSURE 0, 592
- 818 PUSH
- 819 CLOSURE 0, 585
- 822 PUSH
- 823 CLOSUREREC 0, 12
- 827 CONST0
- 828 C_CALL1 caml_open_descriptor
- 830 PUSHCONST1
- 831 C_CALL1 caml_open_descriptor
- 833 PUSHCONST2
- 834 C_CALL1 caml_open_descriptor
- 836 PUSH
- 837 CLOSURE 0, 574
- 840 PUSHACC0
- 841 CLOSURE 1, 565
- 844 PUSHACC1
- 845 CLOSURE 1, 557
- 848 PUSH
- 849 CLOSURE 0, 545
- 852 PUSHACC 22
- 854 CLOSURE 1, 515
- 857 PUSH
- 858 CLOSURE 0, 505
- 861 PUSH
- 862 CLOSURE 0, 496
- 865 PUSH
- 866 CLOSURE 0, 485
- 869 PUSHACC0
- 870 CLOSURE 1, 477
- 873 PUSHACC1
- 874 CLOSURE 1, 470
- 877 PUSHACC 28
- 879 CLOSURE 1, 441
- 882 PUSH
- 883 CLOSUREREC 0, 32
- 887 ACC0
- 888 PUSHACC 31
- 890 CLOSURE 2, 411
- 893 PUSHACC 22
- 895 CLOSUREREC 1, 70
- 899 ACC 15
- 901 CLOSURE 1, 404
- 904 PUSHACC 11
- 906 PUSHACC 17
- 908 CLOSURE 2, 399
- 911 PUSHACC 12
- 913 PUSHACC 18
- 915 PUSHACC 23
- 917 CLOSURE 3, 392
- 920 PUSHACC 13
- 922 PUSHACC 19
- 924 PUSHACC 23
- 926 CLOSURE 3, 385
- 929 PUSHACC 14
- 931 PUSHACC 20
- 933 CLOSURE 2, 374
- 936 PUSHACC 20
- 938 CLOSURE 1, 364
- 941 PUSHACC 20
- 943 CLOSURE 1, 358
- 946 PUSHACC 17
- 948 PUSHACC 22
- 950 CLOSURE 2, 353
- 953 PUSHACC 18
- 955 PUSHACC 23
- 957 PUSHACC 29
- 959 CLOSURE 3, 346
- 962 PUSHACC 19
- 964 PUSHACC 24
- 966 PUSHACC 29
- 968 CLOSURE 3, 339
- 971 PUSHACC 20
- 973 PUSHACC 25
- 975 CLOSURE 2, 325
- 978 PUSHACC 25
- 980 CLOSURE 1, 315
- 983 PUSHACC 12
- 985 PUSHACC 28
- 987 PUSHACC 30
- 989 CLOSURE 3, 308
- 992 PUSHACC0
- 993 CLOSURE 1, 301
- 996 PUSHACC1
- 997 CLOSURE 1, 294
- 1000 PUSHACC 29
- 1002 PUSHACC 31
- 1004 CLOSURE 2, 286
- 1007 MAKEBLOCK1 0
- 1009 PUSHACC0
- 1010 CLOSURE 1, 275
- 1013 PUSHACC1
- 1014 CLOSURE 1, 263
- 1017 PUSHACC0
- 1018 CLOSURE 1, 255
- 1021 PUSHACC1
- 1022 PUSHACC 22
- 1024 PUSHACC4
- 1025 PUSHACC3
- 1026 PUSH
- 1027 CLOSURE 0, 247
- 1030 PUSH
- 1031 CLOSURE 0, 241
- 1034 PUSH
- 1035 CLOSURE 0, 236
- 1038 PUSH
- 1039 CLOSURE 0, 231
- 1042 PUSH
- 1043 CLOSURE 0, 223
- 1046 PUSH
- 1047 CLOSURE 0, 217
- 1050 PUSH
- 1051 CLOSURE 0, 212
- 1054 PUSH
- 1055 CLOSURE 0, 207
- 1058 PUSHACC 32
- 1060 PUSHACC 35
- 1062 PUSHACC 33
- 1064 PUSH
- 1065 CLOSURE 0, 202
- 1068 PUSHACC 41
- 1070 PUSHACC 40
- 1072 PUSHACC 42
- 1074 PUSH
- 1075 CLOSURE 0, 194
- 1078 PUSHACC 46
- 1080 PUSH
- 1081 CLOSURE 0, 188
- 1084 PUSH
- 1085 CLOSURE 0, 183
- 1088 PUSH
- 1089 CLOSURE 0, 175
- 1092 PUSHACC 51
- 1094 PUSH
- 1095 CLOSURE 0, 166
- 1098 PUSH
- 1099 CLOSURE 0, 157
- 1102 PUSHACC 55
- 1104 PUSHACC 57
- 1106 PUSH
- 1107 CLOSURE 0, 148
- 1110 PUSH
- 1111 CLOSURE 0, 142
- 1114 PUSHACC 63
- 1116 PUSHACC 62
- 1118 PUSHACC 64
- 1120 PUSHACC 38
- 1122 PUSHACC 40
- 1124 PUSHACC 42
- 1126 PUSHACC 44
- 1128 PUSHACC 46
- 1130 PUSHACC 48
- 1132 PUSHACC 50
- 1134 PUSHACC 52
- 1136 PUSHACC 54
- 1138 PUSHACC 56
- 1140 PUSHACC 58
- 1142 PUSHACC 60
- 1144 PUSHACC 62
- 1146 PUSHACC 64
- 1148 PUSHACC 66
- 1150 PUSHACC 82
- 1152 PUSHACC 84
- 1154 PUSHACC 86
- 1156 PUSHACC 88
- 1158 PUSHACC 90
- 1160 PUSHACC 92
- 1162 PUSHACC 94
- 1164 PUSHACC 96
- 1166 PUSHACC 98
- 1168 PUSHACC 100
- 1170 PUSHACC 104
- 1172 PUSHACC 104
- 1174 PUSHACC 104
- 1176 PUSHACC 108
- 1178 PUSHACC 110
- 1180 PUSHACC 112
- 1182 PUSHACC 117
- 1184 PUSHACC 117
- 1186 PUSHACC 117
- 1188 PUSHACC 117
- 1190 MAKEBLOCK 69, 0
- 1193 POP 53
- 1195 SETGLOBAL Pervasives
- 1197 BRANCH 2177
- 1199 RESTART
- 1200 GRAB 1
- 1202 ACC1
- 1203 BRANCHIFNOT 1213
- 1205 ACC1
- 1206 GETFIELD1
- 1207 PUSHACC1
- 1208 OFFSETINT 1
- 1210 PUSHOFFSETCLOSURE0
- 1211 APPTERM2 4
- 1213 ACC0
- 1214 RETURN 2
- 1216 RESTART
- 1217 GRAB 1
- 1219 ACC0
- 1220 BRANCHIFNOT 1251
- 1222 CONST0
- 1223 PUSHACC2
- 1224 EQ
- 1225 BRANCHIFNOT 1231
- 1227 ACC0
- 1228 GETFIELD0
- 1229 RETURN 2
- 1231 CONST0
- 1232 PUSHACC2
- 1233 GTINT
- 1234 BRANCHIFNOT 1244
- 1236 ACC1
- 1237 OFFSETINT -1
- 1239 PUSHACC1
- 1240 GETFIELD1
- 1241 PUSHOFFSETCLOSURE0
- 1242 APPTERM2 4
- 1244 GETGLOBAL "List.nth"
- 1246 PUSHGETGLOBALFIELD Pervasives, 2
- 1249 APPTERM1 3
- 1251 GETGLOBAL "nth"
- 1253 PUSHGETGLOBALFIELD Pervasives, 3
- 1256 APPTERM1 3
- 1258 RESTART
- 1259 GRAB 1
- 1261 ACC0
- 1262 BRANCHIFNOT 1274
- 1264 ACC1
- 1265 PUSHACC1
- 1266 GETFIELD0
- 1267 MAKEBLOCK2 0
- 1269 PUSHACC1
- 1270 GETFIELD1
- 1271 PUSHOFFSETCLOSURE0
- 1272 APPTERM2 4
- 1274 ACC1
- 1275 RETURN 2
- 1277 ACC0
- 1278 BRANCHIFNOT 1291
- 1280 ACC0
- 1281 GETFIELD1
- 1282 PUSHOFFSETCLOSURE0
- 1283 APPLY1
- 1284 PUSHACC1
- 1285 GETFIELD0
- 1286 PUSHGETGLOBALFIELD Pervasives, 16
- 1289 APPTERM2 3
- 1291 RETURN 1
- 1293 RESTART
- 1294 GRAB 1
- 1296 ACC1
- 1297 BRANCHIFNOT 1313
- 1299 ACC1
- 1300 GETFIELD0
- 1301 PUSHACC1
- 1302 APPLY1
- 1303 PUSHACC2
- 1304 GETFIELD1
- 1305 PUSHACC2
- 1306 PUSHOFFSETCLOSURE0
- 1307 APPLY2
- 1308 PUSHACC1
- 1309 MAKEBLOCK2 0
- 1311 POP 1
- 1313 RETURN 2
- 1315 RESTART
- 1316 GRAB 1
- 1318 ACC1
- 1319 BRANCHIFNOT 1331
- 1321 ACC1
- 1322 GETFIELD0
- 1323 PUSHACC1
- 1324 APPLY1
- 1325 ACC1
- 1326 GETFIELD1
- 1327 PUSHACC1
- 1328 PUSHOFFSETCLOSURE0
- 1329 APPTERM2 4
- 1331 RETURN 2
- 1333 RESTART
- 1334 GRAB 2
- 1336 ACC2
- 1337 BRANCHIFNOT 1350
- 1339 ACC2
- 1340 GETFIELD1
- 1341 PUSHACC3
- 1342 GETFIELD0
- 1343 PUSHACC3
- 1344 PUSHACC3
- 1345 APPLY2
- 1346 PUSHACC2
- 1347 PUSHOFFSETCLOSURE0
- 1348 APPTERM3 6
- 1350 ACC1
- 1351 RETURN 3
- 1353 RESTART
- 1354 GRAB 2
- 1356 ACC1
- 1357 BRANCHIFNOT 1370
- 1359 ACC2
- 1360 PUSHACC2
- 1361 GETFIELD1
- 1362 PUSHACC2
- 1363 PUSHOFFSETCLOSURE0
- 1364 APPLY3
- 1365 PUSHACC2
- 1366 GETFIELD0
- 1367 PUSHACC2
- 1368 APPTERM2 5
- 1370 ACC2
- 1371 RETURN 3
- 1373 RESTART
- 1374 GRAB 2
- 1376 ACC1
- 1377 BRANCHIFNOT 1400
- 1379 ACC2
- 1380 BRANCHIFNOT 1407
- 1382 ACC2
- 1383 GETFIELD0
- 1384 PUSHACC2
- 1385 GETFIELD0
- 1386 PUSHACC2
- 1387 APPLY2
- 1388 PUSHACC3
- 1389 GETFIELD1
- 1390 PUSHACC3
- 1391 GETFIELD1
- 1392 PUSHACC3
- 1393 PUSHOFFSETCLOSURE0
- 1394 APPLY3
- 1395 PUSHACC1
- 1396 MAKEBLOCK2 0
- 1398 RETURN 4
- 1400 ACC2
- 1401 BRANCHIFNOT 1405
- 1403 BRANCH 1407
- 1405 RETURN 3
- 1407 GETGLOBAL "List.map2"
- 1409 PUSHGETGLOBALFIELD Pervasives, 2
- 1412 APPTERM1 4
- 1414 RESTART
- 1415 GRAB 2
- 1417 ACC1
- 1418 BRANCHIFNOT 1437
- 1420 ACC2
- 1421 BRANCHIFNOT 1444
- 1423 ACC2
- 1424 GETFIELD0
- 1425 PUSHACC2
- 1426 GETFIELD0
- 1427 PUSHACC2
- 1428 APPLY2
- 1429 ACC2
- 1430 GETFIELD1
- 1431 PUSHACC2
- 1432 GETFIELD1
- 1433 PUSHACC2
- 1434 PUSHOFFSETCLOSURE0
- 1435 APPTERM3 6
- 1437 ACC2
- 1438 BRANCHIFNOT 1442
- 1440 BRANCH 1444
- 1442 RETURN 3
- 1444 GETGLOBAL "List.iter2"
- 1446 PUSHGETGLOBALFIELD Pervasives, 2
- 1449 APPTERM1 4
- 1451 RESTART
- 1452 GRAB 3
- 1454 ACC2
- 1455 BRANCHIFNOT 1476
- 1457 ACC3
- 1458 BRANCHIFNOT 1482
- 1460 ACC3
- 1461 GETFIELD1
- 1462 PUSHACC3
- 1463 GETFIELD1
- 1464 PUSHACC5
- 1465 GETFIELD0
- 1466 PUSHACC5
- 1467 GETFIELD0
- 1468 PUSHACC5
- 1469 PUSHACC5
- 1470 APPLY3
- 1471 PUSHACC3
- 1472 PUSHOFFSETCLOSURE0
- 1473 APPTERM 4, 8
- 1476 ACC3
- 1477 BRANCHIF 1482
- 1479 ACC1
- 1480 RETURN 4
- 1482 GETGLOBAL "List.fold_left2"
- 1484 PUSHGETGLOBALFIELD Pervasives, 2
- 1487 APPTERM1 5
- 1489 RESTART
- 1490 GRAB 3
- 1492 ACC1
- 1493 BRANCHIFNOT 1516
- 1495 ACC2
- 1496 BRANCHIFNOT 1522
- 1498 PUSH_RETADDR 1509
- 1500 ACC6
- 1501 PUSHACC6
- 1502 GETFIELD1
- 1503 PUSHACC6
- 1504 GETFIELD1
- 1505 PUSHACC6
- 1506 PUSHOFFSETCLOSURE0
- 1507 APPLY 4
- 1509 PUSHACC3
- 1510 GETFIELD0
- 1511 PUSHACC3
- 1512 GETFIELD0
- 1513 PUSHACC3
- 1514 APPTERM3 7
- 1516 ACC2
- 1517 BRANCHIF 1522
- 1519 ACC3
- 1520 RETURN 4
- 1522 GETGLOBAL "List.fold_right2"
- 1524 PUSHGETGLOBALFIELD Pervasives, 2
- 1527 APPTERM1 5
- 1529 RESTART
- 1530 GRAB 1
- 1532 ACC1
- 1533 BRANCHIFNOT 1549
- 1535 ACC1
- 1536 GETFIELD0
- 1537 PUSHACC1
- 1538 APPLY1
- 1539 BRANCHIFNOT 1547
- 1541 ACC1
- 1542 GETFIELD1
- 1543 PUSHACC1
- 1544 PUSHOFFSETCLOSURE0
- 1545 APPTERM2 4
- 1547 RETURN 2
- 1549 CONST1
- 1550 RETURN 2
- 1552 RESTART
- 1553 GRAB 1
- 1555 ACC1
- 1556 BRANCHIFNOT 1570
- 1558 ACC1
- 1559 GETFIELD0
- 1560 PUSHACC1
- 1561 APPLY1
- 1562 BRANCHIF 1570
- 1564 ACC1
- 1565 GETFIELD1
- 1566 PUSHACC1
- 1567 PUSHOFFSETCLOSURE0
- 1568 APPTERM2 4
- 1570 RETURN 2
- 1572 RESTART
- 1573 GRAB 2
- 1575 ACC1
- 1576 BRANCHIFNOT 1599
- 1578 ACC2
- 1579 BRANCHIFNOT 1605
- 1581 ACC2
- 1582 GETFIELD0
- 1583 PUSHACC2
- 1584 GETFIELD0
- 1585 PUSHACC2
- 1586 APPLY2
- 1587 BRANCHIFNOT 1597
- 1589 ACC2
- 1590 GETFIELD1
- 1591 PUSHACC2
- 1592 GETFIELD1
- 1593 PUSHACC2
- 1594 PUSHOFFSETCLOSURE0
- 1595 APPTERM3 6
- 1597 RETURN 3
- 1599 ACC2
- 1600 BRANCHIF 1605
- 1602 CONST1
- 1603 RETURN 3
- 1605 GETGLOBAL "List.for_all2"
- 1607 PUSHGETGLOBALFIELD Pervasives, 2
- 1610 APPTERM1 4
- 1612 RESTART
- 1613 GRAB 2
- 1615 ACC1
- 1616 BRANCHIFNOT 1639
- 1618 ACC2
- 1619 BRANCHIFNOT 1646
- 1621 ACC2
- 1622 GETFIELD0
- 1623 PUSHACC2
- 1624 GETFIELD0
- 1625 PUSHACC2
- 1626 APPLY2
- 1627 BRANCHIF 1637
- 1629 ACC2
- 1630 GETFIELD1
- 1631 PUSHACC2
- 1632 GETFIELD1
- 1633 PUSHACC2
- 1634 PUSHOFFSETCLOSURE0
- 1635 APPTERM3 6
- 1637 RETURN 3
- 1639 ACC2
- 1640 BRANCHIFNOT 1644
- 1642 BRANCH 1646
- 1644 RETURN 3
- 1646 GETGLOBAL "List.exists2"
- 1648 PUSHGETGLOBALFIELD Pervasives, 2
- 1651 APPTERM1 4
- 1653 RESTART
- 1654 GRAB 1
- 1656 ACC1
- 1657 BRANCHIFNOT 1672
- 1659 ACC0
- 1660 PUSHACC2
- 1661 GETFIELD0
- 1662 C_CALL2 equal
- 1664 BRANCHIF 1672
- 1666 ACC1
- 1667 GETFIELD1
- 1668 PUSHACC1
- 1669 PUSHOFFSETCLOSURE0
- 1670 APPTERM2 4
- 1672 RETURN 2
- 1674 RESTART
- 1675 GRAB 1
- 1677 ACC1
- 1678 BRANCHIFNOT 1692
- 1680 ACC0
- 1681 PUSHACC2
- 1682 GETFIELD0
- 1683 EQ
- 1684 BRANCHIF 1692
- 1686 ACC1
- 1687 GETFIELD1
- 1688 PUSHACC1
- 1689 PUSHOFFSETCLOSURE0
- 1690 APPTERM2 4
- 1692 RETURN 2
- 1694 RESTART
- 1695 GRAB 1
- 1697 ACC1
- 1698 BRANCHIFNOT 1719
- 1700 ACC1
- 1701 GETFIELD0
- 1702 PUSHACC1
- 1703 PUSHACC1
- 1704 GETFIELD0
- 1705 C_CALL2 equal
- 1707 BRANCHIFNOT 1713
- 1709 ACC0
- 1710 GETFIELD1
- 1711 RETURN 3
- 1713 ACC2
- 1714 GETFIELD1
- 1715 PUSHACC2
- 1716 PUSHOFFSETCLOSURE0
- 1717 APPTERM2 5
- 1719 GETGLOBAL Not_found
- 1721 MAKEBLOCK1 0
- 1723 RAISE
- 1724 RESTART
- 1725 GRAB 1
- 1727 ACC1
- 1728 BRANCHIFNOT 1748
- 1730 ACC1
- 1731 GETFIELD0
- 1732 PUSHACC1
- 1733 PUSHACC1
- 1734 GETFIELD0
- 1735 EQ
- 1736 BRANCHIFNOT 1742
- 1738 ACC0
- 1739 GETFIELD1
- 1740 RETURN 3
- 1742 ACC2
- 1743 GETFIELD1
- 1744 PUSHACC2
- 1745 PUSHOFFSETCLOSURE0
- 1746 APPTERM2 5
- 1748 GETGLOBAL Not_found
- 1750 MAKEBLOCK1 0
- 1752 RAISE
- 1753 RESTART
- 1754 GRAB 1
- 1756 ACC1
- 1757 BRANCHIFNOT 1773
- 1759 ACC0
- 1760 PUSHACC2
- 1761 GETFIELD0
- 1762 GETFIELD0
- 1763 C_CALL2 equal
- 1765 BRANCHIF 1773
- 1767 ACC1
- 1768 GETFIELD1
- 1769 PUSHACC1
- 1770 PUSHOFFSETCLOSURE0
- 1771 APPTERM2 4
- 1773 RETURN 2
- 1775 RESTART
- 1776 GRAB 1
- 1778 ACC1
- 1779 BRANCHIFNOT 1794
- 1781 ACC0
- 1782 PUSHACC2
- 1783 GETFIELD0
- 1784 GETFIELD0
- 1785 EQ
- 1786 BRANCHIF 1794
- 1788 ACC1
- 1789 GETFIELD1
- 1790 PUSHACC1
- 1791 PUSHOFFSETCLOSURE0
- 1792 APPTERM2 4
- 1794 RETURN 2
- 1796 RESTART
- 1797 GRAB 1
- 1799 ACC1
- 1800 BRANCHIFNOT 1825
- 1802 ACC1
- 1803 GETFIELD0
- 1804 PUSHACC2
- 1805 GETFIELD1
- 1806 PUSHACC2
- 1807 PUSHACC2
- 1808 GETFIELD0
- 1809 C_CALL2 equal
- 1811 BRANCHIFNOT 1816
- 1813 ACC0
- 1814 RETURN 4
- 1816 ACC0
- 1817 PUSHACC3
- 1818 PUSHOFFSETCLOSURE0
- 1819 APPLY2
- 1820 PUSHACC2
- 1821 MAKEBLOCK2 0
- 1823 POP 2
- 1825 RETURN 2
- 1827 RESTART
- 1828 GRAB 1
- 1830 ACC1
- 1831 BRANCHIFNOT 1855
- 1833 ACC1
- 1834 GETFIELD0
- 1835 PUSHACC2
- 1836 GETFIELD1
- 1837 PUSHACC2
- 1838 PUSHACC2
- 1839 GETFIELD0
- 1840 EQ
- 1841 BRANCHIFNOT 1846
- 1843 ACC0
- 1844 RETURN 4
- 1846 ACC0
- 1847 PUSHACC3
- 1848 PUSHOFFSETCLOSURE0
- 1849 APPLY2
- 1850 PUSHACC2
- 1851 MAKEBLOCK2 0
- 1853 POP 2
- 1855 RETURN 2
- 1857 RESTART
- 1858 GRAB 1
- 1860 ACC1
- 1861 BRANCHIFNOT 1879
- 1863 ACC1
- 1864 GETFIELD0
- 1865 PUSHACC0
- 1866 PUSHACC2
- 1867 APPLY1
- 1868 BRANCHIFNOT 1873
- 1870 ACC0
- 1871 RETURN 3
- 1873 ACC2
- 1874 GETFIELD1
- 1875 PUSHACC2
- 1876 PUSHOFFSETCLOSURE0
- 1877 APPTERM2 5
- 1879 GETGLOBAL Not_found
- 1881 MAKEBLOCK1 0
- 1883 RAISE
- 1884 RESTART
- 1885 GRAB 2
- 1887 ACC2
- 1888 BRANCHIFNOT 1917
- 1890 ACC2
- 1891 GETFIELD0
- 1892 PUSHACC3
- 1893 GETFIELD1
- 1894 PUSHACC1
- 1895 PUSHENVACC2
- 1896 APPLY1
- 1897 BRANCHIFNOT 1908
- 1899 ACC0
- 1900 PUSHACC4
- 1901 PUSHACC4
- 1902 PUSHACC4
- 1903 MAKEBLOCK2 0
- 1905 PUSHOFFSETCLOSURE0
- 1906 APPTERM3 8
- 1908 ACC0
- 1909 PUSHACC4
- 1910 PUSHACC3
- 1911 MAKEBLOCK2 0
- 1913 PUSHACC4
- 1914 PUSHOFFSETCLOSURE0
- 1915 APPTERM3 8
- 1917 ACC1
- 1918 PUSHENVACC1
- 1919 APPLY1
- 1920 PUSHACC1
- 1921 PUSHENVACC1
- 1922 APPLY1
- 1923 MAKEBLOCK2 0
- 1925 RETURN 3
- 1927 RESTART
- 1928 GRAB 1
- 1930 ACC0
- 1931 PUSHENVACC1
- 1932 CLOSUREREC 2, 1885
- 1936 ACC2
- 1937 PUSHCONST0
- 1938 PUSHCONST0
- 1939 PUSHACC3
- 1940 APPTERM3 6
- 1942 ACC0
- 1943 BRANCHIFNOT 1967
- 1945 ACC0
- 1946 GETFIELD0
- 1947 PUSHACC1
- 1948 GETFIELD1
- 1949 PUSHOFFSETCLOSURE0
- 1950 APPLY1
- 1951 PUSHACC0
- 1952 GETFIELD1
- 1953 PUSHACC2
- 1954 GETFIELD1
- 1955 MAKEBLOCK2 0
- 1957 PUSHACC1
- 1958 GETFIELD0
- 1959 PUSHACC3
- 1960 GETFIELD0
- 1961 MAKEBLOCK2 0
- 1963 MAKEBLOCK2 0
- 1965 RETURN 3
- 1967 GETGLOBAL <0>(0, 0)
- 1969 RETURN 1
- 1971 RESTART
- 1972 GRAB 1
- 1974 ACC0
- 1975 BRANCHIFNOT 1996
- 1977 ACC1
- 1978 BRANCHIFNOT 2003
- 1980 ACC1
- 1981 GETFIELD1
- 1982 PUSHACC1
- 1983 GETFIELD1
- 1984 PUSHOFFSETCLOSURE0
- 1985 APPLY2
- 1986 PUSHACC2
- 1987 GETFIELD0
- 1988 PUSHACC2
- 1989 GETFIELD0
- 1990 MAKEBLOCK2 0
- 1992 MAKEBLOCK2 0
- 1994 RETURN 2
- 1996 ACC1
- 1997 BRANCHIFNOT 2001
- 1999 BRANCH 2003
- 2001 RETURN 2
- 2003 GETGLOBAL "List.combine"
- 2005 PUSHGETGLOBALFIELD Pervasives, 2
- 2008 APPTERM1 3
- 2010 RESTART
- 2011 GRAB 1
- 2013 ACC1
- 2014 BRANCHIFNOT 2038
- 2016 ACC1
- 2017 GETFIELD0
- 2018 PUSHACC2
- 2019 GETFIELD1
- 2020 PUSHACC1
- 2021 PUSHENVACC2
- 2022 APPLY1
- 2023 BRANCHIFNOT 2033
- 2025 ACC0
- 2026 PUSHACC3
- 2027 PUSHACC3
- 2028 MAKEBLOCK2 0
- 2030 PUSHOFFSETCLOSURE0
- 2031 APPTERM2 6
- 2033 ACC0
- 2034 PUSHACC3
- 2035 PUSHOFFSETCLOSURE0
- 2036 APPTERM2 6
- 2038 ACC0
- 2039 PUSHENVACC1
- 2040 APPTERM1 3
- 2042 ACC0
- 2043 PUSHENVACC1
- 2044 CLOSUREREC 2, 2011
- 2048 CONST0
- 2049 PUSHACC1
- 2050 APPTERM1 3
- 2052 RESTART
- 2053 GRAB 2
- 2055 ACC1
- 2056 BRANCHIFNOT 2077
- 2058 ACC2
- 2059 BRANCHIFNOT 2084
- 2061 ACC2
- 2062 GETFIELD1
- 2063 PUSHACC2
- 2064 GETFIELD1
- 2065 PUSHACC2
- 2066 PUSHACC5
- 2067 GETFIELD0
- 2068 PUSHACC5
- 2069 GETFIELD0
- 2070 PUSHENVACC1
- 2071 APPLY2
- 2072 MAKEBLOCK2 0
- 2074 PUSHOFFSETCLOSURE0
- 2075 APPTERM3 6
- 2077 ACC2
- 2078 BRANCHIFNOT 2082
- 2080 BRANCH 2084
- 2082 RETURN 3
- 2084 GETGLOBAL "List.rev_map2"
- 2086 PUSHGETGLOBALFIELD Pervasives, 2
- 2089 APPTERM1 4
- 2091 RESTART
- 2092 GRAB 2
- 2094 ACC0
- 2095 CLOSUREREC 1, 2053
- 2099 ACC3
- 2100 PUSHACC3
- 2101 PUSHCONST0
- 2102 PUSHACC3
- 2103 APPTERM3 7
- 2105 RESTART
- 2106 GRAB 1
- 2108 ACC1
- 2109 BRANCHIFNOT 2123
- 2111 ACC1
- 2112 GETFIELD1
- 2113 PUSHACC1
- 2114 PUSHACC3
- 2115 GETFIELD0
- 2116 PUSHENVACC1
- 2117 APPLY1
- 2118 MAKEBLOCK2 0
- 2120 PUSHOFFSETCLOSURE0
- 2121 APPTERM2 4
- 2123 ACC0
- 2124 RETURN 2
- 2126 RESTART
- 2127 GRAB 1
- 2129 ACC0
- 2130 CLOSUREREC 1, 2106
- 2134 ACC2
- 2135 PUSHCONST0
- 2136 PUSHACC2
- 2137 APPTERM2 5
- 2139 CONST0
- 2140 PUSHACC1
- 2141 PUSHENVACC1
- 2142 APPTERM2 3
- 2144 ACC0
- 2145 BRANCHIFNOT 2151
- 2147 ACC0
- 2148 GETFIELD1
- 2149 RETURN 1
- 2151 GETGLOBAL "tl"
- 2153 PUSHGETGLOBALFIELD Pervasives, 3
- 2156 APPTERM1 2
- 2158 ACC0
- 2159 BRANCHIFNOT 2165
- 2161 ACC0
- 2162 GETFIELD0
- 2163 RETURN 1
- 2165 GETGLOBAL "hd"
- 2167 PUSHGETGLOBALFIELD Pervasives, 3
- 2170 APPTERM1 2
- 2172 ACC0
- 2173 PUSHCONST0
- 2174 PUSHENVACC1
- 2175 APPTERM2 3
- 2177 CLOSUREREC 0, 1200
- 2181 ACC0
- 2182 CLOSURE 1, 2172
- 2185 PUSH
- 2186 CLOSURE 0, 2158
- 2189 PUSH
- 2190 CLOSURE 0, 2144
- 2193 PUSH
- 2194 CLOSUREREC 0, 1217
- 2198 GETGLOBALFIELD Pervasives, 16
- 2201 PUSH
- 2202 CLOSUREREC 0, 1259
- 2206 ACC0
- 2207 CLOSURE 1, 2139
- 2210 PUSH
- 2211 CLOSUREREC 0, 1277
- 2215 CLOSUREREC 0, 1294
- 2219 CLOSURE 0, 2127
- 2222 PUSH
- 2223 CLOSUREREC 0, 1316
- 2227 CLOSUREREC 0, 1334
- 2231 CLOSUREREC 0, 1354
- 2235 CLOSUREREC 0, 1374
- 2239 CLOSURE 0, 2092
- 2242 PUSH
- 2243 CLOSUREREC 0, 1415
- 2247 CLOSUREREC 0, 1452
- 2251 CLOSUREREC 0, 1490
- 2255 CLOSUREREC 0, 1530
- 2259 CLOSUREREC 0, 1553
- 2263 CLOSUREREC 0, 1573
- 2267 CLOSUREREC 0, 1613
- 2271 CLOSUREREC 0, 1654
- 2275 CLOSUREREC 0, 1675
- 2279 CLOSUREREC 0, 1695
- 2283 CLOSUREREC 0, 1725
- 2287 CLOSUREREC 0, 1754
- 2291 CLOSUREREC 0, 1776
- 2295 CLOSUREREC 0, 1797
- 2299 CLOSUREREC 0, 1828
- 2303 CLOSUREREC 0, 1858
- 2307 ACC 24
- 2309 CLOSURE 1, 2042
- 2312 PUSHACC 25
- 2314 CLOSUREREC 1, 1928
- 2318 CLOSUREREC 0, 1942
- 2322 CLOSUREREC 0, 1972
- 2326 ACC0
- 2327 PUSHACC2
- 2328 PUSHACC7
- 2329 PUSHACC 9
- 2331 PUSHACC 11
- 2333 PUSHACC 13
- 2335 PUSHACC 15
- 2337 PUSHACC 17
- 2339 PUSHACC 10
- 2341 PUSHACC 12
- 2343 PUSHACC 13
- 2345 PUSHACC 15
- 2347 PUSHACC 23
- 2349 PUSHACC 25
- 2351 PUSHACC 27
- 2353 PUSHACC 29
- 2355 PUSHACC 31
- 2357 PUSHACC 33
- 2359 PUSHACC 35
- 2361 PUSHACC 37
- 2363 PUSHACC 40
- 2365 PUSHACC 42
- 2367 PUSHACC 41
- 2369 PUSHACC 45
- 2371 PUSHACC 47
- 2373 PUSHACC 50
- 2375 PUSHACC 52
- 2377 PUSHACC 51
- 2379 PUSHACC 55
- 2381 PUSHACC 56
- 2383 PUSHACC 59
- 2385 PUSHACC 61
- 2387 PUSHACC 60
- 2389 PUSHACC 64
- 2391 PUSHACC 66
- 2393 PUSHACC 68
- 2395 PUSHACC 70
- 2397 MAKEBLOCK 37, 0
- 2400 POP 36
- 2402 SETGLOBAL List
- 2404 BRANCH 2432
- 2406 CONST0
- 2407 PUSHACC1
- 2408 LEINT
- 2409 BRANCHIFNOT 2414
- 2411 CONST0
- 2412 RETURN 1
- 2414 ACC0
- 2415 OFFSETINT -1
- 2417 PUSHOFFSETCLOSURE0
- 2418 APPLY1
- 2419 PUSHACC1
- 2420 MAKEBLOCK2 0
- 2422 RETURN 1
- 2424 RESTART
- 2425 GRAB 1
- 2427 ACC1
- 2428 PUSHACC1
- 2429 ADDINT
- 2430 RETURN 2
- 2432 CLOSUREREC 0, 2406
- 2436 CONST0
- 2437 C_CALL1 gc_compaction
- 2439 CONSTINT 300
- 2441 PUSHACC1
- 2442 APPLY1
- 2443 PUSHCONSTINT 150
- 2445 PUSHCONSTINT 301
- 2447 MULINT
- 2448 PUSHACC1
- 2449 PUSHCONST0
- 2450 PUSH
- 2451 CLOSURE 0, 2425
- 2454 PUSHGETGLOBALFIELD List, 12
- 2457 APPLY3
- 2458 NEQ
- 2459 BRANCHIFNOT 2466
- 2461 GETGLOBAL Not_found
- 2463 MAKEBLOCK1 0
- 2465 RAISE
- 2466 POP 2
- 2468 ATOM0
- 2469 SETGLOBAL T330-compact-4
- 2471 STOP
-**)
diff --git a/test/testinterp/t340-weak.ml b/test/testinterp/t340-weak.ml
deleted file mode 100644
index e36dbab503..0000000000
--- a/test/testinterp/t340-weak.ml
+++ /dev/null
@@ -1,2551 +0,0 @@
-open Lib;;
-let x = Array.make 20 "" in
-let w = weak_create 20 in
-for i = 0 to 19 do
- x.(i) <- String.make 20 's';
- weak_set w i (Some x.(i));
-done;
-Gc.full_major ();
-for i = 0 to 19 do
- match weak_get w i with
- | None -> raise Not_found
- | _ -> ()
-done;
-for i = 0 to 19 do
- if i mod 2 = 0 then x.(i) <- ""
-done;
-Gc.full_major ();
-for i = 0 to 19 do
- match weak_get w i with
- | None when i mod 2 = 0 -> ()
- | Some s when i mod 2 = 1 -> if s.[5] <> 's' then raise Not_found
- | _ -> raise Not_found
-done
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 746
- 11 RESTART
- 12 GRAB 1
- 14 ACC0
- 15 BRANCHIFNOT 28
- 17 ACC1
- 18 PUSHACC1
- 19 GETFIELD1
- 20 PUSHOFFSETCLOSURE0
- 21 APPLY2
- 22 PUSHACC1
- 23 GETFIELD0
- 24 MAKEBLOCK2 0
- 26 RETURN 2
- 28 ACC1
- 29 RETURN 2
- 31 RESTART
- 32 GRAB 3
- 34 CONST0
- 35 PUSHACC4
- 36 LEINT
- 37 BRANCHIFNOT 42
- 39 CONST0
- 40 RETURN 4
- 42 ACC3
- 43 PUSHACC3
- 44 PUSHACC3
- 45 PUSHACC3
- 46 C_CALL4 caml_input
- 48 PUSHCONST0
- 49 PUSHACC1
- 50 EQ
- 51 BRANCHIFNOT 58
- 53 GETGLOBAL End_of_file
- 55 MAKEBLOCK1 0
- 57 RAISE
- 58 ACC0
- 59 PUSHACC5
- 60 SUBINT
- 61 PUSHACC1
- 62 PUSHACC5
- 63 ADDINT
- 64 PUSHACC4
- 65 PUSHACC4
- 66 PUSHOFFSETCLOSURE0
- 67 APPTERM 4, 9
- 70 ACC0
- 71 C_CALL1 caml_input_scan_line
- 73 PUSHCONST0
- 74 PUSHACC1
- 75 EQ
- 76 BRANCHIFNOT 83
- 78 GETGLOBAL End_of_file
- 80 MAKEBLOCK1 0
- 82 RAISE
- 83 CONST0
- 84 PUSHACC1
- 85 GTINT
- 86 BRANCHIFNOT 107
- 88 ACC0
- 89 OFFSETINT -1
- 91 C_CALL1 create_string
- 93 PUSHACC1
- 94 OFFSETINT -1
- 96 PUSHCONST0
- 97 PUSHACC2
- 98 PUSHACC5
- 99 C_CALL4 caml_input
- 101 ACC2
- 102 C_CALL1 caml_input_char
- 104 ACC0
- 105 RETURN 3
- 107 ACC0
- 108 NEGINT
- 109 C_CALL1 create_string
- 111 PUSHACC1
- 112 NEGINT
- 113 PUSHCONST0
- 114 PUSHACC2
- 115 PUSHACC5
- 116 C_CALL4 caml_input
- 118 CONST0
- 119 PUSHTRAP 130
- 121 ACC6
- 122 PUSHOFFSETCLOSURE0
- 123 APPLY1
- 124 PUSHACC5
- 125 PUSHENVACC1
- 126 APPLY2
- 127 POPTRAP
- 128 RETURN 3
- 130 PUSHGETGLOBAL End_of_file
- 132 PUSHACC1
- 133 GETFIELD0
- 134 EQ
- 135 BRANCHIFNOT 140
- 137 ACC1
- 138 RETURN 4
- 140 ACC0
- 141 RAISE
- 142 ACC0
- 143 C_CALL1 caml_flush
- 145 RETURN 1
- 147 RESTART
- 148 GRAB 1
- 150 ACC1
- 151 PUSHACC1
- 152 C_CALL2 caml_output_char
- 154 RETURN 2
- 156 RESTART
- 157 GRAB 1
- 159 ACC1
- 160 PUSHACC1
- 161 C_CALL2 caml_output_char
- 163 RETURN 2
- 165 RESTART
- 166 GRAB 1
- 168 ACC1
- 169 PUSHACC1
- 170 C_CALL2 caml_output_int
- 172 RETURN 2
- 174 RESTART
- 175 GRAB 1
- 177 ACC1
- 178 PUSHACC1
- 179 C_CALL2 caml_seek_out
- 181 RETURN 2
- 183 ACC0
- 184 C_CALL1 caml_pos_out
- 186 RETURN 1
- 188 ACC0
- 189 C_CALL1 caml_channel_size
- 191 RETURN 1
- 193 RESTART
- 194 GRAB 1
- 196 ACC1
- 197 PUSHACC1
- 198 C_CALL2 caml_set_binary_mode
- 200 RETURN 2
- 202 ACC0
- 203 C_CALL1 caml_input_char
- 205 RETURN 1
- 207 ACC0
- 208 C_CALL1 caml_input_char
- 210 RETURN 1
- 212 ACC0
- 213 C_CALL1 caml_input_int
- 215 RETURN 1
- 217 ACC0
- 218 C_CALL1 input_value
- 220 RETURN 1
- 222 RESTART
- 223 GRAB 1
- 225 ACC1
- 226 PUSHACC1
- 227 C_CALL2 caml_seek_in
- 229 RETURN 2
- 231 ACC0
- 232 C_CALL1 caml_pos_in
- 234 RETURN 1
- 236 ACC0
- 237 C_CALL1 caml_channel_size
- 239 RETURN 1
- 241 ACC0
- 242 C_CALL1 caml_close_channel
- 244 RETURN 1
- 246 RESTART
- 247 GRAB 1
- 249 ACC1
- 250 PUSHACC1
- 251 C_CALL2 caml_set_binary_mode
- 253 RETURN 2
- 255 CONST0
- 256 PUSHENVACC1
- 257 APPLY1
- 258 ACC0
- 259 C_CALL1 sys_exit
- 261 RETURN 1
- 263 CONST0
- 264 PUSHENVACC1
- 265 GETFIELD0
- 266 APPTERM1 2
- 268 CONST0
- 269 PUSHENVACC1
- 270 APPLY1
- 271 CONST0
- 272 PUSHENVACC2
- 273 APPTERM1 2
- 275 ENVACC1
- 276 GETFIELD0
- 277 PUSHACC0
- 278 PUSHACC2
- 279 CLOSURE 2, 268
- 282 PUSHENVACC1
- 283 SETFIELD0
- 284 RETURN 2
- 286 ENVACC1
- 287 C_CALL1 caml_flush
- 289 ENVACC2
- 290 C_CALL1 caml_flush
- 292 RETURN 1
- 294 CONST0
- 295 PUSHENVACC1
- 296 APPLY1
- 297 C_CALL1 float_of_string
- 299 RETURN 1
- 301 CONST0
- 302 PUSHENVACC1
- 303 APPLY1
- 304 C_CALL1 int_of_string
- 306 RETURN 1
- 308 ENVACC2
- 309 C_CALL1 caml_flush
- 311 ENVACC1
- 312 PUSHENVACC3
- 313 APPTERM1 2
- 315 CONSTINT 13
- 317 PUSHENVACC1
- 318 C_CALL2 caml_output_char
- 320 ENVACC1
- 321 C_CALL1 caml_flush
- 323 RETURN 1
- 325 ACC0
- 326 PUSHENVACC1
- 327 PUSHENVACC2
- 328 APPLY2
- 329 CONSTINT 13
- 331 PUSHENVACC1
- 332 C_CALL2 caml_output_char
- 334 ENVACC1
- 335 C_CALL1 caml_flush
- 337 RETURN 1
- 339 ACC0
- 340 PUSHENVACC1
- 341 APPLY1
- 342 PUSHENVACC2
- 343 PUSHENVACC3
- 344 APPTERM2 3
- 346 ACC0
- 347 PUSHENVACC1
- 348 APPLY1
- 349 PUSHENVACC2
- 350 PUSHENVACC3
- 351 APPTERM2 3
- 353 ACC0
- 354 PUSHENVACC1
- 355 PUSHENVACC2
- 356 APPTERM2 3
- 358 ACC0
- 359 PUSHENVACC1
- 360 C_CALL2 caml_output_char
- 362 RETURN 1
- 364 CONSTINT 13
- 366 PUSHENVACC1
- 367 C_CALL2 caml_output_char
- 369 ENVACC1
- 370 C_CALL1 caml_flush
- 372 RETURN 1
- 374 ACC0
- 375 PUSHENVACC1
- 376 PUSHENVACC2
- 377 APPLY2
- 378 CONSTINT 13
- 380 PUSHENVACC1
- 381 C_CALL2 caml_output_char
- 383 RETURN 1
- 385 ACC0
- 386 PUSHENVACC1
- 387 APPLY1
- 388 PUSHENVACC2
- 389 PUSHENVACC3
- 390 APPTERM2 3
- 392 ACC0
- 393 PUSHENVACC1
- 394 APPLY1
- 395 PUSHENVACC2
- 396 PUSHENVACC3
- 397 APPTERM2 3
- 399 ACC0
- 400 PUSHENVACC1
- 401 PUSHENVACC2
- 402 APPTERM2 3
- 404 ACC0
- 405 PUSHENVACC1
- 406 C_CALL2 caml_output_char
- 408 RETURN 1
- 410 RESTART
- 411 GRAB 3
- 413 CONST0
- 414 PUSHACC3
- 415 LTINT
- 416 BRANCHIF 427
- 418 ACC1
- 419 C_CALL1 ml_string_length
- 421 PUSHACC4
- 422 PUSHACC4
- 423 ADDINT
- 424 GTINT
- 425 BRANCHIFNOT 432
- 427 GETGLOBAL "really_input"
- 429 PUSHENVACC1
- 430 APPTERM1 5
- 432 ACC3
- 433 PUSHACC3
- 434 PUSHACC3
- 435 PUSHACC3
- 436 PUSHENVACC2
- 437 APPTERM 4, 8
- 440 RESTART
- 441 GRAB 3
- 443 CONST0
- 444 PUSHACC3
- 445 LTINT
- 446 BRANCHIF 457
- 448 ACC1
- 449 C_CALL1 ml_string_length
- 451 PUSHACC4
- 452 PUSHACC4
- 453 ADDINT
- 454 GTINT
- 455 BRANCHIFNOT 462
- 457 GETGLOBAL "input"
- 459 PUSHENVACC1
- 460 APPTERM1 5
- 462 ACC3
- 463 PUSHACC3
- 464 PUSHACC3
- 465 PUSHACC3
- 466 C_CALL4 caml_input
- 468 RETURN 4
- 470 ACC0
- 471 PUSHCONST0
- 472 PUSHGETGLOBAL <0>(0, <0>(6, 0))
- 474 PUSHENVACC1
- 475 APPTERM3 4
- 477 ACC0
- 478 PUSHCONST0
- 479 PUSHGETGLOBAL <0>(0, <0>(7, 0))
- 481 PUSHENVACC1
- 482 APPTERM3 4
- 484 RESTART
- 485 GRAB 2
- 487 ACC1
- 488 PUSHACC1
- 489 PUSHACC4
- 490 C_CALL3 sys_open
- 492 C_CALL1 caml_open_descriptor
- 494 RETURN 3
- 496 ACC0
- 497 C_CALL1 caml_flush
- 499 ACC0
- 500 C_CALL1 caml_close_channel
- 502 RETURN 1
- 504 RESTART
- 505 GRAB 1
- 507 CONST0
- 508 PUSHACC2
- 509 PUSHACC2
- 510 C_CALL3 output_value
- 512 RETURN 2
- 514 RESTART
- 515 GRAB 3
- 517 CONST0
- 518 PUSHACC3
- 519 LTINT
- 520 BRANCHIF 531
- 522 ACC1
- 523 C_CALL1 ml_string_length
- 525 PUSHACC4
- 526 PUSHACC4
- 527 ADDINT
- 528 GTINT
- 529 BRANCHIFNOT 536
- 531 GETGLOBAL "output"
- 533 PUSHENVACC1
- 534 APPTERM1 5
- 536 ACC3
- 537 PUSHACC3
- 538 PUSHACC3
- 539 PUSHACC3
- 540 C_CALL4 caml_output
- 542 RETURN 4
- 544 RESTART
- 545 GRAB 1
- 547 ACC1
- 548 C_CALL1 ml_string_length
- 550 PUSHCONST0
- 551 PUSHACC3
- 552 PUSHACC3
- 553 C_CALL4 caml_output
- 555 RETURN 2
- 557 ACC0
- 558 PUSHCONSTINT 438
- 560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0))))
- 562 PUSHENVACC1
- 563 APPTERM3 4
- 565 ACC0
- 566 PUSHCONSTINT 438
- 568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0))))
- 570 PUSHENVACC1
- 571 APPTERM3 4
- 573 RESTART
- 574 GRAB 2
- 576 ACC1
- 577 PUSHACC1
- 578 PUSHACC4
- 579 C_CALL3 sys_open
- 581 C_CALL1 caml_open_descriptor
- 583 RETURN 3
- 585 ACC0
- 586 PUSHGETGLOBAL "%.12g"
- 588 C_CALL2 format_float
- 590 RETURN 1
- 592 ACC0
- 593 PUSHGETGLOBAL "%d"
- 595 C_CALL2 format_int
- 597 RETURN 1
- 599 GETGLOBAL "false"
- 601 PUSHACC1
- 602 C_CALL2 string_equal
- 604 BRANCHIFNOT 609
- 606 CONST0
- 607 RETURN 1
- 609 GETGLOBAL "true"
- 611 PUSHACC1
- 612 C_CALL2 string_equal
- 614 BRANCHIFNOT 619
- 616 CONST1
- 617 RETURN 1
- 619 GETGLOBAL "bool_of_string"
- 621 PUSHENVACC1
- 622 APPTERM1 2
- 624 ACC0
- 625 BRANCHIFNOT 631
- 627 GETGLOBAL "true"
- 629 RETURN 1
- 631 GETGLOBAL "false"
- 633 RETURN 1
- 635 CONST0
- 636 PUSHACC1
- 637 LTINT
- 638 BRANCHIF 646
- 640 CONSTINT 255
- 642 PUSHACC1
- 643 GTINT
- 644 BRANCHIFNOT 651
- 646 GETGLOBAL "char_of_int"
- 648 PUSHENVACC1
- 649 APPTERM1 2
- 651 ACC0
- 652 RETURN 1
- 654 RESTART
- 655 GRAB 1
- 657 ACC0
- 658 C_CALL1 ml_string_length
- 660 PUSHACC2
- 661 C_CALL1 ml_string_length
- 663 PUSHACC0
- 664 PUSHACC2
- 665 ADDINT
- 666 C_CALL1 create_string
- 668 PUSHACC2
- 669 PUSHCONST0
- 670 PUSHACC2
- 671 PUSHCONST0
- 672 PUSHACC7
- 673 C_CALL5 blit_string
- 675 ACC1
- 676 PUSHACC3
- 677 PUSHACC2
- 678 PUSHCONST0
- 679 PUSHACC 8
- 681 C_CALL5 blit_string
- 683 ACC0
- 684 RETURN 5
- 686 CONSTINT -1
- 688 PUSHACC1
- 689 XORINT
- 690 RETURN 1
- 692 CONST0
- 693 PUSHACC1
- 694 GEINT
- 695 BRANCHIFNOT 700
- 697 ACC0
- 698 RETURN 1
- 700 ACC0
- 701 NEGINT
- 702 RETURN 1
- 704 RESTART
- 705 GRAB 1
- 707 ACC1
- 708 PUSHACC1
- 709 C_CALL2 greaterequal
- 711 BRANCHIFNOT 716
- 713 ACC0
- 714 RETURN 2
- 716 ACC1
- 717 RETURN 2
- 719 RESTART
- 720 GRAB 1
- 722 ACC1
- 723 PUSHACC1
- 724 C_CALL2 lessequal
- 726 BRANCHIFNOT 731
- 728 ACC0
- 729 RETURN 2
- 731 ACC1
- 732 RETURN 2
- 734 ACC0
- 735 PUSHGETGLOBAL Invalid_argument
- 737 MAKEBLOCK2 0
- 739 RAISE
- 740 ACC0
- 741 PUSHGETGLOBAL Failure
- 743 MAKEBLOCK2 0
- 745 RAISE
- 746 CLOSURE 0, 740
- 749 PUSH
- 750 CLOSURE 0, 734
- 753 PUSHGETGLOBAL "Pervasives.Exit"
- 755 MAKEBLOCK1 0
- 757 PUSHGETGLOBAL "Pervasives.Assert_failure"
- 759 MAKEBLOCK1 0
- 761 PUSH
- 762 CLOSURE 0, 720
- 765 PUSH
- 766 CLOSURE 0, 705
- 769 PUSH
- 770 CLOSURE 0, 692
- 773 PUSH
- 774 CLOSURE 0, 686
- 777 PUSHCONST0
- 778 PUSHCONSTINT 31
- 780 PUSHCONST1
- 781 LSLINT
- 782 EQ
- 783 BRANCHIFNOT 789
- 785 CONSTINT 30
- 787 BRANCH 791
- 789 CONSTINT 62
- 791 PUSHCONST1
- 792 LSLINT
- 793 PUSHACC0
- 794 OFFSETINT -1
- 796 PUSH
- 797 CLOSURE 0, 655
- 800 PUSHACC 9
- 802 CLOSURE 1, 635
- 805 PUSH
- 806 CLOSURE 0, 624
- 809 PUSHACC 11
- 811 CLOSURE 1, 599
- 814 PUSH
- 815 CLOSURE 0, 592
- 818 PUSH
- 819 CLOSURE 0, 585
- 822 PUSH
- 823 CLOSUREREC 0, 12
- 827 CONST0
- 828 C_CALL1 caml_open_descriptor
- 830 PUSHCONST1
- 831 C_CALL1 caml_open_descriptor
- 833 PUSHCONST2
- 834 C_CALL1 caml_open_descriptor
- 836 PUSH
- 837 CLOSURE 0, 574
- 840 PUSHACC0
- 841 CLOSURE 1, 565
- 844 PUSHACC1
- 845 CLOSURE 1, 557
- 848 PUSH
- 849 CLOSURE 0, 545
- 852 PUSHACC 22
- 854 CLOSURE 1, 515
- 857 PUSH
- 858 CLOSURE 0, 505
- 861 PUSH
- 862 CLOSURE 0, 496
- 865 PUSH
- 866 CLOSURE 0, 485
- 869 PUSHACC0
- 870 CLOSURE 1, 477
- 873 PUSHACC1
- 874 CLOSURE 1, 470
- 877 PUSHACC 28
- 879 CLOSURE 1, 441
- 882 PUSH
- 883 CLOSUREREC 0, 32
- 887 ACC0
- 888 PUSHACC 31
- 890 CLOSURE 2, 411
- 893 PUSHACC 22
- 895 CLOSUREREC 1, 70
- 899 ACC 15
- 901 CLOSURE 1, 404
- 904 PUSHACC 11
- 906 PUSHACC 17
- 908 CLOSURE 2, 399
- 911 PUSHACC 12
- 913 PUSHACC 18
- 915 PUSHACC 23
- 917 CLOSURE 3, 392
- 920 PUSHACC 13
- 922 PUSHACC 19
- 924 PUSHACC 23
- 926 CLOSURE 3, 385
- 929 PUSHACC 14
- 931 PUSHACC 20
- 933 CLOSURE 2, 374
- 936 PUSHACC 20
- 938 CLOSURE 1, 364
- 941 PUSHACC 20
- 943 CLOSURE 1, 358
- 946 PUSHACC 17
- 948 PUSHACC 22
- 950 CLOSURE 2, 353
- 953 PUSHACC 18
- 955 PUSHACC 23
- 957 PUSHACC 29
- 959 CLOSURE 3, 346
- 962 PUSHACC 19
- 964 PUSHACC 24
- 966 PUSHACC 29
- 968 CLOSURE 3, 339
- 971 PUSHACC 20
- 973 PUSHACC 25
- 975 CLOSURE 2, 325
- 978 PUSHACC 25
- 980 CLOSURE 1, 315
- 983 PUSHACC 12
- 985 PUSHACC 28
- 987 PUSHACC 30
- 989 CLOSURE 3, 308
- 992 PUSHACC0
- 993 CLOSURE 1, 301
- 996 PUSHACC1
- 997 CLOSURE 1, 294
- 1000 PUSHACC 29
- 1002 PUSHACC 31
- 1004 CLOSURE 2, 286
- 1007 MAKEBLOCK1 0
- 1009 PUSHACC0
- 1010 CLOSURE 1, 275
- 1013 PUSHACC1
- 1014 CLOSURE 1, 263
- 1017 PUSHACC0
- 1018 CLOSURE 1, 255
- 1021 PUSHACC1
- 1022 PUSHACC 22
- 1024 PUSHACC4
- 1025 PUSHACC3
- 1026 PUSH
- 1027 CLOSURE 0, 247
- 1030 PUSH
- 1031 CLOSURE 0, 241
- 1034 PUSH
- 1035 CLOSURE 0, 236
- 1038 PUSH
- 1039 CLOSURE 0, 231
- 1042 PUSH
- 1043 CLOSURE 0, 223
- 1046 PUSH
- 1047 CLOSURE 0, 217
- 1050 PUSH
- 1051 CLOSURE 0, 212
- 1054 PUSH
- 1055 CLOSURE 0, 207
- 1058 PUSHACC 32
- 1060 PUSHACC 35
- 1062 PUSHACC 33
- 1064 PUSH
- 1065 CLOSURE 0, 202
- 1068 PUSHACC 41
- 1070 PUSHACC 40
- 1072 PUSHACC 42
- 1074 PUSH
- 1075 CLOSURE 0, 194
- 1078 PUSHACC 46
- 1080 PUSH
- 1081 CLOSURE 0, 188
- 1084 PUSH
- 1085 CLOSURE 0, 183
- 1088 PUSH
- 1089 CLOSURE 0, 175
- 1092 PUSHACC 51
- 1094 PUSH
- 1095 CLOSURE 0, 166
- 1098 PUSH
- 1099 CLOSURE 0, 157
- 1102 PUSHACC 55
- 1104 PUSHACC 57
- 1106 PUSH
- 1107 CLOSURE 0, 148
- 1110 PUSH
- 1111 CLOSURE 0, 142
- 1114 PUSHACC 63
- 1116 PUSHACC 62
- 1118 PUSHACC 64
- 1120 PUSHACC 38
- 1122 PUSHACC 40
- 1124 PUSHACC 42
- 1126 PUSHACC 44
- 1128 PUSHACC 46
- 1130 PUSHACC 48
- 1132 PUSHACC 50
- 1134 PUSHACC 52
- 1136 PUSHACC 54
- 1138 PUSHACC 56
- 1140 PUSHACC 58
- 1142 PUSHACC 60
- 1144 PUSHACC 62
- 1146 PUSHACC 64
- 1148 PUSHACC 66
- 1150 PUSHACC 82
- 1152 PUSHACC 84
- 1154 PUSHACC 86
- 1156 PUSHACC 88
- 1158 PUSHACC 90
- 1160 PUSHACC 92
- 1162 PUSHACC 94
- 1164 PUSHACC 96
- 1166 PUSHACC 98
- 1168 PUSHACC 100
- 1170 PUSHACC 104
- 1172 PUSHACC 104
- 1174 PUSHACC 104
- 1176 PUSHACC 108
- 1178 PUSHACC 110
- 1180 PUSHACC 112
- 1182 PUSHACC 117
- 1184 PUSHACC 117
- 1186 PUSHACC 117
- 1188 PUSHACC 117
- 1190 MAKEBLOCK 69, 0
- 1193 POP 53
- 1195 SETGLOBAL Pervasives
- 1197 BRANCH 2177
- 1199 RESTART
- 1200 GRAB 1
- 1202 ACC1
- 1203 BRANCHIFNOT 1213
- 1205 ACC1
- 1206 GETFIELD1
- 1207 PUSHACC1
- 1208 OFFSETINT 1
- 1210 PUSHOFFSETCLOSURE0
- 1211 APPTERM2 4
- 1213 ACC0
- 1214 RETURN 2
- 1216 RESTART
- 1217 GRAB 1
- 1219 ACC0
- 1220 BRANCHIFNOT 1251
- 1222 CONST0
- 1223 PUSHACC2
- 1224 EQ
- 1225 BRANCHIFNOT 1231
- 1227 ACC0
- 1228 GETFIELD0
- 1229 RETURN 2
- 1231 CONST0
- 1232 PUSHACC2
- 1233 GTINT
- 1234 BRANCHIFNOT 1244
- 1236 ACC1
- 1237 OFFSETINT -1
- 1239 PUSHACC1
- 1240 GETFIELD1
- 1241 PUSHOFFSETCLOSURE0
- 1242 APPTERM2 4
- 1244 GETGLOBAL "List.nth"
- 1246 PUSHGETGLOBALFIELD Pervasives, 2
- 1249 APPTERM1 3
- 1251 GETGLOBAL "nth"
- 1253 PUSHGETGLOBALFIELD Pervasives, 3
- 1256 APPTERM1 3
- 1258 RESTART
- 1259 GRAB 1
- 1261 ACC0
- 1262 BRANCHIFNOT 1274
- 1264 ACC1
- 1265 PUSHACC1
- 1266 GETFIELD0
- 1267 MAKEBLOCK2 0
- 1269 PUSHACC1
- 1270 GETFIELD1
- 1271 PUSHOFFSETCLOSURE0
- 1272 APPTERM2 4
- 1274 ACC1
- 1275 RETURN 2
- 1277 ACC0
- 1278 BRANCHIFNOT 1291
- 1280 ACC0
- 1281 GETFIELD1
- 1282 PUSHOFFSETCLOSURE0
- 1283 APPLY1
- 1284 PUSHACC1
- 1285 GETFIELD0
- 1286 PUSHGETGLOBALFIELD Pervasives, 16
- 1289 APPTERM2 3
- 1291 RETURN 1
- 1293 RESTART
- 1294 GRAB 1
- 1296 ACC1
- 1297 BRANCHIFNOT 1313
- 1299 ACC1
- 1300 GETFIELD0
- 1301 PUSHACC1
- 1302 APPLY1
- 1303 PUSHACC2
- 1304 GETFIELD1
- 1305 PUSHACC2
- 1306 PUSHOFFSETCLOSURE0
- 1307 APPLY2
- 1308 PUSHACC1
- 1309 MAKEBLOCK2 0
- 1311 POP 1
- 1313 RETURN 2
- 1315 RESTART
- 1316 GRAB 1
- 1318 ACC1
- 1319 BRANCHIFNOT 1331
- 1321 ACC1
- 1322 GETFIELD0
- 1323 PUSHACC1
- 1324 APPLY1
- 1325 ACC1
- 1326 GETFIELD1
- 1327 PUSHACC1
- 1328 PUSHOFFSETCLOSURE0
- 1329 APPTERM2 4
- 1331 RETURN 2
- 1333 RESTART
- 1334 GRAB 2
- 1336 ACC2
- 1337 BRANCHIFNOT 1350
- 1339 ACC2
- 1340 GETFIELD1
- 1341 PUSHACC3
- 1342 GETFIELD0
- 1343 PUSHACC3
- 1344 PUSHACC3
- 1345 APPLY2
- 1346 PUSHACC2
- 1347 PUSHOFFSETCLOSURE0
- 1348 APPTERM3 6
- 1350 ACC1
- 1351 RETURN 3
- 1353 RESTART
- 1354 GRAB 2
- 1356 ACC1
- 1357 BRANCHIFNOT 1370
- 1359 ACC2
- 1360 PUSHACC2
- 1361 GETFIELD1
- 1362 PUSHACC2
- 1363 PUSHOFFSETCLOSURE0
- 1364 APPLY3
- 1365 PUSHACC2
- 1366 GETFIELD0
- 1367 PUSHACC2
- 1368 APPTERM2 5
- 1370 ACC2
- 1371 RETURN 3
- 1373 RESTART
- 1374 GRAB 2
- 1376 ACC1
- 1377 BRANCHIFNOT 1400
- 1379 ACC2
- 1380 BRANCHIFNOT 1407
- 1382 ACC2
- 1383 GETFIELD0
- 1384 PUSHACC2
- 1385 GETFIELD0
- 1386 PUSHACC2
- 1387 APPLY2
- 1388 PUSHACC3
- 1389 GETFIELD1
- 1390 PUSHACC3
- 1391 GETFIELD1
- 1392 PUSHACC3
- 1393 PUSHOFFSETCLOSURE0
- 1394 APPLY3
- 1395 PUSHACC1
- 1396 MAKEBLOCK2 0
- 1398 RETURN 4
- 1400 ACC2
- 1401 BRANCHIFNOT 1405
- 1403 BRANCH 1407
- 1405 RETURN 3
- 1407 GETGLOBAL "List.map2"
- 1409 PUSHGETGLOBALFIELD Pervasives, 2
- 1412 APPTERM1 4
- 1414 RESTART
- 1415 GRAB 2
- 1417 ACC1
- 1418 BRANCHIFNOT 1437
- 1420 ACC2
- 1421 BRANCHIFNOT 1444
- 1423 ACC2
- 1424 GETFIELD0
- 1425 PUSHACC2
- 1426 GETFIELD0
- 1427 PUSHACC2
- 1428 APPLY2
- 1429 ACC2
- 1430 GETFIELD1
- 1431 PUSHACC2
- 1432 GETFIELD1
- 1433 PUSHACC2
- 1434 PUSHOFFSETCLOSURE0
- 1435 APPTERM3 6
- 1437 ACC2
- 1438 BRANCHIFNOT 1442
- 1440 BRANCH 1444
- 1442 RETURN 3
- 1444 GETGLOBAL "List.iter2"
- 1446 PUSHGETGLOBALFIELD Pervasives, 2
- 1449 APPTERM1 4
- 1451 RESTART
- 1452 GRAB 3
- 1454 ACC2
- 1455 BRANCHIFNOT 1476
- 1457 ACC3
- 1458 BRANCHIFNOT 1482
- 1460 ACC3
- 1461 GETFIELD1
- 1462 PUSHACC3
- 1463 GETFIELD1
- 1464 PUSHACC5
- 1465 GETFIELD0
- 1466 PUSHACC5
- 1467 GETFIELD0
- 1468 PUSHACC5
- 1469 PUSHACC5
- 1470 APPLY3
- 1471 PUSHACC3
- 1472 PUSHOFFSETCLOSURE0
- 1473 APPTERM 4, 8
- 1476 ACC3
- 1477 BRANCHIF 1482
- 1479 ACC1
- 1480 RETURN 4
- 1482 GETGLOBAL "List.fold_left2"
- 1484 PUSHGETGLOBALFIELD Pervasives, 2
- 1487 APPTERM1 5
- 1489 RESTART
- 1490 GRAB 3
- 1492 ACC1
- 1493 BRANCHIFNOT 1516
- 1495 ACC2
- 1496 BRANCHIFNOT 1522
- 1498 PUSH_RETADDR 1509
- 1500 ACC6
- 1501 PUSHACC6
- 1502 GETFIELD1
- 1503 PUSHACC6
- 1504 GETFIELD1
- 1505 PUSHACC6
- 1506 PUSHOFFSETCLOSURE0
- 1507 APPLY 4
- 1509 PUSHACC3
- 1510 GETFIELD0
- 1511 PUSHACC3
- 1512 GETFIELD0
- 1513 PUSHACC3
- 1514 APPTERM3 7
- 1516 ACC2
- 1517 BRANCHIF 1522
- 1519 ACC3
- 1520 RETURN 4
- 1522 GETGLOBAL "List.fold_right2"
- 1524 PUSHGETGLOBALFIELD Pervasives, 2
- 1527 APPTERM1 5
- 1529 RESTART
- 1530 GRAB 1
- 1532 ACC1
- 1533 BRANCHIFNOT 1549
- 1535 ACC1
- 1536 GETFIELD0
- 1537 PUSHACC1
- 1538 APPLY1
- 1539 BRANCHIFNOT 1547
- 1541 ACC1
- 1542 GETFIELD1
- 1543 PUSHACC1
- 1544 PUSHOFFSETCLOSURE0
- 1545 APPTERM2 4
- 1547 RETURN 2
- 1549 CONST1
- 1550 RETURN 2
- 1552 RESTART
- 1553 GRAB 1
- 1555 ACC1
- 1556 BRANCHIFNOT 1570
- 1558 ACC1
- 1559 GETFIELD0
- 1560 PUSHACC1
- 1561 APPLY1
- 1562 BRANCHIF 1570
- 1564 ACC1
- 1565 GETFIELD1
- 1566 PUSHACC1
- 1567 PUSHOFFSETCLOSURE0
- 1568 APPTERM2 4
- 1570 RETURN 2
- 1572 RESTART
- 1573 GRAB 2
- 1575 ACC1
- 1576 BRANCHIFNOT 1599
- 1578 ACC2
- 1579 BRANCHIFNOT 1605
- 1581 ACC2
- 1582 GETFIELD0
- 1583 PUSHACC2
- 1584 GETFIELD0
- 1585 PUSHACC2
- 1586 APPLY2
- 1587 BRANCHIFNOT 1597
- 1589 ACC2
- 1590 GETFIELD1
- 1591 PUSHACC2
- 1592 GETFIELD1
- 1593 PUSHACC2
- 1594 PUSHOFFSETCLOSURE0
- 1595 APPTERM3 6
- 1597 RETURN 3
- 1599 ACC2
- 1600 BRANCHIF 1605
- 1602 CONST1
- 1603 RETURN 3
- 1605 GETGLOBAL "List.for_all2"
- 1607 PUSHGETGLOBALFIELD Pervasives, 2
- 1610 APPTERM1 4
- 1612 RESTART
- 1613 GRAB 2
- 1615 ACC1
- 1616 BRANCHIFNOT 1639
- 1618 ACC2
- 1619 BRANCHIFNOT 1646
- 1621 ACC2
- 1622 GETFIELD0
- 1623 PUSHACC2
- 1624 GETFIELD0
- 1625 PUSHACC2
- 1626 APPLY2
- 1627 BRANCHIF 1637
- 1629 ACC2
- 1630 GETFIELD1
- 1631 PUSHACC2
- 1632 GETFIELD1
- 1633 PUSHACC2
- 1634 PUSHOFFSETCLOSURE0
- 1635 APPTERM3 6
- 1637 RETURN 3
- 1639 ACC2
- 1640 BRANCHIFNOT 1644
- 1642 BRANCH 1646
- 1644 RETURN 3
- 1646 GETGLOBAL "List.exists2"
- 1648 PUSHGETGLOBALFIELD Pervasives, 2
- 1651 APPTERM1 4
- 1653 RESTART
- 1654 GRAB 1
- 1656 ACC1
- 1657 BRANCHIFNOT 1672
- 1659 ACC0
- 1660 PUSHACC2
- 1661 GETFIELD0
- 1662 C_CALL2 equal
- 1664 BRANCHIF 1672
- 1666 ACC1
- 1667 GETFIELD1
- 1668 PUSHACC1
- 1669 PUSHOFFSETCLOSURE0
- 1670 APPTERM2 4
- 1672 RETURN 2
- 1674 RESTART
- 1675 GRAB 1
- 1677 ACC1
- 1678 BRANCHIFNOT 1692
- 1680 ACC0
- 1681 PUSHACC2
- 1682 GETFIELD0
- 1683 EQ
- 1684 BRANCHIF 1692
- 1686 ACC1
- 1687 GETFIELD1
- 1688 PUSHACC1
- 1689 PUSHOFFSETCLOSURE0
- 1690 APPTERM2 4
- 1692 RETURN 2
- 1694 RESTART
- 1695 GRAB 1
- 1697 ACC1
- 1698 BRANCHIFNOT 1719
- 1700 ACC1
- 1701 GETFIELD0
- 1702 PUSHACC1
- 1703 PUSHACC1
- 1704 GETFIELD0
- 1705 C_CALL2 equal
- 1707 BRANCHIFNOT 1713
- 1709 ACC0
- 1710 GETFIELD1
- 1711 RETURN 3
- 1713 ACC2
- 1714 GETFIELD1
- 1715 PUSHACC2
- 1716 PUSHOFFSETCLOSURE0
- 1717 APPTERM2 5
- 1719 GETGLOBAL Not_found
- 1721 MAKEBLOCK1 0
- 1723 RAISE
- 1724 RESTART
- 1725 GRAB 1
- 1727 ACC1
- 1728 BRANCHIFNOT 1748
- 1730 ACC1
- 1731 GETFIELD0
- 1732 PUSHACC1
- 1733 PUSHACC1
- 1734 GETFIELD0
- 1735 EQ
- 1736 BRANCHIFNOT 1742
- 1738 ACC0
- 1739 GETFIELD1
- 1740 RETURN 3
- 1742 ACC2
- 1743 GETFIELD1
- 1744 PUSHACC2
- 1745 PUSHOFFSETCLOSURE0
- 1746 APPTERM2 5
- 1748 GETGLOBAL Not_found
- 1750 MAKEBLOCK1 0
- 1752 RAISE
- 1753 RESTART
- 1754 GRAB 1
- 1756 ACC1
- 1757 BRANCHIFNOT 1773
- 1759 ACC0
- 1760 PUSHACC2
- 1761 GETFIELD0
- 1762 GETFIELD0
- 1763 C_CALL2 equal
- 1765 BRANCHIF 1773
- 1767 ACC1
- 1768 GETFIELD1
- 1769 PUSHACC1
- 1770 PUSHOFFSETCLOSURE0
- 1771 APPTERM2 4
- 1773 RETURN 2
- 1775 RESTART
- 1776 GRAB 1
- 1778 ACC1
- 1779 BRANCHIFNOT 1794
- 1781 ACC0
- 1782 PUSHACC2
- 1783 GETFIELD0
- 1784 GETFIELD0
- 1785 EQ
- 1786 BRANCHIF 1794
- 1788 ACC1
- 1789 GETFIELD1
- 1790 PUSHACC1
- 1791 PUSHOFFSETCLOSURE0
- 1792 APPTERM2 4
- 1794 RETURN 2
- 1796 RESTART
- 1797 GRAB 1
- 1799 ACC1
- 1800 BRANCHIFNOT 1825
- 1802 ACC1
- 1803 GETFIELD0
- 1804 PUSHACC2
- 1805 GETFIELD1
- 1806 PUSHACC2
- 1807 PUSHACC2
- 1808 GETFIELD0
- 1809 C_CALL2 equal
- 1811 BRANCHIFNOT 1816
- 1813 ACC0
- 1814 RETURN 4
- 1816 ACC0
- 1817 PUSHACC3
- 1818 PUSHOFFSETCLOSURE0
- 1819 APPLY2
- 1820 PUSHACC2
- 1821 MAKEBLOCK2 0
- 1823 POP 2
- 1825 RETURN 2
- 1827 RESTART
- 1828 GRAB 1
- 1830 ACC1
- 1831 BRANCHIFNOT 1855
- 1833 ACC1
- 1834 GETFIELD0
- 1835 PUSHACC2
- 1836 GETFIELD1
- 1837 PUSHACC2
- 1838 PUSHACC2
- 1839 GETFIELD0
- 1840 EQ
- 1841 BRANCHIFNOT 1846
- 1843 ACC0
- 1844 RETURN 4
- 1846 ACC0
- 1847 PUSHACC3
- 1848 PUSHOFFSETCLOSURE0
- 1849 APPLY2
- 1850 PUSHACC2
- 1851 MAKEBLOCK2 0
- 1853 POP 2
- 1855 RETURN 2
- 1857 RESTART
- 1858 GRAB 1
- 1860 ACC1
- 1861 BRANCHIFNOT 1879
- 1863 ACC1
- 1864 GETFIELD0
- 1865 PUSHACC0
- 1866 PUSHACC2
- 1867 APPLY1
- 1868 BRANCHIFNOT 1873
- 1870 ACC0
- 1871 RETURN 3
- 1873 ACC2
- 1874 GETFIELD1
- 1875 PUSHACC2
- 1876 PUSHOFFSETCLOSURE0
- 1877 APPTERM2 5
- 1879 GETGLOBAL Not_found
- 1881 MAKEBLOCK1 0
- 1883 RAISE
- 1884 RESTART
- 1885 GRAB 2
- 1887 ACC2
- 1888 BRANCHIFNOT 1917
- 1890 ACC2
- 1891 GETFIELD0
- 1892 PUSHACC3
- 1893 GETFIELD1
- 1894 PUSHACC1
- 1895 PUSHENVACC2
- 1896 APPLY1
- 1897 BRANCHIFNOT 1908
- 1899 ACC0
- 1900 PUSHACC4
- 1901 PUSHACC4
- 1902 PUSHACC4
- 1903 MAKEBLOCK2 0
- 1905 PUSHOFFSETCLOSURE0
- 1906 APPTERM3 8
- 1908 ACC0
- 1909 PUSHACC4
- 1910 PUSHACC3
- 1911 MAKEBLOCK2 0
- 1913 PUSHACC4
- 1914 PUSHOFFSETCLOSURE0
- 1915 APPTERM3 8
- 1917 ACC1
- 1918 PUSHENVACC1
- 1919 APPLY1
- 1920 PUSHACC1
- 1921 PUSHENVACC1
- 1922 APPLY1
- 1923 MAKEBLOCK2 0
- 1925 RETURN 3
- 1927 RESTART
- 1928 GRAB 1
- 1930 ACC0
- 1931 PUSHENVACC1
- 1932 CLOSUREREC 2, 1885
- 1936 ACC2
- 1937 PUSHCONST0
- 1938 PUSHCONST0
- 1939 PUSHACC3
- 1940 APPTERM3 6
- 1942 ACC0
- 1943 BRANCHIFNOT 1967
- 1945 ACC0
- 1946 GETFIELD0
- 1947 PUSHACC1
- 1948 GETFIELD1
- 1949 PUSHOFFSETCLOSURE0
- 1950 APPLY1
- 1951 PUSHACC0
- 1952 GETFIELD1
- 1953 PUSHACC2
- 1954 GETFIELD1
- 1955 MAKEBLOCK2 0
- 1957 PUSHACC1
- 1958 GETFIELD0
- 1959 PUSHACC3
- 1960 GETFIELD0
- 1961 MAKEBLOCK2 0
- 1963 MAKEBLOCK2 0
- 1965 RETURN 3
- 1967 GETGLOBAL <0>(0, 0)
- 1969 RETURN 1
- 1971 RESTART
- 1972 GRAB 1
- 1974 ACC0
- 1975 BRANCHIFNOT 1996
- 1977 ACC1
- 1978 BRANCHIFNOT 2003
- 1980 ACC1
- 1981 GETFIELD1
- 1982 PUSHACC1
- 1983 GETFIELD1
- 1984 PUSHOFFSETCLOSURE0
- 1985 APPLY2
- 1986 PUSHACC2
- 1987 GETFIELD0
- 1988 PUSHACC2
- 1989 GETFIELD0
- 1990 MAKEBLOCK2 0
- 1992 MAKEBLOCK2 0
- 1994 RETURN 2
- 1996 ACC1
- 1997 BRANCHIFNOT 2001
- 1999 BRANCH 2003
- 2001 RETURN 2
- 2003 GETGLOBAL "List.combine"
- 2005 PUSHGETGLOBALFIELD Pervasives, 2
- 2008 APPTERM1 3
- 2010 RESTART
- 2011 GRAB 1
- 2013 ACC1
- 2014 BRANCHIFNOT 2038
- 2016 ACC1
- 2017 GETFIELD0
- 2018 PUSHACC2
- 2019 GETFIELD1
- 2020 PUSHACC1
- 2021 PUSHENVACC2
- 2022 APPLY1
- 2023 BRANCHIFNOT 2033
- 2025 ACC0
- 2026 PUSHACC3
- 2027 PUSHACC3
- 2028 MAKEBLOCK2 0
- 2030 PUSHOFFSETCLOSURE0
- 2031 APPTERM2 6
- 2033 ACC0
- 2034 PUSHACC3
- 2035 PUSHOFFSETCLOSURE0
- 2036 APPTERM2 6
- 2038 ACC0
- 2039 PUSHENVACC1
- 2040 APPTERM1 3
- 2042 ACC0
- 2043 PUSHENVACC1
- 2044 CLOSUREREC 2, 2011
- 2048 CONST0
- 2049 PUSHACC1
- 2050 APPTERM1 3
- 2052 RESTART
- 2053 GRAB 2
- 2055 ACC1
- 2056 BRANCHIFNOT 2077
- 2058 ACC2
- 2059 BRANCHIFNOT 2084
- 2061 ACC2
- 2062 GETFIELD1
- 2063 PUSHACC2
- 2064 GETFIELD1
- 2065 PUSHACC2
- 2066 PUSHACC5
- 2067 GETFIELD0
- 2068 PUSHACC5
- 2069 GETFIELD0
- 2070 PUSHENVACC1
- 2071 APPLY2
- 2072 MAKEBLOCK2 0
- 2074 PUSHOFFSETCLOSURE0
- 2075 APPTERM3 6
- 2077 ACC2
- 2078 BRANCHIFNOT 2082
- 2080 BRANCH 2084
- 2082 RETURN 3
- 2084 GETGLOBAL "List.rev_map2"
- 2086 PUSHGETGLOBALFIELD Pervasives, 2
- 2089 APPTERM1 4
- 2091 RESTART
- 2092 GRAB 2
- 2094 ACC0
- 2095 CLOSUREREC 1, 2053
- 2099 ACC3
- 2100 PUSHACC3
- 2101 PUSHCONST0
- 2102 PUSHACC3
- 2103 APPTERM3 7
- 2105 RESTART
- 2106 GRAB 1
- 2108 ACC1
- 2109 BRANCHIFNOT 2123
- 2111 ACC1
- 2112 GETFIELD1
- 2113 PUSHACC1
- 2114 PUSHACC3
- 2115 GETFIELD0
- 2116 PUSHENVACC1
- 2117 APPLY1
- 2118 MAKEBLOCK2 0
- 2120 PUSHOFFSETCLOSURE0
- 2121 APPTERM2 4
- 2123 ACC0
- 2124 RETURN 2
- 2126 RESTART
- 2127 GRAB 1
- 2129 ACC0
- 2130 CLOSUREREC 1, 2106
- 2134 ACC2
- 2135 PUSHCONST0
- 2136 PUSHACC2
- 2137 APPTERM2 5
- 2139 CONST0
- 2140 PUSHACC1
- 2141 PUSHENVACC1
- 2142 APPTERM2 3
- 2144 ACC0
- 2145 BRANCHIFNOT 2151
- 2147 ACC0
- 2148 GETFIELD1
- 2149 RETURN 1
- 2151 GETGLOBAL "tl"
- 2153 PUSHGETGLOBALFIELD Pervasives, 3
- 2156 APPTERM1 2
- 2158 ACC0
- 2159 BRANCHIFNOT 2165
- 2161 ACC0
- 2162 GETFIELD0
- 2163 RETURN 1
- 2165 GETGLOBAL "hd"
- 2167 PUSHGETGLOBALFIELD Pervasives, 3
- 2170 APPTERM1 2
- 2172 ACC0
- 2173 PUSHCONST0
- 2174 PUSHENVACC1
- 2175 APPTERM2 3
- 2177 CLOSUREREC 0, 1200
- 2181 ACC0
- 2182 CLOSURE 1, 2172
- 2185 PUSH
- 2186 CLOSURE 0, 2158
- 2189 PUSH
- 2190 CLOSURE 0, 2144
- 2193 PUSH
- 2194 CLOSUREREC 0, 1217
- 2198 GETGLOBALFIELD Pervasives, 16
- 2201 PUSH
- 2202 CLOSUREREC 0, 1259
- 2206 ACC0
- 2207 CLOSURE 1, 2139
- 2210 PUSH
- 2211 CLOSUREREC 0, 1277
- 2215 CLOSUREREC 0, 1294
- 2219 CLOSURE 0, 2127
- 2222 PUSH
- 2223 CLOSUREREC 0, 1316
- 2227 CLOSUREREC 0, 1334
- 2231 CLOSUREREC 0, 1354
- 2235 CLOSUREREC 0, 1374
- 2239 CLOSURE 0, 2092
- 2242 PUSH
- 2243 CLOSUREREC 0, 1415
- 2247 CLOSUREREC 0, 1452
- 2251 CLOSUREREC 0, 1490
- 2255 CLOSUREREC 0, 1530
- 2259 CLOSUREREC 0, 1553
- 2263 CLOSUREREC 0, 1573
- 2267 CLOSUREREC 0, 1613
- 2271 CLOSUREREC 0, 1654
- 2275 CLOSUREREC 0, 1675
- 2279 CLOSUREREC 0, 1695
- 2283 CLOSUREREC 0, 1725
- 2287 CLOSUREREC 0, 1754
- 2291 CLOSUREREC 0, 1776
- 2295 CLOSUREREC 0, 1797
- 2299 CLOSUREREC 0, 1828
- 2303 CLOSUREREC 0, 1858
- 2307 ACC 24
- 2309 CLOSURE 1, 2042
- 2312 PUSHACC 25
- 2314 CLOSUREREC 1, 1928
- 2318 CLOSUREREC 0, 1942
- 2322 CLOSUREREC 0, 1972
- 2326 ACC0
- 2327 PUSHACC2
- 2328 PUSHACC7
- 2329 PUSHACC 9
- 2331 PUSHACC 11
- 2333 PUSHACC 13
- 2335 PUSHACC 15
- 2337 PUSHACC 17
- 2339 PUSHACC 10
- 2341 PUSHACC 12
- 2343 PUSHACC 13
- 2345 PUSHACC 15
- 2347 PUSHACC 23
- 2349 PUSHACC 25
- 2351 PUSHACC 27
- 2353 PUSHACC 29
- 2355 PUSHACC 31
- 2357 PUSHACC 33
- 2359 PUSHACC 35
- 2361 PUSHACC 37
- 2363 PUSHACC 40
- 2365 PUSHACC 42
- 2367 PUSHACC 41
- 2369 PUSHACC 45
- 2371 PUSHACC 47
- 2373 PUSHACC 50
- 2375 PUSHACC 52
- 2377 PUSHACC 51
- 2379 PUSHACC 55
- 2381 PUSHACC 56
- 2383 PUSHACC 59
- 2385 PUSHACC 61
- 2387 PUSHACC 60
- 2389 PUSHACC 64
- 2391 PUSHACC 66
- 2393 PUSHACC 68
- 2395 PUSHACC 70
- 2397 MAKEBLOCK 37, 0
- 2400 POP 36
- 2402 SETGLOBAL List
- 2404 BRANCH 2622
- 2406 CONSTINT 97
- 2408 PUSHACC1
- 2409 GEINT
- 2410 BRANCHIFNOT 2418
- 2412 CONSTINT 122
- 2414 PUSHACC1
- 2415 LEINT
- 2416 BRANCHIF 2442
- 2418 CONSTINT 224
- 2420 PUSHACC1
- 2421 GEINT
- 2422 BRANCHIFNOT 2430
- 2424 CONSTINT 246
- 2426 PUSHACC1
- 2427 LEINT
- 2428 BRANCHIF 2442
- 2430 CONSTINT 248
- 2432 PUSHACC1
- 2433 GEINT
- 2434 BRANCHIFNOT 2447
- 2436 CONSTINT 254
- 2438 PUSHACC1
- 2439 LEINT
- 2440 BRANCHIFNOT 2447
- 2442 ACC0
- 2443 OFFSETINT -32
- 2445 RETURN 1
- 2447 ACC0
- 2448 RETURN 1
- 2450 CONSTINT 65
- 2452 PUSHACC1
- 2453 GEINT
- 2454 BRANCHIFNOT 2462
- 2456 CONSTINT 90
- 2458 PUSHACC1
- 2459 LEINT
- 2460 BRANCHIF 2486
- 2462 CONSTINT 192
- 2464 PUSHACC1
- 2465 GEINT
- 2466 BRANCHIFNOT 2474
- 2468 CONSTINT 214
- 2470 PUSHACC1
- 2471 LEINT
- 2472 BRANCHIF 2486
- 2474 CONSTINT 216
- 2476 PUSHACC1
- 2477 GEINT
- 2478 BRANCHIFNOT 2491
- 2480 CONSTINT 222
- 2482 PUSHACC1
- 2483 LEINT
- 2484 BRANCHIFNOT 2491
- 2486 ACC0
- 2487 OFFSETINT 32
- 2489 RETURN 1
- 2491 ACC0
- 2492 RETURN 1
- 2494 CONSTINT 39
- 2496 PUSHACC1
- 2497 LTINT
- 2498 BRANCHIFNOT 2520
- 2500 CONSTINT 9
- 2502 PUSHACC1
- 2503 EQ
- 2504 BRANCHIFNOT 2510
- 2506 GETGLOBAL "\\t"
- 2508 RETURN 1
- 2510 CONSTINT 13
- 2512 PUSHACC1
- 2513 EQ
- 2514 BRANCHIFNOT 2540
- 2516 GETGLOBAL "\\n"
- 2518 RETURN 1
- 2520 CONSTINT 39
- 2522 PUSHACC1
- 2523 EQ
- 2524 BRANCHIFNOT 2530
- 2526 GETGLOBAL "\\'"
- 2528 RETURN 1
- 2530 CONSTINT 92
- 2532 PUSHACC1
- 2533 EQ
- 2534 BRANCHIFNOT 2540
- 2536 GETGLOBAL "\\\\"
- 2538 RETURN 1
- 2540 ACC0
- 2541 C_CALL1 is_printable
- 2543 BRANCHIFNOT 2555
- 2545 CONST1
- 2546 C_CALL1 create_string
- 2548 PUSHACC1
- 2549 PUSHCONST0
- 2550 PUSHACC2
- 2551 SETSTRINGCHAR
- 2552 ACC0
- 2553 RETURN 2
- 2555 ACC0
- 2556 PUSHCONSTINT 4
- 2558 C_CALL1 create_string
- 2560 PUSHCONSTINT 92
- 2562 PUSHCONST0
- 2563 PUSHACC2
- 2564 SETSTRINGCHAR
- 2565 CONSTINT 100
- 2567 PUSHACC2
- 2568 DIVINT
- 2569 PUSHCONSTINT 48
- 2571 ADDINT
- 2572 PUSHCONST1
- 2573 PUSHACC2
- 2574 SETSTRINGCHAR
- 2575 CONSTINT 10
- 2577 PUSHCONSTINT 10
- 2579 PUSHACC3
- 2580 DIVINT
- 2581 MODINT
- 2582 PUSHCONSTINT 48
- 2584 ADDINT
- 2585 PUSHCONST2
- 2586 PUSHACC2
- 2587 SETSTRINGCHAR
- 2588 CONSTINT 10
- 2590 PUSHACC2
- 2591 MODINT
- 2592 PUSHCONSTINT 48
- 2594 ADDINT
- 2595 PUSHCONST3
- 2596 PUSHACC2
- 2597 SETSTRINGCHAR
- 2598 ACC0
- 2599 RETURN 3
- 2601 CONST0
- 2602 PUSHACC1
- 2603 LTINT
- 2604 BRANCHIF 2612
- 2606 CONSTINT 255
- 2608 PUSHACC1
- 2609 GTINT
- 2610 BRANCHIFNOT 2619
- 2612 GETGLOBAL "Char.chr"
- 2614 PUSHGETGLOBALFIELD Pervasives, 2
- 2617 APPTERM1 2
- 2619 ACC0
- 2620 RETURN 1
- 2622 CLOSURE 0, 2601
- 2625 PUSH
- 2626 CLOSURE 0, 2494
- 2629 PUSH
- 2630 CLOSURE 0, 2450
- 2633 PUSH
- 2634 CLOSURE 0, 2406
- 2637 PUSHACC0
- 2638 PUSHACC2
- 2639 PUSHACC4
- 2640 PUSHACC6
- 2641 MAKEBLOCK 4, 0
- 2644 POP 4
- 2646 SETGLOBAL Char
- 2648 BRANCH 3540
- 2650 RESTART
- 2651 GRAB 3
- 2653 ACC1
- 2654 PUSHACC3
- 2655 GEINT
- 2656 BRANCHIFNOT 2663
- 2658 GETGLOBAL Not_found
- 2660 MAKEBLOCK1 0
- 2662 RAISE
- 2663 ACC3
- 2664 PUSHACC3
- 2665 PUSHACC2
- 2666 GETSTRINGCHAR
- 2667 EQ
- 2668 BRANCHIFNOT 2673
- 2670 ACC2
- 2671 RETURN 4
- 2673 ACC3
- 2674 PUSHACC3
- 2675 OFFSETINT 1
- 2677 PUSHACC3
- 2678 PUSHACC3
- 2679 PUSHOFFSETCLOSURE0
- 2680 APPTERM 4, 8
- 2683 RESTART
- 2684 GRAB 2
- 2686 CONST0
- 2687 PUSHACC2
- 2688 LTINT
- 2689 BRANCHIFNOT 2696
- 2691 GETGLOBAL Not_found
- 2693 MAKEBLOCK1 0
- 2695 RAISE
- 2696 ACC2
- 2697 PUSHACC2
- 2698 PUSHACC2
- 2699 GETSTRINGCHAR
- 2700 EQ
- 2701 BRANCHIFNOT 2706
- 2703 ACC1
- 2704 RETURN 3
- 2706 ACC2
- 2707 PUSHACC2
- 2708 OFFSETINT -1
- 2710 PUSHACC2
- 2711 PUSHOFFSETCLOSURE0
- 2712 APPTERM3 6
- 2714 RESTART
- 2715 GRAB 1
- 2717 ACC1
- 2718 PUSHCONST0
- 2719 PUSHACC2
- 2720 PUSHENVACC1
- 2721 APPTERM3 5
- 2723 RESTART
- 2724 GRAB 2
- 2726 CONST0
- 2727 PUSHACC2
- 2728 LTINT
- 2729 BRANCHIF 2738
- 2731 ACC0
- 2732 C_CALL1 ml_string_length
- 2734 PUSHACC2
- 2735 GEINT
- 2736 BRANCHIFNOT 2745
- 2738 GETGLOBAL "String.rcontains_from"
- 2740 PUSHGETGLOBALFIELD Pervasives, 2
- 2743 APPTERM1 4
- 2745 PUSHTRAP 2756
- 2747 ACC6
- 2748 PUSHACC6
- 2749 PUSHACC6
- 2750 PUSHENVACC1
- 2751 APPLY3
- 2752 CONST1
- 2753 POPTRAP
- 2754 RETURN 3
- 2756 PUSHGETGLOBAL Not_found
- 2758 PUSHACC1
- 2759 GETFIELD0
- 2760 EQ
- 2761 BRANCHIFNOT 2766
- 2763 CONST0
- 2764 RETURN 4
- 2766 ACC0
- 2767 RAISE
- 2768 RESTART
- 2769 GRAB 2
- 2771 CONST0
- 2772 PUSHACC2
- 2773 LTINT
- 2774 BRANCHIF 2783
- 2776 ACC0
- 2777 C_CALL1 ml_string_length
- 2779 PUSHACC2
- 2780 GTINT
- 2781 BRANCHIFNOT 2790
- 2783 GETGLOBAL "String.contains_from"
- 2785 PUSHGETGLOBALFIELD Pervasives, 2
- 2788 APPTERM1 4
- 2790 PUSHTRAP 2811
- 2792 PUSH_RETADDR 2807
- 2794 ACC 9
- 2796 PUSHACC 9
- 2798 PUSHACC 9
- 2800 C_CALL1 ml_string_length
- 2802 PUSHACC 10
- 2804 PUSHENVACC1
- 2805 APPLY 4
- 2807 CONST1
- 2808 POPTRAP
- 2809 RETURN 3
- 2811 PUSHGETGLOBAL Not_found
- 2813 PUSHACC1
- 2814 GETFIELD0
- 2815 EQ
- 2816 BRANCHIFNOT 2821
- 2818 CONST0
- 2819 RETURN 4
- 2821 ACC0
- 2822 RAISE
- 2823 RESTART
- 2824 GRAB 2
- 2826 CONST0
- 2827 PUSHACC2
- 2828 LTINT
- 2829 BRANCHIF 2838
- 2831 ACC0
- 2832 C_CALL1 ml_string_length
- 2834 PUSHACC2
- 2835 GEINT
- 2836 BRANCHIFNOT 2845
- 2838 GETGLOBAL "String.rindex_from"
- 2840 PUSHGETGLOBALFIELD Pervasives, 2
- 2843 APPTERM1 4
- 2845 ACC2
- 2846 PUSHACC2
- 2847 PUSHACC2
- 2848 PUSHENVACC1
- 2849 APPTERM3 6
- 2851 RESTART
- 2852 GRAB 1
- 2854 ACC1
- 2855 PUSHACC1
- 2856 C_CALL1 ml_string_length
- 2858 OFFSETINT -1
- 2860 PUSHACC2
- 2861 PUSHENVACC1
- 2862 APPTERM3 5
- 2864 RESTART
- 2865 GRAB 2
- 2867 CONST0
- 2868 PUSHACC2
- 2869 LTINT
- 2870 BRANCHIF 2879
- 2872 ACC0
- 2873 C_CALL1 ml_string_length
- 2875 PUSHACC2
- 2876 GTINT
- 2877 BRANCHIFNOT 2886
- 2879 GETGLOBAL "String.index_from"
- 2881 PUSHGETGLOBALFIELD Pervasives, 2
- 2884 APPTERM1 4
- 2886 ACC2
- 2887 PUSHACC2
- 2888 PUSHACC2
- 2889 C_CALL1 ml_string_length
- 2891 PUSHACC3
- 2892 PUSHENVACC1
- 2893 APPTERM 4, 7
- 2896 RESTART
- 2897 GRAB 1
- 2899 ACC1
- 2900 PUSHCONST0
- 2901 PUSHACC2
- 2902 C_CALL1 ml_string_length
- 2904 PUSHACC3
- 2905 PUSHENVACC1
- 2906 APPTERM 4, 6
- 2909 ACC0
- 2910 PUSHGETGLOBALFIELD Char, 2
- 2913 PUSHENVACC1
- 2914 APPTERM2 3
- 2916 ACC0
- 2917 PUSHGETGLOBALFIELD Char, 3
- 2920 PUSHENVACC1
- 2921 APPTERM2 3
- 2923 RESTART
- 2924 GRAB 1
- 2926 CONST0
- 2927 PUSHACC2
- 2928 C_CALL1 ml_string_length
- 2930 EQ
- 2931 BRANCHIFNOT 2936
- 2933 ACC1
- 2934 RETURN 2
- 2936 ACC1
- 2937 PUSHENVACC1
- 2938 APPLY1
- 2939 PUSHCONST0
- 2940 PUSHACC3
- 2941 GETSTRINGCHAR
- 2942 PUSHACC2
- 2943 APPLY1
- 2944 PUSHCONST0
- 2945 PUSHACC2
- 2946 SETSTRINGCHAR
- 2947 ACC0
- 2948 RETURN 3
- 2950 ACC0
- 2951 PUSHGETGLOBALFIELD Char, 2
- 2954 PUSHENVACC1
- 2955 APPTERM2 3
- 2957 ACC0
- 2958 PUSHGETGLOBALFIELD Char, 3
- 2961 PUSHENVACC1
- 2962 APPTERM2 3
- 2964 RESTART
- 2965 GRAB 1
- 2967 ACC1
- 2968 C_CALL1 ml_string_length
- 2970 PUSHCONST0
- 2971 PUSHACC1
- 2972 EQ
- 2973 BRANCHIFNOT 2978
- 2975 ACC2
- 2976 RETURN 3
- 2978 ACC0
- 2979 C_CALL1 create_string
- 2981 PUSHCONST0
- 2982 PUSHACC2
- 2983 OFFSETINT -1
- 2985 PUSH
- 2986 BRANCH 3002
- 2988 CHECK_SIGNALS
- 2989 ACC1
- 2990 PUSHACC6
- 2991 GETSTRINGCHAR
- 2992 PUSHACC5
- 2993 APPLY1
- 2994 PUSHACC2
- 2995 PUSHACC4
- 2996 SETSTRINGCHAR
- 2997 ACC1
- 2998 OFFSETINT 1
- 3000 ASSIGN 1
- 3002 ACC0
- 3003 PUSHACC2
- 3004 LEINT
- 3005 BRANCHIF 2988
- 3007 CONST0
- 3008 POP 2
- 3010 ACC0
- 3011 RETURN 4
- 3013 CONST0
- 3014 PUSHCONST0
- 3015 PUSHACC2
- 3016 C_CALL1 ml_string_length
- 3018 OFFSETINT -1
- 3020 PUSH
- 3021 BRANCH 3059
- 3023 CHECK_SIGNALS
- 3024 ACC1
- 3025 PUSHACC4
- 3026 GETSTRINGCHAR
- 3027 PUSHACC0
- 3028 PUSHGETGLOBAL "\000\"\000\000\004\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000"
- 3030 C_CALL2 bitvect_test
- 3032 BRANCHIFNOT 3038
- 3034 CONST0
- 3035 CONST2
- 3036 BRANCH 3048
- 3038 ACC0
- 3039 C_CALL1 is_printable
- 3041 BRANCHIFNOT 3046
- 3043 CONST1
- 3044 BRANCH 3048
- 3046 CONSTINT 4
- 3048 POP 1
- 3050 PUSHACC3
- 3051 ADDINT
- 3052 ASSIGN 2
- 3054 ACC1
- 3055 OFFSETINT 1
- 3057 ASSIGN 1
- 3059 ACC0
- 3060 PUSHACC2
- 3061 LEINT
- 3062 BRANCHIF 3023
- 3064 CONST0
- 3065 POP 2
- 3067 ACC1
- 3068 C_CALL1 ml_string_length
- 3070 PUSHACC1
- 3071 EQ
- 3072 BRANCHIFNOT 3077
- 3074 ACC1
- 3075 RETURN 2
- 3077 ACC0
- 3078 C_CALL1 create_string
- 3080 PUSHCONST0
- 3081 ASSIGN 1
- 3083 CONST0
- 3084 PUSHACC3
- 3085 C_CALL1 ml_string_length
- 3087 OFFSETINT -1
- 3089 PUSH
- 3090 BRANCH 3245
- 3092 CHECK_SIGNALS
- 3093 ACC1
- 3094 PUSHACC5
- 3095 GETSTRINGCHAR
- 3096 PUSHACC0
- 3097 PUSHGETGLOBAL "\000\000\000\000\004\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000"
- 3099 C_CALL2 bitvect_test
- 3101 BRANCHIFNOT 3120
- 3103 CONST0
- 3104 CONSTINT 92
- 3106 PUSHACC5
- 3107 PUSHACC5
- 3108 SETSTRINGCHAR
- 3109 ACC4
- 3110 OFFSETINT 1
- 3112 ASSIGN 4
- 3114 ACC0
- 3115 PUSHACC5
- 3116 PUSHACC5
- 3117 SETSTRINGCHAR
- 3118 BRANCH 3233
- 3120 CONSTINT 9
- 3122 PUSHACC1
- 3123 EQ
- 3124 BRANCHIFNOT 3143
- 3126 CONSTINT 92
- 3128 PUSHACC5
- 3129 PUSHACC5
- 3130 SETSTRINGCHAR
- 3131 ACC4
- 3132 OFFSETINT 1
- 3134 ASSIGN 4
- 3136 CONSTINT 116
- 3138 PUSHACC5
- 3139 PUSHACC5
- 3140 SETSTRINGCHAR
- 3141 BRANCH 3233
- 3143 CONSTINT 13
- 3145 PUSHACC1
- 3146 EQ
- 3147 BRANCHIFNOT 3166
- 3149 CONSTINT 92
- 3151 PUSHACC5
- 3152 PUSHACC5
- 3153 SETSTRINGCHAR
- 3154 ACC4
- 3155 OFFSETINT 1
- 3157 ASSIGN 4
- 3159 CONSTINT 110
- 3161 PUSHACC5
- 3162 PUSHACC5
- 3163 SETSTRINGCHAR
- 3164 BRANCH 3233
- 3166 ACC0
- 3167 C_CALL1 is_printable
- 3169 BRANCHIFNOT 3177
- 3171 ACC0
- 3172 PUSHACC5
- 3173 PUSHACC5
- 3174 SETSTRINGCHAR
- 3175 BRANCH 3233
- 3177 ACC0
- 3178 PUSHCONSTINT 92
- 3180 PUSHACC6
- 3181 PUSHACC6
- 3182 SETSTRINGCHAR
- 3183 ACC5
- 3184 OFFSETINT 1
- 3186 ASSIGN 5
- 3188 CONSTINT 100
- 3190 PUSHACC1
- 3191 DIVINT
- 3192 PUSHCONSTINT 48
- 3194 ADDINT
- 3195 PUSHACC6
- 3196 PUSHACC6
- 3197 SETSTRINGCHAR
- 3198 ACC5
- 3199 OFFSETINT 1
- 3201 ASSIGN 5
- 3203 CONSTINT 10
- 3205 PUSHCONSTINT 10
- 3207 PUSHACC2
- 3208 DIVINT
- 3209 MODINT
- 3210 PUSHCONSTINT 48
- 3212 ADDINT
- 3213 PUSHACC6
- 3214 PUSHACC6
- 3215 SETSTRINGCHAR
- 3216 ACC5
- 3217 OFFSETINT 1
- 3219 ASSIGN 5
- 3221 CONSTINT 10
- 3223 PUSHACC1
- 3224 MODINT
- 3225 PUSHCONSTINT 48
- 3227 ADDINT
- 3228 PUSHACC6
- 3229 PUSHACC6
- 3230 SETSTRINGCHAR
- 3231 POP 1
- 3233 POP 1
- 3235 ACC3
- 3236 OFFSETINT 1
- 3238 ASSIGN 3
- 3240 ACC1
- 3241 OFFSETINT 1
- 3243 ASSIGN 1
- 3245 ACC0
- 3246 PUSHACC2
- 3247 LEINT
- 3248 BRANCHIF 3092
- 3250 CONST0
- 3251 POP 2
- 3253 ACC0
- 3254 RETURN 3
- 3256 ENVACC1
- 3257 C_CALL1 ml_string_length
- 3259 PUSHENVACC3
- 3260 GETFIELD0
- 3261 PUSHENVACC2
- 3262 PUSHCONST0
- 3263 PUSHENVACC1
- 3264 C_CALL5 blit_string
- 3266 ENVACC1
- 3267 C_CALL1 ml_string_length
- 3269 PUSHENVACC3
- 3270 GETFIELD0
- 3271 ADDINT
- 3272 PUSHENVACC3
- 3273 SETFIELD0
- 3274 ACC0
- 3275 C_CALL1 ml_string_length
- 3277 PUSHENVACC3
- 3278 GETFIELD0
- 3279 PUSHENVACC2
- 3280 PUSHCONST0
- 3281 PUSHACC4
- 3282 C_CALL5 blit_string
- 3284 ACC0
- 3285 C_CALL1 ml_string_length
- 3287 PUSHENVACC3
- 3288 GETFIELD0
- 3289 ADDINT
- 3290 PUSHENVACC3
- 3291 SETFIELD0
- 3292 RETURN 1
- 3294 ENVACC1
- 3295 OFFSETREF 1
- 3297 ACC0
- 3298 C_CALL1 ml_string_length
- 3300 PUSHENVACC2
- 3301 GETFIELD0
- 3302 ADDINT
- 3303 PUSHENVACC2
- 3304 SETFIELD0
- 3305 RETURN 1
- 3307 RESTART
- 3308 GRAB 1
- 3310 ACC1
- 3311 BRANCHIFNOT 3374
- 3313 ACC1
- 3314 GETFIELD0
- 3315 PUSHCONST0
- 3316 MAKEBLOCK1 0
- 3318 PUSHCONST0
- 3319 MAKEBLOCK1 0
- 3321 PUSHACC4
- 3322 PUSHACC1
- 3323 PUSHACC3
- 3324 CLOSURE 2, 3294
- 3327 PUSHGETGLOBALFIELD List, 9
- 3330 APPLY2
- 3331 ACC1
- 3332 GETFIELD0
- 3333 OFFSETINT -1
- 3335 PUSHACC4
- 3336 C_CALL1 ml_string_length
- 3338 MULINT
- 3339 PUSHACC1
- 3340 GETFIELD0
- 3341 ADDINT
- 3342 C_CALL1 create_string
- 3344 PUSHACC3
- 3345 C_CALL1 ml_string_length
- 3347 PUSHCONST0
- 3348 PUSHACC2
- 3349 PUSHCONST0
- 3350 PUSHACC7
- 3351 C_CALL5 blit_string
- 3353 ACC3
- 3354 C_CALL1 ml_string_length
- 3356 MAKEBLOCK1 0
- 3358 PUSHACC6
- 3359 GETFIELD1
- 3360 PUSHACC1
- 3361 PUSHACC3
- 3362 PUSHACC 8
- 3364 CLOSURE 3, 3256
- 3367 PUSHGETGLOBALFIELD List, 9
- 3370 APPLY2
- 3371 ACC1
- 3372 RETURN 7
- 3374 GETGLOBAL ""
- 3376 RETURN 2
- 3378 RESTART
- 3379 GRAB 4
- 3381 CONST0
- 3382 PUSHACC5
- 3383 LTINT
- 3384 BRANCHIF 3414
- 3386 CONST0
- 3387 PUSHACC2
- 3388 LTINT
- 3389 BRANCHIF 3414
- 3391 ACC0
- 3392 C_CALL1 ml_string_length
- 3394 PUSHACC5
- 3395 PUSHACC3
- 3396 ADDINT
- 3397 GTINT
- 3398 BRANCHIF 3414
- 3400 CONST0
- 3401 PUSHACC4
- 3402 LTINT
- 3403 BRANCHIF 3414
- 3405 ACC2
- 3406 C_CALL1 ml_string_length
- 3408 PUSHACC5
- 3409 PUSHACC5
- 3410 ADDINT
- 3411 GTINT
- 3412 BRANCHIFNOT 3421
- 3414 GETGLOBAL "String.blit"
- 3416 PUSHGETGLOBALFIELD Pervasives, 2
- 3419 APPTERM1 6
- 3421 ACC4
- 3422 PUSHACC4
- 3423 PUSHACC4
- 3424 PUSHACC4
- 3425 PUSHACC4
- 3426 C_CALL5 blit_string
- 3428 RETURN 5
- 3430 RESTART
- 3431 GRAB 3
- 3433 CONST0
- 3434 PUSHACC2
- 3435 LTINT
- 3436 BRANCHIF 3452
- 3438 CONST0
- 3439 PUSHACC3
- 3440 LTINT
- 3441 BRANCHIF 3452
- 3443 ACC0
- 3444 C_CALL1 ml_string_length
- 3446 PUSHACC3
- 3447 PUSHACC3
- 3448 ADDINT
- 3449 GTINT
- 3450 BRANCHIFNOT 3459
- 3452 GETGLOBAL "String.fill"
- 3454 PUSHGETGLOBALFIELD Pervasives, 2
- 3457 APPTERM1 5
- 3459 ACC3
- 3460 PUSHACC3
- 3461 PUSHACC3
- 3462 PUSHACC3
- 3463 C_CALL4 fill_string
- 3465 RETURN 4
- 3467 RESTART
- 3468 GRAB 2
- 3470 CONST0
- 3471 PUSHACC2
- 3472 LTINT
- 3473 BRANCHIF 3489
- 3475 CONST0
- 3476 PUSHACC3
- 3477 LTINT
- 3478 BRANCHIF 3489
- 3480 ACC0
- 3481 C_CALL1 ml_string_length
- 3483 PUSHACC3
- 3484 PUSHACC3
- 3485 ADDINT
- 3486 GTINT
- 3487 BRANCHIFNOT 3496
- 3489 GETGLOBAL "String.sub"
- 3491 PUSHGETGLOBALFIELD Pervasives, 2
- 3494 APPTERM1 4
- 3496 ACC2
- 3497 C_CALL1 create_string
- 3499 PUSHACC3
- 3500 PUSHCONST0
- 3501 PUSHACC2
- 3502 PUSHACC5
- 3503 PUSHACC5
- 3504 C_CALL5 blit_string
- 3506 ACC0
- 3507 RETURN 4
- 3509 ACC0
- 3510 C_CALL1 ml_string_length
- 3512 PUSHACC0
- 3513 C_CALL1 create_string
- 3515 PUSHACC1
- 3516 PUSHCONST0
- 3517 PUSHACC2
- 3518 PUSHCONST0
- 3519 PUSHACC6
- 3520 C_CALL5 blit_string
- 3522 ACC0
- 3523 RETURN 3
- 3525 RESTART
- 3526 GRAB 1
- 3528 ACC0
- 3529 C_CALL1 create_string
- 3531 PUSHACC2
- 3532 PUSHACC2
- 3533 PUSHCONST0
- 3534 PUSHACC3
- 3535 C_CALL4 fill_string
- 3537 ACC0
- 3538 RETURN 3
- 3540 CLOSURE 0, 3526
- 3543 PUSH
- 3544 CLOSURE 0, 3509
- 3547 PUSH
- 3548 CLOSURE 0, 3468
- 3551 PUSH
- 3552 CLOSURE 0, 3431
- 3555 PUSH
- 3556 CLOSURE 0, 3379
- 3559 PUSH
- 3560 CLOSURE 0, 3308
- 3563 PUSH
- 3564 CLOSURE 0, 3013
- 3567 PUSH
- 3568 CLOSURE 0, 2965
- 3571 PUSHACC0
- 3572 CLOSURE 1, 2957
- 3575 PUSHACC1
- 3576 CLOSURE 1, 2950
- 3579 PUSHACC 8
- 3581 CLOSURE 1, 2924
- 3584 PUSHACC0
- 3585 CLOSURE 1, 2916
- 3588 PUSHACC1
- 3589 CLOSURE 1, 2909
- 3592 PUSH
- 3593 CLOSUREREC 0, 2651
- 3597 ACC0
- 3598 CLOSURE 1, 2897
- 3601 PUSHACC1
- 3602 CLOSURE 1, 2865
- 3605 PUSH
- 3606 CLOSUREREC 0, 2684
- 3610 ACC0
- 3611 CLOSURE 1, 2852
- 3614 PUSHACC1
- 3615 CLOSURE 1, 2824
- 3618 PUSHACC5
- 3619 CLOSURE 1, 2769
- 3622 PUSHACC3
- 3623 CLOSURE 1, 2724
- 3626 PUSHACC1
- 3627 CLOSURE 1, 2715
- 3630 PUSHACC 9
- 3632 PUSHACC 11
- 3634 PUSHACC 14
- 3636 PUSHACC 16
- 3638 PUSHACC5
- 3639 PUSHACC7
- 3640 PUSHACC6
- 3641 PUSHACC 10
- 3643 PUSHACC 14
- 3645 PUSHACC 13
- 3647 PUSHACC 17
- 3649 PUSHACC 26
- 3651 PUSHACC 28
- 3653 PUSHACC 30
- 3655 PUSHACC 32
- 3657 PUSHACC 34
- 3659 PUSHACC 36
- 3661 PUSHACC 38
- 3663 MAKEBLOCK 18, 0
- 3666 POP 22
- 3668 SETGLOBAL String
- 3670 GETGLOBAL ""
- 3672 PUSHCONSTINT 20
- 3674 C_CALL2 make_vect
- 3676 PUSHCONSTINT 20
- 3678 C_CALL1 weak_create
- 3680 PUSHCONST0
- 3681 PUSHCONSTINT 19
- 3683 PUSH
- 3684 BRANCH 3712
- 3686 CHECK_SIGNALS
- 3687 CONSTINT 115
- 3689 PUSHCONSTINT 20
- 3691 PUSHGETGLOBALFIELD String, 0
- 3694 APPLY2
- 3695 PUSHACC2
- 3696 PUSHACC5
- 3697 SETVECTITEM
- 3698 ACC1
- 3699 PUSHACC4
- 3700 GETVECTITEM
- 3701 MAKEBLOCK1 0
- 3703 PUSHACC2
- 3704 PUSHACC4
- 3705 C_CALL3 weak_set
- 3707 ACC1
- 3708 OFFSETINT 1
- 3710 ASSIGN 1
- 3712 ACC0
- 3713 PUSHACC2
- 3714 LEINT
- 3715 BRANCHIF 3686
- 3717 CONST0
- 3718 POP 2
- 3720 CONST0
- 3721 C_CALL1 gc_full_major
- 3723 CONST0
- 3724 PUSHCONSTINT 19
- 3726 PUSH
- 3727 BRANCH 3750
- 3729 CHECK_SIGNALS
- 3730 ACC1
- 3731 PUSHACC3
- 3732 C_CALL2 weak_get
- 3734 PUSHACC0
- 3735 BRANCHIF 3742
- 3737 GETGLOBAL Not_found
- 3739 MAKEBLOCK1 0
- 3741 RAISE
- 3742 CONST0
- 3743 POP 1
- 3745 ACC1
- 3746 OFFSETINT 1
- 3748 ASSIGN 1
- 3750 ACC0
- 3751 PUSHACC2
- 3752 LEINT
- 3753 BRANCHIF 3729
- 3755 CONST0
- 3756 POP 2
- 3758 CONST0
- 3759 PUSHCONSTINT 19
- 3761 PUSH
- 3762 BRANCH 3782
- 3764 CHECK_SIGNALS
- 3765 CONST0
- 3766 PUSHCONST2
- 3767 PUSHACC3
- 3768 MODINT
- 3769 EQ
- 3770 BRANCHIFNOT 3777
- 3772 GETGLOBAL ""
- 3774 PUSHACC2
- 3775 PUSHACC5
- 3776 SETVECTITEM
- 3777 ACC1
- 3778 OFFSETINT 1
- 3780 ASSIGN 1
- 3782 ACC0
- 3783 PUSHACC2
- 3784 LEINT
- 3785 BRANCHIF 3764
- 3787 CONST0
- 3788 POP 2
- 3790 CONST0
- 3791 C_CALL1 gc_full_major
- 3793 CONST0
- 3794 PUSHCONSTINT 19
- 3796 PUSH
- 3797 BRANCH 3851
- 3799 CHECK_SIGNALS
- 3800 ACC1
- 3801 PUSHACC3
- 3802 C_CALL2 weak_get
- 3804 PUSHACC0
- 3805 BRANCHIFNOT 3829
- 3807 CONST1
- 3808 PUSHCONST2
- 3809 PUSHACC4
- 3810 MODINT
- 3811 EQ
- 3812 BRANCHIFNOT 3839
- 3814 CONSTINT 115
- 3816 PUSHCONSTINT 5
- 3818 PUSHACC2
- 3819 GETFIELD0
- 3820 GETSTRINGCHAR
- 3821 NEQ
- 3822 BRANCHIFNOT 3844
- 3824 GETGLOBAL Not_found
- 3826 MAKEBLOCK1 0
- 3828 RAISE
- 3829 CONST0
- 3830 PUSHCONST2
- 3831 PUSHACC4
- 3832 MODINT
- 3833 EQ
- 3834 BRANCHIFNOT 3839
- 3836 CONST0
- 3837 BRANCH 3844
- 3839 GETGLOBAL Not_found
- 3841 MAKEBLOCK1 0
- 3843 RAISE
- 3844 POP 1
- 3846 ACC1
- 3847 OFFSETINT 1
- 3849 ASSIGN 1
- 3851 ACC0
- 3852 PUSHACC2
- 3853 LEINT
- 3854 BRANCHIF 3799
- 3856 CONST0
- 3857 POP 4
- 3859 ATOM0
- 3860 SETGLOBAL T340-weak
- 3862 STOP
-**)
diff --git a/test/testinterp/t350-heapcheck.ml b/test/testinterp/t350-heapcheck.ml
deleted file mode 100644
index ef4557cd52..0000000000
--- a/test/testinterp/t350-heapcheck.ml
+++ /dev/null
@@ -1,2554 +0,0 @@
-open Lib;;
-ignore (Gc.stat ());
-let x = Array.make 20 "" in
-let w = weak_create 20 in
-for i = 0 to 19 do
- x.(i) <- String.make 20 's';
- weak_set w i (Some x.(i));
-done;
-Gc.full_major ();
-for i = 0 to 19 do
- match weak_get w i with
- | None -> raise Not_found
- | _ -> ()
-done;
-for i = 0 to 19 do
- if i mod 2 = 0 then x.(i) <- ""
-done;
-Gc.full_major ();
-for i = 0 to 19 do
- match weak_get w i with
- | None when i mod 2 = 0 -> ()
- | Some s when i mod 2 = 1 -> if s.[5] <> 's' then raise Not_found
- | _ -> raise Not_found
-done
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 746
- 11 RESTART
- 12 GRAB 1
- 14 ACC0
- 15 BRANCHIFNOT 28
- 17 ACC1
- 18 PUSHACC1
- 19 GETFIELD1
- 20 PUSHOFFSETCLOSURE0
- 21 APPLY2
- 22 PUSHACC1
- 23 GETFIELD0
- 24 MAKEBLOCK2 0
- 26 RETURN 2
- 28 ACC1
- 29 RETURN 2
- 31 RESTART
- 32 GRAB 3
- 34 CONST0
- 35 PUSHACC4
- 36 LEINT
- 37 BRANCHIFNOT 42
- 39 CONST0
- 40 RETURN 4
- 42 ACC3
- 43 PUSHACC3
- 44 PUSHACC3
- 45 PUSHACC3
- 46 C_CALL4 caml_input
- 48 PUSHCONST0
- 49 PUSHACC1
- 50 EQ
- 51 BRANCHIFNOT 58
- 53 GETGLOBAL End_of_file
- 55 MAKEBLOCK1 0
- 57 RAISE
- 58 ACC0
- 59 PUSHACC5
- 60 SUBINT
- 61 PUSHACC1
- 62 PUSHACC5
- 63 ADDINT
- 64 PUSHACC4
- 65 PUSHACC4
- 66 PUSHOFFSETCLOSURE0
- 67 APPTERM 4, 9
- 70 ACC0
- 71 C_CALL1 caml_input_scan_line
- 73 PUSHCONST0
- 74 PUSHACC1
- 75 EQ
- 76 BRANCHIFNOT 83
- 78 GETGLOBAL End_of_file
- 80 MAKEBLOCK1 0
- 82 RAISE
- 83 CONST0
- 84 PUSHACC1
- 85 GTINT
- 86 BRANCHIFNOT 107
- 88 ACC0
- 89 OFFSETINT -1
- 91 C_CALL1 create_string
- 93 PUSHACC1
- 94 OFFSETINT -1
- 96 PUSHCONST0
- 97 PUSHACC2
- 98 PUSHACC5
- 99 C_CALL4 caml_input
- 101 ACC2
- 102 C_CALL1 caml_input_char
- 104 ACC0
- 105 RETURN 3
- 107 ACC0
- 108 NEGINT
- 109 C_CALL1 create_string
- 111 PUSHACC1
- 112 NEGINT
- 113 PUSHCONST0
- 114 PUSHACC2
- 115 PUSHACC5
- 116 C_CALL4 caml_input
- 118 CONST0
- 119 PUSHTRAP 130
- 121 ACC6
- 122 PUSHOFFSETCLOSURE0
- 123 APPLY1
- 124 PUSHACC5
- 125 PUSHENVACC1
- 126 APPLY2
- 127 POPTRAP
- 128 RETURN 3
- 130 PUSHGETGLOBAL End_of_file
- 132 PUSHACC1
- 133 GETFIELD0
- 134 EQ
- 135 BRANCHIFNOT 140
- 137 ACC1
- 138 RETURN 4
- 140 ACC0
- 141 RAISE
- 142 ACC0
- 143 C_CALL1 caml_flush
- 145 RETURN 1
- 147 RESTART
- 148 GRAB 1
- 150 ACC1
- 151 PUSHACC1
- 152 C_CALL2 caml_output_char
- 154 RETURN 2
- 156 RESTART
- 157 GRAB 1
- 159 ACC1
- 160 PUSHACC1
- 161 C_CALL2 caml_output_char
- 163 RETURN 2
- 165 RESTART
- 166 GRAB 1
- 168 ACC1
- 169 PUSHACC1
- 170 C_CALL2 caml_output_int
- 172 RETURN 2
- 174 RESTART
- 175 GRAB 1
- 177 ACC1
- 178 PUSHACC1
- 179 C_CALL2 caml_seek_out
- 181 RETURN 2
- 183 ACC0
- 184 C_CALL1 caml_pos_out
- 186 RETURN 1
- 188 ACC0
- 189 C_CALL1 caml_channel_size
- 191 RETURN 1
- 193 RESTART
- 194 GRAB 1
- 196 ACC1
- 197 PUSHACC1
- 198 C_CALL2 caml_set_binary_mode
- 200 RETURN 2
- 202 ACC0
- 203 C_CALL1 caml_input_char
- 205 RETURN 1
- 207 ACC0
- 208 C_CALL1 caml_input_char
- 210 RETURN 1
- 212 ACC0
- 213 C_CALL1 caml_input_int
- 215 RETURN 1
- 217 ACC0
- 218 C_CALL1 input_value
- 220 RETURN 1
- 222 RESTART
- 223 GRAB 1
- 225 ACC1
- 226 PUSHACC1
- 227 C_CALL2 caml_seek_in
- 229 RETURN 2
- 231 ACC0
- 232 C_CALL1 caml_pos_in
- 234 RETURN 1
- 236 ACC0
- 237 C_CALL1 caml_channel_size
- 239 RETURN 1
- 241 ACC0
- 242 C_CALL1 caml_close_channel
- 244 RETURN 1
- 246 RESTART
- 247 GRAB 1
- 249 ACC1
- 250 PUSHACC1
- 251 C_CALL2 caml_set_binary_mode
- 253 RETURN 2
- 255 CONST0
- 256 PUSHENVACC1
- 257 APPLY1
- 258 ACC0
- 259 C_CALL1 sys_exit
- 261 RETURN 1
- 263 CONST0
- 264 PUSHENVACC1
- 265 GETFIELD0
- 266 APPTERM1 2
- 268 CONST0
- 269 PUSHENVACC1
- 270 APPLY1
- 271 CONST0
- 272 PUSHENVACC2
- 273 APPTERM1 2
- 275 ENVACC1
- 276 GETFIELD0
- 277 PUSHACC0
- 278 PUSHACC2
- 279 CLOSURE 2, 268
- 282 PUSHENVACC1
- 283 SETFIELD0
- 284 RETURN 2
- 286 ENVACC1
- 287 C_CALL1 caml_flush
- 289 ENVACC2
- 290 C_CALL1 caml_flush
- 292 RETURN 1
- 294 CONST0
- 295 PUSHENVACC1
- 296 APPLY1
- 297 C_CALL1 float_of_string
- 299 RETURN 1
- 301 CONST0
- 302 PUSHENVACC1
- 303 APPLY1
- 304 C_CALL1 int_of_string
- 306 RETURN 1
- 308 ENVACC2
- 309 C_CALL1 caml_flush
- 311 ENVACC1
- 312 PUSHENVACC3
- 313 APPTERM1 2
- 315 CONSTINT 13
- 317 PUSHENVACC1
- 318 C_CALL2 caml_output_char
- 320 ENVACC1
- 321 C_CALL1 caml_flush
- 323 RETURN 1
- 325 ACC0
- 326 PUSHENVACC1
- 327 PUSHENVACC2
- 328 APPLY2
- 329 CONSTINT 13
- 331 PUSHENVACC1
- 332 C_CALL2 caml_output_char
- 334 ENVACC1
- 335 C_CALL1 caml_flush
- 337 RETURN 1
- 339 ACC0
- 340 PUSHENVACC1
- 341 APPLY1
- 342 PUSHENVACC2
- 343 PUSHENVACC3
- 344 APPTERM2 3
- 346 ACC0
- 347 PUSHENVACC1
- 348 APPLY1
- 349 PUSHENVACC2
- 350 PUSHENVACC3
- 351 APPTERM2 3
- 353 ACC0
- 354 PUSHENVACC1
- 355 PUSHENVACC2
- 356 APPTERM2 3
- 358 ACC0
- 359 PUSHENVACC1
- 360 C_CALL2 caml_output_char
- 362 RETURN 1
- 364 CONSTINT 13
- 366 PUSHENVACC1
- 367 C_CALL2 caml_output_char
- 369 ENVACC1
- 370 C_CALL1 caml_flush
- 372 RETURN 1
- 374 ACC0
- 375 PUSHENVACC1
- 376 PUSHENVACC2
- 377 APPLY2
- 378 CONSTINT 13
- 380 PUSHENVACC1
- 381 C_CALL2 caml_output_char
- 383 RETURN 1
- 385 ACC0
- 386 PUSHENVACC1
- 387 APPLY1
- 388 PUSHENVACC2
- 389 PUSHENVACC3
- 390 APPTERM2 3
- 392 ACC0
- 393 PUSHENVACC1
- 394 APPLY1
- 395 PUSHENVACC2
- 396 PUSHENVACC3
- 397 APPTERM2 3
- 399 ACC0
- 400 PUSHENVACC1
- 401 PUSHENVACC2
- 402 APPTERM2 3
- 404 ACC0
- 405 PUSHENVACC1
- 406 C_CALL2 caml_output_char
- 408 RETURN 1
- 410 RESTART
- 411 GRAB 3
- 413 CONST0
- 414 PUSHACC3
- 415 LTINT
- 416 BRANCHIF 427
- 418 ACC1
- 419 C_CALL1 ml_string_length
- 421 PUSHACC4
- 422 PUSHACC4
- 423 ADDINT
- 424 GTINT
- 425 BRANCHIFNOT 432
- 427 GETGLOBAL "really_input"
- 429 PUSHENVACC1
- 430 APPTERM1 5
- 432 ACC3
- 433 PUSHACC3
- 434 PUSHACC3
- 435 PUSHACC3
- 436 PUSHENVACC2
- 437 APPTERM 4, 8
- 440 RESTART
- 441 GRAB 3
- 443 CONST0
- 444 PUSHACC3
- 445 LTINT
- 446 BRANCHIF 457
- 448 ACC1
- 449 C_CALL1 ml_string_length
- 451 PUSHACC4
- 452 PUSHACC4
- 453 ADDINT
- 454 GTINT
- 455 BRANCHIFNOT 462
- 457 GETGLOBAL "input"
- 459 PUSHENVACC1
- 460 APPTERM1 5
- 462 ACC3
- 463 PUSHACC3
- 464 PUSHACC3
- 465 PUSHACC3
- 466 C_CALL4 caml_input
- 468 RETURN 4
- 470 ACC0
- 471 PUSHCONST0
- 472 PUSHGETGLOBAL <0>(0, <0>(6, 0))
- 474 PUSHENVACC1
- 475 APPTERM3 4
- 477 ACC0
- 478 PUSHCONST0
- 479 PUSHGETGLOBAL <0>(0, <0>(7, 0))
- 481 PUSHENVACC1
- 482 APPTERM3 4
- 484 RESTART
- 485 GRAB 2
- 487 ACC1
- 488 PUSHACC1
- 489 PUSHACC4
- 490 C_CALL3 sys_open
- 492 C_CALL1 caml_open_descriptor
- 494 RETURN 3
- 496 ACC0
- 497 C_CALL1 caml_flush
- 499 ACC0
- 500 C_CALL1 caml_close_channel
- 502 RETURN 1
- 504 RESTART
- 505 GRAB 1
- 507 CONST0
- 508 PUSHACC2
- 509 PUSHACC2
- 510 C_CALL3 output_value
- 512 RETURN 2
- 514 RESTART
- 515 GRAB 3
- 517 CONST0
- 518 PUSHACC3
- 519 LTINT
- 520 BRANCHIF 531
- 522 ACC1
- 523 C_CALL1 ml_string_length
- 525 PUSHACC4
- 526 PUSHACC4
- 527 ADDINT
- 528 GTINT
- 529 BRANCHIFNOT 536
- 531 GETGLOBAL "output"
- 533 PUSHENVACC1
- 534 APPTERM1 5
- 536 ACC3
- 537 PUSHACC3
- 538 PUSHACC3
- 539 PUSHACC3
- 540 C_CALL4 caml_output
- 542 RETURN 4
- 544 RESTART
- 545 GRAB 1
- 547 ACC1
- 548 C_CALL1 ml_string_length
- 550 PUSHCONST0
- 551 PUSHACC3
- 552 PUSHACC3
- 553 C_CALL4 caml_output
- 555 RETURN 2
- 557 ACC0
- 558 PUSHCONSTINT 438
- 560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0))))
- 562 PUSHENVACC1
- 563 APPTERM3 4
- 565 ACC0
- 566 PUSHCONSTINT 438
- 568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0))))
- 570 PUSHENVACC1
- 571 APPTERM3 4
- 573 RESTART
- 574 GRAB 2
- 576 ACC1
- 577 PUSHACC1
- 578 PUSHACC4
- 579 C_CALL3 sys_open
- 581 C_CALL1 caml_open_descriptor
- 583 RETURN 3
- 585 ACC0
- 586 PUSHGETGLOBAL "%.12g"
- 588 C_CALL2 format_float
- 590 RETURN 1
- 592 ACC0
- 593 PUSHGETGLOBAL "%d"
- 595 C_CALL2 format_int
- 597 RETURN 1
- 599 GETGLOBAL "false"
- 601 PUSHACC1
- 602 C_CALL2 string_equal
- 604 BRANCHIFNOT 609
- 606 CONST0
- 607 RETURN 1
- 609 GETGLOBAL "true"
- 611 PUSHACC1
- 612 C_CALL2 string_equal
- 614 BRANCHIFNOT 619
- 616 CONST1
- 617 RETURN 1
- 619 GETGLOBAL "bool_of_string"
- 621 PUSHENVACC1
- 622 APPTERM1 2
- 624 ACC0
- 625 BRANCHIFNOT 631
- 627 GETGLOBAL "true"
- 629 RETURN 1
- 631 GETGLOBAL "false"
- 633 RETURN 1
- 635 CONST0
- 636 PUSHACC1
- 637 LTINT
- 638 BRANCHIF 646
- 640 CONSTINT 255
- 642 PUSHACC1
- 643 GTINT
- 644 BRANCHIFNOT 651
- 646 GETGLOBAL "char_of_int"
- 648 PUSHENVACC1
- 649 APPTERM1 2
- 651 ACC0
- 652 RETURN 1
- 654 RESTART
- 655 GRAB 1
- 657 ACC0
- 658 C_CALL1 ml_string_length
- 660 PUSHACC2
- 661 C_CALL1 ml_string_length
- 663 PUSHACC0
- 664 PUSHACC2
- 665 ADDINT
- 666 C_CALL1 create_string
- 668 PUSHACC2
- 669 PUSHCONST0
- 670 PUSHACC2
- 671 PUSHCONST0
- 672 PUSHACC7
- 673 C_CALL5 blit_string
- 675 ACC1
- 676 PUSHACC3
- 677 PUSHACC2
- 678 PUSHCONST0
- 679 PUSHACC 8
- 681 C_CALL5 blit_string
- 683 ACC0
- 684 RETURN 5
- 686 CONSTINT -1
- 688 PUSHACC1
- 689 XORINT
- 690 RETURN 1
- 692 CONST0
- 693 PUSHACC1
- 694 GEINT
- 695 BRANCHIFNOT 700
- 697 ACC0
- 698 RETURN 1
- 700 ACC0
- 701 NEGINT
- 702 RETURN 1
- 704 RESTART
- 705 GRAB 1
- 707 ACC1
- 708 PUSHACC1
- 709 C_CALL2 greaterequal
- 711 BRANCHIFNOT 716
- 713 ACC0
- 714 RETURN 2
- 716 ACC1
- 717 RETURN 2
- 719 RESTART
- 720 GRAB 1
- 722 ACC1
- 723 PUSHACC1
- 724 C_CALL2 lessequal
- 726 BRANCHIFNOT 731
- 728 ACC0
- 729 RETURN 2
- 731 ACC1
- 732 RETURN 2
- 734 ACC0
- 735 PUSHGETGLOBAL Invalid_argument
- 737 MAKEBLOCK2 0
- 739 RAISE
- 740 ACC0
- 741 PUSHGETGLOBAL Failure
- 743 MAKEBLOCK2 0
- 745 RAISE
- 746 CLOSURE 0, 740
- 749 PUSH
- 750 CLOSURE 0, 734
- 753 PUSHGETGLOBAL "Pervasives.Exit"
- 755 MAKEBLOCK1 0
- 757 PUSHGETGLOBAL "Pervasives.Assert_failure"
- 759 MAKEBLOCK1 0
- 761 PUSH
- 762 CLOSURE 0, 720
- 765 PUSH
- 766 CLOSURE 0, 705
- 769 PUSH
- 770 CLOSURE 0, 692
- 773 PUSH
- 774 CLOSURE 0, 686
- 777 PUSHCONST0
- 778 PUSHCONSTINT 31
- 780 PUSHCONST1
- 781 LSLINT
- 782 EQ
- 783 BRANCHIFNOT 789
- 785 CONSTINT 30
- 787 BRANCH 791
- 789 CONSTINT 62
- 791 PUSHCONST1
- 792 LSLINT
- 793 PUSHACC0
- 794 OFFSETINT -1
- 796 PUSH
- 797 CLOSURE 0, 655
- 800 PUSHACC 9
- 802 CLOSURE 1, 635
- 805 PUSH
- 806 CLOSURE 0, 624
- 809 PUSHACC 11
- 811 CLOSURE 1, 599
- 814 PUSH
- 815 CLOSURE 0, 592
- 818 PUSH
- 819 CLOSURE 0, 585
- 822 PUSH
- 823 CLOSUREREC 0, 12
- 827 CONST0
- 828 C_CALL1 caml_open_descriptor
- 830 PUSHCONST1
- 831 C_CALL1 caml_open_descriptor
- 833 PUSHCONST2
- 834 C_CALL1 caml_open_descriptor
- 836 PUSH
- 837 CLOSURE 0, 574
- 840 PUSHACC0
- 841 CLOSURE 1, 565
- 844 PUSHACC1
- 845 CLOSURE 1, 557
- 848 PUSH
- 849 CLOSURE 0, 545
- 852 PUSHACC 22
- 854 CLOSURE 1, 515
- 857 PUSH
- 858 CLOSURE 0, 505
- 861 PUSH
- 862 CLOSURE 0, 496
- 865 PUSH
- 866 CLOSURE 0, 485
- 869 PUSHACC0
- 870 CLOSURE 1, 477
- 873 PUSHACC1
- 874 CLOSURE 1, 470
- 877 PUSHACC 28
- 879 CLOSURE 1, 441
- 882 PUSH
- 883 CLOSUREREC 0, 32
- 887 ACC0
- 888 PUSHACC 31
- 890 CLOSURE 2, 411
- 893 PUSHACC 22
- 895 CLOSUREREC 1, 70
- 899 ACC 15
- 901 CLOSURE 1, 404
- 904 PUSHACC 11
- 906 PUSHACC 17
- 908 CLOSURE 2, 399
- 911 PUSHACC 12
- 913 PUSHACC 18
- 915 PUSHACC 23
- 917 CLOSURE 3, 392
- 920 PUSHACC 13
- 922 PUSHACC 19
- 924 PUSHACC 23
- 926 CLOSURE 3, 385
- 929 PUSHACC 14
- 931 PUSHACC 20
- 933 CLOSURE 2, 374
- 936 PUSHACC 20
- 938 CLOSURE 1, 364
- 941 PUSHACC 20
- 943 CLOSURE 1, 358
- 946 PUSHACC 17
- 948 PUSHACC 22
- 950 CLOSURE 2, 353
- 953 PUSHACC 18
- 955 PUSHACC 23
- 957 PUSHACC 29
- 959 CLOSURE 3, 346
- 962 PUSHACC 19
- 964 PUSHACC 24
- 966 PUSHACC 29
- 968 CLOSURE 3, 339
- 971 PUSHACC 20
- 973 PUSHACC 25
- 975 CLOSURE 2, 325
- 978 PUSHACC 25
- 980 CLOSURE 1, 315
- 983 PUSHACC 12
- 985 PUSHACC 28
- 987 PUSHACC 30
- 989 CLOSURE 3, 308
- 992 PUSHACC0
- 993 CLOSURE 1, 301
- 996 PUSHACC1
- 997 CLOSURE 1, 294
- 1000 PUSHACC 29
- 1002 PUSHACC 31
- 1004 CLOSURE 2, 286
- 1007 MAKEBLOCK1 0
- 1009 PUSHACC0
- 1010 CLOSURE 1, 275
- 1013 PUSHACC1
- 1014 CLOSURE 1, 263
- 1017 PUSHACC0
- 1018 CLOSURE 1, 255
- 1021 PUSHACC1
- 1022 PUSHACC 22
- 1024 PUSHACC4
- 1025 PUSHACC3
- 1026 PUSH
- 1027 CLOSURE 0, 247
- 1030 PUSH
- 1031 CLOSURE 0, 241
- 1034 PUSH
- 1035 CLOSURE 0, 236
- 1038 PUSH
- 1039 CLOSURE 0, 231
- 1042 PUSH
- 1043 CLOSURE 0, 223
- 1046 PUSH
- 1047 CLOSURE 0, 217
- 1050 PUSH
- 1051 CLOSURE 0, 212
- 1054 PUSH
- 1055 CLOSURE 0, 207
- 1058 PUSHACC 32
- 1060 PUSHACC 35
- 1062 PUSHACC 33
- 1064 PUSH
- 1065 CLOSURE 0, 202
- 1068 PUSHACC 41
- 1070 PUSHACC 40
- 1072 PUSHACC 42
- 1074 PUSH
- 1075 CLOSURE 0, 194
- 1078 PUSHACC 46
- 1080 PUSH
- 1081 CLOSURE 0, 188
- 1084 PUSH
- 1085 CLOSURE 0, 183
- 1088 PUSH
- 1089 CLOSURE 0, 175
- 1092 PUSHACC 51
- 1094 PUSH
- 1095 CLOSURE 0, 166
- 1098 PUSH
- 1099 CLOSURE 0, 157
- 1102 PUSHACC 55
- 1104 PUSHACC 57
- 1106 PUSH
- 1107 CLOSURE 0, 148
- 1110 PUSH
- 1111 CLOSURE 0, 142
- 1114 PUSHACC 63
- 1116 PUSHACC 62
- 1118 PUSHACC 64
- 1120 PUSHACC 38
- 1122 PUSHACC 40
- 1124 PUSHACC 42
- 1126 PUSHACC 44
- 1128 PUSHACC 46
- 1130 PUSHACC 48
- 1132 PUSHACC 50
- 1134 PUSHACC 52
- 1136 PUSHACC 54
- 1138 PUSHACC 56
- 1140 PUSHACC 58
- 1142 PUSHACC 60
- 1144 PUSHACC 62
- 1146 PUSHACC 64
- 1148 PUSHACC 66
- 1150 PUSHACC 82
- 1152 PUSHACC 84
- 1154 PUSHACC 86
- 1156 PUSHACC 88
- 1158 PUSHACC 90
- 1160 PUSHACC 92
- 1162 PUSHACC 94
- 1164 PUSHACC 96
- 1166 PUSHACC 98
- 1168 PUSHACC 100
- 1170 PUSHACC 104
- 1172 PUSHACC 104
- 1174 PUSHACC 104
- 1176 PUSHACC 108
- 1178 PUSHACC 110
- 1180 PUSHACC 112
- 1182 PUSHACC 117
- 1184 PUSHACC 117
- 1186 PUSHACC 117
- 1188 PUSHACC 117
- 1190 MAKEBLOCK 69, 0
- 1193 POP 53
- 1195 SETGLOBAL Pervasives
- 1197 BRANCH 2177
- 1199 RESTART
- 1200 GRAB 1
- 1202 ACC1
- 1203 BRANCHIFNOT 1213
- 1205 ACC1
- 1206 GETFIELD1
- 1207 PUSHACC1
- 1208 OFFSETINT 1
- 1210 PUSHOFFSETCLOSURE0
- 1211 APPTERM2 4
- 1213 ACC0
- 1214 RETURN 2
- 1216 RESTART
- 1217 GRAB 1
- 1219 ACC0
- 1220 BRANCHIFNOT 1251
- 1222 CONST0
- 1223 PUSHACC2
- 1224 EQ
- 1225 BRANCHIFNOT 1231
- 1227 ACC0
- 1228 GETFIELD0
- 1229 RETURN 2
- 1231 CONST0
- 1232 PUSHACC2
- 1233 GTINT
- 1234 BRANCHIFNOT 1244
- 1236 ACC1
- 1237 OFFSETINT -1
- 1239 PUSHACC1
- 1240 GETFIELD1
- 1241 PUSHOFFSETCLOSURE0
- 1242 APPTERM2 4
- 1244 GETGLOBAL "List.nth"
- 1246 PUSHGETGLOBALFIELD Pervasives, 2
- 1249 APPTERM1 3
- 1251 GETGLOBAL "nth"
- 1253 PUSHGETGLOBALFIELD Pervasives, 3
- 1256 APPTERM1 3
- 1258 RESTART
- 1259 GRAB 1
- 1261 ACC0
- 1262 BRANCHIFNOT 1274
- 1264 ACC1
- 1265 PUSHACC1
- 1266 GETFIELD0
- 1267 MAKEBLOCK2 0
- 1269 PUSHACC1
- 1270 GETFIELD1
- 1271 PUSHOFFSETCLOSURE0
- 1272 APPTERM2 4
- 1274 ACC1
- 1275 RETURN 2
- 1277 ACC0
- 1278 BRANCHIFNOT 1291
- 1280 ACC0
- 1281 GETFIELD1
- 1282 PUSHOFFSETCLOSURE0
- 1283 APPLY1
- 1284 PUSHACC1
- 1285 GETFIELD0
- 1286 PUSHGETGLOBALFIELD Pervasives, 16
- 1289 APPTERM2 3
- 1291 RETURN 1
- 1293 RESTART
- 1294 GRAB 1
- 1296 ACC1
- 1297 BRANCHIFNOT 1313
- 1299 ACC1
- 1300 GETFIELD0
- 1301 PUSHACC1
- 1302 APPLY1
- 1303 PUSHACC2
- 1304 GETFIELD1
- 1305 PUSHACC2
- 1306 PUSHOFFSETCLOSURE0
- 1307 APPLY2
- 1308 PUSHACC1
- 1309 MAKEBLOCK2 0
- 1311 POP 1
- 1313 RETURN 2
- 1315 RESTART
- 1316 GRAB 1
- 1318 ACC1
- 1319 BRANCHIFNOT 1331
- 1321 ACC1
- 1322 GETFIELD0
- 1323 PUSHACC1
- 1324 APPLY1
- 1325 ACC1
- 1326 GETFIELD1
- 1327 PUSHACC1
- 1328 PUSHOFFSETCLOSURE0
- 1329 APPTERM2 4
- 1331 RETURN 2
- 1333 RESTART
- 1334 GRAB 2
- 1336 ACC2
- 1337 BRANCHIFNOT 1350
- 1339 ACC2
- 1340 GETFIELD1
- 1341 PUSHACC3
- 1342 GETFIELD0
- 1343 PUSHACC3
- 1344 PUSHACC3
- 1345 APPLY2
- 1346 PUSHACC2
- 1347 PUSHOFFSETCLOSURE0
- 1348 APPTERM3 6
- 1350 ACC1
- 1351 RETURN 3
- 1353 RESTART
- 1354 GRAB 2
- 1356 ACC1
- 1357 BRANCHIFNOT 1370
- 1359 ACC2
- 1360 PUSHACC2
- 1361 GETFIELD1
- 1362 PUSHACC2
- 1363 PUSHOFFSETCLOSURE0
- 1364 APPLY3
- 1365 PUSHACC2
- 1366 GETFIELD0
- 1367 PUSHACC2
- 1368 APPTERM2 5
- 1370 ACC2
- 1371 RETURN 3
- 1373 RESTART
- 1374 GRAB 2
- 1376 ACC1
- 1377 BRANCHIFNOT 1400
- 1379 ACC2
- 1380 BRANCHIFNOT 1407
- 1382 ACC2
- 1383 GETFIELD0
- 1384 PUSHACC2
- 1385 GETFIELD0
- 1386 PUSHACC2
- 1387 APPLY2
- 1388 PUSHACC3
- 1389 GETFIELD1
- 1390 PUSHACC3
- 1391 GETFIELD1
- 1392 PUSHACC3
- 1393 PUSHOFFSETCLOSURE0
- 1394 APPLY3
- 1395 PUSHACC1
- 1396 MAKEBLOCK2 0
- 1398 RETURN 4
- 1400 ACC2
- 1401 BRANCHIFNOT 1405
- 1403 BRANCH 1407
- 1405 RETURN 3
- 1407 GETGLOBAL "List.map2"
- 1409 PUSHGETGLOBALFIELD Pervasives, 2
- 1412 APPTERM1 4
- 1414 RESTART
- 1415 GRAB 2
- 1417 ACC1
- 1418 BRANCHIFNOT 1437
- 1420 ACC2
- 1421 BRANCHIFNOT 1444
- 1423 ACC2
- 1424 GETFIELD0
- 1425 PUSHACC2
- 1426 GETFIELD0
- 1427 PUSHACC2
- 1428 APPLY2
- 1429 ACC2
- 1430 GETFIELD1
- 1431 PUSHACC2
- 1432 GETFIELD1
- 1433 PUSHACC2
- 1434 PUSHOFFSETCLOSURE0
- 1435 APPTERM3 6
- 1437 ACC2
- 1438 BRANCHIFNOT 1442
- 1440 BRANCH 1444
- 1442 RETURN 3
- 1444 GETGLOBAL "List.iter2"
- 1446 PUSHGETGLOBALFIELD Pervasives, 2
- 1449 APPTERM1 4
- 1451 RESTART
- 1452 GRAB 3
- 1454 ACC2
- 1455 BRANCHIFNOT 1476
- 1457 ACC3
- 1458 BRANCHIFNOT 1482
- 1460 ACC3
- 1461 GETFIELD1
- 1462 PUSHACC3
- 1463 GETFIELD1
- 1464 PUSHACC5
- 1465 GETFIELD0
- 1466 PUSHACC5
- 1467 GETFIELD0
- 1468 PUSHACC5
- 1469 PUSHACC5
- 1470 APPLY3
- 1471 PUSHACC3
- 1472 PUSHOFFSETCLOSURE0
- 1473 APPTERM 4, 8
- 1476 ACC3
- 1477 BRANCHIF 1482
- 1479 ACC1
- 1480 RETURN 4
- 1482 GETGLOBAL "List.fold_left2"
- 1484 PUSHGETGLOBALFIELD Pervasives, 2
- 1487 APPTERM1 5
- 1489 RESTART
- 1490 GRAB 3
- 1492 ACC1
- 1493 BRANCHIFNOT 1516
- 1495 ACC2
- 1496 BRANCHIFNOT 1522
- 1498 PUSH_RETADDR 1509
- 1500 ACC6
- 1501 PUSHACC6
- 1502 GETFIELD1
- 1503 PUSHACC6
- 1504 GETFIELD1
- 1505 PUSHACC6
- 1506 PUSHOFFSETCLOSURE0
- 1507 APPLY 4
- 1509 PUSHACC3
- 1510 GETFIELD0
- 1511 PUSHACC3
- 1512 GETFIELD0
- 1513 PUSHACC3
- 1514 APPTERM3 7
- 1516 ACC2
- 1517 BRANCHIF 1522
- 1519 ACC3
- 1520 RETURN 4
- 1522 GETGLOBAL "List.fold_right2"
- 1524 PUSHGETGLOBALFIELD Pervasives, 2
- 1527 APPTERM1 5
- 1529 RESTART
- 1530 GRAB 1
- 1532 ACC1
- 1533 BRANCHIFNOT 1549
- 1535 ACC1
- 1536 GETFIELD0
- 1537 PUSHACC1
- 1538 APPLY1
- 1539 BRANCHIFNOT 1547
- 1541 ACC1
- 1542 GETFIELD1
- 1543 PUSHACC1
- 1544 PUSHOFFSETCLOSURE0
- 1545 APPTERM2 4
- 1547 RETURN 2
- 1549 CONST1
- 1550 RETURN 2
- 1552 RESTART
- 1553 GRAB 1
- 1555 ACC1
- 1556 BRANCHIFNOT 1570
- 1558 ACC1
- 1559 GETFIELD0
- 1560 PUSHACC1
- 1561 APPLY1
- 1562 BRANCHIF 1570
- 1564 ACC1
- 1565 GETFIELD1
- 1566 PUSHACC1
- 1567 PUSHOFFSETCLOSURE0
- 1568 APPTERM2 4
- 1570 RETURN 2
- 1572 RESTART
- 1573 GRAB 2
- 1575 ACC1
- 1576 BRANCHIFNOT 1599
- 1578 ACC2
- 1579 BRANCHIFNOT 1605
- 1581 ACC2
- 1582 GETFIELD0
- 1583 PUSHACC2
- 1584 GETFIELD0
- 1585 PUSHACC2
- 1586 APPLY2
- 1587 BRANCHIFNOT 1597
- 1589 ACC2
- 1590 GETFIELD1
- 1591 PUSHACC2
- 1592 GETFIELD1
- 1593 PUSHACC2
- 1594 PUSHOFFSETCLOSURE0
- 1595 APPTERM3 6
- 1597 RETURN 3
- 1599 ACC2
- 1600 BRANCHIF 1605
- 1602 CONST1
- 1603 RETURN 3
- 1605 GETGLOBAL "List.for_all2"
- 1607 PUSHGETGLOBALFIELD Pervasives, 2
- 1610 APPTERM1 4
- 1612 RESTART
- 1613 GRAB 2
- 1615 ACC1
- 1616 BRANCHIFNOT 1639
- 1618 ACC2
- 1619 BRANCHIFNOT 1646
- 1621 ACC2
- 1622 GETFIELD0
- 1623 PUSHACC2
- 1624 GETFIELD0
- 1625 PUSHACC2
- 1626 APPLY2
- 1627 BRANCHIF 1637
- 1629 ACC2
- 1630 GETFIELD1
- 1631 PUSHACC2
- 1632 GETFIELD1
- 1633 PUSHACC2
- 1634 PUSHOFFSETCLOSURE0
- 1635 APPTERM3 6
- 1637 RETURN 3
- 1639 ACC2
- 1640 BRANCHIFNOT 1644
- 1642 BRANCH 1646
- 1644 RETURN 3
- 1646 GETGLOBAL "List.exists2"
- 1648 PUSHGETGLOBALFIELD Pervasives, 2
- 1651 APPTERM1 4
- 1653 RESTART
- 1654 GRAB 1
- 1656 ACC1
- 1657 BRANCHIFNOT 1672
- 1659 ACC0
- 1660 PUSHACC2
- 1661 GETFIELD0
- 1662 C_CALL2 equal
- 1664 BRANCHIF 1672
- 1666 ACC1
- 1667 GETFIELD1
- 1668 PUSHACC1
- 1669 PUSHOFFSETCLOSURE0
- 1670 APPTERM2 4
- 1672 RETURN 2
- 1674 RESTART
- 1675 GRAB 1
- 1677 ACC1
- 1678 BRANCHIFNOT 1692
- 1680 ACC0
- 1681 PUSHACC2
- 1682 GETFIELD0
- 1683 EQ
- 1684 BRANCHIF 1692
- 1686 ACC1
- 1687 GETFIELD1
- 1688 PUSHACC1
- 1689 PUSHOFFSETCLOSURE0
- 1690 APPTERM2 4
- 1692 RETURN 2
- 1694 RESTART
- 1695 GRAB 1
- 1697 ACC1
- 1698 BRANCHIFNOT 1719
- 1700 ACC1
- 1701 GETFIELD0
- 1702 PUSHACC1
- 1703 PUSHACC1
- 1704 GETFIELD0
- 1705 C_CALL2 equal
- 1707 BRANCHIFNOT 1713
- 1709 ACC0
- 1710 GETFIELD1
- 1711 RETURN 3
- 1713 ACC2
- 1714 GETFIELD1
- 1715 PUSHACC2
- 1716 PUSHOFFSETCLOSURE0
- 1717 APPTERM2 5
- 1719 GETGLOBAL Not_found
- 1721 MAKEBLOCK1 0
- 1723 RAISE
- 1724 RESTART
- 1725 GRAB 1
- 1727 ACC1
- 1728 BRANCHIFNOT 1748
- 1730 ACC1
- 1731 GETFIELD0
- 1732 PUSHACC1
- 1733 PUSHACC1
- 1734 GETFIELD0
- 1735 EQ
- 1736 BRANCHIFNOT 1742
- 1738 ACC0
- 1739 GETFIELD1
- 1740 RETURN 3
- 1742 ACC2
- 1743 GETFIELD1
- 1744 PUSHACC2
- 1745 PUSHOFFSETCLOSURE0
- 1746 APPTERM2 5
- 1748 GETGLOBAL Not_found
- 1750 MAKEBLOCK1 0
- 1752 RAISE
- 1753 RESTART
- 1754 GRAB 1
- 1756 ACC1
- 1757 BRANCHIFNOT 1773
- 1759 ACC0
- 1760 PUSHACC2
- 1761 GETFIELD0
- 1762 GETFIELD0
- 1763 C_CALL2 equal
- 1765 BRANCHIF 1773
- 1767 ACC1
- 1768 GETFIELD1
- 1769 PUSHACC1
- 1770 PUSHOFFSETCLOSURE0
- 1771 APPTERM2 4
- 1773 RETURN 2
- 1775 RESTART
- 1776 GRAB 1
- 1778 ACC1
- 1779 BRANCHIFNOT 1794
- 1781 ACC0
- 1782 PUSHACC2
- 1783 GETFIELD0
- 1784 GETFIELD0
- 1785 EQ
- 1786 BRANCHIF 1794
- 1788 ACC1
- 1789 GETFIELD1
- 1790 PUSHACC1
- 1791 PUSHOFFSETCLOSURE0
- 1792 APPTERM2 4
- 1794 RETURN 2
- 1796 RESTART
- 1797 GRAB 1
- 1799 ACC1
- 1800 BRANCHIFNOT 1825
- 1802 ACC1
- 1803 GETFIELD0
- 1804 PUSHACC2
- 1805 GETFIELD1
- 1806 PUSHACC2
- 1807 PUSHACC2
- 1808 GETFIELD0
- 1809 C_CALL2 equal
- 1811 BRANCHIFNOT 1816
- 1813 ACC0
- 1814 RETURN 4
- 1816 ACC0
- 1817 PUSHACC3
- 1818 PUSHOFFSETCLOSURE0
- 1819 APPLY2
- 1820 PUSHACC2
- 1821 MAKEBLOCK2 0
- 1823 POP 2
- 1825 RETURN 2
- 1827 RESTART
- 1828 GRAB 1
- 1830 ACC1
- 1831 BRANCHIFNOT 1855
- 1833 ACC1
- 1834 GETFIELD0
- 1835 PUSHACC2
- 1836 GETFIELD1
- 1837 PUSHACC2
- 1838 PUSHACC2
- 1839 GETFIELD0
- 1840 EQ
- 1841 BRANCHIFNOT 1846
- 1843 ACC0
- 1844 RETURN 4
- 1846 ACC0
- 1847 PUSHACC3
- 1848 PUSHOFFSETCLOSURE0
- 1849 APPLY2
- 1850 PUSHACC2
- 1851 MAKEBLOCK2 0
- 1853 POP 2
- 1855 RETURN 2
- 1857 RESTART
- 1858 GRAB 1
- 1860 ACC1
- 1861 BRANCHIFNOT 1879
- 1863 ACC1
- 1864 GETFIELD0
- 1865 PUSHACC0
- 1866 PUSHACC2
- 1867 APPLY1
- 1868 BRANCHIFNOT 1873
- 1870 ACC0
- 1871 RETURN 3
- 1873 ACC2
- 1874 GETFIELD1
- 1875 PUSHACC2
- 1876 PUSHOFFSETCLOSURE0
- 1877 APPTERM2 5
- 1879 GETGLOBAL Not_found
- 1881 MAKEBLOCK1 0
- 1883 RAISE
- 1884 RESTART
- 1885 GRAB 2
- 1887 ACC2
- 1888 BRANCHIFNOT 1917
- 1890 ACC2
- 1891 GETFIELD0
- 1892 PUSHACC3
- 1893 GETFIELD1
- 1894 PUSHACC1
- 1895 PUSHENVACC2
- 1896 APPLY1
- 1897 BRANCHIFNOT 1908
- 1899 ACC0
- 1900 PUSHACC4
- 1901 PUSHACC4
- 1902 PUSHACC4
- 1903 MAKEBLOCK2 0
- 1905 PUSHOFFSETCLOSURE0
- 1906 APPTERM3 8
- 1908 ACC0
- 1909 PUSHACC4
- 1910 PUSHACC3
- 1911 MAKEBLOCK2 0
- 1913 PUSHACC4
- 1914 PUSHOFFSETCLOSURE0
- 1915 APPTERM3 8
- 1917 ACC1
- 1918 PUSHENVACC1
- 1919 APPLY1
- 1920 PUSHACC1
- 1921 PUSHENVACC1
- 1922 APPLY1
- 1923 MAKEBLOCK2 0
- 1925 RETURN 3
- 1927 RESTART
- 1928 GRAB 1
- 1930 ACC0
- 1931 PUSHENVACC1
- 1932 CLOSUREREC 2, 1885
- 1936 ACC2
- 1937 PUSHCONST0
- 1938 PUSHCONST0
- 1939 PUSHACC3
- 1940 APPTERM3 6
- 1942 ACC0
- 1943 BRANCHIFNOT 1967
- 1945 ACC0
- 1946 GETFIELD0
- 1947 PUSHACC1
- 1948 GETFIELD1
- 1949 PUSHOFFSETCLOSURE0
- 1950 APPLY1
- 1951 PUSHACC0
- 1952 GETFIELD1
- 1953 PUSHACC2
- 1954 GETFIELD1
- 1955 MAKEBLOCK2 0
- 1957 PUSHACC1
- 1958 GETFIELD0
- 1959 PUSHACC3
- 1960 GETFIELD0
- 1961 MAKEBLOCK2 0
- 1963 MAKEBLOCK2 0
- 1965 RETURN 3
- 1967 GETGLOBAL <0>(0, 0)
- 1969 RETURN 1
- 1971 RESTART
- 1972 GRAB 1
- 1974 ACC0
- 1975 BRANCHIFNOT 1996
- 1977 ACC1
- 1978 BRANCHIFNOT 2003
- 1980 ACC1
- 1981 GETFIELD1
- 1982 PUSHACC1
- 1983 GETFIELD1
- 1984 PUSHOFFSETCLOSURE0
- 1985 APPLY2
- 1986 PUSHACC2
- 1987 GETFIELD0
- 1988 PUSHACC2
- 1989 GETFIELD0
- 1990 MAKEBLOCK2 0
- 1992 MAKEBLOCK2 0
- 1994 RETURN 2
- 1996 ACC1
- 1997 BRANCHIFNOT 2001
- 1999 BRANCH 2003
- 2001 RETURN 2
- 2003 GETGLOBAL "List.combine"
- 2005 PUSHGETGLOBALFIELD Pervasives, 2
- 2008 APPTERM1 3
- 2010 RESTART
- 2011 GRAB 1
- 2013 ACC1
- 2014 BRANCHIFNOT 2038
- 2016 ACC1
- 2017 GETFIELD0
- 2018 PUSHACC2
- 2019 GETFIELD1
- 2020 PUSHACC1
- 2021 PUSHENVACC2
- 2022 APPLY1
- 2023 BRANCHIFNOT 2033
- 2025 ACC0
- 2026 PUSHACC3
- 2027 PUSHACC3
- 2028 MAKEBLOCK2 0
- 2030 PUSHOFFSETCLOSURE0
- 2031 APPTERM2 6
- 2033 ACC0
- 2034 PUSHACC3
- 2035 PUSHOFFSETCLOSURE0
- 2036 APPTERM2 6
- 2038 ACC0
- 2039 PUSHENVACC1
- 2040 APPTERM1 3
- 2042 ACC0
- 2043 PUSHENVACC1
- 2044 CLOSUREREC 2, 2011
- 2048 CONST0
- 2049 PUSHACC1
- 2050 APPTERM1 3
- 2052 RESTART
- 2053 GRAB 2
- 2055 ACC1
- 2056 BRANCHIFNOT 2077
- 2058 ACC2
- 2059 BRANCHIFNOT 2084
- 2061 ACC2
- 2062 GETFIELD1
- 2063 PUSHACC2
- 2064 GETFIELD1
- 2065 PUSHACC2
- 2066 PUSHACC5
- 2067 GETFIELD0
- 2068 PUSHACC5
- 2069 GETFIELD0
- 2070 PUSHENVACC1
- 2071 APPLY2
- 2072 MAKEBLOCK2 0
- 2074 PUSHOFFSETCLOSURE0
- 2075 APPTERM3 6
- 2077 ACC2
- 2078 BRANCHIFNOT 2082
- 2080 BRANCH 2084
- 2082 RETURN 3
- 2084 GETGLOBAL "List.rev_map2"
- 2086 PUSHGETGLOBALFIELD Pervasives, 2
- 2089 APPTERM1 4
- 2091 RESTART
- 2092 GRAB 2
- 2094 ACC0
- 2095 CLOSUREREC 1, 2053
- 2099 ACC3
- 2100 PUSHACC3
- 2101 PUSHCONST0
- 2102 PUSHACC3
- 2103 APPTERM3 7
- 2105 RESTART
- 2106 GRAB 1
- 2108 ACC1
- 2109 BRANCHIFNOT 2123
- 2111 ACC1
- 2112 GETFIELD1
- 2113 PUSHACC1
- 2114 PUSHACC3
- 2115 GETFIELD0
- 2116 PUSHENVACC1
- 2117 APPLY1
- 2118 MAKEBLOCK2 0
- 2120 PUSHOFFSETCLOSURE0
- 2121 APPTERM2 4
- 2123 ACC0
- 2124 RETURN 2
- 2126 RESTART
- 2127 GRAB 1
- 2129 ACC0
- 2130 CLOSUREREC 1, 2106
- 2134 ACC2
- 2135 PUSHCONST0
- 2136 PUSHACC2
- 2137 APPTERM2 5
- 2139 CONST0
- 2140 PUSHACC1
- 2141 PUSHENVACC1
- 2142 APPTERM2 3
- 2144 ACC0
- 2145 BRANCHIFNOT 2151
- 2147 ACC0
- 2148 GETFIELD1
- 2149 RETURN 1
- 2151 GETGLOBAL "tl"
- 2153 PUSHGETGLOBALFIELD Pervasives, 3
- 2156 APPTERM1 2
- 2158 ACC0
- 2159 BRANCHIFNOT 2165
- 2161 ACC0
- 2162 GETFIELD0
- 2163 RETURN 1
- 2165 GETGLOBAL "hd"
- 2167 PUSHGETGLOBALFIELD Pervasives, 3
- 2170 APPTERM1 2
- 2172 ACC0
- 2173 PUSHCONST0
- 2174 PUSHENVACC1
- 2175 APPTERM2 3
- 2177 CLOSUREREC 0, 1200
- 2181 ACC0
- 2182 CLOSURE 1, 2172
- 2185 PUSH
- 2186 CLOSURE 0, 2158
- 2189 PUSH
- 2190 CLOSURE 0, 2144
- 2193 PUSH
- 2194 CLOSUREREC 0, 1217
- 2198 GETGLOBALFIELD Pervasives, 16
- 2201 PUSH
- 2202 CLOSUREREC 0, 1259
- 2206 ACC0
- 2207 CLOSURE 1, 2139
- 2210 PUSH
- 2211 CLOSUREREC 0, 1277
- 2215 CLOSUREREC 0, 1294
- 2219 CLOSURE 0, 2127
- 2222 PUSH
- 2223 CLOSUREREC 0, 1316
- 2227 CLOSUREREC 0, 1334
- 2231 CLOSUREREC 0, 1354
- 2235 CLOSUREREC 0, 1374
- 2239 CLOSURE 0, 2092
- 2242 PUSH
- 2243 CLOSUREREC 0, 1415
- 2247 CLOSUREREC 0, 1452
- 2251 CLOSUREREC 0, 1490
- 2255 CLOSUREREC 0, 1530
- 2259 CLOSUREREC 0, 1553
- 2263 CLOSUREREC 0, 1573
- 2267 CLOSUREREC 0, 1613
- 2271 CLOSUREREC 0, 1654
- 2275 CLOSUREREC 0, 1675
- 2279 CLOSUREREC 0, 1695
- 2283 CLOSUREREC 0, 1725
- 2287 CLOSUREREC 0, 1754
- 2291 CLOSUREREC 0, 1776
- 2295 CLOSUREREC 0, 1797
- 2299 CLOSUREREC 0, 1828
- 2303 CLOSUREREC 0, 1858
- 2307 ACC 24
- 2309 CLOSURE 1, 2042
- 2312 PUSHACC 25
- 2314 CLOSUREREC 1, 1928
- 2318 CLOSUREREC 0, 1942
- 2322 CLOSUREREC 0, 1972
- 2326 ACC0
- 2327 PUSHACC2
- 2328 PUSHACC7
- 2329 PUSHACC 9
- 2331 PUSHACC 11
- 2333 PUSHACC 13
- 2335 PUSHACC 15
- 2337 PUSHACC 17
- 2339 PUSHACC 10
- 2341 PUSHACC 12
- 2343 PUSHACC 13
- 2345 PUSHACC 15
- 2347 PUSHACC 23
- 2349 PUSHACC 25
- 2351 PUSHACC 27
- 2353 PUSHACC 29
- 2355 PUSHACC 31
- 2357 PUSHACC 33
- 2359 PUSHACC 35
- 2361 PUSHACC 37
- 2363 PUSHACC 40
- 2365 PUSHACC 42
- 2367 PUSHACC 41
- 2369 PUSHACC 45
- 2371 PUSHACC 47
- 2373 PUSHACC 50
- 2375 PUSHACC 52
- 2377 PUSHACC 51
- 2379 PUSHACC 55
- 2381 PUSHACC 56
- 2383 PUSHACC 59
- 2385 PUSHACC 61
- 2387 PUSHACC 60
- 2389 PUSHACC 64
- 2391 PUSHACC 66
- 2393 PUSHACC 68
- 2395 PUSHACC 70
- 2397 MAKEBLOCK 37, 0
- 2400 POP 36
- 2402 SETGLOBAL List
- 2404 BRANCH 2622
- 2406 CONSTINT 97
- 2408 PUSHACC1
- 2409 GEINT
- 2410 BRANCHIFNOT 2418
- 2412 CONSTINT 122
- 2414 PUSHACC1
- 2415 LEINT
- 2416 BRANCHIF 2442
- 2418 CONSTINT 224
- 2420 PUSHACC1
- 2421 GEINT
- 2422 BRANCHIFNOT 2430
- 2424 CONSTINT 246
- 2426 PUSHACC1
- 2427 LEINT
- 2428 BRANCHIF 2442
- 2430 CONSTINT 248
- 2432 PUSHACC1
- 2433 GEINT
- 2434 BRANCHIFNOT 2447
- 2436 CONSTINT 254
- 2438 PUSHACC1
- 2439 LEINT
- 2440 BRANCHIFNOT 2447
- 2442 ACC0
- 2443 OFFSETINT -32
- 2445 RETURN 1
- 2447 ACC0
- 2448 RETURN 1
- 2450 CONSTINT 65
- 2452 PUSHACC1
- 2453 GEINT
- 2454 BRANCHIFNOT 2462
- 2456 CONSTINT 90
- 2458 PUSHACC1
- 2459 LEINT
- 2460 BRANCHIF 2486
- 2462 CONSTINT 192
- 2464 PUSHACC1
- 2465 GEINT
- 2466 BRANCHIFNOT 2474
- 2468 CONSTINT 214
- 2470 PUSHACC1
- 2471 LEINT
- 2472 BRANCHIF 2486
- 2474 CONSTINT 216
- 2476 PUSHACC1
- 2477 GEINT
- 2478 BRANCHIFNOT 2491
- 2480 CONSTINT 222
- 2482 PUSHACC1
- 2483 LEINT
- 2484 BRANCHIFNOT 2491
- 2486 ACC0
- 2487 OFFSETINT 32
- 2489 RETURN 1
- 2491 ACC0
- 2492 RETURN 1
- 2494 CONSTINT 39
- 2496 PUSHACC1
- 2497 LTINT
- 2498 BRANCHIFNOT 2520
- 2500 CONSTINT 9
- 2502 PUSHACC1
- 2503 EQ
- 2504 BRANCHIFNOT 2510
- 2506 GETGLOBAL "\\t"
- 2508 RETURN 1
- 2510 CONSTINT 13
- 2512 PUSHACC1
- 2513 EQ
- 2514 BRANCHIFNOT 2540
- 2516 GETGLOBAL "\\n"
- 2518 RETURN 1
- 2520 CONSTINT 39
- 2522 PUSHACC1
- 2523 EQ
- 2524 BRANCHIFNOT 2530
- 2526 GETGLOBAL "\\'"
- 2528 RETURN 1
- 2530 CONSTINT 92
- 2532 PUSHACC1
- 2533 EQ
- 2534 BRANCHIFNOT 2540
- 2536 GETGLOBAL "\\\\"
- 2538 RETURN 1
- 2540 ACC0
- 2541 C_CALL1 is_printable
- 2543 BRANCHIFNOT 2555
- 2545 CONST1
- 2546 C_CALL1 create_string
- 2548 PUSHACC1
- 2549 PUSHCONST0
- 2550 PUSHACC2
- 2551 SETSTRINGCHAR
- 2552 ACC0
- 2553 RETURN 2
- 2555 ACC0
- 2556 PUSHCONSTINT 4
- 2558 C_CALL1 create_string
- 2560 PUSHCONSTINT 92
- 2562 PUSHCONST0
- 2563 PUSHACC2
- 2564 SETSTRINGCHAR
- 2565 CONSTINT 100
- 2567 PUSHACC2
- 2568 DIVINT
- 2569 PUSHCONSTINT 48
- 2571 ADDINT
- 2572 PUSHCONST1
- 2573 PUSHACC2
- 2574 SETSTRINGCHAR
- 2575 CONSTINT 10
- 2577 PUSHCONSTINT 10
- 2579 PUSHACC3
- 2580 DIVINT
- 2581 MODINT
- 2582 PUSHCONSTINT 48
- 2584 ADDINT
- 2585 PUSHCONST2
- 2586 PUSHACC2
- 2587 SETSTRINGCHAR
- 2588 CONSTINT 10
- 2590 PUSHACC2
- 2591 MODINT
- 2592 PUSHCONSTINT 48
- 2594 ADDINT
- 2595 PUSHCONST3
- 2596 PUSHACC2
- 2597 SETSTRINGCHAR
- 2598 ACC0
- 2599 RETURN 3
- 2601 CONST0
- 2602 PUSHACC1
- 2603 LTINT
- 2604 BRANCHIF 2612
- 2606 CONSTINT 255
- 2608 PUSHACC1
- 2609 GTINT
- 2610 BRANCHIFNOT 2619
- 2612 GETGLOBAL "Char.chr"
- 2614 PUSHGETGLOBALFIELD Pervasives, 2
- 2617 APPTERM1 2
- 2619 ACC0
- 2620 RETURN 1
- 2622 CLOSURE 0, 2601
- 2625 PUSH
- 2626 CLOSURE 0, 2494
- 2629 PUSH
- 2630 CLOSURE 0, 2450
- 2633 PUSH
- 2634 CLOSURE 0, 2406
- 2637 PUSHACC0
- 2638 PUSHACC2
- 2639 PUSHACC4
- 2640 PUSHACC6
- 2641 MAKEBLOCK 4, 0
- 2644 POP 4
- 2646 SETGLOBAL Char
- 2648 BRANCH 3540
- 2650 RESTART
- 2651 GRAB 3
- 2653 ACC1
- 2654 PUSHACC3
- 2655 GEINT
- 2656 BRANCHIFNOT 2663
- 2658 GETGLOBAL Not_found
- 2660 MAKEBLOCK1 0
- 2662 RAISE
- 2663 ACC3
- 2664 PUSHACC3
- 2665 PUSHACC2
- 2666 GETSTRINGCHAR
- 2667 EQ
- 2668 BRANCHIFNOT 2673
- 2670 ACC2
- 2671 RETURN 4
- 2673 ACC3
- 2674 PUSHACC3
- 2675 OFFSETINT 1
- 2677 PUSHACC3
- 2678 PUSHACC3
- 2679 PUSHOFFSETCLOSURE0
- 2680 APPTERM 4, 8
- 2683 RESTART
- 2684 GRAB 2
- 2686 CONST0
- 2687 PUSHACC2
- 2688 LTINT
- 2689 BRANCHIFNOT 2696
- 2691 GETGLOBAL Not_found
- 2693 MAKEBLOCK1 0
- 2695 RAISE
- 2696 ACC2
- 2697 PUSHACC2
- 2698 PUSHACC2
- 2699 GETSTRINGCHAR
- 2700 EQ
- 2701 BRANCHIFNOT 2706
- 2703 ACC1
- 2704 RETURN 3
- 2706 ACC2
- 2707 PUSHACC2
- 2708 OFFSETINT -1
- 2710 PUSHACC2
- 2711 PUSHOFFSETCLOSURE0
- 2712 APPTERM3 6
- 2714 RESTART
- 2715 GRAB 1
- 2717 ACC1
- 2718 PUSHCONST0
- 2719 PUSHACC2
- 2720 PUSHENVACC1
- 2721 APPTERM3 5
- 2723 RESTART
- 2724 GRAB 2
- 2726 CONST0
- 2727 PUSHACC2
- 2728 LTINT
- 2729 BRANCHIF 2738
- 2731 ACC0
- 2732 C_CALL1 ml_string_length
- 2734 PUSHACC2
- 2735 GEINT
- 2736 BRANCHIFNOT 2745
- 2738 GETGLOBAL "String.rcontains_from"
- 2740 PUSHGETGLOBALFIELD Pervasives, 2
- 2743 APPTERM1 4
- 2745 PUSHTRAP 2756
- 2747 ACC6
- 2748 PUSHACC6
- 2749 PUSHACC6
- 2750 PUSHENVACC1
- 2751 APPLY3
- 2752 CONST1
- 2753 POPTRAP
- 2754 RETURN 3
- 2756 PUSHGETGLOBAL Not_found
- 2758 PUSHACC1
- 2759 GETFIELD0
- 2760 EQ
- 2761 BRANCHIFNOT 2766
- 2763 CONST0
- 2764 RETURN 4
- 2766 ACC0
- 2767 RAISE
- 2768 RESTART
- 2769 GRAB 2
- 2771 CONST0
- 2772 PUSHACC2
- 2773 LTINT
- 2774 BRANCHIF 2783
- 2776 ACC0
- 2777 C_CALL1 ml_string_length
- 2779 PUSHACC2
- 2780 GTINT
- 2781 BRANCHIFNOT 2790
- 2783 GETGLOBAL "String.contains_from"
- 2785 PUSHGETGLOBALFIELD Pervasives, 2
- 2788 APPTERM1 4
- 2790 PUSHTRAP 2811
- 2792 PUSH_RETADDR 2807
- 2794 ACC 9
- 2796 PUSHACC 9
- 2798 PUSHACC 9
- 2800 C_CALL1 ml_string_length
- 2802 PUSHACC 10
- 2804 PUSHENVACC1
- 2805 APPLY 4
- 2807 CONST1
- 2808 POPTRAP
- 2809 RETURN 3
- 2811 PUSHGETGLOBAL Not_found
- 2813 PUSHACC1
- 2814 GETFIELD0
- 2815 EQ
- 2816 BRANCHIFNOT 2821
- 2818 CONST0
- 2819 RETURN 4
- 2821 ACC0
- 2822 RAISE
- 2823 RESTART
- 2824 GRAB 2
- 2826 CONST0
- 2827 PUSHACC2
- 2828 LTINT
- 2829 BRANCHIF 2838
- 2831 ACC0
- 2832 C_CALL1 ml_string_length
- 2834 PUSHACC2
- 2835 GEINT
- 2836 BRANCHIFNOT 2845
- 2838 GETGLOBAL "String.rindex_from"
- 2840 PUSHGETGLOBALFIELD Pervasives, 2
- 2843 APPTERM1 4
- 2845 ACC2
- 2846 PUSHACC2
- 2847 PUSHACC2
- 2848 PUSHENVACC1
- 2849 APPTERM3 6
- 2851 RESTART
- 2852 GRAB 1
- 2854 ACC1
- 2855 PUSHACC1
- 2856 C_CALL1 ml_string_length
- 2858 OFFSETINT -1
- 2860 PUSHACC2
- 2861 PUSHENVACC1
- 2862 APPTERM3 5
- 2864 RESTART
- 2865 GRAB 2
- 2867 CONST0
- 2868 PUSHACC2
- 2869 LTINT
- 2870 BRANCHIF 2879
- 2872 ACC0
- 2873 C_CALL1 ml_string_length
- 2875 PUSHACC2
- 2876 GTINT
- 2877 BRANCHIFNOT 2886
- 2879 GETGLOBAL "String.index_from"
- 2881 PUSHGETGLOBALFIELD Pervasives, 2
- 2884 APPTERM1 4
- 2886 ACC2
- 2887 PUSHACC2
- 2888 PUSHACC2
- 2889 C_CALL1 ml_string_length
- 2891 PUSHACC3
- 2892 PUSHENVACC1
- 2893 APPTERM 4, 7
- 2896 RESTART
- 2897 GRAB 1
- 2899 ACC1
- 2900 PUSHCONST0
- 2901 PUSHACC2
- 2902 C_CALL1 ml_string_length
- 2904 PUSHACC3
- 2905 PUSHENVACC1
- 2906 APPTERM 4, 6
- 2909 ACC0
- 2910 PUSHGETGLOBALFIELD Char, 2
- 2913 PUSHENVACC1
- 2914 APPTERM2 3
- 2916 ACC0
- 2917 PUSHGETGLOBALFIELD Char, 3
- 2920 PUSHENVACC1
- 2921 APPTERM2 3
- 2923 RESTART
- 2924 GRAB 1
- 2926 CONST0
- 2927 PUSHACC2
- 2928 C_CALL1 ml_string_length
- 2930 EQ
- 2931 BRANCHIFNOT 2936
- 2933 ACC1
- 2934 RETURN 2
- 2936 ACC1
- 2937 PUSHENVACC1
- 2938 APPLY1
- 2939 PUSHCONST0
- 2940 PUSHACC3
- 2941 GETSTRINGCHAR
- 2942 PUSHACC2
- 2943 APPLY1
- 2944 PUSHCONST0
- 2945 PUSHACC2
- 2946 SETSTRINGCHAR
- 2947 ACC0
- 2948 RETURN 3
- 2950 ACC0
- 2951 PUSHGETGLOBALFIELD Char, 2
- 2954 PUSHENVACC1
- 2955 APPTERM2 3
- 2957 ACC0
- 2958 PUSHGETGLOBALFIELD Char, 3
- 2961 PUSHENVACC1
- 2962 APPTERM2 3
- 2964 RESTART
- 2965 GRAB 1
- 2967 ACC1
- 2968 C_CALL1 ml_string_length
- 2970 PUSHCONST0
- 2971 PUSHACC1
- 2972 EQ
- 2973 BRANCHIFNOT 2978
- 2975 ACC2
- 2976 RETURN 3
- 2978 ACC0
- 2979 C_CALL1 create_string
- 2981 PUSHCONST0
- 2982 PUSHACC2
- 2983 OFFSETINT -1
- 2985 PUSH
- 2986 BRANCH 3002
- 2988 CHECK_SIGNALS
- 2989 ACC1
- 2990 PUSHACC6
- 2991 GETSTRINGCHAR
- 2992 PUSHACC5
- 2993 APPLY1
- 2994 PUSHACC2
- 2995 PUSHACC4
- 2996 SETSTRINGCHAR
- 2997 ACC1
- 2998 OFFSETINT 1
- 3000 ASSIGN 1
- 3002 ACC0
- 3003 PUSHACC2
- 3004 LEINT
- 3005 BRANCHIF 2988
- 3007 CONST0
- 3008 POP 2
- 3010 ACC0
- 3011 RETURN 4
- 3013 CONST0
- 3014 PUSHCONST0
- 3015 PUSHACC2
- 3016 C_CALL1 ml_string_length
- 3018 OFFSETINT -1
- 3020 PUSH
- 3021 BRANCH 3059
- 3023 CHECK_SIGNALS
- 3024 ACC1
- 3025 PUSHACC4
- 3026 GETSTRINGCHAR
- 3027 PUSHACC0
- 3028 PUSHGETGLOBAL "\000\"\000\000\004\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000"
- 3030 C_CALL2 bitvect_test
- 3032 BRANCHIFNOT 3038
- 3034 CONST0
- 3035 CONST2
- 3036 BRANCH 3048
- 3038 ACC0
- 3039 C_CALL1 is_printable
- 3041 BRANCHIFNOT 3046
- 3043 CONST1
- 3044 BRANCH 3048
- 3046 CONSTINT 4
- 3048 POP 1
- 3050 PUSHACC3
- 3051 ADDINT
- 3052 ASSIGN 2
- 3054 ACC1
- 3055 OFFSETINT 1
- 3057 ASSIGN 1
- 3059 ACC0
- 3060 PUSHACC2
- 3061 LEINT
- 3062 BRANCHIF 3023
- 3064 CONST0
- 3065 POP 2
- 3067 ACC1
- 3068 C_CALL1 ml_string_length
- 3070 PUSHACC1
- 3071 EQ
- 3072 BRANCHIFNOT 3077
- 3074 ACC1
- 3075 RETURN 2
- 3077 ACC0
- 3078 C_CALL1 create_string
- 3080 PUSHCONST0
- 3081 ASSIGN 1
- 3083 CONST0
- 3084 PUSHACC3
- 3085 C_CALL1 ml_string_length
- 3087 OFFSETINT -1
- 3089 PUSH
- 3090 BRANCH 3245
- 3092 CHECK_SIGNALS
- 3093 ACC1
- 3094 PUSHACC5
- 3095 GETSTRINGCHAR
- 3096 PUSHACC0
- 3097 PUSHGETGLOBAL "\000\000\000\000\004\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000"
- 3099 C_CALL2 bitvect_test
- 3101 BRANCHIFNOT 3120
- 3103 CONST0
- 3104 CONSTINT 92
- 3106 PUSHACC5
- 3107 PUSHACC5
- 3108 SETSTRINGCHAR
- 3109 ACC4
- 3110 OFFSETINT 1
- 3112 ASSIGN 4
- 3114 ACC0
- 3115 PUSHACC5
- 3116 PUSHACC5
- 3117 SETSTRINGCHAR
- 3118 BRANCH 3233
- 3120 CONSTINT 9
- 3122 PUSHACC1
- 3123 EQ
- 3124 BRANCHIFNOT 3143
- 3126 CONSTINT 92
- 3128 PUSHACC5
- 3129 PUSHACC5
- 3130 SETSTRINGCHAR
- 3131 ACC4
- 3132 OFFSETINT 1
- 3134 ASSIGN 4
- 3136 CONSTINT 116
- 3138 PUSHACC5
- 3139 PUSHACC5
- 3140 SETSTRINGCHAR
- 3141 BRANCH 3233
- 3143 CONSTINT 13
- 3145 PUSHACC1
- 3146 EQ
- 3147 BRANCHIFNOT 3166
- 3149 CONSTINT 92
- 3151 PUSHACC5
- 3152 PUSHACC5
- 3153 SETSTRINGCHAR
- 3154 ACC4
- 3155 OFFSETINT 1
- 3157 ASSIGN 4
- 3159 CONSTINT 110
- 3161 PUSHACC5
- 3162 PUSHACC5
- 3163 SETSTRINGCHAR
- 3164 BRANCH 3233
- 3166 ACC0
- 3167 C_CALL1 is_printable
- 3169 BRANCHIFNOT 3177
- 3171 ACC0
- 3172 PUSHACC5
- 3173 PUSHACC5
- 3174 SETSTRINGCHAR
- 3175 BRANCH 3233
- 3177 ACC0
- 3178 PUSHCONSTINT 92
- 3180 PUSHACC6
- 3181 PUSHACC6
- 3182 SETSTRINGCHAR
- 3183 ACC5
- 3184 OFFSETINT 1
- 3186 ASSIGN 5
- 3188 CONSTINT 100
- 3190 PUSHACC1
- 3191 DIVINT
- 3192 PUSHCONSTINT 48
- 3194 ADDINT
- 3195 PUSHACC6
- 3196 PUSHACC6
- 3197 SETSTRINGCHAR
- 3198 ACC5
- 3199 OFFSETINT 1
- 3201 ASSIGN 5
- 3203 CONSTINT 10
- 3205 PUSHCONSTINT 10
- 3207 PUSHACC2
- 3208 DIVINT
- 3209 MODINT
- 3210 PUSHCONSTINT 48
- 3212 ADDINT
- 3213 PUSHACC6
- 3214 PUSHACC6
- 3215 SETSTRINGCHAR
- 3216 ACC5
- 3217 OFFSETINT 1
- 3219 ASSIGN 5
- 3221 CONSTINT 10
- 3223 PUSHACC1
- 3224 MODINT
- 3225 PUSHCONSTINT 48
- 3227 ADDINT
- 3228 PUSHACC6
- 3229 PUSHACC6
- 3230 SETSTRINGCHAR
- 3231 POP 1
- 3233 POP 1
- 3235 ACC3
- 3236 OFFSETINT 1
- 3238 ASSIGN 3
- 3240 ACC1
- 3241 OFFSETINT 1
- 3243 ASSIGN 1
- 3245 ACC0
- 3246 PUSHACC2
- 3247 LEINT
- 3248 BRANCHIF 3092
- 3250 CONST0
- 3251 POP 2
- 3253 ACC0
- 3254 RETURN 3
- 3256 ENVACC1
- 3257 C_CALL1 ml_string_length
- 3259 PUSHENVACC3
- 3260 GETFIELD0
- 3261 PUSHENVACC2
- 3262 PUSHCONST0
- 3263 PUSHENVACC1
- 3264 C_CALL5 blit_string
- 3266 ENVACC1
- 3267 C_CALL1 ml_string_length
- 3269 PUSHENVACC3
- 3270 GETFIELD0
- 3271 ADDINT
- 3272 PUSHENVACC3
- 3273 SETFIELD0
- 3274 ACC0
- 3275 C_CALL1 ml_string_length
- 3277 PUSHENVACC3
- 3278 GETFIELD0
- 3279 PUSHENVACC2
- 3280 PUSHCONST0
- 3281 PUSHACC4
- 3282 C_CALL5 blit_string
- 3284 ACC0
- 3285 C_CALL1 ml_string_length
- 3287 PUSHENVACC3
- 3288 GETFIELD0
- 3289 ADDINT
- 3290 PUSHENVACC3
- 3291 SETFIELD0
- 3292 RETURN 1
- 3294 ENVACC1
- 3295 OFFSETREF 1
- 3297 ACC0
- 3298 C_CALL1 ml_string_length
- 3300 PUSHENVACC2
- 3301 GETFIELD0
- 3302 ADDINT
- 3303 PUSHENVACC2
- 3304 SETFIELD0
- 3305 RETURN 1
- 3307 RESTART
- 3308 GRAB 1
- 3310 ACC1
- 3311 BRANCHIFNOT 3374
- 3313 ACC1
- 3314 GETFIELD0
- 3315 PUSHCONST0
- 3316 MAKEBLOCK1 0
- 3318 PUSHCONST0
- 3319 MAKEBLOCK1 0
- 3321 PUSHACC4
- 3322 PUSHACC1
- 3323 PUSHACC3
- 3324 CLOSURE 2, 3294
- 3327 PUSHGETGLOBALFIELD List, 9
- 3330 APPLY2
- 3331 ACC1
- 3332 GETFIELD0
- 3333 OFFSETINT -1
- 3335 PUSHACC4
- 3336 C_CALL1 ml_string_length
- 3338 MULINT
- 3339 PUSHACC1
- 3340 GETFIELD0
- 3341 ADDINT
- 3342 C_CALL1 create_string
- 3344 PUSHACC3
- 3345 C_CALL1 ml_string_length
- 3347 PUSHCONST0
- 3348 PUSHACC2
- 3349 PUSHCONST0
- 3350 PUSHACC7
- 3351 C_CALL5 blit_string
- 3353 ACC3
- 3354 C_CALL1 ml_string_length
- 3356 MAKEBLOCK1 0
- 3358 PUSHACC6
- 3359 GETFIELD1
- 3360 PUSHACC1
- 3361 PUSHACC3
- 3362 PUSHACC 8
- 3364 CLOSURE 3, 3256
- 3367 PUSHGETGLOBALFIELD List, 9
- 3370 APPLY2
- 3371 ACC1
- 3372 RETURN 7
- 3374 GETGLOBAL ""
- 3376 RETURN 2
- 3378 RESTART
- 3379 GRAB 4
- 3381 CONST0
- 3382 PUSHACC5
- 3383 LTINT
- 3384 BRANCHIF 3414
- 3386 CONST0
- 3387 PUSHACC2
- 3388 LTINT
- 3389 BRANCHIF 3414
- 3391 ACC0
- 3392 C_CALL1 ml_string_length
- 3394 PUSHACC5
- 3395 PUSHACC3
- 3396 ADDINT
- 3397 GTINT
- 3398 BRANCHIF 3414
- 3400 CONST0
- 3401 PUSHACC4
- 3402 LTINT
- 3403 BRANCHIF 3414
- 3405 ACC2
- 3406 C_CALL1 ml_string_length
- 3408 PUSHACC5
- 3409 PUSHACC5
- 3410 ADDINT
- 3411 GTINT
- 3412 BRANCHIFNOT 3421
- 3414 GETGLOBAL "String.blit"
- 3416 PUSHGETGLOBALFIELD Pervasives, 2
- 3419 APPTERM1 6
- 3421 ACC4
- 3422 PUSHACC4
- 3423 PUSHACC4
- 3424 PUSHACC4
- 3425 PUSHACC4
- 3426 C_CALL5 blit_string
- 3428 RETURN 5
- 3430 RESTART
- 3431 GRAB 3
- 3433 CONST0
- 3434 PUSHACC2
- 3435 LTINT
- 3436 BRANCHIF 3452
- 3438 CONST0
- 3439 PUSHACC3
- 3440 LTINT
- 3441 BRANCHIF 3452
- 3443 ACC0
- 3444 C_CALL1 ml_string_length
- 3446 PUSHACC3
- 3447 PUSHACC3
- 3448 ADDINT
- 3449 GTINT
- 3450 BRANCHIFNOT 3459
- 3452 GETGLOBAL "String.fill"
- 3454 PUSHGETGLOBALFIELD Pervasives, 2
- 3457 APPTERM1 5
- 3459 ACC3
- 3460 PUSHACC3
- 3461 PUSHACC3
- 3462 PUSHACC3
- 3463 C_CALL4 fill_string
- 3465 RETURN 4
- 3467 RESTART
- 3468 GRAB 2
- 3470 CONST0
- 3471 PUSHACC2
- 3472 LTINT
- 3473 BRANCHIF 3489
- 3475 CONST0
- 3476 PUSHACC3
- 3477 LTINT
- 3478 BRANCHIF 3489
- 3480 ACC0
- 3481 C_CALL1 ml_string_length
- 3483 PUSHACC3
- 3484 PUSHACC3
- 3485 ADDINT
- 3486 GTINT
- 3487 BRANCHIFNOT 3496
- 3489 GETGLOBAL "String.sub"
- 3491 PUSHGETGLOBALFIELD Pervasives, 2
- 3494 APPTERM1 4
- 3496 ACC2
- 3497 C_CALL1 create_string
- 3499 PUSHACC3
- 3500 PUSHCONST0
- 3501 PUSHACC2
- 3502 PUSHACC5
- 3503 PUSHACC5
- 3504 C_CALL5 blit_string
- 3506 ACC0
- 3507 RETURN 4
- 3509 ACC0
- 3510 C_CALL1 ml_string_length
- 3512 PUSHACC0
- 3513 C_CALL1 create_string
- 3515 PUSHACC1
- 3516 PUSHCONST0
- 3517 PUSHACC2
- 3518 PUSHCONST0
- 3519 PUSHACC6
- 3520 C_CALL5 blit_string
- 3522 ACC0
- 3523 RETURN 3
- 3525 RESTART
- 3526 GRAB 1
- 3528 ACC0
- 3529 C_CALL1 create_string
- 3531 PUSHACC2
- 3532 PUSHACC2
- 3533 PUSHCONST0
- 3534 PUSHACC3
- 3535 C_CALL4 fill_string
- 3537 ACC0
- 3538 RETURN 3
- 3540 CLOSURE 0, 3526
- 3543 PUSH
- 3544 CLOSURE 0, 3509
- 3547 PUSH
- 3548 CLOSURE 0, 3468
- 3551 PUSH
- 3552 CLOSURE 0, 3431
- 3555 PUSH
- 3556 CLOSURE 0, 3379
- 3559 PUSH
- 3560 CLOSURE 0, 3308
- 3563 PUSH
- 3564 CLOSURE 0, 3013
- 3567 PUSH
- 3568 CLOSURE 0, 2965
- 3571 PUSHACC0
- 3572 CLOSURE 1, 2957
- 3575 PUSHACC1
- 3576 CLOSURE 1, 2950
- 3579 PUSHACC 8
- 3581 CLOSURE 1, 2924
- 3584 PUSHACC0
- 3585 CLOSURE 1, 2916
- 3588 PUSHACC1
- 3589 CLOSURE 1, 2909
- 3592 PUSH
- 3593 CLOSUREREC 0, 2651
- 3597 ACC0
- 3598 CLOSURE 1, 2897
- 3601 PUSHACC1
- 3602 CLOSURE 1, 2865
- 3605 PUSH
- 3606 CLOSUREREC 0, 2684
- 3610 ACC0
- 3611 CLOSURE 1, 2852
- 3614 PUSHACC1
- 3615 CLOSURE 1, 2824
- 3618 PUSHACC5
- 3619 CLOSURE 1, 2769
- 3622 PUSHACC3
- 3623 CLOSURE 1, 2724
- 3626 PUSHACC1
- 3627 CLOSURE 1, 2715
- 3630 PUSHACC 9
- 3632 PUSHACC 11
- 3634 PUSHACC 14
- 3636 PUSHACC 16
- 3638 PUSHACC5
- 3639 PUSHACC7
- 3640 PUSHACC6
- 3641 PUSHACC 10
- 3643 PUSHACC 14
- 3645 PUSHACC 13
- 3647 PUSHACC 17
- 3649 PUSHACC 26
- 3651 PUSHACC 28
- 3653 PUSHACC 30
- 3655 PUSHACC 32
- 3657 PUSHACC 34
- 3659 PUSHACC 36
- 3661 PUSHACC 38
- 3663 MAKEBLOCK 18, 0
- 3666 POP 22
- 3668 SETGLOBAL String
- 3670 CONST0
- 3671 C_CALL1 gc_stat
- 3673 GETGLOBAL ""
- 3675 PUSHCONSTINT 20
- 3677 C_CALL2 make_vect
- 3679 PUSHCONSTINT 20
- 3681 C_CALL1 weak_create
- 3683 PUSHCONST0
- 3684 PUSHCONSTINT 19
- 3686 PUSH
- 3687 BRANCH 3715
- 3689 CHECK_SIGNALS
- 3690 CONSTINT 115
- 3692 PUSHCONSTINT 20
- 3694 PUSHGETGLOBALFIELD String, 0
- 3697 APPLY2
- 3698 PUSHACC2
- 3699 PUSHACC5
- 3700 SETVECTITEM
- 3701 ACC1
- 3702 PUSHACC4
- 3703 GETVECTITEM
- 3704 MAKEBLOCK1 0
- 3706 PUSHACC2
- 3707 PUSHACC4
- 3708 C_CALL3 weak_set
- 3710 ACC1
- 3711 OFFSETINT 1
- 3713 ASSIGN 1
- 3715 ACC0
- 3716 PUSHACC2
- 3717 LEINT
- 3718 BRANCHIF 3689
- 3720 CONST0
- 3721 POP 2
- 3723 CONST0
- 3724 C_CALL1 gc_full_major
- 3726 CONST0
- 3727 PUSHCONSTINT 19
- 3729 PUSH
- 3730 BRANCH 3753
- 3732 CHECK_SIGNALS
- 3733 ACC1
- 3734 PUSHACC3
- 3735 C_CALL2 weak_get
- 3737 PUSHACC0
- 3738 BRANCHIF 3745
- 3740 GETGLOBAL Not_found
- 3742 MAKEBLOCK1 0
- 3744 RAISE
- 3745 CONST0
- 3746 POP 1
- 3748 ACC1
- 3749 OFFSETINT 1
- 3751 ASSIGN 1
- 3753 ACC0
- 3754 PUSHACC2
- 3755 LEINT
- 3756 BRANCHIF 3732
- 3758 CONST0
- 3759 POP 2
- 3761 CONST0
- 3762 PUSHCONSTINT 19
- 3764 PUSH
- 3765 BRANCH 3785
- 3767 CHECK_SIGNALS
- 3768 CONST0
- 3769 PUSHCONST2
- 3770 PUSHACC3
- 3771 MODINT
- 3772 EQ
- 3773 BRANCHIFNOT 3780
- 3775 GETGLOBAL ""
- 3777 PUSHACC2
- 3778 PUSHACC5
- 3779 SETVECTITEM
- 3780 ACC1
- 3781 OFFSETINT 1
- 3783 ASSIGN 1
- 3785 ACC0
- 3786 PUSHACC2
- 3787 LEINT
- 3788 BRANCHIF 3767
- 3790 CONST0
- 3791 POP 2
- 3793 CONST0
- 3794 C_CALL1 gc_full_major
- 3796 CONST0
- 3797 PUSHCONSTINT 19
- 3799 PUSH
- 3800 BRANCH 3854
- 3802 CHECK_SIGNALS
- 3803 ACC1
- 3804 PUSHACC3
- 3805 C_CALL2 weak_get
- 3807 PUSHACC0
- 3808 BRANCHIFNOT 3832
- 3810 CONST1
- 3811 PUSHCONST2
- 3812 PUSHACC4
- 3813 MODINT
- 3814 EQ
- 3815 BRANCHIFNOT 3842
- 3817 CONSTINT 115
- 3819 PUSHCONSTINT 5
- 3821 PUSHACC2
- 3822 GETFIELD0
- 3823 GETSTRINGCHAR
- 3824 NEQ
- 3825 BRANCHIFNOT 3847
- 3827 GETGLOBAL Not_found
- 3829 MAKEBLOCK1 0
- 3831 RAISE
- 3832 CONST0
- 3833 PUSHCONST2
- 3834 PUSHACC4
- 3835 MODINT
- 3836 EQ
- 3837 BRANCHIFNOT 3842
- 3839 CONST0
- 3840 BRANCH 3847
- 3842 GETGLOBAL Not_found
- 3844 MAKEBLOCK1 0
- 3846 RAISE
- 3847 POP 1
- 3849 ACC1
- 3850 OFFSETINT 1
- 3852 ASSIGN 1
- 3854 ACC0
- 3855 PUSHACC2
- 3856 LEINT
- 3857 BRANCHIF 3802
- 3859 CONST0
- 3860 POP 4
- 3862 ATOM0
- 3863 SETGLOBAL T350-heapcheck
- 3865 STOP
-**)
diff --git a/test/testinterp/t360-stacks-1.ml b/test/testinterp/t360-stacks-1.ml
deleted file mode 100644
index 100fbabb2b..0000000000
--- a/test/testinterp/t360-stacks-1.ml
+++ /dev/null
@@ -1,43 +0,0 @@
-open Lib;;
-let rec f n =
- if n <= 0 then 12
- else 1 + f (n-1)
-in
-if f 30000 <> 30012 then raise Not_found
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 29
- 11 CONST0
- 12 PUSHACC1
- 13 LEINT
- 14 BRANCHIFNOT 20
- 16 CONSTINT 12
- 18 RETURN 1
- 20 ACC0
- 21 OFFSETINT -1
- 23 PUSHOFFSETCLOSURE0
- 24 APPLY1
- 25 PUSHCONST1
- 26 ADDINT
- 27 RETURN 1
- 29 CLOSUREREC 0, 11
- 33 CONSTINT 30012
- 35 PUSHCONSTINT 30000
- 37 PUSHACC2
- 38 APPLY1
- 39 NEQ
- 40 BRANCHIFNOT 47
- 42 GETGLOBAL Not_found
- 44 MAKEBLOCK1 0
- 46 RAISE
- 47 POP 1
- 49 ATOM0
- 50 SETGLOBAL T360-stacks-1
- 52 STOP
-**)
diff --git a/test/testinterp/t360-stacks-2.ml b/test/testinterp/t360-stacks-2.ml
deleted file mode 100644
index 8d13c7d7fc..0000000000
--- a/test/testinterp/t360-stacks-2.ml
+++ /dev/null
@@ -1,54 +0,0 @@
-open Lib;;
-let rec f n =
- if n <= 0 then 12
- else 1 + f (n-1)
-in
-try
- ignore (f 3000000);
- raise Not_found
-with Stack_overflow -> ()
-;;
-
-(**
- 0 CONSTINT 42
- 2 PUSHACC0
- 3 MAKEBLOCK1 0
- 5 POP 1
- 7 SETGLOBAL Lib
- 9 BRANCH 29
- 11 CONST0
- 12 PUSHACC1
- 13 LEINT
- 14 BRANCHIFNOT 20
- 16 CONSTINT 12
- 18 RETURN 1
- 20 ACC0
- 21 OFFSETINT -1
- 23 PUSHOFFSETCLOSURE0
- 24 APPLY1
- 25 PUSHCONST1
- 26 ADDINT
- 27 RETURN 1
- 29 CLOSUREREC 0, 11
- 33 PUSHTRAP 44
- 35 CONSTINT 3000000
- 37 PUSHACC5
- 38 APPLY1
- 39 GETGLOBAL Not_found
- 41 MAKEBLOCK1 0
- 43 RAISE
- 44 PUSHGETGLOBAL Stack_overflow
- 46 PUSHACC1
- 47 GETFIELD0
- 48 EQ
- 49 BRANCHIFNOT 54
- 51 CONST0
- 52 BRANCH 56
- 54 ACC0
- 55 RAISE
- 56 POP 1
- 58 POP 1
- 60 ATOM0
- 61 SETGLOBAL T360-stacks-2
- 63 STOP
-**)
diff --git a/testasmcomp/.cvsignore b/testasmcomp/.cvsignore
deleted file mode 100644
index 76174b53d3..0000000000
--- a/testasmcomp/.cvsignore
+++ /dev/null
@@ -1,5 +0,0 @@
-codegen
-parsecmm.ml
-parsecmm.mli
-lexcmm.ml
-*.out
diff --git a/testasmcomp/.depend b/testasmcomp/.depend
deleted file mode 100644
index 282114bc24..0000000000
--- a/testasmcomp/.depend
+++ /dev/null
@@ -1,17 +0,0 @@
-lexcmm.cmi: parsecmm.cmi
-parsecmm.cmi: ../asmcomp/cmm.cmi
-parsecmmaux.cmi: ../typing/ident.cmi
-lexcmm.cmo: ../utils/misc.cmi parsecmm.cmi lexcmm.cmi
-lexcmm.cmx: ../utils/misc.cmx parsecmm.cmx lexcmm.cmi
-main.cmo: ../asmcomp/asmgen.cmi ../utils/clflags.cmo ../asmcomp/compilenv.cmi \
- ../asmcomp/emit.cmi lexcmm.cmi parsecmm.cmi parsecmmaux.cmi \
- ../asmcomp/printmach.cmi
-main.cmx: ../asmcomp/asmgen.cmx ../utils/clflags.cmx ../asmcomp/compilenv.cmx \
- ../asmcomp/emit.cmx lexcmm.cmx parsecmm.cmx parsecmmaux.cmx \
- ../asmcomp/printmach.cmx
-parsecmm.cmo: ../asmcomp/arch.cmo ../asmcomp/cmm.cmi ../utils/misc.cmi \
- parsecmmaux.cmi parsecmm.cmi
-parsecmm.cmx: ../asmcomp/arch.cmx ../asmcomp/cmm.cmx ../utils/misc.cmx \
- parsecmmaux.cmx parsecmm.cmi
-parsecmmaux.cmo: ../typing/ident.cmi parsecmmaux.cmi
-parsecmmaux.cmx: ../typing/ident.cmx parsecmmaux.cmi
diff --git a/testasmcomp/Makefile b/testasmcomp/Makefile
deleted file mode 100644
index a87b934451..0000000000
--- a/testasmcomp/Makefile
+++ /dev/null
@@ -1,159 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-include ../config/Makefile
-
-CAMLC=../boot/ocamlrun ../boot/ocamlc -I ../boot
-COMPFLAGS=$(INCLUDES) -g
-LINKFLAGS=-g
-CAMLYACC=../boot/ocamlyacc
-YACCFLAGS=
-CAMLLEX=../boot/ocamlrun ../boot/ocamllex
-CAMLDEP=../boot/ocamlrun ../tools/ocamldep
-DEPFLAGS=$(INCLUDES)
-CAMLRUN=../boot/ocamlrun
-
-CODEGEN=./codegen
-CC=$(NATIVECC)
-CFLAGS=$(NATIVECCCOMPOPTS) -g
-
-PROGS=fib.out tak.out quicksort.out quicksort2.out soli.out integr.out \
- arith.out checkbound.out
-
-all: codegen $(PROGS)
-
-INCLUDES=-I ../utils -I ../typing -I ../asmcomp
-
-OTHEROBJS=../utils/misc.cmo ../utils/config.cmo ../utils/tbl.cmo \
- ../utils/clflags.cmo ../utils/ccomp.cmo \
- ../utils/config.cmo ../utils/clflags.cmo ../utils/warnings.cmo \
- ../utils/consistbl.cmo \
- ../parsing/linenum.cmo ../parsing/location.cmo \
- ../typing/ident.cmo ../typing/path.cmo ../typing/types.cmo \
- ../typing/btype.cmo ../typing/subst.cmo ../typing/primitive.cmo \
- ../typing/predef.cmo ../typing/datarepr.cmo ../typing/env.cmo \
- ../bytecomp/lambda.cmo ../bytecomp/switch.cmo \
- ../asmcomp/arch.cmo ../asmcomp/cmm.cmo ../asmcomp/printcmm.cmo \
- ../asmcomp/clambda.cmo ../asmcomp/compilenv.cmo \
- ../asmcomp/reg.cmo ../asmcomp/mach.cmo ../asmcomp/proc.cmo \
- ../asmcomp/closure.cmo ../asmcomp/cmmgen.cmo \
- ../asmcomp/printmach.cmo \
- ../asmcomp/selectgen.cmo ../asmcomp/selection.cmo ../asmcomp/comballoc.cmo \
- ../asmcomp/liveness.cmo ../asmcomp/spill.cmo ../asmcomp/split.cmo \
- ../asmcomp/interf.cmo ../asmcomp/coloring.cmo \
- ../asmcomp/reloadgen.cmo ../asmcomp/reload.cmo \
- ../asmcomp/linearize.cmo ../asmcomp/schedgen.cmo ../asmcomp/scheduling.cmo \
- ../asmcomp/printlinear.cmo ../asmcomp/emitaux.cmo \
- ../asmcomp/emit.cmo ../asmcomp/asmgen.cmo
-
-OBJS=parsecmmaux.cmo parsecmm.cmo lexcmm.cmo main.cmo
-
-codegen: $(OTHEROBJS) $(OBJS)
- $(CAMLC) $(LINKFLAGS) -o codegen $(OTHEROBJS) $(OBJS)
-clean::
- rm -f codegen
-
-# The parser
-
-parsecmm.mli parsecmm.ml: parsecmm.mly
- $(CAMLYACC) $(YACCFLAGS) parsecmm.mly
-
-clean::
- rm -f parsecmm.mli parsecmm.ml parsecmm.output
-
-beforedepend:: parsecmm.mli parsecmm.ml
-
-# The lexer
-
-lexcmm.ml: lexcmm.mll
- $(CAMLLEX) lexcmm.mll
-
-clean::
- rm -f lexcmm.ml
-
-beforedepend:: lexcmm.ml
-
-# The test programs
-
-$(PROGS:.out=.o): codegen
-
-fib.out: main.c fib.o $(ARCH).o
- $(CC) $(CFLAGS) -o fib.out -DINT_INT -DFUN=fib main.c fib.o $(ARCH).o
-
-tak.out: main.c tak.o $(ARCH).o
- $(CC) $(CFLAGS) -o tak.out -DUNIT_INT -DFUN=takmain main.c tak.o $(ARCH).o
-
-quicksort.out: main.c quicksort.o $(ARCH).o
- $(CC) $(CFLAGS) -o quicksort.out -DSORT -DFUN=quicksort main.c quicksort.o $(ARCH).o
-
-quicksort2.out: main.c quicksort2.o $(ARCH).o
- $(CC) $(CFLAGS) -o quicksort2.out -DSORT -DFUN=quicksort main.c quicksort2.o $(ARCH).o
-
-soli.out: main.c soli.o $(ARCH).o
- $(CC) $(CFLAGS) -o soli.out -DUNIT_INT -DFUN=solitaire main.c soli.o $(ARCH).o
-
-integr.out: main.c integr.o $(ARCH).o
- $(CC) $(CFLAGS) -o integr.out -DINT_FLOAT -DFUN=test main.c integr.o $(ARCH).o
-
-tagged-fib.out: main.c tagged-fib.o $(ARCH).o
- $(CC) $(CFLAGS) -o tagged-fib.out -DINT_INT -DFUN=fib main.c tagged-fib.o $(ARCH).o
-
-tagged-tak.out: main.c tagged-tak.o $(ARCH).o
- $(CC) $(CFLAGS) -o tagged-tak.out -DUNIT_INT -DFUN=takmain main.c tagged-tak.o $(ARCH).o
-
-tagged-quicksort.out: main.c tagged-quicksort.o $(ARCH).o
- $(CC) $(CFLAGS) -o tagged-quicksort.out -DSORT -DFUN=quicksort main.c tagged-quicksort.o $(ARCH).o
-
-tagged-integr.out: main.c tagged-integr.o $(ARCH).o
- $(CC) $(CFLAGS) -o tagged-integr.out -DINT_FLOAT -DFUN=test main.c tagged-integr.o $(ARCH).o
-
-arith.out: mainarith.c arith.o $(ARCH).o
- $(CC) $(CFLAGS) -o arith.out mainarith.c arith.o $(ARCH).o
-
-checkbound.out: main.c checkbound.o $(ARCH).o
- $(CC) $(CFLAGS) -o checkbound.out -DCHECKBOUND main.c checkbound.o $(ARCH).o
-
-# The runtime environment
-
-power.o: power-$(SYSTEM).o
- cp power-$(SYSTEM).o power.o
-
-.SUFFIXES:
-.SUFFIXES: .cmm .c .o .S .ml .mli .cmo .cmi .s
-
-.ml.cmo:
- $(CAMLC) $(COMPFLAGS) -c $<
-
-.mli.cmi:
- $(CAMLC) $(COMPFLAGS) -c $<
-
-.cmm.o:
- $(CAMLRUN) $(CODEGEN) $*.cmm > $*.s
- $(AS) $(ASFLAGS) -o $*.o $*.s
-
-.S.o:
- $(ASPP) $(ASPPFLAGS) -o $*.o $*.S
-
-.s.o:
- $(ASPP) $(ASPPFLAGS) -o $*.o $*.s
-
-clean::
- rm -f *.out *.cm[io] *.s *.o *~
-
-$(PROGS:.out=.o): $(CODEGEN)
-
-depend: beforedepend
- $(CAMLDEP) $(DEPFLAGS) *.mli *.ml > .depend
-
-include .depend
diff --git a/testasmcomp/alpha.S b/testasmcomp/alpha.S
deleted file mode 100644
index d8851065c3..0000000000
--- a/testasmcomp/alpha.S
+++ /dev/null
@@ -1,62 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
- .globl call_gen_code
- .ent call_gen_code
-
-call_gen_code:
- lda $sp, -80($sp)
- stq $26, 0($sp)
- stq $9, 8($sp)
- stq $10, 16($sp)
- stq $11, 24($sp)
- stq $12, 32($sp)
- stt $f2, 40($sp)
- stt $f3, 48($sp)
- stt $f4, 56($sp)
- stt $f5, 64($sp)
- mov $16, $27
- mov $17, $16
- mov $18, $17
- mov $19, $18
- mov $20, $19
- jsr ($27)
- ldq $26, 0($sp)
- ldq $9, 8($sp)
- ldq $10, 16($sp)
- ldq $11, 24($sp)
- ldq $12, 32($sp)
- ldt $f2, 40($sp)
- ldt $f3, 48($sp)
- ldt $f4, 56($sp)
- ldt $f5, 64($sp)
- lda $sp, 80($sp)
- ret ($26)
-
- .end call_gen_code
-
- .globl caml_c_call
- .ent caml_c_call
-caml_c_call:
- lda $sp, -16($sp)
- stq $26, 0($sp)
- stq $gp, 8($sp)
- mov $25, $27
- jsr ($25)
- ldq $26, 0($sp)
- ldq $gp, 8($sp)
- lda $sp, 16($sp)
- ret ($26)
-
- .end caml_c_call
diff --git a/testasmcomp/amd64.S b/testasmcomp/amd64.S
deleted file mode 100644
index ff72e97da9..0000000000
--- a/testasmcomp/amd64.S
+++ /dev/null
@@ -1,53 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 2000 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
- .globl call_gen_code
- .align 16
-call_gen_code:
- pushq %rbx
- pushq %rbp
- pushq %r12
- pushq %r13
- pushq %r14
- pushq %r15
- movq %rdi, %r10
- movq %rsi, %rax
- movq %rdx, %rbx
- movq %rcx, %rdi
- movq %r8, %rsi
- call *%r10
- popq %r15
- popq %r14
- popq %r13
- popq %r12
- popq %rbp
- popq %rbx
- ret
-
- .globl caml_c_call
- .align 16
-caml_c_call:
- jmp *%rax
-
- .section .rodata.cst8,"aM",@progbits,8
- .globl caml_negf_mask
- .align 16
-caml_negf_mask:
- .quad 0x8000000000000000, 0
- .globl caml_absf_mask
- .align 16
-caml_absf_mask:
- .quad 0x7FFFFFFFFFFFFFFF, 0
-
- .comm young_limit, 8
diff --git a/testasmcomp/arith.cmm b/testasmcomp/arith.cmm
deleted file mode 100644
index f4efefdbef..0000000000
--- a/testasmcomp/arith.cmm
+++ /dev/null
@@ -1,222 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Regression test for arithmetic instructions *)
-
-(function "testarith" ()
- (let r "R"
- (let d "D"
- (let x (load int "X")
- (let y (load int "Y")
- (let f (load float "F")
- (let g (load float "G")
- (addraset r 0 0)
- (addraset r 1 1)
- (addraset r 2 -1)
- (addraset r 3 256)
- (addraset r 4 65536)
- (addraset r 5 16777216)
- (addraset r 6 -256)
- (addraset r 7 -65536)
- (addraset r 8 -16777216)
-
- (addraset r 9 (+ x y))
- (addraset r 10 (+ x 1))
- (addraset r 11 (+ x -1))
-
- (addraset r 12 (+a "R" 8))
- (addraset r 13 (+a "R" y))
-
- (addraset r 14 (- x y))
- (addraset r 15 (- x 1))
- (addraset r 16 (- x -1))
-
- (addraset r 17 (-a "R" 8))
- (addraset r 18 (-a "R" y))
-
- (addraset r 19 ( * x 2))
- (addraset r 20 ( * 2 x))
- (addraset r 21 ( * x 16))
- (addraset r 22 ( * 16 x))
- (addraset r 23 ( * x 12345))
- (addraset r 24 ( * 12345 x))
- (addraset r 25 ( * x y))
-
- (addraset r 26 (/ x 2))
- (addraset r 27 (/ x 16))
- (addraset r 28 (/ x 7))
- (addraset r 29 (if (!= y 0) (/ x y) 0))
-
- (addraset r 30 (mod x 2))
- (addraset r 31 (mod x 16))
- (addraset r 32 (if (!= y 0) (mod x y) 0))
-
- (addraset r 33 (and x y))
- (addraset r 34 (and x 3))
- (addraset r 35 (and 3 x))
-
- (addraset r 36 (or x y))
- (addraset r 37 (or x 3))
- (addraset r 38 (or 3 x))
-
- (addraset r 39 (xor x y))
- (addraset r 40 (xor x 3))
- (addraset r 41 (xor 3 x))
-
- (addraset r 42 (<< x y))
- (addraset r 43 (<< x 1))
- (addraset r 44 (<< x 8))
-
- (addraset r 45 (>>u x y))
- (addraset r 46 (>>u x 1))
- (addraset r 47 (>>u x 8))
-
- (addraset r 48 (>>s x y))
- (addraset r 49 (>>s x 1))
- (addraset r 50 (>>s x 8))
-
- (addraset r 51 (== x y))
- (addraset r 52 (!= x y))
- (addraset r 53 (< x y))
- (addraset r 54 (> x y))
- (addraset r 55 (<= x y))
- (addraset r 56 (>= x y))
- (addraset r 57 (== x 1))
- (addraset r 58 (!= x 1))
- (addraset r 59 (< x 1))
- (addraset r 60 (> x 1))
- (addraset r 61 (<= x 1))
- (addraset r 62 (>= x 1))
-
- (addraset r 63 (==a x y))
- (addraset r 64 (!=a x y))
- (addraset r 65 (<a x y))
- (addraset r 66 (>a x y))
- (addraset r 67 (<=a x y))
- (addraset r 68 (>=a x y))
- (addraset r 69 (==a x 1))
- (addraset r 70 (!=a x 1))
- (addraset r 71 (<a x 1))
- (addraset r 72 (>a x 1))
- (addraset r 73 (<=a x 1))
- (addraset r 74 (>=a x 1))
-
- (addraset r 75 (+ x (<< y 1)))
- (addraset r 76 (+ x (<< y 2)))
- (addraset r 77 (+ x (<< y 3)))
- (addraset r 78 (- x (<< y 1)))
- (addraset r 79 (- x (<< y 2)))
- (addraset r 80 (- x (<< y 3)))
-
- (floataset d 0 0.0)
- (floataset d 1 1.0)
- (floataset d 2 -1.0)
- (floataset d 3 (+f f g))
- (floataset d 4 (-f f g))
- (floataset d 5 ( *f f g))
- (floataset d 6 (/f f g))
-
- (floataset d 7 (+f f (+f g 1.0)))
- (floataset d 8 (-f f (+f g 1.0)))
- (floataset d 9 ( *f f (+f g 1.0)))
- (floataset d 10 (/f f (+f g 1.0)))
-
- (floataset d 11 (+f (+f f 1.0) g))
- (floataset d 12 (-f (+f f 1.0) g))
- (floataset d 13 ( *f (+f f 1.0) g))
- (floataset d 14 (/f (+f f 1.0) g))
-
- (floataset d 15 (+f (+f f 1.0) (+f g 1.0)))
- (floataset d 16 (-f (+f f 1.0) (+f g 1.0)))
- (floataset d 17 ( *f (+f f 1.0) (+f g 1.0)))
- (floataset d 18 (/f (+f f 1.0) (+f g 1.0)))
-
- (addraset r 81 (==f f g))
- (addraset r 82 (!=f f g))
- (addraset r 83 (<f f g))
- (addraset r 84 (>f f g))
- (addraset r 85 (<=f f g))
- (addraset r 86 (>=f f g))
-
- (floataset d 19 (floatofint x))
- (addraset r 87 (intoffloat f))
-
- (if (and (>= x 0) (< x y))
- (seq (checkbound y x) (addraset r 88 1))
- (addraset r 88 0))
-
- (if (< 0 y)
- (seq (checkbound y 0) (addraset r 89 1))
- (addraset r 89 0))
-
- (if (< 5 y)
- (seq (checkbound y 5) (addraset r 90 1))
- (addraset r 90 0))
-
- (addraset r 91 (let res 1 (if (==f f g) [] (assign res 0)) res))
- (addraset r 92 (let res 1 (if (!=f f g) [] (assign res 0)) res))
- (addraset r 93 (let res 1 (if (<f f g) [] (assign res 0)) res))
- (addraset r 94 (let res 1 (if (>f f g) [] (assign res 0)) res))
- (addraset r 95 (let res 1 (if (<=f f g) [] (assign res 0)) res))
- (addraset r 96 (let res 1 (if (>=f f g) [] (assign res 0)) res))
-
- (addraset r 97 (==f (+f f 1.0) (+f g 1.0)))
- (addraset r 98 (!=f (+f f 1.0) (+f g 1.0)))
- (addraset r 99 (<f (+f f 1.0) (+f g 1.0)))
- (addraset r 100 (>f (+f f 1.0) (+f g 1.0)))
- (addraset r 101 (<=f (+f f 1.0) (+f g 1.0)))
- (addraset r 102 (>=f (+f f 1.0) (+f g 1.0)))
-
- (addraset r 103 (==f f (+f g 1.0)))
- (addraset r 104 (!=f f (+f g 1.0)))
- (addraset r 105 (<f f (+f g 1.0)))
- (addraset r 106 (>f f (+f g 1.0)))
- (addraset r 107 (<=f f (+f g 1.0)))
- (addraset r 108 (>=f f (+f g 1.0)))
-
- (addraset r 109 (==f (+f f 1.0) g))
- (addraset r 110 (!=f (+f f 1.0) g))
- (addraset r 111 (<f (+f f 1.0) g))
- (addraset r 112 (>f (+f f 1.0) g))
- (addraset r 113 (<=f (+f f 1.0) g))
- (addraset r 114 (>=f (+f f 1.0) g))
-
- (floataset d 20 (+f (floatofint x) 1.0))
- (addraset r 115 (intoffloat (+f f 1.0)))
-
- (floataset d 21 (+f f (load float "G")))
- (floataset d 22 (+f (load float "G") f))
- (floataset d 23 (-f f (load float "G")))
- (floataset d 24 (-f (load float "G") f))
- (floataset d 25 ( *f f (load float "G")))
- (floataset d 26 ( *f (load float "G") f))
- (floataset d 27 (/f f (load float "G")))
- (floataset d 28 (/f (load float "G") f))
-
- (floataset d 29 (+f ( *f f 2.0) (load float "G")))
- (floataset d 30 (+f (load float "G") ( *f f 2.0)))
- (floataset d 31 (-f ( *f f 2.0) (load float "G")))
- (floataset d 32 (-f (load float "G") ( *f f 2.0)))
- (floataset d 33 ( *f ( +f f 2.0) (load float "G")))
- (floataset d 34 ( *f (load float "G") ( +f f 2.0)))
- (floataset d 35 (/f ( *f f 2.0) (load float "G")))
- (floataset d 36 (/f (load float "G") ( *f f 2.0)))
-
- (floataset d 37 (-f f))
- (floataset d 38 (absf f))
-
-)))))))
-
-
-
diff --git a/testasmcomp/arm.S b/testasmcomp/arm.S
deleted file mode 100644
index 196a3f3974..0000000000
--- a/testasmcomp/arm.S
+++ /dev/null
@@ -1,45 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1998 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-fp .req r11
-ip .req r12
-sp .req r13
-lr .req r14
-pc .req r15
-
- .text
-
- .global call_gen_code
- .type call_gen_code, %function
- .align 0
-call_gen_code:
- mov ip, sp
- stmfd sp!, {r4, r5, r6, r7, r8, r9, fp, ip, lr, pc}
- sub fp, ip, #4
- @ r0 is function to call
- @ r1, r2, r3 are arguments 1, 2, 3
- mov r4, r0
- mov r0, r1
- mov r1, r2
- mov r2, r3
- mov lr, pc
- mov pc, r4
- ldmea fp, {r4, r5, r6, r7, r8, r9, fp, sp, pc}
-
- .global caml_c_call
- .type caml_c_call, %function
- .align 0
-caml_c_call:
- @ function to call is in r10
- mov pc, r10
diff --git a/testasmcomp/checkbound.cmm b/testasmcomp/checkbound.cmm
deleted file mode 100644
index 995b74f8a3..0000000000
--- a/testasmcomp/checkbound.cmm
+++ /dev/null
@@ -1,21 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(function "checkbound2" (x: int y: int)
- (checkbound x y))
-
-(function "checkbound1" (x: int)
- (checkbound x 2))
-
-
diff --git a/testasmcomp/fib.cmm b/testasmcomp/fib.cmm
deleted file mode 100644
index b7e64d3025..0000000000
--- a/testasmcomp/fib.cmm
+++ /dev/null
@@ -1,19 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(function "fib" (n: int)
- (if (< n 2)
- 1
- (+ (app "fib" (- n 1) int)
- (app "fib" (- n 2) int))))
diff --git a/testasmcomp/hppa.S b/testasmcomp/hppa.S
deleted file mode 100644
index 2b1ab21c66..0000000000
--- a/testasmcomp/hppa.S
+++ /dev/null
@@ -1,162 +0,0 @@
-;*********************************************************************
-;* *
-;* Objective Caml *
-;* *
-;* Xavier Leroy, projet Cristal, INRIA Rocquencourt *
-;* *
-;* Copyright 1996 Institut National de Recherche en Informatique et *
-;* en Automatique. All rights reserved. This file is distributed *
-;* under the terms of the Q Public License version 1.0. *
-;* *
-;*********************************************************************
-
-; $Id$
-; Must be preprocessed by cpp
-
-#ifdef SYS_hpux
-#define G(x) x
-#define CODESPACE .code
-#define CODE_ALIGN 4
-#define EXPORT_CODE(x) .export x, entry, priv_lev=3
-#define STARTPROC .proc ! .callinfo frame=0, no_calls ! .entry
-#define ENDPROC .exit ! .procend
-#endif
-
-#ifdef SYS_nextstep
-#define G(x) _##x
-#define CODESPACE .text
-#define CODE_ALIGN 2
-#define EXPORT_CODE(x) .globl x
-#define STARTPROC
-#define ENDPROC
-#endif
-
-#ifdef SYS_hpux
- .space $PRIVATE$
- .subspa $DATA$,quad=1,align=8,access=31
- .subspa $BSS$,quad=1,align=8,access=31,zero,sort=82
- .space $TEXT$
- .subspa $LIT$,quad=0,align=8,access=44
- .subspa $CODE$,quad=0,align=8,access=44,code_only
- .import $global$, data
- .import $$dyncall, millicode
-#endif
-
- CODESPACE
- .align CODE_ALIGN
- EXPORT_CODE(G(call_gen_code))
-G(call_gen_code):
- STARTPROC
- stw %r2,-20(%r30)
- ldo 256(%r30), %r30
-; Save the callee-save registers
- ldo -32(%r30), %r1
- stws,ma %r3, -4(%r1)
- stws,ma %r4, -4(%r1)
- stws,ma %r5, -4(%r1)
- stws,ma %r6, -4(%r1)
- stws,ma %r7, -4(%r1)
- stws,ma %r8, -4(%r1)
- stws,ma %r9, -4(%r1)
- stws,ma %r10, -4(%r1)
- stws,ma %r11, -4(%r1)
- stws,ma %r12, -4(%r1)
- stws,ma %r13, -4(%r1)
- stws,ma %r14, -4(%r1)
- stws,ma %r15, -4(%r1)
- stws,ma %r16, -4(%r1)
- stws,ma %r17, -4(%r1)
- stws,ma %r18, -4(%r1)
- fstds,ma %fr12, -8(%r1)
- fstds,ma %fr13, -8(%r1)
- fstds,ma %fr14, -8(%r1)
- fstds,ma %fr15, -8(%r1)
- fstds,ma %fr16, -8(%r1)
- fstds,ma %fr17, -8(%r1)
- fstds,ma %fr18, -8(%r1)
- fstds,ma %fr19, -8(%r1)
- fstds,ma %fr20, -8(%r1)
- fstds,ma %fr21, -8(%r1)
- fstds,ma %fr22, -8(%r1)
- fstds,ma %fr23, -8(%r1)
- fstds,ma %fr24, -8(%r1)
- fstds,ma %fr25, -8(%r1)
- fstds,ma %fr26, -8(%r1)
- fstds,ma %fr27, -8(%r1)
- fstds,ma %fr28, -8(%r1)
- fstds,ma %fr29, -8(%r1)
- fstds,ma %fr30, -8(%r1)
- fstds,ma %fr31, -8(%r1)
-
-; Shuffle the arguments and call
- copy %r26, %r22
- copy %r25, %r26
- copy %r24, %r25
- copy %r23, %r24
- fcpy,dbl %fr5, %fr4
-#ifdef SYS_hpux
- bl $$dyncall, %r2
- nop
-#else
- ble 0(4, %r22)
- copy %r31, %r2
-#endif
-; Shuffle the results
- copy %r26, %r28
-; Restore the callee-save registers
- ldo -32(%r30), %r1
- ldws,ma -4(%r1), %r3
- ldws,ma -4(%r1), %r4
- ldws,ma -4(%r1), %r5
- ldws,ma -4(%r1), %r6
- ldws,ma -4(%r1), %r7
- ldws,ma -4(%r1), %r8
- ldws,ma -4(%r1), %r9
- ldws,ma -4(%r1), %r10
- ldws,ma -4(%r1), %r11
- ldws,ma -4(%r1), %r12
- ldws,ma -4(%r1), %r13
- ldws,ma -4(%r1), %r14
- ldws,ma -4(%r1), %r15
- ldws,ma -4(%r1), %r16
- ldws,ma -4(%r1), %r17
- ldws,ma -4(%r1), %r18
- fldds,ma -8(%r1), %fr12
- fldds,ma -8(%r1), %fr13
- fldds,ma -8(%r1), %fr14
- fldds,ma -8(%r1), %fr15
- fldds,ma -8(%r1), %fr16
- fldds,ma -8(%r1), %fr17
- fldds,ma -8(%r1), %fr18
- fldds,ma -8(%r1), %fr19
- fldds,ma -8(%r1), %fr20
- fldds,ma -8(%r1), %fr21
- fldds,ma -8(%r1), %fr22
- fldds,ma -8(%r1), %fr23
- fldds,ma -8(%r1), %fr24
- fldds,ma -8(%r1), %fr25
- fldds,ma -8(%r1), %fr26
- fldds,ma -8(%r1), %fr27
- fldds,ma -8(%r1), %fr28
- fldds,ma -8(%r1), %fr29
- fldds,ma -8(%r1), %fr30
- fldds,ma -8(%r1), %fr31
-
- ldo -256(%r30), %r30
- ldw -20(%r30), %r2
- bv 0(%r2)
- nop
- ENDPROC
-
- .align CODE_ALIGN
- EXPORT_CODE(caml_c_call)
-G(caml_c_call):
- STARTPROC
-#ifdef SYS_hpux
- bl $$dyncall, %r0
- nop
-#else
- bv 0(%r22)
- nop
-#endif
- ENDPROC
diff --git a/testasmcomp/i386.S b/testasmcomp/i386.S
deleted file mode 100644
index f4b65e57ac..0000000000
--- a/testasmcomp/i386.S
+++ /dev/null
@@ -1,56 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Linux with ELF binaries does not prefix identifiers with _.
- Linux with a.out binaries, FreeBSD, and NextStep do. */
-
-#ifdef SYS_linux_elf
-#define G(x) x
-#define FUNCTION_ALIGN 16
-#else
-#define G(x) _##x
-#define FUNCTION_ALIGN 4
-#endif
-
- .globl G(call_gen_code)
- .align FUNCTION_ALIGN
-G(call_gen_code):
- pushl %ebp
- movl %esp,%ebp
- pushl %ebx
- pushl %esi
- pushl %edi
- movl 12(%ebp),%eax
- movl 16(%ebp),%ebx
- movl 20(%ebp),%ecx
- movl 24(%ebp),%edx
- call *8(%ebp)
- popl %edi
- popl %esi
- popl %ebx
- popl %ebp
- ret
-
- .globl G(caml_c_call)
- .align FUNCTION_ALIGN
-G(caml_c_call):
- ffree %st(0)
- ffree %st(1)
- ffree %st(2)
- ffree %st(3)
- jmp *%eax
-
- .comm G(caml_exception_pointer), 4
- .comm G(young_ptr), 4
- .comm G(young_start), 4
diff --git a/testasmcomp/i386nt.asm b/testasmcomp/i386nt.asm
deleted file mode 100644
index 66550eb8b2..0000000000
--- a/testasmcomp/i386nt.asm
+++ /dev/null
@@ -1,67 +0,0 @@
-;*********************************************************************
-;
-; Objective Caml
-;
-; Xavier Leroy, projet Cristal, INRIA Rocquencourt
-;
-; Copyright 1996 Institut National de Recherche en Informatique et
-; en Automatique. All rights reserved. This file is distributed
-; under the terms of the Q Public License version 1.0.
-;
-;*********************************************************************
-
-; $Id$
-
- .386
- .MODEL FLAT
-
- .CODE
- PUBLIC _call_gen_code
- ALIGN 4
-_call_gen_code:
- push ebp
- mov ebp, esp
- push ebx
- push esi
- push edi
- mov eax, [ebp+12]
- mov ebx, [ebp+16]
- mov ecx, [ebp+20]
- mov edx, [ebp+24]
- call DWORD PTR [ebp+8]
- pop edi
- pop esi
- pop ebx
- pop ebp
- ret
-
- PUBLIC _caml_c_call
- ALIGN 4
-_caml_c_call:
- ffree st(0)
- ffree st(1)
- ffree st(2)
- ffree st(3)
- jmp eax
-
- PUBLIC _caml_call_gc
- PUBLIC _caml_alloc
- PUBLIC _caml_alloc1
- PUBLIC _caml_alloc2
- PUBLIC _caml_alloc3
-_caml_call_gc:
-_caml_alloc:
-_caml_alloc1:
-_caml_alloc2:
-_caml_alloc3:
- int 3
-
- .DATA
- PUBLIC _caml_exception_pointer
-_caml_exception_pointer dword 0
- PUBLIC _young_ptr
-_young_ptr dword 0
- PUBLIC _young_limit
-_young_limit dword 0
-
- END
diff --git a/testasmcomp/ia64.S b/testasmcomp/ia64.S
deleted file mode 100644
index 51361690b8..0000000000
--- a/testasmcomp/ia64.S
+++ /dev/null
@@ -1,118 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#define ST8OFF(a,b,d) st8 [a] = b, d
-#define LD8OFF(a,b,d) ld8 a = [b], d
-#define STFDOFF(a,b,d) stfd [a] = b, d
-#define LDFDOFF(a,b,d) ldfd a = [b], d
-#define STFSPILLOFF(a,b,d) stf.spill [a] = b, d
-#define LDFFILLOFF(a,b,d) ldf.fill a = [b], d
-
- .text
- .align 16
-
- .global call_gen_code#
- .proc call_gen_code#
-
-call_gen_code:
- /* Allocate 64 "out" registers (for the Caml code) and no locals */
- alloc r3 = ar.pfs, 0, 0, 64, 0
-
- /* Save PFS, return address and GP on stack */
- add sp = -368, sp ;;
- add r2 = 16, sp ;;
- ST8OFF(r2,r3,8) ;;
- mov r3 = b0 ;;
- ST8OFF(r2,r3,8) ;;
- ST8OFF(r2,gp,8) ;;
-
- /* Save predicates on stack */
- mov r3 = pr ;;
- st8 [r2] = r3
-
- /* Save callee-save floating-point registers on stack */
- add r2 = 48, sp
- add r3 = 64, sp ;;
- STFSPILLOFF(r2,f2,16) ;;
- STFSPILLOFF(r3,f3,16) ;;
- STFSPILLOFF(r2,f4,16) ;;
- STFSPILLOFF(r3,f5,16) ;;
- STFSPILLOFF(r2,f16,16) ;;
- STFSPILLOFF(r3,f17,16) ;;
- STFSPILLOFF(r2,f18,16) ;;
- STFSPILLOFF(r3,f19,16) ;;
- STFSPILLOFF(r2,f20,16) ;;
- STFSPILLOFF(r3,f21,16) ;;
- STFSPILLOFF(r2,f22,16) ;;
- STFSPILLOFF(r3,f23,16) ;;
- STFSPILLOFF(r2,f24,16) ;;
- STFSPILLOFF(r3,f25,16) ;;
- STFSPILLOFF(r2,f26,16) ;;
- STFSPILLOFF(r3,f27,16) ;;
- STFSPILLOFF(r2,f28,16) ;;
- STFSPILLOFF(r3,f29,16) ;;
- STFSPILLOFF(r2,f30,16) ;;
- STFSPILLOFF(r3,f31,16) ;;
-
- /* Recover entry point and gp from the function pointer in in0 */
- LD8OFF(r2,r32,8) ;;
- ld8 r3 = [r32] ;;
- mov b6 = r2
- mov gp = r3 ;;
-
- /* Shift arguments r33 ... r35 to r32 ... r34 */
- mov r32 = r33
- mov r33 = r34
- mov r34 = r35
-
- /* Do the call */
- br.call.sptk b0 = b6 ;;
-
- /* Restore the saved floating-point registers */
- add r2 = 48, sp
- add r3 = 64, sp ;;
- LDFFILLOFF(f2,r2,16) ;;
- LDFFILLOFF(f3,r3,16) ;;
- LDFFILLOFF(f4,r2,16) ;;
- LDFFILLOFF(f5,r3,16) ;;
- LDFFILLOFF(f16,r2,16) ;;
- LDFFILLOFF(f17,r3,16) ;;
- LDFFILLOFF(f18,r2,16) ;;
- LDFFILLOFF(f19,r3,16) ;;
- LDFFILLOFF(f20,r2,16) ;;
- LDFFILLOFF(f21,r3,16) ;;
- LDFFILLOFF(f22,r2,16) ;;
- LDFFILLOFF(f23,r3,16) ;;
- LDFFILLOFF(f24,r2,16) ;;
- LDFFILLOFF(f25,r3,16) ;;
- LDFFILLOFF(f26,r2,16) ;;
- LDFFILLOFF(f27,r3,16) ;;
- LDFFILLOFF(f28,r2,16) ;;
- LDFFILLOFF(f29,r3,16) ;;
- LDFFILLOFF(f30,r2,16) ;;
- LDFFILLOFF(f31,r3,16) ;;
-
- /* Restore gp, predicates and return */
- add r2 = 16, sp ;;
- LD8OFF(r3,r2,8) ;;
- mov ar.pfs = r3
- LD8OFF(r3,r2,8) ;;
- mov b0 = r3
- LD8OFF(gp,r2,8) ;;
- LD8OFF(r3,r2,8) ;;
- mov pr = r3, -1
-
- br.ret.sptk.many b0 ;;
-
- .endp call_gen_code#
diff --git a/testasmcomp/integr.cmm b/testasmcomp/integr.cmm
deleted file mode 100644
index 481dd7587d..0000000000
--- a/testasmcomp/integr.cmm
+++ /dev/null
@@ -1,30 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(function "square" (x: float)
- ( *f x x))
-
-(function "integr" (f: addr low: float high: float n: int)
- (let (h (/f (-f high low) (floatofint n))
- x low
- s 0.0
- i n)
- (while (> i 0)
- (assign s (+f s (app f x float)))
- (assign x (+f x h))
- (assign i (- i 1)))
- ( *f s h)))
-
-(function "test" (n: int)
- (app "integr" "square" 0.0 1.0 n float))
diff --git a/testasmcomp/lexcmm.mli b/testasmcomp/lexcmm.mli
deleted file mode 100644
index a28a57c520..0000000000
--- a/testasmcomp/lexcmm.mli
+++ /dev/null
@@ -1,24 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-val token: Lexing.lexbuf -> Parsecmm.token
-
-type error =
- Illegal_character
- | Unterminated_comment
- | Unterminated_string
-
-exception Error of error
-
-val report_error: Lexing.lexbuf -> error -> unit
diff --git a/testasmcomp/lexcmm.mll b/testasmcomp/lexcmm.mll
deleted file mode 100644
index 0e8432e1c8..0000000000
--- a/testasmcomp/lexcmm.mll
+++ /dev/null
@@ -1,228 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-{
-open Parsecmm
-
-type error =
- Illegal_character
- | Unterminated_comment
- | Unterminated_string
-
-exception Error of error
-
-(* For nested comments *)
-
-let comment_depth = ref 0
-
-(* The table of keywords *)
-
-let keyword_table =
- Misc.create_hashtable 149 [
- "absf", ABSF;
- "addr", ADDR;
- "align", ALIGN;
- "alloc", ALLOC;
- "and", AND;
- "app", APPLY;
- "assign", ASSIGN;
- "byte", BYTE;
- "case", CASE;
- "catch", CATCH;
- "checkbound", CHECKBOUND;
- "exit", EXIT;
- "extcall", EXTCALL;
- "float", FLOAT;
- "float32", FLOAT32;
- "float64", FLOAT64;
- "floatofint", FLOATOFINT;
- "function", FUNCTION;
- "half", HALF;
- "if", IF;
- "int", INT;
- "int32", INT32;
- "intoffloat", INTOFFLOAT;
- "string", KSTRING;
- "let", LET;
- "load", LOAD;
- "mod", MODI;
- "or", OR;
- "proj", PROJ;
- "raise", RAISE;
- "seq", SEQ;
- "signed", SIGNED;
- "skip", SKIP;
- "store", STORE;
- "switch", SWITCH;
- "try", TRY;
- "unit", UNIT;
- "unsigned", UNSIGNED;
- "while", WHILE;
- "with", WITH;
- "xor", XOR;
- "addraref", ADDRAREF;
- "intaref", INTAREF;
- "floataref", FLOATAREF;
- "addraset", ADDRASET;
- "intaset", INTASET;
- "floataset", FLOATASET
-]
-
-(* To buffer string literals *)
-
-let initial_string_buffer = String.create 256
-let string_buff = ref initial_string_buffer
-let string_index = ref 0
-
-let reset_string_buffer () =
- string_buff := initial_string_buffer;
- string_index := 0
-
-let store_string_char c =
- if !string_index >= String.length (!string_buff) then begin
- let new_buff = String.create (String.length (!string_buff) * 2) in
- String.blit (!string_buff) 0 new_buff 0 (String.length (!string_buff));
- string_buff := new_buff
- end;
- String.unsafe_set (!string_buff) (!string_index) c;
- incr string_index
-
-let get_stored_string () =
- let s = String.sub (!string_buff) 0 (!string_index) in
- string_buff := initial_string_buffer;
- s
-
-(* To translate escape sequences *)
-
-let char_for_backslash = function
- 'n' -> '\010'
- | 'r' -> '\013'
- | 'b' -> '\008'
- | 't' -> '\009'
- | c -> c
-
-let char_for_decimal_code lexbuf i =
- Char.chr(100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) +
- 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) +
- (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48))
-
-(* Error report *)
-
-let report_error lexbuf msg =
- prerr_string "Lexical error around character ";
- prerr_int (Lexing.lexeme_start lexbuf);
- match msg with
- Illegal_character ->
- prerr_string ": illegal character"
- | Unterminated_comment ->
- prerr_string ": unterminated comment"
- | Unterminated_string ->
- prerr_string ": unterminated string"
-
-}
-
-rule token = parse
- [' ' '\010' '\013' '\009' '\012'] +
- { token lexbuf }
- | "+a" { ADDA }
- | "+f" { ADDF }
- | "+" { ADDI }
- | ">>s" { ASR }
- | ":" { COLON }
- | "/f" { DIVF }
- | "/" { DIVI }
- | eof { EOF }
- | "==a" { EQA }
- | "==f" { EQF }
- | "==" { EQI }
- | ">=a" { GEA }
- | ">=f" { GEF }
- | ">=" { GEI }
- | ">a" { GTA }
- | ">f" { GTF }
- | ">" { GTI }
- | "[" { LBRACKET }
- | "<=a" { LEA }
- | "<=f" { LEF }
- | "<=" { LEI }
- | "(" { LPAREN }
- | "<<" { LSL }
- | ">>u" { LSR }
- | "<a" { LTA }
- | "<f" { LTF }
- | "<" { LTI }
- | "*f" { MULF }
- | "*" { MULI }
- | "!=a" { NEA }
- | "!=f" { NEF }
- | "!=" { NEI }
- | "]" { RBRACKET }
- | ")" { RPAREN }
- | "*" { STAR }
- | "-a" { SUBA }
- | "-f" { SUBF }
- | "-" { SUBI }
- | '-'? (['0'-'9']+ | "0x" ['0'-'9' 'a'-'f' 'A'-'F']+
- | "0o" ['0'-'7']+ | "0b" ['0'-'1']+)
- { INTCONST(int_of_string(Lexing.lexeme lexbuf)) }
- | '-'? ['0'-'9']+ 'a'
- { let s = Lexing.lexeme lexbuf in
- POINTER(int_of_string(String.sub s 0 (String.length s - 1))) }
- | '-'? ['0'-'9']+ ('.' ['0'-'9']*)? (['e' 'E'] ['+' '-']? ['0'-'9']+)?
- { FLOATCONST(Lexing.lexeme lexbuf) }
- | ['A'-'Z' 'a'-'z' '\223'-'\246' '\248'-'\255' ]
- (['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255'
- '\'' '0'-'9' ]) *
- { let s = Lexing.lexeme lexbuf in
- try
- Hashtbl.find keyword_table s
- with Not_found ->
- IDENT s }
- | "\""
- { reset_string_buffer();
- string lexbuf;
- STRING (get_stored_string()) }
- | "(*"
- { comment_depth := 1;
- comment lexbuf;
- token lexbuf }
- | _ { raise(Error(Illegal_character)) }
-
-and comment = parse
- "(*"
- { comment_depth := succ !comment_depth; comment lexbuf }
- | "*)"
- { comment_depth := pred !comment_depth;
- if !comment_depth > 0 then comment lexbuf }
- | eof
- { raise (Error(Unterminated_comment)) }
- | _
- { comment lexbuf }
-
-and string = parse
- '"'
- { () }
- | '\\' [' ' '\010' '\013' '\009' '\026' '\012'] +
- { string lexbuf }
- | '\\' ['\\' '"' 'n' 't' 'b' 'r']
- { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1));
- string lexbuf }
- | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9']
- { store_string_char(char_for_decimal_code lexbuf 1);
- string lexbuf }
- | eof
- { raise (Error(Unterminated_string)) }
- | _
- { store_string_char(Lexing.lexeme_char lexbuf 0);
- string lexbuf }
diff --git a/testasmcomp/m68k.S b/testasmcomp/m68k.S
deleted file mode 100644
index 436e65e695..0000000000
--- a/testasmcomp/m68k.S
+++ /dev/null
@@ -1,59 +0,0 @@
-|***********************************************************************
-|* *
-|* Objective Caml *
-|* *
-|* Xavier Leroy, projet Cristal, INRIA Rocquencourt *
-|* *
-|* Copyright 1996 Institut National de Recherche en Informatique et *
-|* en Automatique. All rights reserved. This file is distributed *
-|* under the terms of the Q Public License version 1.0. *
-|* *
-|***********************************************************************
-
-| $Id$
-
-| call_gen_code is used with the following types:
-| unit -> int
-| int -> int
-| int -> double
-| int * int * address -> void
-| int * int -> void
-| unit -> unit
-| Hence arg1 -> d0, arg2 -> d1, arg3 -> a0,
-| and we need a special case for int -> double
-
- .text
- .globl _call_gen_code
-_call_gen_code:
- link a6, #0
- movem d2-d7/a2-a6, a7@-
- fmovem fp2-fp7, a7@-
- movel a6@(8), a1
- movel a6@(12), d0
- movel a6@(16), d1
- movel a6@(20), a0
- jsr a1@
- fmovem a7@+, fp2-fp7
- movem a7@+, d2-d7/a2-a6
- unlk a6
- rts
-
- .globl _call_gen_code_float
-_call_gen_code_float:
- link a6, #0
- moveml d2-d7/a2-a6, a7@-
- fmovem fp2-fp7, a7@-
- movel a6@(8), a1
- movel a6@(12), d0
- jsr a1@
- fmoved fp0, a7@-
- movel a7@+, d0
- movel a7@+, d1
- fmovem a7@+, fp2-fp7
- moveml a7@+, d2-d7/a2-a6
- unlk a6
- rts
-
- .globl _caml_c_call
-_caml_c_call:
- jmp a0@
diff --git a/testasmcomp/main.c b/testasmcomp/main.c
deleted file mode 100644
index 035572a677..0000000000
--- a/testasmcomp/main.c
+++ /dev/null
@@ -1,126 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <stddef.h>
-#include <stdio.h>
-#include <stdlib.h>
-
-void caml_array_bound_error(void)
-{
- fprintf(stderr, "Fatal error: out-of-bound access in array or string\n");
- exit(2);
-}
-
-void print_string(char * s)
-{
- fputs(s, stdout);
-}
-
-void printf_int(char * fmt, int arg)
-{
- printf(fmt, arg);
-}
-
-#ifdef SORT
-
-int cmpint(const void * i, const void * j)
-{
- long vi = *((long *) i);
- long vj = *((long *) j);
- if (vi == vj) return 0;
- if (vi < vj) return -1;
- return 1;
-}
-
-#endif
-
-int main(int argc, char **argv)
-{
-#ifdef UNIT_INT
- { extern int FUN();
- extern int call_gen_code();
- printf("%d\n", call_gen_code(FUN));
- }
-#else
- if (argc < 2) {
- fprintf(stderr, "Usage: %s [int arg]\n", argv[0]);
- exit(2);
- }
-#ifdef INT_INT
- { extern int FUN();
- extern int call_gen_code();
- printf("%d\n", call_gen_code(FUN, atoi(argv[1])));
- }
-#endif
-#ifdef INT_FLOAT
- { extern double FUN();
-#ifdef __mc68020__
-#define call_gen_code call_gen_code_float
-#endif
- extern double call_gen_code();
- printf("%f\n", call_gen_code(FUN, atoi(argv[1])));
- }
-#endif
-#ifdef SORT
- { extern void FUN();
- extern void call_gen_code();
- long n;
- long * a, * b;
- long i;
-
- srand(argc >= 3 ? atoi(argv[2]) : time((char *) 0));
- n = atoi(argv[1]);
- a = (long *) malloc(n * sizeof(long));
- for (i = 0 ; i < n; i++) a[i] = rand() & 0xFFF;
-#ifdef DEBUG
- for (i = 0; i < n; i++) printf("%ld ", a[i]); printf("\n");
-#endif
- b = (long *) malloc(n * sizeof(long));
- for (i = 0; i < n; i++) b[i] = a[i];
- call_gen_code(FUN, 0, n-1, a);
-#ifdef DEBUG
- for (i = 0; i < n; i++) printf("%ld ", a[i]); printf("\n");
-#endif
- qsort(b, n, sizeof(long), cmpint);
- for (i = 0; i < n; i++) {
- if (a[i] != b[i]) { printf("Bug!\n"); return 2; }
- }
- printf("OK\n");
- }
-#endif
-#endif
-#ifdef CHECKBOUND
- { extern void checkbound1(), checkbound2();
- extern void call_gen_code();
- long x, y;
- x = atoi(argv[1]);
- if (argc >= 3) {
- y = atoi(argv[2]);
- if ((unsigned long) x < (unsigned long) y)
- printf("Should not trap\n");
- else
- printf("Should trap\n");
- call_gen_code(checkbound2, y, x);
- } else {
- if (2 < (unsigned long) x)
- printf("Should not trap\n");
- else
- printf("Should trap\n");
- call_gen_code(checkbound1, x);
- }
- printf("OK\n");
- }
-#endif
- return 0;
-}
diff --git a/testasmcomp/main.ml b/testasmcomp/main.ml
deleted file mode 100644
index d6207102ac..0000000000
--- a/testasmcomp/main.ml
+++ /dev/null
@@ -1,60 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Clflags
-
-let compile_file filename =
- Compilenv.reset "test";
- Emit.begin_assembly();
- let ic = open_in filename in
- let lb = Lexing.from_channel ic in
- try
- while true do
- Asmgen.compile_phrase Format.std_formatter (Parsecmm.phrase Lexcmm.token lb)
- done
- with
- End_of_file ->
- close_in ic; Emit.end_assembly()
- | Lexcmm.Error msg ->
- close_in ic; Lexcmm.report_error lb msg
- | Parsing.Parse_error ->
- close_in ic;
- prerr_string "Syntax error near character ";
- prerr_int (Lexing.lexeme_start lb);
- prerr_newline()
- | Parsecmmaux.Error msg ->
- close_in ic; Parsecmmaux.report_error msg
- | x ->
- close_in ic; raise x
-
-let usage = "Usage: codegen <options> <files>\noptions are:"
-
-let main() =
- Arg.parse [
- "-dcmm", Arg.Set dump_cmm, "";
- "-dsel", Arg.Set dump_selection, "";
- "-dlive", Arg.Unit(fun () -> dump_live := true;
- Printmach.print_live := true), "";
- "-dspill", Arg.Set dump_spill, "";
- "-dsplit", Arg.Set dump_split, "";
- "-dinterf", Arg.Set dump_interf, "";
- "-dprefer", Arg.Set dump_prefer, "";
- "-dalloc", Arg.Set dump_regalloc, "";
- "-dreload", Arg.Set dump_reload, "";
- "-dscheduling", Arg.Set dump_scheduling, "";
- "-dlinear", Arg.Set dump_linear, ""
- ] compile_file usage
-
-let _ = (*Printexc.catch*) main (); exit 0
-
diff --git a/testasmcomp/mainarith.c b/testasmcomp/mainarith.c
deleted file mode 100644
index 063e63ae61..0000000000
--- a/testasmcomp/mainarith.c
+++ /dev/null
@@ -1,304 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <stdio.h>
-#include <math.h>
-
-void caml_array_bound_error(void)
-{
- fprintf(stderr, "Fatal error: out-of-bound access in array or string\n");
- exit(2);
-}
-
-long R[200];
-double D[40];
-long X, Y;
-double F, G;
-
-#define INTTEST(arg,res) \
- { long result = (res); \
- if (arg != result) \
- printf("Failed test \"%s == %s\" for X=%ld and Y=%ld: result %ld, expected %ld\n", \
- #arg, #res, X, Y, arg, result); \
- }
-#define INTFLOATTEST(arg,res) \
- { long result = (res); \
- if (arg != result) \
- printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: result %ld, expected %ld\n", \
- #arg, #res, F, G, arg, result); \
- }
-#define FLOATTEST(arg,res) \
- { double result = (res); \
- if (arg < result || arg > result) \
- printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: result %.15g, expected %.15g\n", \
- #arg, #res, F, G, arg, result); \
- }
-#define FLOATINTTEST(arg,res) \
- { double result = (res); \
- if (arg < result || arg > result) \
- printf("Failed test \"%s == %s\" for X=%ld and Y=%ld: result %.15g, expected %.15g\n", \
- #arg, #res, X, Y, arg, result); \
- }
-
-extern void call_gen_code();
-extern void testarith();
-
-void do_test(void)
-{
- call_gen_code(testarith);
-
- INTTEST(R[0], 0);
- INTTEST(R[1], 1);
- INTTEST(R[2], -1);
- INTTEST(R[3], 256);
- INTTEST(R[4], 65536);
- INTTEST(R[5], 16777216);
- INTTEST(R[6], -256);
- INTTEST(R[7], -65536);
- INTTEST(R[8], -16777216);
-
- INTTEST(R[9], (X + Y));
- INTTEST(R[10], (X + 1));
- INTTEST(R[11], (X + -1));
-
- INTTEST(R[12], ((long) ((char *)R + 8)));
- INTTEST(R[13], ((long) ((char *)R + Y)));
-
- INTTEST(R[14], (X - Y));
- INTTEST(R[15], (X - 1));
- INTTEST(R[16], (X - -1));
-
- INTTEST(R[17], ((long) ((char *)R - 8)));
- INTTEST(R[18], ((long) ((char *)R - Y)));
-
- INTTEST(R[19], (X * 2));
- INTTEST(R[20], (2 * X));
- INTTEST(R[21], (X * 16));
- INTTEST(R[22], (16 * X));
- INTTEST(R[23], (X * 12345));
- INTTEST(R[24], (12345 * X));
- INTTEST(R[25], (X * Y));
-
- INTTEST(R[26], (X / 2));
- INTTEST(R[27], (X / 16));
- INTTEST(R[28], (X / 7));
- INTTEST(R[29], (Y != 0 ? X / Y : 0));
-
- INTTEST(R[30], (X % 2));
- INTTEST(R[31], (X % 16));
- INTTEST(R[32], (Y != 0 ? X % Y : 0));
-
- INTTEST(R[33], (X & Y));
- INTTEST(R[34], (X & 3));
- INTTEST(R[35], (3 & X));
-
- INTTEST(R[36], (X | Y));
- INTTEST(R[37], (X | 3));
- INTTEST(R[38], (3 | X));
-
- INTTEST(R[39], (X ^ Y));
- INTTEST(R[40], (X ^ 3));
- INTTEST(R[41], (3 ^ X));
-
- INTTEST(R[42], (X << Y));
- INTTEST(R[43], (X << 1));
- INTTEST(R[44], (X << 8));
-
- INTTEST(R[45], ((unsigned long) X >> Y));
- INTTEST(R[46], ((unsigned long) X >> 1));
- INTTEST(R[47], ((unsigned long) X >> 8));
-
- INTTEST(R[48], (X >> Y));
- INTTEST(R[49], (X >> 1));
- INTTEST(R[50], (X >> 8));
-
- INTTEST(R[51], (X == Y));
- INTTEST(R[52], (X != Y));
- INTTEST(R[53], (X < Y));
- INTTEST(R[54], (X > Y));
- INTTEST(R[55], (X <= Y));
- INTTEST(R[56], (X >= Y));
- INTTEST(R[57], (X == 1));
- INTTEST(R[58], (X != 1));
- INTTEST(R[59], (X < 1));
- INTTEST(R[60], (X > 1));
- INTTEST(R[61], (X <= 1));
- INTTEST(R[62], (X >= 1));
-
- INTTEST(R[63], ((char *)X == (char *)Y));
- INTTEST(R[64], ((char *)X != (char *)Y));
- INTTEST(R[65], ((char *)X < (char *)Y));
- INTTEST(R[66], ((char *)X > (char *)Y));
- INTTEST(R[67], ((char *)X <= (char *)Y));
- INTTEST(R[68], ((char *)X >= (char *)Y));
- INTTEST(R[69], ((char *)X == (char *)1));
- INTTEST(R[70], ((char *)X != (char *)1));
- INTTEST(R[71], ((char *)X < (char *)1));
- INTTEST(R[72], ((char *)X > (char *)1));
- INTTEST(R[73], ((char *)X <= (char *)1));
- INTTEST(R[74], ((char *)X >= (char *)1));
-
- INTTEST(R[75], (X + (Y << 1)));
- INTTEST(R[76], (X + (Y << 2)));
- INTTEST(R[77], (X + (Y << 3)));
- INTTEST(R[78], (X - (Y << 1)));
- INTTEST(R[79], (X - (Y << 2)));
- INTTEST(R[80], (X - (Y << 3)));
-
- FLOATTEST(D[0], 0.0);
- FLOATTEST(D[1], 1.0);
- FLOATTEST(D[2], -1.0);
- FLOATTEST(D[3], (F + G));
- FLOATTEST(D[4], (F - G));
- FLOATTEST(D[5], (F * G));
- FLOATTEST(D[6], F / G);
-
- FLOATTEST(D[7], (F + (G + 1.0)));
- FLOATTEST(D[8], (F - (G + 1.0)));
- FLOATTEST(D[9], (F * (G + 1.0)));
- FLOATTEST(D[10], F / (G + 1.0));
-
- FLOATTEST(D[11], ((F + 1.0) + G));
- FLOATTEST(D[12], ((F + 1.0) - G));
- FLOATTEST(D[13], ((F + 1.0) * G));
- FLOATTEST(D[14], (F + 1.0) / G);
-
- FLOATTEST(D[15], ((F + 1.0) + (G + 1.0)));
- FLOATTEST(D[16], ((F + 1.0) - (G + 1.0)));
- FLOATTEST(D[17], ((F + 1.0) * (G + 1.0)));
- FLOATTEST(D[18], (F + 1.0) / (G + 1.0));
-
- INTFLOATTEST(R[81], (F == G));
- INTFLOATTEST(R[82], (F != G));
- INTFLOATTEST(R[83], (F < G));
- INTFLOATTEST(R[84], (F > G));
- INTFLOATTEST(R[85], (F <= G));
- INTFLOATTEST(R[86], (F >= G));
-
- FLOATINTTEST(D[19], (double) X);
- INTFLOATTEST(R[87], (long) F);
-
- INTTEST(R[88], (X >= 0) && (X < Y));
- INTTEST(R[89], (0 < Y));
- INTTEST(R[90], (5 < Y));
-
- INTFLOATTEST(R[91], (F == G));
- INTFLOATTEST(R[92], (F != G));
- INTFLOATTEST(R[93], (F < G));
- INTFLOATTEST(R[94], (F > G));
- INTFLOATTEST(R[95], (F <= G));
- INTFLOATTEST(R[96], (F >= G));
-
- INTFLOATTEST(R[97], (F + 1.0 == G + 1.0));
- INTFLOATTEST(R[98], (F + 1.0 != G + 1.0));
- INTFLOATTEST(R[99], (F + 1.0 < G + 1.0));
- INTFLOATTEST(R[100], (F + 1.0 > G + 1.0));
- INTFLOATTEST(R[101], (F + 1.0 <= G + 1.0));
- INTFLOATTEST(R[102], (F + 1.0 >= G + 1.0));
-
- INTFLOATTEST(R[103], (F == G + 1.0));
- INTFLOATTEST(R[104], (F != G + 1.0));
- INTFLOATTEST(R[105], (F < G + 1.0));
- INTFLOATTEST(R[106], (F > G + 1.0));
- INTFLOATTEST(R[107], (F <= G + 1.0));
- INTFLOATTEST(R[108], (F >= G + 1.0));
-
- INTFLOATTEST(R[109], (F + 1.0 == G));
- INTFLOATTEST(R[110], (F + 1.0 != G));
- INTFLOATTEST(R[111], (F + 1.0 < G));
- INTFLOATTEST(R[112], (F + 1.0 > G));
- INTFLOATTEST(R[113], (F + 1.0 <= G));
- INTFLOATTEST(R[114], (F + 1.0 >= G));
-
- FLOATINTTEST(D[20], ((double) X) + 1.0);
- INTFLOATTEST(R[115], (long)(F + 1.0));
-
- FLOATTEST(D[21], F + G);
- FLOATTEST(D[22], G + F);
- FLOATTEST(D[23], F - G);
- FLOATTEST(D[24], G - F);
- FLOATTEST(D[25], F * G);
- FLOATTEST(D[26], G * F);
- FLOATTEST(D[27], F / G);
- FLOATTEST(D[28], G / F);
-
- FLOATTEST(D[29], (F * 2.0) + G);
- FLOATTEST(D[30], G + (F * 2.0));
- FLOATTEST(D[31], (F * 2.0) - G);
- FLOATTEST(D[32], G - (F * 2.0));
- FLOATTEST(D[33], (F + 2.0) * G);
- FLOATTEST(D[34], G * (F + 2.0));
- FLOATTEST(D[35], (F * 2.0) / G);
- FLOATTEST(D[36], G / (F * 2.0));
-
- FLOATTEST(D[37], - F);
- FLOATTEST(D[38], fabs(F));
-}
-
-#ifdef __i386__
-#ifdef __FreeBSD__
-#include <floatingpoint.h>
-#endif
-#endif
-
-void init_ieee_floats(void)
-{
-#ifdef __i386__
-#ifdef __FreeBSD__
- fpsetmask(0);
-#endif
-#endif
-}
-
-int main(int argc, char **argv)
-{
- double weird[4];
-
- init_ieee_floats();
-
- if (argc >= 5) {
- X = atoi(argv[1]);
- Y = atoi(argv[2]);
- sscanf(argv[3], "%lf", &F);
- sscanf(argv[4], "%lf", &G);
- do_test();
- return 0;
- }
- for(Y = -2; Y <= 2; Y++) {
- for (X = -2; X <= 2; X++) {
- F = X; G = Y; do_test();
- }
- }
- if (!(argc >= 2 && strcmp(argv[1], "noinf"))) {
- weird[0] = 0.0;
- weird[1] = 1.0 / weird[0]; /* +infty */
- weird[2] = -1.0 / weird[0]; /* -infty */
- weird[3] = 0.0 / weird[0]; /* NaN */
- for (X = 0; X < 4; X++) {
- for (Y = 0; Y < 4; Y++) {
- F = weird[X]; G = weird[Y]; do_test();
- }
- }
- }
- while(1) {
- X = (rand() & 0x1FFFFFFF) - 0x10000000;
- Y = (rand() & 0x1FFFFFFF) - 0x10000000;
- F = X / 1e3;
- G = Y / 1e3;
- do_test();
- printf("."); fflush(stdout);
- }
- return 0;
-}
-
diff --git a/testasmcomp/mips.s b/testasmcomp/mips.s
deleted file mode 100644
index 9fe9f94b60..0000000000
--- a/testasmcomp/mips.s
+++ /dev/null
@@ -1,71 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
- .globl call_gen_code
- .ent call_gen_code
-call_gen_code:
- subu $sp, $sp, 0x90
- sd $31, 0x88($sp)
- /* Save all callee-save registers */
- sd $16, 0x0($sp)
- sd $17, 0x8($sp)
- sd $18, 0x10($sp)
- sd $19, 0x18($sp)
- sd $20, 0x20($sp)
- sd $21, 0x28($sp)
- sd $22, 0x30($sp)
- sd $23, 0x38($sp)
- sd $30, 0x40($sp)
- s.d $f20, 0x48($sp)
- s.d $f22, 0x50($sp)
- s.d $f24, 0x58($sp)
- s.d $f26, 0x60($sp)
- s.d $f28, 0x68($sp)
- s.d $f30, 0x70($sp)
- /* Shuffle arguments */
- move $8, $5
- move $9, $6
- move $10, $7
- move $25, $4
- jal $4
- /* Restore registers */
- ld $31, 0x88($sp)
- ld $16, 0x0($sp)
- ld $17, 0x8($sp)
- ld $18, 0x10($sp)
- ld $19, 0x18($sp)
- ld $20, 0x20($sp)
- ld $21, 0x28($sp)
- ld $22, 0x30($sp)
- ld $23, 0x38($sp)
- ld $30, 0x40($sp)
- l.d $f20, 0x48($sp)
- l.d $f22, 0x50($sp)
- l.d $f24, 0x58($sp)
- l.d $f26, 0x60($sp)
- l.d $f28, 0x68($sp)
- l.d $f30, 0x70($sp)
- addu $sp, $sp, 0x90
- j $31
-
- .end call_gen_code
-
-/* Call a C function */
-
- .globl caml_c_call
- .ent caml_c_call
-caml_c_call:
- move $25, $24
- j $24
- .end caml_c_call
diff --git a/testasmcomp/parsecmm.mly b/testasmcomp/parsecmm.mly
deleted file mode 100644
index 937b549c92..0000000000
--- a/testasmcomp/parsecmm.mly
+++ /dev/null
@@ -1,325 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* A simple parser for C-- */
-
-%{
-open Cmm
-open Parsecmmaux
-
-let rec make_letdef def body =
- match def with
- [] -> body
- | (id, def) :: rem ->
- unbind_ident id;
- Clet(id, def, make_letdef rem body)
-
-let make_switch n selector caselist =
- let index = Array.create n 0 in
- let casev = Array.of_list caselist in
- let actv = Array.create (Array.length casev) (Cexit(0,[])) in
- for i = 0 to Array.length casev - 1 do
- let (posl, e) = casev.(i) in
- List.iter (fun pos -> index.(pos) <- i) posl;
- actv.(i) <- e
- done;
- Cswitch(selector, index, actv)
-
-let access_array base numelt size =
- match numelt with
- Cconst_int 0 -> base
- | Cconst_int n -> Cop(Cadda, [base; Cconst_int(n * size)])
- | _ -> Cop(Cadda, [base;
- Cop(Clsl, [numelt; Cconst_int(Misc.log2 size)])])
-
-%}
-
-%token ABSF
-%token ADDA
-%token ADDF
-%token ADDI
-%token ADDR
-%token ALIGN
-%token ALLOC
-%token AND
-%token APPLY
-%token ASR
-%token ASSIGN
-%token BYTE
-%token CASE
-%token CATCH
-%token CHECKBOUND
-%token COLON
-%token DIVF
-%token DIVI
-%token EOF
-%token EQA
-%token EQF
-%token EQI
-%token EXIT
-%token EXTCALL
-%token FLOAT
-%token FLOAT32
-%token FLOAT64
-%token <string> FLOATCONST
-%token FLOATOFINT
-%token FUNCTION
-%token GEA
-%token GEF
-%token GEI
-%token GTA
-%token GTF
-%token GTI
-%token HALF
-%token <string> IDENT
-%token IF
-%token INT
-%token INT32
-%token <int> INTCONST
-%token INTOFFLOAT
-%token KSTRING
-%token LBRACKET
-%token LEA
-%token LEF
-%token LEI
-%token LET
-%token LOAD
-%token LPAREN
-%token LSL
-%token LSR
-%token LTA
-%token LTF
-%token LTI
-%token MODI
-%token MULF
-%token MULI
-%token NEA
-%token NEF
-%token NEI
-%token OR
-%token <int> POINTER
-%token PROJ
-%token RAISE
-%token RBRACKET
-%token RPAREN
-%token SEQ
-%token SIGNED
-%token SKIP
-%token STAR
-%token STORE
-%token <string> STRING
-%token SUBA
-%token SUBF
-%token SUBI
-%token SWITCH
-%token TRY
-%token UNIT
-%token UNSIGNED
-%token WHILE
-%token WITH
-%token XOR
-%token ADDRAREF
-%token INTAREF
-%token FLOATAREF
-%token ADDRASET
-%token INTASET
-%token FLOATASET
-
-%start phrase
-%type <Cmm.phrase> phrase
-
-%%
-
-phrase:
- fundecl { Cfunction $1 }
- | datadecl { Cdata $1 }
- | EOF { raise End_of_file }
-;
-fundecl:
- LPAREN FUNCTION STRING LPAREN params RPAREN sequence RPAREN
- { List.iter (fun (id, ty) -> unbind_ident id) $5;
- {fun_name = $3; fun_args = $5; fun_body = $7; fun_fast = true} }
-;
-params:
- oneparam params { $1 :: $2 }
- | /**/ { [] }
-;
-oneparam:
- IDENT COLON machtype { (bind_ident $1, $3) }
-;
-machtype:
- UNIT { [||] }
- | componentlist { Array.of_list(List.rev $1) }
-;
-component:
- ADDR { Addr }
- | INT { Int }
- | FLOAT { Float }
-;
-componentlist:
- component { [$1] }
- | componentlist STAR component { $3 :: $1 }
-;
-expr:
- INTCONST { Cconst_int $1 }
- | FLOATCONST { Cconst_float $1 }
- | STRING { Cconst_symbol $1 }
- | POINTER { Cconst_pointer $1 }
- | IDENT { Cvar(find_ident $1) }
- | LBRACKET RBRACKET { Ctuple [] }
- | LPAREN LET letdef sequence RPAREN { make_letdef $3 $4 }
- | LPAREN ASSIGN IDENT expr RPAREN { Cassign(find_ident $3, $4) }
- | LPAREN APPLY expr exprlist machtype RPAREN { Cop(Capply $5, $3 :: List.rev $4) }
- | LPAREN EXTCALL STRING exprlist machtype RPAREN { Cop(Cextcall($3, $5, false), List.rev $4) }
- | LPAREN SUBF expr RPAREN { Cop(Cnegf, [$3]) }
- | LPAREN SUBF expr expr RPAREN { Cop(Csubf, [$3; $4]) }
- | LPAREN unaryop expr RPAREN { Cop($2, [$3]) }
- | LPAREN binaryop expr expr RPAREN { Cop($2, [$3; $4]) }
- | LPAREN SEQ sequence RPAREN { $3 }
- | LPAREN IF expr expr expr RPAREN { Cifthenelse($3, $4, $5) }
- | LPAREN SWITCH INTCONST expr caselist RPAREN { make_switch $3 $4 $5 }
- | LPAREN WHILE expr sequence RPAREN
- { let body =
- match $3 with
- Cconst_int x when x <> 0 -> $4
- | _ -> Cifthenelse($3, $4, (Cexit(0,[]))) in
- Ccatch(0, [], Cloop body, Ctuple []) }
- | LPAREN CATCH sequence WITH sequence RPAREN { Ccatch(0, [], $3, $5) }
- | EXIT { Cexit(0,[]) }
- | LPAREN TRY sequence WITH bind_ident sequence RPAREN
- { unbind_ident $5; Ctrywith($3, $5, $6) }
- | LPAREN ADDRAREF expr expr RPAREN
- { Cop(Cload Word, [access_array $3 $4 Arch.size_addr]) }
- | LPAREN INTAREF expr expr RPAREN
- { Cop(Cload Word, [access_array $3 $4 Arch.size_int]) }
- | LPAREN FLOATAREF expr expr RPAREN
- { Cop(Cload Double_u, [access_array $3 $4 Arch.size_float]) }
- | LPAREN ADDRASET expr expr expr RPAREN
- { Cop(Cstore Word, [access_array $3 $4 Arch.size_addr; $5]) }
- | LPAREN INTASET expr expr expr RPAREN
- { Cop(Cstore Word, [access_array $3 $4 Arch.size_int; $5]) }
- | LPAREN FLOATASET expr expr expr RPAREN
- { Cop(Cstore Double_u, [access_array $3 $4 Arch.size_float; $5]) }
-;
-exprlist:
- exprlist expr { $2 :: $1 }
- | /**/ { [] }
-;
-letdef:
- oneletdef { [$1] }
- | LPAREN letdefmult RPAREN { $2 }
-;
-letdefmult:
- /**/ { [] }
- | oneletdef letdefmult { $1 :: $2 }
-;
-oneletdef:
- IDENT expr { (bind_ident $1, $2) }
-;
-chunk:
- UNSIGNED BYTE { Byte_unsigned }
- | SIGNED BYTE { Byte_signed }
- | UNSIGNED HALF { Sixteen_unsigned }
- | SIGNED HALF { Sixteen_signed }
- | UNSIGNED INT32 { Thirtytwo_unsigned }
- | SIGNED INT32 { Thirtytwo_signed }
- | INT { Word }
- | ADDR { Word }
- | FLOAT32 { Single }
- | FLOAT64 { Double }
- | FLOAT { Double_u }
-
-;
-unaryop:
- LOAD chunk { Cload $2 }
- | ALLOC { Calloc }
- | FLOATOFINT { Cfloatofint }
- | INTOFFLOAT { Cintoffloat }
- | RAISE { Craise }
- | ABSF { Cabsf }
-;
-binaryop:
- STORE chunk { Cstore $2 }
- | ADDI { Caddi }
- | SUBI { Csubi }
- | MULI { Cmuli }
- | DIVI { Cdivi }
- | MODI { Cmodi }
- | AND { Cand }
- | OR { Cor }
- | XOR { Cxor }
- | LSL { Clsl }
- | LSR { Clsr }
- | ASR { Casr }
- | EQI { Ccmpi Ceq }
- | NEI { Ccmpi Cne }
- | LTI { Ccmpi Clt }
- | LEI { Ccmpi Cle }
- | GTI { Ccmpi Cgt }
- | GEI { Ccmpi Cge }
- | ADDA { Cadda }
- | SUBA { Csuba }
- | EQA { Ccmpa Ceq }
- | NEA { Ccmpa Cne }
- | LTA { Ccmpa Clt }
- | LEA { Ccmpa Cle }
- | GTA { Ccmpa Cgt }
- | GEA { Ccmpa Cge }
- | ADDF { Caddf }
- | MULF { Cmulf }
- | DIVF { Cdivf }
- | EQF { Ccmpf Ceq }
- | NEF { Ccmpf Cne }
- | LTF { Ccmpf Clt }
- | LEF { Ccmpf Cle }
- | GTF { Ccmpf Cgt }
- | GEF { Ccmpf Cge }
- | CHECKBOUND { Ccheckbound }
-;
-sequence:
- expr sequence { Csequence($1, $2) }
- | expr { $1 }
-;
-caselist:
- onecase sequence caselist { ($1, $2) :: $3 }
- | /**/ { [] }
-;
-onecase:
- CASE INTCONST COLON onecase { $2 :: $4 }
- | CASE INTCONST COLON { [$2] }
-;
-bind_ident:
- IDENT { bind_ident $1 }
-;
-datadecl:
- LPAREN datalist RPAREN { List.rev $2 }
-;
-datalist:
- datalist dataitem { $2 :: $1 }
- | /**/ { [] }
-;
-dataitem:
- STRING COLON { Cdefine_symbol $1 }
- | INTCONST COLON { Cdefine_label $1 }
- | BYTE INTCONST { Cint8 $2 }
- | HALF INTCONST { Cint16 $2 }
- | INT INTCONST { Cint(Nativeint.of_int $2) }
- | FLOAT FLOATCONST { Cdouble $2 }
- | ADDR STRING { Csymbol_address $2 }
- | ADDR INTCONST { Clabel_address $2 }
- | KSTRING STRING { Cstring $2 }
- | SKIP INTCONST { Cskip $2 }
- | ALIGN INTCONST { Calign $2 }
-;
-
diff --git a/testasmcomp/parsecmmaux.ml b/testasmcomp/parsecmmaux.ml
deleted file mode 100644
index 8c46888c6b..0000000000
--- a/testasmcomp/parsecmmaux.ml
+++ /dev/null
@@ -1,40 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Auxiliary functions for parsing *)
-
-type error =
- Unbound of string
-
-exception Error of error
-
-let tbl_ident = (Hashtbl.create 57 : (string, Ident.t) Hashtbl.t)
-
-let bind_ident s =
- let id = Ident.create s in
- Hashtbl.add tbl_ident s id;
- id
-
-let find_ident s =
- try
- Hashtbl.find tbl_ident s
- with Not_found ->
- raise(Error(Unbound s))
-
-let unbind_ident id =
- Hashtbl.remove tbl_ident (Ident.name id)
-
-let report_error = function
- Unbound s ->
- prerr_string "Unbound identifier "; prerr_string s; prerr_endline "."
diff --git a/testasmcomp/parsecmmaux.mli b/testasmcomp/parsecmmaux.mli
deleted file mode 100644
index 558996552c..0000000000
--- a/testasmcomp/parsecmmaux.mli
+++ /dev/null
@@ -1,26 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Auxiliary functions for parsing *)
-
-val bind_ident: string -> Ident.t
-val find_ident: string -> Ident.t
-val unbind_ident: Ident.t -> unit
-
-type error =
- Unbound of string
-
-exception Error of error
-
-val report_error: error -> unit
diff --git a/testasmcomp/power-aix.S b/testasmcomp/power-aix.S
deleted file mode 100644
index 96ed2b92d1..0000000000
--- a/testasmcomp/power-aix.S
+++ /dev/null
@@ -1,152 +0,0 @@
-#*********************************************************************
-#* *
-#* Objective Caml *
-#* *
-#* Xavier Leroy, projet Cristal, INRIA Rocquencourt *
-#* *
-#* Copyright 1996 Institut National de Recherche en Informatique et *
-#* en Automatique. All rights reserved. This file is distributed *
-#* under the terms of the Q Public License version 1.0. *
-#* *
-#*********************************************************************
-
-# $Id$
-
- .csect .text[PR]
-
- .globl .call_gen_code
-.call_gen_code:
-# Save return address
- mflr 0
- stw 0, 8(1)
-# Save all callee-save registers
- stw 13,-76(1)
- stw 14,-72(1)
- stw 15,-68(1)
- stw 16,-64(1)
- stw 17,-60(1)
- stw 18,-56(1)
- stw 19,-52(1)
- stw 20,-48(1)
- stw 21,-44(1)
- stw 22,-40(1)
- stw 23,-36(1)
- stw 24,-32(1)
- stw 25,-28(1)
- stw 26,-24(1)
- stw 27,-20(1)
- stw 28,-16(1)
- stw 29,-12(1)
- stw 30,-8(1)
- stw 31,-4(1)
- stfd 14, -224(1)
- stfd 15, -216(1)
- stfd 16, -208(1)
- stfd 17, -200(1)
- stfd 18, -192(1)
- stfd 19, -184(1)
- stfd 20, -176(1)
- stfd 21, -168(1)
- stfd 22, -160(1)
- stfd 23, -152(1)
- stfd 24, -144(1)
- stfd 25, -136(1)
- stfd 26, -128(1)
- stfd 27, -120(1)
- stfd 28, -112(1)
- stfd 29, -104(1)
- stfd 30, -96(1)
- stfd 31, -88(1)
-# Allocate and link stack frame
- stwu 1, -280(1)
-# Save global pointer
- stw 2, 20(1)
-# Load code to call
- lwz 0, 0(3)
- lwz 2, 4(3)
- mtlr 0
-# Shuffle arguments
- mr 3, 4
- mr 4, 5
- mr 5, 6
- mr 6, 7
-# Call the function
- blrl
-# Restore global pointer
- lwz 2, 20(1)
-# Deallocate stack frame
- addic 1, 1, 280
-# Restore callee-save registers
- lwz 13,-76(1)
- lwz 14,-72(1)
- lwz 15,-68(1)
- lwz 16,-64(1)
- lwz 17,-60(1)
- lwz 18,-56(1)
- lwz 19,-52(1)
- lwz 20,-48(1)
- lwz 21,-44(1)
- lwz 22,-40(1)
- lwz 23,-36(1)
- lwz 24,-32(1)
- lwz 25,-28(1)
- lwz 26,-24(1)
- lwz 27,-20(1)
- lwz 28,-16(1)
- lwz 29,-12(1)
- lwz 30,-8(1)
- lwz 31,-4(1)
- lfd 14, -224(1)
- lfd 15, -216(1)
- lfd 16, -208(1)
- lfd 17, -200(1)
- lfd 18, -192(1)
- lfd 19, -184(1)
- lfd 20, -176(1)
- lfd 21, -168(1)
- lfd 22, -160(1)
- lfd 23, -152(1)
- lfd 24, -144(1)
- lfd 25, -136(1)
- lfd 26, -128(1)
- lfd 27, -120(1)
- lfd 28, -112(1)
- lfd 29, -104(1)
- lfd 30, -96(1)
- lfd 31, -88(1)
-# Reload return address
- lwz 0, 8(1)
- mtlr 0
-# Return
- blr
-
- .globl .caml_c_call
-.caml_c_call:
-# Preserve RTOC and return address in callee-save registers
-# The C function will preserve them, and the Caml code does not
-# expect them to be preserved
-# Return address is in 25, RTOC is in 26
- mflr 25
- mr 26, 2
-# Call desired function (descriptor in r11)
- lwz 0, 0(11)
- lwz 2, 4(11)
- mtlr 0
- blrl
-# Restore return address and RTOC
- mtlr 25
- mr 2, 26
-# Return to caller
- blr
-
-# Function closures
-
- .globl call_gen_code
- .csect call_gen_code[DS]
-call_gen_code:
- .long .call_gen_code, TOC[tc0], 0
-
- .globl caml_c_call
- .csect caml_c_call[DS]
-caml_c_call:
- .long .caml_c_call, TOC[tc0], 0
diff --git a/testasmcomp/power-elf.S b/testasmcomp/power-elf.S
deleted file mode 100644
index 994a9fa7be..0000000000
--- a/testasmcomp/power-elf.S
+++ /dev/null
@@ -1,131 +0,0 @@
-/*********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/*********************************************************************/
-
-/* $Id$ */
-
-/* Save and restore all callee-save registers */
-/* GPR 14 at sp+16 ... GPR 31 at sp+84
- FPR 14 at sp+92 ... FPR 31 at sp+228 */
-
-#define Save_callee_save \
- addic 11, 1, 16-4; \
- stwu 14, 4(11); \
- stwu 15, 4(11); \
- stwu 16, 4(11); \
- stwu 17, 4(11); \
- stwu 18, 4(11); \
- stwu 19, 4(11); \
- stwu 20, 4(11); \
- stwu 21, 4(11); \
- stwu 22, 4(11); \
- stwu 23, 4(11); \
- stwu 24, 4(11); \
- stwu 25, 4(11); \
- stwu 26, 4(11); \
- stwu 27, 4(11); \
- stwu 28, 4(11); \
- stwu 29, 4(11); \
- stwu 30, 4(11); \
- stwu 31, 4(11); \
- stfdu 14, 8(11); \
- stfdu 15, 8(11); \
- stfdu 16, 8(11); \
- stfdu 17, 8(11); \
- stfdu 18, 8(11); \
- stfdu 19, 8(11); \
- stfdu 20, 8(11); \
- stfdu 21, 8(11); \
- stfdu 22, 8(11); \
- stfdu 23, 8(11); \
- stfdu 24, 8(11); \
- stfdu 25, 8(11); \
- stfdu 26, 8(11); \
- stfdu 27, 8(11); \
- stfdu 28, 8(11); \
- stfdu 29, 8(11); \
- stfdu 30, 8(11); \
- stfdu 31, 8(11)
-
-#define Restore_callee_save \
- addic 11, 1, 16-4; \
- lwzu 14, 4(11); \
- lwzu 15, 4(11); \
- lwzu 16, 4(11); \
- lwzu 17, 4(11); \
- lwzu 18, 4(11); \
- lwzu 19, 4(11); \
- lwzu 20, 4(11); \
- lwzu 21, 4(11); \
- lwzu 22, 4(11); \
- lwzu 23, 4(11); \
- lwzu 24, 4(11); \
- lwzu 25, 4(11); \
- lwzu 26, 4(11); \
- lwzu 27, 4(11); \
- lwzu 28, 4(11); \
- lwzu 29, 4(11); \
- lwzu 30, 4(11); \
- lwzu 31, 4(11); \
- lfdu 14, 8(11); \
- lfdu 15, 8(11); \
- lfdu 16, 8(11); \
- lfdu 17, 8(11); \
- lfdu 18, 8(11); \
- lfdu 19, 8(11); \
- lfdu 20, 8(11); \
- lfdu 21, 8(11); \
- lfdu 22, 8(11); \
- lfdu 23, 8(11); \
- lfdu 24, 8(11); \
- lfdu 25, 8(11); \
- lfdu 26, 8(11); \
- lfdu 27, 8(11); \
- lfdu 28, 8(11); \
- lfdu 29, 8(11); \
- lfdu 30, 8(11); \
- lfdu 31, 8(11)
-
- .section ".text"
-
- .globl call_gen_code
- .type call_gen_code, @function
-call_gen_code:
- /* Allocate and link stack frame */
- stwu 1, -256(1)
- /* Save return address */
- mflr 0
- stw 0, 256+4(1)
- /* Save all callee-save registers */
- Save_callee_save
- /* Shuffle arguments */
- mtlr 3
- mr 3, 4
- mr 4, 5
- mr 5, 6
- mr 6, 7
- /* Call the function */
- blrl
- /* Restore callee-save registers */
- Restore_callee_save
- /* Reload return address */
- lwz 0, 256+4(1)
- mtlr 0
- /* Return */
- addi 1, 1, 256
- blr
-
- .globl caml_c_call
- .type caml_c_call, @function
-caml_c_call:
- /* Jump to C function (address in 11) */
- mtctr 11
- bctr
diff --git a/testasmcomp/power-rhapsody.S b/testasmcomp/power-rhapsody.S
deleted file mode 100644
index b456105862..0000000000
--- a/testasmcomp/power-rhapsody.S
+++ /dev/null
@@ -1,129 +0,0 @@
-/*********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/*********************************************************************/
-
-/* $Id$ */
-
-/* Save and restore all callee-save registers */
-/* GPR 14 at sp+16 ... GPR 31 at sp+84
- FPR 14 at sp+92 ... FPR 31 at sp+228 */
-
-#define Save_callee_save \
- addic r11, r1, 16-4; \
- stwu r14, 4(r11); \
- stwu r15, 4(r11); \
- stwu r16, 4(r11); \
- stwu r17, 4(r11); \
- stwu r18, 4(r11); \
- stwu r19, 4(r11); \
- stwu r20, 4(r11); \
- stwu r21, 4(r11); \
- stwu r22, 4(r11); \
- stwu r23, 4(r11); \
- stwu r24, 4(r11); \
- stwu r25, 4(r11); \
- stwu r26, 4(r11); \
- stwu r27, 4(r11); \
- stwu r28, 4(r11); \
- stwu r29, 4(r11); \
- stwu r30, 4(r11); \
- stwu r31, 4(r11); \
- stfdu f14, 8(r11); \
- stfdu f15, 8(r11); \
- stfdu f16, 8(r11); \
- stfdu f17, 8(r11); \
- stfdu f18, 8(r11); \
- stfdu f19, 8(r11); \
- stfdu f20, 8(r11); \
- stfdu f21, 8(r11); \
- stfdu f22, 8(r11); \
- stfdu f23, 8(r11); \
- stfdu f24, 8(r11); \
- stfdu f25, 8(r11); \
- stfdu f26, 8(r11); \
- stfdu f27, 8(r11); \
- stfdu f28, 8(r11); \
- stfdu f29, 8(r11); \
- stfdu f30, 8(r11); \
- stfdu f31, 8(r11)
-
-#define Restore_callee_save \
- addic r11, r1, 16-4; \
- lwzu r14, 4(r11); \
- lwzu r15, 4(r11); \
- lwzu r16, 4(r11); \
- lwzu r17, 4(r11); \
- lwzu r18, 4(r11); \
- lwzu r19, 4(r11); \
- lwzu r20, 4(r11); \
- lwzu r21, 4(r11); \
- lwzu r22, 4(r11); \
- lwzu r23, 4(r11); \
- lwzu r24, 4(r11); \
- lwzu r25, 4(r11); \
- lwzu r26, 4(r11); \
- lwzu r27, 4(r11); \
- lwzu r28, 4(r11); \
- lwzu r29, 4(r11); \
- lwzu r30, 4(r11); \
- lwzu r31, 4(r11); \
- lfdu f14, 8(r11); \
- lfdu f15, 8(r11); \
- lfdu f16, 8(r11); \
- lfdu f17, 8(r11); \
- lfdu f18, 8(r11); \
- lfdu f19, 8(r11); \
- lfdu f20, 8(r11); \
- lfdu f21, 8(r11); \
- lfdu f22, 8(r11); \
- lfdu f23, 8(r11); \
- lfdu f24, 8(r11); \
- lfdu f25, 8(r11); \
- lfdu f26, 8(r11); \
- lfdu f27, 8(r11); \
- lfdu f28, 8(r11); \
- lfdu f29, 8(r11); \
- lfdu f30, 8(r11); \
- lfdu f31, 8(r11)
-
- .text
-
- .globl _call_gen_code
-_call_gen_code:
- /* Allocate and link stack frame */
- stwu r1, -256(r1)
- /* Save return address */
- mflr r0
- stw r0, 256+4(r1)
- /* Save all callee-save registers */
- Save_callee_save
- /* Shuffle arguments */
- mtlr r3
- mr r3, r4
- mr r4, r5
- mr r5, r6
- mr r6, r7
- /* Call the function */
- blrl
- /* Restore callee-save registers */
- Restore_callee_save
- /* Reload return address */
- lwz r0, 256+4(r1)
- mtlr r0
- /* Return */
- addi r1, r1, 256
- blr
-
- .globl _caml_c_call
-_caml_c_call:
- /* Jump to C function (address in 11) */
- mtctr r11
- bctr
diff --git a/testasmcomp/quicksort.cmm b/testasmcomp/quicksort.cmm
deleted file mode 100644
index 4029da8d15..0000000000
--- a/testasmcomp/quicksort.cmm
+++ /dev/null
@@ -1,43 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(function "quicksort" (lo: int hi: int a: addr)
- (if (< lo hi)
- (let (i lo
- j hi
- pivot (addraref a hi))
- (while (< i j)
- (catch
- (while 1
- (if (>= i hi) exit [])
- (if (> (addraref a i) pivot) exit [])
- (assign i (+ i 1)))
- with [])
- (catch
- (while 1
- (if (<= j lo) exit [])
- (if (< (addraref a j) pivot) exit [])
- (assign j (- j 1)))
- with [])
- (if (< i j)
- (let temp (addraref a i)
- (addraset a i (addraref a j))
- (addraset a j temp))
- []))
- (let temp (addraref a i)
- (addraset a i (addraref a hi))
- (addraset a hi temp))
- (app "quicksort" lo (- i 1) a unit)
- (app "quicksort" (+ i 1) hi a unit))
- []))
diff --git a/testasmcomp/quicksort2.cmm b/testasmcomp/quicksort2.cmm
deleted file mode 100644
index eae9809a79..0000000000
--- a/testasmcomp/quicksort2.cmm
+++ /dev/null
@@ -1,49 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(function "cmp" (i: int j: int)
- (- i j))
-
-(function "quick" (lo: int hi: int a: addr cmp: addr)
- (if (< lo hi)
- (let (i lo
- j hi
- pivot (intaref a hi))
- (while (< i j)
- (catch
- (while 1
- (if (>= i hi) exit [])
- (if (> (app cmp (intaref a i) pivot int) 0) exit [])
- (assign i (+ i 1)))
- with [])
- (catch
- (while 1
- (if (<= j lo) exit [])
- (if (< (app cmp (intaref a j) pivot int) 0) exit [])
- (assign j (- j 1)))
- with [])
- (if (< i j)
- (let temp (intaref a i)
- (intaset a i (intaref a j))
- (intaset a j temp))
- []))
- (let temp (intaref a i)
- (intaset a i (intaref a hi))
- (intaset a hi temp))
- (app "quick" lo (- i 1) a cmp unit)
- (app "quick" (+ i 1) hi a cmp unit))
- []))
-
-(function "quicksort" (lo: int hi: int a: addr)
- (app "quick" lo hi a "cmp" unit))
diff --git a/testasmcomp/soli.cmm b/testasmcomp/soli.cmm
deleted file mode 100644
index 47ce64c0b5..0000000000
--- a/testasmcomp/soli.cmm
+++ /dev/null
@@ -1,109 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-("d1": int 0 int 1
- "d2": int 1 int 0
- "d3": int 0 int -1
- "d4": int -1 int 0
- "dir": addr "d1" addr "d2" addr "d3" addr "d4")
-
-("counter": int 0)
-
-(* Out = 0 Empty = 1 Peg = 2 *)
-
-("line0": int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0
- "line1": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0
- "line2": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0
- "line3": int 0 int 2 int 2 int 2 int 2 int 2 int 2 int 2 int 0
- "line4": int 0 int 2 int 2 int 2 int 1 int 2 int 2 int 2 int 0
- "line5": int 0 int 2 int 2 int 2 int 2 int 2 int 2 int 2 int 0
- "line6": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0
- "line7": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0
- "line8": int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0
- "board": addr "line0" addr "line1" addr "line2" addr "line3"
- addr "line4" addr "line5" addr "line6" addr "line7" addr "line8")
-
-("format": string "%d\n\000")
-
-(function "solve" (m: int)
- (store int "counter" (+ (load int "counter") 1))
- (if (== m 31)
- (== (intaref (addraref "board" 4) 4) 2)
- (try
- (if (== (mod (load int "counter") 500) 0)
- (extcall "printf_int" "format" (load int "counter") unit)
- [])
- (let i 1
- (while (<= i 7)
- (let j 1
- (while (<= j 7)
- (if (== (intaref (addraref "board" i) j) 2)
- (seq
- (let k 0
- (while (<= k 3)
- (let (d1 (intaref (addraref "dir" k) 0)
- d2 (intaref (addraref "dir" k) 1)
- i1 (+ i d1)
- i2 (+ i1 d1)
- j1 (+ j d2)
- j2 (+ j1 d2))
- (if (== (intaref (addraref "board" i1) j1) 2)
- (if (== (intaref (addraref "board" i2) j2) 1)
- (seq
- (intaset (addraref "board" i) j 1)
- (intaset (addraref "board" i1) j1 1)
- (intaset (addraref "board" i2) j2 2)
- (if (app "solve" (+ m 1) int)
- (raise 0a)
- [])
- (intaset (addraref "board" i) j 2)
- (intaset (addraref "board" i1) j1 2)
- (intaset (addraref "board" i2) j2 1))
- [])
- []))
- (assign k (+ k 1)))))
- [])
- (assign j (+ j 1))))
- (assign i (+ i 1))))
- 0
- with bucket
- 1)))
-
-("format_out": string ".\000")
-("format_empty": string " \000")
-("format_peg": string "$\000")
-("format_newline": string "\n\000")
-
-(function "print_board" ()
- (let i 0
- (while (< i 9)
- (let j 0
- (while (< j 9)
- (switch 3 (intaref (addraref "board" i) j)
- case 0:
- (extcall "print_string" "format_out" unit)
- case 1:
- (extcall "print_string" "format_empty" unit)
- case 2:
- (extcall "print_string" "format_peg" unit))
- (assign j (+ j 1))))
- (extcall "print_string" "format_newline" unit)
- (assign i (+ i 1)))))
-
-(function "solitaire" ()
- (seq
- (if (app "solve" 0 int)
- (app "print_board" [] unit)
- [])
- 0))
diff --git a/testasmcomp/sparc.S b/testasmcomp/sparc.S
deleted file mode 100644
index 9a829e1732..0000000000
--- a/testasmcomp/sparc.S
+++ /dev/null
@@ -1,41 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#ifndef SYS_solaris
-#define Call_gen_code _call_gen_code
-#define Caml_c_call _caml_c_call
-#else
-#define Call_gen_code call_gen_code
-#define Caml_c_call caml_c_call
-#endif
-
- .global Call_gen_code
-Call_gen_code:
- save %sp, -96, %sp
- mov %i0, %l0
- mov %i1, %i0
- mov %i2, %i1
- mov %i3, %i2
- mov %i4, %i3
- mov %i5, %i4
- call %l0
- nop
- mov %o0, %i0
- ret
- restore
-
- .global Caml_c_call
-Caml_c_call:
- jmp %g4
- nop
diff --git a/testasmcomp/tagged-fib.cmm b/testasmcomp/tagged-fib.cmm
deleted file mode 100644
index e5e45b0fbf..0000000000
--- a/testasmcomp/tagged-fib.cmm
+++ /dev/null
@@ -1,19 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(function "fib" (n: int)
- (if (< n 5)
- 3
- (- (+ (app "fib" (- n 2) int) (app "fib" (- n 4) int)) 1)))
-
diff --git a/testasmcomp/tagged-integr.cmm b/testasmcomp/tagged-integr.cmm
deleted file mode 100644
index df46813eb9..0000000000
--- a/testasmcomp/tagged-integr.cmm
+++ /dev/null
@@ -1,45 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-("res_square": skip 8)
-("h": skip 8)
-("x": skip 8)
-("s": skip 8)
-("res_integr": skip 8)
-
-(function "square" (x: addr)
- (let r "res_square"
- (store float r ( *f (load float x) (load float x)))
- r))
-
-(function "integr" (f: addr low: addr high: addr n: int)
- (let (h "h" x "x" s "s" i n)
- (store float h (/f (-f (load float high) (load float low)) (floatofint n)))
- (store float x (load float low))
- (store float s 0.0)
- (while (> i 0)
- (store float s (+f (load float s) (load float (app f x addr))))
- (store float x (+f (load float x) (load float h)))
- (assign i (- i 1)))
- (store float "res_integr" ( *f (load float s) (load float h)))
- "res_integr"))
-
-("low": skip 8)
-("hi": skip 8)
-
-(function "test" (n: int)
- (store float "low" 0.0)
- (store float "hi" 1.0)
- (load float (app "integr" "square" "low" "hi" n addr)))
-
diff --git a/testasmcomp/tagged-quicksort.cmm b/testasmcomp/tagged-quicksort.cmm
deleted file mode 100644
index b519e5cef9..0000000000
--- a/testasmcomp/tagged-quicksort.cmm
+++ /dev/null
@@ -1,46 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(function "quick" (lo: int hi: int a: addr)
- (if (< lo hi)
- (let (i lo
- j hi
- pivot (addraref a (>>s hi 1)))
- (while (< i j)
- (catch
- (while 1
- (if (>= i hi) exit [])
- (if (> (addraref a (>>s i 1)) pivot) exit [])
- (assign i (+ i 2)))
- with [])
- (catch
- (while 1
- (if (<= j lo) exit [])
- (if (< (addraref a (>>s j 1)) pivot) exit [])
- (assign j (- j 2)))
- with [])
- (if (< i j)
- (let temp (addraref a (>>s i 1))
- (addraset a (>>s i 1) (addraref a (>>s j 1)))
- (addraset a (>>s j 1) temp))
- []))
- (let temp (addraref a (>>s i 1))
- (addraset a (>>s i 1) (addraref a (>>s hi 1)))
- (addraset a (>>s hi 1) temp))
- (app "quick" lo (- i 2) a unit)
- (app "quick" (+ i 2) hi a unit))
- []))
-
-(function "quicksort" (lo: int hi: int a: addr)
- (app "quick" (+ (<< lo 1) 1) (+ (<< hi 1) 1) a unit))
diff --git a/testasmcomp/tagged-tak.cmm b/testasmcomp/tagged-tak.cmm
deleted file mode 100644
index fe9e6eb026..0000000000
--- a/testasmcomp/tagged-tak.cmm
+++ /dev/null
@@ -1,23 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(function "tak" (x:int y:int z:int)
- (if (> x y)
- (app "tak" (app "tak" (- x 2) y z int)
- (app "tak" (- y 2) z x int)
- (app "tak" (- z 2) x y int) int)
- z))
-
-(function "takmain" (dummy: int)
- (app "tak" 37 25 13 int))
diff --git a/testasmcomp/tak.cmm b/testasmcomp/tak.cmm
deleted file mode 100644
index cd61ec89be..0000000000
--- a/testasmcomp/tak.cmm
+++ /dev/null
@@ -1,23 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(function "tak" (x:int y:int z:int)
- (if (> x y)
- (app "tak" (app "tak" (- x 1) y z int)
- (app "tak" (- y 1) z x int)
- (app "tak" (- z 1) x y int) int)
- z))
-
-(function "takmain" (dummy: int)
- (app "tak" 18 12 6 int))
diff --git a/testlabl/.cvsignore b/testlabl/.cvsignore
deleted file mode 100644
index 4c57147b38..0000000000
--- a/testlabl/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-*.out *.out2 \ No newline at end of file
diff --git a/testlabl/Makefile b/testlabl/Makefile
deleted file mode 100644
index f75e7007dd..0000000000
--- a/testlabl/Makefile
+++ /dev/null
@@ -1,17 +0,0 @@
-# $Id$
-# Test extensions
-
-CAMLTOP=../boot/ocamlrun ../ocaml -I ../stdlib
-
-test: test-poly
-
-test-poly:
- TERM=norepeat $(CAMLTOP) < poly.ml > poly.out 2>&1
- TERM=norepeat $(CAMLTOP) -principal < poly.ml > poly.out2 2>&1
- @diff poly.exp poly.out && echo ocaml OK || echo ocaml changed
- @diff poly.exp2 poly.out2 && echo ocaml -principal OK \
- || echo ocaml -principal changed
-
-promote:
- mv poly.out poly.exp
- mv poly.out2 poly.exp2
diff --git a/testlabl/bugs/yamagata021012.ml b/testlabl/bugs/yamagata021012.ml
deleted file mode 100644
index 212a1683fa..0000000000
--- a/testlabl/bugs/yamagata021012.ml
+++ /dev/null
@@ -1,193 +0,0 @@
-(* The module begins *)
-exception Out_of_range
-
-class type ['a] cursor =
- object
- method get : 'a
- method incr : unit -> unit
- method is_last : bool
- end
-
-class type ['a] storage =
- object ('self)
- method first : 'a cursor
- method len : int
- method nth : int -> 'a cursor
- method copy : 'self
- method sub : int -> int -> 'self
- method concat : 'a storage -> 'self
- method fold : 'b. ('a -> int -> 'b -> 'b) -> 'b -> 'b
- method iter : ('a -> unit) -> unit
- end
-
-class virtual ['a, 'cursor] storage_base =
- object (self : 'self)
- constraint 'cursor = 'a #cursor
- method virtual first : 'cursor
- method virtual len : int
- method virtual copy : 'self
- method virtual sub : int -> int -> 'self
- method virtual concat : 'a storage -> 'self
- method fold : 'b. ('a -> int -> 'b -> 'b) -> 'b -> 'b = fun f a0 ->
- let cur = self#first in
- let rec loop count a =
- if count >= self#len then a else
- let a' = f cur#get count a in
- cur#incr (); loop (count + 1) a'
- in
- loop 0 a0
- method iter proc =
- let p = self#first in
- for i = 0 to self#len - 2 do proc p#get; p#incr () done;
- if self#len > 0 then proc p#get else ()
- end
-
-class type ['a] obj_input_channel =
- object
- method get : unit -> 'a
- method close : unit -> unit
- end
-
-class type ['a] obj_output_channel =
- object
- method put : 'a -> unit
- method flush : unit -> unit
- method close : unit -> unit
- end
-
-module UChar =
-struct
-
- type t = int
-
- let highest_bit = 1 lsl 30
- let lower_bits = highest_bit - 1
-
- let char_of c =
- try Char.chr c with Invalid_argument _ -> raise Out_of_range
-
- let of_char = Char.code
-
- let code c =
- if c lsr 30 = 0
- then c
- else raise Out_of_range
-
- let chr n =
- if n >= 0 && (n lsr 31 = 0) then n else raise Out_of_range
-
- let uint_code c = c
- let chr_of_uint n = n
-
-end
-
-type uchar = UChar.t
-
-let int_of_uchar u = UChar.uint_code u
-let uchar_of_int n = UChar.chr_of_uint n
-
-class type ucursor = [uchar] cursor
-
-class type ustorage = [uchar] storage
-
-class virtual ['ucursor] ustorage_base = [uchar, 'ucursor] storage_base
-
-module UText =
-struct
-
-(* the internal representation is UCS4 with big endian*)
-(* The most significant digit appears first. *)
-let get_buf s i =
- let n = Char.code s.[i] in
- let n = (n lsl 8) lor (Char.code s.[i + 1]) in
- let n = (n lsl 8) lor (Char.code s.[i + 2]) in
- let n = (n lsl 8) lor (Char.code s.[i + 3]) in
- UChar.chr_of_uint n
-
-let set_buf s i u =
- let n = UChar.uint_code u in
- begin
- s.[i] <- Char.chr (n lsr 24);
- s.[i + 1] <- Char.chr (n lsr 16 lor 0xff);
- s.[i + 2] <- Char.chr (n lsr 8 lor 0xff);
- s.[i + 3] <- Char.chr (n lor 0xff);
- end
-
-let init_buf buf pos init =
- if init#len = 0 then () else
- let cur = init#first in
- for i = 0 to init#len - 2 do
- set_buf buf (pos + i lsl 2) (cur#get); cur#incr ()
- done;
- set_buf buf (pos + (init#len - 1) lsl 2) (cur#get)
-
-let make_buf init =
- let s = String.create (init#len lsl 2) in
- init_buf s 0 init; s
-
-class text_raw buf =
- object (self : 'self)
- inherit [cursor] ustorage_base
- val contents = buf
- method first = new cursor (self :> text_raw) 0
- method len = (String.length contents) / 4
- method get i = get_buf contents (4 * i)
- method nth i = new cursor (self :> text_raw) i
- method copy = {< contents = String.copy contents >}
- method sub pos len =
- {< contents = String.sub contents (pos * 4) (len * 4) >}
- method concat (text : ustorage) =
- let buf = String.create (String.length contents + 4 * text#len) in
- String.blit contents 0 buf 0 (String.length contents);
- init_buf buf (String.length contents) text;
- {< contents = buf >}
- end
-and cursor text i =
- object
- val contents = text
- val mutable pos = i
- method get = contents#get pos
- method incr () = pos <- pos + 1
- method is_last = (pos + 1 >= contents#len)
- end
-
-class string_raw buf =
- object
- inherit text_raw buf
- method set i u = set_buf contents (4 * i) u
- end
-
-class text init = text_raw (make_buf init)
-class string init = string_raw (make_buf init)
-
-let of_string s =
- let buf = String.make (4 * String.length s) '\000' in
- for i = 0 to String.length s - 1 do
- buf.[4 * i] <- s.[i]
- done;
- new text_raw buf
-
-let make len u =
- let s = String.create (4 * len) in
- for i = 0 to len - 1 do set_buf s (4 * i) u done;
- new string_raw s
-
-let create len = make len (UChar.chr 0)
-
-let copy s = s#copy
-
-let sub s start len = s#sub start len
-
-let fill s start len u =
- for i = start to start + len - 1 do s#set i u done
-
-let blit src srcoff dst dstoff len =
- for i = 0 to len - 1 do
- let u = src#get (srcoff + i) in
- dst#set (dstoff + i) u
- done
-
-let concat s1 s2 = s1#concat (s2 (* : #ustorage *) :> uchar storage)
-
-let iter proc s = s#iter proc
-end
diff --git a/testlabl/dirs_multimatch b/testlabl/dirs_multimatch
deleted file mode 100644
index b449514644..0000000000
--- a/testlabl/dirs_multimatch
+++ /dev/null
@@ -1 +0,0 @@
-parsing typing bytecomp driver toplevel \ No newline at end of file
diff --git a/testlabl/dirs_poly b/testlabl/dirs_poly
deleted file mode 100644
index 3aec606ed4..0000000000
--- a/testlabl/dirs_poly
+++ /dev/null
@@ -1 +0,0 @@
-bytecomp byterun driver parsing stdlib tools toplevel typing utils otherlibs/labltk/browser/searchpos.ml
diff --git a/testlabl/mixin.ml b/testlabl/mixin.ml
deleted file mode 100644
index b08e7cdfc7..0000000000
--- a/testlabl/mixin.ml
+++ /dev/null
@@ -1,146 +0,0 @@
-(* $Id$ *)
-
-open StdLabels
-open MoreLabels
-
-(* Use maps for substitutions and sets for free variables *)
-
-module Subst = Map.Make(struct type t = string let compare = compare end)
-module Names = Set.Make(struct type t = string let compare = compare end)
-
-
-(* Variables are common to lambda and expr *)
-
-type var = [`Var of string]
-
-let subst_var ~subst : var -> _ =
- function `Var s as x ->
- try Subst.find s subst
- with Not_found -> x
-
-let free_var : var -> _ = function `Var s -> Names.singleton s
-
-
-(* The lambda language: free variables, substitutions, and evaluation *)
-
-type 'a lambda = [`Var of string | `Abs of string * 'a | `App of 'a * 'a]
-
-let free_lambda ~free_rec : _ lambda -> _ = function
- #var as x -> free_var x
- | `Abs (s, t) -> Names.remove s (free_rec t)
- | `App (t1, t2) -> Names.union (free_rec t1) (free_rec t2)
-
-let map_lambda ~map_rec : _ lambda -> _ = function
- #var as x -> x
- | `Abs (s, t) as l ->
- let t' = map_rec t in
- if t == t' then l else `Abs(s, t')
- | `App (t1, t2) as l ->
- let t'1 = map_rec t1 and t'2 = map_rec t2 in
- if t'1 == t1 && t'2 == t2 then l else `App (t'1, t'2)
-
-let next_id =
- let current = ref 3 in
- fun () -> incr current; !current
-
-let subst_lambda ~subst_rec ~free ~subst : _ lambda -> _ = function
- #var as x -> subst_var ~subst x
- | `Abs(s, t) as l ->
- let used = free t in
- let used_expr =
- Subst.fold subst ~init:[]
- ~f:(fun ~key ~data acc ->
- if Names.mem s used then data::acc else acc) in
- if List.exists used_expr ~f:(fun t -> Names.mem s (free t)) then
- let name = s ^ string_of_int (next_id ()) in
- `Abs(name,
- subst_rec ~subst:(Subst.add ~key:s ~data:(`Var name) subst) t)
- else
- map_lambda ~map_rec:(subst_rec ~subst:(Subst.remove s subst)) l
- | `App _ as l ->
- map_lambda ~map_rec:(subst_rec ~subst) l
-
-let eval_lambda ~eval_rec ~subst l =
- match map_lambda ~map_rec:eval_rec l with
- `App(`Abs(s,t1), t2) ->
- eval_rec (subst ~subst:(Subst.add ~key:s ~data:t2 Subst.empty) t1)
- | t -> t
-
-(* Specialized versions to use on lambda *)
-
-let rec free1 x = free_lambda ~free_rec:free1 x
-let rec subst1 ~subst = subst_lambda ~subst_rec:subst1 ~free:free1 ~subst
-let rec eval1 x = eval_lambda ~eval_rec:eval1 ~subst:subst1 x
-
-
-(* The expr language of arithmetic expressions *)
-
-type 'a expr =
- [`Var of string | `Num of int | `Add of 'a * 'a
- | `Neg of 'a | `Mult of 'a * 'a]
-
-let free_expr ~free_rec : _ expr -> _ = function
- #var as x -> free_var x
- | `Num _ -> Names.empty
- | `Add(x, y) -> Names.union (free_rec x) (free_rec y)
- | `Neg x -> free_rec x
- | `Mult(x, y) -> Names.union (free_rec x) (free_rec y)
-
-(* Here map_expr helps a lot *)
-let map_expr ~map_rec : _ expr -> _ = function
- #var as x -> x
- | `Num _ as x -> x
- | `Add(x, y) as e ->
- let x' = map_rec x and y' = map_rec y in
- if x == x' && y == y' then e
- else `Add(x', y')
- | `Neg x as e ->
- let x' = map_rec x in
- if x == x' then e else `Neg x'
- | `Mult(x, y) as e ->
- let x' = map_rec x and y' = map_rec y in
- if x == x' && y == y' then e
- else `Mult(x', y')
-
-let subst_expr ~subst_rec ~subst : _ expr -> _ = function
- #var as x -> subst_var ~subst x
- | #expr as e -> map_expr ~map_rec:(subst_rec ~subst) e
-
-let eval_expr ~eval_rec e =
- match map_expr ~map_rec:eval_rec e with
- `Add(`Num m, `Num n) -> `Num (m+n)
- | `Neg(`Num n) -> `Num (-n)
- | `Mult(`Num m, `Num n) -> `Num (m*n)
- | #expr as e -> e
-
-(* Specialized versions *)
-
-let rec free2 x = free_expr ~free_rec:free2 x
-let rec subst2 ~subst = subst_expr ~subst_rec:subst2 ~subst
-let rec eval2 x = eval_expr ~eval_rec:eval2 x
-
-
-(* The lexpr language, reunion of lambda and expr *)
-
-type lexpr =
- [ `Var of string | `Abs of string * lexpr | `App of lexpr * lexpr
- | `Num of int | `Add of lexpr * lexpr | `Neg of lexpr
- | `Mult of lexpr * lexpr ]
-
-let rec free : lexpr -> _ = function
- #lambda as x -> free_lambda ~free_rec:free x
- | #expr as x -> free_expr ~free_rec:free x
-
-let rec subst ~subst:s : lexpr -> _ = function
- #lambda as x -> subst_lambda ~subst_rec:subst ~subst:s ~free x
- | #expr as x -> subst_expr ~subst_rec:subst ~subst:s x
-
-let rec eval : lexpr -> _ = function
- #lambda as x -> eval_lambda ~eval_rec:eval ~subst x
- | #expr as x -> eval_expr ~eval_rec:eval x
-
-(* A few examples:
-eval1 (`App(`Abs("x",`Var"x"), `Var"y"));;
-eval2 (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x"));;
-eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5));;
-*)
diff --git a/testlabl/mixin2.ml b/testlabl/mixin2.ml
deleted file mode 100644
index fa56857340..0000000000
--- a/testlabl/mixin2.ml
+++ /dev/null
@@ -1,179 +0,0 @@
-(* $Id$ *)
-
-(* Full fledge version, using objects to structure code *)
-
-open StdLabels
-open MoreLabels
-
-(* Use maps for substitutions and sets for free variables *)
-
-module Subst = Map.Make(struct type t = string let compare = compare end)
-module Names = Set.Make(struct type t = string let compare = compare end)
-
-(* To build recursive objects *)
-
-let lazy_fix make =
- let rec obj () = make (lazy (obj ()) : _ Lazy.t) in
- obj ()
-
-let (!!) = Lazy.force
-
-(* The basic operations *)
-
-class type ['a, 'b] ops =
- object
- method free : 'b -> Names.t
- method subst : sub:'a Subst.t -> 'b -> 'a
- method eval : 'b -> 'a
- end
-
-(* Variables are common to lambda and expr *)
-
-type var = [`Var of string]
-
-class ['a] var_ops = object (self : ('a, var) #ops)
- constraint 'a = [> var]
- method subst ~sub (`Var s as x) =
- try Subst.find s sub with Not_found -> x
- method free (`Var s) =
- Names.singleton s
- method eval (#var as v) = v
-end
-
-(* The lambda language: free variables, substitutions, and evaluation *)
-
-type 'a lambda = [`Var of string | `Abs of string * 'a | `App of 'a * 'a]
-
-let next_id =
- let current = ref 3 in
- fun () -> incr current; !current
-
-class ['a] lambda_ops (ops : ('a,'a) #ops Lazy.t) =
- let var : 'a var_ops = new var_ops
- and free = lazy !!ops#free
- and subst = lazy !!ops#subst
- and eval = lazy !!ops#eval in
- object (self : ('a, 'a lambda) #ops)
- constraint 'a = [> 'a lambda]
- method free = function
- #var as x -> var#free x
- | `Abs (s, t) -> Names.remove s (!!free t)
- | `App (t1, t2) -> Names.union (!!free t1) (!!free t2)
-
- method map ~f = function
- #var as x -> x
- | `Abs (s, t) as l ->
- let t' = f t in
- if t == t' then l else `Abs(s, t')
- | `App (t1, t2) as l ->
- let t'1 = f t1 and t'2 = f t2 in
- if t'1 == t1 && t'2 == t2 then l else `App (t'1, t'2)
-
- method subst ~sub = function
- #var as x -> var#subst ~sub x
- | `Abs(s, t) as l ->
- let used = !!free t in
- let used_expr =
- Subst.fold sub ~init:[]
- ~f:(fun ~key ~data acc ->
- if Names.mem s used then data::acc else acc) in
- if List.exists used_expr ~f:(fun t -> Names.mem s (!!free t)) then
- let name = s ^ string_of_int (next_id ()) in
- `Abs(name,
- !!subst ~sub:(Subst.add ~key:s ~data:(`Var name) sub) t)
- else
- self#map ~f:(!!subst ~sub:(Subst.remove s sub)) l
- | `App _ as l ->
- self#map ~f:(!!subst ~sub) l
-
- method eval l =
- match self#map ~f:!!eval l with
- `App(`Abs(s,t1), t2) ->
- !!eval (!!subst ~sub:(Subst.add ~key:s ~data:t2 Subst.empty) t1)
- | t -> t
-end
-
-(* Operations specialized to lambda *)
-
-let lambda = lazy_fix (new lambda_ops)
-
-(* The expr language of arithmetic expressions *)
-
-type 'a expr =
- [ `Var of string | `Num of int | `Add of 'a * 'a
- | `Neg of 'a | `Mult of 'a * 'a]
-
-class ['a] expr_ops (ops : ('a,'a) #ops Lazy.t) =
- let var : 'a var_ops = new var_ops
- and free = lazy !!ops#free
- and subst = lazy !!ops#subst
- and eval = lazy !!ops#eval in
- object (self : ('a, 'a expr) #ops)
- constraint 'a = [> 'a expr]
- method free = function
- #var as x -> var#free x
- | `Num _ -> Names.empty
- | `Add(x, y) -> Names.union (!!free x) (!!free y)
- | `Neg x -> !!free x
- | `Mult(x, y) -> Names.union (!!free x) (!!free y)
-
- method map ~f = function
- #var as x -> x
- | `Num _ as x -> x
- | `Add(x, y) as e ->
- let x' = f x and y' = f y in
- if x == x' && y == y' then e
- else `Add(x', y')
- | `Neg x as e ->
- let x' = f x in
- if x == x' then e else `Neg x'
- | `Mult(x, y) as e ->
- let x' = f x and y' = f y in
- if x == x' && y == y' then e
- else `Mult(x', y')
-
- method subst ~sub = function
- #var as x -> var#subst ~sub x
- | #expr as e -> self#map ~f:(!!subst ~sub) e
-
- method eval (#expr as e) =
- match self#map ~f:!!eval e with
- `Add(`Num m, `Num n) -> `Num (m+n)
- | `Neg(`Num n) -> `Num (-n)
- | `Mult(`Num m, `Num n) -> `Num (m*n)
- | e -> e
- end
-
-(* Specialized versions *)
-
-let expr = lazy_fix (new expr_ops)
-
-(* The lexpr language, reunion of lambda and expr *)
-
-type 'a lexpr = [ 'a lambda | 'a expr ]
-
-class ['a] lexpr_ops (ops : ('a,'a) #ops Lazy.t) =
- let lambda = new lambda_ops ops in
- let expr = new expr_ops ops in
- object (self : ('a, 'a lexpr) #ops)
- constraint 'a = [> 'a lexpr]
- method free = function
- #lambda as x -> lambda#free x
- | #expr as x -> expr#free x
-
- method subst ~sub = function
- #lambda as x -> lambda#subst ~sub x
- | #expr as x -> expr#subst ~sub x
-
- method eval = function
- #lambda as x -> lambda#eval x
- | #expr as x -> expr#eval x
-end
-
-let lexpr = lazy_fix (new lexpr_ops)
-
-(* A few examples:
-lambda#eval (`App(`Abs("x",`Var"x"), `Var"y"));;
-expr#eval (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x"));;
-lexpr#eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5));;
-*)
diff --git a/testlabl/mixin3.ml b/testlabl/mixin3.ml
deleted file mode 100644
index daae839e6a..0000000000
--- a/testlabl/mixin3.ml
+++ /dev/null
@@ -1,173 +0,0 @@
-(* $Id$ *)
-
-(* Full fledge version, using objects to structure code *)
-
-open StdLabels
-open MoreLabels
-
-(* Use maps for substitutions and sets for free variables *)
-
-module Subst = Map.Make(struct type t = string let compare = compare end)
-module Names = Set.Make(struct type t = string let compare = compare end)
-
-(* To build recursive objects *)
-
-let lazy_fix make =
- let rec obj () = make (lazy (obj ()) : _ Lazy.t) in
- obj ()
-
-let (!!) = Lazy.force
-
-(* The basic operations *)
-
-class type ['a, 'b] ops =
- object
- method free : 'b -> Names.t
- method subst : sub:'a Subst.t -> 'b -> 'a
- method eval : 'b -> 'a
- end
-
-(* Variables are common to lambda and expr *)
-
-type var = [`Var of string]
-
-let var = object (self : ([>var], var) #ops)
- method subst ~sub (`Var s as x) =
- try Subst.find s sub with Not_found -> x
- method free (`Var s) =
- Names.singleton s
- method eval (#var as v) = v
-end
-
-(* The lambda language: free variables, substitutions, and evaluation *)
-
-type 'a lambda = [`Var of string | `Abs of string * 'a | `App of 'a * 'a]
-
-let next_id =
- let current = ref 3 in
- fun () -> incr current; !current
-
-let lambda_ops (ops : ('a,'a) #ops Lazy.t) =
- let free = lazy !!ops#free
- and subst = lazy !!ops#subst
- and eval = lazy !!ops#eval in
- object (self : ([> 'a lambda], 'a lambda) #ops)
- method free = function
- #var as x -> var#free x
- | `Abs (s, t) -> Names.remove s (!!free t)
- | `App (t1, t2) -> Names.union (!!free t1) (!!free t2)
-
- method private map ~f = function
- #var as x -> x
- | `Abs (s, t) as l ->
- let t' = f t in
- if t == t' then l else `Abs(s, t')
- | `App (t1, t2) as l ->
- let t'1 = f t1 and t'2 = f t2 in
- if t'1 == t1 && t'2 == t2 then l else `App (t'1, t'2)
-
- method subst ~sub = function
- #var as x -> var#subst ~sub x
- | `Abs(s, t) as l ->
- let used = !!free t in
- let used_expr =
- Subst.fold sub ~init:[]
- ~f:(fun ~key ~data acc ->
- if Names.mem s used then data::acc else acc) in
- if List.exists used_expr ~f:(fun t -> Names.mem s (!!free t)) then
- let name = s ^ string_of_int (next_id ()) in
- `Abs(name,
- !!subst ~sub:(Subst.add ~key:s ~data:(`Var name) sub) t)
- else
- self#map ~f:(!!subst ~sub:(Subst.remove s sub)) l
- | `App _ as l ->
- self#map ~f:(!!subst ~sub) l
-
- method eval l =
- match self#map ~f:!!eval l with
- `App(`Abs(s,t1), t2) ->
- !!eval (!!subst ~sub:(Subst.add ~key:s ~data:t2 Subst.empty) t1)
- | t -> t
-end
-
-(* Operations specialized to lambda *)
-
-let lambda = lazy_fix lambda_ops
-
-(* The expr language of arithmetic expressions *)
-
-type 'a expr =
- [ `Var of string | `Num of int | `Add of 'a * 'a
- | `Neg of 'a | `Mult of 'a * 'a]
-
-let expr_ops (ops : ('a,'a) #ops Lazy.t) =
- let free = lazy !!ops#free
- and subst = lazy !!ops#subst
- and eval = lazy !!ops#eval in
- object (self : ([> 'a expr], 'a expr) #ops)
- method free = function
- #var as x -> var#free x
- | `Num _ -> Names.empty
- | `Add(x, y) -> Names.union (!!free x) (!!free y)
- | `Neg x -> !!free x
- | `Mult(x, y) -> Names.union (!!free x) (!!free y)
-
- method private map ~f = function
- #var as x -> x
- | `Num _ as x -> x
- | `Add(x, y) as e ->
- let x' = f x and y' = f y in
- if x == x' && y == y' then e
- else `Add(x', y')
- | `Neg x as e ->
- let x' = f x in
- if x == x' then e else `Neg x'
- | `Mult(x, y) as e ->
- let x' = f x and y' = f y in
- if x == x' && y == y' then e
- else `Mult(x', y')
-
- method subst ~sub = function
- #var as x -> var#subst ~sub x
- | #expr as e -> self#map ~f:(!!subst ~sub) e
-
- method eval (#expr as e) =
- match self#map ~f:!!eval e with
- `Add(`Num m, `Num n) -> `Num (m+n)
- | `Neg(`Num n) -> `Num (-n)
- | `Mult(`Num m, `Num n) -> `Num (m*n)
- | e -> e
- end
-
-(* Specialized versions *)
-
-let expr = lazy_fix expr_ops
-
-(* The lexpr language, reunion of lambda and expr *)
-
-type 'a lexpr = [ 'a lambda | 'a expr ]
-
-let lexpr_ops (ops : ('a,'a) #ops Lazy.t) =
- let lambda = lambda_ops ops in
- let expr = expr_ops ops in
- object (self : ([> 'a lexpr], 'a lexpr) #ops)
- method free = function
- #lambda as x -> lambda#free x
- | #expr as x -> expr#free x
-
- method subst ~sub = function
- #lambda as x -> lambda#subst ~sub x
- | #expr as x -> expr#subst ~sub x
-
- method eval = function
- #lambda as x -> lambda#eval x
- | #expr as x -> expr#eval x
-end
-
-let lexpr = lazy_fix lexpr_ops
-
-(* A few examples:
-lambda#eval (`App(`Abs("x",`Var"x"), `Var"y"));;
-expr#eval (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x"));;
-lexpr#eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5));;
-*)
diff --git a/testlabl/multimatch.ml b/testlabl/multimatch.ml
deleted file mode 100644
index 4add221062..0000000000
--- a/testlabl/multimatch.ml
+++ /dev/null
@@ -1,157 +0,0 @@
-(* Simple example *)
-let f x =
- (multimatch x with `A -> 1 | `B -> true),
- (multimatch x with `A -> 1. | `B -> "1");;
-
-(* OK *)
-module M : sig
- val f :
- [< `A & 'a = int & 'b = float | `B & 'b =string & 'a = bool] -> 'a * 'b
-end = struct let f = f end;;
-
-(* Bad *)
-module M : sig
- val f :
- [< `A & 'a = int & 'b = float | `B & 'b =string & 'a = int] -> 'a * 'b
-end = struct let f = f end;;
-
-(* Should be good! *)
-module M : sig
- val f :
- [< `A & 'a = int * float | `B & 'a = bool * string] -> 'a
-end = struct let f = f end;;
-
-let f = multifun `A|`B as x -> f x;;
-
-(* Two-level example *)
-let f = multifun
- `A -> (multifun `C -> 1 | `D -> 1.)
- | `B -> (multifun `C -> true | `D -> "1");;
-
-(* OK *)
-module M : sig
- val f :
- [< `A & 'b = [< `C & 'a = int | `D & 'a = float & 'c = bool] -> 'a
- | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
-end = struct let f = f end;;
-
-(* Bad *)
-module M : sig
- val f :
- [< `A & 'b = [< `C & 'a = int | `D & 'a = bool] -> 'a
- | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
-end = struct let f = f end;;
-
-module M : sig
- val f :
- [< `A & 'b = [< `C & 'a = int | `D] -> 'a
- | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
-end = struct let f = f end;;
-
-
-(* Examples with hidden sharing *)
-let r = ref []
-let f = multifun `A -> 1 | `B -> true
-let g x = r := [f x];;
-
-(* Bad! *)
-module M : sig
- val g : [< `A & 'a = int | `B & 'a = bool] -> unit
-end = struct let g = g end;;
-
-let r = ref []
-let f = multifun `A -> r | `B -> ref [];;
-(* Now OK *)
-module M : sig
- val f : [< `A & 'b = int list ref | `B & 'b = 'c list ref] -> 'b
-end = struct let f = f end;;
-(* Still OK *)
-let l : int list ref = r;;
-module M : sig
- val f : [< `A & 'b = int list ref | `B & 'b = 'c list ref] -> 'b
-end = struct let f = f end;;
-
-
-(* Examples that would need unification *)
-let f = multifun `A -> (1, []) | `B -> (true, [])
-let g x = fst (f x);;
-(* Didn't work, now Ok *)
-module M : sig
- val g : [< `A & 'a * 'b = int * bool | `B & 'a * 'b = bool * int] -> 'a
-end = struct let g = g end;;
-let g = multifun (`A|`B) as x -> g x;;
-
-(* Other examples *)
-
-let f x =
- let a = multimatch x with `A -> 1 | `B -> "1" in
- (multifun `A -> print_int | `B -> print_string) x a
-;;
-
-let f = multifun (`A|`B) as x -> f x;;
-
-type unit_op = [`Set of int | `Move of int]
-type int_op = [`Get]
-
-let op r =
- multifun
- `Get -> !r
- | `Set x -> r := x
- | `Move dx -> r := !r + dx
-;;
-
-let rec trace r = function
- [] -> []
- | op1 :: ops ->
- multimatch op1 with
- #int_op as op1 ->
- let x = op r op1 in
- x :: trace r ops
- | #unit_op as op1 ->
- op r op1;
- trace r ops
-;;
-
-class point x = object
- val mutable x : int = x
- method get = x
- method set y = x <- y
- method move dx = x <- x + dx
-end;;
-
-let poly sort coeffs x =
- let add, mul, zero =
- multimatch sort with
- `Int -> (+), ( * ), 0
- | `Float -> (+.), ( *. ), 0.
- in
- let rec compute = function
- [] -> zero
- | c :: cs -> add c (mul x (compute cs))
- in
- compute coeffs
-;;
-
-module M : sig
- val poly : [< `Int & 'a = int | `Float & 'a = float] -> 'a list -> 'a -> 'a
-end = struct let poly = poly end;;
-
-type ('a,'b) num_sort =
- 'b constraint 'b = [< `Int & 'a = int | `Float & 'a = float]
-module M : sig
- val poly : ('a,_) num_sort -> 'a list -> 'a -> 'a
-end = struct let poly = poly end;;
-
-
-(* type dispatch *)
-
-let print0 = multifun
- `Int -> print_int
- | `Float -> print_float
-;;
-let print1 = multifun
- #num as x -> print0 x
- | `List t -> List.iter (print0 t)
- | `Pair(t1,t2) -> (fun (x,y) -> print0 t1 x; print0 t2 y)
-;;
-print1 (`Pair(`Int,`Float)) (1,1.0);;
diff --git a/testlabl/newlabels.ps b/testlabl/newlabels.ps
deleted file mode 100644
index 01eac1945b..0000000000
--- a/testlabl/newlabels.ps
+++ /dev/null
@@ -1,1458 +0,0 @@
-%!PS-Adobe-2.0
-%%Creator: dvipsk 5.78 p1.4 Copyright 1996-98 ASCII Corp.(www-ptex@ascii.co.jp)
-%%dvipsk 5.78 Copyright 1998 Radical Eye Software (www.radicaleye.com)
-%%Title: newlabels.dvi
-%%Pages: 2 0
-%%PageOrder: Ascend
-%%BoundingBox: 0 0 596 842
-%%EndComments
-%%BeginProcSet: PStoPS 1 15
-userdict begin
-[/showpage/erasepage/copypage]{dup where{pop dup load
- type/operatortype eq{1 array cvx dup 0 3 index cvx put
- bind def}{pop}ifelse}{pop}ifelse}forall
-[/letter/legal/executivepage/a4/a4small/b5/com10envelope
- /monarchenvelope/c5envelope/dlenvelope/lettersmall/note
- /folio/quarto/a5]{dup where{dup wcheck{exch{}put}
- {pop{}def}ifelse}{pop}ifelse}forall
-/setpagedevice {pop}bind 1 index where{dup wcheck{3 1 roll put}
- {pop def}ifelse}{def}ifelse
-/PStoPSmatrix matrix currentmatrix def
-/PStoPSxform matrix def/PStoPSclip{clippath}def
-/defaultmatrix{PStoPSmatrix exch PStoPSxform exch concatmatrix}bind def
-/initmatrix{matrix defaultmatrix setmatrix}bind def
-/initclip[{matrix currentmatrix PStoPSmatrix setmatrix
- [{currentpoint}stopped{$error/newerror false put{newpath}}
- {/newpath cvx 3 1 roll/moveto cvx 4 array astore cvx}ifelse]
- {[/newpath cvx{/moveto cvx}{/lineto cvx}
- {/curveto cvx}{/closepath cvx}pathforall]cvx exch pop}
- stopped{$error/errorname get/invalidaccess eq{cleartomark
- $error/newerror false put cvx exec}{stop}ifelse}if}bind aload pop
- /initclip dup load dup type dup/operatortype eq{pop exch pop}
- {dup/arraytype eq exch/packedarraytype eq or
- {dup xcheck{exch pop aload pop}{pop cvx}ifelse}
- {pop cvx}ifelse}ifelse
- {newpath PStoPSclip clip newpath exec setmatrix} bind aload pop]cvx def
-/initgraphics{initmatrix newpath initclip 1 setlinewidth
- 0 setlinecap 0 setlinejoin []0 setdash 0 setgray
- 10 setmiterlimit}bind def
-end
-%%EndProcSet
-%DVIPSCommandLine: dvips -f newlabels
-%DVIPSParameters: dpi=300
-%DVIPSSource: TeX output 1999.10.26:1616
-%%BeginProcSet: tex.pro
-%!
-/TeXDict 300 dict def TeXDict begin /N{def}def /B{bind def}N /S{exch}N
-/X{S N}B /TR{translate}N /isls false N /vsize 11 72 mul N /hsize 8.5 72
-mul N /landplus90{false}def /@rigin{isls{[0 landplus90{1 -1}{-1 1}
-ifelse 0 0 0]concat}if 72 Resolution div 72 VResolution div neg scale
-isls{landplus90{VResolution 72 div vsize mul 0 exch}{Resolution -72 div
-hsize mul 0}ifelse TR}if Resolution VResolution vsize -72 div 1 add mul
-TR[matrix currentmatrix{dup dup round sub abs 0.00001 lt{round}if}
-forall round exch round exch]setmatrix}N /@landscape{/isls true N}B
-/@manualfeed{statusdict /manualfeed true put}B /@copies{/#copies X}B
-/FMat[1 0 0 -1 0 0]N /FBB[0 0 0 0]N /nn 0 N /IE 0 N /ctr 0 N /df-tail{
-/nn 8 dict N nn begin /FontType 3 N /FontMatrix fntrx N /FontBBox FBB N
-string /base X array /BitMaps X /BuildChar{CharBuilder}N /Encoding IE N
-end dup{/foo setfont}2 array copy cvx N load 0 nn put /ctr 0 N[}B /df{
-/sf 1 N /fntrx FMat N df-tail}B /dfs{div /sf X /fntrx[sf 0 0 sf neg 0 0]
-N df-tail}B /E{pop nn dup definefont setfont}B /ch-width{ch-data dup
-length 5 sub get}B /ch-height{ch-data dup length 4 sub get}B /ch-xoff{
-128 ch-data dup length 3 sub get sub}B /ch-yoff{ch-data dup length 2 sub
-get 127 sub}B /ch-dx{ch-data dup length 1 sub get}B /ch-image{ch-data
-dup type /stringtype ne{ctr get /ctr ctr 1 add N}if}B /id 0 N /rw 0 N
-/rc 0 N /gp 0 N /cp 0 N /G 0 N /sf 0 N /CharBuilder{save 3 1 roll S dup
-/base get 2 index get S /BitMaps get S get /ch-data X pop /ctr 0 N ch-dx
-0 ch-xoff ch-yoff ch-height sub ch-xoff ch-width add ch-yoff
-setcachedevice ch-width ch-height true[1 0 0 -1 -.1 ch-xoff sub ch-yoff
-.1 sub]{ch-image}imagemask restore}B /D{/cc X dup type /stringtype ne{]}
-if nn /base get cc ctr put nn /BitMaps get S ctr S sf 1 ne{dup dup
-length 1 sub dup 2 index S get sf div put}if put /ctr ctr 1 add N}B /I{
-cc 1 add D}B /bop{userdict /bop-hook known{bop-hook}if /SI save N @rigin
-0 0 moveto /V matrix currentmatrix dup 1 get dup mul exch 0 get dup mul
-add .99 lt{/QV}{/RV}ifelse load def pop pop}N /eop{SI restore userdict
-/eop-hook known{eop-hook}if showpage}N /@start{userdict /start-hook
-known{start-hook}if pop /VResolution X /Resolution X 1000 div /DVImag X
-/IE 256 array N 2 string 0 1 255{IE S dup 360 add 36 4 index cvrs cvn
-put}for pop 65781.76 div /vsize X 65781.76 div /hsize X}N /p{show}N
-/RMat[1 0 0 -1 0 0]N /BDot 260 string N /rulex 0 N /ruley 0 N /v{/ruley
-X /rulex X V}B /V{}B /RV statusdict begin /product where{pop false[
-(Display)(NeXT)(LaserWriter 16/600)]{dup length product length le{dup
-length product exch 0 exch getinterval eq{pop true exit}if}{pop}ifelse}
-forall}{false}ifelse end{{gsave TR -.1 .1 TR 1 1 scale rulex ruley false
-RMat{BDot}imagemask grestore}}{{gsave TR -.1 .1 TR rulex ruley scale 1 1
-false RMat{BDot}imagemask grestore}}ifelse B /QV{gsave newpath transform
-round exch round exch itransform moveto rulex 0 rlineto 0 ruley neg
-rlineto rulex neg 0 rlineto fill grestore}B /a{moveto}B /delta 0 N /tail
-{dup /delta X 0 rmoveto}B /M{S p delta add tail}B /b{S p tail}B /c{-4 M}
-B /d{-3 M}B /e{-2 M}B /f{-1 M}B /g{0 M}B /h{1 M}B /i{2 M}B /j{3 M}B /k{
-4 M}B /w{0 rmoveto}B /l{p -4 w}B /m{p -3 w}B /n{p -2 w}B /o{p -1 w}B /q{
-p 1 w}B /r{p 2 w}B /s{p 3 w}B /t{p 4 w}B /x{0 S rmoveto}B /y{3 2 roll p
-a}B /bos{/SS save N}B /eos{SS restore}B end
-
-%%EndProcSet
-TeXDict begin 39158280 55380996 1000 300 300 (newlabels.dvi)
-@start
-%DVIPSBitmapFont: Fa cmr6 6 2
-/Fa 2 51 df<187898181818181818181818181818FF08107D8F0F> 49
-D<1F00618040C08060C0600060006000C00180030006000C00102020207FC0FFC00B107F
-8F0F> I E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fb cmmi8 8 4
-/Fb 4 111 df<FFC0FF1C00181C00101C00101C00103800203800203800203800207000
-40700040700040700040E00080E00080E00080E00080E00100E00200E004006008003830
-000FC00018177E9618> 85 D<0300038003000000000000000000000000001C00240046
-0046008C000C0018001800180031003100320032001C0009177F960C> 105
-D<383C1E0044C6630047028100460301008E0703000C0603000C0603000C060300180C06
-00180C0620180C0C20180C0C40301804C0301807001B0E7F8D1F> 109
-D<383C0044C6004702004602008E06000C06000C06000C0600180C00180C401818401818
-80300980300E00120E7F8D15> I E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fc cmbx8 8 4
-/Fc 4 111 df<01800780FF80FF80078007800780078007800780078007800780078007
-800780078007800780FFF8FFF80D157D9414> 49 D<387C7C7C3800000000FCFC3C3C3C
-3C3C3C3C3C3C3C3CFFFF08187F970B> 105 D<FC7E0FC0FD8730E03E07C0F03E07C0F03C
-0780F03C0780F03C0780F03C0780F03C0780F03C0780F03C0780F03C0780F03C0780F0FF
-1FE3FCFF1FE3FC1E0F7E8E23> 109 D<FC7C00FD8E003E0F003E0F003C0F003C0F003C0F
-003C0F003C0F003C0F003C0F003C0F003C0F00FF3FC0FF3FC0120F7E8E17> I
-E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fd cmsy8 8 3
-/Fd 3 93 df<FFFFF0FFFFF014027D881B> 0 D<020002000200C218F2783AE00F800F80
-3AE0F278C2180200020002000D0E7E8E12> 3 D<03F8001FFF003C07806000C0C00060C0
-0060C00060C00060C00060C00060C00060C00060C00060C00060C00060C00060C00060C0
-006040002013137E9218> 92 D E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fe cmtt12 12 43
-/Fe 43 125 df<01818003C3C003C3C003C3C003C3C003C3C003C3C07FFFF0FFFFF8FFFF
-F87FFFF00787800787800787800F8F800F0F000F0F000F0F000F0F007FFFF0FFFFF8FFFF
-F87FFFF01E1E001E1E001E1E001E1E001E1E001E1E000C0C00151E7E9D1A> 35
-D<00E00003F00007F8000738000E1C000E1C000E1C000E1C000E38000E39FC0E71FC07F1
-FC07E1C007C1C00781C00783800F83801FC3803DC70078E70070EE00E07E00E07E00E03C
-08E03C1CE07E1C70FF1C7FE7F83FC3F80F00E0161E7F9D1A> 38
-D<0038007800F001E003C007800F000E001C001C0038003800700070007000E000E000E0
-00E000E000E000E000E000E000E000700070007000380038001C001C000E000F00078003
-C001E000F8007800380D2878A21A> 40 D<6000F00078003C001E000F000780038001C0
-01C000E000E0007000700070003800380038003800380038003800380038003800700070
-007000E000E001C001C0038007800F001E003C007800F00060000D287CA21A> I<7FFFC0
-FFFFE0FFFFE07FFFC013047D901A> 45 D<00C001C001C003C007C00FC07FC0FDC071C0
-01C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C0
-7FFF7FFF7FFF101E7B9D1A> 49 D<03F8000FFE001FFF803C07C07801E07000E0E00070
-F00070F000706000700000700000700000E00000E00001C00003C0000780000F00001E00
-003C0000780000F00003E00007C0000F00001E00703C00707FFFF0FFFFF07FFFF0141E7D
-9D1A> I<03FC000FFF003FFFC03C03E07800E07800707800700000700000700000E00001
-E00007C003FF8003FF0003FFC00003E00000E0000070000078000038000038600038F000
-38F00078E000707000E07E03E03FFFC00FFF0001FC00151E7E9D1A> I<01FC0007FF001F
-FFC01F07C03C01E07800F07000707000707000707800F03800E01E03C00FFF8003FE0007
-FF001F8FC03C01E07800F0700070E00038E00038E00038E00038F000787000707800F03E
-03E01FFFC007FF0001FC00151E7E9D1A> 56 D<01F00007FC001FFE003E0F0038078070
-03807001C0E001C0E001C0E001E0E000E0E000E0E001E07001E07803E03C0FE01FFFE00F
-FCE003F0E00001C00001C00001C0000380600380F00700F00F00F03E007FFC003FF0000F
-C000131E7D9D1A> I<3078FCFC78300000000000000000003078FCFC7830061576941A>
-I<183C7E7E3C18000000000000000000183C7E7E3E1E0E0E1C3CF8F060071C77941A> I<
-0000C00003E00007E0000FC0003F80007E0000FC0003F80007E0000FC0003F80007E0000
-FC0000FC00007E00003F80000FC00007E00003F80000FC00007E00003F80000FC00007E0
-0003E00000C0131A7D9B1A> I<7FFFF0FFFFF8FFFFF87FFFF00000000000000000000000
-007FFFF0FFFFF8FFFFF87FFFF0150C7E941A> I<600000F80000FC00007E00003F80000F
-C00007E00003F80000FC00007E00003F80000FC00007E00007E0000FC0003F80007E0000
-FC0003F80007E0000FC0003F80007E0000FC0000F80000600000131A7D9B1A> I<007C38
-01FF3807FFF80F83F81E00F81C0078380078380038700038700038700000E00000E00000
-E00000E00000E00000E00000E00000E000007000007000387000383800383800381C0070
-1E00F00F83E007FFC001FF80007C00151E7E9D1A> 67 D<FE03FEFF03FEFF03FE1D8070
-1D80701DC0701CC0701CC0701CE0701CE0701C60701C70701C70701C30701C38701C3870
-1C18701C1C701C1C701C0C701C0E701C0E701C06701C06701C07701C03701C0370FF81F0
-FF81F0FF80F0171E7F9D1A> 78 D<03F8E00FFEE01FFFE03C07E07801E0F001E0E000E0
-E000E0E000E0E000007000007800003F80001FF80007FF00007FC00007E00000F0000070
-000038000038600038E00038E00038E00070F000F0FE01E0FFFFC0EFFF80E1FE00151E7E
-9D1A> 83 D<7FFFFEFFFFFEFFFFFEE0380EE0380EE0380EE0380E003800003800003800
-003800003800003800003800003800003800003800003800003800003800003800003800
-00380000380000380000380000380003FF8003FF8003FF80171E7F9D1A> I<FFFCFFFCFF
-FCE000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E0
-00E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000FFFCFFFCFF
-FC0E2776A21A> 91 D<FFFCFFFCFFFC001C001C001C001C001C001C001C001C001C001C
-001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C
-001C001C001C001C001CFFFCFFFCFFFC0E277FA21A> 93 D<1FF0003FFC007FFE00780F
-00300700000380000380007F8007FF801FFF803F8380780380700380E00380E00380E003
-80700780780F803FFFFC1FFDFC07F0FC16157D941A> 97 D<7E0000FE00007E00000E00
-000E00000E00000E00000E00000E00000E3E000EFF800FFFE00FC1F00F80700F00380E00
-380E001C0E001C0E001C0E001C0E001C0E001C0E001C0F00380F00780F80F00FC1E00FFF
-C00EFF80063E00161E7F9D1A> I<00FF8003FFC00FFFE01F01E03C00C078000070000070
-0000E00000E00000E00000E00000E000007000007000007800703C00701F01F00FFFE003
-FFC000FE0014157D941A> I<000FC0001FC0000FC00001C00001C00001C00001C00001C0
-0001C001F1C007FDC00FFFC01E0FC03C07C07803C07001C0E001C0E001C0E001C0E001C0
-E001C0E001C0E001C07003C07003C03807C03E0FC01FFFF807FDFC01F1F8161E7E9D1A>
-I<01F80007FF000FFF801E07C03C01C07800E07000E0E00070E00070FFFFF0FFFFF0FFFF
-F0E000007000007000007800703C00701F01F00FFFE003FF8000FE0014157D941A> I<00
-07E0001FF0003FF800787800F03000E00000E00000E00000E0007FFFF0FFFFF0FFFFF000
-E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000
-E00000E00000E0003FFF807FFFC03FFF80151E7F9D1A> I<7E0000FE00007E00000E0000
-0E00000E00000E00000E00000E00000E3E000EFF800FFFC00FC1C00F80E00F00E00E00E0
-0E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E07FC3FC
-FFE7FE7FC3FC171E7F9D1A> 104 D<00C00001E00001E00000C000000000000000000000
-0000000000000000007FE0007FE0007FE00000E00000E00000E00000E00000E00000E000
-00E00000E00000E00000E00000E00000E00000E00000E00000E0007FFF80FFFFC07FFF80
-121F7C9E1A> I<7FE000FFE0007FE00000E00000E00000E00000E00000E00000E00000E0
-0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0
-0000E00000E00000E00000E00000E0007FFFC0FFFFE07FFFC0131E7D9D1A> 108
-D<7CE0E000FFFBF8007FFFF8001F1F1C001E1E1C001E1E1C001C1C1C001C1C1C001C1C1C
-001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C
-007F1F1F00FFBFBF807F1F1F00191580941A> I<7E3E00FEFF807FFFC00FC1C00F80E00F
-00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E
-00E07FC3FCFFE7FE7FC3FC17157F941A> I<01F00007FC001FFF003E0F803C07807803C0
-7001C0E000E0E000E0E000E0E000E0E000E0E000E0F001E07001C07803C03C07803E0F80
-1FFF0007FC0001F00013157D941A> I<7E3E00FEFF807FFFE00FC1F00F80700F00380E00
-380E001C0E001C0E001C0E001C0E001C0E001C0E001C0F00380F00780F80F00FC1E00FFF
-C00EFF800E3E000E00000E00000E00000E00000E00000E00000E00000E00007FC000FFE0
-007FC00016207F941A> I<7F81F8FF8FFC7F9FFE03FE1E03F80C03E00003E00003C00003
-80000380000380000380000380000380000380000380000380000380007FFF00FFFF007F
-FF0017157F941A> 114 D<07FB801FFF807FFF80780780E00380E00380E003807800007F
-C0001FFC0007FE00003F800007806001C0E001C0E001C0F003C0FC0780FFFF00EFFE00E3
-F80012157C941A> I<0180000380000380000380000380000380000380007FFFE0FFFFE0
-FFFFE0038000038000038000038000038000038000038000038000038000038000038070
-03807003807003807001C1E001FFE000FF80003F00141C7F9B1A> I<7E07E0FE0FE07E07
-E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00
-E00E00E00E01E00F03E007FFFC03FFFE00FCFC17157F941A> I<7F83FCFFC7FE7F83FC0E
-00E00E00E00E00E00701C00701C00701C003838003838003838001C70001C70001C70000
-EE0000EE0000EE00007C00007C0000380017157F941A> I<FF83FEFF83FEFF83FE380038
-3800381C00701C00701C00701C38701C7C701C7C700C6C600EEEE00EEEE00EEEE00EEEE0
-0EC6E006C6C007C7C00783C00783C017157F941A> I<7FC7F87FCFFC7FC7F80703C00383
-8003C70001EF0000FE00007C00007800003800007C0000EE0001EE0001C7000383800783
-C00F01C07FC7FCFFC7FE7FC7FC17157F941A> I<7F83FCFFC7FE7F83FC0E00E00E00E007
-00E00701C00701C00381C003838003C38001C38001C70000E70000E70000E60000660000
-6E00003C00003C00003C0000380000380000380000700000700030F00078E00071E0007F
-C0003F80001E000017207F941A> I<60F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0
-F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F060042775A21A> 124 D
-E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Ff cmr8 8 3
-/Ff 3 51 df<003000003000003000003000003000003000003000003000003000003000
-003000FFFFFCFFFFFC003000003000003000003000003000003000003000003000003000
-00300000300016187E931B> 43 D<06000E00FE000E000E000E000E000E000E000E000E
-000E000E000E000E000E000E000E000E000E00FFE00B157D9412> 49
-D<0F8030E040708030C038E0384038003800700070006000C00180030006000C08080810
-183FF07FF0FFF00D157E9412> I E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fg cmmi12 12 13
-/Fg 13 121 df<0FFFF81FFFFC3FFFF870200040200080200080600000600000600000C0
-0000C00000C00000C00001C0000180000180000380000380000380000700000300001615
-7E9415> 28 D<0000100000002000000020000000200000002000000040000000400000
-004000000040000000800000008000000080000000800000010000000FE00000711C0001
-C10600030203000E0203801C020180180201C0380401C0700401C0700401C0700401C0E0
-080380E0080380E00807006008070070100E0030101C00301038001C10E0000623800001
-FE0000002000000020000000400000004000000040000000400000008000000080000000
-800000008000001A2D7EA21D> 30 D<70F8F8F87005057C840E> 58
-D<70F8FCFC7404040404080810102040060F7C840E> I<00008000018000018000030000
-0300000300000600000600000600000C00000C00000C0000180000180000180000300000
-300000300000600000600000600000C00000C00000C00001800001800001800001800003
-00000300000300000600000600000600000C00000C00000C000018000018000018000030
-0000300000300000600000600000600000C00000C00000C0000011317DA418> 61
-D<00FFFC00000F8000000F0000000F0000001E0000001E0000001E0000001E0000003C00
-00003C0000003C0000003C00000078000000780000007800000078000000F0000000F000
-0000F0000000F0000001E0000001E0000001E0002001E0002003C0004003C0004003C000
-8003C0008007800180078001000780030007800F000F803E00FFFFFE001B227DA121> 76
-D<1FFFFFFE1E01E00E1801E0063001E0062003C0062003C0064003C0044003C004400780
-04800780048007800400078000000F0000000F0000000F0000000F0000001E0000001E00
-00001E0000001E0000003C0000003C0000003C0000003C00000078000000780000007800
-000078000000F0000000F0000000F0000000F0000001F000007FFFC0001F227EA11D> 84
-D<3FFE01FF8003C0003C0003C000300003C0001000078000200007800020000780002000
-07800020000F000040000F000040000F000040000F000040001E000080001E000080001E
-000080001E000080003C000100003C000100003C000100003C0001000078000200007800
-020000780002000078000200007000040000F000040000F0000800007000080000700010
-00007000200000380040000038008000001C01000000060600000001F800000021237DA1
-21> I<007E000381000700800E00801C0080380080780100700600FFF800F00000F00000
-E00000E00000E00000E00000E00080E000807003003004001838000FC00011157D9417>
-101 D<01E00FC001C001C001C0038003800380038007000700070007000E000E000E000E
-001C001C001C001C0038003800380038007000700070007080E100E100E100620062003C
-000B237EA20F> 108 D<03C0F004631C04740E08780E08700708700708700F00E00F00E0
-0F00E00F00E00F01C01E01C01E01C01E01C03C03803803803803C07003C0E0072180071E
-000700000700000E00000E00000E00000E00001C00001C00001C0000FF8000181F819418
-> 112 D<3C0F004630C04741C08783C08783C08701808700000E00000E00000E00000E00
-001C00001C00001C00001C000038000038000038000038000070000030000012157E9416
-> 114 D<01E0F006310C081A1C101A3C201C3C201C18201C000038000038000038000038
-0000700000700000700000700860E010F0E010F0E020E170404230803C1F0016157E941C
-> 120 D E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fh cmti12 12 22
-/Fh 22 122 df<FFF0FFF0FFE00C037C8B11> 45 D<70F8F8F0E005057A840F> I<00F8
-C00185C00705C00E03800E03801C03803C0380380700780700780700780700F00E00F00E
-00F00E00F00E10F01C20701C20703C20305C40308C400F078014157B9419> 97
-D<03C01F8003800380038007000700070007000E000E000E000E001C001CF81D0C1E0E3C
-0638073807380F700F700F700F700FE01EE01EE01EE03CE038E038607060E031C01F0010
-237BA216> I<007E0001C1000301800703800E07801C07803C0000380000780000780000
-780000F00000F00000F00000F00000F00100700100700200300C001830000FC00011157B
-9416> I<00003C0003F80000380000380000380000700000700000700000700000E00000
-E00000E00000E00001C000F9C00185C00705C00E03800E03801C03803C03803807007807
-00780700780700F00E00F00E00F00E00F00E10F01C20701C20703C20305C40308C400F07
-8016237BA219> I<00F803840E021C023C0238027804F018FFE0F000F000E000E000E000
-E000E002E0026004701830600F800F157A9416> I<00003E0000470000CF00018F000186
-000380000380000380000700000700000700000700000700000E0000FFF0000E00000E00
-000E00001C00001C00001C00001C00001C00003800003800003800003800003800007000
-00700000700000700000700000E00000E00000E00000E00000C00001C00001C000718000
-F18000F300006200003C0000182D82A20F> I<001F180030B800E0B801C07001C0700380
-700780700700E00F00E00F00E00F00E01E01C01E01C01E01C01E01C01E03800E03800E07
-80060B8006170001E700000700000700000E00000E00000E00701C00F01800F0300060E0
-003F8000151F7E9416> I<00C001E001C001C0000000000000000000000000000000001E
-002300430043008700870087000E000E001C001C001C0038003800384070807080708071
-0032001C000B217BA00F> 105 D<00F00007E00000E00000E00000E00001C00001C00001
-C00001C0000380000380000380000380000700000701E00702100704700E08F00E10F00E
-20600E40001D80001E00001FC0001C7000383800383800381C00381C2070384070384070
-3840701880E01880600F0014237DA216> 107 D<01E00FC001C001C001C0038003800380
-038007000700070007000E000E000E000E001C001C001C001C0038003800380038007000
-700070007100E200E200E200E200640038000B237CA20C> I<1C0F80F8002610C10C0047
-6066060087807807008780780700870070070087007007000E00E00E000E00E00E000E00
-E00E000E00E00E001C01C01C001C01C01C001C01C01C001C01C038203803803840380380
-70403803807080380380308070070031003003001E0023157B9428> I<380F804C30C04E
-40608E80708F00708E00708E00701C00E01C00E01C00E01C00E03801C03801C03801C038
-0384700388700308700708700310E003106001E016157B941B> I<007E0001C300038180
-0701C00E01C01C01E03C01E03801E07801E07801E07801E0F003C0F003C0F00380F00780
-700700700E00700C0030180018700007C00013157B9419> I<01C1F002621804741C0878
-0C08700E08700E08701E00E01E00E01E00E01E00E01E01C03C01C03C01C03C01C0780380
-7003807003C0E003C1C0072380071E000700000700000E00000E00000E00000E00001C00
-001C00001C0000FFC000171F7F9419> I<1C1F002620804741C08783C08703C087018087
-00000E00000E00000E00000E00001C00001C00001C00001C000038000038000038000038
-000070000030000012157B9415> 114 D<00FC000183000200800401800C03800C03000C
-00000F00000FF00007FC0003FE00003E00000F00000700700700F00600F00600E0040040
-08002030001FC00011157D9414> I<00C001C001C001C001C003800380038003800700FF
-F8070007000E000E000E000E001C001C001C001C00380038003800381070207020704070
-8031001E000D1F7C9E10> I<1E0060E02300E0F04380E1F04381C0F08381C0708701C030
-8701C030070380200E0380200E0380200E0380201C0700401C0700401C0700401C070080
-1C0700801C0701001C0F01000C0B02000613840003E0F8001C157B9420> 119
-D<03C1E0046210083470103CF02038F020386020380000700000700000700000700000E0
-0000E00000E00000E02061C040F1C040F1C080E2C100446200383C0014157D9416> I<1E
-00302300704380704380E08380E08700E08700E00701C00E01C00E01C00E01C01C03801C
-03801C03801C03801C07001C07001C07001C0F000C3E0003CE00000E00000E00001C0060
-1C00F03800F03000E0600080C0004380003E0000141F7B9418> I
-E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fi cmbx12 12 20
-/Fi 20 122 df<FFFFFF8000FFFFFFF00007F003FC0007F0007E0007F0003F0007F0001F
-8007F0000FC007F00007E007F00007E007F00007F007F00003F007F00003F007F00003F0
-07F00003F807F00003F807F00003F807F00003F807F00003F807F00003F807F00003F807
-F00003F807F00003F807F00003F007F00003F007F00003F007F00007E007F00007E007F0
-000FC007F0001F8007F0003F0007F0007E0007F003FC00FFFFFFF000FFFFFF800025227E
-A12B> 68 D<01FE0207FF861F01FE3C007E7C001E78000E78000EF80006F80006FC0006
-FC0000FF0000FFE0007FFF007FFFC03FFFF01FFFF80FFFFC03FFFE003FFE0003FE00007F
-00003F00003FC0001FC0001FC0001FE0001EE0001EF0003CFC003CFF00F8C7FFE080FF80
-18227DA11F> 83 D<7FFFFFFF807FFFFFFF807E03F80F807803F807807003F803806003
-F80180E003F801C0E003F801C0C003F800C0C003F800C0C003F800C0C003F800C00003F8
-00000003F800000003F800000003F800000003F800000003F800000003F800000003F800
-000003F800000003F800000003F800000003F800000003F800000003F800000003F80000
-0003F800000003F800000003F800000003F800000003F8000001FFFFF00001FFFFF00022
-227EA127> I<0FFC003FFF807E07C07E03E07E01E07E01F03C01F00001F00001F0003FF0
-03FDF01FC1F03F01F07E01F0FC01F0FC01F0FC01F0FC01F07E02F07E0CF81FF87F07E03F
-18167E951B> 97 D<FF000000FF0000001F0000001F0000001F0000001F0000001F0000
-001F0000001F0000001F0000001F0000001F0000001F0000001F0FE0001F3FF8001FE07C
-001F803E001F001F001F000F801F000F801F000FC01F000FC01F000FC01F000FC01F000F
-C01F000FC01F000FC01F000FC01F000F801F001F801F801F001FC03E001EE07C001C3FF8
-00180FC0001A237EA21F> I<00FF8007FFE00F83F01F03F03E03F07E03F07C01E07C0000
-FC0000FC0000FC0000FC0000FC0000FC00007C00007E00007E00003E00181F00300FC060
-07FFC000FF0015167E9519> I<00FE0007FF800F87C01E01E03E01F07C00F07C00F8FC00
-F8FC00F8FFFFF8FFFFF8FC0000FC0000FC00007C00007C00007E00003E00181F00300FC0
-7003FFC000FF0015167E951A> 101 D<001FC0007FE000F1F001E3F003E3F007C3F007C1
-E007C00007C00007C00007C00007C00007C000FFFE00FFFE0007C00007C00007C00007C0
-0007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C0
-0007C00007C0003FFC003FFC00142380A211> I<01FE0F0007FFBF800F87C7801F03E780
-1E01E0003E01F0003E01F0003E01F0003E01F0003E01F0001E01E0001F03E0000F87C000
-0FFF800009FE000018000000180000001C0000001FFFE0000FFFF80007FFFE001FFFFF00
-3C003F0078000F80F0000780F0000780F0000780F000078078000F003C001E001F007C00
-0FFFF80001FFC00019217F951C> I<1C003E007F007F007F003E001C0000000000000000
-00000000000000FF00FF001F001F001F001F001F001F001F001F001F001F001F001F001F
-001F001F001F001F001F00FFE0FFE00B247EA310> 105 D<FF00FF001F001F001F001F00
-1F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F00
-1F001F001F001F001F001F001F001F001F00FFE0FFE00B237EA210> 108
-D<FF07F007F000FF1FFC1FFC001F303E303E001F403E403E001F801F801F001F801F801F
-001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F
-001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F
-001F001F001F001F001F001F00FFE0FFE0FFE0FFE0FFE0FFE02B167E9530> I<FF07E000
-FF1FF8001F307C001F403C001F803E001F803E001F003E001F003E001F003E001F003E00
-1F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E00
-1F003E00FFE1FFC0FFE1FFC01A167E951F> I<00FE0007FFC00F83E01E00F03E00F87C00
-7C7C007C7C007CFC007EFC007EFC007EFC007EFC007EFC007EFC007E7C007C7C007C3E00
-F81F01F00F83E007FFC000FE0017167E951C> I<FF0FE000FF3FF8001FE07C001F803E00
-1F001F001F001F801F001F801F000FC01F000FC01F000FC01F000FC01F000FC01F000FC0
-1F000FC01F000FC01F001F801F001F801F803F001FC03E001FE0FC001F3FF8001F0FC000
-1F0000001F0000001F0000001F0000001F0000001F0000001F0000001F000000FFE00000
-FFE000001A207E951F> I<0FF3003FFF00781F00600700E00300E00300F00300FC00007F
-E0007FF8003FFE000FFF0001FF00000F80C00780C00380E00380E00380F00700FC0E00EF
-FC00C7F00011167E9516> 115 D<01800001800001800001800003800003800007800007
-80000F80003F8000FFFF00FFFF000F80000F80000F80000F80000F80000F80000F80000F
-80000F80000F80000F80000F81800F81800F81800F81800F81800F830007C30003FE0000
-F80011207F9F16> I<FF01FE00FF01FE001F003E001F003E001F003E001F003E001F003E
-001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E
-001F003E001F007E001F00FE000F81BE0007FF3FC001FC3FC01A167E951F> I<FFE07FC0
-FFE07FC00F801C0007C0380003E0700003F0600001F8C00000F98000007F8000003F0000
-001F0000001F8000003FC0000037C0000063E00000C1F00001C0F8000380FC0007007E00
-0E003E00FF80FFE0FF80FFE01B167F951E> 120 D<FFE01FE0FFE01FE01F8007000F8006
-000FC00E0007C00C0007E00C0003E0180003E0180001F0300001F0300000F8600000F860
-00007CC000007CC000007FC000003F8000003F8000001F0000001F0000000E0000000E00
-00000C0000000C00000018000078180000FC380000FC300000FC60000069C000007F8000
-001F0000001B207F951E> I E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fj cmsy10 12 15
-/Fj 15 107 df<FFFFFFFCFFFFFFFC1E027C8C27> 0 D<03F0000FFC001FFE003FFF007F
-FF807FFF80FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC07FFF807FFF803F
-FF001FFE000FFC0003F00012147D9519> 15 D<000FFFFC007FFFFC01F0000003800000
-060000000C0000001800000030000000300000006000000060000000C0000000C0000000
-C0000000C0000000C0000000C0000000C0000000C0000000600000006000000030000000
-30000000180000000C000000060000000380000001E00000007FFFFC001FFFFC1E1E7C9A
-27> 26 D<00000001800000000001800000000001800000000001800000000000C00000
-000000C000000000006000000000003000000000003000000000001C00000000000E0000
-0000000700FFFFFFFFFFE0FFFFFFFFFFE0000000000700000000000E00000000001C0000
-000000300000000000300000000000600000000000C00000000000C00000000001800000
-00000180000000000180000000000180002B1A7D9832> 33 D<001FFF007FFF01E00003
-80000600000C0000180000300000300000600000600000600000C00000C00000FFFFFFFF
-FFFFC00000C000006000006000006000003000003000001800000C000006000003800001
-E000007FFF001FFF181E7C9A21> 50 D<00000300000300000600000600000C00000C00
-00180000180000300000300000600000600000C00000C00000C000018000018000030000
-0300000600000600000C00000C0000180000180000300000300000600000600000C00000
-C0000180000180000300000300000300000600000600000C00000C000018000018000030
-0000300000600000600000C00000400000183079A300> 54 D<C0C0C0C0C0C0C0C0E0E0
-C0C0C0C0C0C0C0C003127D9400> I<00008000018001F980070F000C0300180380180780
-3006C03006C0700CE0600C60600C60600C60E01870E01870E01870E03070E03070E03070
-E06070E06070E06070E06070E0C070E0C070E0C070E18070E180706180606300607300E0
-7300E03300C03600C01E01801E01800C03000F0E000DF800180000180000180000142A7E
-A519> 59 D<000100000003000000030000000300000003000000030000000300000003
-000000030000000300000003000000030000000300000003000000030000000300000003
-000000030000000300000003000000030000000300000003000000030000000300000003
-000000030000000300000003000000030000FFFFFFFEFFFFFFFE1F207C9F27> 63
-D<40000040C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000
-C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000
-C0C00000C0C00000C0C00000C0C00000C0C00000C0600001806000018030000300180006
-000E001C000780780001FFE000007F80001A1F7D9D21> 91 D<007F800001FFE0000780
-78000E001C0018000600300003006000018060000180C00000C0C00000C0C00000C0C000
-00C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C000
-00C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C000
-00C0400000401A1F7D9D21> I<000C0000000C0000001E0000001E0000001E0000003300
-0000330000006180000061800000C0C00000C0C00000C0C0000180600001806000030030
-00030030000300300006001800060018000C000C000C000C000C000C0018000600180006
-003000030030000300600001806000018060000180C00000C0C00000401A1F7D9D21> 94
-D<0003C0001E0000380000700000E00000E00000E00000E00000E00000E00000E00000E0
-0000E00000E00000E00000E00000E00000E00000E00000E00000E00001C0000380000F00
-00F800000F000003800001C00000E00000E00000E00000E00000E00000E00000E00000E0
-0000E00000E00000E00000E00000E00000E00000E00000E00000E000007000003800001E
-000003C012317DA419> 102 D<F800000F000003800001C00000E00000E00000E00000E0
-0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0
-0000E000007000003800001E000003C0001E0000380000700000E00000E00000E00000E0
-0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0
-0000E00001C0000380000F0000F8000012317DA419> I<C0C0C0C0C0C0C0C0C0C0C0C0C0
-C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0
-02317AA40E> 106 D E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fk cmr12 12 65
-/Fk 65 125 df<001FC1F00070371800C03E3C01807C3C0380783C070038000700380007
-003800070038000700380007003800070038000700380007003800FFFFFFC00700380007
-003800070038000700380007003800070038000700380007003800070038000700380007
-0038000700380007003800070038000700380007003800070038000700380007003C007F
-E1FFC01E2380A21C> 11 D<001FC0000070200000C01000018038000380780007007800
-0700300007000000070000000700000007000000070000000700000007000000FFFFF800
-070078000700380007003800070038000700380007003800070038000700380007003800
-070038000700380007003800070038000700380007003800070038000700380007003800
-070038007FE1FF80192380A21B> I<001FD8000070380000C07800018078000380780007
-0038000700380007003800070038000700380007003800070038000700380007003800FF
-FFF800070038000700380007003800070038000700380007003800070038000700380007
-003800070038000700380007003800070038000700380007003800070038000700380007
-003800070038007FF3FF80192380A21B> I<000FC07F00007031C08000E00B004001801E
-00E003803E01E007003C01E007001C00C007001C000007001C000007001C000007001C00
-0007001C000007001C000007001C0000FFFFFFFFE007001C01E007001C00E007001C00E0
-07001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007
-001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007001C00E00700
-1C00E007001C00E07FF1FFCFFE272380A229> I<70F8FCFC740404040408081010204006
-0F7CA20E> 39 D<00200040008001000300060004000C000C0018001800300030003000
-7000600060006000E000E000E000E000E000E000E000E000E000E000E000E000E000E000
-6000600060007000300030003000180018000C000C000400060003000100008000400020
-0B327CA413> I<800040002000100018000C000400060006000300030001800180018001
-C000C000C000C000E000E000E000E000E000E000E000E000E000E000E000E000E000E000
-C000C000C001C0018001800180030003000600060004000C00180010002000400080000B
-327DA413> I<70F8FCFC7404040404080810102040060F7C840E> 44
-D<FFF8FFF80D02808B10> I<70F8F8F87005057C840E> I<01F000071C000C0600180300
-3803803803807001C07001C07001C07001C0F001E0F001E0F001E0F001E0F001E0F001E0
-F001E0F001E0F001E0F001E0F001E0F001E0F001E0F001E07001C07001C07001C07803C0
-3803803803801C07000C0600071C0001F00013227EA018> 48 D<008003800F80F38003
-800380038003800380038003800380038003800380038003800380038003800380038003
-800380038003800380038003800380038007C0FFFE0F217CA018> I<03F0000C1C001007
-002007804003C04003C08003E0F003E0F801E0F801E0F801E02003E00003E00003C00003
-C0000780000700000E00001C0000180000300000600000C0000180000100000200200400
-200800201800603000403FFFC07FFFC0FFFFC013217EA018> I<03F8000C1E00100F0020
-07804007C07807C07803C07807C03807C0000780000780000700000F00000C0000380003
-F000001C00000F000007800007800003C00003C00003E02003E07003E0F803E0F803E0F0
-03C04003C0400780200780100F000C1C0003F00013227EA018> I<000300000300000700
-000700000F00001700001700002700006700004700008700018700010700020700060700
-040700080700080700100700200700200700400700C00700FFFFF8000700000700000700
-000700000700000700000700000F80007FF015217FA018> I<70F8F8F870000000000000
-000000000070F8F8F87005157C940E> 58 D<FFFFFFFEFFFFFFFE000000000000000000
-0000000000000000000000000000000000000000000000FFFFFFFEFFFFFFFE1F0C7D9126
-> 61 D<07E01838201C400E800FF00FF00FF00F000F000E001C00380030006000C000C0
-00800080018001000100010001000100010000000000000000000000038007C007C007C0
-038010237DA217> 63 D<0001800000018000000180000003C0000003C0000003C00000
-05E0000005E0000009F0000008F0000008F00000107800001078000010780000203C0000
-203C0000203C0000401E0000401E0000C01F0000800F0000800F0001FFFF800100078001
-000780020003C0020003C0020003C0040001E0040001E0040001E0080000F01C0000F03E
-0001F8FF800FFF20237EA225> 65 D<FFFFF8000F800E0007800780078003C0078003E0
-078001E0078001F0078001F0078001F0078001F0078001F0078001E0078003E0078007C0
-07800F8007803E0007FFFE0007800780078003C0078001E0078001F0078000F0078000F8
-078000F8078000F8078000F8078000F8078000F8078001F0078001F0078003E0078007C0
-0F800F00FFFFFC001D227EA123> I<0007E0100038183000E0063001C00170038000F007
-0000F00E0000701E0000701C0000303C0000303C0000307C0000107800001078000010F8
-000000F8000000F8000000F8000000F8000000F8000000F8000000F80000007800000078
-0000107C0000103C0000103C0000101C0000201E0000200E000040070000400380008001
-C0010000E0020000381C000007E0001C247DA223> I<FFFFF0000F801E00078007000780
-0380078001C0078000E0078000F007800078078000780780007C0780003C0780003C0780
-003C0780003E0780003E0780003E0780003E0780003E0780003E0780003E0780003E0780
-003E0780003C0780003C0780007C0780007807800078078000F0078000E0078001E00780
-03C0078007000F801E00FFFFF0001F227EA125> I<FFFFFFC00F8007C0078001C0078000
-C00780004007800040078000600780002007800020078000200780202007802000078020
-0007802000078060000780E00007FFE0000780E000078060000780200007802000078020
-000780200007800000078000000780000007800000078000000780000007800000078000
-00078000000FC00000FFFE00001B227EA120> 70 D<0007F008003C0C1800E0021801C0
-01B8038000F8070000780F0000381E0000381E0000183C0000183C0000187C0000087800
-000878000008F8000000F8000000F8000000F8000000F8000000F8000000F8000000F800
-1FFF780000F8780000787C0000783C0000783C0000781E0000781E0000780F0000780700
-0078038000B801C000B800E00318003C0C080007F00020247DA226> I<FFFC3FFF0FC003
-F0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001
-E0078001E0078001E0078001E0078001E0078001E007FFFFE0078001E0078001E0078001
-E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001
-E0078001E0078001E0078001E00FC003F0FFFC3FFF20227EA125> I<FFFC0FC007800780
-078007800780078007800780078007800780078007800780078007800780078007800780
-07800780078007800780078007800780078007800FC0FFFC0E227EA112> I<FFFC00FF80
-0FC0007C0007800030000780002000078000400007800080000780010000078002000007
-80040000078008000007801000000780200000078040000007808000000781C000000783
-E000000785E000000788F000000790F0000007A078000007C03C000007803C000007801E
-000007800F000007800F00000780078000078007C000078003C000078001E000078001E0
-00078000F000078000F8000FC000FC00FFFC07FF8021227EA126> 75
-D<FFFC001F80000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00
-000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00010F00
-010F00010F00010F00030F00030F00020F00060F00060F001E1F007EFFFFFE18227DA11E
-> I<FF8007FF07C000F807C0007005E0002004F0002004F0002004780020047C0020043C
-0020041E0020041F0020040F002004078020040780200403C0200401E0200401E0200400
-F0200400F8200400782004003C2004003E2004001E2004000F2004000F20040007A00400
-03E0040003E0040001E0040001E0040000E00E0000601F000060FFE0002020227EA125>
-78 D<000FE00000783C0000E00E0003C00780078003C00F0001E00E0000E01E0000F03C
-0000783C0000787C00007C7C00007C7800003C7800003CF800003EF800003EF800003EF8
-00003EF800003EF800003EF800003EF800003EF800003E7800003C7C00007C7C00007C3C
-0000783E0000F81E0000F00F0001E00F0001E0078003C003C0078000E00E0000783C0000
-0FE0001F247DA226> I<FFFFF0000F803C0007800F0007800780078007C0078003C00780
-03E0078003E0078003E0078003E0078003E0078003E0078003C0078007C0078007800780
-0F0007803C0007FFF0000780000007800000078000000780000007800000078000000780
-0000078000000780000007800000078000000780000007800000078000000FC00000FFFC
-00001B227EA121> I<FFFFE000000F803C000007800E00000780078000078007C0000780
-03C000078003E000078003E000078003E000078003E000078003E000078003C000078007
-C000078007800007800E000007803C000007FFE000000780700000078038000007801C00
-0007801E000007800E000007800F000007800F000007800F000007800F000007800F8000
-07800F800007800F800007800F808007800FC080078007C0800FC003C100FFFC01E20000
-00007C0021237EA124> 82 D<03F0200C0C601802603001E07000E0600060E00060E000
-60E00020E00020E00020F00000F000007800007F00003FF0001FFE000FFF0003FF80003F
-C00007E00001E00000F00000F0000070800070800070800070800070C00060C00060E000
-C0F000C0C80180C6070081FC0014247DA21B> I<7FFFFFF8780780786007801840078008
-4007800840078008C007800C800780048007800480078004800780040007800000078000
-000780000007800000078000000780000007800000078000000780000007800000078000
-000780000007800000078000000780000007800000078000000780000007800000078000
-00078000000FC00001FFFE001E227EA123> I<FFF0007FC01F80001F000F00000C000F80
-000C000780000800078000080003C000100003C000100003C000100001E000200001E000
-200001F000600000F000400000F000400000780080000078008000007C008000003C0100
-00003C010000001E020000001E020000001E020000000F040000000F040000000F8C0000
-000788000000078800000003D000000003D000000003F000000001E000000001E0000000
-00C000000000C000000000C0000022237FA125> 86 D<FFF03FFC03FE1F8007E000F80F
-0003C000700F0003C000200F0001E00020078001E00040078001E00040078003F0004003
-C002F0008003C002F0008003C002F0008003E00478018001E00478010001E00478010001
-E0083C010000F0083C020000F0083C020000F0101E02000078101E04000078101E040000
-78200F0400003C200F0800003C200F0800003C600F8800001E40079000001E4007900000
-1E4007D000001F8003F000000F8003E000000F8003E000000F0001E00000070001C00000
-070001C00000060000C0000002000080002F237FA132> I<FEFEC0C0C0C0C0C0C0C0C0C0
-C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0FE
-FE07317BA40E> 91 D<FEFE060606060606060606060606060606060606060606060606
-060606060606060606060606060606060606060606FEFE07317FA40E> 93
-D<1FE000303800780C00780E0030070000070000070000070000FF0007C7001E07003C07
-00780700700700F00708F00708F00708F00F087817083C23900FC1E015157E9418> 97
-D<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E00000E00
-000E00000E00000E1F000E61C00E80600F00300E00380E003C0E001C0E001E0E001E0E00
-1E0E001E0E001E0E001E0E001E0E001C0E003C0E00380F00700C80600C41C0083F001723
-7FA21B> I<01FE000703000C07801C0780380300780000700000F00000F00000F00000F0
-0000F00000F00000F000007000007800403800401C00800C010007060001F80012157E94
-16> I<0000E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E0
-0000E00000E00000E001F8E00704E00C02E01C01E03800E07800E07000E0F000E0F000E0
-F000E0F000E0F000E0F000E0F000E07000E07800E03800E01801E00C02E0070CF001F0FE
-17237EA21B> I<01FC000707000C03801C01C03801C07801E07000E0F000E0FFFFE0F000
-00F00000F00000F00000F000007000007800203800201C00400E008007030000FC001315
-7F9416> I<003E0000E30001C78003878003078007000007000007000007000007000007
-0000070000070000070000FFF80007000007000007000007000007000007000007000007
-00000700000700000700000700000700000700000700000700000700000700000780007F
-F000112380A20F> I<00007003F1980E1E181C0E18380700380700780780780780780780
-7807803807003807001C0E001E1C0033F0002000002000003000003800003FFE001FFFC0
-0FFFE03000F0600030C00018C00018C00018C000186000306000303800E00E038003FE00
-15217F9518> I<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00
-000E00000E00000E00000E00000E1F800E60C00E80E00F00700F00700E00700E00700E00
-700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00
-70FFE7FF18237FA21B> I<1C003E003E003E001C00000000000000000000000000000000
-000E007E001E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E
-000E000E00FFC00A227FA10E> I<00E001F001F001F000E0000000000000000000000000
-00000000007007F000F00070007000700070007000700070007000700070007000700070
-00700070007000700070007000700070007000706070F0E0F0C061803F000C2C83A10F>
-I<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E00000E00
-000E00000E00000E03FC0E01F00E01C00E01800E02000E04000E08000E10000E38000EF8
-000F1C000E1E000E0E000E07000E07800E03C00E01C00E01E00E00F00E00F8FFE3FE1723
-7FA21A> I<0E00FE001E000E000E000E000E000E000E000E000E000E000E000E000E000E
-000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E
-00FFE00B237FA20E> I<0E1FC07F00FE60E183801E807201C00F003C00E00F003C00E00E
-003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E00
-3800E00E003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E0038
-00E0FFE3FF8FFE27157F942A> I<0E1F80FE60C01E80E00F00700F00700E00700E00700E
-00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E
-0070FFE7FF18157F941B> I<01FC000707000C01801800C03800E0700070700070F00078
-F00078F00078F00078F00078F00078F000787000707800F03800E01C01C00E0380070700
-01FC0015157F9418> I<0E1F00FE61C00E80600F00700E00380E003C0E003C0E001E0E00
-1E0E001E0E001E0E001E0E001E0E001E0E003C0E003C0E00380F00700E80E00E41C00E3F
-000E00000E00000E00000E00000E00000E00000E00000E00000E0000FFE000171F7F941B
-> I<01F8200704600E02601C01603801E07800E07800E0F000E0F000E0F000E0F000E0F0
-00E0F000E0F000E07800E07800E03801E01C01E00C02E0070CE001F0E00000E00000E000
-00E00000E00000E00000E00000E00000E00000E0000FFE171F7E941A> I<0E3CFE461E8F
-0F0F0F060F000E000E000E000E000E000E000E000E000E000E000E000E000E000F00FFF0
-10157F9413> I<0F8830786018C018C008C008E008F0007F003FE00FF001F8003C801C80
-0C800CC00CC008E018D0308FC00E157E9413> I<02000200020002000600060006000E00
-1E003E00FFFC0E000E000E000E000E000E000E000E000E000E000E000E040E040E040E04
-0E040E040708030801F00E1F7F9E13> I<0E0070FE07F01E00F00E00700E00700E00700E
-00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00F00E00F006
-017003827800FC7F18157F941B> I<FF80FE1E00781E00300E00200E0020070040070040
-0780C003808003808001C10001C10000E20000E20000E200007400007400003800003800
-00380000100017157F941A> I<FF8FF87F3E01E03C1C01C0181C01E0180E01E0100E0260
-100E027010070270200704302007043820038438400388184003881C4001C81C8001D00C
-8001D00E8000F00F0000E0070000E00700006006000040020020157F9423> I<FF83FE1F
-00F00E00C007008007810003830001C20000E400007800007800003800003C00004E0000
-8F000187000103800201C00401E00C00E03E01F0FF03FE17157F941A> I<FF80FE1E0078
-1E00300E00200E00200700400700400780C003808003808001C10001C10000E20000E200
-00E200007400007400003800003800003800001000001000002000002000002000004000
-F04000F08000F180004300003C0000171F7F941A> I<3FFFC0380380300780200700600E
-00401C00403C0040380000700000E00001E00001C0000380400700400F00400E00C01C00
-80380080780180700780FFFF8012157F9416> I<FFFFFFFFFFFF3001808C31> 124
-D E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fl cmbx12 14.4 19
-/Fl 19 118 df<00007FE0030007FFFC07001FFFFF0F007FF00F9F00FF0001FF01FC0000
-FF03F800007F07F000003F0FE000001F1FC000001F1FC000000F3F8000000F3F80000007
-7F800000077F800000077F00000000FF00000000FF00000000FF00000000FF00000000FF
-00000000FF00000000FF00000000FF00000000FF000000007F000000007F800000007F80
-0000073F800000073F800000071FC00000071FC000000E0FE000000E07F000001C03F800
-003C01FC00007800FF0001F0007FF007C0001FFFFF800007FFFE0000007FF00028297CA8
-31> 67 D<FFFFFC0000FFFFFC0000FFFFFC000003FC00000003FC00000003FC00000003
-FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC
-00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00
-000003FC00000003FC00000003FC00000003FC0001C003FC0001C003FC0001C003FC0001
-C003FC0003C003FC00038003FC00038003FC00078003FC00078003FC000F8003FC000F80
-03FC001F8003FC007F8003FC01FF00FFFFFFFF00FFFFFFFF00FFFFFFFF0022297EA828>
-76 D<0000FFC00000000FFFFC0000003F807F000000FE001FC00001F80007E00003F000
-03F00007E00001F8000FE00001FC001FC00000FE001FC00000FE003F8000007F003F8000
-007F007F8000007F807F0000003F807F0000003F807F0000003F80FF0000003FC0FF0000
-003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000
-003FC0FF0000003FC0FF0000003FC07F0000003F807F8000007F807F8000007F803F8000
-007F003F8000007F001FC00000FE001FC00000FE000FE00001FC0007F00003F80003F800
-07F00001FC000FE00000FE001FC000003FC0FF0000000FFFFC00000000FFC000002A297C
-A833> 79 D<FFFFF0007FFFFFFFF0007FFFFFFFF0007FFF03FE000001C001FE00000380
-01FE0000038001FF0000078000FF0000070000FF80000F00007F80000E00007FC0000E00
-003FC0001C00003FC0001C00003FE0003C00001FE0003800001FF0007800000FF0007000
-000FF80070000007F800E0000007F800E0000003FC01C0000003FC01C0000003FE03C000
-0001FE0380000001FF0780000000FF0700000000FF87000000007F8E000000007F8E0000
-00007FDE000000003FDC000000003FFC000000001FF8000000001FF8000000000FF00000
-00000FF0000000000FF00000000007E00000000007E00000000003C00000000003C00000
-30297FA833> 86 D<03FF80000FFFF0001F01FC003F80FE003F807F003F803F003F803F
-801F003F8000003F8000003F8000003F8000003F80003FFF8001FC3F800FE03F801F803F
-803F003F807E003F80FC003F80FC003F80FC003F80FC003F80FC005F807E00DF803F839F
-FC1FFE0FFC03FC03FC1E1B7E9A21> 97 D<FFE00000FFE00000FFE000000FE000000FE0
-00000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE0
-00000FE000000FE1FE000FEFFF800FFE07E00FF803F00FF001F80FE000FC0FE000FC0FE0
-007E0FE0007E0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0
-007F0FE0007E0FE0007E0FE0007E0FE000FC0FE000FC0FF001F80FF803F00F9C0FE00F0F
-FF800E01FC00202A7EA925> I<00007FF000007FF000007FF0000007F0000007F0000007
-F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007
-F0003F87F001FFF7F007F03FF00FC00FF01F8007F03F0007F03F0007F07E0007F07E0007
-F07E0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007
-F07E0007F07E0007F03F0007F03F0007F01F800FF00FC01FF007E07FFF01FFE7FF007F87
-FF202A7EA925> 100 D<003FC00001FFF00003E07C000F803E001F801F001F001F003F00
-0F807E000F807E000FC07E000FC0FE0007C0FE0007C0FFFFFFC0FFFFFFC0FE000000FE00
-0000FE0000007E0000007E0000007F0000003F0001C01F0001C00F80038007C0070003F0
-1E0000FFFC00003FE0001A1B7E9A1F> I<0007F8003FFC007E3E01FC7F03F87F03F07F07
-F07F07F03E07F00007F00007F00007F00007F00007F00007F000FFFFC0FFFFC0FFFFC007
-F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007
-F00007F00007F00007F00007F00007F00007F00007F00007F0007FFF807FFF807FFF8018
-2A7EA915> I<FFE00000FFE00000FFE000000FE000000FE000000FE000000FE000000FE0
-00000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE07E000FE1
-FF800FE30FC00FE40FE00FE807E00FF807F00FF007F00FF007F00FE007F00FE007F00FE0
-07F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE0
-07F00FE007F00FE007F00FE007F00FE007F0FFFE3FFFFFFE3FFFFFFE3FFF202A7DA925>
-104 D<07000F801FC03FE03FE03FE01FC00F8007000000000000000000000000000000FF
-E0FFE0FFE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00F
-E00FE00FE00FE00FE00FE0FFFEFFFEFFFE0F2B7EAA12> I<FFE0FFE0FFE00FE00FE00FE0
-0FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE0
-0FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE0FFFEFFFEFFFE
-0F2A7EA912> 108 D<FFC07E00FFC1FF80FFC30FC00FC40FE00FC807E00FD807F00FD007
-F00FD007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007
-F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F0FFFE3F
-FFFFFE3FFFFFFE3FFF201B7D9A25> 110 D<003FE00001FFFC0003F07E000FC01F801F80
-0FC03F0007E03F0007E07E0003F07E0003F07E0003F0FE0003F8FE0003F8FE0003F8FE00
-03F8FE0003F8FE0003F8FE0003F8FE0003F87E0003F07E0003F03F0007E03F0007E01F80
-0FC00FC01F8007F07F0001FFFC00003FE0001D1B7E9A22> I<FFE1FE00FFEFFF80FFFE0F
-E00FF803F00FF001F80FE001FC0FE000FC0FE000FE0FE000FE0FE0007F0FE0007F0FE000
-7F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007E0FE000FE0FE000FE0FE000
-FC0FE001FC0FF001F80FF807F00FFC0FE00FEFFF800FE1FC000FE000000FE000000FE000
-000FE000000FE000000FE000000FE000000FE000000FE00000FFFE0000FFFE0000FFFE00
-0020277E9A25> I<FFC1F0FFC7FCFFC63E0FCC7F0FD87F0FD07F0FD07F0FF03E0FE0000F
-E0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000F
-E0000FE0000FE000FFFF00FFFF00FFFF00181B7F9A1B> 114 D<03FE300FFFF03E03F078
-00F07000F0F00070F00070F80070FE0000FFE0007FFF007FFFC03FFFE01FFFF007FFF800
-FFF80007FC0000FCE0007CE0003CF0003CF00038F80038FC0070FF01E0E7FFC0C1FF0016
-1B7E9A1B> I<00E00000E00000E00000E00001E00001E00001E00003E00003E00007E000
-0FE0001FFFE0FFFFE0FFFFE00FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE000
-0FE0000FE0000FE0000FE0000FE0000FE0700FE0700FE0700FE0700FE0700FE0700FE070
-07F0E003F0C001FF80007F0014267FA51A> I<FFE07FF0FFE07FF0FFE07FF00FE007F00F
-E007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00F
-E007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE00FF00F
-E00FF007E017F003F067FF01FFC7FF007F87FF201B7D9A25> I E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fm cmr12 14.4 20
-/Fm 20 118 df<78FCFCFEFE7A02020202040404080810204007127B8510> 44
-D<00200000E00001E0000FE000FFE000F1E00001E00001E00001E00001E00001E00001E0
-0001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E0
-0001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E0
-0001E00003F000FFFFC0FFFFC012287BA71D> 49 D<01FC0007FF000C0FC01803E02001
-F06001F04000F84000F8F800FCFC00FCFC007CFC007CFC007C7800FC0000FC0000F80000
-F80001F00001F00003E00003C0000780000700000E00001C0000380000300000600000C0
-000180000300040200040400080800081000082000183FFFF87FFFF0FFFFF0FFFFF01628
-7DA71D> I<000FC0003FF000F01801C01803803C07007C0F007C0E00381E00003C00003C
-00003C0000780000780000780000F83F00F8C1C0F900E0FA0070FA0038FC003CFC001EFC
-001EF8001EF8001FF8001FF8001FF8001F78001F78001F78001F78001F3C001E3C001E1C
-003C1E003C0E007807007003C1E001FFC0007E0018297EA71D> 54
-D<007E0001FF800781C00F00E01E00703C00383C003878003C78003CF8001EF8001EF800
-1EF8001EF8001FF8001FF8001FF8001F78001F78003F78003F3C003F1C005F0E005F0700
-9F03831F00FC1F00001E00001E00001E00003E00003C00003C0000381C00783E00703E00
-E03C01C01803801C0F000FFE0003F80018297EA71D> 57 D<0000FF00100007FFE03000
-1FC07830003E000C7000F80006F001F00003F003E00001F007C00000F00F800000700F80
-0000701F000000303F000000303E000000303E000000107E000000107E000000107C0000
-0000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000000FC000000
-00FC00000000FC0000FFFF7C0000FFFF7E000003F07E000001F03E000001F03E000001F0
-3F000001F01F000001F00F800001F00F800001F007C00001F003E00001F001F00002F000
-F80002F0003E000C70001FC038300007FFE0100000FF8000282B7DA92E> 71
-D<01FFFE01FFFE0007E00003E00003E00003E00003E00003E00003E00003E00003E00003
-E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003
-E00003E00003E00003E00003E00003E00003E00003E03003E07803E0FC03E0FC03E0FC03
-C0F807C0400780200F00300E000C3C0003F000172A7DA81E> 74
-D<0001FF0000000F01E000003C0078000078003C0000E0000E0001E0000F0003C0000780
-07800003C00F800003E01F000001F01F000001F03E000000F83E000000F87E000000FC7E
-000000FC7C0000007C7C0000007CFC0000007EFC0000007EFC0000007EFC0000007EFC00
-00007EFC0000007EFC0000007EFC0000007EFC0000007E7C0000007C7E000000FC7E0000
-00FC7E000000FC3E000000F83F000001F81F000001F01F000001F00F800003E007800003
-C007C00007C003E0000F8000F0001E000078003C00003C007800000F01E0000001FF0000
-272B7DA92E> 79 D<03FC00000C070000100380003C01C0003E01E0003E00F0001C00F0
-000800F0000000F0000000F0000000F000007FF00003E0F0000F80F0001E00F0003C00F0
-007C00F0007800F040F800F040F800F040F800F040F801F0407C01F0403C0278801E0C7F
-8007F01E001A1A7E991D> 97 D<0F000000FF000000FF0000001F0000000F0000000F00
-00000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F00
-00000F0000000F07E0000F1838000F600E000F8007000F8007800F0003C00F0003C00F00
-01E00F0001E00F0001F00F0001F00F0001F00F0001F00F0001F00F0001F00F0001F00F00
-01E00F0001E00F0003E00F0003C00F0003800F8007800E800F000E401C000C303800080F
-C0001C2A7EA921> I<007F0001C0E00700100E00781E00F83C00F83C00707C0020780000
-F80000F80000F80000F80000F80000F80000F80000F800007800007C00003C00083C0008
-1E00100E002007006001C180007E00151A7E991A> I<00FC000387800701C00E01E01C00
-E03C00F03C00F0780078780078F80078F80078FFFFF8F80000F80000F80000F80000F800
-007800007800003C00083C00081E00100E002007004001C180007E00151A7E991A> 101
-D<00000F0001FC3080070743800E03C3801E03C1003C01E0003C01E0007C01F0007C01F0
-007C01F0007C01F0007C01F0003C01E0003C01E0001E03C0000E0380001707000011FC00
-0030000000300000003000000030000000180000001FFF80000FFFF00007FFF80018007C
-0030001E0070000E0060000700E0000700E0000700E0000700E000070070000E0070000E
-0038001C001C0038000781E00000FF000019287E9A1D> 103 D<1E003F003F003F003F00
-1E000000000000000000000000000000000000000F00FF00FF001F000F000F000F000F00
-0F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F00FFF0FFF0
-0C297EA811> 105 D<007E0003C3C00700E00E00701C00383C003C3C003C78001E78001E
-F8001FF8001FF8001FF8001FF8001FF8001FF8001FF8001F78001E78001E3C003C3C003C
-1C00380E00700700E003C3C0007E00181A7E991D> 111 D<003F010001E0830003804300
-0F0027001E0017001E001F003C000F007C000F007C000F0078000F00F8000F00F8000F00
-F8000F00F8000F00F8000F00F8000F00F8000F007C000F007C000F003C000F003E001F00
-1E001F000F002F0007804F0001C18F00007E0F0000000F0000000F0000000F0000000F00
-00000F0000000F0000000F0000000F0000000F0000000F000000FFF00000FFF01C267E99
-1F> 113 D<0F0F80FF11C0FF23E01F43E00F83E00F81C00F80000F00000F00000F00000F
-00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F
-00000F8000FFFC00FFFC00131A7E9917> I<07F0801C0D80300380600180E00180E00080
-E00080F00080F800007E00007FE0003FFC001FFE0007FF00003F800007808003C08003C0
-8001C0C001C0C001C0E00180E00380F00300CC0E0083F800121A7E9917> I<0080000080
-000080000080000180000180000180000380000380000780000F80001FFF80FFFF800780
-000780000780000780000780000780000780000780000780000780000780000780000780
-0007804007804007804007804007804007804007804003C08001C08000E100003E001225
-7FA417> I<0F000F00FF00FF00FF00FF001F001F000F000F000F000F000F000F000F000F
-000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F
-000F000F000F000F000F000F000F001F000F001F0007002F0003804F8001C08FF0007F0F
-F01C1A7E9921> I E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fn cmr17 20.74 18
-/Fn 18 119 df<000001FF00008000001FFFE0018000007F007801800001F8000E038000
-03E000070780000FC000018780001F000000CF80003E0000006F80007C0000003F8000F8
-0000003F8001F00000001F8003F00000000F8007E00000000F8007C000000007800FC000
-000007800FC000000007801F8000000003801F8000000003803F8000000003803F000000
-0001803F0000000001807F0000000001807F0000000001807E0000000000007E00000000
-0000FE000000000000FE000000000000FE000000000000FE000000000000FE0000000000
-00FE000000000000FE000000000000FE000000000000FE000000000000FE000000000000
-FE0000000000007E0000000000007E0000000000007F0000000000007F0000000001803F
-0000000001803F0000000001803F8000000001801F8000000001801F8000000003000FC0
-00000003000FC0000000030007E0000000060007E0000000060003F0000000060001F000
-00000C0000F80000001800007C0000001800003E0000003000001F0000006000000FC000
-01C0000003E0000380000001F8000E000000007F007C000000001FFFF00000000001FF00
-0000313D7CBB39> 67 D<FFFFFC000000FFFFFC00000003FE0000000001F80000000001
-F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
-F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
-F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
-F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
-F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
-F80000000001F80000000001F80000000001F80000006001F80000006001F80000006001
-F80000006001F80000006001F8000000E001F8000000C001F8000000C001F8000000C001
-F8000000C001F8000001C001F8000001C001F8000001C001F8000003C001F8000007C001
-F8000007C001F800000FC001F800003F8001F80000FF8003FC0007FF80FFFFFFFFFF80FF
-FFFFFFFF802B3B7CBA32> 76 D<000003FF00000000001E01E000000000F0003C000000
-03C0000F000000078000078000000F000003C000003E000001F000007C000000F80000F8
-0000007C0001F00000003E0001F00000003E0003E00000001F0007E00000001F8007C000
-00000F800FC00000000FC00F8000000007C01F8000000007E01F8000000007E03F000000
-0003F03F0000000003F03F0000000003F07F0000000003F87E0000000001F87E00000000
-01F87E0000000001F8FE0000000001FCFE0000000001FCFE0000000001FCFE0000000001
-FCFE0000000001FCFE0000000001FCFE0000000001FCFE0000000001FCFE0000000001FC
-FE0000000001FCFE0000000001FC7E0000000001F87F0000000003F87F0000000003F87F
-0000000003F87F0000000003F83F0000000003F03F8000000007F01F8000000007E01F80
-00000007E01FC00000000FE00FC00000000FC007C00000000F8007E00000001F8003E000
-00001F0001F00000003E0001F80000007E0000F80000007C00007C000000F800003E0000
-01F000000F000003C000000780000780000003E0001F00000000F8007C000000001E01E0
-0000000003FF000000363D7CBB3E> 79 D<003F80000001C0F0000003003C000004001E
-00000C000F000018000780001C0007C0003E0003C0003F0003E0003F0003E0003F0003E0
-001E0003E000000003E000000003E000000003E00000003FE000000FF3E000007E03E000
-01F803E00003E003E0000FC003E0001F8003E0003F0003E0003E0003E0007E0003E0007E
-0003E060FC0003E060FC0003E060FC0003E060FC0007E060FC0007E0607C000BE0607E00
-0BE0603E0011F0C01F0060F0C007C1807F8000FE003E0023257CA427> 97
-D<03E0000000FFE0000000FFE000000007E000000003E000000003E000000003E0000000
-03E000000003E000000003E000000003E000000003E000000003E000000003E000000003
-E000000003E000000003E000000003E000000003E000000003E000000003E000000003E0
-00000003E000000003E03FC00003E0E0780003E3001C0003E6000F0003E800078003F800
-03C003F00001E003E00001F003E00000F003E00000F803E00000F803E00000FC03E00000
-7C03E000007C03E000007E03E000007E03E000007E03E000007E03E000007E03E000007E
-03E000007E03E000007E03E000007E03E000007C03E000007C03E00000FC03E00000F803
-E00000F803E00001F003E00001E003F00003E003D80003C003C80007800384000E000383
-001C000381C0F00003003F8000273C7EBB2C> I<0007F800003C0E0000F0018001E000C0
-03C00060078000300F0000701F0000F81F0001F83E0001F83E0001F87E0000F07C000000
-7C000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000
-FC0000007C0000007C0000007E0000003E0000003E00000C1F00000C1F0000180F800018
-0780003003C0006001E000C000F00180003C0E000007F8001E257DA423> I<0007F80000
-3C1E0000F0078001C003C003C001E0078000F00F0000F81F0000781E00007C3E00007C3E
-00007C7E00003E7C00003E7C00003EFC00003EFC00003EFFFFFFFEFC000000FC000000FC
-000000FC000000FC000000FC0000007C0000007C0000007E0000003E0000003E0000061F
-0000060F00000C0F80000C0780001803C0003000E00060007000C0001E07000003FC001F
-257EA423> 101 D<0000FC0000078300000E0380001C07C0003C0FC000780FC000F80FC0
-00F8078000F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
-01F0000001F0000001F0000001F0000001F0000001F0000001F00000FFFFFC00FFFFFC00
-01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
-01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
-01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
-01F0000001F0000001F0000001F0000001F0000003F800007FFFE0007FFFE0001A3C7FBB
-18> I<07000F801FC01FC01FC00F80070000000000000000000000000000000000000000
-0000000000000007C0FFC0FFC00FC007C007C007C007C007C007C007C007C007C007C007
-C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
-C007C00FE0FFFEFFFE0F397DB815> 105 D<0003800007C0000FE0000FE0000FE00007C0
-000380000000000000000000000000000000000000000000000000000000000000000000
-0000000000000007E000FFE000FFE0000FE00003E00003E00003E00003E00003E00003E0
-0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0
-0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0
-0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0
-7803C0FC07C0FC0780FC0780FC0F00780E00381C000FE000134A82B818> I<07C0FFC0FF
-C00FC007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
-C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
-C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
-C00FE0FFFEFFFE0F3C7DBB15> 108 D<03E01FE0003FC000FFE0607C00C0F800FFE0801E
-01003C0007E3000F06001E0003E4000F88001F0003E4000F88001F0003E8000790000F00
-03E80007D0000F8003F00007E0000F8003F00007E0000F8003E00007C0000F8003E00007
-C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80
-03E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007
-C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80
-03E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007
-C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80
-07F0000FE0001FC0FFFF81FFFF03FFFEFFFF81FFFF03FFFE3F257EA443> I<03E01FE000
-FFE0607C00FFE0801E0007E3000F0003E4000F8003E4000F8003E800078003E80007C003
-F00007C003F00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E0
-0007C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E000
-07C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007
-C003E00007C003E00007C003E00007C003E00007C007F0000FE0FFFF81FFFFFFFF81FFFF
-28257EA42C> I<0007FC0000001C070000007001C00001E000F00003C00078000780003C
-000F00001E001F00001F001E00000F003E00000F803E00000F807C000007C07C000007C0
-7C000007C0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FC
-000007E0FC000007E0FC000007E07C000007C07C000007C07E00000FC03E00000F803E00
-000F801E00000F001F00001F000F00001E000780003C0003C000780001E000F000007001
-C000001C0700000007FC000023257EA427> I<03E03E00FFE0C300FFE1078007E20FC003
-E40FC003E80FC003E8078003E8030003F0000003F0000003F0000003E0000003E0000003
-E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003
-E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003
-E0000003E0000003E0000007F00000FFFFC000FFFFC0001A257EA41E> 114
-D<00FF02000700C6000C002E0010001E0030001E0060000E0060000E00E0000600E00006
-00E0000600F0000600F8000600FC0000007F0000003FF000003FFF80000FFFE00007FFF0
-0001FFFC00003FFE000001FE0000003F00C0001F00C0000F80C0000780E0000380E00003
-80E0000380E0000380F0000300F0000300F8000700F8000600E4000C00E2001800C18070
-00807F800019257DA41F> I<003000000030000000300000003000000030000000300000
-0070000000700000007000000070000000F0000000F0000001F0000001F0000003F00000
-07F000001FFFFE00FFFFFE0001F0000001F0000001F0000001F0000001F0000001F00000
-01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
-01F0000001F0000001F0000001F0000001F0018001F0018001F0018001F0018001F00180
-01F0018001F0018001F0018001F0018000F0010000F8030000F8030000780200003C0400
-000E08000003F00019357FB41E> I<FFFE000FFFFFFE000FFF07F00007F803E00003E003
-E00001C001F00001C001F000018001F800018000F800030000F8000300007C000600007C
-000600007E000600003E000C00003E000C00003F001C00001F001800001F001800000F80
-3000000F803000000FC070000007C060000007C060000003E0C0000003E0C0000003F1C0
-000001F180000001F180000000FB00000000FB00000000FF000000007E000000007E0000
-00003C000000003C000000003C0000000018000028257FA42A> 118
-D E
-%EndDVIPSBitmapFont
-end
-%%EndProlog
-%%BeginSetup
-%%Feature: *Resolution 300dpi
-TeXDict begin
-%%PaperSize: a4
-
-userdict/PStoPSxform PStoPSmatrix matrix currentmatrix
- matrix invertmatrix matrix concatmatrix
- matrix invertmatrix put
-%%EndSetup
-%%Page: (0,1) 1
-userdict/PStoPSsaved save put
-PStoPSmatrix setmatrix
-595.000000 0.271378 translate
-90 rotate
-0.706651 dup scale
-userdict/PStoPSmatrix matrix currentmatrix put
-userdict/PStoPSclip{0 0 moveto
- 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
- closepath}put initclip
-/showpage{}def/copypage{}def/erasepage{}def
-PStoPSxform concat
-1 0 bop Fn 281 370 a(Cleaner) p 570 370 a(seman) n(tics) p
-927 370 a(for) p 1047 370 a(Ob) t(jectiv) n(e) p 1404
-370 a(Lab) r(el) p Fm 717 518 a(Jacques) p 934 518 a(Garrigue) 719
-634 y(Octob) r(er) p 945 634 a(26,) p 1040 634 a(1999) p
-Fl 11 836 a(Credits) p Fk 11 929 a(This) p 122 929 a(prop) q(osal) p
-319 929 a(con) o(tains) p 510 929 a(ideas) p 632 929
-a(from) p 747 929 a(Damien) p 928 929 a(Doligez) p 1101
-929 a(and) p 1196 929 a(Pierre) p 1340 929 a(W) l(eis.) p
-Fl 11 1073 a(Lab) r(els) p 221 1073 a(and) p 351 1073
-a(optionals) p Fk 11 1165 a(Lab) q(els) p 165 1165 a(and) p
-259 1165 a(optional) p 449 1165 a(argumen) o(ts) p 687
-1165 a(had) p 781 1165 a(t) o(w) o(o) p 873 1165 a(problems) p
-1082 1165 a(in) p 1139 1165 a(Ob) s(jectiv) o(e) p 1360
-1165 a(Lab) q(el.) p Fj 83 1280 a(\017) p Fk 133 1280
-a(They) p 259 1280 a(w) o(ere) p 372 1280 a(not) p 459
-1280 a(fully) p 570 1280 a(coheren) o(t) p 767 1280 a(with) p
-878 1280 a(the) p 963 1280 a(original) p 1139 1280 a(call-b) o(y-v) m
-(alue) p 1423 1280 a(seman) o(tics) p 1644 1280 a(of) p
-1700 1280 a(the) p 1784 1280 a(lan-) 133 1340 y(guage.) p
-303 1340 a(In) p 368 1340 a(some) p 495 1340 a(\(subtle\)) p
-681 1340 a(cases,) p 823 1340 a(a) p 868 1340 a(side-e\013ect) p
-1099 1340 a(migh) o(t) p 1243 1340 a(get) p 1329 1340
-a(dela) o(y) o(ed) p 1508 1340 a(more) p 1635 1340 a(than) p
-1753 1340 a(in) p 1814 1340 a(an) 133 1400 y(un) o(t) o(yp) q(ed) p
-322 1400 a(seman) o(tics.) p Fj 83 1502 a(\017) p Fk
-133 1502 a(F) l(or) p 220 1502 a(optional) p 410 1502
-a(argumen) o(ts,) p 660 1502 a(no) p 728 1502 a(un) o(t) o(yp) q(ed) p
-918 1502 a(seman) o(tics) p 1139 1502 a(existed.) 84
-1616 y(This) p 195 1616 a(new) p 295 1616 a(prop) q(osal) p
-492 1616 a(corrects) p 674 1616 a(these) p 799 1616 a(t) o(w) o(o) p
-891 1616 a(\015a) o(ws.) p Fi 11 1746 a(Syn) n(tax) p
-Fk 11 1838 a(W) l(e) p 95 1838 a(k) o(eep) p 206 1838
-a(Ob) s(jectiv) o(e) p 426 1838 a(Lab) q(el's) p 594
-1838 a(syn) o(tax,) p 764 1838 a(except) p 917 1838 a(for) p
-991 1838 a(default) p 1155 1838 a(v) m(alues) p 1301
-1838 a(in) p 1357 1838 a(optional) p 1547 1838 a(argumen) o(ts.) p
-Fh 329 1944 a(typ) n(expr) p Fk 528 1944 a(::=) p Fg
-634 1944 a(:) p 656 1944 a(:) p 678 1944 a(:) p Fj 579
-2004 a(j) p Fh 634 2004 a(typ) n(expr) p Fj 806 2004
-a(!) p Fh 870 2004 a(typ) n(expr) p Fj 579 2064 a(j) p
-Fk 634 2064 a([?]) p Fi(lab) r(el) p Fk 801 2064 a(:) p
-Fh(typ) n(expr) p Fj 987 2064 a(!) p Fh 1050 2064 a(typ) n(expr) 391
-2124 y(expr) p Fk 528 2124 a(::=) p Fg 634 2124 a(:) p
-656 2124 a(:) p 678 2124 a(:) p Fj 579 2185 a(j) p Fh
-634 2185 a(expr) p 746 2185 a(lab) n(ele) n(d-expr) p
-Ff 991 2163 a(+) p Fj 579 2245 a(j) p Fe 634 2245 a(fun) p
-Fj 728 2245 a(f) p Fh(lab) n(ele) n(d-simple-p) n(attern) p
-Fj 1209 2245 a(g) p Ff 1234 2227 a(+) p Fk 1280 2245
-a([) p Fe(when) p Fh 1412 2245 a(expr) p Fk 1507 2245
-a(]) p Fj 1535 2245 a(!) p Fh 1599 2245 a(expr) p Fj
-579 2305 a(j) p Fe 634 2305 a(function) p Fh 856 2305
-a(lab) n(ele) n(d-p) n(attern) p Fk 1177 2305 a([) p
-Fe(when) p Fh 1309 2305 a(expr) p Fk 1404 2305 a(]) p
-Fj 1432 2305 a(!) p Fh 1496 2305 a(expr) p Fj 785 2365
-a(f) p Fe(|) p Fh 851 2365 a(lab) n(ele) n(d-p) n(attern) p
-Fk 1172 2365 a([) p Fe(when) p Fg 1305 2365 a(expr) p
-Fk 1403 2365 a(]) p Fj 1430 2365 a(!) p Fh 1494 2365
-a(expr) p Fj 1589 2365 a(g) p Fd 1614 2347 a(\003) p
-Fh 242 2425 a(lab) n(ele) n(d-expr) p Fk 528 2425 a(::=) p
-634 2425 a([?]) p Fh(expr) p Fj 579 2486 a(j) p Fk 634
-2486 a([?]) p Fi(lab) r(el) p Fk 801 2486 a(:) p Fh(expr) 182
-2546 y(lab) n(ele) n(d-p) n(attern) p Fk 528 2546 a(::=) p
-Fh 634 2546 a(p) n(attern) p Fj 579 2606 a(j) p Fi 634
-2606 a(lab) r(el) p Fk 751 2606 a(:) p Fh(p) n(attern) p
-Fj 579 2666 a(j) p Fk 634 2666 a(?[) p Fe(\() p Fh(expr) p
-Fe(\)) p Fk(]) p Fi(lab) r(el) p Fk 943 2666 a(:) p Fh
-956 2666 a(p) n(attern) p Fk 926 2937 a(1) p eop
-PStoPSsaved restore
-userdict/PStoPSsaved save put
-PStoPSmatrix setmatrix
-595.000000 421.271378 translate
-90 rotate
-0.706651 dup scale
-userdict/PStoPSmatrix matrix currentmatrix put
-userdict/PStoPSclip{0 0 moveto
- 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
- closepath}put initclip
-PStoPSxform concat
-2 1 bop Fi 11 168 a(Dynamic) p 247 168 a(seman) n(tics) p
-Fj 11 261 a(;) p Fk 52 261 a(is) p 101 261 a(a) p 141
-261 a(notation) p 337 261 a(for) p 411 261 a(the) p 495
-261 a(empt) o(y) p 644 261 a(lab) q(el.) 86 366 y(\() p
-Fe(fun) p Fi 198 366 a(l) p Fc 214 373 a(i) p Fk 227
-366 a(:) p Fg(x) p Fj 282 366 a(!) p Fg 346 366 a(e) p
-Fk(\)) p Fi 404 366 a(l) p Fc 420 373 a(1) p Fk 442 366
-a(:) p Fg 455 366 a(e) p Ff 478 373 a(1) p Fg 506 366
-a(:) p 528 366 a(:) p 550 366 a(:) p Fi 571 366 a(l) p
-Fc 587 373 a(n) p Fk 612 366 a(:) p Fg 625 366 a(e) p
-Fb 648 373 a(n) p Fj 515 427 a(!) p Fk 579 427 a(\() p
-Fg(e) p Fk([) p Fg(e) p Fb 658 434 a(i) p Fg 671 427
-a(=x) p Fk(]) p Fi 752 427 a(l) p Fc 768 434 a(1) p Fk
-790 427 a(:) p Fg(e) p Ff 827 434 a(1) p Fg 855 427 a(:) p
-877 427 a(:) p 899 427 a(:) p Fi 920 427 a(l) p Fc 936
-434 a(i) p Fd(\000) p Fc(1) p Fk 997 427 a(:) p Fg 1010
-427 a(e) p Fb 1033 434 a(i) p Fd(\000) p Ff(1) p Fi 1108
-427 a(l) p Fc 1124 434 a(i) p Ff(+) p Fc(1) p Fk 1185
-427 a(:) p Fg(e) p Fb 1222 434 a(i) p Ff(+1) p Fg 1289
-427 a(:) p 1311 427 a(:) p 1333 427 a(:) p Fi 1354 427
-a(l) p Fc 1370 434 a(n) p Fk 1395 427 a(:) p Fg 1408
-427 a(e) p Fb 1431 434 a(n) p Fk 86 487 a(\() p Fe(fun) p
-Fk 198 487 a(?) p Fi(l) p Fc 237 494 a(i) p Fk 250 487
-a(:) p Fg(x) p Fj 305 487 a(!) p Fg 369 487 a(e) p Fk(\)) p
-Fi 427 487 a(l) p Fc 443 494 a(1) p Fk 465 487 a(:) p
-Fg 478 487 a(e) p Ff 501 494 a(1) p Fg 529 487 a(:) p
-551 487 a(:) p 573 487 a(:) p Fi 594 487 a(l) p Fc 610
-494 a(n) p Fk 635 487 a(:) p Fg 648 487 a(e) p Fb 671
-494 a(n) p Fj 515 547 a(!) p Fg 579 547 a(e) p Fk([) p
-Fe(Some) p Fk 717 547 a(\() p Fg(e) p Fb 759 554 a(i) p
-Fk 773 547 a(\)) p Fg(=x) p Fk(]) p Fi 874 547 a(l) p
-Fc 890 554 a(1) p Fk 912 547 a(:) p Fg 925 547 a(e) p
-Ff 948 554 a(1) p Fg 976 547 a(:) p 998 547 a(:) p 1020
-547 a(:) p Fi 1042 547 a(l) p Fc 1058 554 a(i) p Fd(\000) p
-Fc(1) p Fk 1118 547 a(:) p Fg(e) p Fb 1155 554 a(i) p
-Fd(\000) p Ff(1) p Fi 1230 547 a(l) p Fc 1246 554 a(i) p
-Ff(+) p Fc(1) p Fk 1307 547 a(:) p Fg 1320 547 a(e) p
-Fb 1343 554 a(i) p Ff(+1) p Fg 1410 547 a(:) p 1432 547
-a(:) p 1454 547 a(:) p Fi 1476 547 a(l) p Fc 1492 554
-a(n) p Fk 1516 547 a(:) p Fg(e) p Fb 1553 554 a(n) p
-Fk 86 607 a(\() p Fe(fun) p Fk 198 607 a(?) p Fi(l) p
-Fk(:) p Fg 250 607 a(x) p Fj 292 607 a(!) p Fg 356 607
-a(e) p Fk(\)) p Fi 413 607 a(l) p Fc 429 614 a(1) p Fk
-451 607 a(:) p Fg(e) p Ff 488 614 a(1) p Fg 516 607 a(:) p
-538 607 a(:) p 560 607 a(:) p Fi 581 607 a(l) p Fc 597
-614 a(n) p Fk 621 607 a(:) p Fg(e) p Fb 658 614 a(n) p
-Fk 1154 607 a(when) p Fi 1281 607 a(l) p Fc 1297 614
-a(i) p Fk 1324 607 a(=) p Fj 1376 607 a(;) p Fk 1417
-607 a(and) p Fg 1512 607 a(l) p Fj 1541 607 a(62) p 1588
-607 a(f) p Fi(l) p Fc 1629 614 a(1) p Fg 1660 607 a(:) p
-1682 607 a(:) p 1704 607 a(:) p Fi 1725 607 a(l) p Fc
-1741 614 a(n) p Fj 1765 607 a(g) 515 667 y(!) p Fg 579
-667 a(e) p Fk([) p Fe(None) p Fg 717 667 a(=x) p Fk(]) p
-Fi 799 667 a(l) p Fc 815 674 a(1) p Fk 837 667 a(:) p
-Fg(e) p Ff 874 674 a(1) p Fg 901 667 a(:) p 923 667 a(:) p
-945 667 a(:) p Fi 967 667 a(l) p Fc 983 674 a(n) p Fk
-1007 667 a(:) p Fg(e) p Fb 1044 674 a(n) p Fk 86 728
-a(\(\() p Fe(fun) p Fi 217 728 a(l) p Fk(:) p Fg 246
-728 a(x) p Fj 288 728 a(!) p Fg 352 728 a(e) p Fk(\)) p
-Fi 409 728 a(l) p Fc 425 735 a(1) p Fk 447 728 a(:) p
-Fg(e) p Ff 484 735 a(1) p Fg 511 728 a(:) p 533 728 a(:) p
-555 728 a(:) p Fi 577 728 a(l) p Fc 593 735 a(m) p Fk
-629 728 a(:) p Fg 642 728 a(e) p Fb 665 735 a(m) p Fk
-698 728 a(\)) p Fi 733 728 a(l) p Fc 749 735 a(m) p Ff(+) p
-Fc(1) p Fk 833 728 a(:) p Fg 846 728 a(e) p Fb 869 735
-a(m) p Ff(+1) p Fg 955 728 a(:) p 977 728 a(:) p 999
-728 a(:) p Fi 1021 728 a(l) p Fc 1037 735 a(n) p Fk 1061
-728 a(:) p Fg(e) p Fb 1098 735 a(n) p Fk 1373 728 a(when) p
-Fi 1501 728 a(l) p Fj 1530 728 a(62) p 1577 728 a(f) p
-Fi(l) p Fc 1618 735 a(1) p Fg 1648 728 a(:) p 1670 728
-a(:) p 1692 728 a(:) p Fi 1714 728 a(l) p Fc 1730 735
-a(m) p Fj 1765 728 a(g) 515 788 y(!) p Fk 579 788 a(\() p
-Fe(fun) p Fi 691 788 a(l) p Fk(:) p Fg 720 788 a(x) p
-Fj 761 788 a(!) p Fg 825 788 a(e) p Fk(\)) p Fi 883 788
-a(l) p Fc 899 795 a(1) p Fk 921 788 a(:) p Fg 934 788
-a(e) p Ff 957 795 a(1) p Fg 985 788 a(:) p 1007 788 a(:) p
-1029 788 a(:) p Fi 1051 788 a(l) p Fc 1067 795 a(n) p
-Fk 1091 788 a(:) p Fg 1104 788 a(e) p Fb 1127 795 a(n) p
-Fk 86 848 a(\(\() p Fe(fun) p Fk 217 848 a(?) p Fi(l) p
-Fk(:) p Fg 269 848 a(x) p Fj 311 848 a(!) p Fg 375 848
-a(e) p Fk(\)) p Fi 432 848 a(l) p Fc 448 855 a(1) p Fk
-470 848 a(:) p Fg(e) p Ff 507 855 a(1) p Fg 535 848 a(:) p
-557 848 a(:) p 579 848 a(:) p Fi 600 848 a(l) p Fc 616
-855 a(m) p Fk 652 848 a(:) p Fg 665 848 a(e) p Fb 688
-855 a(m) p Fk 721 848 a(\)) p Fi 756 848 a(l) p Fc 772
-855 a(m) p Ff(+) p Fc(1) p Fk 856 848 a(:) p Fg 869 848
-a(e) p Fb 892 855 a(m) p Ff(+1) p Fg 978 848 a(:) p 1000
-848 a(:) p 1022 848 a(:) p Fi 1044 848 a(l) p Fc 1060
-855 a(n) p Fk 1084 848 a(:) p Fg(e) p Fb 1121 855 a(n) p
-Fk 1261 848 a(when) p Fj 1388 848 a(f) p Fi(l) p Fg(;) p
-Fj 1451 848 a(;g) p 1530 848 a(6) m(\\) p 1577 848 a(f) p
-Fi(l) p Fc 1618 855 a(1) p Fg 1648 848 a(:) p 1670 848
-a(:) p 1692 848 a(:) p Fi 1714 848 a(l) p Fc 1730 855
-a(m) p Fj 1765 848 a(g) 515 908 y(!) p Fk 579 908 a(\() p
-Fe(fun) p Fk 691 908 a(?) p Fi(l) p Fk(:) p Fg 743 908
-a(x) p Fj 785 908 a(!) p Fg 848 908 a(e) p Fk(\)) p Fi
-906 908 a(l) p Fc 922 915 a(1) p Fk 944 908 a(:) p Fg(e) p
-Ff 981 915 a(1) p Fg 1008 908 a(:) p 1030 908 a(:) p
-1052 908 a(:) p Fi 1074 908 a(l) p Fc 1090 915 a(n) p
-Fk 1114 908 a(:) p Fg 1127 908 a(e) p Fb 1150 915 a(n) p
-Fi 11 1035 a(T) n(yping) p Fk 11 1127 a(Seman) o(tics) p
-240 1127 a(are) p 321 1127 a(k) o(ept) p 430 1127 a(throughout) p
-685 1127 a(compilation) p 950 1127 a(b) o(y) p 1018 1127
-a(disallo) o(wing) p 1269 1127 a(lab) q(el) p 1387 1127
-a(comm) o(utation) p 1684 1127 a(for) p 1759 1127 a(func-) 11
-1187 y(tion) p 116 1187 a(t) o(yp) q(es.) p 278 1187
-a(Ho) o(w) o(ev) o(er,) p 494 1187 a(the) p 583 1187
-a(original) p 764 1187 a(comfort) p 949 1187 a(of) p
-1009 1187 a(out-of-order) p 1283 1187 a(application) p
-1540 1187 a(is) p 1594 1187 a(reco) o(v) o(ered) p 1814
-1187 a(b) o(y) 11 1247 y(allo) o(wing) p 207 1247 a(argumen) o(t) p
-431 1247 a(reordering) p 670 1247 a(in) p 732 1247 a(application,) p
-1005 1247 a(when) p 1138 1247 a(the) p 1227 1247 a(function's) p
-1457 1247 a(t) o(yp) q(e) p 1572 1247 a(is) p Fh 1626
-1247 a(wel) r(l) p 1731 1247 a(known) p Fk 11 1308 a(\() p
-Fh(c.f.) p Fk 118 1308 a(p) q(olymorphic) p 400 1308
-a(metho) q(ds\).) p Fl 11 1452 a(V) p 56 1452 a(arian) n(ts) p
-Fk 11 1544 a(V) l(arian) o(t) p 187 1544 a(t) o(yping,) p
-355 1544 a(as) p 417 1544 a(it) p 468 1544 a(is) p 519
-1544 a(presen) o(ted) p 739 1544 a(in) p 798 1544 a(the) p
-884 1544 a(user's) p 1022 1544 a(man) o(ual,) p 1210
-1544 a(is) p 1261 1544 a(not) p 1350 1544 a(principal:) p
-1576 1544 a(in) p 1635 1544 a(some) p 1760 1544 a(cases) 11
-1605 y(t) o(ypabilit) o(y) p 239 1605 a(of) p 301 1605
-a(an) p 375 1605 a(expression) p 616 1605 a(ma) o(y) p
-728 1605 a(dep) q(end) p 904 1605 a(on) p 978 1605 a(the) p
-1069 1605 a(order) p 1202 1605 a(in) p 1265 1605 a(whic) o(h) p
-1411 1605 a(the) p 1502 1605 a(t) o(yping) p 1660 1605
-a(algorithm) 11 1665 y(pro) q(ceeds.) p Fe 133 1779 a(#) p
-184 1779 a(let) p 286 1779 a(f1) p 363 1779 a(\(x) p
-440 1779 a(:) p 491 1779 a([<) p 568 1779 a(a) p 620
-1779 a(b\(int\)]\)) p 850 1779 a(=) p 902 1779 a(\(\)) 184
-1839 y(let) p 286 1839 a(f2) p 363 1839 a(\(x) p 440
-1839 a(:) p 491 1839 a([<) p 568 1839 a(a]\)) p 671 1839
-a(=) p 722 1839 a(\(\)) 184 1899 y(let) p 286 1899 a(f3) p
-363 1899 a(\(x) p 440 1899 a(:) p 491 1899 a([<) p 568
-1899 a(a) p 620 1899 a(b\(bool\)]\)) p 876 1899 a(=) p
-927 1899 a(\(\);;) 133 1960 y(val) p 235 1960 a(f1) p
-312 1960 a(:) p 363 1960 a([<) p 440 1960 a(a) p 491
-1960 a(b\(int\)]) p 696 1960 a(->) p 773 1960 a(unit) p
-902 1960 a(=) p 953 1960 a(<fun>) 133 2020 y(val) p 235
-2020 a(f2) p 312 2020 a(:) p 363 2020 a([<) p 440 2020
-a(a]) p 517 2020 a(->) p 594 2020 a(unit) p 722 2020
-a(=) p 773 2020 a(<fun>) 133 2080 y(val) p 235 2080 a(f3) p
-312 2080 a(:) p 363 2080 a([<) p 440 2080 a(a) p 491
-2080 a(b\(bool\)]) p 722 2080 a(->) p 799 2080 a(unit) p
-927 2080 a(=) p 978 2080 a(<fun>) 133 2140 y(#) p 184
-2140 a(fun) p 286 2140 a(x) p 338 2140 a(->) p 414 2140
-a(f1) p 491 2140 a(x;) p 568 2140 a(f2) p 645 2140 a(x;) p
-722 2140 a(f3) p 799 2140 a(x;;) 133 2200 y(-) p 184
-2200 a(:) p 235 2200 a([<) p 312 2200 a(a]) p 389 2200
-a(->) p 466 2200 a(unit) p 594 2200 a(=) p 645 2200 a(<fun>) 133
-2260 y(#) p 184 2260 a(fun) p 286 2260 a(x) p 338 2260
-a(->) p 414 2260 a(f1) p 491 2260 a(x;) p 568 2260 a(f3) p
-645 2260 a(x;;) 133 2321 y(Character) o(s) p 414 2321
-a(18-19:) 133 2381 y(This) p 261 2381 a(expressio) o(n) p
-543 2381 a(has) p 645 2381 a(type) p 773 2381 a([<) p
-850 2381 a(a) p 902 2381 a(b\(int\)]) p 1107 2381 a(but) p
-1209 2381 a(is) p 1286 2381 a(here) p 1414 2381 a(used) p
-1542 2381 a(with) p 1670 2381 a(type) 184 2441 y([<) p
-261 2441 a(a) p 312 2441 a(b\(bool\)]) p Fk 84 2555 a(Here) p
-204 2555 a(the) p 292 2555 a(constrain) o(t) p 526 2555
-a(in) o(tro) q(duced) p 775 2555 a(b) o(y) p Fe 848 2555
-a(f2) p Fk 920 2555 a(hides) p 1049 2555 a(the) p 1138
-2555 a(constructor) p Fe 1401 2555 a(b) p Fk(,) p 1462
-2555 a(and) p 1562 2555 a(a) o(v) o(oids) p 1714 2555
-a(a) p 1760 2555 a(clash) 11 2615 y(b) q(et) o(w) o(een) p
-Fe 199 2615 a(int) p Fk 292 2615 a(and) p Fe 387 2615
-a(bool) p Fk(.) 84 2676 y(An) p 163 2676 a(easy) p 270
-2676 a(w) o(a) o(y) p 369 2676 a(to) p 428 2676 a(solv) o(e) p
-547 2676 a(this) p 642 2676 a(w) o(ould) p 784 2676 a(b) q(e) p
-850 2676 a(to) p 909 2676 a(restrict) p 1077 2676 a(hiding) p
-1226 2676 a(absen) o(t) p 1379 2676 a(lab) q(els) p 1515
-2676 a(to) p 1575 2676 a(generic) p 1739 2676 a(t) o(yp) q(es.) 11
-2736 y(This) p 124 2736 a(w) o(a) o(y) p 224 2736 a(the) p
-310 2736 a(second) p 469 2736 a(case) p 574 2736 a(w) o(ould) p
-718 2736 a(still) p 814 2736 a(fail,) p 913 2736 a(since) p
-Fe 1034 2736 a(x) p Fk 1077 2736 a(has) p 1166 2736 a(a) p
-1208 2736 a(monorphic) p 1451 2736 a(t) o(yp) q(e.) p
-1584 2736 a(This) p 1697 2736 a(solution) 11 2796 y(w) o(ould) p
-153 2796 a(b) q(e) p 219 2796 a(correct) p 382 2796 a(and) p
-477 2796 a(principal.) 926 2937 y(2) p eop
-PStoPSsaved restore
-%%Page: (2,3) 2
-userdict/PStoPSsaved save put
-PStoPSmatrix setmatrix
-595.000000 0.271378 translate
-90 rotate
-0.706651 dup scale
-userdict/PStoPSmatrix matrix currentmatrix put
-userdict/PStoPSclip{0 0 moveto
- 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
- closepath}put initclip
-/showpage{}def/copypage{}def/erasepage{}def
-PStoPSxform concat
-3 2 bop Fk 84 168 a(Ho) o(w) o(ev) o(er,) p 293 168 a(one) p
-382 168 a(can) p 472 168 a(easily) p 606 168 a(see) p
-684 168 a(that) p 789 168 a(this) p 884 168 a(solution) p
-1068 168 a(is) p 1117 168 a(coun) o(ter-in) o(tuitiv) o(e.) p
-1504 168 a(F) l(or) p 1591 168 a(the) p 1675 168 a(user,) p
-Fe 1791 168 a(b) p Fk 1833 168 a(is) 11 229 y(already) p
-183 229 a(an) p 250 229 a(imp) q(ossible) p 488 229 a(constructor,) p
-759 229 a(and) p 854 229 a(ha) o(ving) p 1011 229 a(a) p
-1052 229 a(clash) p 1174 229 a(on) p 1242 229 a(it) p
-1291 229 a(is) p 1340 229 a(hard) p 1453 229 a(to) p
-1513 229 a(understand.) 84 289 y(Another) p 277 289 a(solution) p
-463 289 a(is) p 514 289 a(to) p 575 289 a(go) p 642 289
-a(the) p 728 289 a(opp) q(osite) p 924 289 a(w) o(a) o(y) l(.) p
-1044 289 a(T) l(o) p 1117 289 a(accept) p 1271 289 a(more) p
-1395 289 a(programs.) p 1634 289 a(This) p 1747 289 a(is) p
-1798 289 a(the) 11 349 y(w) o(a) o(y) p 109 349 a(w) o(e) p
-181 349 a(explore) p 351 349 a(here,) p 470 349 a(with) p
-581 349 a(an) p 649 349 a(unc) o(hanged) p 891 349 a(syn) o(tax.) p
-Fi 11 479 a(T) n(yping) p Fk 11 571 a(The) p 114 571
-a(idea) p 220 571 a(is) p 273 571 a(to) p 336 571 a(dela) o(y) p
-466 571 a(uni\014cation) p 711 571 a(on) p 782 571 a(constructor) p
-1043 571 a(un) o(til) p 1161 571 a(they) p 1274 571 a(are) p
-1359 571 a(explicitely) p 1595 571 a(kno) o(wn) p 1753
-571 a(to) p 1816 571 a(b) q(e) 11 631 y(presen) o(t.) p
-199 631 a(W) l(e) p 280 631 a(k) o(eep) p 390 631 a(the) p
-472 631 a(\() p Fg(T) t(;) p 546 631 a(U;) p 601 631
-a(L) p Fk(\)) p 666 631 a(represen) o(tation) p 983 631
-a(of) p 1036 631 a(v) m(arian) o(t) p 1200 631 a(t) o(yp) q(es,) p
-1341 631 a(but) p Fg 1428 631 a(T) p Fk 1478 631 a(is) p
-1525 631 a(no) p 1591 631 a(longer) p 1735 631 a(a) p
-1774 631 a(map) 11 692 y(from) p 126 692 a(constructors) p
-403 692 a(to) p 462 692 a(t) o(yp) q(es,) p 605 692 a(but) p
-694 692 a(from) p 809 692 a(constructors) p 1086 692
-a(to) p 1146 692 a(sets) p 1241 692 a(of) p 1297 692
-a(t) o(yp) q(es.) 84 752 y(When) p 230 752 a(w) o(e) p
-307 752 a(unify) p 436 752 a(t) o(w) o(o) p 532 752 a(v) m(arian) o(t) p
-702 752 a(t) o(yp) q(es,) p 850 752 a(the) p 938 752
-a(\014rst) p 1043 752 a(step) p 1150 752 a(is) p 1204
-752 a(just) p 1305 752 a(to) p 1369 752 a(tak) o(e) p
-1479 752 a(the) p 1567 752 a(union) p 1707 752 a(of) p
-1767 752 a(b) q(oth) 11 812 y(t) o(yping) p 162 812 a(en) o(vironmen) o
-(ts,) p 476 812 a(dropping) p 682 812 a(unnecessary) p
-952 812 a(t) o(yp) q(es.) 204 932 y(\() p Fg(T) p Ff
-252 939 a(1) p Fg 272 932 a(;) p 294 932 a(U) p Ff 327
-939 a(1) p Fg 346 932 a(;) p 368 932 a(L) p Ff 401 939
-a(1) p Fk 421 932 a(\)) p Fj 451 932 a(^) p Fk 495 932
-a(\() p Fg(T) p Ff 543 939 a(2) p Fg 563 932 a(;) p 585
-932 a(U) p Ff 618 939 a(2) p Fg 637 932 a(;) p 659 932
-a(L) p Ff 692 939 a(2) p Fk 712 932 a(\)) p 745 932 a(=) p
-797 932 a(\(\() p Fg(T) p Ff 864 939 a(1) p Fj 883 932
-a(j) p Fb 897 939 a(U) p Fa 921 944 a(1) p Fd 938 939
-a(\\) p Fb(U) p Fa 986 944 a(2) p Fk 1005 932 a(\)) p
-Fj 1035 932 a([) p Fk 1079 932 a(\() p Fg(T) p Ff 1127
-939 a(2) p Fj 1146 932 a(j) p Fb 1160 939 a(U) p Fa 1184
-944 a(1) p Fd 1201 939 a(\\) p Fb(U) p Fa 1249 944 a(2) p
-Fk 1268 932 a(\)) p Fg(;) p 1309 932 a(U) p Ff 1342 939
-a(1) p Fj 1373 932 a(\\) p Fg 1417 932 a(U) p Ff 1450
-939 a(2) p Fg 1470 932 a(;) p 1492 932 a(L) p Ff 1525
-939 a(1) p Fj 1556 932 a([) p Fg 1600 932 a(L) p Ff 1633
-939 a(2) p Fk 1653 932 a(\)) 84 1042 y(Here) p 203 1042
-a(the) p 291 1042 a(union) p 431 1042 a(of) p 490 1042
-a(t) o(w) o(o) p 587 1042 a(t) o(yping) p 742 1042 a(en) o(vironmen) o
-(ts) p 1046 1042 a(is) p 1099 1042 a(the) p 1187 1042
-a(p) q(oin) o(t) o(wise) p 1407 1042 a(union) p 1547
-1042 a(of) p 1606 1042 a(their) p 1727 1042 a(sets) p
-1826 1042 a(of) 11 1102 y(t) o(yp) q(es) p 140 1102 a(for) p
-214 1102 a(eac) o(h) p 324 1102 a(constructor.) 84 1162
-y(This) p 195 1162 a(\014rst) p 296 1162 a(step) p 399
-1162 a(nev) o(er) p 529 1162 a(fails.) 84 1222 y(In) p
-145 1222 a(a) p 186 1222 a(second) p 343 1222 a(step,) p
-460 1222 a(structural) p 685 1222 a(constrain) o(ts) p
-934 1222 a(are) p 1015 1222 a(enforced) p 1209 1222 a(on) p
-1277 1222 a(the) p 1361 1222 a(resulting) p 1562 1222
-a(t) o(yp) q(e) p 1672 1222 a(\() p Fg(T) t(;) p 1746
-1222 a(U;) p 1801 1222 a(L) p Fk(\).) 11 1282 y(First,) p
-Fg 144 1282 a(L) p Fk 195 1282 a(should) p 351 1282 a(b) q(e) p
-418 1282 a(included) p 614 1282 a(in) p Fg 672 1282 a(U) p
-Fk 710 1282 a(.) p 749 1282 a(Then,) p 892 1282 a(for) p
-967 1282 a(all) p 1036 1282 a(constructors) p 1314 1282
-a(app) q(earing) p 1542 1282 a(in) p Fg 1600 1282 a(L) p
-Fk(,) p 1664 1282 a(the) p 1749 1282 a(set) p 1826 1282
-a(of) 11 1343 y(t) o(yp) q(es) p 136 1343 a(asso) q(ciated) p
-365 1343 a(with) p 472 1343 a(eac) o(h) p 578 1343 a(constructor) p
-833 1343 a(is) p 878 1343 a(collapsed) p 1084 1343 a(b) o(y) p
-1148 1343 a(uni\014cation.) p 1407 1343 a(This) p 1515
-1343 a(can) p 1600 1343 a(b) q(e) p 1663 1343 a(expressed) 11
-1403 y(b) o(y) p 78 1403 a(rewriting) p 287 1403 a(rules,) p
-417 1403 a(where) p Fg 558 1403 a(e) p Fk 597 1403 a(is) p
-646 1403 a(a) p 687 1403 a(m) o(ulti-equation) p 1015
-1403 a(and) p Fg 1109 1403 a(\036) p Fk 1155 1403 a(a) p
-1195 1403 a(set) p 1271 1403 a(of) p 1327 1403 a(m) o(ultiequations) 249
-1509 y(if) p Fg 294 1509 a(L) p Fj 341 1509 a(6\032) p
-Fg 393 1509 a(U) p Fk 448 1509 a(then) p 559 1509 a(\() p
-Fg(T) t(;) p 633 1509 a(U;) p 688 1509 a(L) p Fk(\)) p
-753 1509 a(=) p Fg 805 1509 a(e) p Fj 839 1509 a(^) p
-Fg 883 1509 a(\036) p Fj 926 1509 a(\000) p 956 1509
-a(!) p 1020 1509 a(?) p Fk 249 1629 a(if) p Fg 294 1629
-a(l) p Fj 323 1629 a(2) p Fg 370 1629 a(L) p Fk 420 1629
-a(and) p Fg 515 1629 a(T) p Fk 551 1629 a(\() p Fg(l) p
-Fk 586 1629 a(\)) p 617 1629 a(=) p Fj 669 1629 a(f) p
-Fg(\034) p Ff 715 1636 a(1) p Fg 735 1629 a(;) p 757
-1629 a(:) p 779 1629 a(:) p 801 1629 a(:) p 822 1629
-a(;) p 844 1629 a(\034) p Fb 865 1636 a(n) p Fj 889 1629
-a(g) p Fk 930 1629 a(then) 298 1689 y(\() p Fg(T) t(;) p
-372 1689 a(U;) p 427 1689 a(L) p Fk(\)) p 492 1689 a(=) p
-Fg 544 1689 a(e) p Fj 577 1689 a(^) p Fg 622 1689 a(\036) p
-Fj 664 1689 a(\000) p 695 1689 a(!) p Fk 759 1689 a(\() p
-Fg(T) p Fj 814 1689 a(f) p Fg(l) p Fj 867 1689 a(7!) p
-Fg 931 1689 a(\034) p Ff 952 1696 a(1) p Fj 972 1689
-a(g) p Fg(;) p 1019 1689 a(U;) p 1074 1689 a(L) p Fk(\)) p
-1139 1689 a(=) p Fg 1191 1689 a(e) p Fj 1225 1689 a(^) p
-Fg 1269 1689 a(\034) p Ff 1290 1696 a(1) p Fk 1324 1689
-a(=) p Fg 1376 1689 a(:) p 1398 1689 a(:) p 1420 1689
-a(:) p Fk 1447 1689 a(=) p Fg 1498 1689 a(\034) p Fb
-1519 1696 a(n) p Fj 1554 1689 a(^) p Fg 1598 1689 a(\036) p
-Fk 84 1796 a(Optionally) p 331 1796 a(one) p 425 1796
-a(can) p 519 1796 a(add) p 619 1796 a(rules) p 740 1796
-a(that) p 850 1796 a(remo) o(v) o(e) p 1022 1796 a(a) p
-1067 1796 a(constructor) p Fg 1329 1796 a(l) p Fk 1366
-1796 a(from) p Fg 1486 1796 a(U) p Fk 1545 1796 a(if) p
-1594 1796 a(the) p 1683 1796 a(equation) 11 1856 y(obtained) p
-211 1856 a(from) p Fg 326 1856 a(T) p Fk 362 1856 a(\() p
-Fg(l) p Fk 397 1856 a(\)) p 431 1856 a(has) p 518 1856
-a(no) p 586 1856 a(solution.) p 790 1856 a(Suc) o(h) p
-908 1856 a(rules) p 1024 1856 a(w) o(ould) p 1167 1856
-a(b) q(e) p 1233 1856 a(sound) p 1374 1856 a(and) p 1469
-1856 a(complete.) p Fi 11 1986 a(Syn) n(tax) p 198 1986
-a(of) p 262 1986 a(t) n(yp) r(es) p Fk 11 2078 a(Thanks) p
-188 2078 a(to) p 250 2078 a(the) p 336 2078 a(go) q(o) q(d) p
-458 2078 a(prop) q(erties) p 689 2078 a(of) p 747 2078
-a(these) p 874 2078 a(constrain) o(ts,) p 1139 2078 a(the) p
-1226 2078 a(surface) p 1392 2078 a(syn) o(tax) p 1551
-2078 a(of) p 1608 2078 a(t) o(yp) q(es) p 1740 2078 a(w) o(ould) 11
-2138 y(only) p 118 2138 a(ha) o(v) o(e) p 230 2138 a(to) p
-290 2138 a(b) q(e) p 356 2138 a(sligh) o(tly) p 527 2138
-a(extended.) p Fh 590 2244 a(tag-typ) n(e) p Fk 798 2244
-a(::=) p Fh 904 2244 a(ident) p Fj 849 2304 a(j) p Fh
-904 2304 a(ident) p Fe 1031 2304 a(\() p Fh(typ) n(expr-list) p
-Fe(\)) p Fh 523 2365 a(typ) n(expr-list) p Fk 798 2365
-a(::=) p Fh 904 2365 a(typ) n(expr) p Fj 849 2425 a(j) p
-Fh 904 2425 a(typ) n(expr) p Fe 1078 2425 a(&) p Fh 1120
-2425 a(typ) n(expr-list) p Fk 84 2531 a(Notice) p 234
-2531 a(that) p 336 2531 a(a) p 373 2531 a(0-ary) p 496
-2531 a(constructor) p 751 2531 a(and) p 842 2531 a(an) p
-907 2531 a(1-ary) p 1030 2531 a(construtor) p 1262 2531
-a(are) p 1340 2531 a(con) o(tradictory) l(,) p 1648 2531
-a(and) p 1740 2531 a(w) o(ould) 11 2592 y(result) p 146
-2592 a(in) p 203 2592 a(the) p 287 2592 a(absence) p
-466 2592 a(of) p 522 2592 a(this) p 617 2592 a(constructor.) 926
-2937 y(3) p eop
-PStoPSsaved restore
-userdict/PStoPSsaved save put
-PStoPSmatrix setmatrix
-595.000000 421.271378 translate
-90 rotate
-0.706651 dup scale
-userdict/PStoPSmatrix matrix currentmatrix put
-userdict/PStoPSclip{0 0 moveto
- 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
- closepath}put initclip
-PStoPSxform concat
-4 3 bop Fi 11 168 a(Discussion) p Fk 11 261 a(Suc) o(h) p
-133 261 a(a) p 179 261 a(c) o(hange) p 345 261 a(has) p
-436 261 a(the) p 525 261 a(ma) s(jor) p 672 261 a(adv) m(an) o(tage) p
-907 261 a(of) p 967 261 a(b) q(oth) p 1087 261 a(reco) o(v) o(ering) p
-1324 261 a(principalit) o(y) p 1589 261 a(and) p 1688
-261 a(a) o(v) o(oiding) 11 321 y(unin) o(tuitiv) o(e) p
-266 321 a(error) p 392 321 a(messages.) p 640 321 a(Constrain) o(ts) p
-909 321 a(created) p 1087 321 a(in) p 1152 321 a(suc) o(h) p
-1269 321 a(a) p 1317 321 a(w) o(a) o(y) p 1423 321 a(are) p
-1512 321 a(v) o(ery) p 1626 321 a(ligh) o(t:) p 1772
-321 a(they) 11 381 y(alw) o(a) o(ys) p 165 381 a(app) q(ear) p
-325 381 a(inside) p 463 381 a(a) p 502 381 a(v) m(arian) o(t) p
-666 381 a(t) o(yp) q(e,) p 788 381 a(and) p 882 381 a(if) p
-926 381 a(the) p 1008 381 a(v) m(arian) o(t) p 1172 381
-a(t) o(yp) q(e) p 1281 381 a(do) q(es) p 1390 381 a(not) p
-1475 381 a(app) q(ear) p 1635 381 a(in) p 1691 381 a(the) p
-1774 381 a(\014nal) 11 441 y(t) o(yp) q(e) p 120 441
-a(sc) o(heme,) p 301 441 a(then) p 412 441 a(the) p 496
-441 a(constrain) o(t) p 725 441 a(can) p 815 441 a(b) q(e) p
-881 441 a(discarded) p 1098 441 a(safely) l(.) 84 501
-y(On) p 165 501 a(the) p 249 501 a(other) p 376 501 a(hand,) p
-512 501 a(there) p 637 501 a(are) p 718 501 a(t) o(w) o(o) p
-810 501 a(dra) o(wbac) o(ks.) p Fj 83 616 a(\017) p Fk
-133 616 a(Some) p 259 616 a(errors) p 393 616 a(will) p
-482 616 a(b) q(e) p 544 616 a(dela) o(y) o(ed) p 715
-616 a(longer) p 858 616 a(than) p 968 616 a(no) o(w,) p
-1080 616 a(un) o(til) p 1191 616 a(a) p 1228 616 a(construtor) p
-1460 616 a(is) p 1505 616 a(actually) p 1687 616 a(included) 133
-676 y(in) p Fg 189 676 a(L) p Fk(.) p 258 676 a(It) p
-311 676 a(is) p 360 676 a(not) p 446 676 a(clear) p 563
-676 a(ho) o(w) p 665 676 a(damageable) p 930 676 a(it) p
-979 676 a(is.) p Fj 83 777 a(\017) p Fk 133 777 a(While) p
-272 777 a(t) o(yp) q(e) p 378 777 a(inference) p 579
-777 a(is) p 625 777 a(simple) p 774 777 a(and) p 865
-777 a(costless) p 1036 777 a(for) p 1108 777 a(this) p
-1200 777 a(extension,) p 1426 777 a(simpli\014cation) p
-1724 777 a(of) p 1776 777 a(con-) 133 838 y(strain) o(ts) p
-310 838 a(|marking) p 551 838 a(constructors) p 830 838
-a(with) p 943 838 a(unsolv) m(able) p 1182 838 a(constrain) o(ts) p
-1432 838 a(as) p 1494 838 a(absen) o(t,) p 1663 838 a(and) p
-1760 838 a(elim-) 133 898 y(inating) p 300 898 a(redundan) o(t) p
-536 898 a(t) o(yp) q(es) p 667 898 a(in) p 726 898 a(constrain) o(ts|) p
-1025 898 a(is) p 1076 898 a(a) p 1119 898 a(bit) p 1197
-898 a(more) p 1320 898 a(exp) q(ensiv) o(e.) p 1565 898
-a(Also,) p 1691 898 a(allo) o(wing) 133 958 y(suc) o(h) p
-244 958 a(constrained) p 506 958 a(t) o(yp) q(es) p 637
-958 a(inside) p 777 958 a(signatures) p 1010 958 a(w) o(ould) p
-1154 958 a(mean) p 1286 958 a(ha) o(ving) p 1444 958
-a(to) p 1506 958 a(solv) o(e) p 1627 958 a(a) p 1669
-958 a(matc) o(hing) 133 1018 y(problem,) p 333 1018 a(whic) o(h) p
-469 1018 a(is) p 514 1018 a(exp) q(onen) o(tial) p 772
-1018 a(in) p 825 1018 a(the) p 906 1018 a(n) o(um) o(b) q(er) p
-1080 1018 a(of) p 1132 1018 a(connected) p 1356 1018
-a(constrain) o(ts) p 1600 1018 a(inside) p 1735 1018
-a(a) p 1772 1018 a(t) o(yp) q(e) 133 1078 y(sc) o(heme.) 84
-1193 y(Reasonably) p 340 1193 a(e\016cien) o(t) p 516
-1193 a(algorithms) p 754 1193 a(exist) p 866 1193 a(to) p
-922 1193 a(solv) o(e) p 1038 1193 a(these) p 1159 1193
-a(problems,) p 1379 1193 a(so) p 1435 1193 a(the) p 1515
-1193 a(di\016cult) o(y) p 1715 1193 a(is) p 1760 1193
-a(more) 11 1253 y(in) p 67 1253 a(the) p 151 1253 a(increased) p
-363 1253 a(complexit) o(y) p 611 1253 a(of) p 667 1253
-a(the) p 751 1253 a(t) o(yp) q(e-c) o(hec) o(k) o(er) p
-1031 1253 a(than) p 1145 1253 a(in) p 1202 1253 a(run-time) p
-1402 1253 a(cost.) p Fl 11 1397 a(Other) p 205 1397 a(features) p
-Fk 11 1490 a(Ob) s(jectiv) o(e) p 238 1490 a(Lab) q(el) p
-380 1490 a(con) o(tains) p 579 1490 a(t) o(w) o(o) p
-678 1490 a(other) p 812 1490 a(features:) p 1029 1490
-a(p) q(olymorphic) p 1318 1490 a(metho) q(ds) p 1521
-1490 a(and) p 1623 1490 a(t) o(yp) q(e-driv) o(en) 11
-1550 y(access) p 153 1550 a(of) p 208 1550 a(records.) p
-394 1550 a(Both) p 514 1550 a(of) p 568 1550 a(them) p
-692 1550 a(use) p 775 1550 a(the) p 857 1550 a(same) p
-978 1550 a(metho) q(d) p 1154 1550 a(of) p 1209 1550
-a(enforcing) p 1417 1550 a(principalit) o(y) p 1676 1550
-a(of) p 1730 1550 a(t) o(yping) 11 1610 y(through) p
-191 1610 a(tracing) p 351 1610 a(user) p 450 1610 a(pro) o(vided) p
-647 1610 a(t) o(yp) q(e) p 752 1610 a(information.) p
-1034 1610 a(With) p 1155 1610 a(this) p 1246 1610 a(tracing,) p
-1422 1610 a(their) p 1534 1610 a(implem) o(en) n(tation) 11
-1670 y(is) p 60 1670 a(v) o(ery) p 167 1670 a(easy) l(,) p
-283 1670 a(but) p 373 1670 a(without) p 554 1670 a(it) p
-603 1670 a(they) p 713 1670 a(lo) q(ose) p 834 1670 a(principalit) o(y)
-l(.) 84 1730 y(While) p 229 1730 a(these) p 357 1730
-a(features) p 543 1730 a(pro) o(vide) p 720 1730 a(some) p
-845 1730 a(comfort) p 1029 1730 a(in) p 1089 1730 a(writing) p
-1260 1730 a(user) p 1366 1730 a(programs,) p 1598 1730
-a(they) p 1711 1730 a(are) p 1795 1730 a(not) 11 1791
-y(strictly) p 182 1791 a(necessary) p 403 1791 a(for) p
-482 1791 a(the) p 571 1791 a(v) m(arious) p 742 1791
-a(libraries) p 934 1791 a(coming) p 1107 1791 a(with) p
-1223 1791 a(O'Labl) p 1391 1791 a(\(LablTk,) p 1602 1791
-a(LablGL) p 1787 1791 a(and) 11 1851 y(LablGTK\).) 926
-2937 y(4) p eop
-PStoPSsaved restore
-%%Trailer
-end
-userdict /end-hook known{end-hook}if
-%%EOF
diff --git a/testlabl/poly.exp b/testlabl/poly.exp
deleted file mode 100644
index 8df92e4445..0000000000
--- a/testlabl/poly.exp
+++ /dev/null
@@ -1,332 +0,0 @@
- Objective Caml version 3.07+4 (2003-11-07)
-
-# * * * # type 'a t = { t : 'a; }
-# type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; }
-# val f : 'a list -> 'a fold = <fun>
-# - : int = 6
-# class ['a] ilist :
- 'a list ->
- object ('b)
- val l : 'a list
- method add : 'a -> 'b
- method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
- end
-# class virtual ['a] vlist :
- object ('b)
- method virtual add : 'a -> 'b
- method virtual fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
- end
-# class ilist2 :
- int list ->
- object ('a)
- val l : int list
- method add : int -> 'a
- method fold : f:('b -> int -> 'b) -> init:'b -> 'b
- end
-# val ilist2 : 'a list -> 'a vlist = <fun>
-# class ['a] ilist3 :
- 'a list ->
- object ('b)
- val l : 'a list
- method add : 'a -> 'b
- method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
- end
-# class ['a] ilist4 :
- 'a list ->
- object ('b)
- val l : 'a list
- method add : 'a -> 'b
- method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
- end
-# class ['a] ilist5 :
- 'a list ->
- object ('b)
- val l : 'a list
- method add : 'a -> 'b
- method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
- method fold2 : f:('d -> 'a -> 'd) -> init:'d -> 'd
- end
-# class ['a] ilist6 :
- 'a list ->
- object ('b)
- val l : 'a list
- method add : 'a -> 'b
- method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
- method fold2 : f:('d -> 'a -> 'd) -> init:'d -> 'd
- end
-# class virtual ['a] olist :
- object method virtual fold : f:('a -> 'b -> 'b) -> init:'b -> 'b end
-# class ['a] onil :
- object method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b end
-# class ['a] ocons :
- hd:'a ->
- tl:'a olist ->
- object
- val hd : 'a
- val tl : 'a olist
- method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b
- end
-# class ['a] ostream :
- hd:'a ->
- tl:'a ostream ->
- object
- val hd : 'a
- val tl : 'a ostream
- method empty : bool
- method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b
- end
-# class ['a] ostream1 :
- hd:'a ->
- tl:'b ->
- object ('b)
- val hd : 'a
- val tl : 'b
- method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
- method hd : 'a
- method tl : 'b
- end
-# class vari : object method m : [< `A | `B | `C ] -> int end
-# class vari : object method m : [< `A | `B | `C ] -> int end
-# module V : sig type v = [ `A | `B | `C ] val m : [< v ] -> int end
-# class varj : object method m : [< V.v ] -> int end
-# module type T =
- sig class vari : object method m : [< `A | `B | `C ] -> int end end
-# module M0 :
- sig class vari : object method m : [< `A | `B | `C ] -> int end end
-# module M : T
-# val v : M.vari = <obj>
-# - : int = 1
-# class point :
- x:int ->
- y:int -> object val x : int val y : int method x : int method y : int end
-# class color_point :
- x:int ->
- y:int ->
- color:string ->
- object
- val color : string
- val x : int
- val y : int
- method color : string
- method x : int
- method y : int
- end
-# class circle :
- #point ->
- r:int ->
- object val p : point val r : int method distance : #point -> float end
-# val p0 : point = <obj>
-val p1 : point = <obj>
-val cp : color_point = <obj>
-val c : circle = <obj>
-val d : float = 11.4536240470737098
-# val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = <fun>
-# Characters 41-42:
-This expression has type < m : 'a. 'a -> 'a list > but is here used with type
- < m : 'a. 'a -> 'b >
-The universal variable 'a would escape its scope
-# class id : object method id : 'a -> 'a end
-# class type id_spec = object method id : 'a -> 'a end
-# class id_impl : object method id : 'a -> 'a end
-# class a : object method m : bool end
-class b : object method id : 'a -> 'a end
-# Characters 72-77:
-This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
-# Characters 75-80:
-This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
-# Characters 80-85:
-This method has type 'a -> 'a which is less general than 'b. 'b -> 'b
-# Characters 92-159:
-This method has type 'a -> 'a which is less general than 'b. 'b -> 'b
-# class c : object method m : 'a -> 'b -> 'a end
-# val f1 : id -> int * bool = <fun>
-# val f2 : id -> int * bool = <fun>
-# Characters 24-28:
-This expression has type bool but is here used with type int
-# val f4 : id -> int * bool = <fun>
-# class c : object method m : #id -> int * bool end
-# class id2 : object method id : 'a -> 'a method mono : int -> int end
-# val app : int * bool = (1, true)
-# Characters 4-25:
-The type abbreviation foo is cyclic
-# class ['a] bar : 'a -> object end
-# type 'a foo = 'a foo bar
-# - : (< m : 'b. 'b * 'a > as 'a) -> 'c * 'a = <fun>
-# - : (< m : 'b. 'a * 'b list > as 'a) -> 'a * 'c list = <fun>
-# val f :
- (< m : 'b. 'a * (< n : 'b; .. > as 'b) > as 'a) ->
- 'a * (< n : 'c; .. > as 'c) = <fun>
-# - : (< p : 'b. < m : 'b; n : 'a; .. > as 'b > as 'a) ->
- (< m : 'c; n : 'a; .. > as 'c)
-= <fun>
-# type sum = T of < id : 'a. 'a -> 'a >
-# - : sum -> 'a -> 'a = <fun>
-# type record = { r : < id : 'a. 'a -> 'a >; }
-# - : record -> 'a -> 'a = <fun>
-# - : record -> 'a -> 'a = <fun>
-# class myself : object ('a) method self : 'b -> 'a end
-# class number :
- object ('a)
- val num : int
- method num : int
- method prev : 'a
- method succ : 'a
- method switch : zero:(unit -> 'b) -> prev:('a -> 'b) -> 'b
- end
-# val id : 'a -> 'a = <fun>
-# class c : object method id : 'a -> 'a end
-# class c' : object method id : 'a -> 'a end
-# class d :
- object
- val mutable count : int
- method count : int
- method id : 'a -> 'a
- method old : 'b -> 'b
- end
-# class ['a] olist :
- 'a list ->
- object ('b)
- val l : 'a list
- method cons : 'a -> 'b
- method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
- end
-# val sum : int #olist -> int = <fun>
-# val count : 'a #olist -> int = <fun>
-# val append : 'a #olist -> ('a #olist as 'b) -> 'b = <fun>
-# type 'a t = unit
-# class o : object method x : [> `A ] t -> unit end
-# class c : object method m : d end
-class d : ?x:int -> unit -> object end
-# class d : ?x:int -> unit -> object end
-class c : object method m : d end
-# class type numeral = object method fold : ('a -> 'a) -> 'a -> 'a end
-class zero : object method fold : ('a -> 'a) -> 'a -> 'a end
-class next : #numeral -> object method fold : ('a -> 'a) -> 'a -> 'a end
-# class type node_type = object method as_variant : [> `Node of node_type ] end
-# class node : node_type
-# class node : object method as_variant : [> `Node of node_type ] end
-# type bad = { bad : 'a. 'a option ref; }
-# Characters 17-25:
-This field value has type 'a option ref which is less general than
- 'b. 'b option ref
-# type bad2 = { mutable bad2 : 'a. 'a option ref option; }
-# val bad2 : bad2 = {bad2 = None}
-# Characters 13-28:
-This field value has type 'a option ref option which is less general than
- 'b. 'b option ref option
-# type 'a t = [ `A of 'a ]
-# class c : object method m : ([> 'a t ] as 'a) -> unit end
-# class c : object method m : ([> 'a t ] as 'a) -> unit end
-# class c : object method m : ([> 'a t ] as 'a) -> 'a end
-# class c : object method m : ([> `A ] as 'a) option -> 'a end
-# Characters 145-166:
-This type scheme cannot quantify 'a :
-it escapes this scope.
-# type ('a, 'b) list_visitor = < caseCons : 'b -> 'b list -> 'a; caseNil : 'a >
-type 'a alist = < visit : 'b. ('b, 'a) list_visitor -> 'b >
-class type ct = object ('a) method fold : ('b -> 'a -> 'b) -> 'b -> 'b end
-type t = { f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b; }
-# Characters 19-25:
-The type abbreviation t is cyclic
-# class ['a] a : object constraint 'a = [> `A of 'a a ] end
-type t = [ `A of t a ]
-# Characters 71-80:
-Constraints are not satisfied in this type.
-Type ('a, 'b) t should be an instance of ('c, 'c) t
-# type 'a t = 'a
-type u = int t
-# type 'a t constraint 'a = int
-# Characters 26-32:
-Constraints are not satisfied in this type.
-Type 'a u t should be an instance of int t
-# type 'a u = 'a constraint 'a = int
-type 'a v = 'a u t constraint 'a = int
-# type g = int
-# type 'a t = unit constraint 'a = g
-# Characters 26-32:
-Constraints are not satisfied in this type.
-Type 'a u t should be an instance of g t
-# type 'a u = 'a constraint 'a = g
-type 'a v = 'a u t constraint 'a = int
-# Characters 38-58:
-In the definition of v, type 'a list u should be 'a u
-# type 'a t = 'a
-type 'a u = A of 'a t
-# type 'a t = < a : 'a >
-# - : ('a t as 'a) -> 'a t = <fun>
-# type u = 'a t as 'a
-# type t = A | B
-# - : [> `A ] * t -> int = <fun>
-# - : [> `A ] * t -> int = <fun>
-# - : [> `A ] option * t -> int = <fun>
-# - : [> `A ] option * t -> int = <fun>
-# - : t * [< `A | `B ] -> int = <fun>
-# - : [< `A | `B ] * t -> int = <fun>
-# Characters 0-41:
-Warning: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(`AnyExtraTag, `AnyExtraTag)
-- : [> `A | `B ] * [> `A | `B ] -> int = <fun>
-# Characters 0-29:
-Warning: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(_, 0)
-Characters 21-24:
-Warning: this match case is unused.
-- : [ `B ] * int -> int = <fun>
-# Characters 0-29:
-Warning: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(0, _)
-Characters 21-24:
-Warning: this match case is unused.
-- : int * [ `B ] -> int = <fun>
-# Characters 69-135:
-Constraints are not satisfied in this type.
-Type
-([> `B of 'a ], 'a) b as 'a
-should be an instance of
-(('b, [> `A of 'b ] as 'c) a as 'b, 'c) b
-# class type ['a, 'b] a =
- object
- constraint 'a = ('a, 'b) #a
- constraint 'b = ('a, 'b) #b
- method as_a : ('a, 'b) a
- method b : 'b
- end
-class type ['a, 'b] b =
- object
- constraint 'a = ('a, 'b) #a
- constraint 'b = ('a, 'b) #b
- method a : 'a
- method as_b : ('a, 'b) b
- end
-class type ['a] ca =
- object ('b)
- constraint 'a = ('b, 'a) #b
- method as_a : ('b, 'a) a
- method b : 'a
- end
-class type ['a] cb =
- object ('b)
- constraint 'a = ('a, 'b) #a
- method a : 'a
- method as_b : ('a, 'b) b
- end
-type bt = 'a ca cb as 'a
-# class c : object method m : int end
-# val f : unit -> c = <fun>
-# val f : unit -> c = <fun>
-# Characters 11-60:
-Warning: the following private methods were made public implicitly:
- n
-val f : unit -> < m : int; n : int > = <fun>
-# Characters 11-56:
-This object is expected to have type c = < m : int > but has actually type
- < m : int; n : 'a >
-Only the second object type has a method n
-# Characters 11-69:
-This object is expected to have type < n : int > but has actually type
- < m : 'a >
-Only the first object type has a method n
-#
diff --git a/testlabl/poly.exp2 b/testlabl/poly.exp2
deleted file mode 100644
index 4d5a15d311..0000000000
--- a/testlabl/poly.exp2
+++ /dev/null
@@ -1,339 +0,0 @@
- Objective Caml version 3.07+4 (2003-11-07)
-
-# * * * # type 'a t = { t : 'a; }
-# type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; }
-# val f : 'a list -> 'a fold = <fun>
-# - : int = 6
-# class ['a] ilist :
- 'a list ->
- object ('b)
- val l : 'a list
- method add : 'a -> 'b
- method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
- end
-# class virtual ['a] vlist :
- object ('b)
- method virtual add : 'a -> 'b
- method virtual fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
- end
-# class ilist2 :
- int list ->
- object ('a)
- val l : int list
- method add : int -> 'a
- method fold : f:('b -> int -> 'b) -> init:'b -> 'b
- end
-# val ilist2 : 'a list -> 'a vlist = <fun>
-# class ['a] ilist3 :
- 'a list ->
- object ('b)
- val l : 'a list
- method add : 'a -> 'b
- method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
- end
-# class ['a] ilist4 :
- 'a list ->
- object ('b)
- val l : 'a list
- method add : 'a -> 'b
- method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
- end
-# class ['a] ilist5 :
- 'a list ->
- object ('b)
- val l : 'a list
- method add : 'a -> 'b
- method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
- method fold2 : f:('d -> 'a -> 'd) -> init:'d -> 'd
- end
-# class ['a] ilist6 :
- 'a list ->
- object ('b)
- val l : 'a list
- method add : 'a -> 'b
- method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
- method fold2 : f:('d -> 'a -> 'd) -> init:'d -> 'd
- end
-# class virtual ['a] olist :
- object method virtual fold : f:('a -> 'b -> 'b) -> init:'b -> 'b end
-# class ['a] onil :
- object method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b end
-# class ['a] ocons :
- hd:'a ->
- tl:'a olist ->
- object
- val hd : 'a
- val tl : 'a olist
- method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b
- end
-# class ['a] ostream :
- hd:'a ->
- tl:'a ostream ->
- object
- val hd : 'a
- val tl : < empty : bool; fold : 'b. f:('a -> 'b -> 'b) -> init:'b -> 'b >
- method empty : bool
- method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
- end
-# class ['a] ostream1 :
- hd:'a ->
- tl:'b ->
- object ('b)
- val hd : 'a
- val tl : 'b
- method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
- method hd : 'a
- method tl : 'b
- end
-# class vari : object method m : [< `A | `B | `C ] -> int end
-# class vari : object method m : [< `A | `B | `C ] -> int end
-# module V : sig type v = [ `A | `B | `C ] val m : [< v ] -> int end
-# class varj : object method m : [< V.v ] -> int end
-# module type T =
- sig class vari : object method m : [< `A | `B | `C ] -> int end end
-# module M0 :
- sig class vari : object method m : [< `A | `B | `C ] -> int end end
-# module M : T
-# val v : M.vari = <obj>
-# - : int = 1
-# class point :
- x:int ->
- y:int -> object val x : int val y : int method x : int method y : int end
-# class color_point :
- x:int ->
- y:int ->
- color:string ->
- object
- val color : string
- val x : int
- val y : int
- method color : string
- method x : int
- method y : int
- end
-# class circle :
- #point ->
- r:int ->
- object val p : point val r : int method distance : #point -> float end
-# val p0 : point = <obj>
-val p1 : point = <obj>
-val cp : color_point = <obj>
-val c : circle = <obj>
-val d : float = 11.4536240470737098
-# val f : < m : 'a. 'a -> 'a > -> < m : 'b. 'b -> 'b > = <fun>
-# Characters 41-42:
-This expression has type < m : 'a. 'a -> 'a list > but is here used with type
- < m : 'a. 'a -> 'b >
-The universal variable 'a would escape its scope
-# class id : object method id : 'a -> 'a end
-# class type id_spec = object method id : 'a -> 'a end
-# class id_impl : object method id : 'a -> 'a end
-# class a : object method m : bool end
-class b : object method id : 'a -> 'a end
-# Characters 72-77:
-This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
-# Characters 75-80:
-This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
-# Characters 80-85:
-This method has type 'a -> 'a which is less general than 'b. 'b -> 'b
-# Characters 92-159:
-This method has type 'a -> 'a which is less general than 'b. 'b -> 'b
-# class c : object method m : 'a -> 'b -> 'a end
-# val f1 : id -> int * bool = <fun>
-# val f2 : id -> int * bool = <fun>
-# Characters 24-28:
-This expression has type bool but is here used with type int
-# Characters 27-31:
-Warning: This use of a polymorphic method is not principal
-Characters 35-39:
-Warning: This use of a polymorphic method is not principal
-val f4 : id -> int * bool = <fun>
-# class c : object method m : #id -> int * bool end
-# class id2 : object method id : 'a -> 'a method mono : int -> int end
-# val app : int * bool = (1, true)
-# Characters 4-25:
-The type abbreviation foo is cyclic
-# class ['a] bar : 'a -> object end
-# type 'a foo = 'a foo bar
-# - : (< m : 'b. 'b * 'a > as 'a) -> 'c * (< m : 'e. 'e * 'd > as 'd) = <fun>
-# - : (< m : 'b. 'a * 'b list > as 'a) ->
- (< m : 'd. 'c * 'd list > as 'c) * 'e list
-= <fun>
-# val f :
- (< m : 'b. 'a * (< n : 'b; .. > as 'b) > as 'a) ->
- (< m : 'd. 'c * (< n : 'd; .. > as 'd) > as 'c) * (< n : 'e; .. > as 'e) =
- <fun>
-# - : (< p : 'b. < m : 'b; n : 'a; .. > as 'b > as 'a) ->
- (< m : 'c; n : < p : 'e. < m : 'e; n : 'd; .. > as 'e > as 'd; .. > as 'c)
-= <fun>
-# type sum = T of < id : 'a. 'a -> 'a >
-# - : sum -> 'a -> 'a = <fun>
-# type record = { r : < id : 'a. 'a -> 'a >; }
-# - : record -> 'a -> 'a = <fun>
-# - : record -> 'a -> 'a = <fun>
-# class myself : object ('a) method self : 'b -> 'a end
-# class number :
- object ('a)
- val num : int
- method num : int
- method prev : 'a
- method succ : 'a
- method switch : zero:(unit -> 'b) -> prev:('a -> 'b) -> 'b
- end
-# val id : 'a -> 'a = <fun>
-# class c : object method id : 'a -> 'a end
-# class c' : object method id : 'a -> 'a end
-# class d :
- object
- val mutable count : int
- method count : int
- method id : 'a -> 'a
- method old : 'b -> 'b
- end
-# class ['a] olist :
- 'a list ->
- object ('b)
- val l : 'a list
- method cons : 'a -> 'b
- method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
- end
-# val sum : int #olist -> int = <fun>
-# val count : 'a #olist -> int = <fun>
-# val append : 'a #olist -> ('a #olist as 'b) -> 'b = <fun>
-# type 'a t = unit
-# class o : object method x : [> `A ] t -> unit end
-# class c : object method m : d end
-class d : ?x:int -> unit -> object end
-# class d : ?x:int -> unit -> object end
-class c : object method m : d end
-# class type numeral = object method fold : ('a -> 'a) -> 'a -> 'a end
-class zero : object method fold : ('a -> 'a) -> 'a -> 'a end
-class next : #numeral -> object method fold : ('a -> 'a) -> 'a -> 'a end
-# class type node_type = object method as_variant : [> `Node of node_type ] end
-# class node : node_type
-# class node : object method as_variant : [> `Node of node_type ] end
-# type bad = { bad : 'a. 'a option ref; }
-# Characters 17-25:
-This field value has type 'a option ref which is less general than
- 'b. 'b option ref
-# type bad2 = { mutable bad2 : 'a. 'a option ref option; }
-# val bad2 : bad2 = {bad2 = None}
-# Characters 13-28:
-This field value has type 'a option ref option which is less general than
- 'b. 'b option ref option
-# type 'a t = [ `A of 'a ]
-# class c : object method m : ([> 'a t ] as 'a) -> unit end
-# class c : object method m : ([> 'a t ] as 'a) -> unit end
-# class c : object method m : ([> 'a t ] as 'a) -> 'a end
-# class c : object method m : ([> `A ] as 'a) option -> 'a end
-# Characters 145-166:
-This type scheme cannot quantify 'a :
-it escapes this scope.
-# type ('a, 'b) list_visitor = < caseCons : 'b -> 'b list -> 'a; caseNil : 'a >
-type 'a alist = < visit : 'b. ('b, 'a) list_visitor -> 'b >
-class type ct = object ('a) method fold : ('b -> 'a -> 'b) -> 'b -> 'b end
-type t = { f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b; }
-# Characters 19-25:
-The type abbreviation t is cyclic
-# class ['a] a : object constraint 'a = [> `A of 'a a ] end
-type t = [ `A of t a ]
-# Characters 71-80:
-Constraints are not satisfied in this type.
-Type ('a, 'b) t should be an instance of ('c, 'c) t
-# type 'a t = 'a
-type u = int t
-# type 'a t constraint 'a = int
-# Characters 26-32:
-Constraints are not satisfied in this type.
-Type 'a u t should be an instance of int t
-# type 'a u = 'a constraint 'a = int
-type 'a v = 'a u t constraint 'a = int
-# type g = int
-# type 'a t = unit constraint 'a = g
-# Characters 26-32:
-Constraints are not satisfied in this type.
-Type 'a u t should be an instance of g t
-# type 'a u = 'a constraint 'a = g
-type 'a v = 'a u t constraint 'a = int
-# Characters 38-58:
-In the definition of v, type 'a list u should be 'a u
-# type 'a t = 'a
-type 'a u = A of 'a t
-# type 'a t = < a : 'a >
-# - : ('a t as 'a) -> ('b t as 'b) t = <fun>
-# type u = 'a t as 'a
-# type t = A | B
-# - : [> `A ] * t -> int = <fun>
-# - : [> `A ] * t -> int = <fun>
-# - : [> `A ] option * t -> int = <fun>
-# - : [> `A ] option * t -> int = <fun>
-# - : t * [< `A | `B ] -> int = <fun>
-# - : [< `A | `B ] * t -> int = <fun>
-# Characters 0-41:
-Warning: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(`AnyExtraTag, `AnyExtraTag)
-- : [> `A | `B ] * [> `A | `B ] -> int = <fun>
-# Characters 0-29:
-Warning: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(_, 0)
-Characters 21-24:
-Warning: this match case is unused.
-- : [ `B ] * int -> int = <fun>
-# Characters 0-29:
-Warning: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(0, _)
-Characters 21-24:
-Warning: this match case is unused.
-- : int * [ `B ] -> int = <fun>
-# Characters 69-135:
-Constraints are not satisfied in this type.
-Type
-([> `B of 'a ], 'a) b as 'a
-should be an instance of
-(('b, [> `A of 'b ] as 'c) a as 'b, 'c) b
-# class type ['a, 'b] a =
- object
- constraint 'a = ('a, 'b) #a
- constraint 'b = ('a, 'b) #b
- method as_a : ('a, 'b) a
- method b : 'b
- end
-class type ['a, 'b] b =
- object
- constraint 'a = ('a, 'b) #a
- constraint 'b = ('a, 'b) #b
- method a : 'a
- method as_b : ('a, 'b) b
- end
-class type ['a] ca =
- object ('b)
- constraint 'a = ('b, 'a) #b
- method as_a : ('b, 'a) a
- method b : 'a
- end
-class type ['a] cb =
- object ('b)
- constraint 'a = ('a, 'b) #a
- method a : 'a
- method as_b : ('a, 'b) b
- end
-type bt = 'a ca cb as 'a
-# class c : object method m : int end
-# val f : unit -> c = <fun>
-# val f : unit -> c = <fun>
-# Characters 11-60:
-Warning: the following private methods were made public implicitly:
- n
-val f : unit -> < m : int; n : int > = <fun>
-# Characters 11-56:
-This object is expected to have type c = < m : int > but has actually type
- < m : int; n : 'a >
-Only the second object type has a method n
-# Characters 11-69:
-This object is expected to have type < n : int > but has actually type
- < m : 'a >
-Only the first object type has a method n
-#
diff --git a/testlabl/poly.ml b/testlabl/poly.ml
deleted file mode 100644
index 3ce1f30e3a..0000000000
--- a/testlabl/poly.ml
+++ /dev/null
@@ -1,468 +0,0 @@
-(* $Id$ *)
-(*
- Polymorphic methods are now available in the main branch.
- Enjoy.
-*)
-
-(* Tests for explicit polymorphism *)
-open StdLabels;;
-
-type 'a t = { t : 'a };;
-type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b };;
-let f l = { fold = List.fold_left l };;
-(f [1;2;3]).fold ~f:(+) ~init:0;;
-
-class ['b] ilist l = object
- val l = l
- method add x = {< l = x :: l >}
- method fold : 'a. f:('a -> 'b -> 'a) -> init:'a -> 'a =
- List.fold_left l
-end
-;;
-class virtual ['a] vlist = object (_ : 'self)
- method virtual add : 'a -> 'self
- method virtual fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b
-end
-;;
-class ilist2 l = object
- inherit [int] vlist
- val l = l
- method add x = {< l = x :: l >}
- method fold = List.fold_left l
-end
-;;
-let ilist2 l = object
- inherit [_] vlist
- val l = l
- method add x = {< l = x :: l >}
- method fold = List.fold_left l
-end
-;;
-class ['a] ilist3 l = object
- inherit ['a] vlist
- val l = l
- method add x = {< l = x :: l >}
- method fold = List.fold_left l
-end
-;;
-class ['a] ilist4 (l : 'a list) = object
- val l = l
- method virtual add : _
- method add x = {< l = x :: l >}
- method virtual fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b
- method fold = List.fold_left l
-end
-;;
-class ['a] ilist5 (l : 'a list) = object (self)
- val l = l
- method add x = {< l = x :: l >}
- method virtual fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b
- method virtual fold2 : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b
- method fold2 ~f ~init = self#fold ~f ~init:(self#fold ~f ~init)
- method fold = List.fold_left l
-end
-;;
-class ['a] ilist6 l = object (self)
- inherit ['a] vlist
- val l = l
- method add x = {< l = x :: l >}
- method virtual fold2 : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b
- method fold2 ~f ~init = self#fold ~f ~init:(self#fold ~f ~init)
- method fold = List.fold_left l
-end
-;;
-class virtual ['a] olist = object
- method virtual fold : 'c. f:('a -> 'c -> 'c) -> init:'c -> 'c
-end
-;;
-class ['a] onil = object
- inherit ['a] olist
- method fold ~f ~init = init
-end
-;;
-class ['a] ocons ~hd ~tl = object (_ : 'b)
- inherit ['a] olist
- val hd : 'a = hd
- val tl : 'a olist = tl
- method fold ~f ~init = f hd (tl#fold ~f ~init)
-end
-;;
-class ['a] ostream ~hd ~tl = object (_ : 'b)
- inherit ['a] olist
- val hd : 'a = hd
- val tl : _ #olist = (tl : 'a ostream)
- method fold ~f ~init = f hd (tl#fold ~f ~init)
- method empty = false
-end
-;;
-class ['a] ostream1 ~hd ~tl = object (self : 'b)
- inherit ['a] olist
- val hd = hd
- val tl : 'b = tl
- method hd = hd
- method tl = tl
- method fold ~f ~init =
- self#tl#fold ~f ~init:(f self#hd init)
-end
-;;
-
-class vari = object
- method virtual m : 'a. ([< `A|`B|`C] as 'a) -> int
- method m = function `A -> 1 | `B|`C -> 0
-end
-;;
-class vari = object
- method m : 'a. ([< `A|`B|`C] as 'a) -> int = function `A -> 1 | `B|`C -> 0
-end
-;;
-module V =
- struct
- type v = [`A | `B | `C]
- let m : [< v] -> int = function `A -> 1 | #v -> 0
- end
-;;
-class varj = object
- method virtual m : 'a. ([< V.v] as 'a) -> int
- method m = V.m
-end
-;;
-
-module type T = sig
- class vari : object method m : 'a. ([< `A | `B | `C] as 'a) -> int end
-end
-;;
-module M0 = struct
- class vari = object
- method virtual m : 'a. ([< `A|`B|`C] as 'a) -> int
- method m = function `A -> 1 | `B|`C -> 0
- end
-end
-;;
-module M : T = M0
-;;
-let v = new M.vari;;
-v#m `A;;
-
-class point ~x ~y = object
- val x : int = x
- val y : int = y
- method x = x
- method y = y
-end
-;;
-class color_point ~x ~y ~color = object
- inherit point ~x ~y
- val color : string = color
- method color = color
-end
-;;
-class circle (p : #point) ~r = object
- val p = (p :> point)
- val r = r
- method virtual distance : 'a. (#point as 'a) -> float
- method distance p' =
- let dx = p#x - p'#x and dy = p#y - p'#y in
- let d = sqrt (float (dx * dx + dy * dy)) -. float r in
- if d < 0. then 0. else d
-end
-;;
-let p0 = new point ~x:3 ~y:5
-let p1 = new point ~x:10 ~y:13
-let cp = new color_point ~x:12 ~y:(-5) ~color:"green"
-let c = new circle p0 ~r:2
-let d = c#distance cp
-;;
-let f (x : < m : 'a. 'a -> 'a >) = (x : < m : 'b. 'b -> 'b >)
-;;
-let f (x : < m : 'a. 'a -> 'a list >) = (x : < m : 'b. 'b -> 'c >)
-;;
-
-class id = object
- method virtual id : 'a. 'a -> 'a
- method id x = x
-end
-;;
-
-class type id_spec = object
- method id : 'a -> 'a
-end
-;;
-class id_impl = object (_ : #id_spec)
- method id x = x
-end
-;;
-
-class a = object
- method m = (new b : id_spec)#id true
-end
-and b = object (_ : #id_spec)
- method id x = x
-end
-;;
-
-class ['a] id1 = object
- method virtual id : 'b. 'b -> 'a
- method id x = x
-end
-;;
-class id2 (x : 'a) = object
- method virtual id : 'b. 'b -> 'a
- method id x = x
-end
-;;
-class id3 x = object
- val x = x
- method virtual id : 'a. 'a -> 'a
- method id _ = x
-end
-;;
-class id4 () = object
- val mutable r = None
- method virtual id : 'a. 'a -> 'a
- method id x =
- match r with
- None -> r <- Some x; x
- | Some y -> y
-end
-;;
-class c = object
- method virtual m : 'a 'b. 'a -> 'b -> 'a
- method m x y = x
-end
-;;
-
-let f1 (f : id) = f#id 1, f#id true
-;;
-let f2 f = (f : id)#id 1, (f : id)#id true
-;;
-let f3 f = f#id 1, f#id true
-;;
-let f4 f = ignore(f : id); f#id 1, f#id true
-;;
-
-class c = object
- method virtual m : 'a. (#id as 'a) -> int * bool
- method m (f : #id) = f#id 1, f#id true
-end
-;;
-
-class id2 = object (_ : 'b)
- method virtual id : 'a. 'a -> 'a
- method id x = x
- method mono (x : int) = x
-end
-;;
-let app = new c #m (new id2)
-;;
-type 'a foo = 'a foo list
-;;
-
-class ['a] bar (x : 'a) = object end
-;;
-type 'a foo = 'a foo bar
-;;
-
-fun x -> (x : < m : 'a. 'a * 'b > as 'b)#m;;
-fun x -> (x : < m : 'a. 'b * 'a list> as 'b)#m;;
-let f x = (x : < m : 'a. 'b * (< n : 'a; .. > as 'a) > as 'b)#m;;
-
-fun (x : < p : 'a. < m : 'a ; n : 'b ; .. > as 'a > as 'b) -> x#p;;
-
-type sum = T of < id: 'a. 'a -> 'a > ;;
-fun (T x) -> x#id;;
-
-type record = { r: < id: 'a. 'a -> 'a > } ;;
-fun x -> x.r#id;;
-fun {r=x} -> x#id;;
-
-class myself = object (self)
- method self : 'a. 'a -> 'b = fun _ -> self
-end;;
-
-class number = object (self : 'self)
- val num = 0
- method num = num
- method succ = {< num = num + 1 >}
- method prev =
- self#switch ~zero:(fun () -> failwith "zero") ~prev:(fun x -> x)
- method switch : 'a. zero:(unit -> 'a) -> prev:('self -> 'a) -> 'a =
- fun ~zero ~prev ->
- if num = 0 then zero () else prev {< num = num - 1 >}
-end
-;;
-
-let id x = x
-;;
-class c = object
- method id : 'a. 'a -> 'a = id
-end
-;;
-class c' = object
- inherit c
- method id = id
-end
-;;
-class d = object
- inherit c as c
- val mutable count = 0
- method id x = count <- count+1; x
- method count = count
- method old : 'a. 'a -> 'a = c#id
-end
-;;
-class ['a] olist l = object
- val l = l
- method fold : 'b. f:('a -> 'b -> 'b) -> init:'b -> 'b
- = List.fold_right l
- method cons a = {< l = a :: l >}
-end
-;;
-let sum (l : 'a #olist) = l#fold ~f:(fun x acc -> x+acc) ~init:0
-;;
-let count (l : 'a #olist) = l#fold ~f:(fun _ acc -> acc+1) ~init:0
-;;
-let append (l : 'a #olist) (l' : 'b #olist) =
- l#fold ~init:l' ~f:(fun x acc -> acc#cons x)
-;;
-
-type 'a t = unit
-;;
-class o = object method x : 'a. ([> `A] as 'a) t -> unit = fun _ -> () end
-;;
-
-class c = object method m = new d () end and d ?(x=0) () = object end;;
-class d ?(x=0) () = object end and c = object method m = new d () end;;
-
-class type numeral = object method fold : ('a -> 'a) -> 'a -> 'a end
-class zero = object (_ : #numeral) method fold f x = x end
-class next (n : #numeral) =
- object (_ : #numeral) method fold f x = n#fold f (f x) end
-;;
-
-class type node_type = object
- method as_variant : [> `Node of node_type]
-end;;
-class node : node_type = object (self)
- method as_variant : 'a. [> `Node of node_type] as 'a
- = `Node (self :> node_type)
-end;;
-class node = object (self : #node_type)
- method as_variant = `Node (self :> node_type)
-end;;
-
-type bad = {bad : 'a. 'a option ref};;
-let bad = {bad = ref None};;
-type bad2 = {mutable bad2 : 'a. 'a option ref option};;
-let bad2 = {bad2 = None};;
-bad2.bad2 <- Some (ref None);;
-
-(* PR#1374 *)
-
-type 'a t= [`A of 'a];;
-class c = object (self)
- method m : 'a. ([> 'a t] as 'a) -> unit
- = fun x -> self#m x
-end;;
-class c = object (self)
- method m : 'a. ([> 'a t] as 'a) -> unit = function
- | `A x' -> self#m x'
- | _ -> failwith "c#m"
-end;;
-class c = object (self)
- method m : 'a. ([> 'a t] as 'a) -> 'a = fun x -> self#m x
-end;;
-
-(* usage avant instance *)
-class c = object method m : 'a. 'a option -> ([> `A] as 'a) = fun x -> `A end;;
-
-(* various old bugs *)
-class virtual ['a] visitor =
-object method virtual caseNil : 'a end
-and virtual int_list =
-object method virtual visit : 'a.('a visitor -> 'a) end;;
-
-type ('a,'b) list_visitor = < caseNil : 'a; caseCons : 'b -> 'b list -> 'a >
-type 'b alist = < visit : 'a. ('a,'b) list_visitor -> 'a >
-
-(* PR#1607 *)
-class type ct = object ('s)
- method fold : ('b -> 's -> 'b) -> 'b -> 'b
-end
-type t = {f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b};;
-
-(* PR#1663 *)
-type t = u and u = t;;
-
-(* PR#1731 *)
-class ['t] a = object constraint 't = [> `A of 't a] end
-type t = [ `A of t a ];;
-
-(* Wrong in 3.06 *)
-type ('a,'b) t constraint 'a = 'b and ('a,'b) u = ('a,'b) t;;
-
-(* Full polymorphism if we do not expand *)
-type 'a t = 'a and u = int t;;
-
-(* Loose polymorphism if we expand *)
-type 'a t constraint 'a = int;;
-type 'a u = 'a and 'a v = 'a u t;;
-type 'a u = 'a and 'a v = 'a u t constraint 'a = int;;
-
-(* Behaviour is unstable *)
-type g = int;;
-type 'a t = unit constraint 'a = g;;
-type 'a u = 'a and 'a v = 'a u t;;
-type 'a u = 'a and 'a v = 'a u t constraint 'a = int;;
-
-(* Example of wrong expansion *)
-type 'a u = < m : 'a v > and 'a v = 'a list u;;
-
-(* PR#1744: Ctype.matches *)
-type 'a t = 'a
-type 'a u = A of 'a t;;
-
-(* Unification of cyclic terms *)
-type 'a t = < a : 'a >;;
-fun (x : 'a t as 'a) -> (x : 'b t);;
-type u = 'a t as 'a;;
-
-
-(* Variant tests *)
-type t = A | B;;
-function `A,_ -> 1 | _,A -> 2 | _,B -> 3;;
-function `A,_ -> 1 | _,(A|B) -> 2;;
-function Some `A, _ -> 1 | Some _, A -> 2 | None, A -> 3 | _, B -> 4;;
-function Some `A, A -> 1 | Some `A, B -> 1
- | Some _, A -> 2 | None, A -> 3 | _, B -> 4;;
-function A, `A -> 1 | A, `B -> 2 | B, _ -> 3;;
-function `A, A -> 1 | `B, A -> 2 | _, B -> 3;;
-function (`A|`B), _ -> 0 | _,(`A|`B) -> 1;;
-function `B,1 -> 1 | _,1 -> 2;;
-function 1,`B -> 1 | 1,_ -> 2;;
-
-(* pass typetexp, but fails during Typedecl.check_recursion *)
-type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b]
-and ('a, 'b) b = 'b -> unit constraint 'b = [> `A of ('a, 'b) a as 'a];;
-
-(* PR#1917: expanding may change original in Ctype.unify2 *)
-class type ['a, 'b] a = object
- method b: ('a, 'b) #b as 'b
- method as_a: ('a, 'b) a
-end and ['a, 'b] b = object
- method a: ('a, 'b) #a as 'a
- method as_b: ('a, 'b) b
-end
-
-class type ['b] ca = object ('s) inherit ['s, 'b] a end
-class type ['a] cb = object ('s) inherit ['a, 's] b end
-
-type bt = 'b ca cb as 'b
-;;
-
-(* final classes, etc... *)
-class c = object method m = 1 end;;
-let f () = object (self:c) method m = 1 end;;
-let f () = object (self:c) method private n = 1 method m = self#n end;;
-let f () = object method private n = 1 method m = {<>}#n end;;
-let f () = object (self:c) method n = 1 method m = 2 end;;
-let f () = object (_:'s) constraint 's = < n : int > method m = 1 end;;
diff --git a/testlabl/printers.ml b/testlabl/printers.ml
deleted file mode 100644
index c80c42d66c..0000000000
--- a/testlabl/printers.ml
+++ /dev/null
@@ -1,11 +0,0 @@
-(* $Id$ *)
-
-open Types
-
-let ignore_abbrevs ppf ab =
- let s = match ab with
- Mnil -> "Mnil"
- | Mlink _ -> "Mlink _"
- | Mcons _ -> "Mcons _"
- in
- Format.pp_print_string ppf s
diff --git a/testlabl/tests.ml b/testlabl/tests.ml
deleted file mode 100644
index c39d152fb2..0000000000
--- a/testlabl/tests.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-(* $Id$ *)
-
-let f1 = function `a x -> x=1 | `b -> true
-let f2 = function `a x -> x | `b -> true
-let f3 = function `b -> true
-let f x = f1 x && f2 x
-
-let sub s ?:pos{=0} ?:len{=String.length s - pos} () =
- String.sub s pos len
-
-let cCAMLtoTKpack_options w = function
- `After v1 -> "-after"
- | `Anchor v1 -> "-anchor"
- | `Before v1 -> "-before"
- | `Expand v1 -> "-expand"
- | `Fill v1 -> "-fill"
- | `In v1 -> "-in"
- | `Ipadx v1 -> "-ipadx"
- | `Ipady v1 -> "-ipady"
- | `Padx v1 -> "-padx"
- | `Pady v1 -> "-pady"
- | `Side v1 -> "-side"
diff --git a/testobjects/Exemples.exp b/testobjects/Exemples.exp
deleted file mode 100644
index 5d55e083d1..0000000000
--- a/testobjects/Exemples.exp
+++ /dev/null
@@ -1,301 +0,0 @@
-# class point (int) =
- val mutable x : int
- method get_x : int
- method move : int -> unit
-end
-# val p : point = <obj>
-# - : int = 7
-# - : unit = ()
-# - : int = 10
-# val q : point = <obj>
-# - : int * int = 10, 17
-# class color_point (int) (string) =
- val c : string
- val mutable x : int
- method color : string
- method get_x : int
- method move : int -> unit
-end
-# val p' : color_point = <obj>
-# - : int * string = 5, "red"
-# val l : point list = [<obj>; <obj>]
-# val get_x : < get_x : 'a; .. > -> 'a = <fun>
-# val set_x : < set_x : 'a; .. > -> 'a = <fun>
-# - : int list = [10; 5]
-# Characters 6-86:
-The type variable 'a is not bound in implicit type definition
- ref = < get : 'a; set : 'a -> unit >
-It should be captured by a class type parameter
-# class ref (int) =
- val mutable x : int
- method get : int
- method set : int -> unit
-end
-# class 'a ref ('a) =
- val mutable x : 'a
- method get : 'a
- method set : 'a -> unit
-end
-# - : int = 2
-# class 'a circle ('a) =
- constraint 'a = < move : int -> unit; .. >
- val mutable center : 'a
- method center : 'a
- method move : int -> unit
- method set_center : 'a -> unit
-end
-# class 'a circle ('a) =
- constraint 'a = #point
- val mutable center : 'a
- method center : 'a
- method move : int -> unit
- method set_center : 'a -> unit
-end
-# val c : point circle = <obj>
-val c' : color_point circle = <obj>
-# class 'a color_circle ('a) =
- constraint 'a = #color_point
- val mutable center : 'a
- method center : 'a
- method color : string
- method move : int -> unit
- method set_center : 'a -> unit
-end
-# Characters 28-29:
-This expression has type point = < get_x : int; move : int -> unit >
-but is here used with type
- #color_point = < get_x : int; move : int -> unit; color : string; .. >
-# val c'' : color_point color_circle = <obj>
-# - : color_point circle = <obj>
-# Characters 1-4:
-This expression cannot be coerced to type
- point circle =
- < center : point; set_center : point -> unit; move : int -> unit >;
-it has type
- color_point color_circle =
- < center : color_point; set_center : color_point -> unit;
- move : int -> unit; color : string >
-but is here used with type
- < center : color_point; set_center : point -> unit; move : int -> unit;
- color : string >
-Type color_point = < get_x : int; move : int -> unit; color : string >
-is not compatible with type point = < get_x : int; move : int -> unit >
-# Characters 9-55:
-Type
- color_point color_circle =
- < center : color_point; set_center : color_point -> unit;
- move : int -> unit; color : string >
-is not a subtype of type
- point circle =
- < center : point; set_center : point -> unit; move : int -> unit >
-Type color_point -> unit is not a subtype of type point -> unit
-Type point = < get_x : int; move : int -> unit > is not a subtype of type
- color_point = < get_x : int; move : int -> unit; color : string >
-# class printable_point (int) =
- val mutable x : int
- method get_x : int
- method move : int -> unit
- method print : unit
-end
-# val p : printable_point = <obj>
-# 7- : unit = ()
-# class printable_color_point (int) (string) =
- val c : string
- val mutable x : int
- method color : string
- method get_x : int
- method move : int -> unit
- method print : unit
-end
-# val p' : printable_color_point = <obj>
-# (7, red)- : unit = ()
-# class functional_point (int) : 'a =
- val x : int
- method get_x : int
- method move : int -> 'a
-end
-# val p : functional_point = <obj>
-# - : int = 7
-# - : int = 10
-# - : int = 7
-# - : (< get_x : int; move : int -> 'a; .. > as 'a) -> functional_point = <fun>
-# class virtual 'a lst (unit) =
- virtual hd : 'a
- method iter : ('a -> unit) -> unit
- method map : ('a -> 'a) -> 'a lst
- virtual null : bool
- method print : ('a -> unit) -> unit
- virtual tl : 'a lst
-end
-class 'a nil (unit) =
- method hd : 'a
- method iter : ('a -> unit) -> unit
- method map : ('a -> 'a) -> 'a lst
- method null : bool
- method print : ('a -> unit) -> unit
- method tl : 'a lst
-end
-class 'a cons ('a) ('a lst) =
- val h : 'a
- val t : 'a lst
- method hd : 'a
- method iter : ('a -> unit) -> unit
- method map : ('a -> 'a) -> 'a lst
- method null : bool
- method print : ('a -> unit) -> unit
- method tl : 'a lst
-end
-# val l1 : int cons = <obj>
-# (3::10::[])- : unit = ()
-# val l2 : int lst = <obj>
-# (4::11::[])- : unit = ()
-# val map_list : ('a -> 'b) -> 'a lst -> 'b lst = <fun>
-# val p1 : printable_color_point lst = <obj>
-# ((3, red)::(10, red)::[])- : unit = ()
-# class virtual comparable (unit) : 'a = virtual leq : 'a -> bool end
-# class int_comparable (int) : 'a =
- val x : int
- method leq : 'a -> bool
- method x : int
-end
-# class int_comparable2 (int) : 'a =
- method leq : 'a -> bool
- method set_x : int -> unit
- method x : int
-end
-# class 'a sorted_list (unit) =
- constraint 'a = #comparable
- val mutable l : 'a list
- method add : 'a -> unit
- method hd : 'a
-end
-# val l : _#comparable sorted_list = <obj>
-# val c : int_comparable = <obj>
-# - : unit = ()
-# val c2 : int_comparable2 = <obj>
-# Characters 7-9:
-This expression cannot be coerced to type
- int_comparable = < leq : int_comparable -> bool; x : int >;
-it has type
- int_comparable2 =
- < leq : int_comparable2 -> bool; x : int; set_x : int -> unit >
-but is here used with type
- < leq : int_comparable -> bool; x : int; set_x : int -> unit >
-Type
- int_comparable2 =
- < leq : int_comparable2 -> bool; x : int; set_x : int -> unit >
-is not compatible with type
- int_comparable = < leq : int_comparable -> bool; x : int >
-# - : unit = ()
-# class int_comparable3 (int) =
- val mutable x : int
- method leq : int_comparable -> bool
- method setx : int -> unit
- method x : int
-end
-# val c3 : int_comparable3 = <obj>
-# - : unit = ()
-# Characters 25-27:
-This expression has type
- int_comparable3 =
- < leq : int_comparable -> bool; x : int; setx : int -> unit >
-but is here used with type
- < leq : 'a -> bool; setx : int -> unit; x : int > as 'a
-Type int_comparable = < leq : int_comparable -> bool; x : int >
-is not compatible with type
- int_comparable3 =
- < leq : int_comparable -> bool; x : int; setx : int -> unit >
-# val sort : (#comparable as 'a) list -> 'a list = <fun>
-# val pr : < x : int; .. > list -> unit = <fun>
-# val l : int_comparable list = [<obj>; <obj>; <obj>]
-# 5 2 4
-- : unit = ()
-# 2 4 5
-- : unit = ()
-# val l : int_comparable2 list = [<obj>; <obj>]
-# 2 0
-- : unit = ()
-# 0 2
-- : unit = ()
-# val min : (#comparable as 'a) -> 'a -> 'a = <fun>
-# - : int = 7
-# - : int = 3
-# class 'a link ('a) : 'b =
- val mutable next : 'b option
- val mutable x : 'a
- method append : 'b option -> unit
- method next : 'b option
- method set_next : 'b option -> unit
- method set_x : 'a -> unit
- method x : 'a
-end
-# class 'a double_link ('a) : 'b =
- val mutable next : 'b option
- val mutable prev : 'b option
- val mutable x : 'a
- method append : 'b option -> unit
- method next : 'b option
- method prev : 'b option
- method set_next : 'b option -> unit
- method set_prev : 'b option -> unit
- method set_x : 'a -> unit
- method x : 'a
-end
-# val fold_right : ('a -> 'b -> 'b) -> 'a #link option -> 'b -> 'b = <fun>
-# class calculator (unit) : 'a =
- val mutable acc : float
- val mutable arg : float
- val mutable equals : 'a -> float
- method acc : float
- method add : 'a
- method arg : float
- method enter : float -> 'a
- method equals : float
- method sub : 'a
-end
-# - : float = 5
-# - : float = 1.5
-# - : float = 15
-# class calculator (unit) : 'a =
- val mutable acc : float
- val mutable arg : float
- val mutable equals : 'a -> float
- method acc : float
- method add : 'a
- method arg : float
- method enter : float -> 'a
- method equals : float
- method sub : 'a
-end
-# - : float = 5
-# - : float = 1.5
-# - : float = 15
-# class calculator (float) (float) =
- val acc : float
- val arg : float
- method add : calculator_add
- method enter : float -> calculator
- method equals : float
- method sub : calculator_sub
-end
-class calculator_add (float) (float) =
- val acc : float
- val arg : float
- method add : calculator_add
- method enter : float -> calculator
- method equals : float
- method sub : calculator_sub
-end
-class calculator_sub (float) (float) =
- val acc : float
- val arg : float
- method add : calculator_add
- method enter : float -> calculator
- method equals : float
- method sub : calculator_sub
-end
-# val calculator : calculator = <obj>
-# - : float = 5
-# - : float = 1.5
-# - : float = 15
-#
diff --git a/testobjects/Exemples.ml b/testobjects/Exemples.ml
deleted file mode 100644
index 30db53ab4f..0000000000
--- a/testobjects/Exemples.ml
+++ /dev/null
@@ -1,333 +0,0 @@
-
-class point x_init =
- val mutable x = x_init
- method get_x = x
- method move d = x <- x + d
-end;;
-
-let p = new point 7;;
-
-p#get_x;;
-p#move 3;;
-p#get_x;;
-
-let q = Oo.copy p;;
-
-q#move 7; p#get_x, q#get_x;;
-
-class color_point x (c : string) =
- inherit point x
- val c = c
- method color = c
-end;;
-
-let p' = new color_point 5 "red";;
-
-p'#get_x, p'#color;;
-
-let l = [p; (p' :> point)];;
-
-let get_x p = p#get_x;;
-let set_x p = p#set_x;;
-List.map get_x l;;
-
-class ref x_init =
- val mutable x = x_init
- method get = x
- method set y = x <- y
-end;;
-
-class ref (x_init:int) =
- val mutable x = x_init
- method get = x
- method set y = x <- y
-end;;
-
-class 'a ref x_init =
- val mutable x = (x_init : 'a)
- method get = x
- method set y = x <- y
-end;;
-
-let r = new ref 1 in r#set 2; (r#get);;
-
-class 'a circle (c : 'a) =
- val mutable center = c
- method center = center
- method set_center c = center <- c
- method move = (center#move : int -> unit)
-end;;
-
-class 'a circle (c : 'a) =
- constraint 'a = #point
- val mutable center = c
- method center = center
- method set_center c = center <- c
- method move = center#move
-end;;
-
-let (c, c') = (new circle p, new circle p');;
-
-class 'a color_circle c =
- constraint 'a = #color_point
- inherit ('a) circle c
- method color = center#color
-end;;
-
-let c'' = new color_circle p;;
-let c'' = new color_circle p';;
-
-(c'' :> color_point circle);;
-(c'' :> point circle);; (* Echec *)
-fun x -> (x : color_point color_circle :> point circle);;
-
-class printable_point y as s =
- inherit point y
- method print = print_int s#get_x
-end;;
-
-let p = new printable_point 7;;
-p#print;;
-
-class printable_color_point y c as self =
- inherit color_point y c
- inherit printable_point y as super
- method print =
- print_string "(";
- super#print;
- print_string ", ";
- print_string (self#color);
- print_string ")"
-end;;
-
-let p' = new printable_color_point 7 "red";;
-p'#print;;
-
-class functional_point y =
- val x = y
- method get_x = x
- method move d = {< x = x + d >}
-end;;
-
-let p = new functional_point 7;;
-
-p#get_x;;
-(p#move 3)#get_x;;
-p#get_x;;
-
-fun x -> (x :> functional_point);;
-
-(*******************************************************************)
-
-class virtual 'a lst () as self =
- virtual null : bool
- virtual hd : 'a
- virtual tl : 'a lst
- method map f =
- (if self#null then
- new nil ()
- else
- new cons (f self#hd) (self#tl#map f)
- : 'a lst)
- method iter (f : 'a -> unit) =
- if self#null then ()
- else begin
- f self#hd;
- self#tl#iter f
- end
- method print (f : 'a -> unit) =
- print_string "(";
- self#iter (fun x -> f x; print_string "::");
- print_string "[]";
- print_string ")"
-and 'a nil () =
- inherit ('a) lst ()
- method null = true
- method hd = failwith "hd"
- method tl = failwith "tl"
-and 'a cons h t =
- inherit ('a) lst ()
- val h = h val t = t
- method null = false
- method hd = h
- method tl = t
-end;;
-
-let l1 = new cons 3 (new cons 10 (new nil ()));;
-
-l1#print print_int;;
-
-let l2 = l1#map (fun x -> x + 1);;
-l2#print print_int;;
-
-let rec map_list f (x:'a lst) =
- if x#null then new nil()
- else new cons (f x#hd) (map_list f x#tl);;
-
-let p1 = (map_list (fun x -> new printable_color_point x "red") l1);;
-p1#print (fun x -> x#print);;
-
-(*******************************************************************)
-
-class virtual comparable () : 'a =
- virtual leq : 'a -> bool
- end;;
-
-class int_comparable (x : int) =
- inherit comparable ()
- val x = x
- method x = x
- method leq p = x <= p#x
-end;;
-
-class int_comparable2 x =
- inherit int_comparable x
- val private mutable x
- method set_x y = x <- y
-end;;
-
-class 'a sorted_list () =
- constraint 'a = #comparable
- val mutable l = ([] : 'a list)
- method add x =
- let rec insert =
- function
- [] -> [x]
- | a::l as l' -> if a#leq x then a::(insert l) else x::l'
- in
- l <- insert l
- method hd = List.hd l
-end;;
-
-let l = new sorted_list ();;
-let c = new int_comparable 10;;
-l#add c;;
-
-let c2 = new int_comparable2 15;;
-l#add (c2 :> int_comparable);; (* Echec : 'a comp2 n'est un sous-type *)
-(new sorted_list ())#add c2;;
-
-class int_comparable3 (x : int) =
- val mutable x = x
- method leq (y : int_comparable) = x < y#x
- method x = x
- method setx y = x <- y
-end;;
-
-let c3 = new int_comparable3 15;;
-l#add (c3 :> int_comparable);;
-(new sorted_list ())#add c3;; (* Echec : leq n'est pas binaire *)
-
-let sort (l : #comparable list) = Sort.list (fun x -> x#leq) l;;
-let pr l =
- List.map (fun c -> print_int c#x; print_string " ") l;
- print_newline ();;
-let l = [new int_comparable 5; (new int_comparable3 2 :> int_comparable);
- new int_comparable 4];;
-pr l;;
-pr (sort l);;
-let l = [new int_comparable2 2; new int_comparable2 0];;
-pr l;;
-pr (sort l);;
-
-let min (x : #comparable) y =
- if x#leq y then x else y;;
-
-(min (new int_comparable 7) (new int_comparable 11))#x;;
-(min (new int_comparable2 5) (new int_comparable2 3))#x;;
-
-(*******************************************************************)
-
-class 'a link (x : 'a) as self : 'b =
- val mutable x = x
- val mutable next = (None : 'b option)
- method x = x
- method next = next
- method set_x y = x <- y
- method set_next l = next <- l
- method append l =
- match next with
- None ->
- self#set_next l
- | Some l' ->
- l'#append l
-end;;
-
-class 'a double_link x as self =
- inherit ('a) link x
- val mutable prev = None
- method prev = prev
- method set_next l =
- next <- l;
- match l with Some l -> l#set_prev (Some self) | None -> ()
- method set_prev l = prev <- l
-end;;
-
-let rec fold_right f (l : 'a #link option) accu =
- match l with
- None -> accu
- | Some l ->
- f l#x (fold_right f l#next accu);;
-
-(*******************************************************************)
-
-class calculator () as self =
- val mutable arg = 0.
- val mutable acc = 0.
- val mutable equals = function s -> s#arg
- method arg = arg
- method acc = acc
- method enter n = arg <- n; self
- method add =
- acc <- equals self;
- equals <- (function s -> s#acc +. s#arg);
- self
- method sub =
- acc <- equals self;
- equals <- (function s -> s#acc -. s#arg);
- self
- method equals = equals self
-end;;
-
-((new calculator ())#enter 5.)#equals;;
-(((new calculator ())#enter 5.)#sub#enter 3.5)#equals;;
-((new calculator ())#enter 5.)#add#add#equals;;
-
-class calculator () as self =
- val mutable arg = 0.
- val mutable acc = 0.
- val mutable equals = function s -> s#arg
- method arg = arg
- method acc = acc
- method enter n = arg <- n; self
- method add = {< acc = equals self; equals = function s -> s#acc +. s#arg >}
- method sub = {< acc = equals self; equals = function s -> s#acc -. s#arg >}
- method equals = equals self
-end;;
-
-((new calculator ())#enter 5.)#equals;;
-(((new calculator ())#enter 5.)#sub#enter 3.5)#equals;;
-((new calculator ())#enter 5.)#add#add#equals;;
-
-class calculator arg acc as self =
- val arg = arg
- val acc = acc
- method enter n = new calculator n acc
- method add = new calculator_add arg self#equals
- method sub = new calculator_sub arg self#equals
- method equals = arg
-and calculator_add arg acc =
- inherit calculator arg acc
- method enter n = new calculator_add n acc
- method equals = acc +. arg
-and calculator_sub arg acc =
- inherit calculator arg acc
- method enter n = new calculator_sub n acc
- method equals = acc -. arg
-end;;
-
-let calculator = new calculator 0. 0.;;
-
-(calculator#enter 5.)#equals;;
-((calculator#enter 5.)#sub#enter 3.5)#equals;;
-(calculator#enter 5.)#add#add#equals;;
diff --git a/testobjects/Makefile b/testobjects/Makefile
deleted file mode 100644
index 08e6460820..0000000000
--- a/testobjects/Makefile
+++ /dev/null
@@ -1,25 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-# ocaml must be installed...
-
-test: Tests Exemples
-
-Tests:
- TERM=dumb ../ocaml < Tests.ml | tail +3 > Tests.proc
- - diff Tests.exp Tests.proc
-
-Exemples:
- TERM=dumb ../ocaml < Exemples.ml | tail +3 > Exemples.proc
- - diff Exemples.exp Exemples.proc
diff --git a/testobjects/Tests.exp b/testobjects/Tests.exp
deleted file mode 100644
index c28ef5adb3..0000000000
--- a/testobjects/Tests.exp
+++ /dev/null
@@ -1,228 +0,0 @@
-# - : < x : int > ->
- < x : int > -> < x : int > -> < x : int > * < x : int > * < x : int >
-= <fun>
-# class 'a c (unit) = constraint 'a = int method f : 'a c end
-class 'a d (unit) = method f : int c end
-# Characters 185-212:
-The type variable 'a is not bound in implicit type definition
- d = < f : 'a -> unit >
-It should be captured by a class type parameter
-# class virtual closed c ('a) : 'a = virtual f : int end
-class virtual closed d ('a) : 'a = virtual f : int end
-# class virtual closed e ('a) : 'a = virtual f : int end
-# class virtual closed c (c) = end
-# class virtual c (unit) = end
-class 'a d (unit) = constraint 'a = < x : int; .. > method f : 'a -> int end
-# class 'a c (unit) = constraint 'a = int end
-class 'a d (unit) = constraint 'a = int #c end
-# class closed 'a c ('a) : 'a =
- constraint 'a = < f : 'a c >
- method f : 'a c
-end
-# - : (< f : 'a c > as 'a) c -> (< f : 'b c > as 'b) c = <fun>
-# Characters 118-143:
-The class x should be virtual: its method f is undefined
-# Characters 184-187:
-The class d inherits from the closed class c which has no method g
-# Characters 37-97:
-The abbreviation c is used with parameters bool c
-wich are incompatible with constraints int c
-# class ('a, 'b) c (unit) =
- constraint 'a = int -> 'c
- constraint 'b = 'a * < x : 'b > * 'c * 'd
- method f : 'a -> 'b -> unit
-end
-# class ('a, 'b) d (unit) =
- constraint 'a = int -> 'c
- constraint 'b = 'a * < x : 'b > * 'c * 'd
- method f : 'a -> 'b -> unit
-end
-# val x : '_a list ref = {contents=[]}
-# Characters 5-37:
-The type parameters of this class contains type variables that cannot be
-generalized: '_a list ref c
-# type 'a c = < f : 'a c; g : 'a d > constraint 'a = int
-type 'a d = < f : 'a c > constraint 'a = int
-# type 'a c = < f : 'a c; g : 'a d >
-type 'a d = < f : 'a c >
-# type 'a c = < f : 'a c > constraint 'a = int
-type 'a d = < f : int c >
-# type 'a u = < x : 'a > constraint 'a = 'b t
-type 'a t = 'a t u
-# Characters 19-32:
-The type abbreviation t is cyclic
-# type 'a u = 'a
-# Characters 4-18:
-The type abbreviation t is cyclic
-# type t = < x : t >
-# type 'a u = 'a
-# - : t -> t u -> bool = <fun>
-# - : t -> t u -> bool = <fun>
-# module M :
- sig
- class ('a, 'b) c ('c) ('b) =
- constraint 'a = int -> bool
- val x : 'd list
- val y : 'b
- method f : 'a -> unit
- method g : 'b
- end
- end
-# module M' :
- sig
- class virtual ('a, 'b) c (int) ('b) =
- constraint 'a = int -> bool
- val x : float list
- val y : 'b
- method f : 'a -> unit
- method g : 'b
- end
- end
-# class ('a, 'b) d (unit) ('b) =
- constraint 'a = int -> bool
- val x : 'c list
- val y : 'b
- method f : 'a -> unit
- method g : 'b
-end
-# class ('a, 'b) e (unit) ('b) =
- constraint 'a = int -> bool
- val x : float list
- val y : 'b
- method f : 'a -> unit
- method g : 'b
-end
-# - : string = "a"
-# Characters 1-9:
-One cannot create instances of the virtual class M'.c
-# - : int = 10
-# - : float = 7.1
-# # - : bool = true
-# module M : sig class closed 'a c (unit) = method f : 'a -> unit end end
-# module M' : sig class closed 'a c (unit) = method f : 'a -> unit end end
-# - : < f : 'a -> unit; .. > -> 'a M.c = <fun>
-# - : < f : 'a -> unit; .. > -> 'a M'.c = <fun>
-# class 'a c ('b #c) = end
-# class closed 'a c ('a c) = end
-# class c (unit) = method f : int end
-class d (unit) = method f : int end
-# class e (unit) = method f : int end
-# - : int = 2
-# Characters 23-27:
-This expression has type bool but is here used with type int
-# class c (unit) = method f : int method g : int method h : int end
-# class d (unit) = method h : int method i : int method j : int end
-# class e (unit) =
- method f : int
- method g : int
- method h : int
- method i : int
- method j : int
-end
-# val e : e = <obj>
-# - : int * int * int * int * int = 1, 3, 2, 2, 3
-# class c ('a) = val a : 'a val x : int val y : int val z : int end
-# class d ('a) = val b : 'a val t : int val u : int val z : int end
-# class e (unit) =
- val a : int
- val b : int
- val t : int
- val u : int
- val x : int
- val y : int
- val z : int
- method a : int
- method b : int
- method t : int
- method u : int
- method x : int
- method y : int
- method z : int
-end
-# val e : e = <obj>
-# - : int * int * int * int * int * int * int = 1, 3, 2, 2, 3, 5, 7
-# class c (int) (int) =
- val x : int
- val y : int
- method x : int
- method y : int
-end
-# class d (int) (int) =
- val x : int
- val y : int
- method x : int
- method y : int
-end
-# - : int * int = 1, 2
-# - : int * int = 1, 2
-# class 'a c ('a) = end
-# - : 'a -> 'a c = <fun>
-# module type M =
- sig class c (unit) = val x : int end class d (unit) = val x : bool end end
-# class c (int) = method get : int method set : int -> unit end
-# val c : c = <obj>
-# - : int = 5
-# - : int = 7
-# class c (unit) = val x : int val y : int method c : int end
-# class d (unit) = val y : int method c : int method d : int end
-# class e (unit) =
- val x : int
- val y : int
- method c : int
- method d : int
- method x : int
- method y : int
-end
-# - : int * int * int * int = 2, 1, 1, 1
-# module M : sig class c (unit) = method xc : int end end
-# class d (unit) = val x : int method xc : int method xd : int end
-# - : int * int = 1, 2
-# Characters 7-143:
-The type variable 'a is not bound in implicit type definition
- 'b matrix = < add : 'b matrix -> 'b; m : 'a >
-It should be captured by a class type parameter
-# class c (unit) = method m : c end
-# - : c = <obj>
-# module M : sig class c (unit) = method m : c end end
-# - : M.c = <obj>
-# type uu = | A of int | B of (< leq : 'a > as 'a)
-# class virtual c (unit) : 'a = virtual m : 'a end
-# module S : sig val f : (#c as 'a) -> 'a end
-# Characters 12-43:
-Signature mismatch:
-Modules do not match:
- sig val f : (#c as 'a) -> 'a end
-is not included in
- sig val f : #c -> #c end
-Values do not match:
- val f : (#c as 'a) -> 'a
-is not included in
- val f : #c -> #c
-# Characters 32-48:
-Multiple definition of the type name t.
-Names must be unique in a given structure.
-# - : (< m : (< m : 'b -> 'b > as 'b) -> 'a; .. > as 'a) ->
- (< m : 'c -> 'c > as 'c)
-= <fun>
-# Characters 10-39:
-Type int -> bool is not a subtype of type int -> int
-Type bool is not a subtype of type int
-# Characters 9-40:
-Type int -> bool is not a subtype of type int -> int
-Type bool is not a subtype of type int
-# - : < > -> < > = <fun>
-# - : < .. > -> < > = <fun>
-# val x : '_a list ref = {contents=[]}
-# module F : functor(X : sig end) -> sig type t = int end
-# - : < m : int > list ref = {contents=[]}
-# type 'a t
-# - : ('a t as 'a) -> unit = <fun>
-# - : ('a t as 'a) -> unit = <fun>
-# type 'a t = < x : 'a >
-# - : (< x : 'a > as 'a) t -> unit = <fun>
-# - : (< x : 'a > as 'a) t -> unit = <fun>
-# class c (unit) = private method m : int method n : int end
-# class d (unit) = private method m : int method n : int method o : int end
-# - : int * int = 1, 1
-# class c (unit) = method m : int end
-#
diff --git a/testobjects/Tests.ml b/testobjects/Tests.ml
deleted file mode 100644
index 29051fa70d..0000000000
--- a/testobjects/Tests.ml
+++ /dev/null
@@ -1,316 +0,0 @@
-(* Le sous-typage est "syntaxique" *)
-fun (x : < x : int >) y z -> (y :> 'a), (x :> 'a), (z :> 'a);;
-(* - : (< x : int > as 'a) -> 'a -> 'a * 'a = <fun> *)
-
-(* Bizarrerie du typage des classes *)
-class 'a c () =
- method f = (new c (): int c)
-and 'a d () =
- inherit ('a) c ()
-end;;
-(* class 'a c (unit) = constraint 'a = int method f : 'a c end *)
-(* class 'a d (unit) method f : int c end *)
-
-(* 'a libre dans classe d *)
-class 'a c () =
- method f (x : 'a) = ()
-and d () =
- inherit ('a) c ()
-end;;
-
-(* Ferme self ! *)
-(* Pas vraiment moyen de garder l'abbreviation en parametre *)
-class virtual closed c ((x : 'a): < f : int >) : 'a =
-and virtual closed d ((x : 'a): < f : int >) : 'a =
- inherit c x
-end;;
-class virtual closed e x =
- inherit d x
-end;;
-(* class virtual closed c (< f : int >) = virtual f : int end *)
-(* class virtual closed d (< f : int >) = virtual f : int end *)
-(* class virtual closed e (< f : int >) = virtual f : int end *)
-
-(* Self unifie avec une abreviation *)
-class virtual closed c ((x : 'a) : c) : 'a = end;;
-
-(* Instancie #c *)
-class virtual c () =
-and 'a d () =
- constraint 'a = #c
- method f (x : #c) = (x#x : int)
-end;;
-(* class virtual c (unit) = end
- class 'a d (unit) = constraint 'a = < x: int; .. > method f : 'a -> int end *)
-
-class 'a c () =
- constraint 'a = int
-and 'a d () =
- constraint 'a = 'b #c
-end;;
-(* class 'a c (unit) = constraint 'a = int end
- class 'a d (unit) = constraint 'a = int #c end *)
-
-(* Self en parametre *)
-class closed 'a c (x : 'a) as self : 'b =
- constraint 'a = 'b
- method f = self
-end;;
-new c;;
-(* class 'a c ('a) :'b = constraint 'a = 'a c method f : 'a end *)
-(* - : ('a c as 'a) -> 'b c as 'b = <fun> *)
-
-class x () =
- virtual f : int
-end;;
-(* The class x should be virtual: its methods f is undefined *)
-
-(* Methode g en trop *)
-class virtual closed c ((x : 'a): < f : int >) : 'a =
-and virtual closed d x : 'a =
- inherit c x
- method g = true
-end;;
-
-(* Contrainte non respectee *)
-class 'a c () =
- constraint 'a = int
- method f x = (x : bool c)
-end;;
-
-(* Differentes contraintes *)
-class ('a, 'b) c () =
- constraint 'a = int -> 'c
- constraint 'b = 'a * <x : 'b> * 'c * 'd
- method f (x : 'a) (y : 'b) = ()
-end;;
-class ('a, 'b) d () =
- inherit ('a, 'b) c ()
-end;;
-
-(* Contrainte non generique *)
-let x = ref [];;
-class 'a c () =
- method f = (x : 'a)
-end;;
-
-(* Abreviations *)
-type 'a c = <f : 'a c; g : 'a d>
-and 'a d = <f : int c>;;
-type 'a c = <f : 'a c; g : 'a d>
-and 'a d = <f : 'a c>;;
-type 'a c = <f : 'a c>
-and 'a d = <f : int c>;;
-type 'a u = < x : 'a>
-and 'a t = 'a t u;;
-type 'a u = 'a
-and 'a t = 'a t u;;
-type 'a u = 'a;;
-type t = t u * t u;;
-
-type t = <x : 'a> as 'a;;
-type 'a u = 'a;;
-fun (x : t) (y : 'a u) -> x = y;;
-fun (x : t) (y : 'a u) -> y = x;;
-(* - : t -> t u -> bool = <fun> *)
-
-(* Modules *)
-module M =
- struct
- class ('a, 'b) c x (y: 'b) =
- constraint 'a = int -> bool
- val x = []
- val y = y
- method f (x : 'a) = ()
- method g = y
- end
- end;;
-module M' = (M :
- sig
- class virtual ('a, 'b) c (int) ('b) =
- constraint 'a = int -> bool
- val x : float list
- val y : 'b
- method f : 'a -> unit
- method g : 'b
- end
- end);;
-class ('a, 'b) d () y = inherit ('a, 'b) M.c () y end;;
-class ('a, 'b) e () y = inherit ('a, 'b) M'.c 1 y end;;
-(new M.c () "a")#g;;
-(new M'.c 1)#g;;
-(new d () 10)#g;;
-(new e () 7.1)#g;;
-open M;;
-(new c () true)#g;;
-
-(* #cl quand cl est fermee *)
-module M = struct class closed 'a c () = method f (x : 'a) = () end end;;
-module M' =
- (M : sig class closed 'a c (unit) = method f : 'a -> unit end end);;
-fun x -> (x :> 'a #M.c);;
-fun x -> (x :> 'a #M'.c);;
-class 'a c (x : 'b #c) = end;;
-class closed 'a c (x : 'b #c) = end;;
-
-(* Ordre de calcul *)
-class c () = method f = 1 and d () = method f = 2 end;;
-class e () = inherit c () inherit d () end;;
-(new e ())#f;;
-class c () = val x = - true val y = -. () end;;
-
-class c () = method f = 1 method g = 1 method h = 1 end;;
-class d () = method h = 2 method i = 2 method j = 2 end;;
-class e () =
- method f = 3
- inherit c ()
- method g = 3
- method i = 3
- inherit d ()
- method j = 3
-end;;
-let e = new e ();;
-e#f, e#g, e#h, e#i, e#j;;
-
-class c a = val x = 1 val y = 1 val z = 1 val a = a end;;
-class d b = val z = 2 val t = 2 val u = 2 val b = b end;;
-class e () =
- val x = 3
- inherit c 5
- val y = 3
- val t = 3
- inherit d 7
- val u = 3
- method x = x
- method y = y
- method z = z
- method t = t
- method u = u
- method a = a
- method b = b
-end;;
-let e = new e ();;
-e#x, e#y, e#z, e#t, e#u, e#a, e#b;;
-
-class c (x : int) (y : int) =
- val x = x
- val y = y
- method x = x
- method y = y
-end;;
-class d x y = inherit c x y end;;
-let c = new c 1 2 in c#x, c#y;;
-let d = new d 1 2 in d#x, d#y;;
-
-(* Parametres n'apparaissant pas dans le type de l'objet *)
-class 'a c (x : 'a) = end;;
-new c;;
-
-(* Variables privees *)
-module type M = sig
- class c (unit) = val x : int end
- class d (unit) = inherit c val private x : int val x : bool end
-end;;
-class c (x : int) =
- val private mutable x = x
- method get = x
- method set y = x <- y
-end;;
-let c = new c 5;;
-c#get;;
-c#set 7; c#get;;
-
-class c () = val x = 1 val y = 1 method c = x end;;
-class d () = inherit c () val private x method d = x end;;
-class e () =
- val x = 2 val y = 2 inherit d () method x = x method y = y
-end;;
-let e = new e () in e#x, e#y, e#c, e#d;;
-
-(* Oubli de variables dans l'interface *)
-module M :
- sig
- class c (unit) =
- method xc : int
- end
- end =
- struct
- class c () =
- val x = 1
- method xc = x
- end
- end;;
-class d () =
- val x = 2
- method xd = x
- inherit M.c ()
-end;;
-let d = new d () in d#xc, d#xd;;
-
-class virtual 'a matrix (sz, init : int * 'a) =
- val m = Array.create_matrix sz sz init
- method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a)
-end;;
-
-class c () = method m = new c () end;;
-(new c ())#m;;
-module M = struct class c () = method m = new c () end end;;
-(new M.c ())#m;;
-
-type uu = A of int | B of (<leq: 'a> as 'a);;
-
-class virtual c () : 'a = virtual m : 'a end;;
-module S = (struct
- let f (x : #c) = x
-end : sig
- val f : #c as 'a -> 'a
-end);;
-module S = (struct
- let f (x : #c) = x
-end : sig
- val f : #c -> #c
-end);;
-
-module M = struct type t = int class t () = end end;;
-
-fun x -> (x :> < m : 'a -> 'a > as 'a);;
-
-fun x -> (x : int -> bool :> 'a -> 'a);;
-fun x -> (x : int -> bool :> int -> int);;
-fun x -> (x : < > :> < .. >);;
-fun x -> (x : < .. > :> < >);;
-
-let x = ref [];;
-module F(X : sig end) =
- struct type t = int let _ = (x : < m : t> list ref) end;;
-x;;
-
-type 'a t;;
-fun (x : 'a t as 'a) -> ();;
-fun (x : 'a t) -> (x : 'a); ();;
-type 'a t = < x : 'a >;;
-fun (x : 'a t as 'a) -> ();;
-fun (x : 'a t) -> (x : 'a); ();;
-
-class 'a c () =
- constraint 'a = < .. > -> unit
- method m = (fun x -> () : 'a)
-end;;
-class 'a c () =
- constraint 'a = unit -> < .. >
- method m (f : 'a) = f ()
-end;;
-
-class c () as self =
- private method m = 1
- method n = self#m
-end;;
-
-class d () as self =
- inherit c ()
- method o = self#m
-end;;
-
-let x = new d () in x#n, x#o;;
-
-class c () = virtual m : int private method m = 1 end;;
diff --git a/tools/.cvsignore b/tools/.cvsignore
deleted file mode 100644
index 1aa5013d57..0000000000
--- a/tools/.cvsignore
+++ /dev/null
@@ -1,22 +0,0 @@
-ocamldep
-ocamldep.opt
-ocamlprof
-opnames.ml
-dumpobj
-dumpapprox
-objinfo
-cvt_emit
-cvt_emit.ml
-ocamlcp
-ocamlmktop
-primreq
-ocamldumpobj
-keywords
-lexer299.ml
-ocaml299to3
-ocamlmklib
-ocamlmklib.ml
-lexer301.ml
-scrapelabels
-addlabels
-
diff --git a/tools/.depend b/tools/.depend
deleted file mode 100644
index 035fd88b96..0000000000
--- a/tools/.depend
+++ /dev/null
@@ -1,49 +0,0 @@
-depend.cmi: ../parsing/parsetree.cmi
-addlabels.cmo: ../parsing/asttypes.cmi ../parsing/location.cmi \
- ../parsing/longident.cmi ../parsing/parse.cmi ../parsing/parsetree.cmi
-addlabels.cmx: ../parsing/asttypes.cmi ../parsing/location.cmx \
- ../parsing/longident.cmx ../parsing/parse.cmx ../parsing/parsetree.cmi
-depend.cmo: ../parsing/location.cmi ../parsing/longident.cmi \
- ../parsing/parsetree.cmi depend.cmi
-depend.cmx: ../parsing/location.cmx ../parsing/longident.cmx \
- ../parsing/parsetree.cmi depend.cmi
-dumpapprox.cmo: ../asmcomp/clambda.cmi ../asmcomp/compilenv.cmi \
- ../utils/config.cmi
-dumpapprox.cmx: ../asmcomp/clambda.cmx ../asmcomp/compilenv.cmx \
- ../utils/config.cmx
-dumpobj.cmo: ../parsing/asttypes.cmi ../bytecomp/bytesections.cmi \
- ../utils/config.cmi ../bytecomp/emitcode.cmi ../typing/ident.cmi \
- ../bytecomp/instruct.cmi ../bytecomp/lambda.cmi ../bytecomp/opcodes.cmo \
- opnames.cmo ../utils/tbl.cmi
-dumpobj.cmx: ../parsing/asttypes.cmi ../bytecomp/bytesections.cmx \
- ../utils/config.cmx ../bytecomp/emitcode.cmx ../typing/ident.cmx \
- ../bytecomp/instruct.cmx ../bytecomp/lambda.cmx ../bytecomp/opcodes.cmx \
- opnames.cmx ../utils/tbl.cmx
-lexer301.cmo: ../parsing/location.cmi ../utils/misc.cmi ../utils/warnings.cmi
-lexer301.cmx: ../parsing/location.cmx ../utils/misc.cmx ../utils/warnings.cmx
-objinfo.cmo: ../utils/config.cmi ../bytecomp/emitcode.cmi
-objinfo.cmx: ../utils/config.cmx ../bytecomp/emitcode.cmx
-ocamlcp.cmo: ../driver/main_args.cmi
-ocamlcp.cmx: ../driver/main_args.cmx
-ocamldep.cmo: ../utils/clflags.cmo ../utils/config.cmi depend.cmi \
- ../parsing/lexer.cmi ../parsing/location.cmi ../parsing/longident.cmi \
- ../utils/misc.cmi ../parsing/parse.cmi ../parsing/parsetree.cmi \
- ../parsing/syntaxerr.cmi
-ocamldep.cmx: ../utils/clflags.cmx ../utils/config.cmx depend.cmx \
- ../parsing/lexer.cmx ../parsing/location.cmx ../parsing/longident.cmx \
- ../utils/misc.cmx ../parsing/parse.cmx ../parsing/parsetree.cmi \
- ../parsing/syntaxerr.cmx
-ocamlmktop.cmo: ../utils/ccomp.cmi
-ocamlmktop.cmx: ../utils/ccomp.cmx
-ocamlprof.cmo: ../utils/clflags.cmo ../utils/config.cmi ../parsing/lexer.cmi \
- ../parsing/location.cmi ../utils/misc.cmi ../parsing/parse.cmi \
- ../parsing/parsetree.cmi ../parsing/syntaxerr.cmi
-ocamlprof.cmx: ../utils/clflags.cmx ../utils/config.cmx ../parsing/lexer.cmx \
- ../parsing/location.cmx ../utils/misc.cmx ../parsing/parse.cmx \
- ../parsing/parsetree.cmi ../parsing/syntaxerr.cmx
-primreq.cmo: ../utils/config.cmi ../bytecomp/emitcode.cmi
-primreq.cmx: ../utils/config.cmx ../bytecomp/emitcode.cmx
-profiling.cmo: profiling.cmi
-profiling.cmx: profiling.cmi
-scrapelabels.cmo: lexer301.cmo
-scrapelabels.cmx: lexer301.cmx
diff --git a/tools/Characters b/tools/Characters
deleted file mode 100644
index fb8e6868ab..0000000000
--- a/tools/Characters
+++ /dev/null
@@ -1,16 +0,0 @@
-# Characters
-
-# $Id$
-
-# Usage:
-# Characters n1 to n2
-#
-# Select the characters in the given interval, counting from the first
-# character of the current line, in the active window.
-#
-# Typical use is an error message of the form:
-# File fff; Line lll; Characters yyy to zzz
-
-exit 1 if {#} ­ 3
-
-Find Ƥ!{1}:¤!`evaluate {3} - {1}` "{active}"
diff --git a/tools/DoMake b/tools/DoMake
deleted file mode 100644
index 2afff48ae2..0000000000
--- a/tools/DoMake
+++ /dev/null
@@ -1,61 +0,0 @@
-# DoMake
-
-# $Id$
-
-# Execute the output of "Make -f Makefile.Mac -f Makefile.Mac.depend"
-# or "Make -f Makefile -f Makefile.depend" if "Makefile.Mac" does not exist
-# or "Make -f <file>" if the "-f" option is given.
-
-# usage: domake [-quiet] [-f <file>]É <make arguments>
-
-set echo 0
-
-set domake_quiet 0
-set domake_files ""
-
-loop
- if "{1}" == "-quiet"
- set domake_quiet 1
- shift
- else if "{1}" == "-f"
- set domake_files "{domake_files} -f `quote "{2}"`"
- shift 2
- else
- break
- end
-end
-
-set tempfile "{TempFolder}temp-domake-`Date -n`"
-if "`exists "{tempfile}"`"
- set i 0
- loop
- break if ! "`exists "{tempfile}.{i}"`"
- evaluate i += 1
- end
- set tempfile "{tempfile}.{i}"
-end
-
-if "{domake_files}" == ""
- if "`exists Makefile.Mac`" != ""
- set domake_main "Makefile.Mac"
- else
- set domake_main "Makefile"
- end
-
- if "`exists "{domake_main}".depend`" != ""
- set domake_files "-f {domake_main} -f {domake_main}.depend"
- else
- set domake_files "-f {domake_main}"
- end
-end
-
-if {domake_quiet}
- echo >"{tempfile}"
-else
- echo 'set echo 1' >"{tempfile}"
-end
-make {domake_files} {"Parameters"} >>"{tempfile}"
-
-"{tempfile}"
-
-Delete -i "{tempfile}"
diff --git a/tools/MakeDepend b/tools/MakeDepend
deleted file mode 100644
index 5693b27e8d..0000000000
--- a/tools/MakeDepend
+++ /dev/null
@@ -1,17 +0,0 @@
-# MakeDepend
-
-# $Id$
-
-
-# Usage: MakeDepend fileÉ
-
-# Generate the Make dependency rules for a set of C files.
-# The rules are printed on standard output.
-
-set echo 0
-set exit 0
-
-for i in {"parameters"}
- mrc -c -w off -make dev:stdout "{i}" ³ dev:null ¶
- | streamedit -e '/¶"(Å)¨0.c.o¶"/ replace // "¶""¨0".c.o¶" ¶""¨0".c.x¶""'
-end
diff --git a/tools/Makefile b/tools/Makefile
deleted file mode 100644
index f9d3343514..0000000000
--- a/tools/Makefile
+++ /dev/null
@@ -1,264 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-include ../config/Makefile
-
-CAMLRUN=../boot/ocamlrun
-CAMLC=$(CAMLRUN) ../boot/ocamlc -nostdlib -I ../boot
-CAMLOPT=$(CAMLRUN) ../ocamlopt -nostdlib -I ../stdlib
-CAMLLEX=$(CAMLRUN) ../boot/ocamllex
-INCLUDES=-I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../asmcomp \
- -I ../driver
-COMPFLAGS= -warn-error A $(INCLUDES)
-LINKFLAGS=$(INCLUDES)
-
-all: ocamldep ocamlprof ocamlcp ocamlmktop ocamlmklib scrapelabels addlabels
-
-opt.opt: ocamldep.opt
-
-# The dependency generator
-
-CAMLDEP_OBJ=depend.cmo ocamldep.cmo
-CAMLDEP_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \
- linenum.cmo warnings.cmo location.cmo longident.cmo \
- syntaxerr.cmo parser.cmo lexer.cmo parse.cmo
-
-ocamldep: depend.cmi $(CAMLDEP_OBJ)
- $(CAMLC) $(LINKFLAGS) -o ocamldep $(CAMLDEP_IMPORTS) $(CAMLDEP_OBJ)
-
-ocamldep.opt: depend.cmi $(CAMLDEP_OBJ:.cmo=.cmx)
- $(CAMLOPT) $(LINKFLAGS) -o ocamldep.opt $(CAMLDEP_IMPORTS:.cmo=.cmx) \
- $(CAMLDEP_OBJ:.cmo=.cmx)
-
-# 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
-
-install::
- cp ocamldep $(BINDIR)/ocamldep$(EXE)
- if test -f ocamldep.opt; \
- then cp ocamldep.opt $(BINDIR)/ocamldep.opt$(EXE); else :; fi
-
-# The profiler
-
-CSLPROF=ocamlprof.cmo
-CSLPROF_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \
- linenum.cmo warnings.cmo location.cmo longident.cmo \
- syntaxerr.cmo parser.cmo lexer.cmo parse.cmo
-
-ocamlprof: $(CSLPROF) profiling.cmo
- $(CAMLC) $(LINKFLAGS) -o ocamlprof $(CSLPROF_IMPORTS) $(CSLPROF)
-
-ocamlcp: ocamlcp.cmo
- $(CAMLC) $(LINKFLAGS) -o ocamlcp main_args.cmo ocamlcp.cmo
-
-install::
- cp ocamlprof $(BINDIR)/ocamlprof$(EXE)
- cp ocamlcp $(BINDIR)/ocamlcp$(EXE)
- cp profiling.cmi profiling.cmo $(LIBDIR)
-
-clean::
- rm -f ocamlprof ocamlcp
-
-# To make custom toplevels
-
-ocamlmktop: ocamlmktop.tpl ../config/Makefile
- sed -e 's|%%BINDIR%%|$(BINDIR)|' ocamlmktop.tpl > ocamlmktop
- chmod +x ocamlmktop
-
-install::
- cp ocamlmktop $(BINDIR)/ocamlmktop
-
-clean::
- rm -f ocamlmktop
-
-# To help building mixed-mode libraries (Caml + C)
-
-ocamlmklib: ocamlmklib.cmo
- $(CAMLC) $(LINKFLAGS) -o ocamlmklib ocamlmklib.cmo
-
-install::
- cp ocamlmklib $(BINDIR)/ocamlmklib
-
-clean::
- rm -f ocamlmklib
-
-ocamlmklib.ml: ocamlmklib.mlp ../config/Makefile
- sed -e "s|%%BINDIR%%|$(BINDIR)|" \
- -e "s|%%SUPPORTS_SHARED_LIBRARIES%%|$(SUPPORTS_SHARED_LIBRARIES)|" \
- -e "s|%%MKSHAREDLIB%%|$(MKSHAREDLIB)|" \
- -e "s|%%BYTECCRPATH%%|$(BYTECCRPATH)|" \
- -e "s|%%NATIVECCRPATH%%|$(NATIVECCRPATH)|" \
- -e "s|%%MKSHAREDLIBRPATH%%|$(MKSHAREDLIBRPATH)|" \
- -e "s|%%RANLIB%%|$(RANLIB)|" \
- ocamlmklib.mlp > ocamlmklib.ml
-
-beforedepend:: ocamlmklib.ml
-
-clean::
- rm -f ocamlmklib.ml
-
-# Converter olabl/ocaml 2.99 to ocaml 3
-
-OCAML299TO3= lexer299.cmo ocaml299to3.cmo
-LIBRARY3= misc.cmo warnings.cmo linenum.cmo location.cmo
-
-ocaml299to3: $(OCAML299TO3)
- $(CAMLC) $(LINKFLAGS) -o ocaml299to3 $(LIBRARY3) $(OCAML299TO3)
-
-lexer299.ml: lexer299.mll
- $(CAMLLEX) lexer299.mll
-
-#install::
-# cp ocaml299to3 $(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 $(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 clflags.cmo terminfo.cmo \
- linenum.cmo warnings.cmo location.cmo longident.cmo \
- syntaxerr.cmo parser.cmo lexer.cmo parse.cmo
-
-addlabels: addlabels.ml
- $(CAMLC) $(LINKFLAGS) -w sl -o addlabels \
- $(ADDLABELS_IMPORTS) addlabels.ml
-
-install::
- cp addlabels $(LIBDIR)
-
-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
-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
-
-# The bytecode disassembler
-
-DUMPOBJ=opnames.cmo dumpobj.cmo
-
-dumpobj: $(DUMPOBJ)
- $(CAMLC) $(LINKFLAGS) -o dumpobj \
- misc.cmo tbl.cmo config.cmo ident.cmo \
- opcodes.cmo bytesections.cmo $(DUMPOBJ)
-
-clean::
- rm -f dumpobj
-
-opnames.ml: ../byterun/instruct.h
- unset LC_ALL LC_CTYPE LC_COLLATE LANG; \
- sed -e '/\/\*/d' \
- -e '/^#/d' \
- -e 's/enum \(.*\) {/let names_of_\1 = [|/' \
- -e 's/};$$/ |]/' \
- -e 's/\([A-Z][A-Z_0-9a-z]*\)/"\1"/g' \
- -e 's/,/;/g' \
- ../byterun/instruct.h > opnames.ml
-
-clean::
- rm -f opnames.ml
-
-beforedepend:: opnames.ml
-
-# Dump .cmx files
-
-dumpapprox: dumpapprox.cmo
- $(CAMLC) $(LINKFLAGS) -o dumpapprox config.cmo dumpapprox.cmo
-
-clean::
- rm -f dumpapprox
-
-# Print imported interfaces for .cmo files
-
-objinfo: objinfo.cmo
- $(CAMLC) $(LINKFLAGS) -o objinfo config.cmo objinfo.cmo
-
-clean::
- rm -f objinfo
-
-# Print imported interfaces for .cmi files
-
-intfinfo: intfinfo.cmo
- $(CAMLC) $(LINKFLAGS) -o intfinfo config.cmo intfinfo.cmo
-
-clean::
- rm -f intfinfo
-
-# Scan object files for required primitives
-
-PRIMREQ=primreq.cmo
-
-primreq: $(PRIMREQ)
- $(CAMLC) $(LINKFLAGS) -o primreq config.cmo $(PRIMREQ)
-
-clean::
- rm -f primreq
-
-# Common stuff
-
-.SUFFIXES:
-.SUFFIXES: .ml .cmo .mli .cmi .cmx
-
-.ml.cmo:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.mli.cmi:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) $(COMPFLAGS) -c $<
-
-clean::
- rm -f *.cmo *.cmi
-
-depend: beforedepend
- $(CAMLRUN) ./ocamldep $(INCLUDES) *.mli *.ml > .depend
-
-include .depend
diff --git a/tools/Makefile.Mac b/tools/Makefile.Mac
deleted file mode 100644
index 0a9a079062..0000000000
--- a/tools/Makefile.Mac
+++ /dev/null
@@ -1,137 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-CAMLRUN = ::boot:ocamlrun
-CAMLC = "{CAMLRUN}" ::boot:ocamlc -I ::boot:
-CAMLLEX = "{CAMLRUN}" ::boot:ocamllex
-INCLUDES = -I ::utils: -I ::parsing: -I ::typing: -I ::bytecomp: -I ::asmcomp:
-COMPFLAGS = {INCLUDES}
-LINKFLAGS = {INCLUDES}
-
-all Ä ocamldep ocamldumpobj objinfo primreq keywords
-
-# The dependency generator
-
-CAMLDEP_IMPORTS = misc.cmo config.cmo clflags.cmo terminfo.cmo ¶
- linenum.cmo warnings.cmo location.cmo longident.cmo ¶
- syntaxerr.cmo parser.cmo lexer.cmo parse.cmo
-
-CAMLDEP = depend.cmo ocamldep.cmo
-
-ocamldep Ä depend.cmi {CAMLDEP}
- {CAMLC} {LINKFLAGS} -o ocamldep {CAMLDEP_IMPORTS} {CAMLDEP}
-
-clean ÄÄ
- delete -i ocamldep
-
-install ÄÄ
- duplicate -y ocamldep "{BINDIR}ocamldep"
-
-# The profiler (not available on MacOS for the moment)
-#
-#CSLPROF = ocamlprof.cmo
-#CSLPROF_IMPORTS = misc.cmo config.cmo clflags.cmo terminfo.cmo ¶
-# linenum.cmo warnings.cmo location.cmo longident.cmo pstream.cmo ¶
-# syntaxerr.cmo parser.cmo lexer.cmo parse.cmo
-#
-#ocamlprof Ä {CSLPROF} profiling.cmo
-# {CAMLC} {LINKFLAGS} -o ocamlprof {CSLPROF_IMPORTS} {CSLPROF}
-#
-#install ÄÄ
-# duplicate -y ocamlprof "{BINDIR}ocamlprof"
-# duplicate -y ocamlcp "{BINDIR}ocamlcp"
-# duplicate -y profiling.cmi profiling.cmo "{LIBDIR}"
-#
-#clean ÄÄ
-# delete -i ocamlprof
-
-# To make custom toplevels
-
-install ÄÄ
- duplicate -y ocamlmktop.tpl "{BINDIR}ocamlmktop"
-
-# The bytecode disassembler
-
-DUMPOBJ = opnames.cmo dumpobj.cmo
-
-ocamldumpobj Ä {DUMPOBJ}
- {CAMLC} {LINKFLAGS} -o ocamldumpobj ¶
- misc.cmo tbl.cmo config.cmo ident.cmo opcodes.cmo ¶
- bytesections.cmo {DUMPOBJ}
-
-clean ÄÄ
- delete -i ocamldumpobj
-
-install ÄÄ
- duplicate -y ocamldumpobj "{BINDIR}ocamldumpobj"
-
-opnames.ml Ä ::byterun:instruct.h
- streamedit -e '/¶/¶*/ delete' ¶
- -e '/enum (Å)¨0 {/ replace // "let names_of_" ¨0 "= [|"' ¶
- -e '/};°/ replace // "|]"' ¶
- -e '/([A-Z][A-Z_0-9a-z]*)¨0/ replace // "¶"" ¨0 "¶"" -c °' ¶
- -e '/,/ replace // ";" -c °' ¶
- ::byterun:instruct.h > opnames.ml
-
-clean ÄÄ
- delete -i opnames.ml
-
-beforedepend ÄÄ opnames.ml
-
-# Dump .cmx files
-
-#dumpapprox Ä dumpapprox.cmo
-# {CAMLC} {LINKFLAGS} -o dumpapprox config.cmo dumpapprox.cmo
-#
-#clean ÄÄ
-# delete -i dumpapprox
-
-# Print imported interfaces for .cmo files
-
-objinfo Ä objinfo.cmo
- {CAMLC} {LINKFLAGS} -o objinfo config.cmo objinfo.cmo
-
-clean ÄÄ
- delete -i objinfo
-
-# Common stuff
-
-.cmo Ä .ml
- {CAMLC} -c {COMPFLAGS} {depdir}{default}.ml
-
-.cmi Ä .mli
- {CAMLC} -c {COMPFLAGS} {depdir}{default}.mli
-
-clean ÄÄ
- delete -i Å.cm[io] || set status 0
-
-depend Ä beforedepend
- {CAMLRUN} :ocamldep {INCLUDES} Å.mli Å.ml > Makefile.Mac.depend
-
-# Scan object files for required primitives
-
-primreq Ä primreq.cmo
- {CAMLC} {LINKFLAGS} -o primreq config.cmo primreq.cmo
-
-clean ÄÄ
- delete -i primreq
-
-
-# Resources for keyword-coloring for MPW Shell
-
-keywords Ä keywords.r
- rez -t rsrc -c RSED -o keywords keywords.r
-
-clean ÄÄ
- delete -i keywords
diff --git a/tools/Makefile.Mac.depend b/tools/Makefile.Mac.depend
deleted file mode 100644
index 0393c7069c..0000000000
--- a/tools/Makefile.Mac.depend
+++ /dev/null
@@ -1,30 +0,0 @@
-dumpapprox.cmoÄ ::asmcomp:clambda.cmi ::asmcomp:compilenv.cmi ¶
- ::utils:config.cmi
-dumpapprox.cmxÄ ::asmcomp:clambda.cmx ::asmcomp:compilenv.cmx ¶
- ::utils:config.cmx
-dumpobj.cmoÄ ::parsing:asttypes.cmi ::bytecomp:bytesections.cmi ¶
- ::utils:config.cmi ::bytecomp:emitcode.cmi ::typing:ident.cmi ¶
- ::bytecomp:instruct.cmi ::bytecomp:lambda.cmi ::bytecomp:opcodes.cmo ¶
- opnames.cmo ::utils:tbl.cmi
-dumpobj.cmxÄ ::parsing:asttypes.cmi ::bytecomp:bytesections.cmx ¶
- ::utils:config.cmx ::bytecomp:emitcode.cmx ::typing:ident.cmx ¶
- ::bytecomp:instruct.cmx ::bytecomp:lambda.cmx ::bytecomp:opcodes.cmx ¶
- opnames.cmx ::utils:tbl.cmx
-objinfo.cmoÄ ::utils:config.cmi ::bytecomp:emitcode.cmi
-objinfo.cmxÄ ::utils:config.cmx ::bytecomp:emitcode.cmx
-ocamldep.cmoÄ ::utils:clflags.cmo ::utils:config.cmi ::parsing:lexer.cmi ¶
- ::parsing:location.cmi ::parsing:longident.cmi ::utils:misc.cmi ¶
- ::parsing:parse.cmi ::parsing:parsetree.cmi ::parsing:syntaxerr.cmi
-ocamldep.cmxÄ ::utils:clflags.cmx ::utils:config.cmx ::parsing:lexer.cmx ¶
- ::parsing:location.cmx ::parsing:longident.cmx ::utils:misc.cmx ¶
- ::parsing:parse.cmx ::parsing:parsetree.cmi ::parsing:syntaxerr.cmx
-ocamlprof.cmoÄ ::utils:clflags.cmo ::utils:config.cmi ::parsing:lexer.cmi ¶
- ::parsing:location.cmi ::utils:misc.cmi ::parsing:parse.cmi ¶
- ::parsing:parsetree.cmi ::parsing:syntaxerr.cmi
-ocamlprof.cmxÄ ::utils:clflags.cmx ::utils:config.cmx ::parsing:lexer.cmx ¶
- ::parsing:location.cmx ::utils:misc.cmx ::parsing:parse.cmx ¶
- ::parsing:parsetree.cmi ::parsing:syntaxerr.cmx
-primreq.cmoÄ ::utils:config.cmi ::bytecomp:emitcode.cmi
-primreq.cmxÄ ::utils:config.cmx ::bytecomp:emitcode.cmx
-profiling.cmoÄ profiling.cmi
-profiling.cmxÄ profiling.cmi
diff --git a/tools/Makefile.nt b/tools/Makefile.nt
deleted file mode 100644
index b23b572c83..0000000000
--- a/tools/Makefile.nt
+++ /dev/null
@@ -1,172 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-include ../config/Makefile
-
-CAMLRUN=../boot/ocamlrun
-CAMLC=$(CAMLRUN) ../boot/ocamlc -I ../boot
-CAMLOPT=$(CAMLRUN) ../ocamlopt
-CAMLLEX=$(CAMLRUN) ../boot/ocamllex
-INCLUDES=-I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../asmcomp \
- -I ../driver
-COMPFLAGS=$(INCLUDES)
-LINKFLAGS=$(INCLUDES)
-
-all: ocamldep ocamlprof ocamlcp.exe ocamlmktop.exe primreq
-
-opt.opt: depend.cmx
-
-# The dependency generator
-
-CAMLDEP=depend.cmo ocamldep.cmo
-CAMLDEP_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \
- linenum.cmo warnings.cmo location.cmo longident.cmo \
- syntaxerr.cmo parser.cmo lexer.cmo parse.cmo
-
-ocamldep: depend.cmi $(CAMLDEP)
- $(CAMLC) $(LINKFLAGS) -o ocamldep $(CAMLDEP_IMPORTS) $(CAMLDEP)
-
-depend.cmx: depend.ml
- $(CAMLOPT) $(INCLUDES) -I ../stdlib depend.ml
-
-clean::
- rm -f ocamldep
-
-install::
- cp ocamldep $(BINDIR)/ocamldep.exe
-
-beforedepend:: ocamldep.ml
-
-# The profiler
-
-CSLPROF=ocamlprof.cmo
-CSLPROF_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \
- linenum.cmo warnings.cmo location.cmo longident.cmo \
- syntaxerr.cmo parser.cmo lexer.cmo parse.cmo
-
-ocamlprof: $(CSLPROF) profiling.cmo
- $(CAMLC) $(LINKFLAGS) -o ocamlprof $(CSLPROF_IMPORTS) $(CSLPROF)
-
-ocamlcp.exe: ocamlcp.cmo
- $(CAMLC) $(LINKFLAGS) -o ocamlcp.exe main_args.cmo ocamlcp.cmo
-
-install::
- cp ocamlprof $(BINDIR)/ocamlprof.exe
- cp ocamlcp.exe $(BINDIR)/ocamlcp.exe
- cp profiling.cmi profiling.cmo $(LIBDIR)
-
-clean::
- rm -f ocamlprof ocamlcp.exe
-
-# To make custom toplevels
-
-OCAMLMKTOP=ocamlmktop.cmo
-OCAMLMKTOP_IMPORTS=misc.cmo config.cmo clflags.cmo ccomp.cmo
-
-ocamlmktop.exe: $(OCAMLMKTOP)
- $(CAMLC) $(LINKFLAGS) -o ocamlmktop.exe $(OCAMLMKTOP_IMPORTS) $(OCAMLMKTOP)
-
-install::
- cp ocamlmktop.exe $(BINDIR)/ocamlmktop.exe
-
-clean::
- rm -f ocamlmktop.exe
-
-# The preprocessor for asm generators
-
-CVT_EMIT=cvt_emit.cmo
-
-cvt_emit: $(CVT_EMIT)
- $(CAMLC) $(LINKFLAGS) -o cvt_emit $(CVT_EMIT)
-
-clean::
- rm -f cvt_emit
-
-cvt_emit.ml: cvt_emit.mll
- $(CAMLLEX) cvt_emit.mll
-
-clean::
- rm -f cvt_emit.ml
-
-beforedepend:: cvt_emit.ml
-
-# The bytecode disassembler
-
-DUMPOBJ=opnames.cmo dumpobj.cmo
-
-dumpobj: $(DUMPOBJ)
- $(CAMLC) $(LINKFLAGS) -o dumpobj \
- misc.cmo tbl.cmo config.cmo ident.cmo \
- opcodes.cmo bytesections.cmo $(DUMPOBJ)
-
-clean::
- rm -f dumpobj
-
-opnames.ml: ../byterun/instruct.h
- sed -e '////*/d' \
- -e 's/enum /(.*/) {/let names_of_/1 = [|/' \
- -e 's/};$$/ |]/' \
- -e 's//([A-Z][A-Z_0-9a-z]*/)/"/1"/g' \
- -e 's/,/;/g' \
- ../byterun/instruct.h > opnames.ml
-
-clean::
- rm -f opnames.ml
-
-beforedepend:: opnames.ml
-
-# Dump .cmx files
-
-dumpapprox: dumpapprox.cmo
- $(CAMLC) $(LINKFLAGS) -o dumpapprox config.cmo dumpapprox.cmo
-
-clean::
- rm -f dumpapprox
-
-# Print imported interfaces for .cmo files
-
-objinfo: objinfo.cmo
- $(CAMLC) $(LINKFLAGS) -o objinfo config.cmo objinfo.cmo
-
-clean::
- rm -f objinfo
-
-# Scan object files for required primitives
-
-PRIMREQ=primreq.cmo
-
-primreq: $(PRIMREQ)
- $(CAMLC) $(LINKFLAGS) -o primreq config.cmo $(PRIMREQ)
-
-clean::
- rm -f primreq
-
-# Common stuff
-
-.SUFFIXES:
-.SUFFIXES: .ml .cmo .mli .cmi
-
-.ml.cmo:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-.mli.cmi:
- $(CAMLC) -c $(COMPFLAGS) $<
-
-clean::
- rm -f *.cmo *.cmi
-
-depend: beforedepend
- $(CAMLRUN) ./ocamldep $(INCLUDES) *.mli *.ml > .depend
-
-include .depend
diff --git a/tools/OCamlc-custom b/tools/OCamlc-custom
deleted file mode 100644
index c389974e2b..0000000000
--- a/tools/OCamlc-custom
+++ /dev/null
@@ -1,10 +0,0 @@
-# OCamlc with option -custom
-# Macintosh version
-
-set echo 0
-set -e ocamlcommands "{tempfolder}"OCaml.temp."`date -n`"
-echo >"{ocamlcommands}"
-ocamlc -custom {"parameters"}
-execute "{ocamlcommands}"
-
-delete -y "{ocamlcommands}"
diff --git a/tools/Time b/tools/Time
deleted file mode 100644
index 0a8267465b..0000000000
--- a/tools/Time
+++ /dev/null
@@ -1,10 +0,0 @@
-# Time # Measure execution time
-# Usage: Time command argumentsÉ
-
-set echo 0
-
-set startdate `date -n`
-{parameters}
-set enddate `date -n`
-
-echo "# Time: `evaluate {enddate} - {startdate}` s" > dev:stderr
diff --git a/tools/addlabels.ml b/tools/addlabels.ml
deleted file mode 100644
index 5a98e161e1..0000000000
--- a/tools/addlabels.ml
+++ /dev/null
@@ -1,451 +0,0 @@
-(* $Id$ *)
-
-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_fun (lab, _, rem) ->
- let (labs, meths) = labels_of_cty rem in
- (lab :: labs, meths)
- | Pcty_signature (_, fields) ->
- ([],
- List.fold_left fields ~init:[] ~f:
- begin fun meths -> function
- 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]
- | Ppat_alias (pat, s) ->
- s :: 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_any | Ppat_constant _ | Ppat_construct _ | Ppat_variant _
- | Ppat_type _ ->
- []
-
-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 -> 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 -> 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(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(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(Longident.Lident s)},meth)}, args) ->
- begin try
- if SMap.find s values = ["<object>"] 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 (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, _) ->
- 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] 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_assertfalse | Pexp_object _ ->
- ()
-
-let rec add_labels_class ~text ~classes ~values ~methods cl =
- match cl.pcl_desc with
- Pcl_constr _ -> ()
- | Pcl_structure (p, 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 ["<object>"] values)
- ~f:(fun m (k,l) -> SMap.add (s^"#"^k) l m)
- in
- List.fold_left l ~init:values ~f:
- begin fun values -> function
- | Pcf_val (s, _, e, _) ->
- add_labels_expr ~text ~classes ~values e;
- SMap.removes [s] values
- | Pcf_meth (s, _, e, _) ->
- begin try
- let labels = List.assoc s 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_virt _ | Pcf_cstr _ -> values
- | Pcf_let _ -> values (* not in the grammar *)
- 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.map 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 (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 (labels_of_cty cty) classes
- end)
- | _ ->
- acc
- end
- in
- let text = input_file file in
- 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 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 values in
- insert_labels_type ~labels ~text sty;
- (SMap.removes [s] values, classes)
- with Not_found -> acc
- end
- | Pstr_class l ->
- let names = List.map l ~f:(fun pci -> pci.pci_name) in
- List.iter l ~f:
- begin fun {pci_name=name; pci_expr=expr} ->
- try
- let (labels, methods) = SMap.find name 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] <files>";
- let files = List.rev !files in
- List.iter files ~f:process_file
-
-let () = main ()
diff --git a/tools/checkstack.c b/tools/checkstack.c
deleted file mode 100644
index 14b5726fb1..0000000000
--- a/tools/checkstack.c
+++ /dev/null
@@ -1,41 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Moscova, INRIA Rocquencourt */
-/* */
-/* Copyright 2002 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <stdio.h>
-#include <sys/types.h>
-#include <sys/time.h>
-#include <sys/resource.h>
-
-#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),
- MINSTACKBYTES / 1024, MINSTACKBYTES / 1024);
- exit (3);
- }
- exit (0);
-}
diff --git a/tools/cleanup-header b/tools/cleanup-header
deleted file mode 100644
index 9c2147573c..0000000000
--- a/tools/cleanup-header
+++ /dev/null
@@ -1,15 +0,0 @@
-#!/bin/sed -f
-# Remove private parts from runtime include files, before installation
-# in /usr/local/lib/ocaml/caml
-
-/\/\* <include \.\.\/config\/m\.h> \*\// {
- r ../config/m.h
- d
-}
-/\/\* <include \.\.\/config\/s\.h> \*\// {
- r ../config/s.h
- d
-}
-/\/\* <private> \*\//,/\/\* <\/private> \*\//d
-
-
diff --git a/tools/cvt_emit.mll b/tools/cvt_emit.mll
deleted file mode 100644
index 3e28ae9722..0000000000
--- a/tools/cvt_emit.mll
+++ /dev/null
@@ -1,84 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-{
-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'] ) +
- { 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/depend.ml b/tools/depend.ml
deleted file mode 100644
index 8871d908df..0000000000
--- a/tools/depend.ml
+++ /dev/null
@@ -1,291 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Format
-open Location
-open Longident
-open Parsetree
-
-module StringSet = Set.Make(struct type t = string let compare = compare end)
-
-(* Collect free module identifiers in the a.s.t. *)
-
-let free_structure_names = ref StringSet.empty
-
-let rec addmodule bv lid =
- match lid with
- Lident s ->
- if not (StringSet.mem s bv)
- then free_structure_names := StringSet.add s !free_structure_names
- | Ldot(l, s) -> addmodule bv l
- | Lapply(l1, l2) -> addmodule bv l1; addmodule bv l2
-
-let add bv lid =
- match lid with
- Ldot(l, s) -> addmodule bv l
- | _ -> ()
-
-let rec add_type bv ty =
- match ty.ptyp_desc with
- Ptyp_any -> ()
- | Ptyp_var v -> ()
- | 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 (add_field_type bv) fl
- | Ptyp_class(c, tl, _) -> add bv c; List.iter (add_type bv) tl
- | Ptyp_alias(t, s) -> 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
-
-and add_field_type bv ft =
- match ft.pfield_desc with
- Pfield(name, ty) -> add_type bv ty
- | Pfield_var -> ()
-
-let add_opt add_fn bv = function
- None -> ()
- | Some x -> add_fn bv x
-
-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 rec add_tkind = function
- Ptype_abstract -> ()
- | Ptype_variant (cstrs, _) ->
- List.iter (fun (c, args) -> List.iter (add_type bv) args) cstrs
- | Ptype_record (lbls, _) ->
- List.iter (fun (l, mut, ty) -> add_type bv ty) lbls in
- add_tkind td.ptype_kind
-
-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 (ty, fieldl) ->
- add_type bv ty;
- List.iter (add_class_type_field bv) fieldl
- | Pcty_fun(_, ty1, cty2) ->
- add_type bv ty1; add_class_type bv cty2
-
-and add_class_type_field bv = function
- Pctf_inher cty -> add_class_type bv cty
- | Pctf_val(_, _, oty, _) -> add_opt add_type bv oty
- | Pctf_virt(_, _, ty, _) -> add_type bv ty
- | Pctf_meth(_, _, ty, _) -> add_type bv ty
- | Pctf_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2
-
-let add_class_description bv infos =
- add_class_type bv infos.pci_expr
-
-let add_class_type_declaration = add_class_description
-
-let rec add_pattern bv pat =
- match pat.ppat_desc with
- Ppat_any -> ()
- | Ppat_var _ -> ()
- | Ppat_alias(p, _) -> add_pattern bv p
- | 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
-
-let rec add_expr bv exp =
- match exp.pexp_desc with
- Pexp_ident l -> add bv l
- | Pexp_constant _ -> ()
- | Pexp_let(_, pel, e) -> add_pat_expr_list bv pel; add_expr bv e
- | Pexp_function (_, opte, pel) ->
- add_opt add_expr bv opte; add_pat_expr_list 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_pat_expr_list bv pel
- | Pexp_try(e, pel) -> add_expr bv e; add_pat_expr_list 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_constraint(e1, oty2, oty3) ->
- add_expr bv e1;
- add_opt add_type bv oty2;
- add_opt add_type bv oty3
- | Pexp_when(e1, e2) -> add_expr bv e1; add_expr bv e2
- | Pexp_send(e, m) -> add_expr bv e
- | Pexp_new l -> add bv l
- | 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) ->
- add_module bv m; add_expr (StringSet.add id bv) e
- | Pexp_assert (e) -> add_expr bv e
- | Pexp_assertfalse -> ()
- | Pexp_lazy (e) -> add_expr bv e
- | Pexp_poly (e, t) -> add_expr bv e; add_opt add_type bv t
- | Pexp_object (pat, fieldl) ->
- add_pattern bv pat; List.iter (add_class_field bv) fieldl
-and add_pat_expr_list bv pel =
- List.iter (fun (p, e) -> add_pattern bv p; add_expr bv e) pel
-
-and add_modtype bv mty =
- match mty.pmty_desc with
- Pmty_ident l -> add bv l
- | Pmty_signature s -> add_signature bv s
- | Pmty_functor(id, mty1, mty2) ->
- add_modtype bv mty1; add_modtype (StringSet.add id 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)
- cstrl
-
-and add_signature bv = function
- [] -> ()
- | item :: rem -> add_signature (add_sig_item bv item) rem
-
-and add_sig_item bv item =
- match item.psig_desc with
- Psig_value(id, vd) ->
- add_type bv vd.pval_type; bv
- | Psig_type dcls ->
- List.iter (fun (id, td) -> add_type_declaration bv td) dcls; bv
- | Psig_exception(id, args) ->
- List.iter (add_type bv) args; bv
- | Psig_module(id, mty) ->
- add_modtype bv mty; StringSet.add id bv
- | Psig_recmodule decls ->
- let bv' = List.fold_right StringSet.add (List.map fst decls) bv in
- List.iter (fun (id, mty) -> add_modtype bv' mty) decls;
- bv'
- | Psig_modtype(id, mtyd) ->
- begin match mtyd with
- Pmodtype_abstract -> ()
- | Pmodtype_manifest mty -> add_modtype bv mty
- end;
- bv
- | Psig_open lid ->
- addmodule bv lid; bv
- | Psig_include mty ->
- add_modtype bv mty; bv
- | Psig_class cdl ->
- List.iter (add_class_description bv) cdl; bv
- | Psig_class_type cdtl ->
- List.iter (add_class_type_declaration bv) cdtl; bv
-
-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) ->
- add_modtype bv mty;
- add_module (StringSet.add id 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
-
-and add_structure bv item_list =
- List.fold_left add_struct_item bv item_list
-
-and add_struct_item bv item =
- match item.pstr_desc with
- Pstr_eval e ->
- add_expr bv e; bv
- | Pstr_value(id, pel) ->
- add_pat_expr_list bv pel; bv
- | Pstr_primitive(id, vd) ->
- add_type bv vd.pval_type; bv
- | Pstr_type dcls ->
- List.iter (fun (id, td) -> add_type_declaration bv td) dcls; bv
- | Pstr_exception(id, args) ->
- List.iter (add_type bv) args; bv
- | Pstr_exn_rebind(id, l) ->
- add bv l; bv
- | Pstr_module(id, modl) ->
- add_module bv modl; StringSet.add id bv
- | Pstr_recmodule bindings ->
- let bv' =
- List.fold_right StringSet.add
- (List.map (fun (id,_,_) -> id) bindings) bv in
- List.iter
- (fun (id, mty, modl) -> add_modtype bv' mty; add_module bv' modl)
- bindings;
- bv'
- | Pstr_modtype(id, mty) ->
- add_modtype bv mty; bv
- | Pstr_open l ->
- addmodule bv l; bv
- | Pstr_class cdl ->
- List.iter (add_class_declaration bv) cdl; bv
- | Pstr_class_type cdtl ->
- List.iter (add_class_type_declaration bv) cdtl; bv
- | Pstr_include modl ->
- add_module bv modl; bv
-
-and add_use_file bv top_phrs =
- ignore (List.fold_left add_top_phrase bv top_phrs)
-
-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(pat, fieldl) ->
- add_pattern bv pat; List.iter (add_class_field bv) fieldl
- | Pcl_fun(_, _, pat, ce) ->
- add_pattern bv pat; 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(_, pel, ce) ->
- add_pat_expr_list bv pel; add_class_expr bv ce
- | Pcl_constraint(ce, ct) ->
- add_class_expr bv ce; add_class_type bv ct
-
-and add_class_field bv = function
- Pcf_inher(ce, _) -> add_class_expr bv ce
- | Pcf_val(_, _, e, _) -> add_expr bv e
- | Pcf_virt(_, _, ty, _) -> add_type bv ty
- | Pcf_meth(_, _, e, _) -> add_expr bv e
- | Pcf_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2
- | Pcf_let(_, pel, _) -> add_pat_expr_list bv pel
- | Pcf_init e -> add_expr bv e
-
-and add_class_declaration bv decl =
- add_class_expr bv decl.pci_expr
-
diff --git a/tools/depend.mli b/tools/depend.mli
deleted file mode 100644
index a13870610b..0000000000
--- a/tools/depend.mli
+++ /dev/null
@@ -1,23 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Module dependencies. *)
-
-module StringSet : Set.S with type elt = string
-
-val free_structure_names : StringSet.t ref
-
-val add_use_file : StringSet.t -> Parsetree.toplevel_phrase list -> unit
-
-val add_signature : StringSet.t -> Parsetree.signature -> unit
diff --git a/tools/dumpapprox.ml b/tools/dumpapprox.ml
deleted file mode 100644
index 3387e7e9a2..0000000000
--- a/tools/dumpapprox.ml
+++ /dev/null
@@ -1,100 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Dump a .cmx file *)
-
-open Config
-open Format
-open Clambda
-open Compilenv
-
-let print_digest ppf d =
- for i = 0 to String.length d - 1 do
- print_string(Printf.sprintf "%02x" (Char.code d.[i]))
- done
-
-let rec print_approx ppf = function
- Value_closure(fundesc, approx) ->
- printf "@[<2>function %s@ arity %i" fundesc.fun_label fundesc.fun_arity;
- if fundesc.fun_closed then begin
- printf "@ (closed)"
- end;
- if fundesc.fun_inline <> None then begin
- printf "@ (inline)"
- end;
- printf "@ -> @ %a@]" print_approx approx
- | Value_tuple approx ->
- let tuple ppf approx =
- for i = 0 to Array.length approx - 1 do
- if i > 0 then printf ";@ ";
- printf "%i: %a" i print_approx approx.(i)
- done in
- printf "@[<hov 1>(%a)@]" tuple approx
- | Value_unknown ->
- print_string "_"
- | Value_integer n ->
- print_int n
- | Value_constptr n ->
- print_int n; print_string "p"
-
-let print_name_crc (name, crc) =
- printf "@ %s (%a)" name print_digest crc
-
-let print_infos (ui, crc) =
- printf "Name: %s@." ui.ui_name;
- printf "CRC of implementation: %a@." print_digest crc;
- printf "@[<hov 2>Globals defined:";
- List.iter (fun s -> printf "@ %s" s) ui.ui_defines;
- printf "@]@.";
- let pr_imports ppf imps = List.iter print_name_crc imps in
- printf "@[<v 2>Interfaces imported:%a@]@." pr_imports ui.ui_imports_cmi;
- printf "@[<v 2>Implementations imported:%a@]@." pr_imports ui.ui_imports_cmx;
- printf "@[<v 2>Approximation:@ %a@]@." print_approx ui.ui_approx;
- let pr_funs ppf fns =
- List.iter (fun arity -> printf "@ %i" arity) fns in
- printf "@[<2>Currying functions:%a@]@." pr_funs ui.ui_curry_fun;
- printf "@[<2>Apply functions:%a@]@." pr_funs ui.ui_apply_fun
-
-let print_unit_info filename =
- let ic = open_in_bin filename in
- try
- let buffer = String.create (String.length cmx_magic_number) in
- really_input ic buffer 0 (String.length cmx_magic_number);
- if buffer = cmx_magic_number then begin
- let ui = (input_value ic : unit_infos) in
- let crc = Digest.input ic in
- close_in ic;
- print_infos (ui, crc)
- end else if buffer = cmxa_magic_number then begin
- let li = (input_value ic : library_infos) in
- close_in ic;
- List.iter print_infos li.lib_units
- end else begin
- close_in ic;
- prerr_endline "Wrong magic number";
- exit 2
- end
- with End_of_file | Failure _ ->
- close_in ic;
- prerr_endline "Error reading file";
- exit 2
-
-let main () =
- print_unit_info Sys.argv.(1);
- exit 0
-
-let _ = main ()
-
-
-
diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml
deleted file mode 100644
index 5a6fa6d4ea..0000000000
--- a/tools/dumpobj.ml
+++ /dev/null
@@ -1,534 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Disassembler for executable and .cmo object files *)
-
-open Obj
-open Printf
-open Config
-open Asttypes
-open Lambda
-open Emitcode
-open Opcodes
-open Instruct
-open Opnames
-
-(* 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_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 rec print_obj x =
- if Obj.is_block x then begin
- match Obj.tag x with
- 252 -> (* string *)
- printf "%S" (Obj.magic x : string)
- | 253 -> (* float *)
- printf "%.12g" (Obj.magic x : float)
- | 254 -> (* float array *)
- 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 "|]"
- | _ ->
- printf "<%d>" (Obj.tag x);
- begin 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
- 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 "<wrong reloc>"
- with Not_found ->
- print_string "<no reloc>"
- end;
- ignore (inputu ic);
- end
- else begin
- let n = inputu ic in
- if n >= Array.length !globals || n < 0
- then print_string "<global table overflow>"
- 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 "<wrong reloc>"
- with Not_found ->
- print_string "<no reloc>"
- end;
- ignore (inputu ic);
- end
- else begin
- let n = inputu ic in
- if n >= Array.length !globals || n < 0
- then print_string "<global table overflow>"
- 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 "<wrong reloc>"
- with Not_found ->
- print_string "<no reloc>"
- 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
-;;
-
-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;
- 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;
-];;
-
-let print_event ev =
- printf "File \"%s\", line %d, character %d:\n" ev.ev_char.Lexing.pos_fname
- ev.ev_char.Lexing.pos_lnum
- (ev.ev_char.Lexing.pos_cnum - ev.ev_char.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);
- print_string " ";
- begin try match List.assoc op op_shapes 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 + inputu ic);
- done;
- | 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 filename ic =
- let buffer = String.create (String.length cmo_magic_number) in
- really_input ic buffer 0 (String.length cmo_magic_number);
- if buffer <> cmo_magic_number then begin
- 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 cu.cu_debug > 0 then begin
- seek_in ic cu.cu_debug;
- let evl = (input_value ic : debug_event list) in
- 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 = String.create len in
- really_input ic p 0 len;
- let rec split beg cur =
- if cur >= len then []
- else if p.[cur] = '\000' then
- String.sub p beg (cur - beg) :: split (cur + 1) (cur + 1)
- else
- split beg (cur + 1) in
- Array.of_list(split 0 0)
-
-(* 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.create (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
- record_events orig evl
- done
- with Not_found -> ()
- end;
- let code_size = Bytesections.seek_section ic "CODE" in
- print_code ic code_size
-
-let main() =
- for i = 1 to Array.length Sys.argv - 1 do
- let ic = open_in_bin Sys.argv.(i) in
- begin try
- objfile := false; dump_exe ic
- with Bytesections.Bad_magic_number ->
- objfile := true; seek_in ic 0; dump_obj (Sys.argv.(i)) ic
- end;
- close_in ic
- done;
- exit 0
-
-let _ = Printexc.catch main (); exit 0
diff --git a/tools/keywords.r b/tools/keywords.r
deleted file mode 100644
index 2a9054c8e0..0000000000
--- a/tools/keywords.r
+++ /dev/null
@@ -1,121 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Damien Doligez, projet Para, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-type 'Odds' {
- longint; /* resource ID of corresponding 'Sods' */
- longint = $$CountOf (suffixes);
- wide array suffixes { pstring; };
-};
-
-type 'Sods' {
- longint = 0xA5666D66;
- pstring; /* default token breaks */
- longint = $$CountOf (keywords);
- wide array keywords {
- pstring; /* the keyword itself */
- longint /* the keyword type */
- case=0,
- caseWord=1,
- noCase=2,
- noCaseWord=3,
- line=4,
- mystery=0xB,
- opening=0x10000,
- closing=0x20000,
- openingFill=0x50000,
- closingFill=0x60000,
- quote=0x80000;
- literal longint; /* scoping parameter */
- longint /* color */
- red=0,
- blue=1,
- bluegreen=2,
- bluepurple=3,
- grey=4,
- darkgreen=7,
- black=255;
- };
-};
-
-resource 'Odds' (26087, "O'Caml") {
- 26087,
- { ".ml", ".mli", ".mll", ".mly", ".mlp" }
-};
-
-resource 'Sods' (26087, "O'Caml Keywords") {
- "\t\r\n ~!$%^&*()/-+=<>,[]{};",
- {
- "(*", openingFill, '(**)', red,
- "*)", closingFill, '(**)', red,
- "\"", quote, 0, grey,
-#define KEY caseWord, 0, blue
- "and", KEY,
- "as", KEY,
- "assert", KEY,
- "begin", KEY,
- "class", KEY,
- "constraint", KEY,
- "do", KEY,
- "done", KEY,
- "downto", KEY,
- "else", KEY,
- "end", KEY,
- "exception", KEY,
- "external", KEY,
- "false", KEY,
- "for", KEY,
- "fun", KEY,
- "function", KEY,
- "functor", KEY,
- "if", KEY,
- "in", KEY,
- "include", KEY,
- "inherit", KEY,
- "initializer", KEY,
- "lazy", KEY,
- "let", KEY,
- "match", KEY,
- "method", KEY,
- "module", KEY,
- "mutable", KEY,
- "new", KEY,
- "object", KEY,
- "of", KEY,
- "open", KEY,
- "or", KEY,
- "parser", KEY,
- "private", KEY,
- "rec", KEY,
- "sig", KEY,
- "struct", KEY,
- "then", KEY,
- "to", KEY,
- "true", KEY,
- "try", KEY,
- "type", KEY,
- "val", KEY,
- "virtual", KEY,
- "when", KEY,
- "while", KEY,
- "with", KEY,
- "mod", KEY,
- "land", KEY,
- "lor", KEY,
- "lxor", KEY,
- "lsl", KEY,
- "lsr", KEY,
- "asr", KEY,
- }
-};
diff --git a/tools/lexer299.mll b/tools/lexer299.mll
deleted file mode 100644
index afdabbd6aa..0000000000
--- a/tools/lexer299.mll
+++ /dev/null
@@ -1,472 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* The lexer 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
- | 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
- | SHARP
- | 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 =
- match Sys.os_type with
- | "Unix" | "Win32" ->
- begin function
- | 'n' -> '\010'
- | 'r' -> '\013'
- | 'b' -> '\008'
- | 't' -> '\009'
- | c -> c
- end
- | "MacOS" ->
- begin function
- | 'n' -> '\013'
- | 'r' -> '\010'
- | 'b' -> '\008'
- | 't' -> '\009'
- | c -> c
- end
- | x -> fatal_error "Lexer: unknown system type"
-
-let char_for_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.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 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 lexbuf;
- Location.loc_end = Lexing.lexeme_end lexbuf - 1;
- Location.loc_ghost = false }
- and warn = Warnings.Comment "the start of a comment"
- in
- Location.prerr_warning loc warn;
- comment_start_pos := [Lexing.lexeme_start lexbuf];
- comment lexbuf;
- token lexbuf
- }
- | "*)"
- { let loc = { Location.loc_start = Lexing.lexeme_start lexbuf;
- Location.loc_end = Lexing.lexeme_end lexbuf;
- Location.loc_ghost = false }
- and warn = Warnings.Comment "not the end of a comment"
- 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 }
- | "#" { SHARP }
- | "&" { 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
deleted file mode 100644
index 33beb041fa..0000000000
--- a/tools/lexer301.mll
+++ /dev/null
@@ -1,474 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* The lexer 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
- | 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
- | SHARP
- | 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 =
- match Sys.os_type with
- | "Unix" | "Win32" | "Cygwin" ->
- begin function
- | 'n' -> '\010'
- | 'r' -> '\013'
- | 'b' -> '\008'
- | 't' -> '\009'
- | c -> c
- end
- | "MacOS" ->
- begin function
- | 'n' -> '\013'
- | 'r' -> '\010'
- | 'b' -> '\008'
- | 't' -> '\009'
- | c -> c
- end
- | x -> fatal_error "Lexer: unknown system type"
-
-let char_for_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 "the start of a comment"
- 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 the end of a comment"
- 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 }
- | "#" { SHARP }
- | "&" { 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/magic b/tools/magic
deleted file mode 100644
index 7468066e01..0000000000
--- a/tools/magic
+++ /dev/null
@@ -1,11 +0,0 @@
-# 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 Objective Caml
->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-opcodes b/tools/make-opcodes
deleted file mode 100644
index c8f573c682..0000000000
--- a/tools/make-opcodes
+++ /dev/null
@@ -1,2 +0,0 @@
-$1=="enum" {n=0; next; }
- {for (i = 1; i <= NF; i++) {printf("let op%s = %d\n", $i, n++);}}
diff --git a/tools/make-opcodes.Mac b/tools/make-opcodes.Mac
deleted file mode 100644
index 0d13822973..0000000000
--- a/tools/make-opcodes.Mac
+++ /dev/null
@@ -1,14 +0,0 @@
-set echo 0
-exit 1 if {#} != 2
-
-catenate "{1}" >"{2}"
-open -t "{2}"
-replace ¥:/¥ / 'let op' "{2}"
-set i 0
-loop
- replace /,[ ¶n]+/ " = {i}¶nlet op" "{2}" || break
- evaluate i += 1
-end
-replace /¥[Â ]/:° " = {i}¶n" "{2}"
-
-close -y "{2}"
diff --git a/tools/make-package-macosx b/tools/make-package-macosx
deleted file mode 100755
index 8f574d9c0c..0000000000
--- a/tools/make-package-macosx
+++ /dev/null
@@ -1,52 +0,0 @@
-#!/bin/sh
-
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Damien Doligez, projet Moscova, INRIA Rocquencourt #
-# #
-# Copyright 2003 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-cd package-macosx
-rm -rf ocaml.pkg ocaml-rw.dmg ocaml.dmg
-
-cat >ocaml.info <<EOF
- Title Objective Caml
- Version 3.06
- Description This package installs Objective Caml version 3.06
- DefaultLocation /
- Relocatable no
- NeedsAuthorization yes
- Application no
- InstallOnly no
- DisableStop no
-EOF
-
-package root ocaml.info
-
-size=`du -s ocaml.pkg | cut -f 1`
-size=`expr $size + 8192`
-
-hdiutil create -sectors $size ocaml-rw.dmg
-name=`hdid -nomount ocaml-rw.dmg | grep Apple_HFS | cut -d ' ' -f 1`
-newfs_hfs -v 'Objective Caml' $name
-hdiutil detach $name
-
-name=`hdid ocaml-rw.dmg | grep Apple_HFS | cut -d ' ' -f 1`
-if test -d '/Volumes/Objective Caml'; then
- ditto -rsrcFork ocaml.pkg "/Volumes/Objective Caml/ocaml.pkg"
-else
- echo 'Unable to mount the disk image as "/Volumes/Objective Caml"' >&2
- exit 3
-fi
-open "/Volumes/Objective Caml"
-hdiutil detach $name
-
-hdiutil convert ocaml-rw.dmg -format UDZO -o ocaml.dmg
diff --git a/tools/objinfo.ml b/tools/objinfo.ml
deleted file mode 100644
index 09f78b7f33..0000000000
--- a/tools/objinfo.ml
+++ /dev/null
@@ -1,101 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Dump a compilation unit description *)
-
-open Config
-open Emitcode
-
-let print_digest d =
- for i = 0 to String.length d - 1 do
- Printf.printf "%02x" (Char.code d.[i])
- done
-
-let print_info cu =
- print_string " Unit name: "; print_string cu.cu_name; print_newline();
- print_string " Interfaces imported:"; print_newline();
- List.iter
- (fun (name, digest) ->
- print_string "\t"; print_digest digest; print_string "\t";
- print_string name; print_newline())
- cu.cu_imports;
- print_string " Uses unsafe features: ";
- begin match cu.cu_primitives with
- [] -> print_string "no"; print_newline()
- | l -> print_string "YES"; print_newline();
- print_string " Primitives declared in this module:";
- print_newline();
- List.iter
- (fun name -> print_string "\t"; print_string name; print_newline())
- l
- end
-
-let print_spaced_string s = print_char ' '; print_string s
-
-let print_library_info lib =
- print_string " Force custom: ";
- print_string (if lib.lib_custom then "YES" else "no");
- print_newline();
- print_string " Extra C object files:";
- List.iter print_spaced_string lib.lib_ccobjs; print_newline();
- print_string " Extra C options:";
- List.iter print_spaced_string lib.lib_ccopts; print_newline();
- List.iter print_info lib.lib_units
-
-let print_intf_info name sign comps crcs =
- print_string " Module name: "; print_string name; print_newline();
- print_string " Interfaces imported:"; print_newline();
- List.iter
- (fun (name, digest) ->
- print_string "\t"; print_digest digest; print_string "\t";
- print_string name; print_newline())
- crcs
-
-let dump_obj filename =
- print_string "File "; print_string filename; print_newline();
- let ic = open_in_bin filename in
- let buffer = String.create (String.length cmo_magic_number) in
- really_input ic buffer 0 (String.length cmo_magic_number);
- if buffer = cmo_magic_number then begin
- let cu_pos = input_binary_int ic in
- seek_in ic cu_pos;
- let cu = (input_value ic : compilation_unit) in
- close_in ic;
- print_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;
- print_library_info toc
- end else
- if buffer = cmi_magic_number then begin
- let (name, sign, comps) = input_value ic in
- let crcs = input_value ic in
- close_in ic;
- print_intf_info name sign comps crcs
- end else begin
- prerr_endline "Not an object file"; exit 2
- end
-
-let main() =
- for i = 1 to Array.length Sys.argv - 1 do
- dump_obj Sys.argv.(i)
- done;
- exit 0
-
-let _ = Printexc.catch main (); exit 0
-
-
diff --git a/tools/ocaml299to3.ml b/tools/ocaml299to3.ml
deleted file mode 100644
index b1dca8daaf..0000000000
--- a/tools/ocaml299to3.ml
+++ /dev/null
@@ -1,139 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* 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 Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-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 <source file> ...";
- print_endline "Description:";
- print_endline
- "Convert Objective Caml 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 <file>.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
deleted file mode 100644
index 73824d5646..0000000000
--- a/tools/ocamlcp.ml
+++ /dev/null
@@ -1,134 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1998 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-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 <options> <files>\noptions are:"
-
-let incompatible o =
- fprintf stderr "ocamlcp: profiling is incompatible with the %s option\n" o;
- exit 2
-
-let ismultithreaded = ref ""
-
-module Options = Main_args.Make_options (struct
- let _a () = make_archive := true; option "-a" ()
- 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 _custom = option "-custom"
- let _dllib = option_with_arg "-dllib"
- let _dllpath = option_with_arg "-dllpath"
- let _dtypes = option "-dtypes"
- 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 _labels = option "-labels"
- let _linkall = option "-linkall"
- let _make_runtime = option "-make-runtime"
- 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 _output_obj = option "-output-obj"
- let _pack = option "-pack"
- let _pp s = incompatible "-pp"
- let _principal = option "-principal"
- let _rectypes = option "-rectypes"
- let _thread () = ismultithreaded := "-thread"; option "-thread" ()
- let _vmthread () = ismultithreaded := "-vmthread"; option "-vmthread" ()
- let _unsafe = option "-unsafe"
- 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 _verbose = option "-verbose"
- let _w = option_with_arg "-w"
- let _warn_error = option_with_arg "-warn-error"
- let _where = option "-where"
- let _nopervasives = option "-nopervasives"
- let _dparsetree = option "-dparsetree"
- let _drawlambda = option "-drawlambda"
- let _dlambda = option "-dlambda"
- let _dinstr = option "-dinstr"
- 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:\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 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 %s -instrument %s\" %s %s"
- !ismultithreaded
- (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
deleted file mode 100644
index c791923302..0000000000
--- a/tools/ocamldep.ml
+++ /dev/null
@@ -1,228 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Format
-open Location
-open Longident
-open Parsetree
-
-
-(* Print the dependencies *)
-
-let load_path = ref ([] : (string * string array) list)
-let native_only = ref false
-let force_slash = ref false
-let error_occurred = ref false
-
-let add_to_load_path dir =
- try
- let dir = Misc.expand_directory Config.standard_library dir in
- let contents = Sys.readdir dir in
- load_path := !load_path @ [dir, contents]
- with Sys_error msg ->
- fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg;
- error_occurred := true
-
-let concat_filename dirname filename =
- if dirname = Filename.current_dir_name then filename
- else if !force_slash then dirname ^ "/" ^ filename
- else Filename.concat dirname filename
-
-let find_file name =
- let uname = String.uncapitalize 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 -> concat_filename dir truename
- | None -> find_in_path rem in
- find_in_path !load_path
-
-let find_dependency modname (byt_deps, opt_deps) =
- try
- let filename = find_file (modname ^ ".mli") in
- let basename = Filename.chop_suffix filename ".mli" in
- let optname =
- if Sys.file_exists (basename ^ ".ml")
- then basename ^ ".cmx"
- else basename ^ ".cmi" in
- ((basename ^ ".cmi") :: byt_deps, optname :: opt_deps)
- with Not_found ->
- try
- let filename = find_file (modname ^ ".ml") in
- let basename = Filename.chop_suffix filename ".ml" in
- let bytename =
- basename ^ (if !native_only then ".cmx" else ".cmo") in
- (bytename :: byt_deps, (basename ^ ".cmx") :: opt_deps)
- with Not_found ->
- (byt_deps, opt_deps)
-
-let (depends_on, escaped_eol) =
- match Sys.os_type with
- | "Unix" | "Win32" | "Cygwin" -> (": ", "\\\n ")
- | "MacOS" -> ("\196 ", "\182\n ")
- | _ -> assert false
-
-let print_dependencies target_file deps =
- match deps with
- [] -> ()
- | _ ->
- print_string target_file; print_string depends_on;
- let rec print_items pos = function
- [] -> print_string "\n"
- | dep :: rem ->
- if pos + String.length dep <= 77 then begin
- print_string dep; print_string " ";
- print_items (pos + String.length dep + 1) rem
- end else begin
- print_string escaped_eol; print_string dep; print_string " ";
- print_items (String.length dep + 5) rem
- end in
- print_items (String.length target_file + 2) deps
-
-(* Optionally preprocess a source file *)
-
-let preprocessor = ref None
-
-let preprocess sourcefile =
- match !preprocessor with
- None -> sourcefile
- | Some pp ->
- flush stdout;
- let tmpfile = Filename.temp_file "camlpp" "" in
- let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in
- if Sys.command comm <> 0 then begin
- Misc.remove_file tmpfile;
- Printf.eprintf "Preprocessing error\n";
- exit 2
- end;
- tmpfile
-
-let remove_preprocessed inputfile =
- match !preprocessor with
- None -> ()
- | Some _ -> Misc.remove_file inputfile
-
-(* Parse a file or get a dumped syntax tree in it *)
-
-exception Outdated_version
-
-let is_ast_file ic ast_magic =
- try
- let buffer = String.create (String.length ast_magic) in
- really_input ic buffer 0 (String.length ast_magic);
- if buffer = ast_magic then true
- else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then
- raise Outdated_version
- else false
- with
- Outdated_version ->
- failwith "Ocaml and preprocessor have incompatible versions"
- | _ -> false
-
-let parse_use_file ic =
- if is_ast_file ic Config.ast_impl_magic_number then
- let source_file = input_value ic in
- [Ptop_def (input_value ic : Parsetree.structure)]
- else begin
- seek_in ic 0;
- let lb = Lexing.from_channel ic in
- Parse.use_file lb
- end
-
-let parse_interface ic =
- if is_ast_file ic Config.ast_intf_magic_number then
- let source_file = input_value ic in
- (input_value ic : Parsetree.signature)
- else begin
- seek_in ic 0;
- let lb = Lexing.from_channel ic in
- Parse.interface lb
- end
-
-(* Process one file *)
-
-let file_dependencies source_file =
- Location.input_name := source_file;
- if Sys.file_exists source_file then begin
- try
- Depend.free_structure_names := Depend.StringSet.empty;
- let input_file = preprocess source_file in
- let ic = open_in_bin input_file in
- try
- if Filename.check_suffix source_file ".ml" then begin
- let ast = parse_use_file ic in
- Depend.add_use_file Depend.StringSet.empty ast;
- let basename = Filename.chop_suffix source_file ".ml" in
- let init_deps =
- if Sys.file_exists (basename ^ ".mli")
- then let cmi_name = basename ^ ".cmi" in ([cmi_name], [cmi_name])
- else ([], []) in
- let (byt_deps, opt_deps) =
- Depend.StringSet.fold find_dependency !Depend.free_structure_names init_deps in
- print_dependencies (basename ^ ".cmo") byt_deps;
- print_dependencies (basename ^ ".cmx") opt_deps
- end else
- if Filename.check_suffix source_file ".mli" then begin
- let ast = parse_interface ic in
- Depend.add_signature Depend.StringSet.empty ast;
- let basename = Filename.chop_suffix source_file ".mli" in
- let (byt_deps, opt_deps) =
- Depend.StringSet.fold find_dependency !Depend.free_structure_names ([], []) in
- print_dependencies (basename ^ ".cmi") byt_deps
- end else
- ();
- close_in ic; remove_preprocessed input_file
- with x ->
- close_in ic; remove_preprocessed input_file;
- raise x
- with x ->
- let report_err = function
- | Lexer.Error(err, range) ->
- fprintf Format.err_formatter "@[%a%a@]@."
- Location.print range Lexer.report_error err
- | Syntaxerr.Error err ->
- fprintf Format.err_formatter "@[%a@]@."
- Syntaxerr.report_error err
- | Sys_error msg ->
- fprintf Format.err_formatter "@[I/O error:@ %s@]@." msg
- | x -> raise x in
- error_occurred := true;
- report_err x
- end
-
-(* Entry point *)
-
-let usage = "Usage: ocamldep [-I <dir>] [-native] <files>"
-
-let _ =
- Clflags.classic := false;
- add_to_load_path Filename.current_dir_name;
- Arg.parse [
- "-I", Arg.String add_to_load_path,
- "<dir> Add <dir> to the list of include directories";
- "-native", Arg.Set native_only,
- " Generate dependencies for a pure native-code project \
- (no .cmo files)";
- "-slash", Arg.Set force_slash,
- " (for Windows) Use forward slash / instead of backslash \\ in file paths";
- "-pp", Arg.String(fun s -> preprocessor := Some s),
- "<command> Pipe sources through preprocessor <command>"
- ] file_dependencies usage;
- exit (if !error_occurred then 2 else 0)
diff --git a/tools/ocamlmklib.mlp b/tools/ocamlmklib.mlp
deleted file mode 100644
index 27eecccbc3..0000000000
--- a/tools/ocamlmklib.mlp
+++ /dev/null
@@ -1,250 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Printf
-
-let bindir = "%%BINDIR%%"
-and supports_shared_libraries = %%SUPPORTS_SHARED_LIBRARIES%%
-and mksharedlib = "%%MKSHAREDLIB%%"
-and bytecc_rpath = "%%BYTECCRPATH%%"
-and nativecc_rpath = "%%NATIVECCRPATH%%"
-and mksharedlib_rpath = "%%MKSHAREDLIBRPATH%%"
-and ranlib = "%%RANLIB%%"
-
-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 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_opts = ref [] (* options to pass to mksharedlib and ocamlc -ccopt *)
-and ld_opts = ref [] (* options to pass only to the linker *)
-and ocamlc = ref (Filename.concat bindir "ocamlc")
-and ocamlopt = ref (Filename.concat bindir "ocamlopt")
-and output = ref "a" (* Output name for Caml part of library *)
-and output_c = ref "" (* Output name for C part of library *)
-and rpath = ref [] (* rpath options *)
-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 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 ends_with s ".o" || ends_with s ".a" 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 = "-h" || 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_opts := s :: !c_opts;
- let l = chop_prefix s "-L" in
- if not (Filename.is_relative l) then rpath := l :: !rpath)
- else if s = "-ocamlc" then
- ocamlc := next_arg ()
- else if s = "-ocamlopt" then
- ocamlopt := next_arg ()
- 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 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; c_objs; caml_libs; caml_opts;
- c_libs; c_objs; c_opts; ld_opts; rpath ];
- if !output_c = "" then output_c := !output
-
-let usage = "\
-Usage: ocamlmklib [options] <.cmo|.cma|.cmx|.cmxa|.ml|.mli|.o|.a files>
-Options are:
- -cclib <lib> C library passed to ocamlc -a or ocamlopt -a only
- -ccopt <opt> C option passed to ocamlc -a or ocamlopt -a only
- -custom disable dynamic loading
- -dllpath <dir> Add <dir> to the run-time search path for DLLs
- -I <dir> Add <dir> to the path searched for Caml object files
- -failsafe fall back to static linking if DLL construction failed
- -ldopt <opt> C option passed to the shared linker only
- -linkall Build Caml archive with link-all behavior
- -l<lib> Specify a dependent C library
- -L<dir> Add <dir> to the path searched for C libraries
- -ocamlc <cmd> Use <cmd> in place of \"ocamlc\"
- -ocamlopt <cmd> Use <cmd> in place of \"ocamlopt\"
- -o <name> Generated Caml library is named <name>.cma or <name>.cmxa
- -oc <name> Generated C library is named lib<name>.so or lib<name>.a
- -rpath <dir> Same as -dllpath <dir>
- -R<dir> Same as -rpath
- -verbose Print commands before executing them
- -Wl,-rpath,<dir> Same as -dllpath <dir>
- -Wl,-rpath -Wl,<dir> Same as -dllpath <dir>
- -Wl,-R<dir> Same as -dllpath <dir>
- -F<dir> Specify a framework directory (MacOSX)
- -framework <name> Use framework <name> (MacOSX)
-"
-
-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 build_libs () =
- if !c_objs <> [] then begin
- if !dynlink then begin
- let retcode = command
- (sprintf "%s dll%s.so %s %s %s %s %s"
- mksharedlib
- !output_c
- (String.concat " " !c_objs)
- (String.concat " " !c_opts)
- (String.concat " " !ld_opts)
- (make_rpath mksharedlib_rpath)
- (String.concat " " !c_libs)) in
- if retcode <> 0 then if !failsafe then dynlink := false else exit 2
- end;
- safe_remove ("lib" ^ !output_c ^ ".a");
- scommand
- (sprintf "ar rc lib%s.a %s"
- !output_c
- (String.concat " " !c_objs));
- scommand
- (sprintf "%s lib%s.a"
- ranlib
- !output_c)
- end;
- if !bytecode_objs <> [] then
- scommand
- (sprintf "%s -a %s -o %s.cma %s %s -dllib -l%s -cclib -l%s %s %s %s %s"
- !ocamlc
- (if !dynlink then "" else "-custom")
- !output
- (String.concat " " !caml_opts)
- (String.concat " " !bytecode_objs)
- !output_c
- !output_c
- (String.concat " " (prefix_list "-ccopt " !c_opts))
- (make_rpath_ccopt bytecc_rpath)
- (String.concat " " (prefix_list "-cclib " !c_libs))
- (String.concat " " !caml_libs));
- if !native_objs <> [] then
- scommand
- (sprintf "%s -a -o %s.cmxa %s %s -cclib -l%s %s %s %s %s"
- !ocamlopt
- !output
- (String.concat " " !caml_opts)
- (String.concat " " !native_objs)
- !output_c
- (String.concat " " (prefix_list "-ccopt " !c_opts))
- (make_rpath_ccopt nativecc_rpath)
- (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
deleted file mode 100644
index 3d353a8f59..0000000000
--- a/tools/ocamlmktop.ml
+++ /dev/null
@@ -1,17 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-let _ =
- let args = Ccomp.quote_files (List.tl (Array.to_list Sys.argv)) in
- exit(Sys.command("ocamlc -linkall toplevellib.cma " ^ args ^ " topstart.cmo"))
diff --git a/tools/ocamlmktop.tpl b/tools/ocamlmktop.tpl
deleted file mode 100644
index 01c1ec9cbf..0000000000
--- a/tools/ocamlmktop.tpl
+++ /dev/null
@@ -1,26 +0,0 @@
-#!/bin/sh
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-
-# Multi-shell script. Works under Bourne Shell, MPW Shell, zsh.
-
-if : == x
-then # Bourne Shell or zsh
- exec %%BINDIR%%/ocamlc -linkall toplevellib.cma "$@" topstart.cmo
-else # MPW Shell
- ocamlc -linkall toplevellib.cma {"parameters"} topstart.cmo
- exit {status}
-End # uppercase E because "end" is a keyword in zsh
-fi
diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
deleted file mode 100644
index f1b637baf2..0000000000
--- a/tools/ocamlprof.ml
+++ /dev/null
@@ -1,482 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* 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 Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Printf
-
-open Clflags
-open Config
-open Location
-open Misc
-open Parsetree
-
-(* User programs must not use identifiers that start with this prefix. *)
-let idprefix = "__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 = String.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
- | Close -> fprintf !outchan ")";
- | Open ->
- fprintf !outchan
- "(%s_cnt_%s_.(%d) <- Pervasives.succ %s_cnt_%s_.(%d); "
- idprefix modul !prof_counter idprefix modul !prof_counter;
- incr prof_counter;
-;;
-
-let counters = ref (Array.create 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 "let %s_cnt_%s_ = Array.create 0000000" idprefix mod_name;
- pos_len := pos_out !outchan;
- fprintf !outchan
- " 0;; Profiling.counters := \
- (\"%s\", (\"%s\", %s_cnt_%s_)) :: !Profiling.counters;; "
- mod_name modes idprefix mod_name
- end
-
-let final_rewrite add_function =
- to_insert := Sort.list (fun x y -> 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 > 7 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 snd l)
-
-and rewrite_patlexp_list iflag l =
- rewrite_exp_list iflag (List.map snd 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 && not sexp.pexp_loc.loc_ghost then
- rewrite_function iflag caselist
- else
- rewrite_patlexp_list iflag caselist
-
- | Pexp_match(sarg, caselist) ->
- rewrite_exp iflag sarg;
- if !instr_match && not sexp.pexp_loc.loc_ghost then
- rewrite_funmatching caselist
- else
- rewrite_patlexp_list 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_patexp_list 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, _, _) ->
- rewrite_exp iflag sarg
-
- | Pexp_when(scond, sbody) ->
- rewrite_exp iflag scond;
- rewrite_exp iflag sbody
-
- | 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_assert (cond) -> rewrite_exp iflag cond
- | Pexp_assertfalse -> ()
-
- | Pexp_lazy (expr) -> rewrite_exp iflag expr
-
- | Pexp_poly (sexp, _) -> rewrite_exp iflag sexp
-
- | Pexp_object (_, fieldl) ->
- List.iter (rewrite_class_field iflag) fieldl
-
-and rewrite_ifbody iflag ghost sifbody =
- if !instr_if && not ghost then
- insert_profile rw_exp sifbody
- else
- rewrite_exp iflag sifbody
-
-(* called only when !instr_fun *)
-and rewrite_annotate_exp_list l =
- List.iter
- (function
- | {pexp_desc = Pexp_when(scond, sbody)}
- -> insert_profile rw_exp scond;
- insert_profile rw_exp sbody;
- | {pexp_desc = Pexp_constraint(sbody, _, _)} (* let f x : t = e *)
- -> insert_profile rw_exp sbody
- | sexp -> insert_profile rw_exp sexp)
- l
-
-and rewrite_function iflag = function
- | [spat, ({pexp_desc = Pexp_function _} as sexp)] -> rewrite_exp iflag sexp
- | l -> rewrite_funmatching l
-
-and rewrite_funmatching l =
- rewrite_annotate_exp_list (List.map snd l)
-
-and rewrite_trymatching l =
- rewrite_annotate_exp_list (List.map snd l)
-
-(* Rewrite a class definition *)
-
-and rewrite_class_field iflag =
- function
- Pcf_inher (cexpr, _) -> rewrite_class_expr iflag cexpr
- | Pcf_val (_, _, sexp, _) -> rewrite_exp iflag sexp
- | Pcf_meth (_, _, ({pexp_desc = Pexp_function _} as sexp), _) ->
- rewrite_exp iflag sexp
- | Pcf_meth (_, _, sexp, loc) ->
- if !instr_fun && not loc.loc_ghost then insert_profile rw_exp sexp
- else rewrite_exp iflag sexp
- | Pcf_let(_, spat_sexp_list, _) ->
- rewrite_patexp_list iflag spat_sexp_list
- | Pcf_init sexp ->
- rewrite_exp iflag sexp
- | Pcf_virt _ | Pcf_cstr _ -> ()
-
-and rewrite_class_expr iflag cexpr =
- match cexpr.pcl_desc with
- Pcl_constr _ -> ()
- | Pcl_structure (_, fields) ->
- List.iter (rewrite_class_field iflag) 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
-
-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 lid -> ()
- | 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
-
-and rewrite_str_item iflag item =
- match item.pstr_desc with
- Pstr_eval exp -> rewrite_exp iflag exp
- | Pstr_value(_, exps)
- -> List.iter (function (_,exp) -> rewrite_exp iflag exp) exps
- | Pstr_module(name, smod) -> rewrite_mod iflag smod
- | 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
- 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 <options> <files>\noptions are:"
-
-let main () =
- try
- Arg.parse [
- "-f", Arg.String (fun s -> dumpfile := s),
- "<file> Use <file> as dump file (default ocamlprof.dump)";
- "-F", Arg.String (fun s -> special_id := s),
- "<s> Insert string <s> with the counts";
- "-impl", Arg.String process_impl_file,
- "<file> Process <file> as a .ml file";
- "-instrument", Arg.Set instr_mode, " (undocumented)";
- "-intf", Arg.String process_intf_file,
- "<file> Process <file> as a .mli file";
- "-m", Arg.String (fun s -> modes := s), "<flags> (undocumented)"
- ] process_anon_file usage;
- exit 0
- with x ->
- let report_error ppf = function
- | Lexer.Error(err, range) ->
- fprintf ppf "@[%a%a@]@."
- Location.print range Lexer.report_error err
- | Syntaxerr.Error err ->
- fprintf ppf "@[%a@]@."
- Syntaxerr.report_error err
- | Profiler msg ->
- fprintf ppf "@[%s@]@." msg
- | Sys_error msg ->
- fprintf ppf "@[I/O error:@ %s@]@." msg
- | x -> raise x in
- report_error Format.err_formatter x;
- exit 2
-
-let _ = main ()
diff --git a/tools/ocamlsize b/tools/ocamlsize
deleted file mode 100755
index 659543d593..0000000000
--- a/tools/ocamlsize
+++ /dev/null
@@ -1,49 +0,0 @@
-#!/usr/bin/perl
-
-foreach $f (@ARGV) {
- open(FILE, $f) || die("Cannot open $f");
- seek(FILE, -16, 2);
- $num_sections = do 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] = do read_int();
- $length{$sec} = $seclength[$i];
- }
- print $f, ":\n" if ($#ARGV > 0);
- $path =
- $length{'RNTM'} > 0 ?
- do 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
deleted file mode 100644
index cfd6e9af00..0000000000
--- a/tools/primreq.ml
+++ /dev/null
@@ -1,90 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1999 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Determine the set of C primitives required by the given .cmo and .cma
- files *)
-
-open Config
-open Emitcode
-
-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 = String.create (String.length cmo_magic_number) in
- really_input ic buffer 0 (String.length cmo_magic_number);
- if buffer = cmo_magic_number then begin
- let 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
- ["-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),
- "<file> don't print the primitives mentioned in <file>"]
- 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 _ = Printexc.catch main (); exit 0
diff --git a/tools/profiling.ml b/tools/profiling.ml
deleted file mode 100644
index 75fe03b96e..0000000000
--- a/tools/profiling.ml
+++ /dev/null
@@ -1,53 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* 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 Library General Public License, with *)
-(* the special exception on linking described in file ../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Run-time library for profiled programs *)
-
-type profiling_counters = (string * (string * int array)) list
-
-let counters = ref ([] : profiling_counters)
-
-exception Bad_profile
-
-let dump_counters () =
- begin try
- let ic = open_in_bin "ocamlprof.dump" 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 "ocamlprof.dump" 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
deleted file mode 100644
index 7a6170e966..0000000000
--- a/tools/profiling.mli
+++ /dev/null
@@ -1,19 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Damien Doligez and Francois Rouaix, INRIA Rocquencourt *)
-(* Ported to Objective Caml 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 Library General Public License, with *)
-(* the special exception on linking described in file ../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Run-time library for profiled programs *)
-
-val counters: (string * (string * int array)) list ref
diff --git a/tools/scrapelabels.ml b/tools/scrapelabels.ml
deleted file mode 100644
index 26512e0a05..0000000000
--- a/tools/scrapelabels.ml
+++ /dev/null
@@ -1,289 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* 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 Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-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),
- "<module> remove also labels for <module>";
- "-noopen", Arg.Set noopen,
- " do not insert `open' statements for -keepstd/-keepmore" ]
- (fun s -> files := s :: !files)
- ("Usage: scrapelabels <options> <source files>\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 <file>.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/toplevel/expunge.ml b/toplevel/expunge.ml
deleted file mode 100644
index 1b52d1bc64..0000000000
--- a/toplevel/expunge.ml
+++ /dev/null
@@ -1,83 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* "Expunge" a toplevel by removing compiler modules from the global List.map.
- Usage: expunge <source file> <dest file> <names of modules to keep> *)
-
-open Sys
-open Misc
-
-module StringSet =
- Set.Make(struct
- type t = string
- let compare = compare
- end)
-
-let to_keep = ref StringSet.empty
-
-let expunge_map tbl =
- Symtable.filter_global_map
- (fun id -> StringSet.mem (Ident.name id) !to_keep)
- tbl
-
-let expunge_crcs tbl =
- List.filter (fun (unit, crc) -> StringSet.mem unit !to_keep) tbl
-
-let main () =
- let input_name = Sys.argv.(1) in
- let output_name = Sys.argv.(2) in
- Array.iter
- (fun exn -> to_keep := StringSet.add exn !to_keep)
- Runtimedef.builtin_exceptions;
- for i = 3 to Array.length Sys.argv - 1 do
- to_keep := StringSet.add (String.capitalize 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
- if Sys.os_type = "MacOS" then begin
- (* Create output as a text file for bytecode scripts *)
- let c = open_out_gen [Open_wronly; Open_creat] 0o777 output_name in
- close_out c
- end;
- let oc =
- open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o777
- output_name in
- (* 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) 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
deleted file mode 100644
index 1f8766c804..0000000000
--- a/toplevel/genprintval.ml
+++ /dev/null
@@ -1,363 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* 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 Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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 value
- val eval_path: Path.t -> value
- exception Error
- val same_value: value -> value -> bool
- end
-
-module type S =
- sig
- type t
- val install_printer :
- Path.t -> Types.type_expr -> (formatter -> t -> unit) -> 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 value = O.t) = struct
-
- type t = O.t
-
- (* 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 =
- 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. *)
-
- let printers = ref ([
- Pident(Ident.create "print_int"), Predef.type_int,
- (fun x -> Oval_int (O.obj x : int));
- Pident(Ident.create "print_float"), Predef.type_float,
- (fun x -> Oval_float (O.obj x : float));
- Pident(Ident.create "print_char"), Predef.type_char,
- (fun x -> Oval_char (O.obj x : char));
- Pident(Ident.create "print_string"), Predef.type_string,
- (fun x -> Oval_string (O.obj x : string));
- Pident(Ident.create "print_int32"), Predef.type_int32,
- (fun x -> Oval_int32 (O.obj x : int32));
- Pident(Ident.create "print_nativeint"), Predef.type_nativeint,
- (fun x -> Oval_nativeint (O.obj x : nativeint));
- Pident(Ident.create "print_int64"), Predef.type_int64,
- (fun x -> Oval_int64 (O.obj x : int64))
- ] : (Path.t * type_expr * (O.t -> Outcometree.out_value)) list)
-
- let install_printer path ty fn =
- let print_val ppf obj =
- try fn ppf obj with
- | exn ->
- fprintf ppf "<printer %a raised an exception>" Printtyp.path path in
- let printer obj = Oval_printer (fun ppf -> print_val ppf obj) in
- printers := (path, ty, printer) :: !printers
-
- let remove_printer path =
- let rec remove = function
- | [] -> raise Not_found
- | (p, ty, fn as printer) :: rem ->
- if Path.same p path then rem else printer :: remove rem in
- printers := remove !printers
-
- let find_printer env ty =
- let rec find = function
- | [] -> raise Not_found
- | (name, sch, printer) :: remainder ->
- if Ctype.moregeneral env false sch ty
- then printer
- else find remainder
- in find !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 id ->
- 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(p1, p2) ->
- 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 rec tree_of_val depth obj ty =
- decr printer_steps;
- if !printer_steps < 0 || depth < 0 then Oval_ellipsis
- else begin
- try
- find_printer env ty obj
- with Not_found ->
- match (Ctype.repr ty).desc with
- | Tvar ->
- Oval_stuff "<poly>"
- | Tarrow(_, ty1, ty2, _) ->
- Oval_stuff "<fun>"
- | Ttuple(ty_list) ->
- Oval_tuple (tree_of_val_list 0 depth obj ty_list)
- | Tconstr(path, [], _) when Path.same path Predef.path_exn ->
- tree_of_exception depth obj
- | 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 obj =
- if !printer_steps < 0 || depth < 0 then
- Oval_ellipsis :: tree_list
- else if O.is_block obj then
- let tree =
- tree_of_val (depth - 1) (O.field obj 0) ty_arg in
- let next_obj = O.field obj 1 in
- tree_of_conses (tree :: tree_list) next_obj
- else tree_list
- in
- Oval_list (List.rev (tree_of_conses [] obj))
- 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 =
- 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 ->
- if Lazy.lazy_is_val (O.obj obj)
- then let v = tree_of_val depth (Lazy.force (O.obj obj)) ty_arg in
- Oval_constr (Oide_ident "lazy", [v])
- else Oval_stuff "<lazy>"
- | 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 "<abstr>"
- | {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, priv)} ->
- let tag =
- if O.is_block obj
- then Cstr_block(O.tag obj)
- else Cstr_constant(O.obj obj) in
- let (constr_name, constr_args) =
- Datarepr.find_constr_by_tag tag constr_list in
- let ty_args =
- List.map
- (function ty ->
- try Ctype.apply env decl.type_params ty ty_list with
- Ctype.Cannot_apply -> abstract_type)
- constr_args in
- tree_of_constr_with_args (tree_of_constr env path)
- constr_name 0 depth obj ty_args
- | {type_kind = Type_record(lbl_list, rep, priv)} ->
- begin match check_depth depth obj ty with
- Some x -> x
- | None ->
- let rec tree_of_fields pos = function
- | [] -> []
- | (lbl_name, _, lbl_arg) :: remainder ->
- let ty_arg =
- try
- Ctype.apply env decl.type_params lbl_arg
- ty_list
- with
- Ctype.Cannot_apply -> abstract_type in
- let lid = tree_of_label env path lbl_name in
- let v =
- 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 0 lbl_list)
- end
- with
- Not_found -> (* raised by Env.find_type *)
- Oval_stuff "<abstr>"
- | Datarepr.Constr_not_found -> (* raised by find_constr_by_tag *)
- Oval_stuff "<unknown constructor>"
- 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) ->
- let args =
- tree_of_val (depth - 1) (O.field obj 1) ty in
- Oval_variant (l, Some args)
- | _ -> find fields
- else find fields
- | [] -> Oval_stuff "<variant>" 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 "<variant>" in
- find row.row_fields
- | Tobject (_, _) ->
- Oval_stuff "<obj>"
- | 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
- | Tunivar ->
- Oval_stuff "<poly>"
- end
-
- and tree_of_val_list start depth obj ty_list =
- let rec tree_list i = function
- | [] -> []
- | ty :: ty_list ->
- let tree = 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 start depth obj ty_args =
- let lid = tree_of_cstr cstr_name in
- let args = tree_of_val_list start depth obj ty_args in
- Oval_constr (lid, args)
-
- and tree_of_exception depth bucket =
- let name = (O.obj(O.field(O.field bucket 0) 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_exception 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 (O.field bucket 0) (EVP.eval_path path))
- then raise Not_found;
- tree_of_constr_with_args
- (fun x -> Oide_ident x) name 1 depth bucket cstr.cstr_args
- with Not_found | EVP.Error ->
- match check_depth depth obj ty with
- Some x -> x
- | None -> outval_of_untyped_exception obj
-
- in tree_of_val max_depth obj ty
-
-end
diff --git a/toplevel/genprintval.mli b/toplevel/genprintval.mli
deleted file mode 100644
index 898588b2dd..0000000000
--- a/toplevel/genprintval.mli
+++ /dev/null
@@ -1,52 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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 value
- val eval_path: Path.t -> value
- exception Error
- val same_value: value -> value -> bool
- end
-
-module type S =
- sig
- type t
- val install_printer :
- Path.t -> Types.type_expr -> (formatter -> t -> unit) -> 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 value = O.t) :
- (S with type t = O.t)
diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml
deleted file mode 100644
index f57e773334..0000000000
--- a/toplevel/topdirs.ml
+++ /dev/null
@@ -1,297 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Toplevel directives *)
-
-open Format
-open Misc
-open Longident
-open Path
-open Types
-open Emitcode
-open Trace
-open Toploop
-
-(* 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;
- Dll.add_path [d]
-
-let _ = Hashtbl.add directive_table "directory" (Directive_string dir_directory)
-
-(* 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 .cmo file *)
-
-exception Load_failed
-
-let check_consistency ppf filename cu =
- try
- List.iter
- (fun (name, crc) -> Consistbl.check Env.crc_units name crc filename)
- cu.cu_imports
- with Consistbl.Inconsistency(name, user, auth) ->
- fprintf ppf "@[<hv 0>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;
- String.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();
- begin try
- may_trace := true;
- ignore((Meta.reify_bytecode code code_size) ());
- may_trace := false;
- with exn ->
- may_trace := false;
- Symtable.restore_state initial_symtable;
- print_exception_outcome ppf exn;
- raise Load_failed
- end
-
-let load_file ppf name =
- try
- let filename = find_in_path !Config.load_path name in
- let ic = open_in_bin filename in
- let buffer = String.create (String.length Config.cmo_magic_number) in
- really_input ic buffer 0 (String.length Config.cmo_magic_number);
- let success = 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;
- load_compunit ic filename ppf (input_value ic : compilation_unit);
- 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
- begin try
- Dll.open_dlls (List.map Dll.extract_dll_name lib.lib_dllibs)
- with Failure reason ->
- fprintf ppf "Cannot load required shared library: %s.@." reason;
- raise Load_failed
- end;
- List.iter (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 in
- close_in ic;
- success
- with Not_found -> fprintf ppf "Cannot find file %s.@." name; false
-
-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(Toploop.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 "Topdirs", 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 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 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))
-
-(* The trace *)
-
-external current_environment: unit -> Obj.t = "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 p ->
- fprintf ppf "%a is an external function and cannot be traced.@."
- Printtyp.longident lid
- | _ ->
- let clos = eval_path 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)
- 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 (eval_path path) 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 (eval_path f.path) 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
-
-let _ =
- Hashtbl.add directive_table "trace" (Directive_ident (dir_trace std_out));
- Hashtbl.add directive_table "untrace" (Directive_ident (dir_untrace std_out));
- Hashtbl.add directive_table
- "untrace_all" (Directive_none (dir_untrace_all std_out));
-
-(* 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/topdirs.mli b/toplevel/topdirs.mli
deleted file mode 100644
index 36af2211ba..0000000000
--- a/toplevel/topdirs.mli
+++ /dev/null
@@ -1,34 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* The toplevel directives. *)
-
-open Format
-
-val dir_quit : unit -> unit
-val dir_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
deleted file mode 100644
index c50dbcbd97..0000000000
--- a/toplevel/toploop.ml
+++ /dev/null
@@ -1,409 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* The interactive toplevel loop *)
-
-open Path
-open Lexing
-open Format
-open Config
-open Misc
-open Parsetree
-open Types
-open Typedtree
-open Outcometree
-
-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)
-
-(* The table of toplevel value bindings and its accessors *)
-
-let toplevel_value_bindings =
- (Hashtbl.create 37 : (string, Obj.t) Hashtbl.t)
-
-let getvalue name =
- try
- Hashtbl.find toplevel_value_bindings name
- with Not_found ->
- fatal_error (name ^ " unbound at toplevel")
-
-let setvalue name v =
- Hashtbl.replace toplevel_value_bindings name v
-
-(* 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 = Ident.name id in
- try
- Hashtbl.find toplevel_value_bindings name
- with Not_found ->
- raise (Symtable.Error(Symtable.Undefined_global name))
- end
- | Pdot(p, s, pos) ->
- Obj.field (eval_path p) pos
- | Papply(p1, p2) ->
- fatal_error "Toploop.eval_path"
-
-(* To print values *)
-
-module EvalPath = struct
- type value = Obj.t
- exception Error
- let eval_path p = try eval_path 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_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)
-
-let install_printer = Printer.install_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
-let print_warning = Location.print_warning
-let input_name = Location.input_name
-
-(* 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 load_lambda ppf lam =
- if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam;
- let slam = Simplif.simplify_lambda 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) = Emitcode.to_memory init_code fun_code in
- 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();
- try
- may_trace := true;
- let retval = (Meta.reify_bytecode code code_size) () in
- may_trace := false;
- if can_free then Meta.static_free code;
- Result retval
- with x ->
- may_trace := false;
- if can_free then Meta.static_free code;
- Symtable.restore_state initial_symtable;
- Exception x
-
-(* Print the outcome of an evaluation *)
-
-let pr_item env = function
- | Tsig_value(id, decl) :: rem ->
- let tree = Printtyp.tree_of_value_description id decl in
- let valopt =
- match decl.val_kind with
- | Val_prim _ -> None
- | _ ->
- let v =
- outval_of_value env (getvalue (Translmod.toplevel_name id))
- decl.val_type
- in
- Some v
- in
- Some (tree, valopt, rem)
- | Tsig_type(id, decl) :: rem ->
- let tree = Printtyp.tree_of_type_declaration id decl in
- Some (tree, None, rem)
- | Tsig_exception(id, decl) :: rem ->
- let tree = Printtyp.tree_of_exception_declaration id decl in
- Some (tree, None, rem)
- | Tsig_module(id, mty) :: rem ->
- let tree = Printtyp.tree_of_module id mty in
- Some (tree, None, rem)
- | Tsig_modtype(id, decl) :: rem ->
- let tree = Printtyp.tree_of_modtype_declaration id decl in
- Some (tree, None, rem)
- | Tsig_class(id, decl) :: cltydecl :: tydecl1 :: tydecl2 :: rem ->
- let tree = Printtyp.tree_of_class_declaration id decl in
- Some (tree, None, rem)
- | Tsig_cltype(id, decl) :: tydecl1 :: tydecl2 :: rem ->
- let tree = Printtyp.tree_of_cltype_declaration id decl in
- Some (tree, None, rem)
- | _ -> None
-
-let rec item_list env = function
- | [] -> []
- | items ->
- match pr_item env items with
- | None -> []
- | Some (tree, valopt, items) -> (tree, valopt) :: item_list env items
-
-(* 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
- Typecore.reset_delayed_checks ();
- let (str, sg, newenv) = Typemod.type_structure oldenv sstr in
- 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
- match str with
- | [Tstr_eval 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 (item_list newenv
- (Typemod.simplify_signature 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) ->
- try
- match (Hashtbl.find directive_table dir_name, 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) -> f n; true
- | (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
- with Not_found ->
- fprintf ppf "Unknown directive `%s'.@." dir_name;
- false
-
-(* Temporary assignment to a reference *)
-
-let protect r newval body =
- let oldval = !r in
- try
- r := newval;
- let res = body() in
- r := oldval;
- res
- with x ->
- r := oldval;
- raise x
-
-(* Read and execute commands from a file *)
-
-let use_print_results = ref true
-
-let use_file ppf name =
- try
- let filename = find_in_path !Config.load_path name in
- let ic = open_in_bin filename in
- let lb = Lexing.from_channel ic in
- Location.init lb filename;
- (* Skip initial #! line if any *)
- Lexer.skip_sharp_bang lb;
- let success =
- protect Location.input_name filename (fun () ->
- try
- List.iter
- (fun ph ->
- if !Clflags.dump_parsetree then Printast.top_phrase ppf ph;
- if not (execute_phrase !use_print_results ppf ph) then raise Exit)
- (!parse_use_file lb);
- true
- with
- | Exit -> false
- | Sys.Break -> fprintf ppf "Interrupted.@."; false
- | x -> Errors.report_error ppf x; false) in
- close_in ic;
- success
- with Not_found -> fprintf ppf "Cannot find file %s.@." name; false
-
-let use_silently ppf name =
- protect 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 refill_lexbuf buffer len =
- if !got_eof then (got_eof := false; 0) else begin
- let prompt =
- if !first_line then "# "
- else if Lexer.in_comment () then "* "
- else " "
- in
- output_string stdout prompt; flush stdout;
- first_line := false;
- let i = ref 0 in
- try
- while true do
- if !i >= len then raise Exit;
- let c = input_char stdin in
- buffer.[!i] <- c;
- incr i;
- if c = '\n' then raise Exit;
- done;
- !i
- with
- | End_of_file ->
- Location.echo_eof ();
- if !i > 0 then (got_eof := true; !i) else 0
- | Exit -> !i
- 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;
- let crc_intfs = Symtable.init_toplevel() in
- Compile.init_path();
- List.iter
- (fun (name, crc) ->
- Consistbl.set Env.crc_units name crc Sys.executable_name)
- crc_intfs
-
-let load_ocamlinit ppf =
- let home_init =
- try Filename.concat (Sys.getenv "HOME") ".ocamlinit"
- with Not_found -> ".ocamlinit" in
- if Sys.file_exists ".ocamlinit" then ignore(use_silently ppf ".ocamlinit")
- else if Sys.file_exists home_init then ignore(use_silently ppf home_init)
-
-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);
- Dll.add_path !load_path
-
-let initialize_toplevel_env () =
- toplevel_env := Compile.initial_env()
-
-(* The interactive loop *)
-
-exception PPerror
-
-let loop ppf =
- fprintf ppf " Objective Caml version %s@.@." Config.version;
- initialize_toplevel_env ();
- let lb = Lexing.from_function refill_lexbuf in
- Location.input_name := "";
- 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
- if !Clflags.dump_parsetree then Printast.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 -> Errors.report_error ppf x; Btype.backtrack snap
- done
-
-(* Execute a script *)
-
-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;
- Compile.init_path();
- toplevel_env := Compile.initial_env();
- Sys.interactive := false;
- use_silently ppf name
diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli
deleted file mode 100644
index 18372c6bda..0000000000
--- a/toplevel/toploop.mli
+++ /dev/null
@@ -1,107 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open 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)
-
-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 use_file : formatter -> string -> bool
-val use_silently : 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. *)
-val eval_path: 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
-
-val install_printer :
- Path.t -> Types.type_expr -> (formatter -> Obj.t -> unit) -> 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_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_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 initialization *)
-
-val toplevel_startup_hook : (unit -> unit) ref
-
-(* Used by Trace module *)
-
-val may_trace : bool ref
diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml
deleted file mode 100644
index cca331e8a1..0000000000
--- a/toplevel/topmain.ml
+++ /dev/null
@@ -1,90 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Clflags
-
-let usage = "Usage: ocaml <options> <object-files> [script-file]\noptions are:"
-
-let preload_objects = ref []
-
-let prepare ppf =
- Toploop.set_paths ();
- try
- let res =
- List.for_all (Topdirs.load_file ppf) (List.rev !preload_objects) in
- !Toploop.toplevel_startup_hook ();
- res
- with x ->
- try Errors.report_error 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 ".cmo" || Filename.check_suffix name ".cma"
- then preload_objects := name :: !preload_objects
- else
- begin
- let newargs = Array.sub Sys.argv !Arg.current
- (Array.length Sys.argv - !Arg.current)
- in
- if prepare ppf && Toploop.run_script ppf name newargs
- then exit 0
- else exit 2
- end
-
-let main () =
- Arg.parse [
- "-I", Arg.String(fun dir ->
- let dir = Misc.expand_directory Config.standard_library dir in
- include_dirs := dir :: !include_dirs),
- "<dir> Add <dir> to the list of include directories";
- "-labels", Arg.Clear classic, " Labels commute (default)";
- "-noassert", Arg.Set noassert, " Do not compile assertion checks";
- "-nolabels", Arg.Set classic, " Ignore labels and do not commute";
- "-nostdlib", Arg.Set no_std_include,
- " do not add default directory to the list of include directories";
- "-principal", Arg.Set principal, " Check principality of type inference";
- "-rectypes", Arg.Set recursive_types, " Allow arbitrary recursive types";
- "-unsafe", Arg.Set fast, " No bound checking on array and string access";
- "-w", Arg.String (Warnings.parse_options false),
- "<flags> Enable or disable warnings according to <flags>:\n\
- \032 A/a enable/disable all warnings\n\
- \032 C/c enable/disable suspicious comment\n\
- \032 D/d enable/disable deprecated features\n\
- \032 E/e enable/disable fragile match\n\
- \032 F/f enable/disable partially applied function\n\
- \032 L/l enable/disable labels omitted in application\n\
- \032 M/m enable/disable overriden method\n\
- \032 P/p enable/disable partial match\n\
- \032 S/s enable/disable non-unit statement\n\
- \032 U/u enable/disable unused match case\n\
- \032 V/v enable/disable hidden instance variable\n\
- \032 X/x enable/disable all other warnings\n\
- \032 default setting is \"Ale\"\n\
- \032 (all warnings but labels and fragile match enabled)";
- "-warn-error" , Arg.String (Warnings.parse_options true),
- "<flags> Enable or disable fatal warnings according to <flags>\n\
- \032 (see option -w for the list of flags)\n\
- \032 default setting is a (all warnings are non-fatal)";
-
- "-dparsetree", Arg.Set dump_parsetree, " (undocumented)";
- "-drawlambda", Arg.Set dump_rawlambda, " (undocumented)";
- "-dlambda", Arg.Set dump_lambda, " (undocumented)";
- "-dinstr", Arg.Set dump_instr, " (undocumented)";
- ] file_argument usage;
- if not (prepare Format.err_formatter) then exit 2;
- Toploop.loop Format.std_formatter
-
diff --git a/toplevel/topmain.mli b/toplevel/topmain.mli
deleted file mode 100644
index 197f88bbc6..0000000000
--- a/toplevel/topmain.mli
+++ /dev/null
@@ -1,17 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Start the [ocaml] toplevel loop *)
-
-val main: unit -> unit
diff --git a/toplevel/topstart.ml b/toplevel/topstart.ml
deleted file mode 100644
index 570e2f203a..0000000000
--- a/toplevel/topstart.ml
+++ /dev/null
@@ -1,15 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-let _ = Topmain.main()
diff --git a/toplevel/trace.ml b/toplevel/trace.ml
deleted file mode 100644
index fad92d98a3..0000000000
--- a/toplevel/trace.ml
+++ /dev/null
@@ -1,144 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* The "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 <> "" then fprintf ppf "%s:" 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(l1, l2) -> 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) *)
-
-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
- let res = invoke_traced_function actual_code closure arg
- in res (* do not remove let, 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
deleted file mode 100644
index ed7dc6e33a..0000000000
--- a/toplevel/trace.mli
+++ /dev/null
@@ -1,35 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* The "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/btype.ml b/typing/btype.ml
deleted file mode 100644
index 01bd331285..0000000000
--- a/typing/btype.ml
+++ /dev/null
@@ -1,465 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* 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 Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Basic operations on core types *)
-
-open Types
-
-(**** 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 = desc; level = level; id = !new_id }
-let newgenty desc = newty2 generic_level desc
-let newgenvar () = newgenty Tvar
-(*
-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 }
-*)
-
-(**** Representative of a type ****)
-
-let rec field_kind_repr =
- function
- Fvar {contents = Some kind} -> field_kind_repr kind
- | kind -> kind
-
-let rec repr =
- function
- {desc = Tlink t'} ->
- (*
- We do no path compression. Path compression does not seem to
- improve notably efficiency, and it prevents from changing a
- [Tlink] into another type (for instance, for undoing a
- unification).
- *)
- repr t'
- | {desc = Tfield (_, k, _, t')} when field_kind_repr k = Fabsent ->
- repr t'
- | 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 row_repr row =
- match (repr row.row_more).desc with
- | Tvariant row' ->
- if row.row_fields = [] then row_repr row' else
- let row' = row_repr row' in
- {row' with row_fields = row.row_fields @ row'.row_fields}
- | _ -> row
-
-let rec row_more row =
- match repr row.row_more with
- | {desc=Tvariant row'} -> row_more row'
- | ty -> ty
-
-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 ty = repr ty in
- match ty.desc with
- | Tvariant row -> row_more row
- | Tobject (ty, _) ->
- let rec proxy_obj ty =
- match ty.desc with
- Tfield (_, _, _, ty) | Tlink ty -> proxy_obj ty
- | Tvar | Tnil | Tunivar -> ty
- | _ -> assert false
- in proxy_obj ty
- | _ -> ty
-
-
- (**********************************)
- (* 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 | Tnil | Tunivar | Tsubst _ ->
- Misc.may (fun (_,l) -> List.iter f l) row.row_name;
- List.iter f row.row_bound
- | _ -> 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
-
-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
-
-let copy_row f fixed row keep more =
- let bound = ref [] in
- 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
- bound := List.filter
- (function {desc=Tconstr(_,[],_)} -> false | _ -> true)
- (List.map repr tl)
- @ !bound;
- 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 = !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 f = function
- Tvar -> Tvar
- | 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 row ->
- let row = row_repr row in
- Tvariant (copy_row f true row false (f row.row_more))
- | Tfield (p, k, ty1, ty2) -> Tfield (p, copy_kind k, f ty1, f ty2)
- | Tnil -> Tnil
- | Tlink ty -> copy_type_desc f ty.desc
- | Tsubst ty -> assert false
- | Tunivar -> Tunivar
- | Tpoly (ty, tyl) ->
- let tyl = List.map (fun x -> norm_univar (f x)) tyl in
- Tpoly (f ty, tyl)
-
-
-(* 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
-
-(* Restored type descriptions. *)
-let cleanup_types () =
- List.iter (fun (ty, desc) -> ty.desc <- desc) !saved_desc;
- saved_desc := []
-
-(* 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
-
-(* 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_type_decl decl =
- List.iter unmark_type decl.type_params;
- begin match decl.type_kind with
- Type_abstract -> ()
- | Type_variant (cstrs, priv) ->
- List.iter (fun (c, tl) -> List.iter unmark_type tl) cstrs
- | Type_record(lbls, rep, priv) ->
- List.iter (fun (c, mut, t) -> unmark_type t) lbls
- end;
- begin match decl.type_manifest with
- None -> ()
- | Some ty -> unmark_type ty
- end
-
-let unmark_class_signature sign =
- unmark_type sign.cty_self;
- Vars.iter (fun l (m, t) -> unmark_type t) sign.cty_vars
-
-let rec unmark_class_type =
- function
- Tcty_constr (p, tyl, cty) ->
- List.iter unmark_type tyl; unmark_class_type cty
- | Tcty_signature sign ->
- unmark_class_signature sign
- | Tcty_fun (_, ty, cty) ->
- unmark_type ty; unmark_class_type cty
-
-
- (*******************************************)
- (* Memorization of abbreviation expansion *)
- (*******************************************)
-
-(* Search whether the expansion has been memorized. *)
-let rec find_expans p1 = function
- Mnil -> None
- | Mcons (p2, ty0, ty, _) when Path.same p1 p2 -> Some ty
- | Mcons (_, _, _, rem) -> find_expans p1 rem
- | Mlink {contents = rem} -> find_expans p1 rem
-
-(* debug: check for cycles in abbreviation. only works with -principal
-let rec check_expans visited ty =
- let ty = repr ty in
- assert (not (List.memq ty visited));
- match ty.desc with
- Tconstr (path, args, abbrev) ->
- begin match find_expans path !abbrev with
- Some ty' -> check_expans (ty :: visited) ty'
- | None -> ()
- end
- | _ -> ()
-*)
-
-let memo = ref []
- (* Contains the list of saved abbreviation expansions. *)
-
-let cleanup_abbrev () =
- (* Remove all memorized abbreviation expansions. *)
- List.iter (fun abbr -> abbr := Mnil) !memo;
- memo := []
-
-let memorize_abbrev mem path v v' =
- (* Memorize the expansion of an abbreviation. *)
- mem := Mcons (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 (path', v, v', rem) ->
- Mcons (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 l =
- String.length l > 0 && l.[0] = '?'
-
-let label_name l =
- if is_optional l then String.sub l 1 (String.length l - 1)
- else l
-
-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 *)
- (**********************************)
-
-type change =
- Ctype of type_expr * 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
-
-let undo_change = function
- Ctype (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
-
-type changes =
- Change of change * changes ref
- | Unchanged
- | Invalid
-
-type snapshot = changes ref * int
-
-let trail = Weak.create 1
-let last_snapshot = ref 0
-
-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')
-
-let log_type ty =
- if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc))
-let link_type ty ty' = log_type ty; ty.desc <- Tlink ty'
- (* ; 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 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)
diff --git a/typing/btype.mli b/typing/btype.mli
deleted file mode 100644
index 0b3658f609..0000000000
--- a/typing/btype.mli
+++ /dev/null
@@ -1,147 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Basic operations on core types *)
-
-open Asttypes
-open Types
-
-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: 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 *)
-*)
-
-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 *)
-
-val row_repr: row_desc -> row_desc
- (* Return the canonical representative of a row description *)
-val row_field_repr: row_field -> 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 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 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 *)
-
-val copy_type_desc: (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 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_class_type: class_type -> unit
-val unmark_class_signature: class_signature -> unit
- (* Remove marks from a type *)
-
-(**** Memorization of abbreviation expansion ****)
-
-val find_expans: Path.t -> abbrev_memo -> type_expr option
- (* Look up a memorized abbreviation *)
-val cleanup_abbrev: unit -> unit
- (* Flush the cache of abbreviation expansions.
- When some types are saved (using [output_value]), this
- function MUST be called just before. *)
-val memorize_abbrev:
- abbrev_memo ref -> 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 : label -> bool
-val label_name : label -> label
-val extract_label :
- label -> (label * 'a) list ->
- label * 'a * (label * 'a) list * (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 *)
-
-(* 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
- (* Set references, logging the old value *)
-val log_type: type_expr -> unit
- (* Log the old value of a type, before modifying it by hand *)
diff --git a/typing/ctype.ml b/typing/ctype.ml
deleted file mode 100644
index 17be1316a2..0000000000
--- a/typing/ctype.ml
+++ /dev/null
@@ -1,3243 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* 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 Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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.
-*)
-
-(*
- A faire
- =======
- - Revoir affichage des types.
- - Etendre la portee d'un alias [... as 'a] a tout le type englobant.
- - #-type implementes comme de vraies abreviations.
- - Niveaux plus fins pour les identificateurs :
- Champ [global] renomme en [level];
- Niveau -1 : global
- 0 : module toplevel
- 1 : module contenu dans module toplevel
- ...
- En fait, incrementer le niveau a chaque fois que l'on rentre dans
- un module.
-
- 3 4 6
- \ / /
- 1 2 5
- \|/
- 0
-
- [Subst] doit ecreter les niveaux (pour qu'un variable non
- generalisable dans un module de niveau 2 ne se retrouve pas
- generalisable lorsque l'on l'utilise au niveau 0).
-
- - Traitement de la trace de l'unification separe de la fonction
- [unify].
-*)
-
-(**** Errors ****)
-
-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
-
-(**** Type level management ****)
-
-let current_level = ref 0
-let nongen_level = ref 0
-let global_level = ref 1
-let saved_level = ref []
-let saved_global_level = ref []
-
-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;
- saved_global_level := []
-let increase_global_level () =
- let gl = !global_level in
- global_level := !current_level;
- gl
-let restore_global_level gl =
- global_level := gl
-
-(* Abbreviations without parameters *)
-(* Shall reset after generalizing *)
-let simple_abbrevs = ref Mnil
-let proper_abbrevs path tl abbrev =
- if !Clflags.principal || tl <> [] then abbrev else
- let name = match path with Path.Pident id -> Ident.name id
- | Path.Pdot(_, s,_) -> s
- | Path.Papply _ -> assert false in
- if name.[0] <> '#' then simple_abbrevs else abbrev
-
-(**** Some type creators ****)
-
-(* Re-export generic type creators *)
-
-let newty2 = Btype.newty2
-let newty desc = newty2 !current_level desc
-let new_global_ty desc = newty2 !global_level desc
-
-let newvar () = newty2 !current_level Tvar
-let newvar2 level = newty2 level Tvar
-let new_global_var () = newty2 !global_level Tvar
-
-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)
-
- (**********************************************)
- (* Miscellaneous operations on object types *)
- (**********************************************)
-
-
-(**** Object field manipulation. ****)
-
-let dummy_method = "*dummy method*"
-
-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
- (Sort.list (fun (n, _, _) (n', _, _) -> 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)::r 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 ****)
-
-(* +++ Il faudra penser a eventuellement expanser l'abreviation *)
-let rec opened_object ty =
- match (repr ty).desc with
- Tobject (t, _) -> opened_object t
- | Tfield(_, _, _, t) -> opened_object t
- | Tvar -> true
- | _ -> false
-
-(**** 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 =
- let (fl, _) = flatten_fields (object_fields ty) in
- List.iter
- (function (_, k, _) ->
- let k = field_kind_repr k in
- match k with
- Fvar r -> set_kind r Fabsent
- | _ -> ())
- fl
-
-
- (*******************************)
- (* Operations on class types *)
- (*******************************)
-
-
-let rec signature_of_class_type =
- function
- Tcty_constr (_, _, cty) -> signature_of_class_type cty
- | Tcty_signature sign -> sign
- | Tcty_fun (_, ty, cty) -> signature_of_class_type cty
-
-let self_type cty =
- repr (signature_of_class_type cty).cty_self
-
-let rec class_type_arity =
- function
- Tcty_constr (_, _, cty) -> class_type_arity cty
- | Tcty_signature _ -> 0
- | Tcty_fun (_, _, cty) -> 1 + class_type_arity cty
-
-
- (*******************************************)
- (* Miscellaneous operations on row types *)
- (*******************************************)
-
-let sort_row_fields = Sort.list (fun (p,_) (q,_) -> p < q)
-
-let merge_row_fields fi1 fi2 =
- let rec merge r1 r2 pairs fi1 fi2 =
- match fi1, fi2 with
- (l1,f1 as p1)::fi1', (l2,f2 as p2)::fi2' ->
- if l1 = l2 then merge r1 r2 ((l1,f1,f2)::pairs) fi1' fi2' else
- if l1 < l2 then merge (p1::r1) r2 pairs fi1' fi2 else
- merge r1 (p2::r2) pairs fi1 fi2'
- | [], _ -> (List.rev r1, List.rev_append r2 fi2, pairs)
- | _, [] -> (List.rev_append r1 fi1, List.rev r2, pairs)
- in
- merge [] [] [] (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
-
-let rec closed_schema_rec ty =
- let ty = repr ty in
- if ty.level >= lowest_level then begin
- let level = ty.level in
- ty.level <- pivot_level - level;
- match ty.desc with
- Tvar when level <> generic_level ->
- raise Non_closed
- | Tfield(_, kind, t1, t2) ->
- if field_kind_repr kind = Fpresent then
- closed_schema_rec t1;
- closed_schema_rec t2
- | Tvariant row ->
- let row = row_repr row in
- iter_row closed_schema_rec {row with row_bound = []};
- if not (static_row row) then closed_schema_rec row.row_more
- | _ ->
- iter_type_expr closed_schema_rec ty
- end
-
-(* Return whether all variables of type [ty] are generic. *)
-let closed_schema ty =
- try
- closed_schema_rec ty;
- unmark_type ty;
- true
- with Non_closed ->
- unmark_type ty;
- false
-
-exception Non_closed of type_expr * bool
-
-let free_variables = ref []
-
-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 with
- Tvar ->
- free_variables := (ty, real) :: !free_variables
-(* 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 with row_bound = []};
- 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 ty =
- free_variables := [];
- free_vars_rec true ty;
- let res = !free_variables in
- free_variables := [];
- res
-
-let rec 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;
- try
- closed_type ty;
- List.iter unmark_type params;
- unmark_type ty;
- true
- with Non_closed _ ->
- List.iter unmark_type params;
- unmark_type ty;
- false
-
-let closed_type_decl decl =
- try
- List.iter mark_type decl.type_params;
- begin match decl.type_kind with
- Type_abstract ->
- ()
- | Type_variant(v, priv) ->
- List.iter (fun (_, tyl) -> List.iter closed_type tyl) v
- | Type_record(r, rep, priv) ->
- List.iter (fun (_, _, ty) -> closed_type ty) r
- 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
-
-type closed_class_failure =
- CC_Method of type_expr * bool * string * type_expr
- | CC_Value of type_expr * bool * string * type_expr
-
-exception Failure of closed_class_failure
-
-let closed_class params sign =
- let ty = object_fields (repr sign.cty_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.cty_self);
- List.iter
- (fun (lab, kind, ty) ->
- if field_kind_repr kind = Fpresent then
- try closed_type ty with Non_closed (ty0, real) ->
- raise (Failure (CC_Method (ty0, real, lab, ty))))
- fields;
- mark_type_params (repr sign.cty_self);
- List.iter unmark_type params;
- unmark_class_signature sign;
- None
- with Failure reason ->
- mark_type_params (repr sign.cty_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 iter_generalize tyl 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 (iter_generalize tyl) !abbrev
- | _ -> ()
- end;
- iter_type_expr (iter_generalize tyl) ty
- end else
- tyl := ty :: !tyl
-
-let iter_generalize tyl ty =
- simple_abbrevs := Mnil;
- iter_generalize tyl ty
-
-let generalize ty =
- iter_generalize (ref []) ty
-
-(* Efficient repeated generalisation of the same type *)
-let iterative_generalization min_level tyl =
- let tyl' = ref [] in
- List.iter (iter_generalize tyl') tyl;
- List.fold_right (fun ty l -> if ty.level <= min_level then l else ty::l)
- !tyl' []
-
-(* 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 ty.desc = Tvar && ty.level > var_level then
- set_level ty var_level
- else if ty.level > !current_level then begin
- set_level ty generic_level;
- begin match ty.desc with
- Tconstr (_, _, abbrev) -> abbrev := Mnil
- | _ -> ()
- end;
- iter_type_expr (generalize_structure var_level) ty
- end
- end
-
-let generalize_structure var_level ty =
- simple_abbrevs := Mnil;
- generalize_structure var_level ty
-
-(* let generalize_expansive ty = generalize_structure !nongen_level ty *)
-let generalize_global ty = generalize_structure !global_level ty
-let generalize_structure ty = generalize_structure !current_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 (_, _, ty', _) | Tpoly (ty', _) ->
- set_level ty generic_level;
- generalize_spine ty'
- | _ -> ()
-
-let try_expand_head' = (* 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 rec update_level env level ty =
- let ty = repr ty in
- if ty.level > level then begin
- begin match ty.desc with
- Tconstr(p, tl, abbrev) when level < Path.binding_time p ->
- (* Try first to replace an abbreviation by its expansion. *)
- begin try
- link_type ty (!try_expand_head' env ty);
- update_level env level ty
- with Cannot_expand ->
- (* +++ Levels should be restored... *)
- raise (Unify [(ty, newvar2 level)])
- end
- | Tobject(_, ({contents=Some(p, tl)} as nm))
- when level < Path.binding_time 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 < Path.binding_time 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, _, _, _) when lab = dummy_method ->
- raise (Unify [(ty, newvar2 level)])
- | _ ->
- set_level ty level;
- (* XXX what about abbreviations in Tconstr ? *)
- iter_type_expr (update_level env level) ty
- end
- end
-
-(* Generalize and lower levels of contravariant branches simultaneously *)
-
-let rec generalize_expansive env var_level ty =
- let ty = repr ty in
- if ty.level <> generic_level then begin
- if ty.level > var_level then begin
- set_level ty generic_level;
- match ty.desc with
- Tconstr (path, tyl, abbrev) ->
- let variance =
- try (Env.find_type path env).type_variance
- with Not_found -> List.map (fun _ -> (true,true,true)) tyl in
- abbrev := Mnil;
- List.iter2
- (fun (co,cn,ct) t ->
- if ct then update_level env var_level t
- else generalize_expansive env var_level t)
- variance tyl
- | Tarrow (_, t1, t2, _) ->
- update_level env var_level t1;
- generalize_expansive env var_level t2
- | _ ->
- iter_type_expr (generalize_expansive env var_level) ty
- end
- end
-
-let generalize_expansive env ty =
- simple_abbrevs := Mnil;
- try
- generalize_expansive env !nongen_level ty
- with Unify [_, ty'] ->
- raise (Unify [ty, 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))
- 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
-
-
- (*******************)
- (* Instantiation *)
- (*******************)
-
-
-let rec find_repr p1 =
- function
- Mnil ->
- None
- | Mcons (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. *)
-
-let rec copy ty =
- let ty = repr ty in
- match ty.desc with
- Tsubst ty -> ty
- | _ ->
- if ty.level <> generic_level then ty else
- let desc = ty.desc in
- save_desc ty desc;
- let t = newvar() in (* Stub *)
- 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 -> (* XXX Commentaire... *)
- 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
- | _ ->
- save_desc more more.desc;
- if keep then more else newty more.desc
- 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
- | _ -> copy_type_desc copy desc
- end;
- t
-
-(**** Variants of instantiations ****)
-
-let instance sch =
- let ty = copy sch in
- cleanup_types ();
- ty
-
-let instance_list schl =
- let tyl = List.map copy schl in
- cleanup_types ();
- tyl
-
-let instance_constructor cstr =
- let ty_res = copy cstr.cstr_res in
- let ty_args = List.map copy cstr.cstr_args in
- cleanup_types ();
- (ty_args, ty_res)
-
-let instance_parameterized_type sch_args sch =
- let ty_args = List.map copy 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 copy sch_args in
- let ty_lst = List.map copy sch_lst in
- let ty = copy sch in
- cleanup_types ();
- (ty_args, ty_lst, ty)
-
-let instance_class params cty =
- let rec copy_class_type =
- function
- Tcty_constr (path, tyl, cty) ->
- Tcty_constr (path, List.map copy tyl, copy_class_type cty)
- | Tcty_signature sign ->
- Tcty_signature
- {cty_self = copy sign.cty_self;
- cty_vars =
- Vars.map (function (mut, ty) -> (mut, copy ty)) sign.cty_vars;
- cty_concr = sign.cty_concr}
- | Tcty_fun (l, ty, cty) ->
- Tcty_fun (l, copy ty, copy_class_type cty)
- in
- let params' = List.map copy params in
- let cty' = copy_class_type cty in
- cleanup_types ();
- (params', cty')
-
-(**** Instanciation for types with free universal variables ****)
-
-module TypeHash = Hashtbl.Make(TypeOps)
-module TypeSet = Set.Make(TypeOps)
-
-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 ty.desc = Tunivar then add_univar ty inv)
- inverted;
- fun ty ->
- try !(TypeHash.find node_univars ty) with Not_found -> TypeSet.empty
-
-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 ty.desc = Tunivar 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 _ ->
- (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 = more.desc = Tvar && more.level <> generic_level in
- let more' = copy_rec 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 Tunivar) 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 fixed univars sch =
- let vars = List.map (fun _ -> newvar ()) univars in
- let pairs = List.map2 (fun u v -> repr 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
- | 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 rec subst env level 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 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 (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 overriden in the environnement.
-*)
-let previous_env = ref Env.empty
-let check_abbrev_env env =
- if env != !previous_env then begin
- 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 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 path !lookup_abbrev with
- Some ty ->
- 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;
- ty
- | None ->
- let (params, body) =
- try Env.find_type_expansion path env with Not_found ->
- raise Cannot_expand
- in
- let ty' = subst env level 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;
- ty'
- end
- | _ ->
- assert false
-
-(* Fully expand the head of a type. Raise an exception if the type
- cannot be expanded. *)
-let rec try_expand_head env ty =
- let ty = repr ty in
- match ty.desc with
- Tconstr _ ->
- let ty' = expand_abbrev env ty in
- begin try
- try_expand_head env ty'
- with Cannot_expand ->
- repr ty'
- end
- | _ ->
- raise Cannot_expand
-
-let _ = try_expand_head' := try_expand_head
-
-(* Expand once the head of a type *)
-let expand_head_once env ty =
- try expand_abbrev env (repr ty) with Cannot_expand -> assert false
-
-(* Fully expand the head of a type. *)
-let rec expand_head env ty =
- try try_expand_head env ty with Cannot_expand -> 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} ->
- let decl = Env.find_type path env in
- ignore
- (subst env level (ref Mnil) None decl.type_params args (newvar2 level))
- | _ ->
- assert false
-
-(* Recursively expand the head of a type.
- Also expand #-types. *)
-let rec full_expand env ty =
- let ty = repr (expand_head env ty) in
- match ty.desc with
- Tobject (fi, {contents = Some (_, v::_)}) when (repr v).desc = Tvar ->
- 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
-
-
- (*****************)
- (* Occur check *)
- (*****************)
-
-
-exception Occur
-
-(* The marks are already used by [expand_abbrev]... *)
-let visited = ref []
-
-let rec non_recursive_abbrev env ty0 ty =
- let ty = repr ty in
- if ty == repr ty0 then raise Recursive_abbrev;
- if not (List.memq ty !visited) then begin
- let level = ty.level in
- visited := ty :: !visited;
- match ty.desc with
- Tconstr(p, args, abbrev) ->
- begin try
- non_recursive_abbrev env ty0 (try_expand_head env ty)
- with Cannot_expand ->
- if !Clflags.recursive_types then () else
- iter_type_expr (non_recursive_abbrev env ty0) ty
- end
- | Tobject _ | Tvariant _ ->
- ()
- | _ ->
- if !Clflags.recursive_types then () else
- iter_type_expr (non_recursive_abbrev env ty0) ty
- end
-
-let correct_abbrev env path params ty =
- check_abbrev_env env;
- let ty0 = newgenvar () in
- visited := [];
- let abbrev = Mcons (path, ty0, ty0, Mnil) in
- simple_abbrevs := abbrev;
- try
- non_recursive_abbrev env ty0
- (subst env generic_level (ref abbrev) None [] [] ty);
- simple_abbrevs := Mnil;
- visited := []
- with exn ->
- simple_abbrevs := Mnil;
- visited := [];
- raise exn
-
-let rec occur_rec env visited ty0 ty =
- if ty == ty0 then raise Occur;
- match ty.desc with
- Tconstr(p, tl, abbrev) ->
- begin try
- if List.memq ty visited then raise Occur;
- if not !Clflags.recursive_types then
- iter_type_expr (occur_rec env (ty::visited) ty0) ty
- with Occur -> try
- let ty' = try_expand_head env ty in
- (* Maybe we could simply make a recursive call here,
- but it seems it could make the occur check loop
- (see change in rev. 1.58) *)
- if ty' == ty0 || List.memq ty' visited then raise Occur;
- match ty'.desc with
- Tobject _ | Tvariant _ -> ()
- | _ ->
- if not !Clflags.recursive_types then
- iter_type_expr (occur_rec env (ty'::visited) ty0) ty'
- with Cannot_expand -> raise Occur
- end
- | Tobject _ | Tvariant _ ->
- ()
- | _ ->
- if not !Clflags.recursive_types then
- iter_type_expr (occur_rec env visited ty0) ty
-
-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 old = !type_changed in
- try
- while type_changed := false; occur_rec env [] 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)
-
-
- (*****************************)
- (* 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 repr_univ = List.map (fun (t,o) -> repr t, o) in
- let cl1 = repr_univ cl1 and cl2 = repr_univ cl2 in
- begin try
- let r1 = List.assq t1 cl1 in
- match !r1 with
- Some t -> if t2 != repr t then raise (Unify [])
- | None ->
- try
- let r2 = List.assq t2 cl2 in
- if !r2 <> None then raise (Unify []);
- set_univar r1 t2; set_univar r2 t1
- with Not_found ->
- raise (Unify [])
- with Not_found ->
- unify_univar t1 t2 rem
- end
- | [] -> raise (Unify [])
-
-module TypeMap = Map.Make (TypeOps)
-
-(* Test the occurence of free univars in a type *)
-(* that's way too expansive. Must do some kind of cacheing *)
-let occur_univar 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
- | _ -> iter_type_expr (occur_rec bound) ty
- in
- try
- occur_rec TypeSet.empty ty; unmark_type ty
- with exn ->
- unmark_type ty; 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 []
-
-(**** 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 = <x : 'a>]). 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 rec unify env t1 t2 =
- (* First step: special cases (optimizations) *)
- if t1 == t2 then () else
- let t1 = repr t1 in
- let t2 = repr t2 in
- if t1 == t2 then () else
-
- try
- type_changed := true;
- 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, _) ->
- occur env t1 t2; occur_univar t2;
- update_level env t1.level t2;
- link_type t1 t2
- | (_, Tvar) ->
- occur env t2 t1; occur_univar t1;
- update_level env t2.level t1;
- link_type 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
- (* 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
- | _ ->
- unify2 env t1 t2
- with Unify trace ->
- raise (Unify ((t1, t2)::trace))
-
-and unify2 env t1 t2 =
- (* Second step: expansion of abbreviations *)
- let rec expand_both t1'' t2'' =
- let t1' = expand_head env t1 in
- let t2' = expand_head env t2 in
- (* Expansion may have changed the representative of the types... *)
- if t1' == t1'' && t2' == t2'' then (t1',t2') else
- expand_both t1' t2'
- in
- let t1', t2' = expand_both t1 t2 in
- if t1' == t2' then () else
-
- let t1 = repr t1 and t2 = repr t2 in
- if (t1 == t1') || (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
- occur env t1' t2;
- update_level env t1'.level t2;
- link_type t1' t2;
-
- try
- begin match (d1, d2) with
- (Tvar, _) ->
- occur_univar t2
- | (_, Tvar) ->
- let td1 = newgenty d1 in
- occur env t2' td1;
- occur_univar td1;
- if t1 == t1' then begin
- (* The variable must be instantiated... *)
- let ty = newty2 t1'.level d1 in
- update_level env t2'.level ty;
- link_type t2' ty
- end else begin
- log_type t1';
- t1'.desc <- d1;
- update_level env t2'.level t1;
- link_type t2' t1
- end
- | (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2
- || !Clflags.classic && 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 ->
- unify_list env tl1 tl2
- | (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 let va = repr va in List.mem va.desc [Tvar; Tunivar; Tnil] ->
- ()
- | Tobject (_, nm2) ->
- set_name nm2 !nm1
- | _ ->
- ()
- end
- | (Tvariant row1, Tvariant row2) ->
- unify_row env row1 row2
- | (Tfield _, Tfield _) -> (* Actually unused *)
- unify_fields env t1' t2'
- | (Tfield(_,kind,_,rem), Tnil) | (Tnil, Tfield(_,kind,_,rem)) ->
- begin match field_kind_repr kind with
- Fvar r -> r := Some Fabsent
- | _ -> raise (Unify [])
- end
- | (Tnil, Tnil) ->
- ()
- | (Tpoly (t1, []), Tpoly (t2, [])) ->
- unify env t1 t2
- | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
- if List.length tl1 <> List.length tl2 then raise (Unify []);
- let old_univars = !univar_pairs in
- 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;
- begin try
- unify env t1 t2;
- let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in
- List.iter
- (fun t1 ->
- if List.memq t1 tl2 then () else
- try
- let t2 =
- List.find (fun t2 -> not (List.memq (repr t2) tl1)) tl2 in
- link_type t2 t1
- with Not_found -> assert false)
- tl1;
- univar_pairs := old_univars
- with exn ->
- univar_pairs := old_univars; raise exn
- end
- | (_, _) ->
- raise (Unify [])
- end;
-
-(* XXX Commentaires + changer "create_recursion" *)
- if create_recursion then begin
- match t2.desc with
- Tconstr (p, tl, abbrev) ->
- forget_abbrev abbrev p;
- let t2'' = expand_head env t2 in
- if not (closed_parameterized_type tl t2'') then
- link_type (repr t2) (repr t2')
- | _ ->
- assert false
- end
-
-(*
- (*
- Can only be done afterwards, once the row variable has
- (possibly) been instantiated.
- *)
- if t1 != t1' (* && t2 != t2' *) then begin
- match (t1.desc, t2.desc) with
- (Tconstr (p, ty::_, _), _)
- when ((repr ty).desc <> Tvar)
- && weak_abbrev p
- && not (deep_occur t1 t2) ->
- update_level env t1.level t2;
- link_type t1 t2
- | (_, Tconstr (p, ty::_, _))
- when ((repr ty).desc <> Tvar)
- && weak_abbrev p
- && not (deep_occur t2 t1) ->
- update_level env t2.level t1;
- link_type t2 t1;
- link_type t1' t2'
- | _ ->
- ()
- end
-*)
- with Unify trace ->
- t1'.desc <- d1;
- raise (Unify trace)
-
-and unify_list env tl1 tl2 =
- if List.length tl1 <> List.length tl2 then
- raise (Unify []);
- List.iter2 (unify env) tl1 tl2
-
-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 va =
- if miss1 = [] then rest2
- else if miss2 = [] then rest1
- else newvar ()
- in
- let d1 = rest1.desc and d2 = rest2.desc in
- try
- unify env (build_fields (repr ty1).level miss1 va) rest2;
- unify env rest1 (build_fields (repr ty2).level miss2 va);
- List.iter
- (fun (n, k1, t1, k2, t2) ->
- unify_kind k1 k2;
- try unify env t1 t2 with Unify trace ->
- raise (Unify ((newty (Tfield(n, k1, t1, va)),
- newty (Tfield(n, k2, t2, va)))::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_pairs env tpl =
- List.iter (fun (t1, t2) -> unify env t1 t2) tpl
-
-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 rm1 == rm2 then () else
- let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
- ignore (List.fold_left
- (fun hl l ->
- let h = hash_variant l in
- try raise(Tags(l,List.assoc h hl))
- with Not_found -> (h,l)::hl)
- (List.map (fun (l,_) -> (hash_variant l, l)) row1.row_fields)
- (List.map fst r2));
- let more =
- if row1.row_fixed then rm1 else
- if row2.row_fixed then rm2 else
- newgenvar ()
- in update_level env (min rm1.level rm2.level) more;
- let fixed = row1.row_fixed || row2.row_fixed
- 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 mkvariant fields closed =
- newgenty
- (Tvariant
- {row_fields = fields; row_closed = closed; row_more = newvar();
- row_bound = []; row_fixed = false; row_name = None }) in
- let empty fields =
- List.for_all (fun (_,f) -> row_field_repr f = Rabsent) fields in
- (* Check whether we are going to build an empty type *)
- 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 bound = row1.row_bound @ row2.row_bound in
- let row0 = {row_fields = []; row_more = more; row_bound = 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.row_fixed)
- || closed && row.row_fixed && 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;
- let rm = row_more row in
- if row.row_fixed then
- if row0.row_more == rm then () else begin
- link_type rm row0.row_more
- end
- else
- let ty = newty2 generic_level (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 row1 r2;
- set_more row2 r1;
- let undo = ref [] in
- List.iter
- (fun (l,f1,f2) ->
- unify_row_field env row1.row_fixed row2.row_fixed undo l f1 f2)
- pairs;
- (* Special case when there is only one field left *)
- if row0.row_closed then begin
- match filter_row_fields false (row_repr row1).row_fields with [l, fi] ->
- begin match row_field_repr fi with
- Reither(c, t1::tl, _, e) as f1 ->
- let f1' = Rpresent (Some t1) in
- set_row_field e f1';
- begin try
- if c then raise (Unify []);
- List.iter (unify env t1) tl
- with exn ->
- e := None;
- List.assoc l !undo := Some f1';
- raise exn
- end
- | Reither(true, [], _, e) ->
- set_row_field e (Rpresent None);
- | _ -> ()
- end
- | _ -> ()
- end
- with exn ->
- log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn
- end
-
-and unify_row_field env fixed1 fixed2 undo l f1 f2 =
- let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
- if f1 == f2 then () else
- match f1, f2 with
- 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 =
- (m1 || m2) &&
- 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 undo l f1 f2 else
- let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in
- let rec remq tl = function [] -> []
- | ty :: tl' ->
- 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
- 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';
- undo := (l, e2) :: !undo
- | Reither(_, _, false, e1), Rabsent -> set_row_field e1 f2
- | Rabsent, Reither(_, _, false, e2) -> set_row_field e2 f1
- | Rabsent, Rabsent -> ()
- | Reither(false, tl, _, e1), Rpresent(Some t2) when not fixed1 ->
- set_row_field e1 f2;
- (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;
- (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 =
- try
- unify env ty1 ty2
- with Unify trace ->
- raise (Unify (expand_trace env trace))
-
-let unify_var env t1 t2 =
- let t1 = repr t1 and t2 = repr t2 in
- if t1 == t2 then () else
- match t1.desc with
- Tvar ->
- begin try
- occur env t1 t2;
- update_level env t1.level t2;
- link_type t1 t2
- with Unify trace ->
- raise (Unify (expand_trace env ((t1,t2)::trace)))
- end
- | _ ->
- unify 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 =
- univar_pairs := [];
- unify env ty1 ty2
-
-
-(**** Special cases of unification ****)
-
-(*
- 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 rec filter_arrow env t l =
- let t = expand_head env t in
- match t.desc with
- Tvar ->
- let t1 = newvar () and t2 = newvar () in
- let t' = newty (Tarrow (l, t1, t2, Cok)) in
- update_level env t.level t';
- link_type t t';
- (t1, t2)
- | Tarrow(l', t1, t2, _)
- when l = l' || !Clflags.classic && l = "" && not (is_optional l') ->
- (t1, t2)
- | _ ->
- raise (Unify [])
-
-(* Used by [filter_method]. *)
-let rec filter_method_field env name priv ty =
- let ty = repr 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 rec filter_method env name priv ty =
- let ty = expand_head 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 ty.desc = Tvar && 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 ty;
- update_level env level ty
-
-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
- (Tunivar, Tunivar) ->
- unify_univar t1 t2 !univar_pairs
- | (Tvar, _) when if inst_nongen then t1.level <> generic_level - 1
- else t1.level = generic_level ->
- 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 if inst_nongen then t1'.level <> generic_level - 1
- else t1'.level = generic_level ->
- 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
- | (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)) ->
- let old_univars = !univar_pairs in
- 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;
- begin try
- moregen inst_nongen type_pairs env t1 t2;
- univar_pairs := old_univars
- with exn ->
- univar_pairs := old_univars; raise exn
- end
- | (_, _) ->
- 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 r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
- let r1, r2 =
- if row2.row_closed then
- filter_row_fields true r1, filter_row_fields false r2
- else r1, r2
- in
- if r1 <> [] || row1.row_closed && (not row2.row_closed || r2 <> [])
- then raise (Unify []);
- let rm1 = repr row1.row_more and rm2 = repr row2.row_more in
- let univ =
- match rm1.desc, rm2.desc with
- Tunivar, Tunivar ->
- unify_univar rm1 rm2 !univar_pairs;
- true
- | Tunivar, _ | _, Tunivar ->
- raise (Unify [])
- | _ ->
- if not (static_row row2) then moregen_occur env rm1.level rm2;
- let ext =
- if r2 = [] then rm2 else
- let row_ext = {row2 with row_fields = r2} in
- iter_row (moregen_occur env rm1.level) row_ext;
- newty2 rm1.level (Tvariant row_ext)
- in
- if ext != rm1 then link_type rm1 ext;
- false
- in
- 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 not univ ->
- 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 not univ ->
- set_row_field e1 f2
- | Reither(_, _, _, e1), Rabsent when not univ ->
- 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 subj_sch) in
- current_level := generic_level;
- (* Duplicate generic variables *)
- let patt = instance 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 more.desc = Tvar && not row.row_fixed then begin
- let more' = newty2 more.level Tvar 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; ty.desc = Tvar))
- 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 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 ->
- subst := (t1, t2) :: !subst
- end
- | (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, Tvar) when rename ->
- begin try
- normalize_subst subst;
- if List.assq t1' !subst != t2' then raise (Unify [])
- with Not_found ->
- 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
- | (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)) ->
- let old_univars = !univar_pairs in
- 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;
- begin try eqtype rename type_pairs subst env t1 t2
- with exn ->
- univar_pairs := old_univars;
- raise exn
- end;
- univar_pairs := old_univars
- | (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
- and (fields2, rest2) = flatten_fields ty2 in
- 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 =
- 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
-
-(* Two modes: with or without renaming of variables *)
-let equal env rename tyl1 tyl2 =
- try
- univar_pairs := [];
- eqtype_list rename (TypePairs.create 11) (ref []) env tyl1 tyl2; true
- with
- Unify _ -> false
-
-(* Must empty univar_pairs first *)
-let eqtype rename type_pairs subst env t1 t2 =
- univar_pairs := [];
- eqtype rename type_pairs subst env t1 t2
-
-
- (*************************)
- (* Class type matching *)
- (*************************)
-
-
-type class_match_failure =
- CM_Virtual_class
- | CM_Parameter_arity_mismatch of int * int
- | CM_Type_parameter_mismatch of (type_expr * type_expr) list
- | CM_Class_type_mismatch of class_type * class_type
- | CM_Parameter_mismatch of (type_expr * type_expr) list
- | CM_Val_type_mismatch of string * (type_expr * type_expr) list
- | CM_Meth_type_mismatch of string * (type_expr * type_expr) list
- | CM_Non_mutable_value of string
- | CM_Missing_value of string
- | CM_Missing_method of string
- | CM_Hide_public of string
- | CM_Hide_virtual of 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
- Tcty_constr (_, _, cty1), _ ->
- moregen_clty true type_pairs env cty1 cty2
- | _, Tcty_constr (_, _, cty2) ->
- moregen_clty true type_pairs env cty1 cty2
- | Tcty_fun (l1, ty1, cty1'), Tcty_fun (l2, ty2, cty2') when l1 = l2 ->
- begin try moregen true type_pairs env ty1 ty2 with Unify trace ->
- raise (Failure [CM_Parameter_mismatch (expand_trace env trace)])
- end;
- moregen_clty false type_pairs env cty1' cty2'
- | Tcty_signature sign1, Tcty_signature sign2 ->
- let ty1 = object_fields (repr sign1.cty_self) in
- let ty2 = object_fields (repr sign2.cty_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, expand_trace env trace)])
- end)
- pairs;
- Vars.iter
- (fun lab (mut, ty) ->
- let (mut', ty') = Vars.find lab sign1.cty_vars in
- try moregen true type_pairs env ty' ty with Unify trace ->
- raise (Failure [CM_Val_type_mismatch
- (lab, expand_trace env trace)]))
- sign2.cty_vars
- | _ ->
- raise (Failure [])
- with
- Failure error when trace ->
- raise (Failure (CM_Class_type_mismatch (cty1, cty2)::error))
-
-let match_class_types 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.cty_self in
- let t2 = repr sign2.cty_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.cty_concr then err
- else CM_Hide_virtual 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, ty) err ->
- try
- let (mut', ty') = Vars.find lab sign1.cty_vars in
- if mut = Mutable && mut' <> Mutable then
- CM_Non_mutable_value lab::err
- else
- err
- with Not_found ->
- CM_Missing_value lab::err)
- sign2.cty_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.cty_concr sign1.cty_concr))
- error
- in
- match error with
- [] ->
- begin try
- moregen_clty true type_pairs env patt subj;
- []
- with
- Failure r -> r
- end
- | error ->
- CM_Class_type_mismatch (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
- Tcty_constr (_, _, cty1), Tcty_constr (_, _, cty2) ->
- equal_clty true type_pairs subst env cty1 cty2
- | Tcty_constr (_, _, cty1), _ ->
- equal_clty true type_pairs subst env cty1 cty2
- | _, Tcty_constr (_, _, cty2) ->
- equal_clty true type_pairs subst env cty1 cty2
- | Tcty_fun (l1, ty1, cty1'), Tcty_fun (l2, ty2, cty2') when l1 = l2 ->
- begin try eqtype true type_pairs subst env ty1 ty2 with Unify trace ->
- raise (Failure [CM_Parameter_mismatch (expand_trace env trace)])
- end;
- equal_clty false type_pairs subst env cty1' cty2'
- | Tcty_signature sign1, Tcty_signature sign2 ->
- let ty1 = object_fields (repr sign1.cty_self) in
- let ty2 = object_fields (repr sign2.cty_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, expand_trace env trace)])
- end)
- pairs;
- Vars.iter
- (fun lab (mut, ty) ->
- let (mut', ty') = Vars.find lab sign1.cty_vars in
- try eqtype true type_pairs subst env ty ty' with Unify trace ->
- raise (Failure [CM_Val_type_mismatch
- (lab, expand_trace env trace)]))
- sign2.cty_vars
- | _ ->
- raise
- (Failure (if trace then []
- else [CM_Class_type_mismatch (cty1, cty2)]))
- with
- Failure error when trace ->
- raise (Failure (CM_Class_type_mismatch (cty1, cty2)::error))
-
-(* XXX On pourrait autoriser l'instantiation du type des parametres... *)
-(* XXX Correct ? (variables de type dans parametres et corps de classe *)
-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.cty_self in
- let t2 = repr sign2.cty_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 -> err
- | _ -> CM_Hide_public lab::err
- end
- in
- if Concr.mem lab sign1.cty_concr then err
- else CM_Hide_virtual 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, ty) err ->
- try
- let (mut', ty') = Vars.find lab sign1.cty_vars in
- if mut = Mutable && mut' <> Mutable then
- CM_Non_mutable_value lab::err
- else
- err
- with Not_found ->
- CM_Missing_value lab::err)
- sign2.cty_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.cty_concr sign1.cty_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
- (expand_trace env trace)]))
- patt_params subj_params;
- equal_clty false type_pairs subst env patt_type 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 sharp = function
- Path.Pident id ->
- Longident.Lident (sharp ^ Ident.name id)
- | Path.Pdot (p1, s, _) ->
- Longident.Ldot (lid_of_path "" p1, sharp ^ s)
- | Path.Papply (p1, p2) ->
- Longident.Lapply (lid_of_path sharp p1, lid_of_path "" p2)
-
-let find_cltype_for_path env p =
- let path, cl_abbr = Env.lookup_type (lid_of_path "#" p) env in
- match cl_abbr.type_manifest with
- Some ty ->
- begin match (repr ty).desc with
- Tobject(_,{contents=Some(p',_)}) when Path.same p p' -> cl_abbr, ty
- | _ -> raise Not_found
- end
- | None -> assert false
-
-let rec build_subtype env visited loops posi level t =
- let t = repr t in
- match t.desc with
- 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 ->
- 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 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
- ty.desc <- Tvar;
- 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 (t''.desc = Tvar);
- 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 then warn := true;
- let tl' =
- List.map2
- (fun (co,cn,_) t ->
- 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 bound = ref row.row_bound in
- let fields = filter_row_fields false row.row_fields in
- let short = posi && List.length fields <= 1 in
- let fields =
- List.map
- (fun (l,f as orig) -> match row_field_repr f with
- Rpresent None ->
- if posi && not short 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
- if posi && level > 0 && not short then begin
- bound := t' :: !bound;
- (l, Reither(false, [t'], false, ref None)), c
- end else
- (l, Rpresent(Some t')), c
- | _ -> assert false)
- fields
- in
- let c = collect fields in
- if posi && short && c = Unchanged then (t, Unchanged) else
- let row =
- { row_fields = List.map fst fields; row_more = newvar();
- row_bound = !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 ->
- (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 [] 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 ->
- subtype_rec env trace (expand_abbrev env t1) t2 cstrs
- | (_, Tconstr(p2, tl2, abbrev2)) when generic_abbrev env p2 ->
- 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 (co, cn, _) (t1, t2) ->
- 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
- | (Tobject (f1, _), Tobject (f2, _))
- when opened_object f1 && opened_object 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) ->
- let row1 = row_repr row1 and row2 = row_repr row2 in
- begin try
- if not row1.row_closed then raise Exit;
- let r1, r2, pairs =
- merge_row_fields row1.row_fields row2.row_fields in
- if filter_row_fields false r1 <> [] then raise Exit;
- 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
- with Exit ->
- (trace, t1, t2, !univar_pairs)::cstrs
- end
- | (Tpoly (u1, []), Tpoly (u2, [])) ->
- subtype_rec env trace u1 u2 cstrs
- | (Tpoly (t1, tl1), Tpoly (t2,tl2)) ->
- let old_univars = !univar_pairs in
- 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;
- let cstrs = subtype_rec env trace t1 t2 cstrs in
- univar_pairs := old_univars;
- cstrs
- | (_, _) ->
- (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 =
- let (fields1, rest1) = flatten_fields ty1 in
- let (fields2, rest2) = flatten_fields ty2 in
- let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
- (trace, rest1, build_fields (repr ty2).level miss2 (newvar ()),
- !univar_pairs)
- ::
- begin match rest2.desc with
- Tnil -> []
- | _ ->
- [trace, build_fields (repr ty1).level miss1 rest1, rest2, !univar_pairs]
- end
- @
- (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)
-
-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 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
- | _ ->
- 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
-
-let unroll_abbrev id tl ty =
- let ty = repr ty in
- if (ty.desc = Tvar) || (List.exists (deep_occur ty) tl) then
- ty
- else
- let ty' = newty2 ty.level ty.desc in
- link_type ty (newty2 ty.level (Tconstr (Path.Pident id, tl, ref Mnil)));
- ty'
-
-(* 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 env ty)
- with Cannot_expand ->
- false
- end
- | _ ->
- false
- in check_cycle [] ty
-
-(* Normalize a type before printing, saving... *)
-let rec normalize_type_rec env ty =
- let ty = repr ty in
- if ty.level >= lowest_level then begin
- mark_type_node ty;
- begin match ty.desc with
- | Tvariant row ->
- let row = row_repr row in
- let fields = List.map
- (fun (l,f) ->
- let f = row_field_repr f 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 List.length tyl' < List.length tyl + 1 then
- let f = Reither(b, List.rev tyl', m, ref None) in
- set_row_field e f;
- f
- else f
- | _ -> f)
- row.row_fields in
- let fields =
- List.sort (fun (p,_) (q,_) -> compare p q)
- (List.filter (fun (_,fi) -> fi <> Rabsent) fields)
- and bound = List.fold_left
- (fun tyl ty -> if List.memq ty tyl then tyl else ty :: tyl)
- [] (List.map repr row.row_bound)
- in
- log_type ty;
- ty.desc <- Tvariant {row with row_fields = fields; row_bound = bound}
- | Tobject (fi, nm) ->
- begin match !nm with
- | None -> ()
- | Some (n, v :: l) ->
- 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) ty
- end
-
-let normalize_type env ty =
- normalize_type_rec env ty;
- unmark_type ty
-
-
- (*************************)
- (* Remove dependencies *)
- (*************************)
-
-
-(*
- Variables are left unchanged. Other type nodes are duplicated, with
- levels set to generic level.
- During copying, the description of a (non-variable) node is first
- replaced by a link to a stub ([Tsubst (newgenvar ())]).
- Once the copy is made, it replaces the stub.
- After copying, the description of node, which was stored by
- [save_desc], must be put back, using [cleanup_types].
-*)
-
-let rec nondep_type_rec env id ty =
- let ty = repr ty in
- match ty.desc with
- Tvar | Tunivar -> ty
- | Tsubst ty -> ty
- | _ ->
- let desc = ty.desc in
- save_desc ty desc;
- let ty' = newgenvar () in (* Stub *)
- ty.desc <- Tsubst ty';
- ty'.desc <-
- begin match 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 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 ->
- raise Not_found
- end
- else
- Tconstr(p, List.map (nondep_type_rec env id) tl, ref Mnil)
- | 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 substitute in a subtle way *)
- (* Tsubst denotes the variant itself, as the row var is unchanged *)
- begin match more.desc with
- Tsubst ty2 ->
- (* This variant type has been already copied *)
- ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *)
- Tlink ty2
- | _ ->
- let static = static_row row in
- (* Register new type first for recursion *)
- save_desc more more.desc;
- more.desc <- ty.desc;
- let more' = if static then newgenvar () 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) desc
- end;
- ty'
-
-let nondep_type env id ty =
- try
- let ty' = nondep_type_rec env id ty in
- cleanup_types ();
- unmark_type ty';
- ty'
- with Not_found ->
- cleanup_types ();
- raise Not_found
-
-(* 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 decl =
- { type_params = params;
- type_arity = decl.type_arity;
- type_kind =
- begin try
- match decl.type_kind with
- Type_abstract ->
- Type_abstract
- | Type_variant(cstrs, priv) ->
- Type_variant(List.map
- (fun (c, tl) -> (c, List.map (nondep_type_rec env mid) tl))
- cstrs, priv)
- | Type_record(lbls, rep, priv) ->
- Type_record(
- List.map
- (fun (c, mut, t) -> (c, mut, nondep_type_rec env mid t))
- lbls,
- rep, priv)
- with Not_found when is_covariant ->
- Type_abstract
- end;
- type_manifest =
- begin 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
- end;
- type_variance = decl.type_variance;
- }
- in
- cleanup_types ();
- List.iter unmark_type decl.type_params;
- begin match decl.type_kind with
- Type_abstract -> ()
- | Type_variant(cstrs, priv) ->
- List.iter (fun (c, tl) -> List.iter unmark_type tl) cstrs
- | Type_record(lbls, rep, priv) ->
- List.iter (fun (c, mut, t) -> unmark_type t) lbls
- end;
- begin match decl.type_manifest with
- None -> ()
- | Some ty -> unmark_type ty
- end;
- decl
- with Not_found ->
- cleanup_types ();
- raise Not_found
-
-(* Preserve sharing inside class types. *)
-let nondep_class_signature env id sign =
- { cty_self = nondep_type_rec env id sign.cty_self;
- cty_vars =
- Vars.map (function (m, t) -> (m, nondep_type_rec env id t))
- sign.cty_vars;
- cty_concr = sign.cty_concr }
-
-let rec nondep_class_type env id =
- function
- Tcty_constr (p, _, cty) when Path.isfree id p ->
- nondep_class_type env id cty
- | Tcty_constr (p, tyl, cty) ->
- Tcty_constr (p, List.map (nondep_type_rec env id) tyl,
- nondep_class_type env id cty)
- | Tcty_signature sign ->
- Tcty_signature (nondep_class_signature env id sign)
- | Tcty_fun (l, ty, cty) ->
- Tcty_fun (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_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 }
- in
- cleanup_types ();
- List.iter unmark_type decl.cty_params;
- unmark_class_type decl.cty_type;
- begin match decl.cty_new with
- None -> ()
- | Some ty -> unmark_type ty
- end;
- 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_type = nondep_class_type env id decl.clty_type;
- clty_path = decl.clty_path }
- in
- cleanup_types ();
- List.iter unmark_type decl.clty_params;
- unmark_class_type decl.clty_type;
- 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
diff --git a/typing/ctype.mli b/typing/ctype.mli
deleted file mode 100644
index bc0ce50cc6..0000000000
--- a/typing/ctype.mli
+++ /dev/null
@@ -1,238 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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
-
-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 *)
-
-val newty: type_desc -> type_expr
-val newvar: unit -> type_expr
- (* Return a fresh variable *)
-val new_global_var: 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 dummy_method: label
-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 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 iterative_generalization: int -> type_expr list -> type_expr list
- (* Efficient repeated generalization of a 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: type_expr -> type_expr
- (* Take an instance of a type scheme *)
-val instance_list: type_expr list -> type_expr list
- (* Take an instance of a list of type schemes *)
-val instance_constructor:
- constructor_description -> type_expr list * type_expr
- (* Same, for a constructor *)
-val instance_parameterized_type:
- 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_class:
- type_expr list -> class_type -> type_expr list * class_type
-val instance_poly:
- 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 full_expand: Env.t -> type_expr -> type_expr
-
-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_var: Env.t -> type_expr -> type_expr -> unit
- (* Same as [unify], but allow free univars when first type
- is a variable. *)
-val filter_arrow: Env.t -> type_expr -> 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 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 (type_expr * type_expr) list
- | CM_Class_type_mismatch of class_type * class_type
- | CM_Parameter_mismatch of (type_expr * type_expr) list
- | CM_Val_type_mismatch of string * (type_expr * type_expr) list
- | CM_Meth_type_mismatch of string * (type_expr * type_expr) list
- | CM_Non_mutable_value of string
- | CM_Missing_value of string
- | CM_Missing_method of string
- | CM_Hide_public of string
- | CM_Hide_virtual of string
- | CM_Public_method of string
- | CM_Private_method of string
- | CM_Virtual_method of string
-val match_class_types:
- 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_class_declaration:
- Env.t -> Ident.t -> class_declaration -> class_declaration
- (* Same for class declarations. *)
-val nondep_cltype_declaration:
- Env.t -> Ident.t -> cltype_declaration -> cltype_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 normalize_type: Env.t -> type_expr -> unit
-
-val closed_schema: type_expr -> bool
- (* Check whether the given type scheme contains no non-generic
- type variables *)
-
-val closed_type_decl: type_declaration -> 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 *)
diff --git a/typing/datarepr.ml b/typing/datarepr.ml
deleted file mode 100644
index ddbd9fb276..0000000000
--- a/typing/datarepr.ml
+++ /dev/null
@@ -1,96 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Compute constructor and label descriptions from type declarations,
- determining their representation. *)
-
-open Misc
-open Asttypes
-open Types
-
-let constructor_descrs ty_res cstrs priv =
- let num_consts = ref 0 and num_nonconsts = ref 0 in
- List.iter
- (function (name, []) -> incr num_consts
- | (name, _) -> incr num_nonconsts)
- cstrs;
- let rec describe_constructors idx_const idx_nonconst = function
- [] -> []
- | (name, ty_args) :: rem ->
- let (tag, descr_rem) =
- match ty_args with
- [] -> (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 =
- { cstr_res = ty_res;
- cstr_args = ty_args;
- cstr_arity = List.length ty_args;
- cstr_tag = tag;
- cstr_consts = !num_consts;
- cstr_nonconsts = !num_nonconsts;
- cstr_private = priv } in
- (name, cstr) :: descr_rem in
- describe_constructors 0 0 cstrs
-
-let exception_descr path_exc decl =
- { cstr_res = Predef.type_exn;
- cstr_args = decl;
- cstr_arity = List.length decl;
- cstr_tag = Cstr_exception path_exc;
- cstr_consts = -1;
- cstr_nonconsts = -1;
- cstr_private = Public }
-
-let none = {desc = Ttuple []; level = -1; id = -1}
- (* Clearly ill-formed type *)
-let dummy_label =
- { lbl_res = none; lbl_arg = none; lbl_mut = Immutable;
- lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular;
- lbl_private = Public }
-
-let label_descrs ty_res lbls repres priv =
- let all_labels = Array.create (List.length lbls) dummy_label in
- let rec describe_labels num = function
- [] -> []
- | (name, mut_flag, ty_arg) :: rest ->
- let lbl =
- { lbl_res = ty_res;
- lbl_arg = ty_arg;
- lbl_mut = mut_flag;
- lbl_pos = num;
- lbl_all = all_labels;
- lbl_repres = repres;
- lbl_private = priv } in
- all_labels.(num) <- lbl;
- (name, 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
- | (name, [] as cstr) :: rem ->
- if tag = Cstr_constant num_const
- then cstr
- else find_constr tag (num_const + 1) num_nonconst rem
- | (name, _ as cstr) :: rem ->
- if tag = Cstr_block num_nonconst
- then cstr
- else find_constr tag num_const (num_nonconst + 1) rem
-
-let find_constr_by_tag tag cstrlist =
- find_constr tag 0 0 cstrlist
diff --git a/typing/datarepr.mli b/typing/datarepr.mli
deleted file mode 100644
index eb440aba27..0000000000
--- a/typing/datarepr.mli
+++ /dev/null
@@ -1,34 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Compute constructor and label descriptions from type declarations,
- determining their representation. *)
-
-open Asttypes
-open Types
-
-val constructor_descrs:
- type_expr -> (string * type_expr list) list -> private_flag ->
- (string * constructor_description) list
-val exception_descr:
- Path.t -> type_expr list -> constructor_description
-val label_descrs:
- type_expr -> (string * mutable_flag * type_expr) list ->
- record_representation -> private_flag ->
- (string * label_description) list
-
-exception Constr_not_found
-
-val find_constr_by_tag:
- constructor_tag -> (string * type_expr list) list -> string * type_expr list
diff --git a/typing/env.ml b/typing/env.ml
deleted file mode 100644
index 4ccb7f7e27..0000000000
--- a/typing/env.ml
+++ /dev/null
@@ -1,784 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Environment handling *)
-
-open Config
-open Misc
-open Asttypes
-open Longident
-open Path
-open Types
-
-
-type error =
- Not_an_interface of string
- | Corrupted_interface of string
- | Illegal_renaming of string * string
- | Inconsistent_import of string * string * string
-
-exception Error of error
-
-type summary =
- Env_empty
- | Env_value of summary * Ident.t * value_description
- | Env_type of summary * Ident.t * type_declaration
- | Env_exception of summary * Ident.t * exception_declaration
- | Env_module of summary * Ident.t * module_type
- | Env_modtype of summary * Ident.t * modtype_declaration
- | Env_class of summary * Ident.t * class_declaration
- | Env_cltype of summary * Ident.t * cltype_declaration
- | Env_open of summary * Path.t
-
-type t = {
- values: (Path.t * value_description) Ident.tbl;
- constrs: constructor_description Ident.tbl;
- labels: label_description Ident.tbl;
- types: (Path.t * type_declaration) Ident.tbl;
- modules: (Path.t * module_type) Ident.tbl;
- modtypes: (Path.t * modtype_declaration) Ident.tbl;
- components: (Path.t * module_components) Ident.tbl;
- classes: (Path.t * class_declaration) Ident.tbl;
- cltypes: (Path.t * cltype_declaration) Ident.tbl;
- summary: summary
-}
-
-and module_components = module_components_repr Lazy.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)) Tbl.t;
- mutable comp_labels: (string, (label_description * int)) Tbl.t;
- mutable comp_types: (string, (type_declaration * int)) Tbl.t;
- mutable comp_modules: (string, (module_type * 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, (cltype_declaration * int)) Tbl.t
-}
-
-and functor_components = {
- fcomp_param: Ident.t; (* Formal parameter *)
- fcomp_arg: module_type; (* Argument signature *)
- fcomp_res: module_type; (* Result signature *)
- fcomp_env: t; (* Environment in which the result signature makes sense *)
- fcomp_subst: Subst.t (* Prefixing substitution for the result signature *)
-}
-
-let empty = {
- values = Ident.empty; constrs = Ident.empty;
- labels = Ident.empty; types = Ident.empty;
- modules = Ident.empty; modtypes = Ident.empty;
- components = Ident.empty; classes = Ident.empty;
- cltypes = Ident.empty;
- summary = Env_empty }
-
-let diff_keys tbl1 tbl2 =
- let keys2 = Ident.keys tbl2 in
- List.filter
- (fun id ->
- match Ident.find_same id tbl2 with Pident _, _ ->
- (try ignore (Ident.find_same id tbl1); false with Not_found -> true)
- | _ -> false)
- keys2
-
-let diff env1 env2 =
- diff_keys env1.values env2.values @
- diff_keys env1.modules env2.modules @
- diff_keys env1.classes env2.classes
-
-(* Forward declarations *)
-
-let components_of_module' =
- ref ((fun env sub path mty -> assert false) :
- t -> Subst.t -> Path.t -> module_type -> module_components)
-let components_of_functor_appl' =
- ref ((fun f p1 p2 -> assert false) :
- functor_components -> Path.t -> Path.t -> module_components)
-let check_modtype_inclusion =
- (* to be filled with Includemod.check_modtype_inclusion *)
- ref ((fun env mty1 mty2 -> assert false) :
- t -> module_type -> module_type -> unit)
-
-(* Persistent structure descriptions *)
-
-type pers_struct =
- { ps_name: string;
- ps_sig: signature;
- ps_comps: module_components;
- ps_crcs: (string * Digest.t) list;
- ps_filename: string }
-
-let persistent_structures =
- (Hashtbl.create 17 : (string, pers_struct) Hashtbl.t)
-
-(* Consistency between persistent structures *)
-
-let crc_units = Consistbl.create()
-
-let check_consistency filename crcs =
- try
- List.iter
- (fun (name, crc) -> Consistbl.check crc_units name crc filename)
- crcs
- with Consistbl.Inconsistency(name, source, auth) ->
- raise(Error(Inconsistent_import(name, auth, source)))
-
-(* Reading persistent structures from .cmi files *)
-
-let read_pers_struct modname filename =
- let ic = open_in_bin filename in
- try
- let buffer = String.create (String.length cmi_magic_number) in
- really_input ic buffer 0 (String.length cmi_magic_number);
- if buffer <> cmi_magic_number then begin
- close_in ic;
- raise(Error(Not_an_interface filename))
- end;
- let (name, sign) = input_value ic in
- let crcs = input_value ic in
- close_in ic;
- let comps =
- !components_of_module' empty Subst.identity
- (Pident(Ident.create_persistent name))
- (Tmty_signature sign) in
- let ps = { ps_name = name;
- ps_sig = sign;
- ps_comps = comps;
- ps_crcs = crcs;
- ps_filename = filename } in
- if ps.ps_name <> modname then
- raise(Error(Illegal_renaming(ps.ps_name, filename)));
- check_consistency filename ps.ps_crcs;
- Hashtbl.add persistent_structures modname ps;
- ps
- with End_of_file | Failure _ ->
- close_in ic;
- raise(Error(Corrupted_interface(filename)))
-
-let find_pers_struct name =
- try
- Hashtbl.find persistent_structures name
- with Not_found ->
- read_pers_struct name (find_in_path_uncap !load_path (name ^ ".cmi"))
-
-let reset_cache() =
- Hashtbl.clear persistent_structures;
- Consistbl.clear crc_units
-
-(* Lookup by identifier *)
-
-let rec find_module_descr path env =
- match path with
- Pident id ->
- begin try
- let (p, desc) = Ident.find_same id env.components
- in desc
- with Not_found ->
- if Ident.persistent id
- then (find_pers_struct (Ident.name id)).ps_comps
- else raise Not_found
- end
- | Pdot(p, s, pos) ->
- begin match Lazy.force(find_module_descr p env) with
- Structure_comps c ->
- let (descr, pos) = Tbl.find s c.comp_components in
- descr
- | Functor_comps f ->
- raise Not_found
- end
- | Papply(p1, p2) ->
- begin match Lazy.force(find_module_descr p1 env) with
- Functor_comps f ->
- !components_of_functor_appl' f p1 p2
- | Structure_comps c ->
- raise Not_found
- end
-
-let find proj1 proj2 path env =
- match path with
- Pident id ->
- let (p, data) = Ident.find_same id (proj1 env)
- in data
- | Pdot(p, s, pos) ->
- begin match Lazy.force(find_module_descr p env) with
- Structure_comps c ->
- let (data, pos) = Tbl.find s (proj2 c) in data
- | Functor_comps f ->
- raise Not_found
- end
- | Papply(p1, p2) ->
- raise Not_found
-
-let find_value =
- find (fun env -> env.values) (fun sc -> sc.comp_values)
-and find_type =
- 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 find_type_expansion path env =
- let decl = find_type path env in
- match decl.type_manifest with
- None -> raise Not_found
- | Some body -> (decl.type_params, body)
-
-let find_modtype_expansion path env =
- match find_modtype path env with
- Tmodtype_abstract -> raise Not_found
- | Tmodtype_manifest mty -> mty
-
-let find_module path env =
- match path with
- Pident id ->
- begin try
- let (p, data) = Ident.find_same id env.modules
- in data
- with Not_found ->
- if Ident.persistent id then
- let ps = find_pers_struct (Ident.name id) in
- Tmty_signature(ps.ps_sig)
- else raise Not_found
- end
- | Pdot(p, s, pos) ->
- begin match Lazy.force (find_module_descr p env) with
- Structure_comps c ->
- let (data, pos) = Tbl.find s c.comp_modules in data
- | Functor_comps f ->
- raise Not_found
- end
- | Papply(p1, p2) ->
- raise Not_found (* not right *)
-
-(* Lookup by name *)
-
-let rec lookup_module_descr lid env =
- match lid with
- Lident s ->
- begin try
- Ident.find_name s env.components
- with 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 l env in
- begin match Lazy.force descr with
- Structure_comps c ->
- let (descr, pos) = Tbl.find s c.comp_components in
- (Pdot(p, s, pos), descr)
- | Functor_comps f ->
- raise Not_found
- end
- | Lapply(l1, l2) ->
- let (p1, desc1) = lookup_module_descr l1 env in
- let (p2, mty2) = lookup_module l2 env in
- begin match Lazy.force desc1 with
- Functor_comps f ->
- !check_modtype_inclusion env mty2 f.fcomp_arg;
- (Papply(p1, p2), !components_of_functor_appl' f p1 p2)
- | Structure_comps c ->
- raise Not_found
- end
-
-and lookup_module lid env =
- match lid with
- Lident s ->
- begin try
- Ident.find_name s env.modules
- with Not_found ->
- let ps = find_pers_struct s in
- (Pident(Ident.create_persistent s), Tmty_signature ps.ps_sig)
- end
- | Ldot(l, s) ->
- let (p, descr) = lookup_module_descr l env in
- begin match Lazy.force descr with
- Structure_comps c ->
- let (data, pos) = Tbl.find s c.comp_modules in
- (Pdot(p, s, pos), data)
- | Functor_comps f ->
- raise Not_found
- end
- | Lapply(l1, l2) ->
- let (p1, desc1) = lookup_module_descr l1 env in
- let (p2, mty2) = lookup_module l2 env in
- let p = Papply(p1, p2) in
- begin match Lazy.force desc1 with
- Functor_comps f ->
- !check_modtype_inclusion env mty2 f.fcomp_arg;
- (p, Subst.modtype (Subst.add_module f.fcomp_param p2 f.fcomp_subst)
- f.fcomp_res)
- | Structure_comps c ->
- raise Not_found
- end
-
-let lookup proj1 proj2 lid env =
- match lid with
- Lident s ->
- Ident.find_name s (proj1 env)
- | Ldot(l, s) ->
- let (p, desc) = lookup_module_descr l env in
- begin match Lazy.force desc with
- Structure_comps c ->
- let (data, pos) = Tbl.find s (proj2 c) in
- (Pdot(p, s, pos), data)
- | Functor_comps f ->
- raise Not_found
- end
- | Lapply(l1, l2) ->
- raise Not_found
-
-let lookup_simple proj1 proj2 lid env =
- match lid with
- Lident s ->
- Ident.find_name s (proj1 env)
- | Ldot(l, s) ->
- let (p, desc) = lookup_module_descr l env in
- begin match Lazy.force desc with
- Structure_comps c ->
- let (data, pos) = Tbl.find s (proj2 c) in
- data
- | Functor_comps f ->
- raise Not_found
- end
- | Lapply(l1, l2) ->
- raise Not_found
-
-let lookup_value =
- lookup (fun env -> env.values) (fun sc -> sc.comp_values)
-and lookup_constructor =
- lookup_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
-and lookup_label =
- lookup_simple (fun env -> env.labels) (fun sc -> sc.comp_labels)
-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)
-
-(* Expand manifest module type names at the top of the given module type *)
-
-let rec scrape_modtype mty env =
- match mty with
- Tmty_ident path ->
- begin try
- scrape_modtype (find_modtype_expansion path env) env
- with Not_found ->
- mty
- end
- | _ -> mty
-
-(* Compute constructor descriptions *)
-
-let constructors_of_type ty_path decl =
- match decl.type_kind with
- Type_variant(cstrs, priv) ->
- Datarepr.constructor_descrs
- (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
- cstrs priv
- | Type_record _ | Type_abstract -> []
-
-(* Compute label descriptions *)
-
-let labels_of_type ty_path decl =
- match decl.type_kind with
- Type_record(labels, rep, priv) ->
- Datarepr.label_descrs
- (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
- labels rep priv
- | Type_variant _ | Type_abstract -> []
-
-(* 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)
- | Tsig_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)
- | Tsig_type(id, decl) :: rem ->
- let p = Pdot(root, Ident.name id, nopos) in
- let (pl, final_sub) =
- prefix_idents root pos (Subst.add_type id p sub) rem in
- (p::pl, final_sub)
- | Tsig_exception(id, decl) :: rem ->
- let p = Pdot(root, Ident.name id, pos) in
- let (pl, final_sub) = prefix_idents root (pos+1) sub rem in
- (p::pl, final_sub)
- | Tsig_module(id, mty) :: rem ->
- let p = Pdot(root, Ident.name id, pos) in
- let (pl, final_sub) =
- prefix_idents root (pos+1) (Subst.add_module id p sub) rem in
- (p::pl, final_sub)
- | Tsig_modtype(id, decl) :: rem ->
- let p = Pdot(root, Ident.name id, nopos) in
- let (pl, final_sub) =
- prefix_idents root pos
- (Subst.add_modtype id (Tmty_ident p) sub) rem in
- (p::pl, final_sub)
- | Tsig_class(id, decl) :: rem ->
- let p = Pdot(root, Ident.name id, pos) in
- let (pl, final_sub) = prefix_idents root (pos + 1) sub rem in
- (p::pl, final_sub)
- | Tsig_cltype(id, decl) :: rem ->
- let p = Pdot(root, Ident.name id, nopos) in
- let (pl, final_sub) = prefix_idents root pos sub rem in
- (p::pl, final_sub)
-
-(* Compute structure descriptions *)
-
-let rec components_of_module env sub path mty =
- lazy(match scrape_modtype mty env with
- Tmty_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 path 0 sub sg in
- let env = ref env in
- let pos = ref 0 in
- List.iter2 (fun item path ->
- match item with
- Tsig_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
- | Tsig_type(id, decl) ->
- let decl' = Subst.type_declaration sub decl in
- c.comp_types <-
- Tbl.add (Ident.name id) (decl', nopos) c.comp_types;
- List.iter
- (fun (name, descr) ->
- c.comp_constrs <- Tbl.add name (descr, nopos) c.comp_constrs)
- (constructors_of_type path decl');
- List.iter
- (fun (name, descr) ->
- c.comp_labels <- Tbl.add name (descr, nopos) c.comp_labels)
- (labels_of_type path decl');
- env := store_type_infos id path decl !env
- | Tsig_exception(id, decl) ->
- let decl' = Subst.exception_declaration sub decl in
- let cstr = Datarepr.exception_descr path decl' in
- c.comp_constrs <-
- Tbl.add (Ident.name id) (cstr, !pos) c.comp_constrs;
- incr pos
- | Tsig_module(id, mty) ->
- let mty' = Subst.modtype sub mty in
- c.comp_modules <-
- Tbl.add (Ident.name id) (mty', !pos) c.comp_modules;
- let comps = components_of_module !env sub path mty in
- c.comp_components <-
- Tbl.add (Ident.name id) (comps, !pos) c.comp_components;
- env := store_module id path mty !env;
- incr pos
- | Tsig_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 id path decl !env
- | Tsig_class(id, decl) ->
- let decl' = Subst.class_declaration sub decl in
- c.comp_classes <-
- Tbl.add (Ident.name id) (decl', !pos) c.comp_classes;
- incr pos
- | Tsig_cltype(id, decl) ->
- 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
- | Tmty_functor(param, ty_arg, ty_res) ->
- Functor_comps {
- fcomp_param = param;
- (* fcomp_arg must be prefixed eagerly, because it is interpreted
- in the outer environment, not in env *)
- fcomp_arg = Subst.modtype sub ty_arg;
- (* fcomp_res is prefixed lazily, because it is interpreted in env *)
- fcomp_res = ty_res;
- fcomp_env = env;
- fcomp_subst = sub }
- | Tmty_ident p ->
- 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 store_value id path decl env =
- { env with
- values = Ident.add id (path, decl) env.values;
- summary = Env_value(env.summary, id, decl) }
-
-and store_type id path info env =
- { env with
- constrs =
- List.fold_right
- (fun (name, descr) constrs ->
- Ident.add (Ident.create name) descr constrs)
- (constructors_of_type path info)
- env.constrs;
- labels =
- List.fold_right
- (fun (name, descr) labels ->
- Ident.add (Ident.create name) descr labels)
- (labels_of_type path info)
- env.labels;
- types = Ident.add id (path, info) env.types;
- summary = Env_type(env.summary, id, info) }
-
-and store_type_infos id path info env =
- (* 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 = Ident.add id (path, info) env.types;
- summary = Env_type(env.summary, id, info) }
-
-and store_exception id path decl env =
- { env with
- constrs = Ident.add id (Datarepr.exception_descr path decl) env.constrs;
- summary = Env_exception(env.summary, id, decl) }
-
-and store_module id path mty env =
- { env with
- modules = Ident.add id (path, mty) env.modules;
- components =
- Ident.add id (path, components_of_module env Subst.identity path mty)
- env.components;
- summary = Env_module(env.summary, id, mty) }
-
-and store_modtype id path info env =
- { env with
- modtypes = Ident.add id (path, info) env.modtypes;
- summary = Env_modtype(env.summary, id, info) }
-
-and store_class id path desc env =
- { env with
- classes = Ident.add id (path, desc) env.classes;
- summary = Env_class(env.summary, id, desc) }
-
-and store_cltype id path desc env =
- { env with
- cltypes = Ident.add id (path, desc) env.cltypes;
- summary = Env_cltype(env.summary, id, desc) }
-
-(* Compute the components of a functor application in a path. *)
-
-let components_of_functor_appl f p1 p2 =
- let p = Papply(p1, p2) in
- let mty =
- Subst.modtype (Subst.add_module f.fcomp_param p2 Subst.identity)
- f.fcomp_res in
- components_of_module f.fcomp_env f.fcomp_subst p mty
-
-(* Define forward functions *)
-
-let _ =
- components_of_module' := components_of_module;
- components_of_functor_appl' := components_of_functor_appl
-
-(* Insertion of bindings by identifier *)
-
-let add_value id desc env =
- store_value id (Pident id) desc env
-
-and add_type id info env =
- store_type id (Pident id) info env
-
-and add_exception id decl env =
- store_exception id (Pident id) decl env
-
-and add_module id mty env =
- store_module id (Pident id) mty env
-
-and add_modtype id info env =
- store_modtype id (Pident id) info env
-
-and add_class id ty env =
- store_class id (Pident id) ty env
-
-and add_cltype id ty env =
- store_cltype id (Pident id) ty env
-
-(* Insertion of bindings by name *)
-
-let enter store_fun name data env =
- let id = Ident.create name in (id, store_fun id (Pident id) data env)
-
-let enter_value = enter store_value
-and enter_type = enter store_type
-and enter_exception = enter store_exception
-and enter_module = enter store_module
-and enter_modtype = enter store_modtype
-and enter_class = enter store_class
-and enter_cltype = enter store_cltype
-
-(* Insertion of all components of a signature *)
-
-let add_item comp env =
- match comp with
- Tsig_value(id, decl) -> add_value id decl env
- | Tsig_type(id, decl) -> add_type id decl env
- | Tsig_exception(id, decl) -> add_exception id decl env
- | Tsig_module(id, mty) -> add_module id mty env
- | Tsig_modtype(id, decl) -> add_modtype id decl env
- | Tsig_class(id, decl) -> add_class id decl env
- | Tsig_cltype(id, decl) -> add_cltype id decl env
-
-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 root sg env =
- (* First build the paths and substitution *)
- let (pl, sub) = prefix_idents root 0 Subst.identity sg in
- (* Then enter the components in the environment after substitution *)
- let newenv =
- List.fold_left2
- (fun env item p ->
- match item with
- Tsig_value(id, decl) ->
- store_value (Ident.hide id) p
- (Subst.value_description sub decl) env
- | Tsig_type(id, decl) ->
- store_type (Ident.hide id) p
- (Subst.type_declaration sub decl) env
- | Tsig_exception(id, decl) ->
- store_exception (Ident.hide id) p
- (Subst.exception_declaration sub decl) env
- | Tsig_module(id, mty) ->
- store_module (Ident.hide id) p (Subst.modtype sub mty) env
- | Tsig_modtype(id, decl) ->
- store_modtype (Ident.hide id) p
- (Subst.modtype_declaration sub decl) env
- | Tsig_class(id, decl) ->
- store_class (Ident.hide id) p
- (Subst.class_declaration sub decl) env
- | Tsig_cltype(id, decl) ->
- store_cltype (Ident.hide id) p
- (Subst.cltype_declaration sub decl) env)
- env sg pl in
- { newenv with summary = Env_open(env.summary, root) }
-
-(* Open a signature from a file *)
-
-let open_pers_signature name env =
- let ps = find_pers_struct name in
- open_signature (Pident(Ident.create_persistent name)) ps.ps_sig env
-
-(* Read a signature from a file *)
-
-let read_signature modname filename =
- let ps = read_pers_struct modname filename in 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
- try
- List.assoc name ps.ps_crcs
- with Not_found ->
- assert false
-
-(* Return the list of imported interfaces with their CRCs *)
-
-let imported_units() =
- Consistbl.extract crc_units
-
-(* Save a signature to a file *)
-
-let save_signature_with_imports sg modname filename imports =
- Btype.cleanup_abbrev ();
- Subst.reset_for_saving ();
- let sg = Subst.signature (Subst.for_saving Subst.identity) sg in
- let oc = open_out_bin filename in
- try
- output_string oc cmi_magic_number;
- output_value oc (modname, sg);
- flush oc;
- let crc = Digest.file filename in
- let crcs = (modname, crc) :: imports in
- output_value oc crcs;
- close_out oc;
- (* Enter signature in persistent table so that imported_unit()
- will also return its crc *)
- let comps =
- components_of_module empty Subst.identity
- (Pident(Ident.create_persistent modname)) (Tmty_signature sg) in
- let ps =
- { ps_name = modname;
- ps_sig = sg;
- ps_comps = comps;
- ps_crcs = crcs;
- ps_filename = filename } in
- Hashtbl.add persistent_structures modname ps;
- Consistbl.set crc_units modname crc filename
- with exn ->
- close_out oc;
- remove_file filename;
- raise exn
-
-let save_signature sg modname filename =
- save_signature_with_imports sg modname filename (imported_units())
-
-(* Make the initial environment *)
-
-let initial = Predef.build_initial_env add_type add_exception empty
-
-(* Return the environment summary *)
-
-let summary env = env.summary
-
-(* Error report *)
-
-open Format
-
-let report_error ppf = function
- | Not_an_interface filename -> fprintf ppf
- "%s@ is not a compiled interface" filename
- | Corrupted_interface filename -> fprintf ppf
- "Corrupted compiled interface@ %s" filename
- | Illegal_renaming(modname, filename) -> fprintf ppf
- "Wrong file naming: %s@ contains the compiled interface for@ %s"
- filename modname
- | Inconsistent_import(name, source1, source2) -> fprintf ppf
- "@[<hov>The files %s@ and %s@ \
- make inconsistent assumptions@ over interface %s@]"
- source1 source2 name
diff --git a/typing/env.mli b/typing/env.mli
deleted file mode 100644
index aec0c29daf..0000000000
--- a/typing/env.mli
+++ /dev/null
@@ -1,139 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Environment handling *)
-
-open Types
-
-type t
-
-val empty: t
-val initial: t
-val diff: t -> t -> Ident.t list
-
-(* Lookup by paths *)
-
-val find_value: Path.t -> t -> value_description
-val find_type: Path.t -> t -> type_declaration
-val find_module: Path.t -> t -> module_type
-val find_modtype: Path.t -> t -> modtype_declaration
-val find_class: Path.t -> t -> class_declaration
-val find_cltype: Path.t -> t -> cltype_declaration
-
-val find_type_expansion: Path.t -> t -> type_expr list * type_expr
-val find_modtype_expansion: Path.t -> t -> Types.module_type
-
-(* Lookup by long identifiers *)
-
-val lookup_value: Longident.t -> t -> Path.t * value_description
-val lookup_constructor: Longident.t -> t -> constructor_description
-val lookup_label: Longident.t -> t -> label_description
-val lookup_type: Longident.t -> t -> Path.t * type_declaration
-val lookup_module: Longident.t -> t -> Path.t * module_type
-val lookup_modtype: Longident.t -> t -> Path.t * modtype_declaration
-val lookup_class: Longident.t -> t -> Path.t * class_declaration
-val lookup_cltype: Longident.t -> t -> Path.t * cltype_declaration
-
-(* Insertion by identifier *)
-
-val add_value: Ident.t -> value_description -> t -> t
-val add_type: Ident.t -> type_declaration -> t -> t
-val add_exception: Ident.t -> exception_declaration -> t -> t
-val add_module: Ident.t -> module_type -> 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 -> cltype_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: Path.t -> signature -> t -> t
-val open_pers_signature: string -> t -> t
-
-(* Insertion by name *)
-
-val enter_value: string -> value_description -> t -> Ident.t * t
-val enter_type: string -> type_declaration -> t -> Ident.t * t
-val enter_exception: string -> exception_declaration -> t -> Ident.t * t
-val enter_module: string -> module_type -> t -> Ident.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 -> cltype_declaration -> t -> Ident.t * t
-
-(* Reset the cache of in-core module interfaces.
- To be called in particular when load_path changes. *)
-
-val reset_cache: unit -> unit
-
-(* Read, save a signature to/from a file *)
-
-val read_signature: string -> string -> signature
- (* Arguments: module name, file name. Results: signature. *)
-val save_signature: signature -> string -> string -> unit
- (* Arguments: signature, module name, file name. *)
-val save_signature_with_imports:
- signature -> string -> string -> (string * Digest.t) list -> unit
- (* 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 imported_units: unit -> (string * Digest.t) list
-
-(* Direct access to the table of imported compilation units with their CRC *)
-
-val crc_units: Consistbl.t
-
-(* Summaries -- compact representation of an environment, to be
- exported in debugging information. *)
-
-type summary =
- Env_empty
- | Env_value of summary * Ident.t * value_description
- | Env_type of summary * Ident.t * type_declaration
- | Env_exception of summary * Ident.t * exception_declaration
- | Env_module of summary * Ident.t * module_type
- | Env_modtype of summary * Ident.t * modtype_declaration
- | Env_class of summary * Ident.t * class_declaration
- | Env_cltype of summary * Ident.t * cltype_declaration
- | Env_open of summary * Path.t
-
-val summary: t -> summary
-
-(* Error report *)
-
-type error =
- Not_an_interface of string
- | Corrupted_interface of string
- | Illegal_renaming of string * string
- | Inconsistent_import of string * string * string
-
-exception Error of error
-
-open Format
-
-val report_error: formatter -> error -> unit
-
-(* Forward declaration to break mutual recursion with Includemod. *)
-val check_modtype_inclusion: (t -> module_type -> module_type -> unit) ref
-
diff --git a/typing/ident.ml b/typing/ident.ml
deleted file mode 100644
index ccc132f094..0000000000
--- a/typing/ident.ml
+++ /dev/null
@@ -1,172 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Format
-
-type t = { stamp: int; name: string; mutable global: bool }
-
-(* A stamp of 0 denotes a persistent identifier *)
-
-let currentstamp = ref 0
-
-let create s =
- incr currentstamp;
- { name = s; stamp = !currentstamp; global = false }
-
-let create_persistent s =
- { name = s; stamp = 0; global = true }
-
-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 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.global <- true
-
-let global i =
- i.global
-
-let print ppf i =
- match i.stamp with
- | 0 -> fprintf ppf "%s!" i.name
- | -1 -> fprintf ppf "%s#" i.name
- | n -> fprintf ppf "%s/%i%s" i.name n (if i.global then "g" else "")
-
-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 keys_aux stack accu = function
- Empty ->
- begin match stack with
- [] -> accu
- | a :: l -> keys_aux l accu a
- end
- | Node(l, k, r, _) ->
- keys_aux (l :: stack) (k.ident :: accu) r
-
-let keys tbl = keys_aux [] [] tbl
diff --git a/typing/ident.mli b/typing/ident.mli
deleted file mode 100644
index ccb0ca46f4..0000000000
--- a/typing/ident.mli
+++ /dev/null
@@ -1,57 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Identifiers (unique names) *)
-
-type t
-
-val create: string -> t
-val create_persistent: 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 equal: t -> t -> bool
- (* Compare identifiers by name. *)
-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 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 binding_time: t -> int
-val current_time: unit -> int
-val set_current_time: int -> unit
-val reinit: unit -> unit
-
-val print: Format.formatter -> t -> 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 keys: 'a tbl -> t list
diff --git a/typing/includeclass.ml b/typing/includeclass.ml
deleted file mode 100644
index 912f64ace8..0000000000
--- a/typing/includeclass.ml
+++ /dev/null
@@ -1,104 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* 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 Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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 include_err ppf =
- function
- | CM_Virtual_class ->
- fprintf ppf "A class cannot be changed from virtual to concrete"
- | CM_Parameter_arity_mismatch (ls, lp) ->
- fprintf ppf
- "The classes do not have the same number of type parameters"
- | CM_Type_parameter_mismatch trace ->
- fprintf ppf "@[%a@]"
- (Printtyp.unification_error false trace
- (function ppf ->
- fprintf ppf "One type parameter has type"))
- (function ppf ->
- fprintf ppf "but is expected to have type")
- | CM_Class_type_mismatch (cty1, cty2) ->
- fprintf ppf
- "@[The class type@;<1 2>%a@ is not matched by the class type@;<1 2>%a@]"
- Printtyp.class_type cty1 Printtyp.class_type cty2
- | CM_Parameter_mismatch trace ->
- fprintf ppf "@[%a@]"
- (Printtyp.unification_error false trace
- (function ppf ->
- fprintf ppf "One parameter has type"))
- (function ppf ->
- fprintf ppf "but is expected to have type")
- | CM_Val_type_mismatch (lab, trace) ->
- fprintf ppf "@[%a@]"
- (Printtyp.unification_error 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, trace) ->
- fprintf ppf "@[%a@]"
- (Printtyp.unification_error 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_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 lab ->
- fprintf ppf "@[The virtual method %s cannot be hidden@]" 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 "@[<v>%a%a@]" include_err err print_errs errs
-
-
-
diff --git a/typing/includeclass.mli b/typing/includeclass.mli
deleted file mode 100644
index 5596056d0f..0000000000
--- a/typing/includeclass.mli
+++ /dev/null
@@ -1,31 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* 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 Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Inclusion checks for the class language *)
-
-open Types
-open Typedtree
-open Ctype
-open Format
-
-val class_types:
- Env.t -> class_type -> class_type -> class_match_failure list
-val class_type_declarations:
- Env.t -> cltype_declaration -> cltype_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
deleted file mode 100644
index 0c98acdd08..0000000000
--- a/typing/includecore.ml
+++ /dev/null
@@ -1,123 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Inclusion checks for the core language *)
-
-open Misc
-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, _) -> Tcoerce_primitive p
- | (_, Val_prim p) -> raise Dont_match
- | (_, _) -> Tcoerce_none
- end else
- raise Dont_match
-
-(* Inclusion between "private" annotations *)
-
-let private_flags priv1 priv2 =
- match (priv1, priv2) with (Private, Public) -> false | (_, _) -> true
-
-(* Inclusion between type declarations *)
-
-let type_declarations env id decl1 decl2 =
- decl1.type_arity = decl2.type_arity &&
- begin match (decl1.type_kind, decl2.type_kind) with
- (_, Type_abstract) -> true
- | (Type_variant (cstrs1, priv1), Type_variant (cstrs2, priv2)) ->
- private_flags priv1 priv2 &&
- Misc.for_all2
- (fun (cstr1, arg1) (cstr2, arg2) ->
- cstr1 = cstr2 &&
- Misc.for_all2
- (fun ty1 ty2 ->
- Ctype.equal env true (ty1::decl1.type_params)
- (ty2::decl2.type_params))
- arg1 arg2)
- cstrs1 cstrs2
- | (Type_record(labels1,rep1,priv1), Type_record(labels2,rep2,priv2)) ->
- private_flags priv1 priv2 &&
- rep1 = rep2 &&
- Misc.for_all2
- (fun (lbl1, mut1, ty1) (lbl2, mut2, ty2) ->
- lbl1 = lbl2 && mut1 = mut2 &&
- Ctype.equal env true (ty1::decl1.type_params)
- (ty2::decl2.type_params))
- labels1 labels2
- | (_, _) -> false
- end &&
- begin match (decl1.type_manifest, decl2.type_manifest) with
- (_, None) ->
- Ctype.equal env true decl1.type_params decl2.type_params
- | (Some ty1, Some ty2) ->
- Ctype.equal env true (ty1::decl1.type_params)
- (ty2::decl2.type_params)
- | (None, Some ty2) ->
- let ty1 =
- Btype.newgenty (Tconstr(Pident id, decl2.type_params, ref Mnil))
- in
- Ctype.equal env true decl1.type_params decl2.type_params &&
- Ctype.equal env false [ty1] [ty2]
- end &&
- begin decl2.type_kind <> Type_abstract || decl2.type_manifest <> None ||
- List.for_all2
- (fun (co1,cn1,ct1) (co2,cn2,ct2) -> (not co1 || co2) && (not cn1 || cn2))
- decl1.type_variance decl2.type_variance
- end
-
-(* Inclusion between exception declarations *)
-
-let exception_declarations env ed1 ed2 =
- Misc.for_all2 (fun ty1 ty2 -> Ctype.equal env false [ty1] [ty2]) ed1 ed2
-
-(* Inclusion between class types *)
-let encode_val (mut, ty) rem =
- begin match mut with
- Asttypes.Mutable -> Predef.type_unit
- | Asttypes.Immutable -> Btype.newgenty Tvar
- end
- ::ty::rem
-
-let meths meths1 meths2 =
- Meths.fold
- (fun nam t2 (ml1, ml2) ->
- (begin try
- Meths.find nam meths1 :: ml1
- with Not_found ->
- ml1
- end,
- t2 :: ml2))
- meths2 ([], [])
-
-let vars vars1 vars2 =
- Vars.fold
- (fun lab v2 (vl1, vl2) ->
- (begin try
- encode_val (Vars.find lab vars1) vl1
- with Not_found ->
- vl1
- end,
- encode_val v2 vl2))
- vars2 ([], [])
diff --git a/typing/includecore.mli b/typing/includecore.mli
deleted file mode 100644
index c68ad237df..0000000000
--- a/typing/includecore.mli
+++ /dev/null
@@ -1,31 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Inclusion checks for the core language *)
-
-open Types
-open Typedtree
-
-exception Dont_match
-
-val value_descriptions:
- Env.t -> value_description -> value_description -> module_coercion
-val type_declarations:
- Env.t -> Ident.t -> type_declaration -> type_declaration -> bool
-val exception_declarations:
- Env.t -> exception_declaration -> exception_declaration -> bool
-(*
-val class_types:
- Env.t -> class_type -> class_type -> bool
-*)
diff --git a/typing/includemod.ml b/typing/includemod.ml
deleted file mode 100644
index d2f2436a69..0000000000
--- a/typing/includemod.ml
+++ /dev/null
@@ -1,376 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Inclusion checks for the module language *)
-
-open Misc
-open Path
-open Types
-open Typedtree
-
-type error =
- Missing_field of Ident.t
- | Value_descriptions of Ident.t * value_description * value_description
- | Type_declarations of Ident.t * type_declaration * type_declaration
- | Exception_declarations of
- Ident.t * exception_declaration * exception_declaration
- | 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 * cltype_declaration * cltype_declaration *
- Ctype.class_match_failure list
- | Class_declarations of
- Ident.t * class_declaration * class_declaration *
- Ctype.class_match_failure list
-
-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 subst id vd1 vd2 =
- let vd2 = Subst.value_description subst vd2 in
- try
- Includecore.value_descriptions env vd1 vd2
- with Includecore.Dont_match ->
- raise(Error[Value_descriptions(id, vd1, vd2)])
-
-(* Inclusion between type declarations *)
-
-let type_declarations env subst id decl1 decl2 =
- let decl2 = Subst.type_declaration subst decl2 in
- if Includecore.type_declarations env id decl1 decl2
- then ()
- else raise(Error[Type_declarations(id, decl1, decl2)])
-
-(* Inclusion between exception declarations *)
-
-let exception_declarations env subst id decl1 decl2 =
- let decl2 = Subst.exception_declaration subst decl2 in
- if Includecore.exception_declarations env decl1 decl2
- then ()
- else raise(Error[Exception_declarations(id, decl1, decl2)])
-
-(* Inclusion between class declarations *)
-
-let class_type_declarations env subst id decl1 decl2 =
- let decl2 = Subst.cltype_declaration subst decl2 in
- match Includeclass.class_type_declarations env decl1 decl2 with
- [] -> ()
- | reason -> raise(Error[Class_type_declarations(id, decl1, decl2, reason)])
-
-let class_declarations env subst id decl1 decl2 =
- let decl2 = Subst.class_declaration subst decl2 in
- match Includeclass.class_declarations env decl1 decl2 with
- [] -> ()
- | reason -> raise(Error[Class_declarations(id, decl1, decl2, reason)])
-
-(* Expand a module type identifier when possible *)
-
-exception Dont_match
-
-let expand_module_path env path =
- try
- Env.find_modtype_expansion path env
- with Not_found ->
- raise Dont_match
-
-(* Extract name, kind and ident from a signature item *)
-
-type field_desc =
- Field_value of string
- | Field_type of string
- | Field_exception of string
- | Field_module of string
- | Field_modtype of string
- | Field_class of string
- | Field_classtype of string
-
-let item_ident_name = function
- Tsig_value(id, _) -> (id, Field_value(Ident.name id))
- | Tsig_type(id, _) -> (id, Field_type(Ident.name id))
- | Tsig_exception(id, _) -> (id, Field_exception(Ident.name id))
- | Tsig_module(id, _) -> (id, Field_module(Ident.name id))
- | Tsig_modtype(id, _) -> (id, Field_modtype(Ident.name id))
- | Tsig_class(id, _) -> (id, Field_class(Ident.name id))
- | Tsig_cltype(id, _) -> (id, Field_classtype(Ident.name id))
-
-(* Simplify a structure coercion *)
-
-let simplify_structure_coercion cc =
- let pos = ref 0 in
- try
- List.iter
- (fun (n, c) ->
- if n <> !pos || c <> Tcoerce_none then raise Exit;
- incr pos)
- cc;
- Tcoerce_none
- with Exit ->
- Tcoerce_structure cc
-
-(* 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 subst mty1 mty2 =
- try
- try_modtypes env subst mty1 mty2
- with
- Dont_match ->
- raise(Error[Module_types(mty1, Subst.modtype subst mty2)])
- | Error reasons ->
- raise(Error(Module_types(mty1, Subst.modtype subst mty2) :: reasons))
-
-and try_modtypes env subst mty1 mty2 =
- match (mty1, mty2) with
- (_, Tmty_ident p2) ->
- try_modtypes2 env mty1 (Subst.modtype subst mty2)
- | (Tmty_ident p1, _) ->
- try_modtypes env subst (expand_module_path env p1) mty2
- | (Tmty_signature sig1, Tmty_signature sig2) ->
- signatures env subst sig1 sig2
- | (Tmty_functor(param1, arg1, res1), Tmty_functor(param2, arg2, res2)) ->
- let arg2' = Subst.modtype subst arg2 in
- let cc_arg = modtypes env Subst.identity arg2' arg1 in
- let cc_res =
- modtypes (Env.add_module param1 arg2' env)
- (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 mty1 mty2 =
- (* mty2 is an identifier *)
- match (mty1, mty2) with
- (Tmty_ident p1, Tmty_ident p2) when Path.same p1 p2 ->
- Tcoerce_none
- | (_, Tmty_ident p2) ->
- try_modtypes env Subst.identity mty1 (expand_module_path env p2)
- | (_, _) ->
- assert false
-
-(* Inclusion between signatures *)
-
-and signatures env subst sig1 sig2 =
- (* Environment used to check inclusion of components *)
- let new_env =
- Env.add_signature sig1 env 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
- [] -> tbl
- | item :: rem ->
- let (id, name) = item_ident_name item in
- let nextpos =
- match item with
- Tsig_value(_,{val_kind = Val_prim _})
- | Tsig_type(_,_)
- | Tsig_modtype(_,_)
- | Tsig_cltype(_,_) -> pos
- | Tsig_value(_,_)
- | Tsig_exception(_,_)
- | Tsig_module(_,_)
- | Tsig_class(_, _) -> pos+1 in
- build_component_table nextpos
- (Tbl.add name (id, item, pos) tbl) rem in
- let comps1 =
- build_component_table 0 Tbl.empty sig1 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
- [] -> signature_components new_env subst (List.rev paired)
- | _ -> raise(Error unpaired)
- end
- | item2 :: rem ->
- let (id2, name2) = item_ident_name item2 in
- begin try
- let (id1, item1, pos1) = Tbl.find name2 comps1 in
- let new_subst =
- match item2 with
- Tsig_type _ ->
- Subst.add_type id2 (Pident id1) subst
- | Tsig_module _ ->
- Subst.add_module id2 (Pident id1) subst
- | Tsig_modtype _ ->
- Subst.add_modtype id2 (Tmty_ident (Pident id1)) subst
- | Tsig_value _ | Tsig_exception _ | Tsig_class _ | Tsig_cltype _ ->
- subst
- in
- pair_components new_subst
- ((item1, item2, pos1) :: paired) unpaired rem
- with Not_found ->
- pair_components subst paired (Missing_field id2 :: unpaired) rem
- end in
- (* Do the pairing and checking, and return the final coercion *)
- simplify_structure_coercion(pair_components subst [] [] sig2)
-
-(* Inclusion between signature components *)
-
-and signature_components env subst = function
- [] -> []
- | (Tsig_value(id1, valdecl1), Tsig_value(id2, valdecl2), pos) :: rem ->
- let cc = value_descriptions env subst id1 valdecl1 valdecl2 in
- begin match valdecl2.val_kind with
- Val_prim p -> signature_components env subst rem
- | _ -> (pos, cc) :: signature_components env subst rem
- end
- | (Tsig_type(id1, tydecl1), Tsig_type(id2, tydecl2), pos) :: rem ->
- type_declarations env subst id1 tydecl1 tydecl2;
- signature_components env subst rem
- | (Tsig_exception(id1, excdecl1), Tsig_exception(id2, excdecl2), pos)
- :: rem ->
- exception_declarations env subst id1 excdecl1 excdecl2;
- (pos, Tcoerce_none) :: signature_components env subst rem
- | (Tsig_module(id1, mty1), Tsig_module(id2, mty2), pos) :: rem ->
- let cc =
- modtypes env subst (Mtype.strengthen env mty1 (Pident id1)) mty2 in
- (pos, cc) :: signature_components env subst rem
- | (Tsig_modtype(id1, info1), Tsig_modtype(id2, info2), pos) :: rem ->
- modtype_infos env subst id1 info1 info2;
- signature_components env subst rem
- | (Tsig_class(id1, decl1), Tsig_class(id2, decl2), pos) :: rem ->
- class_declarations env subst id1 decl1 decl2;
- (pos, Tcoerce_none) :: signature_components env subst rem
- | (Tsig_cltype(id1, info1), Tsig_cltype(id2, info2), pos) :: rem ->
- class_type_declarations env subst id1 info1 info2;
- signature_components env subst rem
- | _ ->
- assert false
-
-(* Inclusion between module type specifications *)
-
-and modtype_infos env subst id info1 info2 =
- let info2 = Subst.modtype_declaration subst info2 in
- try
- match (info1, info2) with
- (Tmodtype_abstract, Tmodtype_abstract) -> ()
- | (Tmodtype_manifest mty1, Tmodtype_abstract) -> ()
- | (Tmodtype_manifest mty1, Tmodtype_manifest mty2) ->
- check_modtype_equiv env mty1 mty2
- | (Tmodtype_abstract, Tmodtype_manifest mty2) ->
- check_modtype_equiv env (Tmty_ident(Pident id)) mty2
- with Error reasons ->
- raise(Error(Modtype_infos(id, info1, info2) :: reasons))
-
-and check_modtype_equiv env mty1 mty2 =
- match
- (modtypes env Subst.identity mty1 mty2,
- modtypes env Subst.identity mty2 mty1)
- with
- (Tcoerce_none, Tcoerce_none) -> ()
- | (_, _) -> raise(Error [Modtype_permutation])
-
-(* Simplified inclusion check between module types *)
-
-let check_modtype_inclusion env mty1 mty2 =
- try
- ignore(modtypes env Subst.identity mty1 mty2)
- with Error reasons ->
- raise Not_found
-
-let _ = Env.check_modtype_inclusion := check_modtype_inclusion
-
-(* Check that an implementation of a compilation unit meets its
- interface. *)
-
-let compunit impl_name impl_sig intf_name intf_sig =
- try
- signatures Env.initial Subst.identity impl_sig intf_sig
- with Error reasons ->
- raise(Error(Interface_mismatch(impl_name, intf_name) :: reasons))
-
-(* Hide the substitution parameter 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
-
-(* Error report *)
-
-open Format
-open Printtyp
-
-let include_err ppf = function
- | Missing_field id ->
- fprintf ppf "The field `%a' is required but not provided" ident id
- | Value_descriptions(id, d1, d2) ->
- fprintf ppf
- "@[<hv 2>Values do not match:@ \
- %a@;<1 -2>is not included in@ %a@]"
- (value_description id) d1 (value_description id) d2
- | Type_declarations(id, d1, d2) ->
- fprintf ppf
- "@[<hv 2>Type declarations do not match:@ \
- %a@;<1 -2>is not included in@ %a@]"
- (type_declaration id) d1
- (type_declaration id) d2
- | Exception_declarations(id, d1, d2) ->
- fprintf ppf
- "@[<hv 2>Exception declarations do not match:@ \
- %a@;<1 -2>is not included in@ %a@]"
- (exception_declaration id) d1
- (exception_declaration id) d2
- | Module_types(mty1, mty2)->
- fprintf ppf
- "@[<hv 2>Modules do not match:@ \
- %a@;<1 -2>is not included in@ %a@]"
- modtype mty1
- modtype mty2
- | Modtype_infos(id, d1, d2) ->
- fprintf ppf
- "@[<hv 2>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
- "@[<hv 2>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
- "@[<hv 2>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
-
-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 "@[<v>%a%a@]" include_err err print_errs errs
diff --git a/typing/includemod.mli b/typing/includemod.mli
deleted file mode 100644
index cfd8003cc0..0000000000
--- a/typing/includemod.mli
+++ /dev/null
@@ -1,46 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Inclusion checks for the module language *)
-
-open Types
-open Typedtree
-open Format
-
-val modtypes: Env.t -> module_type -> module_type -> module_coercion
-val signatures: Env.t -> signature -> signature -> module_coercion
-val compunit: string -> signature -> string -> signature -> module_coercion
-val type_declarations:
- Env.t -> Ident.t -> type_declaration -> type_declaration -> unit
-
-type error =
- Missing_field of Ident.t
- | Value_descriptions of Ident.t * value_description * value_description
- | Type_declarations of Ident.t * type_declaration * type_declaration
- | Exception_declarations of
- Ident.t * exception_declaration * exception_declaration
- | 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 * cltype_declaration * cltype_declaration *
- Ctype.class_match_failure list
- | Class_declarations of
- Ident.t * class_declaration * class_declaration *
- Ctype.class_match_failure list
-
-exception Error of error list
-
-val report_error: formatter -> error list -> unit
diff --git a/typing/mtype.ml b/typing/mtype.ml
deleted file mode 100644
index 0b4805c144..0000000000
--- a/typing/mtype.ml
+++ /dev/null
@@ -1,179 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Operations on module types *)
-
-open Path
-open Types
-
-
-let rec scrape env mty =
- match mty with
- Tmty_ident p ->
- begin try
- scrape env (Env.find_modtype_expansion p env)
- with Not_found ->
- mty
- end
- | _ -> mty
-
-let rec strengthen env mty p =
- match scrape env mty with
- Tmty_signature sg ->
- Tmty_signature(strengthen_sig env sg p)
- | Tmty_functor(param, arg, res) ->
- Tmty_functor(param, arg, strengthen env res (Papply(p, Pident param)))
- | mty ->
- mty
-
-and strengthen_sig env sg p =
- match sg with
- [] -> []
- | (Tsig_value(id, desc) as sigelt) :: rem ->
- sigelt :: strengthen_sig env rem p
- | Tsig_type(id, decl) :: rem ->
- let newdecl =
- match decl.type_manifest with
- None ->
- { decl with type_manifest =
- Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id, nopos),
- decl.type_params, ref Mnil))) }
- | _ -> decl in
- Tsig_type(id, newdecl) :: strengthen_sig env rem p
- | (Tsig_exception(id, d) as sigelt) :: rem ->
- sigelt :: strengthen_sig env rem p
- | Tsig_module(id, mty) :: rem ->
- Tsig_module(id, strengthen env mty (Pdot(p, Ident.name id, nopos))) ::
- strengthen_sig (Env.add_module id mty env) rem p
- (* Need to add the module in case it defines manifest module types *)
- | Tsig_modtype(id, decl) :: rem ->
- let newdecl =
- match decl with
- Tmodtype_abstract ->
- Tmodtype_manifest(Tmty_ident(Pdot(p, Ident.name id, nopos)))
- | Tmodtype_manifest _ ->
- decl in
- Tsig_modtype(id, newdecl) ::
- strengthen_sig (Env.add_modtype id decl env) rem p
- (* Need to add the module type in case it is manifest *)
- | (Tsig_class(id, decl) as sigelt) :: rem ->
- sigelt :: strengthen_sig env rem p
- | (Tsig_cltype(id, decl) as sigelt) :: rem ->
- sigelt :: strengthen_sig env rem p
-
-(* 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 va mty =
- match mty with
- Tmty_ident p ->
- if Path.isfree mid p then
- nondep_mty va (Env.find_modtype_expansion p env)
- else mty
- | Tmty_signature sg ->
- Tmty_signature(nondep_sig va sg)
- | Tmty_functor(param, arg, res) ->
- let var_inv =
- match va with Co -> Contra | Contra -> Co | Strict -> Strict in
- Tmty_functor(param, nondep_mty var_inv arg, nondep_mty va res)
-
- and nondep_sig va = function
- [] -> []
- | item :: rem ->
- let rem' = nondep_sig va rem in
- match item with
- Tsig_value(id, d) ->
- Tsig_value(id, {val_type = Ctype.nondep_type env mid d.val_type;
- val_kind = d.val_kind}) :: rem'
- | Tsig_type(id, d) ->
- Tsig_type(id, Ctype.nondep_type_decl env mid id (va = Co) d) :: rem'
- | Tsig_exception(id, d) ->
- Tsig_exception(id, List.map (Ctype.nondep_type env mid) d) :: rem'
- | Tsig_module(id, mty) ->
- Tsig_module(id, nondep_mty va mty) :: rem'
- | Tsig_modtype(id, d) ->
- begin try
- Tsig_modtype(id, nondep_modtype_decl d) :: rem'
- with Not_found ->
- match va with
- Co -> Tsig_modtype(id, Tmodtype_abstract) :: rem'
- | _ -> raise Not_found
- end
- | Tsig_class(id, d) ->
- Tsig_class(id, Ctype.nondep_class_declaration env mid d) :: rem'
- | Tsig_cltype(id, d) ->
- Tsig_cltype(id, Ctype.nondep_cltype_declaration env mid d) :: rem'
-
- and nondep_modtype_decl = function
- Tmodtype_abstract -> Tmodtype_abstract
- | Tmodtype_manifest mty -> Tmodtype_manifest(nondep_mty Strict mty)
-
- in
- nondep_mty Co mty
-
-let enrich_typedecl env p decl =
- match decl.type_manifest with
- Some ty -> 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
- Tmty_signature sg ->
- Tmty_signature(List.map (enrich_item env p) sg)
- | _ ->
- mty
-
-and enrich_item env p = function
- Tsig_type(id, decl) ->
- Tsig_type(id, enrich_typedecl env (Pdot(p, Ident.name id, nopos)) decl)
- | Tsig_module(id, mty) ->
- Tsig_module(id, enrich_modtype env (Pdot(p, Ident.name id, nopos)) mty)
- | item -> item
-
-let rec type_paths env p mty =
- match scrape env mty with
- Tmty_ident p -> []
- | Tmty_signature sg -> type_paths_sig env p 0 sg
- | Tmty_functor(param, arg, res) -> []
-
-and type_paths_sig env p pos sg =
- match sg with
- [] -> []
- | Tsig_value(id, decl) :: rem ->
- let pos' = match decl.val_kind with Val_prim _ -> pos | _ -> pos + 1 in
- type_paths_sig env p pos' rem
- | Tsig_type(id, decl) :: rem ->
- Pdot(p, Ident.name id, nopos) :: type_paths_sig env p pos rem
- | Tsig_module(id, mty) :: rem ->
- type_paths env (Pdot(p, Ident.name id, pos)) mty @
- type_paths_sig (Env.add_module id mty env) p (pos+1) rem
- | Tsig_modtype(id, decl) :: rem ->
- type_paths_sig (Env.add_modtype id decl env) p pos rem
- | (Tsig_exception _ | Tsig_class _) :: rem ->
- type_paths_sig env p (pos+1) rem
- | (Tsig_cltype _) :: rem ->
- type_paths_sig env p pos rem
diff --git a/typing/mtype.mli b/typing/mtype.mli
deleted file mode 100644
index ee720be283..0000000000
--- a/typing/mtype.mli
+++ /dev/null
@@ -1,32 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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 strengthen: Env.t -> module_type -> Path.t -> module_type
- (* Strengthen abstract type components relative to the
- given path. *)
-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 enrich_modtype: Env.t -> Path.t -> module_type -> module_type
-val enrich_typedecl: Env.t -> Path.t -> type_declaration -> type_declaration
-val type_paths: Env.t -> Path.t -> module_type -> Path.t list
diff --git a/typing/oprint.ml b/typing/oprint.ml
deleted file mode 100644
index 5487831929..0000000000
--- a/typing/oprint.ml
+++ /dev/null
@@ -1,453 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Format
-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 -> fprintf ppf "%s" s
- | Oide_dot (id, s) -> fprintf ppf "%a.%s" print_ident id s
- | Oide_apply (id1, id2) ->
- fprintf ppf "%a(%a)" print_ident id1 print_ident id2
-
-let value_ident ppf name =
- if List.mem name
- ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"] then
- fprintf ppf "( %s )" name
- else
- match name.[0] with
- 'a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' ->
- fprintf ppf "%s" name
- | _ -> fprintf ppf "( %s )" name
-
-(* Values *)
-
-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 s1 = Printf.sprintf "%.12g" f in
- if f = float_of_string s1 then valid_float_lexeme s1 else
- let s2 = Printf.sprintf "%.15g" f in
- if f = float_of_string s2 then valid_float_lexeme s2 else
- Printf.sprintf "%.18g" f
-
-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_simple_tree 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 -> fprintf ppf "%s" (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 "<huge string>"
- 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 -> fprintf ppf "%s" s
- | Oval_record fel ->
- fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel
- | Oval_ellipsis -> raise Ellipsis
- | Oval_printer f -> f ppf
- | 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 "@[<hov 2>%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) ->
- fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "")
- print_out_type_2 ty1 print_out_type_1 ty2
- | ty -> print_out_type_2 ppf ty
-and print_out_type_2 ppf =
- 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) ->
- fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id
- | Otyp_object (fields, rest) ->
- fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields
- | Otyp_stuff s -> fprintf ppf "%s" s
- | Otyp_var (ng, s) -> fprintf ppf "'%s%s" (if ng then "_" else "") s
- | Otyp_variant (non_gen, row_fields, closed, tags) ->
- let print_present ppf =
- function
- None | Some [] -> ()
- | Some l -> fprintf ppf "@;<1 -2>> @[<hov>%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_name (id, tyl) ->
- fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id
- in
- fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a ]@]" (if non_gen then "_" else "")
- (if closed then if tags = None then " " else "< "
- else if tags = None then "> " else "? ")
- print_fields row_fields
- print_present tags
- | Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty ->
- fprintf ppf "@[<1>(%a)@]" print_out_type ty
- | Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) -> ()
-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 "@[<hv 2>`%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 ->
- fprintf ppf "%a%s@ %a" print_elem ty sep (print_typlist print_elem sep)
- tyl
-and print_typargs ppf =
- function
- [] -> ()
- | [ty1] -> fprintf ppf "%a@ " print_simple_out_type ty1
- | tyl -> fprintf ppf "@[<1>(%a)@]@ " (print_typlist print_out_type ",") tyl
-
-let out_type = ref print_out_type
-
-(* Class types *)
-
-let print_out_class_params ppf =
- function
- [] -> ()
- | tyl ->
- fprintf ppf "@[<1>[%a]@]@ "
- (print_list (fun ppf x -> fprintf ppf "'%s" x)
- (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_fun (lab, ty, cty) ->
- fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "")
- print_out_type_2 ty print_out_class_type cty
- | Octy_signature (self_ty, csil) ->
- let pr_param ppf =
- function
- Some ty -> fprintf ppf "@ @[(%a)@]" !out_type ty
- | None -> ()
- in
- fprintf ppf "@[<hv 2>@[<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, ty) ->
- fprintf ppf "@[<2>val %s%s :@ %a@]" (if mut then "mutable " 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 rec print_out_module_type ppf =
- function
- Omty_abstract -> ()
- | Omty_functor (name, mty_arg, mty_res) ->
- fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name
- print_out_module_type mty_arg print_out_module_type mty_res
- | Omty_ident id -> fprintf ppf "%a" print_ident id
- | Omty_signature sg ->
- fprintf ppf "@[<hv 2>sig@ %a@;<1 -2>end@]" !out_signature sg
-and print_out_signature ppf =
- function
- [] -> ()
- | [item] -> !out_sig_item ppf item
- | 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) ->
- fprintf ppf "@[<2>class%s@ %a%s@ :@ %a@]"
- (if vir_flag then " virtual" else "") print_out_class_params params
- name !out_class_type clt
- | Osig_class_type (vir_flag, name, params, clt) ->
- fprintf ppf "@[<2>class type%s@ %a%s@ =@ %a@]"
- (if vir_flag then " virtual" else "") print_out_class_params params
- name !out_class_type clt
- | Osig_exception (id, tyl) ->
- fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl)
- | Osig_modtype (name, Omty_abstract) ->
- fprintf ppf "@[<2>module type %s@]" name
- | Osig_modtype (name, mty) ->
- fprintf ppf "@[<2>module type %s =@ %a@]" name !out_module_type mty
- | Osig_module (name, mty) ->
- fprintf ppf "@[<2>module %s :@ %a@]" name !out_module_type mty
- | Osig_type tdl -> print_out_type_decl_list ppf tdl
- | Osig_value (name, ty, prims) ->
- let kwd = if 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@]" kwd value_ident name !out_type
- ty pr_prims prims
-and print_out_type_decl_list ppf =
- function
- [] -> ()
- | [x] -> print_out_type_decl "type" ppf x
- | x :: l ->
- print_out_type_decl "type" ppf x;
- List.iter (fun x -> fprintf ppf "@ %a" (print_out_type_decl "and") x) l
-and print_out_type_decl kwd ppf (name, args, ty, constraints) =
- let print_constraints ppf params =
- List.iter
- (fun (ty1, ty2) ->
- fprintf ppf "@ @[<2>constraint %a =@ %a@]" !out_type ty1
- !out_type ty2)
- params
- in
- let type_parameter ppf (ty, (co, cn)) =
- fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "")
- ty
- in
- let type_defined ppf =
- match args with
- [] -> fprintf ppf "%s" name
- | [arg] -> fprintf ppf "@[%a@ %s@]" type_parameter arg name
- | _ ->
- fprintf ppf "@[(@[%a)@]@ %s@]"
- (print_list type_parameter (fun ppf -> fprintf ppf ",@ ")) args name
- in
- let print_manifest ppf =
- function
- Otyp_manifest (ty, _) -> fprintf ppf " =@ %a" !out_type ty
- | _ -> ()
- in
- let print_name_args ppf =
- fprintf ppf "%s %t%a" kwd type_defined print_manifest ty
- in
- let ty =
- match ty with
- Otyp_manifest (_, ty) -> ty
- | _ -> ty
- in
- let print_private ppf = function
- Asttypes.Private -> fprintf ppf "private "
- | Asttypes.Public -> () in
- let rec print_out_tkind = function
- | Otyp_abstract ->
- fprintf ppf "@[<2>@[<hv 2>%t@]%a@]" print_name_args print_constraints
- constraints
- | Otyp_record (lbls, priv) ->
- fprintf ppf "@[<2>@[<hv 2>%t = %a{%a@;<1 -2>}@]%a@]" print_name_args
- print_private priv
- (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls
- print_constraints constraints
- | Otyp_sum (constrs, priv) ->
- fprintf ppf "@[<2>@[<hv 2>%t =@;<1 2>%a%a@]%a@]" print_name_args
- print_private priv
- (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs
- print_constraints constraints
- | ty ->
- fprintf ppf "@[<2>@[<hv 2>%t =@ %a@]%a@]" print_name_args !out_type
- ty print_constraints constraints in
- print_out_tkind ty
-and print_out_constr ppf (name, tyl) =
- match tyl with
- [] -> fprintf ppf "%s" name
- | _ ->
- fprintf ppf "@[<2>%s of@ %a@]" name
- (print_typlist print_simple_out_type " *") tyl
-and print_out_label ppf (name, mut, arg) =
- fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name
- !out_type arg
-
-let _ = out_module_type := print_out_module_type
-let _ = out_signature := print_out_signature
-let _ = out_sig_item := print_out_sig_item
-
-(* 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
- [] -> ()
- | (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 "@[<v>%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
deleted file mode 100644
index 902d3cf26b..0000000000
--- a/typing/oprint.mli
+++ /dev/null
@@ -1,24 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Format
-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_phrase : (formatter -> out_phrase -> unit) ref
diff --git a/typing/outcometree.mli b/typing/outcometree.mli
deleted file mode 100644
index 6017719fae..0000000000
--- a/typing/outcometree.mli
+++ /dev/null
@@ -1,96 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* 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 Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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_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_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 * Asttypes.private_flag
- | Otyp_stuff of string
- | Otyp_sum of (string * out_type list) list * Asttypes.private_flag
- | 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
-and out_variant =
- | Ovar_fields of (string * bool * out_type list) list
- | Ovar_name of out_ident * out_type list
-
-type out_class_type =
- | Octy_constr of out_ident * out_type list
- | Octy_fun 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 * out_type
-
-type out_module_type =
- | Omty_abstract
- | Omty_functor of string * out_module_type * out_module_type
- | Omty_ident of out_ident
- | Omty_signature of out_sig_item list
-and out_sig_item =
- | Osig_class of bool * string * string list * out_class_type
- | Osig_class_type of bool * string * string list * out_class_type
- | Osig_exception of string * out_type list
- | Osig_modtype of string * out_module_type
- | Osig_module of string * out_module_type
- | Osig_type of out_type_decl list
- | Osig_value of string * out_type * string list
-and out_type_decl =
- string * (string * (bool * bool)) list * out_type *
- (out_type * out_type) list
-
-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
deleted file mode 100644
index 45c5181717..0000000000
--- a/typing/parmatch.ml
+++ /dev/null
@@ -1,1617 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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_type = ty ; pat_env = tenv }
-
-let omega = make_pat Tpat_any 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 =
- let row = Btype.row_repr row in
- let field =
- try Btype.row_field_repr (List.assoc tag row.row_fields)
- with Not_found -> Rabsent
- in field = Rabsent
-
-let sort_fields args =
- Sort.list
- (fun (lbl1,_) (lbl2,_) -> lbl1.lbl_pos <= lbl2.lbl_pos)
- args
-
-let records_args l1 l2 =
- let l1 = sort_fields l1
- and l2 = sort_fields l2 in
- let rec combine r1 r2 l1 l2 = match l1,l2 with
- | [],[] -> r1,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 -> c1=c2
- | Tpat_tuple ps, Tpat_tuple qs -> compats ps qs
- | Tpat_construct (c1,ps1), Tpat_construct (c2,ps2) ->
- c1.cstr_tag = c2.cstr_tag && compats ps1 ps2
- | Tpat_variant(l1,Some p1, r1), Tpat_variant(l2,Some p2,_) ->
- l1=l2 && not (is_absent l1 r1) && compat p1 p2
- | Tpat_variant (l1,None,r1), Tpat_variant(l2,None,_) ->
- l1 = l2 && not (is_absent l1 r1)
- | 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
-
-(****************************************)
-(* Utilities for retrieving constructor *)
-(* and record label names *)
-(****************************************)
-
-exception Empty (* Empty pattern *)
-
-let get_type_path ty tenv =
- let ty = Ctype.repr (Ctype.expand_head tenv ty) in
- match ty.desc with
- | Tconstr (path,_,_) -> path
- | _ -> fatal_error "Parmatch.get_type_path"
-
-let get_type_descr ty tenv =
- match (Ctype.repr ty).desc with
- | Tconstr (path,_,_) -> Env.find_type path tenv
- | _ -> fatal_error "Parmatch.get_type_descr"
-
-let rec get_constr tag ty tenv =
- match get_type_descr ty tenv with
- | {type_kind=Type_variant(constr_list, priv)} ->
- Datarepr.find_constr_by_tag tag constr_list
- | {type_manifest = Some _} ->
- get_constr tag (Ctype.expand_head_once tenv ty) tenv
- | _ -> fatal_error "Parmatch.get_constr"
-
-let find_label lbl lbls =
- try
- let name,_,_ = List.nth lbls lbl.lbl_pos in
- name
- with Failure "nth" -> "*Unkown label*"
-
-let rec get_record_labels ty tenv =
- match get_type_descr ty tenv with
- | {type_kind = Type_record(lbls, rep, priv)} -> lbls
- | {type_manifest = Some _} ->
- get_record_labels (Ctype.expand_head_once tenv ty) tenv
- | _ -> fatal_error "Parmatch.get_record_labels"
-
-
-(*************************************)
-(* Values as patterns pretty printer *)
-(*************************************)
-
-open Format
-;;
-
-let get_constr_name tag ty tenv = match tag with
-| Cstr_exception path -> Path.name path
-| _ ->
- try
- let name,_ = get_constr tag ty tenv in name
- with
- | Datarepr.Constr_not_found -> "*Unknown constructor*"
-
-let is_cons tag v = match get_constr_name tag v.pat_type v.pat_env with
-| "::" -> true
-| _ -> false
-
-
-let rec pretty_val ppf v = match v.pat_desc with
- | Tpat_any -> fprintf ppf "_"
- | Tpat_var x -> Ident.print ppf x
- | Tpat_constant (Const_int i) -> fprintf ppf "%d" i
- | Tpat_constant (Const_char c) -> fprintf ppf "%C" c
- | Tpat_constant (Const_string s) -> fprintf ppf "%S" s
- | Tpat_constant (Const_float f) -> fprintf ppf "%s" f
- | Tpat_constant (Const_int32 i) -> fprintf ppf "%ldl" i
- | Tpat_constant (Const_int64 i) -> fprintf ppf "%LdL" i
- | Tpat_constant (Const_nativeint i) -> fprintf ppf "%ndn" i
- | Tpat_tuple vs ->
- fprintf ppf "@[(%a)@]" (pretty_vals ",") vs
- | Tpat_construct ({cstr_tag=tag},[]) ->
- let name = get_constr_name tag v.pat_type v.pat_env in
- fprintf ppf "%s" name
- | Tpat_construct ({cstr_tag=tag},[w]) ->
- let name = get_constr_name tag v.pat_type v.pat_env in
- fprintf ppf "@[<2>%s@ %a@]" name pretty_arg w
- | Tpat_construct ({cstr_tag=tag},vs) ->
- let name = get_constr_name tag v.pat_type v.pat_env 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 ->
- fprintf ppf "@[{%a}@]"
- (pretty_lvals (get_record_labels v.pat_type v.pat_env))
- (List.filter
- (function
- | (_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
- | _ -> true) lvs)
- | Tpat_array vs ->
- fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
- | 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_tag=tag}, [_ ; _])
- when is_cons tag v ->
- fprintf ppf "(%a)" pretty_val v
-| _ -> pretty_val ppf v
-
-and pretty_cdr ppf v = match v.pat_desc with
-| Tpat_construct ({cstr_tag=tag}, [v1 ; v2])
- when is_cons tag v ->
- 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 (_,_::_) -> 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 lbls ppf = function
- | [] -> ()
- | [lbl,v] ->
- let name = find_label lbl lbls in
- fprintf ppf "%s=%a" name pretty_val v
- | (lbl,v)::rest ->
- let name = find_label lbl lbls in
- fprintf ppf "%s=%a;@ %a" name pretty_val v (pretty_lvals lbls) rest
-
-let top_pretty ppf v =
- fprintf ppf "@[%a@]@?" pretty_val v
-
-
-let prerr_pat v =
- top_pretty str_formatter v ;
- prerr_string (flush_str_formatter ())
-
-
-(****************************)
-(* 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(Const_float s1), Tpat_constant(Const_float s2) ->
- float_of_string s1 = float_of_string s2
- | Tpat_constant(c1), Tpat_constant(c2) -> c1 = c2
- | Tpat_tuple _, Tpat_tuple _ -> 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 sort_record p = match p.pat_desc with
-| Tpat_record args ->
- make_pat
- (Tpat_record (sort_fields args))
- p.pat_type p.pat_env
-| _ -> p
-
-let all_record_args lbls = match lbls with
-| ({lbl_all=lbl_all},_)::_ ->
- let t =
- Array.map
- (fun lbl -> 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(cstr, args) -> args
-| Tpat_variant(lab, Some arg, _) -> [arg]
-| Tpat_tuple(args) -> args
-| Tpat_record(args) -> extract_fields (record_arg p1) args
-| Tpat_array(args) -> args
-| (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
- | _ -> []
- 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 (c,args) ->
- make_pat (Tpat_construct (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) ->
- make_pat (Tpat_record (List.map (fun (lbl,_) -> lbl,omega) largs))
- 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_record largs} as p)::_)::pss ->
- let new_omegas =
- List.fold_left
- (fun r (lbl,_) ->
- try
- let _ = get_field lbl.lbl_pos r in
- r
- with Not_found ->
- (lbl,omega)::r)
- (record_arg acc)
- largs in
- acc_pat
- (make_pat (Tpat_record new_omegas) p.pat_type p.pat_env)
- pss
- | _ -> acc in
-
- match normalize_pat q with
- | {pat_desc= (Tpat_any | Tpat_record _)} as q ->
- sort_record (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 set_args 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} ->
- let args,rest = read_args omegas r in
- make_pat
- (Tpat_record
- (List.map2 (fun (lbl,_) arg -> lbl,arg) omegas args))
- q.pat_type q.pat_env::
- rest
-| {pat_desc = Tpat_construct (c,omegas)} ->
- let args,rest = read_args omegas r in
- make_pat
- (Tpat_construct (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_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"
-
-
-(* 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(_)) -> [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
-
-(*
- 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 ({cstr_tag=Cstr_exception _},_)},_)::_ ->
- false
-| ({pat_desc = Tpat_construct(c,_)},_) :: _ ->
- List.length env = c.cstr_consts + c.cstr_nonconsts
-| ({pat_desc = Tpat_variant(_,_,row)},_) :: _ ->
- let fields =
- List.map
- (function ({pat_desc = Tpat_variant (tag, _, _)}, _) -> tag
- | _ -> assert false)
- env
- in
- let row = Btype.row_repr row in
- if closing && not row.row_fixed 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
-| _ -> fatal_error "Parmatch.full_match"
-
-let extendable_match env = match env with
-| ({pat_desc = Tpat_construct ({cstr_tag=Cstr_exception _},_)},_)::_ -> false
-| ({pat_desc = Tpat_construct(c,_)} as p,_) :: _ ->
- let path = get_type_path p.pat_type p.pat_env in
- not
- (Path.same path Predef.path_bool ||
- Path.same path Predef.path_list ||
- Path.same path Predef.path_option)
-| _ -> false
-
-
-(* complement constructor tags *)
-let complete_tags nconsts nconstrs tags =
- let seen_const = Array.create nconsts false
- and seen_constr = Array.create 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 (cstr,omegas cstr.cstr_arity)}
-
-let rec pat_of_constrs ex_pat = function
-| [] -> raise Empty
-| [cstr] -> pat_of_constr ex_pat cstr
-| cstr::rem ->
- {ex_pat with
- pat_desc=
- Tpat_or
- (pat_of_constr ex_pat cstr,
- pat_of_constrs ex_pat rem, None)}
-
-(* Sends back a pattern that complements constructor tags all_tag *)
-let complete_constrs p all_tags = match p.pat_desc with
-| Tpat_construct (c,_) ->
- begin try
- let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in
- List.map
- (fun tag ->
- let _,targs = get_constr tag p.pat_type p.pat_env in
- {c with
- cstr_tag = tag ;
- cstr_args = targs ;
- cstr_arity = List.length targs})
- not_tags
-with
-| Datarepr.Constr_not_found ->
- fatal_error "Parmatch.complete_constr: constr_not_found"
- end
-| _ -> fatal_error "Parmatch.complete_constr"
-
-
-(* 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 env = match env with
-| ({pat_desc = Tpat_construct ({cstr_tag=Cstr_exception _} as c,_)},_) as p
- ::_ ->
- make_pat
- (Tpat_construct
- ({c with
- cstr_tag=(Cstr_exception
- (Path.Pident (Ident.create "*exception*")))},
- []))
- Ctype.none Env.empty
-| ({pat_desc = Tpat_construct (_,_)} as p,_) :: _ ->
- 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)
-| ({pat_desc = Tpat_variant(_,_,row)} as p,_) :: _ ->
- let tags =
- List.map
- (function ({pat_desc = Tpat_variant (tag, _, _)}, _) -> tag
- | _ -> assert false)
- env
- in
- let row = Btype.row_repr row in
- let make_other_pat tag const =
- let arg = if const then None else Some omega in
- make_pat (Tpat_variant(tag, arg, row)) 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 '*')))
- 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 args} 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)
- NOTE:
- satisfiable assumes that any pattern has at least one
- matching value (see first case)
- quid of << absent >> variants ??
-
-*)
-
-let rec has_instance p = match p.pat_desc with
- | 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 snd lps)
-
-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 ->
- (not (full_match false constrs) &&
- satisfiable (filter_extra pss) qs) ||
- List.exists
- (fun (p,pss) -> satisfiable pss (simple_match_args p omega @ qs))
- constrs
- 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)
-
-(*
- Like satisfiable, looking for a matching value with an extra constructor.
- That is, look for the situation where adding one constructor
- would NOT yield a non-exhaustive matching.
- *)
-
-let relevant_location loc r = match r with
- | None -> None
- | Some rloc ->
- if rloc = Location.none then
- Some loc
- else
- r
-
-let rec satisfiable_extra some pss qs = match qs with
-| [] -> if pss = [] then some else None
-| {pat_desc = Tpat_or(q1,q2,_)}::qs ->
- let r1 = satisfiable_extra some pss (q1::qs) in
- begin match r1 with
- | Some _ -> r1
- | None -> satisfiable_extra some pss (q2::qs)
- end
-| {pat_desc = Tpat_alias(q,_)}::qs ->
- satisfiable_extra some pss (q::qs)
-| {pat_desc = (Tpat_any | Tpat_var(_))} as q::qs ->
- let q0 = discr_pat omega pss in
- let r =
- match filter_all q0 pss with
- (* first column of pss is made of variables only *)
- | [] -> satisfiable_extra some (filter_extra pss) qs
- | constrs ->
- if extendable_match constrs then
- let rloc =
- satisfiable_extra (Some q.pat_loc) (filter_extra pss) qs in
- match rloc with
- | Some loc -> rloc
- | None -> try_many_extra some qs constrs
- else
- try_many_extra some qs constrs in
- relevant_location q.pat_loc r
-| q::qs ->
- let q0 = discr_pat q pss in
- relevant_location
- q.pat_loc
- (satisfiable_extra
- some (filter_one q0 pss) (simple_match_args q0 q @ qs))
-
-and try_many_extra some qs = function
- | [] -> None
- | (p,pss)::rem ->
- let rloc = satisfiable_extra some pss (simple_match_args p omega @ qs) in
- match rloc with
- | Some _ -> rloc
- | None -> try_many_extra some qs rem
-
-
-(*
- 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
- | x::rest ->
- begin match f x with
- | Rnone -> try_many f rest
- | r -> r
- end
-
-let rec exhaust 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 (filter_extra pss) (n-1) with
- | Rsome r -> Rsome (q0::r)
- | r -> r
- end
- | constrs ->
- let try_non_omega (p,pss) =
- match
- exhaust pss (List.length (simple_match_args p omega) + n - 1)
- with
- | Rsome r -> Rsome (set_args p r)
- | r -> r in
- if full_match false 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 (filter_extra pss) (n-1) in
- match r with
- | Rnone -> Rnone
- | Rsome r ->
- try
- Rsome (build_other constrs::r)
- with
- (* cannot occur, since constructors don't make a full signature *)
- | Empty -> fatal_error "Parmatch.exhaust"
- end
-
-(*
- 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(_,_,row)},_):: _, Some env ->
- let row = Btype.row_repr row in
- if row.row_fixed
- || 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 (* Neither, with list of useless pattern *)
-
-
-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 =
- prerr_endline "begin matrix" ;
- List.iter
- (fun ps ->
- pretty_line ps ;
- prerr_endline "")
- pss ;
- prerr_endline "end matrix"
-
-(* 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
-(* Absent variants have no instance *)
- | _, Tpat_variant (l,_,row) when is_absent l row -> true
- | Tpat_alias(p,_), _ -> le_pat p q
- | _, Tpat_alias(q,_) -> le_pat p q
- | _, Tpat_or(q1,q2,_) -> le_pat p q1 && le_pat p q2
- | Tpat_constant(c1), Tpat_constant(c2) -> c1 = c2
- | Tpat_construct(c1,ps), Tpat_construct(c2,qs) ->
- c1.cstr_tag = c2.cstr_tag && le_pats ps qs
- | 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_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs
- | 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 and 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 c1=c2 -> 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_construct (c1,ps1), Tpat_construct (c2,ps2)
- when c1.cstr_tag = c2.cstr_tag ->
- let rs = lubs ps1 ps2 in
- make_pat (Tpat_construct (c1,rs)) p.pat_type p.pat_env
-| Tpat_variant(l1,Some p1,row), Tpat_variant(l2,Some p2,_)
- when l1=l2 && not (is_absent l1 row) ->
- let r=lub p1 p2 in
- make_pat (Tpat_variant (l1,Some r,row)) p.pat_type p.pat_env
-| Tpat_variant (l1,None,row), Tpat_variant(l2,None,_)
- when l1 = l2 && not (is_absent l1 row) -> p
-| Tpat_record l1,Tpat_record l2 ->
- let rs = record_lubs l1 l2 in
- make_pat (Tpat_record rs) 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 l1 = sort_fields l1 and l2 = sort_fields l2 in
- let rec lub_rec l1 l2 = match l1,l2 with
- | [],_ -> l2
- | _,[] -> l1
- | (lbl1,p1)::rem1, (lbl2,p2)::rem2 ->
- if lbl1.lbl_pos < lbl2.lbl_pos then
- (lbl1,p1)::lub_rec rem1 l2
- else if lbl2.lbl_pos < lbl1.lbl_pos then
- (lbl2,p2)::lub_rec l1 rem2
- else
- (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
-| _,_ -> []
-
-
-(******************************)
-(* Entry points *)
-(* - Variant closing *)
-(* - Partial match *)
-(* - Unused match case *)
-(******************************)
-
-(* 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)
-
-(*
- Build up a working pattern matrix.
- - Forget about guarded patterns
-*)
-
-let has_guard act = match act.exp_desc with
-| Texp_when(_, _) -> true
-| _ -> false
-
-
-let rec initial_matrix = function
- [] -> []
- | (pat, act) :: rem ->
- if has_guard act
- then
- initial_matrix rem
- else
- [pat] :: initial_matrix rem
-
-(*
- All the following ``*_all'' functions
- check whether a given value [v] is matched by some row in pss.
- They are used to whether the exhaustiveness exemple is
- matched by a guarded clause
-*)
-
-
-exception NoGuard
-
-let rec initial_all no_guard = function
- | [] ->
- if no_guard then
- raise NoGuard
- else
- []
- | (pat, act) :: rem ->
- ([pat], pat.pat_loc) :: initial_all (no_guard && not (has_guard act)) 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
-
-let check_partial loc casel =
- let pss = initial_matrix casel in
- let pss = get_mins le_pats pss in
- 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.Other
- "Bad style, all clauses in this pattern-matching are guarded.")
- end ;
- Partial
- | ps::_ ->
- begin match exhaust pss (List.length ps) with
- | Rnone -> Total
- | Rsome [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 l'', where l is the location of
- a possibly matching clause.
- I forget about l, 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 ;
- Buffer.contents buf
- with _ ->
- "" in
- Location.prerr_warning loc (Warnings.Partial_match errmsg) ;
- Partial
- | _ ->
- fatal_error "Parmatch.check_partial"
- end
-
-
-let location_of_clause = function
- pat :: _ -> pat.pat_loc
- | _ -> fatal_error "Parmatch.location_of_clause"
-
-let seen_pat q pss = [q]::pss
-
-(* Extra check
- Will this clause match if someone adds a constructor somewhere
-*)
-
-let warn_fragile () = Warnings.is_active (Warnings.Fragile_pat "")
-
-let check_used_extra pss qs =
- if warn_fragile () then begin
- match satisfiable_extra None pss qs with
- | Some location ->
- Location.prerr_warning
- location
- (Warnings.Fragile_pat "")
- | None -> ()
- end
-
-
-
-let check_unused tdefs casel =
- if Warnings.is_active Warnings.Unused_match then
- let rec do_rec pref = function
- | [] -> ()
- | (q,act as clause)::rem ->
- let qs = [q] in
- begin try
- let pss = get_mins le_pats (List.filter (compats qs) pref) in
- let r = every_satisfiables (make_rows pss) (make_row qs) in
- match r with
- | Unused ->
- Location.prerr_warning
- (location_of_clause qs) Warnings.Unused_match
- | Upartial ps ->
- List.iter
- (fun p ->
- Location.prerr_warning
- p.pat_loc Warnings.Unused_pat)
- ps
- | Used ->
- check_used_extra pss qs
- with e -> (* useless ? *)
- Location.prerr_warning (location_of_clause qs)
- (Warnings.Other "Fatal Error in Parmatch.check_unused") ;
- raise e
- end ;
-
- if has_guard act then
- do_rec pref rem
- else
- do_rec (seen_pat q pref) rem in
-
-
-
- do_rec [] casel
diff --git a/typing/parmatch.mli b/typing/parmatch.mli
deleted file mode 100644
index 168876d649..0000000000
--- a/typing/parmatch.mli
+++ /dev/null
@@ -1,52 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Detection of partial matches and unused match cases. *)
-open Types
-open Typedtree
-
-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 :
- (label_description * pattern) list -> (label_description * pattern) list
-
-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
-
-val set_args : pattern -> pattern list -> pattern list
-
-val pat_of_constr : pattern -> constructor_description -> pattern
-val complete_constrs :
- pattern -> constructor_tag list -> constructor_description list
-
-val pressure_variants: Env.t -> pattern list -> unit
-val check_partial: Location.t -> (pattern * expression) list -> partial
-val check_unused: Env.t -> (pattern * expression) list -> unit
-
-
-
diff --git a/typing/path.ml b/typing/path.ml
deleted file mode 100644
index 88f9aa5748..0000000000
--- a/typing/path.ml
+++ /dev/null
@@ -1,49 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-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 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 rec name = function
- Pident id -> Ident.name id
- | Pdot(p, s, pos) -> name p ^ "." ^ s
- | Papply(p1, p2) -> name p1 ^ "(" ^ name p2 ^ ")"
-
-let rec head = function
- Pident id -> id
- | Pdot(p, s, pos) -> head p
- | Papply(p1, p2) -> assert false
-
diff --git a/typing/path.mli b/typing/path.mli
deleted file mode 100644
index 96f3e98369..0000000000
--- a/typing/path.mli
+++ /dev/null
@@ -1,29 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Access paths *)
-
-type t =
- Pident of Ident.t
- | Pdot of t * string * int
- | Papply of t * t
-
-val same: t -> t -> bool
-val isfree: Ident.t -> t -> bool
-val binding_time: t -> int
-
-val nopos: int
-
-val name: t -> string
-val head: t -> Ident.t
diff --git a/typing/predef.ml b/typing/predef.ml
deleted file mode 100644
index 436d48d237..0000000000
--- a/typing/predef.ml
+++ /dev/null
@@ -1,187 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Predefined type constructors (with special typing rules in typecore) *)
-
-open Asttypes
-open Path
-open Types
-open Btype
-
-let ident_int = Ident.create "int"
-and ident_char = Ident.create "char"
-and ident_string = Ident.create "string"
-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_format4 = Ident.create "format4"
-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"
-
-let path_int = Pident ident_int
-and path_char = Pident ident_char
-and path_string = Pident ident_string
-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_format4 = Pident ident_format4
-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
-
-let type_int = newgenty (Tconstr(path_int, [], ref Mnil))
-and type_char = newgenty (Tconstr(path_char, [], ref Mnil))
-and type_string = newgenty (Tconstr(path_string, [], 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))
-
-let ident_match_failure = Ident.create "Match_failure"
-and ident_out_of_memory = Ident.create "Out_of_memory"
-and ident_invalid_argument = Ident.create "Invalid_argument"
-and ident_failure = Ident.create "Failure"
-and ident_not_found = Ident.create "Not_found"
-and ident_sys_error = Ident.create "Sys_error"
-and ident_end_of_file = Ident.create "End_of_file"
-and ident_division_by_zero = Ident.create "Division_by_zero"
-and ident_stack_overflow = Ident.create "Stack_overflow"
-and ident_sys_blocked_io = Ident.create "Sys_blocked_io"
-and ident_assert_failure = Ident.create "Assert_failure"
-and ident_undefined_recursive_module = Ident.create "Undefined_recursive_module"
-
-let 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 build_initial_env add_type add_exception empty_env =
- let decl_abstr =
- {type_params = [];
- type_arity = 0;
- type_kind = Type_abstract;
- type_manifest = None;
- type_variance = []}
- and decl_bool =
- {type_params = [];
- type_arity = 0;
- type_kind = Type_variant(["false",[]; "true",[]], Public);
- type_manifest = None;
- type_variance = []}
- and decl_unit =
- {type_params = [];
- type_arity = 0;
- type_kind = Type_variant(["()",[]], Public);
- type_manifest = None;
- type_variance = []}
- and decl_exn =
- {type_params = [];
- type_arity = 0;
- type_kind = Type_variant([], Public);
- type_manifest = None;
- type_variance = []}
- and decl_array =
- let tvar = newgenvar() in
- {type_params = [tvar];
- type_arity = 1;
- type_kind = Type_abstract;
- type_manifest = None;
- type_variance = [true, true, true]}
- and decl_list =
- let tvar = newgenvar() in
- {type_params = [tvar];
- type_arity = 1;
- type_kind =
- Type_variant(["[]", []; "::", [tvar; type_list tvar]], Public);
- type_manifest = None;
- type_variance = [true, false, false]}
- and decl_format4 =
- {type_params = [newgenvar(); newgenvar(); newgenvar(); newgenvar()];
- type_arity = 4;
- type_kind = Type_abstract;
- type_manifest = None;
- type_variance = [true, true, true; true, true, true;
- true, true, true; true, true, true]}
- and decl_option =
- let tvar = newgenvar() in
- {type_params = [tvar];
- type_arity = 1;
- type_kind = Type_variant(["None", []; "Some", [tvar]], Public);
- type_manifest = None;
- type_variance = [true, false, false]}
- and decl_lazy_t =
- let tvar = newgenvar() in
- {type_params = [tvar];
- type_arity = 1;
- type_kind = Type_abstract;
- type_manifest = None;
- type_variance = [true, false, false]}
- in
-
- add_exception ident_match_failure
- [newgenty (Ttuple[type_string; type_int; type_int])] (
- add_exception ident_out_of_memory [] (
- add_exception ident_stack_overflow [] (
- add_exception ident_invalid_argument [type_string] (
- add_exception ident_failure [type_string] (
- add_exception ident_not_found [] (
- add_exception ident_sys_blocked_io [] (
- add_exception ident_sys_error [type_string] (
- add_exception ident_end_of_file [] (
- add_exception ident_division_by_zero [] (
- add_exception ident_assert_failure
- [newgenty (Ttuple[type_string; type_int; type_int])] (
- add_exception 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_format4 decl_format4 (
- 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 (
- add_type ident_int decl_abstr (
- empty_env)))))))))))))))))))))))))))
-
-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 ]
diff --git a/typing/predef.mli b/typing/predef.mli
deleted file mode 100644
index cfcb71cd71..0000000000
--- a/typing/predef.mli
+++ /dev/null
@@ -1,65 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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_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 path_int: Path.t
-val path_char: Path.t
-val path_string: 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_format4: 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_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_exception. *)
-
-val build_initial_env:
- (Ident.t -> type_declaration -> 'a -> 'a) ->
- (Ident.t -> exception_declaration -> 'a -> 'a) ->
- 'a -> 'a
-
-(* To initialize linker tables *)
-
-val builtin_values: (string * Ident.t) list
diff --git a/typing/primitive.ml b/typing/primitive.ml
deleted file mode 100644
index fbbdb05b11..0000000000
--- a/typing/primitive.ml
+++ /dev/null
@@ -1,56 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Description of primitive functions *)
-
-open Misc
-
-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_float: bool } (* Does the above operate on unboxed floats? *)
-
-let parse_declaration arity decl =
- match decl with
- | name :: "noalloc" :: name2 :: "float" :: _ ->
- {prim_name = name; prim_arity = arity; prim_alloc = false;
- prim_native_name = name2; prim_native_float = true}
- | name :: "noalloc" :: name2 :: _ ->
- {prim_name = name; prim_arity = arity; prim_alloc = false;
- prim_native_name = name2; prim_native_float = false}
- | name :: name2 :: "float" :: _ ->
- {prim_name = name; prim_arity = arity; prim_alloc = true;
- prim_native_name = name2; prim_native_float = true}
- | name :: "noalloc" :: _ ->
- {prim_name = name; prim_arity = arity; prim_alloc = false;
- prim_native_name = ""; prim_native_float = false}
- | name :: name2 :: _ ->
- {prim_name = name; prim_arity = arity; prim_alloc = true;
- prim_native_name = name2; prim_native_float = false}
- | name :: _ ->
- {prim_name = name; prim_arity = arity; prim_alloc = true;
- prim_native_name = ""; prim_native_float = false}
- | [] ->
- fatal_error "Primitive.parse_declaration"
-
-let description_list p =
- let list = [p.prim_name] in
- let list = if not p.prim_alloc then "noalloc" :: list else list in
- let list =
- if p.prim_native_name <> "" then p.prim_native_name :: list else list
- in
- let list = if p.prim_native_float then "float" :: list else list in
- List.rev list
diff --git a/typing/primitive.mli b/typing/primitive.mli
deleted file mode 100644
index e89678aec7..0000000000
--- a/typing/primitive.mli
+++ /dev/null
@@ -1,26 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Description of primitive functions *)
-
-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_float: bool } (* Does the above operate on unboxed floats? *)
-
-val parse_declaration: int -> string list -> description
-
-val description_list: description -> string list
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
deleted file mode 100644
index 232a32abb8..0000000000
--- a/typing/printtyp.ml
+++ /dev/null
@@ -1,1000 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* 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 Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Printing functions *)
-
-open Misc
-open Ctype
-open Format
-open Longident
-open Path
-open Asttypes
-open Types
-open Btype
-open Outcometree
-
-(* Redefine it here since goal differs *)
-
-let rec opened_object ty =
- match (repr ty).desc with
- Tobject (t, _) -> opened_object t
- | Tfield(_, _, _, t) -> opened_object t
- | Tvar -> true
- | Tunivar -> true
- | _ -> false
-
-(* Print a long identifier *)
-
-let rec longident ppf = function
- | Lident s -> fprintf ppf "%s" 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 ident ppf id = fprintf ppf "%s" (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 ->
- fprintf ppf "%s" s
- | Pdot(p, s, pos) ->
- fprintf ppf "%a.%s" path p s
- | Papply(p1, p2) ->
- fprintf ppf "%a(%a)" path p1 path p2
-
-(* Print a raw type expression, with sharing *)
-
-let raw_list pr ppf = function
- [] -> fprintf ppf "[]"
- | a :: l ->
- fprintf ppf "@[<1>[%a%t]@]" pr a
- (fun ppf -> List.iter (fun x -> fprintf ppf ";@,%a" pr x) l)
-
-let rec safe_kind_repr v = function
- Fvar {contents=Some k} ->
- if List.memq k v then "Fvar loop" else
- safe_kind_repr (k::v) k
- | Fvar _ -> "Fvar None"
- | Fpresent -> "Fpresent"
- | Fabsent -> "Fabsent"
-
-let rec safe_commu_repr v = function
- Cok -> "Cok"
- | Cunknown -> "Cunknown"
- | Clink r ->
- if List.memq r v then "Clink loop" else
- safe_commu_repr (r::v) !r
-
-let rec safe_repr v = function
- {desc = Tlink t} when not (List.memq t v) ->
- safe_repr (t::v) t
- | t -> t
-
-let rec list_of_memo = function
- Mnil -> []
- | Mcons (p, t1, t2, rem) -> (p,t1,t2) :: list_of_memo rem
- | Mlink rem -> list_of_memo !rem
-
-let visited = ref []
-let rec raw_type ppf ty =
- let ty = safe_repr [] ty in
- if List.memq ty !visited then fprintf ppf "{id=%d}" ty.id else begin
- visited := ty :: !visited;
- fprintf ppf "@[<1>{id=%d;level=%d;desc=@,%a}@]" ty.id ty.level
- raw_type_desc ty.desc
- end
-and raw_type_list tl = raw_list raw_type tl
-and raw_type_desc ppf = function
- Tvar -> fprintf ppf "Tvar"
- | Tarrow(l,t1,t2,c) ->
- fprintf ppf "@[<hov1>Tarrow(%s,@,%a,@,%a,@,%s)@]"
- l raw_type t1 raw_type t2
- (safe_commu_repr [] c)
- | Ttuple tl ->
- fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl
- | Tconstr (p, tl, abbrev) ->
- fprintf ppf "@[<hov1>Tconstr(@,%a,@,%a,@,%a)@]" path p
- raw_type_list tl
- (raw_list (fun ppf (p,t1,t2) ->
- fprintf ppf "@[%a,@ %a,@ %a@]" path p raw_type t1 raw_type t2))
- (list_of_memo !abbrev)
- | Tobject (t, nm) ->
- fprintf ppf "@[<hov1>Tobject(@,%a,@,@[<1>ref%t@])@]" raw_type t
- (fun ppf ->
- match !nm with None -> fprintf ppf " None"
- | Some(p,tl) ->
- fprintf ppf "(Some(@,%a,@,%a))" path p raw_type_list tl)
- | Tfield (f, k, t1, t2) ->
- fprintf ppf "@[<hov1>Tfield(@,%s,@,%s,@,%a,@,%a)@]" f
- (safe_kind_repr [] k)
- raw_type t1 raw_type t2
- | Tnil -> fprintf ppf "Tnil"
- | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t
- | Tsubst t -> fprintf ppf "@[<1>Tsubst@,%a@]" raw_type t
- | Tunivar -> fprintf ppf "Tunivar"
- | Tpoly (t, tl) ->
- fprintf ppf "@[<hov1>Tpoly(@,%a,@,%a)@]"
- raw_type t
- raw_type_list tl
- | Tvariant row ->
- fprintf ppf
- "@[<hov1>{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%b;@ %s%b;@ @[<1>%s%t@]}@]"
- "row_fields="
- (raw_list (fun ppf (l, f) ->
- fprintf ppf "@[%s,@ %a@]" l raw_field f))
- row.row_fields
- "row_more=" raw_type row.row_more
- "row_closed=" row.row_closed
- "row_fixed=" row.row_fixed
- "row_name="
- (fun ppf ->
- match row.row_name with None -> fprintf ppf "None"
- | Some(p,tl) ->
- fprintf ppf "Some(@,%a,@,%a)" path p raw_type_list tl)
-
-and raw_field ppf = function
- Rpresent None -> fprintf ppf "Rpresent None"
- | Rpresent (Some t) -> fprintf ppf "@[<1>Rpresent(Some@,%a)@]" raw_type t
- | Reither (c,tl,m,e) ->
- fprintf ppf "@[<hov1>Reither(%b,@,%a,@,%b,@,@[<1>ref%t@])@]" c
- raw_type_list tl m
- (fun ppf ->
- match !e with None -> fprintf ppf " None"
- | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f)
- | Rabsent -> fprintf ppf "Rabsent"
-
-let raw_type_expr ppf t =
- visited := [];
- raw_type ppf t;
- visited := []
-
-(* Print a type expression *)
-
-let names = ref ([] : (type_expr * string) list)
-let name_counter = ref 0
-
-let reset_names () = names := []; name_counter := 0
-
-let 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;
- name
-
-let name_of_type t =
- try List.assq t !names with Not_found ->
- let name = new_name () in
- names := (t, name) :: !names;
- name
-
-let check_name_of_type t = ignore(name_of_type t)
-
-let non_gen_mark sch ty =
- if sch && ty.desc = Tvar && ty.level <> generic_level then "_" else ""
-
-let print_name_of_type sch ppf t =
- fprintf ppf "'%s%s" (non_gen_mark sch t) (name_of_type t)
-
-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.mem_assq t !names) 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 aliased := px :: !aliased
-
-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 then add_alias px else
- let visited = px :: visited in
- match ty.desc with
- | Tvar -> ()
- | Tarrow(_, ty1, ty2, _) ->
- mark_loops_rec visited ty1; mark_loops_rec visited ty2
- | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl
- | Tconstr(_, 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 with row_bound = []}
- 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 -> ()
-
-let mark_loops ty =
- normalize_type Env.empty ty;
- mark_loops_rec [] ty;;
-
-let reset_loop_marks () =
- visited_objects := []; aliased := []; delayed := []
-
-let reset () =
- 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 print_label ppf l =
- if !print_labels && l <> "" || is_optional l then fprintf ppf "%s:" l
-
-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 ->
- 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 && l <> "" || is_optional l then 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 "<hidden>"
- 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) ->
- 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 id = tree_of_path p in
- let args = tree_of_typlist sch tyl in
- if row.row_closed && all_present then
- Otyp_constr (id, args)
- 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_name(tree_of_path p, args),
- 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
- | Tsubst ty ->
- tree_of_typexp sch ty
- | Tlink _ | Tnil | Tfield _ ->
- fatal_error "Printtyp.tree_of_typexp"
- | Tpoly (ty, []) ->
- tree_of_typexp sch ty
- | Tpoly (ty, tyl) ->
- let tyl = List.map repr tyl in
- (* let tyl = List.filter is_aliased tyl in *)
- if tyl = [] then tree_of_typexp sch ty else begin
- List.iter add_delayed tyl;
- let tl = List.map name_of_type tyl in
- Otyp_poly (tl, tree_of_typexp sch ty)
- end
- | Tunivar ->
- Otyp_var (false, name_of_type ty)
- in
- if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed;
- if is_aliased px && ty.desc <> Tvar && ty.desc <> Tunivar 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: un constructeur constant qui a un argument *)
- then (l, true, tree_of_typlist sch tyl)
- else (l, false, tree_of_typlist sch tyl)
- | Rabsent -> (l, false, [] (* une erreur, en fait *))
-
-and tree_of_typlist sch = function
- | [] -> []
- | ty :: tyl ->
- let tr = tree_of_typexp sch ty in
- tr :: tree_of_typlist 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 =
- Sort.list (fun (n, _) (n', _) -> 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
- Otyp_class (non_gen, tree_of_path p, args)
- | _ ->
- fatal_error "Printtyp.tree_of_typobject"
- end
-
-and is_non_gen sch ty =
- sch && ty.desc = Tvar && 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)
- | 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 prio ppf ty =
- !Oprint.out_type ppf (tree_of_typexp sch ty)
-
-let type_expr ppf ty = typexp false 0 ppf ty
-
-and type_sch ppf ty = typexp true 0 ppf ty
-
-and type_scheme ppf ty = reset_and_mark_loops ty; typexp true 0 ppf ty
-
-(* Maxence *)
-let type_scheme_max ?(b_reset_names=true) ppf ty =
- if b_reset_names then reset_names () ;
- typexp true 0 ppf ty
-(* Fin 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 string_of_mutable = function
- | Immutable -> ""
- | Mutable -> "mutable "
-
-let rec tree_of_type_decl id decl =
-
- reset();
-
- let params = filter_params decl.type_params in
-
- 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 ([], _) -> ()
- | Type_variant (cstrs, priv) ->
- List.iter (fun (_, args) -> List.iter mark_loops args) cstrs
- | Type_record(l, rep, priv) ->
- List.iter (fun (_, _, ty) -> mark_loops ty) l
- end;
-
- let type_param =
- function
- | Otyp_var (_, id) -> id
- | _ -> "?"
- in
- let type_defined decl =
- if decl.type_kind = Type_abstract && ty_manifest = None
- && List.exists (fun x -> x <> (true,true,true)) decl.type_variance then
- let vari = List.map (fun (co,cn,ct) -> (co,cn)) decl.type_variance in
- (Ident.name id,
- List.combine
- (List.map (fun ty -> type_param (tree_of_typexp false ty)) params)
- vari)
- else
- let ty =
- tree_of_typexp false
- (Btype.newgenty (Tconstr(Pident id, params, ref Mnil)))
- in
- match ty with
- | Otyp_constr (Oide_ident id, tyl) ->
- (id, List.map (fun ty -> (type_param ty, (true, true))) tyl)
- | _ -> ("?", [])
- 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 =
- match decl.type_kind with
- | Type_abstract ->
- begin match ty_manifest with
- | None -> Otyp_abstract
- | Some ty -> tree_of_typexp false ty
- end
- | Type_variant(cstrs, priv) ->
- tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs, priv))
- | Type_record(lbls, rep, priv) ->
- tree_of_manifest (Otyp_record (List.map tree_of_label lbls, priv))
- in
- (name, args, ty, constraints)
-
-and tree_of_constructor (name, args) =
- (name, tree_of_typlist false args)
-
-and tree_of_label (name, mut, arg) =
- (name, mut = Mutable, tree_of_typexp false arg)
-
-let tree_of_type_declaration id decl =
- Osig_type [tree_of_type_decl id decl]
-
-let type_declaration id ppf decl =
- !Oprint.out_sig_item ppf (tree_of_type_declaration id decl)
-
-(* Print an exception declaration *)
-
-let tree_of_exception_declaration id decl =
- let tyl = tree_of_typlist false decl in
- Osig_exception (Ident.name id, tyl)
-
-let exception_declaration id ppf decl =
- !Oprint.out_sig_item ppf (tree_of_exception_declaration id decl)
-
-(* Print a value declaration *)
-
-let tree_of_value_description id decl =
- let id = Ident.name id in
- let ty = tree_of_type_scheme decl.val_type in
- let prims =
- match decl.val_kind with
- | Val_prim p -> Primitive.description_list p
- | _ -> []
- in
- Osig_value (id, ty, prims)
-
-let value_description id ppf decl =
- !Oprint.out_sig_item ppf (tree_of_value_description id decl)
-
-(* Print a class type *)
-
-let class_var sch ppf l (m, t) =
- fprintf ppf
- "@ @[<2>val %s%s :@ %a@]" (string_of_mutable m) l (typexp sch 0) t
-
-let metho sch concrete ppf (lab, kind, ty) =
- if lab <> dummy_method then begin
- let priv =
- match field_kind_repr kind with
- | Fvar _ (* {contents = None} *) -> "private "
- | _ (* Fpresent *) -> "" in
- let virt =
- if Concr.mem lab concrete then "" else "virtual " in
- fprintf ppf "@ @[<2>method %s%s%s :@ %a@]" priv virt lab (typexp sch 0) ty
- end
-
-let method_type ty =
- let ty = repr ty in
- match ty.desc with
- Tpoly(ty, _) -> ty
- | _ -> ty
-
-let tree_of_metho sch concrete csil (lab, kind, ty) =
- if lab <> dummy_method then begin
- let priv =
- match field_kind_repr kind with
- | Fvar _ (* {contents = None} *) -> true
- | _ (* Fpresent *) -> false in
- let virt = not (Concr.mem lab concrete) in
- let ty = method_type ty in
- Ocsg_method (lab, priv, virt, tree_of_typexp sch ty) :: csil
- end
- else csil
-
-let rec prepare_class_type params = function
- | Tcty_constr (p, tyl, cty) ->
- let sty = Ctype.self_type cty in
- if List.memq (proxy sty) !visited_objects
- || List.exists (fun ty -> (repr ty).desc <> Tvar) params
- || List.exists (deep_occur sty) tyl
- then prepare_class_type params cty
- else List.iter mark_loops tyl
- | Tcty_signature sign ->
- let sty = repr sign.cty_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.cty_self)
- in
- List.iter (fun (_, _, ty) -> mark_loops (method_type ty)) fields;
- Vars.iter (fun _ (_, ty) -> mark_loops ty) sign.cty_vars
- | Tcty_fun (_, ty, cty) ->
- mark_loops ty;
- prepare_class_type params cty
-
-let rec tree_of_class_type sch params =
- function
- | Tcty_constr (p', tyl, cty) ->
- let sty = Ctype.self_type cty in
- if List.memq (proxy sty) !visited_objects
- || List.exists (fun ty -> (repr ty).desc <> Tvar) params
- then
- tree_of_class_type sch params cty
- else
- Octy_constr (tree_of_path p', tree_of_typlist true tyl)
- | Tcty_signature sign ->
- let sty = repr sign.cty_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.cty_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, t) all -> (l, m, t) :: all) sign.cty_vars [] in
- let csil =
- List.fold_left
- (fun csil (l, m, t) ->
- Ocsg_value (l, m = Mutable, tree_of_typexp sch t) :: csil)
- csil all_vars
- in
- let csil =
- List.fold_left (tree_of_metho sch sign.cty_concr) csil fields
- in
- Octy_signature (self_ty, List.rev csil)
- | Tcty_fun (l, ty, cty) ->
- let lab = if !print_labels && l <> "" || is_optional l then 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 "<hidden>")) []
- else ty in
- let tr = tree_of_typexp sch ty in
- Octy_fun (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_params = function
- | [] -> []
- | params ->
- let tyl = tree_of_typlist true params in
- List.map (function Otyp_var (_, s) -> s | _ -> "?") tyl
-
-let tree_of_class_declaration id cl =
- let params = filter_params cl.cty_params in
-
- reset ();
- List.iter add_alias params;
- prepare_class_type params cl.cty_type;
- let sty = 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, tree_of_class_params params,
- tree_of_class_type true params cl.cty_type)
-
-let class_declaration id ppf cl =
- !Oprint.out_sig_item ppf (tree_of_class_declaration id cl)
-
-let tree_of_cltype_declaration id cl =
- let params = List.map repr cl.clty_params in
-
- reset ();
- List.iter add_alias params;
- prepare_class_type params cl.clty_type;
- let sty = 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.cty_self) in
- List.exists
- (fun (lab, _, ty) ->
- not (lab = dummy_method || Concr.mem lab sign.cty_concr))
- fields in
-
- Osig_class_type
- (virt, Ident.name id, tree_of_class_params params,
- tree_of_class_type true params cl.clty_type)
-
-let cltype_declaration id ppf cl =
- !Oprint.out_sig_item ppf (tree_of_cltype_declaration id cl)
-
-(* Print a module type *)
-
-let rec tree_of_modtype = function
- | Tmty_ident p ->
- Omty_ident (tree_of_path p)
- | Tmty_signature sg ->
- Omty_signature (tree_of_signature sg)
- | Tmty_functor(param, ty_arg, ty_res) ->
- Omty_functor
- (Ident.name param, tree_of_modtype ty_arg, tree_of_modtype ty_res)
-
-and tree_of_signature = function
- | [] -> []
- | item :: rem ->
- match item with
- | Tsig_value(id, decl) ->
- tree_of_value_description id decl :: tree_of_signature rem
- | Tsig_type(id, decl) ->
- let (type_decl_list, rem) =
- let rec more_type_declarations = function
- | Tsig_type(id, decl) :: rem ->
- let (type_decl_list, rem) = more_type_declarations rem in
- (id, decl) :: type_decl_list, rem
- | rem -> [], rem in
- more_type_declarations rem
- in
- let type_decl_list =
- List.map (fun (id, decl) -> tree_of_type_decl id decl)
- ((id, decl) :: type_decl_list)
- in
- Osig_type type_decl_list
- ::
- tree_of_signature rem
- | Tsig_exception(id, decl) ->
- Osig_exception (Ident.name id, tree_of_typlist false decl) ::
- tree_of_signature rem
- | Tsig_module(id, mty) ->
- Osig_module (Ident.name id, tree_of_modtype mty) ::
- tree_of_signature rem
- | Tsig_modtype(id, decl) ->
- tree_of_modtype_declaration id decl :: tree_of_signature rem
- | Tsig_class(id, decl) ->
- let rem =
- match rem with
- | ctydecl :: tydecl1 :: tydecl2 :: rem -> rem
- | _ -> []
- in
- tree_of_class_declaration id decl :: tree_of_signature rem
- | Tsig_cltype(id, decl) ->
- let rem =
- match rem with
- | tydecl1 :: tydecl2 :: rem -> rem
- | _ -> []
- in
- tree_of_cltype_declaration id decl :: tree_of_signature rem
-
-and tree_of_modtype_declaration id decl =
- let mty =
- match decl with
- | Tmodtype_abstract -> Omty_abstract
- | Tmodtype_manifest mty -> tree_of_modtype mty
- in
- Osig_modtype (Ident.name id, mty)
-
-let tree_of_module id mty = Osig_module (Ident.name id, tree_of_modtype mty)
-
-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)
-
-(* Print a signature body (used by -i when compiling a .ml) *)
-
-let print_signature ppf tree =
- fprintf ppf "@[<v>%a@]" !Oprint.out_signature tree
-
-let signature ppf sg =
- fprintf ppf "%a" print_signature (tree_of_signature sg)
-
-(* Print an unification error *)
-
-let type_expansion t ppf t' =
- if t == t' then type_expr ppf t 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 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 mismatch = function
- | [(_, t); (_, t')] -> (t, t')
- | _ :: _ :: rem -> mismatch rem
- | _ -> assert false
-
-let rec filter_trace = function
- | (t1, t1') :: (t2, t2') :: rem ->
- let rem' = filter_trace rem in
- if t1 == t1' && t2 == t2'
- then rem'
- else (t1, t1') :: (t2, t2') :: 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 = newty2 (row_more row).level Tvar})
- | _ -> t
-
-let prepare_expansion (t, t') =
- let t' = hide_variant_name t' in
- mark_loops t; if t != t' then mark_loops t';
- (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 explanation unif t3 t4 ppf =
- match t3.desc, t4.desc with
- | Tfield _, Tvar | Tvar, Tfield _ ->
- 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 t3.desc = Tunivar then t3 else t4)
- | Tfield (lab, _, _, _), _
- | _, Tfield (lab, _, _, _) when lab = dummy_method ->
- fprintf ppf
- "@,Self type cannot be unified with a closed object type"
- | Tfield (l, _, _, _), _ ->
- fprintf ppf
- "@,@[Only the first object type has a method %s@]" l
- | _, Tfield (l, _, _, _) ->
- fprintf ppf
- "@,@[Only the second object type has a method %s@]" l
- | 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, row1.row_closed with
- | [], true, [], true ->
- fprintf ppf "@,These two variant types have no intersection"
- | [], true, fields, _ ->
- fprintf ppf
- "@,@[The first variant type does not allow tag(s)@ @[<hov>%a@]@]"
- print_tags fields
- | fields, _, [], true ->
- fprintf ppf
- "@,@[The second variant type does not allow tag(s)@ @[<hov>%a@]@]"
- print_tags fields
- | _ -> ()
- end
- | _ -> ()
-
-let unification_error unif tr txt1 ppf txt2 =
- reset ();
- let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in
- let (t3, t4) = mismatch tr in
- match tr with
- | [] | _ :: [] -> assert false
- | t1 :: t2 :: tr ->
- try
- let t1, t1' = prepare_expansion t1
- and t2, t2' = prepare_expansion t2 in
- print_labels := not !Clflags.classic;
- let tr = filter_trace tr in
- let tr = List.map prepare_expansion tr in
- fprintf ppf
- "@[<v>\
- @[%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 t3 t4);
- print_labels := true
- with exn ->
- print_labels := true;
- raise exn
-
-let report_unification_error ppf tr txt1 txt2 =
- unification_error true tr txt1 ppf txt2;;
-
-let trace fst txt ppf tr =
- print_labels := not !Clflags.classic;
- try match tr with
- t1 :: t2 :: tr' ->
- if fst then trace fst txt ppf (t1 :: t2 :: filter_trace tr')
- else trace fst txt ppf (filter_trace tr);
- print_labels := true
- | _ -> ()
- with exn ->
- print_labels := true;
- raise exn
-
-let report_subtyping_error ppf tr1 txt1 tr2 =
- reset ();
- let tr1 = List.map prepare_expansion tr1
- and tr2 = List.map prepare_expansion tr2 in
- trace true txt1 ppf tr1;
- if tr2 = [] then () else
- let t3, t4 = mismatch tr2 in
- trace false "is not compatible with type" ppf tr2;
- explanation true t3 t4 ppf
diff --git a/typing/printtyp.mli b/typing/printtyp.mli
deleted file mode 100644
index c02c13f0df..0000000000
--- a/typing/printtyp.mli
+++ /dev/null
@@ -1,67 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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 raw_type_expr: formatter -> type_expr -> unit
-val reset: unit -> unit
-val mark_loops: type_expr -> unit
-val reset_and_mark_loops: type_expr -> unit
-val reset_and_mark_loops_list: type_expr list -> unit
-val type_expr: formatter -> type_expr -> unit
-val tree_of_type_scheme: type_expr -> out_type
-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
-(* Fin Maxence *)
-val tree_of_value_description: Ident.t -> value_description -> out_sig_item
-val value_description: Ident.t -> formatter -> value_description -> unit
-val tree_of_type_declaration: Ident.t -> type_declaration -> out_sig_item
-val type_declaration: Ident.t -> formatter -> type_declaration -> unit
-val tree_of_exception_declaration: Ident.t -> exception_declaration -> out_sig_item
-val exception_declaration: Ident.t -> formatter -> exception_declaration -> unit
-val tree_of_module: Ident.t -> module_type -> out_sig_item
-val modtype: formatter -> module_type -> unit
-val signature: formatter -> signature -> unit
-val tree_of_modtype_declaration: Ident.t -> modtype_declaration -> out_sig_item
-val modtype_declaration: Ident.t -> formatter -> modtype_declaration -> unit
-val class_type: formatter -> class_type -> unit
-val tree_of_class_declaration: Ident.t -> class_declaration -> out_sig_item
-val class_declaration: Ident.t -> formatter -> class_declaration -> unit
-val tree_of_cltype_declaration: Ident.t -> cltype_declaration -> out_sig_item
-val cltype_declaration: Ident.t -> formatter -> cltype_declaration -> unit
-val type_expansion: type_expr -> Format.formatter -> type_expr -> unit
-val prepare_expansion: type_expr * type_expr -> type_expr * type_expr
-val trace: bool -> string -> formatter -> (type_expr * type_expr) list -> unit
-val unification_error:
- bool -> (type_expr * type_expr) list ->
- (formatter -> unit) -> formatter -> (formatter -> unit) ->
- unit
-val report_unification_error:
- formatter -> (type_expr * type_expr) list ->
- (formatter -> unit) -> (formatter -> unit) ->
- unit
-val report_subtyping_error:
- formatter -> (type_expr * type_expr) list ->
- string -> (type_expr * type_expr) list -> unit
diff --git a/typing/stypes.ml b/typing/stypes.ml
deleted file mode 100644
index ab0477b4b1..0000000000
--- a/typing/stypes.ml
+++ /dev/null
@@ -1,130 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Damien Doligez, projet Moscova, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2003 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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 Format;;
-open Lexing;;
-open Location;;
-open Typedtree;;
-
-type type_info =
- Ti_pat of pattern
- | Ti_expr of expression
- | Ti_class of class_expr
- | Ti_mod of module_expr
-;;
-
-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
-;;
-
-let type_info = ref ([] : type_info list);;
-let phrases = ref ([] : Location.t list);;
-
-let record ti =
- if !Clflags.save_types && not (get_location ti).Location.loc_ghost then
- type_info := ti :: !type_info
-;;
-
-let record_phrase loc =
- if !Clflags.save_types 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 =
- fprintf pp "%S %d %d %d" pos.pos_fname pos.pos_lnum pos.pos_bol pos.pos_cnum;
-;;
-
-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;
- | _ -> ()
-;;
-
-
-(* The format of the annotation file is documented in emacs/caml-types.el. *)
-
-let print_info pp ti =
- match ti with
- | Ti_class _ | Ti_mod _ -> ()
- | Ti_pat {pat_loc = loc; pat_type = typ}
- | Ti_expr {exp_loc = loc; exp_type = typ} ->
- print_position pp loc.loc_start;
- fprintf pp " ";
- print_position pp loc.loc_end;
- fprintf pp "@.type(@. ";
- printtyp_reset_maybe loc;
- Printtyp.mark_loops typ;
- Printtyp.type_expr pp typ;
- fprintf pp "@.)@.";
-;;
-
-let get_info () =
- let info = List.fast_sort cmp_ti_inner_first !type_info in
- type_info := [];
- info
-;;
-
-let dump filename =
- if !Clflags.save_types then begin
- let info = get_info () in
- let pp = formatter_of_out_channel (open_out filename) in
- sort_filter_phrases ();
- List.iter (print_info pp) info;
- phrases := [];
- end else begin
- type_info := [];
- end;
-;;
diff --git a/typing/stypes.mli b/typing/stypes.mli
deleted file mode 100644
index ed5fa9149e..0000000000
--- a/typing/stypes.mli
+++ /dev/null
@@ -1,33 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Damien Doligez, projet Moscova, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2003 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Recording and dumping (partial) type information *)
-
-(* Clflags.save_types must be true *)
-
-open Typedtree;;
-
-type type_info =
- Ti_pat of pattern
- | Ti_expr of expression
- | Ti_class of class_expr
- | Ti_mod of module_expr
-;;
-
-val record : type_info -> unit;;
-val record_phrase : Location.t -> unit;;
-val dump : string -> unit;;
-
-val get_location : type_info -> Location.t;;
-val get_info : unit -> type_info list;;
diff --git a/typing/subst.ml b/typing/subst.ml
deleted file mode 100644
index 438adb5247..0000000000
--- a/typing/subst.ml
+++ /dev/null
@@ -1,295 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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 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 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(p1, p2) ->
- fatal_error "Subst.type_path"
-
-(* 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 }
-
-(* Similar to [Ctype.nondep_type_rec]. *)
-let rec typexp s ty =
- let ty = repr ty in
- match ty.desc with
- Tvar | Tunivar ->
- if s.for_saving || ty.id < 0 then
- let ty' =
- if s.for_saving then newpersty ty.desc else newty2 ty.level ty.desc
- in
- save_desc ty ty.desc; ty.desc <- Tsubst ty'; ty'
- else ty
- | Tsubst ty ->
- 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;
- (* Make a stub *)
- let ty' = if s.for_saving then newpersty Tvar else newgenvar () in
- ty.desc <- Tsubst ty';
- ty'.desc <-
- begin match desc with
- | Tconstr(p, tl, abbrev) ->
- Tconstr(type_path s p, List.map (typexp s) tl, ref Mnil)
- | 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 in
- (* Various cases for the row variable *)
- let more' =
- match more.desc with Tsubst ty -> ty
- | _ ->
- save_desc more more.desc;
- if s.for_saving then newpersty more.desc else
- if dup && more.desc <> Tunivar then newgenvar () else more
- 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
- let row =
- if s.for_saving then {row with row_bound = []} else row 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) ->
- begin match field_kind_repr kind with
- Fpresent ->
- Tfield(label, Fpresent, typexp s t1, typexp s t2)
- | Fabsent ->
- Tlink (typexp s t2)
- | Fvar _ (* {contents = None} *) as k ->
- let k = if s.for_saving then Fvar(ref None) else k in
- Tfield(label, k, typexp s t1, typexp s t2)
- end
- | _ -> 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 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, priv) ->
- Type_variant(
- List.map (fun (n, args) -> (n, List.map (typexp s) args))
- cstrs,
- priv)
- | Type_record(lbls, rep, priv) ->
- Type_record(
- List.map (fun (n, mut, arg) -> (n, mut, typexp s arg))
- lbls,
- rep, priv)
- end;
- type_manifest =
- begin match decl.type_manifest with
- None -> None
- | Some ty -> Some(typexp s ty)
- end;
- type_variance = decl.type_variance;
- }
- in
- cleanup_types ();
- decl
-
-let class_signature s sign =
- { cty_self = typexp s sign.cty_self;
- cty_vars = Vars.map (function (m, t) -> (m, typexp s t)) sign.cty_vars;
- cty_concr = sign.cty_concr }
-
-let rec class_type s =
- function
- Tcty_constr (p, tyl, cty) ->
- Tcty_constr (type_path s p, List.map (typexp s) tyl, class_type s cty)
- | Tcty_signature sign ->
- Tcty_signature (class_signature s sign)
- | Tcty_fun (l, ty, cty) ->
- Tcty_fun (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_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 }
- 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_type = class_type s decl.clty_type;
- clty_path = type_path s decl.clty_path }
- 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 }
-
-let exception_declaration s tyl =
- List.map (type_expr s) tyl
-
-let rec rename_bound_idents s idents = function
- [] -> (List.rev idents, s)
- | Tsig_type(id, d) :: sg ->
- let id' = Ident.rename id in
- rename_bound_idents (add_type id (Pident id') s) (id' :: idents) sg
- | Tsig_module(id, mty) :: sg ->
- let id' = Ident.rename id in
- rename_bound_idents (add_module id (Pident id') s) (id' :: idents) sg
- | Tsig_modtype(id, d) :: sg ->
- let id' = Ident.rename id in
- rename_bound_idents (add_modtype id (Tmty_ident(Pident id')) s)
- (id' :: idents) sg
- | (Tsig_value(id, _) | Tsig_exception(id, _) |
- Tsig_class(id, _) | Tsig_cltype(id, _)) :: sg ->
- let id' = Ident.rename id in
- rename_bound_idents s (id' :: idents) sg
-
-let rec modtype s = function
- Tmty_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) ->
- Tmty_ident(Pdot(module_path s p, n, pos))
- | Papply(p1, p2) ->
- fatal_error "Subst.modtype"
- end
- | Tmty_signature sg ->
- Tmty_signature(signature s sg)
- | Tmty_functor(id, arg, res) ->
- let id' = Ident.rename id in
- Tmty_functor(id', modtype s arg,
- modtype (add_module id (Pident id') s) res)
-
-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
- Tsig_value(id, d) ->
- Tsig_value(newid, value_description s d)
- | Tsig_type(id, d) ->
- Tsig_type(newid, type_declaration s d)
- | Tsig_exception(id, d) ->
- Tsig_exception(newid, exception_declaration s d)
- | Tsig_module(id, mty) ->
- Tsig_module(newid, modtype s mty)
- | Tsig_modtype(id, d) ->
- Tsig_modtype(newid, modtype_declaration s d)
- | Tsig_class(id, d) ->
- Tsig_class(newid, class_declaration s d)
- | Tsig_cltype(id, d) ->
- Tsig_cltype(newid, cltype_declaration s d)
-
-and modtype_declaration s = function
- Tmodtype_abstract -> Tmodtype_abstract
- | Tmodtype_manifest mty -> Tmodtype_manifest(modtype s mty)
diff --git a/typing/subst.mli b/typing/subst.mli
deleted file mode 100644
index b2220bb49e..0000000000
--- a/typing/subst.mli
+++ /dev/null
@@ -1,51 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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 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 exception_declaration:
- t -> exception_declaration -> exception_declaration
-val class_declaration: t -> class_declaration -> class_declaration
-val cltype_declaration: t -> cltype_declaration -> cltype_declaration
-val modtype: t -> module_type -> module_type
-val signature: t -> signature -> signature
-val modtype_declaration: t -> modtype_declaration -> modtype_declaration
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
deleted file mode 100644
index eecc265d36..0000000000
--- a/typing/typeclass.ml
+++ /dev/null
@@ -1,1495 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* typeclass.ml,v 1.57.4.6 2002/02/15 14:26:04 garrigue Exp *)
-
-open Misc
-open Parsetree
-open Asttypes
-open Path
-open Types
-open Typedtree
-open Typecore
-open Typetexp
-open Format
-
-type error =
- Unconsistent_constraint of (type_expr * type_expr) list
- | Method_type_mismatch of string * (type_expr * type_expr) list
- | Structure_expected of class_type
- | Cannot_apply of class_type
- | Apply_wrong_label of label
- | Pattern_type_clash of type_expr
- | Repeated_parameter
- | Unbound_class of Longident.t
- | Unbound_class_2 of Longident.t
- | Unbound_class_type 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 * 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
-
-exception Error of Location.t * error
-
-
- (**********************)
- (* Useful constants *)
- (**********************)
-
-
-(*
- Self type have a dummy private method, thus preventing it to become
- closed.
-*)
-let dummy_method = Ctype.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 "")
-
-
- (************************************)
- (* Some operations on class types *)
- (************************************)
-
-
-(* Fully expand the head of a class type *)
-let rec scrape_class_type =
- function
- Tcty_constr (_, _, cty) -> scrape_class_type cty
- | cty -> cty
-
-(* Generalize a class type *)
-let rec generalize_class_type =
- function
- Tcty_constr (_, params, cty) ->
- List.iter Ctype.generalize params;
- generalize_class_type cty
- | Tcty_signature {cty_self = sty; cty_vars = vars } ->
- Ctype.generalize sty;
- Vars.iter (fun _ (_, ty) -> Ctype.generalize ty) vars
- | Tcty_fun (_, ty, cty) ->
- Ctype.generalize ty;
- generalize_class_type cty
-
-(* Return the virtual methods of a class type *)
-let virtual_methods sign =
- let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sign.cty_self) in
- List.fold_left
- (fun virt (lab, _, _) ->
- if lab = dummy_method then virt else
- if Concr.mem lab sign.cty_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
- Tcty_constr (_, _, cty) ->
- constructor_type constr cty
- | Tcty_signature sign ->
- constr
- | Tcty_fun (l, ty, cty) ->
- Ctype.newty (Tarrow (l, ty, constructor_type constr cty, Cok))
-
-let rec class_body cty =
- match cty with
- Tcty_constr (_, _, cty') ->
- cty (* Only class bodies can be abbreviated *)
- | Tcty_signature sign ->
- cty
- | Tcty_fun (_, ty, cty) ->
- class_body cty
-
-let rec extract_constraints cty =
- let sign = Ctype.signature_of_class_type cty in
- (Vars.fold (fun lab _ vars -> lab :: vars) sign.cty_vars [],
- begin let (fields, _) =
- Ctype.flatten_fields (Ctype.object_fields sign.cty_self)
- in
- List.fold_left
- (fun meths (lab, _, _) ->
- if lab = dummy_method then meths else lab::meths)
- [] fields
- end,
- sign.cty_concr)
-
-let rec abbreviate_class_type path params cty =
- match cty with
- Tcty_constr (_, _, _) | Tcty_signature _ ->
- Tcty_constr (path, params, cty)
- | Tcty_fun (l, ty, cty) ->
- Tcty_fun (l, ty, abbreviate_class_type path params cty)
-
-let rec closed_class_type =
- function
- Tcty_constr (_, params, _) ->
- List.for_all Ctype.closed_schema params
- | Tcty_signature sign ->
- Ctype.closed_schema sign.cty_self
- &&
- Vars.fold (fun _ (_, ty) cc -> Ctype.closed_schema ty && cc)
- sign.cty_vars
- true
- | Tcty_fun (_, ty, cty) ->
- Ctype.closed_schema ty
- &&
- closed_class_type cty
-
-let closed_class cty =
- List.for_all Ctype.closed_schema cty.cty_params
- &&
- closed_class_type cty.cty_type
-
-let rec limited_generalize rv =
- function
- Tcty_constr (path, params, cty) ->
- List.iter (Ctype.limited_generalize rv) params;
- limited_generalize rv cty
- | Tcty_signature sign ->
- Ctype.limited_generalize rv sign.cty_self;
- Vars.iter (fun _ (_, ty) -> Ctype.limited_generalize rv ty)
- sign.cty_vars
- | Tcty_fun (_, ty, cty) ->
- Ctype.limited_generalize rv ty;
- limited_generalize rv cty
-
-(* Record a class type *)
-let rc node =
- Stypes.record (Stypes.Ti_class node);
- node
-
-
- (***********************************)
- (* Primitives for typing classes *)
- (***********************************)
-
-
-(* Enter a value in the method environment only *)
-let enter_met_env 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_env
- in
- (id, val_env,
- Env.add_value id {val_type = ty; val_kind = kind} met_env,
- Env.add_value id {val_type = ty; val_kind = Val_unbound} par_env)
-
-(* Enter an instance variable in the environment *)
-let enter_val cl_num vars lab mut ty val_env met_env par_env =
- let (id, val_env, met_env, par_env) as result =
- enter_met_env lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env
- in
- vars := Vars.add lab (id, mut, ty) !vars;
- result
-
-let inheritance self_type env concr_meths warn_meths loc parent =
- match scrape_class_type parent with
- Tcty_signature cl_sig ->
-
- (* Methods *)
- begin try
- Ctype.unify env self_type cl_sig.cty_self
- with Ctype.Unify trace ->
- match trace with
- _::_::_::({desc = Tfield(n, _, _, _)}, _)::rem ->
- raise(Error(loc, Method_type_mismatch (n, rem)))
- | _ ->
- assert false
- end;
-
- let overridings = Concr.inter cl_sig.cty_concr warn_meths in
- if not (Concr.is_empty overridings) then begin
- Location.prerr_warning loc
- (Warnings.Method_override (Concr.elements overridings))
- end;
-
- let concr_meths = Concr.union cl_sig.cty_concr concr_meths in
- let warn_meths = Concr.union cl_sig.cty_concr warn_meths in
-
- (cl_sig, concr_meths, warn_meths)
-
- | _ ->
- raise(Error(loc, 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 ty = transl_simple_type val_env false sty in
- try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
- raise(Error(loc, Method_type_mismatch (lab, trace)))
-
-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 ty =
- match sty.ptyp_desc with
- Ptyp_poly ([],sty) -> transl_simple_type_univars val_env sty
- | _ -> transl_simple_type val_env false sty
- in
- begin try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
- raise(Error(loc, Method_type_mismatch (lab, trace)))
- end
-
-let type_constraint val_env sty sty' loc =
- let ty = transl_simple_type val_env false sty in
- let ty' = transl_simple_type val_env false sty' in
- try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
- raise(Error(loc, Unconsistent_constraint trace))
-
-let mkpat d = { ppat_desc = d; ppat_loc = Location.none }
-let make_method cl_num expr =
- { pexp_desc =
- Pexp_function ("", None,
- [mkpat (Ppat_alias (mkpat(Ppat_var "self-*"),
- "self-" ^ cl_num)),
- expr]);
- pexp_loc = expr.pexp_loc }
-
-(*******************************)
-
-let rec class_type_field env self_type meths (val_sig, concr_meths) =
- function
- Pctf_inher sparent ->
- let parent = class_type env sparent in
- let (cl_sig, concr_meths, _) =
- inheritance self_type env concr_meths Concr.empty sparent.pcty_loc
- parent
- in
- let val_sig =
- Vars.fold
- (fun lab (mut, ty) val_sig -> Vars.add lab (mut, ty) val_sig)
- cl_sig.cty_vars val_sig
- in
- (val_sig, concr_meths)
-
- | Pctf_val (lab, mut, sty_opt, loc) ->
- let (mut, ty) =
- match sty_opt with
- None ->
- let (mut', ty) =
- try Vars.find lab val_sig with Not_found ->
- raise(Error(loc, Unbound_val lab))
- in
- (if mut = Mutable then mut' else Immutable), ty
- | Some sty ->
- mut, transl_simple_type env false sty
- in
- (Vars.add lab (mut, ty) val_sig, concr_meths)
-
- | Pctf_virt (lab, priv, sty, loc) ->
- declare_method env meths self_type lab priv sty loc;
- (val_sig, concr_meths)
-
- | Pctf_meth (lab, priv, sty, loc) ->
- declare_method env meths self_type lab priv sty loc;
- (val_sig, Concr.add lab concr_meths)
-
- | Pctf_cstr (sty, sty', loc) ->
- type_constraint env sty sty' loc;
- (val_sig, concr_meths)
-
-and class_signature env sty sign =
- let meths = ref Meths.empty in
- let self_type = transl_simple_type env false sty in
-
- (* Check that the binder is a correct type, and introduce a dummy
- method preventing self type from being closed. *)
- begin try
- Ctype.unify env
- (Ctype.filter_method env dummy_method Private self_type)
- (Ctype.newty (Ttuple []))
- with Ctype.Unify _ ->
- raise(Error(sty.ptyp_loc, Pattern_type_clash self_type))
- end;
-
- (* Class type fields *)
- let (val_sig, concr_meths) =
- List.fold_left (class_type_field env self_type meths)
- (Vars.empty, Concr.empty)
- sign
- in
-
- {cty_self = self_type;
- cty_vars = val_sig;
- cty_concr = concr_meths }
-
-and class_type env scty =
- match scty.pcty_desc with
- Pcty_constr (lid, styl) ->
- let (path, decl) =
- try Env.lookup_cltype lid env with Not_found ->
- raise(Error(scty.pcty_loc, Unbound_class_type lid))
- in
- if Path.same decl.clty_path unbound_class then
- raise(Error(scty.pcty_loc, Unbound_class_type_2 lid));
- let (params, clty) =
- Ctype.instance_class decl.clty_params decl.clty_type
- in
- let sty = Ctype.self_type clty in
- if List.length params <> List.length styl then
- raise(Error(scty.pcty_loc,
- Parameter_arity_mismatch (lid, List.length params,
- List.length styl)));
- List.iter2
- (fun sty ty ->
- let ty' = transl_simple_type env false sty in
- try Ctype.unify env ty' ty with Ctype.Unify trace ->
- raise(Error(sty.ptyp_loc, Parameter_mismatch trace)))
- styl params;
- Tcty_constr (path, params, clty)
-
- | Pcty_signature (sty, sign) ->
- Tcty_signature (class_signature env sty sign)
-
- | Pcty_fun (l, sty, scty) ->
- let ty = transl_simple_type env false sty in
- let cty = class_type env scty in
- Tcty_fun (l, ty, cty)
-
-(*******************************)
-
-module StringSet = Set.Make(struct type t = string let compare = compare end)
-
-let rec class_field cl_num self_type meths vars
- (val_env, met_env, par_env, fields, concr_meths, warn_meths, inh_vals) =
- function
- Pcf_inher (sparent, super) ->
- let parent = class_expr cl_num val_env par_env sparent in
- let (cl_sig, concr_meths, warn_meths) =
- inheritance self_type val_env concr_meths warn_meths sparent.pcl_loc
- parent.cl_type
- in
- (* Variables *)
- let (val_env, met_env, par_env, inh_vars, inh_vals) =
- Vars.fold
- (fun lab (mut, ty) (val_env, met_env, par_env, inh_vars, inh_vals) ->
- let (id, val_env, met_env, par_env) =
- enter_val cl_num vars lab mut ty val_env met_env par_env
- in
- if StringSet.mem lab inh_vals then
- Location.prerr_warning sparent.pcl_loc
- (Warnings.Hide_instance_variable lab);
- (val_env, met_env, par_env, (lab, id) :: inh_vars,
- StringSet.add lab inh_vals))
- cl_sig.cty_vars (val_env, met_env, par_env, [], inh_vals)
- in
- (* Inherited concrete methods *)
- let inh_meths =
- Concr.fold (fun lab rem -> (lab, Ident.create lab)::rem)
- cl_sig.cty_concr []
- in
- (* Super *)
- let (val_env, met_env, par_env) =
- match super with
- None ->
- (val_env, met_env, par_env)
- | Some name ->
- let (id, val_env, met_env, par_env) =
- enter_met_env name (Val_anc (inh_meths, cl_num)) self_type
- val_env met_env par_env
- in
- (val_env, met_env, par_env)
- in
- (val_env, met_env, par_env,
- lazy(Cf_inher (parent, inh_vars, inh_meths))::fields,
- concr_meths, warn_meths, inh_vals)
-
- | Pcf_val (lab, mut, sexp, loc) ->
- if StringSet.mem lab inh_vals then
- Location.prerr_warning loc (Warnings.Hide_instance_variable lab);
- if !Clflags.principal then Ctype.begin_def ();
- let exp =
- try type_exp val_env sexp with Ctype.Unify [(ty, _)] ->
- raise(Error(loc, 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 lab mut exp.exp_type val_env met_env par_env
- in
- (val_env, met_env, par_env, lazy(Cf_val (lab, id, exp)) :: fields,
- concr_meths, warn_meths, inh_vals)
-
- | Pcf_virt (lab, priv, sty, loc) ->
- virtual_method val_env meths self_type lab priv sty loc;
- let warn_meths = Concr.remove lab warn_meths in
- (val_env, met_env, par_env, fields, concr_meths, warn_meths, inh_vals)
-
- | Pcf_meth (lab, priv, expr, loc) ->
- let (_, ty) =
- Ctype.filter_self_method val_env lab priv meths self_type
- in
- begin try match expr.pexp_desc with
- Pexp_poly (sbody, sty) ->
- begin match sty with None -> ()
- | Some sty ->
- Ctype.unify val_env
- (Typetexp.transl_simple_type val_env false sty) 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, Method_type_mismatch (lab, trace)))
- end;
- let meth_expr = make_method cl_num expr in
- (* backup variables for Pexp_override *)
- let vars_local = !vars in
-
- let field =
- lazy begin
- let meth_type =
- Ctype.newty (Tarrow("", self_type, Ctype.instance ty, Cok)) in
- Ctype.raise_nongen_level ();
- vars := vars_local;
- let texp = type_expect met_env meth_expr meth_type in
- Ctype.end_def ();
- Cf_meth (lab, texp)
- end in
- (val_env, met_env, par_env, field::fields,
- Concr.add lab concr_meths, Concr.add lab warn_meths, inh_vals)
-
- | Pcf_cstr (sty, sty', loc) ->
- type_constraint val_env sty sty' loc;
- (val_env, met_env, par_env, fields, concr_meths, warn_meths, inh_vals)
-
- | Pcf_let (rec_flag, sdefs, loc) ->
- let (defs, val_env) =
- try
- Typecore.type_let val_env rec_flag sdefs
- with Ctype.Unify [(ty, _)] ->
- raise(Error(loc, Make_nongen_seltype ty))
- in
- let (vals, met_env, par_env) =
- List.fold_right
- (fun id (vals, met_env, par_env) ->
- let expr =
- Typecore.type_exp val_env
- {pexp_desc = Pexp_ident (Longident.Lident (Ident.name id));
- pexp_loc = Location.none}
- in
- let desc =
- {val_type = expr.exp_type;
- val_kind = Val_ivar (Immutable, cl_num)}
- in
- let id' = Ident.create (Ident.name id) in
- ((id', expr)
- :: vals,
- Env.add_value id' desc met_env,
- Env.add_value id' desc par_env))
- (let_bound_idents defs)
- ([], met_env, par_env)
- in
- (val_env, met_env, par_env, lazy(Cf_let(rec_flag, defs, vals))::fields,
- concr_meths, warn_meths, inh_vals)
-
- | Pcf_init expr ->
- let expr = make_method cl_num expr in
- let vars_local = !vars in
- let field =
- lazy begin
- Ctype.raise_nongen_level ();
- let meth_type =
- Ctype.newty
- (Tarrow ("", self_type, Ctype.instance Predef.type_unit, Cok)) in
- vars := vars_local;
- let texp = type_expect met_env expr meth_type in
- Ctype.end_def ();
- Cf_init texp
- end in
- (val_env, met_env, par_env, field::fields,
- concr_meths, warn_meths, inh_vals)
-
-and class_structure cl_num final val_env met_env loc (spat, str) =
- (* Environment for substructures *)
- let par_env = met_env in
-
- (* Private self type more method access, 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 []));
-
- (* Self binder *)
- let (pat, meths, vars, val_env, meth_env, par_env) =
- type_self_pattern cl_num self_type 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, 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) ->
- try Ctype.unify val_env ty
- (Ctype.filter_method val_env lab Public self_type)
- with _ -> assert false)
- (get_methods public_self)
- end;
-
- (* Typing of class fields *)
- let (_, _, _, fields, concr_meths, _, _) =
- List.fold_left (class_field cl_num self_type meths vars)
- (val_env, meth_env, par_env, [], Concr.empty, Concr.empty,
- StringSet.empty)
- str
- in
- Ctype.unify val_env self_type (Ctype.newvar ());
- let sign =
- {cty_self = public_self;
- cty_vars = Vars.map (function (id, mut, ty) -> (mut, ty)) !vars;
- cty_concr = concr_meths } 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 public_self and a copy of self_type. self_type will not
- be modified after this point *)
- Ctype.close_object self_type;
- let mets = virtual_methods {sign with cty_self = self_type} in
- if mets <> [] then raise(Error(loc, Virtual_class(true, mets)));
- let self_methods =
- List.fold_right
- (fun (lab,kind,ty) rem ->
- if lab = dummy_method then rem else
- Ctype.newty(Tfield(lab, Btype.copy_kind kind, ty, rem)))
- methods (Ctype.newty Tnil) in
- begin try Ctype.unify val_env public_self
- (Ctype.newty (Tobject(self_methods, ref None)))
- with Ctype.Unify trace -> raise(Error(loc, Final_self_clash trace))
- end;
- end;
-
- (* Typing of method bodies *)
- if !Clflags.principal then
- List.iter (fun (_,_,ty) -> Ctype.generalize_spine ty) methods;
- let fields = List.map Lazy.force (List.rev fields) in
- if !Clflags.principal then
- List.iter (fun (_,_,ty) -> Ctype.unify val_env ty (Ctype.newvar ()))
- methods;
- let meths = Meths.map (function (id, ty) -> id) !meths in
-
- (* Check for private methods made public *)
- let pub_meths' =
- List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind = Fpresent)
- (get_methods public_self) in
- let names = List.map (fun (x,_,_) -> x) in
- let l1 = names priv_meths and l2 = names pub_meths' in
- let added = List.filter (fun x -> List.mem x l1) l2 in
- if added <> [] then
- Location.prerr_warning loc
- (Warnings.Other
- (String.concat " "
- ("the following private methods were made public implicitly:\n "
- :: added)));
-
- {cl_field = fields; cl_meths = meths}, sign
-
-and class_expr cl_num val_env met_env scl =
- match scl.pcl_desc with
- Pcl_constr (lid, styl) ->
- let (path, decl) =
- try Env.lookup_class lid val_env with Not_found ->
- raise(Error(scl.pcl_loc, Unbound_class lid))
- in
- if Path.same decl.cty_path unbound_class then
- raise(Error(scl.pcl_loc, Unbound_class_2 lid));
- let tyl = List.map
- (fun sty -> transl_simple_type val_env false sty, sty.ptyp_loc)
- 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,
- Parameter_arity_mismatch (lid, List.length params,
- List.length tyl)));
- List.iter2
- (fun (ty',loc) ty ->
- try Ctype.unify val_env ty' ty with Ctype.Unify trace ->
- raise(Error(loc, Parameter_mismatch trace)))
- tyl params;
- let cl =
- rc {cl_desc = Tclass_ident path;
- cl_loc = scl.pcl_loc;
- cl_type = clty';
- cl_env = val_env}
- in
- let (vals, meths, concrs) = extract_constraints clty in
- rc {cl_desc = Tclass_constraint (cl, vals, meths, concrs);
- cl_loc = scl.pcl_loc;
- cl_type = clty';
- cl_env = val_env}
- | 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 = Tclass_structure desc;
- cl_loc = scl.pcl_loc;
- cl_type = Tcty_signature ty;
- cl_env = val_env}
- | Pcl_fun (l, Some default, spat, sbody) ->
- let loc = default.pexp_loc in
- let scases =
- [{ppat_loc = loc; ppat_desc =
- Ppat_construct(Longident.Lident"Some",
- Some{ppat_loc = loc; ppat_desc = Ppat_var"*sth*"},
- false)},
- {pexp_loc = loc; pexp_desc = Pexp_ident(Longident.Lident"*sth*")};
- {ppat_loc = loc; ppat_desc =
- Ppat_construct(Longident.Lident"None", None, false)},
- default] in
- let smatch =
- {pexp_loc = loc; pexp_desc =
- Pexp_match({pexp_loc = loc; pexp_desc =
- Pexp_ident(Longident.Lident"*opt*")},
- scases)} in
- let sfun =
- {pcl_loc = scl.pcl_loc; pcl_desc =
- Pcl_fun(l, None, {ppat_loc = loc; ppat_desc = Ppat_var"*opt*"},
- {pcl_loc = scl.pcl_loc; pcl_desc =
- Pcl_let(Default, [spat, smatch], sbody)})}
- 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
- (function (id, id', ty) ->
- (id,
- Typecore.type_exp val_env
- {pexp_desc = Pexp_ident (Longident.Lident (Ident.name id));
- pexp_loc = Location.none}))
- pv
- in
- let rec all_labeled = function
- Tcty_fun ("", _, _) -> false
- | Tcty_fun (l, _, ty_fun) -> l.[0] <> '?' && all_labeled ty_fun
- | _ -> true
- in
- let partial =
- Parmatch.check_partial pat.pat_loc
- [pat, (* Dummy expression *)
- {exp_desc = Texp_constant (Asttypes.Const_int 1);
- exp_loc = Location.none;
- exp_type = Ctype.none;
- exp_env = Env.empty }] 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 && all_labeled cl.cl_type then
- Location.prerr_warning pat.pat_loc
- (Warnings.Other "This optional argument cannot be erased");
- rc {cl_desc = Tclass_fun (pat, pv, cl, partial);
- cl_loc = scl.pcl_loc;
- cl_type = Tcty_fun (l, Ctype.instance pat.pat_type, cl.cl_type);
- cl_env = val_env}
- | Pcl_apply (scl', sargs) ->
- let cl = class_expr cl_num val_env met_env scl' in
- let rec nonopt_labels ls ty_fun =
- match ty_fun with
- | Tcty_fun (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 = "") sargs &&
- List.exists (fun l -> l <> "") labels &&
- begin
- Location.prerr_warning cl.cl_loc Warnings.Labels_omitted;
- true
- end
- in
- let rec type_args args omitted ty_fun sargs more_sargs =
- match ty_fun with
- | Tcty_fun (l, ty, ty_fun) when sargs <> [] || more_sargs <> [] ->
- let name = Btype.label_name l
- and optional =
- if Btype.is_optional l then Optional else Required 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, Apply_wrong_label(l')))
- | _, (l', sarg0)::more_sargs ->
- if l <> l' && l' <> "" then
- raise(Error(sarg0.pexp_loc, Apply_wrong_label l'))
- else ([], more_sargs, Some(type_argument val_env sarg0 ty))
- | _ ->
- 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
- sargs, more_sargs,
- if Btype.is_optional l' || not (Btype.is_optional l) then
- Some (type_argument val_env sarg0 ty)
- else
- let arg = type_argument val_env
- sarg0 (extract_option_type val_env ty) in
- Some (option_some arg)
- with Not_found ->
- sargs, more_sargs,
- if Btype.is_optional l &&
- (List.mem_assoc "" sargs || List.mem_assoc "" more_sargs)
- then
- Some (option_none ty Location.none)
- else None
- in
- let omitted = if arg = None then (l,ty) :: omitted else omitted in
- type_args ((arg,optional)::args) omitted ty_fun sargs more_sargs
- | _ ->
- match sargs @ more_sargs with
- (l, sarg0)::_ ->
- if omitted <> [] then
- raise(Error(sarg0.pexp_loc, Apply_wrong_label l))
- else
- raise(Error(cl.cl_loc, Cannot_apply cl.cl_type))
- | [] ->
- (List.rev args,
- List.fold_left
- (fun ty_fun (l,ty) -> Tcty_fun(l,ty,ty_fun))
- ty_fun omitted)
- in
- let (args, cty) =
- if ignore_labels then
- type_args [] [] cl.cl_type [] sargs
- else
- type_args [] [] cl.cl_type sargs []
- in
- rc {cl_desc = Tclass_apply (cl, args);
- cl_loc = scl.pcl_loc;
- cl_type = cty;
- cl_env = val_env}
- | Pcl_let (rec_flag, sdefs, scl') ->
- let (defs, val_env) =
- try
- Typecore.type_let val_env rec_flag sdefs
- with Ctype.Unify [(ty, _)] ->
- raise(Error(scl.pcl_loc, Make_nongen_seltype ty))
- in
- let (vals, met_env) =
- List.fold_right
- (fun id (vals, met_env) ->
- Ctype.begin_def ();
- let expr =
- Typecore.type_exp val_env
- {pexp_desc = Pexp_ident (Longident.Lident (Ident.name id));
- pexp_loc = Location.none}
- in
- Ctype.end_def ();
- Ctype.generalize expr.exp_type;
- let desc =
- {val_type = expr.exp_type; val_kind = Val_ivar (Immutable,
- cl_num)}
- in
- let id' = Ident.create (Ident.name id) in
- ((id', expr)
- :: vals,
- Env.add_value id' desc met_env))
- (let_bound_idents defs)
- ([], met_env)
- in
- let cl = class_expr cl_num val_env met_env scl' in
- rc {cl_desc = Tclass_let (rec_flag, defs, vals, cl);
- cl_loc = scl.pcl_loc;
- cl_type = cl.cl_type;
- cl_env = val_env}
- | 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)) clty;
-
- begin match Includeclass.class_types val_env cl.cl_type clty with
- [] -> ()
- | error -> raise(Error(cl.cl_loc, Class_match_failure error))
- end;
- let (vals, meths, concrs) = extract_constraints clty in
- rc {cl_desc = Tclass_constraint (cl, vals, meths, concrs);
- cl_loc = scl.pcl_loc;
- cl_type = snd (Ctype.instance_class [] clty);
- cl_env = val_env}
-
-(*******************************)
-
-(* 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 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_fun (l, _, ct) ->
- let arg =
- if Btype.is_optional l then Ctype.instance var_option
- else Ctype.newvar () in
- Ctype.newty (Tarrow (l, arg, approx_description ct, Cok))
- | _ -> Ctype.newvar ()
-
-(*******************************)
-
-let temp_abbrev 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 id
- {type_params = !params;
- type_arity = arity;
- type_kind = Type_abstract;
- type_manifest = Some ty;
- type_variance = List.map (fun _ -> true, true, true) !params}
- env
- in
- (!params, ty, env)
-
-let rec initial_env define_class approx
- (res, env) (cl, id, ty_id, obj_id, cl_id) =
- (* Temporary abbreviations *)
- let arity = List.length (fst cl.pci_params) in
- let (obj_params, obj_ty, env) = temp_abbrev env obj_id arity in
- let (cl_params, cl_ty, env) = temp_abbrev 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 =
- Tcty_signature
- { cty_self = Ctype.newvar ();
- cty_vars = Vars.empty;
- cty_concr = Concr.empty }
- in
- let dummy_class =
- {cty_params = []; (* Dummy value *)
- cty_type = dummy_cty; (* Dummy value *)
- cty_path = unbound_class;
- cty_new =
- match cl.pci_virt with
- Virtual -> None
- | Concrete -> Some constr_type}
- in
- let env =
- Env.add_cltype ty_id
- {clty_params = []; (* Dummy value *)
- clty_type = dummy_cty; (* Dummy value *)
- clty_path = unbound_class} (
- 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 params =
- try
- let params, loc = cl.pci_params in
- List.map (enter_type_variable true loc) params
- with Already_bound ->
- raise(Error(snd cl.pci_params, Repeated_parameter))
- 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
-
- (* 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,
- 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,
- 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,
- 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, 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 constr_type)
- with Ctype.Unify trace ->
- raise(Error(cl.pci_loc,
- Constructor_type_mismatch (cl.pci_name, trace)))
- end;
-
- (* Class and class type temporary definitions *)
- let cltydef =
- {clty_params = params; clty_type = class_body typ;
- clty_path = Path.Pident obj_id}
- and clty =
- {cty_params = params; cty_type = typ;
- cty_path = Path.Pident obj_id;
- cty_new =
- match cl.pci_virt with
- Virtual -> None
- | Concrete -> Some constr_type}
- 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
- match virtual_methods (Ctype.signature_of_class_type typ) with
- [] -> ()
- | mets -> raise(Error(cl.pci_loc, Virtual_class(define_class, mets)))
- 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_path = Path.Pident obj_id}
- and clty =
- {cty_params = params'; cty_type = typ';
- cty_path = Path.Pident obj_id;
- cty_new =
- match cl.pci_virt with
- Virtual -> None
- | Concrete -> Some (Ctype.instance constr_type)}
- in
- let obj_abbr =
- {type_params = obj_params;
- type_arity = List.length obj_params;
- type_kind = Type_abstract;
- type_manifest = Some obj_ty;
- type_variance = List.map (fun _ -> true, true, true) obj_params}
- 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_manifest = Some cl_ty;
- type_variance = List.map (fun _ -> true, true, true) cl_params}
- in
- ((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
- 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,
- arity, pub_meths, coe, expr) =
-
- begin try Ctype.collapse_conj_params env clty.cty_params
- with Ctype.Unify trace ->
- raise(Error(cl.pci_loc, Non_collapsable_conjunction (id, clty, trace)))
- end;
-
- List.iter Ctype.generalize clty.cty_params;
- generalize_class_type clty.cty_type;
- begin match clty.cty_new with
- None -> ()
- | Some ty -> Ctype.generalize ty
- end;
- List.iter Ctype.generalize obj_abbr.type_params;
- begin match obj_abbr.type_manifest with
- None -> ()
- | Some ty -> Ctype.generalize ty
- end;
- List.iter Ctype.generalize cl_abbr.type_params;
- begin match cl_abbr.type_manifest with
- None -> ()
- | Some ty -> Ctype.generalize ty
- end;
-
- if not (closed_class clty) then
- raise(Error(cl.pci_loc, 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, Unbound_type_var(printer, reason)))
- end;
-
- (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
- arity, pub_meths, coe, expr, (cl.pci_variance, cl.pci_loc))
-
-let extract_type_decls
- (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
- arity, pub_meths, coe, expr, required) decls =
- ((obj_id, obj_abbr), required) :: ((cl_id, cl_abbr), required) :: decls
-
-let rec compact = function
- [] -> []
- | a :: b :: l -> (a,b) :: compact l
- | _ -> fatal_error "Typeclass.compact"
-
-let merge_type_decls
- (id, clty, ty_id, cltydef, _obj_id, _obj_abbr, _cl_id, _cl_abbr,
- arity, pub_meths, coe, expr, req) ((obj_id, obj_abbr), (cl_id, cl_abbr)) =
- (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
- arity, pub_meths, coe, expr)
-
-let final_env define_class env
- (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
- arity, pub_meths, coe, expr) =
- (* Add definitions after cleaning them *)
- Env.add_type obj_id (Subst.type_declaration Subst.identity obj_abbr) (
- Env.add_type cl_id (Subst.type_declaration Subst.identity cl_abbr) (
- Env.add_cltype ty_id (Subst.cltype_declaration Subst.identity cltydef) (
- if define_class then
- Env.add_class id (Subst.class_declaration Subst.identity clty) env
- else env)))
-
-(* Check that #c is coercible to c if there is a self-coercion *)
-let check_coercions env
- (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
- arity, pub_meths, coercion_locs, expr) =
- 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, Typecore.Not_subtype(tr1, tr2)))
- end;
- if not (Ctype.opened_object cl_ty) then
- raise(Error(loc, Cannot_coerce_self obj_ty))
- end;
- (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
- arity, pub_meths, expr)
-
-(*******************************)
-
-let type_classes define_class approx kind env cls =
- let cls =
- List.map
- (function cl ->
- (cl,
- Ident.create cl.pci_name, Ident.create cl.pci_name,
- Ident.create cl.pci_name, Ident.create ("#" ^ cl.pci_name)))
- 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 (compact 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)
-
-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 (decl, env) =
- type_classes false approx_description class_description env cls
- in
- (List.map
- (function
- (_, _, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, _, _, _) ->
- (ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr))
- decl,
- env)
-
-let rec unify_parents env ty cl =
- match cl.cl_desc with
- Tclass_ident p ->
- begin try
- let decl = Env.find_class p env in
- let _, body = Ctype.find_cltype_for_path env decl.cty_path in
- Ctype.unify env ty (Ctype.instance body)
- with exn -> assert (exn = Not_found)
- end
- | Tclass_structure st -> unify_parents_struct env ty st
- | Tclass_fun (_, _, cl, _)
- | Tclass_apply (cl, _)
- | Tclass_let (_, _, _, cl)
- | Tclass_constraint (cl, _, _, _) -> unify_parents env ty cl
-and unify_parents_struct env ty st =
- List.iter
- (function Cf_inher (cl, _, _) -> unify_parents env ty cl
- | _ -> ())
- st.cl_field
-
-let type_object env loc s =
- incr class_num;
- let (desc, sign) =
- class_structure (string_of_int !class_num) true env env loc s in
- let sty = Ctype.expand_head env sign.cty_self in
- Ctype.hide_private_methods sty;
- let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in
- let meths = List.map (fun (s,_,_) -> s) fields in
- unify_parents_struct env sign.cty_self desc;
- (desc, sign, meths)
-
-let () =
- Typecore.type_object := type_object
-
-(*******************************)
-
-(* Approximate the class declaration as class ['params] id = object end *)
-let approx_class sdecl =
- let self' =
- { ptyp_desc = Ptyp_any; ptyp_loc = Location.none } in
- let clty' =
- { pcty_desc = Pcty_signature(self', []);
- pcty_loc = sdecl.pci_expr.pcty_loc } 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 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 trace
- (fun ppf -> fprintf ppf "Type")
- (fun ppf -> fprintf ppf "is not compatible with type")
- | Method_type_mismatch (m, trace) ->
- Printtyp.report_unification_error ppf trace
- (function ppf ->
- fprintf ppf "The method %s@ has type" 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 clty ->
- fprintf ppf
- "This class expression is not a class function, it cannot be applied"
- | Apply_wrong_label l ->
- let mark_label = function
- | "" -> "out label"
- | l -> sprintf " label ~%s" 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 *)
- fprintf ppf "@[This pattern cannot match self: \
- it only matches values of type@ %a@]"
- Printtyp.type_expr ty
- | Unbound_class cl ->
- fprintf ppf "Unbound class@ %a"
- Printtyp.longident cl
- | Unbound_class_2 cl ->
- fprintf ppf "The class@ %a@ is not yet completely defined"
- Printtyp.longident cl
- | Unbound_class_type cl ->
- fprintf ppf "Unbound class type@ %a"
- 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 ? *)
- 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 trace
- (function ppf ->
- fprintf ppf "The expression \"new %s\" has type" c)
- (function ppf ->
- fprintf ppf "but is used with type")
- | Virtual_class (cl, mets) ->
- let print_mets ppf mets =
- List.iter (function met -> fprintf ppf "@ %s" met) mets in
- let cl_mark = if cl then "" else " type" in
- fprintf ppf
- "@[This class%s should be virtual@ \
- @[<2>The following methods are undefined :%a@]
- @]"
- cl_mark print_mets mets
- | 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 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@ \
- wich 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
- Printtyp.reset_and_mark_loops_list [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
- "@[<v>@[Some type variables are unbound in this type:@;<1 2>%t@]@ \
- @[%a@]@]"
- printer print_reason reason
- | Make_nongen_seltype ty ->
- fprintf ppf
- "@[<v>@[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 occurences are contravariant@]"
- Printtyp.type_scheme ty
- | Non_collapsable_conjunction (id, clty, trace) ->
- fprintf ppf
- "@[The type of this class,@ %a,@ \
- contains non-collapsable conjunctive types in constraints@]"
- (Printtyp.class_declaration id) clty;
- Printtyp.report_unification_error ppf trace
- (fun ppf -> fprintf ppf "Type")
- (fun ppf -> fprintf ppf "is not compatible with type")
- | Final_self_clash trace ->
- Printtyp.report_unification_error ppf trace
- (function ppf ->
- fprintf ppf "This object is expected to have type")
- (function ppf ->
- fprintf ppf "but has actually type")
diff --git a/typing/typeclass.mli b/typing/typeclass.mli
deleted file mode 100644
index ae7d4325ea..0000000000
--- a/typing/typeclass.mli
+++ /dev/null
@@ -1,78 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Asttypes
-open Types
-open Typedtree
-open Format
-
-val class_declarations:
- Env.t -> Parsetree.class_declaration list ->
- (Ident.t * class_declaration *
- Ident.t * cltype_declaration *
- Ident.t * type_declaration *
- Ident.t * type_declaration *
- int * string list * class_expr) list * Env.t
-
-val class_descriptions:
- Env.t -> Parsetree.class_description list ->
- (Ident.t * class_declaration *
- Ident.t * cltype_declaration *
- Ident.t * type_declaration *
- Ident.t * type_declaration *
- int * string list * class_type) list * Env.t
-
-val class_type_declarations:
- Env.t -> Parsetree.class_description list ->
- (Ident.t * cltype_declaration *
- Ident.t * type_declaration *
- Ident.t * type_declaration) list * Env.t
-
-val approx_class_declarations:
- Env.t -> Parsetree.class_description list ->
- (Ident.t * cltype_declaration *
- Ident.t * type_declaration *
- Ident.t * type_declaration) list
-
-type error =
- Unconsistent_constraint of (type_expr * type_expr) list
- | Method_type_mismatch of string * (type_expr * type_expr) list
- | Structure_expected of class_type
- | Cannot_apply of class_type
- | Apply_wrong_label of label
- | Pattern_type_clash of type_expr
- | Repeated_parameter
- | Unbound_class of Longident.t
- | Unbound_class_2 of Longident.t
- | Unbound_class_type 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 * 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
-
-exception Error of Location.t * error
-
-val report_error : formatter -> error -> unit
diff --git a/typing/typecore.ml b/typing/typecore.ml
deleted file mode 100644
index a793793f06..0000000000
--- a/typing/typecore.ml
+++ /dev/null
@@ -1,2028 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Typechecking for the core language *)
-
-open Misc
-open Asttypes
-open Parsetree
-open Types
-open Typedtree
-open Btype
-open Ctype
-
-type error =
- Unbound_value of Longident.t
- | Unbound_constructor of Longident.t
- | Unbound_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
- | Multiply_bound_variable
- | Orpat_vars of Ident.t
- | Expr_type_clash of (type_expr * type_expr) list
- | Apply_non_function of type_expr
- | Apply_wrong_label of label * type_expr
- | Label_multiply_defined of Longident.t
- | Label_missing of string list
- | Label_not_mutable of Longident.t
- | Bad_format of string
- | Undefined_method of type_expr * string
- | Undefined_inherited_method of string
- | Unbound_class of Longident.t
- | Virtual_class of Longident.t
- | Private_type of type_expr
- | Private_label of Longident.t * type_expr
- | Unbound_instance_variable of string
- | Instance_variable_not_mutable of 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 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
-
-exception Error of Location.t * 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 Typeclass.class_structure *)
-let type_object =
- ref (fun env s -> assert false :
- Env.t -> Location.t -> Parsetree.class_structure ->
- class_structure * class_signature * string list)
-
-(*
- Saving and outputting type information.
- 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 =
- Stypes.record (Stypes.Ti_expr node);
- node
-;;
-let rp node =
- Stypes.record (Stypes.Ti_pat node);
- node
-;;
-
-
-(* Typing of constants *)
-
-let type_constant = function
- Const_int _ -> instance Predef.type_int
- | Const_char _ -> instance Predef.type_char
- | Const_string _ -> instance Predef.type_string
- | Const_float _ -> instance Predef.type_float
- | Const_int32 _ -> instance Predef.type_int32
- | Const_int64 _ -> instance Predef.type_int64
- | Const_nativeint _ -> instance Predef.type_nativeint
-
-(* Specific version of type_option, using newty rather than newgenty *)
-
-let type_option ty =
- newty (Tconstr(Predef.path_option,[ty], ref Mnil))
-
-let option_none ty loc =
- let cnone = Env.lookup_constructor (Longident.Lident "None") Env.initial in
- { exp_desc = Texp_construct(cnone, []);
- exp_type = ty; exp_loc = loc; exp_env = Env.initial }
-
-let option_some texp =
- let csome = Env.lookup_constructor (Longident.Lident "Some") Env.initial in
- { exp_desc = Texp_construct(csome, [texp]); exp_loc = texp.exp_loc;
- exp_type = type_option texp.exp_type; exp_env = 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 rec extract_label_names sexp env ty =
- let ty = repr ty in
- match ty.desc with
- | Tconstr (path, _, _) ->
- let td = Env.find_type path env in
- begin match td.type_kind with
- | Type_record (fields, _, _) ->
- List.map (fun (name, _, _) -> name) fields
- | Type_abstract when td.type_manifest <> None ->
- extract_label_names sexp env (expand_head env ty)
- | _ -> assert false
- end
- | _ ->
- assert false
-
-(* Typing of patterns *)
-
-(* Creating new conjunctive types is not allowed when typing patterns *)
-let unify_pat env pat expected_ty =
- try
- unify env pat.pat_type expected_ty
- with
- Unify trace ->
- raise(Error(pat.pat_loc, Pattern_type_clash(trace)))
- | Tags(l1,l2) ->
- raise(Typetexp.Error(pat.pat_loc, Typetexp.Variant_tags (l1, l2)))
-
-(* make all Reither present in open variants *)
-let finalize_variant pat =
- match pat.pat_desc with
- Tpat_variant(tag, opat, row) ->
- let row = row_repr row in
- let field =
- try row_field_repr (List.assoc tag row.row_fields)
- with Not_found -> Rabsent
- in
- begin match field 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.row_fixed ->
- set_row_field e (Reither (c, [], false, ref None))
- | _ -> ()
- end;
- (* Force check of well-formedness *)
- 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) list)
-let pattern_force = ref ([] : (unit -> unit) list)
-let reset_pattern () =
- pattern_variables := [];
- pattern_force := []
-
-let enter_variable loc name ty =
- if List.exists (fun (id, _) -> Ident.name id = name) !pattern_variables
- then raise(Error(loc, Multiply_bound_variable));
- let id = Ident.create name in
- pattern_variables := (id, ty) :: !pattern_variables;
- 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 = match p1_vs, p2_vs with
- | (x1,t1)::rem1, (x2,t2)::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, Pattern_type_clash(trace)))
- end ;
- (x2,x1)::unify_vars rem1 rem2
- end
- | [],[] -> []
- | (x,_)::_, [] -> raise (Error (loc, Orpat_vars x))
- | [],(x,_)::_ -> raise (Error (loc, Orpat_vars x))
- | (x,_)::_, (y,_)::_ ->
- let min_var =
- if Ident.name x < Ident.name y then x
- else y in
- raise (Error (loc, Orpat_vars min_var)) 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 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 = fst(List.hd lpl) in
- let ty = newvar () in
- let ppl = List.map (fun (l,p) -> l.lbl_pos, p) lpl in
- let do_label lbl =
- let _, ty_arg, ty_res = instance_label false lbl in
- unify_pat env {p with pat_type = ty} ty_res;
- if lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_pos ppl then begin
- let arg = List.assoc lbl.lbl_pos ppl in
- unify_pat env {arg with pat_type = build_as_type env arg} ty_arg
- end else begin
- let _, ty_arg', ty_res' = instance_label false lbl in
- 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, path) ->
- let ty1 = build_as_type env p1 and ty2 = build_as_type env p2 in
- unify_pat env {p2 with pat_type = ty2} ty1;
- begin match path with None -> ()
- | Some path ->
- let td = try Env.find_type path env with Not_found -> assert false in
- let params = List.map (fun _ -> newvar()) td.type_params in
- match expand_head env (newty (Tconstr (path, params, ref Mnil)))
- with {desc=Tvariant row} when static_row row ->
- unify_pat env {p1 with pat_type = ty1}
- (newty (Tvariant{row with row_closed=false; row_more=newvar()}))
- | _ -> ()
- end;
- ty1
- | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_array _ -> p.pat_type
-
-let build_or_pat env loc lid =
- let path, decl =
- try Env.lookup_type lid env
- with Not_found ->
- raise(Typetexp.Error(loc, Typetexp.Unbound_type_constructor lid))
- in
- let tyl = List.map (fun _ -> newvar()) decl.type_params in
- let fields =
- let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in
- match ty.desc with
- Tvariant row when static_row row ->
- (row_repr row).row_fields
- | _ -> raise(Error(loc, Not_a_variant_type lid))
- in
- let bound = ref [] 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) ->
- bound := ty :: !bound;
- (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env;
- pat_type=ty})
- :: pats,
- (l, Reither(false, [ty], true, ref None)) :: fields
- | _ -> pats, fields)
- ([],[]) fields in
- let row =
- { row_fields = List.rev fields; row_more = newvar(); row_bound = !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 pats =
- List.map (fun (l,p) -> {pat_desc=Tpat_variant(l,p,row); pat_loc=gloc;
- pat_env=env; pat_type=ty})
- pats
- in
- match pats with
- [] -> raise(Error(loc, Not_a_variant_type lid))
- | pat :: pats ->
- let r =
- List.fold_left
- (fun pat pat0 -> {pat_desc=Tpat_or(pat0,pat,Some path);
- pat_loc=gloc; pat_env=env; pat_type=ty})
- pat pats in
- rp { r with pat_loc = loc }
-
-let rec type_pat env sp =
- match sp.ppat_desc with
- Ppat_any ->
- rp {
- pat_desc = Tpat_any;
- pat_loc = sp.ppat_loc;
- pat_type = newvar();
- pat_env = env }
- | Ppat_var name ->
- let ty = newvar() in
- let id = enter_variable sp.ppat_loc name ty in
- rp {
- pat_desc = Tpat_var id;
- pat_loc = sp.ppat_loc;
- pat_type = ty;
- pat_env = env }
- | Ppat_alias(sq, name) ->
- let q = type_pat env sq in
- begin_def ();
- let ty_var = build_as_type env q in
- end_def ();
- generalize ty_var;
- let id = enter_variable sp.ppat_loc name ty_var in
- rp {
- pat_desc = Tpat_alias(q, id);
- pat_loc = sp.ppat_loc;
- pat_type = q.pat_type;
- pat_env = env }
- | Ppat_constant cst ->
- rp {
- pat_desc = Tpat_constant cst;
- pat_loc = sp.ppat_loc;
- pat_type = type_constant cst;
- pat_env = env }
- | Ppat_tuple spl ->
- let pl = List.map (type_pat env) spl in
- rp {
- pat_desc = Tpat_tuple pl;
- pat_loc = sp.ppat_loc;
- pat_type = newty (Ttuple(List.map (fun p -> p.pat_type) pl));
- pat_env = env }
- | Ppat_construct(lid, sarg, explicit_arity) ->
- let constr =
- try
- Env.lookup_constructor lid env
- with Not_found ->
- raise(Error(sp.ppat_loc, Unbound_constructor lid)) in
- let sargs =
- match sarg with
- None -> []
- | Some {ppat_desc = Ppat_tuple spl} when explicit_arity -> spl
- | Some {ppat_desc = Ppat_tuple spl} when constr.cstr_arity > 1 -> spl
- | Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity > 1 ->
- replicate_list sp constr.cstr_arity
- | Some sp -> [sp] in
- if List.length sargs <> constr.cstr_arity then
- raise(Error(sp.ppat_loc, Constructor_arity_mismatch(lid,
- constr.cstr_arity, List.length sargs)));
- let args = List.map (type_pat env) sargs in
- let (ty_args, ty_res) = instance_constructor constr in
- List.iter2 (unify_pat env) args ty_args;
- rp {
- pat_desc = Tpat_construct(constr, args);
- pat_loc = sp.ppat_loc;
- pat_type = ty_res;
- pat_env = env }
- | Ppat_variant(l, sarg) ->
- let arg = may_map (type_pat env) sarg in
- let arg_type = match arg with None -> [] | Some arg -> [arg.pat_type] in
- let row = { row_fields =
- [l, Reither(arg = None, arg_type, true, ref None)];
- row_bound = arg_type;
- row_closed = false;
- row_more = newvar ();
- row_fixed = false;
- row_name = None } in
- rp {
- pat_desc = Tpat_variant(l, arg, row);
- pat_loc = sp.ppat_loc;
- pat_type = newty (Tvariant row);
- pat_env = env }
- | Ppat_record lid_sp_list ->
- let rec check_duplicates = function
- [] -> ()
- | (lid, sarg) :: remainder ->
- if List.mem_assoc lid remainder
- then raise(Error(sp.ppat_loc, Label_multiply_defined lid))
- else check_duplicates remainder in
- check_duplicates lid_sp_list;
- let ty = newvar() in
- let type_label_pat (lid, sarg) =
- let label =
- try
- Env.lookup_label lid env
- with Not_found ->
- raise(Error(sp.ppat_loc, Unbound_label lid)) in
- let (_, ty_arg, ty_res) = instance_label false label in
- begin try
- unify env ty_res ty
- with Unify trace ->
- raise(Error(sp.ppat_loc, Label_mismatch(lid, trace)))
- end;
- let arg = type_pat env sarg in
- unify_pat env arg ty_arg;
- (label, arg)
- in
- rp {
- pat_desc = Tpat_record(List.map type_label_pat lid_sp_list);
- pat_loc = sp.ppat_loc;
- pat_type = ty;
- pat_env = env }
- | Ppat_array spl ->
- let pl = List.map (type_pat env) spl in
- let ty_elt = newvar() in
- List.iter (fun p -> unify_pat env p ty_elt) pl;
- rp {
- pat_desc = Tpat_array pl;
- pat_loc = sp.ppat_loc;
- pat_type = instance (Predef.type_array ty_elt);
- pat_env = env }
- | Ppat_or(sp1, sp2) ->
- let initial_pattern_variables = !pattern_variables in
- let p1 = type_pat env sp1 in
- let p1_variables = !pattern_variables in
- pattern_variables := initial_pattern_variables ;
- let p2 = type_pat env sp2 in
- let p2_variables = !pattern_variables in
- unify_pat env p2 p1.pat_type;
- let alpha_env =
- enter_orpat_variables sp.ppat_loc env p1_variables p2_variables in
- pattern_variables := p1_variables ;
- rp {
- pat_desc = Tpat_or(p1, alpha_pat alpha_env p2, None);
- pat_loc = sp.ppat_loc;
- pat_type = p1.pat_type;
- pat_env = env }
- | Ppat_constraint(sp, sty) ->
- let p = type_pat env sp in
- let ty, force = Typetexp.transl_simple_type_delayed env sty in
- unify_pat env p ty;
- pattern_force := force :: !pattern_force;
- p
- | Ppat_type lid ->
- build_or_pat env sp.ppat_loc lid
-
-let get_ref r =
- let v = !r in r := []; v
-
-let add_pattern_variables env =
- let pv = get_ref pattern_variables in
- List.fold_right
- (fun (id, ty) env ->
- Env.add_value id {val_type = ty; val_kind = Val_reg} env)
- pv env
-
-let type_pattern env spat =
- reset_pattern ();
- let pat = type_pat env spat in
- let new_env = add_pattern_variables env in
- (pat, new_env, get_ref pattern_force)
-
-let type_pattern_list env spatl =
- reset_pattern ();
- let patl = List.map (type_pat env) spatl in
- let new_env = add_pattern_variables env in
- (patl, new_env, get_ref pattern_force)
-
-let type_class_arg_pattern cl_num val_env met_env l spat =
- reset_pattern ();
- let pat = type_pat val_env spat 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) (pv, env) ->
- let id' = Ident.create (Ident.name id) in
- ((id', id, ty)::pv,
- Env.add_value id' {val_type = ty;
- val_kind = Val_ivar (Immutable, cl_num)}
- env))
- !pattern_variables ([], met_env)
- in
- let val_env = add_pattern_variables val_env in
- (pat, pv, val_env, met_env)
-
-let mkpat d = { ppat_desc = d; ppat_loc = Location.none }
-
-let type_self_pattern cl_num privty val_env met_env par_env spat =
- let spat =
- mkpat (Ppat_alias (mkpat(Ppat_alias (spat, "selfpat-*")),
- "selfpat-" ^ cl_num))
- in
- reset_pattern ();
- let pat = type_pat val_env spat 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) (val_env, met_env, par_env) ->
- (Env.add_value id {val_type = ty; val_kind = Val_unbound} val_env,
- Env.add_value id {val_type = ty;
- val_kind = Val_self (meths, vars, cl_num, privty)}
- met_env,
- Env.add_value id {val_type = ty; val_kind = Val_unbound} 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 :: !delayed_checks
-let force_delayed_checks () =
- List.iter (fun f -> f ()) (List.rev !delayed_checks);
- reset_delayed_checks ()
-
-
-(* 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 (pat, exp) -> is_nonexpansive exp) 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 fst el)
- | 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(lbl_exp_list, opt_init_exp) ->
- List.for_all
- (fun (lbl, exp) -> lbl.lbl_mut = Immutable && is_nonexpansive exp)
- lbl_exp_list
- && is_nonexpansive_opt opt_init_exp
- | Texp_field(exp, lbl) -> is_nonexpansive exp
- | Texp_array [] -> true
- | Texp_ifthenelse(cond, ifso, ifnot) ->
- is_nonexpansive ifso && is_nonexpansive_opt ifnot
- | 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 ({cl_field=fields}, {cty_vars=vars}, _) ->
- let count = ref 0 in
- List.for_all
- (function
- Cf_meth _ -> true
- | Cf_val (_,_,e) -> incr count; is_nonexpansive e
- | Cf_init e -> is_nonexpansive e
- | Cf_inher _ | Cf_let _ -> false)
- fields &&
- Vars.fold (fun _ (mut,_) b -> decr count; b && mut = Immutable)
- vars true &&
- !count = 0
- | _ -> false
-
-and is_nonexpansive_opt = function
- None -> true
- | Some e -> is_nonexpansive e
-
-(* Typing of printf formats.
- (Handling of * modifiers contributed by Thorsten Ohl.) *)
-
-let type_format loc fmt =
- let len = String.length fmt in
- let ty_input = newvar ()
- and ty_result = newvar ()
- and ty_aresult = newvar () in
- let ty_arrow gty ty = newty (Tarrow ("", instance gty, ty, Cok)) in
- let bad_format i len =
- raise (Error (loc, Bad_format (String.sub fmt i len))) in
- let incomplete i = bad_format i (len - i) in
-
- let rec scan_format i =
- if i >= len then ty_aresult, ty_result else
- match fmt.[i] with
- | '%' -> scan_flags i (i + 1)
- | _ -> scan_format (i + 1)
- and scan_flags i j =
- if j >= len then incomplete i else
- match fmt.[j] with
- | '#' | '0' | '-' | ' ' | '+' -> scan_flags i (j + 1)
- | _ -> scan_skip i j
- and scan_skip i j =
- if j >= len then incomplete i else
- match fmt.[j] with
- | '_' -> scan_rest true i j
- | _ -> scan_rest false i j
- and scan_rest skip i j =
- let rec scan_width i j =
- if j >= len then incomplete i else
- match fmt.[j] with
- | '*' ->
- let ty_aresult, ty_result = scan_dot i (j + 1) in
- ty_aresult, ty_arrow Predef.type_int ty_result
- | '_' -> scan_fixed_width i (j + 1)
- | '.' -> scan_precision i (j + 1)
- | _ -> scan_fixed_width i j
- and scan_fixed_width i j =
- if j >= len then incomplete i else
- match fmt.[j] with
- | '0' .. '9' | '-' | '+' -> scan_fixed_width i (j + 1)
- | '.' -> scan_precision i (j + 1)
- | _ -> scan_conversion i j
- and scan_dot i j =
- if j >= len then incomplete i else
- match fmt.[j] with
- | '.' -> scan_precision i (j + 1)
- | _ -> scan_conversion i j
- and scan_precision i j =
- if j >= len then incomplete i else
- match fmt.[j] with
- | '*' ->
- let ty_aresult, ty_result = scan_conversion i (j + 1) in
- ty_aresult, ty_arrow Predef.type_int ty_result
- | _ -> scan_fixed_precision i j
- and scan_fixed_precision i j =
- if j >= len then incomplete i else
- match fmt.[j] with
- | '0' .. '9' | '-' | '+' -> scan_fixed_precision i (j + 1)
- | _ -> scan_conversion i j
-
- and conversion j ty_arg =
- let ty_aresult, ty_result = scan_format (j + 1) in
- ty_aresult,
- if skip then ty_result else ty_arrow ty_arg ty_result
-
- and scan_conversion i j =
- if j >= len then incomplete i else
- match fmt.[j] with
- | '%' | '!' -> scan_format (j + 1)
- | 's' | 'S' | '[' -> conversion j Predef.type_string
- | 'c' | 'C' -> conversion j Predef.type_char
- | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' ->
- conversion j Predef.type_int
- | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> conversion j Predef.type_float
- | 'B' | 'b' -> conversion j Predef.type_bool
- | 'a' ->
- let ty_arg = newvar () in
- let ty_a = ty_arrow ty_input (ty_arrow ty_arg ty_aresult) in
- let ty_aresult, ty_result = conversion j ty_arg in
- ty_aresult, ty_arrow ty_a ty_result
- | 't' -> conversion j (ty_arrow ty_input ty_aresult)
- | 'n' when j + 1 = len -> conversion j Predef.type_int
- | 'l' | 'n' | 'L' as conv ->
- let j = j + 1 in
- if j >= len then incomplete i else begin
- match fmt.[j] with
- | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
- let ty_arg =
- match conv with
- | 'l' -> Predef.type_int32
- | 'n' -> Predef.type_nativeint
- | _ -> Predef.type_int64 in
- conversion j ty_arg
- | c ->
- if conv = 'l' || conv = 'n'
- then conversion (j - 1) Predef.type_int
- else bad_format i (j - i)
- end
- | c -> bad_format i (j - i + 1) in
- scan_width i j in
-
- let ty_ares, ty_res = scan_format 0 in
- newty
- (Tconstr(Predef.path_format4,
- [ty_res; ty_input; ty_ares; ty_result],
- ref Mnil))
-
-(* Approximate the type of an expression, for better recursion *)
-
-let rec approx_type 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 sty, Cok))
- | _ -> newvar ()
-
-let rec type_approx env sexp =
- match sexp.pexp_desc with
- Pexp_let (_, _, e) -> type_approx env e
- | Pexp_function (p,_,(_,e)::_) when is_optional p ->
- newty (Tarrow(p, type_option (newvar ()), type_approx env e, Cok))
- | Pexp_function (p,_,(_,e)::_) ->
- newty (Tarrow(p, newvar (), type_approx env e, Cok))
- | Pexp_match (_, (_,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, sty1, sty2) ->
- let ty = type_approx env e
- and ty1 = match sty1 with None -> newvar () | Some sty -> approx_type sty
- and ty2 = match sty2 with None -> newvar () | Some sty -> approx_type sty
- in begin
- try unify env ty ty1; unify env ty1 ty2; ty2
- with Unify trace ->
- raise(Error(sexp.pexp_loc, Expr_type_clash trace))
- end
- | _ -> 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, ty.desc = Tvar
-
-let list_labels env ty = list_labels_aux env [] [] ty
-
-(* Check that all univars are safe in a type *)
-let check_univars env kind exp ty_expected vars =
- (* 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;
- if t.desc = Tvar && t.level = generic_level then
- (log_type t; t.desc <- Tunivar; true)
- else 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,
- Less_general(kind, [ty, ty; ty_expected, ty_expected])))
-
-(* Check that a type is not a function *)
-let check_partial_application env exp =
- match expand_head env exp.exp_type with
- | {desc = Tarrow _} ->
- Location.prerr_warning exp.exp_loc Warnings.Partial_application
- | _ -> ()
-
-(* Hack to allow coercion of self. Will clean-up later. *)
-let self_coercion = ref ([] : (Path.t * Location.t list ref) list)
-
-(* Typing of expressions *)
-
-let unify_exp env exp expected_ty =
- try
- unify env exp.exp_type expected_ty
- with
- Unify trace ->
- raise(Error(exp.exp_loc, Expr_type_clash(trace)))
- | Tags(l1,l2) ->
- raise(Typetexp.Error(exp.exp_loc, Typetexp.Variant_tags (l1, l2)))
-
-let rec type_exp env sexp =
- match sexp.pexp_desc with
- Pexp_ident lid ->
- begin try
- let (path, desc) = Env.lookup_value lid env in
- re {
- 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)
- | Val_self (_, _, cl_num, _) ->
- let (path, _) =
- Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
- in
- Texp_ident(path, desc)
- | Val_unbound ->
- raise(Error(sexp.pexp_loc, Masked_instance_variable lid))
- | _ ->
- Texp_ident(path, desc)
- end;
- exp_loc = sexp.pexp_loc;
- exp_type = instance desc.val_type;
- exp_env = env }
- with Not_found ->
- raise(Error(sexp.pexp_loc, Unbound_value lid))
- end
- | Pexp_constant cst ->
- re {
- exp_desc = Texp_constant cst;
- exp_loc = sexp.pexp_loc;
- exp_type = type_constant cst;
- exp_env = env }
- | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
- let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list in
- let body = type_exp new_env sbody in
- re {
- exp_desc = Texp_let(rec_flag, pat_exp_list, body);
- exp_loc = sexp.pexp_loc;
- exp_type = body.exp_type;
- exp_env = env }
- | Pexp_function _ -> (* defined in type_expect *)
- type_expect env sexp (newvar())
- | Pexp_apply(sfunct, sargs) ->
- 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 (args, ty_res) = type_application env funct sargs in
- let funct = {funct with exp_type = instance funct.exp_type} in
- re {
- exp_desc = Texp_apply(funct, args);
- exp_loc = sexp.pexp_loc;
- exp_type = ty_res;
- exp_env = env }
- | Pexp_match(sarg, caselist) ->
- let arg = type_exp env sarg in
- let ty_res = newvar() in
- let cases, partial =
- type_cases env arg.exp_type ty_res (Some sexp.pexp_loc) caselist
- in
- re {
- exp_desc = Texp_match(arg, cases, partial);
- exp_loc = sexp.pexp_loc;
- exp_type = ty_res;
- exp_env = env }
- | Pexp_try(sbody, caselist) ->
- let body = type_exp env sbody in
- let cases, _ =
- type_cases env (instance Predef.type_exn) body.exp_type None
- caselist in
- re {
- exp_desc = Texp_try(body, cases);
- exp_loc = sexp.pexp_loc;
- exp_type = body.exp_type;
- exp_env = env }
- | Pexp_tuple sexpl ->
- let expl = List.map (type_exp env) sexpl in
- re {
- exp_desc = Texp_tuple expl;
- exp_loc = sexp.pexp_loc;
- exp_type = newty (Ttuple(List.map (fun exp -> exp.exp_type) expl));
- exp_env = env }
- | Pexp_construct(lid, sarg, explicit_arity) ->
- type_construct env sexp.pexp_loc lid sarg explicit_arity (newvar ())
- | Pexp_variant(l, sarg) ->
- let arg = may_map (type_exp env) sarg in
- let arg_type = may_map (fun arg -> arg.exp_type) arg in
- re {
- exp_desc = Texp_variant(l, arg);
- exp_loc = sexp.pexp_loc;
- 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_env = env }
- | Pexp_record(lid_sexp_list, opt_sexp) ->
- let ty = newvar() in
- let num_fields = ref 0 in
- let type_label_exp (lid, sarg) =
- let label =
- try
- Env.lookup_label lid env
- with Not_found ->
- raise(Error(sexp.pexp_loc, Unbound_label lid)) in
- begin_def ();
- if !Clflags.principal then begin_def ();
- let (vars, ty_arg, ty_res) = instance_label true label in
- if !Clflags.principal then begin
- end_def ();
- generalize_structure ty_arg;
- generalize_structure ty_res
- end;
- begin try
- unify env (instance ty_res) ty
- with Unify trace ->
- raise(Error(sexp.pexp_loc, Label_mismatch(lid, trace)))
- end;
- let arg = type_argument env sarg ty_arg in
- end_def ();
- if vars <> [] && not (is_nonexpansive arg) then
- generalize_expansive env arg.exp_type;
- check_univars env "field value" arg label.lbl_arg vars;
- num_fields := Array.length label.lbl_all;
- if label.lbl_private = Private then
- raise(Error(sexp.pexp_loc, Private_type ty));
- (label, {arg with exp_type = instance arg.exp_type}) in
- let lbl_exp_list = List.map type_label_exp lid_sexp_list in
- let rec check_duplicates seen_pos lid_sexp lbl_exp =
- match (lid_sexp, lbl_exp) with
- ((lid, _) :: rem1, (lbl, _) :: rem2) ->
- if List.mem lbl.lbl_pos seen_pos
- then raise(Error(sexp.pexp_loc, Label_multiply_defined lid))
- else check_duplicates (lbl.lbl_pos :: seen_pos) rem1 rem2
- | (_, _) -> () in
- check_duplicates [] lid_sexp_list lbl_exp_list;
- let opt_exp =
- match opt_sexp, lbl_exp_list with
- None, _ -> None
- | Some sexp, (lbl, _) :: _ ->
- let ty_exp = newvar () in
- let unify_kept lbl =
- if List.for_all (fun (lbl',_) -> lbl'.lbl_pos <> lbl.lbl_pos)
- lbl_exp_list
- then begin
- let _, ty_arg1, ty_res1 = instance_label false lbl
- and _, ty_arg2, ty_res2 = instance_label false lbl in
- unify env ty_exp ty_res1;
- unify env ty ty_res2;
- unify env ty_arg1 ty_arg2
- end in
- Array.iter unify_kept lbl.lbl_all;
- Some(type_expect env sexp ty_exp)
- | _ -> assert false
- in
- if opt_sexp = None && List.length lid_sexp_list <> !num_fields then begin
- let present_indices =
- List.map (fun (lbl, _) -> lbl.lbl_pos) lbl_exp_list in
- let label_names = extract_label_names sexp env ty 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(sexp.pexp_loc, Label_missing missing))
- end;
- re {
- exp_desc = Texp_record(lbl_exp_list, opt_exp);
- exp_loc = sexp.pexp_loc;
- exp_type = ty;
- exp_env = env }
- | Pexp_field(sarg, lid) ->
- let arg = type_exp env sarg in
- let label =
- try
- Env.lookup_label lid env
- with Not_found ->
- raise(Error(sexp.pexp_loc, Unbound_label lid)) in
- let (_, ty_arg, ty_res) = instance_label false label in
- unify_exp env arg ty_res;
- re {
- exp_desc = Texp_field(arg, label);
- exp_loc = sexp.pexp_loc;
- exp_type = ty_arg;
- exp_env = env }
- | Pexp_setfield(srecord, lid, snewval) ->
- let record = type_exp env srecord in
- let label =
- try
- Env.lookup_label lid env
- with Not_found ->
- raise(Error(sexp.pexp_loc, Unbound_label lid)) in
- if label.lbl_mut = Immutable then
- raise(Error(sexp.pexp_loc, Label_not_mutable lid));
- begin_def ();
- let (vars, ty_arg, ty_res) = instance_label true label in
- unify_exp env record ty_res;
- let newval = type_expect env snewval ty_arg in
- end_def ();
- if vars <> [] && not (is_nonexpansive newval) then
- generalize_expansive env newval.exp_type;
- check_univars env "field value" newval label.lbl_arg vars;
- if label.lbl_private = Private then
- raise(Error(sexp.pexp_loc, Private_label(lid, ty_res)));
- re {
- exp_desc = Texp_setfield(record, label, newval);
- exp_loc = sexp.pexp_loc;
- exp_type = instance Predef.type_unit;
- exp_env = env }
- | Pexp_array(sargl) ->
- let ty = newvar() in
- let argl = List.map (fun sarg -> type_expect env sarg ty) sargl in
- re {
- exp_desc = Texp_array argl;
- exp_loc = sexp.pexp_loc;
- exp_type = instance (Predef.type_array ty);
- exp_env = env }
- | Pexp_ifthenelse(scond, sifso, sifnot) ->
- let cond = type_expect env scond (instance Predef.type_bool) in
- begin match sifnot with
- None ->
- let ifso = type_expect env sifso (instance Predef.type_unit) in
- re {
- exp_desc = Texp_ifthenelse(cond, ifso, None);
- exp_loc = sexp.pexp_loc;
- exp_type = instance Predef.type_unit;
- exp_env = env }
- | Some sifnot ->
- let ifso = type_exp env sifso in
- let ifnot = type_expect env sifnot ifso.exp_type in
- re {
- exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot);
- exp_loc = sexp.pexp_loc;
- exp_type = ifso.exp_type;
- exp_env = env }
- end
- | Pexp_sequence(sexp1, sexp2) ->
- let exp1 = type_statement env sexp1 in
- let exp2 = type_exp env sexp2 in
- re {
- exp_desc = Texp_sequence(exp1, exp2);
- exp_loc = sexp.pexp_loc;
- exp_type = exp2.exp_type;
- exp_env = env }
- | Pexp_while(scond, sbody) ->
- let cond = type_expect env scond (instance Predef.type_bool) in
- let body = type_statement env sbody in
- re {
- exp_desc = Texp_while(cond, body);
- exp_loc = sexp.pexp_loc;
- exp_type = instance Predef.type_unit;
- exp_env = env }
- | Pexp_for(param, slow, shigh, dir, sbody) ->
- let low = type_expect env slow (instance Predef.type_int) in
- let high = type_expect env shigh (instance Predef.type_int) in
- let (id, new_env) =
- Env.enter_value param {val_type = instance Predef.type_int;
- val_kind = Val_reg} env in
- let body = type_statement new_env sbody in
- re {
- exp_desc = Texp_for(id, low, high, dir, body);
- exp_loc = sexp.pexp_loc;
- exp_type = instance Predef.type_unit;
- exp_env = env }
- | Pexp_constraint(sarg, sty, sty') ->
- let (arg, ty') =
- match (sty, sty') with
- (None, None) -> (* Case actually unused *)
- let arg = type_exp env sarg in
- (arg, arg.exp_type)
- | (Some sty, None) ->
- if !Clflags.principal then begin_def ();
- let ty = Typetexp.transl_simple_type env false sty in
- if !Clflags.principal then begin
- end_def ();
- generalize_structure ty;
- let ty1 = instance ty and ty2 = instance ty in
- (type_expect env sarg ty1, ty2)
- end else
- (type_expect env sarg ty, ty)
- | (None, Some sty') ->
- let (ty', force) =
- Typetexp.transl_simple_type_delayed env sty'
- in
- let arg = type_exp env sarg 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' ->
- r := sexp.pexp_loc :: !r;
- force ()
- | _ ->
- 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,
- Coercion_failure(ty', full_expand env ty', trace, b)))
- end
- end;
- (arg, ty')
- | (Some sty, Some sty') ->
- let (ty, force) =
- Typetexp.transl_simple_type_delayed env sty
- and (ty', force') =
- Typetexp.transl_simple_type_delayed env sty'
- in
- begin try
- let force'' = subtype env ty ty' in
- force (); force' (); force'' ()
- with Subtype (tr1, tr2) ->
- raise(Error(sexp.pexp_loc, Not_subtype(tr1, tr2)))
- end;
- (type_expect env sarg ty, ty')
- in
- re {
- exp_desc = arg.exp_desc;
- exp_loc = arg.exp_loc;
- exp_type = ty';
- exp_env = env }
- | Pexp_when(scond, sbody) ->
- let cond = type_expect env scond (instance Predef.type_bool) in
- let body = type_exp env sbody in
- re {
- exp_desc = Texp_when(cond, body);
- exp_loc = sexp.pexp_loc;
- exp_type = body.exp_type;
- exp_env = env }
- | Pexp_send (e, met) ->
- if !Clflags.principal then begin_def ();
- let obj = type_exp env e in
- begin try
- let (exp, typ) =
- match obj.exp_desc with
- Texp_ident(path, {val_kind = Val_self (meths, _, _, privty)}) ->
- let (id, typ) =
- filter_self_method env met Private meths privty
- in
- (Texp_send(obj, Tmeth_val id), typ)
- | Texp_ident(path, {val_kind = Val_anc (methods, cl_num)}) ->
- let method_id =
- begin try List.assoc met methods with Not_found ->
- raise(Error(e.pexp_loc, Undefined_inherited_method met))
- 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, _) ->
- 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 "" in
- unify env obj_ty desc.val_type;
- unify env res_ty (instance typ);
- (Texp_apply({ exp_desc = Texp_ident(Path.Pident method_id,
- {val_type = method_type;
- val_kind = Val_reg});
- exp_loc = sexp.pexp_loc;
- exp_type = method_type;
- exp_env = env },
- [Some {exp_desc = Texp_ident(path, desc);
- exp_loc = obj.exp_loc;
- exp_type = desc.val_type;
- exp_env = env },
- Required]),
- typ)
- | _ ->
- assert false
- end
- | _ ->
- (Texp_send(obj, Tmeth_name met),
- 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 ty
- | {desc = Tpoly (ty, tl); level = l} ->
- if !Clflags.principal && l <> generic_level then
- Location.prerr_warning sexp.pexp_loc
- (Warnings.Other
- "This use of a polymorphic method is not principal");
- snd (instance_poly false tl ty)
- | {desc = Tvar} as ty ->
- let ty' = newvar () in
- unify env (instance ty) (newty(Tpoly(ty',[])));
- (* if not !Clflags.nolabels then
- Location.prerr_warning loc (Warnings.Unknown_method met); *)
- ty'
- | _ ->
- assert false
- in
- re {
- exp_desc = exp;
- exp_loc = sexp.pexp_loc;
- exp_type = typ;
- exp_env = env }
- with Unify _ ->
- raise(Error(e.pexp_loc, Undefined_method (obj.exp_type, met)))
- end
- | Pexp_new cl ->
- let (cl_path, cl_decl) =
- try Env.lookup_class cl env with Not_found ->
- raise(Error(sexp.pexp_loc, Unbound_class cl))
- in
- begin match cl_decl.cty_new with
- None ->
- raise(Error(sexp.pexp_loc, Virtual_class cl))
- | Some ty ->
- re {
- exp_desc = Texp_new (cl_path, cl_decl);
- exp_loc = sexp.pexp_loc;
- exp_type = instance ty;
- exp_env = env }
- end
- | Pexp_setinstvar (lab, snewval) ->
- begin try
- let (path, desc) = Env.lookup_value (Longident.Lident lab) env in
- match desc.val_kind with
- Val_ivar (Mutable, cl_num) ->
- let newval = type_expect env snewval (instance desc.val_type) in
- let (path_self, _) =
- Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
- in
- re {
- exp_desc = Texp_setinstvar(path_self, path, newval);
- exp_loc = sexp.pexp_loc;
- exp_type = instance Predef.type_unit;
- exp_env = env }
- | Val_ivar _ ->
- raise(Error(sexp.pexp_loc, Instance_variable_not_mutable lab))
- | _ ->
- raise(Error(sexp.pexp_loc, Unbound_instance_variable lab))
- with
- Not_found ->
- raise(Error(sexp.pexp_loc, Unbound_instance_variable lab))
- end
- | Pexp_override lst ->
- let _ =
- List.fold_right
- (fun (lab, _) l ->
- if List.exists ((=) lab) l then
- raise(Error(sexp.pexp_loc,
- Value_multiply_overridden lab));
- 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(sexp.pexp_loc, 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 !vars in
- (Path.Pident id, type_expect env snewval (instance ty))
- with
- Not_found ->
- raise(Error(sexp.pexp_loc, Unbound_instance_variable lab))
- end
- in
- let modifs = List.map type_override lst in
- re {
- exp_desc = Texp_override(path_self, modifs);
- exp_loc = sexp.pexp_loc;
- exp_type = self_ty;
- exp_env = env }
- | _ ->
- assert false
- end
- | Pexp_letmodule(name, smodl, sbody) ->
- let ty = newvar() in
- 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 modl.mod_type env in
- Ctype.init_def(Ident.current_time());
- Typetexp.widen context;
- let body = type_exp new_env sbody in
- (* 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 new_env body.exp_type ty
- with Unify _ ->
- raise(Error(sexp.pexp_loc, Scoping_let_module(name, body.exp_type)))
- end;
- re {
- exp_desc = Texp_letmodule(id, modl, body);
- exp_loc = sexp.pexp_loc;
- exp_type = ty;
- exp_env = env }
- | Pexp_assert (e) ->
- let cond = type_expect env e (instance Predef.type_bool) in
- re {
- exp_desc = Texp_assert (cond);
- exp_loc = sexp.pexp_loc;
- exp_type = instance Predef.type_unit;
- exp_env = env;
- }
- | Pexp_assertfalse ->
- re {
- exp_desc = Texp_assertfalse;
- exp_loc = sexp.pexp_loc;
- exp_type = newvar ();
- exp_env = env;
- }
- | Pexp_lazy (e) ->
- let arg = type_exp env e in
- re {
- exp_desc = Texp_lazy arg;
- exp_loc = sexp.pexp_loc;
- exp_type = instance (Predef.type_lazy_t arg.exp_type);
- exp_env = env;
- }
- | Pexp_object s ->
- let desc, sign, meths = !type_object env sexp.pexp_loc s in
- re {
- exp_desc = Texp_object (desc, sign, meths);
- exp_loc = sexp.pexp_loc;
- exp_type = sign.cty_self;
- exp_env = env;
- }
- | Pexp_poly _ ->
- assert false
-
-and type_argument env sarg ty_expected' =
- (* ty_expected' may be generic *)
- let no_labels ty =
- let ls, tvar = list_labels env ty in
- not tvar && List.for_all ((=) "") ls
- in
- let ty_expected = instance ty_expected' in
- match expand_head env ty_expected', sarg with
- | _, {pexp_desc = Pexp_function(l,_,_)} when not (is_optional l) ->
- type_expect env sarg ty_expected
- | {desc = Tarrow("",ty_arg,ty_res,_); level = lv}, _ ->
- (* 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 ->
- make_args
- ((Some(option_none (instance ty_arg) sarg.pexp_loc), Optional)
- :: args)
- ty_fun
- | Tarrow (l,_,ty_res',_) when l = "" || !Clflags.classic ->
- args, ty_fun, no_labels ty_res'
- | Tvar -> 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 texp.exp_type}
- and ty_fun = instance 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; pat_type = ty;
- pat_loc = Location.none; pat_env = env},
- {exp_type = ty; exp_loc = Location.none; exp_env = env; exp_desc =
- Texp_ident(Path.Pident id,{val_type = ty; val_kind = Val_reg})}
- in
- let eta_pat, eta_var = var_pair "eta" ty_arg in
- let func texp =
- { texp with exp_type = ty_fun; exp_desc =
- Texp_function([eta_pat, {texp with exp_type = ty_res; exp_desc =
- Texp_apply (texp, args@
- [Some eta_var, Required])}],
- Total) } in
- if warn then Location.prerr_warning texp.exp_loc
- (Warnings.Other "Eliminated optional argument without principality");
- if is_nonexpansive texp then func texp else
- (* let-expand to have side effects *)
- let let_pat, let_var = var_pair "let" texp.exp_type in
- re { texp with exp_type = ty_fun; exp_desc =
- Texp_let (Nonrecursive, [let_pat, texp], func let_var) }
- end
- | _ ->
- type_expect env sarg ty_expected
-
-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 omitted ty_fun = function
- [] ->
- (List.map
- (function None, x -> None, x | Some f, x -> Some (f ()), x)
- (List.rev args),
- instance (result_type omitted ty_fun))
- | (l1, sarg1) :: sargl ->
- let (ty1, ty2) =
- match (expand_head env ty_fun).desc with
- Tvar ->
- let t1 = newvar () and t2 = newvar () in
- unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown))));
- (t1, t2)
- | Tarrow (l,t1,t2,_) when l = l1
- || !Clflags.classic && l1 = "" && 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, Apply_wrong_label(l1, ty_res)))
- else
- raise(Error(funct.exp_loc, Incoherent_label_order))
- | _ ->
- raise(Error(funct.exp_loc, Apply_non_function
- (expand_head env funct.exp_type)))
- in
- let optional = if is_optional l1 then Optional else Required in
- let arg1 () =
- let arg1 = type_expect env sarg1 ty1 in
- if optional = Optional then
- unify_exp env arg1 (type_option(newvar()));
- arg1
- in
- type_unknown_args ((Some arg1, optional) :: 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 = "") sargs &&
- List.exists (fun l -> l <> "") labels &&
- (Location.prerr_warning funct.exp_loc Warnings.Labels_omitted;
- true)
- end
- in
- let warned = ref false in
- let rec type_args args omitted ty_fun ty_old sargs more_sargs =
- match expand_head env ty_fun with
- {desc=Tarrow (l, ty, ty_fun, com); level=lv} as ty_fun'
- when (sargs <> [] || more_sargs <> []) && commu_repr com = Cok ->
- let may_warn loc msg =
- if not !warned && !Clflags.principal && lv <> generic_level
- then begin
- warned := true;
- Location.prerr_warning loc (Warnings.Other msg)
- end
- in
- let name = label_name l
- and optional = if is_optional l then Optional else Required 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, Apply_wrong_label(l', ty_old)))
- | _, (l', sarg0) :: more_sargs ->
- if l <> l' && l' <> "" then
- raise(Error(sarg0.pexp_loc, Apply_wrong_label(l', ty_fun')))
- else
- ([], more_sargs, Some (fun () -> type_argument env sarg0 ty))
- | _ ->
- 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
- "Commuting this argument is not principal";
- (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
- "Commuting this argument is not principal";
- (l', sarg0, sargs @ sargs1, sargs2)
- in
- sargs, more_sargs,
- if optional = Required || is_optional l' then
- Some (fun () -> type_argument env sarg0 ty)
- else begin
- may_warn sarg0.pexp_loc
- "Using an optional argument here is not principal";
- Some (fun () -> option_some (type_argument env sarg0
- (extract_option_type env ty)))
- end
- with Not_found ->
- sargs, more_sargs,
- if optional = Optional &&
- (List.mem_assoc "" sargs || List.mem_assoc "" more_sargs)
- then begin
- may_warn funct.exp_loc
- "Eliminated an optional argument without principality";
- ignored := (l,ty,lv) :: !ignored;
- Some (fun () -> option_none (instance ty) Location.none)
- end else begin
- may_warn funct.exp_loc
- "Commuted an argument without principality";
- 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 ((arg,optional)::args) omitted ty_fun ty_old sargs more_sargs
- | _ ->
- match sargs with
- (l, sarg0) :: _ when ignore_labels ->
- raise(Error(sarg0.pexp_loc, Apply_wrong_label(l, ty_old)))
- | _ ->
- type_unknown_args args omitted (instance ty_fun)
- (sargs @ more_sargs)
- in
- match funct.exp_desc, sargs with
- (* Special case for ignore: avoid discarding warning *)
- Texp_ident (_, {val_kind=Val_prim{Primitive.prim_name="%ignore"}}),
- ["", sarg] ->
- let ty_arg, ty_res = filter_arrow env (instance funct.exp_type) "" 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_partial_application env exp)
- | _ -> ()
- end;
- ([Some exp, Required], ty_res)
- | _ ->
- let ty = funct.exp_type in
- if ignore_labels then
- type_args [] [] ty ty [] sargs
- else
- type_args [] [] ty ty sargs []
-
-and type_construct env loc lid sarg explicit_arity ty_expected =
- let constr =
- try
- Env.lookup_constructor lid env
- with Not_found ->
- raise(Error(loc, Unbound_constructor lid)) in
- let sargs =
- match sarg with
- None -> []
- | Some {pexp_desc = Pexp_tuple sel} when explicit_arity -> sel
- | Some {pexp_desc = Pexp_tuple sel} when constr.cstr_arity > 1 -> sel
- | Some se -> [se] in
- if List.length sargs <> constr.cstr_arity then
- raise(Error(loc, Constructor_arity_mismatch
- (lid, constr.cstr_arity, List.length sargs)));
- if !Clflags.principal then begin_def ();
- let (ty_args, ty_res) = instance_constructor constr in
- if !Clflags.principal then begin
- end_def ();
- List.iter generalize_structure ty_args;
- generalize_structure ty_res
- end;
- let texp =
- re {
- exp_desc = Texp_construct(constr, []);
- exp_loc = loc;
- exp_type = instance ty_res;
- exp_env = env } in
- unify_exp env texp ty_expected;
- let args = List.map2 (type_argument env) sargs ty_args in
- if constr.cstr_private = Private then
- raise(Error(loc, Private_type ty_res));
- { texp with exp_desc = Texp_construct(constr, args) }
-
-(* Typing of an expression with an expected type.
- Some constructs are treated specially to provide better error messages. *)
-
-and type_expect ?in_function env sexp ty_expected =
- match sexp.pexp_desc with
- Pexp_constant(Const_string s as cst) ->
- let exp =
- re {
- exp_desc = Texp_constant cst;
- exp_loc = sexp.pexp_loc;
- exp_type =
- (* Terrible hack for format strings *)
- begin match (repr (expand_head env ty_expected)).desc with
- Tconstr(path, _, _) when Path.same path Predef.path_format4 ->
- type_format sexp.pexp_loc s
- | _ -> instance Predef.type_string
- end;
- exp_env = env } in
- unify_exp env exp ty_expected;
- exp
- | Pexp_construct(lid, sarg, explicit_arity) ->
- type_construct env sexp.pexp_loc lid sarg explicit_arity ty_expected
- | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
- let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list in
- let body = type_expect new_env sbody ty_expected in
- re {
- exp_desc = Texp_let(rec_flag, pat_exp_list, body);
- exp_loc = sexp.pexp_loc;
- exp_type = body.exp_type;
- exp_env = env }
- | 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 = sexp.pexp_loc;
- exp_type = exp2.exp_type;
- exp_env = env }
- | Pexp_function (l, Some default, [spat, sbody]) ->
- let loc = default.pexp_loc in
- let scases =
- [{ppat_loc = loc; ppat_desc =
- Ppat_construct(Longident.Lident"Some",
- Some{ppat_loc = loc; ppat_desc = Ppat_var"*sth*"},
- false)},
- {pexp_loc = loc; pexp_desc = Pexp_ident(Longident.Lident"*sth*")};
- {ppat_loc = loc; ppat_desc =
- Ppat_construct(Longident.Lident"None", None, false)},
- default] in
- let smatch =
- {pexp_loc = loc; pexp_desc =
- Pexp_match({pexp_loc = loc; pexp_desc =
- Pexp_ident(Longident.Lident"*opt*")},
- scases)} in
- let sfun =
- {pexp_loc = sexp.pexp_loc; pexp_desc =
- Pexp_function(l, None,[{ppat_loc = loc; ppat_desc = Ppat_var"*opt*"},
- {pexp_loc = sexp.pexp_loc; pexp_desc =
- Pexp_let(Default, [spat, smatch], sbody)}])}
- in
- type_expect ?in_function env sfun ty_expected
- | Pexp_function (l, _, caselist) ->
- let (loc, ty_fun) =
- match in_function with Some p -> p
- | None -> (sexp.pexp_loc, ty_expected)
- in
- let (ty_arg, ty_res) =
- try filter_arrow env ty_expected l
- with Unify _ ->
- match expand_head env ty_expected with
- {desc = Tarrow _} as ty ->
- raise(Error(sexp.pexp_loc, Abstract_wrong_label(l, ty)))
- | _ ->
- raise(Error(loc,
- Too_many_arguments (in_function <> None, ty_fun)))
- in
- if is_optional l then begin
- try unify env ty_arg (type_option(newvar()))
- with Unify _ -> assert false
- end;
- let cases, partial =
- type_cases ~in_function:(loc,ty_fun) env ty_arg ty_res
- (Some sexp.pexp_loc) caselist in
- let all_labeled ty =
- let ls, tvar = list_labels env ty in
- not (tvar || List.exists (fun l -> l = "" || l.[0] = '?') ls)
- in
- if is_optional l && all_labeled ty_res then
- Location.prerr_warning (fst (List.hd cases)).pat_loc
- (Warnings.Other "This optional argument cannot be erased");
- re {
- exp_desc = Texp_function(cases, partial);
- exp_loc = sexp.pexp_loc;
- exp_type = newty (Tarrow(l, ty_arg, ty_res, Cok));
- exp_env = env }
- | Pexp_poly(sbody, sty) ->
- let ty =
- match sty with None -> repr ty_expected
- | Some sty ->
- let ty = Typetexp.transl_simple_type env false sty in
- repr ty
- in
- let set_type ty =
- unify_exp env
- { exp_desc = Texp_tuple []; exp_loc = sexp.pexp_loc;
- exp_type = ty; exp_env = env } ty_expected in
- begin
- match ty.desc with
- Tpoly (ty', []) ->
- if sty <> None then set_type ty;
- let exp = type_expect env sbody ty' in
- re { exp with exp_type = ty }
- | Tpoly (ty', tl) ->
- if sty <> None then set_type ty;
- (* One more level to generalize locally *)
- begin_def ();
- let vars, ty'' = instance_poly true tl ty' in
- let exp = type_expect env sbody ty'' in
- end_def ();
- check_univars env "method" exp ty_expected vars;
- re { exp with exp_type = ty }
- | _ -> assert false
- end
- | _ ->
- let exp = type_exp env sexp in
- unify_exp env exp ty_expected;
- exp
-
-(* Typing of statements (expressions whose values are discarded) *)
-
-and type_statement env sexp =
- let exp = type_exp env sexp in
- match (expand_head env exp.exp_type).desc with
- | Tarrow _ ->
- Location.prerr_warning sexp.pexp_loc Warnings.Partial_application;
- exp
- | Tconstr (p, _, _) when Path.same p Predef.path_unit -> exp
- | Tvar ->
- add_delayed_check (fun () -> check_partial_application env exp);
- exp
- | _ ->
- Location.prerr_warning sexp.pexp_loc Warnings.Statement_type;
- exp
-
-(* Typing of match cases *)
-
-and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
- let ty_arg' = newvar () in
- let pattern_force = ref [] in
- let pat_env_list =
- List.map
- (fun (spat, sexp) ->
- if !Clflags.principal then begin_def ();
- let (pat, ext_env, force) = type_pattern env spat 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 pat.pat_type }
- end else pat
- in
- unify_pat env pat ty_arg';
- (pat, ext_env))
- caselist in
- (* Check for polymorphic variants to close *)
- let patl = List.map fst pat_env_list in
- 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;
- begin match pat_env_list with [] -> ()
- | (pat, _) :: _ -> unify_pat env pat ty_arg
- end;
- let in_function = if List.length caselist = 1 then in_function else None in
- let cases =
- List.map2
- (fun (pat, ext_env) (spat, sexp) ->
- let exp = type_expect ?in_function ext_env sexp ty_res in
- (pat, exp))
- pat_env_list caselist
- in
- let partial =
- match partial_loc with None -> Partial
- | Some loc -> Parmatch.check_partial loc cases
- in
- add_delayed_check (fun () -> Parmatch.check_unused env cases);
- cases, partial
-
-(* Typing of let bindings *)
-
-and type_let env rec_flag spat_sexp_list =
- begin_def();
- if !Clflags.principal then begin_def ();
- let (pat_list, new_env, force) =
- type_pattern_list env (List.map (fun (spat, sexp) -> spat) spat_sexp_list)
- in
- if rec_flag = Recursive then
- List.iter2
- (fun pat (_, sexp) -> unify_pat env pat (type_approx env sexp))
- pat_list spat_sexp_list;
- 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 pat.pat_type})
- pat_list
- end else pat_list in
- (* Polymoprhic 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;
- (* Only bind pattern variables after generalizing *)
- List.iter (fun f -> f()) force;
- let exp_env =
- match rec_flag with Nonrecursive | Default -> env | Recursive -> new_env in
- let exp_list =
- List.map2
- (fun (spat, sexp) pat -> type_expect exp_env sexp pat.pat_type)
- spat_sexp_list pat_list in
- List.iter2
- (fun pat exp -> ignore(Parmatch.check_partial pat.pat_loc [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;
- (List.combine pat_list exp_list, new_env)
-
-(* Typing of toplevel bindings *)
-
-let type_binding env rec_flag spat_sexp_list =
- Typetexp.reset_type_variables();
- type_let env rec_flag spat_sexp_list
-
-(* 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 is_nonexpansive exp then generalize exp.exp_type
- else generalize_expansive env exp.exp_type;
- exp
-
-(* Error report *)
-
-open Format
-open Printtyp
-
-let report_error ppf = function
- | Unbound_value lid ->
- fprintf ppf "Unbound value %a" longident lid
- | Unbound_constructor lid ->
- fprintf ppf "Unbound constructor %a" longident lid
- | Unbound_label lid ->
- fprintf ppf "Unbound record field label %a" longident lid
- | Constructor_arity_mismatch(lid, expected, provided) ->
- fprintf ppf
- "@[The constructor %a@ expects %i argument(s),@ \
- but is here applied to %i argument(s)@]"
- longident lid expected provided
- | Label_mismatch(lid, trace) ->
- report_unification_error ppf trace
- (function ppf ->
- fprintf ppf "The record field label %a@ belongs to the type"
- longident lid)
- (function ppf ->
- fprintf ppf "but is here mixed with labels of type")
- | Pattern_type_clash trace ->
- report_unification_error ppf trace
- (function ppf ->
- fprintf ppf "This pattern matches values of type")
- (function ppf ->
- fprintf ppf "but is here used to match values of type")
- | Multiply_bound_variable ->
- fprintf ppf "This variable is bound several times in this matching"
- | Orpat_vars id ->
- fprintf ppf "Variable %s must occur on both sides of this | pattern"
- (Ident.name id)
- | Expr_type_clash trace ->
- report_unification_error ppf trace
- (function ppf ->
- fprintf ppf "This expression has type")
- (function ppf ->
- fprintf ppf "but is here used with type")
- | Apply_non_function typ ->
- begin match (repr typ).desc with
- Tarrow _ ->
- fprintf ppf "This function is applied to too many arguments,@ ";
- fprintf ppf "maybe you forgot a `;'"
- | _ ->
- fprintf ppf
- "This expression is not a function, it cannot be applied"
- end
- | Apply_wrong_label (l, ty) ->
- let print_label ppf = function
- | "" -> fprintf ppf "without label"
- | l ->
- fprintf ppf "with label %s%s" (if is_optional l then "" else "~") l
- in
- reset_and_mark_loops ty;
- fprintf ppf
- "@[<v>@[<2>Expecting function has type@ %a@]@.\
- This argument cannot be applied %a@]"
- type_expr ty print_label l
- | Label_multiply_defined lid ->
- fprintf ppf "The record field label %a is defined several times"
- longident lid
- | Label_missing labels ->
- let print_labels ppf = List.iter (fun lbl -> fprintf ppf "@ %s" lbl) in
- fprintf ppf "@[<hov>Some record field labels are undefined:%a@]"
- print_labels labels
- | Label_not_mutable lid ->
- fprintf ppf "The record field label %a is not mutable" longident lid
- | Bad_format s ->
- fprintf ppf "Bad format `%s'" s
- | Undefined_method (ty, me) ->
- reset_and_mark_loops ty;
- fprintf ppf
- "@[<v>@[This expression has type@;<1 2>%a@]@,\
- It has no method %s@]" type_expr ty me
- | Undefined_inherited_method me ->
- fprintf ppf "This expression has no method %s" me
- | Unbound_class cl ->
- fprintf ppf "Unbound class %a" longident cl
- | Virtual_class cl ->
- fprintf ppf "One cannot create instances of the virtual class %a"
- longident cl
- | Unbound_instance_variable v ->
- fprintf ppf "Unbound instance variable %s" v
- | Instance_variable_not_mutable v ->
- fprintf ppf "The instance variable %s is not mutable" v
- | Not_subtype(tr1, tr2) ->
- report_subtyping_error ppf tr1 "is not a subtype of type" 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 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 ".@.@[<hov>%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
- | "" -> "but its first argument is not labeled"
- | l -> sprintf "but its first argument is labeled ~%s" l in
- reset_and_mark_loops ty;
- fprintf ppf "@[<v>@[<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 trace
- (fun ppf -> fprintf ppf "This %s has type" kind)
- (fun ppf -> fprintf ppf "which is less general than")
diff --git a/typing/typecore.mli b/typing/typecore.mli
deleted file mode 100644
index 3511b93b5a..0000000000
--- a/typing/typecore.mli
+++ /dev/null
@@ -1,108 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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.pattern * Parsetree.expression) list ->
- (Typedtree.pattern * Typedtree.expression) list * Env.t
-val type_let:
- Env.t -> rec_flag ->
- (Parsetree.pattern * Parsetree.expression) list ->
- (Typedtree.pattern * Typedtree.expression) list * Env.t
-val type_expression:
- Env.t -> Parsetree.expression -> Typedtree.expression
-val type_class_arg_pattern:
- string -> Env.t -> Env.t -> label -> Parsetree.pattern ->
- Typedtree.pattern * (Ident.t * 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 * type_expr) Vars.t ref *
- Env.t * Env.t * Env.t
-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 -> 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 reset_delayed_checks: unit -> unit
-val force_delayed_checks: unit -> unit
-
-val self_coercion : (Path.t * Location.t list ref) list ref
-
-type error =
- Unbound_value of Longident.t
- | Unbound_constructor of Longident.t
- | Unbound_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
- | Multiply_bound_variable
- | Orpat_vars of Ident.t
- | Expr_type_clash of (type_expr * type_expr) list
- | Apply_non_function of type_expr
- | Apply_wrong_label of label * type_expr
- | Label_multiply_defined of Longident.t
- | Label_missing of string list
- | Label_not_mutable of Longident.t
- | Bad_format of string
- | Undefined_method of type_expr * string
- | Undefined_inherited_method of string
- | Unbound_class of Longident.t
- | Virtual_class of Longident.t
- | Private_type of type_expr
- | Private_label of Longident.t * type_expr
- | Unbound_instance_variable of string
- | Instance_variable_not_mutable of 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 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
-
-exception Error of Location.t * error
-
-val report_error: formatter -> error -> unit
-
-(* Forward declaration, to be filled in by Typemod.type_module *)
-val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref
-(* Forward declaration, to be filled in by Typeclass.class_structure *)
-val type_object:
- (Env.t -> Location.t -> Parsetree.class_structure ->
- Typedtree.class_structure * class_signature * string list) ref
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
deleted file mode 100644
index c4bcc9def1..0000000000
--- a/typing/typedecl.ml
+++ /dev/null
@@ -1,717 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* 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 Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(**** Typing of type definitions ****)
-
-open Misc
-open Asttypes
-open Parsetree
-open Primitive
-open Types
-open Typedtree
-open Typetexp
-
-type error =
- Repeated_parameter
- | Duplicate_constructor of string
- | Too_many_constructors
- | Duplicate_label of string
- | Recursive_abbrev of string
- | Definition_mismatch of type_expr
- | Constraint_failed of type_expr * type_expr
- | Unconsistent_constraint of (type_expr * type_expr) list
- | Type_clash of (type_expr * type_expr) list
- | Parameters_differ of Path.t * type_expr * type_expr
- | Null_arity_external
- | Missing_native_external
- | Unbound_type_var
- | Unbound_exception of Longident.t
- | Not_an_exception of Longident.t
- | Bad_variance
- | Unavailable_type_constructor of Path.t
-
-exception Error of Location.t * error
-
-(* Enter all declared types in the environment as abstract types *)
-
-let enter_type env (name, sdecl) id =
- let decl =
- { type_params =
- List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params;
- type_arity = List.length sdecl.ptype_params;
- type_kind = Type_abstract;
- type_manifest =
- begin match sdecl.ptype_manifest with None -> None
- | Some _ -> Some(Ctype.newvar ()) end;
- type_variance = List.map (fun _ -> true, true, true) sdecl.ptype_params;
- }
- in
- Env.add_type 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 trace))
-
-(* Determine if a type is (an abbreviation for) the type "float" *)
-
-let is_float env ty =
- match Ctype.repr (Ctype.expand_head env ty) with
- {desc = Tconstr(p, _, _)} -> Path.same p Predef.path_float
- | _ -> false
-
-(* Translate one type declaration *)
-
-module StringSet =
- Set.Make(struct
- type t = string
- let compare = compare
- end)
-
-let transl_declaration env (name, sdecl) id =
- (* Bind type parameters *)
- reset_type_variables();
- Ctype.begin_def ();
- let params =
- try List.map (enter_type_variable true sdecl.ptype_loc) sdecl.ptype_params
- with Already_bound ->
- raise(Error(sdecl.ptype_loc, Repeated_parameter))
- 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 decl =
- { type_params = params;
- type_arity = List.length params;
- type_kind =
- begin match sdecl.ptype_kind with
- Ptype_abstract ->
- Type_abstract
- | Ptype_variant (cstrs, priv) ->
- let all_constrs = ref StringSet.empty in
- List.iter
- (fun (name, args) ->
- if StringSet.mem name !all_constrs then
- raise(Error(sdecl.ptype_loc, Duplicate_constructor name));
- all_constrs := StringSet.add name !all_constrs)
- cstrs;
- if List.length (List.filter (fun (name, args) -> args <> []) cstrs)
- > (Config.max_tag + 1) then
- raise(Error(sdecl.ptype_loc, Too_many_constructors));
- Type_variant(List.map
- (fun (name, args) ->
- (name, List.map (transl_simple_type env true) args))
- cstrs, priv)
- | Ptype_record (lbls, priv) ->
- let all_labels = ref StringSet.empty in
- List.iter
- (fun (name, mut, arg) ->
- if StringSet.mem name !all_labels then
- raise(Error(sdecl.ptype_loc, Duplicate_label name));
- all_labels := StringSet.add name !all_labels)
- lbls;
- let lbls' =
- List.map
- (fun (name, mut, arg) ->
- let ty = transl_simple_type env true arg in
- name, mut, match ty.desc with Tpoly(t,[]) -> t | _ -> ty)
- lbls in
- let rep =
- if List.for_all (fun (name, mut, arg) -> is_float env arg) lbls'
- then Record_float
- else Record_regular in
- Type_record(lbls', rep, priv)
- end;
- type_manifest =
- begin match sdecl.ptype_manifest with
- None -> None
- | Some sty ->
- let ty = transl_simple_type env true sty in
- if Ctype.cyclic_abbrev env id ty then
- raise(Error(sdecl.ptype_loc, Recursive_abbrev name));
- Some ty
- end;
- type_variance = List.map (fun _ -> true, true, true) params;
- } in
-
- (* Check constraints *)
- List.iter
- (fun (ty, ty', loc) ->
- try Ctype.unify env ty ty' with Ctype.Unify tr ->
- raise(Error(loc, Unconsistent_constraint tr)))
- cstrs;
- Ctype.end_def ();
-
- (id, decl)
-
-(* Generalize a type declaration *)
-
-let generalize_decl decl =
- List.iter Ctype.generalize decl.type_params;
- begin match decl.type_kind with
- Type_abstract ->
- ()
- | Type_variant (v, priv) ->
- List.iter (fun (_, tyl) -> List.iter Ctype.generalize tyl) v
- | Type_record(r, rep, priv) ->
- List.iter (fun (_, _, ty) -> Ctype.generalize ty) r
- end;
- begin match decl.type_manifest with
- | None -> ()
- | Some ty -> Ctype.generalize ty
- end
-
-(* Check that all constraints are enforced *)
-
-module TypeSet =
- Set.Make
- (struct
- type t = type_expr
- let compare t1 t2 = t1.id - t2.id
- end)
-
-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
-
-let check_constraints env (_, sdecl) (_, decl) =
- let visited = ref TypeSet.empty in
- begin match decl.type_kind with
- | Type_abstract -> ()
- | Type_variant (l, _) ->
- let rec find_pl = function
- Ptype_variant(pl, _) -> pl
- | Ptype_record _ | Ptype_abstract -> assert false
- in
- let pl = find_pl sdecl.ptype_kind in
- List.iter
- (fun (name, tyl) ->
- let styl = try List.assoc name pl with Not_found -> assert false in
- List.iter2
- (fun sty ty ->
- check_constraints_rec env sty.ptyp_loc visited ty)
- styl tyl)
- l
- | Type_record (l, _, _) ->
- let rec find_pl = function
- Ptype_record(pl, _) -> pl
- | Ptype_variant _ | Ptype_abstract -> assert false
- in
- let pl = find_pl sdecl.ptype_kind in
- let rec get_loc name = function
- [] -> assert false
- | (name', _, sty) :: tl ->
- if name = name' then sty.ptyp_loc else get_loc name tl
- in
- List.iter
- (fun (name, _, ty) ->
- check_constraints_rec env (get_loc name pl) visited ty)
- l
- 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_abbrev env (_, sdecl) (id, decl) =
- match decl with
- {type_kind = (Type_variant _ | Type_record _); type_manifest = Some ty} ->
- begin match (Ctype.repr ty).desc with
- Tconstr(path, args, _) ->
- begin try
- let decl' = Env.find_type path env in
- if List.length args = List.length decl.type_params
- && Ctype.equal env false args decl.type_params
- && Includecore.type_declarations env id
- decl'
- (Subst.type_declaration (Subst.add_type id path Subst.identity)
- decl)
- then ()
- else raise(Error(sdecl.ptype_loc, Definition_mismatch ty))
- with Not_found ->
- raise(Error(sdecl.ptype_loc, Unavailable_type_constructor path))
- end
- | _ -> raise(Error(sdecl.ptype_loc, Definition_mismatch ty))
- end
- | _ -> ()
-
-(* 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. *)
-
- 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 false tl ty in
- check_regular cpath args prev_exp ty
- | _ ->
- Btype.iter_type_expr (check_regular cpath args prev_exp) ty
- end in
-
- match decl.type_manifest with
- | None -> ()
- | Some body ->
- (* Check that recursion is well-founded *)
- begin try
- Ctype.correct_abbrev env path decl.type_params body
- with Ctype.Recursive_abbrev ->
- raise(Error(loc, Recursive_abbrev (Path.name path)))
- end;
- (* Check that recursion is regular *)
- if decl.type_params = [] then () else
- let (args, body) =
- Ctype.instance_parameterized_type decl.type_params body in
- check_regular path args [] body
-
-let check_abbrev_recursion env id_loc_list (id, decl) =
- check_recursion env (List.assoc id id_loc_list) (Path.Pident id) decl
- (function Path.Pident id -> List.mem_assoc id id_loc_list | _ -> false)
-
-(* Compute variance *)
-
-let compute_variance env tvl nega posi cntr ty =
- let pvisited = ref TypeSet.empty
- and nvisited = ref TypeSet.empty
- and cvisited = ref TypeSet.empty in
- let rec compute_variance_rec posi nega cntr ty =
- let ty = Ctype.repr ty in
- if (not posi || TypeSet.mem ty !pvisited)
- && (not nega || TypeSet.mem ty !nvisited)
- && (not cntr || TypeSet.mem ty !cvisited) then
- ()
- else begin
- if posi then pvisited := TypeSet.add ty !pvisited;
- if nega then nvisited := TypeSet.add ty !nvisited;
- if cntr then cvisited := TypeSet.add ty !cvisited;
- let compute_same = compute_variance_rec posi nega cntr in
- match ty.desc with
- Tarrow (_, ty1, ty2, _) ->
- compute_variance_rec nega posi true ty1;
- compute_same ty2
- | Ttuple tl ->
- List.iter compute_same tl
- | Tconstr (path, tl, _) ->
- if tl = [] then () else begin
- try
- let decl = Env.find_type path env in
- List.iter2
- (fun ty (co,cn,ct) ->
- compute_variance_rec
- (posi && co || nega && cn)
- (posi && cn || nega && co)
- (cntr || ct)
- ty)
- tl decl.type_variance
- with Not_found ->
- List.iter (compute_variance_rec true true true) tl
- end
- | Tobject (ty, _) ->
- compute_same ty
- | Tfield (_, _, ty1, ty2) ->
- compute_same ty1;
- compute_same ty2
- | Tsubst ty ->
- compute_same ty
- | Tvariant row ->
- List.iter
- (fun (_,f) ->
- match Btype.row_field_repr f with
- Rpresent (Some ty) ->
- compute_same ty
- | Reither (_, tyl, _, _) ->
- List.iter compute_same tyl
- | _ -> ())
- (Btype.row_repr row).row_fields
- | Tpoly (ty, _) ->
- compute_same ty
- | Tvar | Tnil | Tlink _ | Tunivar -> ()
- end
- in
- compute_variance_rec nega posi cntr ty;
- List.iter
- (fun (ty, covar, convar, ctvar) ->
- if TypeSet.mem ty !pvisited then covar := true;
- if TypeSet.mem ty !nvisited then convar := true;
- if TypeSet.mem ty !cvisited then ctvar := true)
- tvl
-
-let compute_variance_decl env decl (required, loc) =
- if decl.type_kind = Type_abstract && decl.type_manifest = None then
- List.map (fun (c, n) -> if c || n then (c, n, n) else (true, true, true))
- required
- else
- let tvl =
- List.map (fun ty -> (Btype.repr ty, ref false, ref false, ref false))
- decl.type_params in
- begin match decl.type_kind with
- Type_abstract ->
- begin match decl.type_manifest with
- None -> assert false
- | Some ty -> compute_variance env tvl true false false ty
- end
- | Type_variant (tll, _) ->
- List.iter
- (fun (_,tl) ->
- List.iter (compute_variance env tvl true false false) tl)
- tll
- | Type_record (ftl, _, _) ->
- List.iter
- (fun (_, mut, ty) ->
- let cn = (mut = Mutable) in
- compute_variance env tvl true cn cn ty)
- ftl
- end;
- List.map2
- (fun (_, co, cn, ct) (c, n) ->
- if c && !cn || n && !co then raise (Error(loc, Bad_variance));
- let ct = if decl.type_kind = Type_abstract then ct else cn in
- (!co, !cn, !ct))
- tvl required
-
-let rec compute_variance_fixpoint env decls required variances =
- let new_decls =
- List.map2
- (fun (id, decl) variance -> id, {decl with type_variance = variance})
- decls variances
- in
- let new_env =
- List.fold_right (fun (id, decl) env -> Env.add_type id decl env)
- new_decls env
- in
- let new_variances =
- List.map2 (fun (_, decl) -> compute_variance_decl new_env decl)
- new_decls required
- in
- let new_variances =
- List.map2
- (List.map2 (fun (c1,n1,t1) (c2,n2,t2) -> c1||c2, n1||n2, t1||t2))
- new_variances variances in
- if new_variances = variances then
- new_decls, new_env
- else
- compute_variance_fixpoint env decls required new_variances
-
-(* for typeclass.ml *)
-let compute_variance_decls env decls =
- let decls, required = List.split decls in
- let variances =
- List.map (fun (l,_) -> List.map (fun _ -> false, false, false) l) required
- in
- fst (compute_variance_fixpoint env decls required variances)
-
-(* Translate a set of mutually recursive type declarations *)
-let transl_type_decl env name_sdecl_list =
- (* Create identifiers. *)
- let id_list =
- List.map (fun (name, _) -> Ident.create name) name_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 env name_sdecl_list id_list in
- (* Translate each declaration. *)
- let decls =
- List.map2 (transl_declaration temp_env) name_sdecl_list id_list in
- (* Build the final env. *)
- let newenv =
- List.fold_right
- (fun (id, decl) env -> Env.add_type id decl env)
- decls env
- in
- (* Update stubs *)
- List.iter2
- (fun id (_, sdecl) -> update_type temp_env newenv id sdecl.ptype_loc)
- id_list name_sdecl_list;
- (* 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 name_sdecl_list
- in
- List.iter (check_abbrev_recursion newenv id_loc_list) decls;
- (* Check that all type variable are closed *)
- List.iter2
- (fun (_, sdecl) (id, decl) ->
- match Ctype.closed_type_decl decl with
- Some _ -> raise(Error(sdecl.ptype_loc, Unbound_type_var))
- | None -> ())
- name_sdecl_list decls;
- (* Check re-exportation *)
- List.iter2 (check_abbrev newenv) name_sdecl_list decls;
- (* Check that constraints are enforced *)
- List.iter2 (check_constraints newenv) name_sdecl_list decls;
- (* Add variances to the environment *)
- let required =
- List.map (fun (_, sdecl) -> sdecl.ptype_variance, sdecl.ptype_loc)
- name_sdecl_list
- in
- let final_decls, final_env =
- compute_variance_fixpoint env decls required
- (List.map
- (fun (_,decl) -> List.map (fun _ -> (false, false, false))
- decl.type_params)
- decls) in
- (* Done *)
- (final_decls, final_env)
-
-(* Translate an exception declaration *)
-let transl_exception env excdecl =
- reset_type_variables();
- Ctype.begin_def();
- let types = List.map (transl_simple_type env true) excdecl in
- Ctype.end_def();
- List.iter Ctype.generalize types;
- types
-
-(* Translate an exception rebinding *)
-let transl_exn_rebind env loc lid =
- let cdescr =
- try
- Env.lookup_constructor lid env
- with Not_found ->
- raise(Error(loc, Unbound_exception lid)) in
- match cdescr.cstr_tag with
- Cstr_exception path -> (path, cdescr.cstr_args)
- | _ -> raise(Error(loc, Not_an_exception lid))
-
-(* Translate a value declaration *)
-let transl_value_decl env valdecl =
- let ty = Typetexp.transl_type_scheme env valdecl.pval_type in
- match valdecl.pval_prim with
- [] ->
- { val_type = ty; val_kind = Val_reg }
- | decl ->
- let arity = Ctype.arity ty in
- if arity = 0 then
- raise(Error(valdecl.pval_type.ptyp_loc, Null_arity_external));
- let prim = Primitive.parse_declaration arity decl in
- if !Clflags.native_code
- && prim.prim_arity > 5
- && prim.prim_native_name = ""
- then raise(Error(valdecl.pval_type.ptyp_loc, Missing_native_external));
- { val_type = ty; val_kind = Val_prim prim }
-
-(* Translate a "with" constraint -- much simplified version of
- transl_type_decl. *)
-let transl_with_constraint env sdecl =
- reset_type_variables();
- Ctype.begin_def();
- let params =
- try
- List.map (enter_type_variable true sdecl.ptype_loc) sdecl.ptype_params
- with Already_bound ->
- raise(Error(sdecl.ptype_loc, Repeated_parameter)) in
- List.iter
- (function (ty, ty', loc) ->
- try
- Ctype.unify env (transl_simple_type env false ty)
- (transl_simple_type env false ty')
- with Ctype.Unify tr ->
- raise(Error(loc, Unconsistent_constraint tr)))
- sdecl.ptype_cstrs;
- let decl =
- { type_params = params;
- type_arity = List.length params;
- type_kind = Type_abstract;
- type_manifest =
- begin match sdecl.ptype_manifest with
- None -> None
- | Some sty -> Some(transl_simple_type env true sty)
- end;
- type_variance = [];
- }
- in
- if Ctype.closed_type_decl decl <> None then
- raise(Error(sdecl.ptype_loc, Unbound_type_var));
- let decl =
- {decl with type_variance =
- compute_variance_decl env decl (sdecl.ptype_variance, sdecl.ptype_loc)} in
- Ctype.end_def();
- generalize_decl decl;
- decl
-
-(* 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_manifest = None;
- type_variance = replicate_list (true, true, true) arity } in
- Ctype.end_def();
- generalize_decl decl;
- decl
-
-let approx_type_decl env name_sdecl_list =
- List.map
- (fun (name, sdecl) ->
- (Ident.create name,
- abstract_type_decl (List.length sdecl.ptype_params)))
- name_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. *)
- check_recursion env loc path decl
- (fun path -> List.mem (Path.head path) recmod_ids)
-
-
-(**** Error report ****)
-
-open Format
-
-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 non-constant constructors"
- (Config.max_tag + 1)
- | Duplicate_label s ->
- fprintf ppf "Two labels are named %s" s
- | Recursive_abbrev s ->
- fprintf ppf "The type abbreviation %s is cyclic" s
- | Definition_mismatch ty ->
- Printtyp.reset_and_mark_loops ty;
- fprintf ppf
- "The variant or record definition does not match that of type@ %a"
- Printtyp.type_expr ty
- | Constraint_failed (ty, ty') ->
- fprintf ppf "Constraints are not satisfied in this type.@.";
- Printtyp.reset_and_mark_loops ty;
- Printtyp.mark_loops ty';
- fprintf ppf "@[<hv>Type@ %a@ should be an instance of@ %a@]"
- 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
- "@[<hv>In the definition of %s, type@ %a@ should be@ %a@]"
- (Path.name path) Printtyp.type_expr ty Printtyp.type_expr ty'
- | Unconsistent_constraint trace ->
- fprintf ppf "The type constraints are not consistent.@.";
- Printtyp.report_unification_error ppf trace
- (fun ppf -> fprintf ppf "Type")
- (fun ppf -> fprintf ppf "is not compatible with type")
- | Type_clash trace ->
- Printtyp.report_unification_error ppf trace
- (function ppf ->
- fprintf ppf "This type constructor expands to type")
- (function ppf ->
- fprintf ppf "but is here used with type")
- | Null_arity_external ->
- fprintf ppf "External identifiers must be functions"
- | Missing_native_external ->
- fprintf ppf "@[<hv>An external function with more than 5 arguments \
- requires second stub function@ \
- for native-code compilation@]"
- | Unbound_type_var ->
- fprintf ppf "A type variable is unbound in this type declaration"
- | Unbound_exception lid ->
- fprintf ppf "Unbound exception constructor@ %a" Printtyp.longident lid
- | Not_an_exception lid ->
- fprintf ppf "The constructor@ %a@ is not an exception"
- Printtyp.longident lid
- | Bad_variance ->
- fprintf ppf
- "In this definition, expected parameter variances are not satisfied"
- | Unavailable_type_constructor p ->
- fprintf ppf "The definition of type %a@ is unavailable" Printtyp.path p
diff --git a/typing/typedecl.mli b/typing/typedecl.mli
deleted file mode 100644
index e5e723b760..0000000000
--- a/typing/typedecl.mli
+++ /dev/null
@@ -1,69 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Typing of type definitions and primitive definitions *)
-
-open Types
-open Format
-
-val transl_type_decl:
- Env.t -> (string * Parsetree.type_declaration) list ->
- (Ident.t * type_declaration) list * Env.t
-val transl_exception:
- Env.t -> Parsetree.exception_declaration -> exception_declaration
-
-val transl_exn_rebind:
- Env.t -> Location.t -> Longident.t -> Path.t * exception_declaration
-
-val transl_value_decl:
- Env.t -> Parsetree.value_description -> value_description
-
-val transl_with_constraint:
- Env.t -> Parsetree.type_declaration -> type_declaration
-
-val abstract_type_decl: int -> type_declaration
-val approx_type_decl:
- Env.t -> (string * 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
-
-(* for typeclass.ml *)
-val compute_variance_decls:
- Env.t ->
- ((Ident.t * type_declaration) * ((bool * bool) list * Location.t)) list ->
- (Ident.t * type_declaration) list
-
-type error =
- Repeated_parameter
- | Duplicate_constructor of string
- | Too_many_constructors
- | Duplicate_label of string
- | Recursive_abbrev of string
- | Definition_mismatch of type_expr
- | Constraint_failed of type_expr * type_expr
- | Unconsistent_constraint of (type_expr * type_expr) list
- | Type_clash of (type_expr * type_expr) list
- | Parameters_differ of Path.t * type_expr * type_expr
- | Null_arity_external
- | Missing_native_external
- | Unbound_type_var
- | Unbound_exception of Longident.t
- | Not_an_exception of Longident.t
- | Bad_variance
- | Unavailable_type_constructor of Path.t
-
-exception Error of Location.t * error
-
-val report_error: formatter -> error -> unit
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
deleted file mode 100644
index ab05b564dd..0000000000
--- a/typing/typedtree.ml
+++ /dev/null
@@ -1,228 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Abstract syntax tree after typing *)
-
-open Misc
-open Asttypes
-open Types
-
-(* Value expressions for the core language *)
-
-type pattern =
- { pat_desc: pattern_desc;
- pat_loc: Location.t;
- pat_type: type_expr;
- pat_env: Env.t }
-
-and pattern_desc =
- Tpat_any
- | Tpat_var of Ident.t
- | Tpat_alias of pattern * Ident.t
- | Tpat_constant of constant
- | Tpat_tuple of pattern list
- | Tpat_construct of constructor_description * pattern list
- | Tpat_variant of label * pattern option * row_desc
- | Tpat_record of (label_description * pattern) list
- | Tpat_array of pattern list
- | Tpat_or of pattern * pattern * Path.t option
-
-type partial = Partial | Total
-type optional = Required | Optional
-
-type expression =
- { exp_desc: expression_desc;
- exp_loc: Location.t;
- exp_type: type_expr;
- exp_env: Env.t }
-
-and expression_desc =
- Texp_ident of Path.t * value_description
- | Texp_constant of constant
- | Texp_let of rec_flag * (pattern * expression) list * expression
- | Texp_function of (pattern * expression) list * partial
- | Texp_apply of expression * (expression option * optional) list
- | Texp_match of expression * (pattern * expression) list * partial
- | Texp_try of expression * (pattern * expression) list
- | Texp_tuple of expression list
- | Texp_construct of constructor_description * expression list
- | Texp_variant of label * expression option
- | Texp_record of (label_description * expression) list * expression option
- | Texp_field of expression * label_description
- | Texp_setfield of expression * 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 * expression * expression * direction_flag * expression
- | Texp_when of expression * expression
- | Texp_send of expression * meth
- | Texp_new of Path.t * class_declaration
- | Texp_instvar of Path.t * Path.t
- | Texp_setinstvar of Path.t * Path.t * expression
- | Texp_override of Path.t * (Path.t * expression) list
- | Texp_letmodule of Ident.t * module_expr * expression
- | Texp_assert of expression
- | Texp_assertfalse
- | Texp_lazy of expression
- | Texp_object of class_structure * class_signature * string list
-
-and meth =
- Tmeth_name of string
- | Tmeth_val of Ident.t
-
-(* Value expressions for the class language *)
-
-and class_expr =
- { cl_desc: class_expr_desc;
- cl_loc: Location.t;
- cl_type: class_type;
- cl_env: Env.t }
-
-and class_expr_desc =
- Tclass_ident of Path.t
- | Tclass_structure of class_structure
- | Tclass_fun of pattern * (Ident.t * expression) list * class_expr * partial
- | Tclass_apply of class_expr * (expression option * optional) list
- | Tclass_let of rec_flag * (pattern * expression) list *
- (Ident.t * expression) list * class_expr
- | Tclass_constraint of class_expr * string list * string list * Concr.t
-
-and class_structure =
- { cl_field: class_field list;
- cl_meths: Ident.t Meths.t }
-
-and class_field =
- Cf_inher of class_expr * (string * Ident.t) list * (string * Ident.t) list
- | Cf_val of string * Ident.t * expression
- | Cf_meth of string * expression
- | Cf_let of rec_flag * (pattern * expression) list *
- (Ident.t * expression) list
- | Cf_init of expression
-
-(* Value expressions for the module language *)
-
-and module_expr =
- { mod_desc: module_expr_desc;
- mod_loc: Location.t;
- mod_type: module_type;
- mod_env: Env.t }
-
-and module_expr_desc =
- Tmod_ident of Path.t
- | Tmod_structure of structure
- | Tmod_functor of Ident.t * module_type * module_expr
- | Tmod_apply of module_expr * module_expr * module_coercion
- | Tmod_constraint of module_expr * module_type * module_coercion
-
-and structure = structure_item list
-
-and structure_item =
- Tstr_eval of expression
- | Tstr_value of rec_flag * (pattern * expression) list
- | Tstr_primitive of Ident.t * value_description
- | Tstr_type of (Ident.t * type_declaration) list
- | Tstr_exception of Ident.t * exception_declaration
- | Tstr_exn_rebind of Ident.t * Path.t
- | Tstr_module of Ident.t * module_expr
- | Tstr_recmodule of (Ident.t * module_expr) list
- | Tstr_modtype of Ident.t * module_type
- | Tstr_open of Path.t
- | Tstr_class of (Ident.t * int * string list * class_expr) list
- | Tstr_cltype of (Ident.t * cltype_declaration) list
- | Tstr_include of module_expr * Ident.t list
-
-and module_coercion =
- Tcoerce_none
- | Tcoerce_structure of (int * module_coercion) list
- | Tcoerce_functor of module_coercion * module_coercion
- | Tcoerce_primitive of Primitive.description
-
-(* Auxiliary functions over the a.s.t. *)
-
-let iter_pattern_desc f = function
- | Tpat_alias(p, id) -> f p
- | Tpat_tuple patl -> List.iter f patl
- | Tpat_construct(cstr, patl) -> List.iter f patl
- | Tpat_variant(_, pat, _) -> may f pat
- | Tpat_record lbl_pat_list ->
- List.iter (fun (lbl, pat) -> f pat) lbl_pat_list
- | Tpat_array patl -> List.iter f patl
- | Tpat_or(p1, p2, _) -> f p1; f p2
- | Tpat_any
- | Tpat_var _
- | Tpat_constant _ -> ()
-
-let map_pattern_desc f d =
- match d with
- | Tpat_alias (p1, id) ->
- Tpat_alias (f p1, id)
- | Tpat_tuple pats ->
- Tpat_tuple (List.map f pats)
- | Tpat_record lpats ->
- Tpat_record (List.map (fun (l,p) -> l, f p) lpats)
- | Tpat_construct (c,pats) ->
- Tpat_construct (c, List.map f pats)
- | Tpat_array pats ->
- Tpat_array (List.map f pats)
- | 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 list)
-
-let rec bound_idents pat =
- match pat.pat_desc with
- | Tpat_var id -> idents := id :: !idents
- | Tpat_alias(p, id) -> bound_idents p; idents := id :: !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 := []; res
-
-let rev_let_bound_idents pat_expr_list =
- idents := [];
- List.iter (fun (pat, expr) -> bound_idents pat) pat_expr_list;
- let res = !idents in idents := []; res
-
-let let_bound_idents pat_expr_list =
- List.rev(rev_let_bound_idents pat_expr_list)
-
-let alpha_var env id = List.assoc id env
-
-let rec alpha_pat env p = match p.pat_desc with
-| Tpat_var id -> (* note the ``Not_found'' case *)
- {p with pat_desc =
- try Tpat_var (alpha_var env id) with
- | Not_found -> Tpat_any}
-| Tpat_alias (p1, id) ->
- let new_p = alpha_pat env p1 in
- begin try
- {p with pat_desc = Tpat_alias (new_p, alpha_var env id)}
- with
- | Not_found -> new_p
- end
-| d ->
- {p with pat_desc = map_pattern_desc (alpha_pat env) d}
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
deleted file mode 100644
index 587b088741..0000000000
--- a/typing/typedtree.mli
+++ /dev/null
@@ -1,164 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Abstract syntax tree after typing *)
-
-open Asttypes
-open Types
-
-(* Value expressions for the core language *)
-
-type pattern =
- { pat_desc: pattern_desc;
- pat_loc: Location.t;
- pat_type: type_expr;
- pat_env: Env.t }
-
-and pattern_desc =
- Tpat_any
- | Tpat_var of Ident.t
- | Tpat_alias of pattern * Ident.t
- | Tpat_constant of constant
- | Tpat_tuple of pattern list
- | Tpat_construct of constructor_description * pattern list
- | Tpat_variant of label * pattern option * row_desc
- | Tpat_record of (label_description * pattern) list
- | Tpat_array of pattern list
- | Tpat_or of pattern * pattern * Path.t option
-
-type partial = Partial | Total
-type optional = Required | Optional
-
-type expression =
- { exp_desc: expression_desc;
- exp_loc: Location.t;
- exp_type: type_expr;
- exp_env: Env.t }
-
-and expression_desc =
- Texp_ident of Path.t * value_description
- | Texp_constant of constant
- | Texp_let of rec_flag * (pattern * expression) list * expression
- | Texp_function of (pattern * expression) list * partial
- | Texp_apply of expression * (expression option * optional) list
- | Texp_match of expression * (pattern * expression) list * partial
- | Texp_try of expression * (pattern * expression) list
- | Texp_tuple of expression list
- | Texp_construct of constructor_description * expression list
- | Texp_variant of label * expression option
- | Texp_record of (label_description * expression) list * expression option
- | Texp_field of expression * label_description
- | Texp_setfield of expression * 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 * expression * expression * direction_flag * expression
- | Texp_when of expression * expression
- | Texp_send of expression * meth
- | Texp_new of Path.t * class_declaration
- | Texp_instvar of Path.t * Path.t
- | Texp_setinstvar of Path.t * Path.t * expression
- | Texp_override of Path.t * (Path.t * expression) list
- | Texp_letmodule of Ident.t * module_expr * expression
- | Texp_assert of expression
- | Texp_assertfalse
- | Texp_lazy of expression
- | Texp_object of class_structure * class_signature * string list
-
-and meth =
- Tmeth_name of string
- | Tmeth_val of Ident.t
-
-(* Value expressions for the class language *)
-
-and class_expr =
- { cl_desc: class_expr_desc;
- cl_loc: Location.t;
- cl_type: class_type;
- cl_env: Env.t }
-
-and class_expr_desc =
- Tclass_ident of Path.t
- | Tclass_structure of class_structure
- | Tclass_fun of pattern * (Ident.t * expression) list * class_expr * partial
- | Tclass_apply of class_expr * (expression option * optional) list
- | Tclass_let of rec_flag * (pattern * expression) list *
- (Ident.t * expression) list * class_expr
- | Tclass_constraint of class_expr * string list * string list * Concr.t
- (* Visible instance variables, methods and concretes methods *)
-
-and class_structure =
- { cl_field: class_field list;
- cl_meths: Ident.t Meths.t }
-
-and class_field =
- Cf_inher of class_expr * (string * Ident.t) list * (string * Ident.t) list
- (* Inherited instance variables and concrete methods *)
- | Cf_val of string * Ident.t * expression
- | Cf_meth of string * expression
- | Cf_let of rec_flag * (pattern * expression) list *
- (Ident.t * expression) list
- | Cf_init of expression
-
-(* Value expressions for the module language *)
-
-and module_expr =
- { mod_desc: module_expr_desc;
- mod_loc: Location.t;
- mod_type: module_type;
- mod_env: Env.t }
-
-and module_expr_desc =
- Tmod_ident of Path.t
- | Tmod_structure of structure
- | Tmod_functor of Ident.t * module_type * module_expr
- | Tmod_apply of module_expr * module_expr * module_coercion
- | Tmod_constraint of module_expr * module_type * module_coercion
-
-and structure = structure_item list
-
-and structure_item =
- Tstr_eval of expression
- | Tstr_value of rec_flag * (pattern * expression) list
- | Tstr_primitive of Ident.t * value_description
- | Tstr_type of (Ident.t * type_declaration) list
- | Tstr_exception of Ident.t * exception_declaration
- | Tstr_exn_rebind of Ident.t * Path.t
- | Tstr_module of Ident.t * module_expr
- | Tstr_recmodule of (Ident.t * module_expr) list
- | Tstr_modtype of Ident.t * module_type
- | Tstr_open of Path.t
- | Tstr_class of (Ident.t * int * string list * class_expr) list
- | Tstr_cltype of (Ident.t * cltype_declaration) list
- | Tstr_include of module_expr * Ident.t list
-
-and module_coercion =
- Tcoerce_none
- | Tcoerce_structure of (int * module_coercion) list
- | Tcoerce_functor of module_coercion * module_coercion
- | Tcoerce_primitive of Primitive.description
-
-(* 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: (pattern * expression) list -> Ident.t list
-val rev_let_bound_idents: (pattern * expression) list -> Ident.t list
-
-(* Alpha conversion of patterns *)
-val alpha_pat : (Ident.t * Ident.t) list -> pattern -> pattern
-
diff --git a/typing/typemod.ml b/typing/typemod.ml
deleted file mode 100644
index 00e87b60e3..0000000000
--- a/typing/typemod.ml
+++ /dev/null
@@ -1,842 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Type-checking of the module language *)
-
-open Misc
-open Longident
-open Path
-open Parsetree
-open Types
-open Typedtree
-open Format
-
-type error =
- Unbound_module of Longident.t
- | Unbound_modtype of Longident.t
- | 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
-
-exception Error of Location.t * error
-
-(* Extract a signature from a module type *)
-
-let extract_sig env loc mty =
- match Mtype.scrape env mty with
- Tmty_signature sg -> sg
- | _ -> raise(Error(loc, Signature_expected))
-
-let extract_sig_open env loc mty =
- match Mtype.scrape env mty with
- Tmty_signature sg -> sg
- | _ -> raise(Error(loc, Structure_expected mty))
-
-(* Lookup the type of a module path *)
-
-let type_module_path env loc lid =
- try
- Env.lookup_module lid env
- with Not_found ->
- raise(Error(loc, Unbound_module lid))
-
-(* Record a module type *)
-let rm node =
- Stypes.record (Stypes.Ti_mod node);
- node
-
-(* Merge one "with" constraint in a signature *)
-
-let merge_constraint initial_env loc sg lid constr =
- let rec merge env sg namelist =
- match (sg, namelist, constr) with
- ([], _, _) ->
- raise(Error(loc, With_no_component lid))
- | (Tsig_type(id, decl) :: rem, [s], Pwith_type sdecl)
- when Ident.name id = s ->
- let newdecl = Typedecl.transl_with_constraint initial_env sdecl in
- Includemod.type_declarations env id newdecl decl;
- Tsig_type(id, newdecl) :: rem
- | (Tsig_module(id, mty) :: rem, [s], Pwith_module lid)
- when Ident.name id = s ->
- let (path, mty') = type_module_path initial_env loc lid in
- let newmty = Mtype.strengthen env mty' path in
- ignore(Includemod.modtypes env newmty mty);
- Tsig_module(id, newmty) :: rem
- | (Tsig_module(id, mty) :: rem, s :: namelist, _) when Ident.name id = s ->
- let newsg = merge env (extract_sig env loc mty) namelist in
- Tsig_module(id, Tmty_signature newsg) :: rem
- | (item :: rem, _, _) ->
- item :: merge (Env.add_item item env) rem namelist in
- try
- merge initial_env sg (Longident.flatten lid)
- with Includemod.Error explanation ->
- raise(Error(loc, With_mismatch(lid, explanation)))
-
-(* 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 approx_modtype transl_mty init_env smty =
-
- let rec approx_mty env smty =
- match smty.pmty_desc with
- Pmty_ident lid ->
- begin try
- let (path, info) = Env.lookup_modtype lid env in
- Tmty_ident path
- with Not_found ->
- raise(Error(smty.pmty_loc, Unbound_modtype lid))
- end
- | Pmty_signature ssg ->
- Tmty_signature(approx_sig env ssg)
- | Pmty_functor(param, sarg, sres) ->
- let arg = approx_mty env sarg in
- let (id, newenv) = Env.enter_module param arg env in
- let res = approx_mty newenv sres in
- Tmty_functor(id, arg, res)
- | Pmty_with(sbody, constraints) ->
- approx_mty env sbody
-
- and approx_sig env ssg =
- match ssg with
- [] -> []
- | item :: srem ->
- match item.psig_desc with
- | Psig_type sdecls ->
- let decls = Typedecl.approx_type_decl env sdecls in
- let rem = approx_sig env srem in
- map_end (fun (id, info) -> Tsig_type(id, info)) decls rem
- | Psig_module(name, smty) ->
- let mty = approx_mty env smty in
- let (id, newenv) = Env.enter_module name mty env in
- Tsig_module(id, mty) :: approx_sig newenv srem
- | Psig_recmodule sdecls ->
- let decls =
- List.map
- (fun (name, smty) ->
- (Ident.create name, approx_mty env smty))
- sdecls in
- let newenv =
- List.fold_left (fun env (id, mty) -> Env.add_module id mty env)
- env decls in
- map_end (fun (id, mty) -> Tsig_module(id, mty)) decls
- (approx_sig newenv srem)
- | Psig_modtype(name, sinfo) ->
- let info = approx_mty_info env sinfo in
- let (id, newenv) = Env.enter_modtype name info env in
- Tsig_modtype(id, info) :: approx_sig newenv srem
- | Psig_open lid ->
- let (path, mty) = type_module_path env item.psig_loc lid in
- let sg = extract_sig_open env item.psig_loc mty in
- let newenv = Env.open_signature path sg env in
- approx_sig newenv srem
- | Psig_include smty ->
- let mty = transl_mty init_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
- (List.map
- (fun (i1, d1, i2, d2, i3, d3) ->
- [Tsig_cltype(i1, d1); Tsig_type(i2, d2); Tsig_type(i3, d3)])
- decls)
- @ rem
- | _ ->
- approx_sig env srem
-
- and approx_mty_info env sinfo =
- match sinfo with
- Pmodtype_abstract ->
- Tmodtype_abstract
- | Pmodtype_manifest smty ->
- Tmodtype_manifest(approx_mty env smty)
-
- in approx_mty init_env smty
-
-(* Additional validity checks on type definitions arising from
- recursive modules *)
-
-let check_recmod_typedecls env sdecls decls =
- let recmod_ids = List.map fst decls in
- List.iter2
- (fun (_, smty) (id, mty) ->
- List.iter
- (fun path ->
- Typedecl.check_recmod_typedecl env smty.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 = compare end)
-
-let check cl loc set_ref name =
- if StringSet.mem name !set_ref
- then raise(Error(loc, Repeated_name(cl, name)))
- else set_ref := StringSet.add name !set_ref
-
-let check_sig_item type_names module_names modtype_names loc = function
- Tsig_type(id, _) ->
- check "type" loc type_names (Ident.name id)
- | Tsig_module(id, _) ->
- check "module" loc module_names (Ident.name id)
- | Tsig_modtype(id, _) ->
- check "module type" loc modtype_names (Ident.name id)
- | _ -> ()
-
-(* Check and translate a module type expression *)
-
-let rec transl_modtype env smty =
- match smty.pmty_desc with
- Pmty_ident lid ->
- begin try
- let (path, info) = Env.lookup_modtype lid env in
- Tmty_ident path
- with Not_found ->
- raise(Error(smty.pmty_loc, Unbound_modtype lid))
- end
- | Pmty_signature ssg ->
- Tmty_signature(transl_signature env ssg)
- | Pmty_functor(param, sarg, sres) ->
- let arg = transl_modtype env sarg in
- let (id, newenv) = Env.enter_module param arg env in
- let res = transl_modtype newenv sres in
- Tmty_functor(id, arg, res)
- | Pmty_with(sbody, constraints) ->
- let body = transl_modtype env sbody in
- let init_sg = extract_sig env sbody.pmty_loc body in
- let final_sg =
- List.fold_left
- (fun sg (lid, sdecl) ->
- merge_constraint env smty.pmty_loc sg lid sdecl)
- init_sg constraints in
- Tmty_signature final_sg
-
-and transl_signature env sg =
- let type_names = ref StringSet.empty
- and module_names = ref StringSet.empty
- and modtype_names = ref StringSet.empty in
- let rec transl_sig env sg =
- Ctype.init_def(Ident.current_time());
- match sg with
- [] -> []
- | item :: srem ->
- match item.psig_desc with
- | Psig_value(name, sdesc) ->
- let desc = Typedecl.transl_value_decl env sdesc in
- let (id, newenv) = Env.enter_value name desc env in
- let rem = transl_sig newenv srem in
- Tsig_value(id, desc) :: rem
- | Psig_type sdecls ->
- List.iter
- (fun (name, decl) -> check "type" item.psig_loc type_names name)
- sdecls;
- let (decls, newenv) = Typedecl.transl_type_decl env sdecls in
- let rem = transl_sig newenv srem in
- map_end (fun (id, info) -> Tsig_type(id, info)) decls rem
- | Psig_exception(name, sarg) ->
- let arg = Typedecl.transl_exception env sarg in
- let (id, newenv) = Env.enter_exception name arg env in
- let rem = transl_sig newenv srem in
- Tsig_exception(id, arg) :: rem
- | Psig_module(name, smty) ->
- check "module" item.psig_loc module_names name;
- let mty = transl_modtype env smty in
- let (id, newenv) = Env.enter_module name mty env in
- let rem = transl_sig newenv srem in
- Tsig_module(id, mty) :: rem
- | Psig_recmodule sdecls ->
- List.iter
- (fun (name, smty) ->
- check "module" item.psig_loc module_names name)
- sdecls;
- let (decls, newenv) =
- transl_recmodule_modtypes item.psig_loc env sdecls in
- let rem = transl_sig newenv srem in
- map_end (fun (id, mty) -> Tsig_module(id, mty)) decls rem
- | Psig_modtype(name, sinfo) ->
- check "module type" item.psig_loc modtype_names name;
- let info = transl_modtype_info env sinfo in
- let (id, newenv) = Env.enter_modtype name info env in
- let rem = transl_sig newenv srem in
- Tsig_modtype(id, info) :: rem
- | Psig_open lid ->
- let (path, mty) = type_module_path env item.psig_loc lid in
- let sg = extract_sig_open env item.psig_loc mty in
- let newenv = Env.open_signature path sg env in
- transl_sig newenv srem
- | Psig_include smty ->
- let mty = transl_modtype env smty in
- let sg = Subst.signature Subst.identity
- (extract_sig env smty.pmty_loc mty) in
- List.iter
- (check_sig_item type_names module_names modtype_names
- item.psig_loc)
- sg;
- let newenv = Env.add_signature sg env in
- let rem = transl_sig newenv srem in
- sg @ rem
- | Psig_class cl ->
- List.iter
- (fun {pci_name = name} ->
- check "type" item.psig_loc type_names name)
- cl;
- let (classes, newenv) = Typeclass.class_descriptions env cl in
- let rem = transl_sig newenv srem in
- List.flatten
- (map_end
- (fun (i, d, i', d', i'', d'', i''', d''', _, _, _) ->
- [Tsig_class(i, d); Tsig_cltype(i', d');
- Tsig_type(i'', d''); Tsig_type(i''', d''')])
- classes [rem])
- | Psig_class_type cl ->
- List.iter
- (fun {pci_name = name} ->
- check "type" item.psig_loc type_names name)
- cl;
- let (classes, newenv) = Typeclass.class_type_declarations env cl in
- let rem = transl_sig newenv srem in
- List.flatten
- (map_end
- (fun (i, d, i', d', i'', d'') ->
- [Tsig_cltype(i, d);
- Tsig_type(i', d'); Tsig_type(i'', d'')])
- classes [rem])
- in transl_sig env sg
-
-and transl_modtype_info env sinfo =
- match sinfo with
- Pmodtype_abstract ->
- Tmodtype_abstract
- | Pmodtype_manifest smty ->
- Tmodtype_manifest(transl_modtype env smty)
-
-and transl_recmodule_modtypes loc env sdecls =
- let make_env curr =
- List.fold_left
- (fun env (id, mty) -> Env.add_module id mty env)
- env curr in
- let transition env_c curr =
- List.map2
- (fun (_, smty) (id, mty) -> (id, transl_modtype env_c smty))
- sdecls curr in
- let init =
- List.map
- (fun (name, smty) ->
- (Ident.create name, approx_modtype transl_modtype env smty))
- sdecls in
- let first = transition (make_env init) init in
- let final_env = make_env first in
- let final_decl = transition final_env init in
- check_recmod_typedecls final_env sdecls final_decl;
- (final_decl, final_env)
-
-(* 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) ->
- Papply(path_of_module funct, path_of_module arg)
- | _ -> raise Not_a_path
-
-(* Check that all core type schemes in a structure are closed *)
-
-let rec closed_modtype = function
- Tmty_ident p -> true
- | Tmty_signature sg -> List.for_all closed_signature_item sg
- | Tmty_functor(id, param, body) -> closed_modtype body
-
-and closed_signature_item = function
- Tsig_value(id, desc) -> Ctype.closed_schema desc.val_type
- | Tsig_module(id, mty) -> closed_modtype mty
- | _ -> true
-
-let check_nongen_scheme env = function
- Tstr_value(rec_flag, pat_exp_list) ->
- List.iter
- (fun (pat, exp) ->
- if not (Ctype.closed_schema exp.exp_type) then
- raise(Error(exp.exp_loc, Non_generalizable exp.exp_type)))
- pat_exp_list
- | Tstr_module(id, md) ->
- if not (closed_modtype md.mod_type) then
- raise(Error(md.mod_loc, Non_generalizable_module md.mod_type))
- | _ -> ()
-
-let check_nongen_schemes env str =
- List.iter (check_nongen_scheme env) str
-
-(* Extract the list of "value" identifiers bound by a signature.
- "Value" identifiers are identifiers for signature components that
- correspond to a run-time value: values, exceptions, modules, classes.
- Note: manifest primitives do not correspond to a run-time value! *)
-
-let rec bound_value_identifiers = function
- [] -> []
- | Tsig_value(id, {val_kind = Val_reg}) :: rem ->
- id :: bound_value_identifiers rem
- | Tsig_exception(id, decl) :: rem -> id :: bound_value_identifiers rem
- | Tsig_module(id, mty) :: rem -> id :: bound_value_identifiers rem
- | Tsig_class(id, decl) :: rem -> id :: bound_value_identifiers rem
- | _ :: rem -> bound_value_identifiers rem
-
-(* 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 anchor =
- Some (Pident id)
-
-let enrich_type_decls anchor decls oldenv newenv =
- match anchor with
- None -> newenv
- | Some p ->
- List.fold_left
- (fun e (id, info) ->
- let info' =
- Mtype.enrich_typedecl oldenv (Pdot(p, Ident.name id, nopos)) info
- in
- Env.add_type 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
-
-(* Type a module value expression *)
-
-let rec type_module anchor env smod =
- match smod.pmod_desc with
- Pmod_ident lid ->
- let (path, mty) = type_module_path env smod.pmod_loc lid in
- rm { mod_desc = Tmod_ident path;
- mod_type = Mtype.strengthen env mty path;
- mod_env = env;
- mod_loc = smod.pmod_loc }
- | Pmod_structure sstr ->
- let (str, sg, finalenv) = type_structure anchor env sstr in
- rm { mod_desc = Tmod_structure str;
- mod_type = Tmty_signature sg;
- mod_env = env;
- mod_loc = smod.pmod_loc }
- | Pmod_functor(name, smty, sbody) ->
- let mty = transl_modtype env smty in
- let (id, newenv) = Env.enter_module name mty env in
- let body = type_module None newenv sbody in
- rm { mod_desc = Tmod_functor(id, mty, body);
- mod_type = Tmty_functor(id, mty, body.mod_type);
- mod_env = env;
- mod_loc = smod.pmod_loc }
- | Pmod_apply(sfunct, sarg) ->
- let funct = type_module None env sfunct in
- let arg = type_module None env sarg in
- begin match Mtype.scrape env funct.mod_type with
- Tmty_functor(param, mty_param, mty_res) as mty_functor ->
- let coercion =
- try
- Includemod.modtypes env arg.mod_type mty_param
- with Includemod.Error msg ->
- raise(Error(sarg.pmod_loc, Not_included msg)) in
- let mty_appl =
- try
- let path = path_of_module arg in
- Subst.modtype (Subst.add_module param path Subst.identity)
- mty_res
- with Not_a_path ->
- try
- Mtype.nondep_supertype
- (Env.add_module param arg.mod_type env) param mty_res
- with Not_found ->
- raise(Error(smod.pmod_loc,
- Cannot_eliminate_dependency mty_functor)) in
- rm { mod_desc = Tmod_apply(funct, arg, coercion);
- mod_type = mty_appl;
- mod_env = env;
- mod_loc = smod.pmod_loc }
- | _ ->
- raise(Error(sfunct.pmod_loc, Cannot_apply funct.mod_type))
- end
- | Pmod_constraint(sarg, smty) ->
- let arg = type_module anchor env sarg in
- let mty = transl_modtype env smty in
- let coercion =
- try
- Includemod.modtypes env arg.mod_type mty
- with Includemod.Error msg ->
- raise(Error(sarg.pmod_loc, Not_included msg)) in
- rm { mod_desc = Tmod_constraint(arg, mty, coercion);
- mod_type = mty;
- mod_env = env;
- mod_loc = smod.pmod_loc }
-
-and type_structure anchor env sstr =
- let type_names = ref StringSet.empty
- and module_names = ref StringSet.empty
- and modtype_names = ref StringSet.empty in
- let rec type_struct env sstr =
- Ctype.init_def(Ident.current_time());
- match sstr with
- [] ->
- ([], [], env)
- | {pstr_desc = Pstr_eval sexpr} :: srem ->
- let expr = Typecore.type_expression env sexpr in
- let (str_rem, sig_rem, final_env) = type_struct env srem in
- (Tstr_eval expr :: str_rem, sig_rem, final_env)
- | {pstr_desc = Pstr_value(rec_flag, sdefs)} :: srem ->
- let (defs, newenv) =
- Typecore.type_binding env rec_flag sdefs in
- let (str_rem, sig_rem, final_env) = type_struct newenv srem in
- let bound_idents = let_bound_idents defs in
- let make_sig_value id =
- Tsig_value(id, Env.find_value (Pident id) newenv) in
- (Tstr_value(rec_flag, defs) :: str_rem,
- map_end make_sig_value bound_idents sig_rem,
- final_env)
- | {pstr_desc = Pstr_primitive(name, sdesc)} :: srem ->
- let desc = Typedecl.transl_value_decl env sdesc in
- let (id, newenv) = Env.enter_value name desc env in
- let (str_rem, sig_rem, final_env) = type_struct newenv srem in
- (Tstr_primitive(id, desc) :: str_rem,
- Tsig_value(id, desc) :: sig_rem,
- final_env)
- | {pstr_desc = Pstr_type sdecls; pstr_loc = loc} :: srem ->
- List.iter
- (fun (name, decl) -> check "type" loc type_names name)
- sdecls;
- let (decls, newenv) = Typedecl.transl_type_decl env sdecls in
- let newenv' =
- enrich_type_decls anchor decls env newenv in
- let (str_rem, sig_rem, final_env) = type_struct newenv' srem in
- (Tstr_type decls :: str_rem,
- map_end (fun (id, info) -> Tsig_type(id, info)) decls sig_rem,
- final_env)
- | {pstr_desc = Pstr_exception(name, sarg)} :: srem ->
- let arg = Typedecl.transl_exception env sarg in
- let (id, newenv) = Env.enter_exception name arg env in
- let (str_rem, sig_rem, final_env) = type_struct newenv srem in
- (Tstr_exception(id, arg) :: str_rem,
- Tsig_exception(id, arg) :: sig_rem,
- final_env)
- | {pstr_desc = Pstr_exn_rebind(name, longid); pstr_loc = loc} :: srem ->
- let (path, arg) = Typedecl.transl_exn_rebind env loc longid in
- let (id, newenv) = Env.enter_exception name arg env in
- let (str_rem, sig_rem, final_env) = type_struct newenv srem in
- (Tstr_exn_rebind(id, path) :: str_rem,
- Tsig_exception(id, arg) :: sig_rem,
- final_env)
- | {pstr_desc = Pstr_module(name, smodl); pstr_loc = loc} :: srem ->
- check "module" loc module_names name;
- let modl = type_module (anchor_submodule name anchor) env smodl in
- let mty = enrich_module_type anchor name modl.mod_type env in
- let (id, newenv) = Env.enter_module name mty env in
- let (str_rem, sig_rem, final_env) = type_struct newenv srem in
- (Tstr_module(id, modl) :: str_rem,
- Tsig_module(id, modl.mod_type) :: sig_rem,
- final_env)
- | {pstr_desc = Pstr_recmodule sbind; pstr_loc = loc} :: srem ->
- List.iter
- (fun (name, _, _) -> check "module" loc module_names name)
- sbind;
- let (decls, newenv) =
- transl_recmodule_modtypes loc env
- (List.map (fun (name, smty, smodl) -> (name, smty)) sbind) in
- let type_recmodule_binding (id, mty) (name, smty, smodl) =
- let modl =
- type_module (anchor_recmodule id anchor) newenv smodl in
- let coercion =
- try
- Includemod.modtypes newenv
- (Mtype.strengthen env modl.mod_type (Pident id))
- mty
- with Includemod.Error msg ->
- raise(Error(smodl.pmod_loc, Not_included msg)) in
- let modl' =
- { mod_desc = Tmod_constraint(modl, mty, coercion);
- mod_type = mty;
- mod_env = newenv;
- mod_loc = smodl.pmod_loc } in
- (id, modl') in
- let bind = List.map2 type_recmodule_binding decls sbind in
- let (str_rem, sig_rem, final_env) = type_struct newenv srem in
- (Tstr_recmodule bind :: str_rem,
- map_end (fun (id, modl) -> Tsig_module(id, modl.mod_type))
- bind sig_rem,
- final_env)
- | {pstr_desc = Pstr_modtype(name, smty); pstr_loc = loc} :: srem ->
- check "module type" loc modtype_names name;
- let mty = transl_modtype env smty in
- let (id, newenv) = Env.enter_modtype name (Tmodtype_manifest mty) env in
- let (str_rem, sig_rem, final_env) = type_struct newenv srem in
- (Tstr_modtype(id, mty) :: str_rem,
- Tsig_modtype(id, Tmodtype_manifest mty) :: sig_rem,
- final_env)
- | {pstr_desc = Pstr_open lid; pstr_loc = loc} :: srem ->
- let (path, mty) = type_module_path env loc lid in
- let sg = extract_sig_open env loc mty in
- type_struct (Env.open_signature path sg env) srem
- | {pstr_desc = Pstr_class cl; pstr_loc = loc} :: srem ->
- List.iter
- (fun {pci_name = name} -> check "type" loc type_names name)
- cl;
- let (classes, new_env) = Typeclass.class_declarations env cl in
- let (str_rem, sig_rem, final_env) = type_struct new_env srem in
- (Tstr_class
- (List.map (fun (i, _,_,_,_,_,_,_, s, m, c) ->
- (i, s, m, c)) classes) ::
- Tstr_cltype
- (List.map (fun (_,_, i, d, _,_,_,_,_,_,_) -> (i, d)) classes) ::
- Tstr_type
- (List.map (fun (_,_,_,_, i, d, _,_,_,_,_) -> (i, d)) classes) ::
- Tstr_type
- (List.map (fun (_,_,_,_,_,_, i, d, _,_,_) -> (i, d)) classes) ::
- str_rem,
- List.flatten
- (map_end
- (fun (i, d, i', d', i'', d'', i''', d''', _, _, _) ->
- [Tsig_class(i, d); Tsig_cltype(i', d');
- Tsig_type(i'', d''); Tsig_type(i''', d''')])
- classes [sig_rem]),
- final_env)
- | {pstr_desc = Pstr_class_type cl; pstr_loc = loc} :: srem ->
- List.iter
- (fun {pci_name = name} -> check "type" loc type_names name)
- cl;
- let (classes, new_env) = Typeclass.class_type_declarations env cl in
- let (str_rem, sig_rem, final_env) = type_struct new_env srem in
- (Tstr_cltype
- (List.map (fun (i, d, _, _, _, _) -> (i, d)) classes) ::
- Tstr_type
- (List.map (fun (_, _, i, d, _, _) -> (i, d)) classes) ::
- Tstr_type
- (List.map (fun (_, _, _, _, i, d) -> (i, d)) classes) ::
- str_rem,
- List.flatten
- (map_end
- (fun (i, d, i', d', i'', d'') ->
- [Tsig_cltype(i, d); Tsig_type(i', d'); Tsig_type(i'', d'')])
- classes [sig_rem]),
- final_env)
- | {pstr_desc = Pstr_include smodl; pstr_loc = loc} :: srem ->
- let modl = type_module 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 type_names module_names modtype_names loc) sg;
- let new_env = Env.add_signature sg env in
- let (str_rem, sig_rem, final_env) = type_struct new_env srem in
- (Tstr_include (modl, bound_value_identifiers sg) :: str_rem,
- sg @ sig_rem,
- final_env)
- in
- if !Clflags.save_types
- then List.iter (function {pstr_loc = l} -> Stypes.record_phrase l) sstr;
- type_struct env sstr
-
-let type_module = type_module None
-let type_structure = type_structure None
-
-(* Fill in the forward declaration *)
-let _ =
- Typecore.type_module := type_module
-
-(* Normalize types in a signature *)
-
-let rec normalize_modtype env = function
- Tmty_ident p -> ()
- | Tmty_signature sg -> normalize_signature env sg
- | Tmty_functor(id, param, body) -> normalize_modtype env body
-
-and normalize_signature env = List.iter (normalize_signature_item env)
-
-and normalize_signature_item env = function
- Tsig_value(id, desc) -> Ctype.normalize_type env desc.val_type
- | Tsig_module(id, mty) -> normalize_modtype env mty
- | _ -> ()
-
-(* Simplify multiple specifications of a value or an exception 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 rec simplify_modtype mty =
- match mty with
- Tmty_ident path -> mty
- | Tmty_functor(id, arg, res) -> Tmty_functor(id, arg, simplify_modtype res)
- | Tmty_signature sg -> Tmty_signature(simplify_signature sg)
-
-and simplify_signature sg =
- let rec simplif val_names exn_names res = function
- [] -> res
- | (Tsig_value(id, descr) as component) :: sg ->
- let name = Ident.name id in
- simplif (StringSet.add name val_names) exn_names
- (if StringSet.mem name val_names then res else component :: res)
- sg
- | (Tsig_exception(id, decl) as component) :: sg ->
- let name = Ident.name id in
- simplif val_names (StringSet.add name exn_names)
- (if StringSet.mem name exn_names then res else component :: res)
- sg
- | Tsig_module(id, mty) :: sg ->
- simplif val_names exn_names
- (Tsig_module(id, simplify_modtype mty) :: res) sg
- | component :: sg ->
- simplif val_names exn_names (component :: res) sg
- in
- simplif StringSet.empty StringSet.empty [] (List.rev sg)
-
-(* Typecheck an implementation file *)
-
-let type_implementation sourcefile prefixname modulename initial_env ast =
- Typecore.reset_delayed_checks ();
- let (str, sg, finalenv) =
- Misc.try_finally (fun () -> type_structure initial_env ast)
- (fun () -> Stypes.dump (prefixname ^ ".annot"))
- in
- Typecore.force_delayed_checks ();
- if !Clflags.print_types then begin
- fprintf std_formatter "%a@." Printtyp.signature (simplify_signature sg);
- (str, Tcoerce_none)
- end else begin
- let coercion =
- if Sys.file_exists (prefixname ^ !Config.interface_suffix) then begin
- let intf_file =
- try find_in_path !Config.load_path (prefixname ^ ".cmi")
- with Not_found -> prefixname ^ ".cmi" in
- let dclsig = Env.read_signature modulename intf_file in
- Includemod.compunit sourcefile sg intf_file dclsig
- end else begin
- check_nongen_schemes finalenv str;
- normalize_signature finalenv sg;
- if not !Clflags.dont_write_files then
- Env.save_signature sg modulename (prefixname ^ ".cmi");
- Tcoerce_none
- end in
- (str, coercion)
- end
-
-(* "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
- Tsig_module(newid, Tmty_signature sg') ::
- package_signatures (Subst.add_module oldid (Pident newid) subst) rem
-
-let package_units objfiles cmifile modulename =
- (* Read the signatures of the units *)
- let units =
- List.map
- (fun f ->
- let pref = chop_extension_if_any f in
- let modname = String.capitalize(Filename.basename pref) in
- (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 mlifile =
- chop_extension_if_any cmifile ^ !Config.interface_suffix in
- if Sys.file_exists mlifile then begin
- let dclsig = Env.read_signature modulename cmifile in
- Includemod.compunit "(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.imported_units()) in
- (* Write packaged signature *)
- Env.save_signature_with_imports sg modulename cmifile imports;
- Tcoerce_none
- end
-
-(* Error report *)
-
-open Printtyp
-
-let report_error ppf = function
- | Unbound_module lid -> fprintf ppf "Unbound module %a" longident lid
- | Unbound_modtype lid -> fprintf ppf "Unbound module type %a" longident lid
- | Cannot_apply mty ->
- fprintf ppf
- "@[This module is not a functor; it has type@ %a@]" modtype mty
- | Not_included errs ->
- fprintf ppf
- "@[<v>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
- "@[<v>\
- @[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
diff --git a/typing/typemod.mli b/typing/typemod.mli
deleted file mode 100644
index 63f1f6614c..0000000000
--- a/typing/typemod.mli
+++ /dev/null
@@ -1,54 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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 -> Typedtree.structure * signature * Env.t
-val type_implementation:
- string -> string -> string -> Env.t -> Parsetree.structure ->
- Typedtree.structure * Typedtree.module_coercion
-val transl_signature:
- Env.t -> Parsetree.signature -> signature
-val check_nongen_schemes:
- Env.t -> Typedtree.structure -> unit
-
-val simplify_signature: signature -> signature
-
-val package_units:
- string list -> string -> string -> Typedtree.module_coercion
-
-type error =
- Unbound_module of Longident.t
- | Unbound_modtype of Longident.t
- | 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
-
-exception Error of Location.t * error
-
-val report_error: formatter -> error -> unit
diff --git a/typing/types.ml b/typing/types.ml
deleted file mode 100644
index 81efda3b83..0000000000
--- a/typing/types.ml
+++ /dev/null
@@ -1,193 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Representation of types and declarations *)
-
-open Misc
-open Asttypes
-
-(* Type expressions for the core language *)
-
-type type_expr =
- { mutable desc: type_desc;
- mutable level: int;
- mutable id: int }
-
-and type_desc =
- Tvar
- | Tarrow of 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
- | Tvariant of row_desc
- | Tunivar
- | Tpoly of type_expr * type_expr list
-
-and row_desc =
- { row_fields: (label * row_field) list;
- row_more: type_expr;
- row_bound: type_expr list;
- 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
- | Rabsent
-
-and abbrev_memo =
- Mnil
- | Mcons of 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 = compare 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 }
-
-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 * type_expr) Vars.t ref *
- string * type_expr
- (* Self *)
- | Val_anc of (string * Ident.t) list * string
- (* Ancestor *)
- | Val_unbound (* Unbound variable *)
-
-(* Constructor descriptions *)
-
-type constructor_description =
- { cstr_res: type_expr; (* Type of the result *)
- 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_private: private_flag } (* Read-only constructor? *)
-
-and constructor_tag =
- Cstr_constant of int (* Constant constructor (an int) *)
- | Cstr_block of int (* Regular constructor (a block) *)
- | Cstr_exception of Path.t (* Exception constructor *)
-
-(* Record label descriptions *)
-
-type label_description =
- { 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? *)
-
-and record_representation =
- Record_regular (* All fields are boxed / tagged *)
- | Record_float (* All fields are floats *)
-
-(* Type definitions *)
-
-type type_declaration =
- { type_params: type_expr list;
- type_arity: int;
- type_kind: type_kind;
- type_manifest: type_expr option;
- type_variance: (bool * bool * bool) list }
-
-and type_kind =
- Type_abstract
- | Type_variant of (string * type_expr list) list * private_flag
- | Type_record of (string * mutable_flag * type_expr) list
- * record_representation * private_flag
-
-type exception_declaration = type_expr list
-
-(* Type expressions for the class language *)
-
-module Concr = Set.Make(OrderedString)
-
-type class_type =
- Tcty_constr of Path.t * type_expr list * class_type
- | Tcty_signature of class_signature
- | Tcty_fun of label * type_expr * class_type
-
-and class_signature =
- { cty_self: type_expr;
- cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t;
- cty_concr: Concr.t }
-
-type class_declaration =
- { cty_params: type_expr list;
- mutable cty_type: class_type;
- cty_path: Path.t;
- cty_new: type_expr option }
-
-type cltype_declaration =
- { clty_params: type_expr list;
- clty_type: class_type;
- clty_path: Path.t }
-
-(* Type expressions for the module language *)
-
-type module_type =
- Tmty_ident of Path.t
- | Tmty_signature of signature
- | Tmty_functor of Ident.t * module_type * module_type
-
-and signature = signature_item list
-
-and signature_item =
- Tsig_value of Ident.t * value_description
- | Tsig_type of Ident.t * type_declaration
- | Tsig_exception of Ident.t * exception_declaration
- | Tsig_module of Ident.t * module_type
- | Tsig_modtype of Ident.t * modtype_declaration
- | Tsig_class of Ident.t * class_declaration
- | Tsig_cltype of Ident.t * cltype_declaration
-
-and modtype_declaration =
- Tmodtype_abstract
- | Tmodtype_manifest of module_type
diff --git a/typing/types.mli b/typing/types.mli
deleted file mode 100644
index 77164cd5db..0000000000
--- a/typing/types.mli
+++ /dev/null
@@ -1,195 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Representation of types and declarations *)
-
-open Asttypes
-
-(* Type expressions for the core language *)
-
-type type_expr =
- { mutable desc: type_desc;
- mutable level: int;
- mutable id: int }
-
-and type_desc =
- Tvar
- | Tarrow of 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
- | Tpoly of type_expr * type_expr list
-
-and row_desc =
- { row_fields: (label * row_field) list;
- row_more: type_expr;
- row_bound: type_expr list;
- 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 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 : 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 }
-
-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 * type_expr) Vars.t ref *
- string * type_expr
- (* Self *)
- | Val_anc of (string * Ident.t) list * string
- (* Ancestor *)
- | Val_unbound (* Unbound variable *)
-
-(* Constructor descriptions *)
-
-type constructor_description =
- { cstr_res: type_expr; (* Type of the result *)
- 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_private: private_flag } (* Read-only constructor? *)
-
-and constructor_tag =
- Cstr_constant of int (* Constant constructor (an int) *)
- | Cstr_block of int (* Regular constructor (a block) *)
- | Cstr_exception of Path.t (* Exception constructor *)
-
-(* Record label descriptions *)
-
-type label_description =
- { 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? *)
-
-and record_representation =
- Record_regular (* All fields are boxed / tagged *)
- | Record_float (* All fields are floats *)
-
-(* Type definitions *)
-
-type type_declaration =
- { type_params: type_expr list;
- type_arity: int;
- type_kind: type_kind;
- type_manifest: type_expr option;
- type_variance: (bool * bool * bool) list }
- (* covariant, contravariant, weakly contravariant *)
-
-and type_kind =
- Type_abstract
- | Type_variant of (string * type_expr list) list * private_flag
- | Type_record of (string * mutable_flag * type_expr) list
- * record_representation * private_flag
-
-type exception_declaration = type_expr list
-
-(* Type expressions for the class language *)
-
-module Concr : Set.S with type elt = string
-
-type class_type =
- Tcty_constr of Path.t * type_expr list * class_type
- | Tcty_signature of class_signature
- | Tcty_fun of label * type_expr * class_type
-
-and class_signature =
- { cty_self: type_expr;
- cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t;
- cty_concr: Concr.t }
-
-type class_declaration =
- { cty_params: type_expr list;
- mutable cty_type: class_type;
- cty_path: Path.t;
- cty_new: type_expr option }
-
-type cltype_declaration =
- { clty_params: type_expr list;
- clty_type: class_type;
- clty_path: Path.t }
-
-(* Type expressions for the module language *)
-
-type module_type =
- Tmty_ident of Path.t
- | Tmty_signature of signature
- | Tmty_functor of Ident.t * module_type * module_type
-
-and signature = signature_item list
-
-and signature_item =
- Tsig_value of Ident.t * value_description
- | Tsig_type of Ident.t * type_declaration
- | Tsig_exception of Ident.t * exception_declaration
- | Tsig_module of Ident.t * module_type
- | Tsig_modtype of Ident.t * modtype_declaration
- | Tsig_class of Ident.t * class_declaration
- | Tsig_cltype of Ident.t * cltype_declaration
-
-and modtype_declaration =
- Tmodtype_abstract
- | Tmodtype_manifest of module_type
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
deleted file mode 100644
index d132820e0f..0000000000
--- a/typing/typetexp.ml
+++ /dev/null
@@ -1,597 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* typetexp.ml,v 1.34.4.9 2002/01/07 08:39:16 garrigue Exp *)
-
-(* Typechecking of type expressions for the core language *)
-
-open Misc
-open Parsetree
-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_class of Longident.t
- | 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
-
-exception Error of Location.t * error
-
-type variable_context = int * (string, type_expr) Tbl.t
-
-(* 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 local_aliases = ref ([] : string list)
-
-let used_variables = ref (Tbl.empty : (string, type_expr) Tbl.t)
-let bindings = ref ([] : (Location.t * type_expr * type_expr) list)
- (* These two variables are used for the "delayed" policy. *)
-
-let reset_pre_univars () =
- pre_univars := [];
- local_aliases := []
-
-let reset_type_variables () =
- reset_global_level ();
- type_variables := Tbl.empty
-
-let narrow () =
- (increase_global_level (), !type_variables)
-
-let widen (gl, tv) =
- restore_global_level gl;
- type_variables := tv
-
-let enter_type_variable strict loc name =
- try
- if name <> "" && name.[0] = '_' then
- raise (Error (loc, Invalid_variable_name ("'" ^ name)));
- let v = Tbl.find name !type_variables in
- if strict then raise Already_bound;
- v
- with Not_found ->
- let v = new_global_var() in
- type_variables := Tbl.add name v !type_variables;
- v
-
-let type_variable loc name =
- try
- Tbl.find name !type_variables
- with Not_found ->
- raise(Error(loc, Unbound_type_variable ("'" ^ name)))
-
-let wrap_method ty =
- match (Ctype.repr ty).desc with
- Tpoly _ -> ty
- | _ -> Ctype.newty (Tpoly (ty, []))
-
-let new_pre_univar () =
- let v = newvar () 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 | Delayed | Univars
-
-let rec transl_type env policy styp =
- match styp.ptyp_desc with
- Ptyp_any ->
- if policy = Univars then new_pre_univar () else newvar ()
- | Ptyp_var name ->
- if name <> "" && name.[0] = '_' then
- raise (Error (styp.ptyp_loc, Invalid_variable_name ("'" ^ name)));
- begin try
- instance (List.assoc name !univars)
- with Not_found ->
- match policy with
- Fixed ->
- begin try
- instance (Tbl.find name !type_variables)
- with Not_found ->
- raise(Error(styp.ptyp_loc, Unbound_type_variable ("'" ^ name)))
- end
- | Extensible ->
- begin try
- instance (Tbl.find name !type_variables)
- with Not_found ->
- let v = new_global_var () in
- type_variables := Tbl.add name v !type_variables;
- v
- end
- | Univars ->
- begin try
- instance (Tbl.find name !type_variables)
- with Not_found ->
- let v = new_pre_univar () in
- type_variables := Tbl.add name v !type_variables;
- local_aliases := name :: !local_aliases;
- v
- end
- | Delayed ->
- begin try
- instance (Tbl.find name !used_variables)
- with Not_found -> try
- let v1 = instance (Tbl.find name !type_variables) in
- let v2 = new_global_var () in
- used_variables := Tbl.add name v2 !used_variables;
- bindings := (styp.ptyp_loc, v1, v2)::!bindings;
- v2
- with Not_found ->
- let v = new_global_var () in
- type_variables := Tbl.add name v !type_variables;
- used_variables := Tbl.add name v !used_variables;
- v
- end
- end
- | Ptyp_arrow(l, st1, st2) ->
- let ty1 = transl_type env policy st1 in
- let ty2 = transl_type env policy st2 in
- newty (Tarrow(l, ty1, ty2, Cok))
- | Ptyp_tuple stl ->
- newty (Ttuple(List.map (transl_type env policy) stl))
- | Ptyp_constr(lid, stl) ->
- let (path, decl) =
- try
- Env.lookup_type lid env
- with Not_found ->
- raise(Error(styp.ptyp_loc, Unbound_type_constructor lid)) in
- if List.length stl <> decl.type_arity then
- raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid, decl.type_arity,
- List.length stl)));
- let args = List.map (transl_type env policy) stl in
- let params = Ctype.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, ty) ty' ->
- try unify_param env ty' ty with Unify trace ->
- raise (Error(sty.ptyp_loc, Type_mismatch (swap_list trace))))
- (List.combine stl args) params;
- let constr = newconstr path args in
- begin try
- Ctype.enforce_constraints env constr
- with Unify trace ->
- raise (Error(styp.ptyp_loc, Type_mismatch trace))
- end;
- constr
- | Ptyp_object fields ->
- newobj (transl_fields env policy fields)
- | Ptyp_class(lid, stl, present) ->
- let (path, decl, is_variant) =
- try
- let (path, decl) = Env.lookup_type lid 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;
- (path, decl,true)
- with Not_found -> try
- if present <> [] then raise Not_found;
- let lid2 =
- match lid 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, decl) = Env.lookup_type lid2 env in
- (path, decl, false)
- with Not_found ->
- raise(Error(styp.ptyp_loc, Unbound_class lid))
- in
- if List.length stl <> decl.type_arity then
- raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid, decl.type_arity,
- List.length stl)));
- let args = List.map (transl_type env policy) stl in
- let params = Ctype.instance_list decl.type_params in
- List.iter2
- (fun (sty, ty) ty' ->
- try unify_var env ty' ty with Unify trace ->
- raise (Error(sty.ptyp_loc, Type_mismatch (swap_list trace))))
- (List.combine stl args) params;
- let ty =
- try Ctype.expand_head env (newconstr path args)
- with Unify trace ->
- raise (Error(styp.ptyp_loc, Type_mismatch trace))
- in
- begin match ty.desc with
- Tvariant row ->
- let row = Btype.row_repr row in
- List.iter
- (fun l -> if not (List.mem_assoc l row.row_fields) then
- raise(Error(styp.ptyp_loc, Present_has_no_type l)))
- present;
- let bound = ref row.row_bound in
- let single = List.length row.row_fields = 1 in
- let fields =
- if single then row.row_fields else
- List.map
- (fun (l,f) -> l,
- if List.mem l present then f else
- match Btype.row_field_repr f with
- | Rpresent (Some ty) ->
- bound := ty :: !bound;
- 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 = !bound; row_name = Some (path, args);
- row_fixed = false; row_more = newvar () } in
- let static = Btype.static_row row in
- let row =
- if static then row else
- { row with row_more =
- if policy = Univars then new_pre_univar () else newvar () }
- in
- newty (Tvariant row)
- | Tobject (fi, _) ->
- let _, tv = flatten_fields fi in
- if policy = Univars then pre_univars := tv :: !pre_univars;
- ty
- | _ ->
- assert false
- end
- | Ptyp_alias(st, alias) ->
- begin
- try
- let t =
- try List.assoc alias !univars
- with Not_found ->
- let v1 = instance ( Tbl.find alias !type_variables) in
- (* Special case if using indirect variable bindings *)
- if policy = Delayed then
- try instance (Tbl.find alias !used_variables)
- with Not_found ->
- let v2 = new_global_var () in
- used_variables := Tbl.add alias v2 !used_variables;
- bindings := (styp.ptyp_loc, v1, v2)::!bindings;
- v2
- else v1
- in
- let ty = transl_type env policy st in
- begin try unify_var env t ty with Unify trace ->
- let trace = swap_list trace in
- raise(Error(styp.ptyp_loc, Alias_type_mismatch trace))
- end;
- ty
- with Not_found ->
- begin_def ();
- let t = newvar () in
- type_variables := Tbl.add alias t !type_variables;
- let local = (policy = Univars || !univars <> []) in
- if local then local_aliases := alias :: !local_aliases;
- if policy = Delayed then
- used_variables := Tbl.add alias t !used_variables;
- let ty = transl_type env policy st in
- begin try unify_var env t ty with Unify trace ->
- let trace = swap_list trace in
- raise(Error(styp.ptyp_loc, Alias_type_mismatch trace))
- end;
- end_def ();
- if local then generalize_structure t
- else generalize_global t;
- instance t
- end
- | Ptyp_variant(fields, closed, present) ->
- let bound = ref [] and 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 add_typed_field loc l f fields =
- try
- let f' = List.assoc l fields in
- let ty = mkfield l f and ty' = mkfield l f' in
- if equal env false [ty] [ty'] then fields
- else raise(Error(loc, Constructor_mismatch (ty,ty')))
- with Not_found ->
- (l, f) :: fields
- in
- (* closed and only one field: make it present anyway *)
- let single = closed && List.length fields = 1 in
- let rec add_field fields = function
- Rtag (l, c, stl) ->
- name := None;
- let f = match present with
- Some present when not (single || List.mem l present) ->
- let tl = List.map (transl_type env policy) stl in
- bound := tl @ !bound;
- Reither(c, tl, false, ref None)
- | _ ->
- if List.length stl > 1 || c && stl <> [] then
- raise(Error(styp.ptyp_loc, Present_has_conjunction l));
- match stl with [] -> Rpresent None
- | st :: _ -> Rpresent (Some(transl_type env policy st))
- in
- add_typed_field styp.ptyp_loc l f fields
- | Rinherit sty ->
- let ty = transl_type env policy sty in
- let nm =
- match repr ty with
- {desc=Tconstr(p, tl, _)} -> Some(p, tl)
- | _ -> None
- in
- name := if fields = [] then nm else None;
- let fl = match expand_head env ty, 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, Unbound_type_constructor_2 p))
- | _ ->
- raise(Error(sty.ptyp_loc, Not_a_variant ty))
- in
- let single = single && List.length fl = 1 in
- List.fold_left
- (fun fields (l, f) ->
- let f = match present with
- Some present when not (single || List.mem l present) ->
- begin match f with
- Rpresent(Some ty) ->
- bound := ty :: !bound;
- 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 fields)
- fields fl
- in
- let fields = List.fold_left add_field [] fields 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, Present_has_no_type l)))
- present
- end;
- ignore begin
- List.fold_left
- (fun hl (l,_) ->
- let h = Btype.hash_variant l in
- try
- let l' = List.assoc h hl in
- if l <> l' then raise(Error(styp.ptyp_loc, Variant_tags(l, l')));
- hl
- with Not_found -> (h,l) :: hl)
- []
- fields
- end;
- let row =
- { row_fields = List.rev fields; row_more = newvar ();
- row_bound = !bound; row_closed = closed;
- row_fixed = false; row_name = !name } in
- let static = Btype.static_row row in
- let row =
- if static then row else
- { row with row_more =
- if policy = Univars then new_pre_univar () else
- if policy = Fixed && not static then
- raise(Error(styp.ptyp_loc, Unbound_type_variable "[..]"))
- else row.row_more
- } in
- newty (Tvariant row)
- | Ptyp_poly(vars, st) ->
- begin_def();
- let new_univars = List.map (fun name -> name, newvar()) vars in
- let old_univars = !univars in
- univars := new_univars @ !univars;
- let ty = transl_type env policy st 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
- if v.level <> Btype.generic_level || v.desc <> Tvar then
- raise (Error (styp.ptyp_loc, Cannot_quantify (name, v)));
- v.desc <- Tunivar;
- v :: tyl
- end else tyl)
- [] new_univars
- in
- let ty' = Btype.newgenty (Tpoly(ty, List.rev ty_list)) in
- unify_var env (newvar()) ty';
- ty'
-
-and transl_fields env policy =
- function
- [] ->
- newty Tnil
- | {pfield_desc = Pfield_var} as field::_ ->
- if policy = Univars then new_pre_univar () else newvar ()
- | {pfield_desc = Pfield(s, e)}::l ->
- let ty1 = transl_type env policy e in
- let ty2 = transl_fields env policy l in
- newty (Tfield (s, Fpresent, ty1, 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.row_more row).desc = Tunivar 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 transl_simple_type env fixed styp =
- univars := []; local_aliases := [];
- let typ = transl_type env (if fixed then Fixed else Extensible) styp in
- type_variables := List.fold_right Tbl.remove !local_aliases !type_variables;
- make_fixed_univars typ;
- typ
-
-let transl_simple_type_univars env styp =
- univars := [];
- reset_pre_univars ();
- begin_def ();
- let typ = transl_type env Univars styp in
- end_def ();
- generalize typ;
- let univs =
- List.fold_left
- (fun acc v ->
- let v = repr v in
- if v.level <> Btype.generic_level || v.desc <> Tvar then acc
- else (v.desc <- Tunivar ; v :: acc))
- [] !pre_univars
- in
- type_variables := List.fold_right Tbl.remove !local_aliases !type_variables;
- reset_pre_univars ();
- make_fixed_univars typ;
- instance (Btype.newgenty (Tpoly (typ, univs)))
-
-let transl_simple_type_delayed env styp =
- univars := [];
- used_variables := Tbl.empty;
- bindings := [];
- let typ = transl_type env Delayed styp in
- let b = !bindings in
- used_variables := Tbl.empty;
- bindings := [];
- (typ,
- function () ->
- List.iter
- (function (loc, t1, t2) ->
- try unify env t1 t2 with Unify trace ->
- raise (Error(loc, Type_mismatch trace)))
- b)
-
-let transl_type_scheme env styp =
- reset_type_variables();
- begin_def();
- let typ = transl_simple_type env false styp in
- end_def();
- generalize typ;
- typ
-
-(* Error report *)
-
-open Format
-open Printtyp
-
-let report_error ppf = function
- | Unbound_type_variable name ->
- fprintf ppf "Unbound type parameter %s" name
- | Unbound_type_constructor lid ->
- fprintf ppf "Unbound type constructor %a" longident 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_class lid ->
- fprintf ppf "Unbound class %a" longident lid
- | Unbound_row_variable lid ->
- fprintf ppf "Unbound row variable in #%a" longident lid
- | Type_mismatch trace ->
- Printtyp.unification_error true trace
- (function ppf ->
- fprintf ppf "This type")
- ppf
- (function ppf ->
- fprintf ppf "should be an instance of type")
- | Alias_type_mismatch trace ->
- Printtyp.unification_error true trace
- (function ppf ->
- fprintf ppf "This alias is bound to type")
- ppf
- (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') ->
- Printtyp.reset_and_mark_loops_list [ty; ty'];
- fprintf ppf "@[<hov>%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
- | Variant_tags (lab1, lab2) ->
- fprintf ppf
- "Variant tags `%s@ and `%s have same hash value.@ Change one of them."
- lab1 lab2
- | Invalid_variable_name name ->
- fprintf ppf "The type variable name %s is not allowed in programs" name
- | Cannot_quantify (name, v) ->
- fprintf ppf "This type scheme cannot quantify '%s :@ %s." name
- (if v.desc = Tvar then "it escapes this scope" else
- if v.desc = Tunivar then "it is aliased to another variable"
- else "it is not a variable")
diff --git a/typing/typetexp.mli b/typing/typetexp.mli
deleted file mode 100644
index ba3abaa412..0000000000
--- a/typing/typetexp.mli
+++ /dev/null
@@ -1,60 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Typechecking of type expressions for the core language *)
-
-open Format;;
-
-val transl_simple_type:
- Env.t -> bool -> Parsetree.core_type -> Types.type_expr
-val transl_simple_type_univars:
- Env.t -> Parsetree.core_type -> Types.type_expr
-val transl_simple_type_delayed:
- Env.t -> Parsetree.core_type -> Types.type_expr * (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 -> Types.type_expr
-val reset_type_variables: unit -> unit
-val enter_type_variable: bool -> Location.t -> string -> Types.type_expr
-val type_variable: Location.t -> string -> Types.type_expr
-
-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_class of Longident.t
- | Unbound_row_variable of Longident.t
- | Type_mismatch of (Types.type_expr * Types.type_expr) list
- | Alias_type_mismatch of (Types.type_expr * Types.type_expr) list
- | Present_has_conjunction of string
- | Present_has_no_type of string
- | Constructor_mismatch of Types.type_expr * Types.type_expr
- | Not_a_variant of Types.type_expr
- | Variant_tags of string * string
- | Invalid_variable_name of string
- | Cannot_quantify of string * Types.type_expr
-
-exception Error of Location.t * error
-
-val report_error: formatter -> error -> unit
diff --git a/utils/.cvsignore b/utils/.cvsignore
deleted file mode 100644
index 25b6d3bc86..0000000000
--- a/utils/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-config.ml
diff --git a/utils/ccomp.ml b/utils/ccomp.ml
deleted file mode 100644
index 1e065666bc..0000000000
--- a/utils/ccomp.ml
+++ /dev/null
@@ -1,99 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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-length line *)
-let build_diversion lst =
- let (responsefile, oc) = Filename.open_temp_file "camlresp" "" in
- List.iter
- (fun f ->
- if f <> "" then begin
- output_string oc (Filename.quote f); output_char oc '\n'
- end)
- lst;
- close_out oc;
- at_exit (fun () -> Misc.remove_file responsefile);
- "@" ^ responsefile
-
-let quote_files lst =
- let s =
- String.concat " "
- (List.map (fun f -> if f = "" then f else Filename.quote f) lst) in
- if Sys.os_type = "Win32" && String.length s >= 256
- then build_diversion lst
- else s
-
-let compile_file name =
- match Config.ccomp_type with
- | "mrc" ->
- let qname = Filename.quote name in
- let includes = (Clflags.std_include_dir ()) @ !Clflags.include_dirs
- in
- let args =
- Printf.sprintf " %s %s -i %s"
- (String.concat " " (List.rev_map Filename.quote !Clflags.ccopts))
- (String.concat "," (List.rev_map Filename.quote includes))
- qname
- in
- command ("mrc " ^ args ^ " -o " ^ qname ^ ".x")
- | "cc" | "msvc" ->
- command
- (Printf.sprintf
- "%s -c %s %s %s %s"
- !Clflags.c_compiler
- (String.concat " " (List.rev !Clflags.ccopts))
- (quote_files
- (List.rev_map (fun dir -> "-I" ^ dir) !Clflags.include_dirs))
- (Clflags.std_include_flag "-I")
- (Filename.quote name))
- | _ -> assert false
-
-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 "lib /nologo /debugtype:cv /out:%s %s"
- quoted_archive (quote_files file_list))
- | _ ->
- let r1 =
- command(Printf.sprintf "ar rc %s %s"
- 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
diff --git a/utils/ccomp.mli b/utils/ccomp.mli
deleted file mode 100644
index 3a1e7fc9ae..0000000000
--- a/utils/ccomp.mli
+++ /dev/null
@@ -1,22 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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
diff --git a/utils/clflags.ml b/utils/clflags.ml
deleted file mode 100644
index a58d8954b2..0000000000
--- a/utils/clflags.ml
+++ /dev/null
@@ -1,87 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Command-line parameters *)
-
-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 output_c_object = ref false (* -output-obj *)
-and ccopts = ref ([] : string list) (* -ccopt *)
-and classic = ref false (* -nolabels *)
-and nopervasives = ref false (* -nopervasives *)
-and preprocessor = ref(None : string option) (* -pp *)
-let save_types = ref false (* -stypes *)
-and use_threads = ref false (* -thread *)
-and use_vmthreads = ref false (* -vmthread *)
-and noassert = ref false (* -noassert *)
-and verbose = ref false (* -verbose *)
-and use_prims = ref "" (* -use-prims ... *)
-and use_runtime = ref "" (* -use-runtime ... *)
-and principal = ref false (* -principal *)
-and recursive_types = ref false (* -rectypes *)
-and make_runtime = ref false (* -make_runtime *)
-and gprofile = ref false (* -p *)
-and c_compiler = ref Config.bytecomp_c_compiler (* -cc *)
-and c_linker = ref Config.bytecomp_c_linker (* -cc *)
-and no_auto_link = ref false (* -noautolink *)
-and dllpaths = ref ([] : string list) (* -dllpath *)
-and make_package = ref false (* -pack *)
-let dump_parsetree = ref false (* -dparsetree *)
-and dump_rawlambda = ref false (* -drawlambda *)
-and dump_lambda = ref false (* -dlambda *)
-and dump_instr = ref false (* -dinstr *)
-
-let keep_asm_file = ref false (* -S *)
-let optimize_for_speed = ref true (* -compact *)
-
-and dump_cmm = ref false (* -dcmm *)
-let dump_selection = ref false (* -dsel *)
-let dump_live = ref false (* -dlive *)
-let dump_spill = ref false (* -dspill *)
-let dump_split = ref false (* -dsplit *)
-let dump_scheduling = ref false (* -dscheduling *)
-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 native_code = ref false (* set to true under ocamlopt *)
-let inline_threshold = ref 10
-
-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]
-;;
diff --git a/utils/config.mli b/utils/config.mli
deleted file mode 100644
index a53fe24f24..0000000000
--- a/utils/config.mli
+++ /dev/null
@@ -1,111 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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: one of
- "cc" (for Unix-style C compilers)
- "msvc" (Microsoft Visual C++)
- "mrc" (Macintosh MPW) *)
-val bytecomp_c_compiler: string
- (* The C compiler to use for compiling C files
- with the bytecode compiler *)
-val bytecomp_c_linker: string
- (* The C compiler to use for building custom runtime systems
- 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_linker: string
- (* The C compiler to use for the final linking step
- in the native code compiler *)
-val native_c_libraries: string
- (* The C libraries to link with native-code programs *)
-val native_partial_linker: string
- (* The linker to use for partial links (ocamlopt -output-obj) *)
-val native_pack_linker: string
- (* The linker to use for packaging (ocamlopt -pack) *)
-val ranlib: string
- (* Command to randomize a library, or "" if not needed *)
-val binutils_nm: string
- (* The "nm" command from GNU binutils, or "" if not available *)
-val binutils_objcopy: string
- (* The "objcopy" command from GNU binutils, or "" if not available *)
-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 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 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 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. *)
diff --git a/utils/config.mlp b/utils/config.mlp
deleted file mode 100644
index 370adbc387..0000000000
--- a/utils/config.mlp
+++ /dev/null
@@ -1,77 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* The main OCaml version string has moved to stdlib/sys.ml *)
-let version = Sys.ocaml_version
-
-let standard_library =
- try
- Sys.getenv "OCAMLLIB"
- with Not_found ->
- try
- Sys.getenv "CAMLLIB"
- with Not_found ->
- "%%LIBDIR%%"
-
-let standard_runtime = "%%BYTERUN%%"
-let ccomp_type = "%%CCOMPTYPE%%"
-let bytecomp_c_compiler = "%%BYTECC%%"
-let bytecomp_c_linker = "%%BYTELINK%%"
-let bytecomp_c_libraries = "%%BYTECCLIBS%%"
-let native_c_compiler = "%%NATIVECC%%"
-let native_c_linker = "%%NATIVELINK%%"
-let native_c_libraries = "%%NATIVECCLIBS%%"
-let native_partial_linker = "%%PARTIALLD%%"
-let native_pack_linker = "%%PACKLD%%"
-let ranlib = "%%RANLIBCMD%%"
-let binutils_nm = "%%BINUTILS_NM%%"
-let binutils_objcopy = "%%BINUTILS_OBJCOPY%%"
-let cc_profile = "%%CC_PROFILE%%"
-
-let exec_magic_number = "Caml1999X007"
-and cmi_magic_number = "Caml1999I009"
-and cmo_magic_number = "Caml1999O005"
-and cma_magic_number = "Caml1999A006"
-and cmx_magic_number = "Caml1999Y008"
-and cmxa_magic_number = "Caml1999Z009"
-and ast_impl_magic_number = "Caml1999M010"
-and ast_intf_magic_number = "Caml1999N009"
-
-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 architecture = "%%ARCH%%"
-let model = "%%MODEL%%"
-let system = "%%SYSTEM%%"
-
-let ext_obj = "%%EXT_OBJ%%"
-let ext_asm = "%%EXT_ASM%%"
-let ext_lib = "%%EXT_LIB%%"
-let ext_dll = "%%EXT_DLL%%"
-
-let default_executable_name =
- match Sys.os_type with
- "Unix" -> "a.out"
- | "Win32" | "Cygwin" -> "camlprog.exe"
- | _ -> "camlprog"
diff --git a/utils/consistbl.ml b/utils/consistbl.ml
deleted file mode 100644
index d01d7c8735..0000000000
--- a/utils/consistbl.ml
+++ /dev/null
@@ -1,57 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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 tbl =
- Hashtbl.fold (fun name (crc, auth) accu -> (name, crc) :: accu) tbl []
-
-let filter p tbl =
- let to_remove = ref [] in
- Hashtbl.iter
- (fun name (crc, auth) ->
- 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
deleted file mode 100644
index edaac12fc5..0000000000
--- a/utils/consistbl.mli
+++ /dev/null
@@ -1,60 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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: t -> (string * Digest.t) list
- (* Return all bindings ([name], [crc]) contained in the given
- table. *)
-
-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/misc.ml b/utils/misc.ml
deleted file mode 100644
index e142ce2ad2..0000000000
--- a/utils/misc.ml
+++ /dev/null
@@ -1,183 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Errors *)
-
-exception Fatal_error
-
-let fatal_error msg =
- prerr_string ">> Fatal error: "; prerr_endline msg; raise Fatal_error
-
-(* Exceptions *)
-
-let try_finally f1 f2 =
- try
- let result = f1 () in
- f2 ();
- result
- with x -> f2 (); raise x
-;;
-
-(* 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)
-
-(* Options *)
-
-let may f = function
- Some x -> f x
- | None -> ()
-
-let may_map f = function
- Some x -> Some (f x)
- | None -> None
-
-(* 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_uncap path name =
- let uname = String.uncapitalize 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
- 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 = String.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 = String.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
-
-(* 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_lsl a = min_int asr 1 <= a && a <= max_int asr 1
-
-(* String operations *)
-
-let chop_extension_if_any fname =
- try
- ignore(String.index (Filename.basename fname) '.');
- Filename.chop_extension fname
- with Not_found -> fname
-
-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 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
diff --git a/utils/misc.mli b/utils/misc.mli
deleted file mode 100644
index 4f92077e73..0000000000
--- a/utils/misc.mli
+++ /dev/null
@@ -1,94 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Miscellaneous useful types and functions *)
-
-val fatal_error: string -> '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
-
-val find_in_path: string list -> string -> string
- (* Search a 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 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_add n1 n2] returns [true] if the computation of
- [n1 - n2] does not overflow. *)
-val no_overflow_lsl: int -> bool
- (* [no_overflow_add n] returns [true] if the computation of
- [n lsl 1] does not overflow. *)
-
-val chop_extension_if_any: string -> string
- (* Like Filename.chop_extension but returns the initial file
- name if it has no 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 rev_split_words: string -> string list
- (* [rev_split_words s] splits [s] in blank-separated words, and return
- the list of words in reverse order. *)
diff --git a/utils/tbl.ml b/utils/tbl.ml
deleted file mode 100644
index b00b2f7c66..0000000000
--- a/utils/tbl.ml
+++ /dev/null
@@ -1,104 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-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) as t ->
- 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) as t ->
- 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
-
-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 "@[<hv 2>[[%a]]@]" print_tbl tbl
diff --git a/utils/tbl.mli b/utils/tbl.mli
deleted file mode 100644
index ddeaa79d6a..0000000000
--- a/utils/tbl.mli
+++ /dev/null
@@ -1,30 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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 -> 'c) -> ('a, 'b) t -> unit
-
-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
deleted file mode 100644
index a423552d1a..0000000000
--- a/utils/terminfo.ml
+++ /dev/null
@@ -1,25 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Basic interface to the terminfo database *)
-
-type status =
- | Uninitialised
- | Bad_term
- | Good_term of int
-;;
-external setup : out_channel -> status = "terminfo_setup";;
-external backup : int -> unit = "terminfo_backup";;
-external standout : bool -> unit = "terminfo_standout";;
-external resume : int -> unit = "terminfo_resume";;
diff --git a/utils/terminfo.mli b/utils/terminfo.mli
deleted file mode 100644
index 56c249a2cc..0000000000
--- a/utils/terminfo.mli
+++ /dev/null
@@ -1,25 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* 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 = "terminfo_setup";;
-external backup : int -> unit = "terminfo_backup";;
-external standout : bool -> unit = "terminfo_standout";;
-external resume : int -> unit = "terminfo_resume";;
diff --git a/utils/warnings.ml b/utils/warnings.ml
deleted file mode 100644
index 16b057dc5b..0000000000
--- a/utils/warnings.ml
+++ /dev/null
@@ -1,148 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* 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 Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Please keep them in alphabetical order *)
-
-type t = (* A is all *)
- | Comment of string (* C *)
- | Deprecated (* D *)
- | Fragile_pat of string (* E *)
- | Partial_application (* F *)
- | Labels_omitted (* L *)
- | Method_override of string list (* M *)
- | Partial_match of string (* P *)
- | Statement_type (* S *)
- | Unused_match (* U *)
- | Unused_pat (* U *)
- | Hide_instance_variable of string (* V *)
- | Other of string (* X *)
-;;
-
-let letter = function (* 'a' is all *)
- | Comment _ -> 'c'
- | Deprecated -> 'd'
- | Fragile_pat _ -> 'e'
- | Partial_application -> 'f'
- | Labels_omitted -> 'l'
- | Method_override _ -> 'm'
- | Partial_match _ -> 'p'
- | Statement_type -> 's'
- | Unused_match|Unused_pat -> 'u'
- | Hide_instance_variable _ -> 'v'
- | Other _ -> 'x'
-;;
-
-let check c =
- try ignore (String.index "acdeflmpsuvxACDEFLMPSUVX" c)
- with _ -> raise (Arg.Bad (Printf.sprintf "unknown warning option %c" c))
-;;
-
-let active = Array.create 26 true;;
-let error = Array.create 26 false;;
-
-let translate c =
- check c;
- if c >= 'A' && c <= 'Z' then
- (Char.code c - Char.code 'A', true)
- else
- (Char.code c - Char.code 'a', false)
-;;
-
-let is_active x =
- let (n, _) = translate (letter x) in
- active.(n)
-;;
-
-let is_error x =
- let (n, _) = translate (letter x) in
- error.(n)
-;;
-
-let parse_options iserr s =
- let flags = if iserr then error else active in
- for i = 0 to String.length s - 1 do
- if s.[i] = 'A' then Array.fill flags 0 (Array.length flags) true
- else if s.[i] = 'a' then Array.fill flags 0 (Array.length flags) false
- else begin
- let (n, fl) = translate s.[i] in
- flags.(n) <- fl;
- end;
- done
-;;
-
-let () = parse_options false "el";;
-
-let message = function
- | Partial_match "" -> "this pattern-matching is not exhaustive."
- | Partial_match s ->
- "this pattern-matching is not exhaustive.\n\
- Here is an example of a value that is not matched:\n" ^ s
- | Unused_match -> "this match case is unused."
- | Unused_pat -> "this pattern is unused."
- | Fragile_pat "" ->
- "this pattern is fragile. It would hide\n\
- the addition of new constructors to the data types it matches."
- | Fragile_pat s ->
- "this pattern is fragile. It would hide\n\
- the addition of new constructors to the data types it matches.\n\
- Here is an example of a more robust pattern:\n" ^ s
- | Labels_omitted ->
- "labels were omitted in the application of this function."
- | Method_override slist ->
- String.concat " "
- ("the following methods are overriden \
- by the inherited class:\n " :: slist)
- | Hide_instance_variable lab ->
- "this definition of an instance variable " ^ lab ^
- " hides a previously\ndefined instance variable of the same name."
- | Partial_application ->
- "this function application is partial,\n\
- maybe some arguments are missing."
- | Statement_type ->
- "this expression should have type unit."
- | Comment s -> "this is " ^ s ^ "."
- | Deprecated -> "this syntax is deprecated."
- | Other s -> s
-;;
-
-let nerrors = ref 0;;
-
-let print ppf w =
- let msg = message w in
- let newlines = ref 0 in
- for i = 0 to String.length msg - 1 do
- if msg.[i] = '\n' then incr newlines;
- done;
- let (out, flush, newline, space) =
- Format.pp_get_all_formatter_output_functions ppf ()
- in
- let countnewline x = incr newlines; newline x in
- Format.pp_set_all_formatter_output_functions ppf out flush countnewline space;
- Format.fprintf ppf "%s" msg;
- Format.pp_print_flush ppf ();
- Format.pp_set_all_formatter_output_functions ppf out flush newline space;
- let (n, _) = translate (letter w) in
- if error.(n) then incr nerrors;
- !newlines
-;;
-
-exception Errors of int;;
-
-let check_fatal () =
- if !nerrors > 0 then begin
- let e = Errors !nerrors in
- nerrors := 0;
- raise e;
- end;
-;;
diff --git a/utils/warnings.mli b/utils/warnings.mli
deleted file mode 100644
index d23a3188b5..0000000000
--- a/utils/warnings.mli
+++ /dev/null
@@ -1,43 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* 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 Q Public License version 1.0. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Format
-
-type t = (* A is all *)
- | Comment of string (* C *)
- | Deprecated (* D *)
- | Fragile_pat of string (* E *)
- | Partial_application (* F *)
- | Labels_omitted (* L *)
- | Method_override of string list (* M *)
- | Partial_match of string (* P *)
- | Statement_type (* S *)
- | Unused_match (* U *)
- | Unused_pat (* U *)
- | Hide_instance_variable of string (* V *)
- | Other of string (* X *)
-;;
-
-val parse_options : bool -> string -> unit;;
-
-val is_active : t -> bool;;
-val is_error : t -> bool;;
-
-val print : formatter -> t -> int;;
- (* returns the number of newlines in the printed string *)
-
-
-exception Errors of int;;
-
-val check_fatal : unit -> unit;;
diff --git a/win32caml/Makefile b/win32caml/Makefile
deleted file mode 100644
index 397448c429..0000000000
--- a/win32caml/Makefile
+++ /dev/null
@@ -1,52 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 2001 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the GNU Library General Public License, with #
-# the special exception on linking described in file ../LICENSE. #
-# #
-#########################################################################
-
-# $Id$
-
-include ../config/Makefile
-
-CC=$(BYTECC)
-CFLAGS=$(BYTECCCOMPOPTS)
-
-OBJS=startocaml.$(O) ocamlres.$(O) ocaml.$(O) menu.$(O)
-
-LIBS=$(call SYSLIB,kernel32) $(call SYSLIB,advapi32) $(call SYSLIB,gdi32) \
- $(call SYSLIB,user32) $(call SYSLIB,comdlg32) $(call SYSLIB,comctl32)
-
-all: ocamlwin.exe
-
-ocamlwin.exe: $(OBJS)
- $(CC) $(CFLAGS) -o ocamlwin.exe $(OBJS) $(LIBS)
-
-ocamlres.$(O): ocaml.rc ocaml.ico
-ifeq ($(TOOLCHAIN),msvc)
- rc ocaml.rc
- cvtres /nologo /machine:ix86 /out:$@ ocaml.res
- rm -f ocaml.res
-endif
-ifeq ($(TOOLCHAIN),mingw)
- windres -i ocaml.rc -o $@
-endif
-
-$(OBJS): inria.h inriares.h
-
-clean:
- rm -f ocamlwin.exe *.$(O) *.pdb ocamlwin.ilk
-
-install:
- cp ocamlwin.exe $(PREFIX)/OCamlWin.exe
-
-.SUFFIXES: .c .$(O)
-
-.c.$(O):
- $(CC) $(CFLAGS) -c $*.c
diff --git a/win32caml/inria.h b/win32caml/inria.h
deleted file mode 100644
index afa252404c..0000000000
--- a/win32caml/inria.h
+++ /dev/null
@@ -1,115 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Developed by Jacob Navia. */
-/* Copyright 2001 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/*------------------------------------------------------------------------
- Module: D:\lcc\inria\inria.h
- Author: Jacob
- Project:
- State:
- Creation Date: June 2001
- Description: The user interface works as follows:
- 1: At startup it will look for the path to the
- ocaml interpreter in the registry using the
- key HKEY_CURRENT_USER\SOFTWARE\ocaml. If not
- found will prompt the user.
- 2: It will start the ocaml interpreter with
- its standard output and standard input
- connected to two pipes in a dedicated thread.
- 3: It will open a window containing an edit
- field. The output from the interpreter will be
- shown in the edit field, and the input of the
- user in the edit field will be sent to the
- interpreter when the user types return.
- 4: Line editing is provided by moving to the
- desired line with the arrows, then pressing
- return; If we aren't in the last input line,
- the input will be copied to the last line and
- sent to the interpreter.
- 5: The GUI ensures that when we exit the ocaml
- interpreter is stopped by sending the
- character string "#quit;;\nCtrl-Z"
- 6: A history of all lines sent to the interpreter
- is maintained in a simple linked list. The
- History dialog box shows that, and allows the
- user to choose a given input line.
- 7: Memory limits. The edit buffer can be of an
- arbitrary length, i.e. maybe 7-8MB or more,
- there are no fixed limits. The History list
- will always grow too, so memory consumption
- could be "high" after several days of
- uninterrupted typing at the keyboard. For that
- cases it is recommended to stop the GUI and
- get some sleep...
- 9: The GUI will start a timer, looking 4 times a
- second if the interpreter has written
- something in the pipe. This is enough for most
- applications.
-------------------------------------------------------------------------*/
-
-#include <windows.h>
-
-// In this structure should go eventually all global variables scattered
-// through the program.
-typedef struct _programParams {
- HFONT hFont; // The handle of the current font
- COLORREF TextColor; // The text color
- char CurrentWorkingDir[MAX_PATH];// The current directory
-} PROGRAM_PARAMS;
-
-//**************** Global variables ***********************
-extern PROGRAM_PARAMS ProgramParams;
-
-extern COLORREF BackColor; // The background color
-extern HBRUSH BackgroundBrush; // A brush built with the background color
-extern char LibDir[]; // The lib directory
-extern char OcamlPath[]; // The Path to ocaml.exe
-extern HANDLE hInst; // The instance handle for this application
-extern HWND hwndSession; // The current session window handle
-extern LOGFONT CurrentFont; // The current font characteristics
-extern HWND hwndMain,hwndMDIClient; // Window handles of frame and mdi window
-
-// ***************** Function prototypes ******************
-int WriteToPipe(char *data); // Writes to the pipe
-int ReadFromPipe(char *data,int len);// Reads from the pipe
-int AskYesOrNo(char *msg); //Ditto!
-int BrowseForFile(char *fname,char *path);
-void GotoEOF(void); // Positions the cursor at the end of the text
-void ShowDbgMsg(char *msg); // Shows an error message
-void HandleCommand(HWND hwnd, WPARAM wParam,LPARAM lParam);
-int GetOcamlPath(void); // Finds where ocaml.exe is
-void ForceRepaint(void); // Ditto.
-void AddLineToControl(char *buf);
-char *GetHistoryLine(int n); // Gets the nth history line base 1.
-int StartOcaml(void);
-// **************** User defined window messages *************
-#define WM_NEWLINE (WM_USER+6000)
-#define WM_TIMERTICK (WM_USER+6001)
-#define WM_QUITOCAML (WM_USER+6002)
-// ********************** Structures ***********************
-typedef struct tagPosition {
- int line;
- int col;
-} POSITION;
-
-// Simple linked list for holding the history lines
-typedef struct tagHistory {
- struct tagHistory *Next;
- char *Text;
-} HISTORYLINE;
-
-extern void *SafeMalloc(int);
-extern HISTORYLINE *History; // The root of the history lines
-
-#define IDEDITCONTROL 15432
-
diff --git a/win32caml/inriares.h b/win32caml/inriares.h
deleted file mode 100644
index 2043a37d79..0000000000
--- a/win32caml/inriares.h
+++ /dev/null
@@ -1,48 +0,0 @@
-/* Weditres generated include file. Do NOT edit */
-#define IDD_ABOUT 100
-#define IDM_NEW 200
-#define IDM_OPEN 210
-#define IDM_SAVE 220
-#define IDM_SAVEAS 230
-#define IDM_CLOSE 240
-#define IDM_PRINT 250
-#define IDM_PRINTSU 260
-#define IDM_PRINTPRE 265
-#define IDM_PAGESETUP 267
-#define IDM_EXIT 270
-#define IDM_HISTORY 281
-#define IDM_GC 282
-#define IDCTRLC 283
-#define IDD_HISTORY 300
-#define IDLIST 301
-#define IDM_EDITUNDO 310
-#define IDM_EDITCUT 320
-#define IDM_EDITCOPY 330
-#define IDM_EDITPASTE 340
-#define IDM_EDITCLEAR 350
-#define IDM_EDITDELETE 360
-#define IDM_EDITREPLACE 370
-#define IDM_EDITREDO 380
-#define IDM_WINDOWTILE 410
-#define IDM_WINDOWCASCADE 420
-#define IDM_WINDOWICONS 430
-#define IDM_WINDOWCLOSEALL 440
-#define IDM_PROPERTIES 450
-#define IDM_ABOUT 500
-#define IDM_HELP 510
-#define IDMAINMENU 600
-#define IDM_FIND 700
-#define IDAPPLICON 710
-#define IDI_CHILDICON 800
-#define IDAPPLCURSOR 810
-#define OCAML_ICON 1000
-#define IDS_FILEMENU 2000
-#define IDS_HELPMENU 2010
-#define IDS_SYSMENU 2030
-#define IDM_STATUSBAR 3000
-#define IDM_WINDOWCHILD 3010
-#define ID_TOOLBAR 5000
-#define IDACCEL 10000
-#define IDM_FONT 40002
-#define IDM_COLORTEXT 40004
-#define IDM_BACKCOLOR 40005
diff --git a/win32caml/libgraph.h b/win32caml/libgraph.h
deleted file mode 100644
index 3bfaff301f..0000000000
--- a/win32caml/libgraph.h
+++ /dev/null
@@ -1,108 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Jacob Navia, after Xavier Leroy */
-/* */
-/* Copyright 2001 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <stdio.h>
-#include <windows.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 int grscreen; /* The screen number */
-//extern Colormap grcolormap; /* The color map */
-//extern struct canvas grwindow; /* The graphics window */
-//extern struct canvas grbstore; /* The pixmap used for backing store */
-//extern int grwhite, grblack; /* Black and white pixels for X */
-//extern int grbackground; /* Background color for X
-// (used for CAML color -1) */
-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 BtoW(y) ((y) + WindowRect.bottom - grbstore.h)
-
-#define DEFAULT_SCREEN_WIDTH 1024
-#define DEFAULT_SCREEN_HEIGHT 768
-#define BORDER_WIDTH 2
-#define WINDOW_NAME "Caml graphics"
-#define ICON_NAME "Caml graphics"
-#define DEFAULT_EVENT_MASK \
- (ExposureMask | KeyPressMask | StructureNotifyMask)
-#define DEFAULT_FONT "fixed"
-#define SIZE_QUEUE 256
-
-/* 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
-
-void gr_fail(char *fmt, char *arg);
-void gr_check_open(void);
-unsigned long gr_pixel_rgb(int rgb);
-int gr_rgb_pixel(long unsigned int pixel);
-void gr_enqueue_char(unsigned char c);
-void gr_init_color_cache(void);
-
-// 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 int MouseLbuttonDown,MouseMbuttonDown,MouseRbuttonDown;
-extern HANDLE EventHandle;
-extern int InspectMessages;
-extern MSG msg;
-
diff --git a/win32caml/menu.c b/win32caml/menu.c
deleted file mode 100644
index 34815d89f2..0000000000
--- a/win32caml/menu.c
+++ /dev/null
@@ -1,592 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Developed by Jacob Navia. */
-/* Copyright 2001 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <stdio.h>
-#include <windows.h>
-#include <Richedit.h>
-#include "inria.h"
-#include "inriares.h"
-
-void InterruptOcaml(void);
-LOGFONT CurrentFont;
-int CurrentFontFamily = (FIXED_PITCH | FF_MODERN);
-int CurrentFontStyle;
-char CurrentFontName[64] = "Courier";
-/*------------------------------------------------------------------------
- Procedure: OpenMlFile ID:1
- Purpose: Opens a file, either a source file (*.ml) or an *.cmo
- file.
- Input: A buffer where the name will be stored, and its
- length
- Output: The user's choice will be stored in the buffer.
- Errors: None
-------------------------------------------------------------------------*/
-int OpenMlFile(char *fname,int lenbuf)
-{
- OPENFILENAME ofn;
- int r;
- char *p,defext[5],tmp[512];
-
- memset(&ofn,0,sizeof(OPENFILENAME));
- memset(tmp,0,sizeof(tmp));
- fname[0] = 0;
- strcpy(tmp,"ocaml sources|*.ml|bytecode object files|*.cmo|All files|*.*");
- p = tmp;
- while (*p) {
- if (*p == '|')
- *p = 0;
- p++;
- }
- strcpy(defext,"ml");
- ofn.lStructSize = sizeof(OPENFILENAME);
- ofn.hwndOwner = hwndMain;
- ofn.lpstrFilter = tmp;
- ofn.nFilterIndex = 1;
- ofn.hInstance = hInst;
- ofn.lpstrFile = fname;
- ofn.lpstrTitle = "Open file";
- ofn.lpstrInitialDir = LibDir;
- ofn.nMaxFile = lenbuf;
- ofn.Flags = OFN_PATHMUSTEXIST | OFN_NOCHANGEDIR | OFN_LONGNAMES |
- OFN_HIDEREADONLY |OFN_EXPLORER;
- r = GetOpenFileName(&ofn);
- if (r) {
- /* Replace backslashes by forward slashes in file name */
- for (p = fname; *p != 0; p++)
- if (*p == '\\') *p = '/';
- }
- return r;
-}
-/*------------------------------------------------------------------------
- Procedure: GetSaveName ID:1
- Purpose: Get a name to save the current session (Save as menu
- item)
- Input: A buffer where the name of the file will be stored,
- and its length
- Output: The name of the file choosen by the user will be
- stored in the buffer
- Errors: none
-------------------------------------------------------------------------*/
-int GetSaveName(char *fname,int lenbuf)
-{
- OPENFILENAME ofn;
- int r;
- char *p,defext[5],tmp[512];
-
- memset(&ofn,0,sizeof(OPENFILENAME));
- memset(tmp,0,sizeof(tmp));
- fname[0] = 0;
- strcpy(tmp,"Text files|*.txt");
- p = tmp;
- while (*p) {
- if (*p == '|')
- *p = 0;
- p++;
- }
- strcpy(defext,"txt");
- ofn.lStructSize = sizeof(OPENFILENAME);
- ofn.hwndOwner = hwndMain;
- ofn.lpstrFilter = tmp;
- ofn.nFilterIndex = 1;
- ofn.hInstance = hInst;
- ofn.lpstrFile = fname;
- ofn.lpstrTitle = "Save as";
- ofn.lpstrInitialDir = LibDir;
- ofn.nMaxFile = lenbuf;
- ofn.Flags = OFN_NOCHANGEDIR | OFN_LONGNAMES |
- OFN_HIDEREADONLY |OFN_EXPLORER;
- r = GetSaveFileName(&ofn);
- if (r == 0)
- return 0;
- else return 1;
-}
-/*------------------------------------------------------------------------
- Procedure: BrowseForFile ID:1
- Purpose: Let's the user browse for a certain kind of file.
- Currently this is only used when browsing for
- ocaml.exe.
- Input: The name of the file to browse for, and the path
- where the user's choice will be stored.
- Output: 1 if user choosed a path, zero otherwise
- Errors: None
-------------------------------------------------------------------------*/
-int BrowseForFile(char *fname,char *path)
-{
- OPENFILENAME ofn;
- char *p,tmp[512],browsefor[512];
- int r;
-
- memset(tmp,0,sizeof(tmp));
- strncpy(tmp,fname,sizeof(tmp)-1);
- p = tmp;
- while (*p) {
- if (*p == '|')
- *p = 0;
- p++;
- }
- memset(&ofn,0,sizeof(OPENFILENAME));
- ofn.lpstrFilter = tmp;
- ofn.nFilterIndex = 1;
- ofn.lStructSize = sizeof(OPENFILENAME);
- ofn.hwndOwner = hwndMain;
- ofn.hInstance = hInst;
- ofn.lpstrFilter = tmp;
- ofn.lpstrFile = path;
- wsprintf(browsefor,"Open %s",fname);
- ofn.lpstrTitle = browsefor;
- ofn.lpstrInitialDir = "c:\\";
- ofn.nMaxFile = MAX_PATH;
- ofn.Flags = OFN_PATHMUSTEXIST | OFN_NOCHANGEDIR | OFN_LONGNAMES |
- OFN_HIDEREADONLY |OFN_EXPLORER;
- r = GetOpenFileName(&ofn);
- if (r == 0)
- return 0;
- else return 1;
-}
-
-/*------------------------------------------------------------------------
- Procedure: CallChangeFont ID:1
- Purpose: Calls the standard windows font change dialog. If the
- user validates a font, it will destroy the current
- font, and recreate a new font with the given
- parameters.
- Input: The calling window handle
- Output: Zero if the user cancelled, 1 otherwise.
- Errors: None
-------------------------------------------------------------------------*/
-static int CallChangeFont(HWND hwnd)
-{
- LOGFONT lf;
- CHOOSEFONT cf;
- int r;
- HWND hwndChild;
-
- memset(&cf, 0, sizeof(CHOOSEFONT));
- memcpy(&lf, &CurrentFont, sizeof(LOGFONT));
- cf.lStructSize = sizeof(CHOOSEFONT);
- cf.hwndOwner = hwnd;
- cf.lpLogFont = &lf;
- cf.Flags = CF_SCREENFONTS | CF_EFFECTS | CF_APPLY | CF_INITTOLOGFONTSTRUCT;
- cf.nFontType = SCREEN_FONTTYPE;
- r = ChooseFont(&cf);
- if (!r)
- return (0);
- DeleteObject(ProgramParams.hFont);
- memcpy(&CurrentFont, &lf, sizeof(LOGFONT));
- ProgramParams.hFont = CreateFontIndirect(&CurrentFont);
- strcpy(CurrentFontName, CurrentFont.lfFaceName);
- CurrentFontFamily = lf.lfPitchAndFamily;
- CurrentFontStyle = lf.lfWeight;
- hwndChild = (HWND) GetWindowLong(hwndSession, DWL_USER);
- SendMessage(hwndChild,WM_SETFONT,(WPARAM)ProgramParams.hFont,0);
- ForceRepaint();
- return (1);
-}
-
-/*------------------------------------------------------------------------
- Procedure: CallDlgProc ID:1
- Purpose: Calls a dialog box procedure
- Input: The function to call, and the numerical ID of the
- resource where the dialog box is stored
- Output: Returns the result of the dialog box.
- Errors: None
-------------------------------------------------------------------------*/
-int CallDlgProc(BOOL (CALLBACK *fn)(HWND,UINT,WPARAM,LPARAM), int id)
-{
- int result;
-
- result = DialogBoxParam(hInst, MAKEINTRESOURCE(id), GetActiveWindow(),
- fn, 0);
- return result;
-}
-
-
-/*------------------------------------------------------------------------
- Procedure: CallChangeColor ID:1
- Purpose: Calls the standard color dialog of windows, starting
- with the given color reference. The result is the
- same as the input if the user cancels, or another
- color if the user validates another one.
- Input: The starting color
- Output: The color the user has choosen.
- Errors: None
-------------------------------------------------------------------------*/
-static COLORREF CallChangeColor(COLORREF InitialColor)
-{
- CHOOSECOLOR CC;
- COLORREF CustColors[16];
- int r, g, b, i;
- memset(&CC, 0, sizeof(CHOOSECOLOR));
- r = g = b = 0;
- for (i = 0; i < 16; i++) {
- CustColors[i] = RGB(r, g, b);
- if (r < 255)
- r += 127;
- else if (g < 255)
- g += 127;
- else if (b < 255)
- g += 127;
- }
- CC.lStructSize = sizeof(CHOOSECOLOR);
- CC.hwndOwner = hwndMain;
- CC.hInstance = hInst;
- CC.rgbResult = InitialColor;
- CC.lpCustColors = CustColors;
- CC.Flags = CC_RGBINIT;
- if (!ChooseColor(&CC))
- return (InitialColor);
- return (CC.rgbResult);
-}
-
-/*------------------------------------------------------------------------
- Procedure: CallPrintSetup ID:1
- Purpose: Calls the printer setup dialog. Currently it is not
- connected to the rest of the software, since printing
- is not done yet
- Input: None
- Output: 1 if OK, 0, user cancelled
- Errors: None
-------------------------------------------------------------------------*/
-static int CallPrintSetup(void)
-{
- PAGESETUPDLG sd;
- int r;
-
- memset(&sd,0,sizeof(sd));
- sd.lStructSize = sizeof(sd);
- sd.Flags = PSD_RETURNDEFAULT;
- r = PageSetupDlg(&sd);
- if (!r)
- return 0;
- sd.Flags = 0;
- r = PageSetupDlg(&sd);
- return r;
-}
-
-
-/*------------------------------------------------------------------------
- Procedure: Undo ID:1
- Purpose: Send an UNDO command to the edit field.
- Input: The parent window of the control
- Output: None
- Errors: None
-------------------------------------------------------------------------*/
-void Undo(HWND hwnd)
-{
- HWND hEdit;
-
- hEdit = (HWND)GetWindowLong(hwnd,DWL_USER);
- SendMessage(hEdit,EM_UNDO,0,0);
-}
-
-/*------------------------------------------------------------------------
- Procedure: ForceRepaint ID:1
- Purpose: Forces a complete redraw of the edit control of the
- current session.
- Input: None
- Output: None
- Errors: None
-------------------------------------------------------------------------*/
-void ForceRepaint(void)
-{
- HWND hwndEdit = (HWND)GetWindowLong(hwndSession,DWL_USER);
- InvalidateRect(hwndEdit,NULL,1);
-}
-
-static void Add_Char_To_Queue(int c)
-{
- HWND hwndEdit = (HWND)GetWindowLong(hwndSession,DWL_USER);
- SendMessage(hwndEdit,WM_CHAR,c,1);
-}
-
-/*------------------------------------------------------------------------
- Procedure: AddLineToControl ID:1
- Purpose: It will ad the given text at the end of the edit
- control, then it will send a return character to it.
- This simulates user input. The history will not be
- modified by this procedure.
- Input: The text to be added
- Output: None
- Errors: If the line is empty, nothing will be done
-------------------------------------------------------------------------*/
-void AddLineToControl(char *buf)
-{
- HWND hEditCtrl;
-
- if (*buf == 0)
- return;
- hEditCtrl = (HWND)GetWindowLong(hwndSession,DWL_USER);
- GotoEOF();
- SendMessage(hEditCtrl,EM_REPLACESEL,0,(LPARAM)buf);
- SendMessage(hEditCtrl,WM_CHAR,'\r',0);
-}
-
-/*------------------------------------------------------------------------
- Procedure: AboutDlgProc ID:1
- Purpose: Shows the "About" dialog box
- Input:
- Output:
- Errors:
-------------------------------------------------------------------------*/
-static BOOL CALLBACK AboutDlgProc(HWND hDlg, UINT message, WPARAM wParam, LPARAM lParam)
-{
- if (message == WM_CLOSE)
- EndDialog(hDlg,1);
- return 0;
-}
-/*------------------------------------------------------------------------
- Procedure: HistoryDlgProc ID:1
- Purpose: Shows the history of the session. Only input lines
- are shown. A double click in a line will make this
- dialog box procedure return the index of the selected
- line (1 based). If the windows is closed (what is
- equivalent to cancel), the return value is zero.
- Input: Normal windows callback
- Output:
- Errors:
-------------------------------------------------------------------------*/
-static BOOL CALLBACK HistoryDlgProc(HWND hDlg, UINT message, WPARAM wParam, LPARAM lParam)
-{
- HISTORYLINE *rvp;
- int idx;
- RECT rc;
-
- switch (message) {
- case WM_INITDIALOG:
- SendDlgItemMessage(hDlg,IDLIST,WM_SETFONT,(WPARAM)ProgramParams.hFont,0);
- rvp = History;
- idx = 0;
- while (rvp) {
- SendDlgItemMessage(hDlg,IDLIST,LB_INSERTSTRING,0,(LPARAM)rvp->Text);
- SendDlgItemMessage(hDlg,IDLIST,LB_SETITEMDATA,0,(LPARAM)idx);
- rvp = rvp->Next;
- idx++;
- }
- SendDlgItemMessage(hDlg,IDLIST,LB_SETCURSEL,(LPARAM)idx-1,0);
- return 1;
- case WM_COMMAND:
- switch(LOWORD(wParam)) {
- case IDLIST:
- switch(HIWORD(wParam)) {
- case LBN_DBLCLK:
- idx = SendDlgItemMessage(hDlg,IDLIST,LB_GETCURSEL,0,0);
- if (idx == LB_ERR)
- break;
- idx = SendDlgItemMessage(hDlg,IDLIST,LB_GETITEMDATA,idx,0);
- EndDialog(hDlg,idx+1);
- return 1;
- }
- break;
- }
- break;
- case WM_SIZE:
- GetClientRect(hDlg,&rc);
- MoveWindow(GetDlgItem(hDlg,IDLIST),0,0,rc.right,rc.bottom,1);
- break;
-
- case WM_CLOSE:
- EndDialog(hDlg,0);
- break;
- }
- return 0;
-}
-/*------------------------------------------------------------------------
- Procedure: SaveText ID:1
- Purpose: Saves the contents of the session transcript. It will
- loop for each line and write it to the specified file
- Input: The name of the file where the session will be saved
- Output: The session is saved
- Errors: If it can't open the file for writing it will show an
- error box
-------------------------------------------------------------------------*/
-static void SaveText(char *fname)
-{
- int i,len;
- HWND hEdit = (HWND)GetWindowLong(hwndSession,DWL_USER);
- int linesCount = SendMessage(hEdit,EM_GETLINECOUNT,0,0);
- FILE *f;
- char *buf = SafeMalloc(8192);
-
- f = fopen(fname,"wb");
- if (f == NULL) {
- wsprintf("Impossible to open %s for writing",fname);
- ShowDbgMsg(buf);
- return;
- }
- for (i=0; i<linesCount;i++) {
- *(unsigned short *)buf = 8100;
- len = SendMessage(hEdit,EM_GETLINE,i,(LPARAM)buf);
- buf[len] = 0;
- strcat(buf,"\r\n");
- fwrite(buf,1,len+2,f);
- }
- fclose(f);
- free(buf);
-}
-
-
-static void Add_Clipboard_To_Queue(void)
-{
- if (IsClipboardFormatAvailable(CF_TEXT) &&
- OpenClipboard(hwndMain))
- {
- HANDLE hClipData = GetClipboardData(CF_TEXT);
-
- if (hClipData)
- {
- char *str = GlobalLock(hClipData);
-
- if (str)
- while (*str)
- {
- if (*str != '\r')
- Add_Char_To_Queue(*str);
- str++;
- }
- GlobalUnlock(hClipData);
- }
- CloseClipboard();
- }
-
-}
-
-static void CopyToClipboard(HWND hwnd)
-{
- HWND hwndEdit = (HWND)GetWindowLong(hwndSession,DWL_USER);
- SendMessage(hwndEdit,WM_COPY,0,0);
-}
-
-int ResetText(void)
-{
- HWND hwndEdit = (HWND) GetWindowLong(hwndSession,DWL_USER);
- TEXTRANGE cr;
- int len = SendMessage(hwndEdit,WM_GETTEXTLENGTH,0,0);
- char *tmp = malloc(len+10),*p;
-
- memset(tmp,0,len+10);
- cr.chrg.cpMin = 0;
- cr.chrg.cpMax = -1;
- cr.lpstrText = tmp;
- SendMessage(hwndEdit,EM_GETTEXTRANGE,0,(LPARAM)&cr);
- p = tmp+len/2;
- while (*p && *p != '\r')
- p++;
- SendMessage(hwndEdit,EM_SETSEL,0,(LPARAM)-1);
- SendMessage(hwndEdit,EM_REPLACESEL,0,(LPARAM)p);
- InvalidateRect(hwndEdit,0,1);
- free(tmp);
- return 0;
-}
-
-/*------------------------------------------------------------------------
- Procedure: HandleCommand ID:1
- Purpose: Handles all menu commands.
- Input:
- Output:
- Errors:
-------------------------------------------------------------------------*/
-void HandleCommand(HWND hwnd, WPARAM wParam,LPARAM lParam)
-{
- char *fname;
- int r;
-
- switch(LOWORD(wParam)) {
- case IDM_OPEN:
- fname = SafeMalloc(512);
- if (OpenMlFile(fname,512)) {
- char *buf = SafeMalloc(512);
- char *p = strrchr(fname,'.');
- if (p && !stricmp(p,".ml")) {
- wsprintf(buf,"#use \"%s\";;",fname);
- AddLineToControl(buf);
- }
- else if (p && !stricmp(p,".cmo")) {
- wsprintf(buf,"#load \"%s\";;",fname);
- AddLineToControl(buf);
- }
- free(buf);
- }
- free(fname);
- break;
- case IDM_GC:
- AddLineToControl("Gc.full_major();;");
- break;
- case IDCTRLC:
- InterruptOcaml();
- break;
- case IDM_EDITPASTE:
- Add_Clipboard_To_Queue();
- break;
- case IDM_EDITCOPY:
- CopyToClipboard(hwnd);
- break;
- case IDM_SAVE:
- fname = SafeMalloc(512);
- if (GetSaveName(fname,512)) {
- SaveText(fname);
- }
- free(fname);
- break;
- case IDM_HISTORY:
- r = CallDlgProc(HistoryDlgProc,IDD_HISTORY);
- if (r) {
- AddLineToControl(GetHistoryLine(r-1));
- }
- break;
- case IDM_PRINTSU:
- CallPrintSetup();
- break;
- case IDM_FONT:
- CallChangeFont(hwndMain);
- break;
- case IDM_COLORTEXT:
- ProgramParams.TextColor = CallChangeColor(ProgramParams.TextColor);
- ForceRepaint();
- break;
- case IDM_BACKCOLOR:
- BackColor = CallChangeColor(BackColor);
- DeleteObject(BackgroundBrush);
- BackgroundBrush = CreateSolidBrush(BackColor);
- ForceRepaint();
- break;
- case IDM_EDITUNDO:
- Undo(hwnd);
- break;
- case IDM_WINDOWTILE:
- SendMessage(hwndMDIClient,WM_MDITILE,0,0);
- break;
- case IDM_WINDOWCASCADE:
- SendMessage(hwndMDIClient,WM_MDICASCADE,0,0);
- break;
- case IDM_WINDOWICONS:
- SendMessage(hwndMDIClient,WM_MDIICONARRANGE,0,0);
- break;
- case IDM_EXIT:
- PostMessage(hwnd,WM_CLOSE,0,0);
- break;
- case IDM_ABOUT:
- CallDlgProc(AboutDlgProc,IDD_ABOUT);
- break;
- default:
- if (LOWORD(wParam) >= IDEDITCONTROL && LOWORD(wParam) < IDEDITCONTROL+5) {
- switch (HIWORD(wParam)) {
- case EN_ERRSPACE:
- ResetText();
- break;
- }
- }
- break;
- }
-}
-
diff --git a/win32caml/ocaml.c b/win32caml/ocaml.c
deleted file mode 100644
index 1172b2bd8b..0000000000
--- a/win32caml/ocaml.c
+++ /dev/null
@@ -1,816 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Developed by Jacob Navia. */
-/* Copyright 2001 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/*@@ Wedit generated application. Written Sat Jun 02 18:22:38 2001
- @@header: D:\lcc\inria\inriares.h
- @@resources: D:\lcc\inria\inria.rc
- Do not edit outside the indicated areas */
-/*<---------------------------------------------------------------------->*/
-/*<---------------------------------------------------------------------->*/
-#include <windows.h>
-#include <windowsx.h>
-#include <commctrl.h>
-#include <string.h>
-#include <direct.h>
-#include <Richedit.h>
-#include "inriares.h"
-#include "inria.h"
-int EditControls = IDEDITCONTROL;
-static WNDPROC lpEProc;
-static char lineBuffer[1024*32];
-int ResetText(void);
-int ReadToLineBuffer(void);
-int AddLineBuffer(void);
-static int busy;
-static DWORD TimerId;
-POSITION LastPromptPosition;
-char LibDir[512];
-char OcamlPath[512];
-HBRUSH BackgroundBrush;
-COLORREF BackColor = RGB(255,255,255);
-PROGRAM_PARAMS ProgramParams;
-HISTORYLINE *History;
-/*<----------------- global variables --------------------------------------->*/
-HANDLE hInst; // Instance handle
-HWND hwndMain; //Main window handle
-HWND hwndSession;
-HWND hwndMDIClient; //Mdi client window handle
-static LRESULT CALLBACK MainWndProc(HWND hwnd,UINT msg,WPARAM wParam,LPARAM lParam);
-static LRESULT CALLBACK MdiChildWndProc(HWND hwnd,UINT msg,WPARAM wParam,LPARAM lParam);
-PROCESS_INFORMATION pi;
-HWND hWndStatusbar;
-
-/*------------------------------------------------------------------------
- Procedure: UpdateStatusBar ID:1
- Purpose: Updates the statusbar control with the appropiate
- text
- Input: lpszStatusString: Charactar string that will be shown
- partNumber: index of the status bar part number.
- displayFlags: Decoration flags
- Output: none
- Errors: none
-
-------------------------------------------------------------------------*/
-void UpdateStatusBar(LPSTR lpszStatusString, WORD partNumber, WORD displayFlags)
-{
- SendMessage(hWndStatusbar,
- SB_SETTEXT,
- partNumber | displayFlags,
- (LPARAM)lpszStatusString);
-}
-
-
-/*------------------------------------------------------------------------
- Procedure: MsgMenuSelect ID:1
- Purpose: Shows in the status bar a descriptive explaation of
- the purpose of each menu item.The message
- WM_MENUSELECT is sent when the user starts browsing
- the menu for each menu item where the mouse passes.
- Input: Standard windows.
- Output: The string from the resources string table is shown
- Errors: If the string is not found nothing will be shown.
-------------------------------------------------------------------------*/
-LRESULT MsgMenuSelect(HWND hwnd, UINT uMessage, WPARAM wparam, LPARAM lparam)
-{
- static char szBuffer[256];
- UINT nStringID = 0;
- UINT fuFlags = GET_WM_MENUSELECT_FLAGS(wparam, lparam) & 0xffff;
- UINT uCmd = GET_WM_MENUSELECT_CMD(wparam, lparam);
- HMENU hMenu = GET_WM_MENUSELECT_HMENU(wparam, lparam);
-
- szBuffer[0] = 0; // First reset the buffer
- if (fuFlags == 0xffff && hMenu == NULL) // Menu has been closed
- nStringID = 0;
-
- else if (fuFlags & MFT_SEPARATOR) // Ignore separators
- nStringID = 0;
-
- else if (fuFlags & MF_POPUP) // Popup menu
- {
- if (fuFlags & MF_SYSMENU) // System menu
- nStringID = IDS_SYSMENU;
- else
- // Get string ID for popup menu from idPopup array.
- nStringID = 0;
- } // for MF_POPUP
- else // Must be a command item
- nStringID = uCmd; // String ID == Command ID
-
- // Load the string if we have an ID
- if (0 != nStringID)
- LoadString(hInst, nStringID, szBuffer, sizeof(szBuffer));
- // Finally... send the string to the status bar
- UpdateStatusBar(szBuffer, 0, 0);
- return 0;
-}
-
-/*------------------------------------------------------------------------
- Procedure: TimerProc ID:1
- Purpose: This procedure will be called by windows about 4
- times a second. It will just send a message to the
- mdi child window to look at the pipe.
- Input:
- Output:
- Errors:
-------------------------------------------------------------------------*/
-static VOID CALLBACK TimerProc(HWND hwnd, UINT uMsg, UINT idEvent, DWORD dwTime)
-{
- SendMessage(hwndSession, WM_TIMERTICK, 0, 0);
-}
-
-/*------------------------------------------------------------------------
- Procedure: InitializeStatusBar ID:1
- Purpose: Initialize the status bar
- Input: hwndParent: the parent window
- nrOfParts: The status bar can contain more than one
- part. What is difficult, is to figure out how this
- should be drawn. So, for the time being only one is
- being used...
- Output: The status bar is created
- Errors:
-------------------------------------------------------------------------*/
-void InitializeStatusBar(HWND hwndParent,int nrOfParts)
-{
- const int cSpaceInBetween = 8;
- int ptArray[40]; // Array defining the number of parts/sections
- RECT rect;
- HDC hDC;
-
- /* * Fill in the ptArray... */
-
- hDC = GetDC(hwndParent);
- GetClientRect(hwndParent, &rect);
-
- ptArray[nrOfParts-1] = rect.right;
- //---TODO--- Add code to calculate the size of each part of the status
- // bar here.
-
- ReleaseDC(hwndParent, hDC);
- SendMessage(hWndStatusbar,
- SB_SETPARTS,
- nrOfParts,
- (LPARAM)(LPINT)ptArray);
-
- UpdateStatusBar("Ready", 0, 0);
-}
-
-
-/*------------------------------------------------------------------------
- Procedure: CreateSBar ID:1
- Purpose: Calls CreateStatusWindow to create the status bar
- Input: hwndParent: the parent window
- initial text: the initial contents of the status bar
- Output:
- Errors:
-------------------------------------------------------------------------*/
-static BOOL CreateSBar(HWND hwndParent,char *initialText,int nrOfParts)
-{
- hWndStatusbar = CreateStatusWindow(WS_CHILD | WS_VISIBLE | WS_BORDER|SBARS_SIZEGRIP,
- initialText,
- hwndParent,
- IDM_STATUSBAR);
- if(hWndStatusbar)
- {
- InitializeStatusBar(hwndParent,nrOfParts);
- return TRUE;
- }
-
- return FALSE;
-}
-/*------------------------------------------------------------------------
- Procedure: InitApplication ID:1
- Purpose: Registers two window classes: the "inria" window
- class with the main window, and the mdi child
- window's window class.
- Input:
- Output:
- Errors:
-------------------------------------------------------------------------*/
-static BOOL InitApplication(void)
-{
- WNDCLASS wc;
-
- memset(&wc,0,sizeof(WNDCLASS));
- wc.style = CS_HREDRAW|CS_VREDRAW |CS_DBLCLKS ;
- wc.lpfnWndProc = (WNDPROC)MainWndProc;
- wc.hInstance = hInst;
- wc.hbrBackground = (HBRUSH)(COLOR_WINDOW+1);
- wc.lpszClassName = "inriaWndClass";
- wc.lpszMenuName = MAKEINTRESOURCE(IDMAINMENU);
- wc.hCursor = LoadCursor(NULL,IDC_ARROW);
- wc.hIcon = LoadIcon(hInst,MAKEINTRESOURCE(OCAML_ICON));
- if (!RegisterClass(&wc))
- return 0;
- wc.style = 0;
- wc.lpfnWndProc = (WNDPROC)MdiChildWndProc;
- wc.cbClsExtra = 0;
- wc.cbWndExtra = 20;
- wc.hInstance = hInst; // Owner of this class
- wc.hIcon = LoadIcon(hInst, MAKEINTRESOURCE(OCAML_ICON));
- wc.hCursor = LoadCursor(NULL, IDC_ARROW);
- wc.hbrBackground = (HBRUSH)(COLOR_WINDOW + 1); // Default color
- wc.lpszMenuName = NULL;
- wc.lpszClassName = "MdiChildWndClass";
- if (!RegisterClass((LPWNDCLASS)&wc))
- return FALSE;
- return 1;
-}
-
-/*------------------------------------------------------------------------
- Procedure: CreateinriaWndClassWnd ID:1
- Purpose: Creates the main window
- Input:
- Output:
- Errors:
-------------------------------------------------------------------------*/
-HWND CreateinriaWndClassWnd(void)
-{
- return CreateWindow("inriaWndClass","Ocaml",
- WS_MINIMIZEBOX|WS_VISIBLE|WS_CLIPSIBLINGS|WS_CLIPCHILDREN|WS_MAXIMIZEBOX|WS_CAPTION|WS_BORDER|WS_SYSMENU|WS_THICKFRAME,
- CW_USEDEFAULT,0,CW_USEDEFAULT,0,
- NULL,
- NULL,
- hInst,
- NULL);
-}
-
-/*------------------------------------------------------------------------
- Procedure: MDICmdFileNew ID:1
- Purpose: Creates a new session window. Note that multiple
- windows with multiple sessions are possible.
- Input:
- Output:
- Errors:
-------------------------------------------------------------------------*/
-static HWND MDICmdFileNew(char *title, int show)
-{
- HWND hwndChild;
- char rgch[150];
- static int cUntitled;
- MDICREATESTRUCT mcs;
-
- if (title == NULL)
- wsprintf(rgch,"Session%d", cUntitled++);
- else {
- strncpy(rgch,title,149);
- rgch[149] = 0;
- }
-
- // Create the MDI child window
-
- mcs.szClass = "MdiChildWndClass"; // window class name
- mcs.szTitle = rgch; // window title
- mcs.hOwner = hInst; // owner
- mcs.x = CW_USEDEFAULT; // x position
- mcs.y = CW_USEDEFAULT; // y position
- mcs.cx = CW_USEDEFAULT; // width
- mcs.cy = CW_USEDEFAULT; // height
- mcs.style = 0; // window style
- mcs.lParam = 0; // lparam
-
- hwndChild = (HWND) SendMessage(hwndMDIClient,
- WM_MDICREATE,
- 0,
- (LPARAM)(LPMDICREATESTRUCT) &mcs);
-
- if (hwndChild != NULL && show)
- ShowWindow(hwndChild, SW_SHOW);
-
- return hwndChild;
-}
-static HWND CreateMdiClient(HWND hwndparent)
-{
- CLIENTCREATESTRUCT ccs = {0};
- HWND hwndMDIClient;
- int icount = GetMenuItemCount(GetMenu(hwndparent));
-
- // Find window menu where children will be listed
- ccs.hWindowMenu = GetSubMenu(GetMenu(hwndparent), icount-2);
- ccs.idFirstChild = IDM_WINDOWCHILD;
-
- // Create the MDI client filling the client area
- hwndMDIClient = CreateWindow("mdiclient",
- NULL,
- WS_CHILD | WS_CLIPCHILDREN | WS_VSCROLL |
- WS_HSCROLL,
- 0, 0, 0, 0,
- hwndparent,
- (HMENU)0xCAC,
- hInst,
- (LPVOID)&ccs);
-
- ShowWindow(hwndMDIClient, SW_SHOW);
-
- return hwndMDIClient;
-}
-
-void GotoEOF(void)
-{
- HWND hEdit = (HWND)GetWindowLong(hwndSession,DWL_USER);
- int linesCount = SendMessage(hEdit,EM_GETLINECOUNT,0,0);
- int lineindex = SendMessage(hEdit,EM_LINEINDEX,linesCount-1,0);
- int lastLineLength = SendMessage(hEdit,EM_LINELENGTH,linesCount-1,0);
-
- lineindex += lastLineLength;
- SendMessage(hEdit,EM_SETSEL,lineindex,lineindex);
-}
-
-int GetCurLineIndex(HWND hEdit)
-{
- return SendMessage(hEdit,EM_LINEFROMCHAR,(WPARAM)-1,0);
-}
-
-int GetNumberOfLines(HWND hEdit)
-{
- return SendMessage(hEdit,EM_GETLINECOUNT,0,0);
-}
-
-static int GetWordUnderCursor(HWND hwndEditControl,char *buf,int len)
-{
- char *line,*p,*pstart,*pend;
- int lineidx,start,end,length,offset,cursorpos,startingChar;
-
- SendMessage(hwndEditControl,EM_GETSEL,(WPARAM)&start,(LPARAM)&end);
- lineidx = SendMessage(hwndEditControl,EM_EXLINEFROMCHAR,0,start);
- startingChar = SendMessage(hwndEditControl,EM_LINEINDEX,lineidx,0);
- start -= startingChar;
- end -= startingChar;
- lineidx = SendMessage(hwndEditControl,EM_LINEFROMCHAR,start,0);
- length = SendMessage(hwndEditControl,EM_LINELENGTH,lineidx,0);
- offset = SendMessage(hwndEditControl,EM_LINEINDEX,lineidx,0);
- line = SafeMalloc(length+1);
- memset(line,0,length+1);
- *(unsigned short *)line = length;
- SendMessage(hwndEditControl,EM_GETLINE,lineidx,(LPARAM)line);
- cursorpos = start-offset;
- p = line + cursorpos;
- pstart = p;
- while (*pstart
- && *pstart != ' '
- && *pstart != '\t'
- && *pstart != '('
- && pstart > line)
- pstart--;
- pend = p;
- while (*pend
- && *pend != ' '
- && *pend != '\t'
- && *pend != '('
- && pend < line + length)
- pend++;
- if (*pstart == ' ' || *pstart == '\t')
- pstart++;
- if (*pend == ' ' || *pend == '\t')
- pend--;
- memcpy(buf,pstart,1+pend-pstart);
- buf[pend-pstart] = 0;
- free(line);
- return 1;
-}
-
-void DoHelp(HWND hwnd)
-{
- char word[256];
- GetWordUnderCursor(hwnd,word,sizeof(word));
- MessageBox(NULL,word,"Aide pour:",MB_OK);
-}
-
-
-static LRESULT CALLBACK SubClassEdit(HWND hwnd, UINT msg, WPARAM mp1, LPARAM mp2)
-{
- LRESULT r;
- int postit=0,nl;
- if (msg == WM_CHAR && mp1 == '\r') {
- if (!busy) {
- CallWindowProc(lpEProc,hwnd,WM_KEYDOWN,VK_END,1);
- CallWindowProc(lpEProc,hwnd,WM_KEYUP,VK_END,1);
- r = GetCurLineIndex(hwnd);
- nl = GetNumberOfLines(hwnd);
- if (r != nl-1) {
- PostMessage(GetParent(hwnd),WM_NEWLINE,0,0);
- return 0;
- }
- postit = 1;
- }
-
- }
- else if (msg == WM_KEYDOWN && mp1 == VK_F1) {
- DoHelp(hwnd);
- }
- r = CallWindowProc(lpEProc, hwnd, msg, mp1, mp2);
- if (postit)
- PostMessage(GetParent(hwnd),WM_NEWLINE,0,0);
- return r;
-}
-
-static void SubClassEditField(HWND hwnd)
-{
- if (lpEProc == NULL) {
- lpEProc = (WNDPROC) GetWindowLong(hwnd, GWL_WNDPROC);
- }
- SetWindowLong(hwnd, GWL_WNDPROC, (DWORD) SubClassEdit);
-}
-
-void AddToHistory(char *text)
-{
- HISTORYLINE *newLine;
-
- while (*text == ' ')
- text++; // skip leading blanks
- if (*text == 0)
- return;
- if (History && !strstr(History->Text,";;")) {
- char *p = History->Text;
- int len = strlen(p)+strlen(text) + 1 + 1; // space and zero terminator
- History->Text = SafeMalloc(len);
- strcpy(History->Text,p);
- strcat(History->Text," ");
- strcat(History->Text,text);
- free(p);
- return;
- }
- newLine = SafeMalloc(sizeof(HISTORYLINE));
- newLine->Next = History;
- newLine->Text = SafeMalloc(strlen(text)+1);
- strcpy(newLine->Text,text);
- History = newLine;
-}
-
-char *GetHistoryLine(int n)
-{
- HISTORYLINE *rvp = History;
- int i;
-
- for (i=0; i<n; i++) {
- rvp = rvp->Next;
- }
- if (rvp)
- return &rvp->Text[0];
- else
- return "";
-}
-
-/*------------------------------------------------------------------------
- Procedure: SendLastLine ID:1
- Purpose: Sends the data in the line containing the cursor to
- the interpreter. If this is NOT the last line, copy
- the line to the end of the text.
- Input: The edit control window handle
- Output: None explicit
- Errors: None
-------------------------------------------------------------------------*/
-void SendLastLine(HWND hEdit)
-{
- int curline = GetCurLineIndex(hEdit);
- char *p,linebuffer[2048];
- int n;
- int linescount = GetNumberOfLines(hEdit);
-
- *(unsigned short *)linebuffer = sizeof(linebuffer)-1;
- if (curline != linescount-1)
- n = SendMessage(hEdit,EM_GETLINE,curline,(LPARAM)linebuffer);
- else
- n = SendMessage(hEdit,EM_GETLINE,curline-1,(LPARAM)linebuffer);
- if (n >= 2 && linebuffer[0] == '#' && linebuffer[1] == ' ') {
- n -= 2;
- memmove(linebuffer, linebuffer+2, n);
- }
- linebuffer[n] = 0;
- // Record user input!
- AddToHistory(linebuffer);
- linebuffer[n] = '\n';
- linebuffer[n+1] = 0;
- WriteToPipe(linebuffer);
- if (curline != linescount-1) {
- // Copy the line sent to the end of the text
- p = strrchr(linebuffer,'\n');
- if (p) {
- *p = 0;
- }
- busy = 1;
- AddLineToControl(linebuffer);
- busy = 0;
- }
-}
-/*------------------------------------------------------------------------
- Procedure: SetLastPrompt ID:1
- Purpose: Record the position of the last prompt ("# ") sent by
- the interpreter. This isn't really used yet.
- Input:
- Output:
- Errors:
-------------------------------------------------------------------------*/
-void SetLastPrompt(HWND hEdit)
-{
- DWORD startpos,endpos;
- SendMessage(hEdit,EM_GETSEL,(WPARAM)&startpos,(LPARAM)&endpos);
- LastPromptPosition.line = SendMessage(hEdit,EM_LINEFROMCHAR,(WPARAM)-1,0);
- LastPromptPosition.col = startpos;
-}
-
-/*------------------------------------------------------------------------
- Procedure: MdiChildWndProc ID:1
- Purpose: The edit control is enclosed in a normal MDI window.
- This is the window procedure for that window. When it
- receives the WM_CREATE message, it will create the
- edit control.
- Input:
- Output:
- Errors:
-------------------------------------------------------------------------*/
-static LRESULT CALLBACK MdiChildWndProc(HWND hwnd,UINT msg,WPARAM wparam,LPARAM lparam)
-{
- HWND hwndChild;
- RECT rc;
- HDC hDC;
-
- switch(msg) {
- case WM_CREATE:
- GetClientRect(hwnd,&rc);
- hwndChild= CreateWindow("EDIT",
- NULL,
- WS_CHILD | WS_VISIBLE |
- ES_MULTILINE |
- WS_VSCROLL | WS_HSCROLL |
- ES_AUTOHSCROLL | ES_AUTOVSCROLL,
- 0,
- 0,
- (rc.right-rc.left),
- (rc.bottom-rc.top),
- hwnd,
- (HMENU) EditControls++,
- hInst,
- NULL);
- SetWindowLong(hwnd, DWL_USER, (DWORD) hwndChild);
- SendMessage(hwndChild, WM_SETFONT, (WPARAM) ProgramParams.hFont, 0L);
- SendMessage(hwndChild,EM_LIMITTEXT,0xffffffff,0);
- SubClassEditField(hwndChild);
- break;
- // Resize the edit control
- case WM_SIZE:
- hwndChild = (HWND) GetWindowLong(hwnd, DWL_USER);
- MoveWindow(hwndChild, 0, 0, LOWORD(lparam), HIWORD(lparam), TRUE);
- break;
- // Always set the focus to the edit control.
- case WM_SETFOCUS:
- hwndChild = (HWND) GetWindowLong(hwnd, DWL_USER);
- SetFocus(hwndChild);
- break;
- // Repainting of the edit control about to happen.
- // Set the text color and the background color
- case WM_CTLCOLOREDIT:
- hDC = (HDC)wparam;
- SetTextColor(hDC,ProgramParams.TextColor);
- SetBkColor(hDC,BackColor);
- return (LRESULT)BackgroundBrush;
- // Take care of erasing the background color to avoid flicker
- case WM_ERASEBKGND:
- GetWindowRect(hwnd,&rc);
- hDC = (HDC)wparam;
- FillRect(hDC,&rc,BackgroundBrush);
- return 1;
- // A carriage return has been pressed. Send the data to the interpreted.
- // This message is posted by the subclassed edit field.
- case WM_COMMAND:
- if (LOWORD(wparam) >= IDEDITCONTROL && LOWORD(wparam) < IDEDITCONTROL+5) {
- switch (HIWORD(wparam)) {
- case EN_ERRSPACE:
- case EN_MAXTEXT:
- ResetText();
- break;
- }
- }
- break;
- case WM_NEWLINE:
- if (busy)
- break;
- hwndChild = (HWND) GetWindowLong(hwnd, DWL_USER);
- SendLastLine(hwndChild);
- break;
- // The timer will call us 4 times a second. Look if the interpreter
- // has written something in its end of the pipe.
- case WM_TIMERTICK:
- hwndChild = (HWND) GetWindowLong(hwnd, DWL_USER);
- if (ReadToLineBuffer()) {
- char *p;
- // Ok we read something. Display it.
- AddLineBuffer();
- p = strrchr(lineBuffer,'\r');
- if (p && !strcmp(p,"\r\n# ")) {
- if (p[4] == 0) {
- SetLastPrompt(hwndChild);
- }
- }
-
- }
- break;
-
- }
- return DefMDIChildProc(hwnd, msg, wparam, lparam);
-}
-
-
-/*------------------------------------------------------------------------
- Procedure: MainWndProc ID:1
- Purpose: Window procedure for the frame window, that contains
- the menu. The messages handled are:
- WM_CREATE: Creates the mdi child window
- WM_SIZE: resizes the status bar and the mdi child
- window
- WM_COMMAND: Sends the command to the dispatcher
- WM_CLOSE: If the user confirms, it exists the program
- WM_QUITOCAML: Stops the program unconditionally.
- Input: Standard windows callback
- Output:
- Errors:
-------------------------------------------------------------------------*/
-static LRESULT CALLBACK MainWndProc(HWND hwnd,UINT msg,WPARAM wParam,LPARAM lParam)
-{
- switch (msg) {
- // Create the MDI client invisible window
- case WM_CREATE:
- hwndMDIClient = CreateMdiClient(hwnd);
- TimerId = SetTimer((HWND) 0, 0, 100, (TIMERPROC) TimerProc);
- break;
- // Move the child windows
- case WM_SIZE:
- SendMessage(hWndStatusbar,msg,wParam,lParam);
- InitializeStatusBar(hWndStatusbar,1);
- // Position the MDI client window between the tool and status bars
- if (wParam != SIZE_MINIMIZED) {
- RECT rc, rcClient;
-
- GetClientRect(hwnd, &rcClient);
- GetWindowRect(hWndStatusbar, &rc);
- ScreenToClient(hwnd, (LPPOINT)&rc.left);
- rcClient.bottom = rc.top;
- MoveWindow(hwndMDIClient,rcClient.left,rcClient.top,rcClient.right-rcClient.left, rcClient.bottom-rcClient.top, TRUE);
- }
-
- return 0;
- // Dispatch the menu commands
- case WM_COMMAND:
- HandleCommand(hwnd, wParam,lParam);
- return 0;
- // If user confirms close
- case WM_CLOSE:
- if (!AskYesOrNo("Quit Ocaml?"))
- return 0;
- break;
- // End application
- case WM_DESTROY:
- PostQuitMessage(0);
- break;
- // The interpreter has exited. Force close of the application
- case WM_QUITOCAML:
- DestroyWindow(hwnd);
- return 0;
- case WM_USER+1000:
- // TestGraphics();
- break;
- default:
- return DefFrameProc(hwnd,hwndMDIClient,msg,wParam,lParam);
- }
- return DefFrameProc(hwnd,hwndMDIClient,msg,wParam,lParam);
-}
-
-/*------------------------------------------------------------------------
- Procedure: CreationCourier ID:1
- Purpose: Creates the courier font
- Input:
- Output:
- Errors:
-------------------------------------------------------------------------*/
-static HFONT CreationCourier(int flag)
-{
- LOGFONT CurrentFont;
- memset(&CurrentFont, 0, sizeof(LOGFONT));
- CurrentFont.lfCharSet = ANSI_CHARSET;
- CurrentFont.lfWeight = FW_NORMAL;
- if (flag)
- CurrentFont.lfHeight = 18;
- else
- CurrentFont.lfHeight = 15;
- CurrentFont.lfPitchAndFamily = (BYTE) (FIXED_PITCH | FF_MODERN);
- strcpy(CurrentFont.lfFaceName, "Courier"); /* Courier */
- return (CreateFontIndirect(&CurrentFont));
-}
-
-/*------------------------------------------------------------------------
- Procedure: ReadToLineBuffer ID:1
- Purpose: Reads into the line buffer the characters written by
- the interpreter
- Input: None
- Output: The number of characters read
- Errors: None
-------------------------------------------------------------------------*/
-int ReadToLineBuffer(void)
-{
- memset(lineBuffer,0,sizeof(lineBuffer));
- return ReadFromPipe(lineBuffer,sizeof(lineBuffer));
-}
-
-/*------------------------------------------------------------------------
- Procedure: AddLineBuffer ID:1
- Purpose: Sends the contents of the line buffer to the edit
- control
- Input: None
- Output:
- Errors:
-------------------------------------------------------------------------*/
-int AddLineBuffer(void)
-{
- HWND hEditCtrl;
-
- hEditCtrl = (HWND)GetWindowLong(hwndSession,DWL_USER);
- return SendMessage(hEditCtrl,EM_REPLACESEL,0,(LPARAM)lineBuffer);
-
-}
-
-/*------------------------------------------------------------------------
- Procedure: Setup ID:1
- Purpose: Handles GUI initialization (Fonts, brushes, colors,
- etc)
- Input:
- Output:
- Errors:
-------------------------------------------------------------------------*/
-static int Setup(HANDLE *phAccelTable)
-{
- if (!InitApplication())
- return 0;
- ProgramParams.hFont = CreationCourier(1);
- ProgramParams.TextColor = RGB(0,0,0);
- GetObject(ProgramParams.hFont,sizeof(LOGFONT),&CurrentFont);
- BackgroundBrush = CreateSolidBrush(BackColor);
- *phAccelTable = LoadAccelerators(hInst,MAKEINTRESOURCE(IDACCEL));
- return 1;
-}
-
-
-/*------------------------------------------------------------------------
- Procedure: WinMain ID:1
- Purpose: Entry point for windows programs.
- Input:
- Output:
- Errors:
-------------------------------------------------------------------------*/
-int WINAPI WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, INT nCmdShow)
-{
- MSG msg;
- HANDLE hAccelTable;
- char consoleTitle[512];
- HWND hwndConsole;
-
- // Setup the hInst global
- hInst = hInstance;
- // Do the setup
- if (!Setup(&hAccelTable))
- return 0;
- // Need to set up a console so that we can send ctrl-break signal
- // to inferior Caml
- AllocConsole();
- GetConsoleTitle(consoleTitle,sizeof(consoleTitle));
- hwndConsole = FindWindow(NULL,consoleTitle);
- ShowWindow(hwndConsole,SW_HIDE);
- // Create main window and exit if this fails
- if ((hwndMain = CreateinriaWndClassWnd()) == (HWND)0)
- return 0;
- // Create the status bar
- CreateSBar(hwndMain,"Ready",2);
- // Show the window
- ShowWindow(hwndMain,SW_SHOW);
- // Create the session window
- hwndSession = MDICmdFileNew("Session transcript",0);
- // Get the path to ocaml.exe
- GetOcamlPath();
- // Start the interpreter
- StartOcaml();
- // Show the session window
- ShowWindow(hwndSession, SW_SHOW);
- // Maximize it
- SendMessage(hwndMDIClient, WM_MDIMAXIMIZE, (WPARAM) hwndSession, 0);
-
- PostMessage(hwndMain,WM_USER+1000,0,0);
- while (GetMessage(&msg,NULL,0,0)) {
- if (!TranslateMDISysAccel(hwndMDIClient, &msg))
- if (!TranslateAccelerator(msg.hwnd, hAccelTable, &msg)) {
- TranslateMessage(&msg); // Translates virtual key codes
- DispatchMessage(&msg); // Dispatches message to window
- }
- }
- WriteToPipe("#quit;;\r\n\032");
- KillTimer((HWND) 0, TimerId);
- return msg.wParam;
-}
diff --git a/win32caml/ocaml.ico b/win32caml/ocaml.ico
deleted file mode 100644
index 13560db450..0000000000
--- a/win32caml/ocaml.ico
+++ /dev/null
Binary files differ
diff --git a/win32caml/ocaml.rc b/win32caml/ocaml.rc
deleted file mode 100644
index 3497f5cb50..0000000000
--- a/win32caml/ocaml.rc
+++ /dev/null
@@ -1,114 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Developed by Jacob Navia. */
-/* Copyright 2001 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Wedit generated resource file */
-#include <windows.h>
-#include "inriares.h"
-
-1000 ICON "ocaml.ico"
-IDMAINMENU MENU
-BEGIN
- POPUP "&File"
- BEGIN
- MENUITEM "&Open...", IDM_OPEN
- MENUITEM "&Save", IDM_SAVE
- MENUITEM "Save &As...", IDM_SAVEAS
- MENUITEM "&Close", IDM_CLOSE
- MENUITEM SEPARATOR
- MENUITEM "&Print", IDM_PRINT
- MENUITEM "P&rint Setup...", IDM_PRINTSU
- MENUITEM SEPARATOR
- MENUITEM "E&xit", IDM_EXIT
- END
- POPUP "&Edit"
- BEGIN
- MENUITEM "&Undo Alt+BkSp", IDM_EDITUNDO
- MENUITEM SEPARATOR
- MENUITEM "Cu&t Shift+Del", IDM_EDITCUT
- MENUITEM "&Copy Ctrl+Ins", IDM_EDITCOPY
- MENUITEM "&Paste Shift+Ins", IDM_EDITPASTE
- MENUITEM "&Delete Del", IDM_EDITCLEAR
- END
- POPUP "Workspace"
- BEGIN
- MENUITEM "Font", IDM_FONT
- MENUITEM "Text Color", IDM_COLORTEXT
- MENUITEM "Background color", IDM_BACKCOLOR
- MENUITEM SEPARATOR
- MENUITEM "&History", IDM_HISTORY
- MENUITEM "&Garbage collect", IDM_GC
- MENUITEM "&Interrupt", IDCTRLC
- END
- POPUP "&Window"
- BEGIN
- MENUITEM "&Tile", IDM_WINDOWTILE
- MENUITEM "&Cascade", IDM_WINDOWCASCADE
- MENUITEM "Arrange &Icons", IDM_WINDOWICONS
- MENUITEM "Close &All", IDM_WINDOWCLOSEALL
- END
- POPUP "&Help"
- BEGIN
- MENUITEM "&About...", IDM_ABOUT
- END
-END
-BARMDI ACCELERATORS
-BEGIN
- 81, IDM_EXIT, VIRTKEY, CONTROL
-END
-
-IDD_ABOUT DIALOGEX 7, 29, 236, 81
-STYLE DS_CENTER | WS_POPUP | WS_VISIBLE | WS_CAPTION | WS_SYSMENU
-EXSTYLE WS_EX_CLIENTEDGE | WS_EX_TOOLWINDOW
-CAPTION "About Ocaml"
-FONT 8, "MS Sans Serif"
-BEGIN
- LTEXT "The Objective Caml system for windows", 101, 56, 9, 126, 12
- LTEXT "Windows Interface 2.0", 102, 78, 21, 72, 12
- LTEXT "Copyright 1996-2001", 103, 84, 42, 66, 10
- CTEXT "Institut National de Recherche en Informatique et Automatique", 104, 15, 56, 211, 10
- CTEXT "Réalisé par Jacob Navia 2001", 105, 19, 66, 207, 12
-END
-
-IDD_HISTORY DIALOGEX 6, 18, 261, 184
-STYLE DS_MODALFRAME | WS_POPUP | WS_VISIBLE | WS_CAPTION | WS_SYSMENU | WS_THICKFRAME
-EXSTYLE WS_EX_TOOLWINDOW
-CAPTION "Session History"
-FONT 8, "MS Sans Serif"
-BEGIN
- LISTBOX IDLIST, 7, 7, 247, 173, LBS_USETABSTOPS | WS_VSCROLL | WS_HSCROLL | WS_TABSTOP
-END
-STRINGTABLE
-BEGIN
- 3010, "Switches to "
- 2010, "Get help"
- 2000, "Create, open, save, or print documents"
- 500, "Displays information about this application"
- 440, "Closes all open windows"
- 430, "Arranges minimized window icons"
- 420, "Arranges windows as overlapping tiles"
- 410, "Arranges windows as non-overlapping tiles"
- 350, "Removes the selection without putting it on the clipboard"
- 340, "Inserts the clipboard contents at the insertion point"
- 330, "Copies the selection and puts it on the clipboard"
- 320, "Cuts the selection and puts it on the clipboard"
- 310, "Reverses the last action"
- 270, "Quits this application"
- 260, "Changes the printer selection or configuration"
- 250, "Prints the active document"
- 240, "Closes the active document"
- 230, "Saves the active document under a different name"
- 220, "Saves the active document"
- 210, "Opens an existing document"
- 200, "Creates a new session"
-END
diff --git a/win32caml/startocaml.c b/win32caml/startocaml.c
deleted file mode 100644
index 37ebde1c20..0000000000
--- a/win32caml/startocaml.c
+++ /dev/null
@@ -1,364 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Developed by Jacob Navia. */
-/* Copyright 2001 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the GNU Library General Public License, with */
-/* the special exception on linking described in file ../LICENSE. */
-/* */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <windows.h>
-#include <stdio.h>
-#include <direct.h>
-#include <io.h>
-#include "inria.h"
-PROCESS_INFORMATION pi;
-#define BUFSIZE 4096
-STARTUPINFO startInfo;
-
-/*------------------------------------------------------------------------
- Procedure: ShowDbgMsg ID:1
- Purpose: Puts up a dialog box with a message, forcing it to
- the foreground.
- Input:
- Output:
- Errors:
-------------------------------------------------------------------------*/
-void ShowDbgMsg(char *str)
-{
- HWND hWnd;
- char p[20], message[255];
- hWnd = hwndMain;
- if (IsIconic(hWnd)){
- ShowWindow(hWnd,SW_RESTORE);
- }
- strncpy(message, str, 254);
- message[254] = 0;
- strcpy(p, "Error");
- MessageBox(hWnd, message, p, MB_OK | MB_ICONHAND|MB_TASKMODAL|MB_SETFOREGROUND);
-}
-
-int AskYesOrNo(char *msg)
-{
- HWND hwnd;
- int r;
-
- hwnd = hwndMain;
- r = MessageBox(hwnd, msg, "Ocaml", MB_YESNO | MB_SETFOREGROUND);
- if (r == IDYES)
- return (TRUE);
- return (FALSE);
-}
-
-
-static DWORD OcamlStatus;
-
-static int RegistryError(void)
-{
- char buf[512];
-
- wsprintf(buf,"Error %d writing to the registry",GetLastError());
- ShowDbgMsg(buf);
- return 0;
-}
-
-static int ReadRegistry(HKEY hroot,
- char * p1, char * p2, char * p3,
- char dest[1024])
-{
- HKEY h1, h2;
- DWORD dwType;
- unsigned long size;
- LONG ret;
-
- if (RegOpenKeyExA(hroot, p1, 0, KEY_QUERY_VALUE, &h1) != ERROR_SUCCESS)
- return 0;
- if (RegOpenKeyExA(h1, p2, 0, KEY_QUERY_VALUE, &h2) != ERROR_SUCCESS) {
- RegCloseKey(h1);
- return 0;
- }
- dwType = REG_SZ;
- size = 1024;
- ret = RegQueryValueExA(h2, p3, 0, &dwType, dest, &size);
- RegCloseKey(h2);
- RegCloseKey(h1);
- return ret == ERROR_SUCCESS;
-}
-
-static int WriteRegistry(HKEY hroot,
- char * p1, char * p2, char * p3,
- char data[1024])
-{
- HKEY h1, h2;
- DWORD disp;
- LONG ret;
-
- if (RegOpenKeyExA(hroot, p1, 0, KEY_QUERY_VALUE, &h1) != ERROR_SUCCESS)
- return 0;
- if (RegCreateKeyExA(h1, p2, 0, NULL, 0, KEY_ALL_ACCESS, NULL, &h2, &disp)
- != ERROR_SUCCESS) {
- RegCloseKey(h1);
- return 0;
- }
- ret = RegSetValueEx(h2, p3, 0, REG_SZ, data, strlen(data) + 1);
- RegCloseKey(h2);
- RegCloseKey(h1);
- return ret == ERROR_SUCCESS;
-}
-
-/*------------------------------------------------------------------------
- Procedure: GetOcamlPath ID:1
- Purpose: Read the registry key
- HKEY_LOCAL_MACHINE\Software\Objective Caml
- or
- HKEY_CURRENT_USER\Software\Objective Caml,
- and creates it if it doesn't exists.
- If any error occurs, i.e. the
- given path doesn't exist, or the key didn't exist, it
- will put up a browse dialog box to allow the user to
- enter the path. The path will be verified that it
- points to a file that exists. If that file is in a
- directory called 'bin', it will look for another
- directory in the same level called lib' and set the
- Lib path to that.
- Input: None explicit
- Output: 1 means sucess, zero failure
- Errors: Almost all system calls will be verified
-------------------------------------------------------------------------*/
-int GetOcamlPath(void)
-{
- char path[1024], *p;
-
- again:
- if (! ReadRegistry(HKEY_CURRENT_USER,
- "Software", "Objective Caml",
- "InterpreterPath", path)
- &&
- ! ReadRegistry(HKEY_LOCAL_MACHINE,
- "Software", "Objective Caml",
- "InterpreterPath", path)) {
- /* Key doesn't exist? Ask user */
- path[0] = '\0';
- if (!BrowseForFile("Ocaml interpreter|ocaml.exe", path)) {
- ShowDbgMsg("Impossible to find ocaml.exe. I quit");
- exit(0);
- }
- WriteRegistry(HKEY_CURRENT_USER,
- "Software", "Objective Caml",
- "InterpreterPath", path);
- }
- /* Check if file exists */
- if (_access(path, 0) != 0) {
- char *errormsg = malloc(1024);
- wsprintf(errormsg,"Incorrect path for ocaml.exe:\n%s", path);
- ShowDbgMsg(errormsg);
- free(errormsg);
- path[0] = 0;
- WriteRegistry(HKEY_CURRENT_USER,
- "Software", "Objective Caml",
- "InterpreterPath", path);
- goto again;
- }
- strcpy(OcamlPath, path);
- p = strrchr(OcamlPath,'\\');
- if (p) {
- *p = 0;
- strcpy(LibDir,OcamlPath);
- *p = '\\';
- p = strrchr(LibDir,'\\');
- if (p && !stricmp(p,"\\bin")) {
- *p = 0;
- strcat(LibDir,"\\lib");
- }
- }
- return 1;
-}
-
-static HANDLE hChildStdinRd, hChildStdinWr,hChildStdoutRd, hChildStdoutWr;
-/*------------------------------------------------------------------------
- Procedure: IsWindowsNT ID:1
- Purpose: Returns 1 if we are running under windows NT, zero
- otherwise.
- Input: None
- Output: 1 or zero
- Errors:
-------------------------------------------------------------------------*/
-int IsWindowsNT(void)
-{
- OSVERSIONINFO osv;
-
- osv.dwOSVersionInfoSize = sizeof(osv);
- GetVersionEx(&osv);
- return(osv.dwPlatformId == VER_PLATFORM_WIN32_NT);
-}
-
-/*------------------------------------------------------------------------
- Procedure: DoStartOcaml ID:1
- Purpose: Starts the ocaml interpreter ocaml.exe. The standard
- input of the interpreter will be connected to a pipe,
- and the standard output and standard error to another
- pipe. The interpreter starts as a hidden process,
- showing only in the task list. Since this is in an
- own thread, its workings are independent of the rest
- of the program. After starting the interpreter, the
- thread waits in case the interpreter exits, for
- instance if the user or some program types #quit;;.
- In this case, the waiting thread awakens and exits
- the user interface.
- Input: Not used. It uses the OcamlPath global variable, that
- is supposed to be correct, no test for its validity
- are done here.
- Output: None visible
- Errors: If any system call for whatever reason fails, the
- thread will exit. No error message is shown.
-------------------------------------------------------------------------*/
-DWORD _stdcall DoStartOcaml(LPVOID param)
-{
- char *cmdline;
- int processStarted;
- LPSECURITY_ATTRIBUTES lpsa=NULL;
- SECURITY_ATTRIBUTES sa;
- SECURITY_DESCRIPTOR sd;
- HWND hwndParent = (HWND) param;
-
- sa.nLength = sizeof(SECURITY_ATTRIBUTES);
- // Under windows NT/2000/Whistler we have to initialize the security descriptors
- // This is not necessary under windows 98/95.
- if (IsWindowsNT()) {
- InitializeSecurityDescriptor(&sd,SECURITY_DESCRIPTOR_REVISION);
- SetSecurityDescriptorDacl(&sd,TRUE,NULL,FALSE);
- sa.bInheritHandle = TRUE;
- sa.lpSecurityDescriptor = &sd;
- lpsa = &sa;
- }
- memset(&startInfo,0,sizeof(STARTUPINFO));
- startInfo.cb = sizeof(STARTUPINFO);
- // Create a pipe for the child process's STDOUT.
- if (! CreatePipe(&hChildStdoutRd, &hChildStdoutWr, &sa, 0))
- return 0;
- // Create a pipe for the child process's STDIN.
- if (! CreatePipe(&hChildStdinRd, &hChildStdinWr, &sa, 0))
- return 0;
- // Setup the start info structure
- startInfo.dwFlags = STARTF_USESTDHANDLES|STARTF_USESHOWWINDOW;
- startInfo.wShowWindow = SW_HIDE;
- startInfo.hStdOutput = hChildStdoutWr;
- startInfo.hStdError = hChildStdoutWr;
- startInfo.hStdInput = hChildStdinRd;
- cmdline = OcamlPath;
- // Set the OCAMLLIB environment variable
- SetEnvironmentVariable("OCAMLLIB", LibDir);
- // Let's go: start the ocaml interpreter
- processStarted = CreateProcess(NULL,cmdline,lpsa,lpsa,1,
- CREATE_NEW_PROCESS_GROUP|NORMAL_PRIORITY_CLASS,
- NULL,ProgramParams.CurrentWorkingDir,&startInfo,&pi);
- if (processStarted) {
- WaitForSingleObject(pi.hProcess,INFINITE);
- GetExitCodeProcess(pi.hProcess,(unsigned long *)&OcamlStatus);
- CloseHandle(pi.hProcess);
- PostMessage(hwndMain,WM_QUITOCAML,0,0);
- }
- else {
- char *msg = malloc(1024);
- wsprintf(msg,"Impossible to start ocaml.exe in:\n%s",cmdline);
- ShowDbgMsg(msg);
- free(msg);
- }
- return 0;
-}
-
-/*------------------------------------------------------------------------
- Procedure: WriteToPipe ID:1
- Purpose: Writes the given character string to the standard
- input of the interpreter
- Input: The character string (zero terminated) to be written
- Output: The number of characters written or zero if an error
- occurs
- Errors: None
-------------------------------------------------------------------------*/
-int WriteToPipe(char *data)
-{
- DWORD dwWritten;
- if (! WriteFile(hChildStdinWr, data, strlen(data),
- &dwWritten, NULL))
- return 0;
- return dwWritten;
-
-}
-
-/*------------------------------------------------------------------------
- Procedure: ReadFromPipe ID:1
- Purpose: Reads from the standard output of the interpreter and
- stores the data in the given buffer up to the given
- length. This is done in a non-blocking manner, i.e.
- it is safe to call this even if there is no data
- available.
- Input: The buffer to be used and its length.
- Output: Returns the number of characters read from the pipe.
- Errors: None explicit
-------------------------------------------------------------------------*/
-int ReadFromPipe(char *data,int len)
-{
- DWORD dwRead;
-
- PeekNamedPipe(hChildStdoutRd,data,len,NULL,&dwRead,NULL);
- if (dwRead == 0)
- return 0;
-
- // Read output from the child process, and write to parent's STDOUT.
- if( !ReadFile( hChildStdoutRd, data, len, &dwRead,
- NULL) || dwRead == 0)
- return 0;
- return dwRead;
-}
-
-static DWORD tid;
-/*------------------------------------------------------------------------
- Procedure: StartOcaml ID:1
- Purpose: Starts the thread that will call the ocaml.exe
- program.
- Input:
- Output:
- Errors:
-------------------------------------------------------------------------*/
-int StartOcaml(void)
-{
- getcwd(ProgramParams.CurrentWorkingDir,sizeof(ProgramParams.CurrentWorkingDir));
- CreateThread(NULL,0,DoStartOcaml,hwndMain,0,&tid);
- return 1;
-}
-
-
-void *SafeMalloc(int size)
-{
- void *result;
-
- if (size < 0) {
- char message[1024];
-
-error:
- sprintf(message,"Can't allocate %d bytes",size);
- MessageBox(NULL,message,"Ocaml",MB_OK);
- exit(-1);
- }
- result = malloc(size);
- if (result == NULL)
- goto error;
- return result;
-}
-
-
-void InterruptOcaml(void)
-{
- if (! GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pi.dwProcessId)) {
- char message[1024];
- sprintf(message, "GenerateConsole failed: %ld\n", GetLastError());
- MessageBox(NULL, message, "Ocaml", MB_OK);
- }
- WriteToPipe(" ");
-}
diff --git a/yacc/.cvsignore b/yacc/.cvsignore
deleted file mode 100644
index c27ac6f3cb..0000000000
--- a/yacc/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-ocamlyacc
-*.c.x
-ocamlyacc.xcoff
diff --git a/yacc/Makefile b/yacc/Makefile
deleted file mode 100644
index d1431d31f7..0000000000
--- a/yacc/Makefile
+++ /dev/null
@@ -1,46 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-# Makefile for the parser generator.
-
-include ../config/Makefile
-
-CC=$(BYTECC)
-CFLAGS=-O -DNDEBUG $(BYTECCCOMPOPTS)
-
-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)
- $(CC) $(CFLAGS) $(CCLINKFLAGS) -o ocamlyacc $(OBJS)
-
-clean:
- rm -f *.o ocamlyacc$(EXE) *~
-
-depend:
-
-closure.o: defs.h
-error.o: defs.h
-lalr.o: defs.h
-lr0.o: defs.h
-main.o: defs.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
diff --git a/yacc/Makefile.Mac b/yacc/Makefile.Mac
deleted file mode 100644
index 0bc0dba999..0000000000
--- a/yacc/Makefile.Mac
+++ /dev/null
@@ -1,54 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-# Makefile for the parser generator.
-
-PPCC = mrc
-PPCCOptions = -includes unix {cdbgflag} -w 2,35
-PPCLinkOptions = -d {ldbgflag}
-PPCLibs = "{sharedlibraries}MathLib" "{ppclibraries}PPCCRuntime.o" ¶
- "{ppclibraries}PPCToolLibs.o" "{sharedlibraries}StdCLib" ¶
- "{ppclibraries}StdCRuntime.o" "{sharedlibraries}InterfaceLib"
-
-PPCOBJS = closure.c.x error.c.x lalr.c.x lr0.c.x main.c.x mkpar.c.x ¶
- output.c.x ¶
- reader.c.x skeleton.c.x symtab.c.x verbose.c.x warshall.c.x ¶
- rotatecursor.c.x
-
-all Ä ocamlyacc
-
-ocamlyacc ÄÄ {PPCOBJS}
- ppclink -c 'MPS ' -t MPST {PPCLinkOptions} -o ocamlyacc {PPCOBJS} {PPCLibs}
-
-clean Ä
- delete -i Å.c.x || set status 0
- delete -i ocamlyacc
-
-rotatecursor.c.x Ä ::byterun:rotatecursor.c ::byterun:rotatecursor.h
- {ppcc} {ppccoptions} -I ::byterun: -o rotatecursor.c.x ::byterun:rotatecursor.c
-
-depend Ä
-
-closure.c.x Ä defs.h ::byterun:rotatecursor.h
-error.c.x Ä defs.h ::byterun:rotatecursor.h
-lalr.c.x Ä defs.h ::byterun:rotatecursor.h
-lr0.c.x Ä defs.h ::byterun:rotatecursor.h
-main.c.x Ä defs.h ::byterun:rotatecursor.h
-mkpar.c.x Ä defs.h ::byterun:rotatecursor.h
-output.c.x Ä defs.h ::byterun:rotatecursor.h
-reader.c.x Ä defs.h ::byterun:rotatecursor.h
-skeleton.c.x Ä defs.h ::byterun:rotatecursor.h
-symtab.c.x Ä defs.h ::byterun:rotatecursor.h
-verbose.c.x Ä defs.h ::byterun:rotatecursor.h
-warshall.c.x Ä defs.h ::byterun:rotatecursor.h
diff --git a/yacc/Makefile.nt b/yacc/Makefile.nt
deleted file mode 100644
index f9a1316a6f..0000000000
--- a/yacc/Makefile.nt
+++ /dev/null
@@ -1,49 +0,0 @@
-#########################################################################
-# #
-# Objective Caml #
-# #
-# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. All rights reserved. This file is distributed #
-# under the terms of the Q Public License version 1.0. #
-# #
-#########################################################################
-
-# $Id$
-
-# Makefile for the parser generator.
-
-include ../config/Makefile
-
-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)
- $(BYTECC) $(BYTECCCOMPOPTS) -o ocamlyacc.exe $(OBJS)
-
-clean:
- rm -f *.$(O) ocamlyacc.exe *~
-
-.SUFFIXES: .c .$(O)
-
-.c.$(O):
- $(BYTECC) -DNDEBUG -DNO_UNIX $(BYTECCCOMPOPTS) -c $<
-
-depend:
-
-closure.$(O): defs.h
-error.$(O): defs.h
-lalr.$(O): defs.h
-lr0.$(O): defs.h
-main.$(O): defs.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
diff --git a/yacc/closure.c b/yacc/closure.c
deleted file mode 100644
index 1b7926a078..0000000000
--- a/yacc/closure.c
+++ /dev/null
@@ -1,283 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* Based on public-domain code from Berkeley Yacc */
-
-/* $Id$ */
-
-#include "defs.h"
-
-short *itemset;
-short *itemsetend;
-unsigned *ruleset;
-
-static unsigned *first_derives;
-static unsigned *EFF;
-
-
-
-void print_EFF ();
-void print_first_derives ();
-void print_closure ();
-
-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
deleted file mode 100644
index a65e543232..0000000000
--- a/yacc/defs.h
+++ /dev/null
@@ -1,377 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* Based on public-domain code from Berkeley Yacc */
-
-/* $Id$ */
-
-#include <assert.h>
-#include <ctype.h>
-#include <errno.h>
-#include <limits.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include "../config/s.h"
-
-#if macintosh
-#include "../byterun/rotatecursor.h"
-#endif
-
-/* machine-dependent definitions */
-/* the following definitions are for the Tahoe */
-/* they might have to be changed for other machines */
-
-/* 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 */
-
-#if macintosh
-
-#define INTERACT() ROTATECURSOR_MAGIC ()
-
-#define CALLOC(k,n) (INTERACT (), calloc((unsigned)(k),(unsigned)(n)))
-#define FREE(x) (INTERACT (), free((char*)(x)))
-#define MALLOC(n) (INTERACT (), malloc((unsigned)(n)))
-#define NEW(t) (INTERACT (), (t*)allocate(sizeof(t)))
-#define NEW2(n,t) (INTERACT (), (t*)allocate((unsigned)((n)*sizeof(t))))
-#define REALLOC(p,n) (INTERACT (), realloc((char*)(p),(unsigned)(n)))
-
-#else
-
-#define CALLOC(k,n) (calloc((unsigned)(k),(unsigned)(n)))
-#define FREE(x) (free((char*)(x)))
-#define MALLOC(n) (malloc((unsigned)(n)))
-#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)))
-
-#endif /* macintosh */
-
-
-/* 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 big_endian;
-
-extern char *myname;
-extern char *cptr;
-extern char *line;
-extern int lineno;
-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);
-extern void done (int k) Noreturn;
-extern void entry_without_type (char *s);
-extern void fatal (char *msg);
-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);
-extern void illegal_token_ref (int i, char *name);
-extern void lalr (void);
-extern void lr0 (void);
-extern void make_parser (void);
-extern void no_grammar (void);
-extern void no_space (void);
-extern void open_error (char *filename);
-extern void output (void);
-extern void over_unionized (char *u_cptr);
-extern void prec_redeclared (void);
-extern void polymorphic_entry_point(char *s);
-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);
-extern void terminal_start (char *s);
-extern void tokenized_start (char *s);
-extern void too_many_entries (void);
-extern void undefined_goal (char *s);
-extern void undefined_symbol (char *s);
-extern void unexpected_EOF (void);
-extern void unknown_rhs (int i);
-extern void unterminated_action (int a_lineno, char *a_line, char *a_cptr);
-extern void unterminated_comment (int c_lineno, char *c_line, char *c_cptr);
-extern void unterminated_string (int s_lineno, char *s_line, char *s_cptr);
-extern void unterminated_text (int t_lineno, char *t_line, char *t_cptr);
-extern void unterminated_union (int u_lineno, char *u_line, char *u_cptr);
-extern void used_reserved (char *s);
-extern void verbose (void);
-extern void write_section (char **section);
-
diff --git a/yacc/error.c b/yacc/error.c
deleted file mode 100644
index 81218b026d..0000000000
--- a/yacc/error.c
+++ /dev/null
@@ -1,313 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* Based on public-domain code from Berkeley Yacc */
-
-/* $Id$ */
-
-/* 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, "%s: e - line %d of \"%s\", unexpected end-of-file\n",
- myname, lineno, input_file_name);
- 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(*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, "%s: e - line %d of \"%s\", syntax error\n",
- myname, st_lineno, input_file_name);
- print_pos(st_line, st_cptr);
- done(1);
-}
-
-
-void unterminated_comment(int c_lineno, char *c_line, char *c_cptr)
-{
- fprintf(stderr, "%s: e - line %d of \"%s\", unmatched /*\n",
- myname, c_lineno, input_file_name);
- print_pos(c_line, c_cptr);
- done(1);
-}
-
-
-void unterminated_string(int s_lineno, char *s_line, char *s_cptr)
-{
- fprintf(stderr, "%s: e - line %d of \"%s\", unterminated string\n",
- myname, s_lineno, input_file_name);
- print_pos(s_line, s_cptr);
- done(1);
-}
-
-
-void unterminated_text(int t_lineno, char *t_line, char *t_cptr)
-{
- fprintf(stderr, "%s: e - line %d of \"%s\", unmatched %%{\n",
- myname, t_lineno, input_file_name);
- print_pos(t_line, t_cptr);
- done(1);
-}
-
-
-void unterminated_union(int u_lineno, char *u_line, char *u_cptr)
-{
- fprintf(stderr, "%s: e - line %d of \"%s\", unterminated %%union \
-declaration\n", myname, u_lineno, input_file_name);
- print_pos(u_line, u_cptr);
- done(1);
-}
-
-
-void over_unionized(char *u_cptr)
-{
- fprintf(stderr, "%s: e - line %d of \"%s\", too many %%union \
-declarations\n", myname, lineno, input_file_name);
- print_pos(line, u_cptr);
- done(1);
-}
-
-
-void illegal_tag(int t_lineno, char *t_line, char *t_cptr)
-{
- fprintf(stderr, "%s: e - line %d of \"%s\", illegal tag\n",
- myname, t_lineno, input_file_name);
- print_pos(t_line, t_cptr);
- done(1);
-}
-
-
-void illegal_character(char *c_cptr)
-{
- fprintf(stderr, "%s: e - line %d of \"%s\", illegal character\n",
- myname, lineno, input_file_name);
- print_pos(line, c_cptr);
- done(1);
-}
-
-
-void used_reserved(char *s)
-{
- fprintf(stderr, "%s: e - line %d of \"%s\", illegal use of reserved symbol \
-%s\n", myname, lineno, input_file_name, s);
- done(1);
-}
-
-
-void tokenized_start(char *s)
-{
- fprintf(stderr, "%s: e - line %d of \"%s\", the start symbol %s cannot be \
-declared to be a token\n", myname, lineno, input_file_name, s);
- done(1);
-}
-
-
-void retyped_warning(char *s)
-{
- fprintf(stderr, "%s: w - line %d of \"%s\", the type of %s has been \
-redeclared\n", myname, lineno, input_file_name, s);
-}
-
-
-void reprec_warning(char *s)
-{
- fprintf(stderr, "%s: w - line %d of \"%s\", the precedence of %s has been \
-redeclared\n", myname, lineno, input_file_name, s);
-}
-
-
-void revalued_warning(char *s)
-{
- fprintf(stderr, "%s: w - line %d of \"%s\", the value of %s has been \
-redeclared\n", myname, lineno, input_file_name, s);
-}
-
-
-void terminal_start(char *s)
-{
- fprintf(stderr, "%s: e - line %d of \"%s\", the entry point %s is a \
-token\n", myname, lineno, input_file_name, s);
- done(1);
-}
-
-void too_many_entries(void)
-{
- fprintf(stderr, "%s: e - line %d of \"%s\", more than 256 entry points\n",
- myname, lineno, input_file_name);
- done(1);
-}
-
-
-void no_grammar(void)
-{
- fprintf(stderr, "%s: e - line %d of \"%s\", no grammar has been \
-specified\n", myname, lineno, input_file_name);
- done(1);
-}
-
-
-void terminal_lhs(int s_lineno)
-{
- fprintf(stderr, "%s: e - line %d of \"%s\", a token appears on the lhs \
-of a production\n", myname, s_lineno, input_file_name);
- done(1);
-}
-
-
-void prec_redeclared(void)
-{
- fprintf(stderr, "%s: w - line %d of \"%s\", conflicting %%prec \
-specifiers\n", myname, lineno, input_file_name);
-}
-
-
-void unterminated_action(int a_lineno, char *a_line, char *a_cptr)
-{
- fprintf(stderr, "%s: e - line %d of \"%s\", unterminated action\n",
- myname, a_lineno, input_file_name);
- print_pos(a_line, a_cptr);
- done(1);
-}
-
-
-void dollar_warning(int a_lineno, int i)
-{
- fprintf(stderr, "%s: w - line %d of \"%s\", $%d references beyond the \
-end of the current rule\n", myname, a_lineno, input_file_name, i);
-}
-
-
-void dollar_error(int a_lineno, char *a_line, char *a_cptr)
-{
- fprintf(stderr, "%s: e - line %d of \"%s\", illegal $-name\n",
- myname, a_lineno, input_file_name);
- print_pos(a_line, a_cptr);
- done(1);
-}
-
-
-void untyped_lhs(void)
-{
- fprintf(stderr, "%s: e - line %d of \"%s\", $$ is untyped\n",
- myname, lineno, input_file_name);
- done(1);
-}
-
-
-void untyped_rhs(int i, char *s)
-{
- fprintf(stderr, "%s: e - line %d of \"%s\", $%d (%s) is untyped\n",
- myname, lineno, input_file_name, i, s);
- done(1);
-}
-
-
-void unknown_rhs(int i)
-{
- fprintf(stderr, "%s: e - line %d of \"%s\", $%d is unbound\n",
- myname, lineno, input_file_name, i);
- done(1);
-}
-
-void illegal_token_ref(int i, char *name)
-{
- fprintf(stderr, "%s: e - line %d of \"%s\", $%d refers to terminal `%s', which has no argument\n",
- myname, lineno, input_file_name, i, name);
- done(1);
-}
-
-void default_action_error(void)
-{
- fprintf(stderr, "%s: e - line %d of \"%s\", no action specified for this production\n",
- myname, lineno, input_file_name);
- 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);
-}
-
diff --git a/yacc/lalr.c b/yacc/lalr.c
deleted file mode 100644
index 81be0ec0e5..0000000000
--- a/yacc/lalr.c
+++ /dev/null
@@ -1,663 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* Based on public-domain code from Berkeley Yacc */
-
-/* $Id$ */
-
-#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
deleted file mode 100644
index e05fcb072a..0000000000
--- a/yacc/lr0.c
+++ /dev/null
@@ -1,621 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* Based on public-domain code from Berkeley Yacc */
-
-/* $Id$ */
-
-
-#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 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
deleted file mode 100644
index 3f2f9ef8e7..0000000000
--- a/yacc/main.c
+++ /dev/null
@@ -1,402 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* Based on public-domain code from Berkeley Yacc */
-
-/* $Id$ */
-
-#include <signal.h>
-#include <string.h>
-#include "defs.h"
-#ifdef HAS_UNISTD
-#include <unistd.h>
-#endif
-
-char dflag;
-char lflag;
-char rflag;
-char tflag;
-char vflag;
-char qflag;
-char sflag;
-char big_endian;
-
-char *file_prefix = 0;
-char *myname = "yacc";
-#ifdef NO_UNIX
-char temp_form[] = "yacc.X";
-#else
-char temp_form[] = "yacc.XXXXXXX";
-#endif
-
-int lineno;
-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;
-
-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;
-
-extern char *mktemp(char *);
-extern char *getenv(const char *);
-
-
-void done(int k)
-{
- 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); }
- 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] [-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;
- if (i + 1 < argc) usage();
- return;
-
- case '-':
- ++i;
- goto no_more_options;
-
- case 'v':
- 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
- len = 0;
- i = sizeof(temp_form);
-#else
- tmpdir = getenv("TMPDIR");
- if (tmpdir == 0) tmpdir = "/tmp";
- len = strlen(tmpdir);
- i = len + sizeof(temp_form);
- if (len && tmpdir[len-1] != '/')
- ++i;
-#endif
-
- 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();
-
-#ifndef NO_UNIX
- 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] != '/')
- {
- action_file_name[len] = '/';
- entry_file_name[len] = '/';
- text_file_name[len] = '/';
- union_file_name[len] = '/';
- ++len;
- }
-#endif
-
- 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';
-
-#ifndef NO_UNIX
- 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);
- }
-
- action_file = fopen(action_file_name, "w");
- if (action_file == 0)
- open_error(action_file_name);
-
- entry_file = fopen(entry_file_name, "w");
- if (entry_file == 0)
- open_error(entry_file_name);
-
- text_file = fopen(text_file_name, "w");
- 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);
- union_file = fopen(union_file_name, "w");
- 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();
- output();
- done(0);
- /*NOTREACHED*/
- return 0;
-}
diff --git a/yacc/mkpar.c b/yacc/mkpar.c
deleted file mode 100644
index 0d70fb8fbe..0000000000
--- a/yacc/mkpar.c
+++ /dev/null
@@ -1,366 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* Based on public-domain code from Berkeley Yacc */
-
-/* $Id$ */
-
-
-#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
deleted file mode 100644
index 0774666e57..0000000000
--- a/yacc/output.c
+++ /dev/null
@@ -1,984 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* Based on public-domain code from Berkeley Yacc */
-
-/* $Id$ */
-
-#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
deleted file mode 100644
index 5ab9997d63..0000000000
--- a/yacc/reader.c
+++ /dev/null
@@ -1,1839 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* Based on public-domain code from Berkeley Yacc */
-
-/* $Id$ */
-
-#include <string.h>
-#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') { 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;
- }
-}
-
-
-int
-nextc(void)
-{
- register char *s;
-
- if (line == 0)
- {
- get_line();
- if (line == 0)
- return (EOF);
- }
-
- s = cptr;
- for (;;)
- {
- switch (*s)
- {
- case '\n':
- get_line();
- 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();
- 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(cptr[1]) && isdigit(cptr[2]) &&
- isdigit(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(name[2]))
- {
- s = name + 3;
- while (isdigit(*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();
-
- cinc = 0;
- while (1) {
- c = *++cptr;
- if (c == EOF) unexpected_EOF();
- if (c == '\n') syntax_error(lineno, line, cptr);
- if (c == '>' && cptr[-1] != '-') break;
- 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;
- int value;
- 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();
- value = UNDEFINED;
- if (isdigit(c))
- {
- 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 parser_env ->\n", nrules-2);
- else
- fprintf(f, "; (fun 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, "(peek_val parser_env %d : %s) in\n", n - i, item->tag);
- else if (sflag)
- fprintf(f, "peek_val parser_env %d in\n", n - i);
- else
- fprintf(f, "(peek_val 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(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");
- 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(cptr[1]) && isdigit(cptr[2]) &&
- isdigit(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 == '\'') 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 (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 parser_env -> raise (YYexit (peek_val parser_env 0)))\n",
- ntotalrules);
- else
- fprintf(action_file,
- "; (fun parser_env -> raise (YYexit (peek_val 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)
-{
- 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
deleted file mode 100644
index 967e170994..0000000000
--- a/yacc/skeleton.c
+++ /dev/null
@@ -1,58 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* Based on public-domain code from Berkeley Yacc */
-
-/* $Id$ */
-
-#include "defs.h"
-
-char *header[] =
-{
- "open Parsing;;",
- 0
-};
-
-char *define_tables[] =
-{
- "let yytables =",
- " { actions=yyact;",
- " transl_const=yytransl_const;",
- " transl_block=yytransl_block;",
- " lhs=yylhs;",
- " len=yylen;",
- " defred=yydefred;",
- " dgoto=yydgoto;",
- " sindex=yysindex;",
- " rindex=yyrindex;",
- " gindex=yygindex;",
- " tablesize=yytablesize;",
- " table=yytable;",
- " check=yycheck;",
- " error_function=parse_error;",
- " names_const=yynames_const;",
- " 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
deleted file mode 100644
index 87e280a09d..0000000000
--- a/yacc/symtab.c
+++ /dev/null
@@ -1,129 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* Based on public-domain code from Berkeley Yacc */
-
-/* $Id$ */
-
-#include <string.h>
-#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
deleted file mode 100644
index 2d79c9a5cb..0000000000
--- a/yacc/verbose.c
+++ /dev/null
@@ -1,350 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* Based on public-domain code from Berkeley Yacc */
-
-/* $Id$ */
-
-
-#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
deleted file mode 100644
index 5b8f10c89f..0000000000
--- a/yacc/warshall.c
+++ /dev/null
@@ -1,96 +0,0 @@
-/***********************************************************************/
-/* */
-/* Objective Caml */
-/* */
-/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
-/* */
-/* Copyright 1996 Institut National de Recherche en Informatique et */
-/* en Automatique. All rights reserved. This file is distributed */
-/* under the terms of the Q Public License version 1.0. */
-/* */
-/***********************************************************************/
-
-/* Based on public-domain code from Berkeley Yacc */
-
-/* $Id$ */
-
-#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;
- }
-}