Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'trunk' of github.com:ocaml/ocaml into trunk

master
Jacques Garrigue 2017-06-12 23:17:58 +09:00
parent 02c4df6dee 996737eb58
commit 75812f5939
136 changed files with 3229 additions and 1897 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

141
.depend
View File

@ -6,11 +6,11 @@ utils/ccomp.cmo : utils/misc.cmi utils/config.cmi utils/clflags.cmi \
utils/ccomp.cmx : utils/misc.cmx utils/config.cmx utils/clflags.cmx \
utils/ccomp.cmi
utils/ccomp.cmi :
utils/clflags.cmo : utils/numbers.cmi utils/misc.cmi utils/config.cmi \
utils/arg_helper.cmi utils/clflags.cmi
utils/clflags.cmx : utils/numbers.cmx utils/misc.cmx utils/config.cmx \
utils/arg_helper.cmx utils/clflags.cmi
utils/clflags.cmi : utils/misc.cmi
utils/clflags.cmo : utils/profile.cmi utils/numbers.cmi utils/misc.cmi \
utils/config.cmi utils/arg_helper.cmi utils/clflags.cmi
utils/clflags.cmx : utils/profile.cmx utils/numbers.cmx utils/misc.cmx \
utils/config.cmx utils/arg_helper.cmx utils/clflags.cmi
utils/clflags.cmi : utils/profile.cmi utils/misc.cmi
utils/config.cmo : utils/config.cmi
utils/config.cmx : utils/config.cmi
utils/config.cmi :
@ -40,9 +40,9 @@ utils/tbl.cmi :
utils/terminfo.cmo : utils/terminfo.cmi
utils/terminfo.cmx : utils/terminfo.cmi
utils/terminfo.cmi :
utils/timings.cmo : utils/misc.cmi utils/timings.cmi
utils/timings.cmx : utils/misc.cmx utils/timings.cmi
utils/timings.cmi :
utils/profile.cmo : utils/misc.cmi utils/profile.cmi
utils/profile.cmx : utils/misc.cmx utils/profile.cmi
utils/profile.cmi :
utils/warnings.cmo : utils/misc.cmi utils/warnings.cmi
utils/warnings.cmx : utils/misc.cmx utils/warnings.cmi
utils/warnings.cmi :
@ -231,13 +231,13 @@ typing/includemod.cmo : typing/types.cmi typing/typedtree.cmi utils/tbl.cmi \
typing/mtype.cmi utils/misc.cmi parsing/location.cmi \
typing/includecore.cmi typing/includeclass.cmi typing/ident.cmi \
typing/env.cmi typing/ctype.cmi typing/cmt_format.cmi utils/clflags.cmi \
typing/btype.cmi typing/includemod.cmi
parsing/builtin_attributes.cmi typing/btype.cmi typing/includemod.cmi
typing/includemod.cmx : typing/types.cmx typing/typedtree.cmx utils/tbl.cmx \
typing/subst.cmx typing/printtyp.cmx typing/primitive.cmx typing/path.cmx \
typing/mtype.cmx utils/misc.cmx parsing/location.cmx \
typing/includecore.cmx typing/includeclass.cmx typing/ident.cmx \
typing/env.cmx typing/ctype.cmx typing/cmt_format.cmx utils/clflags.cmx \
typing/btype.cmx typing/includemod.cmi
parsing/builtin_attributes.cmx typing/btype.cmx typing/includemod.cmi
typing/includemod.cmi : typing/types.cmi typing/typedtree.cmi \
typing/path.cmi parsing/location.cmi typing/includecore.cmi \
typing/ident.cmi typing/env.cmi typing/ctype.cmi
@ -282,12 +282,12 @@ typing/predef.cmx : typing/types.cmx typing/path.cmx parsing/parsetree.cmi \
parsing/location.cmx typing/ident.cmx typing/btype.cmx \
parsing/asttypes.cmi typing/predef.cmi
typing/predef.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi
typing/primitive.cmo : utils/warnings.cmi parsing/parsetree.cmi \
typing/outcometree.cmi utils/misc.cmi parsing/location.cmi \
parsing/attr_helper.cmi typing/primitive.cmi
typing/primitive.cmx : utils/warnings.cmx parsing/parsetree.cmi \
typing/outcometree.cmi utils/misc.cmx parsing/location.cmx \
parsing/attr_helper.cmx typing/primitive.cmi
typing/primitive.cmo : parsing/parsetree.cmi typing/outcometree.cmi \
utils/misc.cmi parsing/location.cmi parsing/attr_helper.cmi \
typing/primitive.cmi
typing/primitive.cmx : parsing/parsetree.cmi typing/outcometree.cmi \
utils/misc.cmx parsing/location.cmx parsing/attr_helper.cmx \
typing/primitive.cmi
typing/primitive.cmi : parsing/parsetree.cmi typing/outcometree.cmi \
parsing/location.cmi
typing/printtyp.cmo : typing/types.cmi typing/primitive.cmi \
@ -453,20 +453,18 @@ typing/types.cmx : typing/primitive.cmx typing/path.cmx \
typing/types.cmi : typing/primitive.cmi typing/path.cmi \
parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
typing/ident.cmi parsing/asttypes.cmi
typing/typetexp.cmo : utils/warnings.cmi typing/types.cmi \
typing/typedtree.cmi utils/tbl.cmi typing/printtyp.cmi typing/predef.cmi \
typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \
parsing/longident.cmi parsing/location.cmi typing/env.cmi \
typing/ctype.cmi utils/clflags.cmi parsing/builtin_attributes.cmi \
typing/btype.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \
typing/typetexp.cmi
typing/typetexp.cmx : utils/warnings.cmx typing/types.cmx \
typing/typedtree.cmx utils/tbl.cmx typing/printtyp.cmx typing/predef.cmx \
typing/path.cmx parsing/parsetree.cmi utils/misc.cmx \
parsing/longident.cmx parsing/location.cmx typing/env.cmx \
typing/ctype.cmx utils/clflags.cmx parsing/builtin_attributes.cmx \
typing/btype.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \
typing/typetexp.cmi
typing/typetexp.cmo : typing/types.cmi typing/typedtree.cmi utils/tbl.cmi \
typing/printtyp.cmi typing/predef.cmi typing/path.cmi \
parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \
parsing/location.cmi typing/env.cmi typing/ctype.cmi utils/clflags.cmi \
parsing/builtin_attributes.cmi typing/btype.cmi parsing/asttypes.cmi \
parsing/ast_helper.cmi typing/typetexp.cmi
typing/typetexp.cmx : typing/types.cmx typing/typedtree.cmx utils/tbl.cmx \
typing/printtyp.cmx typing/predef.cmx typing/path.cmx \
parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \
parsing/location.cmx typing/env.cmx typing/ctype.cmx utils/clflags.cmx \
parsing/builtin_attributes.cmx typing/btype.cmx parsing/asttypes.cmi \
parsing/ast_helper.cmx typing/typetexp.cmi
typing/typetexp.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
typing/env.cmi parsing/asttypes.cmi
@ -717,7 +715,7 @@ asmcomp/afl_instrument.cmi : asmcomp/cmm.cmi
asmcomp/arch.cmo : utils/config.cmi utils/clflags.cmi
asmcomp/arch.cmx : utils/config.cmx utils/clflags.cmx
asmcomp/asmgen.cmo : asmcomp/un_anf.cmi bytecomp/translmod.cmi \
utils/timings.cmi middle_end/base_types/symbol.cmi asmcomp/split.cmi \
utils/profile.cmi middle_end/base_types/symbol.cmi asmcomp/split.cmi \
asmcomp/spill.cmi asmcomp/selection.cmi asmcomp/scheduling.cmi \
asmcomp/reload.cmi asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printmach.cmi \
asmcomp/printlinear.cmi asmcomp/printcmm.cmi asmcomp/printclambda.cmi \
@ -732,7 +730,7 @@ asmcomp/asmgen.cmo : asmcomp/un_anf.cmi bytecomp/translmod.cmi \
asmcomp/closure.cmi utils/clflags.cmi asmcomp/clambda.cmi asmcomp/CSE.cmo \
asmcomp/build_export_info.cmi asmcomp/asmgen.cmi
asmcomp/asmgen.cmx : asmcomp/un_anf.cmx bytecomp/translmod.cmx \
utils/timings.cmx middle_end/base_types/symbol.cmx asmcomp/split.cmx \
utils/profile.cmx middle_end/base_types/symbol.cmx asmcomp/split.cmx \
asmcomp/spill.cmx asmcomp/selection.cmx asmcomp/scheduling.cmx \
asmcomp/reload.cmx asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printmach.cmx \
asmcomp/printlinear.cmx asmcomp/printcmm.cmx asmcomp/printclambda.cmx \
@ -757,19 +755,19 @@ asmcomp/asmlibrarian.cmx : utils/misc.cmx parsing/location.cmx \
asmcomp/cmx_format.cmi utils/clflags.cmx asmcomp/clambda.cmx \
utils/ccomp.cmx asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmi
asmcomp/asmlibrarian.cmi :
asmcomp/asmlink.cmo : utils/timings.cmi bytecomp/runtimedef.cmi \
asmcomp/asmlink.cmo : utils/profile.cmi bytecomp/runtimedef.cmi \
utils/misc.cmi parsing/location.cmi asmcomp/emitaux.cmi asmcomp/emit.cmi \
utils/consistbl.cmi utils/config.cmi asmcomp/compilenv.cmi \
asmcomp/cmx_format.cmi asmcomp/cmmgen.cmi utils/clflags.cmi \
utils/ccomp.cmi asmcomp/asmgen.cmi asmcomp/asmlink.cmi
asmcomp/asmlink.cmx : utils/timings.cmx bytecomp/runtimedef.cmx \
asmcomp/asmlink.cmx : utils/profile.cmx bytecomp/runtimedef.cmx \
utils/misc.cmx parsing/location.cmx asmcomp/emitaux.cmx asmcomp/emit.cmx \
utils/consistbl.cmx utils/config.cmx asmcomp/compilenv.cmx \
asmcomp/cmx_format.cmi asmcomp/cmmgen.cmx utils/clflags.cmx \
utils/ccomp.cmx asmcomp/asmgen.cmx asmcomp/asmlink.cmi
asmcomp/asmlink.cmi : asmcomp/cmx_format.cmi
asmcomp/asmpackager.cmo : typing/typemod.cmi bytecomp/translmod.cmi \
utils/timings.cmi utils/misc.cmi middle_end/middle_end.cmi \
utils/profile.cmi utils/misc.cmi middle_end/middle_end.cmi \
parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \
asmcomp/export_info_for_pack.cmi asmcomp/export_info.cmi typing/env.cmi \
utils/config.cmi asmcomp/compilenv.cmi \
@ -777,7 +775,7 @@ asmcomp/asmpackager.cmo : typing/typemod.cmi bytecomp/translmod.cmi \
utils/clflags.cmi utils/ccomp.cmi asmcomp/asmlink.cmi asmcomp/asmgen.cmi \
asmcomp/asmpackager.cmi
asmcomp/asmpackager.cmx : typing/typemod.cmx bytecomp/translmod.cmx \
utils/timings.cmx utils/misc.cmx middle_end/middle_end.cmx \
utils/profile.cmx utils/misc.cmx middle_end/middle_end.cmx \
parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \
asmcomp/export_info_for_pack.cmx asmcomp/export_info.cmx typing/env.cmx \
utils/config.cmx asmcomp/compilenv.cmx \
@ -1671,7 +1669,7 @@ middle_end/lift_let_to_initialize_symbol.cmx : \
middle_end/lift_let_to_initialize_symbol.cmi : middle_end/flambda.cmi \
middle_end/backend_intf.cmi
middle_end/middle_end.cmo : utils/warnings.cmi \
middle_end/base_types/variable.cmi utils/timings.cmi \
middle_end/base_types/variable.cmi utils/profile.cmi \
middle_end/base_types/symbol.cmi middle_end/share_constants.cmi \
middle_end/remove_unused_program_constructs.cmi \
middle_end/remove_unused_closure_vars.cmi middle_end/ref_to_variables.cmi \
@ -1685,7 +1683,7 @@ middle_end/middle_end.cmo : utils/warnings.cmi \
middle_end/base_types/closure_id.cmi middle_end/closure_conversion.cmi \
utils/clflags.cmi middle_end/backend_intf.cmi middle_end/middle_end.cmi
middle_end/middle_end.cmx : utils/warnings.cmx \
middle_end/base_types/variable.cmx utils/timings.cmx \
middle_end/base_types/variable.cmx utils/profile.cmx \
middle_end/base_types/symbol.cmx middle_end/share_constants.cmx \
middle_end/remove_unused_program_constructs.cmx \
middle_end/remove_unused_closure_vars.cmx middle_end/ref_to_variables.cmx \
@ -2002,14 +2000,16 @@ middle_end/base_types/variable.cmx : utils/misc.cmx utils/identifiable.cmx \
middle_end/base_types/variable.cmi : utils/identifiable.cmi typing/ident.cmi \
middle_end/base_types/compilation_unit.cmi
driver/compdynlink.cmi :
driver/compenv.cmo : utils/warnings.cmi utils/misc.cmi parsing/location.cmi \
utils/config.cmi utils/clflags.cmi utils/ccomp.cmi driver/compenv.cmi
driver/compenv.cmx : utils/warnings.cmx utils/misc.cmx parsing/location.cmx \
utils/config.cmx utils/clflags.cmx utils/ccomp.cmx driver/compenv.cmi
driver/compenv.cmo : utils/warnings.cmi utils/profile.cmi utils/misc.cmi \
parsing/location.cmi utils/config.cmi utils/clflags.cmi utils/ccomp.cmi \
driver/compenv.cmi
driver/compenv.cmx : utils/warnings.cmx utils/profile.cmx utils/misc.cmx \
parsing/location.cmx utils/config.cmx utils/clflags.cmx utils/ccomp.cmx \
driver/compenv.cmi
driver/compenv.cmi :
driver/compile.cmo : utils/warnings.cmi typing/typemod.cmi \
typing/typedtree.cmi typing/typecore.cmi bytecomp/translmod.cmi \
utils/timings.cmi typing/stypes.cmi bytecomp/simplif.cmi \
utils/profile.cmi typing/stypes.cmi bytecomp/simplif.cmi \
typing/printtyped.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \
bytecomp/printinstr.cmi parsing/printast.cmi parsing/pprintast.cmi \
driver/pparse.cmi utils/misc.cmi bytecomp/lambda.cmi \
@ -2018,7 +2018,7 @@ driver/compile.cmo : utils/warnings.cmi typing/typemod.cmi \
bytecomp/bytegen.cmi parsing/builtin_attributes.cmi driver/compile.cmi
driver/compile.cmx : utils/warnings.cmx typing/typemod.cmx \
typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \
utils/timings.cmx typing/stypes.cmx bytecomp/simplif.cmx \
utils/profile.cmx typing/stypes.cmx bytecomp/simplif.cmx \
typing/printtyped.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \
bytecomp/printinstr.cmx parsing/printast.cmx parsing/pprintast.cmx \
driver/pparse.cmx utils/misc.cmx bytecomp/lambda.cmx \
@ -2045,25 +2045,25 @@ driver/compplugin.cmi :
driver/errors.cmo : parsing/location.cmi driver/errors.cmi
driver/errors.cmx : parsing/location.cmx driver/errors.cmi
driver/errors.cmi :
driver/main.cmo : utils/warnings.cmi utils/timings.cmi utils/misc.cmi \
driver/main.cmo : utils/warnings.cmi utils/profile.cmi utils/misc.cmi \
driver/main_args.cmi parsing/location.cmi utils/config.cmi \
driver/compplugin.cmi driver/compmisc.cmi driver/compile.cmi \
driver/compenv.cmi utils/clflags.cmi bytecomp/bytepackager.cmi \
bytecomp/bytelink.cmi bytecomp/bytelibrarian.cmi driver/main.cmi
driver/main.cmx : utils/warnings.cmx utils/timings.cmx utils/misc.cmx \
driver/main.cmx : utils/warnings.cmx utils/profile.cmx utils/misc.cmx \
driver/main_args.cmx parsing/location.cmx utils/config.cmx \
driver/compplugin.cmx driver/compmisc.cmx driver/compile.cmx \
driver/compenv.cmx utils/clflags.cmx bytecomp/bytepackager.cmx \
bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmx driver/main.cmi
driver/main.cmi :
driver/main_args.cmo : utils/warnings.cmi utils/config.cmi utils/clflags.cmi \
driver/main_args.cmi
driver/main_args.cmx : utils/warnings.cmx utils/config.cmx utils/clflags.cmx \
driver/main_args.cmi
driver/main_args.cmo : utils/warnings.cmi utils/profile.cmi utils/config.cmi \
utils/clflags.cmi driver/main_args.cmi
driver/main_args.cmx : utils/warnings.cmx utils/profile.cmx utils/config.cmx \
utils/clflags.cmx driver/main_args.cmi
driver/main_args.cmi :
driver/optcompile.cmo : utils/warnings.cmi typing/typemod.cmi \
typing/typedtree.cmi typing/typecore.cmi bytecomp/translmod.cmi \
utils/timings.cmi typing/stypes.cmi bytecomp/simplif.cmi \
utils/profile.cmi typing/stypes.cmi bytecomp/simplif.cmi \
typing/printtyped.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \
parsing/printast.cmi parsing/pprintast.cmi driver/pparse.cmi \
utils/misc.cmi middle_end/middle_end.cmi bytecomp/lambda.cmi \
@ -2072,7 +2072,7 @@ driver/optcompile.cmo : utils/warnings.cmi typing/typemod.cmi \
parsing/builtin_attributes.cmi asmcomp/asmgen.cmi driver/optcompile.cmi
driver/optcompile.cmx : utils/warnings.cmx typing/typemod.cmx \
typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \
utils/timings.cmx typing/stypes.cmx bytecomp/simplif.cmx \
utils/profile.cmx typing/stypes.cmx bytecomp/simplif.cmx \
typing/printtyped.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \
parsing/printast.cmx parsing/pprintast.cmx driver/pparse.cmx \
utils/misc.cmx middle_end/middle_end.cmx bytecomp/lambda.cmx \
@ -2083,14 +2083,14 @@ driver/optcompile.cmi : middle_end/backend_intf.cmi
driver/opterrors.cmo : parsing/location.cmi driver/opterrors.cmi
driver/opterrors.cmx : parsing/location.cmx driver/opterrors.cmi
driver/opterrors.cmi :
driver/optmain.cmo : utils/warnings.cmi utils/timings.cmi asmcomp/proc.cmi \
driver/optmain.cmo : utils/warnings.cmi utils/profile.cmi asmcomp/proc.cmi \
asmcomp/printmach.cmi driver/optcompile.cmi utils/misc.cmi \
driver/main_args.cmi parsing/location.cmi asmcomp/import_approx.cmi \
utils/config.cmi driver/compplugin.cmi driver/compmisc.cmi \
asmcomp/compilenv.cmi driver/compenv.cmi utils/clflags.cmi \
middle_end/backend_intf.cmi asmcomp/asmpackager.cmi asmcomp/asmlink.cmi \
asmcomp/asmlibrarian.cmi asmcomp/arch.cmo driver/optmain.cmi
driver/optmain.cmx : utils/warnings.cmx utils/timings.cmx asmcomp/proc.cmx \
driver/optmain.cmx : utils/warnings.cmx utils/profile.cmx asmcomp/proc.cmx \
asmcomp/printmach.cmx driver/optcompile.cmx utils/misc.cmx \
driver/main_args.cmx parsing/location.cmx asmcomp/import_approx.cmx \
utils/config.cmx driver/compplugin.cmx driver/compmisc.cmx \
@ -2098,11 +2098,11 @@ driver/optmain.cmx : utils/warnings.cmx utils/timings.cmx asmcomp/proc.cmx \
middle_end/backend_intf.cmi asmcomp/asmpackager.cmx asmcomp/asmlink.cmx \
asmcomp/asmlibrarian.cmx asmcomp/arch.cmx driver/optmain.cmi
driver/optmain.cmi :
driver/pparse.cmo : utils/timings.cmi parsing/parsetree.cmi \
driver/pparse.cmo : utils/profile.cmi parsing/parsetree.cmi \
parsing/parse.cmi utils/misc.cmi parsing/location.cmi utils/config.cmi \
utils/clflags.cmi utils/ccomp.cmi parsing/ast_mapper.cmi \
parsing/ast_invariants.cmi driver/pparse.cmi
driver/pparse.cmx : utils/timings.cmx parsing/parsetree.cmi \
driver/pparse.cmx : utils/profile.cmx parsing/parsetree.cmi \
parsing/parse.cmx utils/misc.cmx parsing/location.cmx utils/config.cmx \
utils/clflags.cmx utils/ccomp.cmx parsing/ast_mapper.cmx \
parsing/ast_invariants.cmx driver/pparse.cmi
@ -2231,13 +2231,15 @@ toplevel/toploop.cmi : utils/warnings.cmi typing/types.cmi typing/path.cmi \
parsing/parsetree.cmi typing/outcometree.cmi parsing/longident.cmi \
parsing/location.cmi typing/env.cmi
toplevel/topmain.cmo : utils/warnings.cmi toplevel/toploop.cmi \
toplevel/topdirs.cmi utils/misc.cmi driver/main_args.cmi \
parsing/location.cmi utils/config.cmi driver/compplugin.cmi \
driver/compenv.cmi utils/clflags.cmi toplevel/topmain.cmi
toplevel/topdirs.cmi utils/profile.cmi utils/misc.cmi \
driver/main_args.cmi parsing/location.cmi utils/config.cmi \
driver/compplugin.cmi driver/compenv.cmi utils/clflags.cmi \
toplevel/topmain.cmi
toplevel/topmain.cmx : utils/warnings.cmx toplevel/toploop.cmx \
toplevel/topdirs.cmx utils/misc.cmx driver/main_args.cmx \
parsing/location.cmx utils/config.cmx driver/compplugin.cmx \
driver/compenv.cmx utils/clflags.cmx toplevel/topmain.cmi
toplevel/topdirs.cmx utils/profile.cmx utils/misc.cmx \
driver/main_args.cmx parsing/location.cmx utils/config.cmx \
driver/compplugin.cmx driver/compenv.cmx utils/clflags.cmx \
toplevel/topmain.cmi
toplevel/topmain.cmi :
toplevel/topstart.cmo : toplevel/topmain.cmi
toplevel/topstart.cmx : toplevel/topmain.cmx
@ -2256,3 +2258,18 @@ driver/compdynlink.cmo : bytecomp/symtable.cmi bytecomp/opcodes.cmo \
utils/misc.cmi bytecomp/meta.cmi bytecomp/dll.cmi utils/consistbl.cmi \
utils/config.cmi bytecomp/cmo_format.cmi typing/cmi_format.cmi \
driver/compdynlink.cmi
driver/makedepend.cmo : driver/pparse.cmi parsing/parsetree.cmi \
parsing/parser.cmi parsing/parse.cmi utils/misc.cmi parsing/longident.cmi \
parsing/location.cmi parsing/lexer.cmi parsing/depend.cmi \
utils/config.cmi driver/compplugin.cmi driver/compenv.cmi \
utils/clflags.cmi driver/makedepend.cmi
driver/makedepend.cmx : driver/pparse.cmx parsing/parsetree.cmi \
parsing/parser.cmx parsing/parse.cmx utils/misc.cmx parsing/longident.cmx \
parsing/location.cmx parsing/lexer.cmx parsing/depend.cmx \
utils/config.cmx driver/compplugin.cmx driver/compenv.cmx \
utils/clflags.cmx driver/makedepend.cmi
driver/main.cmo : driver/makedepend.cmi
driver/main.cmx : driver/makedepend.cmx
driver/optmain.cmo : driver/makedepend.cmi
driver/optmain.cmx : driver/makedepend.cmx

2
.gitignore vendored
View File

