Skip to content
Browse files

Import from Francois Pessaux' archive

Francois sent me this archive, updated to work with ocaml 3.12 parser.
  • Loading branch information...
0 parents commit 80aa8e93a7da3814724fff661c444994a02ccb0d @lefessan lefessan committed Mar 9, 2012
Showing with 19,869 additions and 0 deletions.
  1. +291 −0 .depend
  2. +1 −0 .gitignore
  3. +85 −0 INSTALL
  4. +312 −0 Makefile
  5. +39 −0 Makefile.example
  6. +15 −0 README.txt
  7. +134 −0 batch/main.ml
  8. +17 −0 bin/makelibcme
  9. +24 −0 interface/global.ml
  10. +138 −0 interface/main.ml
  11. +85 −0 interface/modselector.ml
  12. +241 −0 interface/preferences.ml
  13. +31 −0 interface/printcontext.mli
  14. +217 −0 interface/rootwindow.ml
  15. +310 −0 interface/tkloadsrc.ml
  16. +91 −0 interface/tklowprint.ml
  17. +118 −0 interface/tkprintmod.ml
  18. +18 −0 interface/tkprintmod.mli
  19. +849 −0 interface/tkprinttypes.ml
  20. +23 −0 interface/tkprinttypes.mli
  21. +117 −0 link/main.ml
  22. +106 −0 man/man1/ocamlexc.1
  23. +99 −0 man/man1/ocamlexcc.1
  24. +353 −0 man/man1/ocamlexcl.1
  25. +359 −0 man/man1/ocamlexcli.1
  26. +36 −0 parsing/asttypes.ml
  27. +33 −0 parsing/asttypes.mli
  28. +321 −0 parsing/lexer.mll
  29. +71 −0 parsing/linenum.mll
  30. +127 −0 parsing/location.ml
  31. +24 −0 parsing/longident.ml
  32. +61 −0 parsing/parse.ml
  33. +1,359 −0 parsing/parser.mly
  34. +287 −0 parsing/parsetree.mli
  35. +4 −0 parsing/patch-parser-boot
  36. +119 −0 parsing/pstream.ml
  37. +49 −0 parsing/syntaxerr.ml
  38. +111 −0 stdlib/arg.ml
  39. +167 −0 stdlib/array.ml
  40. +24 −0 stdlib/callback.ml
  41. +65 −0 stdlib/char.ml
  42. +51 −0 stdlib/digest.ml
  43. +222 −0 stdlib/filename.ml
  44. +858 −0 stdlib/format.ml
  45. +66 −0 stdlib/gc.ml
  46. +170 −0 stdlib/genlex.ml
  47. +200 −0 stdlib/hashtbl.ml
  48. +105 −0 stdlib/lexing.ml
  49. +144 −0 stdlib/list.ml
  50. +135 −0 stdlib/map.ml
  51. +55 −0 stdlib/marshal.ml
  52. +35 −0 stdlib/obj.ml
  53. +191 −0 stdlib/parsing.ml
  54. +411 −0 stdlib/pervasives.ml
  55. +73 −0 stdlib/printexc.ml
  56. +167 −0 stdlib/printf.ml
  57. +71 −0 stdlib/queue.ml
  58. +182 −0 stdlib/random.ml
  59. +270 −0 stdlib/set.ml
  60. +41 −0 stdlib/sort.ml
  61. +31 −0 stdlib/stack.ml
  62. +154 −0 stdlib/str.ml
  63. +189 −0 stdlib/stream.ml
  64. +173 −0 stdlib/string.ml
  65. +77 −0 stdlib/sys.ml
  66. +924 −0 stdlib/unix.ml
  67. +62 −0 stdlib/weak.ml
  68. +149 −0 toplevel/main-for-bootstrap.ml
  69. +186 −0 toplevel/main.ml
  70. +530 −0 typing/corescope.ml
  71. +36 −0 typing/corescope.mli
  72. +393 −0 typing/envscope.ml
  73. +51 −0 typing/envscope.mli
  74. +681 −0 typing/envtype.ml
  75. +55 −0 typing/envtype.mli
  76. +96 −0 typing/error.ml
  77. +252 −0 typing/extendhandler.ml
  78. +16 −0 typing/extendhandler.mli
  79. +63 −0 typing/files.ml
  80. +127 −0 typing/freevars.ml
  81. +120 −0 typing/ident.ml
  82. +52 −0 typing/ident.mli
  83. +1,923 −0 typing/infercore.ml
  84. +88 −0 typing/infercore.mli
  85. +665 −0 typing/infermod.ml
  86. +73 −0 typing/inputpt.ml
  87. +42 −0 typing/listextra.ml
  88. +19 −0 typing/listextra.mli
  89. +218 −0 typing/modscope.ml
  90. +18 −0 typing/modscope.mli
  91. +43 −0 typing/outputp.ml
  92. +59 −0 typing/path.ml
  93. +23 −0 typing/path.mli
  94. +78 −0 typing/printbasic.ml
  95. +24 −0 typing/printbasic.mli
  96. +167 −0 typing/printmod.ml
  97. +18 −0 typing/printmod.mli
  98. +395 −0 typing/printparse.ml
  99. +16 −0 typing/printparse.mli
  100. +448 −0 typing/printscope.ml
  101. +18 −0 typing/printscope.mli
  102. +469 −0 typing/printtypes.ml
  103. +20 −0 typing/printtypes.mli
  104. +235 −0 typing/scopedtree.mli
  105. +15 −0 typing/stdlibpath.ml
