├── .gitignore ├── .gitmodules ├── .merlin ├── .ocamlformat ├── LICENSE ├── Makefile ├── Makefile.ocamlc ├── Makefile.stdlib ├── README.md ├── compile_ocamlc.sh ├── compile_stdlib.sh ├── interpreter ├── Makefile ├── README.md ├── conf.ml ├── conf.mli ├── data.ml ├── data.mli ├── envir.ml ├── envir.mli ├── eval.ml ├── eval.mli ├── interp ├── interp.ml ├── interp.mli ├── primitives.ml ├── primitives.mli ├── runtime_base.ml ├── runtime_base.mli ├── runtime_compiler.ml ├── runtime_compiler.mli ├── runtime_lib.ml ├── runtime_lib.mli ├── runtime_stdlib.ml ├── runtime_stdlib.mli └── tests │ ├── README │ ├── checktests.sh │ ├── functor-units-dependency │ ├── files │ ├── functor.ml │ ├── main.ml │ └── x.ml │ └── runtests.sh ├── lex └── lexer.ml ├── miniml ├── compiler │ ├── README.md │ ├── compile.scm │ └── test │ │ ├── .gitignore │ │ ├── Makefile │ │ ├── arith.info.reference │ │ ├── arith.ml │ │ ├── arith.output.reference │ │ ├── empty.info.reference │ │ ├── empty.ml │ │ ├── empty.output.reference │ │ ├── exceptions.info.reference │ │ ├── exceptions.ml │ │ ├── exceptions.output.reference │ │ ├── exits.info.reference │ │ ├── exits.ml │ │ ├── exits.output.reference │ │ ├── external_exceptions.info.reference │ │ ├── external_exceptions.ml │ │ ├── external_exceptions.output.reference │ │ ├── functions.info.reference │ │ ├── functions.ml │ │ ├── functions.output.reference │ │ ├── functors.info.reference │ │ ├── functors.ml │ │ ├── functors.output.reference │ │ ├── infix_sugar.info.reference │ │ ├── infix_sugar.ml │ │ ├── infix_sugar.output.reference │ │ ├── labels.info.reference │ │ ├── labels.ml │ │ ├── labels.output.reference │ │ ├── let_open.info.reference │ │ ├── let_open.ml │ │ ├── let_open.output.reference │ │ ├── lib.ml │ │ ├── lists.info.reference │ │ ├── lists.ml │ │ ├── lists.output.reference │ │ ├── loops.info.reference │ │ ├── loops.ml │ │ ├── loops.output.reference │ │ ├── patterns.info.reference │ │ ├── patterns.ml │ │ ├── patterns.output.reference │ │ ├── records.info.reference │ │ ├── records.ml │ │ └── records.output.reference └── interp │ ├── Makefile │ ├── arg.ml │ ├── arg.mli │ ├── array.ml │ ├── array.mli │ ├── ast_helper.ml │ ├── ast_helper.mli │ ├── asttypes.mli │ ├── buffer.ml │ ├── buffer.mli │ ├── bytes.ml │ ├── bytes.mli │ ├── char.ml │ ├── char.mli │ ├── clflags.ml │ ├── clflags.mli │ ├── cvt_emit.sh │ ├── depend.ml │ ├── depend.sh │ ├── digest.ml │ ├── digest.mli │ ├── docstrings.ml │ ├── docstrings.mli │ ├── filename.ml │ ├── filename.mli │ ├── format.ml │ ├── format.mli │ ├── gc.ml │ ├── gc.mli │ ├── genfileopt.sh │ ├── hashtbl.ml │ ├── hashtbl.mli │ ├── int32.ml │ ├── int32.mli │ ├── int64.ml │ ├── int64.mli │ ├── interp │ ├── interp.opt │ ├── lex.sh │ ├── lexer.mli │ ├── lexer.mll │ ├── lexing.ml │ ├── lexing.mli │ ├── list.ml │ ├── list.mli │ ├── location.ml │ ├── location.mli │ ├── longident.ml │ ├── longident.mli │ ├── make_opcodes.sh │ ├── makedepend.ml │ ├── map.ml │ ├── map.mli │ ├── marshal.ml │ ├── marshal.mli │ ├── misc.ml │ ├── misc.mli │ ├── nativeint.ml │ ├── nativeint.mli │ ├── parse.ml │ ├── parse.mli │ ├── parser.mly │ ├── parsetree.mli │ ├── parsing.ml │ ├── parsing.mli │ ├── printf.ml │ ├── printf.mli │ ├── seq.ml │ ├── seq.mli │ ├── set.ml │ ├── set.mli │ ├── stack.ml │ ├── stack.mli │ ├── std.ml │ ├── std.mli │ ├── std_miniml.ml │ ├── std_miniml_prefix.ml │ ├── std_opt_prefix.ml │ ├── std_opt_prefix.mli │ ├── string.ml │ ├── string.mli │ ├── syntaxerr.ml │ ├── syntaxerr.mli │ ├── warnings.ml │ └── warnings.mli ├── patches ├── compflags.patch ├── disable-profiling.patch └── parsetree.patch └── timed.sh /.gitignore: -------------------------------------------------------------------------------- 1 | .depend 2 | *.cmi 3 | *.cmo 4 | *.cmx 5 | *.o 6 | miniml/interp/lexer.ml 7 | miniml/interp/parser.ml 8 | miniml/interp/parser.mli 9 | miniml/interp/out.ml 10 | miniml/interp/out.byte 11 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "ocaml-src"] 2 | path = ocaml-src 3 | url = https://github.com/Ekdohibs/ocaml 4 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | PKG compiler-libs.common -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile = janestreet 2 | margin = 80 3 | break-infix-before-func = false 4 | break-separators = after 5 | parens-tuple = always 6 | single-case = compact 7 | module-item-spacing = preserve 8 | let-binding-spacing = compact 9 | field-space = loose -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 Nathanaël Courant 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | BOOT=_boot 2 | OCAMLSRC=ocaml-src 3 | CONFIG=$(OCAMLSRC)/config/Makefile 4 | OCAMLRUN=$(OCAMLSRC)/byterun/ocamlrun 5 | GENERATED=$(OCAMLSRC)/bytecomp/opcodes.ml 6 | 7 | $(OCAMLRUN): $(CONFIG) 8 | touch $(OCAMLSRC)/byterun/.depend && $(MAKE) -C $(OCAMLSRC)/byterun depend 9 | $(MAKE) -C $(OCAMLSRC)/byterun all 10 | touch $(OCAMLSRC)/asmrun/.depend && $(MAKE) -C $(OCAMLSRC)/asmrun depend 11 | $(MAKE) -C $(OCAMLSRC)/asmrun all 12 | 13 | .PHONY: configure-ocaml 14 | configure-ocaml: 15 | rm -f $(OCAMLSRC)/boot/ocamlc $(OCAMLSRC)/boot/ocamllex 16 | find $(OCAMLSRC) -iname .depend | xargs rm -f 17 | touch $(OCAMLSRC)/.depend $(OCAMLSRC)/stdlib/.depend $(OCAMLSRC)/lex/.depend 18 | cd $(OCAMLSRC) && bash configure 19 | $(MAKE) -C $(OCAMLSRC) ocamlyacc && cp $(OCAMLSRC)/yacc/ocamlyacc $(OCAMLSRC)/boot 20 | $(MAKE) -C $(OCAMLSRC)/lex parser.ml 21 | 22 | # Here, including $(CONFIG) would provide $(ARCH), but it leads to a recursive 23 | # dependency because its rule has a dependency that reloads this Makefile. 24 | .PHONY: ocaml-generated-files 25 | ocaml-generated-files: $(OCAMLRUN) lex make_opcodes cvt_emit 26 | $(MAKE) -C $(OCAMLSRC)/stdlib sys.ml 27 | $(MAKE) -C $(OCAMLSRC) utils/config.ml 28 | $(MAKE) -C $(OCAMLSRC) parsing/parser.ml 29 | cd $(OCAMLSRC); ../miniml/interp/lex.sh parsing/lexer.mll 30 | $(MAKE) -C $(OCAMLSRC) bytecomp/runtimedef.ml 31 | miniml/interp/make_opcodes.sh -opcodes < $(OCAMLSRC)/byterun/caml/instruct.h > $(OCAMLSRC)/bytecomp/opcodes.ml 32 | $(MAKE) -C $(OCAMLSRC) asmcomp/arch.ml asmcomp/proc.ml asmcomp/selection.ml asmcomp/CSE.ml asmcomp/reload.ml asmcomp/scheduling.ml 33 | miniml/interp/cvt_emit.sh < $(OCAMLSRC)/asmcomp/$(shell cat $(CONFIG) | grep '^ARCH=' | cut -f2 -d=)/emit.mlp > $(OCAMLSRC)/asmcomp/emit.ml 34 | 35 | .PHONY: lex 36 | lex: $(OCAMLRUN) 37 | touch miniml/interp/.depend 38 | $(MAKE) -C miniml/interp lex.byte 39 | 40 | .PHONY: make_opcodes 41 | make_opcodes: $(OCAMLRUN) lex 42 | $(MAKE) -C miniml/interp make_opcodes.byte 43 | 44 | .PHONY: cvt_emit 45 | cvt_emit: $(OCAMLRUN) lex 46 | $(MAKE) -C miniml/interp cvt_emit.byte 47 | 48 | .PHONY: makedepend 49 | makedepend: $(OCAMLRUN) lex 50 | $(MAKE) -C miniml/interp makedepend.byte 51 | 52 | .PHONY: clean-ocaml-config 53 | clean-ocaml-config: 54 | cd $(OCAMLSRC) && make distclean 55 | 56 | # this dependency is fairly coarse-grained, so feel free to 57 | # use clean-ocaml-config if make a small change to $(OCAMLSRC) 58 | # that you believe does require re-configuring. 59 | $(CONFIG): $(OCAMLSRC)/VERSION 60 | $(MAKE) configure-ocaml 61 | 62 | $(GENERATED): $(OCAMLRUN) lex make_opcodes 63 | $(MAKE) ocaml-generated-files 64 | 65 | $(BOOT)/driver: $(OCAMLSRC)/driver $(OCAMLSRC)/otherlibs/dynlink $(CONFIG) $(GENERATED) 66 | mkdir -p $(BOOT) 67 | rm -rf $@ 68 | cp -r $< $@ 69 | cp $(OCAMLSRC)/otherlibs/dynlink/dynlink.mli $@/compdynlink.mli 70 | grep -v 'REMOVE_ME for ../../debugger/dynlink.ml' \ 71 | $(OCAMLSRC)/otherlibs/dynlink/dynlink.ml > $@/compdynlink.mlbyte 72 | 73 | $(BOOT)/byterun: $(OCAMLSRC)/byterun $(CONFIG) $(GENERATED) 74 | mkdir -p $(BOOT) 75 | rm -rf $@ 76 | cp -r $< $@ 77 | 78 | $(BOOT)/bytecomp: $(OCAMLSRC)/bytecomp $(CONFIG) $(GENERATED) 79 | mkdir -p $(BOOT) 80 | rm -rf $@ 81 | cp -r $< $@ 82 | 83 | $(BOOT)/typing: $(OCAMLSRC)/typing $(CONFIG) $(GENERATED) 84 | mkdir -p $(BOOT) 85 | rm -rf $@ 86 | cp -r $< $@ 87 | 88 | $(BOOT)/parsing: $(OCAMLSRC)/parsing $(CONFIG) $(GENERATED) patches/parsetree.patch lex 89 | mkdir -p $(BOOT) 90 | rm -rf $@ 91 | cp -r $< $@ 92 | #patch $(BOOT)/parsing/parsetree.mli patches/parsetree.patch 93 | 94 | $(BOOT)/utils: $(OCAMLSRC)/utils $(CONFIG) $(GENERATED) patches/disable-profiling.patch 95 | mkdir -p $(BOOT) 96 | rm -rf $@ 97 | cp -r $< $@ 98 | cp $(BOOT)/utils/profile.ml $(BOOT)/utils/profile.ml.noprof 99 | patch $(BOOT)/utils/profile.ml.noprof patches/disable-profiling.patch 100 | 101 | $(BOOT)/stdlib: $(OCAMLSRC)/stdlib $(CONFIG) $(GENERATED) patches/compflags.patch 102 | mkdir -p $(BOOT) 103 | rm -rf $@ 104 | cp -r $< $@ 105 | patch $(BOOT)/stdlib/Compflags patches/compflags.patch 106 | awk -f $(BOOT)/stdlib/expand_module_aliases.awk < $(BOOT)/stdlib/stdlib.mli > $(BOOT)/stdlib/stdlib.pp.mli 107 | awk -f $(BOOT)/stdlib/expand_module_aliases.awk < $(BOOT)/stdlib/stdlib.ml > $(BOOT)/stdlib/stdlib.pp.ml 108 | cp $(OCAMLSRC)/asmrun/libasmrun.a $(BOOT)/stdlib/ 109 | cp Makefile.stdlib $(BOOT)/stdlib/Makefile 110 | 111 | COPY_TARGETS=\ 112 | $(BOOT)/bytecomp \ 113 | $(BOOT)/byterun \ 114 | $(BOOT)/driver \ 115 | $(BOOT)/parsing \ 116 | $(BOOT)/stdlib \ 117 | $(BOOT)/typing \ 118 | $(BOOT)/utils 119 | 120 | .PHONY: copy 121 | copy: $(COPY_TARGETS) 122 | cp Makefile.ocamlc $(BOOT)/Makefile 123 | 124 | .PHONY: ocamlrun 125 | ocamlrun: $(OCAMLRUN) 126 | 127 | $(BOOT)/ocamlc: copy makedepend 128 | $(MAKE) -C $(OCAMLSRC)/yacc all 129 | $(MAKE) -C miniml/interp depend 130 | ./timed.sh $(MAKE) $(MAKEFLAGS) -C miniml/interp interpopt.opt 131 | touch _boot/stdlib/.depend && $(MAKE) -C _boot/stdlib depend 132 | touch _boot/.depend && $(MAKE) -C _boot depend 133 | ./timed.sh $(MAKE) $(MAKEFLAGS) -C _boot/stdlib all 134 | # cd $(BOOT)/stdlib && ../../timed.sh ../../compile_stdlib.sh 135 | mkdir -p $(BOOT)/compilerlibs 136 | ./timed.sh $(MAKE) $(MAKEFLAGS) -C _boot ocamlc 137 | # cd $(BOOT) && ../timed.sh ../compile_ocamlc.sh 138 | 139 | # Remove dependency on $(BOOT)/ocamlc, because it seems to cause ocamlc to be rebuilt even if it was just built 140 | fullboot: 141 | cp $(BOOT)/ocamlc $(OCAMLSRC)/boot/ 142 | cp miniml/interp/lex.byte $(OCAMLSRC)/boot/ocamllex 143 | cp $(OCAMLSRC)/byterun/ocamlrun $(OCAMLSRC)/boot/ocamlrun$(EXE) 144 | touch $(OCAMLSRC)/stdlib/.depend && ./timed.sh $(MAKE) $(MAKEFLAGS) -C $(OCAMLSRC)/stdlib CAMLDEP="../boot/ocamlc -depend" depend 145 | ./timed.sh $(MAKE) $(MAKEFLAGS) -C $(OCAMLSRC)/stdlib COMPILER="" CAMLC="../boot/ocamlc -use-prims ../byterun/primitives" all 146 | cd $(OCAMLSRC)/stdlib; cp stdlib.cma std_exit.cmo *.cmi camlheader ../boot 147 | cd $(OCAMLSRC)/boot; ln -sf ../byterun/libcamlrun.a . 148 | touch $(OCAMLSRC)/tools/.depend && ./timed.sh $(MAKE) $(MAKEFLAGS) -C $(OCAMLSRC)/tools CAMLC="../boot/ocamlc -nostdlib -I ../boot -use-prims ../byterun/primitives -I .." make_opcodes cvt_emit 149 | touch $(OCAMLSRC)/lex/.depend && ./timed.sh $(MAKE) $(MAKEFLAGS) -C $(OCAMLSRC)/lex CAMLDEP="../boot/ocamlc -depend" depend 150 | ./timed.sh $(MAKE) $(MAKEFLAGS) -C $(OCAMLSRC) CAMLDEP="boot/ocamlc -depend" depend 151 | ./timed.sh $(MAKE) $(MAKEFLAGS) -C $(OCAMLSRC) CAMLC="boot/ocamlc -nostdlib -I boot -use-prims byterun/primitives" ocamlc 152 | ./timed.sh $(MAKE) $(MAKEFLAGS) -C $(OCAMLSRC)/lex CAMLC="../boot/ocamlc -strict-sequence -nostdlib -I ../boot -use-prims ../byterun/primitives" all 153 | 154 | .PHONY: test-compiler 155 | test-compiler: $(OCAMLRUN) 156 | $(MAKE) -C miniml/compiler/test all OCAMLRUN=../../../$(OCAMLRUN) 157 | 158 | .PHONY: test-compiler-promote 159 | test-compiler-promote: $(OCAMLRUN) 160 | $(MAKE) -C miniml/compiler/test promote OCAMLRUN=../../../$(OCAMLRUN) 161 | -------------------------------------------------------------------------------- /Makefile.ocamlc: -------------------------------------------------------------------------------- 1 | #************************************************************************** 2 | #* * 3 | #* OCaml * 4 | #* * 5 | #* Xavier Leroy, projet Cristal, INRIA Rocquencourt * 6 | #* * 7 | #* Copyright 1999 Institut National de Recherche en Informatique et * 8 | #* en Automatique. * 9 | #* * 10 | #* All rights reserved. This file is distributed under the terms of * 11 | #* the GNU Lesser General Public License version 2.1, with the * 12 | #* special exception on linking described in the file LICENSE. * 13 | #* * 14 | #************************************************************************** 15 | 16 | OPAQUE=-opaque 17 | 18 | COMPILER=../miniml/interp/interp.opt $(OPAQUE) -nostdlib -I stdlib 19 | INCLUDES=-I utils -I parsing -I typing -I bytecomp -I driver 20 | 21 | COMPFLAGS=-strict-sequence -principal -absname -w +a-4-9-41-42-44-45-48 \ 22 | -warn-error A \ 23 | -bin-annot -safe-string -strict-formats $(INCLUDES) 24 | LINKFLAGS= 25 | 26 | DEPEND=../miniml/interp/depend.sh $(OPAQUE) 27 | DEPFLAGS=$(INCLUDES) 28 | 29 | UTILS=utils/config.cmx utils/misc.cmx \ 30 | utils/identifiable.cmx utils/numbers.cmx utils/arg_helper.cmx \ 31 | utils/clflags.cmx utils/tbl.cmx utils/profile.cmx \ 32 | utils/terminfo.cmx utils/ccomp.cmx utils/warnings.cmx \ 33 | utils/consistbl.cmx \ 34 | utils/strongly_connected_components.cmx \ 35 | utils/build_path_prefix_map.cmx \ 36 | utils/targetint.cmx 37 | 38 | PARSING=parsing/location.cmx parsing/longident.cmx \ 39 | parsing/docstrings.cmx parsing/syntaxerr.cmx \ 40 | parsing/ast_helper.cmx parsing/parser.cmx \ 41 | parsing/lexer.cmx parsing/parse.cmx parsing/printast.cmx \ 42 | parsing/pprintast.cmx \ 43 | parsing/ast_mapper.cmx parsing/ast_iterator.cmx parsing/attr_helper.cmx \ 44 | parsing/builtin_attributes.cmx parsing/ast_invariants.cmx parsing/depend.cmx 45 | 46 | TYPING=typing/ident.cmx typing/path.cmx \ 47 | typing/primitive.cmx typing/types.cmx \ 48 | typing/btype.cmx typing/oprint.cmx \ 49 | typing/subst.cmx typing/predef.cmx \ 50 | typing/datarepr.cmx typing/cmi_format.cmx typing/env.cmx \ 51 | typing/typedtree.cmx typing/printtyped.cmx typing/ctype.cmx \ 52 | typing/printtyp.cmx typing/includeclass.cmx \ 53 | typing/mtype.cmx typing/envaux.cmx typing/includecore.cmx \ 54 | typing/typedtreeIter.cmx typing/typedtreeMap.cmx \ 55 | typing/tast_mapper.cmx \ 56 | typing/cmt_format.cmx typing/untypeast.cmx \ 57 | typing/includemod.cmx typing/typetexp.cmx typing/printpat.cmx \ 58 | typing/parmatch.cmx typing/stypes.cmx typing/typedecl.cmx typing/typeopt.cmx \ 59 | typing/typecore.cmx typing/typeclass.cmx typing/typemod.cmx 60 | 61 | COMP=bytecomp/lambda.cmx bytecomp/printlambda.cmx \ 62 | bytecomp/semantics_of_primitives.cmx \ 63 | bytecomp/switch.cmx bytecomp/matching.cmx \ 64 | bytecomp/translobj.cmx bytecomp/translattribute.cmx \ 65 | bytecomp/translprim.cmx bytecomp/translcore.cmx \ 66 | bytecomp/translclass.cmx bytecomp/translmod.cmx \ 67 | bytecomp/simplif.cmx bytecomp/runtimedef.cmx \ 68 | bytecomp/meta.cmx bytecomp/opcodes.cmx \ 69 | bytecomp/bytesections.cmx bytecomp/dll.cmx \ 70 | bytecomp/symtable.cmx \ 71 | driver/pparse.cmx driver/main_args.cmx \ 72 | driver/compenv.cmx driver/compmisc.cmx \ 73 | driver/compdynlink.cmx driver/compplugin.cmx driver/makedepend.cmx 74 | 75 | COMMON=$(UTILS) $(PARSING) $(TYPING) $(COMP) 76 | 77 | BYTECOMP=bytecomp/instruct.cmx bytecomp/bytegen.cmx \ 78 | bytecomp/printinstr.cmx bytecomp/emitcode.cmx \ 79 | bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmx bytecomp/bytepackager.cmx \ 80 | driver/errors.cmx driver/compile.cmx 81 | 82 | BYTESTART=driver/main.cmx 83 | 84 | # Shared parts of the system compiled with the native-code compiler 85 | 86 | compilerlibs/ocamlcommon.cmxa: $(COMMON) 87 | $(COMPILER) -a -linkall -o $@ $^ 88 | 89 | # The bytecode compiler compiled with the native-code compiler 90 | 91 | compilerlibs/ocamlbytecomp.cmxa: $(BYTECOMP) 92 | $(COMPILER) -a -o $@ $^ 93 | 94 | ocamlc: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \ 95 | $(BYTESTART) 96 | $(COMPILER) $(LINKFLAGS) -o $@ $^ -cclib "$(BYTECCLIBS)" 97 | 98 | # Compiler Plugins 99 | 100 | driver/compdynlink.cmx: driver/compdynlink.mlno driver/compdynlink.cmi 101 | $(COMPILER) $(COMPFLAGS) -c -impl $< 102 | 103 | # Default rules 104 | 105 | .SUFFIXES: .ml .mli .cmi .cmx 106 | 107 | .mli.cmi: 108 | $(COMPILER) $(COMPFLAGS) -c $< 109 | 110 | .ml.cmx: 111 | $(COMPILER) $(COMPFLAGS) -c $< 112 | 113 | .PHONY: depend 114 | depend: 115 | (for d in utils parsing typing bytecomp driver; \ 116 | do $(DEPEND) $(DEPFLAGS) $$d/*.mli $$d/*.ml || exit; \ 117 | done) > .depend 118 | $(DEPEND) $(DEPFLAGS) -impl driver/compdynlink.mlno >> .depend 119 | 120 | include .depend 121 | -------------------------------------------------------------------------------- /Makefile.stdlib: -------------------------------------------------------------------------------- 1 | #************************************************************************** 2 | #* * 3 | #* OCaml * 4 | #* * 5 | #* Xavier Leroy, projet Cristal, INRIA Rocquencourt * 6 | #* * 7 | #* Copyright 1999 Institut National de Recherche en Informatique et * 8 | #* en Automatique. * 9 | #* * 10 | #* All rights reserved. This file is distributed under the terms of * 11 | #* the GNU Lesser General Public License version 2.1, with the * 12 | #* special exception on linking described in the file LICENSE. * 13 | #* * 14 | #************************************************************************** 15 | 16 | COMPFLAGS=-strict-sequence -absname -w +a-4-9-41-42-44-45-48 \ 17 | -g -warn-error A -bin-annot -nostdlib \ 18 | -safe-string -strict-formats 19 | 20 | # Set -opaque for faster compilation 21 | OPAQUE=-opaque 22 | 23 | COMPILER=../../miniml/interp/interp.opt $(OPAQUE) 24 | DEPEND=../../miniml/interp/depend.sh $(OPAQUE) -native 25 | 26 | # Object file prefix 27 | P=stdlib__ 28 | 29 | OBJS=camlinternalFormatBasics.cmx stdlib.cmx $(OTHERS) 30 | OTHERS=$(P)seq.cmx $(P)char.cmx $(P)uchar.cmx $(P)sys.cmx $(P)list.cmx \ 31 | $(P)bytes.cmx $(P)string.cmx \ 32 | $(P)sort.cmx $(P)marshal.cmx $(P)obj.cmx $(P)float.cmx $(P)array.cmx \ 33 | $(P)int32.cmx $(P)int64.cmx $(P)nativeint.cmx \ 34 | $(P)lexing.cmx $(P)parsing.cmx \ 35 | $(P)set.cmx $(P)map.cmx $(P)stack.cmx $(P)queue.cmx \ 36 | camlinternalLazy.cmx $(P)lazy.cmx $(P)stream.cmx \ 37 | $(P)buffer.cmx camlinternalFormat.cmx $(P)printf.cmx \ 38 | $(P)arg.cmx $(P)printexc.cmx $(P)gc.cmx \ 39 | $(P)digest.cmx $(P)random.cmx $(P)hashtbl.cmx $(P)weak.cmx \ 40 | $(P)format.cmx $(P)scanf.cmx $(P)callback.cmx \ 41 | camlinternalOO.cmx $(P)oo.cmx camlinternalMod.cmx \ 42 | $(P)genlex.cmx $(P)ephemeron.cmx \ 43 | $(P)filename.cmx $(P)complex.cmx \ 44 | $(P)arrayLabels.cmx $(P)listLabels.cmx $(P)bytesLabels.cmx \ 45 | $(P)stringLabels.cmx $(P)moreLabels.cmx $(P)stdLabels.cmx \ 46 | $(P)spacetime.cmx $(P)bigarray.cmx 47 | 48 | PREFIXED_OBJS=$(filter stdlib__%.cmx,$(OBJS)) 49 | 50 | all: stdlib.cmxa std_exit.cmx 51 | 52 | stdlib.cmxa: $(OBJS) 53 | $(COMPILER) -a -o $@ $^ 54 | 55 | .SUFFIXES: .mli .ml .cmi .cmx 56 | 57 | stdlib.cmi: stdlib.pp.mli 58 | $(COMPILER) $(COMPFLAGS) $(shell ./Compflags $@) -o $@ -c $< 59 | 60 | stdlib.cmx: stdlib.pp.ml 61 | $(COMPILER) $(COMPFLAGS) $(shell ./Compflags $@) -o $@ -c $< 62 | 63 | %.cmi: %.mli 64 | $(COMPILER) $(COMPFLAGS) $(shell ./Compflags $@) -c $< 65 | 66 | stdlib__%.cmi: %.mli 67 | $(COMPILER) $(COMPFLAGS) $(shell ./Compflags $@) -o $@ -c $< 68 | 69 | %.cmx: %.ml 70 | $(COMPILER) $(COMPFLAGS) $(shell ./Compflags $@) -c $< 71 | 72 | stdlib__%.cmx: %.ml 73 | $(COMPILER) $(COMPFLAGS) $(shell ./Compflags $@) -o $@ -c $< 74 | 75 | 76 | 77 | # Dependencies on Stdlib (not tracked by ocamldep) 78 | 79 | $(OTHERS:.cmx=.cmi) std_exit.cmi: stdlib.cmi 80 | $(OBJS) std_exit.cmx: stdlib.cmi 81 | ifeq "$(OPAQUE)" "" 82 | CMIX=cmx 83 | $(OTHERS) std_exit.cmx: stdlib.cmx 84 | else 85 | CMIX=cmi 86 | endif 87 | 88 | clean:: 89 | rm -f *.cm* *.o *.a 90 | rm -f *~ 91 | 92 | include .depend 93 | 94 | EMPTY := 95 | SPACE := $(EMPTY) $(EMPTY) 96 | 97 | .PHONY: depend 98 | depend: 99 | $(DEPEND) $(filter-out stdlib.%,$(wildcard *.mli *.ml)) \ 100 | > .depend.tmp 101 | echo "stdlib.cmi : camlinternalFormatBasics.cmi" >> .depend.tmp 102 | echo "stdlib.cmx : camlinternalFormatBasics.$(CMIX)" >> .depend.tmp 103 | sed -Ee \ 104 | 's#(^| )(${subst ${SPACE},|,${PREFIXED_OBJS:stdlib__%.cmx=%}})[.]#\1stdlib__\2.#g' \ 105 | .depend.tmp > .depend 106 | rm -f .depend.tmp 107 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # camlboot: An OCaml bootstrap experiment 2 | 3 | camlboot is an experiment on the boostraping of the [OCaml](https://ocaml.org/) compiler. It is composed of: 4 | 5 | - An interpreter of OCaml, in the directory `interpreter/`, which is able to interpret the OCaml compiler. This interpreter is written in a subset of OCaml called miniml, for which a compiler is available as part of the experiment. 6 | - A compiler for miniml, in the directory `miniml/compiler/`. This compiler compiles miniml to OCaml bytecode, which is then executed by the OCaml runtime. It is written in scheme (more specifically, [guile](https://www.gnu.org/software/guile/)), since the goal is to bootstrap OCaml. Note that guile is itself bootstrapped directly from gcc, and building OCaml needs a C compiler as well, so we effectively bootstrap OCaml from gcc. 7 | - A handwritten lexer for the bootstrapping of ocamllex, in the directory `lex/`. This lexer is able to perform the lexing of ocamllex's own `lexer.mll`, the first step towards the bootstrap of ocamllex, and then OCaml. 8 | 9 | ## Compilation: 10 | 11 | After cloning, you first need to clone the `ocaml/` submodule, with `git submodule init && git submodule update --recursive`. 12 | You will also need a C compiler, and `guile`. 13 | 14 | Then you can perform `make -j$(nproc) _boot/ocamlc && make -j$(nproc) fullboot`, which will compile a bootstrap compiler, and use it to fully bootstrap OCaml from sources. The resulting bytecode should be bit-for-bit compatible with the one you can get by compiling the code in the `ocaml-src/` submodule with its own bundled bootstrap compiler. 15 | Expect this to take some time: on an 8-core machine, it took about 16 hours of CPU time, and 4 hours of wall-clock time. 16 | -------------------------------------------------------------------------------- /compile_stdlib.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | ulimit -s 2000000 4 | 5 | export COMPILER=../../miniml/interp/interp.opt 6 | export COMPFLAGS="-strict-sequence -absname -w +a-4-9-41-42-44-45-48 -g -warn-error A -bin-annot -nostdlib -safe-string -strict-formats" 7 | 8 | export EXT=cmx 9 | export AEXT=cmxa 10 | 11 | compile () { 12 | # Target = $1, source = $2 13 | echo $COMPILER $COMPFLAGS $(./Compflags $1) -o $1 -c $2 14 | $COMPILER $COMPFLAGS $(./Compflags $1) -o $1 -c $2 15 | } 16 | 17 | compile camlinternalFormatBasics.cmi camlinternalFormatBasics.mli 18 | compile camlinternalFormatBasics.$EXT camlinternalFormatBasics.ml 19 | compile stdlib.cmi stdlib.pp.mli 20 | compile stdlib.$EXT stdlib.pp.ml 21 | compile stdlib__seq.cmi seq.mli 22 | compile stdlib__seq.$EXT seq.ml 23 | compile stdlib__char.cmi char.mli 24 | compile stdlib__char.$EXT char.ml 25 | compile stdlib__uchar.cmi uchar.mli 26 | compile stdlib__uchar.$EXT uchar.ml 27 | compile stdlib__sys.cmi sys.mli 28 | compile stdlib__sys.$EXT sys.ml 29 | compile stdlib__list.cmi list.mli 30 | compile stdlib__list.$EXT list.ml 31 | compile stdlib__bytes.cmi bytes.mli 32 | compile stdlib__bytes.$EXT bytes.ml 33 | compile stdlib__string.cmi string.mli 34 | compile stdlib__string.$EXT string.ml 35 | compile stdlib__array.cmi array.mli 36 | compile stdlib__sort.cmi sort.mli 37 | compile stdlib__sort.$EXT sort.ml 38 | compile stdlib__marshal.cmi marshal.mli 39 | compile stdlib__marshal.$EXT marshal.ml 40 | compile stdlib__int32.cmi int32.mli 41 | compile stdlib__obj.cmi obj.mli 42 | compile stdlib__obj.$EXT obj.ml 43 | compile stdlib__float.cmi float.mli 44 | compile stdlib__float.$EXT float.ml 45 | compile stdlib__array.$EXT array.ml 46 | compile stdlib__int32.$EXT int32.ml 47 | compile stdlib__int64.cmi int64.mli 48 | compile stdlib__int64.$EXT int64.ml 49 | compile stdlib__nativeint.cmi nativeint.mli 50 | compile stdlib__nativeint.$EXT nativeint.ml 51 | compile stdlib__lexing.cmi lexing.mli 52 | compile stdlib__lexing.$EXT lexing.ml 53 | compile stdlib__parsing.cmi parsing.mli 54 | compile stdlib__parsing.$EXT parsing.ml 55 | compile stdlib__set.cmi set.mli 56 | compile stdlib__set.$EXT set.ml 57 | compile stdlib__map.cmi map.mli 58 | compile stdlib__map.$EXT map.ml 59 | compile stdlib__stack.cmi stack.mli 60 | compile stdlib__stack.$EXT stack.ml 61 | compile stdlib__queue.cmi queue.mli 62 | compile stdlib__queue.$EXT queue.ml 63 | compile camlinternalLazy.cmi camlinternalLazy.mli 64 | compile camlinternalLazy.$EXT camlinternalLazy.ml 65 | compile stdlib__lazy.cmi lazy.mli 66 | compile stdlib__lazy.$EXT lazy.ml 67 | compile stdlib__stream.cmi stream.mli 68 | compile stdlib__stream.$EXT stream.ml 69 | compile stdlib__buffer.cmi buffer.mli 70 | compile stdlib__buffer.$EXT buffer.ml 71 | compile camlinternalFormat.cmi camlinternalFormat.mli 72 | compile camlinternalFormat.$EXT camlinternalFormat.ml 73 | compile stdlib__printf.cmi printf.mli 74 | compile stdlib__printf.$EXT printf.ml 75 | compile stdlib__arg.cmi arg.mli 76 | compile stdlib__arg.$EXT arg.ml 77 | compile stdlib__printexc.cmi printexc.mli 78 | compile stdlib__printexc.$EXT printexc.ml 79 | compile stdlib__gc.cmi gc.mli 80 | compile stdlib__gc.$EXT gc.ml 81 | compile stdlib__digest.cmi digest.mli 82 | compile stdlib__digest.$EXT digest.ml 83 | compile stdlib__random.cmi random.mli 84 | compile stdlib__random.$EXT random.ml 85 | compile stdlib__hashtbl.cmi hashtbl.mli 86 | compile stdlib__hashtbl.$EXT hashtbl.ml 87 | compile stdlib__weak.cmi weak.mli 88 | compile stdlib__weak.$EXT weak.ml 89 | compile stdlib__format.cmi format.mli 90 | compile stdlib__format.$EXT format.ml 91 | compile stdlib__scanf.cmi scanf.mli 92 | compile stdlib__scanf.$EXT scanf.ml 93 | compile stdlib__callback.cmi callback.mli 94 | compile stdlib__callback.$EXT callback.ml 95 | compile camlinternalOO.cmi camlinternalOO.mli 96 | compile camlinternalOO.$EXT camlinternalOO.ml 97 | compile stdlib__oo.cmi oo.mli 98 | compile stdlib__oo.$EXT oo.ml 99 | compile camlinternalMod.cmi camlinternalMod.mli 100 | compile camlinternalMod.$EXT camlinternalMod.ml 101 | compile stdlib__genlex.cmi genlex.mli 102 | compile stdlib__genlex.$EXT genlex.ml 103 | compile stdlib__ephemeron.cmi ephemeron.mli 104 | compile stdlib__ephemeron.$EXT ephemeron.ml 105 | compile stdlib__filename.cmi filename.mli 106 | compile stdlib__filename.$EXT filename.ml 107 | compile stdlib__complex.cmi complex.mli 108 | compile stdlib__complex.$EXT complex.ml 109 | compile stdlib__arrayLabels.cmi arrayLabels.mli 110 | compile stdlib__arrayLabels.$EXT arrayLabels.ml 111 | compile stdlib__listLabels.cmi listLabels.mli 112 | compile stdlib__listLabels.$EXT listLabels.ml 113 | compile stdlib__bytesLabels.cmi bytesLabels.mli 114 | compile stdlib__bytesLabels.$EXT bytesLabels.ml 115 | compile stdlib__stringLabels.cmi stringLabels.mli 116 | compile stdlib__stringLabels.$EXT stringLabels.ml 117 | compile stdlib__moreLabels.cmi moreLabels.mli 118 | compile stdlib__moreLabels.$EXT moreLabels.ml 119 | compile stdlib__stdLabels.cmi stdLabels.mli 120 | compile stdlib__stdLabels.$EXT stdLabels.ml 121 | compile stdlib__spacetime.cmi spacetime.mli 122 | compile stdlib__spacetime.$EXT spacetime.ml 123 | compile stdlib__bigarray.cmi bigarray.mli 124 | compile stdlib__bigarray.$EXT bigarray.ml 125 | $COMPILER -a -o stdlib.$AEXT camlinternalFormatBasics.$EXT stdlib.$EXT stdlib__seq.$EXT stdlib__char.$EXT stdlib__uchar.$EXT stdlib__sys.$EXT stdlib__list.$EXT stdlib__bytes.$EXT stdlib__string.$EXT stdlib__sort.$EXT stdlib__marshal.$EXT stdlib__obj.$EXT stdlib__float.$EXT stdlib__array.$EXT stdlib__int32.$EXT stdlib__int64.$EXT stdlib__nativeint.$EXT stdlib__lexing.$EXT stdlib__parsing.$EXT stdlib__set.$EXT stdlib__map.$EXT stdlib__stack.$EXT stdlib__queue.$EXT camlinternalLazy.$EXT stdlib__lazy.$EXT stdlib__stream.$EXT stdlib__buffer.$EXT camlinternalFormat.$EXT stdlib__printf.$EXT stdlib__arg.$EXT stdlib__printexc.$EXT stdlib__gc.$EXT stdlib__digest.$EXT stdlib__random.$EXT stdlib__hashtbl.$EXT stdlib__weak.$EXT stdlib__format.$EXT stdlib__scanf.$EXT stdlib__callback.$EXT camlinternalOO.$EXT stdlib__oo.$EXT camlinternalMod.$EXT stdlib__genlex.$EXT stdlib__ephemeron.$EXT stdlib__filename.$EXT stdlib__complex.$EXT stdlib__arrayLabels.$EXT stdlib__listLabels.$EXT stdlib__bytesLabels.$EXT stdlib__stringLabels.$EXT stdlib__moreLabels.$EXT stdlib__stdLabels.$EXT stdlib__spacetime.$EXT stdlib__bigarray.$EXT 126 | $COMPILER $COMPFLAGS -c std_exit.ml 127 | -------------------------------------------------------------------------------- /interpreter/Makefile: -------------------------------------------------------------------------------- 1 | OBJS=conf.cmo data.cmo envir.cmo \ 2 | runtime_lib.cmo runtime_base.cmo \ 3 | eval.cmo \ 4 | runtime_stdlib.cmo runtime_compiler.cmo \ 5 | primitives.cmo \ 6 | interp.cmo 7 | SRCS=$(OBJS:.cmo=.ml) 8 | FLAGS=-g -package unix -package compiler-libs.common -linkpkg 9 | OCAML=ocamlfind ocamlc 10 | OCAMLOPT=ocamlfind ocamlopt 11 | 12 | .PHONY: all clean format 13 | all: interp interpopt 14 | 15 | clean: 16 | for f in $(wildcard *.cm*) $(wildcard *.o); do rm $$f; done 17 | 18 | format: 19 | ocamlformat --inplace $(SRCS) 20 | 21 | 22 | .SUFFIXES: .mli .ml .cmi .cmo .cmx 23 | 24 | .ml.cmx: 25 | $(OCAMLOPT) $(FLAGS) -c $< 26 | 27 | .ml.cmo: 28 | $(OCAML) $(FLAGS) -c $< 29 | 30 | .mli.cmi: 31 | $(OCAML) $(FLAGS) -c $< 32 | 33 | .depend: $(SRCS) 34 | ocamldep $(SRCS) > .depend 35 | 36 | include .depend 37 | 38 | interp: $(OBJS) 39 | echo $(OCAML) $(FLAGS) -linkpkg -o $@ $+ 40 | $(OCAML) $(FLAGS) -linkpkg -o $@ $+ 41 | 42 | interpopt: $(OBJS:.cmo=.cmx) 43 | $(OCAMLOPT) $(FLAGS) -linkpkg -o $@ $+ 44 | 45 | .PHONY: run 46 | 47 | RUNARGS ?= 48 | OCAMLINTERP_DEBUG ?= true 49 | OCAMLRUNPARAM ?= b 50 | # we defined a symbolic link ../ocaml-src to point to the compiler sources, 51 | # at a version copmatible with the OCAMLINTERP_STDLIB_PATH version. 52 | OCAMLINTERP_SRC_PATH ?= ../ocaml-src 53 | OCAMLINTERP_STDLIB_PATH ?= $(OCAMLINTERP_SRC_PATH)/stdlib 54 | 55 | run: interpopt 56 | env \ 57 | OCAMLRUNPARAM=$(OCAMLRUNPARAM) \ 58 | OCAMLINTERP_DEBUG=$(OCAMLINTERP_DEBUG) \ 59 | OCAMLINTERP_SRC_PATH=$(OCAMLINTERP_SRC_PATH) \ 60 | OCAMLINTERP_STDLIB_PATH=$(OCAMLINTERP_STDLIB_PATH) \ 61 | ./interpopt $(RUNARGS) 62 | 63 | test: interpopt 64 | cd tests && sh runtests.sh 65 | -------------------------------------------------------------------------------- /interpreter/README.md: -------------------------------------------------------------------------------- 1 | # OCaml interpreter 2 | 3 | This directory contains an interpreter for OCaml, written in miniml. It aims to be as correct as possible while only using the untyped representation of the program. 4 | 5 | It has three main modes: 6 | - `OCAMLINTERP_COMMAND=ocamlc ./interp`, which will interpret the compiler sources to get a replacement for `ocamlc`, 7 | - `OCAMLINTERP_COMMAND=ocamlopt ./interp`, which will interpret the compiler sources to get a replacement for `ocamlopt`, 8 | - `OCAMLINTERP_COMMAND=files ./interp [list of files]`, which will interpret the list of files given as argument. 9 | 10 | For now, it is written in a subset of OCaml a bit larger than miniml, but we are working on making it compatible with miniml by avoiding the use of unnecessary features and adding other features to miniml. 11 | -------------------------------------------------------------------------------- /interpreter/conf.ml: -------------------------------------------------------------------------------- 1 | let trace = false 2 | let traceend = false 3 | let tracearg_from = 75000_000000L 4 | let tracecur = ref 0L 5 | let tracedepth = ref 0 6 | 7 | let debug = 8 | match Sys.getenv_opt "OCAMLINTERP_DEBUG" with 9 | | Some ("1" | "true" | "yes") -> true 10 | | Some ("0" | "false" | "no") -> false 11 | | Some other -> 12 | Printf.kprintf 13 | failwith 14 | "Error: unknown OCAMLINTERP_DEBUG value %S, use 'true' or 'false'" 15 | other 16 | | None -> 17 | (* default *) 18 | false 19 | 20 | let stdlib_path () = 21 | match Sys.getenv_opt "OCAMLINTERP_STDLIB_PATH" with 22 | | Some path -> path 23 | | None -> (* 24 | let input = Unix.open_process_in "ocamlc -where" in 25 | (match input_line input with 26 | | exception _ -> 27 | close_in input; 28 | failwith "Error: unable to determine the standard library location" 29 | | path -> 30 | close_in input; 31 | path) *) 32 | failwith "Error: standard library location must be specified" 33 | 34 | let compiler_source_path () = 35 | match Sys.getenv_opt "OCAMLINTERP_SRC_PATH" with 36 | | Some path -> path 37 | | None -> 38 | failwith 39 | "Error: please set an OCAMLINTERP_SRC_PATH variable pointing to a \ 40 | checkout of the OCaml compiler distribution sources" 41 | 42 | type command = 43 | | Ocamlc 44 | | Ocamlopt 45 | | Files 46 | 47 | let command () = 48 | match Sys.getenv_opt "OCAMLINTERP_COMMAND" with 49 | | Some "ocamlc" -> Some Ocamlc 50 | | Some "ocamlopt" -> Some Ocamlopt 51 | | Some "files" -> Some Files 52 | | Some cmd -> 53 | Format.eprintf "Unexpected OCAMLINTERP_COMMAND command %S, \ 54 | expected ocamlc|ocamlopt|files.@." 55 | cmd; exit 1 56 | | None -> None 57 | -------------------------------------------------------------------------------- /interpreter/conf.mli: -------------------------------------------------------------------------------- 1 | val trace : bool 2 | val traceend : bool 3 | val tracearg_from : int64 4 | val tracecur : int64 ref 5 | val tracedepth : int ref 6 | val debug : bool 7 | val stdlib_path : unit -> string 8 | val compiler_source_path : unit -> string 9 | type command = Ocamlc | Ocamlopt | Files 10 | val command : unit -> command option 11 | -------------------------------------------------------------------------------- /interpreter/data.mli: -------------------------------------------------------------------------------- 1 | module SMap : Map.S with type key = string 2 | module SSet : Set.S with type elt = string 3 | type module_unit_id = Path of string 4 | module UStore : Map.S with type key = module_unit_id 5 | 6 | module Ptr : 7 | sig 8 | type 'a t 9 | val create : 'a -> 'a t 10 | exception Null 11 | val get : 'a t -> 'a 12 | val dummy : unit -> 'a t 13 | exception Full 14 | val backpatch : 'a t -> 'a -> unit 15 | end 16 | 17 | val ptr : 'a -> 'a Ptr.t 18 | val onptr : ('a -> 'b) -> 'a Ptr.t -> 'b 19 | 20 | type value = value_ Ptr.t 21 | and value_ = 22 | Int of int 23 | | Int32 of int32 24 | | Int64 of int64 25 | | Nativeint of nativeint 26 | | Fun of Asttypes.arg_label * Parsetree.expression option * 27 | Parsetree.pattern * Parsetree.expression * env 28 | | Function of Parsetree.case list * env 29 | | String of bytes 30 | | Float of float 31 | | Tuple of value list 32 | | Constructor of string * int * value option 33 | | Prim of (value -> value) 34 | | Fexpr of fexpr 35 | | ModVal of mdl 36 | | InChannel of in_channel 37 | | OutChannel of out_channel 38 | | Record of value ref SMap.t 39 | | Lz of (unit -> value) ref 40 | | Array of value array 41 | | Fun_with_extra_args of value * value list * 42 | (Asttypes.arg_label * value) SMap.t 43 | | Object of object_value 44 | 45 | and fexpr = 46 | Location.t -> 47 | (Asttypes.arg_label * Parsetree.expression) list -> 48 | Parsetree.expression option 49 | 50 | and 'a env_map = (bool * 'a) SMap.t 51 | 52 | and env = { 53 | values : value_or_lvar env_map; 54 | modules : mdl env_map; 55 | constructors : int env_map; 56 | classes : class_def env_map; 57 | current_object : object_value option; 58 | } 59 | 60 | and value_or_lvar = 61 | Value of value 62 | | Instance_variable of object_value * string 63 | 64 | and class_def = Parsetree.class_expr * env ref 65 | 66 | and mdl = 67 | Unit of module_unit_id * module_unit_state ref 68 | | Module of mdl_val 69 | | Functor of string * Parsetree.module_expr * env 70 | 71 | and mdl_val = { 72 | mod_values : value SMap.t; 73 | mod_modules : mdl SMap.t; 74 | mod_constructors : int SMap.t; 75 | mod_classes : class_def SMap.t; 76 | } 77 | 78 | and module_unit_state = Not_initialized_yet | Initialized of mdl_val 79 | 80 | and object_value = { 81 | env : env; 82 | self : Parsetree.pattern; 83 | initializers : expr_in_object list; 84 | named_parents : object_value SMap.t; 85 | variables : value ref SMap.t; 86 | methods : expr_in_object SMap.t; 87 | parent_view : string list; 88 | } 89 | 90 | and source_object = Current_object | Parent of object_value 91 | 92 | and expr_in_object = { 93 | source : source_object; 94 | instance_variable_scope : SSet.t; 95 | named_parents_scope : SSet.t; 96 | expr : Parsetree.expression; 97 | } 98 | 99 | exception InternalException of value 100 | 101 | val unit : value_ Ptr.t 102 | val is_true : value_ Ptr.t -> bool 103 | val pp_print_value : Format.formatter -> value_ Ptr.t -> unit 104 | val pp_print_unit_id : Format.formatter -> module_unit_id -> unit 105 | val read_caml_int : string -> int64 106 | val value_of_constant : Parsetree.constant -> value_ Ptr.t 107 | val value_compare : value_ Ptr.t -> value_ Ptr.t -> int 108 | val value_equal : value_ Ptr.t -> value_ Ptr.t -> bool 109 | val value_lt : value_ Ptr.t -> value_ Ptr.t -> bool 110 | val value_le : value_ Ptr.t -> value_ Ptr.t -> bool 111 | val value_gt : value_ Ptr.t -> value_ Ptr.t -> bool 112 | val value_ge : value_ Ptr.t -> value_ Ptr.t -> bool 113 | val next_exn_id : unit -> int 114 | exception No_module_data 115 | val get_module_data : Location.t -> mdl -> mdl_val 116 | val module_name_of_unit_path : string -> string 117 | -------------------------------------------------------------------------------- /interpreter/envir.ml: -------------------------------------------------------------------------------- 1 | open Asttypes 2 | open Conf 3 | open Data 4 | 5 | let empty_env = 6 | { values = SMap.empty; 7 | modules = SMap.empty; 8 | constructors = SMap.empty; 9 | classes = SMap.empty; 10 | current_object = None; 11 | } 12 | 13 | let env_set_value key v env = 14 | { env with values = SMap.add key (true, Value v) env.values } 15 | 16 | let env_set_lvar lvar obj env = 17 | { env with values = 18 | SMap.add lvar (false, Instance_variable (obj, lvar)) env.values } 19 | 20 | let env_set_instance_variable key obj v env = 21 | { env with values = SMap.add key (true, Instance_variable (obj, v)) env.values } 22 | 23 | let env_set_module key m env = 24 | { env with modules = SMap.add key (true, m) env.modules } 25 | 26 | let env_set_constr key c env = 27 | { env with constructors = SMap.add key (true, c) env.constructors } 28 | 29 | let env_set_class key cl env = 30 | { env with classes = SMap.add key (true, cl) env.classes } 31 | 32 | let env_extend exported env1 data = 33 | let merge s1 s2 = 34 | SMap.fold (fun k v env -> SMap.add k (exported, v) env) s2 s1 35 | in 36 | let values s = SMap.map (fun v -> Value v) s in 37 | { values = merge env1.values (values data.mod_values); 38 | modules = merge env1.modules data.mod_modules; 39 | constructors = merge env1.constructors data.mod_constructors; 40 | classes = merge env1.classes data.mod_classes; 41 | current_object = env1.current_object; 42 | } 43 | 44 | let declare_unit env unit_path = 45 | let module_name = module_name_of_unit_path unit_path in 46 | let unit_id = Path unit_path in 47 | let unit_mod = Unit (unit_id, ref Not_initialized_yet) in 48 | let modules = SMap.add module_name (true, unit_mod) env.modules in 49 | { env with modules; } 50 | 51 | let define_unit env unit_path mdl = 52 | let module_name = module_name_of_unit_path unit_path in 53 | match SMap.find module_name env.modules with 54 | | exception Not_found -> 55 | Format.kasprintf invalid_arg 56 | "define_unit: The module unit %s is not yet declared" 57 | module_name 58 | | (_, (Module _ | Functor _)) -> 59 | Format.kasprintf invalid_arg 60 | "define_unit: The module %s is not a unit" 61 | module_name 62 | | (_, Unit (unit_id, unit_state)) -> 63 | begin match !unit_state with 64 | | Initialized _ -> 65 | Format.kasprintf invalid_arg 66 | "define_unit: The module unit %a is already defined" 67 | pp_print_unit_id unit_id 68 | | Not_initialized_yet -> 69 | unit_state := Initialized mdl; 70 | env 71 | end 72 | 73 | let env_of_module_data mod_data = 74 | env_extend true empty_env mod_data 75 | 76 | let make_module_data env = 77 | let exported env_map = 78 | env_map |> SMap.filter (fun _ (b, _) -> b) |> SMap.map snd 79 | in 80 | let values env_map = 81 | env_map 82 | |> SMap.filter (fun _ -> function 83 | | Value _v -> true 84 | | Instance_variable _ -> false) 85 | |> SMap.map (function 86 | | Value v -> v 87 | | Instance_variable _ -> assert false) in 88 | { 89 | mod_values = values (exported env.values); 90 | mod_modules = exported env.modules; 91 | mod_constructors = exported env.constructors; 92 | mod_classes = exported env.classes; 93 | } 94 | 95 | let prevent_export env = 96 | let prevent env_map = SMap.map (fun (_, x) -> (false, x)) env_map in 97 | { values = prevent env.values; 98 | modules = prevent env.modules; 99 | constructors = prevent env.constructors; 100 | classes = prevent env.classes; 101 | current_object = env.current_object; 102 | } 103 | 104 | let decompose get_module_data env { txt = lident; loc } = 105 | match lident with 106 | | Longident.Lapply _ -> failwith "Lapply lookups not supported" 107 | | Longident.Lident str -> ("env", env, str) 108 | | Longident.Ldot (ld, str) -> 109 | let md = get_module_data env { txt = ld; loc } in 110 | ("module", env_of_module_data md, str) 111 | 112 | let lookup object_name ~env_name object_env { txt = str; loc } = 113 | try snd (SMap.find str object_env) 114 | with Not_found -> 115 | Format.eprintf 116 | "%a@.%s not found in %s: %s@." 117 | Location.print_loc 118 | loc 119 | (String.capitalize_ascii object_name) 120 | env_name 121 | str; 122 | raise Not_found 123 | 124 | let rec env_get_module env ({ loc; _ } as lid) = 125 | let env_name, env, id = decompose env_get_module_data env lid in 126 | lookup "module" ~env_name env.modules { txt = id; loc } 127 | 128 | and env_get_value_or_lvar env ({ loc; _ } as lid) = 129 | let env_name, env, id = decompose env_get_module_data env lid in 130 | lookup "value" ~env_name env.values { txt = id; loc } 131 | 132 | and env_get_constr env ({ loc; _ } as lid) = 133 | let env_name, env, id = decompose env_get_module_data env lid in 134 | lookup "constructor" ~env_name env.constructors { txt = id; loc } 135 | 136 | and env_get_class env ({ loc; _ } as lid) = 137 | let env_name, env, id = decompose env_get_module_data env lid in 138 | lookup "class" ~env_name env.classes { txt = id; loc } 139 | 140 | and env_get_module_data env ({ loc; _ } as id) = 141 | get_module_data loc (env_get_module env id) 142 | -------------------------------------------------------------------------------- /interpreter/envir.mli: -------------------------------------------------------------------------------- 1 | open Data 2 | 3 | val empty_env : env 4 | val env_set_value : SMap.key -> value -> env -> env 5 | val env_set_lvar : SMap.key -> object_value -> env -> env 6 | val env_set_instance_variable : 7 | SMap.key -> object_value -> string -> env -> env 8 | val env_set_module : SMap.key -> mdl -> env -> env 9 | val env_set_constr : SMap.key -> int -> env -> env 10 | val env_set_class : SMap.key -> class_def -> env -> env 11 | val env_extend : bool -> env -> mdl_val -> env 12 | val declare_unit : env -> string -> env 13 | val define_unit : env -> string -> mdl_val -> env 14 | val env_of_module_data : mdl_val -> env 15 | val make_module_data : env -> mdl_val 16 | val prevent_export : env -> env 17 | val decompose : 18 | (env -> Longident.t Asttypes.loc -> mdl_val) -> 19 | env -> Longident.t Asttypes.loc -> string * env * string 20 | val lookup : 21 | string -> 22 | env_name:string -> ('a * 'b) SMap.t -> SMap.key Asttypes.loc -> 'b 23 | val env_get_module : env -> Longident.t Asttypes.loc -> mdl 24 | val env_get_value_or_lvar : 25 | env -> Longident.t Asttypes.loc -> value_or_lvar 26 | val env_get_constr : env -> Longident.t Asttypes.loc -> int 27 | val env_get_class : env -> Longident.t Asttypes.loc -> class_def 28 | val env_get_module_data : 29 | env -> Longident.t Asttypes.loc -> mdl_val 30 | -------------------------------------------------------------------------------- /interpreter/eval.mli: -------------------------------------------------------------------------------- 1 | open Data 2 | 3 | exception Match_fail 4 | val lident_name : Longident.t -> string 5 | val expr_label_shape : 6 | Parsetree.expression_desc -> 7 | (Asttypes.arg_label * Parsetree.expression option) list 8 | val fun_label_shape : 9 | value_ -> 10 | (Asttypes.arg_label * Parsetree.expression option) list 11 | val mismatch : Location.t -> unit 12 | val unsupported : Location.t -> unit 13 | val take : int -> 'a list -> 'a list 14 | val apply : 15 | value SMap.t -> 16 | value -> 17 | (Asttypes.arg_label * value) list -> value 18 | val eval_expr : 19 | value SMap.t -> env -> Parsetree.expression -> value 20 | val eval_expr_exn : 21 | value SMap.t -> 22 | env -> Parsetree.expression -> (value, value) result 23 | val bind_value : 24 | value SMap.t -> env -> Parsetree.value_binding -> env 25 | val eval_bindings : 26 | value SMap.t -> 27 | env -> 28 | Asttypes.rec_flag -> Parsetree.value_binding list -> env 29 | val pattern_bind : 30 | value SMap.t -> 31 | env -> Parsetree.pattern -> value -> env 32 | val pattern_bind_exn : 33 | value SMap.t -> 34 | env -> Parsetree.pattern -> value -> env 35 | val pattern_bind_checkexn : 36 | value SMap.t -> 37 | env -> 38 | Parsetree.pattern -> (value, value) result -> env 39 | val eval_match : 40 | value SMap.t -> 41 | env -> 42 | Parsetree.case list -> 43 | (value, value) result -> value 44 | val lookup_viewed_object : object_value -> object_value 45 | val eval_expr_in_object : 46 | value SMap.t -> 47 | object_value -> expr_in_object -> value 48 | val eval_obj_send : 49 | Location.t -> 50 | value SMap.t -> 51 | object_value -> Asttypes.label Asttypes.loc -> value 52 | val eval_obj_override : 53 | value SMap.t -> 54 | env -> 55 | object_value -> 56 | (SMap.key Asttypes.loc * Parsetree.expression) list -> 57 | object_value 58 | val eval_class_expr : 59 | value SMap.t -> env -> Parsetree.class_expr -> value 60 | val eval_class_structure : 61 | value SMap.t -> 62 | env -> Location.t -> Parsetree.class_structure -> object_value 63 | val eval_obj_initializers : 64 | value SMap.t -> env -> object_value -> unit 65 | val eval_obj_new : 66 | value SMap.t -> env -> Parsetree.class_expr -> value 67 | val eval_module_expr : 68 | value SMap.t -> env -> Parsetree.module_expr -> mdl 69 | val eval_functor_data : 70 | env -> 71 | Location.t -> mdl -> SMap.key * Parsetree.module_expr * env 72 | val eval_structitem : 73 | value SMap.t -> env -> Parsetree.structure_item -> env 74 | val eval_structure_ : 75 | value SMap.t -> env -> Parsetree.structure -> env 76 | val eval_structure : 77 | value SMap.t -> env -> Parsetree.structure -> env 78 | -------------------------------------------------------------------------------- /interpreter/interp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Ekdohibs/camlboot/2692b14a4e685387194556e511fe23057d25c6c3/interpreter/interp -------------------------------------------------------------------------------- /interpreter/interp.mli: -------------------------------------------------------------------------------- 1 | open Data 2 | 3 | val parse : string -> Parsetree.structure 4 | type env_flag = Open of Longident.t 5 | val stdlib_flag : env_flag list 6 | val no_stdlib_flag : 'a list 7 | val stdlib_units : (env_flag list * string) list 8 | val eval_env_flag : loc:Location.t -> env -> env_flag -> env 9 | val load_rec_units : 10 | env -> (env_flag list * string) list -> env 11 | val stdlib_env : env 12 | module Compiler_files : 13 | sig 14 | val utils : string list 15 | val parsing : string list 16 | val pure_typing : string list 17 | val lambda : string list 18 | val more_typing : string list 19 | val bytecomp : string list 20 | val driver : string list 21 | val middle_end : string list 22 | val asmcomp : string list 23 | val bytegen : string list 24 | val bytecode_main : string list 25 | val native_main : string list 26 | end 27 | val bytecode_compiler_units : (env_flag list * string) list 28 | val native_compiler_units : (env_flag list * string) list 29 | val run_ocamlc : unit -> unit 30 | val run_ocamlopt : unit -> unit 31 | val run_files : unit -> unit 32 | -------------------------------------------------------------------------------- /interpreter/primitives.mli: -------------------------------------------------------------------------------- 1 | open Data 2 | 3 | val prims : value SMap.t 4 | -------------------------------------------------------------------------------- /interpreter/runtime_base.ml: -------------------------------------------------------------------------------- 1 | open Data 2 | 3 | let type_error expected got = Format.eprintf "Error: expected %s, got %a@." expected pp_print_value (Ptr.create got); assert false 4 | 5 | let wrap_int n = ptr @@ Int n 6 | let unwrap_int = onptr @@ function 7 | | Int n -> n 8 | | v -> type_error "int" v 9 | 10 | let wrap_int32 n = ptr @@ Int32 n 11 | let unwrap_int32 = onptr @@ function 12 | | Int32 n -> n 13 | | v -> type_error "int32" v 14 | 15 | let wrap_int64 n = ptr @@ Int64 n 16 | let unwrap_int64 = onptr @@ function 17 | | Int64 n -> n 18 | | v -> type_error "int64" v 19 | 20 | let wrap_nativeint n = ptr @@ Nativeint n 21 | let unwrap_nativeint = onptr @@ function 22 | | Nativeint n -> n 23 | | v -> type_error "nativeint" v 24 | 25 | let wrap_float f = ptr @@ Float f 26 | let unwrap_float = onptr @@ function 27 | | Float f -> f 28 | | v -> type_error "float" v 29 | 30 | let unwrap_bool = is_true 31 | 32 | let wrap_bool b = ptr @@ 33 | if b then Constructor ("true", 1, None) else Constructor ("false", 0, None) 34 | 35 | let wrap_unit () = unit 36 | 37 | let unwrap_unit = onptr @@ function 38 | | Constructor ("()", 0, None) -> () 39 | | v -> type_error "unit" v 40 | 41 | let wrap_bytes s = ptr @@ String s 42 | 43 | let unwrap_bytes = onptr @@ function 44 | | String s -> s 45 | | v -> type_error "bytes" v 46 | 47 | let wrap_string s = ptr @@ String (Bytes.of_string s) 48 | 49 | let unwrap_string = onptr @@ function 50 | | String s -> Bytes.to_string s 51 | | v -> type_error "string" v 52 | 53 | let wrap_string_unsafe s = ptr @@ String (Bytes.unsafe_of_string s) 54 | 55 | let unwrap_string_unsafe = onptr @@ function 56 | | String s -> Bytes.unsafe_to_string s 57 | | v -> type_error "string" v 58 | 59 | let wrap_char c = ptr @@ Int (int_of_char c) 60 | 61 | let unwrap_char = onptr @@ function 62 | | Int n -> char_of_int (n land 255) 63 | | v -> type_error "char" v 64 | 65 | let wrap_array wrapf a = ptr @@ Array (Array.map wrapf a) 66 | 67 | let unwrap_array unwrapf = onptr @@ function 68 | | Array a -> Array.map unwrapf a 69 | | v -> type_error "array" v 70 | 71 | let declare_builtin_constructor name d env = 72 | Envir.env_set_constr name d env 73 | 74 | let declare_exn name env = 75 | let d = next_exn_id () in 76 | declare_builtin_constructor name d env 77 | 78 | let initial_env = 79 | Envir.empty_env 80 | |> declare_exn "Not_found" 81 | |> declare_exn "Exit" 82 | |> declare_exn "Invalid_argument" 83 | |> declare_exn "Failure" 84 | |> declare_exn "Match_failure" 85 | |> declare_exn "Assert_failure" 86 | |> declare_exn "Sys_blocked_io" 87 | |> declare_exn "Sys_error" 88 | |> declare_exn "End_of_file" 89 | |> declare_exn "Division_by_zero" 90 | |> declare_exn "Undefined_recursive_module" 91 | |> declare_builtin_constructor "false" 0 92 | |> declare_builtin_constructor "true" 1 93 | |> declare_builtin_constructor "None" 0 94 | |> declare_builtin_constructor "Some" 0 95 | |> declare_builtin_constructor "[]" 0 96 | |> declare_builtin_constructor "::" 0 97 | |> declare_builtin_constructor "()" 0 98 | 99 | let not_found_exn = Runtime_lib.exn0 initial_env "Not_found" 100 | 101 | let exit_exn = Runtime_lib.exn0 initial_env "Exit" 102 | 103 | let invalid_argument_exn = 104 | Runtime_lib.exn1 initial_env "Invalid_argument" wrap_string 105 | 106 | let failure_exn = Runtime_lib.exn1 initial_env "Failure" wrap_string 107 | 108 | let match_failure_exn = 109 | Runtime_lib.exn3 initial_env "Match_failure" wrap_string wrap_int wrap_int 110 | 111 | let assert_failure_exn = 112 | Runtime_lib.exn3 initial_env "Assert_failure" wrap_string wrap_int wrap_int 113 | 114 | let sys_blocked_io_exn = Runtime_lib.exn0 initial_env "Sys_blocked_io" 115 | 116 | let sys_error_exn = Runtime_lib.exn1 initial_env "Sys_error" wrap_string 117 | 118 | let end_of_file_exn = Runtime_lib.exn0 initial_env "End_of_file" 119 | 120 | let division_by_zero_exn = Runtime_lib.exn0 initial_env "Division_by_zero" 121 | 122 | let undefined_recursive_module_exn = 123 | Runtime_lib.exn3 124 | initial_env 125 | "Undefined_recursive_module" 126 | wrap_string 127 | wrap_int 128 | wrap_int 129 | 130 | let wrap_exn = function 131 | | Not_found -> Some not_found_exn 132 | | Exit -> Some exit_exn 133 | | Invalid_argument s -> Some (invalid_argument_exn s) 134 | | Failure s -> Some (failure_exn s) 135 | | Match_failure (s, i, j) -> Some (match_failure_exn s i j) 136 | | Assert_failure (s, i, j) -> Some (assert_failure_exn s i j) 137 | | Sys_blocked_io -> Some sys_blocked_io_exn 138 | | Sys_error s -> Some (sys_error_exn s) 139 | | End_of_file -> Some end_of_file_exn 140 | | Division_by_zero -> Some division_by_zero_exn 141 | | Undefined_recursive_module (s, i, j) -> 142 | Some (undefined_recursive_module_exn s i j) 143 | | _ -> None 144 | -------------------------------------------------------------------------------- /interpreter/runtime_base.mli: -------------------------------------------------------------------------------- 1 | open Data 2 | 3 | val type_error : string -> Data.value_ -> 'a 4 | val wrap_int : int -> value 5 | val unwrap_int : value -> int 6 | val wrap_int32 : int32 -> value 7 | val unwrap_int32 : value -> int32 8 | val wrap_int64 : int64 -> value 9 | val unwrap_int64 : value -> int64 10 | val wrap_nativeint : nativeint -> value 11 | val unwrap_nativeint : value -> nativeint 12 | val wrap_float : float -> value 13 | val unwrap_float : value -> float 14 | val unwrap_bool : value -> bool 15 | val wrap_bool : bool -> value 16 | val wrap_unit : unit -> value 17 | val unwrap_unit : value -> unit 18 | val wrap_bytes : bytes -> value 19 | val unwrap_bytes : value -> bytes 20 | val wrap_string : string -> value 21 | val unwrap_string : value -> string 22 | val wrap_string_unsafe : string -> value 23 | val unwrap_string_unsafe : value -> string 24 | val wrap_char : char -> value 25 | val unwrap_char : value -> char 26 | val wrap_array : ('a -> value) -> 'a array -> value 27 | val unwrap_array : (value -> 'a) -> value -> 'a array 28 | val declare_builtin_constructor : 29 | SMap.key -> int -> env -> env 30 | val declare_exn : SMap.key -> env -> env 31 | val initial_env : env 32 | val not_found_exn : value 33 | val exit_exn : value 34 | val invalid_argument_exn : string -> value 35 | val failure_exn : string -> value 36 | val match_failure_exn : string -> int -> int -> value 37 | val assert_failure_exn : string -> int -> int -> value 38 | val sys_blocked_io_exn : value 39 | val sys_error_exn : string -> value 40 | val end_of_file_exn : value 41 | val division_by_zero_exn : value 42 | val undefined_recursive_module_exn : 43 | string -> int -> int -> value 44 | val wrap_exn : exn -> value option 45 | -------------------------------------------------------------------------------- /interpreter/runtime_compiler.mli: -------------------------------------------------------------------------------- 1 | open Data 2 | 3 | val wrap_array_id : value array -> value 4 | val unwrap_array_id : value -> value array 5 | val unwrap_position : value -> Lexing.position 6 | val wrap_position : Lexing.position -> value 7 | val wrap_gc_stat : Gc.stat -> value 8 | type parser_env = { 9 | mutable s_stack : int array; 10 | mutable v_stack : Obj.t array; 11 | mutable symb_start_stack : Lexing.position array; 12 | mutable symb_end_stack : Lexing.position array; 13 | mutable stacksize : int; 14 | mutable stackbase : int; 15 | mutable curr_char : int; 16 | mutable lval : Obj.t; 17 | mutable symb_start : Lexing.position; 18 | mutable symb_end : Lexing.position; 19 | mutable asp : int; 20 | mutable rule_len : int; 21 | mutable rule_number : int; 22 | mutable sp : int; 23 | mutable state : int; 24 | mutable errflag : int; 25 | } 26 | type parse_tables = { 27 | actions : (parser_env -> Obj.t) array; 28 | transl_const : int array; 29 | transl_block : int array; 30 | lhs : string; 31 | len : string; 32 | defred : string; 33 | dgoto : string; 34 | sindex : string; 35 | rindex : string; 36 | gindex : string; 37 | tablesize : int; 38 | table : string; 39 | check : string; 40 | error_function : string -> unit; 41 | names_const : string; 42 | names_block : string; 43 | } 44 | type parser_input = 45 | Start 46 | | Token_read 47 | | Stacks_grown_1 48 | | Stacks_grown_2 49 | | Semantic_action_computed 50 | | Error_detected 51 | val unwrap_parser_input : value -> parser_input 52 | type parser_output = 53 | Read_token 54 | | Raise_parse_error 55 | | Grow_stacks_1 56 | | Grow_stacks_2 57 | | Compute_semantic_action 58 | | Call_error_function 59 | val wrap_parser_output : parser_output -> value 60 | val unwrap_parser_env : value -> parser_env 61 | val sync_parser_env : parser_env -> value -> unit 62 | val apply_ref : 63 | (value -> (Asttypes.arg_label * value) list -> value) 64 | ref 65 | val unwrap_parse_tables : 66 | value -> value -> parse_tables 67 | external parse_engine : 68 | parse_tables -> parser_env -> parser_input -> Obj.t -> parser_output 69 | = "caml_parse_engine" 70 | external lex_engine : Lexing.lex_tables -> int -> Lexing.lexbuf -> int 71 | = "caml_lex_engine" 72 | external new_lex_engine : Lexing.lex_tables -> int -> Lexing.lexbuf -> int 73 | = "caml_new_lex_engine" 74 | val parse_engine_wrapper : 75 | value -> 76 | value -> parser_input -> value -> parser_output 77 | val unwrap_lexbuf : value -> Lexing.lexbuf 78 | val sync_lexbuf : value -> Lexing.lexbuf -> unit 79 | val unwrap_lex_tables : value -> Lexing.lex_tables 80 | val lex_engine_wrapper : 81 | value -> int -> value -> int 82 | val new_lex_engine_wrapper : 83 | value -> int -> value -> int 84 | val parse_engine_prim : value 85 | val lex_engine_prim : value 86 | val new_lex_engine_prim : value 87 | -------------------------------------------------------------------------------- /interpreter/runtime_lib.ml: -------------------------------------------------------------------------------- 1 | open Data 2 | 3 | let cc x d = ptr @@ Constructor (x, d, None) 4 | 5 | (* 6 | let builtin_exn_handler wrap_exn f = 7 | try f () 8 | with exn -> 9 | let bt = Printexc.get_raw_backtrace () in 10 | let exn = 11 | match wrap_exn exn with 12 | | None -> exn 13 | | Some exn_code -> InternalException exn_code 14 | in 15 | Printexc.raise_with_backtrace exn bt 16 | *) 17 | 18 | external reraise : exn -> 'a = "%reraise" 19 | 20 | let builtin_exn_handler wrap_exn f = 21 | try f () 22 | with exn -> 23 | let exn = 24 | match wrap_exn exn with 25 | | None -> exn 26 | | Some exn_code -> InternalException exn_code 27 | in 28 | reraise exn 29 | 30 | let prim1 f wrap_exn unwrap1 wrap = 31 | ptr @@ Prim 32 | (fun x -> wrap (builtin_exn_handler wrap_exn (fun () -> f (unwrap1 x)))) 33 | 34 | let prim2 f wrap_exn unwrap1 unwrap2 wrap = 35 | ptr @@ Prim 36 | (fun x -> prim1 (f (unwrap1 x)) wrap_exn unwrap2 wrap) 37 | 38 | let prim3 f wrap_exn unwrap1 unwrap2 unwrap3 wrap = 39 | ptr @@ Prim 40 | (fun x -> prim2 (f (unwrap1 x)) wrap_exn unwrap2 unwrap3 wrap) 41 | 42 | let prim4 f wrap_exn unwrap1 unwrap2 unwrap3 unwrap4 wrap = 43 | ptr @@ Prim 44 | (fun x -> prim3 (f (unwrap1 x)) wrap_exn unwrap2 unwrap3 unwrap4 wrap) 45 | 46 | let prim5 f wrap_exn unwrap1 unwrap2 unwrap3 unwrap4 unwrap5 wrap = 47 | ptr @@ Prim 48 | (fun x -> 49 | prim4 (f (unwrap1 x)) wrap_exn unwrap2 unwrap3 unwrap4 unwrap5 wrap) 50 | 51 | let id x = x 52 | 53 | let builtin_exn_id env id = 54 | Envir.env_get_constr env (Location.mknoloc (Longident.Lident id)) 55 | 56 | let exn0 env name = ptr @@ Constructor (name, builtin_exn_id env name, None) 57 | 58 | let exn1 env name wrap1 = 59 | let exn_id = builtin_exn_id env name in 60 | fun arg1 -> 61 | let v1 = wrap1 arg1 in 62 | ptr @@ Constructor (name, exn_id, Some (ptr @@ Tuple [ v1 ])) 63 | 64 | let exn2 env name wrap1 wrap2 = 65 | let exn_id = builtin_exn_id env name in 66 | fun arg1 arg2 -> 67 | let v1 = wrap1 arg1 in 68 | let v2 = wrap2 arg2 in 69 | ptr @@ Constructor (name, exn_id, Some (ptr @@ Tuple [ v1; v2 ])) 70 | 71 | let exn3 env name wrap1 wrap2 wrap3 = 72 | let exn_id = builtin_exn_id env name in 73 | fun arg1 arg2 arg3 -> 74 | let v1 = wrap1 arg1 in 75 | let v2 = wrap2 arg2 in 76 | let v3 = wrap3 arg3 in 77 | ptr @@ Constructor (name, exn_id, Some (ptr @@ Tuple [ v1; v2; v3 ])) 78 | -------------------------------------------------------------------------------- /interpreter/runtime_lib.mli: -------------------------------------------------------------------------------- 1 | open Data 2 | 3 | val cc : string -> int -> value 4 | external reraise : exn -> 'a = "%reraise" 5 | val builtin_exn_handler : (exn -> value option) -> (unit -> 'a) -> 'a 6 | val prim1 : 7 | ('a -> 'b) -> 8 | (exn -> value option) -> 9 | (value -> 'a) -> ('b -> value) -> value 10 | val prim2 : 11 | ('a -> 'b -> 'c) -> 12 | (exn -> value option) -> 13 | (value -> 'a) -> 14 | (value -> 'b) -> ('c -> value) -> value 15 | val prim3 : 16 | ('a -> 'b -> 'c -> 'd) -> 17 | (exn -> value option) -> 18 | (value -> 'a) -> 19 | (value -> 'b) -> 20 | (value -> 'c) -> ('d -> value) -> value 21 | val prim4 : 22 | ('a -> 'b -> 'c -> 'd -> 'e) -> 23 | (exn -> value option) -> 24 | (value -> 'a) -> 25 | (value -> 'b) -> 26 | (value -> 'c) -> 27 | (value -> 'd) -> ('e -> value) -> value 28 | val prim5 : 29 | ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 30 | (exn -> value option) -> 31 | (value -> 'a) -> 32 | (value -> 'b) -> 33 | (value -> 'c) -> 34 | (value -> 'd) -> 35 | (value -> 'e) -> ('f -> value) -> value 36 | val id : 'a -> 'a 37 | val builtin_exn_id : env -> string -> int 38 | val exn0 : env -> string -> value 39 | val exn1 : 40 | env -> string -> ('a -> value) -> 'a -> value 41 | val exn2 : 42 | env -> 43 | string -> 44 | ('a -> value) -> 45 | ('b -> value) -> 'a -> 'b -> value 46 | val exn3 : 47 | env -> 48 | string -> 49 | ('a -> value) -> 50 | ('b -> value) -> 51 | ('c -> value) -> 'a -> 'b -> 'c -> value 52 | -------------------------------------------------------------------------------- /interpreter/runtime_stdlib.ml: -------------------------------------------------------------------------------- 1 | open Data 2 | open Runtime_lib 3 | 4 | let wrap_in_channel ic = ptr @@ InChannel ic 5 | 6 | let unwrap_in_channel = onptr @@ function 7 | | InChannel ic -> ic 8 | | _ -> assert false 9 | 10 | let wrap_out_channel oc = ptr @@ OutChannel oc 11 | 12 | let unwrap_out_channel = onptr @@ function 13 | | OutChannel oc -> oc 14 | | _ -> assert false 15 | 16 | let wrap_open_flag = function 17 | | Open_rdonly -> cc "Open_rdonly" 0 18 | | Open_wronly -> cc "Open_wronly" 1 19 | | Open_append -> cc "Open_append" 2 20 | | Open_creat -> cc "Open_creat" 3 21 | | Open_trunc -> cc "Open_trunc" 4 22 | | Open_excl -> cc "Open_excl" 5 23 | | Open_binary -> cc "Open_binary" 6 24 | | Open_text -> cc "Open_text" 7 25 | | Open_nonblock -> cc "Open_nonblock" 8 26 | 27 | let unwrap_open_flag = onptr @@ function 28 | | Constructor ("Open_rdonly", _, None) -> Open_rdonly 29 | | Constructor ("Open_wronly", _, None) -> Open_wronly 30 | | Constructor ("Open_append", _, None) -> Open_append 31 | | Constructor ("Open_creat", _, None) -> Open_creat 32 | | Constructor ("Open_trunc", _, None) -> Open_trunc 33 | | Constructor ("Open_excl", _, None) -> Open_excl 34 | | Constructor ("Open_binary", _, None) -> Open_binary 35 | | Constructor ("Open_text", _, None) -> Open_text 36 | | Constructor ("Open_nonblock", _, None) -> Open_nonblock 37 | | _ -> assert false 38 | 39 | let rec wrap_list wrapf = function 40 | | [] -> cc "[]" 0 41 | | x :: l -> 42 | ptr @@ Constructor ("::", 0, 43 | Some (ptr @@ Tuple [ wrapf x; wrap_list wrapf l ])) 44 | 45 | let rec unwrap_list unwrapf = onptr @@ function 46 | | Constructor ("[]", _, None) -> [] 47 | | Constructor ("::", _, Some arg) -> 48 | begin match Ptr.get arg with 49 | | Tuple [ x; l ] -> 50 | unwrapf x :: unwrap_list unwrapf l 51 | | _ -> assert false 52 | end 53 | | _ -> assert false 54 | 55 | let unwrap_marshal_flag = onptr @@ function 56 | | Constructor ("No_sharing", _, None) -> Marshal.No_sharing 57 | | Constructor ("Closures", _, None) -> Marshal.Closures 58 | | Constructor ("Compat_32", _, None) -> Marshal.Compat_32 59 | | _ -> assert false 60 | 61 | external open_descriptor_out 62 | : int -> 63 | out_channel 64 | = "caml_ml_open_descriptor_out" 65 | 66 | external open_descriptor_in : int -> in_channel = "caml_ml_open_descriptor_in" 67 | external open_desc : string -> open_flag list -> int -> int = "caml_sys_open" 68 | external close_desc: int -> unit = "caml_sys_close" 69 | 70 | external set_out_channel_name 71 | : out_channel -> 72 | string -> 73 | unit 74 | = "caml_ml_set_channel_name" 75 | 76 | external out_channels_list 77 | : unit -> 78 | out_channel list 79 | = "caml_ml_out_channels_list" 80 | 81 | external unsafe_output 82 | : out_channel -> 83 | bytes -> 84 | int -> 85 | int -> 86 | unit 87 | = "caml_ml_output_bytes" 88 | 89 | external unsafe_output_string 90 | : out_channel -> 91 | string -> 92 | int -> 93 | int -> 94 | unit 95 | = "caml_ml_output" 96 | 97 | external set_in_channel_name 98 | : in_channel -> 99 | string -> 100 | unit 101 | = "caml_ml_set_channel_name" 102 | 103 | external unsafe_input 104 | : in_channel -> 105 | bytes -> 106 | int -> 107 | int -> 108 | int 109 | = "caml_ml_input" 110 | 111 | external format_int : string -> int -> string = "caml_format_int" 112 | external format_float : string -> float -> string = "caml_format_float" 113 | external random_seed : unit -> int array = "caml_sys_random_seed" 114 | 115 | let rec seeded_hash_param meaningful total seed = onptr @@ function 116 | | Int n -> Hashtbl.seeded_hash_param meaningful total seed n 117 | | Int32 n -> Hashtbl.seeded_hash_param meaningful total seed n 118 | | Int64 n -> Hashtbl.seeded_hash_param meaningful total seed n 119 | | Nativeint n -> Hashtbl.seeded_hash_param meaningful total seed n 120 | | Float f -> Hashtbl.seeded_hash_param meaningful total seed f 121 | | Tuple _l -> 0 122 | | String s -> 123 | Hashtbl.seeded_hash_param meaningful total seed (Bytes.to_string s) 124 | | Constructor (c, _, _v) -> Hashtbl.seeded_hash_param meaningful total seed c 125 | | Object _ -> 0 126 | | Array _a -> 0 127 | | Record _r -> 0 128 | | Fexpr _ | Fun _ | Function _ 129 | | InChannel _ | OutChannel _ | Prim _ | Lz _ 130 | | ModVal _ | Fun_with_extra_args _ -> 131 | assert false 132 | 133 | external digest_unsafe_string 134 | : string -> 135 | int -> 136 | int -> 137 | string 138 | = "caml_md5_string" 139 | 140 | external marshal_to_channel 141 | : out_channel -> 142 | 'a -> 143 | unit list -> 144 | unit 145 | = "caml_output_value" 146 | 147 | external caml_output_value_to_string : 'a -> Marshal.extern_flags list -> string 148 | = "caml_output_value_to_string" 149 | 150 | external append_prim : 'a array -> 'a array -> 'a array = "caml_array_append" 151 | external input_scan_line : in_channel -> int = "caml_ml_input_scan_line" 152 | 153 | external caml_int32_format : string -> int32 -> string = "caml_int32_format" 154 | external caml_int64_format : string -> int64 -> string = "caml_int64_format" 155 | external caml_nativeint_format : string -> nativeint -> string = "caml_nativeint_format" 156 | 157 | external caml_sys_system_command: string -> int = "caml_sys_system_command" 158 | -------------------------------------------------------------------------------- /interpreter/runtime_stdlib.mli: -------------------------------------------------------------------------------- 1 | open Data 2 | 3 | val wrap_in_channel : in_channel -> value 4 | val unwrap_in_channel : value -> in_channel 5 | val wrap_out_channel : out_channel -> value 6 | val unwrap_out_channel : value -> out_channel 7 | val wrap_open_flag : open_flag -> value 8 | val unwrap_open_flag : value -> open_flag 9 | val wrap_list : ('a -> value) -> 'a list -> value 10 | val unwrap_list : (value -> 'a) -> value -> 'a list 11 | val unwrap_marshal_flag : value -> Marshal.extern_flags 12 | 13 | external open_descriptor_out : int -> out_channel 14 | = "caml_ml_open_descriptor_out" 15 | external open_descriptor_in : int -> in_channel 16 | = "caml_ml_open_descriptor_in" 17 | external open_desc : string -> open_flag list -> int -> int 18 | = "caml_sys_open" 19 | external close_desc : int -> unit = "caml_sys_close" 20 | external set_out_channel_name : out_channel -> string -> unit 21 | = "caml_ml_set_channel_name" 22 | external out_channels_list : unit -> out_channel list 23 | = "caml_ml_out_channels_list" 24 | external unsafe_output : out_channel -> bytes -> int -> int -> unit 25 | = "caml_ml_output_bytes" 26 | external unsafe_output_string : 27 | out_channel -> string -> int -> int -> unit = "caml_ml_output" 28 | external set_in_channel_name : in_channel -> string -> unit 29 | = "caml_ml_set_channel_name" 30 | external unsafe_input : in_channel -> bytes -> int -> int -> int 31 | = "caml_ml_input" 32 | external format_int : string -> int -> string = "caml_format_int" 33 | external format_float : string -> float -> string = "caml_format_float" 34 | external random_seed : unit -> int array = "caml_sys_random_seed" 35 | val seeded_hash_param : int -> int -> int -> value -> int 36 | external digest_unsafe_string : string -> int -> int -> string 37 | = "caml_md5_string" 38 | external marshal_to_channel : 39 | out_channel -> 'a -> unit list -> unit = "caml_output_value" 40 | external caml_output_value_to_string : 41 | 'a -> Marshal.extern_flags list -> string 42 | = "caml_output_value_to_string" 43 | external append_prim : 'a array -> 'a array -> 'a array = "caml_array_append" 44 | external input_scan_line : in_channel -> int 45 | = "caml_ml_input_scan_line" 46 | external caml_int32_format : string -> int32 -> string = "caml_int32_format" 47 | external caml_int64_format : string -> int64 -> string = "caml_int64_format" 48 | external caml_nativeint_format : string -> nativeint -> string 49 | = "caml_nativeint_format" 50 | external caml_sys_system_command : string -> int = "caml_sys_system_command" 51 | -------------------------------------------------------------------------------- /interpreter/tests/README: -------------------------------------------------------------------------------- 1 | Test cases are written by creating a new directory, containing a list 2 | of files to be interpreted, and a file called `files` that lists those 3 | file, in the order in which they should be interpreted/linked. 4 | 5 | runtests.sh runs the tests -- if passed a directory name as argument, 6 | it runs only that test, otherwise it tests everything. 7 | 8 | checktests.sh checks that the tests are correct by running them using 9 | the official OCaml implementation rather than the interpreted. If your 10 | test fails this check, the test is quite probably wrong. 11 | 12 | There is no explicit support for reporting success/failure of a test; 13 | you should write your tests so that success is doing nothing, and 14 | failure fails visibly -- for example, using `assert` to check for the 15 | expected result or fail loudly. 16 | -------------------------------------------------------------------------------- /interpreter/tests/checktests.sh: -------------------------------------------------------------------------------- 1 | function test() { 2 | echo "Checking $1" 3 | cd $1 4 | ocamlc $(cat files) -o check.byte 5 | ./check.byte 6 | rm *.cm* check.byte 7 | echo "done with $1." 8 | } 9 | 10 | if [ ! -z $1 ] 11 | then 12 | test $1 13 | else 14 | for f in */ 15 | do 16 | test $f 17 | done 18 | fi 19 | -------------------------------------------------------------------------------- /interpreter/tests/functor-units-dependency/files: -------------------------------------------------------------------------------- 1 | functor.ml 2 | x.ml 3 | main.ml 4 | 5 | -------------------------------------------------------------------------------- /interpreter/tests/functor-units-dependency/functor.ml: -------------------------------------------------------------------------------- 1 | module F(X : sig val x : int end) = struct 2 | let x = X.x 3 | end 4 | -------------------------------------------------------------------------------- /interpreter/tests/functor-units-dependency/main.ml: -------------------------------------------------------------------------------- 1 | module M = Functor.F(X) 2 | 3 | let () = assert (M.x = 1) 4 | -------------------------------------------------------------------------------- /interpreter/tests/functor-units-dependency/x.ml: -------------------------------------------------------------------------------- 1 | let x = 1 2 | -------------------------------------------------------------------------------- /interpreter/tests/runtests.sh: -------------------------------------------------------------------------------- 1 | function test() { 2 | echo "Testing $1" 3 | cd $1 4 | OCAMLINTERP_DEBUG=0 OCAMLRUNPARAM=b \ 5 | OCAMLINTERP_SRC_PATH=../../../ocaml-src \ 6 | OCAMLINTERP_STDLIB_PATH=$OCAMLINTERP_SRC_PATH/stdlib \ 7 | OCAMLINTERP_COMMAND=files ../../interpopt $(cat files) 8 | echo "done with $1." 9 | } 10 | 11 | if [ ! -z $1 ] 12 | then 13 | test $1 14 | else 15 | for f in */ 16 | do 17 | test $f 18 | done 19 | fi 20 | -------------------------------------------------------------------------------- /miniml/compiler/README.md: -------------------------------------------------------------------------------- 1 | # miniml compiler 2 | 3 | The file `compile.scm` is a single-file compiler for the miniml language, written in Scheme. It targets the OCaml bytecode for the version 4.07.0 of the OCaml compiler. 4 | 5 | It is used as such: 6 | ```bash 7 | $ guile compile.scm file.ml -o file.byte 8 | ``` 9 | The file `file.byte` will then contain executable OCaml bytecode, which can be run using `ocamlrun` from version 4.07.0 of the OCaml compiler (in this repository's `ocaml-src/` submodule). 10 | 11 | It can only process a single file of input; in case you wish to use multiple files, you must first bundle them all into a single `.ml` file, putting the contents of file `x.ml` between `module X = struct`/`end` delimiters. 12 | 13 | All OCaml external functions can be used with `external` declarations, but primitives work differently: they call a single bytecode instruction, with the instruction number specified in the external declaration; see `hello.ml` for examples. 14 | 15 | `miniml` is completely untyped, and error reporting during compilation is very limited. However, since syntax and semantics are almost completely compatible with OCaml, in most cases you can just use OCaml to find the syntax or type error. 16 | 17 | -------------------------------------------------------------------------------- /miniml/compiler/test/.gitignore: -------------------------------------------------------------------------------- 1 | *.byte 2 | *.output 3 | *.info 4 | -------------------------------------------------------------------------------- /miniml/compiler/test/Makefile: -------------------------------------------------------------------------------- 1 | define ERRMSG 2 | Fatal error: 3 | This Makefile depends on an OCAMLRUN variable pointing to an 4 | ocamlrun binary compatible with the bytecode produced by the 5 | compiler. 6 | 7 | Running 'make ocamlrun' at the root of this repository will 8 | populate ../../_boot/byterun with a compatible 'ocamlrun', 9 | which is used by default. 10 | 11 | A standard way to invoke this testsuite is by using the 12 | 'test-compiler' target of the root makefile. 13 | endef 14 | 15 | OCAMLRUN?=../../../_boot/byterun/ocamlrun 16 | ifeq "$(wildcard $(OCAMLRUN))" "" 17 | $(error $(ERRMSG)) 18 | endif 19 | 20 | COMPILE_CMD=GUILE_WARN_DEPRECATED=detailed guile ../compile.scm 21 | COMPILE_DEPS=../compile.scm 22 | 23 | TESTS=\ 24 | empty \ 25 | arith \ 26 | functions \ 27 | patterns \ 28 | lists \ 29 | labels \ 30 | records \ 31 | exceptions \ 32 | let_open \ 33 | infix_sugar \ 34 | functors \ 35 | exits \ 36 | external_exceptions \ 37 | loops 38 | 39 | .PHONY: all 40 | all: $(addprefix test-,$(TESTS)) 41 | 42 | .PHONY: promote 43 | promote: $(addprefix promote-,$(TESTS)) 44 | 45 | .PHONY: clean 46 | clean: 47 | rm -f *.byte *.output *.info 48 | 49 | test-%: %.byte %.output %.info 50 | diff -u --report-identical-files $*.output.reference $*.output 51 | diff -u --report-identical-files $*.info.reference $*.info 52 | 53 | promote-%: %.byte %.output %.info 54 | cp $*.output $*.output.reference 55 | cp $*.info $*.info.reference 56 | 57 | .PHONY: always-rerun 58 | always-rerun: 59 | 60 | %.byte: always-rerun %.ml $(COMPILE_DEPS) lib.ml 61 | $(COMPILE_CMD) lib.ml --open Lib $*.ml -o $*.byte 62 | 63 | %.output: always-rerun %.byte 64 | $(OCAMLRUN) $*.byte > $*.output 65 | 66 | %.info: always-rerun %.byte 67 | rm -f $*.info 68 | stat --printf="Bytecode size: %7s bytes\n" $*.byte >> $*.info 69 | -------------------------------------------------------------------------------- /miniml/compiler/test/arith.info.reference: -------------------------------------------------------------------------------- 1 | Bytecode size: 7600 bytes 2 | -------------------------------------------------------------------------------- /miniml/compiler/test/arith.ml: -------------------------------------------------------------------------------- 1 | let () = print_endline "Arithmetic:" 2 | 3 | let () = show_int (6 * 7) 4 | let () = show_int (17 + 12) 5 | let () = show_int (7 - 5) 6 | let () = show_int (19 / 3) 7 | let () = show_int (-2 + 3) 8 | let () = show_int (19 mod 3) 9 | let () = show_int (3 land 5) 10 | let () = show_int (3 lor 5) 11 | let () = show_int (3 lxor 5) 12 | let () = show_int (7 lsl 1) 13 | let () = show_int (7 lsr 1) 14 | let () = show_int (7 asr 1) 15 | let () = show_int (-1 lsr 1) 16 | let () = show_int (1 lsl 62 - 1) (* Should be previous number *) 17 | let () = show_int (-1 asr 1) 18 | 19 | let () = print_newline () 20 | 21 | let () = show_int (4 - 2 - 1) 22 | let () = show_int (0 * 3 + 2) 23 | let () = show_int (1 + 1 * 2) 24 | 25 | let () = print_newline () 26 | 27 | let ( % ) a b = a mod b 28 | 29 | let () = show_int (3 % 2) 30 | let () = show_int (1 + 3 % 2) 31 | let () = show_int (7 % 4 % 4) 32 | 33 | let () = print_newline () 34 | 35 | let () = show_int 0xff 36 | let () = show_int 0xFF 37 | let () = show_int 255 38 | let () = show_int 0o377 39 | let () = show_int 0b11111111 40 | 41 | let () = show_int 0x2a 42 | let () = show_int 42 43 | let () = show_int 0o52 44 | let () = show_int 0b101010 45 | 46 | let () = print_newline () 47 | 48 | external int64_format : string -> int64 -> string = "caml_int64_format" 49 | external int32_format : string -> int32 -> string = "caml_int32_format" 50 | external nativeint_format : string -> nativeint -> string = "caml_nativeint_format" 51 | 52 | let () = print_endline (int64_format "%d" 9223372036854775807L) 53 | let () = print_endline (int32_format "%d" 2147483647l) 54 | let () = print_endline (nativeint_format "%d" 9223372036854775807n) 55 | -------------------------------------------------------------------------------- /miniml/compiler/test/arith.output.reference: -------------------------------------------------------------------------------- 1 | Arithmetic: 2 | 42 29 2 6 1 1 1 7 6 14 3 3 4611686018427387903 4611686018427387903 -1 3 | 1 2 3 4 | 1 2 3 5 | 255 255 255 255 255 42 42 42 42 6 | 9223372036854775807 7 | 2147483647 8 | 9223372036854775807 9 | -------------------------------------------------------------------------------- /miniml/compiler/test/empty.info.reference: -------------------------------------------------------------------------------- 1 | Bytecode size: 5020 bytes 2 | -------------------------------------------------------------------------------- /miniml/compiler/test/empty.ml: -------------------------------------------------------------------------------- 1 | (* this empty file tests the compilation of lib.ml *) 2 | -------------------------------------------------------------------------------- /miniml/compiler/test/empty.output.reference: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Ekdohibs/camlboot/2692b14a4e685387194556e511fe23057d25c6c3/miniml/compiler/test/empty.output.reference -------------------------------------------------------------------------------- /miniml/compiler/test/exceptions.info.reference: -------------------------------------------------------------------------------- 1 | Bytecode size: 10036 bytes 2 | -------------------------------------------------------------------------------- /miniml/compiler/test/exceptions.ml: -------------------------------------------------------------------------------- 1 | let () = print_endline "Exceptions:" 2 | 3 | exception E1 4 | exception E2 of int 5 | exception E3 6 | exception E4 of int 7 | exception E5 of { x : int } 8 | 9 | let show_exn e = 10 | match e with 11 | | E1 -> print_string "E1" 12 | | E2 i -> print_string "(E2"; show_int i; print_string ")" 13 | | _ -> print_string "" 14 | 15 | let () = 16 | try raise E1 with 17 | | E1 -> print_string " ok" 18 | | _ -> print_string " ko" 19 | 20 | let () = 21 | try raise (E2 7) with 22 | (* note: no leading bar *) 23 | E2 x -> if x = 7 then print_string " ok" else print_string " ko" 24 | | _ -> print_string " ko" 25 | 26 | let () = print_string (try " ok" with _ -> " ko") 27 | 28 | let () = try (try raise E1 with E2 _ -> print_string " ko") with E1 -> print_string " ok" | _ -> print_string " ko" 29 | let () = try (try raise (E2 7) with E1 -> print_string " ko") with E2 x -> if x = 7 then print_string " ok" else print_string " ko" | _ -> print_string " ko" 30 | let () = try (try raise E3 with E1 -> print_string " ko" | E2 _ -> print_string " ko") with _ -> print_string " ok" 31 | let () = try (try raise (E4 7) with E1 -> print_string " ko" | E2 _ -> print_string " ko") with _ -> print_string " ok" 32 | 33 | let () = try (try raise E1 with E1 -> print_string " ok") with _ -> print_string " ko" 34 | let () = try (try raise (E2 7) with E2 x -> if x = 7 then print_string " ok" else print_string " ko") with _ -> print_string " ko" 35 | 36 | let () = print_string " "; show_exn E1 37 | let () = print_string " "; show_exn (E2 7) 38 | let () = print_string " "; show_exn E3 39 | let () = print_string " "; show_exn (E4 7) 40 | let () = try raise (E5 { x = 8 }) with E5 { x } -> show_int x 41 | 42 | let () = print_newline () 43 | -------------------------------------------------------------------------------- /miniml/compiler/test/exceptions.output.reference: -------------------------------------------------------------------------------- 1 | Exceptions: 2 | ok ok ok ok ok ok ok ok ok E1 (E2 7) 8 3 | -------------------------------------------------------------------------------- /miniml/compiler/test/exits.info.reference: -------------------------------------------------------------------------------- 1 | Bytecode size: 7896 bytes 2 | -------------------------------------------------------------------------------- /miniml/compiler/test/exits.ml: -------------------------------------------------------------------------------- 1 | let () = print_endline "Local exits" 2 | 3 | let () = print_string "simple: " 4 | 5 | (* exit not taken *) 6 | let () = show_int (let%exit ex = 42 in 0) 7 | 8 | (* constant exit *) 9 | let () = show_int (let%exit ex = 1 in [%exit] ex) 10 | 11 | (* one-parameter exit *) 12 | let () = show_int (let%exit ex n = 2 * n in [%exit] ex 1) 13 | 14 | (* two-parameters exit *) 15 | let () = 16 | let%exit ex m n = show_int (m * m + n) in 17 | [%exit] ex 1 (1 + 1) 18 | 19 | let () = print_newline () 20 | let () = print_string "multi-exits: " 21 | 22 | (* two exits *) 23 | let () = 24 | show_int ( 25 | let%exit ex1 = 0 26 | and ex2 = 7 27 | in 28 | ([%exit] ex1) + 8 29 | (* note: exits interrupt the computation, so the + 8 is discarded *) 30 | ) 31 | 32 | (* two exits of different arity, max arity taken *) 33 | let () = 34 | show_int ( 35 | let%exit ex1 n = n - 3 36 | and ex2 = 3 37 | in 38 | ([%exit] ex1 4) + 8 39 | ) 40 | 41 | (* two exits of different arity, below-max arity taken *) 42 | let () = 43 | show_int ( 44 | let%exit ex1 n = n + 4 45 | and ex2 = 2 46 | in 47 | ([%exit] ex2) + 8 48 | ) 49 | 50 | let () = print_newline () 51 | let () = print_string "exceptions: " 52 | 53 | exception Foo of int 54 | 55 | (* exiting within an exception handler *) 56 | let () = 57 | try 58 | let%exit ex n = raise (Foo n) in 59 | [%exit] ex 0 60 | with Foo n -> show_int n 61 | 62 | (* exiting across an exception handler *) 63 | let () = 64 | show_int ( 65 | let%exit ex n = n + 2 in 66 | try 67 | [%exit] ex (-1) 68 | with Foo n -> show_int n 69 | ) 70 | 71 | (* exiting across two exception handlers *) 72 | let () = 73 | try 74 | let%exit ex n = raise (Foo n) in 75 | try 76 | try 77 | [%exit] ex 2 78 | with Invalid_argument _ -> () 79 | with Foo n -> show_int (2 * n) 80 | with Foo n -> show_int n 81 | 82 | (* exiting from an exception handler which is not at the top of the stack; 83 | we need another exception handler below, which is used, to observe 84 | scenarios where POPTRAP would be used at the wrong place and corrupt 85 | caml_trapsp. *) 86 | let () = 87 | try 88 | let%exit ex n = raise (Foo (n + 2)) in 89 | try 90 | let v = 1+0 in 91 | [%exit] ex v 92 | with Foo n -> show_int (2 * n) 93 | with Foo n -> show_int n 94 | 95 | let () = print_newline () 96 | -------------------------------------------------------------------------------- /miniml/compiler/test/exits.output.reference: -------------------------------------------------------------------------------- 1 | Local exits 2 | simple: 0 1 2 3 3 | multi-exits: 0 1 2 4 | exceptions: 0 1 2 3 5 | -------------------------------------------------------------------------------- /miniml/compiler/test/external_exceptions.info.reference: -------------------------------------------------------------------------------- 1 | Bytecode size: 10598 bytes 2 | -------------------------------------------------------------------------------- /miniml/compiler/test/external_exceptions.ml: -------------------------------------------------------------------------------- 1 | let () = print_endline "Externally raised exceptions:" 2 | 3 | external obj_tag : Obj.t -> int = "caml_obj_tag" 4 | external obj_size : Obj.t -> int = "%79" 5 | external obj_field : Obj.t -> int -> Obj.t = "%80" 6 | 7 | let rec print_obj x = 8 | let t = obj_tag x in 9 | if t = 1000 then print_string (format_int "%d" x) 10 | else if t = 1001 then print_string "" 11 | else if t = 1002 then print_string "" 12 | else if t = 252 then (print_string "\""; print_string x; print_string "\"") 13 | else (print_string (format_int "%d" t); print_string "["; print_obj_fields x 0; print_string "]") 14 | 15 | and print_obj_fields x i = 16 | if i = obj_size x then () 17 | else if i = obj_size x - 1 then print_obj (obj_field x i) 18 | else (print_obj (obj_field x i); print_string " "; print_obj_fields x (i + 1)) 19 | 20 | let print_exn e = 21 | match e with 22 | | Out_of_memory -> print_string "Out_of_memory" 23 | | Sys_error s -> print_string "Sys_error \""; print_string s; print_string "\"" 24 | | Failure s -> print_string "Failure \""; print_string s; print_string "\"" 25 | | Invalid_argument s -> print_string "Invalid_argument \""; print_string s; print_string "\"" 26 | | End_of_file -> print_string "End_of_file" 27 | | Division_by_zero -> print_string "Division_by_zero" 28 | | Not_found -> print_string "Not_found" 29 | | Match_failure _ -> print_string "Match_failure _" 30 | | Stack_overflow -> print_string "Stack overflow" 31 | | Sys_blocked_io -> print_string "Sys_blocked_io" 32 | | Assert_failure _ -> print_string "Assert_failure _" 33 | | Undefined_recursive_module _ -> print_string "Undefined_recursive_module _" 34 | | _ -> print_string "" 35 | 36 | let run_and_print_exn f = 37 | try f (); print_string "no exception\n" with e -> (print_obj e; print_string " "; print_exn e; print_string "\n") 38 | 39 | external int_of_string : string -> int = "caml_int_of_string" 40 | external sys_getenv : string -> string = "caml_sys_getenv" 41 | 42 | let () = run_and_print_exn (fun () -> (fun x -> ()) = (fun x -> ())) 43 | let () = run_and_print_exn (fun () -> int_of_string "fqsq") 44 | let () = run_and_print_exn (fun () -> sys_getenv "fqsq") 45 | let rec stack_overflow () = 1 + stack_overflow () 46 | let () = run_and_print_exn stack_overflow 47 | let () = run_and_print_exn (fun () -> 1 / 0) 48 | 49 | let () = print_newline () 50 | -------------------------------------------------------------------------------- /miniml/compiler/test/external_exceptions.output.reference: -------------------------------------------------------------------------------- 1 | Externally raised exceptions: 2 | 0[4 "compare: functional value"] Invalid_argument "compare: functional value" 3 | 0[3 "int_of_string"] Failure "int_of_string" 4 | 7 Not_found 5 | 9 Stack overflow 6 | 6 Division_by_zero 7 | 8 | -------------------------------------------------------------------------------- /miniml/compiler/test/functions.info.reference: -------------------------------------------------------------------------------- 1 | Bytecode size: 9292 bytes 2 | -------------------------------------------------------------------------------- /miniml/compiler/test/functions.ml: -------------------------------------------------------------------------------- 1 | let _ = print_endline "Functions:" 2 | 3 | let () = print_string "simple: " 4 | (* let g x = let z = x * 2 in fun y -> z * 3 *) 5 | 6 | let g x y = x - y 7 | 8 | let h = g 6 9 | 10 | let () = show_int (6 - 3) 11 | let () = show_int (g 6 3) 12 | let () = show_int (h 3) 13 | 14 | let () = print_newline () 15 | let () = print_string "currified: " 16 | 17 | let f1 = fun x -> fun y -> x * y 18 | let f2 = f1 6 19 | 20 | let () = show_int (f2 7) 21 | 22 | let () = print_newline () 23 | let () = print_string "higher-order: " 24 | 25 | let double f x = f (f x) 26 | let add2n n x = double (( + ) n) x 27 | 28 | let () = show_int (add2n 20 2) 29 | let () = show_int (double double double double (( + ) 1) 0) 30 | let () = show_int (if false then 17 else 42) 31 | let () = show_int (if true then 17 else 42) 32 | 33 | let f x = let x = x + x in x + x + x 34 | let () = show_int (f 7) 35 | 36 | let () = print_newline () 37 | let () = print_string "local: " 38 | 39 | let () = 40 | let twice x = x + x in show_int (twice 21) 41 | 42 | let () = print_newline () 43 | let () = print_string "recursive: " 44 | 45 | let () = 46 | let n = 10 in 47 | let rec sum i = if i = n then 0 else i + sum (i + 1) in 48 | show_int (sum 0) 49 | 50 | let () = 51 | let n = 10 in 52 | let rec sum1 i = if i = n then 0 else i + sum2 (i + 1) 53 | and sum2 i = if i = n then 0 else sum1 (i + 1) in 54 | show_int (sum1 0); show_int (sum2 0) 55 | 56 | (* regression test for nested let-rec *) 57 | let () = 58 | let f () = 59 | let rec g i = i in 60 | g 0 61 | in 62 | show_int (f ()) 63 | 64 | let () = print_newline () 65 | let () = print_string "let-binding tests: " 66 | 67 | let () = show_int (let a = 17 in let b = 42 in if (let x = 2 in true) then a else b) 68 | let () = show_int (let a = 17 in let b = 42 in if (let x = 2 in false) then a else b) 69 | 70 | (* this ensures that the 'let' are not substituted away... as long as we don't support constant-folding *) 71 | let () = show_int (let a = 16+1 in let b = 41+1 in if (let x = 1+1 in true) then a else b) 72 | let () = show_int (let a = 16+1 in let b = 41+1 in if (let x = 1+1 in false) then a else b) 73 | 74 | (* regression test for an infinite loop in 'Subst unfolding *) 75 | let () = show_int (let x = 21 in let y = x in let x = y in x + y) 76 | 77 | let () = print_newline () 78 | let () = print_string "more recursion: " 79 | 80 | let rec go n = 81 | if n = 0 then () else (show_int n; go (n - 1)) 82 | 83 | let () = go 10 84 | 85 | let () = print_newline () 86 | let () = print_string "general function application: " 87 | 88 | let () = 89 | let f = ref ( + ) in 90 | show_int (!f 12 30) 91 | 92 | let () = print_newline () 93 | -------------------------------------------------------------------------------- /miniml/compiler/test/functions.output.reference: -------------------------------------------------------------------------------- 1 | Functions: 2 | simple: 3 3 3 3 | currified: 42 4 | higher-order: 42 65536 42 17 42 5 | local: 42 6 | recursive: 45 20 25 0 7 | let-binding tests: 17 42 17 42 42 8 | more recursion: 10 9 8 7 6 5 4 3 2 1 9 | general function application: 42 10 | -------------------------------------------------------------------------------- /miniml/compiler/test/functors.info.reference: -------------------------------------------------------------------------------- 1 | Bytecode size: 6159 bytes 2 | -------------------------------------------------------------------------------- /miniml/compiler/test/functors.ml: -------------------------------------------------------------------------------- 1 | let () = print_endline "Functors:" 2 | 3 | module F(X : sig val x : int end) = struct 4 | let x = 2 * X.x 5 | end 6 | 7 | module A = F(struct let x = 21 end) 8 | module B = F(struct let x = 12 end) 9 | module X = struct let () = print_string " only once" let x = 16 end 10 | module C = F(X) 11 | module D = F(X) 12 | 13 | let () = 14 | show_int A.x; show_int B.x; if C.x = D.x then print_string " ok" else print_string " ko" 15 | 16 | let () = print_newline () 17 | 18 | 19 | let () = print_endline "High-order functors:" 20 | 21 | module type X = sig val x : int end 22 | module Twice(F : functor (M : X) -> X)(X : X) = struct 23 | module M = F(F(X)) 24 | let x = M.x 25 | end 26 | 27 | module Four = Twice(F)(struct let x = 1 end) 28 | let () = 29 | show_int Four.x 30 | 31 | let () = print_newline () 32 | -------------------------------------------------------------------------------- /miniml/compiler/test/functors.output.reference: -------------------------------------------------------------------------------- 1 | Functors: 2 | only once 42 24 ok 3 | High-order functors: 4 | 4 5 | -------------------------------------------------------------------------------- /miniml/compiler/test/infix_sugar.info.reference: -------------------------------------------------------------------------------- 1 | Bytecode size: 5589 bytes 2 | -------------------------------------------------------------------------------- /miniml/compiler/test/infix_sugar.ml: -------------------------------------------------------------------------------- 1 | let () = print_endline "Infix operators treated as sugar:" 2 | 3 | let succ n = n + 1 4 | let ignore_and_show_int () n = show_int n 5 | let () = ignore_and_show_int () @@ succ @@ 1 6 | let () = 2 |> succ |> ignore_and_show_int () 7 | 8 | let () = print_newline () 9 | -------------------------------------------------------------------------------- /miniml/compiler/test/infix_sugar.output.reference: -------------------------------------------------------------------------------- 1 | Infix operators treated as sugar: 2 | 2 3 3 | -------------------------------------------------------------------------------- /miniml/compiler/test/labels.info.reference: -------------------------------------------------------------------------------- 1 | Bytecode size: 6680 bytes 2 | -------------------------------------------------------------------------------- /miniml/compiler/test/labels.ml: -------------------------------------------------------------------------------- 1 | let () = print_endline "Arguments:" 2 | 3 | let f1 ~x ~y = show_int (x + 2 * y) 4 | let () = f1 0 1 5 | let () = f1 ~x:0 ~y:1 6 | let () = f1 ~y:1 ~x:0 7 | 8 | let f2 ?(x=1) ~y = show_int (x + 2 * y) 9 | let () = f2 100 10 | let () = f2 ~y:101 (* Note: this is different from ocaml *) 11 | let () = f2 ?x:None ~y:102 12 | let () = f2 ?x:(Some 0) ~y:103 13 | let () = f2 ~x:0 ~y:104 14 | 15 | let f3 () ?(x=1) (y1, y2) ~z = show_int x; show_int y1; show_int y2; show_int z 16 | let () = f3 () (2, 3) ~z:4 17 | let () = f3 () ~x:0 (1, 2) ~z:3 18 | 19 | let f4 ~p:(x, y) = show_int x; show_int y 20 | let () = f4 ~p:(4, 5) 21 | 22 | let () = print_newline () 23 | -------------------------------------------------------------------------------- /miniml/compiler/test/labels.output.reference: -------------------------------------------------------------------------------- 1 | Arguments: 2 | 2 2 2 201 203 205 206 208 1 2 3 4 0 1 2 3 4 5 3 | -------------------------------------------------------------------------------- /miniml/compiler/test/let_open.info.reference: -------------------------------------------------------------------------------- 1 | Bytecode size: 6303 bytes 2 | -------------------------------------------------------------------------------- /miniml/compiler/test/let_open.ml: -------------------------------------------------------------------------------- 1 | let () = print_endline "Let open:" 2 | 3 | module M = struct 4 | let x = 42 5 | let f x = x + x 6 | end 7 | 8 | let () = 9 | show_int M.x; 10 | M.(show_int x); 11 | let open M in 12 | show_int (f 21) 13 | 14 | module N = struct 15 | let f ~x ?(y=2) p = p (x * y) 16 | end 17 | 18 | let () = 19 | let open N in 20 | f ~x:21 show_int 21 | 22 | module R = struct 23 | type r = { a : int; b : int } 24 | type o = A of int | B of int 25 | end 26 | 27 | let () = 28 | let mk a b = R.{ a; b } in 29 | let unmk R.{ a; b } = (a, b) in 30 | let r = mk 42 21 in 31 | let u = snd (unmk r) in 32 | let w = match R.A 12 with R.(A x) -> x + 30 | R.B x -> x in 33 | show_int r.R.a; 34 | show_int (u + u); 35 | show_int w 36 | 37 | let () = print_newline () 38 | -------------------------------------------------------------------------------- /miniml/compiler/test/let_open.output.reference: -------------------------------------------------------------------------------- 1 | Let open: 2 | 42 42 42 42 42 42 42 3 | -------------------------------------------------------------------------------- /miniml/compiler/test/lib.ml: -------------------------------------------------------------------------------- 1 | (* type out_channel *) 2 | external caml_ml_open_descriptor_out : int -> out_channel = "caml_ml_open_descriptor_out" 3 | external caml_ml_output : out_channel -> string -> int -> int -> unit = "caml_ml_output" 4 | external caml_ml_flush : out_channel -> unit = "caml_ml_flush" 5 | external caml_ml_bytes_length : string -> int = "caml_ml_bytes_length" 6 | external format_int : string -> int -> string = "caml_format_int" 7 | external ( ~- ) : int -> int = "%negint" 8 | external ( + ) : int -> int -> int = "%addint" 9 | external ( - ) : int -> int -> int = "%subint" 10 | external ( * ) : int -> int -> int = "%mulint" 11 | external ( / ) : int -> int -> int = "%divint" 12 | external ( mod ) : int -> int -> int = "%modint" 13 | external ( land ) : int -> int -> int = "%andint" 14 | external ( lor ) : int -> int -> int = "%orint" 15 | external ( lxor ) : int -> int -> int = "%xorint" 16 | external ( lsl ) : int -> int -> int = "%lslint" 17 | external ( lsr ) : int -> int -> int = "%lsrint" 18 | external ( asr ) : int -> int -> int = "%asrint" 19 | external ( = ) : 'a -> 'a -> bool = "caml_equal" 20 | external ( <> ) : 'a -> 'a -> bool = "caml_notequal" 21 | external ( > ) : 'a -> 'a -> bool = "caml_greaterthan" 22 | external ( >= ) : 'a -> 'a -> bool = "caml_greaterequal" 23 | external ( < ) : 'a -> 'a -> bool = "caml_lessthan" 24 | external ( <= ) : 'a -> 'a -> bool = "caml_lessequal" 25 | external raise : exn -> 'a = "%raise" 26 | 27 | let failwith s = raise (Failure s) 28 | let invalid_arg s = raise (Invalid_argument s) 29 | let assert b = if b then () else raise (Assert_failure ("", 0, 0)) 30 | let fst (a, b) = a 31 | let snd (a, b) = b 32 | 33 | let stdout = caml_ml_open_descriptor_out 1 34 | 35 | let flush () = caml_ml_flush stdout 36 | 37 | let print_string s = caml_ml_output stdout s 0 (caml_ml_bytes_length s) 38 | let print_int n = print_string (format_int "%d" n) 39 | let show_int n = print_string " "; print_int n 40 | 41 | let print_newline () = 42 | print_string "\n"; 43 | flush () 44 | 45 | let print_endline s = 46 | print_string s ; 47 | print_string "\n" ; 48 | flush () 49 | 50 | (* various types used in the tests *) 51 | 52 | (* variants *) 53 | type bool = false | true 54 | type 'a list = [] | (::) of 'a * 'a list 55 | type 'a option = None | Some of 'a 56 | 57 | (* synonyms *) 58 | type 'a t = 'a * int 59 | 60 | (* references *) 61 | type 'a ref = { mutable contents : 'a } 62 | 63 | let ref x = { contents = x } 64 | let ( ! ) x = x.contents 65 | let ( := ) x v = x.contents <- v 66 | 67 | let __atexit () = flush () 68 | -------------------------------------------------------------------------------- /miniml/compiler/test/lists.info.reference: -------------------------------------------------------------------------------- 1 | Bytecode size: 7859 bytes 2 | -------------------------------------------------------------------------------- /miniml/compiler/test/lists.ml: -------------------------------------------------------------------------------- 1 | let () = print_endline "Lists:" 2 | 3 | let rec iter f l = 4 | match l with 5 | | [] -> () 6 | | x :: l -> 7 | f x; iter f l 8 | 9 | let print_list l = 10 | print_string "["; iter show_int l; print_string "]" 11 | 12 | let () = print_list [1; 2; 3; 4; 5; 6; 7; 8; 9] 13 | 14 | let () = print_newline () 15 | 16 | let rec iter_sep f sep l = 17 | match l with 18 | | [] -> () 19 | | [x] -> 20 | f x 21 | (* this function is an excuse to test literral patterns 22 | [p1; p2; ...; pn] *) 23 | | [x0; x1] -> 24 | f x0; sep (); f x1 25 | | x :: l -> 26 | f x; sep (); iter_sep f sep l 27 | 28 | let print_list l = 29 | print_string "["; iter_sep show_int (fun () -> print_string ";") l; print_string "]" 30 | 31 | let () = print_list [1; 2; 3; 4; 5; 6; 7; 8; 9] 32 | 33 | let () = print_newline () 34 | 35 | let rec map f l = 36 | match l with 37 | | [] -> [] 38 | | x :: l -> f x :: map f l 39 | 40 | let () = print_list (map (fun x -> x + 1) [1; 2; 3; 4; 5; 6; 7; 8; 9]) 41 | 42 | let () = print_list (map (fun (x, y) -> x + y) [(1, 1); (2, 2); (3, 3)]) 43 | 44 | let () = print_newline () 45 | -------------------------------------------------------------------------------- /miniml/compiler/test/lists.output.reference: -------------------------------------------------------------------------------- 1 | Lists: 2 | [ 1 2 3 4 5 6 7 8 9] 3 | [ 1; 2; 3; 4; 5; 6; 7; 8; 9] 4 | [ 2; 3; 4; 5; 6; 7; 8; 9; 10][ 2; 4; 6] 5 | -------------------------------------------------------------------------------- /miniml/compiler/test/loops.info.reference: -------------------------------------------------------------------------------- 1 | Bytecode size: 6838 bytes 2 | -------------------------------------------------------------------------------- /miniml/compiler/test/loops.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | print_endline "nonempty while"; 3 | let x = ref 42 in 4 | while !x > 0 do 5 | show_int !x; 6 | x := !x / 2 7 | done; 8 | print_newline () 9 | 10 | let () = 11 | print_endline "empty while"; 12 | while false do 13 | show_int 42 14 | done; 15 | print_newline () 16 | 17 | let () = 18 | print_endline "nonempty for (up)"; 19 | for x = 0 to 10 do 20 | show_int x 21 | done; 22 | print_newline () 23 | 24 | let () = 25 | print_endline "nonempty for (down)"; 26 | for x = 10 downto 0 do 27 | show_int x 28 | done; 29 | print_newline () 30 | 31 | let () = 32 | print_endline "one-iteration for"; 33 | for x = 42 to 42 do 34 | show_int x 35 | done; 36 | for x = 42 downto 42 do 37 | show_int x 38 | done; 39 | print_newline () 40 | 41 | let () = 42 | print_endline "empty for"; 43 | for x = 1 to 0 do 44 | show_int x 45 | done; 46 | for x = 0 downto 1 do 47 | show_int x 48 | done; 49 | print_newline () 50 | -------------------------------------------------------------------------------- /miniml/compiler/test/loops.output.reference: -------------------------------------------------------------------------------- 1 | nonempty while 2 | 42 21 10 5 2 1 3 | empty while 4 | 5 | nonempty for (up) 6 | 0 1 2 3 4 5 6 7 8 9 10 7 | nonempty for (down) 8 | 10 9 8 7 6 5 4 3 2 1 0 9 | one-iteration for 10 | 42 42 11 | empty for 12 | 13 | -------------------------------------------------------------------------------- /miniml/compiler/test/patterns.info.reference: -------------------------------------------------------------------------------- 1 | Bytecode size: 17729 bytes 2 | -------------------------------------------------------------------------------- /miniml/compiler/test/patterns.ml: -------------------------------------------------------------------------------- 1 | let () = print_endline "Pattern-matching:" 2 | 3 | let () = print_string "simple: " 4 | 5 | let () = 6 | show_int (match [] with [] -> 2 | x :: l -> 3) 7 | 8 | let () = 9 | show_int (match 1 :: [] with 10 | | [] -> 2 (* note: leading bar *) 11 | | _ :: _ -> 3 12 | ) 13 | 14 | let test_function = function 15 | | [] -> 2 16 | | x :: _ -> x + 1 (* note: one of the pattern arguments is a wildcard *) 17 | 18 | let () = 19 | show_int (test_function (3 :: [])) 20 | 21 | type 'a tree = 22 | | Empty 23 | | Leaf of 'a 24 | | Node of 'a tree * 'a tree 25 | 26 | let () = 27 | show_int (match Node (Leaf 1, Leaf 2) with 28 | | Empty -> 4 29 | | Leaf _ -> 4 30 | | Node _ -> 5 (* note: a single wildcard for several arguments *) 31 | ) 32 | 33 | let () = print_newline () 34 | let () = print_string "irrefutable patterns in let-bindings: " 35 | 36 | let () = show_int ( 37 | let (a, b) = (2, 3) in b - a 38 | ) 39 | 40 | let () = print_newline () 41 | let () = print_string "nested patterns: " 42 | 43 | let test_nested_patterns = 44 | match Node(Leaf 0, Node(Leaf 8, Node(Leaf 2, Empty))) with 45 | | Empty -> 0 46 | | Leaf _ -> 0 47 | | Node(_, Empty) -> 0 48 | | Node(Empty, Node _) -> 1 49 | | Node(Node _, Node _) -> 1 50 | | Node(Leaf 0, Node (_, Node (_, Node _))) -> 2 51 | | Node(Leaf 0, Node (Leaf x, Node (Leaf y, Empty))) -> x - y 52 | | Node(Leaf 0, Node (_, Empty)) -> 4 53 | | Node (a, b) -> 54 | (match Node (a, b) with 55 | | Node (Empty, _) -> 0 56 | | Node (_, Empty) -> 0 57 | | Node (Leaf _, Leaf _) -> 1 58 | | _ -> 2) 59 | 60 | let () = show_int test_nested_patterns 61 | 62 | let () = print_newline () 63 | let () = print_string "as-patterns: " 64 | 65 | let () = show_int (match (2, 3) with 66 | | (_ as a, _) as p -> 67 | let (_, b) = p in 68 | b - a 69 | ) 70 | 71 | let () = print_newline () 72 | let () = print_string "or-patterns: " 73 | 74 | (* toplevel ors, no parentheses *) 75 | let () = show_int (match 1 with 76 | | 0 | 1 | 2 -> 1 (* no parentheses *) 77 | | 3 | 4 -> 2 78 | | 5 | _ -> 3 79 | ) 80 | 81 | (* toplevel ors, with parentheses *) 82 | let () = show_int (match 3 with 83 | | (0 | 1 | 2) -> 1 84 | | (3 | 4) -> 2 (* parentheses *) 85 | | 5 | _ -> 3 86 | ) 87 | 88 | (* in-depth ors *) 89 | let () = show_int (match (2, 3) with 90 | | ((0 | 1), _) -> 1 91 | | (2, (0 | 1)) -> 2 92 | | (2, (2 | 3)) -> 3 93 | | ((3 | 4), _) -> 4 94 | | _ -> 5 95 | ) 96 | 97 | (* oring constant and non-constant patterns *) 98 | let () = show_int (match Node (Empty, Empty) with 99 | | Empty | Leaf _ -> 0 100 | | Node ((Empty | Leaf _), Node _) -> 1 101 | | Node (_, (Empty | Leaf _)) -> 4 102 | | Node (Node _, Node _) -> 12 103 | ) 104 | 105 | let () = print_newline () 106 | let () = print_string "record patterns" 107 | 108 | type ('a, 'b) t = { a : 'a; b : 'b } 109 | let () = show_int (match { a = Empty; b = Leaf 1 } with 110 | | { a = (Leaf _ | Node _) } -> 0 111 | | { b = (Empty | Node _) } -> 2 112 | | { a = Empty; b = Leaf n } -> n 113 | ) 114 | 115 | let () = print_newline () 116 | let () = print_string "string patterns" 117 | let f = function 118 | | "foo" -> 42 119 | | "barbar" -> 21 120 | | _ -> 0 121 | 122 | let () = show_int (f "foo") 123 | let () = show_int (2 * f "barbar") 124 | let () = show_int (42 + f "bar") 125 | 126 | let () = print_newline () 127 | let () = print_string "when-guards" 128 | 129 | let () = show_int (match Node (Leaf 2, Leaf 2) with 130 | | Node _ when (show_int 1; false) -> 0 131 | | Node (Leaf n, (Leaf _ | Empty)) when (show_int n; false) -> 0 132 | | Node _ -> 3 133 | | _ -> 4 134 | ) 135 | 136 | let () = print_newline () 137 | let () = print_string "match with exception" 138 | 139 | let f ~success:b = 140 | if b then 17 141 | else raise (Failure " 42") 142 | 143 | let () = match f ~success:true with 144 | | n -> show_int n 145 | | exception (Failure s) -> print_string s 146 | 147 | let () = match f ~success:false with 148 | | n -> show_int n 149 | | exception (Failure s) -> print_string s 150 | 151 | let () = print_newline () 152 | let () = print_string "interval patterns" 153 | 154 | let f c = show_int (match c with 155 | | 'c' | 'W' | '6' -> 0 156 | | 'a'..'z' -> 1 157 | | 'A'..'Z' -> 2 158 | | '0'..'9' -> 3 159 | | _ -> 4) 160 | 161 | let () = f 'c'; f 'W'; f '6'; f 'a'; f 'b'; f 'd'; f 'z'; f 'A'; f 'V'; f 'X'; f 'Z'; f '0'; f '5'; f '7'; f '9'; f '/'; f ':'; f '@'; f '['; f '`'; f '{' 162 | 163 | let () = print_newline () 164 | -------------------------------------------------------------------------------- /miniml/compiler/test/patterns.output.reference: -------------------------------------------------------------------------------- 1 | Pattern-matching: 2 | simple: 2 3 4 5 3 | irrefutable patterns in let-bindings: 1 4 | nested patterns: 6 5 | as-patterns: 1 6 | or-patterns: 1 2 3 4 7 | record patterns 1 8 | string patterns 42 42 42 9 | when-guards 1 2 3 10 | match with exception 17 42 11 | interval patterns 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 4 4 12 | -------------------------------------------------------------------------------- /miniml/compiler/test/records.info.reference: -------------------------------------------------------------------------------- 1 | Bytecode size: 7287 bytes 2 | -------------------------------------------------------------------------------- /miniml/compiler/test/records.ml: -------------------------------------------------------------------------------- 1 | let () = print_endline "Records:" 2 | let () = print_string "simple: " 3 | 4 | type t = { a : int ; b : int } 5 | 6 | let () = 7 | let u = { a = 5 ; b = 7 } in 8 | show_int u.a; show_int u.b 9 | 10 | let () = 11 | let u = { b = 5 ; a = 7 } in 12 | show_int u.a; show_int u.b 13 | 14 | let () = print_newline () 15 | let () = print_string "with: " 16 | 17 | let () = 18 | let u = { a = 5 ; b = 7 } in 19 | let v = { u with a = 42 } in 20 | let w = { u with b = 16 } in 21 | show_int u.a; show_int u.b; 22 | show_int v.a; show_int v.b; 23 | show_int w.a; show_int w.b 24 | 25 | let () = print_newline () 26 | let () = print_string "record field punning: " 27 | 28 | let () = 29 | let u = let a, b = 1, 2 in { a; b } in 30 | match u with 31 | | {a; b} -> show_int a; show_int b 32 | 33 | let () = print_newline () 34 | let () = print_string "inline records: " 35 | 36 | type t = 37 | | A of { x : int; y : int; u : int } 38 | | B of { z : int } 39 | 40 | let print_t = function 41 | | A { x; u } -> show_int x; show_int u (* note: field y is ignored *) 42 | | B { z = name } -> show_int name 43 | 44 | let rec loop = function 45 | | [] -> () 46 | | t :: ts -> print_t t; loop ts 47 | 48 | let () = let z = 3 in loop [ 49 | A { x = 1; y = 0; u = 2 }; 50 | B { z; } 51 | ] 52 | 53 | let () = print_newline () 54 | -------------------------------------------------------------------------------- /miniml/compiler/test/records.output.reference: -------------------------------------------------------------------------------- 1 | Records: 2 | simple: 5 7 7 5 3 | with: 5 7 42 7 5 16 4 | record field punning: 1 2 5 | inline records: 1 2 3 6 | -------------------------------------------------------------------------------- /miniml/interp/Makefile: -------------------------------------------------------------------------------- 1 | TIMED=../../timed.sh 2 | 3 | MINIML=guile ../compiler/compile.scm std_miniml_prefix.ml --open Std_miniml_prefix std.ml --open Std std_miniml.ml --open Std_miniml 4 | 5 | OCAMLRUN=../../ocaml-src/byterun/ocamlrun 6 | OCAMLLEX=../../ocaml-src/byterun/ocamlrun ../../ocaml-src/boot/ocamllex 7 | OCAMLYACC=../../ocaml-src/yacc/ocamlyacc 8 | 9 | COMMONOBJS=int32.ml int64.ml nativeint.ml seq.ml char.ml bytes.ml string.ml digest.ml marshal.ml array.ml list.ml stack.ml hashtbl.ml map.ml set.ml buffer.ml format.ml printf.ml arg.ml gc.ml filename.ml lexing.ml parsing.ml 10 | PARSEOBJS=misc.ml clflags.ml location.ml asttypes.mli warnings.ml syntaxerr.ml longident.ml parsetree.mli docstrings.ml ast_helper.ml parser.ml lexer.ml parse.ml 11 | INTERPOBJS=$(COMMONOBJS) $(PARSEOBJS) ../../interpreter/conf.ml ../../interpreter/data.ml ../../interpreter/envir.ml ../../interpreter/runtime_lib.ml ../../interpreter/runtime_base.ml ../../interpreter/eval.ml ../../interpreter/runtime_stdlib.ml ../../interpreter/runtime_compiler.ml ../../interpreter/primitives.ml ../../interpreter/interp.ml 12 | LEXOBJS1=../../ocaml-src/lex/cset.ml ../../ocaml-src/lex/syntax.ml ../../ocaml-src/lex/parser.ml 13 | LEXOBJS2=../../ocaml-src/lex/table.ml ../../ocaml-src/lex/lexgen.ml ../../ocaml-src/lex/compact.ml ../../ocaml-src/lex/common.ml ../../ocaml-src/lex/output.ml ../../ocaml-src/lex/outputbis.ml ../../ocaml-src/lex/main.ml 14 | DEPENDOBJS=$(COMMONOBJS) $(PARSEOBJS) depend.ml makedepend.ml 15 | 16 | LEXBOOTOBJS=$(COMMONOBJS) $(LEXOBJS1) ../../lex/lexer.ml $(LEXOBJS2) 17 | LEXOBJS=$(COMMONOBJS) $(LEXOBJS1) lex/lexer.ml $(LEXOBJS2) 18 | 19 | OPTCOMPILE=./interp -nopervasives -nostdlib -w -20-21 -I ../../interpreter 20 | 21 | %.byte: std.ml 22 | 23 | lex.boot.byte: $(LEXBOOTOBJS) 24 | $(MINIML) $(LEXBOOTOBJS) -o $@ 25 | 26 | lex/lexer.ml: lex.boot.byte ../../ocaml-src/lex/lexer.mll 27 | mkdir -p lex/ 28 | $(OCAMLRUN) lex.boot.byte ../../ocaml-src/lex/lexer.mll -o $@ 29 | 30 | lex.byte: $(LEXOBJS) 31 | $(MINIML) $(LEXOBJS) -o $@ 32 | 33 | make_opcodes.ml: lex.byte ../../ocaml-src/tools/make_opcodes.mll 34 | $(OCAMLRUN) lex.byte ../../ocaml-src/tools/make_opcodes.mll -o make_opcodes.ml 35 | 36 | make_opcodes.byte: $(COMMONOBJS) make_opcodes.ml 37 | $(MINIML) $(COMMONOBJS) make_opcodes.ml -o $@ 38 | 39 | cvt_emit.ml: lex.byte ../../ocaml-src/tools/cvt_emit.mll 40 | $(OCAMLRUN) lex.byte ../../ocaml-src/tools/cvt_emit.mll -o cvt_emit.ml 41 | 42 | cvt_emit.byte: $(COMMONOBJS) cvt_emit.ml 43 | $(MINIML) $(COMMONOBJS) cvt_emit.ml -o $@ 44 | 45 | interp.byte: $(INTERPOBJS) 46 | $(MINIML) $(INTERPOBJS) -o $@ 47 | 48 | makedepend.byte: $(DEPENDOBJS) 49 | $(MINIML) $(DEPENDOBJS) -o $@ 50 | 51 | #interpopt.opt: $(INTERPOBJS) interp.byte 52 | # ./genfileopt.sh 53 | # @echo "Compiling interpopt.opt, this make take a while..." 54 | # $(TIMED) ./interp -nopervasives -nostdlib -w -20-21 ../../ocaml-src/asmrun/libasmrun.a interpopt.ml -o interpopt.opt -ccopt "-lm -lpthread -ldl" 55 | 56 | INTERPCMX=$(filter %.cmx,$(INTERPOBJS:.ml=.cmx)) 57 | interpopt.opt: interp.byte stdopt.cmx $(INTERPCMX) stdopt_exit.cmx 58 | $(OPTCOMPILE) ../../ocaml-src/asmrun/libasmrun.a $(filter %.cmx, $^) -o $@ -ccopt "-lm -lpthread -ldl" 59 | 60 | lexer.ml: lex.byte lexer.mll 61 | $(OCAMLRUN) lex.byte lexer.mll 62 | 63 | parser.ml: parser.mly 64 | $(OCAMLYACC) $< 65 | 66 | stdopt.cmi: stdopt.mli interp.byte 67 | $(OPTCOMPILE) -c $< 68 | 69 | stdopt.cmx: stdopt.ml stdopt.cmi interp.byte 70 | $(OPTCOMPILE) -c $< 71 | 72 | %.cmi: %.mli stdopt.cmi interp.byte 73 | $(OPTCOMPILE) -open Stdopt -c $< 74 | 75 | %.cmx: %.ml stdopt.cmx interp.byte 76 | $(OPTCOMPILE) -open Stdopt -c $< 77 | 78 | stdopt.ml: std_opt_prefix.ml std.ml 79 | cat $^ > $@ 80 | 81 | stdopt.mli: std_opt_prefix.mli std.mli 82 | cat $^ > $@ 83 | 84 | stdopt_exit.mli: 85 | echo > $@ 86 | 87 | stdopt_exit.ml: 88 | echo "let () = __atexit ()" > $@ 89 | 90 | 91 | 92 | include .depend 93 | 94 | 95 | .PHONY: depend 96 | depend: makedepend.byte stdopt.ml stdopt.mli stdopt_exit.ml stdopt_exit.mli lexer.ml parser.ml 97 | ./depend.sh -native -I ../../interpreter $(INTERPOBJS) $(INTERPOBJS:.ml=.mli) stdopt.ml stdopt.mli stdopt_exit.ml stdopt_exit.mli > .depend 98 | -------------------------------------------------------------------------------- /miniml/interp/asttypes.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (** Auxiliary AST types used by parsetree and typedtree. *) 17 | 18 | type constant = 19 | Const_int of int 20 | | Const_char of char 21 | | Const_string of string * string option 22 | | Const_float of string 23 | | Const_int32 of int32 24 | | Const_int64 of int64 25 | | Const_nativeint of nativeint 26 | 27 | type rec_flag = Nonrecursive | Recursive 28 | 29 | type direction_flag = Upto | Downto 30 | 31 | (* Order matters, used in polymorphic comparison *) 32 | type private_flag = Private | Public 33 | 34 | type mutable_flag = Immutable | Mutable 35 | 36 | type virtual_flag = Virtual | Concrete 37 | 38 | type override_flag = Override | Fresh 39 | 40 | type closed_flag = Closed | Open 41 | 42 | type label = string 43 | 44 | type arg_label = 45 | Nolabel 46 | | Labelled of string (* label:T -> ... *) 47 | | Optional of string (* ?label:T -> ... *) 48 | 49 | type 'a loc = 'a Location.loc = { 50 | txt : 'a; 51 | loc : Location.t; 52 | } 53 | 54 | 55 | type variance = 56 | | Covariant 57 | | Contravariant 58 | | Invariant 59 | -------------------------------------------------------------------------------- /miniml/interp/char.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (* Character operations *) 17 | 18 | external code: char -> int = "%identity" 19 | external unsafe_chr: int -> char = "%identity" 20 | 21 | let chr n = 22 | if n < 0 || n > 255 then invalid_arg "Char.chr" else unsafe_chr n 23 | 24 | external bytes_create: int -> bytes = "caml_create_bytes" 25 | external bytes_unsafe_set : bytes -> int -> char -> unit 26 | = "%bytes_unsafe_set" 27 | external unsafe_to_string : bytes -> string = "%bytes_to_string" 28 | 29 | let escaped = function 30 | | '\'' -> "\\'" 31 | | '\\' -> "\\\\" 32 | | '\n' -> "\\n" 33 | | '\t' -> "\\t" 34 | | '\r' -> "\\r" 35 | | '\b' -> "\\b" 36 | | ' ' .. '~' as c -> 37 | let s = bytes_create 1 in 38 | bytes_unsafe_set s 0 c; 39 | unsafe_to_string s 40 | | c -> 41 | let n = code c in 42 | let s = bytes_create 4 in 43 | bytes_unsafe_set s 0 '\\'; 44 | bytes_unsafe_set s 1 (unsafe_chr (48 + n / 100)); 45 | bytes_unsafe_set s 2 (unsafe_chr (48 + (n / 10) mod 10)); 46 | bytes_unsafe_set s 3 (unsafe_chr (48 + n mod 10)); 47 | unsafe_to_string s 48 | 49 | let lowercase c = 50 | if (c >= 'A' && c <= 'Z') 51 | || (c >= '\192' && c <= '\214') 52 | || (c >= '\216' && c <= '\222') 53 | then unsafe_chr(code c + 32) 54 | else c 55 | 56 | let uppercase c = 57 | if (c >= 'a' && c <= 'z') 58 | || (c >= '\224' && c <= '\246') 59 | || (c >= '\248' && c <= '\254') 60 | then unsafe_chr(code c - 32) 61 | else c 62 | 63 | let lowercase_ascii c = 64 | if (c >= 'A' && c <= 'Z') 65 | then unsafe_chr(code c + 32) 66 | else c 67 | 68 | let uppercase_ascii c = 69 | if (c >= 'a' && c <= 'z') 70 | then unsafe_chr(code c - 32) 71 | else c 72 | 73 | type t = char 74 | 75 | let compare c1 c2 = code c1 - code c2 76 | let equal (c1: t) (c2: t) = compare c1 c2 = 0 77 | -------------------------------------------------------------------------------- /miniml/interp/char.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (** Character operations. *) 17 | 18 | external code : char -> int = "%identity" 19 | (** Return the ASCII code of the argument. *) 20 | 21 | val chr : int -> char 22 | (** Return the character with the given ASCII code. 23 | Raise [Invalid_argument "Char.chr"] if the argument is 24 | outside the range 0--255. *) 25 | 26 | val escaped : char -> string 27 | (** Return a string representing the given character, 28 | with special characters escaped following the lexical conventions 29 | of OCaml. 30 | All characters outside the ASCII printable range (32..126) are 31 | escaped, as well as backslash, double-quote, and single-quote. *) 32 | 33 | val lowercase : char -> char 34 | [@@ocaml.deprecated "Use Char.lowercase_ascii instead."] 35 | (** Convert the given character to its equivalent lowercase character, 36 | using the ISO Latin-1 (8859-1) character set. 37 | @deprecated Functions operating on Latin-1 character set are deprecated. *) 38 | 39 | val uppercase : char -> char 40 | [@@ocaml.deprecated "Use Char.uppercase_ascii instead."] 41 | (** Convert the given character to its equivalent uppercase character, 42 | using the ISO Latin-1 (8859-1) character set. 43 | @deprecated Functions operating on Latin-1 character set are deprecated. *) 44 | 45 | val lowercase_ascii : char -> char 46 | (** Convert the given character to its equivalent lowercase character, 47 | using the US-ASCII character set. 48 | @since 4.03.0 *) 49 | 50 | val uppercase_ascii : char -> char 51 | (** Convert the given character to its equivalent uppercase character, 52 | using the US-ASCII character set. 53 | @since 4.03.0 *) 54 | 55 | type t = char 56 | (** An alias for the type of characters. *) 57 | 58 | val compare: t -> t -> int 59 | (** The comparison function for characters, with the same specification as 60 | {!Pervasives.compare}. Along with the type [t], this function [compare] 61 | allows the module [Char] to be passed as argument to the functors 62 | {!Set.Make} and {!Map.Make}. *) 63 | 64 | val equal: t -> t -> bool 65 | (** The equal function for chars. 66 | @since 4.03.0 *) 67 | 68 | (**/**) 69 | 70 | (* The following is for system use only. Do not call directly. *) 71 | 72 | external unsafe_chr : int -> char = "%identity" 73 | -------------------------------------------------------------------------------- /miniml/interp/clflags.ml: -------------------------------------------------------------------------------- 1 | let fast = ref false 2 | let applicative_functors = ref true 3 | let transparent_modules = ref false 4 | -------------------------------------------------------------------------------- /miniml/interp/clflags.mli: -------------------------------------------------------------------------------- 1 | val fast : bool ref 2 | val applicative_functors : bool ref 3 | val transparent_modules : bool ref 4 | -------------------------------------------------------------------------------- /miniml/interp/cvt_emit.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | r=$(dirname $0) 3 | root=$r/../.. 4 | $root/ocaml-src/byterun/ocamlrun $r/cvt_emit.byte "$@" -------------------------------------------------------------------------------- /miniml/interp/depend.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | r=$(dirname $0) 3 | root=$r/../.. 4 | $root/ocaml-src/byterun/ocamlrun $r/makedepend.byte "$@" -------------------------------------------------------------------------------- /miniml/interp/digest.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (* Message digest (MD5) *) 17 | 18 | type t = string 19 | 20 | let compare = String.compare 21 | let equal = String.equal 22 | 23 | external unsafe_string: string -> int -> int -> t = "caml_md5_string" 24 | external channel: in_channel -> int -> t = "caml_md5_chan" 25 | 26 | let string str = 27 | unsafe_string str 0 (String.length str) 28 | 29 | let bytes b = string (Bytes.unsafe_to_string b) 30 | 31 | let substring str ofs len = 32 | if ofs < 0 || len < 0 || ofs > String.length str - len 33 | then invalid_arg "Digest.substring" 34 | else unsafe_string str ofs len 35 | 36 | let subbytes b ofs len = substring (Bytes.unsafe_to_string b) ofs len 37 | 38 | let file filename = 39 | let ic = open_in_bin filename in 40 | match channel ic (-1) with 41 | | d -> close_in ic; d 42 | | exception e -> close_in ic; raise e 43 | 44 | let output chan digest = 45 | output_string chan digest 46 | 47 | let input chan = really_input_string chan 16 48 | 49 | let char_hex n = 50 | Char.unsafe_chr (n + if n < 10 then Char.code '0' else (Char.code 'a' - 10)) 51 | 52 | let to_hex d = 53 | if String.length d <> 16 then invalid_arg "Digest.to_hex"; 54 | let result = Bytes.create 32 in 55 | for i = 0 to 15 do 56 | let x = Char.code d.[i] in 57 | Bytes.unsafe_set result (i*2) (char_hex (x lsr 4)); 58 | Bytes.unsafe_set result (i*2+1) (char_hex (x land 0x0f)); 59 | done; 60 | Bytes.unsafe_to_string result 61 | 62 | let from_hex s = 63 | if String.length s <> 32 then invalid_arg "Digest.from_hex"; 64 | let digit c = 65 | match c with 66 | | '0'..'9' -> Char.code c - Char.code '0' 67 | | 'A'..'F' -> Char.code c - Char.code 'A' + 10 68 | | 'a'..'f' -> Char.code c - Char.code 'a' + 10 69 | | _ -> raise (Invalid_argument "Digest.from_hex") 70 | in 71 | let byte i = digit s.[i] lsl 4 + digit s.[i+1] in 72 | let result = Bytes.create 16 in 73 | for i = 0 to 15 do 74 | Bytes.set result i (Char.chr (byte (2 * i))); 75 | done; 76 | Bytes.unsafe_to_string result 77 | -------------------------------------------------------------------------------- /miniml/interp/digest.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (** MD5 message digest. 17 | 18 | This module provides functions to compute 128-bit 'digests' of 19 | arbitrary-length strings or files. The digests are of cryptographic 20 | quality: it is very hard, given a digest, to forge a string having 21 | that digest. The algorithm used is MD5. This module should not be 22 | used for secure and sensitive cryptographic applications. For these 23 | kind of applications more recent and stronger cryptographic 24 | primitives should be used instead. 25 | *) 26 | 27 | type t = string 28 | (** The type of digests: 16-character strings. *) 29 | 30 | val compare : t -> t -> int 31 | (** The comparison function for 16-character digest, with the same 32 | specification as {!Pervasives.compare} and the implementation 33 | shared with {!String.compare}. Along with the type [t], this 34 | function [compare] allows the module [Digest] to be passed as 35 | argument to the functors {!Set.Make} and {!Map.Make}. 36 | @since 4.00.0 *) 37 | 38 | val equal : t -> t -> bool 39 | (** The equal function for 16-character digest. 40 | @since 4.03.0 *) 41 | 42 | val string : string -> t 43 | (** Return the digest of the given string. *) 44 | 45 | val bytes : bytes -> t 46 | (** Return the digest of the given byte sequence. 47 | @since 4.02.0 *) 48 | 49 | val substring : string -> int -> int -> t 50 | (** [Digest.substring s ofs len] returns the digest of the substring 51 | of [s] starting at index [ofs] and containing [len] characters. *) 52 | 53 | val subbytes : bytes -> int -> int -> t 54 | (** [Digest.subbytes s ofs len] returns the digest of the subsequence 55 | of [s] starting at index [ofs] and containing [len] bytes. 56 | @since 4.02.0 *) 57 | 58 | external channel : in_channel -> int -> t = "caml_md5_chan" 59 | (** If [len] is nonnegative, [Digest.channel ic len] reads [len] 60 | characters from channel [ic] and returns their digest, or raises 61 | [End_of_file] if end-of-file is reached before [len] characters 62 | are read. If [len] is negative, [Digest.channel ic len] reads 63 | all characters from [ic] until end-of-file is reached and return 64 | their digest. *) 65 | 66 | val file : string -> t 67 | (** Return the digest of the file whose name is given. *) 68 | 69 | val output : out_channel -> t -> unit 70 | (** Write a digest on the given output channel. *) 71 | 72 | val input : in_channel -> t 73 | (** Read a digest from the given input channel. *) 74 | 75 | val to_hex : t -> string 76 | (** Return the printable hexadecimal representation of the given digest. 77 | Raise [Invalid_argument] if the argument is not exactly 16 bytes. 78 | *) 79 | 80 | val from_hex : string -> t 81 | (** Convert a hexadecimal representation back into the corresponding digest. 82 | Raise [Invalid_argument] if the argument is not exactly 32 hexadecimal 83 | characters. 84 | @since 4.00.0 *) 85 | -------------------------------------------------------------------------------- /miniml/interp/docstrings.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Leo White *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (** Documentation comments *) 17 | 18 | (** (Re)Initialise all docstring state *) 19 | val init : unit -> unit 20 | 21 | (** Emit warnings for unattached and ambiguous docstrings *) 22 | val warn_bad_docstrings : unit -> unit 23 | 24 | (** {2 Docstrings} *) 25 | 26 | (** Documentation comments *) 27 | type docstring 28 | 29 | (** Create a docstring *) 30 | val docstring : string -> Location.t -> docstring 31 | 32 | (** Register a docstring *) 33 | val register : docstring -> unit 34 | 35 | (** Get the text of a docstring *) 36 | val docstring_body : docstring -> string 37 | 38 | (** Get the location of a docstring *) 39 | val docstring_loc : docstring -> Location.t 40 | 41 | (** {2 Set functions} 42 | 43 | These functions are used by the lexer to associate docstrings to 44 | the locations of tokens. *) 45 | 46 | (** Docstrings immediately preceding a token *) 47 | val set_pre_docstrings : Lexing.position -> docstring list -> unit 48 | 49 | (** Docstrings immediately following a token *) 50 | val set_post_docstrings : Lexing.position -> docstring list -> unit 51 | 52 | (** Docstrings not immediately adjacent to a token *) 53 | val set_floating_docstrings : Lexing.position -> docstring list -> unit 54 | 55 | (** Docstrings immediately following the token which precedes this one *) 56 | val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit 57 | 58 | (** Docstrings immediately preceding the token which follows this one *) 59 | val set_post_extra_docstrings : Lexing.position -> docstring list -> unit 60 | 61 | (** {2 Items} 62 | 63 | The {!docs} type represents documentation attached to an item. *) 64 | 65 | type docs = 66 | { docs_pre: docstring option; 67 | docs_post: docstring option; } 68 | 69 | val empty_docs : docs 70 | 71 | val docs_attr : docstring -> Parsetree.attribute 72 | 73 | (** Convert item documentation to attributes and add them to an 74 | attribute list *) 75 | val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes 76 | 77 | (** Fetch the item documentation for the current symbol. This also 78 | marks this documentation (for ambiguity warnings). *) 79 | val symbol_docs : unit -> docs 80 | 81 | (** Fetch the item documentation for the symbols between two 82 | positions. This also marks this documentation (for ambiguity 83 | warnings). *) 84 | val rhs_docs : int -> int -> docs 85 | 86 | (** Mark the item documentation for the current symbol (for ambiguity 87 | warnings). *) 88 | val mark_symbol_docs : unit -> unit 89 | 90 | (** Mark as associated the item documentation for the symbols between 91 | two positions (for ambiguity warnings) *) 92 | val mark_rhs_docs : int -> int -> unit 93 | 94 | (** {2 Fields and constructors} 95 | 96 | The {!info} type represents documentation attached to a field or 97 | constructor. *) 98 | 99 | type info = docstring option 100 | 101 | val empty_info : info 102 | 103 | val info_attr : docstring -> Parsetree.attribute 104 | 105 | (** Convert field info to attributes and add them to an 106 | attribute list *) 107 | val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes 108 | 109 | (** Fetch the field info for the current symbol. *) 110 | val symbol_info : unit -> info 111 | 112 | (** Fetch the field info following the symbol at a given position. *) 113 | val rhs_info : int -> info 114 | 115 | (** {2 Unattached comments} 116 | 117 | The {!text} type represents documentation which is not attached to 118 | anything. *) 119 | 120 | type text = docstring list 121 | 122 | val empty_text : text 123 | 124 | val text_attr : docstring -> Parsetree.attribute 125 | 126 | (** Convert text to attributes and add them to an attribute list *) 127 | val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes 128 | 129 | (** Fetch the text preceding the current symbol. *) 130 | val symbol_text : unit -> text 131 | 132 | (** Fetch the text preceding the symbol at the given position. *) 133 | val rhs_text : int -> text 134 | 135 | (** {2 Extra text} 136 | 137 | There may be additional text attached to the delimiters of a block 138 | (e.g. [struct] and [end]). This is fetched by the following 139 | functions, which are applied to the contents of the block rather 140 | than the delimiters. *) 141 | 142 | (** Fetch additional text preceding the current symbol *) 143 | val symbol_pre_extra_text : unit -> text 144 | 145 | (** Fetch additional text following the current symbol *) 146 | val symbol_post_extra_text : unit -> text 147 | 148 | (** Fetch additional text preceding the symbol at the given position *) 149 | val rhs_pre_extra_text : int -> text 150 | 151 | (** Fetch additional text following the symbol at the given position *) 152 | val rhs_post_extra_text : int -> text 153 | 154 | (** Fetch text following the symbol at the given position *) 155 | val rhs_post_text : int -> text 156 | -------------------------------------------------------------------------------- /miniml/interp/filename.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (** Operations on file names. *) 17 | 18 | val current_dir_name : string 19 | (** The conventional name for the current directory (e.g. [.] in Unix). *) 20 | 21 | val parent_dir_name : string 22 | (** The conventional name for the parent of the current directory 23 | (e.g. [..] in Unix). *) 24 | 25 | val dir_sep : string 26 | (** The directory separator (e.g. [/] in Unix). @since 3.11.2 *) 27 | 28 | val concat : string -> string -> string 29 | (** [concat dir file] returns a file name that designates file 30 | [file] in directory [dir]. *) 31 | 32 | val is_relative : string -> bool 33 | (** Return [true] if the file name is relative to the current 34 | directory, [false] if it is absolute (i.e. in Unix, starts 35 | with [/]). *) 36 | 37 | val is_implicit : string -> bool 38 | (** Return [true] if the file name is relative and does not start 39 | with an explicit reference to the current directory ([./] or 40 | [../] in Unix), [false] if it starts with an explicit reference 41 | to the root directory or the current directory. *) 42 | 43 | val check_suffix : string -> string -> bool 44 | (** [check_suffix name suff] returns [true] if the filename [name] 45 | ends with the suffix [suff]. *) 46 | 47 | val chop_suffix : string -> string -> string 48 | (** [chop_suffix name suff] removes the suffix [suff] from 49 | the filename [name]. The behavior is undefined if [name] does not 50 | end with the suffix [suff]. *) 51 | 52 | val extension : string -> string 53 | (** [extension name] is the shortest suffix [ext] of [name0] where: 54 | 55 | - [name0] is the longest suffix of [name] that does not 56 | contain a directory separator; 57 | - [ext] starts with a period; 58 | - [ext] is preceded by at least one non-period character 59 | in [name0]. 60 | 61 | If such a suffix does not exist, [extension name] is the empty 62 | string. 63 | 64 | @since 4.04 65 | *) 66 | 67 | val remove_extension : string -> string 68 | (** Return the given file name without its extension, as defined 69 | in {!Filename.extension}. If the extension is empty, the function 70 | returns the given file name. 71 | 72 | The following invariant holds for any file name [s]: 73 | 74 | [remove_extension s ^ extension s = s] 75 | 76 | @since 4.04 77 | *) 78 | 79 | val chop_extension : string -> string 80 | (** Same as {!Filename.remove_extension}, but raise [Invalid_argument] 81 | if the given name has an empty extension. *) 82 | 83 | 84 | val basename : string -> string 85 | (** Split a file name into directory name / base file name. 86 | If [name] is a valid file name, then [concat (dirname name) (basename name)] 87 | returns a file name which is equivalent to [name]. Moreover, 88 | after setting the current directory to [dirname name] (with {!Sys.chdir}), 89 | references to [basename name] (which is a relative file name) 90 | designate the same file as [name] before the call to {!Sys.chdir}. 91 | 92 | This function conforms to the specification of POSIX.1-2008 for the 93 | [basename] utility. *) 94 | 95 | val dirname : string -> string 96 | (** See {!Filename.basename}. 97 | This function conforms to the specification of POSIX.1-2008 for the 98 | [dirname] utility. *) 99 | 100 | val temp_dir_name : string 101 | [@@ocaml.deprecated "Use Filename.get_temp_dir_name instead"] 102 | (** The name of the initial temporary directory: 103 | Under Unix, the value of the [TMPDIR] environment variable, or "/tmp" 104 | if the variable is not set. 105 | Under Windows, the value of the [TEMP] environment variable, or "." 106 | if the variable is not set. 107 | @deprecated You should use {!Filename.get_temp_dir_name} instead. 108 | @since 3.09.1 109 | *) 110 | 111 | val quote : string -> string 112 | (** Return a quoted version of a file name, suitable for use as 113 | one argument in a command line, escaping all meta-characters. 114 | Warning: under Windows, the output is only suitable for use 115 | with programs that follow the standard Windows quoting 116 | conventions. 117 | *) 118 | -------------------------------------------------------------------------------- /miniml/interp/format.ml: -------------------------------------------------------------------------------- 1 | 2 | type formatter = { 3 | out_string : string -> unit 4 | } 5 | 6 | let error msg = 7 | print_string msg; print_string "\n"; failwith msg 8 | 9 | let mkprintf is_format print_fun ff fmt cont = 10 | let out_string = print_fun ff in 11 | let rec loop i = 12 | let j = ref i in 13 | while !j < String.length fmt && fmt.[!j] <> '%' && (not is_format || fmt.[!j] <> '@') do 14 | incr j 15 | done; 16 | let j = !j in 17 | if (i < j) then 18 | out_string (String.sub fmt i (j - i)); 19 | if j < String.length fmt then begin 20 | if (fmt.[j] = '%') then begin 21 | assert (j + 1 < String.length fmt); 22 | match fmt.[j + 1] with 23 | | 'd' | 'i' -> Obj.magic (fun n -> (out_string (string_of_int n); loop (j + 2))) 24 | | 'L' -> 25 | assert (j + 2 < String.length fmt && (fmt.[j + 2] = 'd' || fmt.[j + 2] = 'i')); 26 | Obj.magic (fun n -> out_string (Int64.to_string n); loop (j + 3)); 27 | | 'n' -> 28 | assert (j + 2 < String.length fmt && (fmt.[j + 2] = 'd' || fmt.[j + 2] = 'i')); 29 | Obj.magic (fun n -> out_string (Nativeint.to_string n); loop (j + 3)); 30 | | 'f' -> Obj.magic (fun f -> (out_string (format_float "%f" f); loop (j + 2))) 31 | | 's' -> Obj.magic (fun s -> (out_string s; loop (j + 2))) 32 | | 'S' -> Obj.magic (fun s -> (out_string (String.escaped s); loop (j + 2))) 33 | | 'a' -> Obj.magic (fun f x -> f ff x; loop (j + 2)) 34 | | '%' -> out_string "%"; loop (j + 2) 35 | | _ -> error ("Unknown format specifier: " ^ String.sub fmt j 2) 36 | end else begin 37 | assert (fmt.[j] = '@' && is_format); 38 | assert (j + 1 < String.length fmt); 39 | match fmt.[j + 1] with 40 | | '@' -> out_string "@"; loop (j + 2) 41 | | '.' -> out_string "\n"; loop (j + 2) 42 | | _ -> error ("Unknown format specifier: " ^ String.sub fmt j 2) 43 | end 44 | end else begin 45 | cont () 46 | end 47 | in 48 | Obj.magic (loop 0) 49 | 50 | let getff ff = ff.out_string 51 | let std_formatter = { out_string = print_string } 52 | let err_formatter = { out_string = print_err } 53 | let fprintf ff fmt = mkprintf true getff ff fmt (fun () -> ()) 54 | let printf fmt = fprintf std_formatter fmt 55 | let eprintf fmt = fprintf err_formatter fmt 56 | let kbprintf k b fmt = mkprintf true getff { out_string = Buffer.add_string b } fmt (fun () -> k b) 57 | let bprintf b fmt = kbprintf (fun _ -> ()) b fmt 58 | let kprintf k fmt = kbprintf (fun b -> k (Buffer.contents b)) (Buffer.create 16) fmt 59 | let ksprintf = kprintf 60 | let kasprintf = kprintf 61 | let sprintf fmt = kprintf (fun s -> s) fmt 62 | 63 | let pp_print_cut ff () = fprintf ff " " 64 | let pp_print_list ?(pp_sep = pp_print_cut) f ff l = 65 | match l with 66 | | [] -> () 67 | | a :: l -> f ff a; List.iter (fun a -> pp_sep ff (); f ff a) l 68 | -------------------------------------------------------------------------------- /miniml/interp/format.mli: -------------------------------------------------------------------------------- 1 | type formatter = { out_string : string -> unit; } 2 | val mkprintf : 3 | bool -> ('a -> string -> unit) -> 'a -> string -> (unit -> 'b) -> 'c 4 | 5 | val std_formatter : formatter 6 | val err_formatter : formatter 7 | 8 | val fprintf : formatter -> string -> 'a 9 | val printf : string -> 'a 10 | val eprintf : string -> 'a 11 | val kbprintf : (Buffer.t -> 'a) -> Buffer.t -> string -> 'b 12 | val bprintf : Buffer.t -> string -> 'a 13 | val kprintf : (string -> 'a) -> string -> 'b 14 | val ksprintf : (string -> 'a) -> string -> 'b 15 | val kasprintf : (string -> 'a) -> string -> 'b 16 | val sprintf : string -> 'a 17 | 18 | val pp_print_cut : formatter -> unit -> 'a 19 | val pp_print_list : 20 | ?pp_sep:(formatter -> unit -> 'a) -> 21 | (formatter -> 'b -> unit) -> formatter -> 'b list -> unit 22 | -------------------------------------------------------------------------------- /miniml/interp/gc.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Damien Doligez, projet Para, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | type stat = { 17 | minor_words : float; 18 | promoted_words : float; 19 | major_words : float; 20 | minor_collections : int; 21 | major_collections : int; 22 | heap_words : int; 23 | heap_chunks : int; 24 | live_words : int; 25 | live_blocks : int; 26 | free_words : int; 27 | free_blocks : int; 28 | largest_free : int; 29 | fragments : int; 30 | compactions : int; 31 | top_heap_words : int; 32 | stack_size : int; 33 | } 34 | 35 | type control = { 36 | mutable minor_heap_size : int; 37 | mutable major_heap_increment : int; 38 | mutable space_overhead : int; 39 | mutable verbose : int; 40 | mutable max_overhead : int; 41 | mutable stack_limit : int; 42 | mutable allocation_policy : int; 43 | window_size : int; 44 | } 45 | 46 | external stat : unit -> stat = "caml_gc_stat" 47 | external quick_stat : unit -> stat = "caml_gc_quick_stat" 48 | external counters : unit -> (float * float * float) = "caml_gc_counters" 49 | external minor_words : unit -> (float [@unboxed]) 50 | = "caml_gc_minor_words" "caml_gc_minor_words_unboxed" 51 | external get : unit -> control = "caml_gc_get" 52 | external set : control -> unit = "caml_gc_set" 53 | external minor : unit -> unit = "caml_gc_minor" 54 | external major_slice : int -> int = "caml_gc_major_slice" 55 | external major : unit -> unit = "caml_gc_major" 56 | external full_major : unit -> unit = "caml_gc_full_major" 57 | external compact : unit -> unit = "caml_gc_compaction" 58 | external get_minor_free : unit -> int = "caml_get_minor_free" 59 | external get_bucket : int -> int = "caml_get_major_bucket" [@@noalloc] 60 | external get_credit : unit -> int = "caml_get_major_credit" [@@noalloc] 61 | external huge_fallback_count : unit -> int = "caml_gc_huge_fallback_count" 62 | 63 | open Printf 64 | 65 | let print_stat c = 66 | let st = stat () in 67 | fprintf c "minor_collections: %d\n" st.minor_collections; 68 | fprintf c "major_collections: %d\n" st.major_collections; 69 | fprintf c "compactions: %d\n" st.compactions; 70 | fprintf c "\n"; 71 | let l1 = String.length (sprintf "%.0f" st.minor_words) in 72 | fprintf c "minor_words: %*.0f\n" l1 st.minor_words; 73 | fprintf c "promoted_words: %*.0f\n" l1 st.promoted_words; 74 | fprintf c "major_words: %*.0f\n" l1 st.major_words; 75 | fprintf c "\n"; 76 | let l2 = String.length (sprintf "%d" st.top_heap_words) in 77 | fprintf c "top_heap_words: %*d\n" l2 st.top_heap_words; 78 | fprintf c "heap_words: %*d\n" l2 st.heap_words; 79 | fprintf c "live_words: %*d\n" l2 st.live_words; 80 | fprintf c "free_words: %*d\n" l2 st.free_words; 81 | fprintf c "largest_free: %*d\n" l2 st.largest_free; 82 | fprintf c "fragments: %*d\n" l2 st.fragments; 83 | fprintf c "\n"; 84 | fprintf c "live_blocks: %d\n" st.live_blocks; 85 | fprintf c "free_blocks: %d\n" st.free_blocks; 86 | fprintf c "heap_chunks: %d\n" st.heap_chunks 87 | 88 | 89 | let allocated_bytes () = 90 | let (mi, pro, ma) = counters () in 91 | (mi +. ma -. pro) *. float_of_int (Sys.word_size / 8) 92 | 93 | 94 | external finalise : ('a -> unit) -> 'a -> unit = "caml_final_register" 95 | external finalise_last : (unit -> unit) -> 'a -> unit = 96 | "caml_final_register_called_without_value" 97 | external finalise_release : unit -> unit = "caml_final_release" 98 | 99 | 100 | type alarm = bool ref 101 | type alarm_rec = {active : alarm; f : unit -> unit} 102 | 103 | let rec call_alarm arec = 104 | if !(arec.active) then begin 105 | finalise call_alarm arec; 106 | arec.f (); 107 | end 108 | 109 | 110 | let create_alarm f = 111 | let arec = { active = ref true; f = f } in 112 | finalise call_alarm arec; 113 | arec.active 114 | 115 | 116 | let delete_alarm a = a := false 117 | -------------------------------------------------------------------------------- /miniml/interp/genfileopt.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | files=( int32.ml int64.ml nativeint.ml seq.ml char.ml bytes.ml string.ml digest.ml marshal.ml array.ml list.ml stack.ml hashtbl.ml map.ml set.ml buffer.ml format.ml printf.ml arg.ml gc.ml filename.ml lexing.ml parsing.ml misc.ml clflags.ml location.ml asttypes.mli warnings.ml syntaxerr.ml longident.ml parsetree.mli docstrings.ml ast_helper.ml parser.ml lexer.ml parse.ml ../../interpreter/conf.ml ../../interpreter/data.ml ../../interpreter/envir.ml ../../interpreter/runtime_lib.ml ../../interpreter/runtime_base.ml ../../interpreter/eval.ml ../../interpreter/runtime_stdlib.ml ../../interpreter/runtime_compiler.ml ../../interpreter/primitives.ml ../../interpreter/interp.ml ) 3 | modules=( Int32 Int64 Nativeint Seq Char Bytes String Digest Marshal Array List Stack Hashtbl Map Set Buffer Format Printf Arg Gc Filename Lexing Parsing Misc Clflags Location Asttypes Warnings Syntaxerr Longident Parsetree Docstrings Ast_helper Parser Lexer Parse Conf Data Envir Runtime_lib Runtime_base Eval Runtime_stdlib Runtime_compiler Primitives Interp ) 4 | out=interpopt.ml 5 | cat std_opt_prefix.ml > $out 6 | cat std.ml >> $out 7 | for i in "${!files[@]}"; do 8 | f=${files[$i]} 9 | m=${modules[$i]} 10 | echo "module $m = struct" >> $out 11 | echo "# 1 \"$f\"" >> $out 12 | cat $f >> $out 13 | echo "# $(($(wc -l < $out) + 2)) \"$out\"" >> $out 14 | echo "end" >> $out 15 | echo >> $out 16 | done 17 | echo >> $out 18 | echo "let () = __atexit ()" >> $out -------------------------------------------------------------------------------- /miniml/interp/int32.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (* Module [Int32]: 32-bit integers *) 17 | 18 | external neg : int32 -> int32 = "%int32_neg" 19 | external add : int32 -> int32 -> int32 = "%int32_add" 20 | external sub : int32 -> int32 -> int32 = "%int32_sub" 21 | external mul : int32 -> int32 -> int32 = "%int32_mul" 22 | external div : int32 -> int32 -> int32 = "%int32_div" 23 | external rem : int32 -> int32 -> int32 = "%int32_mod" 24 | external logand : int32 -> int32 -> int32 = "%int32_and" 25 | external logor : int32 -> int32 -> int32 = "%int32_or" 26 | external logxor : int32 -> int32 -> int32 = "%int32_xor" 27 | external shift_left : int32 -> int -> int32 = "%int32_lsl" 28 | external shift_right : int32 -> int -> int32 = "%int32_asr" 29 | external shift_right_logical : int32 -> int -> int32 = "%int32_lsr" 30 | external of_int : int -> int32 = "%int32_of_int" 31 | external to_int : int32 -> int = "%int32_to_int" 32 | external of_float : float -> int32 33 | = "caml_int32_of_float" "caml_int32_of_float_unboxed" 34 | [@@unboxed] [@@noalloc] 35 | external to_float : int32 -> float 36 | = "caml_int32_to_float" "caml_int32_to_float_unboxed" 37 | [@@unboxed] [@@noalloc] 38 | external bits_of_float : float -> int32 39 | = "caml_int32_bits_of_float" "caml_int32_bits_of_float_unboxed" 40 | [@@unboxed] [@@noalloc] 41 | external float_of_bits : int32 -> float 42 | = "caml_int32_float_of_bits" "caml_int32_float_of_bits_unboxed" 43 | [@@unboxed] [@@noalloc] 44 | 45 | let zero = 0l 46 | let one = 1l 47 | let minus_one = -1l 48 | let succ n = add n 1l 49 | let pred n = sub n 1l 50 | let abs n = if n >= 0l then n else neg n 51 | let min_int = 0x80000000l 52 | let max_int = 0x7FFFFFFFl 53 | let lognot n = logxor n (-1l) 54 | 55 | external format : string -> int32 -> string = "caml_int32_format" 56 | let to_string n = format "%d" n 57 | 58 | external of_string : string -> int32 = "caml_int32_of_string" 59 | 60 | let of_string_opt s = 61 | (* TODO: expose a non-raising primitive directly. *) 62 | try Some (of_string s) 63 | with Failure _ -> None 64 | 65 | type t = int32 66 | 67 | let compare (x: t) (y: t) = Pervasives.compare x y 68 | let equal (x: t) (y: t) = compare x y = 0 69 | -------------------------------------------------------------------------------- /miniml/interp/int64.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (* Module [Int64]: 64-bit integers *) 17 | 18 | external neg : int64 -> int64 = "%int64_neg" 19 | external add : int64 -> int64 -> int64 = "%int64_add" 20 | external sub : int64 -> int64 -> int64 = "%int64_sub" 21 | external mul : int64 -> int64 -> int64 = "%int64_mul" 22 | external div : int64 -> int64 -> int64 = "%int64_div" 23 | external rem : int64 -> int64 -> int64 = "%int64_mod" 24 | external logand : int64 -> int64 -> int64 = "%int64_and" 25 | external logor : int64 -> int64 -> int64 = "%int64_or" 26 | external logxor : int64 -> int64 -> int64 = "%int64_xor" 27 | external shift_left : int64 -> int -> int64 = "%int64_lsl" 28 | external shift_right : int64 -> int -> int64 = "%int64_asr" 29 | external shift_right_logical : int64 -> int -> int64 = "%int64_lsr" 30 | external of_int : int -> int64 = "%int64_of_int" 31 | external to_int : int64 -> int = "%int64_to_int" 32 | external of_float : float -> int64 33 | = "caml_int64_of_float" "caml_int64_of_float_unboxed" 34 | [@@unboxed] [@@noalloc] 35 | external to_float : int64 -> float 36 | = "caml_int64_to_float" "caml_int64_to_float_unboxed" 37 | [@@unboxed] [@@noalloc] 38 | external of_int32 : int32 -> int64 = "%int64_of_int32" 39 | external to_int32 : int64 -> int32 = "%int64_to_int32" 40 | external of_nativeint : nativeint -> int64 = "%int64_of_nativeint" 41 | external to_nativeint : int64 -> nativeint = "%int64_to_nativeint" 42 | 43 | let zero = 0L 44 | let one = 1L 45 | let minus_one = -1L 46 | let succ n = add n 1L 47 | let pred n = sub n 1L 48 | let abs n = if n >= 0L then n else neg n 49 | let min_int = 0x8000000000000000L 50 | let max_int = 0x7FFFFFFFFFFFFFFFL 51 | let lognot n = logxor n (-1L) 52 | 53 | external format : string -> int64 -> string = "caml_int64_format" 54 | let to_string n = format "%d" n 55 | 56 | external of_string : string -> int64 = "caml_int64_of_string" 57 | 58 | let of_string_opt s = 59 | (* TODO: expose a non-raising primitive directly. *) 60 | try Some (of_string s) 61 | with Failure _ -> None 62 | 63 | 64 | 65 | external bits_of_float : float -> int64 66 | = "caml_int64_bits_of_float" "caml_int64_bits_of_float_unboxed" 67 | [@@unboxed] [@@noalloc] 68 | external float_of_bits : int64 -> float 69 | = "caml_int64_float_of_bits" "caml_int64_float_of_bits_unboxed" 70 | [@@unboxed] [@@noalloc] 71 | 72 | type t = int64 73 | 74 | let compare (x: t) (y: t) = Pervasives.compare x y 75 | let equal (x: t) (y: t) = compare x y = 0 76 | -------------------------------------------------------------------------------- /miniml/interp/interp: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | r=$(dirname $0) 3 | root=$r/../.. 4 | OCAMLRUNPARAM='l=100M' OCAMLINTERP_STDLIB_PATH=$root/ocaml-src/stdlib/ OCAMLINTERP_SRC_PATH=$root/ocaml-src/ OCAMLINTERP_COMMAND=ocamlopt $root/ocaml-src/byterun/ocamlrun $r/interp.byte "$@" -------------------------------------------------------------------------------- /miniml/interp/interp.opt: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | r=$(dirname $0) 3 | root=$r/../.. 4 | ulimit -s 200000 5 | OCAMLRUNPARAM=b OCAMLINTERP_STDLIB_PATH=$root/ocaml-src/stdlib/ OCAMLINTERP_SRC_PATH=$root/ocaml-src/ OCAMLINTERP_COMMAND=ocamlopt $r/interpopt.opt "$@" -------------------------------------------------------------------------------- /miniml/interp/lex.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | r=$(dirname $0) 3 | root=$r/../.. 4 | $root/ocaml-src/byterun/ocamlrun $r/lex.byte "$@" -------------------------------------------------------------------------------- /miniml/interp/lexer.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (* The lexical analyzer *) 17 | 18 | val init : unit -> unit 19 | val token: Lexing.lexbuf -> Parser.token 20 | val skip_hash_bang: Lexing.lexbuf -> unit 21 | 22 | type error = 23 | | Illegal_character of char 24 | | Illegal_escape of string 25 | | Unterminated_comment of Location.t 26 | | Unterminated_string 27 | | Unterminated_string_in_comment of Location.t * Location.t 28 | | Keyword_as_label of string 29 | | Invalid_literal of string 30 | | Invalid_directive of string * string option 31 | ;; 32 | 33 | exception Error of error * Location.t 34 | 35 | open Format 36 | 37 | val report_error: formatter -> error -> unit 38 | (* Deprecated. Use Location.{error_of_exn, report_error}. *) 39 | 40 | val in_comment : unit -> bool;; 41 | val in_string : unit -> bool;; 42 | 43 | 44 | val print_warnings : bool ref 45 | val handle_docstrings: bool ref 46 | val comments : unit -> (string * Location.t) list 47 | val token_with_comments : Lexing.lexbuf -> Parser.token 48 | 49 | (* 50 | [set_preprocessor init preprocessor] registers [init] as the function 51 | to call to initialize the preprocessor when the lexer is initialized, 52 | and [preprocessor] a function that is called when a new token is needed 53 | by the parser, as [preprocessor lexer lexbuf] where [lexer] is the 54 | lexing function. 55 | 56 | When a preprocessor is configured by calling [set_preprocessor], the lexer 57 | changes its behavior to accept backslash-newline as a token-separating blank. 58 | *) 59 | 60 | val set_preprocessor : 61 | (unit -> unit) -> 62 | ((Lexing.lexbuf -> Parser.token) -> Lexing.lexbuf -> Parser.token) -> 63 | unit 64 | -------------------------------------------------------------------------------- /miniml/interp/lexing.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (** The run-time library for lexers generated by [ocamllex]. *) 17 | 18 | (** {1 Positions} *) 19 | 20 | type position = { 21 | pos_fname : string; 22 | pos_lnum : int; 23 | pos_bol : int; 24 | pos_cnum : int; 25 | } 26 | (** A value of type [position] describes a point in a source file. 27 | [pos_fname] is the file name; [pos_lnum] is the line number; 28 | [pos_bol] is the offset of the beginning of the line (number 29 | of characters between the beginning of the lexbuf and the beginning 30 | of the line); [pos_cnum] is the offset of the position (number of 31 | characters between the beginning of the lexbuf and the position). 32 | The difference between [pos_cnum] and [pos_bol] is the character 33 | offset within the line (i.e. the column number, assuming each 34 | character is one column wide). 35 | 36 | See the documentation of type [lexbuf] for information about 37 | how the lexing engine will manage positions. 38 | *) 39 | 40 | val dummy_pos : position 41 | (** A value of type [position], guaranteed to be different from any 42 | valid position. 43 | *) 44 | 45 | 46 | (** {1 Lexer buffers} *) 47 | 48 | 49 | type lexbuf = 50 | { refill_buff : lexbuf -> unit; 51 | mutable lex_buffer : bytes; 52 | mutable lex_buffer_len : int; 53 | mutable lex_abs_pos : int; 54 | mutable lex_start_pos : int; 55 | mutable lex_curr_pos : int; 56 | mutable lex_last_pos : int; 57 | mutable lex_last_action : int; 58 | mutable lex_eof_reached : bool; 59 | mutable lex_mem : int array; 60 | mutable lex_start_p : position; 61 | mutable lex_curr_p : position; 62 | } 63 | (** The type of lexer buffers. A lexer buffer is the argument passed 64 | to the scanning functions defined by the generated scanners. 65 | The lexer buffer holds the current state of the scanner, plus 66 | a function to refill the buffer from the input. 67 | 68 | At each token, the lexing engine will copy [lex_curr_p] to 69 | [lex_start_p], then change the [pos_cnum] field 70 | of [lex_curr_p] by updating it with the number of characters read 71 | since the start of the [lexbuf]. The other fields are left 72 | unchanged by the lexing engine. In order to keep them 73 | accurate, they must be initialised before the first use of the 74 | lexbuf, and updated by the relevant lexer actions (i.e. at each 75 | end of line -- see also [new_line]). 76 | *) 77 | 78 | val from_channel : in_channel -> lexbuf 79 | (** Create a lexer buffer on the given input channel. 80 | [Lexing.from_channel inchan] returns a lexer buffer which reads 81 | from the input channel [inchan], at the current reading position. *) 82 | 83 | val from_string : string -> lexbuf 84 | (** Create a lexer buffer which reads from 85 | the given string. Reading starts from the first character in 86 | the string. An end-of-input condition is generated when the 87 | end of the string is reached. *) 88 | 89 | val from_function : (bytes -> int -> int) -> lexbuf 90 | (** Create a lexer buffer with the given function as its reading method. 91 | When the scanner needs more characters, it will call the given 92 | function, giving it a byte sequence [s] and a byte 93 | count [n]. The function should put [n] bytes or fewer in [s], 94 | starting at index 0, and return the number of bytes 95 | provided. A return value of 0 means end of input. *) 96 | 97 | 98 | (** {1 Functions for lexer semantic actions} *) 99 | 100 | 101 | (** The following functions can be called from the semantic actions 102 | of lexer definitions (the ML code enclosed in braces that 103 | computes the value returned by lexing functions). They give 104 | access to the character string matched by the regular expression 105 | associated with the semantic action. These functions must be 106 | applied to the argument [lexbuf], which, in the code generated by 107 | [ocamllex], is bound to the lexer buffer passed to the parsing 108 | function. *) 109 | 110 | val lexeme : lexbuf -> string 111 | (** [Lexing.lexeme lexbuf] returns the string matched by 112 | the regular expression. *) 113 | 114 | val lexeme_char : lexbuf -> int -> char 115 | (** [Lexing.lexeme_char lexbuf i] returns character number [i] in 116 | the matched string. *) 117 | 118 | val lexeme_start : lexbuf -> int 119 | (** [Lexing.lexeme_start lexbuf] returns the offset in the 120 | input stream of the first character of the matched string. 121 | The first character of the stream has offset 0. *) 122 | 123 | val lexeme_end : lexbuf -> int 124 | (** [Lexing.lexeme_end lexbuf] returns the offset in the input stream 125 | of the character following the last character of the matched 126 | string. The first character of the stream has offset 0. *) 127 | 128 | val lexeme_start_p : lexbuf -> position 129 | (** Like [lexeme_start], but return a complete [position] instead 130 | of an offset. *) 131 | 132 | val lexeme_end_p : lexbuf -> position 133 | (** Like [lexeme_end], but return a complete [position] instead 134 | of an offset. *) 135 | 136 | val new_line : lexbuf -> unit 137 | (** Update the [lex_curr_p] field of the lexbuf to reflect the start 138 | of a new line. You can call this function in the semantic action 139 | of the rule that matches the end-of-line character. 140 | @since 3.11.0 141 | *) 142 | 143 | (** {1 Miscellaneous functions} *) 144 | 145 | val flush_input : lexbuf -> unit 146 | (** Discard the contents of the buffer and reset the current 147 | position to 0. The next use of the lexbuf will trigger a 148 | refill. *) 149 | 150 | (**/**) 151 | 152 | (** {1 } *) 153 | 154 | (** The following definitions are used by the generated scanners only. 155 | They are not intended to be used directly by user programs. *) 156 | 157 | val sub_lexeme : lexbuf -> int -> int -> string 158 | val sub_lexeme_opt : lexbuf -> int -> int -> string option 159 | val sub_lexeme_char : lexbuf -> int -> char 160 | val sub_lexeme_char_opt : lexbuf -> int -> char option 161 | 162 | type lex_tables = 163 | { lex_base : string; 164 | lex_backtrk : string; 165 | lex_default : string; 166 | lex_trans : string; 167 | lex_check : string; 168 | lex_base_code : string; 169 | lex_backtrk_code : string; 170 | lex_default_code : string; 171 | lex_trans_code : string; 172 | lex_check_code : string; 173 | lex_code: string;} 174 | 175 | val engine : lex_tables -> int -> lexbuf -> int 176 | val new_engine : lex_tables -> int -> lexbuf -> int 177 | -------------------------------------------------------------------------------- /miniml/interp/location.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | open Lexing 17 | 18 | let absname = ref false 19 | (* This reference should be in Clflags, but it would create an additional 20 | dependency and make bootstrapping Camlp4 more difficult. *) 21 | 22 | type t = { loc_start: position; loc_end: position; loc_ghost: bool };; 23 | 24 | let in_file name = 25 | let loc = { 26 | pos_fname = name; 27 | pos_lnum = 1; 28 | pos_bol = 0; 29 | pos_cnum = -1; 30 | } in 31 | { loc_start = loc; loc_end = loc; loc_ghost = true } 32 | ;; 33 | 34 | let none = in_file "_none_";; 35 | 36 | let curr lexbuf = { 37 | loc_start = lexbuf.lex_start_p; 38 | loc_end = lexbuf.lex_curr_p; 39 | loc_ghost = false 40 | };; 41 | 42 | let init lexbuf fname = 43 | lexbuf.lex_curr_p <- { 44 | pos_fname = fname; 45 | pos_lnum = 1; 46 | pos_bol = 0; 47 | pos_cnum = 0; 48 | } 49 | ;; 50 | 51 | let symbol_rloc () = { 52 | loc_start = Parsing.symbol_start_pos (); 53 | loc_end = Parsing.symbol_end_pos (); 54 | loc_ghost = false; 55 | };; 56 | 57 | let symbol_gloc () = { 58 | loc_start = Parsing.symbol_start_pos (); 59 | loc_end = Parsing.symbol_end_pos (); 60 | loc_ghost = true; 61 | };; 62 | 63 | let rhs_loc n = { 64 | loc_start = Parsing.rhs_start_pos n; 65 | loc_end = Parsing.rhs_end_pos n; 66 | loc_ghost = false; 67 | };; 68 | 69 | let input_name = ref "_none_" 70 | let input_lexbuf = ref (None : lexbuf option) 71 | 72 | 73 | let print_filename ppf file = 74 | Format.fprintf ppf "%s" file 75 | 76 | let msg_file = "File \"" 77 | let msg_line = "\", line " 78 | let msg_chars = ", characters " 79 | let msg_to = "-" 80 | let msg_colon = ":" 81 | 82 | (* return file, line, char from the given position *) 83 | let get_pos_info pos = 84 | (pos.pos_fname, pos.pos_lnum, pos.pos_cnum - pos.pos_bol) 85 | ;; 86 | 87 | let setup_colors () = () 88 | 89 | let print_loc ppf loc = 90 | let (file, line, startchar) = get_pos_info loc.loc_start in 91 | let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in 92 | Format.fprintf ppf "%s%a%s%d" msg_file print_filename file msg_line line; 93 | if startchar >= 0 then 94 | Format.fprintf ppf "%s%d%s%d" msg_chars startchar msg_to endchar 95 | 96 | let error_prefix = "Error" 97 | let warning_prefix = "Warning" 98 | 99 | let print_error ppf loc = 100 | Format.fprintf ppf "%a%s:" print_loc loc error_prefix 101 | 102 | let print_error_cur_file ppf () = print_error ppf (in_file !input_name);; 103 | 104 | let print_warning loc ppf w = () 105 | let prerr_warning loc w = () 106 | 107 | type 'a loc = { 108 | txt : 'a; 109 | loc : t; 110 | } 111 | 112 | let mkloc txt loc = { txt=txt ; loc=loc } 113 | let mknoloc txt = mkloc txt none 114 | 115 | let register_error_of_exn f = () 116 | let deprecated ?(def = none) ?(use = none) loc msg = () 117 | let error_of_printer loc print x = assert false 118 | -------------------------------------------------------------------------------- /miniml/interp/location.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (** Source code locations (ranges of positions), used in parsetree. *) 17 | 18 | open Format 19 | 20 | type t = { 21 | loc_start: Lexing.position; 22 | loc_end: Lexing.position; 23 | loc_ghost: bool; 24 | } 25 | 26 | (** Note on the use of Lexing.position in this module. 27 | If [pos_fname = ""], then use [!input_name] instead. 28 | If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and 29 | re-parse the file to get the line and character numbers. 30 | Else all fields are correct. 31 | *) 32 | 33 | val none : t 34 | (** An arbitrary value of type [t]; describes an empty ghost range. *) 35 | 36 | val in_file : string -> t 37 | (** Return an empty ghost range located in a given file. *) 38 | 39 | val init : Lexing.lexbuf -> string -> unit 40 | (** Set the file name and line number of the [lexbuf] to be the start 41 | of the named file. *) 42 | 43 | val curr : Lexing.lexbuf -> t 44 | (** Get the location of the current token from the [lexbuf]. *) 45 | 46 | val symbol_rloc: unit -> t 47 | val symbol_gloc: unit -> t 48 | 49 | (** [rhs_loc n] returns the location of the symbol at position [n], starting 50 | at 1, in the current parser rule. *) 51 | val rhs_loc: int -> t 52 | 53 | val input_name: string ref 54 | val input_lexbuf: Lexing.lexbuf option ref 55 | 56 | val get_pos_info: Lexing.position -> string * int * int (* file, line, char *) 57 | val print_loc: formatter -> t -> unit 58 | val print_error: formatter -> t -> unit 59 | val print_warning: t -> formatter -> Warnings.t -> unit 60 | val prerr_warning: t -> Warnings.t -> unit 61 | 62 | type 'a loc = { 63 | txt : 'a; 64 | loc : t; 65 | } 66 | 67 | val mknoloc : 'a -> 'a loc 68 | val mkloc : 'a -> t -> 'a loc 69 | 70 | val print_filename: formatter -> string -> unit 71 | 72 | val absname: bool ref 73 | 74 | val register_error_of_exn: (exn -> 'a option) -> unit 75 | (** Each compiler module which defines a custom type of exception 76 | which can surface as a user-visible error should register 77 | a "printer" for this exception using [register_error_of_exn]. 78 | The result of the printer is an [error] value containing 79 | a location, a message, and optionally sub-messages (each of them 80 | being located as well). *) 81 | 82 | val deprecated: ?def:t -> ?use:t -> t -> string -> unit 83 | 84 | val error_of_printer: t -> (formatter -> 'a -> unit) -> 'a -> 'b 85 | 86 | -------------------------------------------------------------------------------- /miniml/interp/longident.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | type t = 17 | Lident of string 18 | | Ldot of t * string 19 | | Lapply of t * t 20 | 21 | let rec flat accu = function 22 | Lident s -> s :: accu 23 | | Ldot(lid, s) -> flat (s :: accu) lid 24 | | Lapply(_, _) -> Misc.fatal_error "Longident.flat" 25 | 26 | let flatten lid = flat [] lid 27 | 28 | let last = function 29 | Lident s -> s 30 | | Ldot(_, s) -> s 31 | | Lapply(_, _) -> Misc.fatal_error "Longident.last" 32 | 33 | let rec split_at_dots s pos = 34 | try 35 | let dot = String.index_from s pos '.' in 36 | String.sub s pos (dot - pos) :: split_at_dots s (dot + 1) 37 | with Not_found -> 38 | [String.sub s pos (String.length s - pos)] 39 | 40 | let unflatten l = 41 | match l with 42 | | [] -> None 43 | | hd :: tl -> Some (List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl) 44 | 45 | let parse s = 46 | match unflatten (split_at_dots s 0) with 47 | | None -> Lident "" (* should not happen, but don't put assert false 48 | so as not to crash the toplevel (see Genprintval) *) 49 | | Some v -> v 50 | -------------------------------------------------------------------------------- /miniml/interp/longident.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (** Long identifiers, used in parsetree. *) 17 | 18 | type t = 19 | Lident of string 20 | | Ldot of t * string 21 | | Lapply of t * t 22 | 23 | val flatten: t -> string list 24 | val unflatten: string list -> t option 25 | val last: t -> string 26 | val parse: string -> t 27 | -------------------------------------------------------------------------------- /miniml/interp/make_opcodes.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | r=$(dirname $0) 3 | root=$r/../.. 4 | $root/ocaml-src/byterun/ocamlrun $r/make_opcodes.byte "$@" -------------------------------------------------------------------------------- /miniml/interp/marshal.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1997 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | type extern_flags = 17 | No_sharing 18 | | Closures 19 | | Compat_32 20 | (* note: this type definition is used in 'byterun/debugger.c' *) 21 | 22 | external to_channel: out_channel -> 'a -> extern_flags list -> unit 23 | = "caml_output_value" 24 | external to_bytes: 'a -> extern_flags list -> bytes 25 | = "caml_output_value_to_bytes" 26 | external to_string: 'a -> extern_flags list -> string 27 | = "caml_output_value_to_string" 28 | external to_buffer_unsafe: 29 | bytes -> int -> int -> 'a -> extern_flags list -> int 30 | = "caml_output_value_to_buffer" 31 | 32 | let to_buffer buff ofs len v flags = 33 | if ofs < 0 || len < 0 || ofs > Bytes.length buff - len 34 | then invalid_arg "Marshal.to_buffer: substring out of bounds" 35 | else to_buffer_unsafe buff ofs len v flags 36 | 37 | (* The functions below use byte sequences as input, never using any 38 | mutation. It makes sense to use non-mutated [bytes] rather than 39 | [string], because we really work with sequences of bytes, not 40 | a text representation. 41 | *) 42 | 43 | external from_channel: in_channel -> 'a = "caml_input_value" 44 | external from_bytes_unsafe: bytes -> int -> 'a = "caml_input_value_from_bytes" 45 | external data_size_unsafe: bytes -> int -> int = "caml_marshal_data_size" 46 | 47 | let header_size = 20 48 | let data_size buff ofs = 49 | if ofs < 0 || ofs > Bytes.length buff - header_size 50 | then invalid_arg "Marshal.data_size" 51 | else data_size_unsafe buff ofs 52 | let total_size buff ofs = header_size + data_size buff ofs 53 | 54 | let from_bytes buff ofs = 55 | if ofs < 0 || ofs > Bytes.length buff - header_size 56 | then invalid_arg "Marshal.from_bytes" 57 | else begin 58 | let len = data_size_unsafe buff ofs in 59 | if ofs > Bytes.length buff - (header_size + len) 60 | then invalid_arg "Marshal.from_bytes" 61 | else from_bytes_unsafe buff ofs 62 | end 63 | 64 | let from_string buff ofs = 65 | (* Bytes.unsafe_of_string is safe here, as the produced byte 66 | sequence is never mutated *) 67 | from_bytes (Bytes.unsafe_of_string buff) ofs 68 | -------------------------------------------------------------------------------- /miniml/interp/misc.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (* Errors *) 17 | 18 | exception Fatal_error 19 | 20 | let fatal_error msg = raise Fatal_error 21 | 22 | let create_hashtable size init = 23 | let tbl = Hashtbl.create size in 24 | List.iter (fun (key, data) -> Hashtbl.add tbl key data) init; 25 | tbl 26 | 27 | let may f = function Some x -> f x | None -> () 28 | -------------------------------------------------------------------------------- /miniml/interp/misc.mli: -------------------------------------------------------------------------------- 1 | exception Fatal_error 2 | val fatal_error : 'a -> 'b 3 | val create_hashtable : int -> ('a * 'b) list -> ('a, 'b) Hashtbl.t 4 | val may : ('a -> unit) -> 'a option -> unit 5 | -------------------------------------------------------------------------------- /miniml/interp/nativeint.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (* Module [Nativeint]: processor-native integers *) 17 | 18 | external neg: nativeint -> nativeint = "%nativeint_neg" 19 | external add: nativeint -> nativeint -> nativeint = "%nativeint_add" 20 | external sub: nativeint -> nativeint -> nativeint = "%nativeint_sub" 21 | external mul: nativeint -> nativeint -> nativeint = "%nativeint_mul" 22 | external div: nativeint -> nativeint -> nativeint = "%nativeint_div" 23 | external rem: nativeint -> nativeint -> nativeint = "%nativeint_mod" 24 | external logand: nativeint -> nativeint -> nativeint = "%nativeint_and" 25 | external logor: nativeint -> nativeint -> nativeint = "%nativeint_or" 26 | external logxor: nativeint -> nativeint -> nativeint = "%nativeint_xor" 27 | external shift_left: nativeint -> int -> nativeint = "%nativeint_lsl" 28 | external shift_right: nativeint -> int -> nativeint = "%nativeint_asr" 29 | external shift_right_logical: nativeint -> int -> nativeint = "%nativeint_lsr" 30 | external of_int: int -> nativeint = "%nativeint_of_int" 31 | external to_int: nativeint -> int = "%nativeint_to_int" 32 | external of_float : float -> nativeint 33 | = "caml_nativeint_of_float" "caml_nativeint_of_float_unboxed" 34 | [@@unboxed] [@@noalloc] 35 | external to_float : nativeint -> float 36 | = "caml_nativeint_to_float" "caml_nativeint_to_float_unboxed" 37 | [@@unboxed] [@@noalloc] 38 | external of_int32: int32 -> nativeint = "%nativeint_of_int32" 39 | external to_int32: nativeint -> int32 = "%nativeint_to_int32" 40 | 41 | let zero = 0n 42 | let one = 1n 43 | let minus_one = -1n 44 | let succ n = add n 1n 45 | let pred n = sub n 1n 46 | let abs n = if n >= 0n then n else neg n 47 | let size = Sys.word_size 48 | let min_int = shift_left 1n (size - 1) 49 | let max_int = sub min_int 1n 50 | let lognot n = logxor n (-1n) 51 | 52 | external format : string -> nativeint -> string = "caml_nativeint_format" 53 | let to_string n = format "%d" n 54 | 55 | external of_string: string -> nativeint = "caml_nativeint_of_string" 56 | 57 | let of_string_opt s = 58 | (* TODO: expose a non-raising primitive directly. *) 59 | try Some (of_string s) 60 | with Failure _ -> None 61 | 62 | type t = nativeint 63 | 64 | let compare (x: t) (y: t) = Pervasives.compare x y 65 | let equal (x: t) (y: t) = compare x y = 0 66 | -------------------------------------------------------------------------------- /miniml/interp/parse.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (* Entry points in the parser *) 17 | 18 | (* Skip tokens to the end of the phrase *) 19 | 20 | let rec skip_phrase lexbuf = 21 | try 22 | match Lexer.token lexbuf with 23 | Parser.SEMISEMI | Parser.EOF -> () 24 | | _ -> skip_phrase lexbuf 25 | with 26 | | Lexer.Error (Lexer.Unterminated_comment _, _) 27 | | Lexer.Error (Lexer.Unterminated_string, _) 28 | | Lexer.Error (Lexer.Unterminated_string_in_comment _, _) 29 | | Lexer.Error (Lexer.Illegal_character _, _) -> skip_phrase lexbuf 30 | ;; 31 | 32 | let maybe_skip_phrase lexbuf = 33 | if Parsing.is_current_lookahead Parser.SEMISEMI 34 | || Parsing.is_current_lookahead Parser.EOF 35 | then () 36 | else skip_phrase lexbuf 37 | 38 | let wrap parsing_fun lexbuf = 39 | try 40 | Docstrings.init (); 41 | Lexer.init (); 42 | let ast = parsing_fun Lexer.token lexbuf in 43 | Parsing.clear_parser(); 44 | Docstrings.warn_bad_docstrings (); 45 | ast 46 | with 47 | | Lexer.Error(Lexer.Illegal_character _, _) as err 48 | when !Location.input_name = "//toplevel//"-> 49 | skip_phrase lexbuf; 50 | raise err 51 | | Syntaxerr.Error _ as err 52 | when !Location.input_name = "//toplevel//" -> 53 | maybe_skip_phrase lexbuf; 54 | raise err 55 | | Parsing.Parse_error | Syntaxerr.Escape_error -> 56 | let loc = Location.curr lexbuf in 57 | if !Location.input_name = "//toplevel//" 58 | then maybe_skip_phrase lexbuf; 59 | raise(Syntaxerr.Error(Syntaxerr.Other loc)) 60 | 61 | let implementation = wrap Parser.implementation 62 | and interface = wrap Parser.interface 63 | and toplevel_phrase = wrap Parser.toplevel_phrase 64 | and use_file = wrap Parser.use_file 65 | and core_type = wrap Parser.parse_core_type 66 | and expression = wrap Parser.parse_expression 67 | and pattern = wrap Parser.parse_pattern 68 | -------------------------------------------------------------------------------- /miniml/interp/parse.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (** Entry points in the parser *) 17 | 18 | val implementation : Lexing.lexbuf -> Parsetree.structure 19 | val interface : Lexing.lexbuf -> Parsetree.signature 20 | val toplevel_phrase : Lexing.lexbuf -> Parsetree.toplevel_phrase 21 | val use_file : Lexing.lexbuf -> Parsetree.toplevel_phrase list 22 | val core_type : Lexing.lexbuf -> Parsetree.core_type 23 | val expression : Lexing.lexbuf -> Parsetree.expression 24 | val pattern : Lexing.lexbuf -> Parsetree.pattern 25 | -------------------------------------------------------------------------------- /miniml/interp/parsing.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (** The run-time library for parsers generated by [ocamlyacc]. *) 17 | 18 | val symbol_start : unit -> int 19 | (** [symbol_start] and {!Parsing.symbol_end} are to be called in the 20 | action part of a grammar rule only. They return the offset of the 21 | string that matches the left-hand side of the rule: [symbol_start()] 22 | returns the offset of the first character; [symbol_end()] returns the 23 | offset after the last character. The first character in a file is at 24 | offset 0. *) 25 | 26 | val symbol_end : unit -> int 27 | (** See {!Parsing.symbol_start}. *) 28 | 29 | val rhs_start : int -> int 30 | (** Same as {!Parsing.symbol_start} and {!Parsing.symbol_end}, but 31 | return the offset of the string matching the [n]th item on the 32 | right-hand side of the rule, where [n] is the integer parameter 33 | to [rhs_start] and [rhs_end]. [n] is 1 for the leftmost item. *) 34 | 35 | val rhs_end : int -> int 36 | (** See {!Parsing.rhs_start}. *) 37 | 38 | val symbol_start_pos : unit -> Lexing.position 39 | (** Same as [symbol_start], but return a [position] instead of an offset. *) 40 | 41 | val symbol_end_pos : unit -> Lexing.position 42 | (** Same as [symbol_end], but return a [position] instead of an offset. *) 43 | 44 | val rhs_start_pos : int -> Lexing.position 45 | (** Same as [rhs_start], but return a [position] instead of an offset. *) 46 | 47 | val rhs_end_pos : int -> Lexing.position 48 | (** Same as [rhs_end], but return a [position] instead of an offset. *) 49 | 50 | val clear_parser : unit -> unit 51 | (** Empty the parser stack. Call it just after a parsing function 52 | has returned, to remove all pointers from the parser stack 53 | to structures that were built by semantic actions during parsing. 54 | This is optional, but lowers the memory requirements of the 55 | programs. *) 56 | 57 | exception Parse_error 58 | (** Raised when a parser encounters a syntax error. 59 | Can also be raised from the action part of a grammar rule, 60 | to initiate error recovery. *) 61 | 62 | val set_trace: bool -> bool 63 | (** Control debugging support for [ocamlyacc]-generated parsers. 64 | After [Parsing.set_trace true], the pushdown automaton that 65 | executes the parsers prints a trace of its actions (reading a token, 66 | shifting a state, reducing by a rule) on standard output. 67 | [Parsing.set_trace false] turns this debugging trace off. 68 | The boolean returned is the previous state of the trace flag. 69 | @since 3.11.0 70 | *) 71 | 72 | (**/**) 73 | 74 | (** {1 } *) 75 | 76 | (** The following definitions are used by the generated parsers only. 77 | They are not intended to be used directly by user programs. *) 78 | 79 | type parser_env 80 | 81 | type parse_tables = 82 | { actions : (parser_env -> Obj.t) array; 83 | transl_const : int array; 84 | transl_block : int array; 85 | lhs : string; 86 | len : string; 87 | defred : string; 88 | dgoto : string; 89 | sindex : string; 90 | rindex : string; 91 | gindex : string; 92 | tablesize : int; 93 | table : string; 94 | check : string; 95 | error_function : string -> unit; 96 | names_const : string; 97 | names_block : string } 98 | 99 | exception YYexit of Obj.t 100 | 101 | val yyparse : 102 | parse_tables -> int -> (Lexing.lexbuf -> 'a) -> Lexing.lexbuf -> 'b 103 | val peek_val : parser_env -> int -> 'a 104 | val is_current_lookahead : 'a -> bool 105 | val parse_error : string -> unit 106 | -------------------------------------------------------------------------------- /miniml/interp/printf.ml: -------------------------------------------------------------------------------- 1 | let getff ff = ff.Format.out_string 2 | let getoc oc = output_string oc 3 | 4 | let printf fmt = Format.(mkprintf false getoc stdout fmt (fun () -> ())) 5 | let fprintf ff fmt = Format.(mkprintf false getoc ff fmt (fun () -> ())) 6 | let eprintf fmt = Format.(mkprintf false getoc stderr fmt (fun () -> ())) 7 | 8 | let kbprintf k b fmt = Format.(mkprintf false getff { out_string = Buffer.add_string b } fmt (fun () -> k b)) 9 | let bprintf b fmt = kbprintf (fun _ -> ()) b fmt 10 | let kprintf k fmt = kbprintf (fun b -> k (Buffer.contents b)) (Buffer.create 16) fmt 11 | let ksprintf = kprintf 12 | let kasprintf = kprintf 13 | let sprintf fmt = kprintf (fun s -> s) fmt 14 | -------------------------------------------------------------------------------- /miniml/interp/printf.mli: -------------------------------------------------------------------------------- 1 | val printf : string -> 'a 2 | val fprintf : out_channel -> string -> 'a 3 | val eprintf : string -> 'a 4 | val kbprintf : (Buffer.t -> 'a) -> Buffer.t -> string -> 'b 5 | val bprintf : Buffer.t -> string -> 'a 6 | val kprintf : (string -> 'a) -> string -> 'b 7 | val ksprintf : (string -> 'a) -> string -> 'b 8 | val kasprintf : (string -> 'a) -> string -> 'b 9 | val sprintf : string -> 'a 10 | -------------------------------------------------------------------------------- /miniml/interp/seq.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Simon Cruanes *) 6 | (* *) 7 | (* Copyright 2017 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (* Module [Seq]: functional iterators *) 17 | 18 | type +'a node = 19 | | Nil 20 | | Cons of 'a * 'a t 21 | 22 | and 'a t = unit -> 'a node 23 | 24 | let empty () = Nil 25 | 26 | let return x () = Cons (x, empty) 27 | 28 | let rec map f seq () = match seq() with 29 | | Nil -> Nil 30 | | Cons (x, next) -> Cons (f x, map f next) 31 | 32 | let rec filter_map f seq () = match seq() with 33 | | Nil -> Nil 34 | | Cons (x, next) -> 35 | match f x with 36 | | None -> filter_map f next () 37 | | Some y -> Cons (y, filter_map f next) 38 | 39 | let rec filter f seq () = match seq() with 40 | | Nil -> Nil 41 | | Cons (x, next) -> 42 | if f x 43 | then Cons (x, filter f next) 44 | else filter f next () 45 | 46 | let rec flat_map f seq () = match seq () with 47 | | Nil -> Nil 48 | | Cons (x, next) -> 49 | flat_map_app f (f x) next () 50 | 51 | (* this is [append seq (flat_map f tail)] *) 52 | and flat_map_app f seq tail () = match seq () with 53 | | Nil -> flat_map f tail () 54 | | Cons (x, next) -> 55 | Cons (x, flat_map_app f next tail) 56 | 57 | let fold_left f acc seq = 58 | let rec aux f acc seq = match seq () with 59 | | Nil -> acc 60 | | Cons (x, next) -> 61 | let acc = f acc x in 62 | aux f acc next 63 | in 64 | aux f acc seq 65 | 66 | let iter f seq = 67 | let rec aux seq = match seq () with 68 | | Nil -> () 69 | | Cons (x, next) -> 70 | f x; 71 | aux next 72 | in 73 | aux seq 74 | -------------------------------------------------------------------------------- /miniml/interp/seq.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Simon Cruanes *) 6 | (* *) 7 | (* Copyright 2017 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (* Module [Seq]: functional iterators *) 17 | 18 | (** {1 Functional Iterators} *) 19 | 20 | (** The type ['a t] is a {b delayed list}, i.e. a list where some evaluation 21 | is needed to access the next element. This makes it possible to build 22 | infinite sequences, to build sequences as we traverse them, and to transform 23 | them in a lazy fashion rather than upfront. 24 | *) 25 | 26 | (** @since 4.07 *) 27 | 28 | type 'a t = unit -> 'a node 29 | (** The type of delayed lists containing elements of type ['a]. 30 | Note that the concrete list node ['a node] is delayed under a closure, 31 | not a [lazy] block, which means it might be recomputed every time 32 | we access it. *) 33 | 34 | and +'a node = 35 | | Nil 36 | | Cons of 'a * 'a t 37 | (** A fully-evaluated list node, either empty or containing an element 38 | and a delayed tail. *) 39 | 40 | val empty : 'a t 41 | (** The empty sequence, containing no elements. *) 42 | 43 | val return : 'a -> 'a t 44 | (** The singleton sequence containing only the given element. *) 45 | 46 | val map : ('a -> 'b) -> 'a t -> 'b t 47 | (** [map f seq] returns a new sequence whose elements are the elements of 48 | [seq], transformed by [f]. 49 | This transformation is lazy, it only applies when the result is traversed. 50 | 51 | If [seq = [1;2;3]], then [map f seq = [f 1; f 2; f 3]]. *) 52 | 53 | val filter : ('a -> bool) -> 'a t -> 'a t 54 | (** Remove from the sequence the elements that do not satisfy the 55 | given predicate. 56 | This transformation is lazy, it only applies when the result is traversed. *) 57 | 58 | val filter_map : ('a -> 'b option) -> 'a t -> 'b t 59 | (** Apply the function to every element; if [f x = None] then [x] is dropped; 60 | if [f x = Some y] then [y] is returned. 61 | This transformation is lazy, it only applies when the result is traversed. *) 62 | 63 | val flat_map : ('a -> 'b t) -> 'a t -> 'b t 64 | (** Map each element to a subsequence, then return each element of this 65 | sub-sequence in turn. 66 | This transformation is lazy, it only applies when the result is traversed. *) 67 | 68 | val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a 69 | (** Traverse the sequence from left to right, combining each element with the 70 | accumulator using the given function. 71 | The traversal happens immediately and will not terminate on infinite sequences. 72 | 73 | Also see {!List.fold_left} *) 74 | 75 | val iter : ('a -> unit) -> 'a t -> unit 76 | (** Iterate on the sequence, calling the (imperative) function on every element. 77 | The traversal happens immediately and will not terminate on infinite sequences. *) 78 | -------------------------------------------------------------------------------- /miniml/interp/stack.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | type 'a t = { mutable c : 'a list; mutable len : int; } 17 | 18 | exception Empty 19 | 20 | let create () = { c = []; len = 0; } 21 | 22 | let clear s = s.c <- []; s.len <- 0 23 | 24 | let copy s = { c = s.c; len = s.len; } 25 | 26 | let push x s = s.c <- x :: s.c; s.len <- s.len + 1 27 | 28 | let pop s = 29 | match s.c with 30 | | hd::tl -> s.c <- tl; s.len <- s.len - 1; hd 31 | | [] -> raise Empty 32 | 33 | let top s = 34 | match s.c with 35 | | hd::_ -> hd 36 | | [] -> raise Empty 37 | 38 | let is_empty s = (s.c = []) 39 | 40 | let length s = s.len 41 | 42 | let iter f s = List.iter f s.c 43 | 44 | let fold f acc s = List.fold_left f acc s.c 45 | 46 | (** {6 Iterators} *) 47 | 48 | let to_seq s = List.to_seq s.c 49 | 50 | let add_seq q i = Seq.iter (fun x -> push x q) i 51 | 52 | let of_seq g = 53 | let s = create() in 54 | add_seq s g; 55 | s 56 | 57 | -------------------------------------------------------------------------------- /miniml/interp/stack.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (** Last-in first-out stacks. 17 | 18 | This module implements stacks (LIFOs), with in-place modification. 19 | *) 20 | 21 | type 'a t 22 | (** The type of stacks containing elements of type ['a]. *) 23 | 24 | exception Empty 25 | (** Raised when {!Stack.pop} or {!Stack.top} is applied to an empty stack. *) 26 | 27 | 28 | val create : unit -> 'a t 29 | (** Return a new stack, initially empty. *) 30 | 31 | val push : 'a -> 'a t -> unit 32 | (** [push x s] adds the element [x] at the top of stack [s]. *) 33 | 34 | val pop : 'a t -> 'a 35 | (** [pop s] removes and returns the topmost element in stack [s], 36 | or raises {!Empty} if the stack is empty. *) 37 | 38 | val top : 'a t -> 'a 39 | (** [top s] returns the topmost element in stack [s], 40 | or raises {!Empty} if the stack is empty. *) 41 | 42 | val clear : 'a t -> unit 43 | (** Discard all elements from a stack. *) 44 | 45 | val copy : 'a t -> 'a t 46 | (** Return a copy of the given stack. *) 47 | 48 | val is_empty : 'a t -> bool 49 | (** Return [true] if the given stack is empty, [false] otherwise. *) 50 | 51 | val length : 'a t -> int 52 | (** Return the number of elements in a stack. Time complexity O(1) *) 53 | 54 | val iter : ('a -> unit) -> 'a t -> unit 55 | (** [iter f s] applies [f] in turn to all elements of [s], 56 | from the element at the top of the stack to the element at the 57 | bottom of the stack. The stack itself is unchanged. *) 58 | 59 | val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b 60 | (** [fold f accu s] is [(f (... (f (f accu x1) x2) ...) xn)] 61 | where [x1] is the top of the stack, [x2] the second element, 62 | and [xn] the bottom element. The stack is unchanged. 63 | @since 4.03 *) 64 | 65 | (** {6 Iterators} *) 66 | 67 | val to_seq : 'a t -> 'a Seq.t 68 | (** Iterate on the stack, top to bottom. 69 | It is safe to modify the stack during iteration. 70 | @since 4.07 *) 71 | 72 | val add_seq : 'a t -> 'a Seq.t -> unit 73 | (** Add the elements from the iterator on the top of the stack. 74 | @since 4.07 *) 75 | 76 | val of_seq : 'a Seq.t -> 'a t 77 | (** Create a stack from the iterator 78 | @since 4.07 *) 79 | 80 | -------------------------------------------------------------------------------- /miniml/interp/std_miniml.ml: -------------------------------------------------------------------------------- 1 | let assert b = if b = 0 then raise (Assert_failure ("", 0, 0)) 2 | 3 | let lazy x = x 4 | module Lazy = struct 5 | let force x = x 6 | end 7 | -------------------------------------------------------------------------------- /miniml/interp/std_miniml_prefix.ml: -------------------------------------------------------------------------------- 1 | type bool = false | true 2 | type 'a option = None | Some of 'a 3 | -------------------------------------------------------------------------------- /miniml/interp/std_opt_prefix.ml: -------------------------------------------------------------------------------- 1 | external ( || ) : bool -> bool -> bool = "%sequor" 2 | external ( && ) : bool -> bool -> bool = "%sequand" 3 | external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply" 4 | external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" 5 | -------------------------------------------------------------------------------- /miniml/interp/std_opt_prefix.mli: -------------------------------------------------------------------------------- 1 | external ( || ) : bool -> bool -> bool = "%sequor" 2 | external ( && ) : bool -> bool -> bool = "%sequand" 3 | external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply" 4 | external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" 5 | -------------------------------------------------------------------------------- /miniml/interp/syntaxerr.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1997 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (* Auxiliary type for reporting syntax errors *) 17 | 18 | type error = 19 | Unclosed of Location.t * string * Location.t * string 20 | | Expecting of Location.t * string 21 | | Not_expecting of Location.t * string 22 | | Applicative_path of Location.t 23 | | Variable_in_scope of Location.t * string 24 | | Other of Location.t 25 | | Ill_formed_ast of Location.t * string 26 | | Invalid_package_type of Location.t * string 27 | 28 | exception Error of error 29 | exception Escape_error 30 | 31 | let prepare_error err = assert false 32 | let report_error ppf err = assert false 33 | let location_of_error err = assert false 34 | let ill_formed_ast loc s = assert false 35 | -------------------------------------------------------------------------------- /miniml/interp/syntaxerr.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1997 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (** Auxiliary type for reporting syntax errors *) 17 | 18 | open Format 19 | 20 | type error = 21 | Unclosed of Location.t * string * Location.t * string 22 | | Expecting of Location.t * string 23 | | Not_expecting of Location.t * string 24 | | Applicative_path of Location.t 25 | | Variable_in_scope of Location.t * string 26 | | Other of Location.t 27 | | Ill_formed_ast of Location.t * string 28 | | Invalid_package_type of Location.t * string 29 | 30 | exception Error of error 31 | exception Escape_error 32 | 33 | val report_error: formatter -> error -> unit 34 | (** @deprecated Use {!Location.error_of_exn}, {!Location.report_error}. *) 35 | 36 | val location_of_error: error -> Location.t 37 | val ill_formed_ast: Location.t -> string -> 'a 38 | -------------------------------------------------------------------------------- /miniml/interp/warnings.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Pierre Weis && Damien Doligez, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1998 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (* When you change this, you need to update the documentation: 17 | - man/ocamlc.m 18 | - man/ocamlopt.m 19 | - manual/manual/cmds/comp.etex 20 | - manual/manual/cmds/native.etex 21 | *) 22 | 23 | type loc = { 24 | loc_start: Lexing.position; 25 | loc_end: Lexing.position; 26 | loc_ghost: bool; 27 | } 28 | 29 | type t = 30 | | Comment_start (* 1 *) 31 | | Comment_not_end (* 2 *) 32 | | Deprecated of string * loc * loc (* 3 *) 33 | | Fragile_match of string (* 4 *) 34 | | Partial_application (* 5 *) 35 | | Labels_omitted of string list (* 6 *) 36 | | Method_override of string list (* 7 *) 37 | | Partial_match of string (* 8 *) 38 | | Non_closed_record_pattern of string (* 9 *) 39 | | Statement_type (* 10 *) 40 | | Unused_match (* 11 *) 41 | | Unused_pat (* 12 *) 42 | | Instance_variable_override of string list (* 13 *) 43 | | Illegal_backslash (* 14 *) 44 | | Implicit_public_methods of string list (* 15 *) 45 | | Unerasable_optional_argument (* 16 *) 46 | | Undeclared_virtual_method of string (* 17 *) 47 | | Not_principal of string (* 18 *) 48 | | Without_principality of string (* 19 *) 49 | | Unused_argument (* 20 *) 50 | | Nonreturning_statement (* 21 *) 51 | | Preprocessor of string (* 22 *) 52 | | Useless_record_with (* 23 *) 53 | | Bad_module_name of string (* 24 *) 54 | | All_clauses_guarded (* 8, used to be 25 *) 55 | | Unused_var of string (* 26 *) 56 | | Unused_var_strict of string (* 27 *) 57 | | Wildcard_arg_to_constant_constr (* 28 *) 58 | | Eol_in_string (* 29 *) 59 | | Duplicate_definitions of string * string * string * string (*30 *) 60 | | Multiple_definition of string * string * string (* 31 *) 61 | | Unused_value_declaration of string (* 32 *) 62 | | Unused_open of string (* 33 *) 63 | | Unused_type_declaration of string (* 34 *) 64 | | Unused_for_index of string (* 35 *) 65 | | Unused_ancestor of string (* 36 *) 66 | | Unused_constructor of string * bool * bool (* 37 *) 67 | | Unused_extension of string * bool * bool * bool (* 38 *) 68 | | Unused_rec_flag (* 39 *) 69 | | Name_out_of_scope of string * string list * bool (* 40 *) 70 | | Ambiguous_name of string list * string list * bool (* 41 *) 71 | | Disambiguated_name of string (* 42 *) 72 | | Nonoptional_label of string (* 43 *) 73 | | Open_shadow_identifier of string * string (* 44 *) 74 | | Open_shadow_label_constructor of string * string (* 45 *) 75 | | Bad_env_variable of string * string (* 46 *) 76 | | Attribute_payload of string * string (* 47 *) 77 | | Eliminated_optional_arguments of string list (* 48 *) 78 | | No_cmi_file of string * string option (* 49 *) 79 | | Bad_docstring of bool (* 50 *) 80 | | Expect_tailcall (* 51 *) 81 | | Fragile_literal_pattern (* 52 *) 82 | | Misplaced_attribute of string (* 53 *) 83 | | Duplicated_attribute of string (* 54 *) 84 | | Inlining_impossible of string (* 55 *) 85 | | Unreachable_case (* 56 *) 86 | | Ambiguous_pattern of string list (* 57 *) 87 | | No_cmx_file of string (* 58 *) 88 | | Assignment_to_non_mutable_value (* 59 *) 89 | | Unused_module of string (* 60 *) 90 | | Unboxable_type_in_prim_decl of string (* 61 *) 91 | | Constraint_on_gadt (* 62 *) 92 | ;; 93 | 94 | (* If you remove a warning, leave a hole in the numbering. NEVER change 95 | the numbers of existing warnings. 96 | If you add a new warning, add it at the end with a new number; 97 | do NOT reuse one of the holes. 98 | *) 99 | 100 | 101 | let is_active x = false 102 | let is_error x = false 103 | -------------------------------------------------------------------------------- /miniml/interp/warnings.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Pierre Weis && Damien Doligez, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1998 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | type loc = { 17 | loc_start: Lexing.position; 18 | loc_end: Lexing.position; 19 | loc_ghost: bool; 20 | } 21 | 22 | type t = 23 | | Comment_start (* 1 *) 24 | | Comment_not_end (* 2 *) 25 | | Deprecated of string * loc * loc (* 3 *) 26 | | Fragile_match of string (* 4 *) 27 | | Partial_application (* 5 *) 28 | | Labels_omitted of string list (* 6 *) 29 | | Method_override of string list (* 7 *) 30 | | Partial_match of string (* 8 *) 31 | | Non_closed_record_pattern of string (* 9 *) 32 | | Statement_type (* 10 *) 33 | | Unused_match (* 11 *) 34 | | Unused_pat (* 12 *) 35 | | Instance_variable_override of string list (* 13 *) 36 | | Illegal_backslash (* 14 *) 37 | | Implicit_public_methods of string list (* 15 *) 38 | | Unerasable_optional_argument (* 16 *) 39 | | Undeclared_virtual_method of string (* 17 *) 40 | | Not_principal of string (* 18 *) 41 | | Without_principality of string (* 19 *) 42 | | Unused_argument (* 20 *) 43 | | Nonreturning_statement (* 21 *) 44 | | Preprocessor of string (* 22 *) 45 | | Useless_record_with (* 23 *) 46 | | Bad_module_name of string (* 24 *) 47 | | All_clauses_guarded (* 8, used to be 25 *) 48 | | Unused_var of string (* 26 *) 49 | | Unused_var_strict of string (* 27 *) 50 | | Wildcard_arg_to_constant_constr (* 28 *) 51 | | Eol_in_string (* 29 *) 52 | | Duplicate_definitions of string * string * string * string (* 30 *) 53 | | Multiple_definition of string * string * string (* 31 *) 54 | | Unused_value_declaration of string (* 32 *) 55 | | Unused_open of string (* 33 *) 56 | | Unused_type_declaration of string (* 34 *) 57 | | Unused_for_index of string (* 35 *) 58 | | Unused_ancestor of string (* 36 *) 59 | | Unused_constructor of string * bool * bool (* 37 *) 60 | | Unused_extension of string * bool * bool * bool (* 38 *) 61 | | Unused_rec_flag (* 39 *) 62 | | Name_out_of_scope of string * string list * bool (* 40 *) 63 | | Ambiguous_name of string list * string list * bool (* 41 *) 64 | | Disambiguated_name of string (* 42 *) 65 | | Nonoptional_label of string (* 43 *) 66 | | Open_shadow_identifier of string * string (* 44 *) 67 | | Open_shadow_label_constructor of string * string (* 45 *) 68 | | Bad_env_variable of string * string (* 46 *) 69 | | Attribute_payload of string * string (* 47 *) 70 | | Eliminated_optional_arguments of string list (* 48 *) 71 | | No_cmi_file of string * string option (* 49 *) 72 | | Bad_docstring of bool (* 50 *) 73 | | Expect_tailcall (* 51 *) 74 | | Fragile_literal_pattern (* 52 *) 75 | | Misplaced_attribute of string (* 53 *) 76 | | Duplicated_attribute of string (* 54 *) 77 | | Inlining_impossible of string (* 55 *) 78 | | Unreachable_case (* 56 *) 79 | | Ambiguous_pattern of string list (* 57 *) 80 | | No_cmx_file of string (* 58 *) 81 | | Assignment_to_non_mutable_value (* 59 *) 82 | | Unused_module of string (* 60 *) 83 | | Unboxable_type_in_prim_decl of string (* 61 *) 84 | | Constraint_on_gadt (* 62 *) 85 | ;; 86 | 87 | val is_active : t -> bool;; 88 | val is_error : t -> bool;; 89 | -------------------------------------------------------------------------------- /patches/compflags.patch: -------------------------------------------------------------------------------- 1 | 19,20c19 2 | < echo ' -nopervasives -no-alias-deps -w -49' \ 3 | < ' -pp "$AWK -f ./expand_module_aliases.awk"';; 4 | --- 5 | > echo ' -nopervasives -no-alias-deps -w -49';; 6 | -------------------------------------------------------------------------------- /patches/disable-profiling.patch: -------------------------------------------------------------------------------- 1 | 99c99 2 | < 3 | --- 4 | > let record_call ?(accumulate = false) name f = f () 5 | -------------------------------------------------------------------------------- /patches/parsetree.patch: -------------------------------------------------------------------------------- 1 | 31c31 2 | < {delim|other constant|delim} 3 | --- 4 | > 5 | -------------------------------------------------------------------------------- /timed.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | r=$(dirname $0) 4 | echo >> "$r/timings" 5 | echo "$@" >> "$r/timings" 6 | { time { "$@" 2>&3; }; } 3>&2 2>> "$r/timings" 7 | --------------------------------------------------------------------------------