@ -269,6 +269,8 @@
/testsuite/tests/lib-threads/*.byt
/testsuite/tests/lib-unix/win-stat/*-file
/testsuite/tests/opaque/*/*.mli
/testsuite/tests/runtime-errors/*.bytecode

28
.travis-ci.sh
View File

@ -15,6 +15,8 @@
PREFIX=~/local
MAKE=make SHELL=dash
BuildAndTest () {
case $XARCH in
i386)
@ -35,37 +37,37 @@ EOF
./configure --prefix $PREFIX -with-debug-runtime \
-with-instrumented-runtime $CONFIG_ARG
export PATH=$PREFIX/bin:$PATH
make world.opt
make ocamlnat
(cd testsuite && make all)
(cd testsuite && make USE_RUNTIME="d" all)
make install
$MAKE world.opt
$MAKE ocamlnat
(cd testsuite && $MAKE all)
(cd testsuite && $MAKE USE_RUNTIME="d" all)
$MAKE install
# check_all_arches checks tries to compile all backends in place,
# we need to redo (small parts of) world.opt afterwards
make check_all_arches
make world.opt
make manual-pregen
$MAKE check_all_arches
$MAKE world.opt
$MAKE manual-pregen
mkdir external-packages
cd external-packages
git clone git://github.com/ocaml/ocamlbuild
mkdir ocamlbuild-install
(cd ocamlbuild &&
make -f configure.make Makefile.config src/ocamlbuild_config.ml \
$MAKE -f configure.make Makefile.config src/ocamlbuild_config.ml \
OCAMLBUILD_PREFIX=$PREFIX \
OCAMLBUILD_BINDIR=$PREFIX/bin \
OCAMLBUILD_LIBDIR=$PREFIX/lib \
OCAML_NATIVE=true \
OCAML_NATIVE_TOOLS=true &&
make all &&
make install)
$MAKE all &&
$MAKE install)
git clone git://github.com/ocaml/camlp4
(cd camlp4 &&
./configure --bindir=$PREFIX/bin --libdir=$PREFIX/lib/ocaml \
--pkgdir=$PREFIX/lib/ocaml && \
make && make install)
$MAKE && $MAKE install)
# git clone git://github.com/ocaml/opam
# (cd opam && ./configure --prefix $PREFIX &&\
# make lib-ext && make && make install)
# $MAKE lib-ext && $MAKE && $MAKE install)
# git config --global user.email "some@name.com"
# git config --global user.name "Some Name"
# opam init -y -a git://github.com/ocaml/opam-repository

50
Changes
View File

@ -5,6 +5,10 @@ Working version
### Language features:
- GPR#1142: Mark assertions nonexpansive, so that 'assert false'
can be used as a placeholder for a polymorphic function.
(Stephen Dolan)
### Code generation and optimizations:
- PR#5324, GPR#375: An alternative Linear Scan register allocator for
@ -47,6 +51,12 @@ Working version
(Sébastien Briais, review by Daniel Buenzli, Alain Frisch and
Gabriel Scherer)
- PR#7515, GPR#1147: Arg.align now optionally uses the tab character '\t' to
separate the "unaligned" and "aligned" parts of the documentation string. If
tab is not present, then space is used as a fallback. Allows to have spaces in
the unaligned part, which is useful for Tuple options.
(Nicolas Ojeda Bar, review by Alain Frisch and Gabriel Scherer)
- GPR#1034: Add List.init
(Richard Degenne, review by David Allsopp, Thomas Braibant, Florian
Angeletti, Gabriel Scherer, Nathan Moreau, Alain Frisch)
@ -59,6 +69,10 @@ Working version
values.
(Daniel Bünzli, review by Damien Doligez, Max Mouratov)
- GPR#1175: bigarray, add a change_layout function to each Array[N]
submodules.
(Florian Angeletti)
- Resurrect tabulation boxes in module Format. Rewrite/extend documentation
of tabulation boxes.
@ -72,6 +86,10 @@ Working version
a trailing "Error: Some fatal warnings were triggered" message.
(Valentin Gatien-Baron, review by Alain Frisch)
- MPR#7444, GPR#1138: trigger deprecation warning when a "deprecated"
attribute is hidden by signature coercion
(Alain Frisch, report by bmillwood, review by Leo White)
### Manual and documentation:
- PR#6548: remove obsolete limitation in the description of private
@ -99,8 +117,20 @@ Working version
specification "%g" with the ISO C90 description.
(Florian Angeletti)
- PR#7551, GPR#1194 : make the final ";;" potentially optional in
caml_example
(Florian Angeletti, review and suggestion by Gabriel Scherer)
- GPR#1187: Minimal documentation for compiler plugins
(Florian Angeletti)
### Tools:
- GPR#1078: add a subcommand "-depend" to "ocamlc" and "ocamlopt",
to behave as ocamldep. Should be used mostly to replace "ocamldep" in the
"boot" directory to reduce its size in the future.
(Fabrice Le Fessant)
- GPR#1045: ocamldep, add a "-shared" option to generate dependencies
for native plugin files (i.e. .cmxs files)
(Florian Angeletti, suggestion by Sébastien Hinderer)
@ -143,6 +173,10 @@ Working version
- PR#6826, GPR#828, GPR#834: improve compilation time for open
(Alain Frisch, review by Frédéric Bour and Jacques Garrigue)
- PR#7514, GPR#1152: add -dprofile option, similar to -dtimings but
also displays memory allocation and consumption
(Valentin Gatien-Baron, report by Gabriel Scherer)
- GPR#1032: display the output of -dtimings as a hierarchy
(Valentin Gatien-Baron, review by Gabriel Scherer)
@ -199,6 +233,10 @@ Working version
- PR#7513: List.compare_length_with mishandles negative numbers / overflow
(Fabrice Le Fessant, report by Jeremy Yallop)
- PR#7531a: Default argument is not evaluated even after passing a
non-labeled argument
(Jacques Garrigue, report by Stephen Dolan)
### Runtime system:
- GPR#71: The runtime can now be shut down gracefully by means of the new
@ -238,6 +276,10 @@ Next major version (4.05.0):
(Stephen Dolan, review by Gabriel Scherer, Pierre Chambart,
Mark Shinwell, and bug report by Gabriel Scherer)
- PR#7533, GPR#1173: Correctly perform side effects for certain
cases of "/" and "mod"
(Mark Shinwell, report by Jan Mitgaard)
### Runtime system:
- MPR#385, GPR#953: Add caml_startup_exn
@ -324,7 +366,8 @@ Next major version (4.05.0):
(Xavier Leroy)
- GPR#1015: add option "-plugin PLUGIN" to ocamldep too. Use compilerlibs
to build ocamldep.
to build ocamldep. Add option "-depend" to ocamlc/ocamlopt to behave
as ocamldep. Remove any use of ocamldep to build the distribution.
(Fabrice Le Fessant)
- GPR#1027: various improvements to -dtimings, mostly including time
@ -487,6 +530,10 @@ Next major version (4.05.0):
to solve ocamlbuild+doc usability issue (ocaml/ocamlbuild#79)
(Gabriel Scherer, review by Florian Angeletti, discussion with Daniel Bünzli)
* GPR#1012: ocamlyacc, fix parsing of raw strings and nested comments, as well
as the handling of ' characters in identifiers.
(Demi Obenour)
- GPR#1017: ocamldoc, add an option to detect code fragments that could be
transformed into a cross-reference to a known element.
(Florian Angeletti, review and suggestion by David Allsopp)
@ -658,6 +705,7 @@ The complete list of changes is listed below.
(Mark Shinwell, report by Jeremy Yallop, review by Frédéric Bour)
- PR#6550, GPR#1094: Allow creation of empty .cmxa files on macOS
- PR#6373, GPR#1093: Suppress trigraph warnings from macOS assembler
(Mark Shinwell)
- PR#6594, GPR#955: Remove "Istore_symbol" specific operation on x86-64.

37
HACKING.adoc
View File

@ -132,6 +132,17 @@ independent and should not need further knowledge.
link:otherlibs/[]:: External libraries such as `unix`, `threads`,
`dynlink`, `str` and `bigarray`.
Instructions for building the full reference manual are provided in
link:manual/README.md[]. However, if you only modify the documentation
comments in `.mli` files in the compiler codebase, you can observe the
result by running
----
make html_doc
----
and then opening link:./ocamldoc/stdlib_html/index.html[] in a web browser.
=== Tools
link:lex/[]:: The `ocamllex` lexer generator.
@ -224,6 +235,32 @@ found in link:INSTALL.adoc#bootstrap[INSTALL.adoc].
==== Github's CI: Travis and AppVeyor
The script that is run on Travis continuous integration servers is
link:.travis-ci.sh[]; its configuration can be found as
a Travis configuration file in link:.travis.yml[].
For example, if you want to reproduce the default build on your
machine, you can use the configuration values and run command taken from
link:.travis.yml[]:
----
CI_KIND=build XARCH=i386 bash -ex .travis-ci.sh
----
The scripts support two other kinds of tests (values of the
`CI_KIND` variable) which both inspect the patch submitted as part of
a pull request. `tests` checks that the testsuite has been modified
(hopefully, improved) by the patch, and `changes` checks that the
link:Changes[] file has been modified (hopefully to add a new entry).
These tests rely on the `$TRAVIS_COMMIT_RANGE` variable which you can
set explicitly to reproduce them locally.
The `changes` check can be disabled by including "(no change
entry needed)" in one of your commit messages -- but in general all
patches submitted should come with a Changes entry; see the guidelines
in link:CONTRIBUTING.md[].
==== INRIA's Continuous Integration (CI)
INRIA provides a Jenkins continuous integration service that OCaml

4
Makefile
View File

@ -84,7 +84,7 @@ OCAMLDOC_OPT=$(WITH_OCAMLDOC:=.opt)
UTILS=utils/config.cmo utils/misc.cmo \
utils/identifiable.cmo utils/numbers.cmo utils/arg_helper.cmo \
utils/clflags.cmo utils/tbl.cmo utils/timings.cmo \
utils/clflags.cmo utils/tbl.cmo utils/profile.cmo \
utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \
utils/consistbl.cmo \
utils/strongly_connected_components.cmo \
@ -131,7 +131,7 @@ BYTECOMP=bytecomp/meta.cmo bytecomp/instruct.cmo bytecomp/bytegen.cmo \
bytecomp/bytesections.cmo bytecomp/dll.cmo bytecomp/symtable.cmo \
bytecomp/bytelink.cmo bytecomp/bytelibrarian.cmo bytecomp/bytepackager.cmo \
driver/compdynlink.cmo driver/compplugin.cmo \
driver/errors.cmo driver/compile.cmo
driver/errors.cmo driver/compile.cmo driver/makedepend.cmo
ARCH_SPECIFIC =\
asmcomp/arch.ml asmcomp/proc.ml asmcomp/CSE.ml asmcomp/selection.ml \

12
README.adoc
View File

@ -1,3 +1,15 @@
|=====
| Branch `trunk` | Branch `4.05` | Branch `4.04`
| image:https://travis-ci.org/ocaml/ocaml.svg?branch=trunk["TravisCI Build Status (trunk branch)",link="https://travis-ci.org/ocaml/ocaml"]
image:https://ci.appveyor.com/api/projects/status/github/ocaml/ocaml?branch=trunk&svg=true["AppVeyor Build Status (trunk branch)",link="https://ci.appveyor.com/project/avsm/ocaml"]
| image:https://travis-ci.org/ocaml/ocaml.svg?branch=4.05["TravisCI Build Status (4.05 branch)",link="https://travis-ci.org/ocaml/ocaml"]
image:https://ci.appveyor.com/api/projects/status/github/ocaml/ocaml?branch=4.05&svg=true["AppVeyor Build Status (4.05 branch)",link="https://ci.appveyor.com/project/avsm/ocaml"]
| image:https://travis-ci.org/ocaml/ocaml.svg?branch=4.04["TravisCI Build Status (4.04 branch)",link="https://travis-ci.org/ocaml/ocaml"]
image:https://ci.appveyor.com/api/projects/status/github/ocaml/ocaml?branch=4.04&svg=true["AppVeyor Build Status (4.04 branch)",link="https://ci.appveyor.com/project/avsm/ocaml"]
|=====
= README =
== Overview

34
asmcomp/asmgen.ml
View File

@ -105,27 +105,27 @@ let compile_fundecl (ppf : formatter) fd_cmm =
Proc.init ();
Reg.reset();
fd_cmm
++ Timings.time ~accumulate:true "selection" Selection.fundecl
++ Profile.record ~accumulate:true "selection" Selection.fundecl
++ pass_dump_if ppf dump_selection "After instruction selection"
++ Timings.time ~accumulate:true "comballoc" Comballoc.fundecl
++ Profile.record ~accumulate:true "comballoc" Comballoc.fundecl
++ pass_dump_if ppf dump_combine "After allocation combining"
++ Timings.time ~accumulate:true "cse" CSE.fundecl
++ Profile.record ~accumulate:true "cse" CSE.fundecl
++ pass_dump_if ppf dump_cse "After CSE"
++ Timings.time ~accumulate:true "liveness" (liveness ppf)
++ Timings.time ~accumulate:true "deadcode" Deadcode.fundecl
++ Profile.record ~accumulate:true "liveness" (liveness ppf)
++ Profile.record ~accumulate:true "deadcode" Deadcode.fundecl
++ pass_dump_if ppf dump_live "Liveness analysis"
++ Timings.time ~accumulate:true "spill" Spill.fundecl
++ Timings.time ~accumulate:true "liveness" (liveness ppf)
++ Profile.record ~accumulate:true "spill" Spill.fundecl
++ Profile.record ~accumulate:true "liveness" (liveness ppf)
++ pass_dump_if ppf dump_spill "After spilling"
++ Timings.time ~accumulate:true "split" Split.fundecl
++ Profile.record ~accumulate:true "split" Split.fundecl
++ pass_dump_if ppf dump_split "After live range splitting"
++ Timings.time ~accumulate:true "liveness" (liveness ppf)
++ Timings.time ~accumulate:true "regalloc" (regalloc ppf 1)
++ Timings.time ~accumulate:true "linearize" Linearize.fundecl
++ Profile.record ~accumulate:true "liveness" (liveness ppf)
++ Profile.record ~accumulate:true "regalloc" (regalloc ppf 1)
++ Profile.record ~accumulate:true "linearize" Linearize.fundecl
++ pass_dump_linear_if ppf dump_linear "Linearized code"
++ Timings.time ~accumulate:true "scheduling" Scheduling.fundecl
++ Profile.record ~accumulate:true "scheduling" Scheduling.fundecl
++ pass_dump_linear_if ppf dump_scheduling "After instruction scheduling"
++ Timings.time ~accumulate:true "emit" Emit.fundecl
++ Profile.record ~accumulate:true "emit" Emit.fundecl
let compile_phrase ppf p =
if !dump_cmm then fprintf ppf "%a@." Printcmm.phrase p;
@ -159,7 +159,7 @@ let compile_unit _output_prefix asm_filename keep_asm
raise exn
end;
let assemble_result =
Timings.time "assemble"
Profile.record "assemble"
(Proc.assemble_file asm_filename) obj_filename
in
if assemble_result <> 0
@ -177,8 +177,8 @@ let end_gen_implementation ?toplevel ppf
(clambda:clambda_and_constants) =
Emit.begin_assembly ();
clambda
++ Timings.time "cmm" Cmmgen.compunit
++ Timings.time "compile_phrases" (List.iter (compile_phrase ppf))
++ Profile.record "cmm" Cmmgen.compunit
++ Profile.record "compile_phrases" (List.iter (compile_phrase ppf))
++ (fun () -> ());
(match toplevel with None -> () | Some f -> compile_genfuns ppf f);
@ -199,7 +199,7 @@ let flambda_gen_implementation ?toplevel ~backend ppf
(program:Flambda.program) =
let export = Build_export_info.build_export_info ~backend program in
let (clambda, preallocated, constants) =
Timings.time_call "backend" (fun () ->
Profile.record_call "backend" (fun () ->
(program, export)
++ Flambda_to_clambda.convert
++ flambda_raw_clambda_dump_if ppf

4
asmcomp/asmlink.ml
View File

@ -260,7 +260,7 @@ let call_linker_shared file_list output_name =
then raise(Error Linking_error)
let link_shared ppf objfiles output_name =
Timings.time_call output_name (fun () ->
Profile.record_call output_name (fun () ->
let units_tolink = List.fold_right scan_file objfiles [] in
List.iter
(fun (info, file_name, crc) -> check_consistency file_name info crc)
@ -315,7 +315,7 @@ let call_linker file_list startup_file output_name =
(* Main entry point *)
let link ppf objfiles output_name =
Timings.time_call output_name (fun () ->
Profile.record_call output_name (fun () ->
let stdlib =
if !Clflags.gprofile then "stdlib.p.cmxa" else "stdlib.cmxa" in
let stdexit =

2
asmcomp/asmpackager.ml
View File

@ -81,7 +81,7 @@ let check_units members =
let make_package_object ppf members targetobj targetname coercion
~backend =
Timings.time_call (Printf.sprintf "pack(%s)" targetname) (fun () ->
Profile.record_call (Printf.sprintf "pack(%s)" targetname) (fun () ->
let objtemp =
if !Clflags.keep_asm_file
then Filename.remove_extension targetobj ^ ".pack" ^ Config.ext_obj

14
asmcomp/cmmgen.ml
View File

@ -409,9 +409,10 @@ let rec div_int c1 c2 is_safe dbg =
Cop(Cdivi, [c1; c2], dbg)
| (c1, c2) ->
bind "divisor" c2 (fun c2 ->
Cifthenelse(c2,
Cop(Cdivi, [c1; c2], dbg),
raise_symbol dbg "caml_exn_Division_by_zero"))
bind "dividend" c1 (fun c1 ->
Cifthenelse(c2,
Cop(Cdivi, [c1; c2], dbg),
raise_symbol dbg "caml_exn_Division_by_zero")))
let mod_int c1 c2 is_safe dbg =
match (c1, c2) with
@ -445,9 +446,10 @@ let mod_int c1 c2 is_safe dbg =
Cop(Cmodi, [c1; c2], dbg)
| (c1, c2) ->
bind "divisor" c2 (fun c2 ->
Cifthenelse(c2,
Cop(Cmodi, [c1; c2], dbg),
raise_symbol dbg "caml_exn_Division_by_zero"))
bind "dividend" c1 (fun c1 ->
Cifthenelse(c2,
Cop(Cmodi, [c1; c2], dbg),
raise_symbol dbg "caml_exn_Division_by_zero")))
(* Division or modulo on boxed integers. The overflow case min_int / -1
can occur, in which case we force x / -1 = -x and x mod -1 = 0. (PR#5513). *)

2
bytecomp/bytegen.ml
View File

@ -868,6 +868,8 @@ let rec comp_expr env exp sz cont =
let ev = event (Event_after ty) info in
let cont1 = add_event ev cont in
comp_expr env lam sz cont1
| Lev_module_definition _ ->
comp_expr env lam sz cont
end
| Lifused (_, exp) ->
comp_expr env exp sz cont

1
bytecomp/lambda.ml
View File

@ -275,6 +275,7 @@ and lambda_event_kind =
| Lev_after of Types.type_expr
| Lev_function
| Lev_pseudo
| Lev_module_definition of Ident.t
type program =
{ module_ident : Ident.t;

1
bytecomp/lambda.mli
View File

@ -294,6 +294,7 @@ and lambda_event_kind =
| Lev_after of Types.type_expr
| Lev_function
| Lev_pseudo
| Lev_module_definition of Ident.t
type program =
{ module_ident : Ident.t;

2
bytecomp/printlambda.ml
View File

@ -601,6 +601,8 @@ let rec lam ppf = function
| Lev_after _ -> "after"
| Lev_function -> "funct-body"
| Lev_pseudo -> "pseudo"
| Lev_module_definition ident ->
Format.asprintf "module-defn(%a)" Ident.print ident
in
fprintf ppf "@[<2>(%s %s(%i)%s:%i-%i@ %a)@]" kind
ev.lev_loc.Location.loc_start.Lexing.pos_fname

2
bytecomp/simplif.mli
View File

@ -13,6 +13,8 @@
(* *)
(**************************************************************************)
(** Lambda simplification and lambda plugin hooks *)
(* Elimination of useless Llet(Alias) bindings.
Transformation of let-bound references into variables.
Simplification over staticraise/staticcatch constructs.

31
bytecomp/translcore.ml
View File

@ -576,12 +576,15 @@ type binding =
| Bind_value of value_binding list
| Bind_module of Ident.t * string loc * module_expr
let rec push_defaults loc bindings cases partial =
let rec push_defaults loc bindings pushing cases partial =
match cases with
[{c_lhs=pat; c_guard=None;
c_rhs={exp_desc = Texp_function { arg_label; param; cases; partial; } }
as exp}] ->
let cases = push_defaults exp.exp_loc bindings cases partial in
as exp}] when pushing || bindings = [] ->
(* Stop pushing when there is a non-labeled argument,
and there are default bindings to discharge *)
let cases = push_defaults
exp.exp_loc bindings (arg_label <> Nolabel) cases partial in
[{c_lhs=pat; c_guard=None;
c_rhs={exp with exp_desc = Texp_function { arg_label; param; cases;
partial; }}}]
@ -589,14 +592,14 @@ let rec push_defaults loc bindings cases partial =
c_rhs={exp_attributes=[{txt="#default"},_];
exp_desc = Texp_let
(Nonrecursive, binds, ({exp_desc = Texp_function _} as e2))}}] ->
push_defaults loc (Bind_value binds :: bindings)
push_defaults loc (Bind_value binds :: bindings) true
[{c_lhs=pat;c_guard=None;c_rhs=e2}]
partial
| [{c_lhs=pat; c_guard=None;
c_rhs={exp_attributes=[{txt="#modulepat"},_];
exp_desc = Texp_letmodule
(id, name, mexpr, ({exp_desc = Texp_function _} as e2))}}] ->
push_defaults loc (Bind_module (id, name, mexpr) :: bindings)
push_defaults loc (Bind_module (id, name, mexpr) :: bindings) true
[{c_lhs=pat;c_guard=None;c_rhs=e2}]
partial
| [case] ->
@ -625,7 +628,7 @@ let rec push_defaults loc bindings cases partial =
})},
cases, [], partial) }
in
push_defaults loc bindings
push_defaults loc bindings pushing
[{c_lhs={pat with pat_desc = Tpat_var (param, mknoloc name)};
c_guard=None; c_rhs=exp}]
Total
@ -740,7 +743,7 @@ and transl_exp0 e =
let ((kind, params), body) =
event_function e
(function repr ->
let pl = push_defaults e.exp_loc [] cases partial in
let pl = push_defaults e.exp_loc [] true cases partial in
transl_function e.exp_loc !Clflags.native_code repr partial
param pl)
in
@ -1029,10 +1032,16 @@ and transl_exp0 e =
(Lvar cpy) path expr, rem))
modifs
(Lvar cpy))
| Texp_letmodule(id, _, modl, body) ->
Llet(Strict, Pgenval, id,
!transl_module Tcoerce_none None modl,
transl_exp body)
| Texp_letmodule(id, loc, modl, body) ->
let defining_expr =
Levent (!transl_module Tcoerce_none None modl, {
lev_loc = loc.loc;
lev_kind = Lev_module_definition id;
lev_repr = None;
lev_env = Env.summary Env.empty;
})
in
Llet(Strict, Pgenval, id, defining_expr, transl_exp body)
| Texp_letexception(cd, body) ->
Llet(Strict, Pgenval,
cd.ext_id, transl_extension_constructor e.exp_env None cd,

28
bytecomp/translmod.ml
View File

@ -312,8 +312,8 @@ let compile_recmodule compile_rhs bindings cont =
eval_rec_bindings
(reorder_rec_bindings
(List.map
(fun {mb_id=id; mb_expr=modl; _} ->
(id, modl.mod_loc, init_shape modl, compile_rhs id modl))
(fun {mb_id=id; mb_expr=modl; mb_loc=loc; _} ->
(id, modl.mod_loc, init_shape modl, compile_rhs id modl loc))
bindings))
cont
@ -501,6 +501,14 @@ and transl_structure loc fields cc rootpath final_env = function
Translattribute.add_inline_attribute module_body mb.mb_loc
mb.mb_attributes
in
let module_body =
Levent (module_body, {
lev_loc = mb.mb_loc;
lev_kind = Lev_module_definition id;
lev_repr = None;
lev_env = Env.summary Env.empty;
})
in
Llet(pure_module mb.mb_expr, Pgenval, id,
module_body,
body), size
@ -513,8 +521,16 @@ and transl_structure loc fields cc rootpath final_env = function
in
let lam =
compile_recmodule
(fun id modl ->
transl_module Tcoerce_none (field_path rootpath id) modl)
(fun id modl loc ->
let module_body =
transl_module Tcoerce_none (field_path rootpath id) modl
in
Levent (module_body, {
lev_loc = loc;
lev_kind = Lev_module_definition id;
lev_repr = None;
lev_env = Env.summary Env.empty;
}))
bindings
body
in
@ -851,7 +867,7 @@ let transl_store_structure glob map prims str =
| Tstr_recmodule bindings ->
let ids = List.map (fun mb -> mb.mb_id) bindings in
compile_recmodule
(fun id modl ->
(fun id modl _loc ->
subst_lambda subst
(transl_module Tcoerce_none
(field_path rootpath id) modl))
@ -1118,7 +1134,7 @@ let transl_toplevel_item item =
| Tstr_recmodule bindings ->
let idents = List.map (fun mb -> mb.mb_id) bindings in
compile_recmodule
(fun id modl -> transl_module Tcoerce_none (Some(Pident id)) modl)
(fun id modl _loc -> transl_module Tcoerce_none (Some(Pident id)) modl)
bindings
(make_sequence toploop_setvalue_id idents)
| Tstr_class cl_list ->

7
byterun/ints.c
View File

@ -501,13 +501,6 @@ value caml_int64_direct_bswap(value v)
{ return caml_swap64(v); }
#endif
/* Microsoft introduced the LL integer literal suffix in Visual C++ .NET 2003 */
#if defined(_MSC_VER) && _MSC_VER < 1400
#define INT64_LITERAL(s) s ## i64
#else
#define INT64_LITERAL(s) s ## LL
#endif
CAMLprim value caml_int64_bswap(value v)
{
int64_t x = Int64_val(v);

7
config/m-nt.h
View File

@ -49,3 +49,10 @@
#undef NONSTANDARD_DIV_MOD
#define PROFINFO_WIDTH 0
/* Microsoft introduced the LL integer literal suffix in Visual C++ .NET 2003 */
#if defined(_MSC_VER) && _MSC_VER < 1400
#define INT64_LITERAL(s) s ## i64
#else
#define INT64_LITERAL(s) s ## LL
#endif

7
configure vendored
View File

@ -635,6 +635,7 @@ echo "#define SIZEOF_LONG $2" >> m.h
echo "#define SIZEOF_PTR $3" >> m.h
echo "#define SIZEOF_SHORT $4" >> m.h
echo "#define SIZEOF_LONGLONG $5" >> m.h
echo "#define INT64_LITERAL(s) s ## LL" >> m.h
# Determine endianness
@ -957,8 +958,8 @@ asppprofflags='-DPROFILING'
case "$arch,$system" in
amd64,macosx) if sh ./searchpath clang; then
as='clang -arch x86_64 -c'
aspp='clang -arch x86_64 -c'
as='clang -arch x86_64 -Wno-trigraphs -c'
aspp='clang -arch x86_64 -Wno-trigraphs -c'
else
as="${TOOLPREF}as -arch x86_64"
aspp="${TOOLPREF}gcc -arch x86_64 -c"
@ -986,7 +987,7 @@ case "$arch,$system" in
as="${TOOLPREF}as"
case "$ccfamily" in
clang-*)
aspp="${TOOLPREF}clang -c"
aspp="${TOOLPREF}clang -c -Wno-trigraphs"
;;
*)
aspp="${TOOLPREF}gcc -c"

4
driver/compenv.ml
View File

@ -404,7 +404,9 @@ let read_one_param ppf position name v =
| "can-discard" ->
can_discard := v ::!can_discard
| "timings" -> set "timings" [ print_timings ] v
| "timings" | "profile" ->
let if_on = if name = "timings" then [ `Time ] else Profile.all_columns in
profile_columns := if check_bool ppf name v then if_on else []
| "plugin" -> !load_plugin v

14
driver/compile.ml
View File

@ -27,7 +27,7 @@ open Compenv
let tool_name = "ocamlc"
let interface ppf sourcefile outputprefix =
Timings.time_call sourcefile (fun () ->
Profile.record_call sourcefile (fun () ->
Compmisc.init_path false;
let modulename = module_of_filename ppf sourcefile outputprefix in
Env.set_unit_name modulename;
@ -36,7 +36,7 @@ let interface ppf sourcefile outputprefix =
if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
if !Clflags.dump_source then fprintf ppf "%a@." Pprintast.signature ast;
Timings.(time_call typing) (fun () ->
Profile.(record_call typing) (fun () ->
let tsg = Typemod.type_interface sourcefile initial_env ast in
if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg;
let sg = tsg.sig_type in
@ -67,7 +67,7 @@ let print_if ppf flag printer arg =
let (++) x f = f x
let implementation ppf sourcefile outputprefix =
Timings.time_call sourcefile (fun () ->
Profile.record_call sourcefile (fun () ->
Compmisc.init_path false;
let modulename = module_of_filename ppf sourcefile outputprefix in
Env.set_unit_name modulename;
@ -77,7 +77,7 @@ let implementation ppf sourcefile outputprefix =
Pparse.parse_implementation ~tool_name ppf sourcefile
++ print_if ppf Clflags.dump_parsetree Printast.implementation
++ print_if ppf Clflags.dump_source Pprintast.structure
++ Timings.(time typing)
++ Profile.(record typing)
(Typemod.type_implementation sourcefile outputprefix modulename env)
++ print_if ppf Clflags.dump_typedtree
Printtyped.implementation_with_coercion
@ -88,9 +88,9 @@ let implementation ppf sourcefile outputprefix =
end else begin
let bytecode, required_globals =
(typedtree, coercion)
++ Timings.(time transl)
++ Profile.(record transl)
(Translmod.transl_implementation modulename)
++ Timings.(time ~accumulate:true generate)
++ Profile.(record ~accumulate:true generate)
(fun { Lambda.code = lambda; required_globals } ->
print_if ppf Clflags.dump_rawlambda Printlambda.lambda lambda
++ Simplif.simplify_lambda sourcefile
@ -103,7 +103,7 @@ let implementation ppf sourcefile outputprefix =
let oc = open_out_bin objfile in
try
bytecode
++ Timings.(time ~accumulate:true generate)
++ Profile.(record ~accumulate:true generate)
(Emitcode.to_file oc modulename objfile ~required_globals);
Warnings.check_fatal ();
close_out oc;

8
driver/main.ml
View File

@ -117,7 +117,8 @@ module Options = Main_args.Make_bytecomp_options (struct
let _drawlambda = set dump_rawlambda
let _dlambda = set dump_lambda
let _dinstr = set dump_instr
let _dtimings = set print_timings
let _dtimings () = profile_columns := [ `Time ]
let _dprofile () = profile_columns := Profile.all_columns
let _args = Arg.read_arg
let _args0 = Arg.read_arg0
@ -127,6 +128,9 @@ end)
let main () =
Clflags.add_arguments __LOC__ Options.list;
Clflags.add_arguments __LOC__
["-depend", Arg.Unit Makedepend.main_from_option,
"<options> Compute dependencies (use 'ocamlc -depend -help' for details)"];
try
readenv ppf Before_args;
Clflags.parse_arguments anonymous usage;
@ -198,5 +202,5 @@ let main () =
let () =
main ();
if !Clflags.print_timings then Timings.print Format.std_formatter;
Profile.print Format.std_formatter !Clflags.profile_columns;
exit 0

9
driver/main_args.ml
View File

@ -460,7 +460,11 @@ let mk_thread f =
;;
let mk_dtimings f =
"-dtimings", Arg.Unit f, " Print timings"
"-dtimings", Arg.Unit f, " Print timings information for each pass";
;;
let mk_dprofile f =
"-dprofile", Arg.Unit f, Profile.options_doc
;;
let mk_unbox_closures f =
@ -843,6 +847,7 @@ module type Compiler_options = sig
val _nopervasives : unit -> unit
val _dtimings : unit -> unit
val _dprofile : unit -> unit
val _args: string -> string array
val _args0: string -> string array
@ -1070,6 +1075,7 @@ struct
mk_dlambda F._dlambda;
mk_dinstr F._dinstr;
mk_dtimings F._dtimings;
mk_dprofile F._dprofile;
mk_args F._args;
mk_args0 F._args0;
@ -1263,6 +1269,7 @@ struct
mk_dinterval F._dinterval;
mk_dstartup F._dstartup;
mk_dtimings F._dtimings;
mk_dprofile F._dprofile;
mk_dump_pass F._dump_pass;
mk_args F._args;

