diff options
| -rw-r--r-- | .depend | 297 | ||||
| -rw-r--r-- | .gitignore | 6 | ||||
| -rw-r--r-- | Changes | 4 | ||||
| -rw-r--r-- | Makefile | 20 | ||||
| -rw-r--r-- | compilerlibs/Makefile.compilerlibs | 22 | ||||
| -rw-r--r-- | testsuite/tests/tool-toplevel/pr6468.compilers.reference | 2 | ||||
| -rw-r--r-- | tools/.depend | 2 | ||||
| -rw-r--r-- | toplevel/byte/topeval.ml | 356 | ||||
| -rw-r--r-- | toplevel/byte/toploop.ml | 649 | ||||
| -rw-r--r-- | toplevel/byte/topmain.ml | 114 | ||||
| -rw-r--r-- | toplevel/byte/trace.ml | 3 | ||||
| -rw-r--r-- | toplevel/dune | 4 | ||||
| -rw-r--r-- | toplevel/native/topdirs.ml | 224 | ||||
| -rw-r--r-- | toplevel/native/topeval.ml (renamed from toplevel/native/toploop.ml) | 430 | ||||
| -rw-r--r-- | toplevel/native/topmain.ml | 26 | ||||
| -rw-r--r-- | toplevel/topcommon.ml | 302 | ||||
| -rw-r--r-- | toplevel/topcommon.mli | 198 | ||||
| -rw-r--r-- | toplevel/topdirs.ml (renamed from toplevel/byte/topdirs.ml) | 233 | ||||
| -rw-r--r-- | toplevel/topdirs.mli | 18 | ||||
| -rw-r--r-- | toplevel/topeval.mli | 56 | ||||
| -rw-r--r-- | toplevel/toploop.ml | 202 | ||||
| -rw-r--r-- | toplevel/toploop.mli | 16 |
22 files changed, 1537 insertions, 1647 deletions
@@ -6118,41 +6118,76 @@ toplevel/genprintval.cmi : \ typing/path.cmi \ typing/outcometree.cmi \ typing/env.cmi -toplevel/topdirs.cmi : \ - parsing/longident.cmi -toplevel/toploop.cmi : \ - utils/warnings.cmi \ +toplevel/topcommon.cmo : \ typing/types.cmi \ + parsing/printast.cmi \ + typing/predef.cmi \ + parsing/pprintast.cmi \ + driver/pparse.cmi \ typing/path.cmi \ parsing/parsetree.cmi \ + parsing/parse.cmi \ typing/outcometree.cmi \ + typing/oprint.cmi \ + utils/misc.cmi \ parsing/longident.cmi \ parsing/location.cmi \ - typing/env.cmi -toplevel/topmain.cmi : -toplevel/topstart.cmo : \ - toplevel/topmain.cmi -toplevel/topstart.cmx : \ - toplevel/topmain.cmi -toplevel/trace.cmi : \ + utils/load_path.cmi \ + parsing/lexer.cmi \ + toplevel/genprintval.cmi \ + typing/env.cmi \ + bytecomp/dll.cmi \ + utils/config.cmi \ + driver/compmisc.cmi \ + driver/compenv.cmi \ + utils/clflags.cmi \ + parsing/ast_helper.cmi \ + toplevel/topcommon.cmi +toplevel/topcommon.cmx : \ + typing/types.cmx \ + parsing/printast.cmx \ + typing/predef.cmx \ + parsing/pprintast.cmx \ + driver/pparse.cmx \ + typing/path.cmx \ + parsing/parsetree.cmi \ + parsing/parse.cmx \ + typing/outcometree.cmi \ + typing/oprint.cmx \ + utils/misc.cmx \ + parsing/longident.cmx \ + parsing/location.cmx \ + utils/load_path.cmx \ + parsing/lexer.cmx \ + toplevel/genprintval.cmx \ + typing/env.cmx \ + bytecomp/dll.cmx \ + utils/config.cmx \ + driver/compmisc.cmx \ + driver/compenv.cmx \ + utils/clflags.cmx \ + parsing/ast_helper.cmx \ + toplevel/topcommon.cmi +toplevel/topcommon.cmi : \ + utils/warnings.cmi \ typing/types.cmi \ typing/path.cmi \ + parsing/parsetree.cmi \ + typing/outcometree.cmi \ parsing/longident.cmi \ + parsing/location.cmi \ + toplevel/genprintval.cmi \ typing/env.cmi -toplevel/byte/topdirs.cmo : \ +toplevel/topdirs.cmo : \ utils/warnings.cmi \ typing/types.cmi \ - toplevel/byte/trace.cmi \ - toplevel/byte/toploop.cmi \ - bytecomp/symtable.cmi \ + toplevel/toploop.cmi \ + toplevel/topeval.cmi \ typing/printtyp.cmi \ typing/predef.cmi \ - typing/persistent_env.cmi \ typing/path.cmi \ parsing/parsetree.cmi \ - bytecomp/opcodes.cmi \ utils/misc.cmi \ - bytecomp/meta.cmi \ parsing/longident.cmi \ parsing/location.cmi \ utils/load_path.cmi \ @@ -6162,26 +6197,21 @@ toplevel/byte/topdirs.cmo : \ typing/ctype.cmi \ utils/config.cmi \ driver/compenv.cmi \ - file_formats/cmo_format.cmi \ utils/clflags.cmi \ typing/btype.cmi \ parsing/asttypes.cmi \ parsing/ast_helper.cmi \ - toplevel/byte/topdirs.cmi -toplevel/byte/topdirs.cmx : \ + toplevel/topdirs.cmi +toplevel/topdirs.cmx : \ utils/warnings.cmx \ typing/types.cmx \ - toplevel/byte/trace.cmx \ - toplevel/byte/toploop.cmx \ - bytecomp/symtable.cmx \ + toplevel/toploop.cmx \ + toplevel/topeval.cmi \ typing/printtyp.cmx \ typing/predef.cmx \ - typing/persistent_env.cmx \ typing/path.cmx \ parsing/parsetree.cmi \ - bytecomp/opcodes.cmx \ utils/misc.cmx \ - bytecomp/meta.cmx \ parsing/longident.cmx \ parsing/location.cmx \ utils/load_path.cmx \ @@ -6191,43 +6221,93 @@ toplevel/byte/topdirs.cmx : \ typing/ctype.cmx \ utils/config.cmx \ driver/compenv.cmx \ - file_formats/cmo_format.cmi \ utils/clflags.cmx \ typing/btype.cmx \ parsing/asttypes.cmi \ parsing/ast_helper.cmx \ - toplevel/byte/topdirs.cmi -toplevel/byte/topdirs.cmi : \ + toplevel/topdirs.cmi +toplevel/topdirs.cmi : \ parsing/longident.cmi -toplevel/byte/toploop.cmo : \ +toplevel/topeval.cmi : \ + toplevel/topcommon.cmi \ + typing/path.cmi \ + parsing/parsetree.cmi \ + typing/env.cmi +toplevel/toploop.cmo : \ utils/warnings.cmi \ typing/typetexp.cmi \ + toplevel/topeval.cmi \ + toplevel/topcommon.cmi \ + utils/misc.cmi \ + parsing/location.cmi \ + utils/load_path.cmi \ + parsing/lexer.cmi \ + typing/env.cmi \ + utils/config.cmi \ + driver/compmisc.cmi \ + driver/compenv.cmi \ + utils/clflags.cmi \ + typing/btype.cmi \ + toplevel/toploop.cmi +toplevel/toploop.cmx : \ + utils/warnings.cmx \ + typing/typetexp.cmx \ + toplevel/topeval.cmi \ + toplevel/topcommon.cmx \ + utils/misc.cmx \ + parsing/location.cmx \ + utils/load_path.cmx \ + parsing/lexer.cmx \ + typing/env.cmx \ + utils/config.cmx \ + driver/compmisc.cmx \ + driver/compenv.cmx \ + utils/clflags.cmx \ + typing/btype.cmx \ + toplevel/toploop.cmi +toplevel/toploop.cmi : \ + utils/warnings.cmi \ + typing/types.cmi \ + typing/path.cmi \ + parsing/parsetree.cmi \ + typing/outcometree.cmi \ + parsing/longident.cmi \ + parsing/location.cmi \ + typing/env.cmi +toplevel/topmain.cmi : +toplevel/topstart.cmo : \ + toplevel/topmain.cmi +toplevel/topstart.cmx : \ + toplevel/topmain.cmi +toplevel/trace.cmi : \ + typing/types.cmi \ + typing/path.cmi \ + parsing/longident.cmi \ + typing/env.cmi +toplevel/byte/topeval.cmo : \ + utils/warnings.cmi \ typing/types.cmi \ typing/typemod.cmi \ typing/typedtree.cmi \ typing/typecore.cmi \ lambda/translmod.cmi \ + toplevel/topcommon.cmi \ bytecomp/symtable.cmi \ lambda/simplif.cmi \ typing/printtyped.cmi \ typing/printtyp.cmi \ lambda/printlambda.cmi \ bytecomp/printinstr.cmi \ - parsing/printast.cmi \ typing/predef.cmi \ - parsing/pprintast.cmi \ - driver/pparse.cmi \ + typing/persistent_env.cmi \ typing/path.cmi \ parsing/parsetree.cmi \ - parsing/parse.cmi \ typing/outcometree.cmi \ - typing/oprint.cmi \ + bytecomp/opcodes.cmi \ utils/misc.cmi \ bytecomp/meta.cmi \ - parsing/longident.cmi \ parsing/location.cmi \ utils/load_path.cmi \ - parsing/lexer.cmi \ typing/includemod.cmi \ typing/ident.cmi \ toplevel/genprintval.cmi \ @@ -6236,42 +6316,35 @@ toplevel/byte/toploop.cmo : \ bytecomp/dll.cmi \ utils/config.cmi \ driver/compmisc.cmi \ - driver/compenv.cmi \ + file_formats/cmo_format.cmi \ utils/clflags.cmi \ bytecomp/bytegen.cmi \ - typing/btype.cmi \ parsing/asttypes.cmi \ - parsing/ast_helper.cmi \ - toplevel/byte/toploop.cmi -toplevel/byte/toploop.cmx : \ + toplevel/byte/topeval.cmi +toplevel/byte/topeval.cmx : \ utils/warnings.cmx \ - typing/typetexp.cmx \ typing/types.cmx \ typing/typemod.cmx \ typing/typedtree.cmx \ typing/typecore.cmx \ lambda/translmod.cmx \ + toplevel/topcommon.cmx \ bytecomp/symtable.cmx \ lambda/simplif.cmx \ typing/printtyped.cmx \ typing/printtyp.cmx \ lambda/printlambda.cmx \ bytecomp/printinstr.cmx \ - parsing/printast.cmx \ typing/predef.cmx \ - parsing/pprintast.cmx \ - driver/pparse.cmx \ + typing/persistent_env.cmx \ typing/path.cmx \ parsing/parsetree.cmi \ - parsing/parse.cmx \ typing/outcometree.cmi \ - typing/oprint.cmx \ + bytecomp/opcodes.cmx \ utils/misc.cmx \ bytecomp/meta.cmx \ - parsing/longident.cmx \ parsing/location.cmx \ utils/load_path.cmx \ - parsing/lexer.cmx \ typing/includemod.cmx \ typing/ident.cmx \ toplevel/genprintval.cmx \ @@ -6280,38 +6353,46 @@ toplevel/byte/toploop.cmx : \ bytecomp/dll.cmx \ utils/config.cmx \ driver/compmisc.cmx \ - driver/compenv.cmx \ + file_formats/cmo_format.cmi \ utils/clflags.cmx \ bytecomp/bytegen.cmx \ - typing/btype.cmx \ parsing/asttypes.cmi \ - parsing/ast_helper.cmx \ - toplevel/byte/toploop.cmi -toplevel/byte/toploop.cmi : \ - utils/warnings.cmi \ - typing/types.cmi \ + toplevel/byte/topeval.cmi +toplevel/byte/topeval.cmi : \ + toplevel/topcommon.cmi \ typing/path.cmi \ parsing/parsetree.cmi \ - typing/outcometree.cmi \ - parsing/longident.cmi \ - parsing/location.cmi \ typing/env.cmi toplevel/byte/topmain.cmo : \ - toplevel/byte/toploop.cmi \ - toplevel/byte/topdirs.cmi \ + toplevel/byte/trace.cmi \ + toplevel/toploop.cmi \ + toplevel/byte/topeval.cmi \ + toplevel/topdirs.cmi \ + toplevel/topcommon.cmi \ + typing/printtyp.cmi \ + typing/path.cmi \ utils/misc.cmi \ driver/main_args.cmi \ parsing/location.cmi \ + typing/env.cmi \ + typing/ctype.cmi \ driver/compmisc.cmi \ driver/compenv.cmi \ utils/clflags.cmi \ toplevel/byte/topmain.cmi toplevel/byte/topmain.cmx : \ - toplevel/byte/toploop.cmx \ - toplevel/byte/topdirs.cmx \ + toplevel/byte/trace.cmx \ + toplevel/toploop.cmx \ + toplevel/byte/topeval.cmx \ + toplevel/topdirs.cmx \ + toplevel/topcommon.cmx \ + typing/printtyp.cmx \ + typing/path.cmx \ utils/misc.cmx \ driver/main_args.cmx \ parsing/location.cmx \ + typing/env.cmx \ + typing/ctype.cmx \ driver/compmisc.cmx \ driver/compenv.cmx \ utils/clflags.cmx \ @@ -6319,7 +6400,8 @@ toplevel/byte/topmain.cmx : \ toplevel/byte/topmain.cmi : toplevel/byte/trace.cmo : \ typing/types.cmi \ - toplevel/byte/toploop.cmi \ + toplevel/byte/topeval.cmi \ + toplevel/topcommon.cmi \ typing/printtyp.cmi \ typing/predef.cmi \ typing/path.cmi \ @@ -6331,7 +6413,8 @@ toplevel/byte/trace.cmo : \ toplevel/byte/trace.cmi toplevel/byte/trace.cmx : \ typing/types.cmx \ - toplevel/byte/toploop.cmx \ + toplevel/byte/topeval.cmx \ + toplevel/topcommon.cmx \ typing/printtyp.cmx \ typing/predef.cmx \ typing/path.cmx \ @@ -6346,66 +6429,26 @@ toplevel/byte/trace.cmi : \ typing/path.cmi \ parsing/longident.cmi \ typing/env.cmi -toplevel/native/topdirs.cmo : \ - utils/warnings.cmi \ - typing/types.cmi \ - toplevel/native/toploop.cmi \ - typing/printtyp.cmi \ - utils/misc.cmi \ - parsing/longident.cmi \ - utils/load_path.cmi \ - typing/ident.cmi \ - typing/env.cmi \ - typing/ctype.cmi \ - utils/config.cmi \ - driver/compenv.cmi \ - utils/clflags.cmi \ - asmcomp/asmlink.cmi \ - toplevel/native/topdirs.cmi -toplevel/native/topdirs.cmx : \ - utils/warnings.cmx \ - typing/types.cmx \ - toplevel/native/toploop.cmx \ - typing/printtyp.cmx \ - utils/misc.cmx \ - parsing/longident.cmx \ - utils/load_path.cmx \ - typing/ident.cmx \ - typing/env.cmx \ - typing/ctype.cmx \ - utils/config.cmx \ - driver/compenv.cmx \ - utils/clflags.cmx \ - asmcomp/asmlink.cmx \ - toplevel/native/topdirs.cmi -toplevel/native/topdirs.cmi : \ - parsing/longident.cmi -toplevel/native/toploop.cmo : \ +toplevel/native/topeval.cmo : \ utils/warnings.cmi \ typing/types.cmi \ typing/typemod.cmi \ typing/typedtree.cmi \ typing/typecore.cmi \ lambda/translmod.cmi \ + toplevel/topcommon.cmi \ lambda/simplif.cmi \ asmcomp/proc.cmi \ typing/printtyped.cmi \ typing/printtyp.cmi \ lambda/printlambda.cmi \ - parsing/printast.cmi \ typing/predef.cmi \ - parsing/pprintast.cmi \ - driver/pparse.cmi \ typing/path.cmi \ parsing/parsetree.cmi \ - parsing/parse.cmi \ typing/outcometree.cmi \ - typing/oprint.cmi \ utils/misc.cmi \ - parsing/longident.cmi \ parsing/location.cmi \ utils/load_path.cmi \ - parsing/lexer.cmi \ lambda/lambda.cmi \ typing/includemod.cmi \ middle_end/flambda/import_approx.cmi \ @@ -6416,43 +6459,35 @@ toplevel/native/toploop.cmo : \ utils/config.cmi \ driver/compmisc.cmi \ middle_end/compilenv.cmi \ - driver/compenv.cmi \ middle_end/closure/closure_middle_end.cmi \ utils/clflags.cmi \ - typing/btype.cmi \ middle_end/backend_intf.cmi \ parsing/asttypes.cmi \ parsing/ast_helper.cmi \ asmcomp/asmlink.cmi \ asmcomp/asmgen.cmi \ asmcomp/arch.cmo \ - toplevel/native/toploop.cmi -toplevel/native/toploop.cmx : \ + toplevel/native/topeval.cmi +toplevel/native/topeval.cmx : \ utils/warnings.cmx \ typing/types.cmx \ typing/typemod.cmx \ typing/typedtree.cmx \ typing/typecore.cmx \ lambda/translmod.cmx \ + toplevel/topcommon.cmx \ lambda/simplif.cmx \ asmcomp/proc.cmx \ typing/printtyped.cmx \ typing/printtyp.cmx \ lambda/printlambda.cmx \ - parsing/printast.cmx \ typing/predef.cmx \ - parsing/pprintast.cmx \ - driver/pparse.cmx \ typing/path.cmx \ parsing/parsetree.cmi \ - parsing/parse.cmx \ typing/outcometree.cmi \ - typing/oprint.cmx \ utils/misc.cmx \ - parsing/longident.cmx \ parsing/location.cmx \ utils/load_path.cmx \ - parsing/lexer.cmx \ lambda/lambda.cmx \ typing/includemod.cmx \ middle_end/flambda/import_approx.cmx \ @@ -6463,29 +6498,24 @@ toplevel/native/toploop.cmx : \ utils/config.cmx \ driver/compmisc.cmx \ middle_end/compilenv.cmx \ - driver/compenv.cmx \ middle_end/closure/closure_middle_end.cmx \ utils/clflags.cmx \ - typing/btype.cmx \ middle_end/backend_intf.cmi \ parsing/asttypes.cmi \ parsing/ast_helper.cmx \ asmcomp/asmlink.cmx \ asmcomp/asmgen.cmx \ asmcomp/arch.cmx \ - toplevel/native/toploop.cmi -toplevel/native/toploop.cmi : \ - utils/warnings.cmi \ - typing/types.cmi \ + toplevel/native/topeval.cmi +toplevel/native/topeval.cmi : \ + toplevel/topcommon.cmi \ typing/path.cmi \ parsing/parsetree.cmi \ - typing/outcometree.cmi \ - parsing/longident.cmi \ - parsing/location.cmi \ typing/env.cmi toplevel/native/topmain.cmo : \ - toplevel/native/toploop.cmi \ - toplevel/native/topdirs.cmi \ + toplevel/toploop.cmi \ + toplevel/native/topeval.cmi \ + toplevel/topcommon.cmi \ utils/misc.cmi \ driver/main_args.cmi \ parsing/location.cmi \ @@ -6494,8 +6524,9 @@ toplevel/native/topmain.cmo : \ utils/clflags.cmi \ toplevel/native/topmain.cmi toplevel/native/topmain.cmx : \ - toplevel/native/toploop.cmx \ - toplevel/native/topdirs.cmx \ + toplevel/toploop.cmx \ + toplevel/native/topeval.cmx \ + toplevel/topcommon.cmx \ utils/misc.cmx \ driver/main_args.cmx \ parsing/location.cmx \ diff --git a/.gitignore b/.gitignore index d88ffd6767..89b6ba95bd 100644 --- a/.gitignore +++ b/.gitignore @@ -263,13 +263,11 @@ _build /tools/caml-tex /tools/eventlog_metadata -/toplevel/byte/toploop.mli +/toplevel/byte/topeval.mli /toplevel/byte/trace.mli -/toplevel/byte/topdirs.mli /toplevel/byte/topmain.mli -/toplevel/native/toploop.mli +/toplevel/native/topeval.mli /toplevel/native/trace.mli -/toplevel/native/topdirs.mli /toplevel/native/topmain.mli /utils/config.ml @@ -101,6 +101,10 @@ Working version `Opttoploop`, `Opttopstart`, which are replaced by `Toploop` and `Topstart` in library `ocamltoplevel`, made available in native code. +- #10124: remove duplicated code from the native toplevel, split toplevel + implementation into the shared part (`Topcommon`, etc.) and specific ones + (`Topeval`, `Trace`, `Topmain`). + * #10086: add the commands `make list-parse-errors` and `make generate-parse-errors` to generate a set of syntactically incorrect sentences that covers all error states of the LR automaton. Add these @@ -67,6 +67,8 @@ OPTSTART=driver/optmain.cmo TOPLEVELSTART=toplevel/topstart.cmo +TOPLEVELINIT=toplevel/toploop.cmo + PERVASIVES=$(STDLIB_MODULES) outcometree topdirs toploop LIBFILES=stdlib.cma std_exit.cmo *.cmi camlheader @@ -400,8 +402,8 @@ endif "$(INSTALL_LIBDIR)" ifeq "$(INSTALL_SOURCE_ARTIFACTS)" "true" $(INSTALL_DATA) \ - toplevel/byte/topdirs.cmt \ - toplevel/topdirs.cmti toplevel/byte/topdirs.mli \ + toplevel/topdirs.cmt \ + toplevel/topdirs.cmti toplevel/topdirs.mli \ "$(INSTALL_LIBDIR)" endif $(MAKE) -C tools install @@ -544,7 +546,9 @@ installoptopt: if test -f ocamlnat$(EXE) ; then \ $(INSTALL_PROG) ocamlnat$(EXE) "$(INSTALL_BINDIR)"; \ $(INSTALL_DATA) \ - $(TOPLEVELSTART:.cmo=.cmx) $(TOPLEVELSTART:.cmo=.$(O)) \ + toplevel/*.cmx \ + toplevel/native/*.cmx \ + $(TOPLEVELSTART:.cmo=.$(O)) \ "$(INSTALL_COMPLIBDIR)"; \ fi cd "$(INSTALL_COMPLIBDIR)" && \ @@ -1015,6 +1019,14 @@ ocamlnat$(EXE): compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ $(TOPLEVELSTART:.cmo=.cmx) $(CAMLOPT_CMD) $(LINKFLAGS) -linkall -I toplevel/native -o $@ $^ + +toplevel/topdirs.cmx: toplevel/topdirs.ml + $(CAMLOPT_CMD) $(COMPFLAGS) $(OPTCOMPFLAGS) -I toplevel/native -c $< + +$(TOPLEVELINIT:.cmo=.cmx): $(TOPLEVELINIT:.cmo=.ml) \ + toplevel/native/topeval.cmx + $(CAMLOPT_CMD) $(COMPFLAGS) $(OPTCOMPFLAGS) -I toplevel/native -c $< + $(TOPLEVELSTART:.cmo=.cmx): $(TOPLEVELSTART:.cmo=.ml) \ toplevel/native/topmain.cmx $(CAMLOPT_CMD) $(COMPFLAGS) $(OPTCOMPFLAGS) -I toplevel/native -c $< @@ -1022,7 +1034,7 @@ $(TOPLEVELSTART:.cmo=.cmx): $(TOPLEVELSTART:.cmo=.ml) \ partialclean:: rm -f ocamlnat ocamlnat.exe -toplevel/native/toploop.cmx: otherlibs/dynlink/dynlink.cmxa +toplevel/native/topeval.cmx: otherlibs/dynlink/dynlink.cmxa # The numeric opcodes diff --git a/compilerlibs/Makefile.compilerlibs b/compilerlibs/Makefile.compilerlibs index 9389e27396..f632d1cd76 100644 --- a/compilerlibs/Makefile.compilerlibs +++ b/compilerlibs/Makefile.compilerlibs @@ -261,17 +261,21 @@ MIDDLE_END_CMI=\ OPTCOMP=$(MIDDLE_END) $(ASMCOMP) OPTCOMP_CMI=$(MIDDLE_END_CMI) $(ASMCOMP_CMI) -TOPLEVEL=toplevel/genprintval.cmo toplevel/byte/toploop.cmo \ - toplevel/byte/trace.cmo toplevel/byte/topdirs.cmo toplevel/byte/topmain.cmo -TOPLEVEL_CMI=toplevel/byte/toploop.cmi toplevel/byte/trace.cmi \ - toplevel/byte/topdirs.cmi toplevel/byte/topmain.cmi - -OPTTOPLEVEL=toplevel/genprintval.cmo toplevel/native/toploop.cmo \ - toplevel/native/topdirs.cmo toplevel/native/topmain.cmo -OPTTOPLEVEL_CMI=toplevel/native/toploop.cmi toplevel/native/topdirs.cmi \ +TOPLEVEL=toplevel/genprintval.cmo toplevel/topcommon.cmo \ + toplevel/byte/topeval.cmo toplevel/byte/trace.cmo toplevel/toploop.cmo \ + toplevel/topdirs.cmo toplevel/byte/topmain.cmo +TOPLEVEL_CMI=toplevel/topcommon.cmi toplevel/byte/topeval.cmi \ + toplevel/byte/trace.cmi toplevel/toploop.cmi toplevel/topdirs.cmi \ + toplevel/byte/topmain.cmi + +OPTTOPLEVEL=toplevel/genprintval.cmo toplevel/topcommon.cmo \ + toplevel/native/topeval.cmo toplevel/native/trace.cmo toplevel/toploop.cmo \ + toplevel/topdirs.cmo toplevel/native/topmain.cmo +OPTTOPLEVEL_CMI=toplevel/topcommon.cmi toplevel/native/topeval.cmi \ + toplevel/native/trace.cmi toplevel/toploop.cmi toplevel/topdirs.cmi \ toplevel/native/topmain.cmi -TOPLEVEL_SHARED_MLIS = toploop.mli trace.mli topdirs.mli topmain.mli +TOPLEVEL_SHARED_MLIS = topeval.mli trace.mli topmain.mli toplevel/byte/%.mli toplevel/byte/%.cmi: toplevel/%.mli toplevel/%.cmi cp toplevel/$*.mli toplevel/$*.cmi $(@D) diff --git a/testsuite/tests/tool-toplevel/pr6468.compilers.reference b/testsuite/tests/tool-toplevel/pr6468.compilers.reference index 90aa2e6bb6..bcb98ee2d4 100644 --- a/testsuite/tests/tool-toplevel/pr6468.compilers.reference +++ b/testsuite/tests/tool-toplevel/pr6468.compilers.reference @@ -10,5 +10,5 @@ Raised at f in file "//toplevel//", line 2, characters 11-26 Called from g in file "//toplevel//", line 1, characters 11-15 Called from Stdlib__fun.protect in file "fun.ml", line 33, characters 8-15 Re-raised at Stdlib__fun.protect in file "fun.ml", line 38, characters 6-52 -Called from Toploop.load_lambda in file "toplevel/byte/toploop.ml", line 212, characters 4-150 +Called from Topeval.load_lambda in file "toplevel/byte/topeval.ml", line 112, characters 4-150 diff --git a/tools/.depend b/tools/.depend index 7fd73c053c..2158c038f3 100644 --- a/tools/.depend +++ b/tools/.depend @@ -12,7 +12,7 @@ caml_tex.cmo : \ ../parsing/ast_iterator.cmi \ ../parsing/ast_helper.cmi caml_tex.cmx : \ - ../toplevel/toploop.cmi \ + ../toplevel/toploop.cmx \ ../parsing/syntaxerr.cmx \ ../parsing/parsetree.cmi \ ../parsing/parse.cmx \ diff --git a/toplevel/byte/topeval.ml b/toplevel/byte/topeval.ml new file mode 100644 index 0000000000..eac9d2c4ad --- /dev/null +++ b/toplevel/byte/topeval.ml @@ -0,0 +1,356 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* The interactive toplevel loop *) + +open Format +open Misc +open Parsetree +open Types +open Typedtree +open Outcometree +open Topcommon +module String = Misc.Stdlib.String + +(* The table of toplevel value bindings and its accessors *) + +let toplevel_value_bindings : Obj.t String.Map.t ref = ref String.Map.empty + +let getvalue name = + try + String.Map.find name !toplevel_value_bindings + with Not_found -> + fatal_error (name ^ " unbound at toplevel") + +let setvalue name v = + toplevel_value_bindings := String.Map.add name v !toplevel_value_bindings + +(* Return the value referred to by a path *) + +let rec eval_address = function + | Env.Aident id -> + if Ident.persistent id || Ident.global id then + Symtable.get_global_value id + else begin + let name = Translmod.toplevel_name id in + try + String.Map.find name !toplevel_value_bindings + with Not_found -> + raise (Symtable.Error(Symtable.Undefined_global name)) + end + | Env.Adot(p, pos) -> + Obj.field (eval_address p) pos + +let eval_path find env path = + match find path env with + | addr -> eval_address addr + | exception Not_found -> + fatal_error ("Cannot find address for: " ^ (Path.name path)) + +let eval_module_path env path = + eval_path Env.find_module_address env path + +let eval_value_path env path = + eval_path Env.find_value_address env path + +let eval_extension_path env path = + eval_path Env.find_constructor_address env path + +let eval_class_path env path = + eval_path Env.find_class_address env path + +(* To print values *) + +module EvalPath = struct + type valu = Obj.t + exception Error + let eval_address addr = + try eval_address addr with Symtable.Error _ -> raise Error + let same_value v1 v2 = (v1 == v2) +end + +include Topcommon.MakePrinter(Obj)(Genprintval.Make(Obj)(EvalPath)) + + +(* Load in-core and execute a lambda term *) + +let may_trace = ref false (* Global lock on tracing *) + +let load_lambda ppf lam = + if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam; + let slam = Simplif.simplify_lambda lam in + if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam; + let (init_code, fun_code) = Bytegen.compile_phrase slam in + if !Clflags.dump_instr then + fprintf ppf "%a%a@." + Printinstr.instrlist init_code + Printinstr.instrlist fun_code; + let (code, reloc, events) = + Emitcode.to_memory init_code fun_code + in + let can_free = (fun_code = []) in + let initial_symtable = Symtable.current_state() in + Symtable.patch_object code reloc; + Symtable.check_global_initialized reloc; + Symtable.update_global_table(); + let initial_bindings = !toplevel_value_bindings in + let bytecode, closure = Meta.reify_bytecode code [| events |] None in + match + may_trace := true; + Fun.protect + ~finally:(fun () -> may_trace := false; + if can_free then Meta.release_bytecode bytecode) + closure + with + | retval -> Result retval + | exception x -> + record_backtrace (); + toplevel_value_bindings := initial_bindings; (* PR#6211 *) + Symtable.restore_state initial_symtable; + Exception x + +(* Print the outcome of an evaluation *) + +let pr_item = + Printtyp.print_items + (fun env -> function + | Sig_value(id, {val_kind = Val_reg; val_type}, _) -> + Some (outval_of_value env (getvalue (Translmod.toplevel_name id)) + val_type) + | _ -> None + ) + +(* Execute a toplevel phrase *) + +let execute_phrase print_outcome ppf phr = + match phr with + | Ptop_def sstr -> + let oldenv = !toplevel_env in + Typecore.reset_delayed_checks (); + let (str, sg, sn, newenv) = Typemod.type_toplevel_phrase oldenv sstr in + if !Clflags.dump_typedtree then Printtyped.implementation ppf str; + let sg' = Typemod.Signature_names.simplify newenv sn sg in + ignore (Includemod.signatures ~mark:Mark_positive oldenv sg sg'); + Typecore.force_delayed_checks (); + let lam = Translmod.transl_toplevel_definition str in + Warnings.check_fatal (); + begin try + toplevel_env := newenv; + let res = load_lambda ppf lam in + let out_phr = + match res with + | Result v -> + if print_outcome then + Printtyp.wrap_printing_env ~error:false oldenv (fun () -> + match str.str_items with + | [ { str_desc = + (Tstr_eval (exp, _) + |Tstr_value + (Asttypes.Nonrecursive, + [{vb_pat = {pat_desc=Tpat_any}; + vb_expr = exp} + ] + ) + ) + } + ] -> + let outv = outval_of_value newenv v exp.exp_type in + let ty = Printtyp.tree_of_type_scheme exp.exp_type in + Ophr_eval (outv, ty) + + | [] -> Ophr_signature [] + | _ -> Ophr_signature (pr_item oldenv sg')) + else Ophr_signature [] + | Exception exn -> + toplevel_env := oldenv; + if exn = Out_of_memory then Gc.full_major(); + let outv = + outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn + in + Ophr_exception (exn, outv) + in + !print_out_phrase ppf out_phr; + if Printexc.backtrace_status () + then begin + match !backtrace with + | None -> () + | Some b -> + pp_print_string ppf b; + pp_print_flush ppf (); + backtrace := None; + end; + begin match out_phr with + | Ophr_eval (_, _) | Ophr_signature _ -> true + | Ophr_exception _ -> false + end + with x -> + toplevel_env := oldenv; raise x + end + | Ptop_dir {pdir_name = {Location.txt = dir_name}; pdir_arg } -> + begin match Topcommon.get_directive dir_name with + | None -> + fprintf ppf "Unknown directive `%s'." dir_name; + let directives = Topcommon.all_directive_names () in + Misc.did_you_mean ppf + (fun () -> Misc.spellcheck directives dir_name); + fprintf ppf "@."; + false + | Some d -> + match d, pdir_arg with + | Directive_none f, None -> f (); true + | Directive_string f, Some {pdira_desc = Pdir_string s} -> f s; true + | Directive_int f, Some {pdira_desc = Pdir_int (n,None) } -> + begin match Int_literal_converter.int n with + | n -> f n; true + | exception _ -> + fprintf ppf "Integer literal exceeds the range of \ + representable integers for directive `%s'.@." + dir_name; + false + end + | Directive_int _, Some {pdira_desc = Pdir_int (_, Some _)} -> + fprintf ppf "Wrong integer literal for directive `%s'.@." + dir_name; + false + | Directive_ident f, Some {pdira_desc = Pdir_ident lid} -> f lid; true + | Directive_bool f, Some {pdira_desc = Pdir_bool b} -> f b; true + | _ -> + fprintf ppf "Wrong type of argument for directive `%s'.@." + dir_name; + false + end + +let execute_phrase print_outcome ppf phr = + try execute_phrase print_outcome ppf phr + with exn -> + Warnings.reset_fatal (); + raise exn + + +(* Additional directives for the bytecode toplevel only *) + +open Cmo_format + +(* Loading files *) + +exception Load_failed + +let check_consistency ppf filename cu = + try Env.import_crcs ~source:filename cu.cu_imports + with Persistent_env.Consistbl.Inconsistency { + unit_name = name; + inconsistent_source = user; + original_source = auth; + } -> + fprintf ppf "@[<hv 0>The files %s@ and %s@ \ + disagree over interface %s@]@." + user auth name; + raise Load_failed + +(* This is basically Dynlink.Bytecode.run with no digest *) +let load_compunit ic filename ppf compunit = + check_consistency ppf filename compunit; + seek_in ic compunit.cu_pos; + let code_size = compunit.cu_codesize + 8 in + let code = LongString.create code_size in + LongString.input_bytes_into code ic compunit.cu_codesize; + LongString.set code compunit.cu_codesize (Char.chr Opcodes.opRETURN); + LongString.blit_string "\000\000\000\001\000\000\000" 0 + code (compunit.cu_codesize + 1) 7; + let initial_symtable = Symtable.current_state() in + Symtable.patch_object code compunit.cu_reloc; + Symtable.update_global_table(); + let events = + if compunit.cu_debug = 0 then [| |] + else begin + seek_in ic compunit.cu_debug; + [| input_value ic |] + end in + begin try + may_trace := true; + let _bytecode, closure = Meta.reify_bytecode code events None in + ignore (closure ()); + may_trace := false; + with exn -> + record_backtrace (); + may_trace := false; + Symtable.restore_state initial_symtable; + print_exception_outcome ppf exn; + raise Load_failed + end + +let rec load_file recursive ppf name = + let filename = + try Some (Load_path.find name) with Not_found -> None + in + match filename with + | None -> fprintf ppf "Cannot find file %s.@." name; false + | Some filename -> + let ic = open_in_bin filename in + Misc.try_finally + ~always:(fun () -> close_in ic) + (fun () -> really_load_file recursive ppf name filename ic) + +and really_load_file recursive ppf name filename ic = + let buffer = really_input_string ic (String.length Config.cmo_magic_number) in + try + if buffer = Config.cmo_magic_number then begin + let compunit_pos = input_binary_int ic in (* Go to descriptor *) + seek_in ic compunit_pos; + let cu : compilation_unit = input_value ic in + if recursive then + List.iter + (function + | (Reloc_getglobal id, _) + when not (Symtable.is_global_defined id) -> + let file = Ident.name id ^ ".cmo" in + begin match Load_path.find_uncap file with + | exception Not_found -> () + | file -> + if not (load_file recursive ppf file) then raise Load_failed + end + | _ -> () + ) + cu.cu_reloc; + load_compunit ic filename ppf cu; + true + end else + if buffer = Config.cma_magic_number then begin + let toc_pos = input_binary_int ic in (* Go to table of contents *) + seek_in ic toc_pos; + let lib = (input_value ic : library) in + List.iter + (fun dllib -> + let name = Dll.extract_dll_name dllib in + try Dll.open_dlls Dll.For_execution [name] + with Failure reason -> + fprintf ppf + "Cannot load required shared library %s.@.Reason: %s.@." + name reason; + raise Load_failed) + lib.lib_dllibs; + List.iter (load_compunit ic filename ppf) lib.lib_units; + true + end else begin + fprintf ppf "File %s is not a bytecode object file.@." name; + false + end + with Load_failed -> false + +let init () = + let crc_intfs = Symtable.init_toplevel() in + Compmisc.init_path (); + Env.import_crcs ~source:Sys.executable_name crc_intfs; + () diff --git a/toplevel/byte/toploop.ml b/toplevel/byte/toploop.ml deleted file mode 100644 index 6f0c12b556..0000000000 --- a/toplevel/byte/toploop.ml +++ /dev/null @@ -1,649 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* The interactive toplevel loop *) - -open Format -open Misc -open Parsetree -open Types -open Typedtree -open Outcometree -open Ast_helper -module String = Misc.Stdlib.String - -type directive_fun = - | Directive_none of (unit -> unit) - | Directive_string of (string -> unit) - | Directive_int of (int -> unit) - | Directive_ident of (Longident.t -> unit) - | Directive_bool of (bool -> unit) - -type directive_info = { - section: string; - doc: string; -} - -(* Phase buffer that stores the last toplevel phrase (see - [Location.input_phrase_buffer]). *) -let phrase_buffer = Buffer.create 1024 - -(* The table of toplevel value bindings and its accessors *) - -let toplevel_value_bindings : Obj.t String.Map.t ref = ref String.Map.empty - -let getvalue name = - try - String.Map.find name !toplevel_value_bindings - with Not_found -> - fatal_error (name ^ " unbound at toplevel") - -let setvalue name v = - toplevel_value_bindings := String.Map.add name v !toplevel_value_bindings - -(* Return the value referred to by a path *) - -let rec eval_address = function - | Env.Aident id -> - if Ident.persistent id || Ident.global id then - Symtable.get_global_value id - else begin - let name = Translmod.toplevel_name id in - try - String.Map.find name !toplevel_value_bindings - with Not_found -> - raise (Symtable.Error(Symtable.Undefined_global name)) - end - | Env.Adot(p, pos) -> - Obj.field (eval_address p) pos - -let eval_path find env path = - match find path env with - | addr -> eval_address addr - | exception Not_found -> - fatal_error ("Cannot find address for: " ^ (Path.name path)) - -let eval_module_path env path = - eval_path Env.find_module_address env path - -let eval_value_path env path = - eval_path Env.find_value_address env path - -let eval_extension_path env path = - eval_path Env.find_constructor_address env path - -let eval_class_path env path = - eval_path Env.find_class_address env path - -(* To print values *) - -module EvalPath = struct - type valu = Obj.t - exception Error - let eval_address addr = - try eval_address addr with Symtable.Error _ -> raise Error - let same_value v1 v2 = (v1 == v2) -end - -module Printer = Genprintval.Make(Obj)(EvalPath) - -let max_printer_depth = ref 100 -let max_printer_steps = ref 300 - -let print_out_value = Oprint.out_value -let print_out_type = Oprint.out_type -let print_out_class_type = Oprint.out_class_type -let print_out_module_type = Oprint.out_module_type -let print_out_type_extension = Oprint.out_type_extension -let print_out_sig_item = Oprint.out_sig_item -let print_out_signature = Oprint.out_signature -let print_out_phrase = Oprint.out_phrase - -let print_untyped_exception ppf obj = - !print_out_value ppf (Printer.outval_of_untyped_exception obj) -let outval_of_value env obj ty = - Printer.outval_of_value !max_printer_steps !max_printer_depth - (fun _ _ _ -> None) env obj ty -let print_value env obj ppf ty = - !print_out_value ppf (outval_of_value env obj ty) - -type ('a, 'b) gen_printer = ('a, 'b) Genprintval.gen_printer = - | Zero of 'b - | Succ of ('a -> ('a, 'b) gen_printer) - -let install_printer = Printer.install_printer -let install_generic_printer = Printer.install_generic_printer -let install_generic_printer' = Printer.install_generic_printer' -let remove_printer = Printer.remove_printer - -(* Hooks for parsing functions *) - -let parse_toplevel_phrase = ref Parse.toplevel_phrase -let parse_use_file = ref Parse.use_file -let print_location = Location.print_loc -let print_error = Location.print_report -let print_warning = Location.print_warning -let input_name = Location.input_name - -let parse_mod_use_file name lb = - let modname = - String.capitalize_ascii - (Filename.remove_extension (Filename.basename name)) - in - let items = - List.concat - (List.map - (function Ptop_def s -> s | Ptop_dir _ -> []) - (!parse_use_file lb)) - in - [ Ptop_def - [ Str.module_ - (Mb.mk - (Location.mknoloc (Some modname)) - (Mod.structure items) - ) - ] - ] - -(* Hook for initialization *) - -let toplevel_startup_hook = ref (fun () -> ()) - -type event = .. -type event += - | Startup - | After_setup - -let hooks = ref [] - -let add_hook f = hooks := f :: !hooks - -let () = - add_hook (function - | Startup -> !toplevel_startup_hook () - | _ -> ()) - -let run_hooks hook = List.iter (fun f -> f hook) !hooks - -(* Load in-core and execute a lambda term *) - -let may_trace = ref false (* Global lock on tracing *) -type evaluation_outcome = Result of Obj.t | Exception of exn - -let backtrace = ref None - -let record_backtrace () = - if Printexc.backtrace_status () - then backtrace := Some (Printexc.get_backtrace ()) - -let load_lambda ppf lam = - if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam; - let slam = Simplif.simplify_lambda lam in - if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam; - let (init_code, fun_code) = Bytegen.compile_phrase slam in - if !Clflags.dump_instr then - fprintf ppf "%a%a@." - Printinstr.instrlist init_code - Printinstr.instrlist fun_code; - let (code, reloc, events) = - Emitcode.to_memory init_code fun_code - in - let can_free = (fun_code = []) in - let initial_symtable = Symtable.current_state() in - Symtable.patch_object code reloc; - Symtable.check_global_initialized reloc; - Symtable.update_global_table(); - let initial_bindings = !toplevel_value_bindings in - let bytecode, closure = Meta.reify_bytecode code [| events |] None in - match - may_trace := true; - Fun.protect - ~finally:(fun () -> may_trace := false; - if can_free then Meta.release_bytecode bytecode) - closure - with - | retval -> Result retval - | exception x -> - record_backtrace (); - toplevel_value_bindings := initial_bindings; (* PR#6211 *) - Symtable.restore_state initial_symtable; - Exception x - -(* Print the outcome of an evaluation *) - -let pr_item = - Printtyp.print_items - (fun env -> function - | Sig_value(id, {val_kind = Val_reg; val_type}, _) -> - Some (outval_of_value env (getvalue (Translmod.toplevel_name id)) - val_type) - | _ -> None - ) - -(* The current typing environment for the toplevel *) - -let toplevel_env = ref Env.empty - -(* Print an exception produced by an evaluation *) - -let print_out_exception ppf exn outv = - !print_out_phrase ppf (Ophr_exception (exn, outv)) - -let print_exception_outcome ppf exn = - if exn = Out_of_memory then Gc.full_major (); - let outv = outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in - print_out_exception ppf exn outv; - if Printexc.backtrace_status () - then - match !backtrace with - | None -> () - | Some b -> - print_string b; - backtrace := None - - -(* Inserting new toplevel directives *) - -let directive_table = (Hashtbl.create 23 : (string, directive_fun) Hashtbl.t) - -let directive_info_table = - (Hashtbl.create 23 : (string, directive_info) Hashtbl.t) - -let add_directive name dir_fun dir_info = - Hashtbl.add directive_table name dir_fun; - Hashtbl.add directive_info_table name dir_info - -(* Execute a toplevel phrase *) - -let execute_phrase print_outcome ppf phr = - match phr with - | Ptop_def sstr -> - let oldenv = !toplevel_env in - Typecore.reset_delayed_checks (); - let (str, sg, sn, newenv) = Typemod.type_toplevel_phrase oldenv sstr in - if !Clflags.dump_typedtree then Printtyped.implementation ppf str; - let sg' = Typemod.Signature_names.simplify newenv sn sg in - ignore (Includemod.signatures ~mark:Mark_positive oldenv sg sg'); - Typecore.force_delayed_checks (); - let lam = Translmod.transl_toplevel_definition str in - Warnings.check_fatal (); - begin try - toplevel_env := newenv; - let res = load_lambda ppf lam in - let out_phr = - match res with - | Result v -> - if print_outcome then - Printtyp.wrap_printing_env ~error:false oldenv (fun () -> - match str.str_items with - | [ { str_desc = - (Tstr_eval (exp, _) - |Tstr_value - (Asttypes.Nonrecursive, - [{vb_pat = {pat_desc=Tpat_any}; - vb_expr = exp} - ] - ) - ) - } - ] -> - let outv = outval_of_value newenv v exp.exp_type in - let ty = Printtyp.tree_of_type_scheme exp.exp_type in - Ophr_eval (outv, ty) - - | [] -> Ophr_signature [] - | _ -> Ophr_signature (pr_item oldenv sg')) - else Ophr_signature [] - | Exception exn -> - toplevel_env := oldenv; - if exn = Out_of_memory then Gc.full_major(); - let outv = - outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn - in - Ophr_exception (exn, outv) - in - !print_out_phrase ppf out_phr; - if Printexc.backtrace_status () - then begin - match !backtrace with - | None -> () - | Some b -> - pp_print_string ppf b; - pp_print_flush ppf (); - backtrace := None; - end; - begin match out_phr with - | Ophr_eval (_, _) | Ophr_signature _ -> true - | Ophr_exception _ -> false - end - with x -> - toplevel_env := oldenv; raise x - end - | Ptop_dir {pdir_name = {Location.txt = dir_name}; pdir_arg } -> - let d = - try Some (Hashtbl.find directive_table dir_name) - with Not_found -> None - in - begin match d with - | None -> - fprintf ppf "Unknown directive `%s'." dir_name; - let directives = - Hashtbl.fold (fun dir _ acc -> dir::acc) directive_table [] in - Misc.did_you_mean ppf - (fun () -> Misc.spellcheck directives dir_name); - fprintf ppf "@."; - false - | Some d -> - match d, pdir_arg with - | Directive_none f, None -> f (); true - | Directive_string f, Some {pdira_desc = Pdir_string s} -> f s; true - | Directive_int f, Some {pdira_desc = Pdir_int (n,None) } -> - begin match Int_literal_converter.int n with - | n -> f n; true - | exception _ -> - fprintf ppf "Integer literal exceeds the range of \ - representable integers for directive `%s'.@." - dir_name; - false - end - | Directive_int _, Some {pdira_desc = Pdir_int (_, Some _)} -> - fprintf ppf "Wrong integer literal for directive `%s'.@." - dir_name; - false - | Directive_ident f, Some {pdira_desc = Pdir_ident lid} -> f lid; true - | Directive_bool f, Some {pdira_desc = Pdir_bool b} -> f b; true - | _ -> - fprintf ppf "Wrong type of argument for directive `%s'.@." - dir_name; - false - end - -let execute_phrase print_outcome ppf phr = - try execute_phrase print_outcome ppf phr - with exn -> - Warnings.reset_fatal (); - raise exn - -(* Read and execute commands from a file, or from stdin if [name] is "". *) - -let use_print_results = ref true - -let preprocess_phrase ppf phr = - let phr = - match phr with - | Ptop_def str -> - let str = - Pparse.apply_rewriters_str ~restore:true ~tool_name:"ocaml" str - in - Ptop_def str - | phr -> phr - in - if !Clflags.dump_parsetree then Printast.top_phrase ppf phr; - if !Clflags.dump_source then Pprintast.top_phrase ppf phr; - phr - -let use_channel ppf ~wrap_in_module ic name filename = - let lb = Lexing.from_channel ic in - Warnings.reset_fatal (); - Location.init lb filename; - (* Skip initial #! line if any *) - Lexer.skip_hash_bang lb; - protect_refs [ R (Location.input_name, filename); - R (Location.input_lexbuf, Some lb); ] - (fun () -> - try - List.iter - (fun ph -> - let ph = preprocess_phrase ppf ph in - if not (execute_phrase !use_print_results ppf ph) then raise Exit) - (if wrap_in_module then - parse_mod_use_file name lb - else - !parse_use_file lb); - true - with - | Exit -> false - | Sys.Break -> fprintf ppf "Interrupted.@."; false - | x -> Location.report_exception ppf x; false) - -let use_output ppf command = - let fn = Filename.temp_file "ocaml" "_toploop.ml" in - Misc.try_finally ~always:(fun () -> - try Sys.remove fn with Sys_error _ -> ()) - (fun () -> - match - Printf.ksprintf Sys.command "%s > %s" - command - (Filename.quote fn) - with - | 0 -> - let ic = open_in_bin fn in - Misc.try_finally ~always:(fun () -> close_in ic) - (fun () -> - use_channel ppf ~wrap_in_module:false ic "" "(command-output)") - | n -> - fprintf ppf "Command exited with code %d.@." n; - false) - -let use_file ppf ~wrap_in_module name = - match name with - | "" -> - use_channel ppf ~wrap_in_module stdin name "(stdin)" - | _ -> - match Load_path.find name with - | filename -> - let ic = open_in_bin filename in - Misc.try_finally ~always:(fun () -> close_in ic) - (fun () -> use_channel ppf ~wrap_in_module ic name filename) - | exception Not_found -> - fprintf ppf "Cannot find file %s.@." name; - false - -let mod_use_file ppf name = - use_file ppf ~wrap_in_module:true name -let use_file ppf name = - use_file ppf ~wrap_in_module:false name - -let use_silently ppf name = - protect_refs [ R (use_print_results, false) ] (fun () -> use_file ppf name) - -(* Reading function for interactive use *) - -let first_line = ref true -let got_eof = ref false;; - -let read_input_default prompt buffer len = - output_string stdout prompt; flush stdout; - let i = ref 0 in - try - while true do - if !i >= len then raise Exit; - let c = input_char stdin in - Bytes.set buffer !i c; - (* Also populate the phrase buffer as new characters are added. *) - Buffer.add_char phrase_buffer c; - incr i; - if c = '\n' then raise Exit; - done; - (!i, false) - with - | End_of_file -> - (!i, true) - | Exit -> - (!i, false) - -let read_interactive_input = ref read_input_default - -let refill_lexbuf buffer len = - if !got_eof then (got_eof := false; 0) else begin - let prompt = - if !Clflags.noprompt then "" - else if !first_line then "# " - else if !Clflags.nopromptcont then "" - else if Lexer.in_comment () then "* " - else " " - in - first_line := false; - let (len, eof) = !read_interactive_input prompt buffer len in - if eof then begin - Location.echo_eof (); - if len > 0 then got_eof := true; - len - end else - len - end - -(* Toplevel initialization. Performed here instead of at the - beginning of loop() so that user code linked in with ocamlmktop - can call directives from Topdirs. *) - -let _ = - if !Sys.interactive then (* PR#6108 *) - invalid_arg "The ocamltoplevel.cma library from compiler-libs \ - cannot be loaded inside the OCaml toplevel"; - Sys.interactive := true; - let crc_intfs = Symtable.init_toplevel() in - Compmisc.init_path (); - Env.import_crcs ~source:Sys.executable_name crc_intfs; - () - -let find_ocamlinit () = - let ocamlinit = ".ocamlinit" in - if Sys.file_exists ocamlinit then Some ocamlinit else - let getenv var = match Sys.getenv var with - | exception Not_found -> None | "" -> None | v -> Some v - in - let exists_in_dir dir file = match dir with - | None -> None - | Some dir -> - let file = Filename.concat dir file in - if Sys.file_exists file then Some file else None - in - let home_dir () = getenv "HOME" in - let config_dir () = - if Sys.win32 then None else - match getenv "XDG_CONFIG_HOME" with - | Some _ as v -> v - | None -> - match home_dir () with - | None -> None - | Some dir -> Some (Filename.concat dir ".config") - in - let init_ml = Filename.concat "ocaml" "init.ml" in - match exists_in_dir (config_dir ()) init_ml with - | Some _ as v -> v - | None -> exists_in_dir (home_dir ()) ocamlinit - -let load_ocamlinit ppf = - if !Clflags.noinit then () - else match !Clflags.init_file with - | Some f -> if Sys.file_exists f then ignore (use_silently ppf f) - else fprintf ppf "Init file not found: \"%s\".@." f - | None -> - match find_ocamlinit () with - | None -> () - | Some file -> ignore (use_silently ppf file) -;; - -let set_paths () = - (* Add whatever -I options have been specified on the command line, - but keep the directories that user code linked in with ocamlmktop - may have added to load_path. *) - let expand = Misc.expand_directory Config.standard_library in - let current_load_path = Load_path.get_paths () in - let load_path = List.concat [ - [ "" ]; - List.map expand (List.rev !Compenv.first_include_dirs); - List.map expand (List.rev !Clflags.include_dirs); - List.map expand (List.rev !Compenv.last_include_dirs); - current_load_path; - [expand "+camlp4"]; - ] - in - Load_path.init load_path; - Dll.add_path load_path - -let initialize_toplevel_env () = - toplevel_env := Compmisc.initial_env() - -(* The interactive loop *) - -exception PPerror - -let loop ppf = - Clflags.debug := true; - Location.formatter_for_warnings := ppf; - if not !Clflags.noversion then - fprintf ppf " OCaml version %s@.@." Config.version; - begin - try initialize_toplevel_env () - with Env.Error _ | Typetexp.Error _ as exn -> - Location.report_exception ppf exn; raise (Compenv.Exit_with_status 2) - end; - let lb = Lexing.from_function refill_lexbuf in - Location.init lb "//toplevel//"; - Location.input_name := "//toplevel//"; - Location.input_lexbuf := Some lb; - Location.input_phrase_buffer := Some phrase_buffer; - Sys.catch_break true; - run_hooks After_setup; - load_ocamlinit ppf; - while true do - let snap = Btype.snapshot () in - try - Lexing.flush_input lb; - (* Reset the phrase buffer when we flush the lexing buffer. *) - Buffer.reset phrase_buffer; - Location.reset(); - Warnings.reset_fatal (); - first_line := true; - let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in - let phr = preprocess_phrase ppf phr in - Env.reset_cache_toplevel (); - ignore(execute_phrase true ppf phr) - with - | End_of_file -> raise (Compenv.Exit_with_status 0) - | Sys.Break -> fprintf ppf "Interrupted.@."; Btype.backtrack snap - | PPerror -> () - | x -> Location.report_exception ppf x; Btype.backtrack snap - done - -external caml_sys_modify_argv : string array -> unit = - "caml_sys_modify_argv" - -let override_sys_argv new_argv = - caml_sys_modify_argv new_argv; - Arg.current := 0 - -(* Execute a script. If [name] is "", read the script from stdin. *) - -let run_script ppf name args = - override_sys_argv args; - Compmisc.init_path ~dir:(Filename.dirname name) (); - (* Note: would use [Filename.abspath] here, if we had it. *) - begin - try toplevel_env := Compmisc.initial_env() - with Env.Error _ | Typetexp.Error _ as exn -> - Location.report_exception ppf exn; raise (Compenv.Exit_with_status 2) - end; - Sys.interactive := false; - run_hooks After_setup; - let explicit_name = - (* Prevent use_silently from searching in the path. *) - if name <> "" && Filename.is_implicit name - then Filename.concat Filename.current_dir_name name - else name - in - use_silently ppf explicit_name diff --git a/toplevel/byte/topmain.ml b/toplevel/byte/topmain.ml index a0020b680b..0fdc12136e 100644 --- a/toplevel/byte/topmain.ml +++ b/toplevel/byte/topmain.ml @@ -13,6 +13,112 @@ (* *) (**************************************************************************) + +(* The trace *) + +open Trace + +external current_environment: unit -> Obj.t = "caml_get_current_environment" + +let tracing_function_ptr = + get_code_pointer + (Obj.repr (fun arg -> Trace.print_trace (current_environment()) arg)) + +let dir_trace ppf lid = + match Env.find_value_by_name lid !Topcommon.toplevel_env with + | (path, desc) -> begin + (* Check if this is a primitive *) + match desc.val_kind with + | Val_prim _ -> + Format.fprintf ppf + "%a is an external function and cannot be traced.@." + Printtyp.longident lid + | _ -> + let clos = Toploop.eval_value_path !Topcommon.toplevel_env path in + (* Nothing to do if it's not a closure *) + if Obj.is_block clos + && (Obj.tag clos = Obj.closure_tag || Obj.tag clos = Obj.infix_tag) + && (match + Ctype.(repr (expand_head !Topcommon.toplevel_env desc.val_type)) + with {desc=Tarrow _} -> true | _ -> false) + then begin + match is_traced clos with + | Some opath -> + Format.fprintf ppf "%a is already traced (under the name %a).@." + Printtyp.path path + Printtyp.path opath + | None -> + (* Instrument the old closure *) + traced_functions := + { path = path; + closure = clos; + actual_code = get_code_pointer clos; + instrumented_fun = + instrument_closure + !Topcommon.toplevel_env lid ppf desc.val_type } + :: !traced_functions; + (* Redirect the code field of the closure to point + to the instrumentation function *) + set_code_pointer clos tracing_function_ptr; + Format.fprintf ppf "%a is now traced.@." Printtyp.longident lid + end else + Format.fprintf ppf "%a is not a function.@." Printtyp.longident lid + end + | exception Not_found -> + Format.fprintf ppf "Unbound value %a.@." Printtyp.longident lid + +let dir_untrace ppf lid = + match Env.find_value_by_name lid !Topcommon.toplevel_env with + | (path, _desc) -> + let rec remove = function + | [] -> + Format.fprintf ppf "%a was not traced.@." Printtyp.longident lid; + [] + | f :: rem -> + if Path.same f.path path then begin + set_code_pointer f.closure f.actual_code; + Format.fprintf ppf "%a is no longer traced.@." + Printtyp.longident lid; + rem + end else f :: remove rem in + traced_functions := remove !traced_functions + | exception Not_found -> + Format.fprintf ppf "Unbound value %a.@." Printtyp.longident lid + +let dir_untrace_all ppf () = + List.iter + (fun f -> + set_code_pointer f.closure f.actual_code; + Format.fprintf ppf "%a is no longer traced.@." Printtyp.path f.path) + !traced_functions; + traced_functions := [] + +let _ = Topcommon.add_directive "trace" + (Directive_ident (dir_trace Format.std_formatter)) + { + section = Topdirs.section_trace; + doc = "All calls to the function \ + named function-name will be traced."; + } + +let _ = Topcommon.add_directive "untrace" + (Directive_ident (dir_untrace Format.std_formatter)) + { + section = Topdirs.section_trace; + doc = "Stop tracing the given function."; + } + +let _ = Topcommon.add_directive "untrace_all" + (Directive_none (dir_untrace_all Format.std_formatter)) + { + section = Topdirs.section_trace; + doc = "Stop tracing all functions traced so far."; + } + + +(* --- *) + + let usage = "Usage: ocaml <options> <object-files> [script-file [arguments]]\n\ options are:" @@ -37,15 +143,15 @@ let expand_position pos len = first_nonexpanded_pos := pos + len + 2 let prepare ppf = - Toploop.set_paths (); + Topcommon.set_paths (); try let res = let objects = List.rev (!preload_objects @ !Compenv.first_objfiles) in - List.for_all (Topdirs.load_file ppf) objects + List.for_all (Topeval.load_file false ppf) objects in - Toploop.run_hooks Toploop.Startup; + Topcommon.run_hooks Topcommon.Startup; res with x -> try Location.report_exception ppf x; false @@ -91,7 +197,7 @@ module Options = Main_args.Make_bytetop_options (struct let _args = wrap_expand Arg.read_arg let _args0 = wrap_expand Arg.read_arg0 let anonymous s = file_argument s -end);; +end) let () = let extra_paths = diff --git a/toplevel/byte/trace.ml b/toplevel/byte/trace.ml index 36839909fb..955bc2523c 100644 --- a/toplevel/byte/trace.ml +++ b/toplevel/byte/trace.ml @@ -19,7 +19,8 @@ open Format open Misc open Longident open Types -open Toploop +open Topeval +open Topcommon type codeptr = Obj.raw_data diff --git a/toplevel/dune b/toplevel/dune index 9e7b745067..8c6c6a0381 100644 --- a/toplevel/dune +++ b/toplevel/dune @@ -19,7 +19,7 @@ (wrapped false) (flags (:standard -principal -nostdlib)) (libraries stdlib ocamlcommon ocamlbytecomp) - (modules genprintval toploop trace topdirs topmain)) + (modules genprintval topeval trace topdirs toploop topmain)) (executable (name topstart) @@ -96,5 +96,5 @@ stdlib__Uchar stdlib__Weak ; the rest - outcometree topdirs toploop + outcometree topdirs topeval toploop topmain ))) diff --git a/toplevel/native/topdirs.ml b/toplevel/native/topdirs.ml deleted file mode 100644 index 8c5453f0d7..0000000000 --- a/toplevel/native/topdirs.ml +++ /dev/null @@ -1,224 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Toplevel directives *) - -open Format -open Misc -open Longident -open Types -open Toploop - -(* The standard output formatter *) -let std_out = std_formatter - -(* To quit *) - -let dir_quit () = raise (Compenv.Exit_with_status 0) - -let _ = Hashtbl.add directive_table "quit" (Directive_none dir_quit) - -(* To add a directory to the load path *) - -let dir_directory s = - let d = expand_directory Config.standard_library s in - let dir = Load_path.Dir.create d in - Load_path.add dir; - toplevel_env := - Stdlib.String.Set.fold - (fun name env -> - Env.add_persistent_structure (Ident.create_persistent name) env) - (Env.persistent_structures_of_dir dir) - !toplevel_env - -let _ = Hashtbl.add directive_table "directory" (Directive_string dir_directory) -(* To remove a directory from the load path *) -let dir_remove_directory s = - let d = expand_directory Config.standard_library s in - let keep id = - match Load_path.find_uncap (Ident.name id ^ ".cmi") with - | exception Not_found -> true - | fn -> Filename.dirname fn <> d - in - toplevel_env := Env.filter_non_loaded_persistent keep !toplevel_env; - Load_path.remove_dir s - -let _ = - Hashtbl.add directive_table "remove_directory" - (Directive_string dir_remove_directory) - -let _ = Hashtbl.add directive_table "show_dirs" - (Directive_none - (fun () -> - List.iter print_endline (Load_path.get_paths ()) - )) - -(* To change the current directory *) - -let dir_cd s = Sys.chdir s - -let _ = Hashtbl.add directive_table "cd" (Directive_string dir_cd) - -(* Load in-core a .cmxs file *) - -let load_file ppf name0 = - let name = - try Some (Load_path.find name0) - with Not_found -> None - in - match name with - | None -> fprintf ppf "File not found: %s@." name0; false - | Some name -> - let fn,tmp = - if Filename.check_suffix name ".cmx" || Filename.check_suffix name ".cmxa" - then - let cmxs = Filename.temp_file "caml" ".cmxs" in - Asmlink.link_shared ~ppf_dump:ppf [name] cmxs; - cmxs,true - else - name,false - in - let success = - (* The Dynlink interface does not allow us to distinguish between - a Dynlink.Error exceptions raised in the loaded modules - or a genuine error during dynlink... *) - try Dynlink.loadfile fn; true - with - | Dynlink.Error err -> - fprintf ppf "Error while loading %s: %s.@." - name (Dynlink.error_message err); - false - | exn -> - print_exception_outcome ppf exn; - false - in - if tmp then (try Sys.remove fn with Sys_error _ -> ()); - success - - -let dir_load ppf name = ignore (load_file ppf name) - -let _ = Hashtbl.add directive_table "load" (Directive_string (dir_load std_out)) - -(* Load commands from a file *) - -let dir_use ppf name = ignore(Toploop.use_file ppf name) -let dir_use_output ppf name = ignore(Toploop.use_output ppf name) - -let _ = Hashtbl.add directive_table "use" (Directive_string (dir_use std_out)) -let _ = Hashtbl.add directive_table "use_output" - (Directive_string (dir_use_output std_out)) - -(* Install, remove a printer *) - -type 'a printer_type_new = Format.formatter -> 'a -> unit -type 'a printer_type_old = 'a -> unit - -let match_printer_type ppf desc typename = - let printer_type = - match - Env.find_type_by_name - (Ldot(Lident "Topdirs", typename)) !toplevel_env - with - | (path, _) -> path - | exception Not_found -> - fprintf ppf "Cannot find type Topdirs.%s.@." typename; - raise Exit - in - Ctype.begin_def(); - let ty_arg = Ctype.newvar() in - Ctype.unify !toplevel_env - (Ctype.newconstr printer_type [ty_arg]) - (Ctype.instance desc.val_type); - Ctype.end_def(); - Ctype.generalize ty_arg; - ty_arg - -let find_printer_type ppf lid = - match Env.find_value_by_name lid !toplevel_env with - | (path, desc) -> begin - match match_printer_type ppf desc "printer_type_new" with - | ty_arg -> (ty_arg, path, false) - | exception Ctype.Unify _ -> begin - match match_printer_type ppf desc "printer_type_old" with - | ty_arg -> (ty_arg, path, true) - | exception Ctype.Unify _ -> - fprintf ppf "%a has a wrong type for a printing function.@." - Printtyp.longident lid; - raise Exit - end - end - | exception Not_found -> - fprintf ppf "Unbound value %a.@." Printtyp.longident lid; - raise Exit - -let dir_install_printer ppf lid = - try - let (ty_arg, path, is_old_style) = find_printer_type ppf lid in - let v = eval_value_path !toplevel_env path in - let print_function = - if is_old_style then - (fun _formatter repr -> Obj.obj v (Obj.obj repr)) - else - (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in - install_printer path ty_arg print_function - with Exit -> () - -let dir_remove_printer ppf lid = - try - let (_ty_arg, path, _is_old_style) = find_printer_type ppf lid in - begin try - remove_printer path - with Not_found -> - fprintf ppf "No printer named %a.@." Printtyp.longident lid - end - with Exit -> () - -let _ = Hashtbl.add directive_table "install_printer" - (Directive_ident (dir_install_printer std_out)) -let _ = Hashtbl.add directive_table "remove_printer" - (Directive_ident (dir_remove_printer std_out)) - -let parse_warnings ppf iserr s = - try Warnings.parse_options iserr s - with Arg.Bad err -> fprintf ppf "%s.@." err - -let unavailable () = invalid_arg "Directive unavailable in the native toplevel." - -let dir_trace _ _ = unavailable () -let dir_untrace _ _ = unavailable () -let dir_untrace_all _ _ = unavailable () - -let _ = -(* Control the printing of values *) - - Hashtbl.add directive_table "print_depth" - (Directive_int(fun n -> max_printer_depth := n)); - Hashtbl.add directive_table "print_length" - (Directive_int(fun n -> max_printer_steps := n)); - -(* Set various compiler flags *) - - Hashtbl.add directive_table "labels" - (Directive_bool(fun b -> Clflags.classic := not b)); - - Hashtbl.add directive_table "principal" - (Directive_bool(fun b -> Clflags.principal := b)); - - Hashtbl.add directive_table "warnings" - (Directive_string (parse_warnings std_out false)); - - Hashtbl.add directive_table "warn_error" - (Directive_string (parse_warnings std_out true)) diff --git a/toplevel/native/toploop.ml b/toplevel/native/topeval.ml index 5b78073315..0a14a1c5da 100644 --- a/toplevel/native/toploop.ml +++ b/toplevel/native/topeval.ml @@ -22,7 +22,7 @@ open Parsetree open Types open Typedtree open Outcometree -open Ast_helper +open Topcommon type res = Ok of Obj.t | Err of string type evaluation_outcome = Result of Obj.t | Exception of exn @@ -53,18 +53,6 @@ let dll_run dll entry = | Err s -> fatal_error ("Toploop.dll_run " ^ s) -type directive_fun = - | Directive_none of (unit -> unit) - | Directive_string of (string -> unit) - | Directive_int of (int -> unit) - | Directive_ident of (Longident.t -> unit) - | Directive_bool of (bool -> unit) - -type directive_info = { - section: string; - doc: string; -} - let remembered = ref Ident.empty let rec remember phrase_name i = function @@ -137,96 +125,12 @@ module EvalPath = struct let same_value v1 v2 = (v1 == v2) end -module Printer = Genprintval.Make(Obj)(EvalPath) - -let max_printer_depth = ref 100 -let max_printer_steps = ref 300 - -let print_out_value = Oprint.out_value -let print_out_type = Oprint.out_type -let print_out_class_type = Oprint.out_class_type -let print_out_module_type = Oprint.out_module_type -let print_out_type_extension = Oprint.out_type_extension -let print_out_sig_item = Oprint.out_sig_item -let print_out_signature = Oprint.out_signature -let print_out_phrase = Oprint.out_phrase - -let print_untyped_exception ppf obj = - !print_out_value ppf (Printer.outval_of_untyped_exception obj) -let outval_of_value env obj ty = - Printer.outval_of_value !max_printer_steps !max_printer_depth - (fun _ _ _ -> None) env obj ty -let print_value env obj ppf ty = - !print_out_value ppf (outval_of_value env obj ty) - -type ('a, 'b) gen_printer = ('a, 'b) Genprintval.gen_printer = - | Zero of 'b - | Succ of ('a -> ('a, 'b) gen_printer) - -let install_printer = Printer.install_printer -let install_generic_printer = Printer.install_generic_printer -let install_generic_printer' = Printer.install_generic_printer' -let remove_printer = Printer.remove_printer - -(* Hooks for parsing functions *) - -let parse_toplevel_phrase = ref Parse.toplevel_phrase -let parse_use_file = ref Parse.use_file -let print_location = Location.print_loc -let print_error = Location.print_report -let print_warning = Location.print_warning -let input_name = Location.input_name - -let parse_mod_use_file name lb = - let modname = - String.capitalize_ascii - (Filename.remove_extension (Filename.basename name)) - in - let items = - List.concat - (List.map - (function Ptop_def s -> s | Ptop_dir _ -> []) - (!parse_use_file lb)) - in - [ Ptop_def - [ Str.module_ - (Mb.mk - (Location.mknoloc (Some modname)) - (Mod.structure items) - ) - ] - ] - -(* Hook for initialization *) - -let toplevel_startup_hook = ref (fun () -> ()) - -type event = .. -type event += - | Startup - | After_setup - -let hooks = ref [] - -let add_hook f = hooks := f :: !hooks - -let () = - add_hook (function - | Startup -> !toplevel_startup_hook () - | _ -> ()) - -let run_hooks hook = List.iter (fun f -> f hook) !hooks +include Topcommon.MakePrinter(Obj)(Genprintval.Make(Obj)(EvalPath)) (* Load in-core and execute a lambda term *) let may_trace = ref false (* Global lock on tracing *) -let backtrace = ref None - -let record_backtrace () = - if Printexc.backtrace_status () - then backtrace := Some (Printexc.get_backtrace ()) - let phrase_seqid = ref 0 let phrase_name = ref "TOP" @@ -284,10 +188,8 @@ let load_lambda ppf ~module_ident ~required_globals lam size = then Filename.concat (Sys.getcwd ()) dll else dll in match - may_trace := true; Fun.protect ~finally:(fun () -> - may_trace := false; (try Sys.remove dll with Sys_error _ -> ())) (* note: under windows, cannot remove a loaded dll (should remember the handles, close them in at_exit, and then @@ -309,39 +211,6 @@ let pr_item = | _ -> None ) -(* The current typing environment for the toplevel *) - -let toplevel_env = ref Env.empty - -(* Print an exception produced by an evaluation *) - -let print_out_exception ppf exn outv = - !print_out_phrase ppf (Ophr_exception (exn, outv)) - -let print_exception_outcome ppf exn = - if exn = Out_of_memory then Gc.full_major (); - let outv = outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in - print_out_exception ppf exn outv; - if Printexc.backtrace_status () - then - match !backtrace with - | None -> () - | Some b -> - print_string b; - backtrace := None - -(* The table of toplevel directives. - Filled by functions from module topdirs. *) - -let directive_table = (Hashtbl.create 23 : (string, directive_fun) Hashtbl.t) - -let directive_info_table = - (Hashtbl.create 23 : (string, directive_info) Hashtbl.t) - -let add_directive name dir_fun dir_info = - Hashtbl.add directive_table name dir_fun; - Hashtbl.add directive_info_table name dir_info - (* Execute a toplevel phrase *) let execute_phrase print_outcome ppf phr = @@ -432,11 +301,7 @@ let execute_phrase print_outcome ppf phr = toplevel_env := oldenv; raise x end | Ptop_dir {pdir_name = {Location.txt = dir_name}; pdir_arg } -> - let d = - try Some (Hashtbl.find directive_table dir_name) - with Not_found -> None - in - begin match d with + begin match get_directive dir_name with | None -> fprintf ppf "Unknown directive `%s'.@." dir_name; false @@ -465,260 +330,51 @@ let execute_phrase print_outcome ppf phr = false end -(* Read and execute commands from a file, or from stdin if [name] is "". *) -let use_print_results = ref true +(* API compat *) -let preprocess_phrase ppf phr = - let phr = - match phr with - | Ptop_def str -> - let str = - Pparse.apply_rewriters_str ~restore:true ~tool_name:"ocaml" str - in - Ptop_def str - | phr -> phr +let getvalue _ = assert false +let setvalue _ _ = assert false + +(* Loading files *) + +(* Load in-core a .cmxs file *) + +let load_file _ (* fixme *) ppf name0 = + let name = + try Some (Load_path.find name0) + with Not_found -> None in - if !Clflags.dump_parsetree then Printast.top_phrase ppf phr; - if !Clflags.dump_source then Pprintast.top_phrase ppf phr; - phr - -let use_channel ppf ~wrap_in_module ic name filename = - let lb = Lexing.from_channel ic in - Location.init lb filename; - (* Skip initial #! line if any *) - Lexer.skip_hash_bang lb; - let success = - protect_refs [ R (Location.input_name, filename) ] (fun () -> - try - List.iter - (fun ph -> - let ph = preprocess_phrase ppf ph in - if not (execute_phrase !use_print_results ppf ph) then raise Exit) - (if wrap_in_module then - parse_mod_use_file name lb - else - !parse_use_file lb); - true - with - | Exit -> false - | Sys.Break -> fprintf ppf "Interrupted.@."; false - | x -> Location.report_exception ppf x; false) in - success - -let use_output ppf command = - let fn = Filename.temp_file "ocaml" "_toploop.ml" in - Misc.try_finally ~always:(fun () -> - try Sys.remove fn with Sys_error _ -> ()) - (fun () -> - match - Printf.ksprintf Sys.command "%s > %s" - command - (Filename.quote fn) - with - | 0 -> - let ic = open_in_bin fn in - Misc.try_finally ~always:(fun () -> close_in ic) - (fun () -> - use_channel ppf ~wrap_in_module:false ic "" "(command-output)") - | n -> - fprintf ppf "Command exited with code %d.@." n; - false) - -let use_file ppf ~wrap_in_module name = match name with - | "" -> - use_channel ppf ~wrap_in_module stdin name "(stdin)" - | _ -> - match Load_path.find name with - | filename -> - let ic = open_in_bin filename in - Misc.try_finally ~always:(fun () -> close_in ic) - (fun () -> use_channel ppf ~wrap_in_module ic name filename) - | exception Not_found -> - fprintf ppf "Cannot find file %s.@." name; - false - -let mod_use_file ppf name = - use_file ppf ~wrap_in_module:true name -let use_file ppf name = - use_file ppf ~wrap_in_module:false name - -let use_silently ppf name = - protect_refs [ R (use_print_results, false) ] (fun () -> use_file ppf name) - -(* Reading function for interactive use *) - -let first_line = ref true -let got_eof = ref false;; - -let read_input_default prompt buffer len = - output_string stdout prompt; flush stdout; - let i = ref 0 in - try - while true do - if !i >= len then raise Exit; - let c = input_char stdin in - Bytes.set buffer !i c; - incr i; - if c = '\n' then raise Exit; - done; - (!i, false) - with - | End_of_file -> - (!i, true) - | Exit -> - (!i, false) - -let read_interactive_input = ref read_input_default - -let refill_lexbuf buffer len = - if !got_eof then (got_eof := false; 0) else begin - let prompt = - if !Clflags.noprompt then "" - else if !first_line then "# " - else if !Clflags.nopromptcont then "" - else if Lexer.in_comment () then "* " - else " " + | None -> fprintf ppf "File not found: %s@." name0; false + | Some name -> + let fn,tmp = + if Filename.check_suffix name ".cmx" || Filename.check_suffix name ".cmxa" + then + let cmxs = Filename.temp_file "caml" ".cmxs" in + Asmlink.link_shared ~ppf_dump:ppf [name] cmxs; + cmxs,true + else + name,false + in + let success = + (* The Dynlink interface does not allow us to distinguish between + a Dynlink.Error exceptions raised in the loaded modules + or a genuine error during dynlink... *) + try Dynlink.loadfile fn; true + with + | Dynlink.Error err -> + fprintf ppf "Error while loading %s: %s.@." + name (Dynlink.error_message err); + false + | exn -> + print_exception_outcome ppf exn; + false in - first_line := false; - let (len, eof) = !read_interactive_input prompt buffer len in - if eof then begin - Location.echo_eof (); - if len > 0 then got_eof := true; - len - end else - len - end - -(* Toplevel initialization. Performed here instead of at the - beginning of loop() so that user code linked in with ocamlmktop - can call directives from Topdirs. *) - -let _ = - Sys.interactive := true; + if tmp then (try Sys.remove fn with Sys_error _ -> ()); + success + +let init () = Compmisc.init_path (); Clflags.dlcode := true; () - -let find_ocamlinit () = - let ocamlinit = ".ocamlinit" in - if Sys.file_exists ocamlinit then Some ocamlinit else - let getenv var = match Sys.getenv var with - | exception Not_found -> None | "" -> None | v -> Some v - in - let exists_in_dir dir file = match dir with - | None -> None - | Some dir -> - let file = Filename.concat dir file in - if Sys.file_exists file then Some file else None - in - let home_dir () = getenv "HOME" in - let config_dir () = - if Sys.win32 then None else - match getenv "XDG_CONFIG_HOME" with - | Some _ as v -> v - | None -> - match home_dir () with - | None -> None - | Some dir -> Some (Filename.concat dir ".config") - in - let init_ml = Filename.concat "ocaml" "init.ml" in - match exists_in_dir (config_dir ()) init_ml with - | Some _ as v -> v - | None -> exists_in_dir (home_dir ()) ocamlinit - -let load_ocamlinit ppf = - if !Clflags.noinit then () - else match !Clflags.init_file with - | Some f -> if Sys.file_exists f then ignore (use_silently ppf f) - else fprintf ppf "Init file not found: \"%s\".@." f - | None -> - match find_ocamlinit () with - | None -> () - | Some file -> ignore (use_silently ppf file) -;; - -let set_paths () = - (* Add whatever -I options have been specified on the command line, - but keep the directories that user code linked in with ocamlmktop - may have added to load_path. *) - let expand = Misc.expand_directory Config.standard_library in - let current_load_path = Load_path.get_paths () in - let load_path = List.concat [ - [ "" ]; - List.map expand (List.rev !Compenv.first_include_dirs); - List.map expand (List.rev !Clflags.include_dirs); - List.map expand (List.rev !Compenv.last_include_dirs); - current_load_path; - [expand "+camlp4"]; - ] - in - Load_path.init load_path - -let initialize_toplevel_env () = - toplevel_env := Compmisc.initial_env() - -(* The interactive loop *) - -exception PPerror - -let loop ppf = - Location.formatter_for_warnings := ppf; - if not !Clflags.noversion then - fprintf ppf " OCaml version %s - native toplevel@.@." Config.version; - initialize_toplevel_env (); - let lb = Lexing.from_function refill_lexbuf in - Location.init lb "//toplevel//"; - Location.input_name := "//toplevel//"; - Location.input_lexbuf := Some lb; - Sys.catch_break true; - run_hooks After_setup; - load_ocamlinit ppf; - while true do - let snap = Btype.snapshot () in - try - Lexing.flush_input lb; - Location.reset(); - first_line := true; - let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in - let phr = preprocess_phrase ppf phr in - Env.reset_cache_toplevel (); - if !Clflags.dump_parsetree then Printast.top_phrase ppf phr; - if !Clflags.dump_source then Pprintast.top_phrase ppf phr; - ignore(execute_phrase true ppf phr) - with - | End_of_file -> raise (Compenv.Exit_with_status 0) - | Sys.Break -> fprintf ppf "Interrupted.@."; Btype.backtrack snap - | PPerror -> () - | x -> Location.report_exception ppf x; Btype.backtrack snap - done - -external caml_sys_modify_argv : string array -> unit = - "caml_sys_modify_argv" - -let override_sys_argv new_argv = - caml_sys_modify_argv new_argv; - Arg.current := 0 - -(* Execute a script. If [name] is "", read the script from stdin. *) - -let run_script ppf name args = - override_sys_argv args; - Compmisc.init_path ~dir:(Filename.dirname name) (); - (* Note: would use [Filename.abspath] here, if we had it. *) - toplevel_env := Compmisc.initial_env(); - Sys.interactive := false; - run_hooks After_setup; - let explicit_name = - (* Prevent use_silently from searching in the path. *) - if Filename.is_implicit name - then Filename.concat Filename.current_dir_name name - else name - in - use_silently ppf explicit_name - -(* API compat *) - -let getvalue _ = assert false -let setvalue _ _ = assert false diff --git a/toplevel/native/topmain.ml b/toplevel/native/topmain.ml index 4828bce83e..10feb68ea7 100644 --- a/toplevel/native/topmain.ml +++ b/toplevel/native/topmain.ml @@ -13,10 +13,8 @@ (* *) (**************************************************************************) -open Compenv - -let usage = - "Usage: ocamlnat <options> <object-files> [script-file]\noptions are:" +let usage = "Usage: ocamlnat <options> <object-files> [script-file]\n\ + options are:" let preload_objects = ref [] @@ -40,12 +38,12 @@ let expand_position pos len = let prepare ppf = - Toploop.set_paths (); + Topcommon.set_paths (); try let res = - List.for_all (Topdirs.load_file ppf) (List.rev !preload_objects) + List.for_all (Topeval.load_file false ppf) (List.rev !preload_objects) in - Toploop.run_hooks Toploop.Startup; + Topcommon.run_hooks Topcommon.Startup; res with x -> try Location.report_exception ppf x; false @@ -67,15 +65,15 @@ let file_argument name = Printf.eprintf "For implementation reasons, the toplevel does not support\ \ having script files (here %S) inside expanded arguments passed through\ \ the -args{,0} command-line option.\n" name; - raise (Exit_with_status 2) + raise (Compenv.Exit_with_status 2) end else begin let newargs = Array.sub !argv !Arg.current (Array.length !argv - !Arg.current) in Compmisc.read_clflags_from_env (); if prepare ppf && Toploop.run_script ppf name newargs - then raise (Exit_with_status 0) - else raise (Exit_with_status 2) + then raise (Compenv.Exit_with_status 0) + else raise (Compenv.Exit_with_status 2) end let wrap_expand f s = @@ -108,16 +106,16 @@ let main () = Arg.parse_and_expand_argv_dynamic current argv list file_argument usage; with | Arg.Bad msg -> Format.fprintf Format.err_formatter "%s%!" msg; - raise (Exit_with_status 2) + raise (Compenv.Exit_with_status 2) | Arg.Help msg -> Format.fprintf Format.std_formatter "%s%!" msg; - raise (Exit_with_status 0) + raise (Compenv.Exit_with_status 0) end; Compmisc.read_clflags_from_env (); - if not (prepare Format.err_formatter) then raise (Exit_with_status 2); + if not (prepare Format.err_formatter) then raise (Compenv.Exit_with_status 2); Compmisc.init_path (); Toploop.loop Format.std_formatter let main () = match main () with - | exception Exit_with_status n -> n + | exception Compenv.Exit_with_status n -> n | () -> 0 diff --git a/toplevel/topcommon.ml b/toplevel/topcommon.ml new file mode 100644 index 0000000000..103872e9e9 --- /dev/null +++ b/toplevel/topcommon.ml @@ -0,0 +1,302 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Definitions for the interactive toplevel loop that are common between + bytecode and native *) + +open Format +open Parsetree +open Outcometree +open Ast_helper + +(* Hooks for parsing functions *) + +let parse_toplevel_phrase = ref Parse.toplevel_phrase +let parse_use_file = ref Parse.use_file +let print_location = Location.print_loc +let print_error = Location.print_report +let print_warning = Location.print_warning +let input_name = Location.input_name + +let parse_mod_use_file name lb = + let modname = + String.capitalize_ascii + (Filename.remove_extension (Filename.basename name)) + in + let items = + List.concat + (List.map + (function Ptop_def s -> s | Ptop_dir _ -> []) + (!parse_use_file lb)) + in + [ Ptop_def + [ Str.module_ + (Mb.mk + (Location.mknoloc (Some modname)) + (Mod.structure items) + ) + ] + ] + +(* Hooks for printing *) + +let max_printer_depth = ref 100 +let max_printer_steps = ref 300 + +let print_out_value = Oprint.out_value +let print_out_type = Oprint.out_type +let print_out_class_type = Oprint.out_class_type +let print_out_module_type = Oprint.out_module_type +let print_out_type_extension = Oprint.out_type_extension +let print_out_sig_item = Oprint.out_sig_item +let print_out_signature = Oprint.out_signature +let print_out_phrase = Oprint.out_phrase + + +(* The current typing environment for the toplevel *) + +let toplevel_env = ref Env.empty + +let backtrace = ref None + +(* Generic printer *) + +module type PRINTER = sig + + module Printer: Genprintval.S + + val print_value: Env.t -> Printer.t -> formatter -> Types.type_expr -> unit + val print_untyped_exception: formatter -> Printer.t -> unit + + val print_exception_outcome : formatter -> exn -> unit + + val outval_of_value: + Env.t -> Printer.t -> Types.type_expr -> Outcometree.out_value + + type ('a, 'b) gen_printer = + | Zero of 'b + | Succ of ('a -> ('a, 'b) gen_printer) + + val install_printer : + Path.t -> Types.type_expr -> (formatter -> Printer.t -> unit) -> unit + val install_generic_printer : + Path.t -> Path.t -> + (int -> (int -> Printer.t -> Outcometree.out_value, + Printer.t-> Outcometree.out_value) gen_printer) -> unit + val install_generic_printer' : + Path.t -> Path.t -> (formatter -> Printer.t -> unit, + formatter -> Printer.t -> unit) gen_printer -> unit + val remove_printer : Path.t -> unit + +end + +module MakePrinter + (O: Genprintval.OBJ) + (Printer: Genprintval.S with type t = O.t) + : PRINTER with type Printer.t = O.t += struct + + module Printer = Printer + + let print_untyped_exception ppf obj = + !print_out_value ppf (Printer.outval_of_untyped_exception obj) + let outval_of_value env obj ty = + Printer.outval_of_value !max_printer_steps !max_printer_depth + (fun _ _ _ -> None) env obj ty + let print_value env obj ppf ty = + !print_out_value ppf (outval_of_value env obj ty) + + (* Print an exception produced by an evaluation *) + + let print_out_exception ppf exn outv = + !print_out_phrase ppf (Ophr_exception (exn, outv)) + + let print_exception_outcome ppf exn = + if exn = Out_of_memory then Gc.full_major (); + let outv = outval_of_value !toplevel_env (O.repr exn) Predef.type_exn in + print_out_exception ppf exn outv; + if Printexc.backtrace_status () + then + match !backtrace with + | None -> () + | Some b -> + print_string b; + backtrace := None + + type ('a, 'b) gen_printer = ('a, 'b) Genprintval.gen_printer = + | Zero of 'b + | Succ of ('a -> ('a, 'b) gen_printer) + + let install_printer = Printer.install_printer + let install_generic_printer = Printer.install_generic_printer + let install_generic_printer' = Printer.install_generic_printer' + let remove_printer = Printer.remove_printer + +end + + +(* Hook for initialization *) + +let toplevel_startup_hook = ref (fun () -> ()) + +type event = .. +type event += + | Startup + | After_setup + +let hooks = ref [] + +let add_hook f = hooks := f :: !hooks + +let () = + add_hook (function + | Startup -> !toplevel_startup_hook () + | _ -> ()) + +let run_hooks hook = List.iter (fun f -> f hook) !hooks + +(* Helpers for execution *) + +type evaluation_outcome = Result of Obj.t | Exception of exn + +let record_backtrace () = + if Printexc.backtrace_status () + then backtrace := Some (Printexc.get_backtrace ()) + +let preprocess_phrase ppf phr = + let phr = + match phr with + | Ptop_def str -> + let str = + Pparse.apply_rewriters_str ~restore:true ~tool_name:"ocaml" str + in + Ptop_def str + | phr -> phr + in + if !Clflags.dump_parsetree then Printast.top_phrase ppf phr; + if !Clflags.dump_source then Pprintast.top_phrase ppf phr; + phr + +(* Phrase buffer that stores the last toplevel phrase (see + [Location.input_phrase_buffer]). *) +let phrase_buffer = Buffer.create 1024 + +(* Reading function for interactive use *) + +let first_line = ref true +let got_eof = ref false + +let read_input_default prompt buffer len = + output_string stdout prompt; flush stdout; + let i = ref 0 in + try + while true do + if !i >= len then raise Exit; + let c = input_char stdin in + Bytes.set buffer !i c; + (* Also populate the phrase buffer as new characters are added. *) + Buffer.add_char phrase_buffer c; + incr i; + if c = '\n' then raise Exit; + done; + (!i, false) + with + | End_of_file -> + (!i, true) + | Exit -> + (!i, false) + +let read_interactive_input = ref read_input_default + +let refill_lexbuf buffer len = + if !got_eof then (got_eof := false; 0) else begin + let prompt = + if !Clflags.noprompt then "" + else if !first_line then "# " + else if !Clflags.nopromptcont then "" + else if Lexer.in_comment () then "* " + else " " + in + first_line := false; + let (len, eof) = !read_interactive_input prompt buffer len in + if eof then begin + Location.echo_eof (); + if len > 0 then got_eof := true; + len + end else + len + end + +let set_paths () = + (* Add whatever -I options have been specified on the command line, + but keep the directories that user code linked in with ocamlmktop + may have added to load_path. *) + let expand = Misc.expand_directory Config.standard_library in + let current_load_path = Load_path.get_paths () in + let load_path = List.concat [ + [ "" ]; + List.map expand (List.rev !Compenv.first_include_dirs); + List.map expand (List.rev !Clflags.include_dirs); + List.map expand (List.rev !Compenv.last_include_dirs); + current_load_path; + [expand "+camlp4"]; + ] + in + Load_path.init load_path; + Dll.add_path load_path + +let initialize_toplevel_env () = + toplevel_env := Compmisc.initial_env() + +external caml_sys_modify_argv : string array -> unit = + "caml_sys_modify_argv" + +let override_sys_argv new_argv = + caml_sys_modify_argv new_argv; + Arg.current := 0 + + +(* The table of toplevel directives. + Filled by functions from module topdirs. *) + +type directive_fun = + | Directive_none of (unit -> unit) + | Directive_string of (string -> unit) + | Directive_int of (int -> unit) + | Directive_ident of (Longident.t -> unit) + | Directive_bool of (bool -> unit) + +type directive_info = { + section: string; + doc: string; +} + +let directive_table = (Hashtbl.create 23 : (string, directive_fun) Hashtbl.t) + +let directive_info_table = + (Hashtbl.create 23 : (string, directive_info) Hashtbl.t) + +let add_directive name dir_fun dir_info = + Hashtbl.add directive_table name dir_fun; + Hashtbl.add directive_info_table name dir_info + +let get_directive name = + Hashtbl.find_opt directive_table name + +let get_directive_info name = + Hashtbl.find_opt directive_info_table name + +let all_directive_names () = + Hashtbl.fold (fun dir _ acc -> dir::acc) directive_table [] diff --git a/toplevel/topcommon.mli b/toplevel/topcommon.mli new file mode 100644 index 0000000000..1cf0f63c2c --- /dev/null +++ b/toplevel/topcommon.mli @@ -0,0 +1,198 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** This module provides common implementations for internals of [Toploop], for + bytecode and native code (see [Topeval] for the diverging parts of the + implementation). + + You should not use it directly, refer to the functions in [Toploop] instead. +*) + +(**/**) + +(* Definitions for the interactive toplevel loop that are common between + bytecode and native *) + +open Format + +(* Set the load paths, before running anything *) + +val set_paths : unit -> unit + +(* Management and helpers for the execution *) + +val toplevel_env : Env.t ref + (* Typing environment for the toplevel *) +val initialize_toplevel_env : unit -> unit + (* Initialize the typing environment for the toplevel *) +val preprocess_phrase : + formatter -> Parsetree.toplevel_phrase -> Parsetree.toplevel_phrase + (* Preprocess the given toplevel phrase using regular and ppx + preprocessors. Return the updated phrase. *) +val record_backtrace : unit -> unit + + +(* Printing of values *) + +val max_printer_depth: int ref +val max_printer_steps: int ref + +val print_out_value : + (formatter -> Outcometree.out_value -> unit) ref +val print_out_type : + (formatter -> Outcometree.out_type -> unit) ref +val print_out_class_type : + (formatter -> Outcometree.out_class_type -> unit) ref +val print_out_module_type : + (formatter -> Outcometree.out_module_type -> unit) ref +val print_out_type_extension : + (formatter -> Outcometree.out_type_extension -> unit) ref +val print_out_sig_item : + (formatter -> Outcometree.out_sig_item -> unit) ref +val print_out_signature : + (formatter -> Outcometree.out_sig_item list -> unit) ref +val print_out_phrase : + (formatter -> Outcometree.out_phrase -> unit) ref + +module type PRINTER = sig + + module Printer: Genprintval.S + + val print_value: Env.t -> Printer.t -> formatter -> Types.type_expr -> unit + + val print_untyped_exception: formatter -> Printer.t -> unit + + val print_exception_outcome : formatter -> exn -> unit + (* Print an exception resulting from the evaluation of user code. *) + + val outval_of_value: + Env.t -> Printer.t -> Types.type_expr -> Outcometree.out_value + + type ('a, 'b) gen_printer = + | Zero of 'b + | Succ of ('a -> ('a, 'b) gen_printer) + + val install_printer : + Path.t -> Types.type_expr -> (formatter -> Printer.t -> unit) -> unit + val install_generic_printer : + Path.t -> Path.t -> + (int -> (int -> Printer.t -> Outcometree.out_value, + Printer.t-> Outcometree.out_value) gen_printer) -> unit + val install_generic_printer' : + Path.t -> Path.t -> (formatter -> Printer.t -> unit, + formatter -> Printer.t -> unit) gen_printer -> unit + val remove_printer : Path.t -> unit + +end + +module MakePrinter (O : Genprintval.OBJ) (P : Genprintval.S with type t = O.t): + PRINTER with module Printer = P + and type Printer.t = O.t + +(* Interface with toplevel directives *) + +type directive_fun = + | Directive_none of (unit -> unit) + | Directive_string of (string -> unit) + | Directive_int of (int -> unit) + | Directive_ident of (Longident.t -> unit) + | Directive_bool of (bool -> unit) + +type directive_info = { + section: string; + doc: string; +} + +(* Add toplevel directive and its documentation. + @since 4.03 *) +val add_directive : string -> directive_fun -> directive_info -> unit + +val get_directive : string -> directive_fun option + +val get_directive_info : string -> directive_info option + +val all_directive_names : unit -> string list + +val[@deprecated] directive_table : (string, directive_fun) Hashtbl.t + (* @deprecated please use [add_directive] instead of inserting + in this table directly. *) + +val[@deprecated] directive_info_table : (string, directive_info) Hashtbl.t + (* @deprecated please use [add_directive] instead of inserting + in this table directly. *) + +(* Hooks for external parsers and printers *) + +val parse_toplevel_phrase : (Lexing.lexbuf -> Parsetree.toplevel_phrase) ref +val parse_use_file : (Lexing.lexbuf -> Parsetree.toplevel_phrase list) ref +val print_location : formatter -> Location.t -> unit +val print_error : formatter -> Location.error -> unit +val print_warning : Location.t -> formatter -> Warnings.t -> unit +val input_name : string ref + +(* Hooks for external line editor *) + +(* Phrase buffer that stores the last toplevel phrase (see + [Location.input_phrase_buffer]). *) +val phrase_buffer : Buffer.t + +val first_line : bool ref + +val got_eof : bool ref + +val read_interactive_input : (string -> bytes -> int -> int * bool) ref + +(* Hooks *) + +val toplevel_startup_hook : (unit -> unit) ref + +type event = .. +type event += + | Startup + | After_setup + (* Just after the setup, when the toplevel is ready to evaluate user + input. This happens before the toplevel has evaluated any kind of + user input, in particular this happens before loading the + [.ocamlinit] file. *) + +val add_hook : (event -> unit) -> unit +(* Add a function that will be called at key points of the toplevel + initialization process. *) + +val run_hooks : event -> unit +(* Run all the registered hooks. *) + +(* Misc *) + +val override_sys_argv : string array -> unit +(* [override_sys_argv args] replaces the contents of [Sys.argv] by [args] + and reset [Arg.current] to [0]. + + This is called by [run_script] so that [Sys.argv] represents + "script.ml args..." instead of the full command line: + "ocamlrun unix.cma ... script.ml args...". *) + +(**/**) + +(* internal functions used by [Topeval] *) + +type evaluation_outcome = Result of Obj.t | Exception of exn + +val backtrace: string option ref + +val parse_mod_use_file: + string -> Lexing.lexbuf -> Parsetree.toplevel_phrase list + +val refill_lexbuf: bytes -> int -> int diff --git a/toplevel/byte/topdirs.ml b/toplevel/topdirs.ml index 6fbbc6c13d..94e066d1d0 100644 --- a/toplevel/byte/topdirs.ml +++ b/toplevel/topdirs.ml @@ -19,8 +19,6 @@ open Format open Misc open Longident open Types -open Cmo_format -open Trace open Toploop (* The standard output formatter *) @@ -104,6 +102,16 @@ let _ = add_directive "remove_directory" (Directive_string dir_remove_directory) section = section_run; doc = "Remove the given directory from the search path."; } + +let dir_show_dirs () = + List.iter print_endline (Load_path.get_paths ()) + +let _ = add_directive "show_dirs" (Directive_none dir_show_dirs) + { + section = section_run; + doc = "List directories currently in the search path."; + } + (* To change the current directory *) let dir_cd s = Sys.chdir s @@ -113,112 +121,8 @@ let _ = add_directive "cd" (Directive_string dir_cd) section = section_run; doc = "Change the current working directory."; } -(* Load in-core a .cmo file *) - -exception Load_failed - -let check_consistency ppf filename cu = - try Env.import_crcs ~source:filename cu.cu_imports - with Persistent_env.Consistbl.Inconsistency { - unit_name = name; - inconsistent_source = user; - original_source = auth; - } -> - fprintf ppf "@[<hv 0>The files %s@ and %s@ \ - disagree over interface %s@]@." - user auth name; - raise Load_failed - -let load_compunit ic filename ppf compunit = - check_consistency ppf filename compunit; - seek_in ic compunit.cu_pos; - let code_size = compunit.cu_codesize + 8 in - let code = LongString.create code_size in - LongString.input_bytes_into code ic compunit.cu_codesize; - LongString.set code compunit.cu_codesize (Char.chr Opcodes.opRETURN); - LongString.blit_string "\000\000\000\001\000\000\000" 0 - code (compunit.cu_codesize + 1) 7; - let initial_symtable = Symtable.current_state() in - Symtable.patch_object code compunit.cu_reloc; - Symtable.update_global_table(); - let events = - if compunit.cu_debug = 0 then [| |] - else begin - seek_in ic compunit.cu_debug; - [| input_value ic |] - end in - begin try - may_trace := true; - let _bytecode, closure = Meta.reify_bytecode code events None in - ignore (closure ()); - may_trace := false; - with exn -> - record_backtrace (); - may_trace := false; - Symtable.restore_state initial_symtable; - print_exception_outcome ppf exn; - raise Load_failed - end -let rec load_file recursive ppf name = - let filename = - try Some (Load_path.find name) with Not_found -> None - in - match filename with - | None -> fprintf ppf "Cannot find file %s.@." name; false - | Some filename -> - let ic = open_in_bin filename in - Misc.try_finally - ~always:(fun () -> close_in ic) - (fun () -> really_load_file recursive ppf name filename ic) - -and really_load_file recursive ppf name filename ic = - let buffer = really_input_string ic (String.length Config.cmo_magic_number) in - try - if buffer = Config.cmo_magic_number then begin - let compunit_pos = input_binary_int ic in (* Go to descriptor *) - seek_in ic compunit_pos; - let cu : compilation_unit = input_value ic in - if recursive then - List.iter - (function - | (Reloc_getglobal id, _) - when not (Symtable.is_global_defined id) -> - let file = Ident.name id ^ ".cmo" in - begin match Load_path.find_uncap file with - | exception Not_found -> () - | file -> - if not (load_file recursive ppf file) then raise Load_failed - end - | _ -> () - ) - cu.cu_reloc; - load_compunit ic filename ppf cu; - true - end else - if buffer = Config.cma_magic_number then begin - let toc_pos = input_binary_int ic in (* Go to table of contents *) - seek_in ic toc_pos; - let lib = (input_value ic : library) in - List.iter - (fun dllib -> - let name = Dll.extract_dll_name dllib in - try Dll.open_dlls Dll.For_execution [name] - with Failure reason -> - fprintf ppf - "Cannot load required shared library %s.@.Reason: %s.@." - name reason; - raise Load_failed) - lib.lib_dllibs; - List.iter (load_compunit ic filename ppf) lib.lib_units; - true - end else begin - fprintf ppf "File %s is not a bytecode object file.@." name; - false - end - with Load_failed -> false - -let dir_load ppf name = ignore (load_file false ppf name) +let dir_load ppf name = ignore (Topeval.load_file false ppf name) let _ = add_directive "load" (Directive_string (dir_load std_out)) { @@ -226,7 +130,7 @@ let _ = add_directive "load" (Directive_string (dir_load std_out)) doc = "Load in memory a bytecode object, produced by ocamlc."; } -let dir_load_rec ppf name = ignore (load_file true ppf name) +let dir_load_rec ppf name = ignore (Topeval.load_file true ppf name) let _ = add_directive "load_rec" (Directive_string (dir_load_rec std_out)) @@ -235,7 +139,7 @@ let _ = add_directive "load_rec" doc = "As #load, but loads dependencies recursively."; } -let load_file = load_file false +let load_file = Topeval.load_file false (* Load commands from a file *) @@ -413,78 +317,6 @@ let _ = add_directive "remove_printer" doc = "Remove the named function from the table of toplevel printers."; } -(* The trace *) - -external current_environment: unit -> Obj.t = "caml_get_current_environment" - -let tracing_function_ptr = - get_code_pointer - (Obj.repr (fun arg -> Trace.print_trace (current_environment()) arg)) - -let dir_trace ppf lid = - match Env.find_value_by_name lid !toplevel_env with - | (path, desc) -> begin - (* Check if this is a primitive *) - match desc.val_kind with - | Val_prim _ -> - fprintf ppf "%a is an external function and cannot be traced.@." - Printtyp.longident lid - | _ -> - let clos = eval_value_path !toplevel_env path in - (* Nothing to do if it's not a closure *) - if Obj.is_block clos - && (Obj.tag clos = Obj.closure_tag || Obj.tag clos = Obj.infix_tag) - && (match Ctype.(repr (expand_head !toplevel_env desc.val_type)) - with {desc=Tarrow _} -> true | _ -> false) - then begin - match is_traced clos with - | Some opath -> - fprintf ppf "%a is already traced (under the name %a).@." - Printtyp.path path - Printtyp.path opath - | None -> - (* Instrument the old closure *) - traced_functions := - { path = path; - closure = clos; - actual_code = get_code_pointer clos; - instrumented_fun = - instrument_closure !toplevel_env lid ppf desc.val_type } - :: !traced_functions; - (* Redirect the code field of the closure to point - to the instrumentation function *) - set_code_pointer clos tracing_function_ptr; - fprintf ppf "%a is now traced.@." Printtyp.longident lid - end else fprintf ppf "%a is not a function.@." Printtyp.longident lid - end - | exception Not_found -> - fprintf ppf "Unbound value %a.@." Printtyp.longident lid - -let dir_untrace ppf lid = - match Env.find_value_by_name lid !toplevel_env with - | (path, _desc) -> - let rec remove = function - | [] -> - fprintf ppf "%a was not traced.@." Printtyp.longident lid; - [] - | f :: rem -> - if Path.same f.path path then begin - set_code_pointer f.closure f.actual_code; - fprintf ppf "%a is no longer traced.@." Printtyp.longident lid; - rem - end else f :: remove rem in - traced_functions := remove !traced_functions - | exception Not_found -> - fprintf ppf "Unbound value %a.@." Printtyp.longident lid - -let dir_untrace_all ppf () = - List.iter - (fun f -> - set_code_pointer f.closure f.actual_code; - fprintf ppf "%a is no longer traced.@." Printtyp.path f.path) - !traced_functions; - traced_functions := [] - let parse_warnings ppf iserr s = try Warnings.parse_options iserr s with Arg.Bad err -> fprintf ppf "%s.@." err @@ -512,7 +344,7 @@ let trim_signature = function | mty -> mty let show_prim to_sig ppf lid = - let env = !Toploop.toplevel_env in + let env = !toplevel_env in let loc = Location.none in try let s = @@ -697,28 +529,6 @@ let () = from any of the categories below."; } -let _ = add_directive "trace" - (Directive_ident (dir_trace std_out)) - { - section = section_trace; - doc = "All calls to the function \ - named function-name will be traced."; - } - -let _ = add_directive "untrace" - (Directive_ident (dir_untrace std_out)) - { - section = section_trace; - doc = "Stop tracing the given function."; - } - -let _ = add_directive "untrace_all" - (Directive_none (dir_untrace_all std_out)) - { - section = section_trace; - doc = "Stop tracing all functions traced so far."; - } - (* Control the printing of values *) let _ = add_directive "print_depth" @@ -784,17 +594,22 @@ let _ = add_directive "warn_error" let directive_sections () = let sections = Hashtbl.create 10 in - let add_dir name dir = + let add_dir name = + let dir = + match get_directive name with + | Some dir -> dir + | None -> assert false + in let section, doc = - match Hashtbl.find directive_info_table name with - | { section; doc } -> section, Some doc - | exception Not_found -> "Undocumented", None + match get_directive_info name with + | Some { section; doc } -> section, Some doc + | None -> "Undocumented", None in Hashtbl.replace sections section ((name, dir, doc) :: (try Hashtbl.find sections section with Not_found -> [])) in - Hashtbl.iter add_dir directive_table; + List.iter add_dir (all_directive_names ()); let take_section section = if not (Hashtbl.mem sections section) then (section, []) else begin diff --git a/toplevel/topdirs.mli b/toplevel/topdirs.mli index 77d3660093..a65ae08720 100644 --- a/toplevel/topdirs.mli +++ b/toplevel/topdirs.mli @@ -26,12 +26,26 @@ val dir_use : formatter -> string -> unit val dir_use_output : formatter -> string -> unit val dir_install_printer : formatter -> Longident.t -> unit val dir_remove_printer : formatter -> Longident.t -> unit + +(* These are now injected from [Topeval], for the bytecode toplevel only: val dir_trace : formatter -> Longident.t -> unit val dir_untrace : formatter -> Longident.t -> unit val dir_untrace_all : formatter -> unit -> unit + *) + +val section_general : string +val section_run : string +val section_env : string + +val section_print : string +val section_trace : string +val section_options : string + +val section_undocumented : string + type 'a printer_type_new = Format.formatter -> 'a -> unit type 'a printer_type_old = 'a -> unit -(* For topmain.ml. Maybe shouldn't be there *) -val load_file : formatter -> string -> bool +(* Here for backwards compatibility, use [Toploop.load_file]. *) +val[@deprecated] load_file : formatter -> string -> bool diff --git a/toplevel/topeval.mli b/toplevel/topeval.mli new file mode 100644 index 0000000000..8d389bce9a --- /dev/null +++ b/toplevel/topeval.mli @@ -0,0 +1,56 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** This module provides two alternative implementations for internals of + [Toploop], for bytecode and native code. + + You should not use it directly, refer to the functions in [Toploop] instead. +*) + +(**/**) + +open Format + +(* Accessors for the table of toplevel value bindings. For the bytecode + toplevel, these functions must appear as first and second exported functions + in this module. + (See module Translmod.) + They aren't used for the native toplevel. +*) +val getvalue : string -> Obj.t +val setvalue : string -> Obj.t -> unit + +val execute_phrase : bool -> formatter -> Parsetree.toplevel_phrase -> bool + (* Read and execute commands from a file. + [use_file] prints the types and values of the results. + [use_silently] does not print them. + [mod_use_file] wrap the file contents into a module. *) +val eval_module_path: Env.t -> Path.t -> Obj.t +val eval_value_path: Env.t -> Path.t -> Obj.t +val eval_extension_path: Env.t -> Path.t -> Obj.t +val eval_class_path: Env.t -> Path.t -> Obj.t + (* Return the toplevel object referred to by the given path *) + +val eval_address: Env.address -> Obj.t + (* Used for printers *) + +val may_trace : bool ref + +include Topcommon.PRINTER with type Printer.t = Obj.t + +(* For topmain.ml. Maybe shouldn't be there *) +val load_file : bool -> formatter -> string -> bool + +val init: unit -> unit diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml new file mode 100644 index 0000000000..de456d5aa9 --- /dev/null +++ b/toplevel/toploop.ml @@ -0,0 +1,202 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Format +include Topcommon +include Topeval + +(* Read and execute commands from a file, or from stdin if [name] is "". *) + +let use_print_results = ref true + +let use_channel ppf ~wrap_in_module ic name filename = + let lb = Lexing.from_channel ic in + Warnings.reset_fatal (); + Location.init lb filename; + (* Skip initial #! line if any *) + Lexer.skip_hash_bang lb; + Misc.protect_refs + [ R (Location.input_name, filename); + R (Location.input_lexbuf, Some lb); ] + (fun () -> + try + List.iter + (fun ph -> + let ph = preprocess_phrase ppf ph in + if not (execute_phrase !use_print_results ppf ph) then raise Exit) + (if wrap_in_module then + parse_mod_use_file name lb + else + !parse_use_file lb); + true + with + | Exit -> false + | Sys.Break -> fprintf ppf "Interrupted.@."; false + | x -> Location.report_exception ppf x; false) + +let use_output ppf command = + let fn = Filename.temp_file "ocaml" "_toploop.ml" in + Misc.try_finally ~always:(fun () -> + try Sys.remove fn with Sys_error _ -> ()) + (fun () -> + match + Printf.ksprintf Sys.command "%s > %s" + command + (Filename.quote fn) + with + | 0 -> + let ic = open_in_bin fn in + Misc.try_finally ~always:(fun () -> close_in ic) + (fun () -> + use_channel ppf ~wrap_in_module:false ic "" "(command-output)") + | n -> + fprintf ppf "Command exited with code %d.@." n; + false) + +let use_file ppf ~wrap_in_module name = + match name with + | "" -> + use_channel ppf ~wrap_in_module stdin name "(stdin)" + | _ -> + match Load_path.find name with + | filename -> + let ic = open_in_bin filename in + Misc.try_finally ~always:(fun () -> close_in ic) + (fun () -> use_channel ppf ~wrap_in_module ic name filename) + | exception Not_found -> + fprintf ppf "Cannot find file %s.@." name; + false + +let mod_use_file ppf name = + use_file ppf ~wrap_in_module:true name +let use_file ppf name = + use_file ppf ~wrap_in_module:false name + +let use_silently ppf name = + Misc.protect_refs + [ R (use_print_results, false) ] + (fun () -> use_file ppf name) + +let load_file = load_file false + +(* Execute a script. If [name] is "", read the script from stdin. *) + +let run_script ppf name args = + override_sys_argv args; + Compmisc.init_path ~dir:(Filename.dirname name) (); + (* Note: would use [Filename.abspath] here, if we had it. *) + begin + try toplevel_env := Compmisc.initial_env() + with Env.Error _ | Typetexp.Error _ as exn -> + Location.report_exception ppf exn; raise (Compenv.Exit_with_status 2) + end; + Sys.interactive := false; + run_hooks After_setup; + let explicit_name = + (* Prevent use_silently from searching in the path. *) + if name <> "" && Filename.is_implicit name + then Filename.concat Filename.current_dir_name name + else name + in + use_silently ppf explicit_name + +(* Toplevel initialization. Performed here instead of at the + beginning of loop() so that user code linked in with ocamlmktop + can call directives from Topdirs. *) +let _ = + if !Sys.interactive then (* PR#6108 *) + invalid_arg "The ocamltoplevel.cma library from compiler-libs \ + cannot be loaded inside the OCaml toplevel"; + Sys.interactive := true; + Topeval.init () + +let find_ocamlinit () = + let ocamlinit = ".ocamlinit" in + if Sys.file_exists ocamlinit then Some ocamlinit else + let getenv var = match Sys.getenv var with + | exception Not_found -> None | "" -> None | v -> Some v + in + let exists_in_dir dir file = match dir with + | None -> None + | Some dir -> + let file = Filename.concat dir file in + if Sys.file_exists file then Some file else None + in + let home_dir () = getenv "HOME" in + let config_dir () = + if Sys.win32 then None else + match getenv "XDG_CONFIG_HOME" with + | Some _ as v -> v + | None -> + match home_dir () with + | None -> None + | Some dir -> Some (Filename.concat dir ".config") + in + let init_ml = Filename.concat "ocaml" "init.ml" in + match exists_in_dir (config_dir ()) init_ml with + | Some _ as v -> v + | None -> exists_in_dir (home_dir ()) ocamlinit + +let load_ocamlinit ppf = + if !Clflags.noinit then () + else match !Clflags.init_file with + | Some f -> if Sys.file_exists f then ignore (use_silently ppf f) + else fprintf ppf "Init file not found: \"%s\".@." f + | None -> + match find_ocamlinit () with + | None -> () + | Some file -> ignore (use_silently ppf file) + +(* The interactive loop *) + +exception PPerror + +let loop ppf = + Clflags.debug := true; + Location.formatter_for_warnings := ppf; + if not !Clflags.noversion then + fprintf ppf " OCaml version %s@.@." Config.version; + begin + try initialize_toplevel_env () + with Env.Error _ | Typetexp.Error _ as exn -> + Location.report_exception ppf exn; raise (Compenv.Exit_with_status 2) + end; + let lb = Lexing.from_function refill_lexbuf in + Location.init lb "//toplevel//"; + Location.input_name := "//toplevel//"; + Location.input_lexbuf := Some lb; + Location.input_phrase_buffer := Some phrase_buffer; + Sys.catch_break true; + run_hooks After_setup; + load_ocamlinit ppf; + while true do + let snap = Btype.snapshot () in + try + Lexing.flush_input lb; + (* Reset the phrase buffer when we flush the lexing buffer. *) + Buffer.reset phrase_buffer; + Location.reset(); + Warnings.reset_fatal (); + first_line := true; + let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in + let phr = preprocess_phrase ppf phr in + Env.reset_cache_toplevel (); + ignore(execute_phrase true ppf phr) + with + | End_of_file -> raise (Compenv.Exit_with_status 0) + | Sys.Break -> fprintf ppf "Interrupted.@."; Btype.backtrack snap + | PPerror -> () + | x -> Location.report_exception ppf x; Btype.backtrack snap + done diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli index 45a43bc3f6..ea18fc28db 100644 --- a/toplevel/toploop.mli +++ b/toplevel/toploop.mli @@ -53,11 +53,19 @@ val add_directive : string -> directive_fun -> directive_info -> unit @since 4.03 *) -val directive_table : (string, directive_fun) Hashtbl.t - (* Deprecated: please use [add_directive] instead of inserting +val get_directive : string -> directive_fun option + +val get_directive_info : string -> directive_info option + +val all_directive_names : unit -> string list + +val[@deprecated] directive_table : (string, directive_fun) Hashtbl.t + (* @deprecated please use [add_directive] instead of inserting in this table directly. *) -val directive_info_table : (string, directive_info) Hashtbl.t +val[@deprecated] directive_info_table : (string, directive_info) Hashtbl.t + (* @deprecated please use [add_directive] instead of inserting + in this table directly. *) val toplevel_env : Env.t ref (* Typing environment for the toplevel *) @@ -89,6 +97,8 @@ val eval_class_path: Env.t -> Path.t -> Obj.t (* Return the toplevel object referred to by the given path *) val record_backtrace : unit -> unit +val load_file: formatter -> string -> bool + (* Printing of values *) val print_value: Env.t -> Obj.t -> formatter -> Types.type_expr -> unit |