Sorry, we could not display the entire diff because it was too big.
291 .depend
@@ -0,0 +1,291 @@
+batch/main.cmo: typing/typecore.cmi parsing/syntaxerr.cmo \
+ typing/substract.cmi typing/stdlibpath.cmo typing/path.cmi \
+ parsing/parse.cmo typing/outputp.cmo typing/modscope.cmi \
+ parsing/lexer.cmo typing/inputpt.cmo typing/infermod.cmo \
+ typing/infercore.cmi typing/ident.cmi typing/files.cmo \
+ typing/extendhandler.cmi typing/error.cmo typing/envtype.cmi \
+ typing/envscope.cmi typing/corescope.cmi
+batch/main.cmx: typing/typecore.cmx parsing/syntaxerr.cmx \
+ typing/substract.cmx typing/stdlibpath.cmx typing/path.cmx \
+ parsing/parse.cmx typing/outputp.cmx typing/modscope.cmx \
+ parsing/lexer.cmx typing/inputpt.cmx typing/infermod.cmx \
+ typing/infercore.cmx typing/ident.cmx typing/files.cmx \
+ typing/extendhandler.cmx typing/error.cmx typing/envtype.cmx \
+ typing/envscope.cmx typing/corescope.cmx
+interface/global.cmo: typing/typedtree.cmi typing/path.cmi
+interface/global.cmx: typing/typedtree.cmi typing/path.cmx
+interface/main.cmo: typing/typedtree.cmi typing/typecore.cmi \
+ interface/tkprinttypes.cmi typing/stdlibpath.cmo \
+ interface/preferences.cmo typing/path.cmi interface/modselector.cmo \
+ typing/inputpt.cmo typing/ident.cmi interface/global.cmo \
+ typing/freevars.cmo typing/files.cmo typing/envtype.cmi \
+ typing/envscope.cmi
+interface/main.cmx: typing/typedtree.cmi typing/typecore.cmx \
+ interface/tkprinttypes.cmx typing/stdlibpath.cmx \
+ interface/preferences.cmx typing/path.cmx interface/modselector.cmx \
+ typing/inputpt.cmx typing/ident.cmx interface/global.cmx \
+ typing/freevars.cmx typing/files.cmx typing/envtype.cmx \
+ typing/envscope.cmx
+interface/modselector.cmo: interface/rootwindow.cmo interface/preferences.cmo \
+ typing/path.cmi typing/ident.cmi interface/global.cmo
+interface/modselector.cmx: interface/rootwindow.cmx interface/preferences.cmx \
+ typing/path.cmx typing/ident.cmx interface/global.cmx
+interface/preferences.cmo:
+interface/preferences.cmx:
+interface/rootwindow.cmo: interface/tkprintmod.cmi interface/tklowprint.cmo \
+ interface/tkloadsrc.cmo interface/printcontext.cmi \
+ interface/preferences.cmo typing/path.cmi interface/global.cmo \
+ typing/envtype.cmi
+interface/rootwindow.cmx: interface/tkprintmod.cmx interface/tklowprint.cmx \
+ interface/tkloadsrc.cmx interface/printcontext.cmi \
+ interface/preferences.cmx typing/path.cmx interface/global.cmx \
+ typing/envtype.cmx
+interface/tkloadsrc.cmo: typing/typedtree.cmi typing/typecore.cmi \
+ interface/tkprinttypes.cmi interface/tklowprint.cmo typing/stdlibpath.cmo \
+ interface/printcontext.cmi parsing/location.cmo
+interface/tkloadsrc.cmx: typing/typedtree.cmi typing/typecore.cmx \
+ interface/tkprinttypes.cmx interface/tklowprint.cmx typing/stdlibpath.cmx \
+ interface/printcontext.cmi parsing/location.cmx
+interface/tklowprint.cmo: interface/printcontext.cmi
+interface/tklowprint.cmx: interface/printcontext.cmi
+interface/tkprintmod.cmo: typing/typedtree.cmi interface/tkprinttypes.cmi \
+ interface/printcontext.cmi typing/printbasic.cmi typing/ident.cmi \
+ interface/tkprintmod.cmi
+interface/tkprintmod.cmx: typing/typedtree.cmi interface/tkprinttypes.cmx \
+ interface/printcontext.cmi typing/printbasic.cmx typing/ident.cmx \
+ interface/tkprintmod.cmi
+interface/tkprinttypes.cmo: typing/typedtree.cmi typing/typecore.cmi \
+ interface/tklowprint.cmo interface/printcontext.cmi typing/printbasic.cmi \
+ typing/path.cmi typing/ident.cmi interface/tkprinttypes.cmi
+interface/tkprinttypes.cmx: typing/typedtree.cmi typing/typecore.cmx \
+ interface/tklowprint.cmx interface/printcontext.cmi typing/printbasic.cmx \
+ typing/path.cmx typing/ident.cmx interface/tkprinttypes.cmi
+interface/printcontext.cmi: typing/typecore.cmi
+interface/tkprintmod.cmi: typing/typedtree.cmi interface/printcontext.cmi
+interface/tkprinttypes.cmi: typing/typedtree.cmi typing/typecore.cmi \
+ interface/printcontext.cmi typing/ident.cmi
+link/main.cmo: typing/typedtree.cmi typing/typecore.cmi typing/stdlibpath.cmo \
+ typing/printmod.cmi typing/path.cmi typing/inputpt.cmo typing/ident.cmi \
+ typing/freevars.cmo typing/error.cmo typing/envtype.cmi \
+ typing/envscope.cmi
+link/main.cmx: typing/typedtree.cmi typing/typecore.cmx typing/stdlibpath.cmx \
+ typing/printmod.cmx typing/path.cmx typing/inputpt.cmx typing/ident.cmx \
+ typing/freevars.cmx typing/error.cmx typing/envtype.cmx \
+ typing/envscope.cmx
+parsing/asttypes.cmo: parsing/asttypes.cmi
+parsing/asttypes.cmx: parsing/asttypes.cmi
+parsing/lexer.cmo: parsing/parser.cmi utils/misc.cmo
+parsing/lexer.cmx: parsing/parser.cmx utils/misc.cmx
+parsing/linenum.cmo: utils/misc.cmo
+parsing/linenum.cmx: utils/misc.cmx
+parsing/location.cmo: utils/terminfo.cmo parsing/linenum.cmo
+parsing/location.cmx: utils/terminfo.cmx parsing/linenum.cmx
+parsing/longident.cmo:
+parsing/longident.cmx:
+parsing/parse.cmo: parsing/syntaxerr.cmo parsing/parser.cmi \
+ parsing/location.cmo parsing/lexer.cmo
+parsing/parse.cmx: parsing/syntaxerr.cmx parsing/parser.cmx \
+ parsing/location.cmx parsing/lexer.cmx
+parsing/parser.cmo: parsing/syntaxerr.cmo parsing/pstream.cmo \
+ parsing/parsetree.cmi parsing/longident.cmo parsing/location.cmo \
+ utils/clflags.cmo parsing/asttypes.cmi parsing/parser.cmi
+parsing/parser.cmx: parsing/syntaxerr.cmx parsing/pstream.cmx \
+ parsing/parsetree.cmi parsing/longident.cmx parsing/location.cmx \
+ utils/clflags.cmx parsing/asttypes.cmx parsing/parser.cmi
+parsing/pstream.cmo: parsing/parsetree.cmi parsing/longident.cmo \
+ parsing/location.cmo parsing/asttypes.cmi
+parsing/pstream.cmx: parsing/parsetree.cmi parsing/longident.cmx \
+ parsing/location.cmx parsing/asttypes.cmx
+parsing/syntaxerr.cmo: parsing/location.cmo
+parsing/syntaxerr.cmx: parsing/location.cmx
+parsing/asttypes.cmi:
+parsing/parser.cmi: parsing/parsetree.cmi
+parsing/parsetree.cmi: parsing/longident.cmo parsing/location.cmo \
+ parsing/asttypes.cmi
+toplevel/main-for-bootstrap.cmo: typing/typecore.cmi typing/topscope.cmi \
+ parsing/syntaxerr.cmo typing/substract.cmi typing/stdlibpath.cmo \
+ typing/path.cmi parsing/parse.cmo parsing/lexer.cmo typing/inputpt.cmo \
+ typing/infermod.cmo typing/infercore.cmi typing/ident.cmi \
+ typing/extendhandler.cmi typing/envtype.cmi typing/envscope.cmi \
+ typing/corescope.cmi
+toplevel/main-for-bootstrap.cmx: typing/typecore.cmx typing/topscope.cmx \
+ parsing/syntaxerr.cmx typing/substract.cmx typing/stdlibpath.cmx \
+ typing/path.cmx parsing/parse.cmx parsing/lexer.cmx typing/inputpt.cmx \
+ typing/infermod.cmx typing/infercore.cmx typing/ident.cmx \
+ typing/extendhandler.cmx typing/envtype.cmx typing/envscope.cmx \
+ typing/corescope.cmx
+toplevel/main.cmo: typing/typecore.cmi typing/topscope.cmi \
+ parsing/syntaxerr.cmo typing/substract.cmi typing/stdlibpath.cmo \
+ typing/printtypes.cmi typing/printscope.cmi typing/printparse.cmi \
+ typing/printmod.cmi typing/path.cmi parsing/parse.cmo parsing/lexer.cmo \
+ typing/inputpt.cmo typing/infermod.cmo typing/infercore.cmi \
+ typing/ident.cmi typing/extendhandler.cmi typing/error.cmo \
+ typing/envtype.cmi typing/envscope.cmi typing/corescope.cmi
+toplevel/main.cmx: typing/typecore.cmx typing/topscope.cmx \
+ parsing/syntaxerr.cmx typing/substract.cmx typing/stdlibpath.cmx \
+ typing/printtypes.cmx typing/printscope.cmx typing/printparse.cmx \
+ typing/printmod.cmx typing/path.cmx parsing/parse.cmx parsing/lexer.cmx \
+ typing/inputpt.cmx typing/infermod.cmx typing/infercore.cmx \
+ typing/ident.cmx typing/extendhandler.cmx typing/error.cmx \
+ typing/envtype.cmx typing/envscope.cmx typing/corescope.cmx
+typing/corescope.cmo: typing/scopedtree.cmi typing/path.cmi \
+ parsing/parsetree.cmi typing/envscope.cmi parsing/asttypes.cmi \
+ typing/corescope.cmi
+typing/corescope.cmx: typing/scopedtree.cmi typing/path.cmx \
+ parsing/parsetree.cmi typing/envscope.cmx parsing/asttypes.cmx \
+ typing/corescope.cmi
+typing/envscope.cmo: typing/stdlibpath.cmo typing/path.cmi \
+ parsing/longident.cmo typing/ident.cmi typing/envscope.cmi
+typing/envscope.cmx: typing/stdlibpath.cmx typing/path.cmx \
+ parsing/longident.cmx typing/ident.cmx typing/envscope.cmi
+typing/envtype.cmo: typing/typedtree.cmi typing/typecore.cmi typing/path.cmi \
+ typing/ident.cmi typing/envtype.cmi
+typing/envtype.cmx: typing/typedtree.cmi typing/typecore.cmx typing/path.cmx \
+ typing/ident.cmx typing/envtype.cmi
+typing/error.cmo: parsing/syntaxerr.cmo typing/printtypes.cmi typing/path.cmi \
+ parsing/location.cmo parsing/lexer.cmo typing/envtype.cmi \
+ typing/envscope.cmi
+typing/error.cmx: parsing/syntaxerr.cmx typing/printtypes.cmx typing/path.cmx \
+ parsing/location.cmx parsing/lexer.cmx typing/envtype.cmx \
+ typing/envscope.cmx
+typing/extendhandler.cmo: parsing/parsetree.cmi parsing/longident.cmo \
+ parsing/location.cmo typing/extendhandler.cmi
+typing/extendhandler.cmx: parsing/parsetree.cmi parsing/longident.cmx \
+ parsing/location.cmx typing/extendhandler.cmi
+typing/files.cmo:
+typing/files.cmx:
+typing/freevars.cmo: typing/typedtree.cmi typing/typecore.cmi
+typing/freevars.cmx: typing/typedtree.cmi typing/typecore.cmx
+typing/ident.cmo: typing/ident.cmi
+typing/ident.cmx: typing/ident.cmi
+typing/infercore.cmo: typing/typedtree.cmi typing/typecore.cmi \
+ typing/substract.cmi typing/scopedtree.cmi typing/printtypes.cmi \
+ typing/path.cmi typing/listextra.cmi typing/ident.cmi typing/files.cmo \
+ typing/envtype.cmi parsing/asttypes.cmi typing/infercore.cmi
+typing/infercore.cmx: typing/typedtree.cmi typing/typecore.cmx \
+ typing/substract.cmx typing/scopedtree.cmi typing/printtypes.cmx \
+ typing/path.cmx typing/listextra.cmx typing/ident.cmx typing/files.cmx \
+ typing/envtype.cmx parsing/asttypes.cmx typing/infercore.cmi
+typing/infermod.cmo: typing/typedtree.cmi typing/typecore.cmi \
+ typing/substmod.cmi typing/subst.cmi typing/scopedtree.cmi \
+ typing/path.cmi parsing/location.cmo typing/listextra.cmi \
+ typing/infercore.cmi typing/ident.cmi typing/envtype.cmi
+typing/infermod.cmx: typing/typedtree.cmi typing/typecore.cmx \
+ typing/substmod.cmx typing/subst.cmx typing/scopedtree.cmi \
+ typing/path.cmx parsing/location.cmx typing/listextra.cmx \
+ typing/infercore.cmx typing/ident.cmx typing/envtype.cmx
+typing/inputpt.cmo: typing/typedtree.cmi typing/stdlibpath.cmo \
+ typing/path.cmi typing/ident.cmi typing/freevars.cmo typing/files.cmo \
+ typing/envtype.cmi typing/envscope.cmi
+typing/inputpt.cmx: typing/typedtree.cmi typing/stdlibpath.cmx \
+ typing/path.cmx typing/ident.cmx typing/freevars.cmx typing/files.cmx \
+ typing/envtype.cmx typing/envscope.cmx
+typing/listextra.cmo: typing/listextra.cmi
+typing/listextra.cmx: typing/listextra.cmi
+typing/modscope.cmo: typing/scopedtree.cmi parsing/parsetree.cmi \
+ parsing/location.cmo typing/envscope.cmi typing/corescope.cmi \
+ typing/modscope.cmi
+typing/modscope.cmx: typing/scopedtree.cmi parsing/parsetree.cmi \
+ parsing/location.cmx typing/envscope.cmx typing/corescope.cmx \
+ typing/modscope.cmi
+typing/outputp.cmo: typing/typedtree.cmi typing/inputpt.cmo \
+ typing/freevars.cmo typing/files.cmo typing/envscope.cmi
+typing/outputp.cmx: typing/typedtree.cmi typing/inputpt.cmx \
+ typing/freevars.cmx typing/files.cmx typing/envscope.cmx
+typing/path.cmo: typing/ident.cmi typing/path.cmi
+typing/path.cmx: typing/ident.cmx typing/path.cmi
+typing/printbasic.cmo: parsing/longident.cmo parsing/asttypes.cmi \
+ typing/printbasic.cmi
+typing/printbasic.cmx: parsing/longident.cmx parsing/asttypes.cmx \
+ typing/printbasic.cmi
+typing/printmod.cmo: typing/typedtree.cmi typing/printtypes.cmi \
+ typing/printbasic.cmi typing/path.cmi typing/ident.cmi \
+ typing/printmod.cmi
+typing/printmod.cmx: typing/typedtree.cmi typing/printtypes.cmx \
+ typing/printbasic.cmx typing/path.cmx typing/ident.cmx \
+ typing/printmod.cmi
+typing/printparse.cmo: typing/printbasic.cmi parsing/parsetree.cmi \
+ typing/printparse.cmi
+typing/printparse.cmx: typing/printbasic.cmx parsing/parsetree.cmi \
+ typing/printparse.cmi
+typing/printscope.cmo: typing/scopedtree.cmi typing/printbasic.cmi \
+ typing/path.cmi typing/ident.cmi typing/printscope.cmi
+typing/printscope.cmx: typing/scopedtree.cmi typing/printbasic.cmx \
+ typing/path.cmx typing/ident.cmx typing/printscope.cmi
+typing/printtypes.cmo: typing/typedtree.cmi typing/typecore.cmi \
+ typing/printbasic.cmi typing/path.cmi typing/ident.cmi \
+ typing/printtypes.cmi
+typing/printtypes.cmx: typing/typedtree.cmi typing/typecore.cmx \
+ typing/printbasic.cmx typing/path.cmx typing/ident.cmx \
+ typing/printtypes.cmi
+typing/stdlibpath.cmo:
+typing/stdlibpath.cmx:
+typing/subst.cmo: typing/path.cmi typing/ident.cmi typing/subst.cmi
+typing/subst.cmx: typing/path.cmx typing/ident.cmx typing/subst.cmi
+typing/substcore.cmo: typing/subst.cmi typing/scopedtree.cmi \
+ typing/substcore.cmi
+typing/substcore.cmx: typing/subst.cmx typing/scopedtree.cmi \
+ typing/substcore.cmi
+typing/substmod.cmo: typing/substcore.cmi typing/subst.cmi \
+ typing/scopedtree.cmi typing/substmod.cmi
+typing/substmod.cmx: typing/substcore.cmx typing/subst.cmx \
+ typing/scopedtree.cmi typing/substmod.cmi
+typing/substract.cmo: typing/typecore.cmi typing/scopedtree.cmi \
+ typing/path.cmi typing/envtype.cmi parsing/asttypes.cmi \
+ typing/substract.cmi
+typing/substract.cmx: typing/typecore.cmx typing/scopedtree.cmi \
+ typing/path.cmx typing/envtype.cmx parsing/asttypes.cmx \
+ typing/substract.cmi
+typing/topscope.cmo: typing/scopedtree.cmi parsing/parsetree.cmi \
+ typing/modscope.cmi typing/envscope.cmi typing/topscope.cmi
+typing/topscope.cmx: typing/scopedtree.cmi parsing/parsetree.cmi \
+ typing/modscope.cmx typing/envscope.cmx typing/topscope.cmi
+typing/typecore.cmo: typing/path.cmi typing/ident.cmi typing/typecore.cmi
+typing/typecore.cmx: typing/path.cmx typing/ident.cmx typing/typecore.cmi
+typing/corescope.cmi: typing/scopedtree.cmi parsing/parsetree.cmi \
+ typing/ident.cmi typing/envscope.cmi parsing/asttypes.cmi
+typing/envscope.cmi: typing/path.cmi parsing/longident.cmo typing/ident.cmi
+typing/envtype.cmi: typing/typedtree.cmi typing/typecore.cmi typing/path.cmi \
+ typing/ident.cmi
+typing/extendhandler.cmi: parsing/parsetree.cmi
+typing/ident.cmi:
+typing/infercore.cmi: typing/typedtree.cmi typing/typecore.cmi \
+ typing/scopedtree.cmi typing/path.cmi typing/ident.cmi \
+ parsing/asttypes.cmi
+typing/listextra.cmi:
+typing/modscope.cmi: typing/scopedtree.cmi parsing/parsetree.cmi \
+ typing/envscope.cmi
+typing/path.cmi: typing/ident.cmi
+typing/printbasic.cmi: parsing/longident.cmo parsing/asttypes.cmi
+typing/printmod.cmi: typing/typedtree.cmi
+typing/printparse.cmi: parsing/parsetree.cmi
+typing/printscope.cmi: typing/scopedtree.cmi typing/ident.cmi
+typing/printtypes.cmi: typing/typedtree.cmi typing/typecore.cmi \
+ typing/ident.cmi
+typing/scopedtree.cmi: typing/path.cmi parsing/location.cmo typing/ident.cmi \
+ parsing/asttypes.cmi
+typing/subst.cmi: typing/path.cmi typing/ident.cmi
+typing/substcore.cmi: typing/subst.cmi typing/scopedtree.cmi
+typing/substmod.cmi: typing/subst.cmi typing/scopedtree.cmi
+typing/substract.cmi: typing/typedtree.cmi typing/typecore.cmi \
+ typing/scopedtree.cmi typing/ident.cmi
+typing/topscope.cmi: typing/scopedtree.cmi parsing/parsetree.cmi \
+ typing/envscope.cmi
+typing/typecore.cmi: typing/path.cmi
+typing/typedtree.cmi: typing/typecore.cmi typing/scopedtree.cmi \
+ typing/path.cmi parsing/location.cmo typing/ident.cmi \
+ parsing/asttypes.cmi
+utils/ccomp.cmo: utils/misc.cmo utils/config.cmo utils/clflags.cmo
+utils/ccomp.cmx: utils/misc.cmx utils/config.cmx utils/clflags.cmx
+utils/clflags.cmo: utils/config.cmo
+utils/clflags.cmx: utils/config.cmx
+utils/config.cmo:
+utils/config.cmx:
+utils/misc.cmo:
+utils/misc.cmx:
+utils/nativeint.cmo:
+utils/nativeint.cmx:
+utils/tbl.cmo:
+utils/tbl.cmx:
+utils/terminfo.cmo:
+utils/terminfo.cmx:
1 .gitignore
@@ -0,0 +1 @@
+*.cm?
85 INSTALL
@@ -0,0 +1,85 @@
+ Installing Ocamlexc 1.0.1 on a Unix machine
+ -------------------------------------------
+
+
+Feb 2002: Initial release.
+Mar 2012: Make it compiling with OCaml 3.12.1 + very minor fix
+
+
+
+
+PREREQUISITES
+
+* The Objective Caml compiler version 2.0 or above
+* The OcamlTk package if you want to be able to use the graphical
+ browser to exploit the results of the analysis. This also means that
+ you need to have Tcl/Tk installed in order to get OcamlTk running.
+
+
+
+INSTALLATION INSTRUCTIONS
+
+0- Let's assume you already have Objective Caml and OcamlTk installed
+and properly set up.
+
+1- Configure the system if needed. From the top directory, edit the
+Makefile. Two variables may need to be changed:
+INSTALLDIR: where to install the software
+OCAMLKLIBDIR: where was installed your version of camltk
+
+NOTE: If you want to compile the software with a particular version of
+the Objective Caml that is installed somewhere else than in the
+regular path, you may also change the variable called BINDIR. In this
+case you should fill it with the path where your compiler is
+installed.
+
+
+2- From the top directory, do:
+
+ make all
+
+This builds the analyser in bytecode mode.
+You can then build the analyser in native code mode by doing:
+
+ make opt
+
+These phases are verbose; you may want to redirect the output to a file:
+
+ make all > log.bytc 2>&1 # in sh
+ make all >& log.bytc # in csh
+ make opt > log.opt 2>&1 # in sh
+ make opt >& log.opt # in csh
+
+NOTE: The bytecode and native code versions of the analyser provide
+the same results. The only difference is that the native code version
+will run faster. It's just a matter of how is compiled the software;
+it doesn't affect the results of the analyser itself.
+
+
+3- Install the software
+First become root. Then set default mask to 022 by doing:
+ umask 022
+
+Then, to install the bytecode version of the analyser, do:
+ make install
+
+If needed, to install the native code version of the analyser, just do:
+ make installopt
+
+
+4- Installation is complete. Time to clean up. From the toplevel
+directory, do "make clean".
+
+
+
+COMMON PROBLEMS AND THINGS TO DO:
+
+* The unix library is not completly handled. More accurately, the set
+of exceptions (Unix_error) that can be returned by the provided
+functions is not exact. We should read carefully read the Unix
+specifications to accurately report the exact set for each
+function. This will be done in a later version.
+
+* The printf library causes troubles with the type "format". This type
+is currently interpreted as a string rather than the builtin hack it
+really is. This causes .......
312 Makefile
@@ -0,0 +1,312 @@
+INSTALLDIR=/tmp/foobar
+
+
+OCAMLKLIBDIR=/usr/local/lib/ocaml/camltk/
+include $(OCAMLKLIBDIR)Makefile.camltk
+
+
+# Compiler part
+BINDIR=
+CAMLC=$(BINDIR)ocamlc
+CAMLOPT=$(BINDIR)ocamlopt
+CAMLCP=$(BINDIR)ocamlcp
+CAMLDEP=$(BINDIR)ocamldep
+CAMLLEX=$(BINDIR)ocamllex
+CAMLYACC=$(BINDIR)ocamlyacc
+
+
+
+# Flags part
+INCLUDEDIRS = -I parsing/ -I utils/ -I typing/ -I toplevel/ -I batch/ \
+ -I interface/
+DEPFLAGS = $(INCLUDEDIRS)
+COMPFLAG = -w A-4-6-9 -warn-error A $(INCLUDEDIRS) $(TKCOMPFLAGS)
+LINKFLAG =
+
+
+
+# Object part
+TOPOBJS = utils/misc.cmo utils/tbl.cmo utils/config.cmo utils/clflags.cmo \
+ utils/terminfo.cmo utils/ccomp.cmo \
+ \
+ parsing/linenum.cmo parsing/location.cmo parsing/longident.cmo \
+ parsing/asttypes.cmo parsing/syntaxerr.cmo parsing/pstream.cmo \
+ parsing/parser.cmo parsing/lexer.cmo parsing/parse.cmo \
+ \
+ typing/files.cmo typing/stdlibpath.cmo typing/listextra.cmo \
+ typing/ident.cmo typing/path.cmo typing/extendhandler.cmo \
+ typing/subst.cmo typing/printbasic.cmo typing/printparse.cmo \
+ typing/printscope.cmo typing/typecore.cmo typing/envscope.cmo \
+ typing/corescope.cmo typing/modscope.cmo typing/topscope.cmo \
+ typing/substcore.cmo typing/substmod.cmo typing/printtypes.cmo \
+ typing/envtype.cmo typing/inputpt.cmo typing/substract.cmo \
+ typing/freevars.cmo typing/outputp.cmo typing/infercore.cmo \
+ typing/printmod.cmo typing/infermod.cmo typing/error.cmo \
+ \
+ toplevel/main.cmo
+
+
+BATCHOBJS = utils/misc.cmo utils/tbl.cmo utils/config.cmo utils/clflags.cmo \
+ utils/terminfo.cmo utils/ccomp.cmo \
+ \
+ parsing/linenum.cmo parsing/location.cmo parsing/longident.cmo \
+ parsing/asttypes.cmo parsing/syntaxerr.cmo parsing/pstream.cmo \
+ parsing/parser.cmo parsing/lexer.cmo parsing/parse.cmo \
+ \
+ typing/files.cmo typing/stdlibpath.cmo typing/listextra.cmo \
+ typing/ident.cmo typing/path.cmo typing/extendhandler.cmo \
+ typing/subst.cmo typing/printbasic.cmo typing/printparse.cmo \
+ typing/printscope.cmo typing/typecore.cmo typing/envscope.cmo \
+ typing/corescope.cmo typing/modscope.cmo typing/topscope.cmo \
+ typing/substcore.cmo typing/substmod.cmo typing/printtypes.cmo \
+ typing/envtype.cmo typing/inputpt.cmo typing/substract.cmo \
+ typing/freevars.cmo typing/outputp.cmo typing/infercore.cmo \
+ typing/printmod.cmo typing/infermod.cmo typing/error.cmo \
+ \
+ batch/main.cmo
+
+
+LINKOBJS = utils/misc.cmo utils/tbl.cmo utils/config.cmo utils/clflags.cmo \
+ utils/terminfo.cmo utils/ccomp.cmo \
+ \
+ parsing/linenum.cmo parsing/location.cmo parsing/longident.cmo \
+ parsing/asttypes.cmo parsing/syntaxerr.cmo parsing/pstream.cmo \
+ parsing/parser.cmo parsing/lexer.cmo parsing/parse.cmo \
+ \
+ typing/files.cmo typing/stdlibpath.cmo typing/listextra.cmo \
+ typing/ident.cmo typing/path.cmo typing/extendhandler.cmo \
+ typing/subst.cmo typing/printbasic.cmo typing/printparse.cmo \
+ typing/printscope.cmo typing/typecore.cmo typing/envscope.cmo \
+ typing/corescope.cmo typing/modscope.cmo typing/topscope.cmo \
+ typing/substcore.cmo typing/substmod.cmo typing/printtypes.cmo \
+ typing/envtype.cmo typing/inputpt.cmo typing/substract.cmo \
+ typing/freevars.cmo typing/outputp.cmo typing/infercore.cmo \
+ typing/printmod.cmo typing/infermod.cmo typing/error.cmo \
+ \
+ link/main.cmo
+
+
+INTERFACEOBJS = utils/misc.cmo utils/tbl.cmo utils/config.cmo \
+ utils/clflags.cmo utils/terminfo.cmo utils/ccomp.cmo \
+ \
+ parsing/linenum.cmo parsing/location.cmo parsing/longident.cmo \
+ parsing/asttypes.cmo parsing/syntaxerr.cmo parsing/pstream.cmo \
+ parsing/parser.cmo parsing/lexer.cmo parsing/parse.cmo \
+ \
+ typing/files.cmo typing/stdlibpath.cmo typing/listextra.cmo \
+ typing/ident.cmo typing/path.cmo typing/extendhandler.cmo \
+ typing/subst.cmo typing/printbasic.cmo typing/printparse.cmo \
+ typing/printscope.cmo typing/typecore.cmo typing/envscope.cmo \
+ typing/corescope.cmo typing/modscope.cmo typing/topscope.cmo \
+ typing/substcore.cmo typing/substmod.cmo \
+ interface/tklowprint.cmo interface/tkprinttypes.cmo \
+ typing/printtypes.cmo typing/envtype.cmo typing/inputpt.cmo \
+ typing/substract.cmo typing/freevars.cmo typing/outputp.cmo \
+ typing/infercore.cmo interface/tkprintmod.cmo \
+ typing/infermod.cmo typing/error.cmo \
+ \
+ interface/global.cmo interface/tkloadsrc.cmo \
+ interface/preferences.cmo interface/rootwindow.cmo \
+ interface/modselector.cmo interface/main.cmo
+
+
+
+# Sources part
+GENERATEDSRCS = parsing/linenum.ml parsing/parser.ml parsing/lexer.ml
+
+
+TOPSRCS = $(GENERATEDSRCS) \
+ parsing/location.ml parsing/longident.ml parsing/syntaxerr.ml \
+ parsing/asttypes.ml parsing/pstream.ml parsing/parse.ml \
+ \
+ utils/misc.ml utils/tbl.ml utils/config.ml utils/clflags.ml \
+ utils/terminfo.ml utils/ccomp.ml \
+ \
+ typing/files.ml typing/stdlibpath.ml typing/listextra.ml \
+ typing/ident.ml typing/path.ml typing/subst.ml typing/envscope.ml \
+ typing/corescope.ml typing/extendhandler.ml typing/modscope.ml \
+ typing/topscope.ml typing/printbasic.ml typing/printparse.ml \
+ typing/printscope.ml typing/typecore.ml typing/substcore.ml \
+ typing/inputpt.ml typing/substmod.ml typing/envtype.ml \
+ typing/printtypes.ml typing/substract.ml typing/freevars.ml \
+ typing/outputp.ml typing/infermod.ml typing/infercore.ml \
+ typing/printmod.ml typing/error.ml \
+ \
+ toplevel/main.ml
+
+
+BATCHSRCS = $(GENERATEDSRCS) \
+ parsing/location.ml parsing/longident.ml parsing/syntaxerr.ml \
+ parsing/asttypes.ml parsing/pstream.ml parsing/parse.ml \
+ \
+ utils/misc.ml utils/tbl.ml utils/config.ml utils/clflags.ml \
+ utils/terminfo.ml utils/ccomp.ml \
+ \
+ typing/files.ml typing/stdlibpath.ml typing/listextra.ml \
+ typing/ident.ml typing/path.ml typing/subst.ml typing/envscope.ml \
+ typing/corescope.ml typing/extendhandler.ml typing/modscope.ml \
+ typing/topscope.ml typing/printbasic.ml typing/printparse.ml \
+ typing/printscope.ml typing/typecore.ml typing/substcore.ml \
+ typing/inputpt.ml typing/substmod.ml typing/envtype.ml \
+ typing/printtypes.ml typing/substract.ml typing/freevars.ml \
+ typing/outputp.ml typing/infermod.ml typing/infercore.ml \
+ typing/printmod.ml typing/error.ml \
+ \
+ batch/main.ml
+
+
+LINKSRCS = parsing/location.ml parsing/longident.ml parsing/syntaxerr.ml \
+ parsing/asttypes.ml parsing/pstream.ml parsing/parse.ml \
+ \
+ utils/misc.ml utils/tbl.ml utils/config.ml utils/clflags.ml \
+ utils/terminfo.ml utils/ccomp.ml \
+ \
+ typing/files.ml typing/stdlibpath.ml typing/listextra.ml \
+ typing/ident.ml typing/path.ml typing/subst.ml typing/envscope.ml \
+ typing/corescope.ml typing/extendhandler.ml typing/modscope.ml \
+ typing/topscope.ml typing/printbasic.ml typing/printparse.ml \
+ typing/printscope.ml typing/typecore.ml typing/substcore.ml \
+ typing/inputpt.ml typing/substmod.ml typing/envtype.ml \
+ typing/printtypes.ml typing/substract.ml typing/freevars.ml \
+ typing/outputp.ml typing/infermod.ml typing/infercore.ml \
+ typing/printmod.ml typing/error.ml \
+ \
+ link/main.ml
+
+
+INTERFACESRCS = parsing/location.ml parsing/longident.ml parsing/syntaxerr.ml \
+ parsing/asttypes.ml parsing/pstream.ml parsing/parse.ml \
+ \
+ utils/misc.ml utils/tbl.ml utils/config.ml utils/clflags.ml \
+ utils/terminfo.ml utils/ccomp.ml \
+ \
+ typing/files.ml typing/stdlibpath.ml typing/listextra.ml \
+ typing/ident.ml typing/path.ml typing/subst.ml typing/envscope.ml \
+ typing/corescope.ml typing/extendhandler.ml typing/modscope.ml \
+ typing/topscope.ml typing/printbasic.ml typing/printparse.ml \
+ typing/printscope.ml typing/typecore.ml typing/substcore.ml \
+ typing/inputpt.ml typing/substmod.ml typing/envtype.ml \
+ interface/printcontext.mli \
+ interface/tkprinttypes.ml typing/printtypes.ml typing/substract.ml \
+ typing/freevars.ml typing/outputp.ml typing/infermod.ml \
+ typing/infercore.ml interface/tkprintmod.ml typing/error.ml \
+ \
+ interface/global.ml interface/tklowprint.ml interface/tkloadsrc.ml \
+ interface/preferences.ml interface/rootwindow.ml \
+ interface/modselector.ml interface/main.ml
+
+
+
+# Exec file names
+TOPNAME = bin/ocamlexc
+BATCHNAME = bin/ocamlexcc
+LINKNAME = bin/ocamlexcl
+INTERFACENAME = bin/ocamlexcli
+
+
+# *******************************************************************
+# Avanti...
+
+# Building the world (but the toplevel)
+all: batch link toplevel interface
+opt: batchopt linkopt toplevelopt interfaceopt
+
+install: batch link toplevel interface stdlibcme
+ cp -R bin $(INSTALLDIR)
+ ln -s $(INSTALLDIR)/bin/batch /usr/local/bin/batch
+ ln -s $(INSTALLDIR)/bin/link /usr/local/bin/link
+ ln -s $(INSTALLDIR)/bin/toplevel /usr/local/bin/toplevel
+ ln -s $(INSTALLDIR)/bin/interface /usr/local/bin/interface
+ cp -R stdlib $(INSTALLDIR)
+
+installopt: batchopt linkopt toplevelopt interfaceopt stdlibcme
+ cp -R bin $(INSTALLDIR)
+ ln -s $(INSTALLDIR)/bin/batchopt /usr/local/bin/batch.opt
+ ln -s $(INSTALLDIR)/bin/linkopt /usr/local/bin/link.opt
+ ln -s $(INSTALLDIR)/bin/toplevelopt /usr/local/bin/toplevel.opt
+ ln -s $(INSTALLDIR)/bin/interfaceopt /usr/local/bin/interface.opt
+ cp -R stdlib $(INSTALLDIR)
+
+stdlibcme:
+ ./bin/makelibcme
+
+
+toplevel: $(TOPOBJS)
+ $(CAMLC) $(LINKFLAG) $(TOPOBJS) -o $(TOPNAME)
+
+batch: $(BATCHOBJS)
+ $(CAMLC) $(LINKFLAG) $(BATCHOBJS) -o $(BATCHNAME)
+
+link: $(LINKOBJS)
+ $(CAMLC) $(LINKFLAG) $(LINKOBJS) -o $(LINKNAME)
+
+interface: $(INTERFACEOBJS)
+ $(CAMLC) -custom unix.cma $(WITH_TK) $(INTERFACEOBJS) \
+ -cclib -lunix -o $(INTERFACENAME)
+
+
+
+toplevelopt: $(TOPOBJS:.cmo=.cmx)
+ $(CAMLOPT) $(LINKFLAG) $(TOPOBJS:.cmo=.cmx) -o $(TOPNAME).opt
+
+batchopt: $(BATCHOBJS:.cmo=.cmx)
+ $(CAMLOPT) $(LINKFLAG) $(BATCHOBJS:.cmo=.cmx) -o $(BATCHNAME).opt
+
+linkopt: $(LINKOBJS:.cmo=.cmx)
+ $(CAMLOPT) $(LINKFLAG) $(LINKOBJS:.cmo=.cmx) -o $(LINKNAME).opt
+
+interfaceopt: $(INTERFACEOBJS:.cmo=.cmx)
+ $(CAMLOPT) unix.cmxa $(WITH_TK_OPT) $(INTERFACEOBJS:.cmo=.cmx)\
+ -cclib -lunix -o $(INTERFACENAME).opt
+
+
+
+parsing/parser.mli parsing/parser.ml: parsing/parser.mly
+ $(CAMLYACC) parsing/parser.mly
+
+parsing/lexer.ml: parsing/lexer.mll
+ $(CAMLLEX) parsing/lexer.mll
+
+parsing/linenum.ml: parsing/linenum.mll
+ $(CAMLLEX) parsing/linenum.mll
+
+
+.SUFFIXES: .ml .mli .cmo .cmi .cmx
+
+.ml.cmo:
+ $(CAMLC) $(COMPFLAG) -c $<
+
+.mli.cmi:
+ $(CAMLC) $(COMPFLAG) -c $<
+
+.ml.cmx:
+ $(CAMLOPT) $(COMPFLAG) -c $<
+
+
+# Clean up
+clean:
+ rm -f parsing/*.cm[iox] parsing/*.o parsing/*~
+ rm -f parsing/parser.mli
+ rm -f utils/*.cm[iox] utils/*.o utils/*~
+ rm -f typing/*.cm[iox] typing/*.o typing/*~
+ rm -f toplevel/*.cm[iox] toplevel/*.o toplevel/*~
+ rm -f batch/*.cm[iox] batch/*.o batch/*~
+ rm -f link/*.cm[iox] link/*.o link/*~
+ rm -f interface/*.cm[iox] interface/*.o interface/*~
+ rm -f oldlib/*.cme oldlib/*~
+ rm -f stdlib/*.cme stdlib/*~
+ rm -f tests/*.cme tests/*/*.cme
+ rm -f $(GENERATEDSRCS)
+ rm -f $(TOPNAME) $(BATCHNAME) $(LINKNAME) $(INTERFACENAME)
+ rm -f $(TOPNAME).opt $(BATCHNAME).opt $(LINKNAME).opt \
+ $(INTERFACENAME).opt
+ rm -f *~
+
+# Dependencies
+depend: $(GENERATEDSRCS)
+ $(CAMLDEP) $(DEPFLAGS) batch/*.ml{,i} interface/*.ml{,i} \
+ link/*.ml{,i} parsing/*.ml{,i} toplevel/*.ml{,i} \
+ typing/*.ml{,i} utils/*.ml{,i} > .depend
+
+include .depend
+# DO NOT DELETE
39 Makefile.example
@@ -0,0 +1,39 @@
+FLAGS = -I stdlib/ -I mydir1/ -I mydir2/ -I mydir3/
+CAMLEXCC = ocamlexcc
+CAMLEXCL = ocamlexcl
+
+
+# ----------------------------------------------------------------------------
+
+STDLIB = stdlib/pervasives.cme stdlib/list.cme stdlib/char.cme \
+ stdlib/string.cme stdlib/sort.cme \
+ stdlib/array.cme stdlib/hashtbl.cme \
+ stdlib/marshal.cme stdlib/obj.cme stdlib/printf.cme \
+ stdlib/sys.cme stdlib/arg.cme \
+ stdlib/filename.cme stdlib/gc.cme \
+ stdlib/stream.cme stdlib/format.cme \
+ stdlib/lexing.cme stdlib/parsing.cme
+
+MYCMES = mydir1/mfile1.cme mydir2/mfile2.cme mydir3/myfile3.cme
+
+
+# ----------------------------------------------------------------------------
+
+MYSRCS = mydir1/mfile1.ml mydir2/mfile2.ml mydir3/myfile3.ml
+
+all: $(STDLIB) $(MYCMES)
+ $(CAMLEXCL) $(FLAGS) $(STDLIB) $(MYCMES)
+
+.SUFFIXES: .ml .mli .cme
+
+.ml.cme:
+ $(CAMLEXCC) $(FLAGS) $<
+
+.mli.cme:
+ $(CAMLEXCC) $(FLAGS) $<
+
+
+clean:
+ rm -f mydir1/*.cme
+ rm -f mydir2/*.cme
+ rm -f mydir3/*.cme
15 README.txt
@@ -0,0 +1,15 @@
+ocamlexc: OCaml Uncaught Exception Analyser
+===========================================
+
+
+March 9, 2012:
+-------------
+This is version 1.01.
+It has been updated to use ocaml 3.12 parser. However, new constructs
+made available after ocaml 3.00 are not implemented.
+
+Documentation coming soon.
+
+Dependencies:
+-------------
+- you need ocamltk (not labltk) installed (see other rep).
134 batch/main.ml
@@ -0,0 +1,134 @@
+(***********************************************************************)
+(* *)
+(* Ocamlexc *)
+(* *)
+(* Francois Pessaux, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1998 Institut National de Recherche en Informatique et *)
+(* Automatique. Distributed only by permission. *)
+(* *)
+(***********************************************************************)
+
+
+
+
+open Format ;;
+
+
+(* Bool telling if we must load pervasives in standard or not *)
+let std_perv = ref true ;;
+
+
+
+(* Main loop *)
+let main filename =
+ Files.current_comp_unit := Files.module_name_from_ml_filename filename ;
+ let channel = open_in filename in
+ let lexbuf = Lexing.from_channel channel in
+ try
+ (* First, load Pervasives if not compiling the Pervasives module *)
+ (* or if pervasives are not wanted. *)
+ if Filename.basename filename <> "pervasives.ml" && !std_perv then
+ begin
+ Envscope.global_scope_env :=
+ Envscope.handle_open_directive
+ !Envscope.global_scope_env
+ (Path.Pident (Ident.create_global "Pervasives")) ;
+ Inputpt.load [Ident.create_global "Pervasives"]
+ end ;
+ (* Now parse the file *)
+ let structure = Parse.implementation lexbuf in
+ (* Extend handlers *)
+ let extended_structure =
+ Extendhandler.extend_structure_handler structure in
+ (* Only scope the module *)
+ let (scoped_structure, new_scenv) = Modscope.scope_structure
+ !Envscope.global_scope_env
+ extended_structure in
+ (* Load external signatures found during scoping. *)
+ (* This update the global typing environment by side effect. *)
+ Inputpt.load (Envscope.get_compil_units_to_load ()) ;
+ (* Now let's type... *)
+ let (typed_structure, struct_signature) = Infermod.infer_structure
+ !Envtype.global_type_env
+ scoped_structure in
+ (* Change all uses of types in this module by prefixing them *)
+ (* with their full path, i.e the module name that will be *)
+ (* generated by considering this compilation unit as a module. *)
+ Infermod.prefix_structure
+ (Path.Pident (Ident.create_global !Files.current_comp_unit))
+ typed_structure ;
+ (* Retrieve scoping information for the interior of the module *)
+ let mod_scope_info = Envscope.diff new_scenv !Envscope.global_scope_env in
+ (* Generate the persistent file containing the result of the analysis. *)
+ Outputp.output filename mod_scope_info struct_signature typed_structure
+ with
+ | End_of_file -> close_in channel ; exit 0
+ | Lexer.Error (err, start, stop) ->
+ Error.handle_lexing_error err start stop ; exit 2
+ | Syntaxerr.Error err ->
+ Error.handle_parsing_error err ; exit 2
+ | Envscope.Scope_error err ->
+ Error.handle_scoping_error err ; exit 2
+ | Typecore.Conflict (ty0, ty1) ->
+ Error.handle_unification_error ty0 ty1 ; exit 2
+ | Typecore.Non_regular_datatype (ty0, ty1) ->
+ Error.handle_circularization_error ty0 ty1
+ | Envtype.Type_error err ->
+ Error.handle_typing_error err ; exit 2
+ | Infercore.Constructor_arity_error path ->
+ fprintf std_formatter "Invalid arity for constructor '%a' use\n"
+ Path.pp_path path ;
+ exit 2
+ | Infercore.Unbound_type_variable var_name ->
+ fprintf std_formatter "Unbound type variable %s\n" var_name ; exit 2
+ | Infercore.Type_arity_error path ->
+ fprintf std_formatter "Bad arity for type %a use\n" Path.pp_path path ;
+ exit 2
+ | Infercore.Bad_labels_number ->
+ fprintf std_formatter "Bad # of labels in record\n" ; exit 2
+ | Infercore.Field_not_mutable lbl_path ->
+ fprintf std_formatter "Label %a is not mutable\n"
+ Path.pp_path lbl_path ;
+ exit 2
+ | Substract.Unused_pattern ->
+ fprintf std_formatter "A pattern is unused.\n" ; exit 2
+ | Corescope.Or_pattern_must_not_bind ->
+ fprintf std_formatter "Or patterns must not bind variables.\n" ; exit 2
+ | Infercore.Expansion_required_in_primitive path ->
+ fprintf std_formatter "Please expand beforehand abbreviation for type '%a' in external definition\n" Path.pp_path path ;
+ exit 2
+ | Infercore.Invalid_equiv_in_variant_type ->
+ fprintf std_formatter "Invalid type equivalence in manifest sum\n" ;
+ exit 2
+;;
+
+
+
+
+(* Let's run... *)
+let filename = ref None ;;
+Arg.parse
+ [ ("-I", Arg.String
+ (fun path ->
+ let path = path ^ "/" in
+ Stdlibpath.std_lib_path := path :: !Stdlibpath.std_lib_path),
+ "Path to stdlib") ;
+ ("-noperv", Arg.Unit (fun () -> std_perv := false), "Disable pervs") ]
+ (fun fname ->
+ if not ((Filename.check_suffix fname ".ml")
+ || (Filename.check_suffix fname ".mli")) then
+ begin
+ fprintf std_formatter "Invalid filename (.ml(i) missing)\n" ;
+ exit 0
+ end ;
+ filename := Some fname)
+ "Ocamlexc 1.0.1 - Uncaught exceptions analyser - First pass" ;;
+Envscope.load_scopes () ;;
+Envtype.load_types () ;;
+Stdlibpath.std_lib_path := List.rev ("./" :: !Stdlibpath.std_lib_path) ;;
+let _ =
+ match !filename with
+ | None -> ()
+ | Some fname -> main fname
+;;
17 bin/makelibcme
@@ -0,0 +1,17 @@
+STDLIB='stdlib/pervasives.ml stdlib/list.ml stdlib/char.ml stdlib/string.ml stdlib/sort.ml stdlib/array.ml stdlib/hashtbl.ml stdlib/digest.ml stdlib/random.ml stdlib/marshal.ml stdlib/obj.ml stdlib/printf.ml stdlib/sys.ml stdlib/arg.ml stdlib/queue.ml stdlib/callback.ml stdlib/filename.ml stdlib/gc.ml stdlib/map.ml stdlib/set.ml stdlib/stack.ml stdlib/weak.ml stdlib/stream.ml stdlib/format.ml stdlib/genlex.ml stdlib/lexing.ml stdlib/parsing.ml stdlib/printexc.ml'
+
+UNIX='stdlib/unix.ml'
+
+STR='stdlib/str.ml'
+
+for i in $STDLIB
+do
+echo "Analysing: " $i "..."
+./bin/ocamlexcc -I stdlib $i
+echo "DONE"
+done
+
+echo "Analysing extra libs (Unix and Str)"
+./bin/ocamlexcc -I stdlib $UNIX
+./bin/ocamlexcc -I stdlib $STR
+echo "DONE"
24 interface/global.ml
@@ -0,0 +1,24 @@
+(***********************************************************************)
+(* *)
+(* Ocamlexc *)
+(* *)
+(* Francois Pessaux, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1998 Institut National de Recherche en Informatique et *)
+(* Automatique. Distributed only by permission. *)
+(* *)
+(***********************************************************************)
+
+
+
+let top_w = Tk.openTk () ;;
+
+let link_files = ref ([] : string list) ;;
+let syntax_trees = ref ([] : (Path.t * Typedtree.structure) list) ;;
+let modules_sources = ref ([] : (string * string) list) ;;
+
+
+type mode =
+ | Syntaxdisplay
+ | Typedisplay
+;;
138 interface/main.ml
@@ -0,0 +1,138 @@
+(***********************************************************************)
+(* *)
+(* Ocamlexc *)
+(* *)
+(* Francois Pessaux, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1998 Institut National de Recherche en Informatique et *)
+(* Automatique. Distributed only by permission. *)
+(* *)
+(***********************************************************************)
+
+
+
+
+open Tk ;;
+open Format ;;
+
+
+
+let tk_report_error msg =
+ Wm.title_set Global.top_w "Error report" ;
+ let label_w = Label.create Global.top_w [Text msg] in
+ let button_w = Button.create Global.top_w [Text "Quit";
+ Command (fun _ -> exit (-1))] in
+ pack [label_w; button_w] [] ;
+ mainLoop ()
+;;
+
+
+
+
+let finish_unification (mod_ident, instanciations) =
+ let original_module_vars =
+ (try List.assoc mod_ident !Inputpt.loaded_compunits_nf_variables
+ with Not_found ->
+ tk_report_error ("Please load module "^(Ident.name mod_ident)^" first") ;
+ []) in
+ List.iter2
+ (fun bnd1 bnd2 ->
+ match (bnd1, bnd2) with
+ | (Freevars.Persist_rowv v1, Freevars.Persist_rowv v2) ->
+ Typecore.unify_phi_type
+ { Typecore.phi_value = Typecore.Pexplicit ([], v1) ;
+ Typecore.phi_print = false ;
+ Typecore.phi_empty = true }
+ { Typecore.phi_value = Typecore.Pexplicit ([], v2) ;
+ Typecore.phi_print = false ;
+ Typecore.phi_empty = true }
+ | (Freevars.Persist_pres v1, Freevars.Persist_pres v2) ->
+ Typecore.unify_presence v1 v2
+ | (Freevars.Persist_mlv ty1, Freevars.Persist_mlv ty2) ->
+ Typecore.unify_ml_type ty1 ty2
+ | (_, _) -> assert false)
+ original_module_vars instanciations
+;;
+
+
+
+
+(* Now the job is : *)
+(* - load each module (the .cme file) *)
+(* - get its interface and insert it a a module in the environment *)
+(* - get its non free variables and add it to the global assoc list *)
+(* - get its instanciations on external compilation units *)
+(* - for each of these external compilation units, unify these *)
+(* instanciations with the non instanciated version of the variables *)
+(* At the end of the work, signatures in the typing environment are *)
+(* modified by side effect, and we can read them as final result. *)
+let load_cme_file_in_linker cme_filename =
+ let module_name = Files.module_name_from_cme_filename cme_filename in
+ let module_ident = Ident.create_global module_name in
+ let in_channel = Stdlibpath.open_in_with_path cme_filename in
+ (* Loading ... *)
+ let (
+ (_ : string),
+ (non_free_variables : Freevars.persistent_binding list),
+ _,
+ (module_sig : Typedtree.signature),
+ (external_instanciations :
+ (Freevars.persistent_binding list) Inputpt.assoclist),
+ (syntax_tree : Typedtree.structure)
+ ) = input_value in_channel in
+ close_in in_channel ;
+ (* Update the global typing environment *)
+ Envtype.global_type_env := Envtype.add_module
+ module_ident
+ (Typedtree.Tmty_signature module_sig)
+ !Envtype.global_type_env ;
+ (* Update the assoc list recording trees of modules *)
+ Global.syntax_trees := ((Path.Pident module_ident), syntax_tree)
+ :: !Global.syntax_trees ;
+ (* Update the assoc list recording sources of modules *)
+ Global.modules_sources :=
+ (module_name , Files.ml_filename_from_cme_filename cme_filename)
+ :: !Global.modules_sources ;
+ (* Update the assoc list binding modules (compilation units) *)
+ (* to their non free variables. *)
+ Inputpt.loaded_compunits_nf_variables :=
+ (module_ident, non_free_variables)
+ :: !Inputpt.loaded_compunits_nf_variables ;
+ (* For all external compilation units, unify the *)
+ (* original variables with those we just found. *)
+ List.iter finish_unification external_instanciations
+;;
+
+
+
+let main () =
+ Arg.parse
+ [ ("-I", Arg.String
+ (fun path ->
+ let path = path ^ "/" in
+ Stdlibpath.std_lib_path := path :: !Stdlibpath.std_lib_path),
+ "Path to stdlib") ;
+ ("-forcevars", Arg.Unit (fun () -> Tkprinttypes.force_vars_print := true),
+ "Force \"empty\" vars to be displayed") ]
+ (fun filename -> Global.link_files := filename :: !Global.link_files)
+ "Ocamlexc 1.0 - Uncaught exceptions analyser - Second pass - (Graphical interface)" ;
+ (* Reverse files list to get dependancies order *)
+ Global.link_files := List.rev !Global.link_files ;
+ try
+ (* Initialize environments with builtin definitions *)
+ Envscope.load_scopes () ;
+ Envtype.load_types () ;
+ Stdlibpath.std_lib_path := List.rev ("./" :: !Stdlibpath.std_lib_path) ;
+ List.iter load_cme_file_in_linker !Global.link_files ;
+ Preferences.load_preferences () ;
+ Modselector.create Global.top_w ;
+ mainLoop ()
+ with
+ | Files.Not_ml_file f -> tk_report_error ("File '"^f^"' is not a ML file")
+ | Files.Not_cme_file f -> tk_report_error ("File '"^f^"' is not a CME file")
+ | Sys_error msg -> tk_report_error msg
+;;
+
+
+
+main () ;;
85 interface/modselector.ml
@@ -0,0 +1,85 @@
+(***********************************************************************)
+(* *)
+(* Ocamlexc *)
+(* *)
+(* Francois Pessaux, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1998 Institut National de Recherche en Informatique et *)
+(* Automatique. Distributed only by permission. *)
+(* *)
+(***********************************************************************)
+
+
+
+open Tk ;;
+
+
+let select_module_bnd parent_w listb_w =
+ Toplevel.configure parent_w [Cursor (XCursor "watch")] ; update () ;
+ begin
+ match Listbox.curselection listb_w with
+ | [] -> ()
+ | h :: _ ->
+ let mod_name = Listbox.get listb_w h in
+ let mod_ident = Ident.create_global mod_name in
+ let mod_path = Path.Pident mod_ident in
+ let module_source = List.assoc mod_name !Global.modules_sources in
+ let new_window1 = Toplevel.create parent_w [] in
+ let new_window2 = Toplevel.create parent_w [] in
+ Rootwindow.create new_window1 mod_path
+ module_source Global.Syntaxdisplay ;
+ Rootwindow.create new_window2 mod_path module_source Global.Typedisplay
+ end ;
+ Toplevel.configure parent_w [Cursor (XCursor "")] ; update () ;
+;;
+
+
+
+let create parent_w =
+ Wm.title_set parent_w "Compilations units" ;
+ (* Containers *)
+ let frame2_w = Frame.create parent_w [] in
+ let frame0_w = Frame.create parent_w [] in
+ let frame1_w = Frame.create parent_w [] in
+ (* Menu *)
+ let mbut0_w = Menubutton.create frame2_w [Text "Misc";
+ UnderlinedChar 0] in
+ let menu0_w = Menu.create mbut0_w [] in
+ Menu.add_command menu0_w [Label "Preferences";
+ Command (fun _->
+ Preferences.open_pref_window parent_w) ;
+ UnderlinedChar 0] ;
+ Menubutton.configure mbut0_w [Menu menu0_w] ;
+ (* Listbox containing all linked files *)
+ let listb0_w = Listbox.create frame0_w [TextWidth 30; TextHeight 10] in
+ (* Scrollbar for this listbox *)
+ let scroll0_w = Scrollbar.create frame0_w [Orient Vertical] in
+ (* Quit button *)
+ let butt0_w = Button.create frame1_w
+ [Text "Quit"; Command (fun _ -> exit 0)] in
+ (* Link scrollbar and listbox together *)
+ Listbox.configure listb0_w [YScrollCommand (Scrollbar.set scroll0_w)] ;
+ Scrollbar.configure scroll0_w [ScrollCommand (Listbox.yview listb0_w)] ;
+ (* Initialize listbox content *)
+ let mod_names = List.map
+ (fun n -> String.capitalize (Filename.basename (Filename.chop_extension n)))
+ !Global.link_files in
+ Listbox.insert listb0_w End mod_names ;
+ (* Set bindings for the listbox *)
+ bind listb0_w [([Double], ButtonPressDetail 1)]
+ (BindSet ([], (fun _ -> select_module_bnd parent_w listb0_w))) ;
+ bind listb0_w [([], KeyPressDetail "Return")]
+ (BindSet ([], (fun _ -> select_module_bnd parent_w listb0_w))) ;
+ (* Set the focus *)
+ Focus.set listb0_w ;
+ Listbox.activate listb0_w (Number 0) ;
+ Listbox.selection_set listb0_w (Number 0) (Number 0) ;
+ (* Finally pack the whole stuff *)
+ pack [frame2_w] [Side Side_Top; Fill Fill_Both] ;
+ pack [frame0_w] [Side Side_Top; Expand true ; Fill Fill_Both] ;
+ pack [frame1_w] [Side Side_Top; Fill Fill_X] ;
+ pack [mbut0_w] [Side Side_Right] ;
+ pack [listb0_w] [Side Side_Left; Expand true; Fill Fill_Both] ;
+ pack [scroll0_w] [Expand true; Fill Fill_Y] ;
+ pack [butt0_w] [Fill Fill_X]
+;;
241 interface/preferences.ml
@@ -0,0 +1,241 @@
+(***********************************************************************)
+(* *)
+(* Ocamlexc *)
+(* *)
+(* Francois Pessaux, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1998 Institut National de Recherche en Informatique et *)
+(* Automatique. Distributed only by permission. *)
+(* *)
+(***********************************************************************)
+
+
+
+open Tk ;;
+
+
+type preferences = {
+ mutable val_tag_color: int ;
+ mutable type_tag_color: int ;
+ mutable module_tag_color: int ;
+ mutable constructor_tag_color: int ;
+ mutable label_tag_color: int ;
+ mutable where_tag_color: int ;
+ mutable background_tag_color: int
+} ;;
+
+
+
+(* Fonction chargee de retrouver le home directory de l'utilisateur. *)
+(* On recherche sont uid et on va parser le /etc/passwd pour retrouver *)
+(* le champ homedir correspondant. *)
+exception No_home_dir ;;
+let gethomedir () =
+ let uid = Unix.getuid () in
+ let etc_passwd = try open_in "/etc/passwd" with _ -> raise No_home_dir in
+ let home_dir = ref "" in
+ try
+ while !home_dir = "" do
+ let line = input_line etc_passwd in
+ (* Saute au password *)
+ let i = String.index line ':' in
+ (* Saute au debut de l'uid *)
+ let i' = String.index_from line (i + 1) ':' in
+ (* Saute au debut du gid *)
+ let i'' = String.index_from line (i' + 1) ':' in
+ let id_string = String.sub line (i' + 1) (i'' - i' - 1) in
+ let id = int_of_string id_string in
+ if id = uid then
+ begin
+ (* Saute a la fin du gid *)
+ let i3 = String.index_from line (i'' + 1) ':' in
+ (* Saute au debut du homedir *)
+ let i4 = String.index_from line (i3 + 1) ':' in
+ (* Fin du homedir *)
+ let i5 = String.index_from line (i4 + 1) ':' in
+ home_dir := String.sub line (i4 + 1) (i5 - i4 - 1) ;
+ end
+ done ;
+ close_in etc_passwd ;
+ !home_dir
+ with _ -> raise No_home_dir
+;;
+
+
+
+let tk_color_of_int i =
+ NamedColor (Printf.sprintf "#%06x" i)
+;;
+
+
+
+let global_prefs = {
+ val_tag_color = 0x00FF00 ; type_tag_color = 0x0000FF ;
+ module_tag_color = 0xFFFF00 ; constructor_tag_color = 0xFFFFFF ;
+ label_tag_color = 0xAF2F5F ; where_tag_color = 0xFFFFFF ;
+ background_tag_color = 0xC9E0FF }
+;;
+
+
+let copy_prefs from_prefs to_prefs =
+ to_prefs.val_tag_color <- from_prefs.val_tag_color ;
+ to_prefs.type_tag_color <- from_prefs.type_tag_color ;
+ to_prefs.module_tag_color <- from_prefs.module_tag_color ;
+ to_prefs.constructor_tag_color <- from_prefs.constructor_tag_color ;
+ to_prefs.label_tag_color <- from_prefs.label_tag_color ;
+ to_prefs.where_tag_color <- from_prefs.where_tag_color ;
+ to_prefs.background_tag_color <- from_prefs.background_tag_color
+;;
+
+
+let load_preferences () =
+ try
+ (* let pref_hd = open_in "/tmp/.ocamlexcrc" in *)
+ let pref_hd = open_in ((gethomedir ()) ^ "/.ocamlexcrc") in
+ let (loaded_prefs : preferences) = input_value pref_hd in
+ close_in pref_hd ;
+ copy_prefs loaded_prefs global_prefs
+ with
+ | Sys_error _ | No_home_dir -> ()
+;;
+
+
+
+let save_preferences () =
+ try
+ (* let pref_hd = open_out "/tmp/.ocamlexcrc" in *)
+ let pref_hd = open_out ((gethomedir ()) ^ "/.ocamlexcrc") in
+ output_value pref_hd global_prefs ;
+ close_out pref_hd ;
+ true
+ with
+ | Sys_error _ | No_home_dir -> false
+;;
+
+
+
+let open_pref_window parent_w =
+ (* Where to store current onfiguration *)
+ let local_prefs = {
+ val_tag_color = 0 ; type_tag_color = 0 ; module_tag_color = 0 ;
+ constructor_tag_color = 0 ; label_tag_color = 0 ;
+ where_tag_color = 0 ; background_tag_color = 0 } in
+ copy_prefs global_prefs local_prefs ;
+ (* Now the graphical stuff *)
+ let requester_w = Toplevel.create parent_w [] in
+ Wm.title_set requester_w "Preferences" ;
+ let frame0_w = Frame.create requester_w [] in
+ let frame1_w = Frame.create requester_w [Relief Raised;
+ BorderWidth (Pixels 2)] in
+ let frame2_w = Frame.create frame0_w [Relief Raised;
+ BorderWidth (Pixels 2)] in
+ let frame3_w = Frame.create frame0_w [Relief Raised;
+ BorderWidth (Pixels 2)] in
+ let frame4_w = Frame.create frame3_w [] in
+
+ let var0_w = Textvariable.create_temporary frame0_w in
+ let radiob0_w = Radiobutton.create frame2_w [Text "Val"; Variable var0_w;
+ Value "val" ] in
+ let radiob1_w = Radiobutton.create frame2_w [Text "Type"; Variable var0_w;
+ Value "type"] in
+ let radiob2_w = Radiobutton.create frame2_w [Text "Module"; Variable var0_w;
+ Value "module"] in
+ let radiob3_w = Radiobutton.create frame2_w [Text "Constructor";
+ Variable var0_w; Value "constructor"] in
+ let radiob4_w = Radiobutton.create frame2_w [Text "Label"; Variable var0_w;
+ Value "label" ] in
+ let radiob5_w = Radiobutton.create frame2_w [Text "Where"; Variable var0_w;
+ Value "where" ] in
+ let radiob6_w = Radiobutton.create frame2_w [Text "Background";
+ Variable var0_w; Value "background"] in
+ let canvas0_w = Canvas.create frame3_w [Width (Pixels 50);
+ BorderWidth (Pixels 3);
+ Height (Pixels 50); Relief Raised] in
+ let scaler_w = Scale.create frame4_w [From 0.0; To 255.0; Digits 0] in
+ let scaleg_w = Scale.create frame4_w [From 0.0; To 255.0; Digits 0] in
+ let scaleb_w = Scale.create frame4_w [From 0.0; To 255.0; Digits 0] in
+ (* Callback for the scalers *)
+ let scale_callback _ =
+ let col = (truncate (Scale.get scaler_w)) lsl 16 +
+ (truncate (Scale.get scaleg_w)) lsl 8 +
+ (truncate (Scale.get scaleb_w)) in
+ let coltxt = tk_color_of_int col in
+ let current_selection = Textvariable.get var0_w in
+ (match current_selection with
+ | "val" -> local_prefs.val_tag_color <- col
+ | "type" -> local_prefs.type_tag_color <- col
+ | "module" -> local_prefs.module_tag_color <- col
+ | "constructor" -> local_prefs.constructor_tag_color <- col
+ | "label" -> local_prefs.label_tag_color <- col
+ | "where" -> local_prefs.where_tag_color <- col
+ | "background" -> local_prefs.background_tag_color <- col
+ | _ -> ()) ;
+ if current_selection <> "" then
+ Canvas.configure canvas0_w [Background coltxt] in
+ Scale.configure scaler_w [ScaleCommand scale_callback] ;
+ Scale.configure scaleg_w [ScaleCommand scale_callback] ;
+ Scale.configure scaleb_w [ScaleCommand scale_callback] ;
+ (* Callback for the radio buttons *)
+ let radio_callback _ =
+ let col = (match Textvariable.get var0_w with
+ | "val" -> local_prefs.val_tag_color
+ | "type" -> local_prefs.type_tag_color
+ | "module" -> local_prefs.module_tag_color
+ | "constructor" -> local_prefs.constructor_tag_color
+ | "label" -> local_prefs.label_tag_color
+ | "where" -> local_prefs.where_tag_color
+ | "background" -> local_prefs.background_tag_color
+ | _ -> assert false) in
+ let coltxt = tk_color_of_int col in
+ let r = float ((col land 0xFF0000) lsr 16) in
+ let g = float ((col land 0x00FF00) lsr 8) in
+ let b = float ((col land 0x0000FF)) in
+ Scale.set scaler_w r ;
+ Scale.set scaleg_w g ;
+ Scale.set scaleb_w b ;
+ Canvas.configure canvas0_w [Background coltxt] in
+ List.iter (fun rb -> Radiobutton.configure rb [Command radio_callback])
+ [radiob0_w;radiob1_w;radiob2_w;radiob3_w;radiob4_w;radiob5_w;
+ radiob6_w] ;
+ (* Callback for the buttons *)
+ let apply_callback _ =
+ copy_prefs local_prefs global_prefs ;
+ destroy requester_w in
+ let save_callback _ =
+ copy_prefs local_prefs global_prefs ;
+ if not (save_preferences ()) then
+ begin
+ let error_w = Toplevel.create parent_w [] in
+ Wm.title_set error_w "Error report" ;
+ let label_w = Label.create error_w [Text ("Can't save prefs in "^
+ "/tmp/.ocamlexcrc")] in
+ let button_w = Button.create error_w [Text "So bad";
+ Command (fun _ -> destroy error_w)] in
+ pack [label_w; button_w] []
+ end ;
+ destroy requester_w in
+ let reset_callback _ =
+ copy_prefs global_prefs local_prefs ;
+ List.iter Radiobutton.deselect
+ [radiob0_w;radiob1_w;radiob2_w;radiob3_w;radiob4_w;radiob5_w;
+ radiob6_w] ;
+ Scale.set scaler_w 0.0 ;
+ Scale.set scaleg_w 0.0 ;
+ Scale.set scaleb_w 0.0 in
+ let button0_w = Button.create frame1_w [Text "Apply";
+ Command apply_callback] in
+ let button1_w = Button.create frame1_w [Text "Save";
+ Command save_callback] in
+ let button2_w = Button.create frame1_w [Text "Cancel";
+ Command (fun _ -> destroy requester_w)] in
+ let button3_w = Button.create frame1_w [Text "Reset";
+ Command reset_callback] in
+ pack [frame0_w; frame1_w] [Side Side_Top; Fill Fill_X] ;
+ pack [frame2_w; frame3_w] [Fill Fill_Y; Side Side_Left] ;
+ pack [frame4_w] [] ;
+ pack [radiob0_w;radiob1_w;radiob2_w;radiob3_w;radiob4_w;radiob5_w;
+ radiob6_w] [Side Side_Top; Anchor W] ;
+ pack [scaler_w; scaleg_w; scaleb_w] [Side Side_Left] ;
+ pack [canvas0_w] [Side Side_Left; Fill Fill_X; Expand true] ;
+ pack [button0_w;button1_w;button2_w;button3_w] [Side Side_Left;Expand true]
+;;
31 interface/printcontext.mli
@@ -0,0 +1,31 @@
+(***********************************************************************)
+(* *)
+(* Ocamlexc *)
+(* *)
+(* Francois Pessaux, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1998 Institut National de Recherche en Informatique et *)
+(* Automatique. Distributed only by permission. *)
+(* *)
+(***********************************************************************)
+
+
+type root_type =
+ | Nothing
+ | Ml of Typecore.ml_type_expr
+ | Phi of Typecore.phi_expr
+
+;;
+
+type print_context = {
+ widget : Widget.widget ; (* Text widget where to display *)
+ root_type : root_type ; (* Type currently printed *)
+ left_indent : int ; (* Left offset for indenting when expanding the *)
+ (* type expression text. In fact, it represent *)
+ (* the number of chars from the left border of *)
+ (* window to the ":" after the component name. *)
+ mark_radical : string ; (* Mark indicating the beginning / end of the *)
+ (* text representing the printed type expr. *)
+ tag_buffer : string ref ; (* Buffer for tag/mark *)
+ tag_scan_flag : bool ref (* Bool telling if we are parsing a tag/mark *)
+ } ;;
217 interface/rootwindow.ml
@@ -0,0 +1,217 @@
+(***********************************************************************)
+(* *)
+(* Ocamlexc *)
+(* *)
+(* Francois Pessaux, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1998 Institut National de Recherche en Informatique et *)
+(* Automatique. Distributed only by permission. *)
+(* *)
+(***********************************************************************)
+
+
+
+open Tk ;;
+open Format ;;
+
+
+let search_string_bnd text_w =
+ let requester_w = Toplevel.create text_w [] in
+ Wm.title_set requester_w "Search string" ;
+ let from_index = ref (TextIndex (LineChar (1, 1), [])) in
+ let to_index = ref (TextIndex (End, [])) in
+ (* Text entry to search *)
+ let entry0_w = Entry.create requester_w [] in
+ (* Search flags stuff *)
+ let frame0_w = Frame.create requester_w [Relief Raised;
+ BorderWidth (Pixels 2)] in
+ let var0_w = Textvariable.create_temporary frame0_w in
+ let radiob0_w = Radiobutton.create frame0_w [Text ">>"; Variable var0_w;
+ Value ">>";
+ Command (fun _ -> to_index := (TextIndex (End, [])))] in
+ let radiob1_w = Radiobutton.create frame0_w [Text "<<"; Variable var0_w;
+ Value "<<";
+ Command (fun _ -> to_index := (TextIndex (LineChar (1, 1), [])))] in
+ let frame1_w = Frame.create requester_w [Relief Raised;
+ BorderWidth (Pixels 2)] in
+ let var1_w = Textvariable.create_temporary frame1_w in
+ let radiob2_w = Radiobutton.create frame1_w [Text "a=A"; Variable var1_w;
+ Value "a=A"] in
+ let radiob3_w = Radiobutton.create frame1_w [Text "a<>A"; Variable var1_w;
+ Value "a<>A"] in
+ let frame2_w = Frame.create requester_w [] in
+ let butt0_w = Button.create frame2_w [Text "Abort";
+ Command (fun _ ->
+ Text.tag_delete text_w ["SEARCH"] ;
+ destroy requester_w)] in
+ (* Select insensitive forward search by default *)
+ Radiobutton.select radiob0_w ;
+ Radiobutton.select radiob2_w ;
+ let search _ =
+ try
+ (* Recover search options *)
+ let search_dir =
+ if Textvariable.get var0_w = "<<" then Backwards else Forwards in
+ let search_opt =
+ [search_dir ;
+ (if Textvariable.get var1_w = "a=A" then Nocase else Exact)] in
+ let i =
+ if search_dir = Forwards then
+ Text.search text_w search_opt (Entry.get entry0_w)
+ !from_index !to_index
+ else
+ Text.search text_w search_opt (Entry.get entry0_w)
+ !from_index !to_index in
+ Text.tag_delete text_w ["SEARCH"] ;
+ Text.tag_add text_w "SEARCH" (TextIndex (i, []))
+ (TextIndex (i, [WordEnd])) ;
+ Text.tag_configure text_w "SEARCH"
+ [Relief Raised; BorderWidth (Pixels 1);
+ Background Red] ;
+ (* Make the found point visible *)
+ Text.see text_w (TextIndex (i, [])) ;
+ if search_dir = Forwards then
+ from_index := (TextIndex (i, [WordEnd]))
+ else from_index := (TextIndex (i, [WordStart]))
+ with Invalid_argument _ -> Bell.ring () in
+ (* Enter : search next *)
+ bind entry0_w [([], KeyPressDetail "Return")] (BindSet ([], search)) ;
+ (* ^g : abandon search *)
+ bind entry0_w [([Control], KeyPressDetail "g")]
+ (BindSet ([], (fun _ -> Text.tag_delete text_w ["SEARCH"] ;
+ destroy requester_w))) ;
+ pack [entry0_w] [Side Side_Left; Fill Fill_X; Expand true] ;
+ pack [frame0_w; frame1_w; frame2_w] [Side Side_Left] ;
+ pack [radiob0_w; radiob1_w] [Side Side_Left] ;
+ pack [radiob2_w; radiob3_w] [Side Side_Left] ;
+ pack [butt0_w] [] ;
+ Focus.set entry0_w
+;;
+
+
+
+let create parent_w module_path module_source mode =
+ let bookmarks = ref 0 in
+ Wm.title_set parent_w (Path.end_name module_path) ;
+ (* Containers *)
+ let frame0_w = Frame.create parent_w [Relief Raised;
+ BorderWidth (Pixels 3) ] in
+ let frame1_w = Frame.create parent_w [] in
+ let butt0_w = Button.create frame0_w [Text "Close" ;
+ Command (fun _ -> destroy parent_w)] in
+ let butt1_w = Button.create frame0_w [Text "Search"] in
+ let butt2_w = Button.create frame0_w [Text "Quit";
+ Command (fun _-> exit 0)] in
+ let butt3_w = Button.create frame0_w [Text "Set Mark"] in
+ let mbut0_w = Menubutton.create frame0_w [Text "Jump Mark"] in
+ let menu0_w = Menu.create mbut0_w [] in
+ Menubutton.configure mbut0_w [Menu menu0_w] ;
+ (* Main text widget. No write possible by default. *)
+ let text0_w =
+ Text.create frame1_w
+ [Background (Preferences.tk_color_of_int
+ Preferences.global_prefs.Preferences.background_tag_color) ;
+ Cursor (XCursor "hand2"); State Disabled] in
+ (* Right scrollbar *)
+ let scroll0_w = Scrollbar.create frame1_w [Orient Vertical] in
+ (* Link scrollbar and text widgets *)
+ Text.configure text0_w [YScrollCommand (Scrollbar.set scroll0_w)] ;
+ Scrollbar.configure scroll0_w [ScrollCommand (Text.yview text0_w)] ;
+ (* Bindings for the text widget *)
+ bind text0_w [([Control], KeyPressDetail "s") ]
+ (BindSet ([], fun _ -> search_string_bnd text0_w)) ;
+ bind text0_w [([Alt], KeyPressDetail "q") ] (BindSet ([], fun _ -> exit 0)) ;
+ (* Configure toolbar buttons and the generic "bookmark" tag. *)
+ Text.tag_configure text0_w "bookmarked" [Relief Sunken;
+ BorderWidth (Pixels 1)] ;
+ Button.configure butt1_w [Command (fun _ -> search_string_bnd text0_w)] ;
+ Button.configure butt3_w
+ [Command (fun _ ->
+ try
+ let i = Text.index text0_w (TextIndex (TagFirst "sel", [])) in
+ let i = TextIndex (i, []) in
+ let j = Text.index text0_w (TextIndex (TagLast "sel", [])) in
+ let j = TextIndex (j, []) in
+ let bm_num_str = string_of_int !bookmarks in
+ Text.mark_set text0_w bm_num_str i ;
+ Menu.add_command menu0_w
+ [ Label bm_num_str ;
+ Command (fun _-> Text.see text0_w i) ] ;
+ Text.tag_add text0_w "bookmarked" i j ;
+ incr bookmarks
+ with Protocol.TkError _ ->
+ (* No selection in widget *) Bell.ring ())] ;
+ (* Finally pack the whole stuff *)
+ pack [frame0_w] [Fill Fill_X] ;
+ pack [frame1_w] [Expand true; Fill Fill_Both] ;
+ pack [butt1_w; butt0_w; butt3_w; mbut0_w] [Side Side_Left] ;
+ pack [butt2_w] [Side Side_Right] ;
+ pack [text0_w] [Side Side_Left; Expand true; Fill Fill_Both] ;
+ pack [scroll0_w] [Expand true; Fill Fill_Y] ;
+ (* Set the focus to the text widget *)
+ Focus.set text0_w ;
+ (* Create standard tags *)
+ Text.tag_add_char text0_w "VAL" (TextIndex (End, [])) ;
+ Text.tag_configure text0_w "VAL"
+ [Foreground
+ (Preferences.tk_color_of_int
+ Preferences.global_prefs.Preferences.val_tag_color)] ;
+ Text.tag_add_char text0_w "TYPE" (TextIndex (End, [])) ;
+ Text.tag_configure text0_w "TYPE"
+ [Foreground
+ (Preferences.tk_color_of_int
+ Preferences.global_prefs.Preferences.type_tag_color)] ;
+ Text.tag_add_char text0_w "MODULE" (TextIndex (End, [])) ;
+ Text.tag_configure text0_w "MODULE"
+ [Foreground
+ (Preferences.tk_color_of_int
+ Preferences.global_prefs.Preferences.module_tag_color)] ;
+ Text.tag_add_char text0_w "CONSTRUCTOR" (TextIndex (End, [])) ;
+ Text.tag_configure text0_w "CONSTRUCTOR"
+ [Foreground
+ (Preferences.tk_color_of_int
+ Preferences.global_prefs.Preferences.constructor_tag_color)] ;
+ Text.tag_add_char text0_w "LABEL" (TextIndex (End, [])) ;
+ Text.tag_configure text0_w "LABEL"
+ [Foreground
+ (Preferences.tk_color_of_int
+ Preferences.global_prefs.Preferences.label_tag_color)] ;
+ Text.tag_add_char text0_w "WHERE" (TextIndex (End, [])) ;
+ Text.tag_configure text0_w "WHERE"
+ [Background
+ (Preferences.tk_color_of_int
+ Preferences.global_prefs.Preferences.where_tag_color)] ;
+ (* Alias printing functions to Tk's ones *)
+ let pcontext = {
+ Printcontext.widget = text0_w ;
+ Printcontext.root_type = Printcontext.Nothing ;
+ Printcontext.left_indent = 0 ;
+ Printcontext.mark_radical = "" ;
+ Printcontext.tag_buffer = ref "" ;
+ Printcontext.tag_scan_flag = ref false } in
+ let (old_print, old_flush) = Format.get_formatter_output_functions () in
+ Format.set_formatter_output_functions
+ (fun s pos num ->
+ Tklowprint.scan_string pcontext s pos num)
+ (fun () -> ()) ;
+ (* Enable temporarily writes in the text widget *)
+ Text.configure text0_w [State Normal] ;
+ begin
+ match mode with
+ | Global.Typedisplay ->
+ (* Print the module signature *)
+ let mod_sig =
+ Envtype.find_module module_path !Envtype.global_type_env in
+ fprintf std_formatter "%a@\n@."
+ (Tkprintmod.pp_module_type pcontext) mod_sig
+ | Global.Syntaxdisplay ->
+ (* Print the module syntax tree *)
+ let tree = List.assoc module_path !Global.syntax_trees in
+ Tkloadsrc.load_source text0_w module_source tree
+ end ;
+ (* Re-disable writes in the text widget *)
+ Text.configure text0_w [State Disabled] ;
+ (* Restore printing functions *)
+ Format.set_formatter_output_functions old_print old_flush
+;;
+
310 interface/tkloadsrc.ml
@@ -0,0 +1,310 @@
+(***********************************************************************)
+(* *)
+(* Ocamlexc *)
+(* *)
+(* Francois Pessaux, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1998 Institut National de Recherche en Informatique et *)
+(* Automatique. Distributed only by permission. *)
+(* *)
+(***********************************************************************)
+
+
+
+open Format ;;
+open Tk ;;
+
+
+exception Found of Typedtree.expression ;;
+
+
+
+let rec find_loc_expression char_start char_stop expr =
+ if char_start = expr.Typedtree.exp_loc.Location.loc_start &&
+ char_stop = expr.Typedtree.exp_loc.Location.loc_end
+ then raise (Found expr) ;
+ if char_start >= expr.Typedtree.exp_loc.Location.loc_start &&
+ char_stop <= expr.Typedtree.exp_loc.Location.loc_end
+ then find_loc_expression_desc char_start char_stop expr.Typedtree.exp_desc
+
+
+and find_loc_expression_desc char_start char_stop = function
+ | Typedtree.Texp_ident _ -> ()
+ | Typedtree.Texp_constant _ -> ()
+ | Typedtree.Texp_let (_, bindings, expr) ->
+ List.iter
+ (fun (_, expr) -> find_loc_expression char_start char_stop expr)
+ bindings ;
+ find_loc_expression char_start char_stop expr
+ | Typedtree.Texp_function bindings ->
+ List.iter
+ (fun (_, expr) -> find_loc_expression char_start char_stop expr)
+ bindings
+ | Typedtree.Texp_apply (expr0, exprs) ->
+ find_loc_expression char_start char_stop expr0 ;
+ List.iter (find_loc_expression char_start char_stop) exprs
+ | Typedtree.Texp_match (expr, bindings) ->
+ find_loc_expression char_start char_stop expr ;
+ List.iter
+ (fun (_, expr) -> find_loc_expression char_start char_stop expr)
+ bindings
+ | Typedtree.Texp_try (expr, bindings) ->
+ find_loc_expression char_start char_stop expr ;
+ List.iter
+ (fun (_, expr) -> find_loc_expression char_start char_stop expr)
+ bindings
+ | Typedtree.Texp_tuple exprs ->
+ List.iter (find_loc_expression char_start char_stop) exprs
+ | Typedtree.Texp_construct (_, expr_opt) ->
+ (match expr_opt with None -> ()
+ | Some e -> find_loc_expression char_start char_stop e)
+ | Typedtree.Texp_record (rec_fields, expr_opt) ->
+ List.iter
+ (fun (_, e) -> find_loc_expression char_start char_stop e)
+ rec_fields ;
+ (match expr_opt with None -> ()
+ | Some e -> find_loc_expression char_start char_stop e)
+ | Typedtree.Texp_field (expr, _) ->
+ find_loc_expression char_start char_stop expr
+ | Typedtree.Texp_setfield (expr0, _, expr1) ->
+ find_loc_expression char_start char_stop expr0 ;
+ find_loc_expression char_start char_stop expr1
+ | Typedtree.Texp_array exprs ->
+ List.iter (find_loc_expression char_start char_stop) exprs
+ | Typedtree.Texp_ifthenelse (expr0, expr1, expr2_opt) ->
+ find_loc_expression char_start char_stop expr0 ;
+ find_loc_expression char_start char_stop expr1 ;
+ (match expr2_opt with None -> ()
+ | Some e -> find_loc_expression char_start char_stop e)
+ | Typedtree.Texp_sequence (expr0, expr1) ->
+ find_loc_expression char_start char_stop expr0 ;
+ find_loc_expression char_start char_stop expr1
+ | Typedtree.Texp_while (expr0, expr1) ->
+ find_loc_expression char_start char_stop expr0 ;
+ find_loc_expression char_start char_stop expr1
+ | Typedtree.Texp_for (_, expr0, expr1, _, expr2) ->
+ find_loc_expression char_start char_stop expr0 ;
+ find_loc_expression char_start char_stop expr1 ;
+ find_loc_expression char_start char_stop expr2
+ | Typedtree.Texp_constraint (expr, _, _) ->
+ find_loc_expression char_start char_stop expr
+ | Typedtree.Texp_when (expr0, expr1) ->
+ find_loc_expression char_start char_stop expr0 ;
+ find_loc_expression char_start char_stop expr1
+ | Typedtree.Texp_letmodule (_, _, _) ->
+ failwith "tkloadsrc.ml: Texp_letmodule never handled since years :/"
+
+
+
+and find_loc_module_expr char_start char_stop mod_expr =
+ if char_start = mod_expr.Typedtree.mod_loc.Location.loc_start &&
+ char_stop = mod_expr.Typedtree.mod_loc.Location.loc_end
+ then () (* We don't take module expressions in account *)
+ else
+ if char_start >= mod_expr.Typedtree.mod_loc.Location.loc_start &&
+ char_stop <= mod_expr.Typedtree.mod_loc.Location.loc_end
+ then
+ find_loc_module_expr_desc char_start char_stop mod_expr.Typedtree.mod_desc
+ else ()
+
+
+and find_loc_module_expr_desc char_start char_stop = function
+ | Typedtree.Tmod_ident _ -> ()
+ | Typedtree.Tmod_structure structure ->
+ find_loc_structure char_start char_stop structure
+ | Typedtree.Tmod_functor (_, _) -> () (* Not a typed tree *)
+ | Typedtree.Tmod_apply (mod_expr0, mod_expr1) ->
+ find_loc_module_expr char_start char_stop mod_expr0 ;
+ find_loc_module_expr char_start char_stop mod_expr1
+
+
+and find_loc_structure char_start char_stop structure =
+ List.iter (find_loc_structure_item char_start char_stop) structure
+
+
+
+and find_loc_structure_item char_start char_stop = function
+ | Typedtree.Tstr_eval expr -> find_loc_expression char_start char_stop expr
+ | Typedtree.Tstr_value (_, bindings) ->
+ List.iter
+ (fun (_, expr) -> find_loc_expression char_start char_stop expr)
+ bindings
+ | Typedtree.Tstr_primitive (_, _) -> ()
+ | Typedtree.Tstr_type _ -> ()
+ | Typedtree.Tstr_exception _ -> ()
+ | Typedtree.Tstr_module (_, mod_expr) ->
+ find_loc_module_expr char_start char_stop mod_expr
+;;
+
+
+
+let line_column_to_char_number lines_mappping line char =
+ (lines_mappping.(line)) + char
+;;
+
+
+let char_number_to_line_column lines_mappping char_number =
+ let max_l = Array.length lines_mappping in
+ let rec find l =
+ if l > max_l then assert false ;
+ if char_number < lines_mappping.(l) then
+ begin
+ (* The char is in the previous line *)
+ let line = l - 1 in
+ let char = char_number - lines_mappping.(l - 1) in
+ (line, char)
+ end
+ else
+ find (l + 1) in
+ find 1 (* Start at line 1, not 0 *)
+;;
+
+
+let create_mark_radical =
+ let cpt = ref 0 in
+ function () ->
+ let name = "MARK" ^ (string_of_int !cpt) in
+ incr cpt ;
+ name
+;;
+
+
+let create_popup parent_w expression =
+ let new_window = Toplevel.create parent_w [] in
+ Wm.title_set new_window "Zoom" ;
+ let label0_w = Label.create new_window [Text "Type of expression"] in
+ let text0_w =
+ Text.create new_window [Background (NamedColor "LightSteelBlue");
+ Cursor (XCursor "hand2"); State Disabled; TextHeight 5] in
+ let label1_w = Label.create new_window [Text "Effect of expression"] in
+ let text1_w =
+ Text.create new_window [Background (NamedColor "LightSteelBlue");
+ Cursor (XCursor "hand2"); State Disabled; TextHeight 5] in
+ (* Button to close the window *)
+ let butt0_w = Button.create new_window
+ [Text "Close" ;
+ Command (fun _ -> destroy new_window)] in
+ (* Right-clic shortcut to close the window *)
+ bind text0_w [([], ButtonPressDetail 3) ]
+ (BindSet ([], fun _ -> destroy new_window)) ;
+ bind text1_w [([], ButtonPressDetail 3) ]
+ (BindSet ([], fun _ -> destroy new_window)) ;
+ (* Create the tag for "where" construction *)
+ Text.tag_add_char text0_w "WHERE" (TextIndex (End, [])) ;
+ Text.tag_configure text0_w "WHERE" [Background White] ;
+ (* Display the whole stuff *)
+ pack [label0_w] [Side Side_Top; Fill Fill_Both] ;
+ pack [text0_w] [Side Side_Top; Expand true; Fill Fill_Both] ;
+ pack [label1_w] [Side Side_Top; Fill Fill_Both] ;
+ pack [text1_w] [Side Side_Top; Expand true; Fill Fill_Both] ;
+ pack [butt0_w] [Fill Fill_Both] ;
+ (* Print expression type in upper window *)
+ let ty_expr = expression.Typedtree.exp_type in
+ let mark_r = create_mark_radical () in
+ let pcontext = {
+ Printcontext.widget = text0_w ;
+ Printcontext.root_type = Printcontext.Ml ty_expr ;
+ Printcontext.left_indent = 0 ;
+ Printcontext.mark_radical = mark_r ;
+ Printcontext.tag_buffer = ref "" ;
+ Printcontext.tag_scan_flag = ref false } in
+ let (old_print, old_flush) =
+ pp_get_formatter_output_functions std_formatter () in
+ pp_set_formatter_output_functions std_formatter
+ (fun s pos num ->
+ Tklowprint.scan_string pcontext s pos num)
+ (fun () -> ()) ;
+ Text.configure text0_w [State Normal] ;
+ pp_print_as std_formatter 0 ("\006START"^mark_r^"\008") ;
+ fprintf std_formatter "%a@\n@." (Tkprinttypes.pp_ml_type pcontext) ty_expr ;
+ pp_print_as std_formatter 0 ("\006STOP"^mark_r^"\008") ;
+ fprintf std_formatter "@?" ;
+ Text.configure text0_w [State Disabled] ;
+ pp_set_formatter_output_functions std_formatter old_print old_flush ;
+ (* Print expression effect in lower window *)
+ let effect_expr = expression.Typedtree.exp_exn in
+ let mark_r = create_mark_radical () in
+ let pcontext = {
+ Printcontext.widget = text1_w ;
+ Printcontext.root_type = Printcontext.Phi effect_expr ;
+ Printcontext.left_indent = 0 ;
+ Printcontext.mark_radical = mark_r ;
+ Printcontext.tag_buffer = ref "" ;
+ Printcontext.tag_scan_flag = ref false } in
+ let (old_print, old_flush) =
+ pp_get_formatter_output_functions std_formatter () in
+ pp_set_formatter_output_functions std_formatter
+ (fun s pos num ->
+ Tklowprint.scan_string pcontext s pos num)
+ (fun () -> ()) ;
+ Text.configure text1_w [State Normal] ;
+ pp_print_as std_formatter 0 ("\006START"^mark_r^"\008") ;
+ (* Make the effect printable *)
+ effect_expr.Typecore.phi_print <- true ;
+ fprintf std_formatter "%a@\n@."
+ (Tkprinttypes.pp_phi_type pcontext) effect_expr ;
+ pp_print_as std_formatter 0 ("\006STOP"^mark_r^"\008") ;
+ fprintf std_formatter "@?" ;
+ Text.configure text1_w [State Disabled] ;
+ pp_set_formatter_output_functions std_formatter old_print old_flush
+;;
+
+
+
+(* Creates the callback associated with click in the source *)
+let make_callback widget lines_mappping syntax_tree _ =
+ try
+ begin
+ let (line, char) =
+ (match Text.index widget (TextIndex (TagFirst "sel", [])) with
+ LineChar (l, c) -> (l - 1, c) | _ -> assert false) in
+ let char_start = line_column_to_char_number lines_mappping line char in
+ let (line', char') =
+ (match Text.index widget (TextIndex (TagLast "sel", [])) with
+ LineChar (l, c) -> (l - 1, c) | _ -> assert false) in
+ let char_stop = line_column_to_char_number lines_mappping line' char' in
+ (* Find the expression associated to the character location *)
+ try find_loc_structure char_start char_stop syntax_tree ; Bell.ring ()
+ with Found expr ->
+ (* Highliht the expression *)
+ let (start_l, start_c) =
+ char_number_to_line_column lines_mappping
+ (expr.Typedtree.exp_loc.Location.loc_start) in
+ let (stop_l, stop_c) =
+ char_number_to_line_column lines_mappping
+ (expr.Typedtree.exp_loc.Location.loc_end) in
+ Text.tag_delete widget ["EXPR"] ;
+ (* Don't forget that lines are numbered from 1 in Tk *)
+ Text.tag_add widget "EXPR" (TextIndex (LineChar (start_l+1, start_c), []))
+ (TextIndex (LineChar (stop_l+1, stop_c), [])) ;
+ Text.tag_configure widget "EXPR"
+ [Relief Raised; BorderWidth (Pixels 1);
+ Background Red] ;
+ (* Pop a window with expression node information *)
+ create_popup widget expr
+ end
+ with Protocol.TkError _ -> (* No selection in widget *) Bell.ring ()
+;;
+
+
+
+(* Line and columns begin at 0 *)
+let load_source widget filename syntax_tree =
+ let in_channel = Stdlibpath.open_in_with_path filename in
+ (* Character # of the beginning of the current line *)
+ let char_of_begin_line = ref 0 in
+ (* List recording the character # of each new line *)
+ let current_mapping = ref [] in
+ try
+ while true do
+ current_mapping := !char_of_begin_line :: !current_mapping ;
+ let l = (input_line in_channel)^"\n" in
+ char_of_begin_line := !char_of_begin_line + String.length l ;
+ Text.insert widget (TextIndex (End, [])) l []
+ done
+ with End_of_file ->
+ close_in in_channel ;
+ let array_of_list = Array.of_list (List.rev !current_mapping) in
+ let callback = make_callback widget array_of_list syntax_tree in
+ bind widget [([], ButtonReleaseDetail 1)] (BindSet ([], callback))
+;;
91 interface/tklowprint.ml
@@ -0,0 +1,91 @@
+(***********************************************************************)
+(* *)
+(* Ocamlexc *)
+(* *)
+(* Francois Pessaux, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1998 Institut National de Recherche en Informatique et *)
+(* Automatique. Distributed only by permission. *)
+(* *)
+(***********************************************************************)
+
+
+
+open Tk ;;
+open Format ;;
+
+
+(* Used for pretty-printing a whole signature *)
+let scan_string pcontext s pos num =
+ let text_w = pcontext.Printcontext.widget in
+ let tag_buffer = pcontext.Printcontext.tag_buffer in
+ let tag_scan_flag = pcontext.Printcontext.tag_scan_flag in
+ let start = ref pos in
+ for i = pos to pos + num - 1 do
+ match s.[i] with
+ | '\006' ->
+ (* Begin of tag *)
+ Text.insert text_w (TextIndex (End, []))
+ (String.sub s !start (i - !start)) [!tag_buffer] ;
+ tag_buffer := "" ;
+ tag_scan_flag := true ;
+ | '\007' ->
+ (* End of tag *)
+ tag_scan_flag := false ;
+ start := i + 1
+ | '\008' ->
+ (* End of mark *)
+ tag_scan_flag := false ;
+ start := i + 1 ;
+ Text.mark_set text_w !tag_buffer (TextIndex (Mark "insert", [])) ;
+ Text.mark_gravity_set text_w !tag_buffer Mark_Left
+ | whatever ->
+ if !tag_scan_flag then
+ tag_buffer := !tag_buffer ^ (Char.escaped whatever)
+ done ;
+ if not !tag_scan_flag then
+ Text.insert text_w (TextIndex (End, []))
+ (String.sub s !start (num - !start)) [!tag_buffer]
+;;
+
+
+
+(* Used for pretty-printing a type component in a callback *)
+let scan_string_at pcontext index s pos num =
+ let text_w = pcontext.Printcontext.widget in
+ let tag_buffer = pcontext.Printcontext.tag_buffer in
+ let tag_scan_flag = pcontext.Printcontext.tag_scan_flag in
+ let left_indent = pcontext.Printcontext.left_indent in
+ let start = ref pos in
+ for i = pos to pos + num - 1 do
+ match s.[i] with
+ | '\006' ->
+ (* Begin of tag *)
+ Text.insert text_w index
+ (String.sub s !start (i - !start)) [!tag_buffer] ;
+ tag_buffer := "" ;
+ tag_scan_flag := true
+ | '\007' ->
+ (* End of tag *)
+ tag_scan_flag := false ;
+ start := i + 1
+ | '\008' ->
+ (* End of mark *)
+ tag_scan_flag := false ;
+ start := i + 1 ;
+ Text.mark_set text_w !tag_buffer (TextIndex (Mark "insert", [])) ;
+ Text.mark_gravity_set text_w !tag_buffer Mark_Left
+ | '\010' ->
+ Text.insert text_w index
+ (String.sub s !start (i - !start)) [!tag_buffer] ;
+ let pad = String.make left_indent ' ' in
+ Text.insert text_w index ("\n"^pad) [!tag_buffer] ;
+ start := i + 1
+ | whatever ->
+ if !tag_scan_flag then
+ tag_buffer := !tag_buffer ^ (Char.escaped whatever)
+ done ;
+ if not !tag_scan_flag then
+ Text.insert text_w index
+ (String.sub s !start (num - !start)) [!tag_buffer]
+;;
118 interface/tkprintmod.ml
@@ -0,0 +1,118 @@
+(***********************************************************************)
+(* *)
+(* Ocamlexc *)
+(* *)
+(* Francois Pessaux, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1998 Institut National de Recherche en Informatique et *)
+(* Automatique. Distributed only by permission. *)
+(* *)
+(* Pretty print of module types. *)
+(***********************************************************************)
+
+
+
+
+open Format ;;
+open Tk ;;
+
+
+
+(* create_mark_radical: unit -> string *)
+(* Creates a new mark core-name *)
+let create_mark_radical =
+ let cpt = ref 0 in
+ function () ->
+ let name = "MARK" ^ (string_of_int !cpt) in
+ incr cpt ;
+ name
+;;
+
+
+
+(* pp_label_description: Format.formatter -> Typedtree.label_description -> *)
+(* unit *)
+let pp_label_description pcontext ppf lbl_desc =
+ fprintf ppf "%a:@ %a" Printbasic.pp_mutable_flag lbl_desc.Typedtree.fld_mut
+ (Tkprinttypes.pp_ml_type_scheme pcontext)
+ lbl_desc.Typedtree.fld_scheme
+;;
+
+
+
+(* pp_signature: Format.formatter -> Typedtree.signature_item list -> unit *)
+(* Pretty print signatures *)
+let rec pp_signature pcontext ppf signature =
+ let iter_pp_signature_item =
+ Printbasic.iter_pp "" (pp_signature_item pcontext) in
+ fprintf ppf "%a" iter_pp_signature_item signature
+
+
+
+(* pp_signature_item: Format.formatter -> Typedtree.signature_item -> unit *)
+(* Pretty print signature items *)
+and pp_signature_item pcontext ppf = function
+ | Typedtree.Tsig_value (ident, scheme) ->
+ let mark_r = create_mark_radical () in
+ let pcontext' = { pcontext with Printcontext.mark_radical = mark_r } in
+ fprintf ppf "@<0>%sval@<0>%s@[ %s:@ @<0>%s%a@]@<0>%s"
+ "\006VAL\007" "\006\007"
+ (Ident.name ident) ("\006START"^mark_r^"\008")
+ (Tkprinttypes.pp_ml_type_scheme pcontext') scheme
+ ("\006STOP"^mark_r^"\008") ;
+ | Typedtree.Tsig_type (ident, ty_declaration) ->
+ fprintf ppf "typ@[e %a@]"
+ (Tkprinttypes.pp_type_declaration pcontext)
+ (ident, ty_declaration)
+ | Typedtree.Tsig_module (ident, mod_ty) ->
+ fprintf ppf "@<0>%smod@[ule@<0>%s %s :@ %a@]"
+ "\006MODULE\007" "\006\007"
+ (Ident.name ident) (pp_module_type pcontext) mod_ty
+ | Typedtree.Tsig_constructor (id, cd) ->
+ (* As specified in typedtree.mli, this the constructor comes *)
+ (* from a type declaration, this kind of component is hidden *)
+ (* to the user. It only serves to keep trace of constructors *)
+ (* induced by type definitions in a module. So don't print ! *)
+ (* Else if it comes from an exception, we must display it ! *)
+ let mark_r = create_mark_radical () in
+ let pcontext' = { pcontext with
+ Printcontext.mark_radical = mark_r } in
+ begin
+ match cd.Typedtree.cstr_kind with
+ | Typedtree.Exn file ->
+ fprintf ppf "@<0>%sexc@[eption@<0>%s %s__%s :@ @<0>%s%a@]@<0>%s"
+ "\006CONSTRUCTOR\007" "\006\007"
+ file (Ident.name id)
+ ("\006START"^mark_r^"\008")
+ (Tkprinttypes.pp_ml_type_scheme pcontext')
+ cd.Typedtree.cstr_scheme
+ ("\006STOP"^mark_r^"\008")
+ | Typedtree.Sum ->
+ fprintf ppf "@<0>%scon@[structor@<0>%s %s :@ @<0>%s%a@]@<0>%s"
+ "\006CONSTRUCTOR\007" "\006\007"
+ (Ident.name id)
+ ("\006START"^mark_r^"\008")
+ (Tkprinttypes.pp_ml_type_scheme pcontext')
+ cd.Typedtree.cstr_scheme
+ ("\006STOP"^mark_r^"\008")
+ end
+ | Typedtree.Tsig_label (id, lbl_descr) ->
+ let mark_r = create_mark_radical () in
+ let pcontext' = { pcontext with
+ Printcontext.mark_radical = mark_r } in
+ fprintf ppf "@<0>%srec@[ord label@<0>%s %s @<0>%s%a@]@<0>%s"
+ "\006LABEL\007" "\006\007"
+ (Ident.name id)
+ ("\006START"^mark_r^"\008")
+ (pp_label_description pcontext') lbl_descr
+ ("\006STOP"^mark_r^"\008")
+