1
driver/main_args.mli
View File

@ -100,6 +100,7 @@ module type Compiler_options = sig
val _nopervasives : unit -> unit
val _dtimings : unit -> unit
val _dprofile : unit -> unit
val _args: string -> string array
val _args0: string -> string array

626
driver/makedepend.ml Normal file
View File

@ -0,0 +1,626 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1999 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
open Compenv
open Parsetree
module StringMap = Depend.StringMap
let ppf = Format.err_formatter
(* Print the dependencies *)
type file_kind = ML | MLI;;
let load_path = ref ([] : (string * string array) list)
let ml_synonyms = ref [".ml"]
let mli_synonyms = ref [".mli"]
let shared = ref false
let native_only = ref false
let bytecode_only = ref false
let error_occurred = ref false
let raw_dependencies = ref false
let sort_files = ref false
let all_dependencies = ref false
let one_line = ref false
let files =
ref ([] : (string * file_kind * Depend.StringSet.t * string list) list)
let allow_approximation = ref false
let map_files = ref []
let module_map = ref StringMap.empty
let debug = ref false
(* Fix path to use '/' as directory separator instead of '\'.
Only under Windows. *)
let fix_slash s =
if Sys.os_type = "Unix" then s else begin
String.map (function '\\' -> '/' | c -> c) s
end
(* Since we reinitialize load_path after reading OCAMLCOMP,
we must use a cache instead of calling Sys.readdir too often. *)
let dirs = ref StringMap.empty
let readdir dir =
try
StringMap.find dir !dirs
with Not_found ->
let contents =
try
Sys.readdir dir
with Sys_error msg ->
Format.fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg;
error_occurred := true;
[||]
in
dirs := StringMap.add dir contents !dirs;
contents
let add_to_list li s =
li := s :: !li
let add_to_load_path dir =
try
let dir = Misc.expand_directory Config.standard_library dir in
let contents = readdir dir in
add_to_list load_path (dir, contents)
with Sys_error msg ->
Format.fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg;
error_occurred := true
let add_to_synonym_list synonyms suffix =
if (String.length suffix) > 1 && suffix.[0] = '.' then
add_to_list synonyms suffix
else begin
Format.fprintf Format.err_formatter "@[Bad suffix: '%s'@]@." suffix;
error_occurred := true
end
(* Find file 'name' (capitalized) in search path *)
let find_file name =
let uname = String.uncapitalize_ascii name in
let rec find_in_array a pos =
if pos >= Array.length a then None else begin
let s = a.(pos) in
if s = name || s = uname then Some s else find_in_array a (pos + 1)
end in
let rec find_in_path = function
[] -> raise Not_found
| (dir, contents) :: rem ->
match find_in_array contents 0 with
Some truename ->
if dir = "." then truename else Filename.concat dir truename
| None -> find_in_path rem in
find_in_path !load_path
let rec find_file_in_list = function
[] -> raise Not_found
| x :: rem -> try find_file x with Not_found -> find_file_in_list rem
let find_dependency target_kind modname (byt_deps, opt_deps) =
try
let candidates = List.map ((^) modname) !mli_synonyms in
let filename = find_file_in_list candidates in
let basename = Filename.chop_extension filename in
let cmi_file = basename ^ ".cmi" in
let cmx_file = basename ^ ".cmx" in
let ml_exists =
List.exists (fun ext -> Sys.file_exists (basename ^ ext)) !ml_synonyms in
let new_opt_dep =
if !all_dependencies then
match target_kind with
| MLI -> [ cmi_file ]
| ML ->
cmi_file :: (if ml_exists then [ cmx_file ] else [])
else
(* this is a make-specific hack that makes .cmx to be a 'proxy'
target that would force the dependency on .cmi via transitivity *)
if ml_exists
then [ cmx_file ]
else [ cmi_file ]
in
( cmi_file :: byt_deps, new_opt_dep @ opt_deps)
with Not_found ->
try
(* "just .ml" case *)
let candidates = List.map ((^) modname) !ml_synonyms in
let filename = find_file_in_list candidates in
let basename = Filename.chop_extension filename in
let cmi_file = basename ^ ".cmi" in
let cmx_file = basename ^ ".cmx" in
let bytenames =
if !all_dependencies then
match target_kind with
| MLI -> [ cmi_file ]
| ML -> [ cmi_file ]
else
(* again, make-specific hack *)
[basename ^ (if !native_only then ".cmx" else ".cmo")] in
let optnames =
if !all_dependencies
then match target_kind with
| MLI -> [ cmi_file ]
| ML -> [ cmi_file; cmx_file ]
else [ cmx_file ]
in
(bytenames @ byt_deps, optnames @ opt_deps)
with Not_found ->
(byt_deps, opt_deps)
let (depends_on, escaped_eol) = (":", " \\\n ")
let print_filename s =
let s = if !Clflags.force_slash then fix_slash s else s in
if not (String.contains s ' ') then begin
print_string s;
end else begin
let rec count n i =
if i >= String.length s then n
else if s.[i] = ' ' then count (n+1) (i+1)
else count n (i+1)
in
let spaces = count 0 0 in
let result = Bytes.create (String.length s + spaces) in
let rec loop i j =
if i >= String.length s then ()
else if s.[i] = ' ' then begin
Bytes.set result j '\\';
Bytes.set result (j+1) ' ';
loop (i+1) (j+2);
end else begin
Bytes.set result j s.[i];
loop (i+1) (j+1);
end
in
loop 0 0;
print_bytes result;
end
;;
let print_dependencies target_files deps =
let rec print_items pos = function
[] -> print_string "\n"
| dep :: rem ->
if !one_line || (pos + 1 + String.length dep <= 77) then begin
if pos <> 0 then print_string " "; print_filename dep;
print_items (pos + String.length dep + 1) rem
end else begin
print_string escaped_eol; print_filename dep;
print_items (String.length dep + 4) rem
end in
print_items 0 (target_files @ [depends_on] @ deps)
let print_raw_dependencies source_file deps =
print_filename source_file; print_string depends_on;
Depend.StringSet.iter
(fun dep ->
(* filter out "*predef*" *)
if (String.length dep > 0)
&& (match dep.[0] with
| 'A'..'Z' | '\128'..'\255' -> true
| _ -> false) then
begin
print_char ' ';
print_string dep
end)
deps;
print_char '\n'
(* Process one file *)
let report_err exn =
error_occurred := true;
Location.report_exception Format.err_formatter exn
let tool_name = "ocamldep"
let rec lexical_approximation lexbuf =
(* Approximation when a file can't be parsed.
Heuristic:
- first component of any path starting with an uppercase character is a
dependency.
- always skip the token after a dot, unless dot is preceded by a
lower-case identifier
- always skip the token after a backquote
*)
try
let rec process after_lident lexbuf =
match Lexer.token lexbuf with
| Parser.UIDENT name ->
Depend.free_structure_names :=
Depend.StringSet.add name !Depend.free_structure_names;
process false lexbuf
| Parser.LIDENT _ -> process true lexbuf
| Parser.DOT when after_lident -> process false lexbuf
| Parser.DOT | Parser.BACKQUOTE -> skip_one lexbuf
| Parser.EOF -> ()
| _ -> process false lexbuf
and skip_one lexbuf =
match Lexer.token lexbuf with
| Parser.DOT | Parser.BACKQUOTE -> skip_one lexbuf
| Parser.EOF -> ()
| _ -> process false lexbuf
in
process false lexbuf
with Lexer.Error _ -> lexical_approximation lexbuf
let read_and_approximate inputfile =
error_occurred := false;
Depend.free_structure_names := Depend.StringSet.empty;
let ic = open_in_bin inputfile in
try
seek_in ic 0;
Location.input_name := inputfile;
let lexbuf = Lexing.from_channel ic in
Location.init lexbuf inputfile;
lexical_approximation lexbuf;
close_in ic;
!Depend.free_structure_names
with exn ->
close_in ic;
report_err exn;
!Depend.free_structure_names
let read_parse_and_extract parse_function extract_function def ast_kind
source_file =
Depend.pp_deps := [];
Depend.free_structure_names := Depend.StringSet.empty;
try
let input_file = Pparse.preprocess source_file in
begin try
let ast =
Pparse.file ~tool_name Format.err_formatter
input_file parse_function ast_kind
in
let bound_vars =
List.fold_left
(fun bv modname ->
Depend.open_module bv (Longident.parse modname))
!module_map ((* PR#7248 *) List.rev !Clflags.open_modules)
in
let r = extract_function bound_vars ast in
Pparse.remove_preprocessed input_file;
(!Depend.free_structure_names, r)
with x ->
Pparse.remove_preprocessed input_file;
raise x
end
with x -> begin
report_err x;
if not !allow_approximation
then (Depend.StringSet.empty, def)
else (read_and_approximate source_file, def)
end
let print_ml_dependencies source_file extracted_deps pp_deps =
let basename = Filename.chop_extension source_file in
let byte_targets = [ basename ^ ".cmo" ] in
let native_targets =
if !all_dependencies
then [ basename ^ ".cmx"; basename ^ ".o" ]
else [ basename ^ ".cmx" ] in
let shared_targets = [ basename ^ ".cmxs" ] in
let init_deps = if !all_dependencies then [source_file] else [] in
let cmi_name = basename ^ ".cmi" in
let init_deps, extra_targets =
if List.exists (fun ext -> Sys.file_exists (basename ^ ext))
!mli_synonyms
then (cmi_name :: init_deps, cmi_name :: init_deps), []
else (init_deps, init_deps),
(if !all_dependencies then [cmi_name] else [])
in
let (byt_deps, native_deps) =
Depend.StringSet.fold (find_dependency ML)
extracted_deps init_deps in
if not !native_only then
print_dependencies (byte_targets @ extra_targets) (byt_deps @ pp_deps);
if not !bytecode_only then
begin
print_dependencies (native_targets @ extra_targets)
(native_deps @ pp_deps);
if !shared then
print_dependencies (shared_targets @ extra_targets)
(native_deps @ pp_deps)
end
let print_mli_dependencies source_file extracted_deps pp_deps =
let basename = Filename.chop_extension source_file in
let (byt_deps, _opt_deps) =
Depend.StringSet.fold (find_dependency MLI)
extracted_deps ([], []) in
print_dependencies [basename ^ ".cmi"] (byt_deps @ pp_deps)
let print_file_dependencies (source_file, kind, extracted_deps, pp_deps) =
if !raw_dependencies then begin
print_raw_dependencies source_file extracted_deps
end else
match kind with
| ML -> print_ml_dependencies source_file extracted_deps pp_deps
| MLI -> print_mli_dependencies source_file extracted_deps pp_deps
let ml_file_dependencies source_file =
let parse_use_file_as_impl lexbuf =
let f x =
match x with
| Ptop_def s -> s
| Ptop_dir _ -> []
in
List.flatten (List.map f (Parse.use_file lexbuf))
in
let (extracted_deps, ()) =
read_parse_and_extract parse_use_file_as_impl Depend.add_implementation ()
Pparse.Structure source_file
in
files := (source_file, ML, extracted_deps, !Depend.pp_deps) :: !files
let mli_file_dependencies source_file =
let (extracted_deps, ()) =
read_parse_and_extract Parse.interface Depend.add_signature ()
Pparse.Signature source_file
in
files := (source_file, MLI, extracted_deps, !Depend.pp_deps) :: !files
let process_file_as process_fun def source_file =
Compenv.readenv ppf (Before_compile source_file);
load_path := [];
List.iter add_to_load_path (
(!Compenv.last_include_dirs @
!Clflags.include_dirs @
!Compenv.first_include_dirs
));
Location.input_name := source_file;
try
if Sys.file_exists source_file then process_fun source_file else def
with x -> report_err x; def
let process_file source_file ~ml_file ~mli_file ~def =
if List.exists (Filename.check_suffix source_file) !ml_synonyms then
process_file_as ml_file def source_file
else if List.exists (Filename.check_suffix source_file) !mli_synonyms then
process_file_as mli_file def source_file
else def
let file_dependencies source_file =
process_file source_file ~def:()
~ml_file:ml_file_dependencies
~mli_file:mli_file_dependencies
let file_dependencies_as kind =
match kind with
| ML -> process_file_as ml_file_dependencies ()
| MLI -> process_file_as mli_file_dependencies ()
let sort_files_by_dependencies files =
let h = Hashtbl.create 31 in
let worklist = ref [] in
(* Init Hashtbl with all defined modules *)
let files = List.map (fun (file, file_kind, deps, pp_deps) ->
let modname =
String.capitalize_ascii (Filename.chop_extension (Filename.basename file))
in
let key = (modname, file_kind) in
let new_deps = ref [] in
Hashtbl.add h key (file, new_deps);
worklist := key :: !worklist;
(modname, file_kind, deps, new_deps, pp_deps)
) files in
(* Keep only dependencies to defined modules *)
List.iter (fun (modname, file_kind, deps, new_deps, _pp_deps) ->
let add_dep modname kind =
new_deps := (modname, kind) :: !new_deps;
in
Depend.StringSet.iter (fun modname ->
match file_kind with
ML -> (* ML depends both on ML and MLI *)
if Hashtbl.mem h (modname, MLI) then add_dep modname MLI;
if Hashtbl.mem h (modname, ML) then add_dep modname ML
| MLI -> (* MLI depends on MLI if exists, or ML otherwise *)
if Hashtbl.mem h (modname, MLI) then add_dep modname MLI
else if Hashtbl.mem h (modname, ML) then add_dep modname ML
) deps;
if file_kind = ML then (* add dep from .ml to .mli *)
if Hashtbl.mem h (modname, MLI) then add_dep modname MLI
) files;
(* Print and remove all files with no remaining dependency. Iterate
until all files have been removed (worklist is empty) or
no file was removed during a turn (cycle). *)
let printed = ref true in
while !printed && !worklist <> [] do
let files = !worklist in
worklist := [];
printed := false;
List.iter (fun key ->
let (file, deps) = Hashtbl.find h key in
let set = !deps in
deps := [];
List.iter (fun key ->
if Hashtbl.mem h key then deps := key :: !deps
) set;
if !deps = [] then begin
printed := true;
Printf.printf "%s " file;
Hashtbl.remove h key;
end else
worklist := key :: !worklist
) files
done;
if !worklist <> [] then begin
Format.fprintf Format.err_formatter
"@[Warning: cycle in dependencies. End of list is not sorted.@]@.";
let sorted_deps =
let li = ref [] in
Hashtbl.iter (fun _ file_deps -> li := file_deps :: !li) h;
List.sort (fun (file1, _) (file2, _) -> String.compare file1 file2) !li
in
List.iter (fun (file, deps) ->
Format.fprintf Format.err_formatter "\t@[%s: " file;
List.iter (fun (modname, kind) ->
Format.fprintf Format.err_formatter "%s.%s " modname
(if kind=ML then "ml" else "mli");
) !deps;
Format.fprintf Format.err_formatter "@]@.";
Printf.printf "%s " file) sorted_deps;
end;
Printf.printf "\n%!";
()
(* Map *)
let rec dump_map s0 ppf m =
let open Depend in
StringMap.iter
(fun key (Node(s1,m')) ->
let s = StringSet.diff s1 s0 in
if StringSet.is_empty s then
Format.fprintf ppf "@ @[<hv2>module %s : sig%a@;<1 -2>end@]"
key (dump_map (StringSet.union s1 s0)) m'
else
Format.fprintf ppf "@ module %s = %s" key (StringSet.choose s))
m
let process_ml_map =
read_parse_and_extract Parse.implementation Depend.add_implementation_binding
StringMap.empty Pparse.Structure
let process_mli_map =
read_parse_and_extract Parse.interface Depend.add_signature_binding
StringMap.empty Pparse.Signature
let parse_map fname =
map_files := fname :: !map_files ;
let old_transp = !Clflags.transparent_modules in
Clflags.transparent_modules := true;
let (deps, m) =
process_file fname ~def:(Depend.StringSet.empty, StringMap.empty)
~ml_file:process_ml_map
~mli_file:process_mli_map
in
Clflags.transparent_modules := old_transp;
let modname =
String.capitalize_ascii
(Filename.basename (Filename.chop_extension fname)) in
if StringMap.is_empty m then
report_err (Failure (fname ^ " : empty map file or parse error"));
let mm = Depend.make_node m in
if !debug then begin
Format.printf "@[<v>%s:%t%a@]@." fname
(fun ppf -> Depend.StringSet.iter (Format.fprintf ppf " %s") deps)
(dump_map deps) (StringMap.add modname mm StringMap.empty)
end;
let mm = Depend.(weaken_map (StringSet.singleton modname) mm) in
module_map := StringMap.add modname mm !module_map
;;
(* Entry point *)
let print_version () =
Format.printf "ocamldep, version %s@." Sys.ocaml_version;
exit 0;
;;
let print_version_num () =
Format.printf "%s@." Sys.ocaml_version;
exit 0;
;;
let main () =
Clflags.classic := false;
add_to_list first_include_dirs Filename.current_dir_name;
Compenv.readenv ppf Before_args;
Clflags.reset_arguments (); (* reset arguments from ocamlc/ocamlopt *)
Clflags.add_arguments __LOC__ [
"-absname", Arg.Set Location.absname,
" Show absolute filenames in error messages";
"-all", Arg.Set all_dependencies,
" Generate dependencies on all files";
"-allow-approx", Arg.Set allow_approximation,
" Fallback to a lexer-based approximation on unparseable files";
"-as-map", Arg.Set Clflags.transparent_modules,
" Omit delayed dependencies for module aliases (-no-alias-deps -w -49)";
(* "compiler uses -no-alias-deps, and no module is coerced"; *)
"-debug-map", Arg.Set debug,
" Dump the delayed dependency map for each map file";
"-I", Arg.String (add_to_list Clflags.include_dirs),
"<dir> Add <dir> to the list of include directories";
"-impl", Arg.String (file_dependencies_as ML),
"<f> Process <f> as a .ml file";
"-intf", Arg.String (file_dependencies_as MLI),
"<f> Process <f> as a .mli file";
"-map", Arg.String parse_map,
"<f> Read <f> and propagate delayed dependencies to following files";
"-ml-synonym", Arg.String(add_to_synonym_list ml_synonyms),
"<e> Consider <e> as a synonym of the .ml extension";
"-mli-synonym", Arg.String(add_to_synonym_list mli_synonyms),
"<e> Consider <e> as a synonym of the .mli extension";
"-modules", Arg.Set raw_dependencies,
" Print module dependencies in raw form (not suitable for make)";
"-native", Arg.Set native_only,
" Generate dependencies for native-code only (no .cmo files)";
"-bytecode", Arg.Set bytecode_only,
" Generate dependencies for bytecode-code only (no .cmx files)";
"-one-line", Arg.Set one_line,
" Output one line per file, regardless of the length";
"-open", Arg.String (add_to_list Clflags.open_modules),
"<module> Opens the module <module> before typing";
"-plugin", Arg.String Compplugin.load,
"<plugin> Load dynamic plugin <plugin>";
"-pp", Arg.String(fun s -> Clflags.preprocessor := Some s),
"<cmd> Pipe sources through preprocessor <cmd>";
"-ppx", Arg.String (add_to_list first_ppx),
"<cmd> Pipe abstract syntax trees through preprocessor <cmd>";
"-shared", Arg.Set shared,
" Generate dependencies for native plugin files (.cmxs targets)";
"-slash", Arg.Set Clflags.force_slash,
" (Windows) Use forward slash / instead of backslash \\ in file paths";
"-sort", Arg.Set sort_files,
" Sort files according to their dependencies";
"-version", Arg.Unit print_version,
" Print version and exit";
"-vnum", Arg.Unit print_version_num,
" Print version number and exit";
"-args", Arg.Expand Arg.read_arg,
"<file> Read additional newline separated command line arguments \n\
\ from <file>";
"-args0", Arg.Expand Arg.read_arg0,
"<file> Read additional NUL separated command line arguments from \n\
\ <file>"
];
let usage =
Printf.sprintf "Usage: %s [options] <source files>\nOptions are:"
(Filename.basename Sys.argv.(0))
in
Clflags.parse_arguments file_dependencies usage;
Compenv.readenv ppf Before_link;
if !sort_files then sort_files_by_dependencies !files
else List.iter print_file_dependencies (List.sort compare !files);
exit (if !error_occurred then 2 else 0)
let main_from_option () =
if Sys.argv.(1) <> "-depend" then begin
Printf.eprintf
"Fatal error: argument -depend must be used as first argument.\n%!";
exit 2;
end;
incr Arg.current;
Sys.argv.(0) <- Sys.argv.(0) ^ " -depend";
Sys.argv.(!Arg.current) <- Sys.argv.(0);
main ()

19
driver/makedepend.mli Normal file
View File

@ -0,0 +1,19 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1999 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
val main : unit -> unit
(* entry point when called from the -depend option of ocamlc/ocamlopt *)
val main_from_option : unit -> unit

16
driver/optcompile.ml
View File

@ -28,7 +28,7 @@ open Compenv
let tool_name = "ocamlopt"
let interface ppf sourcefile outputprefix =
Timings.time_call sourcefile (fun () ->
Profile.record_call sourcefile (fun () ->
Compmisc.init_path false;
let modulename = module_of_filename ppf sourcefile outputprefix in
Env.set_unit_name modulename;
@ -36,7 +36,7 @@ let interface ppf sourcefile outputprefix =
let ast = Pparse.parse_interface ~tool_name ppf sourcefile in
if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
if !Clflags.dump_source then fprintf ppf "%a@." Pprintast.signature ast;
Timings.(time_call typing) (fun () ->
Profile.(record_call typing) (fun () ->
let tsg = Typemod.type_interface sourcefile initial_env ast in
if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg;
let sg = tsg.sig_type in
@ -68,7 +68,7 @@ let (++) x f = f x
let (+++) (x, y) f = (x, f y)
let implementation ~backend ppf sourcefile outputprefix =
Timings.time_call sourcefile (fun () ->
Profile.record_call sourcefile (fun () ->
Compmisc.init_path true;
let modulename = module_of_filename ppf sourcefile outputprefix in
Env.set_unit_name modulename;
@ -81,7 +81,7 @@ let implementation ~backend ppf sourcefile outputprefix =
ast
++ print_if ppf Clflags.dump_parsetree Printast.implementation
++ print_if ppf Clflags.dump_source Pprintast.structure
++ Timings.(time typing)
++ Profile.(record typing)
(Typemod.type_implementation sourcefile outputprefix modulename env)
++ print_if ppf Clflags.dump_typedtree
Printtyped.implementation_with_coercion
@ -95,9 +95,9 @@ let implementation ~backend ppf sourcefile outputprefix =
Clflags.unbox_specialised_args := false
end;
(typedtree, coercion)
++ Timings.(time transl)
++ Profile.(record transl)
(Translmod.transl_implementation_flambda modulename)
++ Timings.(time generate)
++ Profile.(record generate)
(fun { Lambda.module_ident; main_module_block_size;
required_globals; code } ->
((module_ident, main_module_block_size), code)
@ -119,10 +119,10 @@ let implementation ~backend ppf sourcefile outputprefix =
else begin
Clflags.use_inlining_arguments_set Clflags.classic_arguments;
(typedtree, coercion)
++ Timings.(time transl)
++ Profile.(record transl)
(Translmod.transl_store_implementation modulename)
++ print_if ppf Clflags.dump_rawlambda Printlambda.program
++ Timings.(time generate)
++ Profile.(record generate)
(fun program ->
{ program with
Lambda.code = Simplif.simplify_lambda sourcefile

8
driver/optmain.ml
View File

@ -224,7 +224,8 @@ module Options = Main_args.Make_optcomp_options (struct
let _dlinear = set dump_linear
let _dinterval = set dump_interval
let _dstartup = set keep_startup_file
let _dtimings = set print_timings
let _dtimings () = profile_columns := [ `Time ]
let _dprofile () = profile_columns := Profile.all_columns
let _opaque = set opaque
let _args = Arg.read_arg
@ -239,6 +240,9 @@ let main () =
try
readenv ppf Before_args;
Clflags.add_arguments __LOC__ (Arch.command_line_options @ Options.list);
Clflags.add_arguments __LOC__
["-depend", Arg.Unit Makedepend.main_from_option,
"<options> Compute dependencies (use 'ocamlopt -depend -help' for details)"];
Clflags.parse_arguments anonymous usage;
Compmisc.read_color_env ppf;
if !gprofile && not Config.profiling then
@ -309,5 +313,5 @@ let main () =
let () =
main ();
if !Clflags.print_timings then Timings.print Format.std_formatter;
Profile.print Format.std_formatter !Clflags.profile_columns;
exit 0

10
driver/pparse.ml
View File

@ -38,7 +38,7 @@ let preprocess sourcefile =
match !Clflags.preprocessor with
None -> sourcefile
| Some pp ->
Timings.time "-pp"
Profile.record "-pp"
(call_external_preprocessor sourcefile) pp
@ -180,13 +180,13 @@ let file_aux ppf ~tool_name inputfile (type a) parse_fun invariant_fun
seek_in ic 0;
let lexbuf = Lexing.from_channel ic in
Location.init lexbuf inputfile;
Timings.time_call "parser" (fun () -> parse_fun lexbuf)
Profile.record_call "parser" (fun () -> parse_fun lexbuf)
end
with x -> close_in ic; raise x
in
close_in ic;
let ast =
Timings.time_call "-ppx" (fun () ->
Profile.record_call "-ppx" (fun () ->
apply_rewriters ~restore:false ~tool_name kind ast) in
if is_ast_file || !Clflags.all_ppx <> [] then invariant_fun ast;
ast
@ -230,10 +230,10 @@ module InterfaceHooks = Misc.MakeHooks(struct
end)
let parse_implementation ppf ~tool_name sourcefile =
Timings.time_call "parsing" (fun () ->
Profile.record_call "parsing" (fun () ->
parse_file ~tool_name Ast_invariants.structure
ImplementationHooks.apply_hooks Structure ppf sourcefile)
let parse_interface ppf ~tool_name sourcefile =
Timings.time_call "parsing" (fun () ->
Profile.record_call "parsing" (fun () ->
parse_file ~tool_name Ast_invariants.signature
InterfaceHooks.apply_hooks Signature ppf sourcefile)

2
driver/pparse.mli
View File

@ -13,6 +13,8 @@
(* *)
(**************************************************************************)
(** Driver for the parser, external preprocessors and ast plugin hooks *)
open Format
type error =

6
man/Makefile
View File

@ -20,9 +20,9 @@ INSTALL_DIR=$(DESTDIR)$(MANDIR)/man$(PROGRAMS_MAN_SECTION)
install:
for i in *.m; do cp \
$$i $(INSTALL_DIR)/`basename $$i .m`.$(PROGRAMS_MAN_SECTION); done
echo '.so man$(PROGRAMS_MAN_SECTION)/ocamlc.$(MANEXT)' \
echo '.so man$(PROGRAMS_MAN_SECTION)/ocamlc.$(PROGRAMS_MAN_SECTION)' \
> $(INSTALL_DIR)/ocamlc.opt.$(PROGRAMS_MAN_SECTION)
echo '.so man$(PROGRAMS_MAN_SECTION)/ocamlopt.$(MANEXT)' \
echo '.so man$(PROGRAMS_MAN_SECTION)/ocamlopt.$(PROGRAMS_MAN_SECTION)' \
> $(INSTALL_DIR)/ocamlopt.opt.$(PROGRAMS_MAN_SECTION)
echo '.so man$(PROGRAMS_MAN_SECTION)/ocamlcp.$(MANEXT)' \
echo '.so man$(PROGRAMS_MAN_SECTION)/ocamlcp.$(PROGRAMS_MAN_SECTION)' \
> $(INSTALL_DIR)/ocamloptp.$(PROGRAMS_MAN_SECTION)

3
man/ocamlc.m
View File

@ -316,6 +316,9 @@ command on executables produced by
.BR ocamlc\ \-custom ,
this would remove the bytecode part of the executable.
.TP
.BI \-depend\ ocamldep-args
Compute dependencies, as ocamldep would do.
.TP
.BI \-dllib\ \-l libname
Arrange for the C shared library
.BI dll libname .so

3
man/ocamlopt.m
View File

@ -252,6 +252,9 @@ Print the version number of
.BR ocamlopt (1)
and a detailed summary of its configuration, then exit.
.TP
.BI \-depend\ ocamldep-args
Compute dependencies, as ocamldep would do.
.TP
.BI \-for\-pack \ module\-path
Generate an object file (.cmx and .o files) that can later be included
as a sub-module (with the given access path) of a compilation unit

26
manual/README.md
View File

@ -125,23 +125,33 @@ The pseudo-environment `caml_example` evaluates its contents using an ocaml
interpreter and then translates both the input code and the interpreter output
to latex code, e.g.
```latex
\begin{caml_example}
\begin{caml_example}{toplevel}
let f x = x;;
\end{caml_example}
```
Note that the toplevel output can be suppressed by using a `*` suffix:
```latex
\begin{caml_example*}
let f x = x;;
\begin{caml_example*}{verbatim}
let f x = x
\end{caml_example*}
```
The `{verbatim}` or `{toplevel}` argument of the environment corresponds
to the the mode of the example, two modes are available `toplevel` and
`verbatim`.
The `toplevel` mode mimics the appearance and behavior of the toplevel.
In particular, toplevel examples must end with a double semi-colon `;;`,
otherwise an error would be raised.
The `verbatim` does not require a final `;;` and is intended to be
a lighter mode for code examples.
By default, `caml_tex2` raises an error and stops if the output of one
the `caml_example` environment contains an unexpected error or warning.
If such an error or warning is, in fact, expected, it is necessary to
indicate the expected output status to `caml_tex2` by adding either
an option to the `caml_example` environment:
```latex
\begin{caml_example}[error]
\begin{caml_example}{toplevel}[error]
1 + 2. ;;
\end{caml_example}
or for warning
@ -152,7 +162,7 @@ let f None = None;;
or an annotation to the concerned phrase:
```latex
\begin{caml_example}
\begin{caml_example}{toplevel}
1 + 2. [@@expect error] ;;
let f None = None [@@expect warning 8];;
3 + 4 [@@expect ok];;
@ -164,10 +174,10 @@ and can be used to evaluate OCaml expressions in the toplevel without
printing anything:
```latex
\begin{caml_eval}
let pi = 4. *. atan 1.
let pi = 4. *. atan 1.;;
\end{caml_eval}
\begin{caml_example}
let f x = x +. pi
\begin{caml_example}{toplevel}
let f x = x +. pi;;
\end{caml_example}
```
Beware that the detection code for these pseudo-environments is quite brittle

6
manual/manual/Makefile
View File

@ -18,6 +18,9 @@ OCAMLDOC=$(SRC)/byterun/ocamlrun $(SRC)/ocamldoc/ocamldoc -hide Pervasives
MLIS=$(SRC)/stdlib/*.mli \
$(SRC)/utils/*.mli \
$(SRC)/parsing/*.mli \
$(SRC)/driver/pparse.mli \
$(SRC)/typing/typemod.mli \
$(SRC)/bytecomp/simplif.mli \
$(SRC)/otherlibs/bigarray/bigarray.mli \
$(SRC)/otherlibs/dynlink/dynlink.mli \
$(SRC)/otherlibs/graph/graphics.mli \
@ -63,6 +66,9 @@ html: files
-I $(SRC)/stdlib \
-I $(SRC)/utils \
-I $(SRC)/parsing \
-I $(SRC)/driver \
-I $(SRC)/typing \
-I $(SRC)/bytecomp \
-I $(SRC)/otherlibs/bigarray \
-I $(SRC)/otherlibs/dynlink \
-I $(SRC)/otherlibs/graph \

1
manual/manual/allfiles.etex
View File

@ -75,6 +75,7 @@ and as a
\input{flambda.tex}
\input{spacetime.tex}
\input{afl-fuzz.tex}
\input{plugins}
\part{The OCaml library}
\label{p:library}

2
manual/manual/cmds/Makefile
View File

@ -1,7 +1,7 @@
FILES=comp.tex top.tex runtime.tex native.tex lexyacc.tex intf-c.tex \
depend.tex profil.tex debugger.tex browser.tex ocamldoc.tex \
warnings-help.tex ocamlbuild.tex flambda.tex spacetime.tex \
afl-fuzz.tex unified-options.tex
afl-fuzz.tex plugins.tex unified-options.tex
TOPDIR=../../..
include $(TOPDIR)/Makefile.tools

88
manual/manual/cmds/plugins.etex Normal file
View File

@ -0,0 +1,88 @@
\chapter{Compiler plugins\label{c:plugins}}
\pdfchapterfold{-9}{Compiler plugind}
%HEVEA\cutname{plugins.html}
\section{Overview}
Starting from OCaml 4.03, it is possible to extend the native and bytecode compilers
with plugins using the "-plugin" command line option of both tools.
This possibility is also available for "ocamldep" for OCaml version ulterior to 4.05.
Beware however that plugins are an advanced feature of which the design
is still in flux and breaking changes may happen in the future. Plugins features
are based on the compiler library API. In complement, new hooks have been added to
the compiler to increase its flexibility.
In particular, hooks are available in the
\ifouthtml\ahref{libref/Pparse.html}{\texttt{Pparse} module}
\else\texttt{Pparse} module (see section~\ref{Pparse})\fi
to transform the parsed abstract syntax tree, providing similar functionality
to extension point based preprocessors.
Other hooks are available to analyze the typed tree in the
\ifouthtml\ahref{libref/Typemod.html}{\texttt{Typemod} module}
\else\texttt{Typemod} module (see section~\ref{Typemod})\fi
after the type-checking phase of the compiler. Since the typed tree relies
on numerous invariants that play a vital part in ulterior phases of the
compiler, it is not possible however to transform the typed tree.
Similarly, the intermediary lambda representation can be modified by using the
hooks provided in the
\ifouthtml\ahref{libref/Simplif.html}{\texttt{Simplif} module}
\else\texttt{Simplif} module (see section~\ref{Simplif})\fi.
A plugin can also add new options to a tool through the
"Clflags.add_arguments" function (see
\ifouthtml\ahref{libref/Clflags.html}{\texttt{Clflags} module}
\else\texttt{Clflags} module (see section~\ref{Clflags})\fi).
Plugins are dynamically loaded and need to be compiled in the same mode (i.e.
native or bytecode) that the tool they extend.
\section{Basic example}
As an illustration, we shall build a simple "Hello world" plugin that adds
a simple statement "print_endline \"Hello from:$sourcefile\"" to a compiled file.
The simplest way to implement this feature is to modify the abstract syntax
tree. We will therefore add an hooks to the "Pparse.ImplementationHooks".
Since the proposed modification is very basic, we could implement the hook
directly. However, for the sake of this illustration, we use the "Ast_mapper"
structure that provides a better path to build more interesting plugins.
The first step is to build the AST fragment corresponding to the
evaluation of "print_endline":
\begin{verbatim}
let print_endline name =
let open Ast_helper in
let print_endline = Exp.ident
@@ Location.mknoloc @@Longident.Lident "print_endline" in
let hello = Exp.constant @@ Const.string @@ "Hello from: " ^ name in
Str.eval @@ Exp.apply print_endline [Asttypes.Nolabel, hello]
\end{verbatim}%
Then, we can construct an ast mapper that adds this fragment to the parsed
ast tree.
\begin{verbatim}
let add_hello name (mapper:Ast_mapper.mapper) structure =
let default = Ast_mapper.default_mapper in
(print_endline name) :: (default.structure default structure)
let ast_mapper name =
{ Ast_mapper.default_mapper with structure = add_hello name }
\end{verbatim}%
%
Once this AST mapper is constructed, we need to convert it to a hook and adds this
hook to the "Pparse.ImplementationsHooks".
\begin{verbatim}
let transform hook_info structure =
let astm = ast_mapper hook_info.Misc.sourcefile in
astm.structure astm structure
let () = Pparse.ImplementationHooks.add_hook "Hello world hook" transform
\end{verbatim}
%
The resulting simplistic plugin can then be compiled with
\begin{verbatim}
$ ocamlopt -I +compiler-libs -shared plugin.ml -o plugin.cmxs
\end{verbatim}
%
Compiling other files with this plugin enabled is then as simple as
\begin{verbatim}
$ ocamlopt -plugin plugin.cmxs test.ml -o test
\end{verbatim}

14
manual/manual/cmds/unified-options.etex
View File

@ -83,10 +83,12 @@ Read additional newline-terminated command line arguments from \var{filename}.
\notop{\item["-bin-annot"]
Dump detailed information about the compilation (types, bindings,
tail-calls, etc) in binary format. The information for file \var{src}".ml"
is put into file \var{src}".cmt". In case of a type error, dump
(resp. \var{src}".mli") is put into file \var{src}".cmt"
(resp. \var{src}".cmti"). In case of a type error, dump
all the information inferred by the type-checker before the error.
The "*.cmt" files produced by "-bin-annot" contain more information
and are much more compact than the files produced by "-annot".
The "*.cmt" and "*.cmti" files produced by "-bin-annot" contain
more information and are much more compact than the files produced by
"-annot".
}%notop
\notop{\item["-c"]
@ -171,6 +173,12 @@ this would remove the bytecode part of the executable.
\end{unix}
}%comp
\notop{%
\item["-depend" \var{ocamldep-args}]
Compute dependencies, as the "ocamldep" command would do. The remaining
arguments are interpreted as if they were given to the "ocamldep" command.
}%notop
\comp{
\item["-dllib" "-l"\var{libname}]
Arrange for the C shared library "dll"\var{libname}".so"

11
manual/manual/library/Makefile
View File

@ -10,8 +10,11 @@ STDLIB_INTF=Arg.tex Array.tex ArrayLabels.tex Char.tex Complex.tex \
Weak.tex Callback.tex Buffer.tex StdLabels.tex \
Bytes.tex BytesLabels.tex Spacetime.tex
COMPILER_LIBS_PLUGIN_HOOKS=Pparse.tex Typemod.tex
COMPILER_LIBS_INTF=Asthelper.tex Astmapper.tex Asttypes.tex \
Lexer.tex Location.tex Longident.tex Parse.tex Pprintast.tex Printast.tex
Lexer.tex Location.tex Longident.tex Parse.tex Pprintast.tex Printast.tex \
$(COMPILER_LIBS_PLUGIN_HOOKS)
OTHERLIB_INTF=Unix.tex UnixLabels.tex Str.tex \
Num.tex Arithstatus.tex Bigint.tex \
@ -25,6 +28,9 @@ INTF=$(CORE_INTF) $(STDLIB_INTF) $(COMPILER_LIBS_INTF) $(OTHERLIB_INTF)
MLIS=$(CSLDIR)/stdlib/*.mli \
$(CSLDIR)/utils/*.mli \
$(CSLDIR)/parsing/*.mli \
$(CSLDIR)/driver/pparse.mli \
$(CSLDIR)/typing/typemod.mli \
$(CSLDIR)/bytecomp/simplif.mli \
$(CSLDIR)/otherlibs/bigarray/bigarray.mli \
$(CSLDIR)/otherlibs/dynlink/dynlink.mli \
$(CSLDIR)/otherlibs/graph/graphics.mli \
@ -60,6 +66,9 @@ $(INTF): $(MLIS)
-I $(CSLDIR)/utils \
-I $(CSLDIR)/stdlib \
-I $(CSLDIR)/parsing \
-I $(CSLDIR)/typing \
-I $(CSLDIR)/driver \
-I $(CSLDIR)/bytecomp \
-I $(CSLDIR)/otherlibs/bigarray \
-I $(CSLDIR)/otherlibs/dynlink \
-I $(CSLDIR)/otherlibs/graph \

18
manual/manual/library/compilerlibs.etex
View File

@ -5,7 +5,8 @@ This chapter describes the OCaml front-end, which declares the abstract
syntax tree used by the compiler, provides a way to parse, print
and pretty-print OCaml code, and ultimately allows to write abstract
syntax tree preprocessors invoked via the {\tt -ppx} flag (see chapters~\ref{c:camlc}
and~\ref{c:nativecomp}).
and~\ref{c:nativecomp}) and plugins invoked via the {\tt -plugin} flag
(see chapter~\ref{c:plugins}).
It is important to note that the exported front-end interface follows the evolution of the OCaml language and implementation, and thus does not provide {\bf any} backwards compatibility guarantees.
@ -56,3 +57,18 @@ type\\*"#load \"compiler-libs/ocamlcommon.cma\";;".
% \input{Printast.tex}
\fi
\ifouthtml
The following modules provides hooks for compiler plugins:
\begin{links}
\item \ahref{libref/Pparse.html}{Module \texttt{Pparse}: OCaml parser driver}
\item \ahref{libref/Typemod.html}{Module \texttt{Typemod}:
OCaml module type checking}
\item \ahref{libref/Simplif.html}{Module \texttt{Simplif}: Lambda simplification}
\item \ahref{libref/Clflags.html}{Module \texttt{Clflags}: command line flags}
\end{links}
\else
\input{Pparse.tex}
\input{Typemod.tex}
\input{Simplif.tex}
\input{Clflags.tex}
\fi

6
manual/manual/refman/Makefile
View File

@ -6,7 +6,8 @@ TOPDIR=../../..
include $(TOPDIR)/Makefile.tools
CAMLLATEX= $(OCAMLRUN) ../../tools/caml-tex2
CAMLLATEX= $(OCAMLRUN) ../../tools/caml-tex2 -caml "TERM=norepeat $(OCAML)" \
-n 80 -v false
TRANSF=../../tools/transf
TEXQUOTE=../../tools/texquote2
@ -22,8 +23,7 @@ clean:
.SUFFIXES: .etex .tex
exten.tex:exten.etex
@$(CAMLLATEX) -caml "TERM=norepeat $(OCAML)" -n 80 -v false \
-o $*.caml_tex_error.tex $*.etex \
@$(CAMLLATEX) -o $*.caml_tex_error.tex $*.etex \
&& mv $*.caml_tex_error.tex $*.gen.tex \
&& $(OCAMLRUN) $(TRANSF) < $*.gen.tex > $*.transf_error.tex \
&& mv $*.transf_error.tex $*.gen.tex\

43
manual/manual/refman/exten.etex
View File

@ -458,8 +458,8 @@ actually be unified with "int".
The other application is to ensure that some definition is sufficiently
polymorphic:
\begin{caml_example}[error]
let id: 'a. 'a -> 'a = fun x -> x + 1;;
\begin{caml_example}{verbatim}[error]
let id: 'a. 'a -> 'a = fun x -> x + 1
\end{caml_example}
\section{Locally abstract types}
@ -863,7 +863,7 @@ parameters.
A natural application of destructive substitution is merging two
signatures sharing a type name.
\begin{caml_example*}
\begin{caml_example*}{verbatim}
module type Printable = sig
type t
val print : Format.formatter -> t -> unit
@ -875,26 +875,26 @@ signatures sharing a type name.
module type PrintableComparable = sig
include Printable
include Comparable with type t := t
end;;
end
\end{caml_example*}
One can also use this to completely remove a field:
\begin{caml_example}
module type S = Comparable with type t := int;;
\begin{caml_example}{verbatim}
module type S = Comparable with type t := int
\end{caml_example}
or to rename one:
\begin{caml_example}
\begin{caml_example}{verbatim}
module type S = sig
type u
include Comparable with type t := u
end;;
end
\end{caml_example}
Note that you can also remove manifest types, by substituting with the
same type.
\begin{caml_example}
\begin{caml_example}{verbatim}
module type ComparableInt = Comparable with type t = int ;;
module type CompareInt = ComparableInt with type t := int ;;
module type CompareInt = ComparableInt with type t := int
\end{caml_example}
\section{Type-level module aliases}
@ -929,8 +929,8 @@ satisfying the above constraints,
\begin{caml_eval}
module P = struct end
\end{caml_eval}
\begin{caml_example*}
module N = P;;
\begin{caml_example*}{verbatim}
module N = P
\end{caml_example*}
has type
\caml
@ -1287,27 +1287,26 @@ compiler generates these names according to the following nomenclature:
\item First, types whose name starts with a "$" are existentials.
\item "$Constr_'a" denotes an existential type introduced for the type
variable "'a" of the GADT constructor "Constr":
\begin{caml_example}[error]
\begin{caml_example}{verbatim}[error]
type any = Any : 'name -> any
let escape (Any x) = x;;
let escape (Any x) = x
\end{caml_example}
\item "$Constr" denotes an existential type introduced for an anonymous %$
type variable in the GADT constructor "Constr":
\begin{caml_example}[error]
\begin{caml_example}{verbatim}[error]
type any = Any : _ -> any
let escape (Any x) = x;;
let escape (Any x) = x
\end{caml_example}
\item "$'a" if the existential variable was unified with the type %$
variable "'a" during typing:
\begin{caml_example}[error]
\begin{caml_example}{verbatim}[error]
type ('arg,'result,'aux) fn =
| Fun: ('a ->'b) -> ('a,'b,unit) fn
| Mem1: ('a ->'b) * 'a * 'b -> ('a, 'b, 'a * 'b) fn
let apply: ('arg,'result, _ ) fn -> 'arg -> 'result = fun f x ->
match f with
| Fun f -> f x
| Mem1 (f,y,fy) -> if x = y then fy else f x;;
| Mem1 (f,y,fy) -> if x = y then fy else f x
\end{caml_example}
\item "$n" (n a number) is an internally generated existential %$
which could not be named using one of the previous schemes.
@ -1808,13 +1807,13 @@ Some extension nodes are understood by the compiler itself:
constructor slot.
\end{itemize}
\begin{caml_example*}
\begin{caml_example*}{verbatim}
type t = ..
type t += X of int | Y of string
let x = [%extension_constructor X]
let y = [%extension_constructor Y];;
let y = [%extension_constructor Y]
\end{caml_example*}
\begin{caml_example}
\begin{caml_example}{toplevel}
x <> y;;
\end{caml_example}

68
manual/manual/tutorials/advexamples.etex
View File

@ -52,7 +52,7 @@ module Euro : MONEY =
end
end;;
\end{caml_eval}
\begin{caml_example}
\begin{caml_example}{toplevel}
let euro = new Euro.c;;
let zero = euro 0.;;
let neg x = x#times (-1.);;
@ -67,7 +67,7 @@ class account =
let c = new account in c # deposit (euro 100.); c # withdraw (euro 50.);;
\end{caml_example}
We now refine this definition with a method to compute interest.
\begin{caml_example}
\begin{caml_example}{toplevel}
class account_with_interests =
object (self)
inherit account
@ -81,7 +81,7 @@ that will manage monthly or yearly updates of the account.
We should soon fix a bug in the current definition: the deposit method can
be used for withdrawing money by depositing negative amounts. We can
fix this directly:
\begin{caml_example}
\begin{caml_example}{toplevel}
class safe_account =
object
inherit account
@ -89,7 +89,7 @@ class safe_account =
end;;
\end{caml_example}
However, the bug might be fixed more safely by the following definition:
\begin{caml_example}
\begin{caml_example}{toplevel}
class safe_account =
object
inherit account as unsafe
@ -104,7 +104,7 @@ the method "deposit".
To keep track of operations, we extend the class with a mutable field
"history" and a private method "trace" to add an operation in the
log. Then each method to be traced is redefined.
\begin{caml_example}
\begin{caml_example}{toplevel}
type 'a operation = Deposit of 'a | Retrieval of 'a;;
class account_with_history =
object (self)
@ -120,7 +120,7 @@ class account_with_history =
One may wish to open an account and simultaneously deposit some initial
amount. Although the initial implementation did not address this
requirement, it can be achieved by using an initializer.
\begin{caml_example}
\begin{caml_example}{toplevel}
class account_with_deposit x =
object
inherit account_with_history
@ -128,7 +128,7 @@ class account_with_deposit x =
end;;
\end{caml_example}
A better alternative is:
\begin{caml_example}
\begin{caml_example}{toplevel}
class account_with_deposit x =
object (self)
inherit account_with_history
@ -138,20 +138,20 @@ class account_with_deposit x =
Indeed, the latter is safer since the call to "deposit" will automatically
benefit from safety checks and from the trace.
Let's test it:
\begin{caml_example}
\begin{caml_example}{toplevel}
let ccp = new account_with_deposit (euro 100.) in
let _balance = ccp#withdraw (euro 50.) in
ccp#history;;
\end{caml_example}
Closing an account can be done with the following polymorphic function:
\begin{caml_example}
\begin{caml_example}{toplevel}
let close c = c#withdraw c#balance;;
\end{caml_example}
Of course, this applies to all sorts of accounts.
Finally, we gather several versions of the account into a module "Account"
abstracted over some currency.
\begin{caml_example*}
\begin{caml_example*}{toplevel}
let today () = (01,01,2000) (* an approximation *)
module Account (M:MONEY) =
struct
@ -215,7 +215,7 @@ the same code can be used to provide accounts in different currencies.
The class "bank" is the {\em real} implementation of the bank account (it
could have been inlined). This is the one that will be used for further
extensions, refinements, etc. Conversely, the client will only be given the client view.
\begin{caml_example*}
\begin{caml_example*}{toplevel}
module Euro_account = Account(Euro);;
module Client = Euro_account.Client (Euro_account);;
new Client.account (new Euro.c 100.);;
@ -236,7 +236,7 @@ It is important to provide the client's view as a functor
specialization of the "bank".
The functor "Client" may remain unchanged and be passed
the new definition to initialize a client's view of the extended account.
\begin{caml_example*}
\begin{caml_example*}{toplevel}
module Investment_account (M : MONEY) =
struct
type m = M.c
@ -261,7 +261,7 @@ new Client.account (new Euro.c 100.);;
\end{caml_eval}
The functor "Client" may also be redefined when some new features of the
account can be given to the client.
\begin{caml_example*}
\begin{caml_example*}{toplevel}
module Internet_account (M : MONEY) =
struct
type m = M.c
@ -313,7 +313,7 @@ We show here how to do it for strings.
\label{module:string}
A naive definition of strings as objects could be:
\begin{caml_example}
\begin{caml_example}{toplevel}
class ostring s =
object
method get n = String.get s n
@ -325,7 +325,7 @@ However, the method "escaped" returns an object of the class "ostring",
and not an object of the current class. Hence, if the class is further
extended, the method "escaped" will only return an object of the parent
class.
\begin{caml_example}
\begin{caml_example}{toplevel}
class sub_string s =
object
inherit ostring s
@ -335,7 +335,7 @@ class sub_string s =
As seen in section \ref{ss:binary-methods}, the solution is to use
functional update instead. We need to create an instance variable
containing the representation "s" of the string.
\begin{caml_example}
\begin{caml_example}{toplevel}
class better_string s =
object
val repr = s
@ -353,7 +353,7 @@ In order to concatenate a string with another string of the same class,
one must be able to access the instance variable externally. Thus, a method
"repr" returning s must be defined. Here is the correct definition of
strings:
\begin{caml_example}
\begin{caml_example}{toplevel}
class ostring s =
object (self : 'mytype)
val repr = s
@ -367,7 +367,7 @@ class ostring s =
\end{caml_example}
Another constructor of the class string can be defined to return a new
string of a given length:
\begin{caml_example}
\begin{caml_example}{toplevel}
class cstring n = ostring (String.make n ' ');;
\end{caml_example}
Here, exposing the representation of strings is probably harmless. We do
@ -381,7 +381,7 @@ There is sometimes an alternative between using modules or classes for
parametric data types.
Indeed, there are situations when the two approaches are quite similar.
For instance, a stack can be straightforwardly implemented as a class:
\begin{caml_example}
\begin{caml_example}{toplevel}
exception Empty;;
class ['a] stack =
object
@ -400,7 +400,7 @@ argument that will be passed to the method "fold".
%The intuition is that method "fold" should be polymorphic, i.e. of type
%"All ('a) ('b -> 'a -> 'b) -> 'b -> 'b".
A naive approach is to make "'b" an extra parameter of class "stack":
\begin{caml_example}
\begin{caml_example}{toplevel}
class ['a, 'b] stack2 =
object
inherit ['a] stack
@ -409,7 +409,7 @@ class ['a, 'b] stack2 =
\end{caml_example}
However, the method "fold" of a given object can only be
applied to functions that all have the same type:
\begin{caml_example}
\begin{caml_example}{toplevel}
let s = new stack2;;
s#fold ( + ) 0;;
s;;
@ -421,7 +421,7 @@ universally quantified, giving "fold" the polymorphic type
"Forall 'b. ('b -> 'a -> 'b) -> 'b -> 'b".
An explicit type declaration on the method "fold" is required, since
the type checker cannot infer the polymorphic type by itself.
\begin{caml_example}
\begin{caml_example}{toplevel}
class ['a] stack3 =
object
inherit ['a] stack
@ -440,7 +440,7 @@ class ['a] stack3 =
A simplified version of object-oriented hash tables should have the
following class type.
\begin{caml_example}
\begin{caml_example}{toplevel}
class type ['a, 'b] hash_table =
object
method find : 'a -> 'b
@ -449,7 +449,7 @@ class type ['a, 'b] hash_table =
\end{caml_example}
A simple implementation, which is quite reasonable for small hash tables is
to use an association list:
\begin{caml_example}
\begin{caml_example}{toplevel}
class ['a, 'b] small_hashtbl : ['a, 'b] hash_table =
object
val mutable table = []
@ -459,7 +459,7 @@ class ['a, 'b] small_hashtbl : ['a, 'b] hash_table =
\end{caml_example}
A better implementation, and one that scales up better, is to use a
true hash table\ldots\ whose elements are small hash tables!
\begin{caml_example}
\begin{caml_example}{toplevel}
class ['a, 'b] hashtbl size : ['a, 'b] hash_table =
object (self)
val table = Array.init size (fun i -> new small_hashtbl)
@ -492,7 +492,7 @@ parametric in the type of elements, the method "tag" has a parametric type
the module definition but abstract in its signature.
From outside, it will then be guaranteed that two objects with a method "tag"
of the same type will share the same representation.
\begin{caml_example*}
\begin{caml_example*}{toplevel}
module type SET =
sig
type 'a tag
@ -544,7 +544,7 @@ classes that recursively interact with one another.
The class "observer" has a distinguished method "notify" that requires
two arguments, a subject and an event to execute an action.
\begin{caml_example}
\begin{caml_example}{toplevel}
class virtual ['subject, 'event] observer =
object
method virtual notify : 'subject -> 'event -> unit
@ -553,7 +553,7 @@ class virtual ['subject, 'event] observer =
The class "subject" remembers a list of observers in an instance variable,
and has a distinguished method "notify_observers" to broadcast the message
"notify" to all observers with a particular event "e".
\begin{caml_example}
\begin{caml_example}{toplevel}
class ['observer, 'event] subject =
object (self)
val mutable observers = ([]:'observer list)
@ -565,7 +565,7 @@ class ['observer, 'event] subject =
The difficulty usually lies in defining instances of the pattern above
by inheritance. This can be done in a natural and obvious manner in
OCaml, as shown on the following example manipulating windows.
\begin{caml_example}
\begin{caml_example}{toplevel}
type event = Raise | Resize | Move;;
let string_of_event = function
Raise -> "Raise" | Resize -> "Resize" | Move -> "Move";;
@ -586,12 +586,12 @@ class ['subject] window_observer =
end;;
\end{caml_example}
As can be expected, the type of "window" is recursive.
\begin{caml_example}
\begin{caml_example}{toplevel}
let window = new window_subject;;
\end{caml_example}
However, the two classes of "window_subject" and "window_observer" are not
mutually recursive.
\begin{caml_example}
\begin{caml_example}{toplevel}
let window_observer = new window_observer;;
window#add_observer window_observer;;
window#move 1;;
@ -600,7 +600,7 @@ window#move 1;;
Classes "window_observer" and "window_subject" can still be extended by
inheritance. For instance, one may enrich the "subject" with new
behaviors and refine the behavior of the observer.
\begin{caml_example}
\begin{caml_example}{toplevel}
class ['observer] richer_window_subject =
object (self)
inherit ['observer] window_subject
@ -617,7 +617,7 @@ class ['subject] richer_window_observer =
end;;
\end{caml_example}
We can also create a different kind of observer:
\begin{caml_example}
\begin{caml_example}{toplevel}
class ['subject] trace_observer =
object
inherit ['subject, event] observer
@ -627,7 +627,7 @@ class ['subject] trace_observer =
end;;
\end{caml_example}
and attach several observers to the same object:
\begin{caml_example}
\begin{caml_example}{toplevel}
let window = new richer_window_subject;;
window#add_observer (new richer_window_observer);;
window#add_observer (new trace_observer);;

82
manual/manual/tutorials/coreexamples.etex
View File

@ -27,7 +27,7 @@ by ";;" in response to the "#" prompt, and the system compiles them
on the fly, executes them, and prints the outcome of evaluation.
Phrases are either simple expressions, or "let" definitions of
identifiers (either values or functions).
\begin{caml_example}
\begin{caml_example}{toplevel}
1+2*3;;
let pi = 4.0 *. atan 1.0;;
let square x = x *. x;;
@ -39,12 +39,12 @@ the system infers their types from their usage in the
function. Notice also that integers and floating-point numbers are
distinct types, with distinct operators: "+" and "*" operate on
integers, but "+." and "*." operate on floats.
\begin{caml_example}[error]
\begin{caml_example}{toplevel}[error]
1.0 * 2;;
\end{caml_example}
Recursive functions are defined with the "let rec" binding:
\begin{caml_example}
\begin{caml_example}{toplevel}
let rec fib n =
if n < 2 then n else fib (n-1) + fib (n-2);;
fib 10;;
@ -55,7 +55,7 @@ fib 10;;
In addition to integers and floating-point numbers, OCaml offers the
usual basic data types: booleans, characters, and immutable character strings.
\begin{caml_example}
\begin{caml_example}{toplevel}
(1 < 2) = false;;
'a';;
"Hello world";;
@ -68,7 +68,7 @@ Lists are either given in extension as a bracketed list of
semicolon-separated elements, or built from the empty list "[]"
(pronounce ``nil'') by adding elements in front using the "::"
(``cons'') operator.
\begin{caml_example}
\begin{caml_example}{toplevel}
let l = ["is"; "a"; "tale"; "told"; "etc."];;
"Life" :: l;;
\end{caml_example}
@ -82,7 +82,7 @@ As with most OCaml data structures, inspecting and destructuring lists
is performed by pattern-matching. List patterns have the exact same
shape as list expressions, with identifier representing unspecified
parts of the list. As an example, here is insertion sort on a list:
\begin{caml_example}
\begin{caml_example}{toplevel}
let rec sort lst =
match lst with
[] -> []
@ -102,7 +102,7 @@ given type. The reason why "sort" can apply to lists of any type is
that the comparisons ("=", "<=", etc.) are {\em polymorphic} in OCaml:
they operate between any two values of the same type. This makes
"sort" itself polymorphic over all list types.
\begin{caml_example}
\begin{caml_example}{toplevel}
sort [6;2;5;3];;
sort [3.14; 2.718];;
\end{caml_example}
@ -123,13 +123,13 @@ sense are supported and can be passed around freely just as any other
piece of data. For instance, here is a "deriv" function that takes any
float function as argument and returns an approximation of its
derivative function:
\begin{caml_example}
\begin{caml_example}{toplevel}
let deriv f dx = function x -> (f (x +. dx) -. f x) /. dx;;
let sin' = deriv sin 1e-6;;
sin' pi;;
\end{caml_example}
Even function composition is definable:
\begin{caml_example}
\begin{caml_example}{toplevel}
let compose f g = function x -> f (g x);;
let cos2 = compose square cos;;
\end{caml_example}
@ -140,13 +140,13 @@ especially useful to provide iterators or similar generic operations
over a data structure. For instance, the standard OCaml library
provides a "List.map" functional that applies a given function to each
element of a list, and returns the list of the results:
\begin{caml_example}
\begin{caml_example}{toplevel}
List.map (function n -> n * 2 + 1) [0;1;2;3;4];;
\end{caml_example}
This functional, along with a number of other list and array
functionals, is predefined because it is often useful, but there is
nothing magic with it: it can easily be defined as follows.
\begin{caml_example}
\begin{caml_example}{toplevel}
let rec map f l =
match l with
[] -> []
@ -160,7 +160,7 @@ let rec map f l =
User-defined data structures include records and variants. Both are
defined with the "type" declaration. Here, we declare a record type to
represent rational numbers.
\begin{caml_example}
\begin{caml_example}{toplevel}
type ratio = {num: int; denom: int};;
let add_ratio r1 r2 =
{num = r1.num * r2.denom + r2.num * r1.denom;
@ -168,36 +168,36 @@ let add_ratio r1 r2 =
add_ratio {num=1; denom=3} {num=2; denom=5};;
\end{caml_example}
Record fields can also be accessed through pattern-matching:
\begin{caml_example}
\begin{caml_example}{toplevel}
let integer_part r =
match r with
{num=num; denom=denom} -> num / denom;;
\end{caml_example}
Since there is only one case in this pattern matching, it
is safe to expand directly the argument "r" in a record pattern:
\begin{caml_example}
\begin{caml_example}{toplevel}
let integer_part {num=num; denom=denom} = num / denom;;
\end{caml_example}
Unneeded fields can be omitted:
\begin{caml_example}
\begin{caml_example}{toplevel}
let get_denom {denom=denom} = denom;;
\end{caml_example}
Optionally, missing fields can be made explicit by ending the list of
fields with a trailing wildcard "_"::
\begin{caml_example}
\begin{caml_example}{toplevel}
let get_num {num=num; _ } = num;;
\end{caml_example}
When both sides of the "=" sign are the same, it is possible to avoid
repeating the field name by eliding the "=field" part:
\begin{caml_example}
\begin{caml_example}{toplevel}
let integer_part {num; denom} = num / denom;;
\end{caml_example}
This short notation for fields also works when constructing records:
\begin{caml_example}
\begin{caml_example}{toplevel}
let ratio num denom = {num; denom};;
\end{caml_example}
At last, it is possible to update few fields of a record at once:
\begin{caml_example}
\begin{caml_example}{toplevel}
let integer_product integer ratio = { ratio with num = integer * ratio.num };;
\end{caml_example}
With this functional update notation, the record on the left-hand side
@ -211,7 +211,7 @@ inspecting them by pattern-matching. Constructor names are capitalized
to distinguish them from variable names (which must start with a
lowercase letter). For instance, here is a variant
type for doing mixed arithmetic (integers and floats):
\begin{caml_example}
\begin{caml_example}{toplevel}
type number = Int of int | Float of float | Error;;
\end{caml_example}
This declaration expresses that a value of type "number" is either an
@ -220,14 +220,14 @@ the result of an invalid operation (e.g. a division by zero).
Enumerated types are a special case of variant types, where all
alternatives are constants:
\begin{caml_example}
\begin{caml_example}{toplevel}
type sign = Positive | Negative;;
let sign_int n = if n >= 0 then Positive else Negative;;
\end{caml_example}
To define arithmetic operations for the "number" type, we use
pattern-matching on the two numbers involved:
\begin{caml_example}
\begin{caml_example}{toplevel}
let add_num n1 n2 =
match (n1, n2) with
(Int i1, Int i2) ->
@ -246,18 +246,18 @@ add_num (Int 123) (Float 3.14159);;
Another interesting example of variant type is the built-in
"'a option" type which represents either a value of type "'a" or an
absence of value:
\begin{caml_example}
\begin{caml_example}{toplevel}
type 'a option = Some of 'a | None;;
\end{caml_example}
This type is particularly useful when defining function that can
fail in common situations, for instance
\begin{caml_example}
\begin{caml_example}{toplevel}
let safe_square_root x = if x > 0. then Some(sqrt x) else None;;
\end{caml_example}
The most common usage of variant types is to describe recursive data
structures. Consider for example the type of binary trees:
\begin{caml_example}
\begin{caml_example}{toplevel}
type 'a btree = Empty | Node of 'a * 'a btree * 'a btree;;
\end{caml_example}
This definition reads as follows: a binary tree containing values of
@ -269,7 +269,7 @@ Operations on binary trees are naturally expressed as recursive functions
following the same structure as the type definition itself. For
instance, here are functions performing lookup and insertion in
ordered binary trees (elements increase from left to right):
\begin{caml_example}
\begin{caml_example}{toplevel}
let rec member x btree =
match btree with
Empty -> false
@ -294,7 +294,7 @@ as arrays. Arrays are either given in extension between "[|" and "|]"
brackets, or allocated and initialized with the "Array.make"
function, then filled up later by assignments. For instance, the
function below sums two vectors (represented as float arrays) componentwise.
\begin{caml_example}
\begin{caml_example}{toplevel}
let add_vect v1 v2 =
let len = min (Array.length v1) (Array.length v2) in
let res = Array.make len 0.0 in
@ -307,7 +307,7 @@ add_vect [| 1.0; 2.0 |] [| 3.0; 4.0 |];;
Record fields can also be modified by assignment, provided they are
declared "mutable" in the definition of the record type:
\begin{caml_example}
\begin{caml_example}{toplevel}
type mutable_point = { mutable x: float; mutable y: float };;
let translate p dx dy =
p.x <- p.x +. dx; p.y <- p.y +. dy;;
@ -324,7 +324,7 @@ indirection cells (or one-element arrays), with operators "!" to fetch
the current contents of the reference and ":=" to assign the contents.
Variables can then be emulated by "let"-binding a reference. For
instance, here is an in-place insertion sort over arrays:
\begin{caml_example}
\begin{caml_example}{toplevel}
let insertion_sort a =
for i = 1 to Array.length a - 1 do
let val_i = a.(i) in
@ -341,7 +341,7 @@ References are also useful to write functions that maintain a current
state between two calls to the function. For instance, the following
pseudo-random number generator keeps the last returned number in a
reference:
\begin{caml_example}
\begin{caml_example}{toplevel}
let current_rand = ref 0;;
let random () =
current_rand := !current_rand * 25713 + 1345;
@ -350,7 +350,7 @@ let random () =
Again, there is nothing magical with references: they are implemented as
a single-field mutable record, as follows.
\begin{caml_example}
\begin{caml_example}{toplevel}
type 'a ref = { mutable contents: 'a };;
let ( ! ) r = r.contents;;
let ( := ) r newval = r.contents <- newval;;
@ -361,7 +361,7 @@ a data structure, keeping its polymorphism. Without user-provided
type annotations, this is not allowed, as polymorphism is only
introduced on a global level. However, you can give explicitly
polymorphic types to record fields.
\begin{caml_example}
\begin{caml_example}{toplevel}
type idref = { mutable id: 'a. 'a -> 'a };;
let r = {id = fun x -> x};;
let g s = (s.id 1, s.id true);;
@ -378,7 +378,7 @@ control structure. Exceptions are declared with the "exception"
construct, and signalled with the "raise" operator. For instance, the
function below for taking the head of a list uses an exception to
signal the case where an empty list is given.
\begin{caml_example}
\begin{caml_example}{toplevel}
exception Empty_list;;
let head l =
match l with
@ -393,13 +393,13 @@ where the library functions cannot complete normally. For instance,
the "List.assoc" function, which returns the data associated with a
given key in a list of (key, data) pairs, raises the predefined
exception "Not_found" when the key does not appear in the list:
\begin{caml_example}
\begin{caml_example}{toplevel}
List.assoc 1 [(0, "zero"); (1, "one")];;
List.assoc 2 [(0, "zero"); (1, "one")];;
\end{caml_example}
Exceptions can be trapped with the "try"\ldots"with" construct:
\begin{caml_example}
\begin{caml_example}{toplevel}
let name_of_binary_digit digit =
try
List.assoc digit [0, "zero"; 1, "one"]
@ -414,7 +414,7 @@ exception value. Thus, several exceptions can be caught by one
"try"\ldots"with" construct. Also, finalization can be performed by
trapping all exceptions, performing the finalization, then raising
again the exception:
\begin{caml_example}
\begin{caml_example}{toplevel}
let temporarily_set_reference ref newval funct =
let oldval = !ref in
try
@ -434,7 +434,7 @@ We finish this introduction with a more complete example
representative of the use of OCaml for symbolic processing: formal
manipulations of arithmetic expressions containing variables. The
following variant type describes the expressions we shall manipulate:
\begin{caml_example}
\begin{caml_example}{toplevel}
type expression =
Const of float
| Var of string
@ -448,7 +448,7 @@ type expression =
We first define a function to evaluate an expression given an
environment that maps variable names to their values. For simplicity,
the environment is represented as an association list.
\begin{caml_example}
\begin{caml_example}{toplevel}
exception Unbound_variable of string;;
let rec eval env exp =
match exp with
@ -464,7 +464,7 @@ eval [("x", 1.0); ("y", 3.14)] (Prod(Sum(Var "x", Const 2.0), Var "y"));;
Now for a real symbolic processing, we define the derivative of an
expression with respect to a variable "dv":
\begin{caml_example}
\begin{caml_example}{toplevel}
let rec deriv exp dv =
match exp with
Const c -> Const 0.0
@ -493,7 +493,7 @@ rules (i.e. "*" binds tighter than "+") to avoid printing unnecessary
parentheses. To this end, we maintain the current operator precedence
and print parentheses around an operator only if its precedence is
less than the current precedence.
\begin{caml_example}
\begin{caml_example}{toplevel}
let print_expr exp =
(* Local function definitions *)
let open_paren prec op_prec =
@ -576,7 +576,7 @@ print_expr (deriv e "x"); print_newline ();;
%% %#load"camlp4o.cma";;
%% %\end{caml_example}
%% %Then we are ready to define our parser.
%% \begin{caml_example}
%% \begin{caml_example}{toplevel}
%% let rec parse_expr = parser
%% [< e1 = parse_mult; e = parse_more_adds e1 >] -> e
%% and parse_more_adds e1 = parser

56
manual/manual/tutorials/lablexamples.etex
View File

@ -15,7 +15,7 @@ If you have a look at modules ending in "Labels" in the standard
library, you will see that function types have annotations you did not
have in the functions you defined yourself.
\begin{caml_example}
\begin{caml_example}{toplevel}
ListLabels.map;;
StringLabels.sub;;
\end{caml_example}
@ -26,7 +26,7 @@ flexibility to function application.
You can give such names to arguments in your programs, by prefixing them
with a tilde "~".
\begin{caml_example}
\begin{caml_example}{toplevel}
let f ~x ~y = x - y;;
let x = 3 and y = 2 in f ~x ~y;;
\end{caml_example}
@ -35,7 +35,7 @@ When you want to use distinct names for the variable and the label
appearing in the type, you can use a naming label of the form
"~name:". This also applies when the argument is not a variable.
\begin{caml_example}
\begin{caml_example}{toplevel}
let f ~x:x1 ~y:y1 = x1 - y1;;
f ~x:3 ~y:2;;
\end{caml_example}
@ -54,7 +54,7 @@ This allows commuting arguments in applications. One can also
partially apply a function on any argument, creating a new function of
the remaining parameters.
\begin{caml_example}
\begin{caml_example}{toplevel}
let f ~x ~y = x - y;;
f ~y:2 ~x:3;;
ListLabels.fold_left;;
@ -66,7 +66,7 @@ If several arguments of a function bear the same label (or no label),
they will not commute among themselves, and order matters. But they
can still commute with other arguments.
\begin{caml_example}
\begin{caml_example}{toplevel}
let hline ~x:x1 ~x:x2 ~y = (x1, x2, y);;
hline ~x:3 ~y:2 ~x:5;;
\end{caml_example}
@ -76,27 +76,27 @@ application is total (omitting all optional arguments), labels may be
omitted.
In practice, many applications are total, so that labels can often be
omitted.
\begin{caml_example}
\begin{caml_example}{toplevel}
f 3 2;;
ListLabels.map succ [1;2;3];;
\end{caml_example}
But beware that functions like "ListLabels.fold_left" whose result
type is a type variable will never be considered as totally applied.
\begin{caml_example}[error]
\begin{caml_example}{toplevel}[error]
ListLabels.fold_left ( + ) 0 [1;2;3];;
\end{caml_example}
When a function is passed as an argument to a higher-order function,
labels must match in both types. Neither adding nor removing labels
are allowed.
\begin{caml_example}
\begin{caml_example}{toplevel}
let h g = g ~x:3 ~y:2;;
h f;;
h ( + ) [@@expect error];;
\end{caml_example}
Note that when you don't need an argument, you can still use a wildcard
pattern, but you must prefix it with the label.
\begin{caml_example}
\begin{caml_example}{toplevel}
h (fun ~x:_ ~y -> y+1);;
\end{caml_example}
@ -108,7 +108,7 @@ tilde "~" of non-optional ones, and the label is also prefixed by "?"
in the function type.
Default values may be given for such optional parameters.
\begin{caml_example}
\begin{caml_example}{toplevel}
let bump ?(step = 1) x = x + step;;
bump 2;;
bump ~step:3 2;;
@ -122,7 +122,7 @@ Note that if that argument is labeled, you will only be able to
eliminate optional arguments through the special case for total
applications.
\begin{caml_example}
\begin{caml_example}{toplevel}
let test ?(x = 0) ?(y = 0) () ?(z = 0) () = (x, y, z);;
test ();;
test ~x:2 () ~z:3 ();;
@ -132,7 +132,7 @@ Optional parameters may also commute with non-optional or unlabeled
ones, as long as they are applied simultaneously. By nature, optional
arguments do not commute with unlabeled arguments applied
independently.
\begin{caml_example}
\begin{caml_example}{toplevel}
test ~y:2 ~x:3 () ();;
test () () ~z:1 ~y:2 ~x:3;;
(test () ()) ~z:1 [@@expect error];;
@ -145,7 +145,7 @@ you do not give a default value, you have access to their internal
representation, "type 'a option = None | Some of 'a". You can then
provide different behaviors when an argument is present or not.
\begin{caml_example}
\begin{caml_example}{toplevel}
let bump ?step x =
match step with
| None -> x * 2
@ -158,7 +158,7 @@ call to another. This can be done by prefixing the applied argument
with "?". This question mark disables the wrapping of optional
argument in an option type.
\begin{caml_example}
\begin{caml_example}{toplevel}
let test2 ?x ?y () = test ?x ?y () ();;
test2 ?x:None;;
\end{caml_example}
@ -171,7 +171,7 @@ applications, labels and optional arguments have the pitfall that they
cannot be inferred as completely as the rest of the language.
You can see it in the following two examples.
\begin{caml_example}
\begin{caml_example}{toplevel}
let h' g = g ~y:2 ~x:3;;
h' f [@@expect error];;
let bump_it bump x =
@ -203,7 +203,7 @@ order.
The right way to solve this problem for optional parameters is to add
a type annotation to the argument "bump".
\begin{caml_example}
\begin{caml_example}{toplevel}
let bump_it (bump : ?step:int -> int -> int) x =
bump ~step:2 x;;
bump_it bump 1;;
@ -220,7 +220,7 @@ parameters, the compiler will attempt to transform the argument to
have it match the expected type, by passing "None" for all optional
parameters.
\begin{caml_example}
\begin{caml_example}{toplevel}
let twice f (x : int) = f(f x);;
twice bump 2;;
\end{caml_example}
@ -334,7 +334,7 @@ type will be inferred independently for each of its uses.
In programs, polymorphic variants work like usual ones. You just have
to prefix their names with a backquote character "`".
\begin{caml_example}
\begin{caml_example}{toplevel}
[`On; `Off];;
`Number 1;;
let f = function `On -> 1 | `Off -> 0 | `Number n -> n;;
@ -357,7 +357,7 @@ variant types, that is types that cannot be refined. This is
also the case for type abbreviations. Such types do not contain "<" or
">", but just an enumeration of the tags and their associated types,
just like in a normal datatype definition.
\begin{caml_example}
\begin{caml_example}{toplevel}
type 'a vlist = [`Nil | `Cons of 'a * 'a vlist];;
let rec map f : 'a vlist -> 'b vlist = function
| `Nil -> `Nil
@ -370,7 +370,7 @@ let rec map f : 'a vlist -> 'b vlist = function
Type-checking polymorphic variants is a subtle thing, and some
expressions may result in more complex type information.
\begin{caml_example}
\begin{caml_example}{toplevel}
let f = function `A -> `C | `B -> `D | x -> x;;
f `E;;
\end{caml_example}
@ -381,7 +381,7 @@ returned as is, input and return types are identical. The notation "as
'a" denotes such type sharing. If we apply "f" to yet another tag
"`E", it gets added to the list.
\begin{caml_example}
\begin{caml_example}{toplevel}
let f1 = function `A x -> x = 1 | `B -> true | `C -> false
let f2 = function `A x -> x = "a" | `B -> true ;;
let f x = f1 x && f2 x;;
@ -398,7 +398,7 @@ Even if a value has a fixed variant type, one can still give it a
larger type through coercions. Coercions are normally written with
both the source type and the destination type, but in simple cases the
source type may be omitted.
\begin{caml_example}
\begin{caml_example}{toplevel}
type 'a wlist = [`Nil | `Cons of 'a * 'a wlist | `Snoc of 'a wlist * 'a];;
let wlist_of_vlist l = (l : 'a vlist :> 'a wlist);;
let open_vlist l = (l : 'a vlist :> [> 'a vlist]);;
@ -406,7 +406,7 @@ fun x -> (x :> [`A|`B|`C]);;
\end{caml_example}
You may also selectively coerce values through pattern matching.
\begin{caml_example}
\begin{caml_example}{toplevel}
let split_cases = function
| `Nil | `Cons _ as x -> `A x
| `Snoc _ as x -> `B x
@ -417,7 +417,7 @@ alias-pattern, the alias is given a type containing only the tags
enumerated in the or-pattern. This allows for many useful idioms, like
incremental definition of functions.
\begin{caml_example}
\begin{caml_example}{toplevel}
let num x = `Num x
let eval1 eval (`Num x) = x
let rec eval x = eval1 eval x ;;
@ -437,13 +437,13 @@ type myvariant = [`Tag1 of int | `Tag2 of bool];;
\end{caml_eval}
Such abbreviations may be used alone,
\begin{caml_example}
\begin{caml_example}{toplevel}
let f = function
| #myvariant -> "myvariant"
| `Tag3 -> "Tag3";;
\end{caml_example}
or combined with with aliases.
\begin{caml_example}
\begin{caml_example}{toplevel}
let g1 = function `Tag1 _ -> "Tag1" | `Tag2 _ -> "Tag2";;
let g = function
| #myvariant as x -> g1 x
@ -476,7 +476,7 @@ programs you are probably better off with core language variants.
Beware also that some idioms make trivial errors very hard to find.
For instance, the following code is probably wrong but the compiler
has no way to see it.
\begin{caml_example}
\begin{caml_example}{toplevel}
type abc = [`A | `B | `C] ;;
let f = function
| `As -> "A"
@ -484,7 +484,7 @@ let f = function
let f : abc -> string = f ;;
\end{caml_example}
You can avoid such risks by annotating the definition itself.
\begin{caml_example}[error]
\begin{caml_example}{toplevel}[error]
let f : abc -> string = function
| `As -> "A"
| #abc -> "other" ;;

36
manual/manual/tutorials/moduleexamples.etex
View File

@ -16,7 +16,7 @@ is introduced by the "struct"\ldots"end" construct, which contains an
arbitrary sequence of definitions. The structure is usually given a
name with the "module" binding. Here is for instance a structure
packaging together a type of priority queues and their operations:
\begin{caml_example}
\begin{caml_example}{toplevel}
module PrioQueue =
struct
type priority = int
@ -49,7 +49,7 @@ Outside the structure, its components can be referred to using the
For instance, "PrioQueue.insert" is the function "insert" defined
inside the structure "PrioQueue" and "PrioQueue.queue" is the type
"queue" defined in "PrioQueue".
\begin{caml_example}
\begin{caml_example}{toplevel}
PrioQueue.insert PrioQueue.empty 1 "hello";;
\end{caml_example}
@ -57,7 +57,7 @@ Another possibility is to open the module, which brings all
identifiers defined inside the module in the scope of the current
structure.
\begin{caml_example}
\begin{caml_example}{toplevel}
open PrioQueue;;
insert empty 1 "hello";;
\end{caml_example}
@ -68,7 +68,7 @@ has been defined. In particular, opened modules can shadow
identifiers present in the current scope, potentially leading
to confusing errors:
\begin{caml_example}
\begin{caml_example}{toplevel}
let empty = []
open PrioQueue;;
let x = 1 :: empty [@@expect error];;
@ -81,24 +81,24 @@ concerned expression. This can also make the code easier to read
-- the open statement is closer to where it is used-- and to refactor
-- the code fragment is more self-contained.
Two constructions are available for this purpose:
\begin{caml_example}
\begin{caml_example}{toplevel}
let open PrioQueue in
insert empty 1 "hello";;
\end{caml_example}
and
\begin{caml_example}
\begin{caml_example}{toplevel}
PrioQueue.(insert empty 1 "hello");;
\end{caml_example}
In the second form, when the body of a local open is itself delimited
by parentheses, braces or bracket, the parentheses of the local open
can be omitted. For instance,
\begin{caml_example}
\begin{caml_example}{toplevel}
PrioQueue.[empty] = PrioQueue.([empty]);;
PrioQueue.[|empty|] = PrioQueue.([|empty|]);;
PrioQueue.{ contents = empty } = PrioQueue.({ contents = empty });;
\end{caml_example}
becomes
\begin{caml_example}
\begin{caml_example}{toplevel}
PrioQueue.[insert empty 1 "hello"];;
\end{caml_example}
@ -107,7 +107,7 @@ another module by using an "include" statement. This can be
particularly useful to extend existing modules. As an illustration,
we could add functions that returns an optional value rather than
an exception when the priority queue is empty.
\begin{caml_example}
\begin{caml_example}{toplevel}
module PrioQueueOpt =
struct
include PrioQueue
@ -131,7 +131,7 @@ restricted type. For instance, the signature below specifies the three
priority queue operations "empty", "insert" and "extract", but not the
auxiliary function "remove_top". Similarly, it makes the "queue" type
abstract (by not providing its actual representation as a concrete type).
\begin{caml_example}
\begin{caml_example}{toplevel}
module type PRIOQUEUE =
sig
type priority = int (* still concrete *)
@ -146,7 +146,7 @@ Restricting the "PrioQueue" structure by this signature results in
another view of the "PrioQueue" structure where the "remove_top"
function is not accessible and the actual representation of priority
queues is hidden:
\begin{caml_example}
\begin{caml_example}{toplevel}
module AbstractPrioQueue = (PrioQueue : PRIOQUEUE);;
AbstractPrioQueue.remove_top [@@expect error];;
AbstractPrioQueue.insert AbstractPrioQueue.empty 1 "hello";;
@ -166,7 +166,7 @@ its components inside the current signature. For instance, we
can extend the PRIOQUEUE signature with the "extract_opt"
function:
\begin{caml_example}
\begin{caml_example}{toplevel}
module type PRIOQUEUE_WITH_OPT =
sig
include PRIOQUEUE
@ -191,7 +191,7 @@ For instance, here is a structure implementing sets as sorted lists,
parameterized by a structure providing the type of the set elements
and an ordering function over this type (used to keep the sets
sorted):
\begin{caml_example}
\begin{caml_example}{toplevel}
type comparison = Less | Equal | Greater;;
module type ORDERED_TYPE =
sig
@ -224,7 +224,7 @@ module Set =
\end{caml_example}
By applying the "Set" functor to a structure implementing an ordered
type, we obtain set operations for this type:
\begin{caml_example}
\begin{caml_example}{toplevel}
module OrderedString =
struct
type t = string
@ -243,7 +243,7 @@ structure will not rely on sets being lists, and we can switch later
to another, more efficient representation of sets without breaking
their code. This can be achieved by restricting "Set" by a suitable
functor signature:
\begin{caml_example}
\begin{caml_example}{toplevel}
module type SETFUNCTOR =
functor (Elt: ORDERED_TYPE) ->
sig
@ -261,7 +261,7 @@ AbstractStringSet.add "gee" AbstractStringSet.empty;;
In an attempt to write the type constraint above more elegantly,
one may wish to name the signature of the structure
returned by the functor, then use that signature in the constraint:
\begin{caml_example}
\begin{caml_example}{toplevel}
module type SET =
sig
type element
@ -285,7 +285,7 @@ impossible above since "SET" is defined in a context where "Elt" does
not exist. To overcome this difficulty, OCaml provides a
"with type" construct over signatures that allows enriching a signature
with extra type equalities:
\begin{caml_example}
\begin{caml_example}{toplevel}
module AbstractSet2 =
(Set : functor(Elt: ORDERED_TYPE) -> (SET with type element = Elt.t));;
\end{caml_example}
@ -303,7 +303,7 @@ illustrate. Consider an ordering over character strings that is
different from the standard ordering implemented in the
"OrderedString" structure. For instance, we compare strings without
distinguishing upper and lower case.
\begin{caml_example}
\begin{caml_example}{toplevel}
module NoCaseString =
struct
type t = string

182
manual/manual/tutorials/objectexamples.etex
View File

@ -52,7 +52,7 @@ The class "point" below defines one instance variable "x" and two methods
"get_x" and "move". The initial value of the instance variable is "0".
The variable "x" is declared mutable, so the method "move" can change
its value.
\begin{caml_example}
\begin{caml_example}{toplevel}
class point =
object
val mutable x = 0
@ -62,7 +62,7 @@ class point =
\end{caml_example}
We now create a new point "p", instance of the "point" class.
\begin{caml_example}
\begin{caml_example}{toplevel}
let p = new point;;
\end{caml_example}
Note that the type of "p" is "point". This is an abbreviation
@ -71,7 +71,7 @@ object type "<get_x : int; move : int -> unit>", listing the methods
of class "point" along with their types.
We now invoke some methods to "p":
\begin{caml_example}
\begin{caml_example}{toplevel}
p#get_x;;
p#move 3;;
p#get_x;;
@ -81,7 +81,7 @@ The evaluation of the body of a class only takes place at object
creation time. Therefore, in the following example, the instance
variable "x" is initialized to different values for two different
objects.
\begin{caml_example}
\begin{caml_example}{toplevel}
let x0 = ref 0;;
class point =
object
@ -95,7 +95,7 @@ new point#get_x;;
The class "point" can also be abstracted over the initial values of
the "x" coordinate.
\begin{caml_example}
\begin{caml_example}{toplevel}
class point = fun x_init ->
object
val mutable x = x_init
@ -105,7 +105,7 @@ class point = fun x_init ->
\end{caml_example}
Like in function definitions, the definition above can be
abbreviated as:
\begin{caml_example}
\begin{caml_example}{toplevel}
class point x_init =
object
val mutable x = x_init
@ -115,7 +115,7 @@ class point x_init =
\end{caml_example}
An instance of the class "point" is now a function that expects an
initial parameter to create a point object:
\begin{caml_example}
\begin{caml_example}{toplevel}
new point;;
let p = new point 7;;
\end{caml_example}
@ -123,7 +123,7 @@ The parameter "x_init" is, of course, visible in the whole body of the
definition, including methods. For instance, the method "get_offset"
in the class below returns the position of the object relative to its
initial position.
\begin{caml_example}
\begin{caml_example}{toplevel}
class point x_init =
object
val mutable x = x_init
@ -134,7 +134,7 @@ class point x_init =
\end{caml_example}
%Instance variables can only be used inside methods. For instance it would
%not be possible to define
%\begin{caml_example}
%\begin{caml_example}{toplevel}
%class point x_init =
% object
% val mutable x = x_init
@ -147,7 +147,7 @@ Expressions can be evaluated and bound before defining the object body
of the class. This is useful to enforce invariants. For instance,
points can be automatically adjusted to the nearest point on a grid,
as follows:
\begin{caml_example}
\begin{caml_example}{toplevel}
class adjusted_point x_init =
let origin = (x_init / 10) * 10 in
object
@ -161,12 +161,12 @@ class adjusted_point x_init =
on the grid.) In fact, the same effect could here be obtained by
calling the definition of class "point" with the value of the
"origin".
\begin{caml_example}
\begin{caml_example}{toplevel}
class adjusted_point x_init = point ((x_init / 10) * 10);;
\end{caml_example}
An alternate solution would have been to define the adjustment in
a special allocation function:
\begin{caml_example}
\begin{caml_example}{toplevel}
let new_adjusted_point x_init = new point ((x_init / 10) * 10);;
\end{caml_example}
However, the former pattern is generally more appropriate, since
@ -189,7 +189,7 @@ without going through a class.
The syntax is exactly the same as for class expressions, but the
result is a single object rather than a class. All the constructs
described in the rest of this section also apply to immediate objects.
\begin{caml_example}
\begin{caml_example}{toplevel}
let p =
object
val mutable x = 0
@ -204,7 +204,7 @@ p#get_x;;
Unlike classes, which cannot be defined inside an expression,
immediate objects can appear anywhere, using variables from their
environment.
\begin{caml_example}
\begin{caml_example}{toplevel}
let minmax x y =
if x < y then object method min = x method max = y end
else object method min = y method max = x end;;
@ -223,7 +223,7 @@ A method or an initializer can send messages to self (that is,
the current object). For that, self must be explicitly bound, here to
the variable "s" ("s" could be any identifier, even though we will
often choose the name "self".)
\begin{caml_example}
\begin{caml_example}{toplevel}
class printable_point x_init =
object (s)
val mutable x = x_init
@ -240,7 +240,7 @@ particular, when the class "printable_point" is inherited, the variable
A common problem with self is that, as its type may be extended in
subclasses, you cannot fix it in advance. Here is a simple example.
\begin{caml_example}
\begin{caml_example}{toplevel}
let ints = ref [];;
class my_int =
object (self)
@ -255,7 +255,7 @@ We will see in section \ref{ss:using-coercions} a workaround to this
problem.
Note however that, since immediate objects are not extensible, the
problem does not occur with them.
\begin{caml_example}
\begin{caml_example}{toplevel}
let my_int =
object (self)
method n = 1
@ -272,7 +272,7 @@ is constructed. It is also possible to evaluate an expression
immediately after the object has been built. Such code is written as
an anonymous hidden method called an initializer. Therefore, it can
access self and the instance variables.
\begin{caml_example}
\begin{caml_example}{toplevel}
class printable_point x_init =
let origin = (x_init / 10) * 10 in
object (self)
@ -300,7 +300,7 @@ subclasses. A class containing virtual methods must be flagged
"virtual", and cannot be instantiated (that is, no object of this class
can be created). It still defines type abbreviations (treating virtual methods
as other methods.)
\begin{caml_example}
\begin{caml_example}{toplevel}
class virtual abstract_point x_init =
object (self)
method virtual get_x : int
@ -318,7 +318,7 @@ class point x_init =
Instance variables can also be declared as virtual, with the same effect
as with methods.
\begin{caml_example}
\begin{caml_example}{toplevel}
class virtual abstract_point2 =
object
val mutable virtual x : int
@ -338,7 +338,7 @@ class point2 x_init =
Private methods are methods that do not appear in object interfaces.
They can only be invoked from other methods of the same object.
\begin{caml_example}
\begin{caml_example}{toplevel}
class restricted_point x_init =
object (self)
val mutable x = x_init
@ -362,7 +362,7 @@ Private methods are inherited (they are by default visible in subclasses),
unless they are hidden by signature matching, as described below.
Private methods can be made public in a subclass.
\begin{caml_example}
\begin{caml_example}{toplevel}
class point_again x =
object (self)
inherit restricted_point x
@ -375,7 +375,7 @@ annotation, this makes the method public, keeping the original
definition.
An alternative definition is
\begin{caml_example}
\begin{caml_example}{toplevel}
class point_again x =
object (self : < move : _; ..> )
inherit restricted_point x
@ -388,7 +388,7 @@ One could think that a private method should remain private in a subclass.
However, since the method is visible in a subclass, it is always possible
to pick its code and define a method of the same name that runs that
code, so yet another (heavier) solution would be:
\begin{caml_example}
\begin{caml_example}{toplevel}
class point_again x =
object
inherit restricted_point x as super
@ -409,7 +409,7 @@ appear in this order "method private virtual".
Class interfaces are inferred from class definitions. They may also
be defined directly and used to restrict the type of a class. Like class
declarations, they also define a new type abbreviation.
\begin{caml_example}
\begin{caml_example}{toplevel}
class type restricted_point_type =
object
method get_x : int
@ -421,16 +421,16 @@ In addition to program documentation, class interfaces can be used to
constrain the type of a class. Both concrete instance variables and concrete
private methods can be hidden by a class type constraint. Public
methods and virtual members, however, cannot.
\begin{caml_example}
\begin{caml_example}{toplevel}
class restricted_point' x = (restricted_point x : restricted_point_type);;
\end{caml_example}
Or, equivalently:
\begin{caml_example}
\begin{caml_example}{toplevel}
class restricted_point' = (restricted_point : int -> restricted_point_type);;
\end{caml_example}
The interface of a class can also be specified in a module
signature, and used to restrict the inferred signature of a module.
\begin{caml_example}
\begin{caml_example}{toplevel}
module type POINT = sig
class restricted_point' : int ->
object
@ -451,7 +451,7 @@ We illustrate inheritance by defining a class of colored points that
inherits from the class of points. This class has all instance
variables and all methods of class "point", plus a new instance
variable "c" and a new method "color".
\begin{caml_example}
\begin{caml_example}{toplevel}
class colored_point x (c : string) =
object
inherit point x
@ -466,12 +466,12 @@ no method "color". However, the function "get_x" below is a generic
function applying method "get_x" to any object "p" that has this
method (and possibly some others, which are represented by an ellipsis
in the type). Thus, it applies to both points and colored points.
\begin{caml_example}
\begin{caml_example}{toplevel}
let get_succ_x p = p#get_x + 1;;
get_succ_x p + get_succ_x p';;
\end{caml_example}
Methods need not be declared previously, as shown by the example:
\begin{caml_example}
\begin{caml_example}{toplevel}
let set_x p = p#set_x;;
let incr p = set_x p (get_succ_x p);;
\end{caml_example}
@ -487,7 +487,7 @@ Previous definitions of a method can be reused by binding the related
ancestor. Below, "super" is bound to the ancestor "printable_point".
The name "super" is a pseudo value identifier that can only be used to
invoke a super-class method, as in "super#print".
\begin{caml_example}
\begin{caml_example}{toplevel}
class printable_colored_point y c =
object (self)
val c = c
@ -512,7 +512,7 @@ Note that for clarity's sake, the method "print" is explicitly marked as
overriding another definition by annotating the "method" keyword with
an exclamation mark "!". If the method "print" were not overriding the
"print" method of "printable_point", the compiler would raise an error:
\begin{caml_example}[error]
\begin{caml_example}{toplevel}[error]
object
method! m = ()
end;;
@ -520,7 +520,7 @@ an exclamation mark "!". If the method "print" were not overriding the
This explicit overriding annotation also works
for "val" and "inherit":
\begin{caml_example}
\begin{caml_example}{toplevel}
class another_printable_colored_point y c c' =
object (self)
inherit printable_point y
@ -535,7 +535,7 @@ class another_printable_colored_point y c c' =
Reference cells can be implemented as objects.
The naive definition fails to typecheck:
\begin{caml_example}[error]
\begin{caml_example}{toplevel}[error]
class oref x_init =
object
val mutable x = x_init
@ -548,7 +548,7 @@ The reason is that at least one of the methods has a polymorphic type
either the class should be parametric, or the method type should be
constrained to a monomorphic type. A monomorphic instance of the class could
be defined by:
\begin{caml_example}
\begin{caml_example}{toplevel}
class oref (x_init:int) =
object
val mutable x = x_init
@ -558,7 +558,7 @@ class oref (x_init:int) =
\end{caml_example}
Note that since immediate objects do not define a class type, they have
no such restriction.
\begin{caml_example}
\begin{caml_example}{toplevel}
let new_oref x_init =
object
val mutable x = x_init
@ -570,7 +570,7 @@ On the other hand, a class for polymorphic references must explicitly
list the type parameters in its declaration. Class type parameters are
listed between "[" and "]". The type parameters must also be
bound somewhere in the class body by a type constraint.
\begin{caml_example}
\begin{caml_example}{toplevel}
class ['a] oref x_init =
object
val mutable x = (x_init : 'a)
@ -582,7 +582,7 @@ let r = new oref 1 in r#set 2; (r#get);;
The type parameter in the declaration may actually be constrained in the
body of the class definition. In the class type, the actual value of
the type parameter is displayed in the "constraint" clause.
\begin{caml_example}
\begin{caml_example}{toplevel}
class ['a] oref_succ (x_init:'a) =
object
val mutable x = x_init + 1
@ -594,7 +594,7 @@ Let us consider a more complex example: define a circle, whose center
may be any kind of point. We put an additional type
constraint in method "move", since no free variables must remain
unaccounted for by the class type parameters.
\begin{caml_example}
\begin{caml_example}{toplevel}
class ['a] circle (c : 'a) =
object
val mutable center = c
@ -612,7 +612,7 @@ object belonging to a subclass of class "point". It actually expands to
alternate definition of "circle", which has slightly stronger
constraints on its argument, as we now expect "center" to have a
method "get_x".
\begin{caml_example}
\begin{caml_example}{toplevel}
class ['a] circle (c : 'a) =
object
constraint 'a = #point
@ -627,7 +627,7 @@ The class "colored_circle" is a specialized version of class
"#colored_point", and adds a method "color". Note that when specializing a
parameterized class, the instance of type parameter must always be
explicitly given. It is again written between "[" and "]".
\begin{caml_example}
\begin{caml_example}{toplevel}
class ['a] colored_circle c =
object
constraint 'a = #colored_point
@ -644,7 +644,7 @@ While parameterized classes may be polymorphic in their contents, they
are not enough to allow polymorphism of method use.
A classical example is defining an iterator.
\begin{caml_example}
\begin{caml_example}{toplevel}
List.fold_left;;
class ['a] intlist (l : int list) =
object
@ -654,7 +654,7 @@ class ['a] intlist (l : int list) =
\end{caml_example}
At first look, we seem to have a polymorphic iterator, however this
does not work in practice.
\begin{caml_example}
\begin{caml_example}{toplevel}
let l = new intlist [1; 2; 3];;
l#fold (fun x y -> x+y) 0;;
l;;
@ -669,7 +669,7 @@ The problem here is that quantification was wrongly located: it is
not the class we want to be polymorphic, but the "fold" method.
This can be achieved by giving an explicitly polymorphic type in the
method definition.
\begin{caml_example}
\begin{caml_example}{toplevel}
class intlist (l : int list) =
object
method empty = (l = [])
@ -694,7 +694,7 @@ cannot choose between those two types, and must be helped.
However, the type can be completely omitted in the class definition if
it is already known, through inheritance or type constraints on self.
Here is an example of method overriding.
\begin{caml_example*}
\begin{caml_example*}{toplevel}
class intlist_rev l =
object
inherit intlist l
@ -702,7 +702,7 @@ class intlist_rev l =
end;;
\end{caml_example*}
The following idiom separates description and definition.
\begin{caml_example*}
\begin{caml_example*}{toplevel}
class type ['a] iterator =
object method fold : ('b -> 'a -> 'b) -> 'b -> 'b end;;
class intlist l =
@ -719,18 +719,18 @@ methods, but you should be aware of some limitations of type
inference. Namely, a polymorphic method can only be called if its
type is known at the call site. Otherwise, the method will be assumed
to be monomorphic, and given an incompatible type.
\begin{caml_example}
\begin{caml_example}{toplevel}
let sum lst = lst#fold (fun x y -> x+y) 0;;
sum l [@@expect error];;
\end{caml_example}
The workaround is easy: you should put a type constraint on the
parameter.
\begin{caml_example}
\begin{caml_example}{toplevel}
let sum (lst : _ #iterator) = lst#fold (fun x y -> x+y) 0;;
\end{caml_example}
Of course the constraint may also be an explicit method type.
Only occurences of quantified variables are required.
\begin{caml_example}
\begin{caml_example}{toplevel}
let sum lst =
(lst : < fold : 'a. ('a -> _ -> 'a) -> 'a -> 'a; .. >)#fold (+) 0;;
\end{caml_example}
@ -739,7 +739,7 @@ Another use of polymorphic methods is to allow some form of implicit
subtyping in method arguments. We have already seen in section
\ref{ss:inheritance} how some functions may be polymorphic in the
class of their argument. This can be extended to methods.
\begin{caml_example}
\begin{caml_example}{toplevel}
class type point0 = object method get_x : int end;;
class distance_point x =
object
@ -754,7 +754,7 @@ Note here the special syntax "(#point0 as 'a)" we have to use to
quantify the extensible part of "#point0". As for the variable binder,
it can be omitted in class specifications. If you want polymorphism
inside object field it must be quantified independently.
\begin{caml_example}
\begin{caml_example}{toplevel}
class multi_poly =
object
method m1 : 'a. (< n1 : 'b. 'b -> 'b; .. > as 'a) -> _ =
@ -778,7 +778,7 @@ domain and the codomain of the type coercion must be given.
We have seen that points and colored points have incompatible types.
For instance, they cannot be mixed in the same list. However, a
colored point can be coerced to a point, hiding its "color" method:
\begin{caml_example}
\begin{caml_example}{toplevel}
let colored_point_to_point cp = (cp : colored_point :> point);;
let p = new point 3 and q = new colored_point 4 "blue";;
let l = [p; (colored_point_to_point q)];;
@ -786,7 +786,7 @@ let l = [p; (colored_point_to_point q)];;
An object of type "t" can be seen as an object of type "t'"
only if "t" is a subtype of "t'". For instance, a point cannot be
seen as a colored point.
\begin{caml_example}[error]
\begin{caml_example}{toplevel}[error]
(p : point :> colored_point);;
\end{caml_example}
Indeed, narrowing coercions without runtime checks would be unsafe.
@ -803,43 +803,43 @@ colored points would remain unchanged and thus still be a subtype of
points.
% Conversely, the class "int_comparable" inherits from class
%"comparable", but type "int_comparable" is not a subtype of "comparable".
%\begin{caml_example}
%\begin{caml_example}{toplevel}
%function x -> (x : int_comparable :> comparable);;
%\end{caml_example}
The domain of a coercion can often be omitted. For instance, one can
define:
\begin{caml_example}
\begin{caml_example}{toplevel}
let to_point cp = (cp :> point);;
\end{caml_example}
In this case, the function "colored_point_to_point" is an instance of the
function "to_point". This is not always true, however. The fully
explicit coercion is more precise and is sometimes unavoidable.
Consider, for example, the following class:
\begin{caml_example}
\begin{caml_example}{toplevel}
class c0 = object method m = {< >} method n = 0 end;;
\end{caml_example}
The object type "c0" is an abbreviation for "<m : 'a; n : int> as 'a".
Consider now the type declaration:
\begin{caml_example}
\begin{caml_example}{toplevel}
class type c1 = object method m : c1 end;;
\end{caml_example}
The object type "c1" is an abbreviation for the type "<m : 'a> as 'a".
The coercion from an object of type "c0" to an object of type "c1" is
correct:
\begin{caml_example}
\begin{caml_example}{toplevel}
fun (x:c0) -> (x : c0 :> c1);;
\end{caml_example}
%%% FIXME come up with a better example.
% However, the domain of the coercion cannot be omitted here:
% \begin{caml_example}
% \begin{caml_example}{toplevel}
% fun (x:c0) -> (x :> c1);;
% \end{caml_example}
However, the domain of the coercion cannot always be omitted.
In that case, the solution is to use the explicit form.
%
Sometimes, a change in the class-type definition can also solve the problem
\begin{caml_example}
\begin{caml_example}{toplevel}
class type c2 = object ('a) method m : 'a end;;
fun (x:c0) -> (x :> c2);;
\end{caml_example}
@ -852,7 +852,7 @@ allows leaving the domain implicit in most cases when coercing form a
subclass to its superclass.
%
The type of a coercion can always be seen as below:
\begin{caml_example}
\begin{caml_example}{toplevel}
let to_c1 x = (x :> c1);;
let to_c2 x = (x :> c2);;
\end{caml_example}
@ -872,7 +872,7 @@ parameterless classes the coercion "(_ :> c)" is always more general than
"(_ : #c :> c)".
%If a class type exposes the type of self through one of its parameters, this
%is no longer true. Here is a counter-example.
%\begin{caml_example}
%\begin{caml_example}{toplevel}
%class type ['a] c = object ('a) method m : 'a end;;
%let to_c x = (x :> _ c);;
%\end{caml_example}
@ -883,7 +883,7 @@ class "c" while defining class "c". The problem is due to the type
abbreviation not being completely defined yet, and so its subtypes are not
clearly known. Then, a coercion "(_ :> c)" or "(_ : #c :> c)" is taken to be
the identity function, as in
\begin{caml_example}
\begin{caml_example}{toplevel}
function x -> (x :> 'a);;
\end{caml_example}
As a consequence, if the coercion is applied to "self", as in the
@ -894,7 +894,7 @@ Indeed, the type of self cannot be closed: this would prevent any
further extension of the class. Therefore, a type error is generated
when the unification of this type with another type would result in a
closed object type.
\begin{caml_example}[error]
\begin{caml_example}{toplevel}[error]
class c = object method m = 1 end
and d = object (self)
inherit c
@ -905,12 +905,12 @@ end;;
However, the most common instance of this problem, coercing self to
its current class, is detected as a special case by the type checker,
and properly typed.
\begin{caml_example}
\begin{caml_example}{toplevel}
class c = object (self) method m = (self :> c) end;;
\end{caml_example}
This allows the following idiom, keeping a list of all objects
belonging to a class or its subclasses:
\begin{caml_example}
\begin{caml_example}{toplevel}
let all_c = ref [];;
class c (m : int) =
object (self)
@ -920,7 +920,7 @@ class c (m : int) =
\end{caml_example}
This idiom can in turn be used to retrieve an object whose type has
been weakened:
\begin{caml_example}
\begin{caml_example}{toplevel}
let rec lookup_obj obj = function [] -> raise Not_found
| obj' :: l ->
if (obj :> < >) = (obj' :> < >) then obj' else lookup_obj obj l ;;
@ -933,7 +933,7 @@ of type "c".
\medskip
The previous coercion problem can often be avoided by first
defining the abbreviation, using a class type:
\begin{caml_example}
\begin{caml_example}{toplevel}
class type c' = object method m : int end;;
class c : c' = object method m = 1 end
and d = object (self)
@ -945,12 +945,12 @@ end;;
It is also possible to use a virtual class. Inheriting from this class
simultaneously forces all methods of "c" to have the same
type as the methods of "c'".
\begin{caml_example}
\begin{caml_example}{toplevel}
class virtual c' = object method virtual m : int end;;
class c = object (self) inherit c' method m = 1 end;;
\end{caml_example}
One could think of defining the type abbreviation directly:
\begin{caml_example*}
\begin{caml_example*}{toplevel}
type c' = <m : int>;;
\end{caml_example*}
However, the abbreviation "#c'" cannot be defined directly in a similar way.
@ -958,7 +958,7 @@ It can only be defined by a class or a class-type definition.
This is because a "#"-abbreviation carries an implicit anonymous
variable ".." that cannot be explicitly named.
The closer you get to it is:
\begin{caml_example*}
\begin{caml_example*}{toplevel}
type 'a c'_class = 'a constraint 'a = < m : int; .. >;;
\end{caml_example*}
with an extra type variable capturing the open object type.
@ -971,7 +971,7 @@ It is possible to write a version of class "point" without assignments
on the instance variables. The override construct "{< ... >}" returns a copy of
``self'' (that is, the current object), possibly changing the value of
some instance variables.
\begin{caml_example}
\begin{caml_example}{toplevel}
class functional_point y =
object
val x = y
@ -989,7 +989,7 @@ and "'a" appears inside the type of the method "move".
The above definition of "functional_point" is not equivalent
to the following:
\begin{caml_example}
\begin{caml_example}{toplevel}
class bad_functional_point y =
object
val x = y
@ -1022,7 +1022,7 @@ A deeper assignment (for example if the instance variable is a reference cell)
will of course affect both the original and the copy.
The type of "Oo.copy" is the following:
\begin{caml_example}
\begin{caml_example}{toplevel}
Oo.copy;;
\end{caml_example}
The keyword "as" in that type binds the type variable "'a" to
@ -1031,7 +1031,7 @@ any methods (represented by the ellipsis), and returns an object of
the same type. The type of "Oo.copy" is different from type "< .. > ->
< .. >" as each ellipsis represents a different set of methods.
Ellipsis actually behaves as a type variable.
\begin{caml_example}
\begin{caml_example}{toplevel}
let p = new point 5;;
let q = Oo.copy p;;
q#move 7; (p#get_x, q#get_x);;
@ -1042,7 +1042,7 @@ method "copy" with body "{< >}" has been defined in the class of "p".
Objects can be compared using the generic comparison functions "=" and "<>".
Two objects are equal if and only if they are physically equal. In
particular, an object and its copy are not equal.
\begin{caml_example}
\begin{caml_example}{toplevel}
let q = Oo.copy p;;
p = q, p = p;;
\end{caml_example}
@ -1055,7 +1055,7 @@ two objects have been created and it is not affected by mutation of fields.
Cloning and override have a non empty intersection.
They are interchangeable when used within an object and without
overriding any field:
\begin{caml_example}
\begin{caml_example}{toplevel}
class copy =
object
method copy = {< >}
@ -1070,7 +1070,7 @@ only the "Oo.copy" primitive can be used externally.
Cloning can also be used to provide facilities for saving and
restoring the state of objects.
\begin{caml_example}
\begin{caml_example}{toplevel}
class backup =
object (self : 'mytype)
val mutable copy = None
@ -1080,7 +1080,7 @@ class backup =
\end{caml_example}
The above definition will only backup one level.
The backup facility can be added to any class by using multiple inheritance.
\begin{caml_example}
\begin{caml_example}{toplevel}
class ['a] backup_ref x = object inherit ['a] oref x inherit backup end;;
let rec get p n = if n = 0 then p # get else get (p # restore) (n-1);;
let p = new backup_ref 0 in
@ -1089,7 +1089,7 @@ p # save; p # set 1; p # save; p # set 2;
\end{caml_example}
We can define a variant of backup that retains all copies. (We also
add a method "clear" to manually erase all copies.)
\begin{caml_example}
\begin{caml_example}{toplevel}
class backup =
object (self : 'mytype)
val mutable copy = None
@ -1098,7 +1098,7 @@ class backup =
method clear = copy <- None
end;;
\end{caml_example}
\begin{caml_example}
\begin{caml_example}{toplevel}
class ['a] backup_ref x = object inherit ['a] oref x inherit backup end;;
let p = new backup_ref 0 in
p # save; p # set 1; p # save; p # set 2;
@ -1113,7 +1113,7 @@ p # save; p # set 1; p # save; p # set 2;
Recursive classes can be used to define objects whose types are
mutually recursive.
\begin{caml_example}
\begin{caml_example}{toplevel}
class window =
object
val mutable top_widget = (None : widget option)
@ -1139,7 +1139,7 @@ binary method "leq" of type "'a -> bool" where the type variable "'a"
is bound to the type of self. Therefore, "#comparable" expands to "<
leq : 'a -> bool; .. > as 'a". We see here that the binder "as" also
allows writing recursive types.
\begin{caml_example}
\begin{caml_example}{toplevel}
class virtual comparable =
object (_ : 'a)
method virtual leq : 'a -> bool
@ -1151,7 +1151,7 @@ more operations. We have to use a type constraint on the class parameter "x"
because the primitive "<=" is a polymorphic function in
OCaml. The "inherit" clause ensures that the type of objects
of this class is an instance of "#comparable".
\begin{caml_example}
\begin{caml_example}{toplevel}
class money (x : float) =
object
inherit comparable
@ -1171,7 +1171,7 @@ call to method "leq" on "m" with an argument that does not have a method
"value", which would be an error.
Similarly, the type "money2" below is not a subtype of type "money".
\begin{caml_example}
\begin{caml_example}{toplevel}
class money2 x =
object
inherit money x
@ -1185,13 +1185,13 @@ will return the minimum of any two objects whose type unifies with
#comparable -> #comparable", as the abbreviation "#comparable" hides a
type variable (an ellipsis). Each occurrence of this abbreviation
generates a new variable.
\begin{caml_example}
\begin{caml_example}{toplevel}
let min (x : #comparable) y =
if x#leq y then x else y;;
\end{caml_example}
This function can be applied to objects of type "money"
or "money2".
\begin{caml_example}
\begin{caml_example}{toplevel}
(min (new money 1.3) (new money 3.1))#value;;
(min (new money2 5.0) (new money2 3.14))#value;;
\end{caml_example}
@ -1207,7 +1207,7 @@ the "times" method would return an object of class "money2" but not of class
The class "money" could naturally carry another binary method. Here is a
direct definition:
\begin{caml_example}
\begin{caml_example}{toplevel}
class money x =
object (self : 'a)
val repr = x
@ -1231,7 +1231,7 @@ the representation can easily be hidden inside objects by removing the method
"value" as well. However, this is not possible as soon as some binary
method requires access to the representation of objects of the same
class (other than self).
\begin{caml_example}
\begin{caml_example}{toplevel}
class safe_money x =
object (self : 'a)
val repr = x
@ -1243,7 +1243,7 @@ Here, the representation of the object is known only to a particular object.
To make it available to other objects of the same class, we are forced to
make it available to the whole world. However we can easily restrict the
visibility of the representation using the module system.
\begin{caml_example*}
\begin{caml_example*}{toplevel}
module type MONEY =
sig
type t

77
manual/tools/caml_tex2.ml
View File

@ -233,6 +233,8 @@ let escape_specials s =
exception Missing_double_semicolon of string * int
exception Missing_mode of string * int
let process_file file =
prerr_endline ("Processing " ^ file);
let ic = try open_in file with _ -> failwith "Cannot read input file" in
@ -249,39 +251,55 @@ let process_file file =
open_out_gen [Open_wronly; Open_creat; Open_append; Open_text]
0x666 !outfile
with _ -> failwith "Cannot open output file" in
let re_spaces = "[ \t]*" in
let re_start = ~!(
{|\\begin{caml_example\(\*?\)}|} ^ re_spaces
^ {|\({toplevel}\|{verbatim}\)?|} ^ re_spaces
^ {|\(\[\(.*\)\]\)?|} ^ re_spaces
^ "$"
) in
try while true do
let input = ref (input_line ic) in
incr_phrase_start();
if string_match
~!"\\\\begin{caml_example\\(\\*?\\)}[ \t]*\\(\\[\\(.*\\)\\]\\)?[ \t]*$"
!input 0
if string_match re_start !input 0
then begin
let omit_answer = matched_group 1 !input = "*" in
let global_expected = try Output.expected @@ matched_group 3 !input
with Not_found -> Output.Ok
in
let explicit_stop =
match matched_group 2 !input with
| exception Not_found -> raise (Missing_mode(file, !phrase_stop))
| "{toplevel}" -> true
| "{verbatim}" -> false
| _ -> assert false in
let global_expected = try Output.expected @@ matched_group 4 !input
with Not_found -> Output.Ok in
start true oc main;
let first = ref true in
let read_phrase () =
let phrase = Buffer.create 256 in
let rec read () =
let input = incr phrase_stop; input_line ic in
if string_match ~!"\\\\end{caml_example\\*?}[ \t]*$"
input 0
then begin
if !phrase_stop = 1 + !phrase_start then
raise End_of_file
else
raise @@ Missing_double_semicolon (file,!phrase_stop)
end;
let implicit_stop =
if string_match ~!"\\\\end{caml_example\\*?}[ \t]*$"
input 0
then
begin
if !phrase_stop = 1 + !phrase_start then
raise End_of_file
else if explicit_stop then
raise @@ Missing_double_semicolon (file,!phrase_stop)
else
true
end
else false in
if Buffer.length phrase > 0 then Buffer.add_char phrase '\n';
let stop = string_match ~!"\\(.*\\)[ \t]*;;[ \t]*$" input 0 in
let stop = implicit_stop
|| string_match ~!"\\(.*\\)[ \t]*;;[ \t]*$" input 0 in
if not stop then (
Buffer.add_string phrase input; read ()
)
else begin
decr phrase_stop;
let last_input = matched_group 1 input in
let last_input = if implicit_stop then "" else matched_group 1 input in
let expected =
if string_match ~!{|\(.*\)\[@@expect \(.*\)\]|} last_input 0 then
( Buffer.add_string phrase (matched_group 1 last_input);
@ -289,14 +307,15 @@ let process_file file =
else
(Buffer.add_string phrase last_input; global_expected)
in
Buffer.add_string phrase ";;";
Buffer.contents phrase, expected
if not implicit_stop then Buffer.add_string phrase ";;";
implicit_stop, Buffer.contents phrase, expected
end in
read ()
in
try while true do
let phrase, expected = read_phrase () in
fprintf caml_output "%s\n" phrase;
let implicit_stop, phrase, expected = read_phrase () in
fprintf caml_output "%s%s" phrase
(if implicit_stop then ";;\n" else "\n");
flush caml_output;
output_string caml_output "\"end_of_input\";;\n";
flush caml_output;
@ -335,7 +354,8 @@ let process_file file =
code_env ~newline:false (Output.env status) oc output;
stop true oc phrase_env;
flush oc;
first := false
first := false;
if implicit_stop then raise End_of_file
done
with End_of_file -> phrase_start:= !phrase_stop; stop true oc main
end
@ -364,11 +384,22 @@ let process_file file =
( Output.print_parsing_error k s;
close_in ic; close_out oc; exit 1 )
| Missing_double_semicolon (file, line_number) ->
( Format.eprintf "Error when evaluating a caml_example environment in \
%s:\nmissing \";;\" at line %d\n" file (line_number-2);
( Format.eprintf "@[<hov 2> Error \
when evaluating a caml_example environment in %s:@;\
missing \";;\" at line %d@]@." file (line_number-2);
close_in ic; close_out oc;
exit 1
)
| Missing_mode (file, line_number) ->
( Format.eprintf "@[<hov 2>Error \
when parsing a caml_example environment in %s:@;\
missing mode argument at line %d,@ \
available modes {toplevel,verbatim}@]@."
file (line_number-2);
close_in ic; close_out oc;
exit 1
)
let _ =
if !outfile <> "-" && !outfile <> "" then begin

10
middle_end/middle_end.ml
View File

@ -35,7 +35,7 @@ let middle_end ppf ~prefixname ~backend
~filename
~module_ident
~module_initializer =
Timings.time_call "flambda" (fun () ->
Profile.record_call "flambda" (fun () ->
let pass_number = ref 0 in
let round_number = ref 0 in
let check flam =
@ -55,15 +55,15 @@ let middle_end ppf ~prefixname ~backend
!round_number Flambda.print_program flam;
Format.eprintf "\n@?"
end;
let flam = Timings.time ~accumulate:true name pass flam in
let flam = Profile.record ~accumulate:true name pass flam in
if !Clflags.flambda_invariant_checks then begin
Timings.time ~accumulate:true "check" check flam
Profile.record ~accumulate:true "check" check flam
end;
flam
in
Timings.time_call ~accumulate:true "middle_end" (fun () ->
Profile.record_call ~accumulate:true "middle_end" (fun () ->
let flam =
Timings.time_call ~accumulate:true "closure_conversion" (fun () ->
Profile.record_call ~accumulate:true "closure_conversion" (fun () ->
module_initializer
|> Closure_conversion.lambda_to_flambda ~backend ~module_ident
~size ~filename)

12
otherlibs/bigarray/bigarray.ml
View File

@ -109,6 +109,9 @@ module Array0 = struct
external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
= "caml_ba_change_layout"
let size_in_bytes arr = kind_size_in_bytes (kind arr)
external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit"
@ -133,6 +136,9 @@ module Array1 = struct
external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
= "caml_ba_change_layout"
let size_in_bytes arr =
(kind_size_in_bytes (kind arr)) * (dim arr)
@ -171,6 +177,9 @@ module Array2 = struct
external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
= "caml_ba_change_layout"
let size_in_bytes arr =
(kind_size_in_bytes (kind arr)) * (dim1 arr) * (dim2 arr)
@ -222,6 +231,9 @@ module Array3 = struct
external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
= "caml_ba_change_layout"
let size_in_bytes arr =
(kind_size_in_bytes (kind arr)) * (dim1 arr) * (dim2 arr) * (dim3 arr)

43
otherlibs/bigarray/bigarray.mli
View File

@ -471,6 +471,15 @@ module Array0 : sig
external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
(** Return the layout of the given big array. *)
val change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
(** [Array0.change_layout a layout] returns a big array with the
specified [layout], sharing the data with [a]. No copying of elements
is involved: the new array and the original array share the same
storage space.
@since 4.06.0
*)
val size_in_bytes : ('a, 'b, 'c) t -> int
(** [size_in_bytes a] is [a]'s {!kind_size_in_bytes}. *)
@ -525,6 +534,16 @@ module Array1 : sig
external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
(** Return the layout of the given big array. *)
val change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
(** [Array1.change_layout a layout] returns a bigarray with the
specified [layout], sharing the data with [a] (and hence having
the same dimension as [a]). No copying of elements is involved: the
new array and the original array share the same storage space.
@since 4.06.0
*)
val size_in_bytes : ('a, 'b, 'c) t -> int
(** [size_in_bytes a] is the number of elements in [a]
multiplied by [a]'s {!kind_size_in_bytes}.
@ -622,6 +641,18 @@ module Array2 :
external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
(** Return the layout of the given big array. *)
val change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
(** [Array2.change_layout a layout] returns a bigarray with the
specified [layout], sharing the data with [a] (and hence having
the same dimensions as [a]). No copying of elements is involved: the
new array and the original array share the same storage space.
The dimensions are reversed, such that [get v [| a; b |]] in
C layout becomes [get v [| b+1; a+1 |]] in Fortran layout.
@since 4.06.0
*)
val size_in_bytes : ('a, 'b, 'c) t -> int
(** [size_in_bytes a] is the number of elements in [a]
multiplied by [a]'s {!kind_size_in_bytes}.
@ -736,6 +767,18 @@ module Array3 :
external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
(** Return the layout of the given big array. *)
val change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
(** [Array3.change_layout a layout] returns a bigarray with the
specified [layout], sharing the data with [a] (and hence having
the same dimensions as [a]). No copying of elements is involved: the
new array and the original array share the same storage space.
The dimensions are reversed, such that [get v [| a; b; c |]] in
C layout becomes [get v [| c+1; b+1; a+1 |]] in Fortran layout.
@since 4.06.0
*)
val size_in_bytes : ('a, 'b, 'c) t -> int
(** [size_in_bytes a] is the number of elements in [a]
multiplied by [a]'s {!kind_size_in_bytes}.

32
otherlibs/win32unix/stat.c
View File

@ -69,9 +69,9 @@ static value stat_aux(int use_64, __int64 st_ino, struct _stat64 *buf)
Store_field (v, 7, Val_int (buf->st_rdev));
Store_field (v, 8,
use_64 ? caml_copy_int64(buf->st_size) : Val_int (buf->st_size));
Store_field (v, 9, caml_copy_double((double) buf->st_atime));
Store_field (v, 10, caml_copy_double((double) buf->st_mtime));
Store_field (v, 11, caml_copy_double((double) buf->st_ctime));
Store_field (v, 9, caml_copy_double((double) buf->st_atime / 10000000.0));
Store_field (v, 10, caml_copy_double((double) buf->st_mtime / 10000000.0));
Store_field (v, 11, caml_copy_double((double) buf->st_ctime / 10000000.0));
CAMLreturn (v);
}
@ -117,23 +117,17 @@ static value stat_aux(int use_64, __int64 st_ino, struct _stat64 *buf)
static int convert_time(FILETIME* time, __time64_t* result, __time64_t def)
{
SYSTEMTIME sys;
FILETIME local;
/* Tempting though it may be, MSDN prohibits casting FILETIME directly
* to __int64 for alignment concerns. While this doesn't affect our supported
* platforms, it's easier to go with the flow...
*/
ULARGE_INTEGER utime = {{time->dwLowDateTime, time->dwHighDateTime}};
if (time->dwLowDateTime || time->dwHighDateTime) {
if (!FileTimeToLocalFileTime(time, &local) ||
!FileTimeToSystemTime(&local, &sys))
{
win32_maperr(GetLastError());
return 0;
}
else
{
struct tm stamp = {sys.wSecond, sys.wMinute, sys.wHour,
sys.wDay, sys.wMonth - 1, sys.wYear - 1900,
0, 0, 0};
*result = _mktime64(&stamp);
}
if (utime.QuadPart) {
/* There are 11644473600000 seconds between 1 January 1601 (the NT Epoch)
* and 1 January 1970 (the Unix Epoch). FILETIME is measured in 100ns ticks.
*/
*result = (utime.QuadPart - INT64_LITERAL(116444736000000000U));
}
else {
*result = def;

53
parsing/builtin_attributes.ml
View File

@ -25,6 +25,11 @@ let string_of_payload = function
string_of_cst c
| _ -> None
let string_of_opt_payload p =
match string_of_payload p with
| Some s -> s
| None -> ""
let rec error_of_extension ext =
match ext with
| ({txt = ("ocaml.error"|"error") as txt; loc}, p) ->
@ -54,35 +59,45 @@ let rec error_of_extension ext =
| ({txt; loc}, _) ->
Location.errorf ~loc "Uninterpreted extension '%s'." txt
let cat s1 s2 =
if s2 = "" then s1 else s1 ^ "\n" ^ s2
let rec deprecated_of_attrs = function
| [] -> None
| ({txt = "ocaml.deprecated"|"deprecated"; _}, p) :: _ ->
begin match string_of_payload p with
| Some txt -> Some txt
| None -> Some ""
end
Some (string_of_opt_payload p)
| _ :: tl -> deprecated_of_attrs tl
let check_deprecated loc attrs s =
match deprecated_of_attrs attrs with
| None -> ()
| Some "" -> Location.prerr_warning loc (Warnings.Deprecated s)
| Some txt ->
Location.prerr_warning loc (Warnings.Deprecated (s ^ "\n" ^ txt))
| Some txt -> Location.deprecated loc (cat s txt)
let rec check_deprecated_mutable loc attrs s =
match attrs with
| [] -> ()
let check_deprecated_inclusion ~def ~use loc attrs1 attrs2 s =
match deprecated_of_attrs attrs1, deprecated_of_attrs attrs2 with
| None, _ | Some _, Some _ -> ()
| Some txt, None -> Location.deprecated ~def ~use loc (cat s txt)
let rec deprecated_mutable_of_attrs = function
| [] -> None
| ({txt = "ocaml.deprecated_mutable"|"deprecated_mutable"; _}, p) :: _ ->
let txt =
match string_of_payload p with
| Some txt -> "\n" ^ txt
| None -> ""
in
Location.prerr_warning loc
(Warnings.Deprecated (Printf.sprintf "mutating field %s%s"
s txt))
| _ :: tl -> check_deprecated_mutable loc tl s
Some (string_of_opt_payload p)
| _ :: tl -> deprecated_mutable_of_attrs tl
let check_deprecated_mutable loc attrs s =
match deprecated_mutable_of_attrs attrs with
| None -> ()
| Some txt ->
Location.deprecated loc (Printf.sprintf "mutating field %s" (cat s txt))
let check_deprecated_mutable_inclusion ~def ~use loc attrs1 attrs2 s =
match deprecated_mutable_of_attrs attrs1,
deprecated_mutable_of_attrs attrs2
with
| None, _ | Some _, Some _ -> ()
| Some txt, None ->
Location.deprecated ~def ~use loc
(Printf.sprintf "mutating field %s" (cat s txt))
let rec deprecated_of_sig = function
| {psig_desc = Psig_attribute a} :: tl ->

6
parsing/builtin_attributes.mli
View File

@ -29,12 +29,18 @@
val check_deprecated: Location.t -> Parsetree.attributes -> string -> unit
val check_deprecated_inclusion:
def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes ->
Parsetree.attributes -> string -> unit
val deprecated_of_attrs: Parsetree.attributes -> string option
val deprecated_of_sig: Parsetree.signature -> string option
val deprecated_of_str: Parsetree.structure -> string option
val check_deprecated_mutable:
Location.t -> Parsetree.attributes -> string -> unit
val check_deprecated_mutable_inclusion:
def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes ->
Parsetree.attributes -> string -> unit
val error_of_extension: Parsetree.extension -> Location.error

2
parsing/depend.ml
View File

@ -18,6 +18,8 @@ open Location
open Longident
open Parsetree
let pp_deps = ref []
module StringSet = Set.Make(struct type t = string let compare = compare end)
module StringMap = Map.Make(String)

3
parsing/depend.mli
View File

@ -26,6 +26,9 @@ val weaken_map : StringSet.t -> map_tree -> map_tree
val free_structure_names : StringSet.t ref
(* dependencies found by preprocessing tools (plugins) *)
val pp_deps : string list ref
val open_module : bound_map -> Longident.t -> bound_map
val add_use_file : bound_map -> Parsetree.toplevel_phrase list -> unit

4
parsing/lexer.mll
View File

@ -222,9 +222,7 @@ let escaped_newlines = ref false
(* Warn about Latin-1 characters used in idents *)
let warn_latin1 lexbuf =
Location.prerr_warning (Location.curr lexbuf)
(Warnings.Deprecated "ISO-Latin1 characters in identifiers")
;;
Location.deprecated (Location.curr lexbuf)"ISO-Latin1 characters in identifiers"
let handle_docstrings = ref true
let comment_list = ref []

14
parsing/location.ml
View File

@ -19,7 +19,7 @@ let absname = ref false
(* This reference should be in Clflags, but it would create an additional
dependency and make bootstrapping Camlp4 more difficult. *)
type t = { loc_start: position; loc_end: position; loc_ghost: bool };;
type t = Warnings.loc = { loc_start: position; loc_end: position; loc_ghost: bool };;
let in_file name =
let loc = {
@ -310,14 +310,19 @@ let print_error_cur_file ppf () = print_error ppf (in_file !input_name);;
let default_warning_printer loc ppf w =
match Warnings.report w with
| `Inactive -> ()
| `Active { Warnings. number; message; is_error } ->
| `Active { Warnings. number; message; is_error; sub_locs } ->
setup_colors ();
print ppf loc;
if is_error
then
fprintf ppf "%t (%s %d): %s@." print_error_prefix
(String.uncapitalize_ascii warning_prefix) number message
else fprintf ppf "@{<warning>%s@} %d: %s@." warning_prefix number message
else fprintf ppf "@{<warning>%s@} %d: %s@." warning_prefix number message;
List.iter
(fun (loc, msg) ->
if loc <> none then fprintf ppf " %a %s@." print loc msg
)
sub_locs
;;
let warning_printer = ref default_warning_printer ;;
@ -474,3 +479,6 @@ let raise_errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") =
pp_ksprintf
~before:print_phanton_error_prefix
(fun msg -> raise (Error ({loc; msg; sub; if_highlight})))
let deprecated ?(def = none) ?(use = none) loc msg =
prerr_warning loc (Warnings.Deprecated (msg, def, use))

4
parsing/location.mli
View File

@ -17,7 +17,7 @@
open Format
type t = {
type t = Warnings.loc = {
loc_start: Lexing.position;
loc_end: Lexing.position;
loc_ghost: bool;
@ -140,3 +140,5 @@ val default_error_reporter : formatter -> error -> unit
val report_exception: formatter -> exn -> unit
(** Reraise the exception if it is unknown. *)
val deprecated: ?def:t -> ?use:t -> t -> string -> unit

19
stdlib/arg.ml
View File

@ -309,8 +309,13 @@ let second_word s =
else if s.[n] = ' ' then loop (n+1)
else n
in
try loop (String.index s ' ')
with Not_found -> len
match String.index s '\t' with
| n -> loop (n+1)
| exception Not_found ->
begin match String.index s ' ' with
| n -> loop (n+1)
| exception Not_found -> len
end
let max_arg_len cur (kwd, spec, doc) =
@ -319,6 +324,10 @@ let max_arg_len cur (kwd, spec, doc) =
| _ -> max cur (String.length kwd + second_word doc)
let replace_leading_tab s =
let seen = ref false in
String.map (function '\t' when not !seen -> seen := true; ' ' | c -> c) s
let add_padding len ksd =
match ksd with
| (_, _, "") ->
@ -328,16 +337,16 @@ let add_padding len ksd =
| (kwd, (Symbol _ as spec), msg) ->
let cutcol = second_word msg in
let spaces = String.make ((max 0 (len - cutcol)) + 3) ' ' in
(kwd, spec, "\n" ^ spaces ^ msg)
(kwd, spec, "\n" ^ spaces ^ replace_leading_tab msg)
| (kwd, spec, msg) ->
let cutcol = second_word msg in
let kwd_len = String.length kwd in
let diff = len - kwd_len - cutcol in
if diff <= 0 then
(kwd, spec, msg)
(kwd, spec, replace_leading_tab msg)
else
let spaces = String.make diff ' ' in
let prefix = String.sub msg 0 cutcol in
let prefix = String.sub (replace_leading_tab msg) 0 cutcol in
let suffix = String.sub msg cutcol (String.length msg - cutcol) in
(kwd, spec, prefix ^ spaces ^ suffix)

15
stdlib/arg.mli
View File

@ -168,14 +168,13 @@ val usage_string : (key * spec * doc) list -> usage_msg -> string
if provided with the same parameters. *)
val align: ?limit: int -> (key * spec * doc) list -> (key * spec * doc) list
(** Align the documentation strings by inserting spaces at the first
space, according to the length of the keyword. Use a
space as the first character in a doc string if you want to
align the whole string. The doc strings corresponding to
[Symbol] arguments are aligned on the next line.
@param limit options with keyword and message longer than
[limit] will not be used to compute the alignment.
*)
(** Align the documentation strings by inserting spaces at the first alignment
separator (tab or, if tab is not found, space), according to the length of
the keyword. Use a alignment separator as the first character in a doc
string if you want to align the whole string. The doc strings corresponding
to [Symbol] arguments are aligned on the next line.
@param limit options with keyword and message longer than [limit] will not
be used to compute the alignment. *)
val current : int ref
(** Position (in {!Sys.argv}) of the argument being processed. You can

138
stdlib/format.mli
View File

@ -34,8 +34,7 @@
You may also use the explicit pretty-printing box management and printing
functions provided by this module. This style is more basic but more
verbose than the concise [fprintf] format strings.
verbose than the concise [{!fprintf}] format strings.
For instance, the sequence
[open_box 0; print_string "x ="; print_space ();
@ -57,7 +56,7 @@
the remaining material, e.g. evaluate [print_newline ()].
The behavior of pretty-printing commands is unspecified
if there is no open pretty-printing box. Each box open via
if there is no open pretty-printing box. Each box opened by
one of the [open_] functions below must be closed using [close_box]
for proper formatting. Otherwise, some of the material printed in the
boxes may not be output, or may be formatted incorrectly.
@ -72,7 +71,7 @@
The pretty-printing functions output material that is delayed in the
pretty-printer queue and stacks in order to compute proper line
splitting. In contrast, basic I/O output functions write directely in
splitting. In contrast, basic I/O output functions write directly in
their output device. As a consequence, the output of a basic I/O function
may appear before the output of a pretty-printing function that has been
called before. For instance,
@ -89,7 +88,7 @@
(** {6 Pretty-printing boxes} *)
(** The pretty-printing engine uses the concepts of pretty-printing box and
break hint to drive the indentation and the line splitting behavior of the
break hint to drive indentation and line splitting behavior of the
pretty-printer.
Each different pretty-printing box kind introduces a specific line splitting
@ -101,7 +100,7 @@
- within an {e horizontal/vertical} box, if the box fits on the current line
then break hints never split the line, otherwise break hint always split
the line,
- within an {e compacting} box, a break hint never splits the line,
- within a {e compacting} box, a break hint never splits the line,
unless there is no more room on the current line.
Note that line splitting policy is box specific: the policy of a box does
@ -226,7 +225,7 @@ val print_space : unit -> unit
the pretty-printer may split the line at this point,
otherwise it prints one space.
[print_space] is equivalent to [print_break 1 0].
[print_space ()] is equivalent to [print_break 1 0].
*)
val print_cut : unit -> unit
@ -234,7 +233,7 @@ val print_cut : unit -> unit
the pretty-printer may split the line at this point,
otherwise it prints nothing.
[print_cut] is equivalent to [print_break 0 0].
[print_cut ()] is equivalent to [print_break 0 0].
*)
val print_break : int -> int -> unit
@ -255,7 +254,6 @@ val force_newline : unit -> unit
interfere with current line counters and box size calculation.
Using break hints within an enclosing vertical box is a better
alternative.
*)
val print_if_newline : unit -> unit
@ -289,7 +287,6 @@ val print_flush : unit -> unit
to flush the out channel; these explicit flush calls could foil the
buffering strategy of output channels and could dramatically impact
efficiency.
*)
val print_newline : unit -> unit
@ -324,8 +321,9 @@ val get_margin : unit -> int
val set_max_indent : int -> unit
(** [set_max_indent d] sets the maximum indentation limit of lines to [d] (in
characters):
once this limit is reached, new pretty-printing boxes are rejected to the left,
if they do not fit on the current line.
once this limit is reached, new pretty-printing boxes are rejected to the
left, if they do not fit on the current line.
Nothing happens if [d] is smaller than 2.
If [d] is too large, the limit is set to the maximum
admissible value (which is greater than [10 ^ 9]).
@ -336,15 +334,20 @@ val get_max_indent : unit -> int
(** {6 Maximum formatting depth} *)
(** The maximum formatting depth is the maximum allowed number of
simultaneously open pretty-printing boxes before ellipsis. *)
(** The maximum formatting depth is the maximum number of pretty-printing
boxes simultaneously open.
Material inside boxes nested deeper is printed as an ellipsis (more
precisely as the text returned by [{!get_ellipsis_text} ()]).
*)
val set_max_boxes : int -> unit
(** [set_max_boxes max] sets the maximum number of pretty-printing boxes
simultaneously open.
Material inside boxes nested deeper is printed as an ellipsis (more
precisely as the text returned by [get_ellipsis_text ()]).
precisely as the text returned by [{!get_ellipsis_text} ()]).
Nothing happens if [max] is smaller than 2.
*)
@ -355,7 +358,7 @@ val get_max_boxes : unit -> int
val over_max_boxes : unit -> bool
(** Tests if the maximum number of pretty-printing boxes allowed have already
been open.
been opened.
*)
(** {6 Tabulation boxes} *)
@ -372,8 +375,8 @@ val over_max_boxes : unit -> bool
Note: printing within tabulation box is line directed, so arbitrary line
splitting inside a tabulation box leads to poor rendering. Yet, controlled
use of tabulation boxes allows simple printing of columns within {!Format}.
use of tabulation boxes allows simple printing of columns within
module [{!Format}].
*)
val open_tbox : unit -> unit
@ -388,7 +391,6 @@ val open_tbox : unit -> unit
A tabulation box features specific {e tabulation breaks} to move to next
tabulation marker or split the line. Function {!Format.print_tbreak} prints
a tabulation break.
*)
val close_tbox : unit -> unit
@ -417,7 +419,8 @@ val print_tbreak : int -> int -> unit
tabulation marker of the box.
If the pretty-printer splits the line, [offset] is added to
the current indentation. *)
the current indentation.
*)
(** {6 Ellipsis} *)
@ -496,19 +499,19 @@ type tag = string
Default tag-printing functions just do nothing.
Tag-marking and tag-printing functions are user definable and can
be set by calling {!set_formatter_tag_functions}.
be set by calling [{!set_formatter_tag_functions}].
Semantic tag operations may be set on or off with {!set_tags}.
Tag-marking operations may be set on or off with {!set_mark_tags}.
Tag-printing operations may be set on or off with {!set_print_tags}.
Semantic tag operations may be set on or off with [{!set_tags}].
Tag-marking operations may be set on or off with [{!set_mark_tags}].
Tag-printing operations may be set on or off with [{!set_print_tags}].
*)
val open_tag : tag -> unit
(** [open_tag t] opens the semantic tag named [t].
The [print_open_tag] tag-printing function of the formatter is called with
[t] as argument; then the opening tag marker, as given by [mark_open_tag t]
is written into the output device of the formatter.
[t] as argument; then the opening tag marker for [t], as given by
[mark_open_tag t], is written into the output device of the formatter.
*)
val close_tag : unit -> unit
@ -521,13 +524,14 @@ val close_tag : unit -> unit
val set_tags : bool -> unit
(** [set_tags b] turns on or off the treatment of semantic tags
(default is off). *)
(default is off).
*)
val set_print_tags : bool -> unit
(** [set_print_tags b] turns on or off the tag-printing operations. *)
val set_mark_tags : bool -> unit
(** [set_mark_tags b] turns on or off the tag-marking operation. *)
(** [set_mark_tags b] turns on or off the tag-marking operations. *)
val get_print_tags : unit -> bool
(** Return the current status of tag-printing operations. *)
@ -541,8 +545,9 @@ val set_formatter_out_channel : Pervasives.out_channel -> unit
(** Redirect the standard pretty-printer output to the given channel.
(All the output functions of the standard formatter are set to the
default output functions printing to the given channel.)
[set_formatter_out_channel] is equivalent to
[pp_set_formatter_out_channel std_formatter].
[{!pp_set_formatter_out_channel} std_formatter].
*)
val set_formatter_output_functions :
@ -606,7 +611,6 @@ type formatter_out_functions = {
- field [out_indent] is the same as field [out_spaces].
*)
val set_formatter_out_functions : formatter_out_functions -> unit
(** [set_formatter_out_functions out_funs]
Set all the pretty-printer output functions to those of argument
@ -616,17 +620,21 @@ val set_formatter_out_functions : formatter_out_functions -> unit
something else than just printing space characters) and the meaning of new
lines opening (which can be connected to any other action needed by the
application at hand).
*)
Reasonable defaults for functions [out_spaces] and [out_newline] are
respectively [out_funs.out_string (String.make n ' ') 0 n] and
[out_funs.out_string "\n" 0 1].
@since 4.01.0
*)
val get_formatter_out_functions : unit -> formatter_out_functions
(** Return the current output functions of the pretty-printer,
including line splitting and indentation functions. Useful to record the
current setting and restore it afterwards.
@since 4.01.0 *)
@since 4.01.0
*)
(** {6:tagsmeaning Redefining semantic tags operations} *)
(** {6:tagsmeaning Redefining semantic tag operations} *)
type formatter_tag_functions = {
mark_open_tag : tag -> string;
@ -647,7 +655,7 @@ val set_formatter_tag_functions : formatter_tag_functions -> unit
opening and closing semantic tag operations to use the functions in
[tag_funs].
When opening a semantic tag name [t], the string [t] is passed to the
When opening a semantic tag with name [t], the string [t] is passed to the
opening tag-marking function (the [mark_open_tag] field of the
record [tag_funs]), that must return the opening tag marker for
that name. When the next call to [close_tag ()] happens, the semantic tag
@ -677,49 +685,48 @@ type formatter
boxes simultaneously open, ellipsis, and so on, are specific to
each formatter and may be fixed independently.
For instance, given a [!Buffer.t] buffer [b], [formatter_of_buffer b]
For instance, given a [{!Buffer.t}] buffer [b], [{!formatter_of_buffer} b]
returns a new formatter using buffer [b] as its output device.
Similarly, given a [!Pervasives.out_channel] output channel [oc],
[formatter_of_out_channel oc] returns a new formatter using
Similarly, given a [{!Pervasives.out_channel}] output channel [oc],
[{!formatter_of_out_channel} oc] returns a new formatter using
channel [oc] as its output device.
Alternatively, given [out_funs], a complete set of output functions for a
formatter, then {!formatter_of_out_function out_funs} computes a new
formatter, then [{!formatter_of_out_functions} out_funs] computes a new
formatter using those functions for output.
*)
val formatter_of_out_channel : out_channel -> formatter
(** [formatter_of_out_channel oc] returns a new formatter writing
to the corresponding channel [oc].
to the corresponding output channel [oc].
*)
val std_formatter : formatter
(** The standard formatter to write to standard output.
It is defined as [formatter_of_out_channel stdout].
It is defined as [{!formatter_of_out_channel} {!Pervasives.stdout}].
*)
val err_formatter : formatter
(** A formatter to to write to standard error.
(** A formatter to write to standard error.
It is defined as [formatter_of_out_channel stderr].
It is defined as [{!formatter_of_out_channe}l {!Pervasives.stderr}].
*)
val formatter_of_buffer : Buffer.t -> formatter
(** [formatter_of_buffer b] returns a new formatter writing to
buffer [b]. At the end of pretty-printing, the formatter must be flushed
using [pp_print_flush] or [pp_print_newline], to print all the pending
material into the buffer.
using [{!pp_print_flush}] or [{!pp_print_newline}], to print all the
pending material into the buffer.
*)
val stdbuf : Buffer.t
(** The string buffer in which [str_formatter] writes. *)
val str_formatter : formatter
(** A formatter to output to the [stdbuf] string buffer.
(** A formatter to output to the [{!stdbuf}] string buffer.
[str_formatter] is defined as [formatter_of_buffer stdbuf].
[str_formatter] is defined as [{!formatter_of_buffer} {!stdbuf}].
*)
val flush_str_formatter : unit -> string
@ -732,15 +739,19 @@ val make_formatter :
(** [make_formatter out flush] returns a new formatter that outputs with
function [out], and flushes with function [flush].
For instance, a formatter to the [!Pervasives.out_channel] [oc] is returned
by [make_formatter (!Pervasives.output oc) (fun () -> !Pervasives.flush
oc)].
For instance,
[
make_formatter
({!Pervasives.output} oc)
(fun () -> {!Pervasives.flush} oc)
]
returns a formatter to the [{!Pervasives.out_channel}] [oc].
*)
val formatter_of_out_functions :
formatter_out_functions -> formatter
(** [formatter_of_out_functions out_funs] returns a new formatter that writes
with the set of output functions [out_funs].
with the set of output functions [out_funs].
See definition of type {!formatter_out_functions} for the meaning of argument
[out_funs].
@ -748,16 +759,26 @@ val formatter_of_out_functions :
@since 4.04.0
*)
(** {7 Symbolic pretty-printing} *)
(**
Symbolic pretty-printing is pretty-printing with no low level output.
Symbolic pretty-printing is pretty-printing using a symbolic formatter,
i.e. a formatter that outputs symbolic pretty-printing items.
When using a symbolic formatter, all regular pretty-printing activities
occur but output material is symbolic and stored in a buffer of output items.
At the end of pretty-printing, flushing the output buffer allows
post-processing of symbolic output before low level output operations.
post-processing of symbolic output before performing low level output
operations.
In practice, first define a symbolic output buffer [b] using:
- [let sob = {!make_symbolic_output_buffer} ()].
Then define a symbolic formatter with:
- [let ppf = {!formatter_of_symbolic_output_buffer} sob]
Use symbolic formatter [ppf] as usual, and retrieve symbolic items at end
of pretty-printing by flushing symbolic output buffer [sob] with:
- [{!flush_symbolic_output_buffer} sob].
*)
type symbolic_output_item =
@ -886,11 +907,10 @@ val pp_set_formatter_out_functions :
val pp_get_formatter_out_functions :
formatter -> unit -> formatter_out_functions
(** These functions are the basic ones: usual functions
operating on the standard formatter are defined via partial
evaluation of these primitives. For instance,
[print_string] is equal to [pp_print_string std_formatter].
[{!print_string}] is equal to [{!pp_print_string} {!std_formatter}].
*)
@ -901,7 +921,7 @@ val pp_print_list:
(formatter -> 'a -> unit) -> (formatter -> 'a list -> unit)
(** [pp_print_list ?pp_sep pp_v ppf l] prints items of list [l],
using [pp_v] to print each item, and calling [pp_sep]
between items ([pp_sep] defaults to {!pp_print_cut}).
between items ([pp_sep] defaults to [{!pp_print_cut}].
Does nothing on empty lists.
@since 4.02.0
@ -909,7 +929,7 @@ val pp_print_list:
val pp_print_text : formatter -> string -> unit
(** [pp_print_text ppf s] prints [s] with spaces and newlines respectively
printed using {!pp_print_space} and {!pp_force_newline}.
printed using [{!pp_print_space}] and [{!pp_force_newline}].
@since 4.02.0
*)

2
stdlib/stringLabels.mli
View File

@ -56,7 +56,7 @@ val init : int -> f:(int -> char) -> string
Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}.
@since 4.02.0 *)
val copy : string -> string
val copy : string -> string [@@ocaml.deprecated]
(** Return a copy of the given string. *)
val sub : string -> pos:int -> len:int -> string

13
testsuite/makefiles/Makefile.several
View File

@ -113,7 +113,18 @@ run-file:
rm -f "$$T"; \
} || true
@rm -f program program$(EXE)
@$(COMP) $(COMPFLAGS) $(FILE) -o program$(EXE)
@if [ -f "$(FILE).silent-compilation" ]; then \
temp="$$(mktemp "$${TMPDIR:-/tmp}/ocaml-test-XXXXXXXX")"; \
$(COMP) $(COMPFLAGS) $(FILE) -o program$(EXE) >$$temp 2>&1 ; \
if [ -s "$$temp" ]; then \
rm -f $$temp; \
printf " Error: compilation wrote to stdout/stderr!\n"; \
exit 1; \
fi; \
rm -f $$temp; \
else \
$(COMP) $(COMPFLAGS) $(FILE) -o program$(EXE); \
fi
@F="`basename $(FILE) .ml`"; \
if [ -f $$F.runner ]; then \
RUNTIME="$(RUNTIME)" sh $$F.runner; \

4
testsuite/tests/asmcomp/main.ml
View File

@ -58,10 +58,10 @@ let main() =
"-dreload", Arg.Set dump_reload, "";
"-dscheduling", Arg.Set dump_scheduling, "";
"-dlinear", Arg.Set dump_linear, "";
"-dtimings", Arg.Set print_timings, "";
"-dtimings", Arg.Unit (fun () -> profile_columns := [ `Time ]), "";
] compile_file usage
let () =
main ();
if !Clflags.print_timings then Timings.print Format.std_formatter;
Profile.print Format.std_formatter !Clflags.profile_columns;
exit 0

3
testsuite/tests/basic/eval_order_5.ml Normal file
View File

@ -0,0 +1,3 @@
let f ?(x = print_endline "hello") () = fun _ -> 1;;
let () = ignore (f ());;

1
testsuite/tests/basic/eval_order_5.reference Normal file
View File

@ -0,0 +1 @@
hello

19
testsuite/tests/basic/pr7533.ml Normal file
View File

@ -0,0 +1,19 @@
(* PR#7533 *)
exception Foo
let f x =
if x > 42 then 1
else raise Foo
let () =
let f = Sys.opaque_identity f in
match (f 0) / (List.hd (Sys.opaque_identity [0])) with
| exception Foo -> ()
| _ -> assert false
let () =
let f = Sys.opaque_identity f in
match (f 0) mod (List.hd (Sys.opaque_identity [0])) with
| exception Foo -> ()
| _ -> assert false

0
testsuite/tests/basic/pr7533.reference Normal file
View File

3
testsuite/tests/basic/trigraph.ml Normal file
View File

@ -0,0 +1,3 @@
(* PR#6373 *)
let () = print_string "??'"

0
testsuite/tests/basic/trigraph.ml.silent-compilation Normal file
View File

1
testsuite/tests/basic/trigraph.reference Normal file
View File

@ -0,0 +1 @@
??'

15
testsuite/tests/lib-arg/testarg.ml
View File

@ -187,3 +187,18 @@ let test_expand spec argv reference =
test_expand (expand1@spec) args1 expected1;;
test_expand (expand2@spec) args2 expected2;;
let test_align () =
let spec =
[
"-foo", Arg.String ignore, "FOO Do foo with FOO";
"-bar", Arg.Tuple [Arg.String ignore; Arg.String ignore], "FOO BAR\tDo bar with FOO and BAR";
"-cha", Arg.Unit ignore, " Another option";
"-sym", Arg.Symbol (["a"; "b"], ignore), "\ty\tfoo";
"-sym2", Arg.Symbol (["a"; "b"], ignore), "x bar";
]
in
print_endline (Arg.usage_string (Arg.align spec) "")
;;
test_align ();;

11
testsuite/tests/lib-arg/testarg.reference
View File

@ -0,0 +1,11 @@
-foo FOO Do foo with FOO
-bar FOO BAR Do bar with FOO and BAR
-cha Another option
-sym {a|b}
y foo
-sym2 {a|b}
x bar
-help Display this list of options
--help Display this list of options

142
testsuite/tests/lib-bigarray/change_layout.ml Normal file
View File

@ -0,0 +1,142 @@
(** Test the various change_layout for Genarray and the various Array[n] *)
open Bigarray
let pp_sep ppf () = Format.fprintf ppf ";@ "
let print_array pp ppf a =
Format.fprintf ppf "@[<hov>⟦%a⟧@]"
Format.(pp_print_list ~pp_sep pp) (Array.to_list a)
let print_index = print_array Format.pp_print_int
let do_test n test =
let rec aux l n =
if n = 0 then l
else
aux
begin match test (n-1) with
| Some error -> error :: l
| None -> l
end
(n-1) in
aux [] n
let kind = float64
let c = c_layout
let fortran = fortran_layout
let rank = 5
let dims = Array.init rank (fun n -> n+2)
let size = Array.fold_left ( * ) 1 dims
let report s test =
let errors = do_test size test in
if errors = [] then
Format.printf"@[%s: Ok@]@." s
else
Format.printf "@[%s:@;Failed at indices @[<hov>%a@]@]@." s
(Format.pp_print_list ~pp_sep print_index)
errors
let array =
let a = Array1.create kind c size in
for i = 0 to size - 1 do a.{i} <- float i done;
a
(** Test for generic biggarray *)
let gen = reshape (genarray_of_array1 array) dims
let sizes =
let a = Array.make rank 1 in
let _ = Array.fold_left (fun (i,s) x -> a.(i)<- s; (i+1, s * x)) (0,1) dims in
a
let multi_index n =
Array.init rank ( fun i -> (n / sizes.(i)) mod dims.(i) )
let testG n =
let pos = multi_index n in
let initial = Genarray.get gen pos in
Genarray.set gen pos (-1.);
let different = Genarray.get gen pos <> initial in
let gen' = Genarray.change_layout gen fortran in
Genarray.set gen' ( Array.init rank @@ fun n -> 1 + pos.( rank - 1 - n ) ) initial;
if not (different && initial = Genarray.get gen pos) then Some pos
else None
;;
report "Generic rank test" testG
;;
(* Scalar *)
let scalar =
let a = Array0.create kind c in
Array0.set a 0.; a
;;
let test =
let a' = Array0.change_layout scalar fortran in
Array0.set a' 1.;
Array0.get scalar = 1.
;;
Format.printf "Scalar test: %s@." (if test then "Ok" else "Failed")
;;
(* Vector *)
let vec = array1_of_genarray @@ reshape gen [|size|]
let test1 i =
let initial = vec.{i} in
vec.{i} <- -1.;
let different = vec.{i} <> initial in
let vec' = Array1.change_layout vec fortran in
vec'.{ i + 1 } <- initial;
if different && initial = vec.{i} then None
else Some [|i|]
;;
report "Rank-1 array test" test1
;;
(* Matrix *)
let mat = array2_of_genarray @@ reshape gen [|dims.(0); size / dims.(0) |]
let bi_index n = n mod dims.(0), n / dims.(0)
let test2 n =
let i, j = bi_index n in
let initial = mat.{i,j} in
mat.{i,j} <- -1.;
let different = mat.{i,j} <> initial in
let mat' = Array2.change_layout mat fortran in
mat'.{ j + 1, i + 1 } <- initial;
if different && initial = mat.{i, j} then None
else Some [|i; j|]
;;
report "Rank-2 array test" test2
;;
(* Rank 3 *)
let t3 = array3_of_genarray @@
reshape gen [|dims.(0); dims.(1); size / (dims.(0) * dims.(1)) |]
let tri_index n =
n mod dims.(0),
(n/ dims.(0)) mod dims.(1),
n / (dims.(0) * dims.(1))
let test3 n =
let i, j, k = tri_index n in
let initial = t3.{i,j,k} in
t3.{i,j,k} <- -1.;
let different = t3.{i,j,k} <> initial in
let t3' = Array3.change_layout t3 fortran in
t3'.{ k + 1, j + 1, i + 1 } <- initial;
if different && initial = t3.{i, j, k} then None
else Some [|i;j;k|]
;;
report "Rank-3 array test" test3
;;

5
testsuite/tests/lib-bigarray/change_layout.reference Normal file
View File

@ -0,0 +1,5 @@
Generic rank test: Ok
Scalar test: Ok
Rank-1 array test: Ok
Rank-2 array test: Ok
Rank-3 array test: Ok

2
testsuite/tests/lib-unix/Makefile → testsuite/tests/lib-unix/common/Makefile
View File

@ -13,7 +13,7 @@
#* *
#**************************************************************************
BASEDIR=../..
BASEDIR=../../..
LIBRARIES=unix
ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix

0
testsuite/tests/lib-unix/cloexec.ml → testsuite/tests/lib-unix/common/cloexec.ml
View File

0
testsuite/tests/lib-unix/cloexec.reference → testsuite/tests/lib-unix/common/cloexec.reference
View File

0
testsuite/tests/lib-unix/cmdline_prog.c → testsuite/tests/lib-unix/common/cmdline_prog.c
View File

0
testsuite/tests/lib-unix/dup.ml → testsuite/tests/lib-unix/common/dup.ml
View File

0
testsuite/tests/lib-unix/dup.reference → testsuite/tests/lib-unix/common/dup.reference
View File

0
testsuite/tests/lib-unix/dup2.ml → testsuite/tests/lib-unix/common/dup2.ml
View File

0
testsuite/tests/lib-unix/dup2.reference → testsuite/tests/lib-unix/common/dup2.reference
View File

0
testsuite/tests/lib-unix/fdstatus.c → testsuite/tests/lib-unix/common/fdstatus.c
View File

0
testsuite/tests/lib-unix/pipe_eof.ml → testsuite/tests/lib-unix/common/pipe_eof.ml
View File

0
testsuite/tests/lib-unix/pipe_eof.reference → testsuite/tests/lib-unix/common/pipe_eof.reference
View File

0
testsuite/tests/lib-unix/redirections.ml → testsuite/tests/lib-unix/common/redirections.ml
View File

0
testsuite/tests/lib-unix/redirections.reference → testsuite/tests/lib-unix/common/redirections.reference
View File

0
testsuite/tests/lib-unix/reflector.c → testsuite/tests/lib-unix/common/reflector.c
View File

0
testsuite/tests/lib-unix/test_unix_cmdline.ml → testsuite/tests/lib-unix/common/test_unix_cmdline.ml
View File

0
testsuite/tests/lib-unix/test_unix_cmdline.reference → testsuite/tests/lib-unix/common/test_unix_cmdline.reference
View File

20
testsuite/tests/lib-unix/win-stat/Makefile Normal file
View File

@ -0,0 +1,20 @@
BASEDIR=../../..
LIBRARIES=unix
ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
C_FILES=fakeclock
MAIN_MODULE=test
TEST_TEMP_FILES=dst-file non-dst-file
ifeq ($(OS),Windows_NT)
test:
@TZ=utc touch -m -t 201707011200 dst-file
@TZ=utc touch -m -t 201702011200 non-dst-file
@$(MAKE) default
else
skip:
@echo " ... testing => skipped (not on Windows)"
endif
include $(BASEDIR)/makefiles/Makefile.one
include $(BASEDIR)/makefiles/Makefile.common

179
testsuite/tests/lib-unix/win-stat/fakeclock.c Normal file
View File

@ -0,0 +1,179 @@
/**************************************************************************/
/* */
/* OCaml */
/* */
/* David Allsopp, OCaml Labs, Cambridge. */
/* */
/* Copyright 2017 MetaStack Solutions Ltd. */
/* */
/* All rights reserved. This file is distributed under the terms of */
/* the GNU Lesser General Public License version 2.1, with the */
/* special exception on linking described in the file LICENSE. */
/* */
/**************************************************************************/
#include <windows.h>
typedef union ufiletime_int64
{
unsigned __int64 scalar;
FILETIME ft;
} filetime_int64;
static filetime_int64 clk;
static DWORD wall = 0;
static unsigned __int64 bias = 0LL;
BOOL WINAPI FakeConvert(const FILETIME* lpFileTime, LPFILETIME lpLocalFileTime)
{
filetime_int64 result;
memcpy(&result.ft, lpFileTime, sizeof(FILETIME));
result.scalar += bias;
memcpy(lpLocalFileTime, &result.ft, sizeof(FILETIME));
return TRUE;
}
void WINAPI FakeClock(LPFILETIME result)
{
DWORD now = GetTickCount();
/* Take a risk on this: GetTickCount64 is not available in Windows XP... */
/* GetTickCount is in ms, clk.scalar is in 100ns intervals */
clk.scalar += ((now - wall) * 10000);
wall = now;
memcpy(result, &clk.ft, sizeof(FILETIME));
return;
}
/* Assuming that nowhere transitions DST in February... */
static short mon_days[13] = {0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31};
void SetBias(void)
{
TIME_ZONE_INFORMATION tzInfo;
filetime_int64 dst;
SYSTEMTIME dst_start;
switch (GetTimeZoneInformation(&tzInfo)) {
case TIME_ZONE_ID_INVALID:
case TIME_ZONE_ID_UNKNOWN:
/* Default to GMT */
tzInfo.DaylightDate.wYear = 0;
tzInfo.DaylightDate.wMonth = 3;
tzInfo.DaylightDate.wDay = 5;
tzInfo.DaylightDate.wDayOfWeek = 0;
tzInfo.DaylightDate.wHour = 1;
tzInfo.StandardBias = 0;
tzInfo.DaylightBias = -60;
}
/* If wYear is given, then DaylightDate is a date, otherwise the transition
* is the wDay'th wDayOfWeek of wMonth (where the 5th wDayOfWeek means last
* when there are only 4 wDayOfWeek's in wMonth)
*/
if (!tzInfo.DaylightDate.wYear) {
int wday;
/* Get the clock date in order to determine wYear */
FileTimeToSystemTime(&clk.ft, &dst_start);
/* Back-up DST transition details */
dst_start.wDay = tzInfo.DaylightDate.wDay;
dst_start.wDayOfWeek = tzInfo.DaylightDate.wDayOfWeek;
/* Set tzInfo to be first day of month on DST change */
tzInfo.DaylightDate.wYear = dst_start.wYear;
tzInfo.DaylightDate.wDay = 1;
/* Normalise tzInfo.DaylightDate (need wDayOfWeek) */
SystemTimeToFileTime(&tzInfo.DaylightDate, &dst.ft);
FileTimeToSystemTime(&dst.ft, &tzInfo.DaylightDate);
/* First to first weekday of DST transition */
if ((wday = dst_start.wDayOfWeek - tzInfo.DaylightDate.wDayOfWeek) < 0)
tzInfo.DaylightDate.wDay += wday + 7;
else
tzInfo.DaylightDate.wDay += wday;
tzInfo.DaylightDate.wDayOfWeek =
(mon_days[tzInfo.DaylightDate.wMonth] - tzInfo.DaylightDate.wDay) / 7;
if (dst_start.wDay > tzInfo.DaylightDate.wDayOfWeek)
dst_start.wDay = tzInfo.DaylightDate.wDayOfWeek;
tzInfo.DaylightDate.wDay += 7 * dst_start.wDay;
}
SystemTimeToFileTime(&tzInfo.DaylightDate, &dst.ft);
bias = -(clk.scalar >= dst.scalar ? tzInfo.DaylightBias
: tzInfo.StandardBias) * 600000000LL;
return;
}
void ReplaceFunction(char* fn, char* module, void* pNew)
{
HMODULE hModule = LoadLibrary(module);
void* pCode;
DWORD dwOldProtect = 0;
#ifdef _M_X64
SIZE_T jmpSize = 13;
BYTE jump[13];
#else
SIZE_T jmpSize = 5;
BYTE jump[5];
#endif
SIZE_T bytesWritten;
/* Patching is permitted to fail (missing API, etc.) */
if (!hModule) return;
pCode = GetProcAddress(hModule, fn);
if (!pCode) return;
/* Overwrite the code with a jump to our function */
if (VirtualProtect(pCode, jmpSize, PAGE_EXECUTE_READWRITE, &dwOldProtect)) {
#ifdef _M_X64
jump[0] = 0x49; /* REX.WB prefix */
jump[1] = 0xBB; /* MOV r11, ... */
memcpy(jump + 2, &pNew, 8); /* imm64 */
jump[10] = 0x41; /* REX.B prefix */
jump[11] = 0xFF; /* JMP */
jump[12] = 0xE3; /* r11 */
#else
/* JMP rel32 to FakeClock */
DWORD dwRelativeAddr = (DWORD)pNew - ((DWORD)pCode + 5);
jump[0] = 0xE9;
memcpy(jump + 1, &dwRelativeAddr, 4);
#endif
if (WriteProcessMemory(GetCurrentProcess(), pCode, jump, jmpSize, NULL)) {
VirtualProtect(pCode, jmpSize, dwOldProtect, &dwOldProtect);
}
}
return;
}
#define CAML_NAME_SPACE
#include <caml/mlvalues.h>
#include <caml/memory.h>
static int patched = 0;
CAMLprim value set_fake_clock(value time)
{
CAMLparam1(time);
clk.scalar = Int64_val(time);
wall = GetTickCount();
SetBias();
if (!patched) {
patched = 1;
/* Patch Windows 8 and later (UCRT) */
ReplaceFunction("GetSystemTimePreciseAsFileTime",
"api-ms-win-core-sysinfo-l1-2-1.dll", &FakeClock);
ReplaceFunction("GetSystemTimeAsFileTime",
"api-ms-win-core-sysinfo-l1-2-1.dll", &FakeClock);
/* Patch Windows 7 API Set */
ReplaceFunction("GetSystemTimeAsFileTime",
"api-ms-win-core-sysinfo-l1-1-0.dll", &FakeClock);
/* Patch Windows 7 and previous (standard CRT) */
ReplaceFunction("GetSystemTimeAsFileTime",
"kernel32.dll", &FakeClock);
ReplaceFunction("FileTimeToLocalFileTime", "kernel32.dll", &FakeConvert);
}
CAMLreturn(Val_unit);
}

31
testsuite/tests/lib-unix/win-stat/test.ml Normal file
View File

@ -0,0 +1,31 @@
open Unix
external set_fake_clock : int64 -> unit = "set_fake_clock"
let real_time tm = {tm with tm_year = tm.tm_year + 1900; tm_mon = tm.tm_mon + 1}
let print_time () =
let time = Unix.time () |> Unix.gmtime |> real_time in
Printf.printf "System clock: %04d/%02d/%02d %02d:%02d\n" time.tm_year
time.tm_mon
time.tm_mday
time.tm_hour
time.tm_min
let test_mtime file =
let time = (Unix.stat file).st_mtime |> Unix.gmtime |> real_time in
Printf.printf "Read mtime for %s = %04d/%02d/%02d %02d:%02d:%02d\n"
file
time.tm_year time.tm_mon time.tm_mday time.tm_hour time.tm_min time.tm_sec
let _ =
(* 1-Jun-2017 20:33:10.42+0000 *)
set_fake_clock 0x1D2DB1648916FA0L;
print_time ();
test_mtime "dst-file";
test_mtime "non-dst-file";
(* 1-Feb-2017 20:33:10.42+0000 *)
set_fake_clock 0x1D27CCA66FF6FA0L;
print_time ();
test_mtime "dst-file";
test_mtime "non-dst-file"

6
testsuite/tests/lib-unix/win-stat/test.reference Normal file
View File

@ -0,0 +1,6 @@
System clock: 2017/06/01 20:33
Read mtime for dst-file = 2017/07/01 12:00:00
Read mtime for non-dst-file = 2017/02/01 12:00:00
System clock: 2017/02/01 20:33
Read mtime for dst-file = 2017/07/01 12:00:00
Read mtime for non-dst-file = 2017/02/01 12:00:00

3
testsuite/tests/tool-lexyacc/grammar.mly
View File

@ -29,7 +29,8 @@ lexer_definition:
;
header:
Taction
{ $1 }
{ $1 (* '"' test that ocamlyacc can
handle comments correctly"*)" "(*" *) }
|
{ Location(0,0) }
;

Some files were not shown because too many files have changed in this diff Show More