diff options
| author | Damien Doligez <damien.doligez-inria.fr> | 2010-01-22 12:48:24 +0000 |
|---|---|---|
| committer | Damien Doligez <damien.doligez-inria.fr> | 2010-01-22 12:48:24 +0000 |
| commit | 04b1656222698bd7e92f213e9a718b7a4185643a (patch) | |
| tree | 6186d1ba1e00adb1232908f95cb92c299902a943 | |
| parent | bdc0fadee2dc9669818955486b4c3497016edda5 (diff) | |
| download | ocaml-04b1656222698bd7e92f213e9a718b7a4185643a.tar.gz | |
clean up spaces and tabs
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@9547 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
586 files changed, 3092 insertions, 3476 deletions
@@ -190,7 +190,7 @@ Compilers: are tail calls. - All compiler error messages now include a file name and location, for better interaction with Emacs' compilation mode. -- Optimized compilation of "lazy e" when the argument "e" is +- Optimized compilation of "lazy e" when the argument "e" is already evaluated. - Optimized compilation of equality tests with a variant constant constructor. - The -dllib options recorded in libraries are no longer ignored when @@ -243,7 +243,7 @@ Other libraries: - Dynlink: on some platforms, the Dynlink library is now available in native code. The boolean Dynlink.is_native allows the program to know whether it has been compiled in bytecode or in native code. -- Bigarrays: added "unsafe_get" and "unsafe_set" +- Bigarrays: added "unsafe_get" and "unsafe_set" (non-bound-checking versions of "get" and "set"). - Bigarrays: removed limitation "array dimension < 2^31". - Labltk: added support for TK 8.5. @@ -274,7 +274,7 @@ Bug fixes: out-of-heap pointers. - PR#3915: updated most man pages. - PR#4261: type-checking of recursive modules -- PR#4308: better stack backtraces for "spontaneous" exceptions such as +- PR#4308: better stack backtraces for "spontaneous" exceptions such as Stack_overflow, Out_of_memory, etc. - PR#4338: Str.global_substitute, Str.global_replace and the Str.*split* functions are now tail-recursive. @@ -78,7 +78,7 @@ The "configure" script accepts the following options: LablTk. "-tkdefs" helps to find the headers, and "-tklibs" the C libraries. "-tklibs" may contain either only -L/path and -Wl,... flags, in which case the library names are determined - automatically, or the actual libraries, which are used as given. + automatically, or the actual libraries, which are used as given. Example: for a Japanese tcl/tk whose headers are in specific directories and libraries in /usr/local/lib, you can use ./configure -tklibs "-L/usr/local/lib -ltk8.0jp -ltcl8.0jp" @@ -32,7 +32,7 @@ SHELL=/bin/sh MKDIR=mkdir -p INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver \ - -I toplevel + -I toplevel UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \ utils/clflags.cmo utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \ @@ -192,9 +192,9 @@ coldstart: cd stdlib; $(MAKE) COMPILER=../boot/ocamlc all cd stdlib; cp $(LIBFILES) ../boot if test -f boot/libcamlrun.a; then :; else \ - ln -s ../byterun/libcamlrun.a boot/libcamlrun.a; fi + ln -s ../byterun/libcamlrun.a boot/libcamlrun.a; fi if test -d stdlib/caml; then :; else \ - ln -s ../byterun stdlib/caml; fi + ln -s ../byterun stdlib/caml; fi # Build the core system: the minimum needed to make depend and bootstrap core: coldstart ocamlc ocamllex ocamlyacc ocamltools library @@ -240,7 +240,7 @@ compare: @if cmp boot/ocamlc ocamlc && cmp boot/ocamllex lex/ocamllex \ && cmp boot/ocamldep tools/ocamldep; \ then echo "Fixpoint reached, bootstrap succeeded."; \ - else echo "Fixpoint not reached, try one more bootstrapping cycle."; \ + else echo "Fixpoint not reached, try one more bootstrapping cycle."; \ fi # Remove old bootstrap compilers @@ -262,9 +262,9 @@ opt: # Native-code versions of the tools opt.opt: checkstack runtime core ocaml opt-core ocamlc.opt otherlibraries \ - ocamlbuild.byte camlp4out $(DEBUGGER) ocamldoc ocamlopt.opt \ - otherlibrariesopt \ - ocamllex.opt ocamltoolsopt.opt ocamlbuild.native camlp4opt ocamldoc.opt + ocamlbuild.byte camlp4out $(DEBUGGER) ocamldoc ocamlopt.opt \ + otherlibrariesopt \ + ocamllex.opt ocamltoolsopt.opt ocamlbuild.native camlp4opt ocamldoc.opt # Installation install: @@ -274,8 +274,8 @@ install: if test -d $(MANDIR)/man$(MANEXT); then : ; \ else $(MKDIR) $(MANDIR)/man$(MANEXT); fi cd $(LIBDIR); rm -f dllbigarray.so dlllabltk.so dllnums.so \ - dllthreads.so dllunix.so dllgraphics.so dllmldbm.so dllstr.so \ - dlltkanim.so + dllthreads.so dllunix.so dllgraphics.so dllmldbm.so dllstr.so \ + dlltkanim.so cd byterun; $(MAKE) install cp ocamlc $(BINDIR)/ocamlc$(EXE) cp ocaml $(BINDIR)/ocaml$(EXE) @@ -291,8 +291,8 @@ install: cd tools; $(MAKE) install -cd man; $(MAKE) install for i in $(OTHERLIBRARIES); do \ - (cd otherlibs/$$i; $(MAKE) install) || exit $$?; \ - done + (cd otherlibs/$$i; $(MAKE) install) || exit $$?; \ + done cd ocamldoc; $(MAKE) install if test -f ocamlopt; then $(MAKE) installopt; else :; fi if test -f debugger/ocamldebug; then (cd debugger; $(MAKE) install); \ @@ -355,7 +355,7 @@ partialclean:: # The native toplevel -ocamlnat: ocamlopt otherlibs/dynlink/dynlink.cmxa $(NATTOPOBJS:.cmo=.cmx) +ocamlnat: ocamlopt otherlibs/dynlink/dynlink.cmxa $(NATTOPOBJS:.cmo=.cmx) $(CAMLOPT) $(LINKFLAGS) otherlibs/dynlink/dynlink.cmxa -o ocamlnat \ $(NATTOPOBJS:.cmo=.cmx) -linkall @@ -369,28 +369,28 @@ otherlibs/dynlink/dynlink.cmxa: otherlibs/dynlink/natdynlink.ml utils/config.ml: utils/config.mlp config/Makefile @rm -f utils/config.ml sed -e 's|%%LIBDIR%%|$(LIBDIR)|' \ - -e 's|%%BYTERUN%%|$(BINDIR)/ocamlrun|' \ - -e 's|%%CCOMPTYPE%%|cc|' \ - -e 's|%%BYTECC%%|$(BYTECC) $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS)|' \ - -e 's|%%NATIVECC%%|$(NATIVECC) $(NATIVECCCOMPOPTS)|' \ - -e 's|%%PACKLD%%|$(PACKLD)|' \ - -e 's|%%BYTECCLIBS%%|$(BYTECCLIBS)|' \ - -e 's|%%NATIVECCLIBS%%|$(NATIVECCLIBS)|' \ - -e 's|%%RANLIBCMD%%|$(RANLIBCMD)|' \ - -e 's|%%CC_PROFILE%%|$(CC_PROFILE)|' \ - -e 's|%%ARCH%%|$(ARCH)|' \ - -e 's|%%MODEL%%|$(MODEL)|' \ - -e 's|%%SYSTEM%%|$(SYSTEM)|' \ - -e 's|%%EXT_OBJ%%|.o|' \ - -e 's|%%EXT_ASM%%|.s|' \ - -e 's|%%EXT_LIB%%|.a|' \ - -e 's|%%EXT_DLL%%|.so|' \ - -e 's|%%SYSTHREAD_SUPPORT%%|$(SYSTHREAD_SUPPORT)|' \ - -e 's|%%ASM%%|$(ASM)|' \ - -e 's|%%MKDLL%%|$(MKDLL)|' \ - -e 's|%%MKEXE%%|$(MKEXE)|' \ - -e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \ - utils/config.mlp > utils/config.ml + -e 's|%%BYTERUN%%|$(BINDIR)/ocamlrun|' \ + -e 's|%%CCOMPTYPE%%|cc|' \ + -e 's|%%BYTECC%%|$(BYTECC) $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS)|' \ + -e 's|%%NATIVECC%%|$(NATIVECC) $(NATIVECCCOMPOPTS)|' \ + -e 's|%%PACKLD%%|$(PACKLD)|' \ + -e 's|%%BYTECCLIBS%%|$(BYTECCLIBS)|' \ + -e 's|%%NATIVECCLIBS%%|$(NATIVECCLIBS)|' \ + -e 's|%%RANLIBCMD%%|$(RANLIBCMD)|' \ + -e 's|%%CC_PROFILE%%|$(CC_PROFILE)|' \ + -e 's|%%ARCH%%|$(ARCH)|' \ + -e 's|%%MODEL%%|$(MODEL)|' \ + -e 's|%%SYSTEM%%|$(SYSTEM)|' \ + -e 's|%%EXT_OBJ%%|.o|' \ + -e 's|%%EXT_ASM%%|.s|' \ + -e 's|%%EXT_LIB%%|.a|' \ + -e 's|%%EXT_DLL%%|.so|' \ + -e 's|%%SYSTHREAD_SUPPORT%%|$(SYSTHREAD_SUPPORT)|' \ + -e 's|%%ASM%%|$(ASM)|' \ + -e 's|%%MKDLL%%|$(MKDLL)|' \ + -e 's|%%MKEXE%%|$(MKEXE)|' \ + -e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \ + utils/config.mlp > utils/config.ml @chmod -w utils/config.ml partialclean:: @@ -433,8 +433,8 @@ beforedepend:: parsing/linenum.ml ocamlc.opt: $(COMPOBJS:.cmo=.cmx) cd asmrun; $(MAKE) meta.o dynlink.o $(CAMLOPT) $(LINKFLAGS) -ccopt "$(BYTECCLINKOPTS)" -o ocamlc.opt \ - $(COMPOBJS:.cmo=.cmx) \ - asmrun/meta.o asmrun/dynlink.o -cclib "$(BYTECCLIBS)" + $(COMPOBJS:.cmo=.cmx) \ + asmrun/meta.o asmrun/dynlink.o -cclib "$(BYTECCLIBS)" @sed -e 's|@compiler@|$$topdir/ocamlc.opt|' \ driver/ocamlcomp.sh.in > ocamlcomp.sh @chmod +x ocamlcomp.sh @@ -459,7 +459,7 @@ $(OPTOBJS:.cmo=.cmx): ocamlopt bytecomp/opcodes.ml: byterun/instruct.h sed -n -e '/^enum/p' -e 's/,//g' -e '/^ /p' byterun/instruct.h | \ - awk -f tools/make-opcodes > bytecomp/opcodes.ml + awk -f tools/make-opcodes > bytecomp/opcodes.ml partialclean:: rm -f bytecomp/opcodes.ml @@ -475,9 +475,9 @@ bytecomp/runtimedef.ml: byterun/primitives byterun/fail.h (echo 'let builtin_exceptions = [|'; \ sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$$| \1;|p' byterun/fail.h | \ sed -e '$$s/;$$//'; \ - echo '|]'; \ - echo 'let builtin_primitives = [|'; \ - sed -e 's/.*/ "&";/' -e '$$s/;$$//' byterun/primitives; \ + echo '|]'; \ + echo 'let builtin_primitives = [|'; \ + sed -e 's/.*/ "&";/' -e '$$s/;$$//' byterun/primitives; \ echo '|]') > bytecomp/runtimedef.ml partialclean:: @@ -531,7 +531,7 @@ beforedepend:: asmcomp/scheduling.ml asmcomp/emit.ml: asmcomp/$(ARCH)/emit.mlp tools/cvt_emit $(CAMLRUN) tools/cvt_emit < asmcomp/$(ARCH)/emit.mlp > asmcomp/emit.ml \ - || { rm -f asmcomp/emit.ml; exit 2; } + || { rm -f asmcomp/emit.ml; exit 2; } partialclean:: rm -f asmcomp/emit.ml @@ -555,7 +555,7 @@ partialclean:: runtime: cd byterun; $(MAKE) all if test -f stdlib/libcamlrun.a; then :; else \ - ln -s ../byterun/libcamlrun.a stdlib/libcamlrun.a; fi + ln -s ../byterun/libcamlrun.a stdlib/libcamlrun.a; fi clean:: cd byterun; $(MAKE) clean @@ -649,18 +649,18 @@ alldepend:: otherlibraries: ocamltools for i in $(OTHERLIBRARIES); do \ - (cd otherlibs/$$i; $(MAKE) RUNTIME=$(RUNTIME) all) || exit $$?; \ - done + (cd otherlibs/$$i; $(MAKE) RUNTIME=$(RUNTIME) all) || exit $$?; \ + done otherlibrariesopt: for i in $(OTHERLIBRARIES); do \ - (cd otherlibs/$$i; $(MAKE) allopt) || exit $$?; \ - done + (cd otherlibs/$$i; $(MAKE) allopt) || exit $$?; \ + done partialclean:: for i in $(OTHERLIBRARIES); do \ - (cd otherlibs/$$i; $(MAKE) partialclean); \ - done + (cd otherlibs/$$i; $(MAKE) partialclean); \ + done clean:: for i in $(OTHERLIBRARIES); do (cd otherlibs/$$i; $(MAKE) clean); done diff --git a/Makefile.nt b/Makefile.nt index fe4199b770..62de9eeaae 100644 --- a/Makefile.nt +++ b/Makefile.nt @@ -29,7 +29,7 @@ DEPFLAGS=$(INCLUDES) CAMLRUN=byterun/ocamlrun INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver \ - -I toplevel + -I toplevel UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \ utils/clflags.cmo utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \ @@ -295,7 +295,7 @@ partialclean:: # The native toplevel -ocamlnat: ocamlopt otherlibs/dynlink/dynlink.cmxa $(NATTOPOBJS:.cmo=.cmx) +ocamlnat: ocamlopt otherlibs/dynlink/dynlink.cmxa $(NATTOPOBJS:.cmo=.cmx) $(CAMLOPT) $(LINKFLAGS) otherlibs/dynlink/dynlink.cmxa -o ocamlnat $(NATTOPOBJS:.cmo=.cmx) -linkall toplevel/opttoploop.cmx: otherlibs/dynlink/dynlink.cmxa @@ -309,31 +309,31 @@ otherlibs/dynlink/dynlink.cmxa: otherlibs/dynlink/natdynlink.ml utils/config.ml: utils/config.mlp config/Makefile @rm -f utils/config.ml sed -e "s|%%LIBDIR%%|$(LIBDIR)|" \ - -e "s|%%BYTERUN%%|ocamlrun|" \ - -e 's|%%CCOMPTYPE%%|$(CCOMPTYPE)|' \ - -e "s|%%BYTECC%%|$(BYTECC) $(BYTECCCOMPOPTS)|" \ - -e "s|%%NATIVECC%%|$(NATIVECC) $(NATIVECCCOMPOPTS)|" \ - -e "s|%%PARTIALLD%%|$(PARTIALLD)|" \ - -e "s|%%PACKLD%%|$(PACKLD)|" \ - -e "s|%%BYTECCLIBS%%|$(BYTECCLIBS)|" \ - -e "s|%%NATIVECCLIBS%%|$(NATIVECCLIBS)|" \ - -e 's|%%RANLIBCMD%%|$(RANLIBCMD)|' \ - -e 's|%%BINUTILS_NM%%|$(BINUTILS_NM)|' \ - -e 's|%%BINUTILS_OBJCOPY%%|$(BINUTILS_OBJCOPY)|' \ - -e "s|%%ARCH%%|$(ARCH)|" \ - -e "s|%%MODEL%%|$(MODEL)|" \ - -e "s|%%SYSTEM%%|$(SYSTEM)|" \ - -e "s|%%EXT_OBJ%%|.$(O)|" \ - -e "s|%%EXT_ASM%%|.$(S)|" \ - -e "s|%%EXT_LIB%%|.$(A)|" \ - -e "s|%%EXT_DLL%%|.dll|" \ - -e "s|%%SYSTHREAD_SUPPORT%%|true|" \ - -e 's|%%ASM%%|$(ASM)|' \ - -e 's|%%MKDLL%%|$(MKDLL)|' \ - -e 's|%%MKEXE%%|$(MKEXE)|' \ - -e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \ - -e 's|%%CC_PROFILE%%||' \ - utils/config.mlp > utils/config.ml + -e "s|%%BYTERUN%%|ocamlrun|" \ + -e 's|%%CCOMPTYPE%%|$(CCOMPTYPE)|' \ + -e "s|%%BYTECC%%|$(BYTECC) $(BYTECCCOMPOPTS)|" \ + -e "s|%%NATIVECC%%|$(NATIVECC) $(NATIVECCCOMPOPTS)|" \ + -e "s|%%PARTIALLD%%|$(PARTIALLD)|" \ + -e "s|%%PACKLD%%|$(PACKLD)|" \ + -e "s|%%BYTECCLIBS%%|$(BYTECCLIBS)|" \ + -e "s|%%NATIVECCLIBS%%|$(NATIVECCLIBS)|" \ + -e 's|%%RANLIBCMD%%|$(RANLIBCMD)|' \ + -e 's|%%BINUTILS_NM%%|$(BINUTILS_NM)|' \ + -e 's|%%BINUTILS_OBJCOPY%%|$(BINUTILS_OBJCOPY)|' \ + -e "s|%%ARCH%%|$(ARCH)|" \ + -e "s|%%MODEL%%|$(MODEL)|" \ + -e "s|%%SYSTEM%%|$(SYSTEM)|" \ + -e "s|%%EXT_OBJ%%|.$(O)|" \ + -e "s|%%EXT_ASM%%|.$(S)|" \ + -e "s|%%EXT_LIB%%|.$(A)|" \ + -e "s|%%EXT_DLL%%|.dll|" \ + -e "s|%%SYSTHREAD_SUPPORT%%|true|" \ + -e 's|%%ASM%%|$(ASM)|' \ + -e 's|%%MKDLL%%|$(MKDLL)|' \ + -e 's|%%MKEXE%%|$(MKEXE)|' \ + -e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \ + -e 's|%%CC_PROFILE%%||' \ + utils/config.mlp > utils/config.ml @chmod -w utils/config.ml partialclean:: @@ -394,7 +394,7 @@ $(OPTOBJS:.cmo=.cmx): ocamlopt bytecomp/opcodes.ml: byterun/instruct.h sed -n -e "/^enum/p" -e "s|,||g" -e "/^ /p" byterun/instruct.h | \ - gawk -f tools/make-opcodes > bytecomp/opcodes.ml + gawk -f tools/make-opcodes > bytecomp/opcodes.ml partialclean:: rm -f bytecomp/opcodes.ml @@ -410,9 +410,9 @@ bytecomp/runtimedef.ml: byterun/primitives byterun/fail.h (echo 'let builtin_exceptions = [|'; \ sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$$| \1;|p' byterun/fail.h | \ sed -e '$$s/;$$//'; \ - echo '|]'; \ - echo 'let builtin_primitives = [|'; \ - sed -e 's/.*/ "&";/' -e '$$s/;$$//' byterun/primitives; \ + echo '|]'; \ + echo 'let builtin_primitives = [|'; \ + sed -e 's/.*/ "&";/' -e '$$s/;$$//' byterun/primitives; \ echo '|]') > bytecomp/runtimedef.ml partialclean:: @@ -561,9 +561,9 @@ alldepend:: # OCamldoc -ocamldoc.byte: +ocamldoc.byte: cd ocamldoc ; $(MAKEREC) all -ocamldoc.opt: +ocamldoc.opt: cd ocamldoc ; $(MAKEREC) opt.opt partialclean:: cd ocamldoc ; $(MAKEREC) clean @@ -84,7 +84,7 @@ All files marked "Copyright INRIA" in this distribution are copyright INSTALLATION: -See the file INSTALL for installation instructions on Unix, Linux and +See the file INSTALL for installation instructions on Unix, Linux and MacOS X machines. For MS Windows, see README.win32. DOCUMENTATION: diff --git a/README.win32 b/README.win32 index bb6b31d90c..9479e11377 100644 --- a/README.win32 +++ b/README.win32 @@ -6,7 +6,7 @@ There are no less than four ports of Objective Caml for MS Windows available: - a native Win32 port, built with the Cygwin/MinGW development tools; - a port consisting of the Unix sources compiled under the Cygwin Unix-like environment for Windows; - - a native Win64 port (64-bit Windows), built with the Microsoft + - a native Win64 port (64-bit Windows), built with the Microsoft development tools. Here is a summary of the main differences between these ports: @@ -95,7 +95,7 @@ THIRD-PARTY SOFTWARE: 2005 can download MASM version 8 from http://www.microsoft.com/downloads/details.aspx?FamilyID=7A1C9DA0-0510-44A2-B042-7EF370530C64&displaylang=en To obtain MASM version 6.11, see - http://users.easystreet.com/jkirwan/new/pctools.html. + http://users.easystreet.com/jkirwan/new/pctools.html. [4] TCL/TK version 8.5. Windows binaries are available as part of the ActiveTCL distribution at http://www.activestate.com/products/ActiveTcl/ @@ -152,7 +152,7 @@ performance of bytecode programs is about 2/3 of that obtained under Unix/GCC or Cygwin or Mingw on similar hardware. * Libraries available in this port: "num", "str", "threads", "graphics", -"labltk", and large parts of "unix". +"labltk", and large parts of "unix". * The replay debugger is partially supported (no reverse execution). @@ -178,7 +178,7 @@ The base bytecode system (ocamlc, ocaml, ocamllex, ocamlyacc, ...) runs without any additional tools. The native-code compiler (ocamlopt), as well as static linking of -Caml bytecode with C code (ocamlc -custom), require +Caml bytecode with C code (ocamlc -custom), require the Cygwin development tools, available at http://www.cygwin.com/ and the flexdll tool, available at @@ -191,7 +191,7 @@ Do *not* install the Mingw/MSYS development tools from www.mingw.org: these are not compatible with this Caml port (@responsefile not recognized on the command line). -The LablTk GUI requires Tcl/Tk 8.5. Windows binaries are available +The LablTk GUI requires Tcl/Tk 8.5. Windows binaries are available as part of the ActiveTCL distribution at http://www.activestate.com/products/ActiveTcl/ @@ -216,7 +216,7 @@ RECOMPILATION FROM THE SOURCES: You will need the following software components to perform the recompilation: - Windows NT, 2000, XP, or Vista. - Cygwin: http://sourceware.cygnus.com/cygwin/ - Install at least the following packages: binutils, diffutils, + Install at least the following packages: binutils, diffutils, gcc-core, gcc-mingw-core, make, mingw-runtime, ncurses, w32-api. - TCL/TK version 8.5 (see above). - The flexdll tool (see above). @@ -238,7 +238,7 @@ Normally, the only variables that need to be changed are PREFIX where to install everything TK_ROOT where TCL/TK was installed -Finally, use "make -f Makefile.nt" to build the system, e.g. +Finally, use "make -f Makefile.nt" to build the system, e.g. make -f Makefile.nt world make -f Makefile.nt bootstrap @@ -250,7 +250,7 @@ Finally, use "make -f Makefile.nt" to build the system, e.g. NOTES: * Libraries available in this port: "num", "str", "threads", "graphics", - "labltk", and large parts of "unix". + "labltk", and large parts of "unix". * The replay debugger is partially supported (no reverse execution). @@ -357,7 +357,7 @@ compiler for AMD64 instead of the Platform SDK compiler, replace the line by EXTRALIBS= -Finally, use "make -f Makefile.nt" to build the system, e.g. +Finally, use "make -f Makefile.nt" to build the system, e.g. make -f Makefile.nt world make -f Makefile.nt bootstrap @@ -369,7 +369,7 @@ Finally, use "make -f Makefile.nt" to build the system, e.g. NOTES: * Libraries available in this port: "num", "str", "threads", "graphics", - and large parts of "unix". + and large parts of "unix". * The replay debugger is partially supported (no reverse execution). @@ -97,7 +97,7 @@ A8: The new default mode is more flexible than the original commuting interface must also be present in the implementation. The addlabels tool can help you to do that. Suppose that you have mymod.ml and mymod.mli, where mymod.mli adds some labels. Then - doing + doing $CAMLLIB/addlabels mymod.ml will insert labels from the interface inside the implementation. It also takes care of inserting them in recursive calls, as @@ -106,4 +106,4 @@ A8: The new default mode is more flexible than the original commuting If you used labels from standard libraries, you will also have problems with them. You can proceed as described in A6. Since you used classic mode, you do not need to bother about changed - argument order.
\ No newline at end of file + argument order. diff --git a/asmcomp/alpha/emit.mlp b/asmcomp/alpha/emit.mlp index 3c04b7a47a..6857da04ef 100644 --- a/asmcomp/alpha/emit.mlp +++ b/asmcomp/alpha/emit.mlp @@ -129,7 +129,7 @@ let emit_label lbl = emit_string "$"; emit_int lbl let emit_Llabel fallthrough lbl = - if (not fallthrough) then begin + if (not fallthrough) then begin emit_string " .align 4\n" end ; emit_label lbl @@ -195,7 +195,7 @@ let int_reg_number = [| 0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 16; 17; 18; 19; 20; 21; 22 |] - + let float_reg_number = [| 0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 17; 18; 19; 20; 21; 22; 23; 24; 25; 26; 27; 29; 30 @@ -358,7 +358,7 @@ let emit_instr fallthrough i = Lend -> () | Lop(Imove | Ispill | Ireload) -> let src = i.arg.(0) and dst = i.res.(0) in - if src.loc <> dst.loc then begin + if src.loc <> dst.loc then begin match (src.loc, dst.loc) with (Reg rs, Reg rd) -> if src.typ = Float then @@ -381,7 +381,7 @@ let emit_instr fallthrough i = | Lop(Iconst_int n) -> if n = 0n then ` clr {emit_reg i.res.(0)}\n` - else if digital_asm || + else if digital_asm || (n >= Nativeint.of_int (-0x80000000) && n <= Nativeint.of_int 0x7FFFFFFF) then ` ldiq {emit_reg i.res.(0)}, {emit_nativeint n}\n` diff --git a/asmcomp/alpha/proc.ml b/asmcomp/alpha/proc.ml index 6bcf44f59a..f31b852fbd 100644 --- a/asmcomp/alpha/proc.ml +++ b/asmcomp/alpha/proc.ml @@ -49,7 +49,7 @@ let int_reg_name = [| (* 8-12 *) "$8"; "$9"; "$10"; "$11"; "$12"; (* 13-19 *) "$16"; "$17"; "$18"; "$19"; "$20"; "$21"; "$22" |] - + let float_reg_name = [| (* 100-107 *) "$f0"; "$f1"; "$f2"; "$f3"; "$f4"; "$f5"; "$f6"; "$f7"; (* 108-115 *) "$f8"; "$f9"; "$f10"; "$f11"; "$f12"; "$f13"; "$f14"; "$f15"; @@ -210,7 +210,7 @@ let assemble_file infile outfile = if digital_asm && !Clflags.gprofile then Config.as ^ " -pg" else Config.as in - Ccomp.command (as_cmd ^ " -o " ^ + Ccomp.command (as_cmd ^ " -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) open Clflags;; diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index 950748d6e2..b1f886da9c 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -60,7 +60,7 @@ let slot_offset loc cl = (* Symbols *) let emit_symbol s = - if macosx then emit_string "_"; + if macosx then emit_string "_"; Emitaux.emit_symbol '$' s let emit_call s = @@ -791,4 +791,3 @@ let end_assembly() = if Config.system = "linux" then (* Mark stack as non-executable, PR#4564 *) ` .section .note.GNU-stack,\"\",%progbits\n` - diff --git a/asmcomp/amd64/emit_nt.mlp b/asmcomp/amd64/emit_nt.mlp index 71b71157b8..23c5b34ec3 100644 --- a/asmcomp/amd64/emit_nt.mlp +++ b/asmcomp/amd64/emit_nt.mlp @@ -39,10 +39,10 @@ let frame_required () = let frame_size () = (* includes return address *) if frame_required() then begin - let sz = + let sz = (!stack_offset + 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + 8) in Misc.align sz 16 - end else + end else !stack_offset + 8 let slot_offset loc cl = @@ -63,7 +63,7 @@ let emit_int32 n = emit_printf "0%lxh" n let emit_symbol s = Emitaux.emit_symbol '$' s -(* Record symbols used and defined - at the end generate extern for those +(* Record symbols used and defined - at the end generate extern for those used but not defined *) let symbols_defined = ref StringSet.empty @@ -84,11 +84,11 @@ let emit_label lbl = let emit_align n = ` ALIGN {emit_int n}\n` - + let emit_Llabel fallthrough lbl = if not fallthrough && !fastcode_flag then emit_align 4; emit_label lbl - + (* Output a pseudo-register *) let emit_reg = function @@ -106,13 +106,13 @@ let emit_reg = function (* Output a reference to the lower 8, 16 or 32 bits of a register *) let reg_low_8_name = - [| "al"; "bl"; "dil"; "sil"; "dl"; "cl"; "r8b"; "r9b"; + [| "al"; "bl"; "dil"; "sil"; "dl"; "cl"; "r8b"; "r9b"; "r10b"; "r11b"; "bpl"; "r12b"; "r13b" |] let reg_low_16_name = - [| "ax"; "bx"; "di"; "si"; "dx"; "cx"; "r8w"; "r9w"; + [| "ax"; "bx"; "di"; "si"; "dx"; "cx"; "r8w"; "r9w"; "r10w"; "r11w"; "bp"; "r12w"; "r13w" |] let reg_low_32_name = - [| "eax"; "ebx"; "edi"; "esi"; "edx"; "ecx"; "r8d"; "r9d"; + [| "eax"; "ebx"; "edi"; "esi"; "edx"; "ecx"; "r8d"; "r9d"; "r10d"; "r11d"; "ebp"; "r12d"; "r13d" |] let emit_subreg tbl pref r = @@ -253,7 +253,7 @@ let name_for_cond_branch = function | Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "be" | Iunsigned Cgt -> "a" | Iunsigned Clt -> "b" | Iunsigned Cge -> "ae" - + (* Output an = 0 or <> 0 test. *) let output_test_zero arg = @@ -544,7 +544,7 @@ let emit_instr fallthrough i = ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; let b = name_for_cond_branch cmp in ` j{emit_string b} {emit_label lbl}\n` - | Iinttest_imm((Isigned Ceq | Isigned Cne | + | Iinttest_imm((Isigned Ceq | Isigned Cne | Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> output_test_zero i.arg.(0); let b = name_for_cond_branch cmp in diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml index c0807b88d4..4ba0d5c3ec 100644 --- a/asmcomp/amd64/proc.ml +++ b/asmcomp/amd64/proc.ml @@ -31,24 +31,24 @@ open Mach rcx 5 r8 6 r9 7 - r10 8 - r11 9 + r10 8 + r11 9 rbp 10 - r12 11 - r13 12 + r12 11 + r13 12 r14 trap pointer r15 allocation pointer - + xmm0 - xmm15 100 - 115 xmm0 - xmm9: Caml function arguments xmm0 - xmm7: C function arguments xmm0: Caml and C function results *) let int_reg_name = - [| "%rax"; "%rbx"; "%rdi"; "%rsi"; "%rdx"; "%rcx"; "%r8"; "%r9"; + [| "%rax"; "%rbx"; "%rdi"; "%rsi"; "%rdx"; "%rcx"; "%r8"; "%r9"; "%r10"; "%r11"; "%rbp"; "%r12"; "%r13" |] let float_reg_name = - [| "%xmm0"; "%xmm1"; "%xmm2"; "%xmm3"; "%xmm4"; "%xmm5"; "%xmm6"; "%xmm7"; + [| "%xmm0"; "%xmm1"; "%xmm2"; "%xmm3"; "%xmm4"; "%xmm5"; "%xmm6"; "%xmm7"; "%xmm8"; "%xmm9"; "%xmm10"; "%xmm11"; "%xmm12"; "%xmm13"; "%xmm14"; "%xmm15" |] diff --git a/asmcomp/amd64/proc_nt.ml b/asmcomp/amd64/proc_nt.ml index 05ce517dd7..5c90e4f52e 100644 --- a/asmcomp/amd64/proc_nt.ml +++ b/asmcomp/amd64/proc_nt.ml @@ -31,25 +31,25 @@ open Mach rcx 5 r8 6 r9 7 - r10 8 - r11 9 + r10 8 + r11 9 rbp 10 - r12 11 - r13 12 + r12 11 + r13 12 r14 trap pointer r15 allocation pointer - + xmm0 - xmm15 100 - 115 xmm0 - xmm9: Caml function arguments xmm0 - xmm3: C function arguments xmm0: Caml and C function results xmm6-xmm15 are preserved by C *) let int_reg_name = - [| "rax"; "rbx"; "rdi"; "rsi"; "rdx"; "rcx"; "r8"; "r9"; + [| "rax"; "rbx"; "rdi"; "rsi"; "rdx"; "rcx"; "r8"; "r9"; "r10"; "r11"; "rbp"; "r12"; "r13" |] let float_reg_name = - [| "xmm0"; "xmm1"; "xmm2"; "xmm3"; "xmm4"; "xmm5"; "xmm6"; "xmm7"; + [| "xmm0"; "xmm1"; "xmm2"; "xmm3"; "xmm4"; "xmm5"; "xmm6"; "xmm7"; "xmm8"; "xmm9"; "xmm10"; "xmm11"; "xmm12"; "xmm13"; "xmm14"; "xmm15" |] let num_register_classes = 2 @@ -229,5 +229,5 @@ let contains_calls = ref false let assemble_file infile outfile = Ccomp.command (Config.asm ^ - Filename.quote outfile ^ " " ^ + Filename.quote outfile ^ " " ^ Filename.quote infile ^ "> NUL") diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp index a2a6b4dad3..307d097dc4 100644 --- a/asmcomp/arm/emit.mlp +++ b/asmcomp/arm/emit.mlp @@ -274,7 +274,7 @@ let emit_instr i = ` mov {emit_reg i.res.(0)}, #{emit_nativeint low_bits} @ {emit_string s}\n`; ` mov {emit_reg i.res.(1)}, #{emit_nativeint high_bits}\n`; 2 - end else begin + end else begin let lbl = label_constant float_constants s 2 in ` ldr {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string s}\n`; ` ldr {emit_reg i.res.(1)}, {emit_label lbl} + 4\n`; diff --git a/asmcomp/arm/selection.ml b/asmcomp/arm/selection.ml index 3fdbd640aa..ded233edad 100644 --- a/asmcomp/arm/selection.ml +++ b/asmcomp/arm/selection.ml @@ -166,7 +166,7 @@ method select_operation op args = method select_condition = function | Cop(Ccmpf cmp, args) -> (Iinttest_imm(Isigned cmp, 0), - Cop(Cextcall(float_comparison_function cmp, + Cop(Cextcall(float_comparison_function cmp, typ_int, false, Debuginfo.none), args)) | expr -> @@ -198,4 +198,3 @@ method insert_op_debug op dbg rs rd = end let fundecl f = (new selector)#emit_fundecl f - diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index 36edea8cf4..9cdf61f40c 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -90,7 +90,7 @@ let compile_genfuns ppf f = List.iter (function | (Cfunction {fun_name = name}) as ph when f name -> - compile_phrase ppf ph + compile_phrase ppf ph | _ -> ()) (Cmmgen.generic_functions true [Compilenv.current_unit_infos ()]) diff --git a/asmcomp/asmlibrarian.ml b/asmcomp/asmlibrarian.ml index 62815809e4..d54d89297b 100644 --- a/asmcomp/asmlibrarian.ml +++ b/asmcomp/asmlibrarian.ml @@ -71,4 +71,3 @@ let report_error ppf = function fprintf ppf "Cannot find file %s" name | Archiver_error name -> fprintf ppf "Error while creating the library %s" name - diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index 6be94a1b64..cb757efc23 100644 --- a/asmcomp/asmpackager.ml +++ b/asmcomp/asmpackager.ml @@ -83,10 +83,10 @@ let make_package_object ppf members targetobj targetname coercion = let objtemp = if !Clflags.keep_asm_file then chop_extension_if_any targetobj ^ ".pack" ^ Config.ext_obj - else + else (* Put the full name of the module in the temporary file name - to avoid collisions with MSVC's link /lib in case of successive - packs *) + to avoid collisions with MSVC's link /lib in case of successive + packs *) Filename.temp_file (Compilenv.make_symbol (Some "")) Config.ext_obj in let components = List.map diff --git a/asmcomp/closure.mli b/asmcomp/closure.mli index cf98dffbc5..f16379068d 100644 --- a/asmcomp/closure.mli +++ b/asmcomp/closure.mli @@ -15,4 +15,3 @@ (* Introduction of closures, uncurrying, recognition of direct calls *) val intro: int -> Lambda.lambda -> Clambda.ulambda - diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml index 8d817a857d..68625e24c8 100644 --- a/asmcomp/cmm.ml +++ b/asmcomp/cmm.ml @@ -129,4 +129,3 @@ type data_item = type phrase = Cfunction of fundecl | Cdata of data_item list - diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli index 5cabc0066a..1b09071657 100644 --- a/asmcomp/cmm.mli +++ b/asmcomp/cmm.mli @@ -115,4 +115,3 @@ type data_item = type phrase = Cfunction of fundecl | Cdata of data_item list - diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 00742dcf99..635c3f751c 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -1950,9 +1950,9 @@ let generic_functions shared units = let (apply,send,curry) = List.fold_left (fun (apply,send,curry) ui -> - List.fold_right IntSet.add ui.Compilenv.ui_apply_fun apply, - List.fold_right IntSet.add ui.Compilenv.ui_send_fun send, - List.fold_right IntSet.add ui.Compilenv.ui_curry_fun curry) + List.fold_right IntSet.add ui.Compilenv.ui_apply_fun apply, + List.fold_right IntSet.add ui.Compilenv.ui_send_fun send, + List.fold_right IntSet.add ui.Compilenv.ui_curry_fun curry) (IntSet.empty,IntSet.empty,IntSet.empty) units in let apply = if shared then apply else IntSet.union apply default_apply in @@ -2071,7 +2071,7 @@ let plugin_header units = crc = crc; imports_cmi = ui.Compilenv.ui_imports_cmi; imports_cmx = ui.Compilenv.ui_imports_cmx; - defines = ui.Compilenv.ui_defines + defines = ui.Compilenv.ui_defines } in global_data "caml_plugin_header" { magic = dyn_magic_number; units = List.map mk units } diff --git a/asmcomp/cmmgen.mli b/asmcomp/cmmgen.mli index 50771c81bf..bd3d9acfff 100644 --- a/asmcomp/cmmgen.mli +++ b/asmcomp/cmmgen.mli @@ -23,7 +23,7 @@ val generic_functions: bool -> Compilenv.unit_infos list -> Cmm.phrase list val entry_point: string list -> Cmm.phrase val global_table: string list -> Cmm.phrase val reference_symbols: string list -> Cmm.phrase -val globals_map: (string * Digest.t * Digest.t * string list) list -> +val globals_map: (string * Digest.t * Digest.t * string list) list -> Cmm.phrase val frame_table: string list -> Cmm.phrase val data_segment_table: string list -> Cmm.phrase diff --git a/asmcomp/codegen.ml b/asmcomp/codegen.ml index fe841e70eb..280f139408 100644 --- a/asmcomp/codegen.ml +++ b/asmcomp/codegen.ml @@ -39,7 +39,7 @@ let rec regalloc fd = let (newfd, redo_regalloc) = Reload.fundecl fd in if !dump_reload then Printmach.phase "After insertion of reloading code" newfd; - if redo_regalloc + if redo_regalloc then begin Reg.reinit(); Liveness.fundecl newfd; regalloc newfd end else newfd @@ -95,7 +95,3 @@ let file filename = close_in ic; Parsecmmaux.report_error msg | x -> close_in ic; raise x - - - - diff --git a/asmcomp/coloring.ml b/asmcomp/coloring.ml index 0fe105e8c5..37c03a05b2 100644 --- a/asmcomp/coloring.ml +++ b/asmcomp/coloring.ml @@ -50,7 +50,7 @@ let find_degree reg = let cl = Proc.register_class reg in let avail_regs = Proc.num_available_registers.(cl) in if avail_regs = 0 then - (* Don't bother computing the degree if there are no regs + (* Don't bother computing the degree if there are no regs in this class *) unconstrained := Reg.Set.add reg !unconstrained else begin @@ -131,7 +131,7 @@ let iter_preferred f reg = List.iter (fun (r, w) -> walk r w) reg.prefer; reg.visited <- false -(* Where to start the search for a suitable register. +(* Where to start the search for a suitable register. Used to introduce some "randomness" in the choice between registers with equal scores. This offers more opportunities for scheduling. *) diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml index e0f999c208..2bf4b6ec8a 100644 --- a/asmcomp/compilenv.ml +++ b/asmcomp/compilenv.ml @@ -179,7 +179,7 @@ let record_global_approx_toplevel id = let global_approx id = if Ident.is_predef_exn id then Value_unknown else try Hashtbl.find toplevel_approx (Ident.name id) - with Not_found -> + with Not_found -> match get_global_info id with | None -> Value_unknown | Some ui -> ui.ui_approx @@ -240,4 +240,3 @@ let report_error ppf = function fprintf ppf "Corrupted compilation unit description@ %s" filename | Illegal_renaming(modname, filename) -> fprintf ppf "%s@ contains the description for unit@ %s" filename modname - diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli index 762123b012..74120f4cd0 100644 --- a/asmcomp/compilenv.mli +++ b/asmcomp/compilenv.mli @@ -106,5 +106,3 @@ type error = exception Error of error val report_error: Format.formatter -> error -> unit - - diff --git a/asmcomp/debuginfo.ml b/asmcomp/debuginfo.ml index 84390442bc..a7124e171b 100644 --- a/asmcomp/debuginfo.ml +++ b/asmcomp/debuginfo.ml @@ -33,7 +33,7 @@ let none = { let to_string d = if d == none - then "" + then "" else Printf.sprintf "{%s:%d,%d-%d}" d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end diff --git a/asmcomp/debuginfo.mli b/asmcomp/debuginfo.mli index 151cd0abbb..c3c9c406e4 100644 --- a/asmcomp/debuginfo.mli +++ b/asmcomp/debuginfo.mli @@ -28,4 +28,3 @@ val from_location: kind -> Location.t -> t val from_call: Lambda.lambda_event -> t val from_raise: Lambda.lambda_event -> t - diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml index 35338eed9b..d4db78ad75 100644 --- a/asmcomp/emitaux.ml +++ b/asmcomp/emitaux.ml @@ -138,7 +138,7 @@ let emit_frames a = let filenames = Hashtbl.create 7 in let lbl_filenames = ref 200000 in let label_filename name = - try + try Hashtbl.find filenames name with Not_found -> let lbl = !lbl_filenames in @@ -165,7 +165,7 @@ let emit_frames a = Int64.add (Int64.shift_left (Int64.of_int char_end) 26) (Int64.of_int kind))) in a.efa_label_rel - (label_filename d.dinfo_file) + (label_filename d.dinfo_file) (Int64.to_int32 info); a.efa_32 (Int64.to_int32 (Int64.shift_right info 32)) end in @@ -189,4 +189,3 @@ let is_generic_function name = List.exists (fun p -> isprefix p name) ["caml_apply"; "caml_curry"; "caml_send"; "caml_tuplify"] - diff --git a/asmcomp/hppa/arch.ml b/asmcomp/hppa/arch.ml index da022ca40f..eb2e1938dd 100644 --- a/asmcomp/hppa/arch.ml +++ b/asmcomp/hppa/arch.ml @@ -71,4 +71,3 @@ let print_specific_operation printreg op ppf arg = | Ishift1add -> fprintf ppf "%a << 1 + %a" printreg arg.(0) printreg arg.(1) | Ishift2add -> fprintf ppf "%a << 2 + %a" printreg arg.(0) printreg arg.(1) | Ishift3add -> fprintf ppf "%a << 3 + %a" printreg arg.(0) printreg arg.(1) - diff --git a/asmcomp/hppa/emit.mlp b/asmcomp/hppa/emit.mlp index 2c81b78925..b697a335a2 100644 --- a/asmcomp/hppa/emit.mlp +++ b/asmcomp/hppa/emit.mlp @@ -137,7 +137,7 @@ let emit_imports () = let is_offset n = (n < 8192) && (n >= -8192) (* 14 bits *) -let is_offset_native n = +let is_offset_native n = n < Nativeint.of_int 8192 && n >= Nativeint.of_int (-8192) let emit_load instr addr arg dst = diff --git a/asmcomp/hppa/proc.ml b/asmcomp/hppa/proc.ml index 296baa17b9..c0b40adbea 100644 --- a/asmcomp/hppa/proc.ml +++ b/asmcomp/hppa/proc.ml @@ -40,18 +40,18 @@ open Mach %fr31 temporary *) let int_reg_name = [| - (* 0-4 *) "%r6"; "%r7"; "%r8"; "%r9"; "%r10"; + (* 0-4 *) "%r6"; "%r7"; "%r8"; "%r9"; "%r10"; (* 5-10 *) "%r11"; "%r12"; "%r13"; "%r14"; "%r15"; "%r16"; - (* 11-16 *) "%r17"; "%r18"; "%r19"; "%r20"; "%r21"; "%r22"; + (* 11-16 *) "%r17"; "%r18"; "%r19"; "%r20"; "%r21"; "%r22"; (* 17-20 *) "%r23"; "%r24"; "%r25"; "%r26"; (* 21-22 *) "%r28"; "%r29" |] - + let float_reg_name = [| (* 100-105 *) "%fr4"; "%fr5"; "%fr6"; "%fr7"; "%fr8"; "%fr9"; (* 106-111 *) "%fr10"; "%fr11"; "%fr12"; "%fr13"; "%fr14"; "%fr15"; (* 112-117 *) "%fr16"; "%fr17"; "%fr18"; "%fr19"; "%fr20"; "%fr21"; - (* 118-123 *) "%fr22"; "%fr23"; "%fr24"; "%fr25"; "%fr26"; "%fr27"; + (* 118-123 *) "%fr22"; "%fr23"; "%fr24"; "%fr25"; "%fr26"; "%fr27"; (* 124-127 *) "%fr28"; "%fr29"; "%fr30"; "%fr31" |] @@ -141,7 +141,7 @@ let loc_results res = let (loc, ofs) = calling_conventions 20 13 100 107 not_supported res in loc (* Calling C functions: - when all arguments are integers, use %r26 - %r23, + when all arguments are integers, use %r26 - %r23, then -52(%r30), -56(%r30), etc. When some arguments are floats, we handle a couple of cases by hand and fail otherwise. *) @@ -218,7 +218,7 @@ let contains_calls = ref false let assemble_file infile outfile = Ccomp.command (Config.asm ^ " -o " ^ - Filename.quote outfile ^ " " ^ Filename.quote infile) + Filename.quote outfile ^ " " ^ Filename.quote infile) open Clflags;; open Config;; diff --git a/asmcomp/hppa/selection.ml b/asmcomp/hppa/selection.ml index 6a0e9fe409..a13b527114 100644 --- a/asmcomp/hppa/selection.ml +++ b/asmcomp/hppa/selection.ml @@ -69,7 +69,7 @@ method select_operation op args = Cand, Cor, Cxor : never *) | (Cmuli, ([arg1; Cconst_int n] as args)) -> let l = Misc.log2 n in - if n = 1 lsl l + if n = 1 lsl l then (Iintop_imm(Ilsl, l), [arg1]) else (Iintop Imul, args) | (Cmuli, ([Cconst_int n; arg1] as args)) -> diff --git a/asmcomp/i386/arch.ml b/asmcomp/i386/arch.ml index 81f94c8fb8..04d673d91d 100644 --- a/asmcomp/i386/arch.ml +++ b/asmcomp/i386/arch.ml @@ -144,11 +144,10 @@ let print_specific_operation printreg op ppf arg = if i > 0 then fprintf ppf ", "; printreg ppf arg.(i) done - + (* Stack alignment constraints *) let stack_alignment = match Config.system with | "macosx" -> 16 | _ -> 4 - diff --git a/asmcomp/i386/emit_nt.mlp b/asmcomp/i386/emit_nt.mlp index a0c94e181d..da1606e449 100644 --- a/asmcomp/i386/emit_nt.mlp +++ b/asmcomp/i386/emit_nt.mlp @@ -49,7 +49,7 @@ let slot_offset loc cl = | Outgoing n -> assert (n >= 0); n -(* Record symbols used and defined - at the end generate extern for those +(* Record symbols used and defined - at the end generate extern for those used but not defined *) let symbols_defined = ref StringSet.empty @@ -74,7 +74,7 @@ let emit_label lbl = (* Output an align directive. *) let emit_align n = ` ALIGN {emit_int n}\n` - + (* Output a pseudo-register *) let emit_reg = function @@ -257,7 +257,7 @@ let name_for_cond_branch = function | Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "be" | Iunsigned Cgt -> "a" | Iunsigned Clt -> "b" | Iunsigned Cge -> "ae" - + (* Output an = 0 or <> 0 test. *) let output_test_zero arg = @@ -687,7 +687,7 @@ let emit_instr i = ` cmp {emit_reg i.arg.(0)},{emit_reg i.arg.(1)}\n`; let b = name_for_cond_branch cmp in ` j{emit_string b} {emit_label lbl}\n` - | Iinttest_imm((Isigned Ceq | Isigned Cne | + | Iinttest_imm((Isigned Ceq | Isigned Cne | Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> output_test_zero i.arg.(0); let b = name_for_cond_branch cmp in diff --git a/asmcomp/i386/proc_nt.ml b/asmcomp/i386/proc_nt.ml index 03b5a2f6bc..5e617ff1a9 100644 --- a/asmcomp/i386/proc_nt.ml +++ b/asmcomp/i386/proc_nt.ml @@ -183,4 +183,4 @@ let contains_calls = ref false let assemble_file infile outfile = Ccomp.command (Config.asm ^ Filename.quote outfile ^ " " ^ Filename.quote infile ^ - (if !Clflags.verbose then "" else ">NUL")) + (if !Clflags.verbose then "" else ">NUL")) diff --git a/asmcomp/i386/selection.ml b/asmcomp/i386/selection.ml index 2f0dd90ee3..d9600f16d7 100644 --- a/asmcomp/i386/selection.ml +++ b/asmcomp/i386/selection.ml @@ -72,7 +72,7 @@ let rec select_addr exp = end | arg -> (Alinear arg, 0) - + (* C functions to be turned into Ifloatspecial instructions if -ffast-math *) let inline_float_ops = @@ -310,7 +310,7 @@ method emit_extcall_args env args = let sz2 = Misc.align sz1 stack_alignment in let rec emit_pushes = function | [] -> - if sz2 > sz1 then + if sz2 > sz1 then self#insert (Iop (Istackoffset (sz2 - sz1))) [||] [||] | e :: el -> emit_pushes el; @@ -324,4 +324,3 @@ method emit_extcall_args env args = end let fundecl f = (new selector)#emit_fundecl f - diff --git a/asmcomp/ia64/emit.mlp b/asmcomp/ia64/emit.mlp index fb84e9e08c..3d8eeb974f 100644 --- a/asmcomp/ia64/emit.mlp +++ b/asmcomp/ia64/emit.mlp @@ -347,7 +347,7 @@ let insimm opc arg imm res = for i = 0 to Array.length arg - 1 do Hashtbl.add code_uses arg.(i) node done; - (* Insert in appropriate queue *) + (* Insert in appropriate queue *) if node.instr.kind = KB then add_branch node else if node.ancestors = 0 then add_ready node @@ -359,7 +359,7 @@ let insert opc arg res = let rec longest_path node = if node.length < 0 then begin - node.length <- + node.length <- List.fold_left (fun len (son, delay) -> max len (longest_path son + delay)) 0 node.sons @@ -447,10 +447,10 @@ let can_issue instr = | KF -> if !num_F < 2 then (incr num_F; true) else false | KI -> - if !num_I < 2 && !num_A + !num_I + !num_M < 4 + if !num_I < 2 && !num_A + !num_I + !num_M < 4 then (incr num_I; true) else false | KM -> - if !num_M < 2 && !num_A + !num_I + !num_M < 4 + if !num_M < 2 && !num_A + !num_I + !num_M < 4 then (incr num_M; true) else false | _ (* KB | KB_exc *) -> if !num_B < 3 then (incr num_B; true) else false @@ -481,7 +481,7 @@ let emit_node date node = end) node.sons -(* Emit all ready nodes that we can emit given the architectural +(* Emit all ready nodes that we can emit given the architectural constraints. *) let rec emit_ready_nodes filter date = @@ -561,7 +561,7 @@ let end_basic_block () = (* Compute critical paths and rebuild ready queue sorted by decreasing criticality *) let r = !ready_queue in - ready_queue := []; + ready_queue := []; let max_length = List.fold_left (fun len node -> max len (longest_path node)) 0 r in List.iter add_ready r; @@ -760,7 +760,7 @@ let is_immediate_adds n = n >= -0x2000 && n < 0x2000 let ones_pos n = let rec ones p accu = - if p >= 63 + if p >= 63 then accu else ones (p+1) (if n land (1 lsl p) = 0 then accu else p :: accu) in ones 0 [] @@ -795,7 +795,7 @@ let emit_instr i = Lend -> () | Lop(Imove | Ispill | Ireload) -> let src = i.arg.(0) and dst = i.res.(0) in - if src.loc <> dst.loc then begin + if src.loc <> dst.loc then begin match (src.loc, dst.loc) with (Reg _, Reg _) -> insert "mov" (regs i.arg) (regs i.res) @@ -1198,7 +1198,7 @@ let emit_instr i = | Lpushtrap -> end_basic_block(); stack_offset := !stack_offset + 16; - (* Store trap pointer at sp, handler addr at sp+8, + (* Store trap pointer at sp, handler addr at sp+8, and decrement sp by 16. Remember, the bottom 16 bytes of the stack must be left free. *) ` add r3 = 8, sp\n`; diff --git a/asmcomp/ia64/proc.ml b/asmcomp/ia64/proc.ml index a82536586a..15311aa024 100644 --- a/asmcomp/ia64/proc.ml +++ b/asmcomp/ia64/proc.ml @@ -71,10 +71,10 @@ let int_reg_name = [| "r88"; "r89"; "r90"; "r91"; (* 80-81 *) "r14"; "r15" |] - + let float_reg_name = [| (* 0-13 *) "f2"; "f3"; "f4"; "f5"; "f6"; "f7"; - "f8"; "f9"; "f10"; "f11"; "f12"; "f13"; "f14"; "f15"; + "f8"; "f9"; "f10"; "f11"; "f12"; "f13"; "f14"; "f15"; (* 14-29 *) "f16"; "f17"; "f18"; "f19"; "f20"; "f21"; "f22"; "f23"; "f24"; "f25"; "f26"; "f27"; "f28"; "f29"; "f30"; "f31"; (* 30-61 *) "f32"; "f33"; "f34"; "f35"; "f36"; "f37"; "f38"; "f39"; diff --git a/asmcomp/ia64/scheduling.ml b/asmcomp/ia64/scheduling.ml index ad64801527..9bed03a6c7 100644 --- a/asmcomp/ia64/scheduling.ml +++ b/asmcomp/ia64/scheduling.ml @@ -14,7 +14,7 @@ open Schedgen (* to create a dependency *) -(* We don't schedule here on the linearized code, but instead schedule the +(* We don't schedule here on the linearized code, but instead schedule the assembly code generated in Emit. *) let fundecl f = f diff --git a/asmcomp/ia64/selection.ml b/asmcomp/ia64/selection.ml index 949ef884ef..86d2691728 100644 --- a/asmcomp/ia64/selection.ml +++ b/asmcomp/ia64/selection.ml @@ -106,7 +106,7 @@ method select_operation op args = Turn general division and modulus into calls to C library functions *) | (Cdivi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> (Iintop_imm(Idiv, n), [arg]) - | (Cdivi, _) -> + | (Cdivi, _) -> (Iextcall("__divdi3", false), args) | (Cmodi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) && n <> 1 -> (Iintop_imm(Imod, n), [arg]) diff --git a/asmcomp/interf.ml b/asmcomp/interf.ml index b6c0dc4510..30f17b7250 100644 --- a/asmcomp/interf.ml +++ b/asmcomp/interf.ml @@ -98,7 +98,7 @@ let build_graph fundecl = | Iexit _ -> () | Itrywith(body, handler) -> - add_interf_set Proc.destroyed_at_raise handler.live; + add_interf_set Proc.destroyed_at_raise handler.live; interf body; interf handler; interf i.next | Iraise -> () in diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml index 47e4dc68a5..5833595ae6 100644 --- a/asmcomp/linearize.ml +++ b/asmcomp/linearize.ml @@ -49,7 +49,7 @@ and instruction_desc = let has_fallthrough = function | Lreturn | Lbranch _ | Lswitch _ | Lraise | Lop Itailcall_ind | Lop (Itailcall_imm _) -> false - | _ -> true + | _ -> true type fundecl = { fun_name: string; @@ -84,13 +84,13 @@ let rec end_instr = (* Cons an instruction (live, debug empty) *) let instr_cons d a r n = - { desc = d; next = n; arg = a; res = r; + { desc = d; next = n; arg = a; res = r; dbg = Debuginfo.none; live = Reg.Set.empty } (* Cons a simple instruction (arg, res, live empty) *) let cons_instr d n = - { desc = d; next = n; arg = [||]; res = [||]; + { desc = d; next = n; arg = [||]; res = [||]; dbg = Debuginfo.none; live = Reg.Set.empty } (* Build an instruction with arg, res, dbg, live taken from @@ -98,7 +98,7 @@ let cons_instr d n = let copy_instr d i n = { desc = d; next = n; - arg = i.Mach.arg; res = i.Mach.res; + arg = i.Mach.arg; res = i.Mach.res; dbg = i.Mach.dbg; live = i.Mach.live } (* @@ -187,7 +187,7 @@ let rec linear i n = copy_instr (Lcondbranch(test, lbl)) i (linear ifnot n1) | _, Iend, Lbranch lbl -> copy_instr (Lcondbranch(invert_test test, lbl)) i (linear ifso n1) - | Iexit nfail1, Iexit nfail2, _ + | Iexit nfail1, Iexit nfail2, _ when is_next_catch nfail1 -> let lbl2 = find_exit_label nfail2 in copy_instr diff --git a/asmcomp/linearize.mli b/asmcomp/linearize.mli index 59985acad7..aaf03184c2 100644 --- a/asmcomp/linearize.mli +++ b/asmcomp/linearize.mli @@ -42,7 +42,7 @@ and instruction_desc = val has_fallthrough : instruction_desc -> bool val end_instr: instruction -val instr_cons: +val instr_cons: instruction_desc -> Reg.t array -> Reg.t array -> instruction -> instruction val invert_test: Mach.test -> Mach.test @@ -52,4 +52,3 @@ type fundecl = fun_fast: bool } val fundecl: Mach.fundecl -> fundecl - diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml index 13c831fc1c..027550ab12 100644 --- a/asmcomp/mach.ml +++ b/asmcomp/mach.ml @@ -82,23 +82,23 @@ type fundecl = fun_fast: bool } let rec dummy_instr = - { desc = Iend; + { desc = Iend; next = dummy_instr; - arg = [||]; + arg = [||]; res = [||]; dbg = Debuginfo.none; live = Reg.Set.empty } let end_instr () = - { desc = Iend; + { desc = Iend; next = dummy_instr; - arg = [||]; + arg = [||]; res = [||]; dbg = Debuginfo.none; live = Reg.Set.empty } let instr_cons d a r n = - { desc = d; next = n; arg = a; res = r; + { desc = d; next = n; arg = a; res = r; dbg = Debuginfo.none; live = Reg.Set.empty } let instr_cons_debug d a r dbg n = @@ -128,5 +128,4 @@ let rec instr_iter f i = instr_iter f body; instr_iter f handler; instr_iter f i.next | Iraise -> () | _ -> - instr_iter f i.next - + instr_iter f i.next diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli index f1b5eae8b6..438d15d2fc 100644 --- a/asmcomp/mach.mli +++ b/asmcomp/mach.mli @@ -71,7 +71,7 @@ and instruction_desc = | Iswitch of int array * instruction array | Iloop of instruction | Icatch of int * instruction * instruction - | Iexit of int + | Iexit of int | Itrywith of instruction * instruction | Iraise @@ -83,11 +83,10 @@ type fundecl = val dummy_instr: instruction val end_instr: unit -> instruction -val instr_cons: +val instr_cons: instruction_desc -> Reg.t array -> Reg.t array -> instruction -> instruction -val instr_cons_debug: +val instr_cons_debug: instruction_desc -> Reg.t array -> Reg.t array -> Debuginfo.t -> instruction -> instruction val instr_iter: (instruction -> unit) -> instruction -> unit - diff --git a/asmcomp/mips/emit.mlp b/asmcomp/mips/emit.mlp index 6908ccfd48..06915fd34f 100644 --- a/asmcomp/mips/emit.mlp +++ b/asmcomp/mips/emit.mlp @@ -94,7 +94,7 @@ let emit_addressing addr r n = let int_reg_number = [| 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 17; 18; 19; 20; 21 |] - + let float_reg_number = [| 0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 17; 18; 19; 20; 21; 22; 23; 24; 25; 26; 27; 28; 29; 30 |] diff --git a/asmcomp/mips/proc.ml b/asmcomp/mips/proc.ml index 6ac37a4c01..53971890ee 100644 --- a/asmcomp/mips/proc.ml +++ b/asmcomp/mips/proc.ml @@ -50,7 +50,7 @@ let int_reg_name = [| (* 6-13 *) "$8"; "$9"; "$10"; "$11"; "$12"; "$13"; "$14"; "$15"; (* 14-19 *) "$16"; "$17"; "$18"; "$19"; "$20"; "$21" |] - + let float_reg_name = [| "$f0"; "$f1"; "$f2"; "$f3"; "$f4"; "$f5"; "$f6"; "$f7"; "$f8"; "$f9"; @@ -143,7 +143,7 @@ let loc_results res = or float regs $f12...$f19. Each argument "consumes" both one slot in the int register file and one slot in the float register file. Extra arguments are passed on stack, in a 64-bits slot, right-justified - (i.e. at +4 from natural address). *) + (i.e. at +4 from natural address). *) let loc_external_arguments arg = let loc = Array.create (Array.length arg) Reg.dummy in diff --git a/asmcomp/power/arch.ml b/asmcomp/power/arch.ml index 729601650b..8828de7c03 100644 --- a/asmcomp/power/arch.ml +++ b/asmcomp/power/arch.ml @@ -84,4 +84,3 @@ let print_specific_operation printreg op ppf arg = printreg arg.(0) printreg arg.(1) printreg arg.(2) | Ialloc_far n -> fprintf ppf "alloc_far %d" n - diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp index ec3abbde47..b6496f9870 100644 --- a/asmcomp/power/emit.mlp +++ b/asmcomp/power/emit.mlp @@ -116,7 +116,7 @@ let emit_reg r = Reg r -> emit_string (register_name r) | _ -> fatal_error "Emit.emit_reg" -let use_full_regnames = +let use_full_regnames = Config.system = "rhapsody" let emit_gpr r = @@ -607,13 +607,13 @@ let rec emit_instr i dslot = | Lop(Iintop_imm(Idiv, n)) -> (* n is guaranteed to be a power of 2 *) let l = Misc.log2 n in ` {emit_string sragi} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int l}\n`; - ` addze {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` + ` addze {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Imod, n)) -> (* n is guaranteed to be a power of 2 *) let l = Misc.log2 n in ` {emit_string sragi} {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_int l}\n`; ` addze {emit_gpr 0}, {emit_gpr 0}\n`; ` {emit_string slgi} {emit_gpr 0}, {emit_gpr 0}, {emit_int l}\n`; - ` subfc {emit_reg i.res.(0)}, {emit_gpr 0}, {emit_reg i.arg.(0)}\n` + ` subfc {emit_reg i.res.(0)}, {emit_gpr 0}, {emit_reg i.arg.(0)}\n` | Lop(Iintop_imm(Icomp cmp, n)) -> begin match cmp with Isigned c -> diff --git a/asmcomp/power/proc.ml b/asmcomp/power/proc.ml index 5d09342a88..ab8e5a5d5a 100644 --- a/asmcomp/power/proc.ml +++ b/asmcomp/power/proc.ml @@ -45,14 +45,14 @@ let word_addressed = false let int_reg_name = if Config.system = "rhapsody" then - [| "r3"; "r4"; "r5"; "r6"; "r7"; "r8"; "r9"; "r10"; + [| "r3"; "r4"; "r5"; "r6"; "r7"; "r8"; "r9"; "r10"; "r14"; "r15"; "r16"; "r17"; "r18"; "r19"; "r20"; "r21"; "r22"; "r23"; "r24"; "r25"; "r26"; "r27"; "r28" |] else - [| "3"; "4"; "5"; "6"; "7"; "8"; "9"; "10"; + [| "3"; "4"; "5"; "6"; "7"; "8"; "9"; "10"; "14"; "15"; "16"; "17"; "18"; "19"; "20"; "21"; "22"; "23"; "24"; "25"; "26"; "27"; "28" |] - + let float_reg_name = if Config.system = "rhapsody" then [| "f1"; "f2"; "f3"; "f4"; "f5"; "f6"; "f7"; "f8"; diff --git a/asmcomp/power/scheduling.ml b/asmcomp/power/scheduling.ml index ef3a77b340..aac37c8790 100644 --- a/asmcomp/power/scheduling.ml +++ b/asmcomp/power/scheduling.ml @@ -63,4 +63,3 @@ method reload_retaddr_issue_cycles = 3 end let fundecl f = (new scheduler)#schedule_fundecl f - diff --git a/asmcomp/power/selection.ml b/asmcomp/power/selection.ml index f3880b0da6..2818c4fd57 100644 --- a/asmcomp/power/selection.ml +++ b/asmcomp/power/selection.ml @@ -69,7 +69,7 @@ method select_operation op args = a power of 2, which do not correspond to an instruction. *) (Cdivi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> (Iintop_imm(Idiv, n), [arg]) - | (Cdivi, _) -> + | (Cdivi, _) -> (Iintop Idiv, args) | (Cmodi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> (Iintop_imm(Imod, n), [arg]) diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml index 0d592ac03c..364d9ea88a 100644 --- a/asmcomp/printcmm.ml +++ b/asmcomp/printcmm.ml @@ -108,7 +108,7 @@ let rec expr ppf = function | Clet(id, def, body) -> fprintf ppf "@[<2>(let@ @[<2>%a@ %a@]@ %a)@]" - Ident.print id expr def sequence body + Ident.print id expr def sequence body | Cassign(id, exp) -> fprintf ppf "@[<2>(assign @[<2>%a@ %a@])@]" Ident.print id expr exp | Ctuple el -> @@ -142,7 +142,7 @@ let rec expr ppf = function for i = 0 to Array.length cases - 1 do fprintf ppf "@ @[<2>%t@ %a@]" (print_case i) sequence cases.(i) done in - fprintf ppf "@[<v 0>@[<2>(switch@ %a@ @]%t)@]" expr e1 print_cases + fprintf ppf "@[<v 0>@[<2>(switch@ %a@ @]%t)@]" expr e1 print_cases | Cloop e -> fprintf ppf "@[<2>(loop@ %a)@]" sequence e | Ccatch(i, ids, e1, e2) -> @@ -172,7 +172,7 @@ let fundecl ppf f = let print_cases ppf cases = let first = ref true in List.iter - (fun (id, ty) -> + (fun (id, ty) -> if !first then first := false else fprintf ppf "@ "; fprintf ppf "%a: %a" Ident.print id machtype ty) cases in diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml index bd1006a937..d7d538df31 100644 --- a/asmcomp/printmach.ml +++ b/asmcomp/printmach.ml @@ -27,7 +27,7 @@ let reg ppf r = fprintf ppf "/%i" r.stamp; begin match r.loc with | Unknown -> () - | Reg r -> + | Reg r -> fprintf ppf "[%s]" (Proc.register_name r) | Stack(Local s) -> fprintf ppf "[s%i]" s diff --git a/asmcomp/reg.ml b/asmcomp/reg.ml index 42670c472f..f9bef49677 100644 --- a/asmcomp/reg.ml +++ b/asmcomp/reg.ml @@ -82,7 +82,7 @@ let first_virtual_reg_stamp = ref (-1) let reset() = (* When reset() is called for the first time, the current stamp reflects all hard pseudo-registers that have been allocated by Proc, so - remember it and use it as the base stamp for allocating + remember it and use it as the base stamp for allocating soft pseudo-registers *) if !first_virtual_reg_stamp = -1 then first_virtual_reg_stamp := !currstamp; currstamp := !first_virtual_reg_stamp; diff --git a/asmcomp/reload.mli b/asmcomp/reload.mli index a562b4fbc0..fc72446e7d 100644 --- a/asmcomp/reload.mli +++ b/asmcomp/reload.mli @@ -15,4 +15,3 @@ (* Insert load/stores for pseudoregs that got assigned to stack locations. *) val fundecl: Mach.fundecl -> Mach.fundecl * bool - diff --git a/asmcomp/reloadgen.ml b/asmcomp/reloadgen.ml index c8e9f49190..898c65c989 100644 --- a/asmcomp/reloadgen.ml +++ b/asmcomp/reloadgen.ml @@ -109,13 +109,13 @@ method private reload i = (self#reload i.next))} | Iifthenelse(tst, ifso, ifnot) -> let newarg = self#reload_test tst i.arg in - insert_moves i.arg newarg + insert_moves i.arg newarg (instr_cons (Iifthenelse(tst, self#reload ifso, self#reload ifnot)) newarg [||] (self#reload i.next)) | Iswitch(index, cases) -> let newarg = self#makeregs i.arg in - insert_moves i.arg newarg + insert_moves i.arg newarg (instr_cons (Iswitch(index, Array.map (self#reload) cases)) newarg [||] (self#reload i.next)) | Iloop body -> diff --git a/asmcomp/schedgen.ml b/asmcomp/schedgen.ml index fae061b19f..388d0d4c8c 100644 --- a/asmcomp/schedgen.ml +++ b/asmcomp/schedgen.ml @@ -91,7 +91,7 @@ let rec longest_path critical_outputs node = then node.delay else 0 | sons -> - node.length <- + node.length <- List.fold_left (fun len (son, delay) -> max len (longest_path critical_outputs son + delay)) @@ -287,7 +287,7 @@ method private ready_instruction date queue = then instr else best in extract new_best rem in extract dummy_node queue - + (* Schedule a basic block, adding its instructions in front of the given instruction sequence *) diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml index 079ae5401d..0b75c64bdc 100644 --- a/asmcomp/selectgen.ml +++ b/asmcomp/selectgen.ml @@ -259,8 +259,8 @@ method select_operation op args = | (Cnegf, _) -> (Inegf, args) | (Cabsf, _) -> (Iabsf, args) | (Caddf, _) -> (Iaddf, args) - | (Csubf, _) -> (Isubf, args) - | (Cmulf, _) -> (Imulf, args) + | (Csubf, _) -> (Isubf, args) + | (Cmulf, _) -> (Imulf, args) | (Cdivf, _) -> (Idivf, args) | (Cfloatofint, _) -> (Ifloatofint, args) | (Cintoffloat, _) -> (Iintoffloat, args) @@ -381,7 +381,7 @@ method insert_move_results loc res stacksize = self#insert_moves loc res (* Add an Iop opcode. Can be overriden by processor description - to insert moves before and after the operation, i.e. for two-address + to insert moves before and after the operation, i.e. for two-address instructions, or instructions using dedicated registers. *) method insert_op_debug op dbg rs rd = @@ -506,7 +506,7 @@ method emit_expr env exp = let r1 = self#emit_tuple env new_args in let rd = self#regs_for ty in Some (self#insert_op_debug op dbg r1 rd) - end + end | Csequence(e1, e2) -> begin match self#emit_expr env e1 with None -> None @@ -545,7 +545,7 @@ method emit_expr env exp = (fun id -> let r = self#regs_for typ_addr in name_regs id r; r) ids in - catch_regs := (nfail, Array.concat rs) :: !catch_regs ; + catch_regs := (nfail, Array.concat rs) :: !catch_regs ; let (r1, s1) = self#emit_sequence env e1 in catch_regs := List.tl !catch_regs ; let new_env = @@ -768,7 +768,7 @@ method emit_tail env exp = name_regs id r ; r) ids in - catch_regs := (nfail, Array.concat rs) :: !catch_regs ; + catch_regs := (nfail, Array.concat rs) :: !catch_regs ; let s1 = self#emit_tail_sequence env e1 in catch_regs := List.tl !catch_regs ; let new_env = diff --git a/asmcomp/selectgen.mli b/asmcomp/selectgen.mli index 6d7bd2948e..fa2cddcf0f 100644 --- a/asmcomp/selectgen.mli +++ b/asmcomp/selectgen.mli @@ -62,7 +62,7 @@ class virtual selector_generic : object (* The following method is the entry point and should not be overriden *) method emit_fundecl : Cmm.fundecl -> Mach.fundecl - + (* The following methods should not be overriden. They cannot be declared "private" in the current implementation because they are not always applied to "self", but ideally they should be private. *) diff --git a/asmcomp/sparc/proc.ml b/asmcomp/sparc/proc.ml index 91f1c8e73d..2fd147bfc7 100644 --- a/asmcomp/sparc/proc.ml +++ b/asmcomp/sparc/proc.ml @@ -50,7 +50,7 @@ let int_reg_name = [| (* 12-16 *) "%l0"; "%l1"; "%l2"; "%l3"; "%l4"; (* 17-18 *) "%g3"; "%g4" |] - + let float_reg_name = [| (* 100-105 *) "%f0"; "%f2"; "%f4"; "%f6"; "%f8"; "%f10"; (* 106-109 *) "%f12"; "%f14"; "%f16"; "%f18"; diff --git a/asmcomp/sparc/scheduling.ml b/asmcomp/sparc/scheduling.ml index fc66239018..efe9a1f4cc 100644 --- a/asmcomp/sparc/scheduling.ml +++ b/asmcomp/sparc/scheduling.ml @@ -62,4 +62,3 @@ method oper_issue_cycles = function end let fundecl f = (new scheduler)#schedule_fundecl f - diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml index 255795c71b..968987d480 100644 --- a/asmcomp/spill.ml +++ b/asmcomp/spill.ml @@ -12,7 +12,7 @@ (* $Id$ *) -(* Insertion of moves to suggest possible spilling / reloading points +(* Insertion of moves to suggest possible spilling / reloading points before register allocation. *) open Reg @@ -130,7 +130,7 @@ let find_reload_at_exit k = List.assoc k !reload_at_exit with | Not_found -> Misc.fatal_error "Spill.find_reload_at_exit" - + let reload_at_break = ref Reg.Set.empty let rec reload i before = @@ -400,4 +400,3 @@ let fundecl f = fun_args = f.fun_args; fun_body = new_body; fun_fast = f.fun_fast } - diff --git a/asmcomp/spill.mli b/asmcomp/spill.mli index 966d471fdf..16a8c01add 100644 --- a/asmcomp/spill.mli +++ b/asmcomp/spill.mli @@ -12,7 +12,7 @@ (* $Id$ *) -(* Insertion of moves to suggest possible spilling / reloading points +(* Insertion of moves to suggest possible spilling / reloading points before register allocation. *) val fundecl: Mach.fundecl -> Mach.fundecl diff --git a/asmcomp/split.ml b/asmcomp/split.ml index 1fcbb07495..9e6130d218 100644 --- a/asmcomp/split.ml +++ b/asmcomp/split.ml @@ -189,7 +189,7 @@ let rec rename i sub = | Iraise -> (instr_cons_debug Iraise (subst_regs i.arg sub) [||] i.dbg i.next, None) - + (* Second pass: replace registers by their final representatives *) let set_repres i = diff --git a/asmrun/alpha.S b/asmrun/alpha.S index dd2e772738..c5251b73a5 100644 --- a/asmrun/alpha.S +++ b/asmrun/alpha.S @@ -80,7 +80,7 @@ caml_allocN: .set at ret ($26) .end caml_allocN - + .globl caml_call_gc .ent caml_call_gc .align 3 diff --git a/asmrun/amd64.S b/asmrun/amd64.S index e1bec27a93..3268a31824 100644 --- a/asmrun/amd64.S +++ b/asmrun/amd64.S @@ -52,7 +52,7 @@ FUNCTION(G(caml_call_gc)) movq %rax, G(caml_last_return_address)(%rip) leaq 8(%rsp), %rax movq %rax, G(caml_bottom_of_stack)(%rip) -.L105: +.L105: /* Save caml_young_ptr, caml_exception_pointer */ movq %r15, G(caml_young_ptr)(%rip) movq %r14, G(caml_exception_pointer)(%rip) diff --git a/asmrun/amd64nt.asm b/asmrun/amd64nt.asm index a21e086063..894331418b 100644 --- a/asmrun/amd64nt.asm +++ b/asmrun/amd64nt.asm @@ -1,13 +1,13 @@ ;********************************************************************* -; -; Objective Caml ; -; Xavier Leroy, projet Gallium, INRIA Rocquencourt +; Objective Caml ; -; Copyright 2006 Institut National de Recherche en Informatique et -; en Automatique. All rights reserved. This file is distributed -; under the terms of the GNU Library General Public License, with -; the special exception on linking described in file ../LICENSE. +; Xavier Leroy, projet Gallium, INRIA Rocquencourt +; +; Copyright 2006 Institut National de Recherche en Informatique et +; en Automatique. All rights reserved. This file is distributed +; under the terms of the GNU Library General Public License, with +; the special exception on linking described in file ../LICENSE. ; ;********************************************************************* @@ -46,11 +46,11 @@ caml_call_gc: mov caml_last_return_address, rax lea rax, [rsp+8] mov caml_bottom_of_stack, rax -L105: +L105: ; Save caml_young_ptr, caml_exception_pointer mov caml_young_ptr, r15 mov caml_exception_pointer, r14 - ; Build array of registers, save it into caml_gc_regs + ; Build array of registers, save it into caml_gc_regs push r13 push r12 push rbp @@ -65,7 +65,7 @@ L105: push rbx push rax mov caml_gc_regs, rsp - ; Save floating-point registers + ; Save floating-point registers sub rsp, 16*8 movlpd QWORD PTR [rsp + 0*8], xmm0 movlpd QWORD PTR [rsp + 1*8], xmm1 @@ -83,9 +83,9 @@ L105: movlpd QWORD PTR [rsp + 13*8], xmm13 movlpd QWORD PTR [rsp + 14*8], xmm14 movlpd QWORD PTR [rsp + 15*8], xmm15 - ; Call the garbage collector + ; Call the garbage collector call caml_garbage_collection - ; Restore all regs used by the code generator + ; Restore all regs used by the code generator movlpd xmm0, QWORD PTR [rsp + 0*8] movlpd xmm1, QWORD PTR [rsp + 1*8] movlpd xmm2, QWORD PTR [rsp + 2*8] @@ -116,10 +116,10 @@ L105: pop rbp pop r12 pop r13 - ; Restore caml_young_ptr, caml_exception_pointer + ; Restore caml_young_ptr, caml_exception_pointer mov r15, caml_young_ptr mov r14, caml_exception_pointer - ; Return to caller + ; Return to caller ret PUBLIC caml_alloc1 @@ -181,41 +181,41 @@ caml_allocN: jb L103 ret L103: - push rax ; save desired size + push rax ; save desired size mov rax, [rsp + 8] mov caml_last_return_address, rax lea rax, [rsp + 16] mov caml_bottom_of_stack, rax call L105 - pop rax ; recover desired size + pop rax ; recover desired size jmp caml_allocN -; Call a C function from Caml +; Call a C function from Caml PUBLIC caml_c_call ALIGN 16 caml_c_call: - ; Record lowest stack address and return address + ; Record lowest stack address and return address pop r12 mov caml_last_return_address, r12 mov caml_bottom_of_stack, rsp - ; Make the exception handler and alloc ptr available to the C code + ; Make the exception handler and alloc ptr available to the C code mov caml_young_ptr, r15 mov caml_exception_pointer, r14 - ; Call the function (address in rax) + ; Call the function (address in rax) call rax - ; Reload alloc ptr + ; Reload alloc ptr mov r15, caml_young_ptr - ; Return to caller + ; Return to caller push r12 ret -; Start the Caml program +; Start the Caml program PUBLIC caml_start_program ALIGN 16 caml_start_program: - ; Save callee-save registers + ; Save callee-save registers push rbx push rbp push rsi @@ -235,39 +235,39 @@ caml_start_program: movapd OWORD PTR [rsp + 7*16], xmm13 movapd OWORD PTR [rsp + 8*16], xmm14 movapd OWORD PTR [rsp + 9*16], xmm15 - ; Initial entry point is caml_program + ; Initial entry point is caml_program lea r12, caml_program - ; Common code for caml_start_program and caml_callback* + ; Common code for caml_start_program and caml_callback* L106: - ; Build a callback link - sub rsp, 8 ; stack 16-aligned + ; Build a callback link + sub rsp, 8 ; stack 16-aligned push caml_gc_regs push caml_last_return_address push caml_bottom_of_stack - ; Setup alloc ptr and exception ptr + ; Setup alloc ptr and exception ptr mov r15, caml_young_ptr mov r14, caml_exception_pointer - ; Build an exception handler + ; Build an exception handler lea r13, L108 push r13 push r14 mov r14, rsp - ; Call the Caml code + ; Call the Caml code call r12 L107: - ; Pop the exception handler + ; Pop the exception handler pop r14 - pop r12 ; dummy register + pop r12 ; dummy register L109: - ; Update alloc ptr and exception ptr + ; Update alloc ptr and exception ptr mov caml_young_ptr, r15 mov caml_exception_pointer, r14 - ; Pop the callback restoring, link the global variables + ; Pop the callback restoring, link the global variables pop caml_bottom_of_stack pop caml_last_return_address pop caml_gc_regs add rsp, 8 - ; Restore callee-save registers. + ; Restore callee-save registers. movapd xmm6, OWORD PTR [rsp + 0*16] movapd xmm7, OWORD PTR [rsp + 1*16] movapd xmm8, OWORD PTR [rsp + 2*16] @@ -291,7 +291,7 @@ L109: ret L108: ; Exception handler - ; Mark the bucket as an exception result and return it + ; Mark the bucket as an exception result and return it or rax, 2 jmp L109 @@ -318,7 +318,7 @@ L110: pop r14 ; Recover previous exception handler ret ; Branch to handler -; Raise an exception from C +; Raise an exception from C PUBLIC caml_raise_exception ALIGN 16 @@ -327,8 +327,8 @@ caml_raise_exception: jne L111 mov rax, rcx ; First argument is exn bucket mov rsp, caml_exception_pointer - pop r14 ; Recover previous exception handler - mov r15, caml_young_ptr ; Reload alloc ptr + pop r14 ; Recover previous exception handler + mov r15, caml_young_ptr ; Reload alloc ptr ret L111: mov r12, rcx ; Save exception bucket in r12 @@ -340,16 +340,16 @@ L111: call caml_stash_backtrace mov rax, r12 ; Recover exception bucket mov rsp, caml_exception_pointer - pop r14 ; Recover previous exception handler - mov r15, caml_young_ptr ; Reload alloc ptr + pop r14 ; Recover previous exception handler + mov r15, caml_young_ptr ; Reload alloc ptr ret -; Callback from C to Caml +; Callback from C to Caml PUBLIC caml_callback_exn ALIGN 16 caml_callback_exn: - ; Save callee-save registers + ; Save callee-save registers push rbx push rbp push rsi @@ -369,16 +369,16 @@ caml_callback_exn: movapd OWORD PTR [rsp + 7*16], xmm13 movapd OWORD PTR [rsp + 8*16], xmm14 movapd OWORD PTR [rsp + 9*16], xmm15 - ; Initial loading of arguments - mov rbx, rcx ; closure - mov rax, rdx ; argument - mov r12, [rbx] ; code pointer + ; Initial loading of arguments + mov rbx, rcx ; closure + mov rax, rdx ; argument + mov r12, [rbx] ; code pointer jmp L106 PUBLIC caml_callback2_exn ALIGN 16 caml_callback2_exn: - ; Save callee-save registers + ; Save callee-save registers push rbx push rbp push rsi @@ -398,17 +398,17 @@ caml_callback2_exn: movapd OWORD PTR [rsp + 7*16], xmm13 movapd OWORD PTR [rsp + 8*16], xmm14 movapd OWORD PTR [rsp + 9*16], xmm15 - ; Initial loading of arguments + ; Initial loading of arguments mov rdi, rcx ; closure - mov rax, rdx ; first argument - mov rbx, r8 ; second argument - lea r12, caml_apply2 ; code pointer + mov rax, rdx ; first argument + mov rbx, r8 ; second argument + lea r12, caml_apply2 ; code pointer jmp L106 PUBLIC caml_callback3_exn ALIGN 16 caml_callback3_exn: - ; Save callee-save registers + ; Save callee-save registers push rbx push rbp push rsi @@ -428,12 +428,12 @@ caml_callback3_exn: movapd OWORD PTR [rsp + 7*16], xmm13 movapd OWORD PTR [rsp + 8*16], xmm14 movapd OWORD PTR [rsp + 9*16], xmm15 - ; Initial loading of arguments + ; Initial loading of arguments mov rsi, rcx ; closure - mov rax, rdx ; first argument - mov rbx, r8 ; second argument - mov rdi, r9 ; third argument - lea r12, caml_apply3 ; code pointer + mov rax, rdx ; first argument + mov rbx, r8 ; second argument + mov rdi, r9 ; third argument + lea r12, caml_apply3 ; code pointer jmp L106 PUBLIC caml_ml_array_bound_error @@ -445,10 +445,10 @@ caml_ml_array_bound_error: .DATA PUBLIC caml_system__frametable caml_system__frametable LABEL QWORD - QWORD 1 ; one descriptor - QWORD L107 ; return address into callback - WORD -1 ; negative frame size => use callback link - WORD 0 ; no roots here + QWORD 1 ; one descriptor + QWORD L107 ; return address into callback + WORD -1 ; negative frame size => use callback link + WORD 0 ; no roots here ALIGN 8 PUBLIC caml_negf_mask diff --git a/asmrun/backtrace.c b/asmrun/backtrace.c index 1b39bfb94f..0825cade53 100644 --- a/asmrun/backtrace.c +++ b/asmrun/backtrace.c @@ -131,7 +131,7 @@ static void extract_location_info(frame_descr * d, uint32 info1, info2; /* If no debugging information available, print nothing. - When everything is compiled with -g, this corresponds to + When everything is compiled with -g, this corresponds to compiler-inserted re-raise operations. */ if ((d->frame_size & 1) == 0) { li->loc_valid = 0; @@ -147,7 +147,7 @@ static void extract_location_info(frame_descr * d, info2 = ((uint32 *)infoptr)[1]; /* Format of the two info words: llllllllllllllllllll aaaaaaaa bbbbbbbbbb nnnnnnnnnnnnnnnnnnnnnnnn kk - 44 36 26 2 0 + 44 36 26 2 0 (32+12) (32+4) k ( 2 bits): 0 if it's a call, 1 if it's a raise n (24 bits): offset (in 4-byte words) of file name relative to infoptr @@ -222,4 +222,3 @@ CAMLprim value caml_get_exception_backtrace(value unit) res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ CAMLreturn(res); } - diff --git a/asmrun/hppa.S b/asmrun/hppa.S index b795f52b0d..abdd4554b8 100644 --- a/asmrun/hppa.S +++ b/asmrun/hppa.S @@ -366,7 +366,7 @@ L102: ldo LOW(G(caml_young_limit))(%r1), %r4 ; Call the Caml code ble 0(4, %r22) - copy %r31, %r2 + copy %r31, %r2 L104: ; Pop the trap frame ldw -8(%r30), %r31 diff --git a/asmrun/i386nt.asm b/asmrun/i386nt.asm index 7d51a7ec19..711449cfbb 100644 --- a/asmrun/i386nt.asm +++ b/asmrun/i386nt.asm @@ -1,13 +1,13 @@ ;********************************************************************* -; -; Objective Caml ; -; Xavier Leroy, projet Cristal, INRIA Rocquencourt +; Objective Caml ; -; Copyright 1996 Institut National de Recherche en Informatique et -; en Automatique. All rights reserved. This file is distributed -; under the terms of the GNU Library General Public License, with -; the special exception on linking described in file ../LICENSE. +; Xavier Leroy, projet Cristal, INRIA Rocquencourt +; +; Copyright 1996 Institut National de Recherche en Informatique et +; en Automatique. All rights reserved. This file is distributed +; under the terms of the GNU Library General Public License, with +; the special exception on linking described in file ../LICENSE. ; ;********************************************************************* @@ -32,7 +32,7 @@ EXTERN _caml_backtrace_active: DWORD EXTERN _caml_stash_backtrace: PROC -; Allocation +; Allocation .CODE PUBLIC _caml_alloc1 @@ -42,12 +42,12 @@ PUBLIC _caml_call_gc _caml_call_gc: - ; Record lowest stack address and return address + ; Record lowest stack address and return address mov eax, [esp] mov _caml_last_return_address, eax lea eax, [esp+4] mov _caml_bottom_of_stack, eax - ; Save all regs used by the code generator + ; Save all regs used by the code generator L105: push ebp push edi push esi @@ -56,9 +56,9 @@ L105: push ebp push ebx push eax mov _caml_gc_regs, esp - ; Call the garbage collector + ; Call the garbage collector call _caml_garbage_collection - ; Restore all regs used by the code generator + ; Restore all regs used by the code generator pop eax pop ebx pop ecx @@ -66,8 +66,8 @@ L105: push ebp pop esi pop edi pop ebp - ; Return to caller - ret + ; Return to caller + ret ALIGN 4 _caml_alloc1: @@ -76,7 +76,7 @@ _caml_alloc1: mov _caml_young_ptr, eax cmp eax, _caml_young_limit jb L100 - ret + ret L100: mov eax, [esp] mov _caml_last_return_address, eax lea eax, [esp+4] @@ -91,7 +91,7 @@ _caml_alloc2: mov _caml_young_ptr, eax cmp eax, _caml_young_limit jb L101 - ret + ret L101: mov eax, [esp] mov _caml_last_return_address, eax lea eax, [esp+4] @@ -106,7 +106,7 @@ _caml_alloc3: mov _caml_young_ptr, eax cmp eax, _caml_young_limit jb L102 - ret + ret L102: mov eax, [esp] mov _caml_last_return_address, eax lea eax, [esp+4] @@ -134,25 +134,25 @@ L103: sub eax, _caml_young_ptr ; eax = - size pop eax ; recover desired size jmp _caml_allocN -; Call a C function from Caml +; Call a C function from Caml PUBLIC _caml_c_call ALIGN 4 _caml_c_call: - ; Record lowest stack address and return address + ; Record lowest stack address and return address mov edx, [esp] mov _caml_last_return_address, edx lea edx, [esp+4] mov _caml_bottom_of_stack, edx - ; Call the function (address in %eax) + ; Call the function (address in %eax) jmp eax -; Start the Caml program +; Start the Caml program PUBLIC _caml_start_program ALIGN 4 _caml_start_program: - ; Save callee-save registers + ; Save callee-save registers push ebx push esi push edi @@ -163,20 +163,20 @@ _caml_start_program: ; Code shared between caml_start_program and callback* L106: - ; Build a callback link + ; Build a callback link push _caml_gc_regs push _caml_last_return_address push _caml_bottom_of_stack - ; Build an exception handler + ; Build an exception handler push L108 push _caml_exception_pointer mov _caml_exception_pointer, esp - ; Call the Caml code + ; Call the Caml code call esi L107: - ; Pop the exception handler + ; Pop the exception handler pop _caml_exception_pointer - pop esi ; dummy register + pop esi ; dummy register L109: ; Pop the callback link, restoring the global variables ; used by caml_c_call @@ -188,8 +188,8 @@ L109: pop edi pop esi pop ebx - ; Return to caller. - ret + ; Return to caller. + ret L108: ; Exception handler ; Mark the bucket as an exception result and return it @@ -205,7 +205,7 @@ _caml_raise_exn: jne L110 mov esp, _caml_exception_pointer pop _caml_exception_pointer - ret + ret L110: mov esi, eax ; Save exception bucket in esi mov edi, _caml_exception_pointer ; SP of handler @@ -221,7 +221,7 @@ L110: pop _caml_exception_pointer ret -; Raise an exception from C +; Raise an exception from C PUBLIC _caml_raise_exception ALIGN 4 @@ -231,7 +231,7 @@ _caml_raise_exception: mov eax, [esp+4] mov esp, _caml_exception_pointer pop _caml_exception_pointer - ret + ret L111: mov esi, [esp+4] ; Save exception bucket in esi push _caml_exception_pointer ; arg 4: SP of handler @@ -244,51 +244,51 @@ L111: pop _caml_exception_pointer ret -; Callback from C to Caml +; Callback from C to Caml PUBLIC _caml_callback_exn ALIGN 4 _caml_callback_exn: - ; Save callee-save registers + ; Save callee-save registers push ebx push esi push edi push ebp - ; Initial loading of arguments - mov ebx, [esp+20] ; closure - mov eax, [esp+24] ; argument + ; Initial loading of arguments + mov ebx, [esp+20] ; closure + mov eax, [esp+24] ; argument mov esi, [ebx] ; code pointer jmp L106 PUBLIC _caml_callback2_exn ALIGN 4 _caml_callback2_exn: - ; Save callee-save registers + ; Save callee-save registers push ebx push esi push edi push ebp - ; Initial loading of arguments - mov ecx, [esp+20] ; closure - mov eax, [esp+24] ; first argument - mov ebx, [esp+28] ; second argument - mov esi, offset _caml_apply2 ; code pointer + ; Initial loading of arguments + mov ecx, [esp+20] ; closure + mov eax, [esp+24] ; first argument + mov ebx, [esp+28] ; second argument + mov esi, offset _caml_apply2 ; code pointer jmp L106 PUBLIC _caml_callback3_exn ALIGN 4 _caml_callback3_exn: - ; Save callee-save registers + ; Save callee-save registers push ebx push esi push edi push ebp - ; Initial loading of arguments - mov edx, [esp+20] ; closure - mov eax, [esp+24] ; first argument - mov ebx, [esp+28] ; second argument - mov ecx, [esp+32] ; third argument - mov esi, offset _caml_apply3 ; code pointer + ; Initial loading of arguments + mov edx, [esp+20] ; closure + mov eax, [esp+24] ; first argument + mov ebx, [esp+28] ; second argument + mov ecx, [esp+32] ; third argument + mov esi, offset _caml_apply3 ; code pointer jmp L106 PUBLIC _caml_ml_array_bound_error @@ -310,14 +310,13 @@ _caml_ml_array_bound_error: .DATA PUBLIC _caml_system__frametable _caml_system__frametable LABEL DWORD - DWORD 1 ; one descriptor - DWORD L107 ; return address into callback - WORD -1 ; negative frame size => use callback link - WORD 0 ; no roots here + DWORD 1 ; one descriptor + DWORD L107 ; return address into callback + WORD -1 ; negative frame size => use callback link + WORD 0 ; no roots here PUBLIC _caml_extra_params _caml_extra_params LABEL DWORD BYTE 64 DUP (?) END - diff --git a/asmrun/ia64.S b/asmrun/ia64.S index 025e064a5e..d4296fa4a4 100644 --- a/asmrun/ia64.S +++ b/asmrun/ia64.S @@ -239,7 +239,7 @@ caml_start_program: mov b6 = r2 /* Code shared with caml_callback* */ -.L103: +.L103: /* Allocate 64 "out" registers (for the Caml code) and no locals */ alloc r3 = ar.pfs, 0, 0, 64, 0 add sp = -(56 * 8), sp ;; @@ -503,7 +503,7 @@ caml_callback3_exn: .align 16 caml_ml_array_bound_error: ADDRGLOBAL(r2, @fptr(caml_array_bound_error#)) - br.sptk caml_c_call /* never returns */ + br.sptk caml_c_call /* never returns */ .rodata diff --git a/asmrun/power-elf.S b/asmrun/power-elf.S index e9f0baef03..968e3aeb88 100644 --- a/asmrun/power-elf.S +++ b/asmrun/power-elf.S @@ -204,7 +204,7 @@ caml_c_call: Storeglobal(12, caml_last_return_address, 11) /* Return to caller */ blr - + /* Raise an exception from C */ .globl caml_raise_exception @@ -298,7 +298,7 @@ caml_start_program: stw 11, 4(1) mr 29, 1 /* Reload allocation pointers */ - Loadglobal(31, caml_young_ptr, 11) + Loadglobal(31, caml_young_ptr, 11) Loadglobal(30, caml_young_limit, 11) /* Say we are back into Caml code */ li 0, 0 @@ -316,9 +316,9 @@ caml_start_program: lwz 9, 0(1) lwz 10, 4(1) lwz 11, 8(1) - Storeglobal(9, caml_bottom_of_stack, 12) - Storeglobal(10, caml_last_return_address, 12) - Storeglobal(11, caml_gc_regs, 12) + Storeglobal(9, caml_bottom_of_stack, 12) + Storeglobal(10, caml_last_return_address, 12) + Storeglobal(11, caml_gc_regs, 12) addi 1, 1, 16 /* Update allocation pointer */ Storeglobal(31, caml_young_ptr, 11) @@ -396,7 +396,7 @@ caml_callback2_exn: mr 5, 0 Addrglobal(12, caml_apply2) b .L102 - + .globl caml_callback3_exn .type caml_callback3_exn, @function caml_callback3_exn: @@ -418,4 +418,3 @@ caml_system__frametable: .long .L105 + 4 /* return address into callback */ .short -1 /* negative size count => use callback link */ .short 0 /* no roots here */ - diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex a4a8b667e4..2d86493c18 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex cbf203cfd9..925338520c 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/build/buildbot b/build/buildbot index f337e3f6d7..82cc26b164 100755 --- a/build/buildbot +++ b/build/buildbot @@ -26,7 +26,7 @@ bad() { } finish_if_bad() { - if [ -f buildbot.failed ]; then + if [ -f buildbot.failed ]; then finish exit 2 fi diff --git a/build/mkconfig.sh b/build/mkconfig.sh index 1cd66f37ec..0eb693030d 100755 --- a/build/mkconfig.sh +++ b/build/mkconfig.sh @@ -8,5 +8,3 @@ sed -e 's/^\(.*\$([0-9]).*\)$/# \1/' \ -e 's/^FLEX.*$//g' \ -e 's/^\([^#=]*\)=\([^"]*\)$/if [ "x$\1" = "x" ]; then \1="\2"; fi/' \ config/Makefile > config/config.sh - - diff --git a/build/myocamlbuild.sh b/build/myocamlbuild.sh index dc129a849b..4333542f93 100755 --- a/build/myocamlbuild.sh +++ b/build/myocamlbuild.sh @@ -7,9 +7,9 @@ if [ ! -x _build/ocamlbuild/ocamlbuildlight.byte ]; then (cd ocamlbuild && make) fi mkdir -p _build/ocamlbuild - for i in "light.cmo" "light.byte" "lightlib.cma" "_plugin.cmi" "_pack.cmi" + for i in "light.cmo" "light.byte" "lightlib.cma" "_plugin.cmi" "_pack.cmi" do - cp ocamlbuild/_build/ocamlbuild$i _build/ocamlbuild + cp ocamlbuild/_build/ocamlbuild$i _build/ocamlbuild done fi rm -f ocamlbuild/myocamlbuild_config.ml ocamlbuild/myocamlbuild_config.mli diff --git a/bytecomp/bytelibrarian.ml b/bytecomp/bytelibrarian.ml index a5d45877fc..ba08fc019f 100644 --- a/bytecomp/bytelibrarian.ml +++ b/bytecomp/bytelibrarian.ml @@ -37,7 +37,7 @@ let copy_compunit ic oc compunit = end (* Add C objects and options and "custom" info from a library descriptor *) - + let lib_sharedobjs = ref [] let lib_ccobjs = ref [] let lib_ccopts = ref [] @@ -119,4 +119,3 @@ let report_error ppf = function fprintf ppf "Cannot find file %s" name | Not_an_object_file name -> fprintf ppf "The file %s is not a bytecode object file" name - diff --git a/bytecomp/cmo_format.mli b/bytecomp/cmo_format.mli index 34df9ffaea..c87e6df4e2 100644 --- a/bytecomp/cmo_format.mli +++ b/bytecomp/cmo_format.mli @@ -58,4 +58,3 @@ type library = ... object code for last library member library descriptor *) - diff --git a/bytecomp/dll.ml b/bytecomp/dll.ml index f5ba48d4f5..bcf66b4296 100644 --- a/bytecomp/dll.ml +++ b/bytecomp/dll.ml @@ -172,4 +172,3 @@ let init_toplevel dllpath = opened_dlls := Array.to_list (get_current_dlls()); names_of_opened_dlls := []; linking_in_core := true - diff --git a/bytecomp/dll.mli b/bytecomp/dll.mli index 4f57571de7..fea455f7cb 100644 --- a/bytecomp/dll.mli +++ b/bytecomp/dll.mli @@ -58,4 +58,3 @@ val init_compile: bool -> unit contents of ld.conf file). Take note of the DLLs that were opened when starting the running program. *) val init_toplevel: string -> unit - diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index db10dea647..2cec99dc83 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -69,7 +69,7 @@ let out_const c = out_int (const_as_int c) with | AsInt -> Misc.fatal_error "Emitcode.const_as_int" - + (* Handling of local labels and backpatching *) diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index 1422401d6a..ff94a6d9cc 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -423,5 +423,3 @@ and negate_comparison = function | Ceq -> Cneq| Cneq -> Ceq | Clt -> Cge | Cle -> Cgt | Cgt -> Cle | Cge -> Clt - - diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index 46a2cf0123..0fe0df2d6c 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -205,4 +205,3 @@ val staticfail : lambda (* Anticipated static failure *) (* Check anticipated failure, substitute its final value *) val is_guarded: lambda -> bool val patch_guarded : lambda -> lambda -> lambda - diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index b20022d7b5..21006cc695 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -59,7 +59,7 @@ let pretty_ctx ctx = let le_ctx c1 c2 = le_pats c1.left c2.left && le_pats c1.right c2.right - + let lshift {left=left ; right=right} = match right with | x::xs -> {left=x::left ; right=xs} | _ -> assert false @@ -77,7 +77,7 @@ let rec small_enough n = function let ctx_lshift ctx = if small_enough 31 ctx then List.map lshift ctx - else (* Context pruning *) begin + else (* Context pruning *) begin get_mins le_ctx (List.map lforget ctx) end @@ -94,7 +94,7 @@ let rec nchars n ps = let chars, cdrs = nchars (n-1) rem in p::chars,cdrs | _ -> assert false - + let rshift_num n {left=left ; right=right} = let shifted,left = nchars n left in {left=left ; right = shifted@right} @@ -298,7 +298,7 @@ let rec jumps_extract i = function let rec jumps_remove i = function | [] -> [] | (j,_)::rem when i=j -> rem - | x::rem -> x::jumps_remove i rem + | x::rem -> x::jumps_remove i rem let jumps_empty = [] and jumps_is_empty = function @@ -363,7 +363,7 @@ type pm_or_compiled = or_matrix : matrix ; } type pm_half_compiled = - | PmOr of pm_or_compiled + | PmOr of pm_or_compiled | PmVar of pm_var_compiled | Pm of pattern_matching @@ -507,7 +507,7 @@ exception Var of pattern let simplify_or p = let rec simpl_rec p = match p with | {pat_desc = Tpat_any|Tpat_var _} -> raise (Var p) - | {pat_desc = Tpat_alias (q,id)} -> + | {pat_desc = Tpat_alias (q,id)} -> begin try {p with pat_desc = Tpat_alias (simpl_rec q,id)} with @@ -515,15 +515,15 @@ let simplify_or p = end | {pat_desc = Tpat_or (p1,p2,o)} -> let q1 = simpl_rec p1 in - begin try + begin try let q2 = simpl_rec p2 in {p with pat_desc = Tpat_or (q1, q2, o)} - with + with | Var q2 -> raise (Var {p with pat_desc = Tpat_or (q1, q2, o)}) end | {pat_desc = Tpat_record lbls} -> let all_lbls = all_record_args lbls in - {p with pat_desc=Tpat_record all_lbls} + {p with pat_desc=Tpat_record all_lbls} | _ -> p in try simpl_rec p @@ -577,7 +577,7 @@ let rec what_is_cases cases = match cases with | (({pat_desc=(Tpat_var _|Tpat_or (_,_,_)|Tpat_alias (_,_))}::_),_)::_ -> assert false (* applies to simplified matchings only *) | (p::_,_)::_ -> p -| [] -> omega +| [] -> omega | _ -> assert false @@ -633,7 +633,7 @@ let mk_alpha_env arg aliases ids = match arg with | Some v -> v | _ -> raise Cannot_flatten - else + else Ident.create (Ident.name id)) ids @@ -646,10 +646,10 @@ let rec explode_or_pat arg patl mk_action rem vars aliases = function | {pat_desc = Tpat_alias (p,id)} -> explode_or_pat arg patl mk_action rem vars (id::aliases) p | {pat_desc = Tpat_var x} -> - let env = mk_alpha_env arg (x::aliases) vars in + let env = mk_alpha_env arg (x::aliases) vars in (omega::patl,mk_action (List.map snd env))::rem | p -> - let env = mk_alpha_env arg aliases vars in + let env = mk_alpha_env arg aliases vars in (alpha_pat env p::patl,mk_action (List.map snd env))::rem let pm_free_variables {cases=cases} = @@ -758,7 +758,7 @@ let insert_or_append p ps act ors no = else (* fail to insert or append *) ors,(p::ps,act)::no else if condb act_q ps qs then (* check condition (b) for append *) - attempt (cl::seen) rem + attempt (cl::seen) rem else ors,(p::ps,act)::no else (* p # q, go on with append/insert *) @@ -781,7 +781,7 @@ let rec rebuild_default nexts def = match nexts with | (e, pmh)::rem -> (add_omega_column (rebuild_matrix pmh), e):: rebuild_default rem def - + let rebuild_nexts arg nexts k = List.fold_right (fun (e, pm) k -> (e, PmVar {inside=pm ; var_arg=arg})::k) @@ -840,7 +840,7 @@ let rec split_or argo cls args def = | rem -> let {me=next ; matrix=matrix ; top_default=def},nexts = do_split [] [] [] rem in - let idef = next_raise_count () in + let idef = next_raise_count () in precompile_or argo yes yesor args (cons_default matrix idef def) @@ -869,10 +869,10 @@ and split_constr cls args def k = begin match yes with | [] -> (* Could not success in raising up a constr matching up *) - split_noex [cl] [] rem + split_noex [cl] [] rem | _ -> let {me=next ; matrix=matrix ; top_default=def}, nexts = - split_noex [cl] [] rem in + split_noex [cl] [] rem in let idef = next_raise_count () in let def = cons_default matrix idef def in {me = Pm {cases=yes ; args=args ; default=def} ; @@ -936,7 +936,7 @@ and precompile_var args cls def k = match args with and var_def = make_default (fun _ rem -> rem) def in let {me=first ; matrix=matrix}, nexts = split_or (Some v) var_cls (arg::rargs) var_def in - + (* Compute top information *) match nexts with | [] -> (* If you need *) @@ -962,7 +962,7 @@ and precompile_or argo cls ors args def k = match ors with | _ -> let rec do_cases = function | ({pat_desc=Tpat_or _} as orp::patl, action)::rem -> - let others,rem = get_equiv orp rem in + let others,rem = get_equiv orp rem in let orpm = {cases = (patl, action):: @@ -1033,7 +1033,7 @@ let add make_matching_fun division key patl_action args = cell.pm.cases <- [patl_action] ; (key, cell) :: division - + let divide make get_key get_args ctx pm = let rec divide_rec = function @@ -1068,7 +1068,7 @@ let divide_line make_ctx make get_args pat ctx pm = They may raise NoMatch or OrPat and perform the full matching (selection + arguments). - + - get_args and get_key are for the compiled matrices, note that selection and geting arguments are separed. @@ -1103,7 +1103,7 @@ let make_constant_matching p def ctx = function let def = make_default (matcher_const (get_key_constant "make" p)) def - and ctx = + and ctx = filter_ctx p ctx in {pm = {cases = []; args = argl ; default = def} ; ctx = ctx ; @@ -1222,7 +1222,7 @@ let rec matcher_variant_const lab p rem = match p.pat_desc with | Tpat_any -> rem | _ -> raise NoMatch - + let make_variant_matching_constant p lab def ctx = function [] -> fatal_error "Matching.make_variant_matching_constant" | ((arg, mut) :: argl) -> @@ -1269,7 +1269,7 @@ let divide_variant row ctx {cases = cl; args = al; default=def} = match pato with None -> add (make_variant_matching_constant p lab def ctx) variants - (Cstr_constant tag) (patl, action) al + (Cstr_constant tag) (patl, action) al | Some pat -> add (make_variant_matching_nonconst p lab def ctx) variants (Cstr_block tag) (pat :: patl, action) al @@ -1378,7 +1378,7 @@ let inline_lazy_force_switch arg loc = Lprim(Pisint, [varg]), varg, (Lswitch (varg, - { sw_numconsts = 0; sw_consts = []; + { sw_numconsts = 0; sw_consts = []; sw_numblocks = (max Obj.lazy_tag Obj.forward_tag) + 1; sw_blocks = [ (Obj.forward_tag, Lprim(Pfield 0, [varg])); @@ -1423,7 +1423,7 @@ let matcher_tuple arity p rem = match p.pat_desc with | Tpat_or (_,_,_) -> raise OrPat | Tpat_var _ -> get_args_tuple arity omega rem | _ -> get_args_tuple arity p rem - + let make_tuple_matching arity def = function [] -> fatal_error "Matching.make_tuple_matching" | (arg, mut) :: argl -> @@ -1525,7 +1525,7 @@ let divide_array kind ctx pm = divide (make_array_matching kind) get_key_array get_args_array ctx pm - + (* To combine sub-matchings together *) let float_compare s1 s2 = @@ -1641,16 +1641,16 @@ let make_switch_switcher arg cases acts = let l = ref [] in for i = Array.length cases-1 downto 0 do l := (i,acts.(cases.(i))) :: !l - done ; + done ; Lswitch(arg, {sw_numconsts = Array.length cases ; sw_consts = !l ; sw_numblocks = 0 ; sw_blocks = [] ; sw_failaction = None}) - + let full sw = List.length sw.sw_consts = sw.sw_numconsts && List.length sw.sw_blocks = sw.sw_numblocks - + let make_switch (arg,sw) = match sw.sw_failaction with | None -> let t = Hashtbl.create 17 in @@ -1685,7 +1685,7 @@ sw_failaction = Some (Lstaticraise (default,[]))}) else Lswitch (arg,sw) | _ -> Lswitch (arg,sw) - + module SArg = struct type primitive = Lambda.primitive @@ -1730,7 +1730,7 @@ let get_edges low high l = match l with | [] -> low, high | (x,_)::_ -> x, last high l - + let as_interval_canfail fail low high l = let store = mk_store equal_action in let rec nofail_rec cur_low cur_high cur_act = function @@ -1897,12 +1897,12 @@ let mk_res get_key env last_choice idef cant_fail ctx = let klist = List.fold_right (fun pat klist -> (get_key pat,act)::klist) - pats klist + pats klist and ctx = if cant_fail then ctx else ctx_lub pat ctx in klist,jumps_add i ctx jumps) env ([],jumps_fail) in fail, klist, jumps - + (* Following two ``failaction'' function compute n, the trap handler @@ -1923,8 +1923,8 @@ let mk_failaction_neg partial ctx def = match partial with | Total -> None, [], jumps_empty - - + + (* Conforme a l'article et plus simple qu'avant *) and mk_failaction_pos partial seen ctx defs = let rec scan_def env to_test defs = match to_test,defs with @@ -1955,8 +1955,8 @@ and mk_failaction_pos partial seen ctx defs = (complete_pats_constrs seen)) defs - -let combine_constant arg cst partial ctx def + +let combine_constant arg cst partial ctx def (const_lambda_list, total, pats) = let fail, to_add, local_jumps = mk_failaction_neg partial ctx def in @@ -2016,12 +2016,12 @@ let split_cases tag_lambda_list = let const, nonconst = split_rec tag_lambda_list in sort_int_lambda_list const, sort_int_lambda_list nonconst - + let combine_constructor arg ex_pat cstr partial ctx def (tag_lambda_list, total1, pats) = if cstr.cstr_consts < 0 then begin - (* Special cases for exceptions *) + (* Special cases for exceptions *) let fail, to_add, local_jumps = mk_failaction_neg partial ctx def in let tag_lambda_list = to_add@tag_lambda_list in @@ -2159,7 +2159,7 @@ let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) = in lambda1, jumps_union local_jumps total1 - + let combine_array arg kind partial ctx def (len_lambda_list, total1, pats) = let fail, to_add, local_jumps = mk_failaction_neg partial ctx def in @@ -2208,12 +2208,12 @@ let rec event_branch repr lam = comp_match_handlers (for compililing splitted matches) may reraise Unused - + *) -exception Unused +exception Unused -let compile_list compile_fun division = +let compile_list compile_fun division = let rec c_rec totals = function | [] -> [], jumps_unions totals, [] @@ -2222,7 +2222,7 @@ let compile_list compile_fun division = | [] -> c_rec totals rem | _ -> try - let (lambda1, total1) = compile_fun cell.ctx cell.pm in + let (lambda1, total1) = compile_fun cell.ctx cell.pm in let c_rem, total, new_pats = c_rec (jumps_map ctx_combine total1::totals) rem in @@ -2298,7 +2298,7 @@ let rec lower_bind v arg lam = match lam with and pnot = approx_present v ifnot in begin match pcond, pso, pnot with | false, false, false -> lam - | false, true, false -> + | false, true, false -> Lifthenelse (cond, lower_bind v arg ifso, ifnot) | false, false, true -> Lifthenelse (cond, ifso, lower_bind v arg ifnot) @@ -2315,19 +2315,19 @@ let rec lower_bind v arg lam = match lam with bind Alias v arg lam else Llet (Alias, vv, lv, lower_bind v arg l) -| _ -> +| _ -> bind Alias v arg lam let bind_check str v arg lam = match str,arg with | _, Lvar _ ->bind str v arg lam -| Alias,_ -> lower_bind v arg lam +| Alias,_ -> lower_bind v arg lam | _,_ -> bind str v arg lam let rec comp_exit ctx m = match m.default with | (_,i)::_ -> Lstaticraise (i,[]), jumps_singleton i ctx | _ -> fatal_error "Matching.comp_exit" - + let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs = match next_matchs with | [] -> comp_fun partial ctx arg first_match @@ -2336,7 +2336,7 @@ let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs = m | [] -> body, total_body (* Hum, -1 meant never taken | (-1,pm)::rem -> c_rec body total_body rem *) - | (i,pm)::rem -> + | (i,pm)::rem -> let ctx_i,total_rem = jumps_extract i total_body in begin match ctx_i with | [] -> c_rec body total_body rem @@ -2424,7 +2424,7 @@ and do_compile_matching_pr repr partial ctx arg x = pretty_ctx ctx ; let (_, jumps) as r = do_compile_matching repr partial ctx arg x in prerr_endline "JUMPS" ; - pretty_jumps jumps ; + pretty_jumps jumps ; r *) and do_compile_matching repr partial ctx arg pmh = match pmh with @@ -2432,7 +2432,7 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with let pat = what_is_cases pm.cases in begin match pat.pat_desc with | Tpat_any -> - compile_no_test + compile_no_test divide_var ctx_rshift repr partial ctx pm | Tpat_tuple patl -> compile_no_test @@ -2453,7 +2453,7 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with (compile_match repr partial) partial divide_constructor (combine_constructor arg pat cstr partial) ctx pm - | Tpat_array _ -> + | Tpat_array _ -> let kind = Typeopt.array_pattern_kind pat in compile_test (compile_match repr partial) partial (divide_array kind) (combine_array arg kind partial) @@ -2499,7 +2499,7 @@ let check_partial pat_act_list partial = (fun (_,lam) -> is_guarded lam) pat_act_list then begin - Partial + Partial end else partial @@ -2590,7 +2590,7 @@ let for_tupled_function loc paraml pats_act_list partial = let flatten_pattern size p = match p.pat_desc with | Tpat_tuple args -> args -| Tpat_any -> omegas size +| Tpat_any -> omegas size | _ -> raise Cannot_flatten let rec flatten_pat_line size p k = match p.pat_desc with @@ -2666,7 +2666,7 @@ let do_for_multiple_match loc paraml pat_act_list partial = { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; args = [Lprim(Pmakeblock(0, Immutable), paraml), Strict] ; default = [] } in - + try try (* Once for checking that compilation is possible *) @@ -2683,7 +2683,7 @@ let do_for_multiple_match loc paraml pat_act_list partial = nexts in let lam, total = - comp_match_handlers + comp_match_handlers (compile_flattened repr) partial (start_ctx size) () flat_next flat_nexts in List.fold_right2 (bind Strict) idl paraml @@ -2728,4 +2728,3 @@ let for_multiple_match loc paraml pat_act_list partial = let paraml = List.map (fun (v,_) -> Lvar v) v_paraml in List.fold_right bind_opt v_paraml (do_for_multiple_match loc paraml pat_act_list partial) - diff --git a/bytecomp/meta.ml b/bytecomp/meta.ml index c03523fbcb..a4beaf4224 100644 --- a/bytecomp/meta.ml +++ b/bytecomp/meta.ml @@ -17,10 +17,11 @@ external realloc_global_data : int -> unit = "caml_realloc_global" external static_alloc : int -> string = "caml_static_alloc" external static_free : string -> unit = "caml_static_free" external static_resize : string -> int -> string = "caml_static_resize" -external static_release_bytecode : string -> int -> unit = "caml_static_release_bytecode" +external static_release_bytecode : string -> int -> unit + = "caml_static_release_bytecode" type closure = unit -> Obj.t external reify_bytecode : string -> int -> closure = "caml_reify_bytecode" external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t = "caml_invoke_traced_function" external get_section_table : unit -> (string * Obj.t) list - = "caml_get_section_table" + = "caml_get_section_table" diff --git a/bytecomp/meta.mli b/bytecomp/meta.mli index 3de027f19c..774c5f1374 100644 --- a/bytecomp/meta.mli +++ b/bytecomp/meta.mli @@ -18,11 +18,12 @@ external global_data : unit -> Obj.t array = "caml_get_global_data" external realloc_global_data : int -> unit = "caml_realloc_global" external static_alloc : int -> string = "caml_static_alloc" external static_free : string -> unit = "caml_static_free" -external static_release_bytecode : string -> int -> unit = "caml_static_release_bytecode" +external static_release_bytecode : string -> int -> unit + = "caml_static_release_bytecode" external static_resize : string -> int -> string = "caml_static_resize" type closure = unit -> Obj.t external reify_bytecode : string -> int -> closure = "caml_reify_bytecode" external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t = "caml_invoke_traced_function" external get_section_table : unit -> (string * Obj.t) list - = "caml_get_section_table" + = "caml_get_section_table" diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml index eaa408935f..6081d5bd4a 100644 --- a/bytecomp/simplif.ml +++ b/bytecomp/simplif.ml @@ -26,7 +26,7 @@ let rec eliminate_ref id = function Lvar v as lam -> if Ident.same v id then raise Real_reference else lam | Lconst cst as lam -> lam - | Lapply(e1, el, loc) -> + | Lapply(e1, el, loc) -> Lapply(eliminate_ref id e1, List.map (eliminate_ref id) el, loc) | Lfunction(kind, params, body) as lam -> if IdentSet.mem id (free_variables lam) @@ -85,7 +85,7 @@ let rec eliminate_ref id = function (* Simplification of exits *) -let simplify_exits lam = +let simplify_exits lam = (* Count occurrences of (exit n ...) statements *) let exits = Hashtbl.create 17 in @@ -101,7 +101,7 @@ let simplify_exits lam = incr (Hashtbl.find exits i) with | Not_found -> Hashtbl.add exits i (ref 1) in - + let rec count = function | (Lvar _| Lconst _) -> () | Lapply(l1, ll, _) -> count l1; List.iter count ll @@ -267,7 +267,7 @@ let simplify_lets lam = !(Hashtbl.find occ v) with Not_found -> 0 - and incr_var v = + and incr_var v = try incr(Hashtbl.find occ v) with Not_found -> @@ -388,7 +388,7 @@ let simplify_lets lam = {sw with sw_consts = new_consts ; sw_blocks = new_blocks; sw_failaction = new_fail}) | Lstaticraise (i,ls) -> - Lstaticraise (i, List.map simplif ls) + Lstaticraise (i, List.map simplif ls) | Lstaticcatch(l1, (i,args), l2) -> Lstaticcatch (simplif l1, (i,args), simplif l2) | Ltrywith(l1, v, l2) -> Ltrywith(simplif l1, v, simplif l2) diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml index ff58af72e6..4fa7b62ba7 100644 --- a/bytecomp/switch.ml +++ b/bytecomp/switch.ml @@ -20,7 +20,7 @@ let mk_store same = let r_acts = ref [] in let store act = let rec store_rec i = function - | [] -> i,[act] + | [] -> i,[act] | act0::rem -> if same act0 act then raise (Found i) else @@ -256,7 +256,7 @@ let coupe_inter i j cases = Array.sub cases i (j-i+1), case_append (Array.sub cases 0 i) (Array.sub cases (j+1) (lcases-(j+1))) -type kind = Kvalue of int | Kinter of int | Kempty +type kind = Kvalue of int | Kinter of int | Kempty let pkind chan = function | Kvalue i ->Printf.fprintf chan "V%d" i @@ -281,7 +281,7 @@ let make_key cases = incr count ; r | (act0,index) :: rem -> - if act0 = act then + if act0 = act then index else got_it act rem in @@ -291,7 +291,7 @@ let make_key cases = Kvalue (got_it act !seen) else Kinter (got_it act !seen) in - + let rec make_rec i pl = if i < 0 then [] @@ -303,8 +303,8 @@ let make_key cases = Kempty::make_one l h act::make_rec (i-1) l in let l,h,act = cases.(Array.length cases-1) in - make_one l h act::make_rec (Array.length cases-2) l - + make_one l h act::make_rec (Array.length cases-2) l + let same_act t = let len = Array.length t in @@ -330,7 +330,7 @@ let make_key cases = This condition is checked by zyva *) - + let inter_limit = 1 lsl 16 let ok_inter = ref false @@ -356,7 +356,7 @@ let rec opt_count top cases = divide top cases in Hashtbl.add t key r ; r - + and divide top cases = let lcases = Array.length cases in let m = lcases/2 in @@ -372,12 +372,12 @@ and divide top cases = else add_test cm cml ; Sep m,(cm, ci) - + and heuristic top cases = let lcases = Array.length cases in - + let sep,csep = divide false cases - + and inter,cinter = if !ok_inter then begin let _,_,act0 = cases.(0) @@ -398,18 +398,18 @@ and heuristic top cases = end else Inter (-1,-1),(too_much, too_much) end else - Inter (-1,-1),(too_much, too_much) in + Inter (-1,-1),(too_much, too_much) in if less2tests csep cinter then sep,csep else inter,cinter - - + + and enum top cases = let lcases = Array.length cases in let lim, with_sep = let best = ref (-1) and best_cost = ref (too_much,too_much) in - + for i = 1 to lcases-(1) do let _,left,right = coupe cases i in let ci = {n=1 ; ni=0} @@ -422,7 +422,7 @@ and enum top cases = add_test cm cmr else add_test cm cml ; - + if less2tests (cm,ci) !best_cost then begin @@ -488,45 +488,45 @@ and enum top cases = r := Sep lim ; rc := with_sep end ; !r, !rc - + let make_if_test konst test arg i ifso ifnot = Arg.make_if (Arg.make_prim test [arg ; konst i]) ifso ifnot - + let make_if_lt konst arg i ifso ifnot = match i with | 1 -> make_if_test konst Arg.leint arg 0 ifso ifnot | _ -> make_if_test konst Arg.ltint arg i ifso ifnot - + and make_if_le konst arg i ifso ifnot = match i with | -1 -> make_if_test konst Arg.ltint arg 0 ifso ifnot | _ -> make_if_test konst Arg.leint arg i ifso ifnot - + and make_if_gt konst arg i ifso ifnot = match i with | -1 -> make_if_test konst Arg.geint arg 0 ifso ifnot | _ -> make_if_test konst Arg.gtint arg i ifso ifnot - + and make_if_ge konst arg i ifso ifnot = match i with | 1 -> make_if_test konst Arg.gtint arg 0 ifso ifnot | _ -> make_if_test konst Arg.geint arg i ifso ifnot - + and make_if_eq konst arg i ifso ifnot = make_if_test konst Arg.eqint arg i ifso ifnot - + and make_if_ne konst arg i ifso ifnot = make_if_test konst Arg.neint arg i ifso ifnot - + let do_make_if_out h arg ifso ifno = Arg.make_if (Arg.make_isout h arg) ifso ifno - + let make_if_out konst ctx l d mk_ifso mk_ifno = match l with | 0 -> do_make_if_out @@ -538,10 +538,10 @@ and enum top cases = let ctx = {off= (-l+ctx.off) ; arg=arg} in do_make_if_out (konst d) arg (mk_ifso ctx) (mk_ifno ctx)) - + let do_make_if_in h arg ifso ifno = Arg.make_if (Arg.make_isin h arg) ifso ifno - + let make_if_in konst ctx l d mk_ifso mk_ifno = match l with | 0 -> do_make_if_in @@ -553,15 +553,15 @@ and enum top cases = let ctx = {off= (-l+ctx.off) ; arg=arg} in do_make_if_in (konst d) arg (mk_ifso ctx) (mk_ifno ctx)) - - + + let rec c_test konst ctx ({cases=cases ; actions=actions} as s) = let lcases = Array.length cases in assert(lcases > 0) ; if lcases = 1 then actions.(get_act cases 0) ctx else begin - + let w,c = opt_count false cases in (* Printf.fprintf stderr @@ -624,7 +624,7 @@ and enum top cases = make_if_ge konst ctx.arg (lim+ctx.off) (c_test konst ctx right) (c_test konst ctx left) - + end @@ -687,7 +687,7 @@ let comp_clusters ({cases=cases ; actions=actions} as s) = get_min (j-1) + 1 < min_clusters.(i) then begin k.(i) <- j ; - min_clusters.(i) <- get_min (j-1) + 1 + min_clusters.(i) <- get_min (j-1) + 1 end done ; done ; @@ -766,15 +766,15 @@ let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k = r.(ir) <- (l,h,add_index (make_switch s i j)) end ; if i > 0 then zyva (i-1) (ir-1) in - + zyva (len-1) (n_clusters-1) ; let acts = Array.create !index (fun _ -> assert false) in Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ; {cases = r ; actions = acts} ;; - -let zyva (low,high) konst arg cases actions = + +let zyva (low,high) konst arg cases actions = let old_ok = !ok_inter in ok_inter := (abs low <= inter_limit && abs high <= inter_limit) ; if !ok_inter <> old_ok then Hashtbl.clear t ; @@ -793,7 +793,7 @@ let zyva (low,high) konst arg cases actions = and test_sequence konst arg cases actions = - let old_ok = !ok_inter in + let old_ok = !ok_inter in ok_inter := false ; if !ok_inter <> old_ok then Hashtbl.clear t ; let s = diff --git a/bytecomp/switch.mli b/bytecomp/switch.mli index 73799daa06..33014c0f7a 100644 --- a/bytecomp/switch.mli +++ b/bytecomp/switch.mli @@ -67,7 +67,7 @@ module Make : functor (Arg : S) -> sig val zyva : - (int * int) -> + (int * int) -> (int -> Arg.act) -> Arg.act -> (int * int * int) array -> diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index bad39a2135..136144efa5 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -133,8 +133,8 @@ let output_primitive_table outchan = let init () = (* Enter the predefined exceptions *) - Array.iter - (fun name -> + Array.iter + (fun name -> let id = try List.assoc name Predef.builtin_values with Not_found -> fatal_error "Symtable.init" in @@ -180,7 +180,7 @@ let patch_int buff pos n = String.unsafe_set buff (pos + 2) (Char.unsafe_chr (n asr 16)); String.unsafe_set buff (pos + 3) (Char.unsafe_chr (n asr 24)) -let patch_object buff patchlist = +let patch_object buff patchlist = List.iter (function (Reloc_literal sc, pos) -> @@ -249,7 +249,7 @@ let update_global_table () = (* Recover data for toplevel initialization. Data can come either from executable file (normal case) or from linked-in data (-output-obj). *) -type section_reader = { +type section_reader = { read_string: string -> string; read_struct: string -> Obj.t; close_reader: unit -> unit @@ -262,7 +262,7 @@ let read_sections () = (fun name -> (Obj.magic(List.assoc name sections) : string)); read_struct = (fun name -> List.assoc name sections); - close_reader = + close_reader = (fun () -> ()) } with Not_found -> let ic = open_in_bin Sys.executable_name in diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 58ce08ae59..bd6107f035 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -84,7 +84,7 @@ let primitive_declarations = ref ([] : Primitive.description list) let record_primitive = function | {val_kind=Val_prim p} -> primitive_declarations := p :: !primitive_declarations | _ -> () - + (* Keep track of the root path (from the root of the namespace to the currently compiled module expression). Useful for naming exceptions. *) diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli index bec880b2f9..9e47ca5e6a 100644 --- a/bytecomp/translmod.mli +++ b/bytecomp/translmod.mli @@ -23,7 +23,7 @@ val transl_store_phrases: string -> structure -> int * lambda val transl_store_implementation: string -> structure * module_coercion -> int * lambda val transl_toplevel_definition: structure -> lambda -val transl_package: +val transl_package: Ident.t option list -> Ident.t -> module_coercion -> lambda val transl_store_package: Ident.t option list -> Ident.t -> module_coercion -> int * lambda diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml index e97fbfc13d..a0df551d80 100644 --- a/bytecomp/translobj.ml +++ b/bytecomp/translobj.ml @@ -112,8 +112,8 @@ let transl_store_label_init glob size f arg = (size+1, Lsequence( Lprim(Psetfield(size, false), - [Lprim(Pgetglobal glob, []); - Lprim (Pccall prim_makearray, [int !method_count; int 0])]), + [Lprim(Pgetglobal glob, []); + Lprim (Pccall prim_makearray, [int !method_count; int 0])]), expr)) in (size, transl_label_init expr) @@ -157,4 +157,3 @@ let oo_wrap env req f x = wrapping := false; top_env := Env.empty; raise exn - diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml index ebcfb20a90..f8e43f0df7 100644 --- a/bytecomp/typeopt.ml +++ b/bytecomp/typeopt.ml @@ -58,7 +58,7 @@ let array_element_kind env ty = else if Path.same p Predef.path_float then Pfloatarray else if Path.same p Predef.path_string - || Path.same p Predef.path_array + || Path.same p Predef.path_array || Path.same p Predef.path_nativeint || Path.same p Predef.path_int32 || Path.same p Predef.path_int64 then diff --git a/byterun/Makefile.nt b/byterun/Makefile.nt index 23fcde9338..a633787de6 100644 --- a/byterun/Makefile.nt +++ b/byterun/Makefile.nt @@ -22,7 +22,7 @@ OBJS=$(COMMONOBJS:.o=.$(O)) win32.$(O) main.$(O) DOBJS=$(OBJS:.$(O)=.$(DBGO)) instrtrace.$(DBGO) ocamlrun$(EXE): libcamlrun.$(A) prims.$(O) - $(MKEXE) -o ocamlrun$(EXE) prims.$(O) $(call SYSLIB,ws2_32) $(EXTRALIBS) libcamlrun.$(A) + $(MKEXE) -o ocamlrun$(EXE) prims.$(O) $(call SYSLIB,ws2_32) $(EXTRALIBS) libcamlrun.$(A) ocamlrund$(EXE): libcamlrund.$(A) prims.$(O) main.$(O) $(MKEXE) -o ocamlrun$(EXE) $(BYTECCDBGCOMPOPTS) prims.$(O) $(call SYSLIB,ws2_32) $(EXTRALIBS) libcamlrund.$(A) diff --git a/byterun/array.c b/byterun/array.c index e282f0600e..fc60659523 100644 --- a/byterun/array.c +++ b/byterun/array.c @@ -34,7 +34,7 @@ CAMLprim value caml_array_get_float(value array, value index) double d; value res; - if (idx < 0 || idx >= Wosize_val(array) / Double_wosize) + if (idx < 0 || idx >= Wosize_val(array) / Double_wosize) caml_array_bound_error(); d = Double_field(array, idx); #define Setup_for_gc diff --git a/byterun/backtrace.c b/byterun/backtrace.c index 1afce8ae2a..2b29c31dcc 100644 --- a/byterun/backtrace.c +++ b/byterun/backtrace.c @@ -308,4 +308,3 @@ CAMLprim value caml_get_exception_backtrace(value unit) } CAMLreturn(res); } - diff --git a/byterun/custom.h b/byterun/custom.h index 3855742f4e..a706857ae0 100644 --- a/byterun/custom.h +++ b/byterun/custom.h @@ -27,7 +27,7 @@ struct custom_operations { void (*finalize)(value v); int (*compare)(value v1, value v2); intnat (*hash)(value v); - void (*serialize)(value v, + void (*serialize)(value v, /*out*/ uintnat * wsize_32 /*size in bytes*/, /*out*/ uintnat * wsize_64 /*size in bytes*/); uintnat (*deserialize)(void * dst); diff --git a/byterun/debugger.c b/byterun/debugger.c index 38b1923e6e..3639c43bbb 100644 --- a/byterun/debugger.c +++ b/byterun/debugger.c @@ -72,7 +72,7 @@ static union { /* Socket address for the debugger */ struct sockaddr s_gen; #ifndef _WIN32 struct sockaddr_un s_unix; -#endif +#endif struct sockaddr_in s_inet; } sock_addr; static int sock_addr_len; /* Length of sock_addr */ @@ -98,7 +98,7 @@ static void open_connection(void) setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, (char *) &newvalue, sizeof(newvalue)); } -#endif +#endif dbg_socket = socket(sock_domain, SOCK_STREAM, 0); #ifdef _WIN32 if (retcode == 0) { @@ -106,7 +106,7 @@ static void open_connection(void) setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, (char *) &oldvalue, oldvaluelen); } -#endif +#endif if (dbg_socket == -1 || connect(dbg_socket, &sock_addr.s_gen, sock_addr_len) == -1){ caml_fatal_error_arg2 ("cannot connect to debugger at %s", dbg_addr, @@ -181,7 +181,7 @@ void caml_debugger_init(void) + strlen(address); #else caml_fatal_error("Unix sockets not supported"); -#endif +#endif } else { /* Internet domain */ sock_domain = PF_INET; @@ -318,7 +318,7 @@ void caml_debugger(enum event_kind event) #else caml_fatal_error("error: REQ_CHECKPOINT command"); exit(-1); -#endif +#endif break; case REQ_GO: caml_event_count = caml_getword(dbg_in); @@ -332,7 +332,7 @@ void caml_debugger(enum event_kind event) #else caml_fatal_error("Fatal error: REQ_WAIT command"); exit(-1); -#endif +#endif break; case REQ_INITIAL_FRAME: frame = caml_extern_sp + 1; diff --git a/byterun/debugger.h b/byterun/debugger.h index 59e23ec0e1..ce479d271a 100644 --- a/byterun/debugger.h +++ b/byterun/debugger.h @@ -46,7 +46,7 @@ enum debugger_request { REQ_RESET_INSTR = 'i', /* uint32 pos */ /* Clear an event or breapoint at position pos, restores initial instr. */ REQ_CHECKPOINT = 'c', /* no args */ - /* Checkpoint the runtime system by forking a child process. + /* Checkpoint the runtime system by forking a child process. Reply is pid of child process or -1 if checkpoint failed. */ REQ_GO = 'g', /* uint32 n */ /* Run the program for n events. diff --git a/byterun/dynlink.c b/byterun/dynlink.c index e08bdc0b2c..7df594dbe9 100644 --- a/byterun/dynlink.c +++ b/byterun/dynlink.c @@ -94,7 +94,7 @@ static char * parse_ld_conf(void) ldconfname); config = caml_stat_alloc(st.st_size + 1); nread = read(ldconf, config, st.st_size); - if (nread == -1) + if (nread == -1) caml_fatal_error_arg ("Fatal error: error while reading loader config file %s\n", ldconfname); diff --git a/byterun/fix_code.c b/byterun/fix_code.c index b626f2cb07..b252efd587 100644 --- a/byterun/fix_code.c +++ b/byterun/fix_code.c @@ -92,7 +92,7 @@ void caml_thread_code (code_t code, asize_t len) code_t p; int l [STOP + 1]; int i; - + for (i = 0; i <= STOP; i++) { l [i] = 0; } diff --git a/byterun/floats.c b/byterun/floats.c index 21ba411a77..d1d178a329 100644 --- a/byterun/floats.c +++ b/byterun/floats.c @@ -429,7 +429,7 @@ CAMLprim value caml_classify_float(value vd) return Val_int(FP_normal); } #else - union { + union { double d; #if defined(ARCH_BIG_ENDIAN) || (defined(__arm__) && !defined(__ARM_EABI__)) struct { uint32 h; uint32 l; } i; diff --git a/byterun/globroots.c b/byterun/globroots.c index e4fec33287..acac1e2170 100644 --- a/byterun/globroots.c +++ b/byterun/globroots.c @@ -133,7 +133,7 @@ static void caml_delete_global_root(struct global_root_list * rootlist, /* Reclaim list element */ caml_stat_free(e); /* Down-correct list level */ - while (rootlist->level > 0 && + while (rootlist->level > 0 && rootlist->forward[rootlist->level] == NULL) rootlist->level--; } @@ -223,11 +223,11 @@ CAMLexport void caml_modify_generational_global_root(value *r, value newval) { value oldval = *r; - /* It is OK to have a root in roots_young that suddenly points to + /* It is OK to have a root in roots_young that suddenly points to the old generation -- the next minor GC will take care of that. What needs corrective action is a root in roots_old that suddenly points to the young generation. */ - if (Is_block(newval) && Is_young(newval) && + if (Is_block(newval) && Is_young(newval) && Is_block(oldval) && Is_in_heap(oldval)) { caml_delete_global_root(&caml_global_roots_old, r); caml_insert_global_root(&caml_global_roots_young, r); diff --git a/byterun/hash.c b/byterun/hash.c index a1d7864db8..c981768d0f 100644 --- a/byterun/hash.c +++ b/byterun/hash.c @@ -61,7 +61,7 @@ static void hash_aux(value obj) /* Pointers into the heap are well-structured blocks. So are atoms. We can inspect the block contents. */ - Assert (Is_block (obj)); + Assert (Is_block (obj)); if (Is_in_value_area(obj)) { tag = Tag_val(obj); switch (tag) { @@ -146,7 +146,7 @@ CAMLexport value caml_hash_variant(char const * tag) { value accu; /* Same hashing algorithm as in ../typing/btype.ml, function hash_variant */ - for (accu = Val_int(0); *tag != 0; tag++) + for (accu = Val_int(0); *tag != 0; tag++) accu = Val_int(223 * Int_val(accu) + *((unsigned char *) tag)); #ifdef ARCH_SIXTYFOUR accu = accu & Val_long(0x7FFFFFFFL); diff --git a/byterun/instrtrace.c b/byterun/instrtrace.c index 3734d82412..3afdc9541e 100644 --- a/byterun/instrtrace.c +++ b/byterun/instrtrace.c @@ -59,7 +59,7 @@ void caml_disasm_instr(pc) /* Instructions with two operands */ case APPTERM: case CLOSURE: case CLOSUREREC: case PUSHGETGLOBALFIELD: case GETGLOBALFIELD: case MAKEBLOCK: - case BEQ: case BNEQ: case BLTINT: case BLEINT: case BGTINT: case BGEINT: + case BEQ: case BNEQ: case BLTINT: case BLEINT: case BGTINT: case BGEINT: case BULTINT: case BUGEINT: printf(" %d, %d\n", pc[0], pc[1]); break; /* Instructions with a C primitive as operand */ @@ -182,13 +182,13 @@ caml_trace_value_file (value v, code_t prog, int proglen, FILE * f) if (!v) return; if (prog && v % sizeof (int) == 0 - && (code_t) v >= prog - && (code_t) v < (code_t) ((char *) prog + proglen)) + && (code_t) v >= prog + && (code_t) v < (code_t) ((char *) prog + proglen)) fprintf (f, "=code@%d", (code_t) v - prog); else if (Is_long (v)) fprintf (f, "=long%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val (v)); - else if ((void*)v >= (void*)caml_stack_low - && (void*)v < (void*)caml_stack_high) + else if ((void*)v >= (void*)caml_stack_low + && (void*)v < (void*)caml_stack_high) fprintf (f, "=stack_%d", (intnat*)caml_stack_high - (intnat*)v); else if (Is_block (v)) { int s = Wosize_val (v); @@ -202,10 +202,10 @@ caml_trace_value_file (value v, code_t prog, int proglen, FILE * f) l = caml_string_length (v); fprintf (f, "=string[s%dL%d]'", s, l); for (i = 0; i < ((l>0x1f)?0x1f:l) ; i++) { - if (isprint (Byte (v, i))) - putc (Byte (v, i), f); - else - putc ('?', f); + if (isprint (Byte (v, i))) + putc (Byte (v, i), f); + else + putc ('?', f); }; fprintf (f, "'"); goto displayfields; @@ -215,7 +215,7 @@ caml_trace_value_file (value v, code_t prog, int proglen, FILE * f) case Double_array_tag: fprintf (f, "=floatarray[s%d]", s); for (i = 0; i < ((s>0xf)?0xf:s); i++) - fprintf (f, " %g", Double_field (v, i)); + fprintf (f, " %g", Double_field (v, i)); goto displayfields; case Abstract_tag: fprintf (f, "=abstract[s%d]", s); @@ -227,25 +227,25 @@ caml_trace_value_file (value v, code_t prog, int proglen, FILE * f) fprintf (f, "=block<T%d/s%d>", tg, s); displayfields: if (s > 0) - fputs ("=(", f); + fputs ("=(", f); for (i = 0; i < s; i++) { - if (i > 20) { - fputs ("....", f); - break; - }; - if (i > 0) - putc (' ', f); - fprintf (f, "%#lx", Field (v, i)); + if (i > 20) { + fputs ("....", f); + break; + }; + if (i > 0) + putc (' ', f); + fprintf (f, "%#lx", Field (v, i)); }; if (s > 0) - putc (')', f); + putc (')', f); }; } } void caml_trace_accu_sp_file (value accu, value * sp, code_t prog, int proglen, - FILE * f) + FILE * f) { int i; value *p; diff --git a/byterun/instruct.h b/byterun/instruct.h index a2eb5b7b5e..c45d4ea287 100644 --- a/byterun/instruct.h +++ b/byterun/instruct.h @@ -27,7 +27,7 @@ enum instructions { ENVACC1, ENVACC2, ENVACC3, ENVACC4, ENVACC, PUSHENVACC1, PUSHENVACC2, PUSHENVACC3, PUSHENVACC4, PUSHENVACC, PUSH_RETADDR, APPLY, APPLY1, APPLY2, APPLY3, - APPTERM, APPTERM1, APPTERM2, APPTERM3, + APPTERM, APPTERM1, APPTERM2, APPTERM3, RETURN, RESTART, GRAB, CLOSURE, CLOSUREREC, OFFSETCLOSUREM2, OFFSETCLOSURE0, OFFSETCLOSURE2, OFFSETCLOSURE, @@ -48,7 +48,7 @@ enum instructions { NEGINT, ADDINT, SUBINT, MULINT, DIVINT, MODINT, ANDINT, ORINT, XORINT, LSLINT, LSRINT, ASRINT, EQ, NEQ, LTINT, LEINT, GTINT, GEINT, - OFFSETINT, OFFSETREF, ISINT, + OFFSETINT, OFFSETREF, ISINT, GETMETHOD, BEQ, BNEQ, BLTINT, BLEINT, BGTINT, BGEINT, ULTINT, UGEINT, diff --git a/byterun/int64_format.h b/byterun/int64_format.h index 2096a030de..b9ae910400 100644 --- a/byterun/int64_format.h +++ b/byterun/int64_format.h @@ -49,7 +49,7 @@ static void I64_format(char * buffer, char * fmt, int64 x) filler = '0'; break; case '#': alternate = 1; break; - case '1': case '2': case '3': case '4': case '5': + case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': width = atoi(p); while (*p >= '0' && *p <= '9') p++; diff --git a/byterun/intern.c b/byterun/intern.c index b7acfd4a06..f442114622 100644 --- a/byterun/intern.c +++ b/byterun/intern.c @@ -104,7 +104,7 @@ static void intern_cleanup(void) if (intern_obj_table != NULL) caml_stat_free(intern_obj_table); if (intern_extra_block != NULL) { /* free newly allocated heap chunk */ - caml_free_for_heap(intern_extra_block); + caml_free_for_heap(intern_extra_block); } else if (intern_block != 0) { /* restore original header for heap block, otherwise GC is confused */ Hd_val(intern_block) = intern_header; @@ -186,7 +186,7 @@ static void intern_rec(value *dest) read_shared: Assert (ofs > 0); Assert (ofs <= obj_counter); - Assert (intern_obj_table != NULL); + Assert (intern_obj_table != NULL); v = intern_obj_table[obj_counter - ofs]; break; case CODE_SHARED16: @@ -237,7 +237,7 @@ static void intern_rec(value *dest) Permute_64(v, ARCH_FLOAT_ENDIANNESS, v, 0x01234567) else Permute_64(v, ARCH_FLOAT_ENDIANNESS, v, 0x76543210); -#endif +#endif break; case CODE_DOUBLE_ARRAY8_LITTLE: case CODE_DOUBLE_ARRAY8_BIG: @@ -508,7 +508,7 @@ CAMLexport value caml_input_value_from_malloc(char * data, intnat ofs) intern_src = intern_input + ofs; intern_input_malloced = 1; magic = read32u(); - if (magic != Intext_magic_number) + if (magic != Intext_magic_number) caml_failwith("input_value_from_malloc: bad object"); block_len = read32u(); obj = input_val_from_block(); @@ -527,7 +527,7 @@ CAMLexport value caml_input_value_from_block(char * data, intnat len) intern_src = intern_input; intern_input_malloced = 0; magic = read32u(); - if (magic != Intext_magic_number) + if (magic != Intext_magic_number) caml_failwith("input_value_from_block: bad object"); block_len = read32u(); if (5*4 + block_len > len) diff --git a/byterun/interp.c b/byterun/interp.c index 254441e6ef..7bcdf7acb3 100644 --- a/byterun/interp.c +++ b/byterun/interp.c @@ -1024,14 +1024,14 @@ value caml_interprete(code_t prog, asize_t prog_size) Instruct(ISINT): accu = Val_long(accu & 1); Next; - + /* Object-oriented operations */ #define Lookup(obj, lab) Field (Field (obj, 0), Int_val(lab)) /* please don't forget to keep below code in sync with the - functions caml_cache_public_method and - caml_cache_public_method2 in obj.c */ + functions caml_cache_public_method and + caml_cache_public_method2 in obj.c */ Instruct(GETMETHOD): accu = Lookup(sp[0], accu); @@ -1137,7 +1137,7 @@ void caml_prepare_bytecode(code_t prog, asize_t prog_size) { Assert(prog); Assert(prog_size>0); /* actually, the threading of the bytecode might be done here */ -} +} void caml_release_bytecode(code_t prog, asize_t prog_size) { /* other implementations of the interpreter (such as an hypothetical diff --git a/byterun/ints.c b/byterun/ints.c index 7b8a136751..9fdaa1802b 100644 --- a/byterun/ints.c +++ b/byterun/ints.c @@ -180,7 +180,7 @@ CAMLprim value caml_format_int(value fmt, value arg) value res; buffer = parse_format(fmt, ARCH_INTNAT_PRINTF_FORMAT, - format_string, default_format_buffer, &conv); + format_string, default_format_buffer, &conv); switch (conv) { case 'u': case 'x': case 'X': case 'o': sprintf(buffer, format_string, Unsigned_long_val(arg)); @@ -492,7 +492,7 @@ CAMLprim value caml_int64_of_float(value v) { return caml_copy_int64(I64_of_double(Double_val(v))); } CAMLprim value caml_int64_to_float(value v) -{ +{ int64 i = Int64_val(v); return caml_copy_double(I64_to_double(i)); } diff --git a/byterun/lexing.c b/byterun/lexing.c index d2776116ef..6e74795c23 100644 --- a/byterun/lexing.c +++ b/byterun/lexing.c @@ -219,7 +219,7 @@ CAMLprim value caml_new_lex_engine(struct lexing_table *tbl, value start_state, pc_off = Short(tbl->lex_trans_code, base_code + c) ; else pc_off = Short(tbl->lex_default_code, pstate) ; - if (pc_off > 0) + if (pc_off > 0) run_mem(Bp_val(tbl->lex_code) + pc_off, lexbuf->lex_mem, lexbuf->lex_curr_pos) ; /* Erase the EOF condition only if the EOF pseudo-character was consumed by the automaton (i.e. there was no backtrack above) @@ -228,4 +228,3 @@ CAMLprim value caml_new_lex_engine(struct lexing_table *tbl, value start_state, } } } - diff --git a/byterun/md5.c b/byterun/md5.c index 9d2481fe91..d0b6e5e462 100644 --- a/byterun/md5.c +++ b/byterun/md5.c @@ -308,4 +308,3 @@ CAMLexport void caml_MD5Transform(uint32 *buf, uint32 *in) buf[2] += c; buf[3] += d; } - diff --git a/byterun/md5.h b/byterun/md5.h index ff8c23ee0e..b92b02ad12 100644 --- a/byterun/md5.h +++ b/byterun/md5.h @@ -32,7 +32,7 @@ struct MD5Context { }; CAMLextern void caml_MD5Init (struct MD5Context *context); -CAMLextern void caml_MD5Update (struct MD5Context *context, unsigned char *buf, +CAMLextern void caml_MD5Update (struct MD5Context *context, unsigned char *buf, uintnat len); CAMLextern void caml_MD5Final (unsigned char *digest, struct MD5Context *ctx); CAMLextern void caml_MD5Transform (uint32 *buf, uint32 *in); diff --git a/byterun/meta.c b/byterun/meta.c index 91143612ac..1ed4fbddd5 100644 --- a/byterun/meta.c +++ b/byterun/meta.c @@ -82,7 +82,7 @@ CAMLprim value caml_realloc_global(value size) } return Val_unit; } - + CAMLprim value caml_get_current_environment(value unit) { return *caml_extern_sp; @@ -148,7 +148,7 @@ value caml_realloc_global(value size) caml_invalid_argument("Meta.realloc_global"); return Val_unit; /* not reached */ } - + value caml_invoke_traced_function(value codeptr, value env, value arg) { caml_invalid_argument("Meta.invoke_traced_function"); diff --git a/byterun/osdeps.h b/byterun/osdeps.h index 3646fb4f78..248b3f6aa3 100644 --- a/byterun/osdeps.h +++ b/byterun/osdeps.h @@ -69,4 +69,3 @@ extern int caml_executable_name(char * name, int name_len); #endif #endif /* CAML_OSDEPS_H */ - diff --git a/byterun/parsing.c b/byterun/parsing.c index 23228bf7bc..bcb9e5faa5 100644 --- a/byterun/parsing.c +++ b/byterun/parsing.c @@ -83,7 +83,7 @@ int caml_parser_trace = 0; /* Output codes */ /* Mirrors parser_output in ../stdlib/parsing.ml */ -#define READ_TOKEN Val_int(0) +#define READ_TOKEN Val_int(0) #define RAISE_PARSE_ERROR Val_int(1) #define GROW_STACKS_1 Val_int(2) #define GROW_STACKS_2 Val_int(3) @@ -133,8 +133,8 @@ static void print_token(struct parser_tables *tables, int state, value tok) else fprintf(stderr, "_"); fprintf(stderr, ")\n"); - } -} + } +} /* The pushdown automata */ @@ -171,7 +171,7 @@ CAMLprim value caml_parse_engine(struct parser_tables *tables, caml_modify(&env->lval, Val_long(0)); } if (caml_parser_trace) print_token(tables, state, arg); - + testshift: n1 = Short(tables->sindex, state); n2 = n1 + Int_val(env->curr_char); @@ -199,7 +199,7 @@ CAMLprim value caml_parse_engine(struct parser_tables *tables, n2 = n1 + ERRCODE; if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) && Short(tables->check, n2) == ERRCODE) { - if (caml_parser_trace) + if (caml_parser_trace) fprintf(stderr, "Recovering in state %d\n", state1); goto shift_recover; } else { @@ -222,7 +222,7 @@ CAMLprim value caml_parse_engine(struct parser_tables *tables, env->curr_char = Val_int(-1); goto loop; } - + shift: env->curr_char = Val_int(-1); if (errflag > 0) errflag--; @@ -289,7 +289,7 @@ CAMLprim value caml_parse_engine(struct parser_tables *tables, Assert(0); return RAISE_PARSE_ERROR; /* Keeps gcc -Wall happy */ } - + } /* Control printing of debugging info */ diff --git a/byterun/printexc.c b/byterun/printexc.c index c2f0af046a..f72157ff08 100644 --- a/byterun/printexc.c +++ b/byterun/printexc.c @@ -44,7 +44,7 @@ static void add_string(struct stringbuf *buf, char *s) if (len > 0) memmove(buf->ptr, s, len); buf->ptr += len; } - + CAMLexport char * caml_format_exception(value exn) { mlsize_t start, i; diff --git a/byterun/roots.c b/byterun/roots.c index ff726bd319..74fbb41edb 100644 --- a/byterun/roots.c +++ b/byterun/roots.c @@ -101,4 +101,3 @@ CAMLexport void caml_do_local_roots (scanning_action f, value *stack_low, } } } - diff --git a/byterun/signals.c b/byterun/signals.c index 31604eba24..90fe891962 100644 --- a/byterun/signals.c +++ b/byterun/signals.c @@ -267,7 +267,7 @@ CAMLprim value caml_install_signal_handler(value signal_number, value action) int sig, act, oldact; sig = caml_convert_signal_number(Int_val(signal_number)); - if (sig < 0 || sig >= NSIG) + if (sig < 0 || sig >= NSIG) caml_invalid_argument("Sys.signal: unavailable signal"); switch(action) { case Val_int(0): /* Signal_default */ diff --git a/byterun/startup.c b/byterun/startup.c index 419d49be60..f954e3ee52 100644 --- a/byterun/startup.c +++ b/byterun/startup.c @@ -176,7 +176,7 @@ int32 caml_seek_optional_section(int fd, struct exec_trailer *trail, char *name) int32 caml_seek_section(int fd, struct exec_trailer *trail, char *name) { int32 len = caml_seek_optional_section(fd, trail, name); - if (len == -1) + if (len == -1) caml_fatal_error_arg("Fatal_error: section `%s' is missing\n", name); return len; } diff --git a/byterun/str.c b/byterun/str.c index 380e2eb5ad..760b154e30 100644 --- a/byterun/str.c +++ b/byterun/str.c @@ -91,7 +91,7 @@ CAMLprim value caml_string_compare(value s1, value s2) if (s1 == s2) return Val_int(0); len1 = caml_string_length(s1); - len2 = caml_string_length(s2); + len2 = caml_string_length(s2); res = memcmp(String_val(s1), String_val(s2), len1 <= len2 ? len1 : len2); if (res < 0) return Val_int(-1); if (res > 0) return Val_int(1); @@ -104,22 +104,22 @@ CAMLprim value caml_string_lessthan(value s1, value s2) { return caml_string_compare(s1, s2) < Val_int(0) ? Val_true : Val_false; } - + CAMLprim value caml_string_lessequal(value s1, value s2) { return caml_string_compare(s1, s2) <= Val_int(0) ? Val_true : Val_false; } - + CAMLprim value caml_string_greaterthan(value s1, value s2) { return caml_string_compare(s1, s2) > Val_int(0) ? Val_true : Val_false; } - + CAMLprim value caml_string_greaterequal(value s1, value s2) { return caml_string_compare(s1, s2) >= Val_int(0) ? Val_true : Val_false; } - + CAMLprim value caml_blit_string(value s1, value ofs1, value s2, value ofs2, value n) { @@ -153,4 +153,3 @@ CAMLprim value caml_bitvect_test(value bv, value n) int pos = Int_val(n); return Val_int(Byte_u(bv, pos >> 3) & (1 << (pos & 7))); } - diff --git a/byterun/win32.c b/byterun/win32.c index fa499f959b..866977b121 100644 --- a/byterun/win32.c +++ b/byterun/win32.c @@ -84,7 +84,7 @@ char * caml_search_in_path(struct ext_table * path, char * name) strcpy(fullname, name); return fullname; } - + CAMLexport char * caml_search_exe_in_path(char * name) { char * fullname, * filepart; @@ -95,14 +95,14 @@ CAMLexport char * caml_search_exe_in_path(char * name) while (1) { fullname = stat_alloc(pathlen); retcode = SearchPath(NULL, /* use system search path */ - name, - ".exe", /* add .exe extension if needed */ - pathlen, - fullname, - &filepart); + name, + ".exe", /* add .exe extension if needed */ + pathlen, + fullname, + &filepart); if (retcode == 0) { caml_gc_message(0x100, "%s not found in search path\n", - (uintnat) name); + (uintnat) name); strcpy(fullname, name); break; } @@ -406,7 +406,7 @@ void caml_signal_thread(void * lpParam) #if defined(NATIVE_CODE) && !defined(_WIN64) -/* Handling of system stack overflow. +/* Handling of system stack overflow. * Based on code provided by Olivier Andrieu. * An EXCEPTION_STACK_OVERFLOW is signaled when the guard page at the @@ -470,11 +470,11 @@ static void caml_reset_stack (void *faulting_address) /* restore the PAGE_GUARD protection on this page */ switch (osi.dwPlatformId) { case VER_PLATFORM_WIN32_NT: - VirtualProtect (mbi.BaseAddress, page_size, + VirtualProtect (mbi.BaseAddress, page_size, mbi.Protect | PAGE_GUARD, &oldprot); break; case VER_PLATFORM_WIN32_WINDOWS: - VirtualProtect (mbi.BaseAddress, page_size, + VirtualProtect (mbi.BaseAddress, page_size, PAGE_NOACCESS, &oldprot); break; } diff --git a/camlp4/CHANGES b/camlp4/CHANGES index 571894b9ce..ef48fc4251 100644 --- a/camlp4/CHANGES +++ b/camlp4/CHANGES @@ -160,8 +160,8 @@ Camlp4 Version 3.05 (Jacques Garrigue's idea): old syntax new syntax [| ... |] [ = ... ] - [| < ... |] [ < ... ] - [| > ... |] [ > ... ] + [| < ... |] [ < ... ] + [| > ... |] [ > ... ] This applies also in predefined quotations of syntax tree for types <:ctyp< ... >> - [05 Jun 02] Added option -ss in pr_o.cmo: print with double semicolons; @@ -600,7 +600,7 @@ Grammar interface is now: Grammar.tokens g "" -Missing features added +Missing features added * Added "lazy" statement (pa_r.cmo, pa_o.cmo, pr_r.cmo, pr_o.cmo) * Added print "assert" statement (pr_o.cmo, pr_r.cmo) * Added parsing of infix operators like in Ocaml (e.g. |||) in pa_o.cmo @@ -690,7 +690,7 @@ Errors and missings in normal and righteous syntaxes. Grammars, EXTEND, DELETE_RULE -* Added functorial version for grammars (started in version 1.07.1, +* Added functorial version for grammars (started in version 1.07.1, completed in this version). * Added statements GEXTEND and GDELETE_RULE in pa_extend.cmo for functorial version. diff --git a/camlp4/Camlp4/Camlp4Ast.partial.ml b/camlp4/Camlp4/Camlp4Ast.partial.ml index ba941d7a87..19b5053b86 100644 --- a/camlp4/Camlp4/Camlp4Ast.partial.ml +++ b/camlp4/Camlp4/Camlp4Ast.partial.ml @@ -160,7 +160,7 @@ (* sig sg end *) | MtSig of loc and sig_item (* mt with wc *) - | MtWit of loc and module_type and with_constr + | MtWit of loc and module_type and with_constr | MtAnt of loc and string (* $s$ *) ] and sig_item = [ SgNil of loc diff --git a/camlp4/Camlp4/Debug.ml b/camlp4/Camlp4/Debug.ml index b94d8f4da3..cbd3092276 100644 --- a/camlp4/Camlp4/Debug.ml +++ b/camlp4/Camlp4/Debug.ml @@ -45,7 +45,7 @@ value mode = StringSet.add (String.sub str i (String.length str - i)) acc ] in let sections = loop StringSet.empty 0 in if StringSet.mem "*" sections then fun _ -> True - else fun x -> StringSet.mem x sections + else fun x -> StringSet.mem x sections with [ Not_found -> fun _ -> False ]; value formatter = diff --git a/camlp4/Camlp4/PreCast.ml b/camlp4/Camlp4/PreCast.ml index 527c0c484a..8e3da3483d 100644 --- a/camlp4/Camlp4/PreCast.ml +++ b/camlp4/Camlp4/PreCast.ml @@ -65,4 +65,3 @@ module Printers = struct module DumpCamlp4Ast = Printers.DumpCamlp4Ast.Make Syntax; module Null = Printers.Null.Make Syntax; end; - diff --git a/camlp4/Camlp4/Printers/Null.ml b/camlp4/Camlp4/Printers/Null.ml index d593f9efc5..a9a2c486b8 100644 --- a/camlp4/Camlp4/Printers/Null.ml +++ b/camlp4/Camlp4/Printers/Null.ml @@ -24,7 +24,7 @@ end; module Make (Syntax : Sig.Syntax) = struct include Syntax; - + value print_interf ?input_file:(_) ?output_file:(_) _ = (); value print_implem ?input_file:(_) ?output_file:(_) _ = (); end; diff --git a/camlp4/Camlp4/Register.ml b/camlp4/Camlp4/Register.ml index 6044b0d97e..4b68193683 100644 --- a/camlp4/Camlp4/Register.ml +++ b/camlp4/Camlp4/Register.ml @@ -139,7 +139,7 @@ module CurrentParser = struct value parse_interf ?directive_handler loc strm = sig_item_parser.val ?directive_handler loc strm; value parse_implem ?directive_handler loc strm = - str_item_parser.val ?directive_handler loc strm; + str_item_parser.val ?directive_handler loc strm; end; module CurrentPrinter = struct @@ -147,7 +147,7 @@ module CurrentPrinter = struct value print_interf ?input_file ?output_file ast = sig_item_printer.val ?input_file ?output_file ast; value print_implem ?input_file ?output_file ast = - str_item_printer.val ?input_file ?output_file ast; + str_item_printer.val ?input_file ?output_file ast; end; value enable_ocaml_printer () = @@ -167,4 +167,3 @@ value enable_dump_camlp4_ast_printer () = value enable_null_printer () = let module M = Printer PP.Null.Id PP.Null.Make in (); - diff --git a/camlp4/Camlp4/Register.mli b/camlp4/Camlp4/Register.mli index df1180ffdd..5131143977 100644 --- a/camlp4/Camlp4/Register.mli +++ b/camlp4/Camlp4/Register.mli @@ -91,4 +91,3 @@ value enable_ocamlr_printer : unit -> unit; value enable_null_printer : unit -> unit; value enable_dump_ocaml_ast_printer : unit -> unit; value enable_dump_camlp4_ast_printer : unit -> unit; - diff --git a/camlp4/Camlp4/Sig.ml b/camlp4/Camlp4/Sig.ml index 3e7106e73d..f2df616b8e 100644 --- a/camlp4/Camlp4/Sig.ml +++ b/camlp4/Camlp4/Sig.ml @@ -247,7 +247,7 @@ module type Ast = sig (** This class is the base class for map traversal on the Ast. To make a custom traversal class one just extend it like that: - + This example swap pairs expression contents: open Camlp4.PreCast; [class swap = object @@ -744,7 +744,7 @@ module type Token = sig type t; value to_string : t -> string; - + value print : Format.formatter -> t -> unit; value match_keyword : string -> t -> bool; @@ -774,7 +774,7 @@ module type Token = sig function to produce token keywords instead. *) value filter : t -> token_filter; - (** Called by the grammar system when a keyword is used. + (** Called by the grammar system when a keyword is used. The boolean argument is True when it's the first time that keyword is used. If you do not care about this information just return [()]. *) value keyword_added : t -> string -> bool -> unit; @@ -955,10 +955,10 @@ module Grammar = struct (** The abstract type of grammar entries. The type parameter is the type of the semantic actions that are associated with this entry. *) type t 'a; - + (** Make a new entry from the given name. *) value mk : gram -> string -> t 'a; - + (** Make a new entry from a name and an hand made token parser. *) value of_parser : gram -> string -> (Stream.t (Token.t * Loc.t) -> 'a) -> t 'a; @@ -1367,4 +1367,3 @@ module type SyntaxExtension = functor (Syn : Syntax) and module Token = Syn.Token and module Gram = Syn.Gram and module Quotation = Syn.Quotation); - diff --git a/camlp4/Camlp4/Struct/CommentFilter.ml b/camlp4/Camlp4/Struct/CommentFilter.ml index 5867df4085..9dac53fbf7 100644 --- a/camlp4/Camlp4/Struct/CommentFilter.ml +++ b/camlp4/Camlp4/Struct/CommentFilter.ml @@ -35,7 +35,7 @@ module Make (Token : Sig.Camlp4Token) = struct do { Queue.add (x, loc) q; debug comments "add: %S at %a@\n" x Loc.dump loc in self xs } - | [: ` x; xs :] -> + | [: ` x; xs :] -> (* debug comments "Found %a at %a@." Token.print x Loc.dump loc in *) [: ` x; self xs :] | [: :] -> [: :] ] diff --git a/camlp4/Camlp4/Struct/FreeVars.ml b/camlp4/Camlp4/Struct/FreeVars.ml index 66a9a8b0ec..7ce12e24d9 100644 --- a/camlp4/Camlp4/Struct/FreeVars.ml +++ b/camlp4/Camlp4/Struct/FreeVars.ml @@ -125,4 +125,3 @@ module Make (Ast : Sig.Camlp4Ast) = struct value free_vars env_init e = let fold = new fold_free_vars S.add ~env_init S.empty in (fold#expr e)#free; end; - diff --git a/camlp4/Camlp4/Struct/Grammar/Context.ml b/camlp4/Camlp4/Struct/Grammar/Context.ml index 75d731c664..b92c2915bc 100644 --- a/camlp4/Camlp4/Struct/Grammar/Context.ml +++ b/camlp4/Camlp4/Struct/Grammar/Context.ml @@ -38,7 +38,7 @@ module Make (Token : Sig.Token) : S with module Token = Token = struct type t = { strm : mutable Stream.t (Token.t * Loc.t); loc : mutable Loc.t }; - value loc_bp c = + value loc_bp c = match Stream.peek c.strm with [ None -> Loc.ghost | Some (_, loc) -> loc ]; diff --git a/camlp4/Camlp4/Struct/Grammar/Parser.mli b/camlp4/Camlp4/Struct/Grammar/Parser.mli index 695982a3d2..e5a3faaafc 100644 --- a/camlp4/Camlp4/Struct/Grammar/Parser.mli +++ b/camlp4/Camlp4/Struct/Grammar/Parser.mli @@ -65,4 +65,3 @@ module Make (Structure : Structure.S) : sig value continue_parser_of_entry : internal_entry -> int -> Loc.t -> Action.t -> Context.t -> Stream.t (Token.t * Loc.t) -> Action.t; end; - diff --git a/camlp4/Camlp4/Struct/Lexer.mll b/camlp4/Camlp4/Struct/Lexer.mll index f024fa4377..40a0822337 100644 --- a/camlp4/Camlp4/Struct/Lexer.mll +++ b/camlp4/Camlp4/Struct/Lexer.mll @@ -396,7 +396,7 @@ module Make (Token : Sig.Camlp4Token) SYMBOL(beginning ^ tok) } and maybe_quotation_at c = parse - | (ident as loc) '<' + | (ident as loc) '<' { mk_quotation quotation c "" loc (1 + String.length loc) } | symbolchar* as tok { SYMBOL("<@" ^ tok) } @@ -434,7 +434,7 @@ module Make (Token : Sig.Camlp4Token) | _ { store_parse (antiquot name) c } { - + let lexing_store s buff max = let rec self n s = if n >= max then n diff --git a/camlp4/Camlp4/Struct/Loc.ml b/camlp4/Camlp4/Struct/Loc.ml index 48974d8293..ac42d4b1c4 100644 --- a/camlp4/Camlp4/Struct/Loc.ml +++ b/camlp4/Camlp4/Struct/Loc.ml @@ -25,32 +25,32 @@ open Format; handling: type pos = ... the same ... - + 1/ - + type loc = { file_name : string; start : pos; stop : pos }; - + type t = [ Nowhere | Ghost of loc (* the closest non ghost loc *) | Concrete of loc ]; - + 2/ - + type loc = { file_name : string; start : pos; stop : pos }; - + type t = option loc; - + 3/ - + type t = { file_name : option string; start : pos; @@ -195,7 +195,7 @@ value merge a b = debug loc "trivial merge@\n" in a else - let r = + let r = match (a.ghost, b.ghost) with [ (False, False) -> (* FIXME if a.file_name <> b.file_name then diff --git a/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml b/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml index f5efd2c6a8..c0af8e53a7 100644 --- a/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml +++ b/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml @@ -56,22 +56,22 @@ module Make (AstFilters : Camlp4.Sig.AstFilters) = struct value exsk s k = <:expr< $lid:xsk s k$>>; value rec apply_expr accu = - fun - [ [] -> accu + fun + [ [] -> accu | [x :: xs] -> let _loc = Ast.loc_of_expr x in apply_expr <:expr< $accu$ $x$ >> xs ]; value rec apply_patt accu = - fun - [ [] -> accu + fun + [ [] -> accu | [x :: xs] -> let _loc = Ast.loc_of_patt x in apply_patt <:patt< $accu$ $x$ >> xs ]; value rec apply_ctyp accu = - fun - [ [] -> accu + fun + [ [] -> accu | [x :: xs] -> let _loc = Ast.loc_of_ctyp x in apply_ctyp <:ctyp< $accu$ $x$ >> xs ]; @@ -430,7 +430,7 @@ module Make (AstFilters : Camlp4.Sig.AstFilters) = struct let priv = if priv then Ast.BTrue else Ast.BFalse in <:class_str_item< method $private:priv$ $lid:id1$ : $ty$ = $funs$; $acc$ >> - and ctyp_name_of_name_params name params = + and ctyp_name_of_name_params name params = apply_ctyp <:ctyp< $id:name$ >> params and method_type_of_type_decl (_, name, params, ctyp, _) = diff --git a/camlp4/Camlp4Filters/Camlp4MetaGenerator.ml b/camlp4/Camlp4Filters/Camlp4MetaGenerator.ml index ea99c99ed9..6eb849995b 100644 --- a/camlp4/Camlp4Filters/Camlp4MetaGenerator.ml +++ b/camlp4/Camlp4Filters/Camlp4MetaGenerator.ml @@ -151,7 +151,7 @@ value filter st = value meta_float _loc s = $m.flo$ _loc s; value meta_char _loc s = $m.chr$ _loc s; value meta_bool _loc = - fun + fun [ False -> $m_uid m "False"$ | True -> $m_uid m "True"$ ]; value rec meta_list mf_a _loc = diff --git a/camlp4/Camlp4Parsers/Camlp4DebugParser.ml b/camlp4/Camlp4Parsers/Camlp4DebugParser.ml index a815a96a24..7e72281881 100644 --- a/camlp4/Camlp4Parsers/Camlp4DebugParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4DebugParser.ml @@ -40,7 +40,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct StringSet.add (String.sub str i (String.length str - i)) acc ] in let sections = loop StringSet.empty 0 in if StringSet.mem "*" sections then fun _ -> True - else fun x -> StringSet.mem x sections + else fun x -> StringSet.mem x sections with [ Not_found -> fun _ -> False ]; value rec apply accu = diff --git a/camlp4/Camlp4Parsers/Camlp4GrammarParser.ml b/camlp4/Camlp4Parsers/Camlp4GrammarParser.ml index 50cbdb2bf3..2aa4334537 100644 --- a/camlp4/Camlp4Parsers/Camlp4GrammarParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4GrammarParser.ml @@ -531,7 +531,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct [ <:expr< $lid:i$ >> -> i | _ -> failwith "internal error in the Grammar extension" ] in <:binding< $lid:i$ = - (grammar_entry_create $str:i$ : $uid:gm$.Entry.t '$x$) >> in + (grammar_entry_create $str:i$ : $uid:gm$.Entry.t '$x$) >> in let expr_of_name {expr = e; tvar = x; loc = _loc} = <:expr< ($e$ : $uid:gm$.Entry.t '$x$) >> in let e = @@ -710,7 +710,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct ; rule_list: [ [ "["; "]" -> [] - | "["; rules = LIST1 rule SEP "|"; "]" -> + | "["; rules = LIST1 rule SEP "|"; "]" -> retype_rule_list_without_patterns _loc rules ] ] ; rule: diff --git a/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml b/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml index 05cfab4725..23db86855c 100644 --- a/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml +++ b/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml @@ -45,21 +45,21 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct [ Some (KEYWORD "<-") -> n | Some (KEYWORD ("[" | "[<")) -> skip_patt (ignore_upto "]" (n + 1) + 1) - | Some (KEYWORD "(") -> + | Some (KEYWORD "(") -> skip_patt (ignore_upto ")" (n + 1) + 1) - | Some (KEYWORD "{") -> + | Some (KEYWORD "{") -> skip_patt (ignore_upto "}" (n + 1) + 1) | Some (KEYWORD ("as" | "::" | "," | "_")) | Some (LIDENT _ | UIDENT _) -> skip_patt (n + 1) | Some _ | None -> raise Stream.Failure ] and ignore_upto end_kwd n = match stream_peek_nth n strm with - [ Some (KEYWORD prm) when prm = end_kwd -> n + [ Some (KEYWORD prm) when prm = end_kwd -> n | Some (KEYWORD ("[" | "[<")) -> ignore_upto end_kwd (ignore_upto "]" (n + 1) + 1) | Some (KEYWORD "(") -> ignore_upto end_kwd (ignore_upto ")" (n + 1) + 1) - | Some (KEYWORD "{") -> + | Some (KEYWORD "{") -> ignore_upto end_kwd (ignore_upto "}" (n + 1) + 1) | Some _ -> ignore_upto end_kwd (n + 1) | None -> raise Stream.Failure ] @@ -69,7 +69,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct value map _loc p e l = match (p, e) with [ (<:patt< $lid:x$ >>, <:expr< $lid:y$ >>) when x = y -> l - | _ -> + | _ -> if Ast.is_irrefut_patt p then <:expr< List.map (fun $p$ -> $e$) $l$ >> else @@ -92,8 +92,8 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct [ [`gen (p, l)] -> map _loc p e l | [`gen (p, l); `cond b :: items] -> compr _loc e [`gen (p, filter _loc p b l) :: items] - | [`gen (p, l) :: ([ `gen (_, _) :: _ ] as is )] -> - concat _loc (map _loc p (compr _loc e is) l) + | [`gen (p, l) :: ([ `gen (_, _) :: _ ] as is )] -> + concat _loc (map _loc p (compr _loc e is) l) | _ -> raise Stream.Failure ]; DELETE_RULE Gram expr: "["; sem_expr_for_list; "]" END; @@ -122,8 +122,8 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | e = expr LEVEL "top" -> <:expr< [$e$] >> ] ] ; - item: - [ [ test_patt_lessminus; + item: + [ [ test_patt_lessminus; p = patt; "<-" ; e = expr LEVEL "top" -> `gen (p, e) | e = expr LEVEL "top" -> `cond e ] ] ; diff --git a/camlp4/Camlp4Parsers/Camlp4MacroParser.ml b/camlp4/Camlp4Parsers/Camlp4MacroParser.ml index ea35915270..57f660daff 100644 --- a/camlp4/Camlp4Parsers/Camlp4MacroParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4MacroParser.ml @@ -316,9 +316,9 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct [ [ "DEFINE"; i = uident; def = opt_macro_value -> SdDef i def | "UNDEF"; i = uident -> SdUnd i | "IFDEF"; uident_eval_ifdef; "THEN"; st1 = smlist_then; st2 = else_macro_def -> - make_SdITE_result st1 st2 + make_SdITE_result st1 st2 | "IFNDEF"; uident_eval_ifndef; "THEN"; st1 = smlist_then; st2 = else_macro_def -> - make_SdITE_result st1 st2 + make_SdITE_result st1 st2 | "INCLUDE"; fname = STRING -> SdLazy (lazy (parse_include_file str_items fname)) ] ] ; @@ -352,23 +352,23 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct ; smlist_then: [ [ sml = LIST1 [ d = macro_def; semi -> - execute_macro_if_active_branch _loc <:str_item<>> (fun a b -> <:str_item< $a$; $b$ >>) Then d - | si = str_item; semi -> SdStr si ] -> sml ] ] + execute_macro_if_active_branch _loc <:str_item<>> (fun a b -> <:str_item< $a$; $b$ >>) Then d + | si = str_item; semi -> SdStr si ] -> sml ] ] ; smlist_else: [ [ sml = LIST1 [ d = macro_def; semi -> - execute_macro_if_active_branch _loc <:str_item<>> (fun a b -> <:str_item< $a$; $b$ >>) Else d - | si = str_item; semi -> SdStr si ] -> sml ] ] + execute_macro_if_active_branch _loc <:str_item<>> (fun a b -> <:str_item< $a$; $b$ >>) Else d + | si = str_item; semi -> SdStr si ] -> sml ] ] ; sglist_then: [ [ sgl = LIST1 [ d = macro_def_sig; semi -> - execute_macro_if_active_branch _loc <:sig_item<>> (fun a b -> <:sig_item< $a$; $b$ >>) Then d - | si = sig_item; semi -> SdStr si ] -> sgl ] ] + execute_macro_if_active_branch _loc <:sig_item<>> (fun a b -> <:sig_item< $a$; $b$ >>) Then d + | si = sig_item; semi -> SdStr si ] -> sgl ] ] ; sglist_else: [ [ sgl = LIST1 [ d = macro_def_sig; semi -> - execute_macro_if_active_branch _loc <:sig_item<>> (fun a b -> <:sig_item< $a$; $b$ >>) Else d - | si = sig_item; semi -> SdStr si ] -> sgl ] ] + execute_macro_if_active_branch _loc <:sig_item<>> (fun a b -> <:sig_item< $a$; $b$ >>) Else d + | si = sig_item; semi -> SdStr si ] -> sgl ] ] ; endif: [ [ "END" -> () diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml index 8a1b53c081..fa550bacf4 100644 --- a/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml @@ -449,7 +449,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct [ [ i = lident_colon; t = ctyp LEVEL "star"; "->"; ct = SELF -> <:class_type< [ ~ $i$ : $t$ ] -> $ct$ >> | "?"; i = a_LIDENT; ":"; t = ctyp LEVEL "star"; "->"; ct = SELF -> - <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> + <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> | i = OPTLABEL (* FIXME inline a_OPTLABEL *); t = ctyp LEVEL "star"; "->"; ct = SELF -> <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> | test_ctyp_minusgreater; t = ctyp LEVEL "star"; "->"; ct = SELF -> diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml index 59cd7b70ee..9dab8bd747 100644 --- a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml @@ -328,7 +328,7 @@ Very old (no more supported) syntax:\n\ <:expr< $lid:x$ >>) ; - let list_ok = ["<"; ">"; "<="; ">="; "="; "<>"; "=="; "!="; "$"] in + let list_ok = ["<"; ">"; "<="; ">="; "="; "<>"; "=="; "!="; "$"] in let list_first_char_ok = ['='; '<'; '>'; '|'; '&'; '$'; '!'] in let excl = ["<-"; "||"; "&&"] in Gram.Entry.setup_parser infixop0 @@ -776,7 +776,7 @@ Very old (no more supported) syntax:\n\ [ p = labeled_ipatt; e = SELF -> <:expr< fun $p$ -> $e$ >> | "="; e = expr -> <:expr< $e$ >> - | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> + | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> | ":>"; t = ctyp; "="; e = expr -> <:expr< ($e$ :> $t$) >> ] ] ; match_case: diff --git a/camlp4/Camlp4Top/Top.ml b/camlp4/Camlp4Top/Top.ml index 4bb92bdc4f..dcd3aa4607 100644 --- a/camlp4/Camlp4Top/Top.ml +++ b/camlp4/Camlp4Top/Top.ml @@ -88,7 +88,7 @@ value wrap parse_fun = | x -> let x = match x with - [ Loc.Exc_located loc x -> do { + [ Loc.Exc_located loc x -> do { Toploop.print_location Format.err_formatter (Loc.to_ocaml_location loc); x } @@ -103,10 +103,10 @@ value wrap parse_fun = value toplevel_phrase token_stream = match Gram.parse_tokens_after_filter Syntax.top_phrase token_stream with [ Some str_item -> - let str_item = - AstFilters.fold_topphrase_filters (fun t filter -> filter t) str_item - in - Ast2pt.phrase str_item + let str_item = + AstFilters.fold_topphrase_filters (fun t filter -> filter t) str_item + in + Ast2pt.phrase str_item | None -> raise End_of_file ]; diff --git a/camlp4/Camlp4_config.ml b/camlp4/Camlp4_config.ml index 8eb191512e..745930b79a 100644 --- a/camlp4/Camlp4_config.ml +++ b/camlp4/Camlp4_config.ml @@ -21,7 +21,7 @@ let ocaml_standard_library = Camlp4_import.Config.standard_library;; let camlp4_standard_library = try Sys.getenv "CAMLP4LIB" - with Not_found -> + with Not_found -> Filename.concat ocaml_standard_library "camlp4";; let version = Sys.ocaml_version;; diff --git a/camlp4/Makefile.ml b/camlp4/Makefile.ml index 681f35bd24..eefedf147a 100644 --- a/camlp4/Makefile.ml +++ b/camlp4/Makefile.ml @@ -275,8 +275,8 @@ let file ppf f = loop () in try loop () with End_of_file -> () let ext_split f = split '.' f - - + + let print_packed_sources ppf ?(skip = fun _ -> false) package_dir = let _ = fold_units_sources [package_dir] (fun name sources k (skip, inside) -> @@ -356,4 +356,3 @@ let just_doc () = let doc () = pack (); just_doc () - diff --git a/camlp4/examples/expression_closure.ml b/camlp4/examples/expression_closure.ml index 58f15448fa..cfc47454d1 100644 --- a/camlp4/examples/expression_closure.ml +++ b/camlp4/examples/expression_closure.ml @@ -21,4 +21,3 @@ value f e = value print_expr = (new PP.printer ())#expr; printf "%a@." print_expr (f <<let z = x + 2 in x + 2 * y * x * z>>); - diff --git a/camlp4/examples/fancy_lambda_quot_test.ml b/camlp4/examples/fancy_lambda_quot_test.ml index 32009828f2..5ff348c9dc 100644 --- a/camlp4/examples/fancy_lambda_quot_test.ml +++ b/camlp4/examples/fancy_lambda_quot_test.ml @@ -3,7 +3,7 @@ let _loc = Camlp4.PreCast.Loc.ghost;; let rec propagate = function | << $f$ $x$ $y$ >> -> begin match propagate f, propagate x, propagate y with - | f, << $int:i$ >>, << $int:j$ >> -> + | f, << $int:i$ >>, << $int:j$ >> -> begin match f with | << plus >> -> << $int:i + j$ >> | << minus >> -> << $int:i - j$ >> diff --git a/camlp4/examples/global_handler.ml b/camlp4/examples/global_handler.ml index 758e4f9680..e2da52873d 100644 --- a/camlp4/examples/global_handler.ml +++ b/camlp4/examples/global_handler.ml @@ -17,4 +17,3 @@ AstFilters.register_str_item_filter begin fun st -> <:str_item@ghost< try let module Main = struct $st$ end in () with e -> $global_handler_ref.val$ e >> end; - diff --git a/camlp4/examples/lambda_test.ml b/camlp4/examples/lambda_test.ml index 408461a523..e2603259a1 100644 --- a/camlp4/examples/lambda_test.ml +++ b/camlp4/examples/lambda_test.ml @@ -10,4 +10,3 @@ let rec_nat = let plus = << fun n -> fun m -> $rec_nat$ n (fun n -> fun p -> $succ$ p) m >> let times = << fun n -> fun m -> $rec_nat$ n (fun n -> fun p -> $plus$ m p) $zero$ >> let fact = << fun n -> $rec_nat$ n (fun n -> fun p -> $times$ ($succ$ n) p) $one$ >> - diff --git a/camlp4/man/Makefile b/camlp4/man/Makefile index bf33c7a051..381bdcc53b 100644 --- a/camlp4/man/Makefile +++ b/camlp4/man/Makefile @@ -12,9 +12,9 @@ install-local: $(MKDIR) $(MANDIR)/man1 ; \ cp $(TARGET) $(MANDIR)/man1/. ; \ for i in $(ALIASES); do \ - rm -f $(MANDIR)/man1/$$i; \ - echo '.so man1/$(TARGET)' > $(MANDIR)/man1/$$i; \ - done; \ + rm -f $(MANDIR)/man1/$$i; \ + echo '.so man1/$(TARGET)' > $(MANDIR)/man1/$$i; \ + done; \ fi camlp4.1: camlp4.1.tpl diff --git a/camlp4/man/camlp4.help.tpl b/camlp4/man/camlp4.help.tpl deleted file mode 100644 index 8b13789179..0000000000 --- a/camlp4/man/camlp4.help.tpl +++ /dev/null @@ -1 +0,0 @@ - diff --git a/config/.cvsignore b/config/.cvsignore index df99fdc719..9fc1c014fc 100644 --- a/config/.cvsignore +++ b/config/.cvsignore @@ -2,4 +2,3 @@ m.h s.h Makefile config.sh - diff --git a/config/Makefile-templ b/config/Makefile-templ index 9889767bb3..dd65452a94 100644 --- a/config/Makefile-templ +++ b/config/Makefile-templ @@ -31,7 +31,7 @@ MANDIR=/usr/local/man MANEXT=1 ### Do #! scripts work on your system? -### Beware: on some systems (e.g. SunOS 4), this will work only if +### Beware: on some systems (e.g. SunOS 4), this will work only if ### the string "#!$(BINDIR)/ocamlrun" is less than 32 characters long. ### In doubt, set SHARPBANGSCRIPTS to false. SHARPBANGSCRIPTS=true @@ -224,7 +224,7 @@ PARTIALLD=ld -r $(NATIVECCLINKOPTS) # unix Unix system calls # str Regular expressions and high-level string processing # num Arbitrary-precision rational arithmetic -# threads Lightweight concurrent processes +# threads Lightweight concurrent processes # systhreads Same as threads, requires POSIX threads # graph Portable drawing primitives for X11 # dynlink Dynamic linking of bytecode diff --git a/config/Makefile.mingw b/config/Makefile.mingw index e5a743e00e..d1e40bb1d7 100644 --- a/config/Makefile.mingw +++ b/config/Makefile.mingw @@ -153,5 +153,5 @@ TK_LINK=$(TK_ROOT)/bin/tk85.dll $(TK_ROOT)/bin/tcl85.dll -lws2_32 ############# Aliases for common commands -MAKEREC=$(MAKE) -f Makefile.nt +MAKEREC=$(MAKE) -f Makefile.nt MAKECMD=$(MAKE) diff --git a/config/Makefile.msvc b/config/Makefile.msvc index 67e4ad7163..4bbf54451f 100644 --- a/config/Makefile.msvc +++ b/config/Makefile.msvc @@ -159,5 +159,5 @@ TK_LINK=tk85.lib tcl85.lib ws2_32.lib ############# Aliases for common commands -MAKEREC=$(MAKE) -f Makefile.nt +MAKEREC=$(MAKE) -f Makefile.nt MAKECMD=$(MAKE) diff --git a/config/Makefile.msvc64 b/config/Makefile.msvc64 index a9f2309b6c..5088fc1727 100644 --- a/config/Makefile.msvc64 +++ b/config/Makefile.msvc64 @@ -154,5 +154,5 @@ TK_LINK= ############# Aliases for common commands -MAKEREC=$(MAKE) -f Makefile.nt +MAKEREC=$(MAKE) -f Makefile.nt MAKECMD=$(MAKE) diff --git a/config/auto-aux/dblalign.c b/config/auto-aux/dblalign.c index 9b44a774e2..c2520381ce 100644 --- a/config/auto-aux/dblalign.c +++ b/config/auto-aux/dblalign.c @@ -52,4 +52,3 @@ int main(void) #endif exit(res); } - diff --git a/config/auto-aux/divmod.c b/config/auto-aux/divmod.c index 24d3786cec..8f69dabf35 100644 --- a/config/auto-aux/divmod.c +++ b/config/auto-aux/divmod.c @@ -15,7 +15,7 @@ /* Test semantics of division and modulus for negative arguments */ -long div4[] = +long div4[] = { -4,-3,-3,-3,-3,-2,-2,-2,-2,-1,-1,-1,-1,0,0,0, 0,0,0,0,1,1,1,1,2,2,2,2,3,3,3,3,4 }; diff --git a/config/auto-aux/int64align.c b/config/auto-aux/int64align.c index 5c77b39c58..6bdd25567a 100644 --- a/config/auto-aux/int64align.c +++ b/config/auto-aux/int64align.c @@ -53,4 +53,3 @@ int main(void) #endif exit(res); } - diff --git a/config/auto-aux/stackov.c b/config/auto-aux/stackov.c index 7f06e9711f..39e4e832be 100644 --- a/config/auto-aux/stackov.c +++ b/config/auto-aux/stackov.c @@ -55,7 +55,7 @@ int main(int argc, char ** argv) #else act.sa_sigaction = segv_handler; act.sa_flags = SA_SIGINFO | SA_ONSTACK | SA_NODEFER; -#endif +#endif sigemptyset(&act.sa_mask); system_stack_top = (char *) &act; if (sigaltstack(&stk, NULL) != 0) { perror("sigaltstack"); return 2; } diff --git a/config/m-nt.h b/config/m-nt.h index d143768151..7a92828110 100644 --- a/config/m-nt.h +++ b/config/m-nt.h @@ -43,4 +43,3 @@ #define ARCH_INT64_PRINTF_FORMAT "I64" #undef NONSTANDARD_DIV_MOD - diff --git a/config/s-templ.h b/config/s-templ.h index 4790478418..a65b178a8c 100644 --- a/config/s-templ.h +++ b/config/s-templ.h @@ -193,7 +193,7 @@ #define HAS_LOCALE -/* Define HAS_LOCALE if you have the include file <locale.h> and the +/* Define HAS_LOCALE if you have the include file <locale.h> and the setlocale() function. */ #define HAS_MMAP @@ -204,13 +204,13 @@ #define HAS_GETHOSTBYNAME_R 6 /* Define HAS_GETHOSTBYNAME_R if gethostbyname_r() is available. - The value of this symbol is the number of arguments of + The value of this symbol is the number of arguments of gethostbyname_r(): either 5 or 6 depending on prototype. (5 is the Solaris version, 6 is the Linux version). */ #define HAS_GETHOSTBYADDR_R 8 /* Define HAS_GETHOSTBYADDR_R if gethostbyname_r() is available. - The value of this symbol is the number of arguments of + The value of this symbol is the number of arguments of gethostbyaddr_r(): either 7 or 8 depending on prototype. (7 is the Solaris version, 8 is the Linux version). */ diff --git a/debugger/Makefile.nt b/debugger/Makefile.nt index 3630d32e0e..70263e94d8 100644 --- a/debugger/Makefile.nt +++ b/debugger/Makefile.nt @@ -14,4 +14,3 @@ UNIXDIR=../otherlibs/win32unix include Makefile.shared - diff --git a/debugger/Makefile.shared b/debugger/Makefile.shared index 1e16f32ef8..4372cf74c4 100644 --- a/debugger/Makefile.shared +++ b/debugger/Makefile.shared @@ -44,7 +44,7 @@ OTHEROBJS=\ OBJS=\ - dynlink.cmo \ + dynlink.cmo \ int64ops.cmo \ primitives.cmo \ unix_tools.cmo \ diff --git a/debugger/breakpoints.ml b/debugger/breakpoints.ml index 9d85aff04c..1da4b74e26 100644 --- a/debugger/breakpoints.ml +++ b/debugger/breakpoints.ml @@ -123,7 +123,7 @@ let change_version version pos = (function () -> current_version := version; positions := pos) - + (* Execute given function with no breakpoint in current checkpoint. *) (* --- `goto' runs faster this way (does not stop on each breakpoint). *) let execute_without_breakpoints f = diff --git a/debugger/command_line.ml b/debugger/command_line.ml index 2bdd8afaa8..5fdf3da472 100644 --- a/debugger/command_line.ml +++ b/debugger/command_line.ml @@ -77,10 +77,10 @@ let error text = raise Toplevel let check_not_windows feature = - match Sys.os_type with + match Sys.os_type with | "Win32" -> error ("'"^feature^"' feature not supported on Windows") - | _ -> + | _ -> () let eol = @@ -227,7 +227,7 @@ let instr_shell ppf lexbuf = let cmd = String.concat " " cmdarg in (* perhaps we should use $SHELL -c ? *) let err = Sys.command cmd in - if (err != 0) then + if (err != 0) then eprintf "Shell command %S failed with exit code %d\n%!" cmd err let instr_pwd ppf lexbuf = @@ -363,8 +363,8 @@ let print_info_list ppf = let instr_complete ppf lexbuf = let ppf = Format.err_formatter in - let rec print_list l = - try + let rec print_list l = + try eol lexbuf; List.iter (function i -> fprintf ppf "%s@." i) l with _ -> @@ -395,7 +395,7 @@ let instr_complete ppf lexbuf = | [i] -> if i.info_name = ident then [] else [i.info_name] | l -> List.map (fun i -> i.info_name) l end - | None -> + | None -> List.map (fun i -> i.info_name) !info_list end else ["info"] diff --git a/debugger/debugcom.ml b/debugger/debugcom.ml index 307f4258de..5bfbb2bfa8 100644 --- a/debugger/debugcom.ml +++ b/debugger/debugcom.ml @@ -183,7 +183,7 @@ exception Marshalling_error module Remote_value = struct type t = Remote of string | Local of Obj.t - + let obj = function | Local obj -> Obj.obj obj | Remote v -> diff --git a/debugger/debugcom.mli b/debugger/debugcom.mli index 447e45d9e2..6c7a534462 100644 --- a/debugger/debugcom.mli +++ b/debugger/debugcom.mli @@ -83,7 +83,7 @@ exception Marshalling_error module Remote_value : sig type t - + val obj : t -> 'a val is_block : t -> bool val tag : t -> int diff --git a/debugger/debugger_config.ml b/debugger/debugger_config.ml index ee707abb2e..54d6b2d583 100644 --- a/debugger/debugger_config.ml +++ b/debugger/debugger_config.ml @@ -23,7 +23,7 @@ exception Toplevel (*ISO 6429 color sequences 00 to restore default color -01 for brighter colors +01 for brighter colors 04 for underlined text 05 for flashing text 30 for black foreground diff --git a/debugger/debugger_config.mli b/debugger/debugger_config.mli index d3185f0832..18faf9c62f 100644 --- a/debugger/debugger_config.mli +++ b/debugger/debugger_config.mli @@ -33,4 +33,3 @@ val checkpoint_big_step : int64 ref val checkpoint_small_step : int64 ref val checkpoint_max_count : int ref val make_checkpoints : bool ref - diff --git a/debugger/dynlink.ml b/debugger/dynlink.ml index 7d3e347f55..a8b6efa766 100644 --- a/debugger/dynlink.ml +++ b/debugger/dynlink.ml @@ -212,7 +212,7 @@ let loadfile file_name = let toc_pos = input_binary_int ic in (* Go to table of contents *) seek_in ic toc_pos; let lib = (input_value ic : library) in - begin try + begin try Dll.open_dlls Dll.For_execution (List.map Dll.extract_dll_name lib.lib_dllibs) with Failure reason -> diff --git a/debugger/dynlink.mli b/debugger/dynlink.mli index caee291710..7cca68c5a0 100644 --- a/debugger/dynlink.mli +++ b/debugger/dynlink.mli @@ -23,9 +23,9 @@ val is_native: bool val loadfile : string -> unit (** In bytecode: load the given bytecode object file ([.cmo] file) or - bytecode library file ([.cma] file), and link it with the running + bytecode library file ([.cma] file), and link it with the running program. In native code: load the given OCaml plugin file (usually - [.cmxs]), and link it with the running + [.cmxs]), and link it with the running program. All toplevel expressions in the loaded compilation units are evaluated. No facilities are provided to diff --git a/debugger/envaux.ml b/debugger/envaux.ml index 7f74ecbf7f..8d462e2f87 100644 --- a/debugger/envaux.ml +++ b/debugger/envaux.ml @@ -60,7 +60,7 @@ let rec env_from_summary sum subst = let env = env_from_summary s subst in let path' = Subst.module_path subst path in let mty = - try + try Env.find_module path' env with Not_found -> raise (Error (Module_not_found path')) diff --git a/debugger/eval.ml b/debugger/eval.ml index abec4291a5..7ee1339f01 100644 --- a/debugger/eval.ml +++ b/debugger/eval.ml @@ -197,7 +197,7 @@ let report_error ppf = function "@[Cannot extract item number %i from a value of type@ %a@]@." pos Printtyp.type_expr ty | Wrong_label(ty, lbl) -> - fprintf ppf + fprintf ppf "@[The record type@ %a@ has no label named %s@]@." Printtyp.type_expr ty lbl | Not_a_record ty -> diff --git a/debugger/events.mli b/debugger/events.mli index df928de00c..7166f2c9d0 100644 --- a/debugger/events.mli +++ b/debugger/events.mli @@ -27,4 +27,3 @@ val current_event : debug_event option ref val get_current_event : unit -> debug_event val current_event_is_before : unit -> bool - diff --git a/debugger/frames.ml b/debugger/frames.ml index 2dcff988d2..c533782fc4 100644 --- a/debugger/frames.ml +++ b/debugger/frames.ml @@ -75,7 +75,7 @@ let select_frame frame_number = | _ -> set_initial_frame(); selected_event := Some(move_up frame_number curr_event); - current_frame := frame_number + current_frame := frame_number with Not_found -> set_frame initial_sp; raise Not_found diff --git a/debugger/loadprinter.ml b/debugger/loadprinter.ml index 07d7b78aeb..ac5aa0187d 100644 --- a/debugger/loadprinter.ml +++ b/debugger/loadprinter.ml @@ -120,10 +120,10 @@ let find_printer_type lid = with Ctype.Unify _ -> (match_printer_type desc "printer_type_old", true) in (ty_arg, path, is_old_style) - with + with | Not_found -> raise(Error(Unbound_identifier lid)) | Ctype.Unify _ -> raise(Error(Wrong_type lid)) - + let install_printer ppf lid = let (ty_arg, path, is_old_style) = find_printer_type lid in let v = @@ -167,5 +167,3 @@ let report_error ppf = function | No_active_printer lid -> fprintf ppf "@[%a is not currently active as a printing function.@]@." Printtyp.longident lid - - diff --git a/debugger/main.ml b/debugger/main.ml index 8d430c0acf..f836bf9f0e 100644 --- a/debugger/main.ml +++ b/debugger/main.ml @@ -179,9 +179,9 @@ let speclist = [ let main () = try - socket_name := + socket_name := (match Sys.os_type with - "Win32" -> + "Win32" -> (Unix.string_of_inet_addr Unix.inet_addr_loopback)^ ":"^ (string_of_int (10000 + ((Unix.getpid ()) mod 10000))) diff --git a/debugger/parser.mly b/debugger/parser.mly index db365a69ea..6fc8392a86 100644 --- a/debugger/parser.mly +++ b/debugger/parser.mly @@ -187,7 +187,7 @@ opt_longident : | { None }; opt_longident_eol : - opt_longident end_of_line { $1 }; + opt_longident end_of_line { $1 }; identifier : LIDENT { $1 } diff --git a/debugger/parser_aux.mli b/debugger/parser_aux.mli index 434c14dbcf..a68e08d5c8 100644 --- a/debugger/parser_aux.mli +++ b/debugger/parser_aux.mli @@ -31,4 +31,3 @@ type break_arg = | BA_pos1 of Longident.t option * int * int option (* break @ [MODULE] LINE [POS] *) | BA_pos2 of Longident.t option * int (* break @ [MODULE] # OFFSET *) - diff --git a/debugger/pattern_matching.ml b/debugger/pattern_matching.ml index a04dcae5b0..97af9326b5 100644 --- a/debugger/pattern_matching.ml +++ b/debugger/pattern_matching.ml @@ -150,7 +150,7 @@ and match_concrete_type pattern obj cstr ty ty_list = | Variant_type constr_list -> let tag = value_tag obj in (try - let constr = + let constr = if same_type_constr cstr constr_type_exn then find_exception tag else diff --git a/debugger/printval.ml b/debugger/printval.ml index 0e37bad6bb..5f36e1a7cc 100644 --- a/debugger/printval.ml +++ b/debugger/printval.ml @@ -106,4 +106,3 @@ let print_named_value max_depth exp env obj ppf ty = print_value_name exp Printtyp.type_expr ty (print_value max_depth env obj) ty - diff --git a/debugger/printval.mli b/debugger/printval.mli index d100a4333b..bb6318880c 100644 --- a/debugger/printval.mli +++ b/debugger/printval.mli @@ -28,6 +28,6 @@ val reset_named_values : unit -> unit val find_named_value : int -> Debugcom.Remote_value.t * Types.type_expr val install_printer : - Path.t -> Types.type_expr -> formatter -> + Path.t -> Types.type_expr -> formatter -> (formatter -> Obj.t -> unit) -> unit val remove_printer : Path.t -> unit diff --git a/debugger/question.ml b/debugger/question.ml index 8b2d4598b7..2eeec3ab0d 100644 --- a/debugger/question.ml +++ b/debugger/question.ml @@ -33,4 +33,3 @@ let yes_or_no message = raise x else false - diff --git a/emacs/.cvsignore b/emacs/.cvsignore index e7e261fca6..ea6381f91b 100644 --- a/emacs/.cvsignore +++ b/emacs/.cvsignore @@ -1,2 +1 @@ ocamltags - diff --git a/emacs/Makefile b/emacs/Makefile index 4f3aa3784b..9519b396a5 100644 --- a/emacs/Makefile +++ b/emacs/Makefile @@ -30,28 +30,28 @@ SCRIPTDIR = $(BINDIR) # Command for byte-compiling the files COMPILECMD=(progn \ - (setq load-path (cons "." load-path)) \ - (byte-compile-file "caml-xemacs.el") \ + (setq load-path (cons "." load-path)) \ + (byte-compile-file "caml-xemacs.el") \ (byte-compile-file "caml-emacs.el") \ - (byte-compile-file "caml.el") \ - (byte-compile-file "inf-caml.el") \ - (byte-compile-file "caml-help.el") \ - (byte-compile-file "caml-types.el") \ - (byte-compile-file "camldebug.el")) + (byte-compile-file "caml.el") \ + (byte-compile-file "inf-caml.el") \ + (byte-compile-file "caml-help.el") \ + (byte-compile-file "caml-types.el") \ + (byte-compile-file "camldebug.el")) install: @if test "$(EMACSDIR)" = ""; then \ - set xxx `($(EMACS) --batch --eval "(mapcar 'print load-path)") \ - 2>/dev/null | \ - sed -n -e '/\/site-lisp/s/"//gp'`; \ - if test "$$2" = ""; then \ - echo "Cannot determine Emacs site-lisp directory"; \ - exit 2; \ - fi; \ - $(MAKE) EMACSDIR="$$2" simple-install; \ - else \ - $(MAKE) simple-install; \ - fi + set xxx `($(EMACS) --batch --eval "(mapcar 'print load-path)") \ + 2>/dev/null | \ + sed -n -e '/\/site-lisp/s/"//gp'`; \ + if test "$$2" = ""; then \ + echo "Cannot determine Emacs site-lisp directory"; \ + exit 2; \ + fi; \ + $(MAKE) EMACSDIR="$$2" simple-install; \ + else \ + $(MAKE) simple-install; \ + fi # install the .el files, but do not compile them. install-el: diff --git a/emacs/caml-compat.el b/emacs/caml-compat.el index 3a48449b2d..8ba7a99c7e 100644 --- a/emacs/caml-compat.el +++ b/emacs/caml-compat.el @@ -39,4 +39,3 @@ only if necessary. It leaves point at end of indentation." (defalias 'buffer-substring-no-properties 'buffer-substring))) (provide 'caml-compat) - diff --git a/emacs/caml-font-old.el b/emacs/caml-font-old.el index fe5721376c..8faa542f05 100644 --- a/emacs/caml-font-old.el +++ b/emacs/caml-font-old.el @@ -114,7 +114,7 @@ ((fboundp 'global-font-lock-mode) (make-local-variable 'font-lock-defaults) (setq font-lock-defaults - '(caml-font-lock-keywords nil nil ((?' . "w") (?_ . "w"))))) + '(caml-font-lock-keywords nil nil ((?' . "w") (?_ . "w"))))) (t (setq font-lock-keywords caml-font-lock-keywords))) (make-local-variable 'font-lock-keywords-only) diff --git a/emacs/caml-font.el b/emacs/caml-font.el index e796abdcb7..f287ffa045 100644 --- a/emacs/caml-font.el +++ b/emacs/caml-font.el @@ -1,6 +1,6 @@ ;; caml-font: font-lock support for OCaml files ;; -;; rewrite and clean-up. +;; rewrite and clean-up. ;; Changes: ;; - fontify strings and comments using syntactic font lock ;; - define a `font-lock-syntactic-face-function' to fontify ocamldoc comments @@ -31,7 +31,7 @@ (unless (facep 'font-lock-preprocessor-face) (defvar font-lock-preprocessor-face - (copy-face 'font-lock-builtin-face + (copy-face 'font-lock-builtin-face 'font-lock-preprocessor-face))) (defconst caml-font-lock-keywords @@ -92,7 +92,7 @@ (defun caml-font-set-font-lock () (setq font-lock-defaults '(caml-font-lock-keywords - nil nil nil nil + nil nil nil nil (font-lock-syntactic-face-function . caml-font-syntactic-face))) (font-lock-mode 1)) (add-hook 'caml-mode-hook 'caml-font-set-font-lock) @@ -106,7 +106,7 @@ (defun inferior-caml-set-font-lock () (setq font-lock-defaults '(inferior-caml-font-lock-keywords - nil nil nil nil + nil nil nil nil (font-lock-syntactic-face-function . caml-font-syntactic-face))) (font-lock-mode 1)) (add-hook 'inferior-caml-mode-hooks 'inferior-caml-set-font-lock) diff --git a/emacs/caml-help.el b/emacs/caml-help.el index 92735acac2..e6517185a9 100644 --- a/emacs/caml-help.el +++ b/emacs/caml-help.el @@ -27,27 +27,27 @@ ;; - dump some databaes: Info, Lib, ... ;; - accept a search path for local libraries instead of current dir ;; (then distinguish between different modules lying in different -;; directories) +;; directories) ;; - improve the construction for info files. ;; -;; Abstract over +;; Abstract over ;; - the viewing method and the database, so that the documentation for -;; and identifier could be search in +;; and identifier could be search in ;; * info / html / man / mli's sources ;; * viewed in emacs or using an external previewer. ;; ;; Take all identifiers (labels, Constructors, exceptions, etc.) -;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (eval-and-compile - (if (and (boundp 'running-xemacs) running-xemacs) + (if (and (boundp 'running-xemacs) running-xemacs) (require 'caml-xemacs) (require 'caml-emacs))) ;; Loading or building databases. -;; +;; ;; variables to be customized @@ -73,7 +73,7 @@ "ocamlc -where"))))) ocaml-lib-path) - + ;; General purpose auxiliary functions @@ -92,17 +92,17 @@ (if (stringp path) (if (file-directory-p path) path nil) (mapconcat '(lambda (d) (if (file-directory-p d) d)) - path " "))) + path " "))) (command (and path-string (concat "find " path-string " '(' " filter " ')' " (if depth (concat " -maxdepth " (int-to-string depth))) - (if split nil " -printf '%\p '") + (if split nil " -printf '%\p '") ))) (files (and command (shell-command-to-string command)))) - (if (and split (stringp files)) (split-string files "\n") files) + (if (and split (stringp files)) (split-string files "\n") files) )) ;; Specialized auxiliary functions @@ -111,7 +111,7 @@ ;; Global table of modules contents of modules loaded lazily. (defvar ocaml-module-alist 'lazy - "A-list of modules with how and where to find help information. + "A-list of modules with how and where to find help information. 'delay means non computed yet") (defun ocaml-add-mli-modules (modules tag &optional path) @@ -209,7 +209,7 @@ alist) )) -;; Local list of visible modules. +;; Local list of visible modules. (defvar ocaml-visible-modules 'lazy "A-list of open modules, local to every file.") @@ -249,8 +249,8 @@ When call interactively, make completion over known modules." (message "%S" (mapcar 'car (ocaml-visible-modules)))) (defun ocaml-close-module (arg) - "*Close module of name ARG when ARG is a string. -When call interactively, make completion over visible modules. + "*Close module of name ARG when ARG is a string. +When call interactively, make completion over visible modules. Otherwise if ARG is true, close all modules and reset to default. " (interactive "P") (if (= (prefix-numeric-value arg) 4) @@ -268,27 +268,27 @@ Otherwise if ARG is true, close all modules and reset to default. " ocaml-visible-modules)) )) (message "%S" (mapcar 'car (ocaml-visible-modules)))) - + ;; Look for identifiers around point (defun ocaml-qualified-identifier (&optional show) - "Search for a qualified identifier (Path. entry) around point. + "Search for a qualified identifier (Path. entry) around point. Entry may be nil. -Currently, the path may only be nil or a single Module. -For paths is of the form Module.Path', it returns Module -and always nil for entry. +Currently, the path may only be nil or a single Module. +For paths is of the form Module.Path', it returns Module +and always nil for entry. -If defined Module and Entry are represented by a region in the buffer, -and are nil otherwise. +If defined Module and Entry are represented by a region in the buffer, +and are nil otherwise. -For debugging purposes, it returns the string Module.entry if called -with an optional non-nil argument. +For debugging purposes, it returns the string Module.entry if called +with an optional non-nil argument. " (save-excursion (let ((module) (entry)) - (if (looking-at "[ \n]") (skip-chars-backward " ")) + (if (looking-at "[ \n]") (skip-chars-backward " ")) (if (re-search-backward "\\([^A-Za-z0-9_.']\\|\\`\\)\\([A-Za-z0-9_']*[.]\\)*[A-Za-z0-9_']*\\=" (- (point) 100) t) @@ -314,7 +314,7 @@ with an optional non-nil argument. (let ((list (or (and module - (list + (list (or (assoc module (ocaml-module-alist)) (error "Unknown module %s" module)))) (ocaml-visible-modules)))) @@ -333,19 +333,19 @@ with an optional non-nil argument. ))) (defun caml-complete (arg) - "Does completion for OCaml identifiers qualified. + "Does completion for OCaml identifiers qualified. -It attemps to recognize an qualified identifier Module . entry +It attemps to recognize an qualified identifier Module . entry around point using function \\[ocaml-qualified-identifier]. If Module is defined, it does completion for identifier in Module. -If Module is undefined, it does completion in visible modules. -Then, if completion fails, it does completion among all modules +If Module is undefined, it does completion in visible modules. +Then, if completion fails, it does completion among all modules where identifier is defined." (interactive "p") (let* ((module-entry (ocaml-qualified-identifier)) (entry) - (module) + (module) (beg) (end) (pattern)) (if (car module-entry) (progn @@ -364,7 +364,7 @@ where identifier is defined." (progn (setq entry (cdr module-entry)) t)) (error "Unknown module %s" module)))) (if (consp (cdr module-entry)) - (progn + (progn (setq beg (cadr module-entry)) (setq end (cddr module-entry))) (if (and module @@ -408,7 +408,7 @@ where identifier is defined." (delete-region (caar module-entry) end) (delete-region beg end)) (insert module "." pattern)))) - + ((not (string-equal pattern completion)) (delete-region beg end) (goto-char beg) @@ -426,10 +426,10 @@ where identifier is defined." (defvar ocaml-info-prefix "ocaml-lib" "Prefix of ocaml info files describing library modules. -Suffix .info will be added to info files. +Suffix .info will be added to info files. Additional suffix .gz may be added if info files are compressed. ") -;; +;; (defun ocaml-hevea-info-add-entries (entries dir name) (let* @@ -470,9 +470,9 @@ Additional suffix .gz may be added if info files are compressed. entries)) (defun ocaml-hevea-info () - "The default way to create an info data base from the value -of \\[Info-default-directory-list] and the base name \\[ocaml-info-name] -of files to look for. + "The default way to create an info data base from the value +of \\[Info-default-directory-list] and the base name \\[ocaml-info-name] +of files to look for. This uses info files produced by HeVeA. " @@ -512,8 +512,8 @@ This uses info files produced by HeVeA. entries)) (defun ocaml-ocamldoc-info () - "The default way to create an info data base from the value -of \\[Info-default-directory-list] and the base name \\[ocaml-info-name] + "The default way to create an info data base from the value +of \\[Info-default-directory-list] and the base name \\[ocaml-info-name] of files to look for. This uses info files produced by ocamldoc." @@ -531,18 +531,18 @@ This uses info files produced by ocamldoc." ;; Continuing (defvar ocaml-info-alist 'ocaml-ocamldoc-info - "A-list binding module names to info entries: + "A-list binding module names to info entries: nil means do not use info. A function to build the list lazily (at the first call). The result of the function call will be assign permanently to this variable for future uses. We provide two default functions \\[ocaml-info-default-function] -(info produced by HeVeA is the default) and \\[ocaml-info-default-function] -(info produced by ocamldoc). +(info produced by HeVeA is the default) and \\[ocaml-info-default-function] +(info produced by ocamldoc). Otherwise, this value should be an alist binding module names to info -entries of the form to \"(entry)section\" be taken by the \\[info] +entries of the form to \"(entry)section\" be taken by the \\[info] command. An entry may be an info module or a complete file name." ) @@ -571,7 +571,7 @@ command. An entry may be an info module or a complete file name." (defun ocaml-buffer-substring (region) (and region (buffer-substring-no-properties (car region) (cdr region)))) -;; Help function. +;; Help function. (defun ocaml-goto-help (&optional module entry same-window) @@ -588,7 +588,7 @@ current buffer using \\[ocaml-qualified-identifier]." (or (assoc module (ocaml-module-alist)) (and (file-exists-p (concat (ocaml-uncapitalize module) ".mli")) - (ocaml-get-or-make-module module)))) + (ocaml-get-or-make-module module)))) (location (cdr (cadr module-info)))) (cond (location @@ -630,27 +630,28 @@ current buffer using \\[ocaml-qualified-identifier]." )) (defun caml-help (arg) - "Find documentation for OCaml qualified identifiers. + "Find documentation for OCaml qualified identifiers. It attemps to recognize an qualified identifier of the form ``Module . entry'' around point using function `ocaml-qualified-identifier'. If Module is undetermined it is temptatively guessed from the identifier name -and according to visible modules. If this is still unsucessful, the user is -then prompted for a Module name. +and according to visible modules. If this is still unsucessful, the user is +then prompted for a Module name. The documentation for Module is first seach in the info manual if available, -then in the ``module.mli'' source file. The entry is then searched in the documentation. +then in the ``module.mli'' source file. The entry is then searched in the +documentation. -Visible modules are computed only once, at the first call. +Visible modules are computed only once, at the first call. Modules can be made visible explicitly with `ocaml-open-module' and -hidden with `ocaml-close-module'. +hidden with `ocaml-close-module'. Prefix arg 0 forces recompilation of visible modules (and their content) -from the file content. +from the file content. Prefix arg 4 prompts for Module and identifier instead of guessing values -from the possition of point in the current buffer. +from the possition of point in the current buffer. " (interactive "p") (let ((module) (entry) (module-entry)) @@ -709,7 +710,7 @@ from the possition of point in the current buffer. (defvar ocaml-links nil "Local links in the current of last info node or interface file. -The car of the list is a key that indentifies the module to prevent +The car of the list is a key that indentifies the module to prevent recompilation when next help command is relative to the same module. The cdr is a list of elments, each of which is an string and a pair of buffer positions." @@ -717,7 +718,7 @@ buffer positions." (make-variable-buffer-local 'ocaml-links) (defun ocaml-info-links (section) - (cdr + (cdr (if (and ocaml-links section (equal (car ocaml-links) section)) ocaml-links (save-excursion @@ -793,19 +794,19 @@ buffer positions." (put-text-property (match-beginning 1) (match-end 1) 'face 'ocaml-link-face))) ) - ;; need to restore flag if buffer was unmodified. + ;; need to restore flag if buffer was unmodified. (unless modified-p (set-buffer-modified-p nil)) )) )))) - + ;; bindings ---now in caml.el ; (and ; (boundp 'caml-mode-map) ; (keymapp caml-mode-map) -; (progn +; (progn ; (define-key caml-mode-map [?\C-c?i] 'ocaml-add-path) ; (define-key caml-mode-map [?\C-c?]] 'ocaml-close-module) ; (define-key caml-mode-map [?\C-c?[] 'ocaml-open-module) @@ -822,7 +823,7 @@ buffer positions." ; (define-key map [open] '("Open module for help" . ocaml-open-module)) ; (define-key map [help] '("Help for identifier" . caml-help)) ; (define-key map [complete] '("Complete identifier" . caml-complete)) -; ) +; ) ; )))) diff --git a/emacs/inf-caml.el b/emacs/inf-caml.el index a213ee4f5c..f2291f90fd 100644 --- a/emacs/inf-caml.el +++ b/emacs/inf-caml.el @@ -80,7 +80,7 @@ be sent from another buffer in Caml mode. (defconst inferior-caml-buffer-name (concat "*" inferior-caml-buffer-subname "*")) -;; for compatibility with xemacs +;; for compatibility with xemacs (defun caml-sit-for (second &optional mili redisplay) (if (and (boundp 'running-xemacs) running-xemacs) @@ -170,7 +170,7 @@ Input and output via buffer `*inferior-caml*'." ) ) -;; patched by Didier to move cursor after evaluation +;; patched by Didier to move cursor after evaluation (defun inferior-caml-eval-region (start end) "Send the current region to the inferior Caml process." @@ -231,15 +231,15 @@ output can be retreived later, asynchronously.") (defun inferior-caml-eval-phrase (arg &optional min max) "Send the phrase containing the point to the CAML process. -With prefix-arg send as many phrases as its numeric value, +With prefix-arg send as many phrases as its numeric value, If an error occurs during evalutaion, stop at this phrase and -repport the error. +repport the error. Return nil if noerror and position of error if any. If arg's numeric value is zero or negative, evaluate the current phrase -or as many as prefix arg, ignoring evaluation errors. -This allows to jump other erroneous phrases. +or as many as prefix arg, ignoring evaluation errors. +This allows to jump other erroneous phrases. Optional arguments min max defines a region within which the phrase should lies." @@ -327,12 +327,12 @@ should lies." (progn (move-overlay caml-error-overlay beg end (current-buffer)) (beep) (if wait (read-event) (caml-sit-for 60))) - (delete-overlay caml-error-overlay))))) + (delete-overlay caml-error-overlay))))) ;; wait some amount for ouput, that is, until inferior-caml-output is set ;; to true. Hence, interleaves sitting for shorts delays and checking the -;; flag. Give up after some time. Typing into the source buffer will cancel -;; waiting, i.e. may report 'No result yet' +;; flag. Give up after some time. Typing into the source buffer will cancel +;; waiting, i.e. may report 'No result yet' (defun caml-wait-output (&optional before after) (let ((c 1)) @@ -351,11 +351,11 @@ should lies." caml-previous-output (- pos 2)))) ;; additional bindings - + ;(let ((map (lookup-key caml-mode-map [menu-bar caml]))) ; (define-key map [indent-buffer] '("Indent buffer" . caml-indent-buffer)) ; (define-key map [eval-buffer] '("Eval buffer" . caml-eval-buffer)) -;) +;) ;(define-key caml-mode-map "\C-c\C-b" 'caml-eval-buffer) diff --git a/lex/compact.ml b/lex/compact.ml index 9475ab6e57..abbf5a5036 100644 --- a/lex/compact.ml +++ b/lex/compact.ml @@ -169,7 +169,7 @@ type lex_tables = tbl_backtrk_code : int array; (* nothing / code when Remember *) (* moves to execute before transitions (compacted) *) tbl_default_code : int array; - tbl_trans_code : int array; + tbl_trans_code : int array; tbl_check_code : int array; (* byte code itself *) tbl_code: int array;} @@ -200,7 +200,7 @@ let compact_tables state_v = base_code.(i) <- b_moves; default_code.(i) <- d_moves ; done; let code = Table.trim code in - let tables = + let tables = if Array.length code > 1 then { tbl_base = base; tbl_backtrk = backtrk; @@ -229,6 +229,3 @@ let compact_tables state_v = reset_compact trans ; reset_compact moves ; tables - - - diff --git a/lex/compact.mli b/lex/compact.mli index e52dc7d2c8..18363c3d4d 100644 --- a/lex/compact.mli +++ b/lex/compact.mli @@ -24,7 +24,7 @@ type lex_tables = tbl_backtrk_code : int array; (* nothing / code when Remember *) (* moves to execute before transitions (compacted) *) tbl_default_code : int array; - tbl_trans_code : int array; + tbl_trans_code : int array; tbl_check_code : int array; (* byte code itself *) tbl_code: int array;} diff --git a/lex/cset.ml b/lex/cset.ml index ec68ee1c8b..c4594540ec 100644 --- a/lex/cset.ml +++ b/lex/cset.ml @@ -95,5 +95,3 @@ let env_to_array env = match env with c) rem ; res - - diff --git a/lex/cset.mli b/lex/cset.mli index fc2c9930c3..3160cc908b 100644 --- a/lex/cset.mli +++ b/lex/cset.mli @@ -15,7 +15,7 @@ (* Set of characters encoded as list of intervals *) -type t +type t exception Bad val empty : t @@ -32,6 +32,3 @@ val inter : t -> t -> t val diff : t -> t -> t val complement : t -> t val env_to_array : (t * 'a) list -> 'a array - - - diff --git a/lex/lexgen.ml b/lex/lexgen.ml index 1a12f0d49d..775e78b056 100644 --- a/lex/lexgen.ml +++ b/lex/lexgen.ml @@ -37,7 +37,7 @@ type regexp = | Star of regexp type tag_base = Start | End | Mem of int -type tag_addr = Sum of (tag_base * int) +type tag_addr = Sum of (tag_base * int) type ident_info = | Ident_string of bool * tag_addr * tag_addr | Ident_char of bool * tag_addr @@ -298,7 +298,7 @@ let rec encode_regexp char_vars act = function (* Optimisation, Static optimization : Replace tags by offsets relative to the beginning - or end of matched string. + or end of matched string. Dynamic optimization: Replace some non-optional, non-double tags by offsets w.r.t a previous similar tag. @@ -448,7 +448,7 @@ let opt_regexp all_vars char_vars optional_vars double_vars r = let a = get_tag_addr (n.id,n.start) in r,Some a end - + | Empty -> r,pos | Chars (_,is_eof) -> r,(if is_eof then pos else add_pos pos 1) | Seq (r1,r2) -> @@ -465,10 +465,10 @@ let opt_regexp all_vars char_vars optional_vars double_vars r = | Action _ -> assert false in let r,_ = alloc_exp None r in - let m = + let m = IdSet.fold (fun ((name,_) as x) r -> - + let v = if IdSet.mem x char_vars then Ident_char @@ -482,8 +482,8 @@ let opt_regexp all_vars char_vars optional_vars double_vars r = all_vars [] in m,r, !loc_count - - + + let encode_casedef casedef = let r = List.fold_left @@ -520,7 +520,7 @@ let encode_lexdef def = (chr, entry_list) (* To generate directly a NFA from a regular expression. - Confer Aho-Sethi-Ullman, dragon book, chap. 3 + Confer Aho-Sethi-Ullman, dragon book, chap. 3 Extension to tagged automata. Confer Ville Larikari @@ -533,7 +533,7 @@ let encode_lexdef def = *) type t_transition = - OnChars of int + OnChars of int | ToAction of int type transition = t_transition * Tags.t @@ -608,7 +608,7 @@ let followpos size entry_list = fill (TransSet.union (firstpos r) s) r in List.iter (fun (entry,_,_) -> fill TransSet.empty entry.lex_regexp) entry_list ; v - + (************************) (* The algorithm itself *) (************************) @@ -654,7 +654,7 @@ let dstate {final=(act,(_,m)) ; others=o} = (fun () -> prerr_endline "") o - + let dfa_state_empty = {final=(no_action, (max_int,TagMap.empty)) ; others=MemMap.empty} @@ -663,7 +663,7 @@ and dfa_state_is_empty {final=(act,_) ; others=o} = act = no_action && o = MemMap.empty - + (* A key is an abstraction on a dfa state, two states with the same key can be made the same by copying some memory cells into others *) @@ -688,14 +688,14 @@ type dfa_key = {kstate : StateSet.t ; kmem : MemKey.t} (* Map a state to its key *) let env_to_class m = - let env1 = + let env1 = MemMap.fold (fun _ (tag,s) r -> try let ss = TagMap.find tag r in let r = TagMap.remove tag r in TagMap.add tag (StateSetSet.add s ss) r - with + with | Not_found -> TagMap.add tag (StateSetSet.add s StateSetSet.empty) r) m TagMap.empty in @@ -739,23 +739,23 @@ let key_compare k1 k2 = match StateSet.compare k1.kstate k2.kstate with | r -> r (* Association dfa_state -> state_num *) - + module StateMap = Map.Make(struct type t = dfa_key let compare = key_compare end) let state_map = ref (StateMap.empty : int StateMap.t) -let todo = Stack.create() +let todo = Stack.create() let next_state_num = ref 0 let next_mem_cell = ref 0 let temp_pending = ref false -let tag_cells = Hashtbl.create 17 +let tag_cells = Hashtbl.create 17 let state_table = Table.create dfa_state_empty (* Initial reset of state *) let reset_state () = Stack.clear todo; - next_state_num := 0 ; + next_state_num := 0 ; let _ = Table.trim state_table in () @@ -878,14 +878,14 @@ let get_map t st = match t with m let dest = function | Copy (d,_) | Set d -> d -and orig = function | Copy (_,o) -> o | Set _ -> -1 +and orig = function | Copy (_,o) -> o | Set _ -> -1 let pmv oc mv = fprintf oc "%d <- %d" (dest mv) (orig mv) let pmvs oc mvs = List.iter (fun mv -> fprintf oc "%a " pmv mv) mvs ; output_char oc '\n' ; flush oc - + (* Topological sort << a la louche >> *) let sort_mvs mvs = let rec do_rec r mvs = match mvs with @@ -917,7 +917,7 @@ let sort_mvs mvs = end | _ -> do_rec (here@r) rem in do_rec [] mvs - + let move_to mem_key src tgt = let mvs = MemKey.fold @@ -943,7 +943,7 @@ let move_to mem_key src tgt = sort_mvs mvs -let get_state st = +let get_state st = let key = get_key st in try let num = StateMap.find key !state_map in @@ -992,7 +992,7 @@ let add_tags_to_map gen tags m = let apply_transition gen r pri m = function | ToAction n,tags -> let on,(opri,_) = r.final in - if n < on || (on=n && pri < opri) then + if n < on || (on=n && pri < opri) then let m = add_tags_to_map gen tags m in {r with final=n,(pri,m)} else r @@ -1000,7 +1000,7 @@ let apply_transition gen r pri m = function try let (opri,_) = MemMap.find n r.others in if pri < opri then - let m = add_tags_to_map gen tags m in + let m = add_tags_to_map gen tags m in {r with others=MemMap.add n (pri,m) (MemMap.remove n r.others)} else r @@ -1018,7 +1018,7 @@ let apply_transitions gen r pri m ts = ts r -(* For a given nfa_state pos, refine char partition *) +(* For a given nfa_state pos, refine char partition *) let rec split_env gen follow pos m s = function | [] -> (* Can occur ! because of non-matching regexp ([^'\000'-'\255']) *) [] @@ -1033,20 +1033,20 @@ let rec split_env gen follow pos m s = function rem else split_env gen follow pos m rest rem - and new_st = apply_transitions gen st1 pos m follow in + and new_st = apply_transitions gen st1 pos m follow in let stay = Cset.diff s1 here in if Cset.is_empty stay then (here, new_st)::rem else (stay, st1)::(here, new_st)::rem - + (* For all nfa_state pos in a dfa state st *) let comp_shift gen chars follow st = MemMap.fold (fun pos (_,m) env -> split_env gen follow.(pos) pos m chars.(pos) env) st [Cset.all_chars_eof,dfa_state_empty] - + let reachs chars follow st = let gen = create_new_addr_gen () in @@ -1058,7 +1058,7 @@ let reachs chars follow st = (fun (s,dfa_state) -> s,goto_state dfa_state) env in (* finally build the char indexed array -> new state num *) let shift = Cset.env_to_array env in - shift + shift let get_tag_mem n env t = @@ -1082,8 +1082,8 @@ let do_tag_actions n env m = used,r) env.(n) (used,r) in r - - + + let translate_state shortest_match tags chars follow st = let (n,(_,m)) = st.final in if MemMap.empty = st.others then @@ -1106,7 +1106,7 @@ let dtags chan tags = Tags.iter (fun t -> fprintf chan " %a" dtag t) tags - + let dtransset s = TransSet.iter (fun trans -> match trans with @@ -1169,7 +1169,7 @@ let make_dfa lexdef = map_on_all_states (translate_state shortest tags chars follow) !r_states ; { auto_name = le.lex_name; - auto_args = args ; + auto_args = args ; auto_mem_size = (if !temp_pending then !next_mem_cell+1 else !next_mem_cell) ; auto_initial_state = init_num ; diff --git a/lex/lexgen.mli b/lex/lexgen.mli index 5c9c1bc757..5136f8f283 100644 --- a/lex/lexgen.mli +++ b/lex/lexgen.mli @@ -14,7 +14,7 @@ (* raised when there are too many bindings (>= 254 memory cells) *) -exception Memory_overflow +exception Memory_overflow (* Representation of automata *) @@ -39,7 +39,7 @@ type ident = string * Syntax.location (* Representation of entry points *) type tag_base = Start | End | Mem of int -type tag_addr = Sum of (tag_base * int) +type tag_addr = Sum of (tag_base * int) type ident_info = | Ident_string of bool * tag_addr * tag_addr | Ident_char of bool * tag_addr @@ -58,4 +58,3 @@ type ('args,'action) automata_entry = val make_dfa : ('args, 'action) Syntax.entry list -> ('args, 'action) automata_entry list * automata array - diff --git a/lex/main.ml b/lex/main.ml index 280537ca1b..5540c97285 100644 --- a/lex/main.ml +++ b/lex/main.ml @@ -36,7 +36,7 @@ let specs = "-q", Arg.Set Common.quiet_mode, " Do not display informational messages"; "-v", Arg.Unit print_version_string, " Print version and exit"; "-version", Arg.Unit print_version_string, " Print version and exit"; - ] + ] let _ = Arg.parse @@ -44,11 +44,11 @@ let _ = (fun name -> source_name := Some name) usage - + let main () = let source_name = match !source_name with - | None -> Arg.usage specs usage ; exit 2 + | None -> Arg.usage specs usage ; exit 2 | Some name -> name in let dest_name = match !output_name with | Some name -> name @@ -105,7 +105,7 @@ let main () = | Lexgen.Memory_overflow -> Printf.fprintf stderr "File \"%s\":\n Position memory overflow, too many bindings\n" - source_name + source_name | Output.Table_overflow -> Printf.fprintf stderr "File \"%s\":\ntransition table overflow, automaton is too big\n" @@ -116,4 +116,3 @@ let main () = exit 3 let _ = (* Printexc.catch *) main (); exit 0 - diff --git a/lex/table.mli b/lex/table.mli index e5d55f9652..b88d7d3454 100644 --- a/lex/table.mli +++ b/lex/table.mli @@ -13,7 +13,7 @@ (* Table used for code emission, ie extensible arrays *) type 'a t -val create : 'a -> 'a t +val create : 'a -> 'a t val emit : 'a t -> 'a -> unit @@ -29,5 +29,3 @@ val get : 'a t -> int -> 'a val size : 'a t -> int - - diff --git a/man/ocaml.help b/man/ocaml.help deleted file mode 100644 index 466896dcc7..0000000000 --- a/man/ocaml.help +++ /dev/null @@ -1,138 +0,0 @@ -- -OCaml # Objective Caml toplevel -Usage: ocaml <options> -options are: - -I <dir> Add <dir> to the list of include directories - -unsafe No bound checking on array and string access - -drawlambda (undocumented) - -dlambda (undocumented) - -dinstr (undocumented) - -rectypes (undocumented) - -- -OCamlc # Objective Caml compiler -Usage: ocamlc <options> <files> -Options are: - -a Build a library - -c Compile only (do not link) - -cc <comp> Use <comp> as the C compiler and linker - -cclib <opt> Pass option <opt> to the C linker - -ccopt <opt> Pass option <opt> to the C compiler and linker - -g Save debugging information - -i Print the types - -I <dir> Add <dir> to the list of include directories - -impl <file> Compile <file> as a .ml file - -intf <file> Compile <file> as a .mli file - -intf-suffix <file> Suffix for interface file (default: .mli) - -intf_suffix <file> (deprecated) same as -intf-suffix - -linkall Link all modules, even unused ones - -make-runtime Build a runtime system with given C objects and libraries - -make_runtime (deprecated) same as -make-runtime - -noassert Do not compile assertion checks - -o <file> Set output file name to <file> - -output-obj Output a C object file instead of an executable - -pp <command> Pipe sources through preprocessor <command> - -thread Use thread-safe standard library - -unsafe No bounds checking on array and string access - -use-runtime <path> Generate bytecode for the given runtime system - -use_runtime <path> (deprecated) same as -use-runtime - -v Print compiler version number - -verbose Print calls to external commands - -w <flags> Enable or disable warnings according to <flags>: - A/a enable/disable all warnings - C/c enable/disable suspicious comment - F/f enable/disable partially applied function - M/m enable/disable overriden method - P/p enable/disable partial match - S/s enable/disable non-unit statement - U/u enable/disable unused match case - V/v enable/disable hidden instance variable - X/x enable/disable all other warnings - default setting is A (all warnings enabled) - -nopervasives (undocumented) - -dparsetree (undocumented) - -drawlambda (undocumented) - -dlambda (undocumented) - -dinstr (undocumented) - -use-prims <file> (undocumented) - -rectypes (undocumented) - - <file> Treat <file> as a file name (even if it starts with `-') - -- -OCamlc-custom # Objective Caml compiler for custom runtime mode -Usage: ocamlc-custom <options> <files> -Options are: - -a Build a library - -c Compile only (do not link) - -cc <comp> Use <comp> as the C compiler and linker - -cclib <opt> Pass option <opt> to the C linker - -ccopt <opt> Pass option <opt> to the C compiler and linker - -g Save debugging information - -i Print the types - -I <dir> Add <dir> to the list of include directories - -impl <file> Compile <file> as a .ml file - -intf <file> Compile <file> as a .mli file - -intf-suffix <file> Suffix for interface file (default: .mli) - -intf_suffix <file> (deprecated) same as -intf-suffix - -linkall Link all modules, even unused ones - -make-runtime Build a runtime system with given C objects and libraries - -make_runtime (deprecated) same as -make-runtime - -noassert Do not compile assertion checks - -o <file> Set output file name to <file> - -output-obj Output a C object file instead of an executable - -pp <command> Pipe sources through preprocessor <command> - -thread Use thread-safe standard library - -unsafe No bounds checking on array and string access - -use-runtime <path> Generate bytecode for the given runtime system - -use_runtime <path> (deprecated) same as -use-runtime - -v Print compiler version number - -verbose Print calls to external commands - -w <flags> Enable or disable warnings according to <flags>: - A/a enable/disable all warnings - C/c enable/disable suspicious comment - F/f enable/disable partially applied function - M/m enable/disable overriden method - P/p enable/disable partial match - S/s enable/disable non-unit statement - U/u enable/disable unused match case - V/v enable/disable hidden instance variable - X/x enable/disable all other warnings - default setting is A (all warnings enabled) - -nopervasives (undocumented) - -dparsetree (undocumented) - -drawlambda (undocumented) - -dlambda (undocumented) - -dinstr (undocumented) - -use-prims <file> (undocumented) - -rectypes (undocumented) - - <file> Treat <file> as a file name (even if it starts with `-') - -- -OCamlDep # Objective Caml dependency generator -Usage: ocamldep [-I <dir>] <files> - -I <dir> Add <dir> to the list of include directories - -- -OCamlLex # Objective Caml lexer generator -OCamlLex name.mll - -- -OCamlRun # Objective Caml bytecode interpreter -OCamlRun [-v] file [argumentsÉ] - -v # print GC messages - -Environment variable: -Set -e OCamlRunParam "<option>=<value>,É" - h # initial size of the major heap - i # minimum size increment for the major heap - l # maximum stack size - o # major GC speed setting - O # heap compaction trigger setting - s # size of the minor heap - v # verbosity flags for GC messages - -- -OCamlYacc # Objective Caml parser generator -OCamlYacc [-v] [-b string] file.mly - -v # put verbose report in file.output - -b string # name output files string.ml and string.mli diff --git a/ocamlbuild/command.mli b/ocamlbuild/command.mli index 48e7fdc277..337762ba80 100644 --- a/ocamlbuild/command.mli +++ b/ocamlbuild/command.mli @@ -42,4 +42,3 @@ val deps_of_tags : Tags.t -> pathname list (** [dep tags deps] Will build [deps] when [tags] will be activated. *) val dep : Tags.elt list -> pathname list -> unit - diff --git a/ocamlbuild/display.ml b/ocamlbuild/display.ml index 8178afece1..2385a58f70 100644 --- a/ocamlbuild/display.ml +++ b/ocamlbuild/display.ml @@ -140,7 +140,7 @@ let create ds_last_cached = false; ds_changed = false; ds_update_interval = default_update_interval; - ds_columns = n; + ds_columns = n; ds_jobs = 0; ds_jobs_cached = 0; ds_tagline = create_tagline description; @@ -196,7 +196,7 @@ HH MM SS XXXX PATHNAME | | \ number of jobs cached | \ number of jobs \ elapsed time -cmo mllib +cmo mllib ***) (*** redraw_sophisticated *) let redraw_sophisticated ds = diff --git a/ocamlbuild/glob.ml b/ocamlbuild/glob.ml index 6ecffedc4f..7cb6127feb 100644 --- a/ocamlbuild/glob.ml +++ b/ocamlbuild/glob.ml @@ -149,7 +149,7 @@ module NFA = else q' :: future' end - graph.(q) + graph.(q) future in transitive past' future' diff --git a/ocamlbuild/glob_lexer.mll b/ocamlbuild/glob_lexer.mll index 99c30168d4..05d199d6f1 100644 --- a/ocamlbuild/glob_lexer.mll +++ b/ocamlbuild/glob_lexer.mll @@ -60,7 +60,7 @@ rule token = parse and parse_pattern eof_chars p = parse | (pattern_chars+ as u) { parse_pattern eof_chars (concat_patterns p (Word u)) lexbuf } -| '{' +| '{' { let rec loop pl = let (p',c) = parse_pattern ['}';','] Epsilon lexbuf in @@ -77,7 +77,7 @@ and parse_pattern eof_chars p = parse let cl = Not(Or(parse_class [] lexbuf)) in parse_pattern eof_chars (concat_patterns p (Class cl)) lexbuf } -| '[' +| '[' { let cl = Or(parse_class [] lexbuf) in parse_pattern eof_chars (concat_patterns p (Class cl)) lexbuf @@ -97,7 +97,7 @@ and parse_pattern eof_chars p = parse | '/' { parse_pattern eof_chars (concat_patterns p slash) lexbuf } | '?' { parse_pattern eof_chars (concat_patterns p not_slash) lexbuf } | _ as c - { if List.mem c eof_chars then + { if List.mem c eof_chars then (p,c) else raise (Parse_error(sf "Unexpected character %C in glob pattern" c)) diff --git a/ocamlbuild/hygiene.ml b/ocamlbuild/hygiene.ml index f6101e915c..e904afb44d 100644 --- a/ocamlbuild/hygiene.ml +++ b/ocamlbuild/hygiene.ml @@ -148,7 +148,7 @@ let check ?sanitize laws entry = @ A@ script@ shell@ file@ %S@ is@ being@ created.\ @ Check@ this@ script@ and@ run@ it@ to@ remove@ unwanted@ files\ @ or@ use@ other@ options@ (such@ as@ defining@ hygiene@ exceptions\ - @ or@ using@ the@ -no-hygiene@ option).@]" + @ or@ using@ the@ -no-hygiene@ option).@]" m (if m = 1 then "" else "s") fn; let oc = open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o755 fn in let fp = Printf.fprintf in diff --git a/ocamlbuild/man/ocamlbuild.1 b/ocamlbuild/man/ocamlbuild.1 index 9077fdf00b..58a33740b7 100644 --- a/ocamlbuild/man/ocamlbuild.1 +++ b/ocamlbuild/man/ocamlbuild.1 @@ -91,7 +91,7 @@ HTML documentation generated with .SH OPTIONS -The following command-line options are recognized by +The following command-line options are recognized by .BR ocamlbuild (1). .TP diff --git a/ocamlbuild/manual/manual.tex b/ocamlbuild/manual/manual.tex index 1827e336ae..62d900450f 100644 --- a/ocamlbuild/manual/manual.tex +++ b/ocamlbuild/manual/manual.tex @@ -40,7 +40,7 @@ libraries, package (-pack) debugging and profiling flags, C stubs. OCaml itself. \item Automatic inference of dependencies. \item Correct handling of dynamically discovered dependencies. -\item Object files and other temporary files are created in a specific directory, leaving your main directory uncluttered. +\item Object files and other temporary files are created in a specific directory, leaving your main directory uncluttered. \item Sanity checks ensure that object files are where they are supposed to be: in the build directory. \item Regular projects are built using a single command with no extra files. \item Parallel compilation to speed up things on multi-core systems. @@ -109,7 +109,7 @@ complex projects with arbitrary dependencies and actions. Your code is in the \texttt{\_build} directory, but \ocb automatically creates a symbolic link to the executables it produces in the current directory. \ocb copies the source files and compiles them in a separate directory -which is \texttt{\_build} by default. +which is \texttt{\_build} by default. For \ocb, any file that is not in the build directory is a source file. It is not unreasonable to think that some users may have bought binary object files @@ -143,7 +143,7 @@ by \ocb to denote native code executables. \begin{verbatim} % ls hello.ml -% ocamlbuild hello.native +% ocamlbuild hello.native Finished, 4 targets (0 cached) in 00:00:00. % ls -l total 12 @@ -156,7 +156,7 @@ of compiling. You usually won't have to look very often into this directory. S into \texttt{\_build} and this is where the compilers will be run. Various cache files are also stored there. Its contents may look like this: \begin{verbatim} -% ls -l _build +% ls -l _build total 208 -rw-rw---- 1 linus gallium 337 2007-01-17 16:24 _digests -rw-rw---- 1 linus gallium 191 2007-01-17 16:24 hello.cmi @@ -179,7 +179,7 @@ ocamlbuild hello.native -- Caesar and it will compile and then run \texttt{hello.native} with the arguments following \texttt{-{}-}, which should display: \begin{verbatim} -% ocamlbuild hello.native -- Caesar +% ocamlbuild hello.native -- Caesar Finished, 4 targets (0 cached) in 00:00:00. Hello, Caesar ! My name is _build/hello.native \end{verbatim} @@ -514,7 +514,7 @@ $\texttt{-}$ and $\texttt{.}$. This is called the pathname alphabet $P$. %***) %(*** Subdirectories \subsection{Subdirectories} -If the files of your project are held in one or more subdirectories, +If the files of your project are held in one or more subdirectories, \ocb must be made aware of that fact using the \texttt{-I} or \texttt{-Is} options or by adding an \texttt{include} tag. For instance, assume your project is made of three subdirectories, \texttt{foo}, \texttt{bar} and \texttt{baz} containing @@ -610,7 +610,7 @@ library. Just write a file with the \texttt{mltop} extension (like You can specify preprocessor options with \texttt{-pp} followed by the preprocessor string, for instance \texttt{ocamlbuild -pp "camlp4o.opt -unsafe"} would run your sources thru CamlP4 with the \texttt{-unsafe} option. -Another way is to use the tags file. +Another way is to use the tags file. \begin{center} \begin{tabular}{|l|l|l|} \hline @@ -631,47 +631,47 @@ Another way is to use the tags file. \end{tabular} \end{center} -%%%%% \subsubsection{An example, dealing with some configuration variables} -%%%%% +%%%%% \subsubsection{An example, dealing with some configuration variables} +%%%%% %%%%% It's quite common to have in your sources some files that you want to access %%%%% when your program is running. One often uses some variables that are setup by %%%%% the end user. Now suppose that there is only two files that use these variables %%%%% (mylib.ml and parseopt.ml). -%%%%% +%%%%% %%%%% In the \tags file: %%%%% \begin{verbatim} %%%%% "mylib.ml" or "parseopt.ml": pp(sed -e "s,LIBDIR,/usr/local/lib/FOO,g") %%%%% \end{verbatim} -%%%%% +%%%%% %%%%% In fact that solution is not really acceptable, since the variable is hardcoded %%%%% in the \tags file. Trying to workaround this issue by using some shell variable %%%%% does not work either since the -pp argument will be escaped in simple quotes. %%%%% Note also that using some script shell that will do that sed and use \verb'$LIBDIR' %%%%% as a shell variable is not a good idea since \ocb don't know this dependency on that %%%%% shell script. -%%%%% +%%%%% %%%%% There is in fact at least two good solutions. The first is to tell that dependency %%%%% using the \texttt{dep} function in your plugin. The second is simpler it just consist %%%%% on generating some OCaml file at configure time. By naming this configuration file %%%%% \texttt{myocamlbuild_config.ml} \ocb will make it also available to your plugin. -%%%%% +%%%%% %%%%% In your \texttt{myocamlbuild_config.mli} interface: %%%%% \begin{verbotim} %%%%% val prefix : string %%%%% val libdir : string %%%%% \end{verbotim} -%%%%% -%%%%% And in your \texttt{configure} script +%%%%% +%%%%% And in your \texttt{configure} script %%%%% \begin{verbatim} %%%%% #!/bin/sh -%%%%% +%%%%% %%%%% # Setting defaults values %%%%% PREFIX=/usr/local %%%%% LIBDIR=$PREFIX/lib/FOO %%%%% CONF=myocamlbuild_config.ml -%%%%% +%%%%% %%%%% # ... some shell to parse option and check configuration ... -%%%%% +%%%%% %%%%% # Dumping the configuration as an OCaml file. %%%%% rm -f $CONF %%%%% echo "let prefix = \"$PREFIX\";;" >> $CONF @@ -751,21 +751,21 @@ the tags \texttt{ocaml}, \texttt{native}, \texttt{byte}, \texttt{program}, \textbf{Tag} & \textbf{Display character} \\ \hline \hline - ocaml & O \\ + ocaml & O \\ \hline - native & N \\ + native & N \\ \hline - byte & B \\ + byte & B \\ \hline - program & P \\ + program & P \\ \hline - pp & R \\ + pp & R \\ \hline - debug & D \\ + debug & D \\ \hline - interf & I \\ + interf & I \\ \hline - link & L \\ + link & L \\ \hline \end{tabular} \end{center} @@ -837,7 +837,7 @@ The second one is as a dispatcher for various actions defined using phony targets with shell script actions. These actions include cleaning, cleaning really well, archiving, uploading and so on. Their characteristic is that they rely little or not on the building process -- they either need -the building to have been completed, or they don't need anything. +the building to have been completed, or they don't need anything. As \texttt{/bin/sh} scripts have been here for three to four decades and are not going anywhere, why not replace that functionality of makefiles with a shell script ? We have thought of three bad reasons: diff --git a/ocamlbuild/misc/opentracer.ml b/ocamlbuild/misc/opentracer.ml index b011f1540b..38a13502bd 100644 --- a/ocamlbuild/misc/opentracer.ml +++ b/ocamlbuild/misc/opentracer.ml @@ -60,7 +60,7 @@ module Driver (T : TRACER) = struct let main () = let log = "opentracer.log" in let oc = - if sys_file_exists log then + if sys_file_exists log then open_out_gen [Open_wronly;Open_append;Open_text] 0 log else let oc = open_out log in diff --git a/ocamlbuild/my_std.ml b/ocamlbuild/my_std.ml index b5abd1186c..78286b53c8 100644 --- a/ocamlbuild/my_std.ml +++ b/ocamlbuild/my_std.ml @@ -35,7 +35,7 @@ module Outcome = struct | Bad exn -> raise exn let wrap f x = - try Good (f x) with e -> Bad e + try Good (f x) with e -> Bad e end @@ -137,7 +137,7 @@ module String = struct let before s pos = sub s 0 pos let after s pos = sub s pos (length s - pos) - let first_chars s n = sub s 0 n + let first_chars s n = sub s 0 n let last_chars s n = sub s (length s - n) n let rec eq_sub_strings s1 p1 s2 p2 len = @@ -260,7 +260,7 @@ let filename_concat x y = if x.[String.length x - 1] = '/' then if y = "" then x else x ^ y - else x ^ "/" ^ y + else x ^ "/" ^ y (* let reslash = match Sys.os_type with diff --git a/ocamlbuild/my_unix.ml b/ocamlbuild/my_unix.ml index 306031a270..a54f05bf23 100644 --- a/ocamlbuild/my_unix.ml +++ b/ocamlbuild/my_unix.ml @@ -93,7 +93,7 @@ and is_link x = and lstat x = if is_link x then { stat_key = x; stat_file_kind = FK_link } else stat x - + let implem = { is_degraded = true; @@ -134,7 +134,6 @@ let run_and_read cmd = if len > 0 then begin Buffer.add_substring totalbuf buf 0 len; loop (pos + len) - end + end in loop 0; Buffer.contents totalbuf end - diff --git a/ocamlbuild/ocaml_dependencies.ml b/ocamlbuild/ocaml_dependencies.ml index 666b1842b9..c6c8efeb93 100644 --- a/ocamlbuild/ocaml_dependencies.ml +++ b/ocamlbuild/ocaml_dependencies.ml @@ -211,7 +211,7 @@ module Make (I : INPUT) = struct end (dependencies_of fn); needed := fn :: !needed end - in + in List.iter aux fns; mydprintf "caml_transitive_closure:@ %a ->@ %a" pp_l fns pp_l !needed; List.rev !needed diff --git a/ocamlbuild/ocaml_tools.ml b/ocamlbuild/ocaml_tools.ml index 74a27a87b5..1791992182 100644 --- a/ocamlbuild/ocaml_tools.ml +++ b/ocamlbuild/ocaml_tools.ml @@ -28,8 +28,8 @@ let ocamldep_command' tags spec = let menhir_ocamldep_command' tags ~menhir_spec ~ocamldep_spec out = let menhir = if !Options.ocamlyacc = N then V"MENHIR" else !Options.ocamlyacc in Cmd(S[menhir; T tags; A"--raw-depend"; - A"--ocamldep"; Quote (ocamldep_command' tags ocamldep_spec); - menhir_spec ; Sh ">"; Px out]) + A"--ocamldep"; Quote (ocamldep_command' tags ocamldep_spec); + menhir_spec ; Sh ">"; Px out]) let menhir_ocamldep_command arg out env _build = let arg = env arg and out = env out in diff --git a/ocamlbuild/ocaml_utils.ml b/ocamlbuild/ocaml_utils.ml index bbfe60e315..449328ce66 100644 --- a/ocamlbuild/ocaml_utils.ml +++ b/ocamlbuild/ocaml_utils.ml @@ -144,7 +144,7 @@ let read_path_dependencies = let deps = List.fold_right begin fun (path, deps) acc -> let module_name' = module_name_of_pathname path in - if module_name' = module_name + if module_name' = module_name then List.union deps acc else raise (Ocamldep_error(Printf.sprintf "Ocamldep.ocamldep: multiple files in ocamldep output (%s not expected)" path)) end ocamldep_output [] in diff --git a/ocamlbuild/ocaml_utils.mli b/ocamlbuild/ocaml_utils.mli index 09329bdd3c..660e27b9b3 100644 --- a/ocamlbuild/ocaml_utils.mli +++ b/ocamlbuild/ocaml_utils.mli @@ -41,4 +41,3 @@ val ocaml_lib : ?dir:Pathname.t -> ?tag_name:string -> Pathname.t -> unit - diff --git a/ocamlbuild/ocamlbuild.mli b/ocamlbuild/ocamlbuild.mli index 3f466934e1..7e5aa0bf45 100644 --- a/ocamlbuild/ocamlbuild.mli +++ b/ocamlbuild/ocamlbuild.mli @@ -12,4 +12,3 @@ (* Original author: Nicolas Pouillard *) (** Nothing to export for now *) - diff --git a/ocamlbuild/ocamlbuild_executor.ml b/ocamlbuild/ocamlbuild_executor.ml index 587f4210e5..9798e052dd 100644 --- a/ocamlbuild/ocamlbuild_executor.ml +++ b/ocamlbuild/ocamlbuild_executor.ml @@ -95,7 +95,7 @@ let execute let jobs_to_terminate = Queue.create () in let commands_to_execute = Queue.create () in let all_ok = ref true in - let results = + let results = List.map (fun tasks -> let result = ref false in Queue.add (tasks, result) commands_to_execute; @@ -174,7 +174,7 @@ let execute if not job.job_dying then begin job.job_dying <- true; - Queue.add (job, continue) jobs_to_terminate + Queue.add (job, continue) jobs_to_terminate end else () @@ -203,7 +203,7 @@ let execute | Unix.Unix_error(_,_,_) -> 0 in if m = 0 then - if job.job_dying then + if job.job_dying then () else terminate job @@ -321,7 +321,7 @@ let execute begin fun _ _job -> (*display (fun oc -> fp oc "Exceptional condition on command %S\n%!" job.job_command); exit Exceptional_condition*) - () (* FIXME *) + () (* FIXME *) end]; loop () end diff --git a/ocamlbuild/options.ml b/ocamlbuild/options.ml index 11839c61fd..2d095b1608 100644 --- a/ocamlbuild/options.ml +++ b/ocamlbuild/options.ml @@ -132,8 +132,8 @@ let spec = "-documentation", Set show_documentation, " Show rules and flags"; "-log", Set_string log_file_internal, "<file> Set log file"; "-no-log", Unit (fun () -> log_file_internal := ""), " No log file"; - "-clean", Set must_clean, " Remove build directory and other files, then exit"; - "-r", Set recursive, " Traverse directories by default (true: traverse)"; + "-clean", Set must_clean, " Remove build directory and other files, then exit"; + "-r", Set recursive, " Traverse directories by default (true: traverse)"; "-I", String (add_to' my_include_dirs), "<path> Add to include directories"; "-Is", String (add_to my_include_dirs), "<path,...> (same as above, but accepts a (comma or blank)-separated list)"; diff --git a/ocamlbuild/pathname.ml b/ocamlbuild/pathname.ml index 7ec8f24cf3..d535488d61 100644 --- a/ocamlbuild/pathname.ml +++ b/ocamlbuild/pathname.ml @@ -156,4 +156,3 @@ let define_context dir context = Hashtbl.replace context_table dir& List.union context& include_dirs_of dir let same_contents x y = Digest.file x = Digest.file y - diff --git a/ocamlbuild/resource.ml b/ocamlbuild/resource.ml index e0bb74ba80..ed90d1cff6 100644 --- a/ocamlbuild/resource.ml +++ b/ocamlbuild/resource.ml @@ -292,41 +292,41 @@ let import x = Pathname.normalize x module MetaPath : sig type t - type env + type env val mk : (bool * string) -> t - val matchit : t -> string -> env option - val subst : env -> t -> string - val print_env : Format.formatter -> env -> unit + val matchit : t -> string -> env option + val subst : env -> t -> string + val print_env : Format.formatter -> env -> unit end = struct open Glob_ast - type atoms = A of string | V of string * Glob.globber - type t = atoms list - type env = (string * string) list + type atoms = A of string | V of string * Glob.globber + type t = atoms list + type env = (string * string) list - exception No_solution + exception No_solution - let mk (pattern_allowed, s) = List.map begin function + let mk (pattern_allowed, s) = List.map begin function | `Var(var_name, globber) -> V(var_name, globber) | `Word s -> A s end (Lexers.path_scheme pattern_allowed (Lexing.from_string s)) let mk = memo mk - let match_prefix s pos prefix = - match String.contains_string s pos prefix with - | Some(pos') -> if pos = pos' then pos' + String.length prefix else raise No_solution - | None -> raise No_solution - - let matchit p s = - let sl = String.length s in - let rec loop xs pos acc delta = - match xs with - | [] -> if pos = sl then acc else raise No_solution - | A prefix :: xs -> loop xs (match_prefix s pos prefix) acc 0 - | V(var, patt) :: A s2 :: xs' -> + let match_prefix s pos prefix = + match String.contains_string s pos prefix with + | Some(pos') -> if pos = pos' then pos' + String.length prefix else raise No_solution + | None -> raise No_solution + + let matchit p s = + let sl = String.length s in + let rec loop xs pos acc delta = + match xs with + | [] -> if pos = sl then acc else raise No_solution + | A prefix :: xs -> loop xs (match_prefix s pos prefix) acc 0 + | V(var, patt) :: A s2 :: xs' -> begin match String.contains_string s (pos + delta) s2 with | Some(pos') -> let matched = String.sub s pos (pos' - pos) in @@ -337,13 +337,13 @@ end = struct else loop xs pos acc (pos' - pos + 1) | None -> raise No_solution end - | [V(var, patt)] -> + | [V(var, patt)] -> let matched = String.sub s pos (sl - pos) in if Glob.eval patt matched then (var, matched) :: acc else raise No_solution - | V _ :: _ -> assert false - in - try Some (loop p 0 [] 0) - with No_solution -> None + | V _ :: _ -> assert false + in + try Some (loop p 0 [] 0) + with No_solution -> None let pp_opt pp_elt f = function @@ -371,14 +371,14 @@ end = struct exit 42 end;; *) - let subst env s = - String.concat "" begin - List.map begin fun x -> - match x with - | A atom -> atom - | V(var, _) -> List.assoc var env - end s - end + let subst env s = + String.concat "" begin + List.map begin fun x -> + match x with + | A atom -> atom + | V(var, _) -> List.assoc var env + end s + end end type env = MetaPath.env diff --git a/ocamlbuild/rule.ml b/ocamlbuild/rule.ml index ac0f0c8bda..8352f6ae53 100644 --- a/ocamlbuild/rule.ml +++ b/ocamlbuild/rule.ml @@ -306,4 +306,3 @@ let copy_rule name ?insert src dest = Shell.mkdir_p (Pathname.dirname dest); cp_p src dest end - diff --git a/ocamlbuild/signatures.mli b/ocamlbuild/signatures.mli index 40923b699c..cddc0f5887 100644 --- a/ocamlbuild/signatures.mli +++ b/ocamlbuild/signatures.mli @@ -251,7 +251,7 @@ module type GLOB = sig A basic expression can be a constant string enclosed in double quotes, in which double quotes must be preceded by backslashes, or a glob pattern enclosed between a [<] and a [>], - ["]{i string}["] matches the literal string {i string}, - - [<]{i glob}[>] matches the glob pattern {i glob}. + - [<]{i glob}[>] matches the glob pattern {i glob}. A glob pattern is an anchored regular expression in a shell-like syntax. Most characters stand for themselves. Character ranges are given in usual shell syntax between brackets. The star [*] stands for any sequence of @@ -540,7 +540,7 @@ module type PLUGIN = sig val flag_and_dep : Tags.elt list -> Command.spec -> unit (** [non_dependency module_path module_name] - Example: + Example: [non_dependency "foo/bar/baz" "Goo"] Says that the module [Baz] in the file [foo/bar/baz.*] does not depend on [Goo]. *) val non_dependency : Pathname.t -> string -> unit @@ -556,7 +556,7 @@ module type PLUGIN = sig At link time it will include: foo/bar.cma or foo/bar.cmxa If you supply the ~dir:"boo" option -I boo - will be added at link and compile time. + will be added at link and compile time. Use ~extern:true for non-ocamlbuild handled libraries. Use ~byte:false or ~native:false to disable byte or native mode. Use ~tag_name:"usebar" to override the default tag name. *) @@ -627,7 +627,7 @@ module type PLUGIN = sig (** Here is the list of hooks that the dispatch function have to handle. Generally one respond to one or two hooks (like After_rules) and do nothing in the default case. *) - type hook = + type hook = | Before_hygiene | After_hygiene | Before_options diff --git a/ocamlbuild/slurp.ml b/ocamlbuild/slurp.ml index 896628db17..ac653c85a7 100644 --- a/ocamlbuild/slurp.ml +++ b/ocamlbuild/slurp.ml @@ -42,7 +42,7 @@ let real_slurp path = let abs x = if Filename.is_implicit x || Filename.is_relative x then cwd/x else x in let visited = Hashtbl.create 1024 in let rec scandir path names = - let (file_acc, dir_acc) = + let (file_acc, dir_acc) = Array.fold_left begin fun ((file_acc, dir_acc) as acc) name -> match do_entry true path name with | None -> acc diff --git a/ocamlbuild/tools.ml b/ocamlbuild/tools.ml index 587c2c7595..69a011b542 100644 --- a/ocamlbuild/tools.ml +++ b/ocamlbuild/tools.ml @@ -25,7 +25,7 @@ let pp_l = List.print String.print let tags_of_pathname p = Configuration.tags_of_filename (Pathname.to_string p) ++("file:"^p) - ++("extension:"^Pathname.get_extension p) + ++("extension:"^Pathname.get_extension p) let flags_of_pathname p = Configuration.flags_of_filename (Pathname.to_string p) let opt_print elt ppf = @@ -44,4 +44,3 @@ let path_and_context_of_string s = let include_dirs = Pathname.include_dirs_of d in List.map (fun include_dir -> include_dir/b) include_dirs else [s] - diff --git a/ocamldoc/Makefile.nt b/ocamldoc/Makefile.nt index caba5769ba..8130fe40e0 100644 --- a/ocamldoc/Makefile.nt +++ b/ocamldoc/Makefile.nt @@ -31,15 +31,15 @@ CP=cp OCAMLDOC=ocamldoc OCAMLDOC_RUN=$(CAMLRUN) $(OCAMLDOC) OCAMLDOC_OPT=$(OCAMLDOC).opt -OCAMLDOC_LIBCMA=odoc_info.cma +OCAMLDOC_LIBCMA=odoc_info.cma OCAMLDOC_LIBCMI=odoc_info.cmi -OCAMLDOC_LIBCMXA=odoc_info.cmxa +OCAMLDOC_LIBCMXA=odoc_info.cmxa OCAMLDOC_LIBA=odoc_info.$(A) INSTALL_LIBDIR=$(OCAMLLIB)/ocamldoc INSTALL_CUSTOMDIR=$(INSTALL_LIBDIR)/custom INSTALL_BINDIR=$(OCAMLBIN) -INSTALL_MLIS=odoc_info.mli +INSTALL_MLIS=odoc_info.mli INSTALL_CMIS=$(INSTALL_MLIS:.mli=.cmi) # Compilation @@ -257,7 +257,7 @@ clean:: dummy @rm -f $(OCAMLDOC) $(OCAMLDOC_OPT) *.cma *.cmxa *.cmo *.cmi *.cmx *.$(A) *.$(O) @rm -f odoc_parser.output odoc_text_parser.output @rm -f odoc_lexer.ml odoc_text_lexer.ml odoc_see_lexer.ml odoc_ocamlhtml.ml - @rm -f odoc_parser.ml odoc_parser.mli odoc_text_parser.ml odoc_text_parser.mli + @rm -f odoc_parser.ml odoc_parser.mli odoc_text_parser.ml odoc_text_parser.mli depend:: rm -f .depend diff --git a/ocamldoc/ocamldoc.sty b/ocamldoc/ocamldoc.sty index e01658b03a..6a8ef1e959 100644 --- a/ocamldoc/ocamldoc.sty +++ b/ocamldoc/ocamldoc.sty @@ -11,7 +11,7 @@ \rightskip\z@skip \parindent\z@ \parfillskip\@flushglue - \parskip\z@skip + \parskip\z@skip %\noindent \@@par\smallskip \@tempswafalse @@ -56,5 +56,3 @@ \let\ocamldocvspace\vspace \endinput - - diff --git a/ocamldoc/odoc.ml b/ocamldoc/odoc.ml index 44bf366e62..5ecf70515c 100644 --- a/ocamldoc/odoc.ml +++ b/ocamldoc/odoc.ml @@ -53,14 +53,14 @@ let get_real_filename name = ( let paths = Filename.current_dir_name :: paths @ [Odoc_config.custom_generators_path] in try - let d = List.find - (fun d -> Sys.file_exists (Filename.concat d name)) - paths - in - Filename.concat d name + let d = List.find + (fun d -> Sys.file_exists (Filename.concat d name)) + paths + in + Filename.concat d name with - Not_found -> - failwith (M.file_not_found_in_paths paths name) + Not_found -> + failwith (M.file_not_found_in_paths paths name) ) let _ = diff --git a/ocamldoc/odoc_analyse.mli b/ocamldoc/odoc_analyse.mli index 636a040460..e9be5ba5b7 100644 --- a/ocamldoc/odoc_analyse.mli +++ b/ocamldoc/odoc_analyse.mli @@ -14,19 +14,18 @@ (** Analysis of source files. *) (** This function builds the top modules from the analysis of the - given list of source files. + given list of source files. @param init is the list of modules already known from a previous analysis. *) -val analyse_files : - ?init: Odoc_module.t_module list -> - Odoc_args.source_file list -> +val analyse_files : + ?init: Odoc_module.t_module list -> + Odoc_args.source_file list -> Odoc_module.t_module list -(** Dump of a list of modules into a file. +(** Dump of a list of modules into a file. @raise Failure if an error occurs.*) val dump_modules : string -> Odoc_module.t_module list -> unit - -(** Load of a list of modules from a file. + +(** Load of a list of modules from a file. @raise Failure if an error occurs.*) val load_modules : string -> Odoc_module.t_module list - diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml index 57143d0d55..242ac9c7c3 100644 --- a/ocamldoc/odoc_ast.ml +++ b/ocamldoc/odoc_ast.ml @@ -846,7 +846,7 @@ module Analyser = | Typedtree.Tmod_constraint (m_exp, _, _) -> tt_name_from_module_expr m_exp | Typedtree.Tmod_structure _ | Typedtree.Tmod_functor _ - | Typedtree.Tmod_apply _ + | Typedtree.Tmod_apply _ | Typedtree.Tmod_unpack _ -> Odoc_messages.struct_end diff --git a/ocamldoc/odoc_ast.mli b/ocamldoc/odoc_ast.mli index 666fa1973e..48ba98bfb3 100644 --- a/ocamldoc/odoc_ast.mli +++ b/ocamldoc/odoc_ast.mli @@ -42,7 +42,7 @@ module Typedtree_search : val search_exception : tab -> string -> Types.exception_declaration (** This function returns the [Path.t] associated to the given exception rebind name, - in the table. + in the table. @raise Not_found if the exception rebind was not found.*) val search_exception_rebind : tab -> string -> Path.t @@ -51,7 +51,7 @@ module Typedtree_search : @raise Not_found if the type was not found. *) val search_type_declaration : tab -> string -> Types.type_declaration - (** This function returns the [Typedtree.class_expr] and type parameters + (** This function returns the [Typedtree.class_expr] and type parameters associated to the given class name, in the given table. @raise Not_found if the class was not found. *) val search_class_exp : tab -> string -> (Typedtree.class_expr * (Types.type_expr list)) @@ -61,23 +61,23 @@ module Typedtree_search : @raise Not_found if the class type was not found. *) val search_class_type_declaration : tab -> string -> Types.cltype_declaration - (** This function returns the couple (pat, exp) for the given value name, in the + (** This function returns the couple (pat, exp) for the given value name, in the given table of values. @raise Not found if no value matches the name.*) val search_value : tab_values -> string -> Typedtree.pattern * Typedtree.expression - (** This function returns the [type_expr] for the given primitive name, in the + (** This function returns the [type_expr] for the given primitive name, in the given table. @raise Not found if no value matches the name.*) val search_primitive : tab -> string -> Types.type_expr - (** This function returns the [Typedtree.class_expr] associated to - the n'th inherit in the given class structure of typed tree. + (** This function returns the [Typedtree.class_expr] associated to + the n'th inherit in the given class structure of typed tree. @raise Not_found if the class expression could not be found.*) val get_nth_inherit_class_expr : Typedtree.class_structure -> int -> Typedtree.class_expr - (** This function returns the [Types.type_expr] of the attribute + (** This function returns the [Types.type_expr] of the attribute whose name is given, in a given class structure. @raise Not_found if the class attribute could not be found.*) val search_attribute_type : @@ -88,15 +88,15 @@ module Typedtree_search : val search_method_expression : Typedtree.class_structure -> string -> Typedtree.expression end - -(** The module which performs the analysis of a typed tree. + +(** The module which performs the analysis of a typed tree. The module uses the module {!Odoc_sig.Analyser}. @param My_ir The module used to retrieve comments and special comments.*) module Analyser : functor (My_ir : Odoc_sig.Info_retriever) -> sig - (** This function takes a file name, a file containg the code and - the typed tree obtained from the compiler. + (** This function takes a file name, a file containg the code and + the typed tree obtained from the compiler. It goes through the tree, creating values for encountered functions, modules, ..., and looking in the source file for comments.*) val analyse_typed_tree : diff --git a/ocamldoc/odoc_class.ml b/ocamldoc/odoc_class.ml index 803aa0ba98..676d0ebc37 100644 --- a/ocamldoc/odoc_class.ml +++ b/ocamldoc/odoc_class.ml @@ -22,7 +22,7 @@ type class_element = | Class_comment of Odoc_types.text (** Used when we can reference t_class or t_class_type. *) -type cct = +type cct = Cl of t_class | Cltype of t_class_type * Types.type_expr list (** class type and type parameters *) @@ -30,20 +30,20 @@ and inherited_class = { ic_name : Name.t ; (** Complete name of the inherited class *) mutable ic_class : cct option ; (** The associated t_class or t_class_type *) ic_text : Odoc_types.text option ; (** The inheritance comment, if any *) - } + } and class_apply = { capp_name : Name.t ; (** The complete name of the applied class *) mutable capp_class : t_class option; (** The associated t_class if we found it *) capp_params : Types.type_expr list; (** The type of expressions the class is applied to *) capp_params_code : string list ; (** The code of these expressions *) - } + } and class_constr = { cco_name : Name.t ; (** The complete name of the applied class *) mutable cco_class : cct option; (** The associated class ot class type if we found it *) cco_type_parameters : Types.type_expr list; (** The type parameters of the class, if needed *) - } + } and class_kind = @@ -52,7 +52,7 @@ and class_kind = | Class_apply of class_apply (** application/alias of a class, used in implementation only *) | Class_constr of class_constr (** a class used to give the type of the defined class, instead of a structure, used in interface only. - For example, it will be used with the name "M1.M2....tutu" + For example, it will be used with the name "M1.M2....tutu" when the class to is defined like this : class toto : int -> tutu *) | Class_constraint of class_kind * class_type_kind @@ -68,28 +68,28 @@ and t_class = { mutable cl_kind : class_kind ; mutable cl_parameters : Odoc_parameter.parameter list ; mutable cl_loc : Odoc_types.location ; - } + } and class_type_alias = { cta_name : Name.t ; mutable cta_class : cct option ; (** we can have a t_class or a t_class_type *) cta_type_parameters : Types.type_expr list ; (** the type parameters *) - } + } -and class_type_kind = +and class_type_kind = Class_signature of inherited_class list * class_element list | Class_type of class_type_alias (** a class type eventually applied to type args *) (** Representation of a class type. *) and t_class_type = { - clt_name : Name.t ; + clt_name : Name.t ; mutable clt_info : Odoc_types.info option ; (** The optional associated user information *) clt_type : Types.class_type ; clt_type_parameters : Types.type_expr list ; (** type parameters *) clt_virtual : bool ; (** true = virtual *) mutable clt_kind : class_type_kind ; mutable clt_loc : Odoc_types.location ; - } + } (** {2 Functions} *) @@ -108,8 +108,8 @@ let class_parameter_text_by_name cl label = None (** Returns the list of elements of a t_class. *) -let rec class_elements ?(trans=true) cl = - let rec iter_kind k = +let rec class_elements ?(trans=true) cl = + let rec iter_kind k = match k with Class_structure (_, elements) -> elements | Class_constraint (c_kind, ct_kind) -> @@ -117,7 +117,7 @@ let rec class_elements ?(trans=true) cl = (* A VOIR : utiliser le c_kind ou le ct_kind ? Pour l'instant, comme le ct_kind n'est pas analysé, on cherche dans le c_kind - class_type_elements ~trans: trans + class_type_elements ~trans: trans { clt_name = "" ; clt_info = None ; clt_type_parameters = [] ; clt_virtual = false ; @@ -137,10 +137,10 @@ let rec class_elements ?(trans=true) cl = | _ -> [] ) in - iter_kind cl.cl_kind - + iter_kind cl.cl_kind + (** Returns the list of elements of a t_class_type. *) -and class_type_elements ?(trans=true) clt = +and class_type_elements ?(trans=true) clt = match clt.clt_kind with Class_signature (_, elements) -> elements | Class_type { cta_class = Some (Cltype (ct, _)) } when trans -> @@ -192,8 +192,8 @@ let class_comments ?(trans=true) cl = (** Update the parameters text of a t_class, according to the cl_info field. *) let class_update_parameters_text cl = - let f p = - Odoc_parameter.update_parameter_text (class_parameter_text_by_name cl) p + let f p = + Odoc_parameter.update_parameter_text (class_parameter_text_by_name cl) p in List.iter f cl.cl_parameters @@ -249,5 +249,5 @@ let class_type_parameter_text_by_name clt label = Not_found -> None - + (* eof $Id$ *) diff --git a/ocamldoc/odoc_comments_global.ml b/ocamldoc/odoc_comments_global.ml index 6e18fd295d..86663d58c7 100644 --- a/ocamldoc/odoc_comments_global.ml +++ b/ocamldoc/odoc_comments_global.ml @@ -43,6 +43,6 @@ let init () = params := []; raised_exceptions := []; return_value := None ; - customs := [] + customs := [] (* eof $Id$ *) diff --git a/ocamldoc/odoc_control.ml b/ocamldoc/odoc_control.ml index 705bf4ad3c..b73796bf8a 100644 --- a/ocamldoc/odoc_control.ml +++ b/ocamldoc/odoc_control.ml @@ -10,4 +10,3 @@ (***********************************************************************) (* $Id$ *) - diff --git a/ocamldoc/odoc_dag2html.mli b/ocamldoc/odoc_dag2html.mli index 0f21e745d2..d377bce2ee 100644 --- a/ocamldoc/odoc_dag2html.mli +++ b/ocamldoc/odoc_dag2html.mli @@ -11,7 +11,7 @@ (* $Id$ *) -(** The types and functions to create a html table representing a dag. +(** The types and functions to create a html table representing a dag. Thanks to Daniel de Rauglaudre. *) type 'a dag = { mutable dag : 'a node array } @@ -24,8 +24,6 @@ val html_of_dag : string dag -> string (** This function takes a list of classes and a list of class types and creates the associate dag. *) val create_class_dag : - Odoc_info.Class.t_class list -> - Odoc_info.Class.t_class_type list -> + Odoc_info.Class.t_class list -> + Odoc_info.Class.t_class_type list -> (Odoc_info.Name.t * Odoc_info.Class.cct option) dag - - diff --git a/ocamldoc/odoc_dep.ml b/ocamldoc/odoc_dep.ml index c7ff69346d..86a0f247c9 100644 --- a/ocamldoc/odoc_dep.ml +++ b/ocamldoc/odoc_dep.ml @@ -33,12 +33,12 @@ let intf_dependencies ast = set_to_list !Depend.free_structure_names -module Dep = +module Dep = struct type id = string module S = Set.Make (struct type t = string let compare = compare end) - + let set_to_list s = let l = ref [] in S.iter (fun e -> l := e :: !l) s; @@ -48,7 +48,7 @@ module Dep = id : id ; mutable near : S.t ; (** fils directs *) mutable far : (id * S.t) list ; (** fils indirects, par quel fils *) - reflex : bool ; (** reflexive or not, we keep + reflex : bool ; (** reflexive or not, we keep information here to remove the node itself from its direct children *) } @@ -58,17 +58,17 @@ module Dep = let set = List.fold_right S.add children - S.empty + S.empty in - { id = s; + { id = s; near = S.remove s set ; far = [] ; reflex = List.mem s children ; } - let get_node graph s = + let get_node graph s = try List.find (fun n -> n.id = s) graph - with Not_found -> + with Not_found -> make_node s [] let rec trans_closure graph acc n = @@ -81,10 +81,10 @@ module Dep = trans_closure graph acc2 (get_node graph child)) n.near (S.add n.id acc) - + let node_trans_closure graph n = let far = List.map - (fun child -> + (fun child -> let set = trans_closure graph S.empty (get_node graph child) in (child, set) ) @@ -118,8 +118,8 @@ module Dep = () ) node.near; - if node.reflex then - node.near <- S.add node.id node.near + if node.reflex then + node.near <- S.add node.id node.near else () @@ -140,9 +140,9 @@ let type_deps t = let module T = Odoc_type in let l = ref [] in let re = Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)" in - let f s = + let f s = let s2 = Str.matched_string s in - l := s2 :: !l ; + l := s2 :: !l ; s2 in (match t.T.ty_kind with @@ -150,8 +150,8 @@ let type_deps t = | T.Type_variant cl -> List.iter (fun c -> - List.iter - (fun e -> + List.iter + (fun e -> let s = Odoc_print.string_of_type_expr e in ignore (Str.global_substitute re f s) ) @@ -184,10 +184,10 @@ let kernel_deps_of_modules modules = modules in let k = Dep.kernel graph in - List.iter + List.iter (fun m -> let node = Dep.get_node k m.Module.m_name in - m.Module.m_top_deps <- + m.Module.m_top_deps <- List.filter (fun m2 -> Dep.S.mem m2 node.Dep.near) m.Module.m_top_deps) modules diff --git a/ocamldoc/odoc_env.ml b/ocamldoc/odoc_env.ml index afc24e6257..a108cf416a 100644 --- a/ocamldoc/odoc_env.ml +++ b/ocamldoc/odoc_env.ml @@ -28,22 +28,22 @@ type env = { env_modules : env_element list ; env_module_types : env_element list ; env_exceptions : env_element list ; - } + } let empty = { - env_values = [] ; - env_types = [] ; - env_class_types = [] ; - env_classes = [] ; - env_modules = [] ; - env_module_types = [] ; - env_exceptions = [] ; - } + env_values = [] ; + env_types = [] ; + env_class_types = [] ; + env_classes = [] ; + env_modules = [] ; + env_module_types = [] ; + env_exceptions = [] ; + } (** Add a signature to an environment. *) let rec add_signature env root ?rel signat = let qualify id = Name.concat root (Name.from_ident id) in - let rel_name id = + let rel_name id = let n = Name.from_ident id in match rel with None -> n @@ -54,18 +54,18 @@ let rec add_signature env root ?rel signat = Types.Tsig_value (ident, _) -> { env with env_values = (rel_name ident, qualify ident) :: env.env_values } | Types.Tsig_type (ident,_,_) -> { env with env_types = (rel_name ident, qualify ident) :: env.env_types } | Types.Tsig_exception (ident, _) -> { env with env_exceptions = (rel_name ident, qualify ident) :: env.env_exceptions } - | Types.Tsig_module (ident, modtype, _) -> - let env2 = + | Types.Tsig_module (ident, modtype, _) -> + let env2 = match modtype with (* A VOIR : le cas où c'est un identificateur, dans ce cas on n'a pas de signature *) Types.Tmty_signature s -> add_signature env (qualify ident) ~rel: (rel_name ident) s | _ -> env in { env2 with env_modules = (rel_name ident, qualify ident) :: env2.env_modules } - | Types.Tsig_modtype (ident, modtype_decl) -> + | Types.Tsig_modtype (ident, modtype_decl) -> let env2 = match modtype_decl with Types.Tmodtype_abstract -> - env + env | Types.Tmodtype_manifest modtype -> match modtype with (* A VOIR : le cas où c'est un identificateur, dans ce cas on n'a pas de signature *) @@ -76,7 +76,7 @@ let rec add_signature env root ?rel signat = | Types.Tsig_class (ident, _, _) -> { env with env_classes = (rel_name ident, qualify ident) :: env.env_classes } | Types.Tsig_cltype (ident, _, _) -> { env with env_class_types = (rel_name ident, qualify ident) :: env.env_class_types } in - List.fold_left f env signat + List.fold_left f env signat let add_exception env full_name = let simple_name = Name.simple full_name in @@ -100,20 +100,20 @@ let add_module_type env full_name = let add_class env full_name = let simple_name = Name.simple full_name in - { env with + { env with env_classes = (simple_name, full_name) :: env.env_classes ; (* we also add a type 'cause the class name may appear as a type *) env_types = (simple_name, full_name) :: env.env_types } - + let add_class_type env full_name = let simple_name = Name.simple full_name in - { env with - env_class_types = (simple_name, full_name) :: env.env_class_types ; + { env with + env_class_types = (simple_name, full_name) :: env.env_class_types ; (* we also add a type 'cause the class type name may appear as a type *) env_types = (simple_name, full_name) :: env.env_types } - + let full_module_name env n = try List.assoc n env.env_modules with Not_found -> @@ -123,7 +123,7 @@ let full_module_name env n = let full_module_type_name env n = try List.assoc n env.env_module_types - with Not_found -> + with Not_found -> print_DEBUG ("Module "^n^" not found with env="); List.iter (fun (sn, fn) -> print_DEBUG ("("^sn^", "^fn^")")) env.env_modules; n @@ -133,16 +133,16 @@ let full_module_or_module_type_name env n = with Not_found -> full_module_type_name env n let full_type_name env n = - try + try let full = List.assoc n env.env_types in (** print_string ("type "^n^" is "^full); print_newline ();*) full - with Not_found -> + with Not_found -> (** print_string ("type "^n^" not found"); print_newline ();*) n - + let full_value_name env n = try List.assoc n env.env_values with Not_found -> n @@ -156,14 +156,14 @@ let full_exception_name env n = let full_class_name env n = try List.assoc n env.env_classes - with Not_found -> + with Not_found -> print_DEBUG ("Class "^n^" not found with env="); List.iter (fun (sn, fn) -> print_DEBUG ("("^sn^", "^fn^")")) env.env_classes; n let full_class_type_name env n = try List.assoc n env.env_class_types - with Not_found -> + with Not_found -> print_DEBUG ("Class type "^n^" not found with env="); List.iter (fun (sn, fn) -> print_DEBUG ("("^sn^", "^fn^")")) env.env_class_types; n @@ -213,7 +213,7 @@ let subst_type env t = in iter t; t - + let subst_module_type env t = let rec iter t = diff --git a/ocamldoc/odoc_env.mli b/ocamldoc/odoc_env.mli index 6532a58d5c..75c0b38a4d 100644 --- a/ocamldoc/odoc_env.mli +++ b/ocamldoc/odoc_env.mli @@ -13,7 +13,7 @@ (** Environment for finding complete names from relative names. *) -(** An environment of known names, +(** An environment of known names, from simple name to complete name. *) type env diff --git a/ocamldoc/odoc_exception.ml b/ocamldoc/odoc_exception.ml index 4d81f81202..74a2fb5a20 100644 --- a/ocamldoc/odoc_exception.ml +++ b/ocamldoc/odoc_exception.ml @@ -18,7 +18,7 @@ module Name = Odoc_name type exception_alias = { ea_name : Name.t ; mutable ea_ex : t_exception option ; - } + } and t_exception = { ex_name : Name.t ; @@ -27,6 +27,4 @@ and t_exception = { ex_alias : exception_alias option ; mutable ex_loc : Odoc_types.location ; mutable ex_code : string option ; - } - - + } diff --git a/ocamldoc/odoc_inherit.ml b/ocamldoc/odoc_inherit.ml index 705bf4ad3c..b73796bf8a 100644 --- a/ocamldoc/odoc_inherit.ml +++ b/ocamldoc/odoc_inherit.ml @@ -10,4 +10,3 @@ (***********************************************************************) (* $Id$ *) - diff --git a/ocamldoc/odoc_lexer.mll b/ocamldoc/odoc_lexer.mll index 44ba7bc3e7..da66a00873 100644 --- a/ocamldoc/odoc_lexer.mll +++ b/ocamldoc/odoc_lexer.mll @@ -220,9 +220,9 @@ and special_comment = parse let len = String.length (Lexing.lexeme lexbuf) in lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - len; lexbuf.Lexing.lex_curr_p <- - { lexbuf.Lexing.lex_curr_p with - pos_cnum = lexbuf.Lexing.lex_curr_p.pos_cnum - len - } ; + { lexbuf.Lexing.lex_curr_p with + pos_cnum = lexbuf.Lexing.lex_curr_p.pos_cnum - len + } ; (* we don't increment the Odoc_comments_global.nb_chars *) special_comment_part2 lexbuf } @@ -409,4 +409,3 @@ and simple = parse incr Odoc_comments_global.nb_chars; simple lexbuf } - diff --git a/ocamldoc/odoc_merge.mli b/ocamldoc/odoc_merge.mli index cae4d230b3..52d39033d9 100644 --- a/ocamldoc/odoc_merge.mli +++ b/ocamldoc/odoc_merge.mli @@ -29,4 +29,3 @@ val merge_info_opt : val merge : Odoc_types.merge_option list -> Odoc_module.t_module list -> Odoc_module.t_module list - diff --git a/ocamldoc/odoc_name.ml b/ocamldoc/odoc_name.ml index c874c5b662..672203ff67 100644 --- a/ocamldoc/odoc_name.ml +++ b/ocamldoc/odoc_name.ml @@ -13,8 +13,8 @@ (** Representation of element names. *) -let infix_chars = [ '|' ; - '<' ; +let infix_chars = [ '|' ; + '<' ; '>' ; '@' ; '^' ; @@ -58,7 +58,7 @@ let cut name = '.' when !j = 0 -> if i < len - 1 then match s.[i+1] with - '(' -> + '(' -> j := 1 | _ -> Buffer.add_char buf.(!j) '.' @@ -86,15 +86,15 @@ let head_and_tail n = if pos > 0 then let h = String.sub n 0 pos in try - ignore (String.index h '('); - (n, "") + ignore (String.index h '('); + (n, "") with - Not_found -> - let len = String.length n in - if pos >= (len - 1) then - (h, "") - else - (h, String.sub n (pos + 1) (len - pos - 1)) + Not_found -> + let len = String.length n in + if pos >= (len - 1) then + (h, "") + else + (h, String.sub n (pos + 1) (len - pos - 1)) else (n, "") with @@ -111,7 +111,7 @@ let depth name = let prefix n1 n2 = (n1 <> n2) & - (try + (try let len1 = String.length n1 in ((String.sub n2 0 len1) = n1) & (n2.[len1] = '.') @@ -125,16 +125,16 @@ let rec get_relative_raw n1 n2 = s2 else if f1 = s1 or s1 = "" then - s2 + s2 else - get_relative_raw s1 s2 + get_relative_raw s1 s2 else n2 let get_relative n1 n2 = if prefix n1 n2 then let len1 = String.length n1 in - try + try String.sub n2 (len1+1) ((String.length n2) - len1 - 1) with _ -> n2 @@ -144,12 +144,12 @@ let get_relative n1 n2 = let hide_given_modules l s = let rec iter = function [] -> s - | h :: q -> + | h :: q -> let s2 = get_relative h s in if s = s2 then iter q else - s2 + s2 in iter l @@ -160,8 +160,8 @@ let from_ident ident = Ident.name ident let from_path path = Path.name path -let to_path n = - match +let to_path n = + match List.fold_left (fun acc_opt -> fun s -> match acc_opt with @@ -174,4 +174,3 @@ let to_path n = | Some p -> p let from_longident = Odoc_misc.string_of_longident - diff --git a/ocamldoc/odoc_name.mli b/ocamldoc/odoc_name.mli index 33b661f937..0feb3b83e2 100644 --- a/ocamldoc/odoc_name.mli +++ b/ocamldoc/odoc_name.mli @@ -63,4 +63,3 @@ val to_path : t -> Path.t (** Get a name from a [Longident.t].*) val from_longident : Longident.t -> t - diff --git a/ocamldoc/odoc_ocamlhtml.mll b/ocamldoc/odoc_ocamlhtml.mll index 2c1549670e..6364a900f6 100644 --- a/ocamldoc/odoc_ocamlhtml.mll +++ b/ocamldoc/odoc_ocamlhtml.mll @@ -342,9 +342,9 @@ rule token = parse | "*)" { lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; lexbuf.Lexing.lex_curr_p <- - { lexbuf.Lexing.lex_curr_p with - pos_cnum = lexbuf.Lexing.lex_curr_p.pos_cnum - 1 - } ; + { lexbuf.Lexing.lex_curr_p with + pos_cnum = lexbuf.Lexing.lex_curr_p.pos_cnum - 1 + } ; print (Lexing.lexeme lexbuf) ; token lexbuf } diff --git a/ocamldoc/odoc_parameter.ml b/ocamldoc/odoc_parameter.ml index ba7ff1de30..56f175ecd4 100644 --- a/ocamldoc/odoc_parameter.ml +++ b/ocamldoc/odoc_parameter.ml @@ -22,9 +22,9 @@ type simple_name = { sn_name : string ; sn_type : Types.type_expr ; mutable sn_text : Odoc_types.text option ; - } + } -(** Representation of parameter names. We need it to represent parameter names in tuples. +(** Representation of parameter names. We need it to represent parameter names in tuples. The value [Tuple ([], t)] stands for an anonymous parameter.*) type param_info = | Simple_name of simple_name @@ -37,7 +37,7 @@ type parameter = param_info (** acces to the name as a string. For tuples, parenthesis and commas are added. *) let complete_name p = - let rec iter pi = + let rec iter pi = match pi with Simple_name sn -> sn.sn_name @@ -49,7 +49,7 @@ let complete_name p = iter p (** access to the complete type *) -let typ pi = +let typ pi = match pi with Simple_name sn -> sn.sn_type | Tuple (_, typ) -> typ @@ -57,7 +57,7 @@ let typ pi = (** Update the text of a parameter using a function returning the optional text associated to a parameter name.*) let update_parameter_text f p = - let rec iter pi = + let rec iter pi = match pi with Simple_name sn -> sn.sn_text <- f sn.sn_name @@ -68,7 +68,7 @@ let update_parameter_text f p = (** access to the description of a specific name. @raise Not_found if no description is associated to the given name. *) -let desc_by_name pi name = +let desc_by_name pi name = let rec iter acc pi = match pi with Simple_name sn -> @@ -92,9 +92,9 @@ let names pi = in iter [] pi -(** access to the type of a specific name. +(** access to the type of a specific name. @raise Not_found if no type is associated to the given name. *) -let type_by_name pi name = +let type_by_name pi name = let rec iter acc pi = match pi with Simple_name sn -> @@ -107,17 +107,17 @@ let type_by_name pi name = (** access to the optional description of a parameter name from an optional info structure.*) let desc_from_info_opt info_opt s = - print_DEBUG "desc_from_info_opt"; + print_DEBUG "desc_from_info_opt"; match info_opt with None -> None | Some i -> match s with "" -> None | _ -> - try + try Some (List.assoc s i.Odoc_types.i_params) with - Not_found -> + Not_found -> print_DEBUG ("desc_from_info_opt "^s^" not found in\n"); List.iter (fun (s, _) -> print_DEBUG s) i.Odoc_types.i_params; None diff --git a/ocamldoc/odoc_parser.mly b/ocamldoc/odoc_parser.mly index 9b99e24f02..0d9d814d29 100644 --- a/ocamldoc/odoc_parser.mly +++ b/ocamldoc/odoc_parser.mly @@ -16,7 +16,7 @@ open Odoc_types open Odoc_comments_global let uppercase = "[A-Z\192-\214\216-\222]" -let identchar = +let identchar = "[A-Za-z_\192-\214\216-\246\248-\255'0-9]" let blank = "[ \010\013\009\012]" @@ -89,7 +89,7 @@ element: param: T_PARAM Desc - { + { (* isolate the identificator *) (* we only look for simple id, no pattern nor tuples *) let s = $2 in @@ -97,7 +97,7 @@ param: [] | _ :: [] -> raise (Failure "usage: @param id description") - | id :: _ -> + | id :: _ -> print_DEBUG ("Identificator "^id); let reg = identchar^"+" in print_DEBUG ("reg="^reg); @@ -105,7 +105,7 @@ param: let remain = String.sub s (String.length id) ((String.length s) - (String.length id)) in print_DEBUG ("T_PARAM Desc remain="^remain); let remain2 = Str.replace_first (Str.regexp ("^"^blank^"+")) "" remain in - params := !params @ [(id, remain2)] + params := !params @ [(id, remain2)] else raise (Failure (id^" is not a valid parameter identificator in \"@param "^s^"\"")) } @@ -126,25 +126,25 @@ deprecated: T_DEPRECATED Desc { deprecated := Some $2 } ; raise_exc: - T_RAISES Desc - { + T_RAISES Desc + { (* isolate the exception construtor name *) let s = $2 in match Str.split (Str.regexp (blank^"+")) s with [] | _ :: [] -> raise (Failure "usage: @raise Exception description") - | id :: _ -> + | id :: _ -> print_DEBUG ("exception "^id); let reg = uppercase^identchar^"*"^"\\(\\."^uppercase^identchar^"*\\)*" in print_DEBUG ("reg="^reg); if Str.string_match (Str.regexp reg) id 0 then let remain = String.sub s (String.length id) ((String.length s) - (String.length id)) in let remain2 = Str.replace_first (Str.regexp ("^"^blank^"+")) "" remain in - raised_exceptions := !raised_exceptions @ [(id, remain2)] + raised_exceptions := !raised_exceptions @ [(id, remain2)] else raise (Failure (id^" is not a valid exception constructor in \"@raise "^s^"\"")) - } + } ; return: T_RETURN Desc { return_value := Some $2 } @@ -155,4 +155,4 @@ custom: ; -%% +%% diff --git a/ocamldoc/odoc_print.ml b/ocamldoc/odoc_print.ml index 1aa9a5dcec..5cc8e038c7 100644 --- a/ocamldoc/odoc_print.ml +++ b/ocamldoc/odoc_print.ml @@ -20,14 +20,14 @@ let new_fmt () = pp_print_flush fmt (); let s = Buffer.contents buf in Buffer.reset buf ; - s + s in (fmt, flush) let (type_fmt, flush_type_fmt) = new_fmt () let _ = - let (out, flush, outnewline, outspace) = - pp_get_all_formatter_output_functions type_fmt () + let (out, flush, outnewline, outspace) = + pp_get_all_formatter_output_functions type_fmt () in pp_set_all_formatter_output_functions type_fmt ~out ~flush @@ -56,12 +56,12 @@ let simpl_module_type ?code t = let rec iter t = match t with Types.Tmty_ident p -> t - | Types.Tmty_signature _ -> - ( - match code with - None -> Types.Tmty_signature [] - | Some s -> raise (Use_code s) - ) + | Types.Tmty_signature _ -> + ( + match code with + None -> Types.Tmty_signature [] + | Some s -> raise (Use_code s) + ) | Types.Tmty_functor (id, mt1, mt2) -> Types.Tmty_functor (id, iter mt1, iter mt2) in @@ -85,7 +85,7 @@ let simpl_class_type t = (* on vire les vals et methods pour ne pas qu'elles soient imprimées quand on affichera le type *) let tnil = { Types.desc = Types.Tnil ; Types.level = 0; Types.id = 0 } in - Types.Tcty_signature { Types.cty_self = { cs.Types.cty_self with + Types.Tcty_signature { Types.cty_self = { cs.Types.cty_self with Types.desc = Types.Tobject (tnil, ref None) }; Types.cty_vars = Types.Vars.empty ; Types.cty_concr = Types.Concr.empty ; @@ -97,7 +97,7 @@ let simpl_class_type t = in iter t -let string_of_class_type ?(complete=false) t = +let string_of_class_type ?(complete=false) t = let t2 = if complete then t else simpl_class_type t in (* A VOIR : ma propre version de Printtyp.class_type pour ne pas faire reset_names *) Printtyp.class_type modtype_fmt t2; diff --git a/ocamldoc/odoc_print.mli b/ocamldoc/odoc_print.mli index b0b11997d1..01b319c35b 100644 --- a/ocamldoc/odoc_print.mli +++ b/ocamldoc/odoc_print.mli @@ -13,11 +13,11 @@ (** Printing functions. *) -(** This function takes a Types.type_expr and returns a string. +(** This function takes a Types.type_expr and returns a string. It writes in and flushes [Format.str_formatter].*) val string_of_type_expr : Types.type_expr -> string -(** This function returns a string representing a [Types.module_type]. +(** This function returns a string representing a [Types.module_type]. @param complete indicates if we must print complete signatures or just [sig end]. Default if [false]. @param code if [complete = false] and the type contains something else @@ -25,9 +25,8 @@ val string_of_type_expr : Types.type_expr -> string *) val string_of_module_type : ?code: string -> ?complete: bool -> Types.module_type -> string -(** This function returns a string representing a [Types.class_type]. +(** This function returns a string representing a [Types.class_type]. @param complete indicates if we must print complete signatures or just [object end]. Default if [false]. *) val string_of_class_type : ?complete: bool -> Types.class_type -> string - diff --git a/ocamldoc/odoc_scan.ml b/ocamldoc/odoc_scan.ml index 2618d064ba..839092df22 100644 --- a/ocamldoc/odoc_scan.ml +++ b/ocamldoc/odoc_scan.ml @@ -15,13 +15,13 @@ The class scanner defined in this module can be used to develop generators which perform controls on the elements - and their comments. + and their comments. *) open Odoc_types (** Class which defines the scanning of a list of modules and their - elements. Inherit this class to develop your own scanner, by + elements. Inherit this class to develop your own scanner, by overriding some methods.*) class scanner = object (self) @@ -34,23 +34,23 @@ class scanner = method scan_method (m : Odoc_value.t_method) = () method scan_included_module (im : Odoc_module.included_module) = () - (** Scan of a class. *) + (** Scan of a class. *) (** Scan of a comment inside a class. *) method scan_class_comment (t : text) = () (** Override this method to perform controls on the class comment - and params. This method is called before scanning the class elements. + and params. This method is called before scanning the class elements. @return true if the class elements must be scanned.*) method scan_class_pre (c : Odoc_class.t_class) = true - (** This method scan the elements of the given class. + (** This method scan the elements of the given class. A VOIR : scan des classes héritées.*) method scan_class_elements c = - List.iter - (fun ele -> + List.iter + (fun ele -> match ele with - Odoc_class.Class_attribute a -> self#scan_attribute a + Odoc_class.Class_attribute a -> self#scan_attribute a | Odoc_class.Class_method m -> self#scan_method m | Odoc_class.Class_comment t -> self#scan_class_comment t ) @@ -66,17 +66,17 @@ class scanner = method scan_class_type_comment (t : text) = () (** Override this method to perform controls on the class type comment - and form. This method is called before scanning the class type elements. + and form. This method is called before scanning the class type elements. @return true if the class type elements must be scanned.*) method scan_class_type_pre (ct : Odoc_class.t_class_type) = true - (** This method scan the elements of the given class type. + (** This method scan the elements of the given class type. A VOIR : scan des classes héritées.*) method scan_class_type_elements ct = - List.iter - (fun ele -> + List.iter + (fun ele -> match ele with - Odoc_class.Class_attribute a -> self#scan_attribute a + Odoc_class.Class_attribute a -> self#scan_attribute a | Odoc_class.Class_method m -> self#scan_method m | Odoc_class.Class_comment t -> self#scan_class_type_comment t ) @@ -92,14 +92,14 @@ class scanner = method scan_module_comment (t : text) = () (** Override this method to perform controls on the module comment - and form. This method is called before scanning the module elements. + and form. This method is called before scanning the module elements. @return true if the module elements must be scanned.*) method scan_module_pre (m : Odoc_module.t_module) = true (** This method scan the elements of the given module. *) method scan_module_elements m = - List.iter - (fun ele -> + List.iter + (fun ele -> match ele with Odoc_module.Element_module m -> self#scan_module m | Odoc_module.Element_module_type mt -> self#scan_module_type mt @@ -123,14 +123,14 @@ class scanner = method scan_module_type_comment (t : text) = () (** Override this method to perform controls on the module type comment - and form. This method is called before scanning the module type elements. + and form. This method is called before scanning the module type elements. @return true if the module type elements must be scanned. *) method scan_module_type_pre (mt : Odoc_module.t_module_type) = true (** This method scan the elements of the given module type. *) method scan_module_type_elements mt = - List.iter - (fun ele -> + List.iter + (fun ele -> match ele with Odoc_module.Element_module m -> self#scan_module m | Odoc_module.Element_module_type mt -> self#scan_module_type mt @@ -146,7 +146,7 @@ class scanner = (** Scan of a module type. Should not be overriden. It calls [scan_module_type_pre] and if [scan_module_type_pre] returns [true], then it calls scan_module_type_elements.*) - method scan_module_type mt = + method scan_module_type mt = if self#scan_module_type_pre mt then self#scan_module_type_elements mt (** Main scanning method. *) diff --git a/ocamldoc/odoc_search.ml b/ocamldoc/odoc_search.ml index a140cfe31c..f39c76bc25 100644 --- a/ocamldoc/odoc_search.ml +++ b/ocamldoc/odoc_search.ml @@ -76,13 +76,13 @@ module Search = | T.Block t | T.Superscript t | T.Subscript t - | T.Custom (_,t) + | T.Custom (_,t) | T.Link (_, t) -> search_text root t v | T.List l | T.Enum l -> List.flatten (List.map (fun t -> search_text root t v) l) | T.Newline - | T.Module_list _ - | T.Index_list -> [] + | T.Module_list _ + | T.Index_list -> [] | T.Title (n, l_opt, t) -> (match l_opt with None -> [] @@ -542,7 +542,7 @@ let type_exists mods regexp = let l = Search_by_name.search mods regexp in List.exists (function - Res_type _ -> true + Res_type _ -> true | _ -> false ) l @@ -551,7 +551,7 @@ let value_exists mods regexp = let l = Search_by_name.search mods regexp in List.exists (function - Res_value _ -> true + Res_value _ -> true | _ -> false ) l @@ -560,7 +560,7 @@ let class_exists mods regexp = let l = Search_by_name.search mods regexp in List.exists (function - Res_class _ -> true + Res_class _ -> true | _ -> false ) l @@ -569,7 +569,7 @@ let class_type_exists mods regexp = let l = Search_by_name.search mods regexp in List.exists (function - Res_class_type _ -> true + Res_class_type _ -> true | _ -> false ) l @@ -578,7 +578,7 @@ let module_exists mods regexp = let l = Search_by_name.search mods regexp in List.exists (function - Res_module _ -> true + Res_module _ -> true | _ -> false ) l @@ -587,7 +587,7 @@ let module_type_exists mods regexp = let l = Search_by_name.search mods regexp in List.exists (function - Res_module_type _ -> true + Res_module_type _ -> true | _ -> false ) l @@ -596,7 +596,7 @@ let exception_exists mods regexp = let l = Search_by_name.search mods regexp in List.exists (function - Res_exception _ -> true + Res_exception _ -> true | _ -> false ) l @@ -605,7 +605,7 @@ let attribute_exists mods regexp = let l = Search_by_name.search mods regexp in List.exists (function - Res_attribute _ -> true + Res_attribute _ -> true | _ -> false ) l @@ -614,7 +614,7 @@ let method_exists mods regexp = let l = Search_by_name.search mods regexp in List.exists (function - Res_method _ -> true + Res_method _ -> true | _ -> false ) l @@ -624,8 +624,8 @@ let find_section mods regexp = match List.find (function - Res_section _ -> true - | _ -> false + Res_section _ -> true + | _ -> false ) l with diff --git a/ocamldoc/odoc_search.mli b/ocamldoc/odoc_search.mli index affd315fb4..d7ace5831a 100644 --- a/ocamldoc/odoc_search.mli +++ b/ocamldoc/odoc_search.mli @@ -29,7 +29,7 @@ type result_element = (** The type representing a research result.*) type result = result_element list -(** The type of modules which contain the predicates used during the research. +(** The type of modules which contain the predicates used during the research. Some functions return a couple of booleans ; the first indicates if we must go deeper in the analysed element, the second if the element satisfies the predicate. @@ -193,7 +193,7 @@ val attribute_exists : Odoc_module.t_module list -> Str.regexp -> bool in the given module list.*) val method_exists : Odoc_module.t_module list -> Str.regexp -> bool -(** Return the [text] of the section with the given complete name (regexp) +(** Return the [text] of the section with the given complete name (regexp) in the given module list. @raise Not_found if the section was not found.*) val find_section : Odoc_module.t_module list -> Str.regexp -> Odoc_types.text diff --git a/ocamldoc/odoc_see_lexer.mll b/ocamldoc/odoc_see_lexer.mll index a556679bd2..b0570f7832 100644 --- a/ocamldoc/odoc_see_lexer.mll +++ b/ocamldoc/odoc_see_lexer.mll @@ -21,52 +21,52 @@ open Odoc_parser let buf = Buffer.create 32 -} +} rule main = parse [' ' '\013' '\009' '\012'] + - { + { print_DEBUG2 "[' ' '\013' '\009' '\012'] +"; - main lexbuf + main lexbuf } - | [ '\010' ] - { + | [ '\010' ] + { print_DEBUG2 " [ '\010' ] "; - main lexbuf + main lexbuf } - | "<" - { + | "<" + { print_DEBUG2 "call url lexbuf" ; - url lexbuf - } + url lexbuf + } - | "\"" - { + | "\"" + { print_DEBUG2 "call doc lexbuf" ; doc lexbuf - } + } | '\'' { print_DEBUG2 "call file lexbuf" ; file lexbuf - } + } | eof - { + { print_DEBUG2 "EOF"; - EOF + EOF } | _ - { + { Buffer.reset buf ; - Buffer.add_string buf (Lexing.lexeme lexbuf); + Buffer.add_string buf (Lexing.lexeme lexbuf); desc lexbuf - } + } and url = parse | ([^'>'] | '\n')+">" @@ -76,7 +76,7 @@ and url = parse See_url (String.sub s 0 ((String.length s) -1)) } - + and doc = parse | ([^'"'] | '\n' | "\\'")* "\"" { @@ -95,8 +95,8 @@ and file = parse and desc = parse eof { Desc (Buffer.contents buf) } - | _ - { + | _ + { Buffer.add_string buf (Lexing.lexeme lexbuf); desc lexbuf } diff --git a/ocamldoc/odoc_sig.mli b/ocamldoc/odoc_sig.mli index 71e68d6fee..65ee128fc5 100644 --- a/ocamldoc/odoc_sig.mli +++ b/ocamldoc/odoc_sig.mli @@ -134,7 +134,7 @@ module Analyser : (Odoc_types.info option * Odoc_module.module_element list) (** [name_comment_from_type_kind pos_end pos_limit type_kind]. - This function takes a [Parsetree.type_kind] and returns the list of + This function takes a [Parsetree.type_kind] and returns the list of (name, optional comment) for the various fields/constructors of the type, or an empty list for an abstract type. [pos_end] is last char of the complete type definition. diff --git a/ocamldoc/odoc_str.ml b/ocamldoc/odoc_str.ml index 2a45573805..b20cd8b4bc 100644 --- a/ocamldoc/odoc_str.ml +++ b/ocamldoc/odoc_str.ml @@ -68,9 +68,9 @@ let raw_string_of_type_list sep type_list = print_one_type variance ty; List.iter (fun (variance, t) -> - Format.fprintf fmt "@,%s" sep; - print_one_type variance t - ) + Format.fprintf fmt "@,%s" sep; + print_one_type variance t + ) tyl; Format.fprintf fmt "@]" end; @@ -82,9 +82,9 @@ let string_of_type_list ?par sep type_list = match par with | Some b -> b | None -> - match type_list with - [] | [_] -> false - | _ -> true + match type_list with + [] | [_] -> false + | _ -> true in Printf.sprintf "%s%s%s" (if par then "(" else "") @@ -101,8 +101,8 @@ let string_of_type_param_list t = (if par then "(" else "") (raw_string_of_type_list ", " (List.map - (fun (typ, co, cn) -> (string_of_variance t (co, cn), typ)) - t.Odoc_type.ty_parameters + (fun (typ, co, cn) -> (string_of_variance t (co, cn), typ)) + t.Odoc_type.ty_parameters ) ) (if par then ")" else "") @@ -117,8 +117,8 @@ let string_of_class_type_param_list l = (if par then "[" else "") (raw_string_of_type_list ", " (List.map - (fun typ -> ("", typ)) - l + (fun typ -> ("", typ)) + l ) ) (if par then "]" else "") @@ -127,23 +127,23 @@ let string_of_class_params c = let b = Buffer.create 256 in let rec iter = function Types.Tcty_fun (label, t, ctype) -> - let parent = is_arrow_type t in - Printf.bprintf b "%s%s%s%s -> " - ( - match label with - "" -> "" - | s -> s^":" - ) - (if parent then "(" else "") - (Odoc_print.string_of_type_expr - (if Odoc_misc.is_optional label then - Odoc_misc.remove_option t - else - t - ) - ) - (if parent then ")" else ""); - iter ctype + let parent = is_arrow_type t in + Printf.bprintf b "%s%s%s%s -> " + ( + match label with + "" -> "" + | s -> s^":" + ) + (if parent then "(" else "") + (Odoc_print.string_of_type_expr + (if Odoc_misc.is_optional label then + Odoc_misc.remove_option t + else + t + ) + ) + (if parent then ")" else ""); + iter ctype | Types.Tcty_signature _ | Types.Tcty_constr _ -> () in @@ -160,9 +160,9 @@ let string_of_type t = (String.concat "" (List.map (fun (p, co, cn) -> - (string_of_variance t (co, cn))^ - (Odoc_print.string_of_type_expr p)^" " - ) + (string_of_variance t (co, cn))^ + (Odoc_print.string_of_type_expr p)^" " + ) t.M.ty_parameters ) )^ diff --git a/ocamldoc/odoc_str.mli b/ocamldoc/odoc_str.mli index 4428378122..5d68c6d234 100644 --- a/ocamldoc/odoc_str.mli +++ b/ocamldoc/odoc_str.mli @@ -26,7 +26,7 @@ val string_of_type_list : ?par: bool -> string -> Types.type_expr list -> string for the given type. *) val string_of_type_param_list : Odoc_type.t_type -> string -(** This function returns a string to represent the given list of +(** This function returns a string to represent the given list of type parameters of a class or class type, with a given separator. *) val string_of_class_type_param_list : Types.type_expr list -> string diff --git a/ocamldoc/odoc_test.ml b/ocamldoc/odoc_test.ml index 13f04ee46c..c11352fadb 100644 --- a/ocamldoc/odoc_test.ml +++ b/ocamldoc/odoc_test.ml @@ -27,64 +27,64 @@ class string_gen = inherit Odoc_info.Scan.scanner val mutable test_kinds = [] - val mutable fmt = Format.str_formatter + val mutable fmt = Format.str_formatter method must_display_types = List.mem Types_display test_kinds method set_test_kinds_from_module m = test_kinds <- List.fold_left - (fun acc (s, _) -> - match s with - "test_types_display" -> Types_display :: acc - | _ -> acc - ) - [] - ( - match m.m_info with - None -> [] - | Some i -> i.i_custom - ) + (fun acc (s, _) -> + match s with + "test_types_display" -> Types_display :: acc + | _ -> acc + ) + [] + ( + match m.m_info with + None -> [] + | Some i -> i.i_custom + ) method scan_type t = match test_kinds with - [] -> () - | _ -> - p fmt "# type %s:\n" t.ty_name; - if self#must_display_types then - ( - p fmt "# manifest (Odoc_info.string_of_type_expr):\n<[%s]>\n" - (match t.ty_manifest with - None -> "None" - | Some e -> Odoc_info.string_of_type_expr e - ); - ); + [] -> () + | _ -> + p fmt "# type %s:\n" t.ty_name; + if self#must_display_types then + ( + p fmt "# manifest (Odoc_info.string_of_type_expr):\n<[%s]>\n" + (match t.ty_manifest with + None -> "None" + | Some e -> Odoc_info.string_of_type_expr e + ); + ); method scan_module_pre m = p fmt "#\n# module %s:\n" m.m_name ; if self#must_display_types then - ( - p fmt "# Odoc_info.string_of_module_type:\n<[%s]>\n" - (Odoc_info.string_of_module_type m.m_type); - p fmt "# Odoc_info.string_of_module_type ~complete: true :\n<[%s]>\n" - (Odoc_info.string_of_module_type ~complete: true m.m_type); - ); + ( + p fmt "# Odoc_info.string_of_module_type:\n<[%s]>\n" + (Odoc_info.string_of_module_type m.m_type); + p fmt "# Odoc_info.string_of_module_type ~complete: true :\n<[%s]>\n" + (Odoc_info.string_of_module_type ~complete: true m.m_type); + ); true method scan_module_type_pre m = p fmt "#\n# module type %s:\n" m.mt_name ; if self#must_display_types then - ( - p fmt "# Odoc_info.string_of_module_type:\n<[%s]>\n" - (match m.mt_type with - None -> "None" - | Some t -> Odoc_info.string_of_module_type t - ); - p fmt "# Odoc_info.string_of_module_type ~complete: true :\n<[%s]>\n" - (match m.mt_type with - None -> "None" - | Some t -> Odoc_info.string_of_module_type ~complete: true t - ); - ); + ( + p fmt "# Odoc_info.string_of_module_type:\n<[%s]>\n" + (match m.mt_type with + None -> "None" + | Some t -> Odoc_info.string_of_module_type t + ); + p fmt "# Odoc_info.string_of_module_type ~complete: true :\n<[%s]>\n" + (match m.mt_type with + None -> "None" + | Some t -> Odoc_info.string_of_module_type ~complete: true t + ); + ); true method generate (module_list: Odoc_info.Module.t_module list) = @@ -92,15 +92,15 @@ class string_gen = fmt <- Format.formatter_of_out_channel oc; ( try - List.iter - (fun m -> - self#set_test_kinds_from_module m; - self#scan_module_list [m]; - ) - module_list + List.iter + (fun m -> + self#set_test_kinds_from_module m; + self#scan_module_list [m]; + ) + module_list with - e -> - prerr_endline (Printexc.to_string e) + e -> + prerr_endline (Printexc.to_string e) ); Format.pp_print_flush fmt (); close_out oc @@ -108,5 +108,5 @@ class string_gen = let my_generator = new string_gen -let _ = Odoc_info.Args.set_doc_generator +let _ = Odoc_info.Args.set_doc_generator (Some (my_generator :> Odoc_info.Args.doc_generator)) diff --git a/ocamldoc/odoc_text.ml b/ocamldoc/odoc_text.ml index e643ca6151..a6dbe67964 100644 --- a/ocamldoc/odoc_text.ml +++ b/ocamldoc/odoc_text.ml @@ -33,7 +33,7 @@ module Texter = let count s c = let count = ref 0 in for i = 0 to String.length s - 1 do - if s.[i] = c then incr count + if s.[i] = c then incr count done; !count @@ -42,13 +42,13 @@ module Texter = let len = String.length s in let b = Buffer.create (len + n) in for i = 0 to len - 1 do - if s.[i] = c && !remain > 0 then - ( - Printf.bprintf b "\\%c" c; - decr remain - ) - else - Buffer.add_char b s.[i] + if s.[i] = c && !remain > 0 then + ( + Printf.bprintf b "\\%c" c; + decr remain + ) + else + Buffer.add_char b s.[i] done; Buffer.contents b @@ -56,22 +56,22 @@ module Texter = let open_brackets = count s '[' in let close_brackets = count s ']' in if open_brackets > close_brackets then - escape_n s '[' (open_brackets - close_brackets) + escape_n s '[' (open_brackets - close_brackets) else - if close_brackets > open_brackets then - escape_n s ']' (close_brackets - open_brackets) - else - s + if close_brackets > open_brackets then + escape_n s ']' (close_brackets - open_brackets) + else + s let escape_raw s = let len = String.length s in let b = Buffer.create len in for i = 0 to len - 1 do - match s.[i] with - '[' | ']' | '{' | '}' -> - Printf.bprintf b "\\%c" s.[i] - | c -> - Buffer.add_char b c + match s.[i] with + '[' | ']' | '{' | '}' -> + Printf.bprintf b "\\%c" s.[i] + | c -> + Buffer.add_char b c done; Buffer.contents b @@ -82,8 +82,8 @@ module Texter = and p_list b l = List.iter - (fun t -> p b "{- " ; p_text b t ; p b "}\n") - l + (fun t -> p b "{- " ; p_text b t ; p b "}\n") + l and p_text_element b = function | Raw s -> p b "%s" (escape_raw s) @@ -101,19 +101,19 @@ module Texter = | Newline -> p b "\n" | Block t -> p_text b t | Title (n, l_opt, t) -> - p b "{%d%s " - n - (match l_opt with - None -> "" - | Some s -> ":"^s - ); - p_text b t ; - p b "}" + p b "{%d%s " + n + (match l_opt with + None -> "" + | Some s -> ":"^s + ); + p_text b t ; + p b "}" | Latex s -> p b "{%% %s%%}" s | Link (s,t) -> - p b "{{:%s}" s; - p_text b t ; - p b "}" + p b "{{:%s}" s; + p_text b t ; + p b "}" | Ref (name, kind_opt, text_opt) -> begin p b "%s{!%s%s}" @@ -144,15 +144,15 @@ module Texter = | Superscript t -> p b "{^" ; p_text b t ; p b "}" | Subscript t -> p b "{_" ; p_text b t ; p b "}" | Module_list l -> - p b "{!modules:"; - List.iter (fun s -> p b " %s" s) l; - p b "}" - | Index_list -> - p b "{!indexlist}" - | Custom (s,t) -> - p b "{%s " s; - p_text b t; - p b "}" + p b "{!modules:"; + List.iter (fun s -> p b " %s" s) l; + p b "}" + | Index_list -> + p b "{!indexlist}" + | Custom (s,t) -> + p b "{%s " s; + p_text b t; + p b "}" let string_of_text s = let b = Buffer.create 256 in diff --git a/ocamldoc/odoc_text.mli b/ocamldoc/odoc_text.mli index bc121791dd..f4f8e911e4 100644 --- a/ocamldoc/odoc_text.mli +++ b/ocamldoc/odoc_text.mli @@ -17,8 +17,8 @@ exception Text_syntax of int * int * string (* line, char, string *) (** Transformation of strings to text structures. *) -module Texter : - sig - val text_of_string : string -> Odoc_types.text +module Texter : + sig + val text_of_string : string -> Odoc_types.text val string_of_text : Odoc_types.text -> string end diff --git a/ocamldoc/odoc_text_lexer.mll b/ocamldoc/odoc_text_lexer.mll index 73b5a1d7d5..74d86a94b0 100644 --- a/ocamldoc/odoc_text_lexer.mll +++ b/ocamldoc/odoc_text_lexer.mll @@ -423,26 +423,26 @@ rule main = parse if !verb_mode or !latex_mode or !ele_ref_mode then Char (Lexing.lexeme lexbuf) else - if !open_brackets >= 1 then - ( - lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; + if !open_brackets >= 1 then + ( + lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; lexbuf.Lexing.lex_curr_p <- - { lexbuf.Lexing.lex_curr_p with - pos_cnum = lexbuf.Lexing.lex_curr_p.pos_cnum - 1 - } ; - decr char_number ; - if !open_brackets > 1 then - ( - decr open_brackets; + { lexbuf.Lexing.lex_curr_p with + pos_cnum = lexbuf.Lexing.lex_curr_p.pos_cnum - 1 + } ; + decr char_number ; + if !open_brackets > 1 then + ( + decr open_brackets; Char "]" - ) - else - ( + ) + else + ( open_brackets := 0; END_CODE ) - ) - else + ) + else if !code_pre_mode then ( code_pre_mode := false; @@ -669,10 +669,10 @@ rule main = parse if !verb_mode or !latex_mode or !code_pre_mode or !open_brackets >= 1 then Char (Lexing.lexeme lexbuf) else - if not !ele_ref_mode then + if not !ele_ref_mode then INDEX_LIST - else - Char (Lexing.lexeme lexbuf) + else + Char (Lexing.lexeme lexbuf) } | begin_verb @@ -728,9 +728,9 @@ rule main = parse incr_cpts lexbuf ; lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; lexbuf.Lexing.lex_curr_p <- - { lexbuf.Lexing.lex_curr_p with - pos_cnum = lexbuf.Lexing.lex_curr_p.pos_cnum - 1 ; - } ; + { lexbuf.Lexing.lex_curr_p with + pos_cnum = lexbuf.Lexing.lex_curr_p.pos_cnum - 1 ; + } ; decr line_number ; if !shortcut_list_mode then ( @@ -741,9 +741,9 @@ rule main = parse END_SHORTCUT_LIST ) else - if !latex_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode or !verb_mode then - Char (Lexing.lexeme lexbuf) - else + if !latex_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode or !verb_mode then + Char (Lexing.lexeme lexbuf) + else BLANK_LINE } @@ -757,8 +757,8 @@ rule main = parse (!open_brackets >= 1) or !ele_ref_mode then Char (Lexing.lexeme lexbuf) else - let s = Lexing.lexeme lexbuf in - let tag = Odoc_misc.no_blanks s in + let s = Lexing.lexeme lexbuf in + let tag = Odoc_misc.no_blanks s in CUSTOM tag } diff --git a/ocamldoc/odoc_to_text.ml b/ocamldoc/odoc_to_text.ml index 523d2fa564..322ed44119 100644 --- a/ocamldoc/odoc_to_text.ml +++ b/ocamldoc/odoc_to_text.ml @@ -229,7 +229,7 @@ class virtual to_text = method normal_class_params m_name c = let s = Odoc_info.string_of_class_params c in self#relative_idents m_name - (Odoc_info.remove_ending_newline s) + (Odoc_info.remove_ending_newline s) (** @return [text] value to represent a [Types.type_expr].*) method text_of_type_expr module_name t = @@ -259,12 +259,12 @@ class virtual to_text = (** @return [text] value to represent parameters of a class (with arraows).*) method text_of_class_params module_name c = let t = Odoc_info.text_concat - [Newline] + [Newline] (List.map (fun s -> [Code s]) - (Str.split (Str.regexp "\n") + (Str.split (Str.regexp "\n") (self#normal_class_params module_name c)) - ) + ) in t @@ -280,10 +280,10 @@ class virtual to_text = let name = v.val_name in let s_name = Name.simple name in let s = - Format.fprintf Format.str_formatter "@[<hov 2>val %s :@ %s" + Format.fprintf Format.str_formatter "@[<hov 2>val %s :@ %s" s_name (self#normal_type (Name.father v.val_name) v.val_type); - Format.flush_str_formatter () + Format.flush_str_formatter () in [ CodePre s ] @ [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @ @@ -294,12 +294,12 @@ class virtual to_text = let s_name = Name.simple a.att_value.val_name in let mod_name = Name.father a.att_value.val_name in let s = - Format.fprintf Format.str_formatter "@[<hov 2>val %s%s%s :@ %s" + Format.fprintf Format.str_formatter "@[<hov 2>val %s%s%s :@ %s" (if a.att_virtual then "virtual " else "") (if a.att_mutable then "mutable " else "") s_name - (self#normal_type mod_name a.att_value.val_type); - Format.flush_str_formatter () + (self#normal_type mod_name a.att_value.val_type); + Format.flush_str_formatter () in (CodePre s) :: [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @ @@ -310,12 +310,12 @@ class virtual to_text = let s_name = Name.simple m.met_value.val_name in let mod_name = Name.father m.met_value.val_name in let s = - Format.fprintf Format.str_formatter "@[<hov 2>method %s%s%s :@ %s" + Format.fprintf Format.str_formatter "@[<hov 2>method %s%s%s :@ %s" (if m.met_private then "private " else "") (if m.met_virtual then "virtual " else "") s_name - (self#normal_type mod_name m.met_value.val_type); - Format.flush_str_formatter () + (self#normal_type mod_name m.met_value.val_type); + Format.flush_str_formatter () in (CodePre s) :: [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @ @@ -332,7 +332,7 @@ class virtual to_text = Format.fprintf Format.str_formatter "@ of " ); let s = self#normal_type_list - ~par: false (Name.father e.ex_name) " * " e.ex_args + ~par: false (Name.father e.ex_name) " * " e.ex_args in let s2 = Format.fprintf Format.str_formatter "%s" s ; @@ -551,7 +551,7 @@ class virtual to_text = | Module_type_functor (p, k) -> let t1 = - [Code ("("^p.mp_name^" : ")] @ + [Code ("("^p.mp_name^" : ")] @ (self#text_of_module_type_kind p.mp_kind) @ [Code ") -> "] in diff --git a/ocamldoc/odoc_type.ml b/ocamldoc/odoc_type.ml index 220a91a4e4..9d19dc67d9 100644 --- a/ocamldoc/odoc_type.ml +++ b/ocamldoc/odoc_type.ml @@ -39,7 +39,7 @@ type type_kind = | Type_variant of variant_constructor list (** constructors *) | Type_record of record_field list - (** fields *) + (** fields *) (** Representation of a type. *) type t_type = { @@ -53,4 +53,3 @@ type t_type = { mutable ty_loc : Odoc_types.location ; mutable ty_code : string option; } - diff --git a/ocamldoc/odoc_value.ml b/ocamldoc/odoc_value.ml index 029509583d..a210f0851e 100644 --- a/ocamldoc/odoc_value.ml +++ b/ocamldoc/odoc_value.ml @@ -75,7 +75,7 @@ let parameter_list_from_arrows typ = (l, t1) :: (iter t2) | Types.Tlink texp | Types.Tsubst texp -> - iter texp + iter texp | Types.Tpoly (texp, _) -> iter texp | Types.Tvar | Types.Ttuple _ @@ -142,5 +142,3 @@ let is_function v = false in f v.val_type - - diff --git a/otherlibs/Makefile.nt b/otherlibs/Makefile.nt index f86b09c022..32aca21c06 100644 --- a/otherlibs/Makefile.nt +++ b/otherlibs/Makefile.nt @@ -22,4 +22,3 @@ CFLAGS=-I$(ROOTDIR)/byterun $(SHAREDCCCOMPOPTS) $(EXTRACFLAGS) include ../Makefile.shared # Note .. is the current directory (this makefile is included from # a subdirectory) - diff --git a/otherlibs/bigarray/mmap_win32.c b/otherlibs/bigarray/mmap_win32.c index e33f5d0994..efb44fe5f6 100644 --- a/otherlibs/bigarray/mmap_win32.c +++ b/otherlibs/bigarray/mmap_win32.c @@ -111,7 +111,7 @@ CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout, delta = (uintnat) (startpos % sysinfo.dwPageSize); /* Map the mapping in memory */ li.QuadPart = startpos - delta; - addr = + addr = MapViewOfFile(fmap, mode, li.HighPart, li.LowPart, array_size + delta); if (addr == NULL) caml_ba_sys_error(); addr = (void *) ((uintnat) addr + delta); diff --git a/otherlibs/db/.depend b/otherlibs/db/.depend index 5d94dce520..ba0e54e577 100644 --- a/otherlibs/db/.depend +++ b/otherlibs/db/.depend @@ -1,2 +1,2 @@ -db.cmo: db.cmi -db.cmx: db.cmi +db.cmo: db.cmi +db.cmx: db.cmi diff --git a/otherlibs/dbm/cldbm.c b/otherlibs/dbm/cldbm.c index a9da59b3db..0d6cb362d6 100644 --- a/otherlibs/dbm/cldbm.c +++ b/otherlibs/dbm/cldbm.c @@ -65,7 +65,7 @@ value caml_dbm_open(value vfile, value vflags, value vmode) /* ML */ int mode = Int_val(vmode); DBM *db = dbm_open(file,flags,mode); - if (db == NULL) + if (db == NULL) raise_dbm("Can't open file"); else return (alloc_dbm(db)); @@ -97,7 +97,7 @@ value caml_dbm_fetch(value vdb, value vkey) /* ML */ value caml_dbm_insert(value vdb, value vkey, value vcontent) /* ML */ { datum key, content; - + key.dptr = String_val(vkey); key.dsize = string_length(vkey); content.dptr = String_val(vcontent); @@ -116,7 +116,7 @@ value caml_dbm_insert(value vdb, value vkey, value vcontent) /* ML */ value caml_dbm_replace(value vdb, value vkey, value vcontent) /* ML */ { datum key, content; - + key.dptr = String_val(vkey); key.dsize = string_length(vkey); content.dptr = String_val(vcontent); diff --git a/otherlibs/dbm/dbm.ml b/otherlibs/dbm/dbm.ml index c98f7fe24d..f31d29934d 100644 --- a/otherlibs/dbm/dbm.ml +++ b/otherlibs/dbm/dbm.ml @@ -24,7 +24,7 @@ type dbm_flag = exception Dbm_error of string -external raw_opendbm : string -> open_flag list -> int -> t +external raw_opendbm : string -> open_flag list -> int -> t = "caml_dbm_open" let opendbm file flags mode = @@ -52,7 +52,7 @@ let iter f t = let rec walk = function None -> () | Some k -> - f k (find t k); + f k (find t k); walk (try Some(nextkey t) with Not_found -> None) in walk (try Some(firstkey t) with Not_found -> None) diff --git a/otherlibs/dbm/dbm.mli b/otherlibs/dbm/dbm.mli index d451745f9e..f9924427a7 100644 --- a/otherlibs/dbm/dbm.mli +++ b/otherlibs/dbm/dbm.mli @@ -19,7 +19,7 @@ type t (** The type of file descriptors opened on NDBM databases. *) -type open_flag = +type open_flag = Dbm_rdonly | Dbm_wronly | Dbm_rdwr @@ -77,4 +77,3 @@ val iter : (string -> string -> 'a) -> t -> unit (** [iter f db] applies [f] to each ([key], [data]) pair in the database [db]. [f] receives [key] as first argument and [data] as second argument. *) - diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile index 97b5bd2464..21771b598c 100644 --- a/otherlibs/dynlink/Makefile +++ b/otherlibs/dynlink/Makefile @@ -93,4 +93,4 @@ clean: partialclean depend: dynlink.cmo: dynlinkaux.cmi dynlink.cmi -extract_crc.cmo: dynlink.cmi +extract_crc.cmo: dynlink.cmi diff --git a/otherlibs/dynlink/dynlink.ml b/otherlibs/dynlink/dynlink.ml index 8d8d9a62d0..1596e9af10 100644 --- a/otherlibs/dynlink/dynlink.ml +++ b/otherlibs/dynlink/dynlink.ml @@ -210,7 +210,7 @@ let loadfile file_name = let toc_pos = input_binary_int ic in (* Go to table of contents *) seek_in ic toc_pos; let lib = (input_value ic : library) in - begin try + begin try Dll.open_dlls Dll.For_execution (List.map Dll.extract_dll_name lib.lib_dllibs) with Failure reason -> diff --git a/otherlibs/dynlink/dynlink.mli b/otherlibs/dynlink/dynlink.mli index caee291710..7cca68c5a0 100644 --- a/otherlibs/dynlink/dynlink.mli +++ b/otherlibs/dynlink/dynlink.mli @@ -23,9 +23,9 @@ val is_native: bool val loadfile : string -> unit (** In bytecode: load the given bytecode object file ([.cmo] file) or - bytecode library file ([.cma] file), and link it with the running + bytecode library file ([.cma] file), and link it with the running program. In native code: load the given OCaml plugin file (usually - [.cmxs]), and link it with the running + [.cmxs]), and link it with the running program. All toplevel expressions in the loaded compilation units are evaluated. No facilities are provided to diff --git a/otherlibs/dynlink/extract_crc.ml b/otherlibs/dynlink/extract_crc.ml index e8bdd64647..e7d9139bed 100644 --- a/otherlibs/dynlink/extract_crc.ml +++ b/otherlibs/dynlink/extract_crc.ml @@ -51,5 +51,3 @@ let main () = print_string "\n]\n" let _ = main(); exit 0 - - diff --git a/otherlibs/dynlink/natdynlink.ml b/otherlibs/dynlink/natdynlink.ml index 5e4200b1b1..184093a399 100644 --- a/otherlibs/dynlink/natdynlink.ml +++ b/otherlibs/dynlink/natdynlink.ml @@ -112,8 +112,8 @@ let default_available_units () = (fun st (name,crc_intf,crc_impl,syms) -> rank := !rank + List.length syms; { - ifaces = StrMap.add name (crc_intf,exe) st.ifaces; - implems = StrMap.add name (crc_impl,exe,Check_inited !rank) st.implems; + ifaces = StrMap.add name (crc_intf,exe) st.ifaces; + implems = StrMap.add name (crc_impl,exe,Check_inited !rank) st.implems; } ) empty_state @@ -130,44 +130,44 @@ let add_check_ifaces allow_ext filename ui ifaces = if name = ui.name then StrMap.add name (crc,filename) ifaces else - try - let (old_crc,old_src) = StrMap.find name ifaces in - if old_crc <> crc - then raise(Error(Inconsistent_import(name))) - else ifaces - with Not_found -> - if allow_ext then StrMap.add name (crc,filename) ifaces - else raise (Error(Unavailable_unit name)) + try + let (old_crc,old_src) = StrMap.find name ifaces in + if old_crc <> crc + then raise(Error(Inconsistent_import(name))) + else ifaces + with Not_found -> + if allow_ext then StrMap.add name (crc,filename) ifaces + else raise (Error(Unavailable_unit name)) ) ifaces ui.imports_cmi let check_implems filename ui implems = List.iter (fun (name, crc) -> match name with - |"Out_of_memory" - |"Sys_error" - |"Failure" - |"Invalid_argument" - |"End_of_file" - |"Division_by_zero" - |"Not_found" - |"Match_failure" - |"Stack_overflow" - |"Sys_blocked_io" - |"Assert_failure" - |"Undefined_recursive_module" -> () - | _ -> + |"Out_of_memory" + |"Sys_error" + |"Failure" + |"Invalid_argument" + |"End_of_file" + |"Division_by_zero" + |"Not_found" + |"Match_failure" + |"Stack_overflow" + |"Sys_blocked_io" + |"Assert_failure" + |"Undefined_recursive_module" -> () + | _ -> try - let (old_crc,old_src,state) = StrMap.find name implems in - if crc <> cmx_not_found_crc && old_crc <> crc - then raise(Error(Inconsistent_implementation(name))) - else match state with - | Check_inited i -> - if ndl_globals_inited() < i - then raise(Error(Unavailable_unit name)) - | Loaded -> () + let (old_crc,old_src,state) = StrMap.find name implems in + if crc <> cmx_not_found_crc && old_crc <> crc + then raise(Error(Inconsistent_implementation(name))) + else match state with + | Check_inited i -> + if ndl_globals_inited() < i + then raise(Error(Unavailable_unit name)) + | Loaded -> () with Not_found -> - raise (Error(Unavailable_unit name)) + raise (Error(Unavailable_unit name)) ) ui.imports_cmx let loadunits filename handle units state = @@ -178,8 +178,8 @@ let loadunits filename handle units state = let new_implems = List.fold_left (fun accu ui -> - check_implems filename ui accu; - StrMap.add ui.name (ui.crc,filename,Loaded) accu) + check_implems filename ui accu; + StrMap.add ui.name (ui.crc,filename,Loaded) accu) state.implems units in let defines = List.flatten (List.map (fun ui -> ui.defines) units) in @@ -203,8 +203,8 @@ let allow_only names = let ifaces = List.fold_left (fun ifaces name -> - try StrMap.add name (StrMap.find name old) ifaces - with Not_found -> ifaces) + try StrMap.add name (StrMap.find name old) ifaces + with Not_found -> ifaces) StrMap.empty names in global_state := { !global_state with ifaces = ifaces }; allow_extension := false diff --git a/otherlibs/graph/color.c b/otherlibs/graph/color.c index 57a9dcd2ff..0dc2967071 100644 --- a/otherlibs/graph/color.c +++ b/otherlibs/graph/color.c @@ -70,23 +70,23 @@ void caml_gr_init_direct_rgb_to_pixel(void) { Visual *visual; int i; - + visual = DefaultVisual(caml_gr_display,caml_gr_screen); - + if ( visual->class == TrueColor || visual->class == DirectColor ){ caml_gr_red_mask = visual->red_mask; caml_gr_green_mask = visual->green_mask; caml_gr_blue_mask = visual->blue_mask; - + #ifdef QUICKCOLORDEBUG - fprintf(stderr, "visual %lx %lx %lx\n", - caml_gr_red_mask, - caml_gr_green_mask, + fprintf(stderr, "visual %lx %lx %lx\n", + caml_gr_red_mask, + caml_gr_green_mask, caml_gr_blue_mask); #endif - caml_gr_get_shifts(caml_gr_red_mask, &caml_gr_red_l, &caml_gr_red_r); + caml_gr_get_shifts(caml_gr_red_mask, &caml_gr_red_l, &caml_gr_red_r); #ifdef QUICKCOLORDEBUG fprintf(stderr, "red %d %d\n", caml_gr_red_l, caml_gr_red_r); #endif @@ -94,7 +94,7 @@ void caml_gr_init_direct_rgb_to_pixel(void) caml_gr_red_vals[i] = (((i << 8) + i) >> caml_gr_red_r) << caml_gr_red_l; } - caml_gr_get_shifts(caml_gr_green_mask, &caml_gr_green_l, &caml_gr_green_r); + caml_gr_get_shifts(caml_gr_green_mask, &caml_gr_green_l, &caml_gr_green_r); #ifdef QUICKCOLORDEBUG fprintf(stderr, "green %d %d\n", caml_gr_green_l, caml_gr_green_r); #endif @@ -102,16 +102,16 @@ void caml_gr_init_direct_rgb_to_pixel(void) caml_gr_green_vals[i] = (((i << 8) + i) >> caml_gr_green_r) << caml_gr_green_l; } - caml_gr_get_shifts(caml_gr_blue_mask, &caml_gr_blue_l, &caml_gr_blue_r); + caml_gr_get_shifts(caml_gr_blue_mask, &caml_gr_blue_l, &caml_gr_blue_r); #ifdef QUICKCOLORDEBUG fprintf(stderr, "blue %d %d\n", caml_gr_blue_l, caml_gr_blue_r); #endif for(i=0; i<256; i++){ caml_gr_blue_vals[i] = (((i << 8) + i) >> caml_gr_blue_r) << caml_gr_blue_l; } - - if( caml_gr_red_l < 0 || caml_gr_red_r < 0 || - caml_gr_green_l < 0 || caml_gr_green_r < 0 || + + if( caml_gr_red_l < 0 || caml_gr_red_r < 0 || + caml_gr_green_l < 0 || caml_gr_green_r < 0 || caml_gr_blue_l < 0 || caml_gr_blue_r < 0 ){ #ifdef QUICKCOLORDEBUG fprintf(stderr, "Damn, boost failed\n"); @@ -186,7 +186,7 @@ unsigned long caml_gr_pixel_rgb(int rgb) int caml_gr_rgb_pixel(long unsigned int pixel) { register int r,g,b; - + XColor color; int i; diff --git a/otherlibs/graph/events.c b/otherlibs/graph/events.c index 069fa486aa..d9563a3970 100644 --- a/otherlibs/graph/events.c +++ b/otherlibs/graph/events.c @@ -165,7 +165,7 @@ static value caml_gr_wait_event_poll(void) mouse_x = -1; mouse_y = -1; } - button = modifiers & (Button1Mask | Button2Mask | Button3Mask + button = modifiers & (Button1Mask | Button2Mask | Button3Mask | Button4Mask | Button5Mask); /* Look inside event queue for pending KeyPress events */ key = 0; diff --git a/otherlibs/graph/graphics.ml b/otherlibs/graph/graphics.ml index 581f13f669..96a2471612 100644 --- a/otherlibs/graph/graphics.ml +++ b/otherlibs/graph/graphics.ml @@ -253,4 +253,3 @@ let curveto b c (x, y as d) = draw_poly_line (Array.of_list (List.map int_point points)); moveto x y;; - diff --git a/otherlibs/graph/graphics.mli b/otherlibs/graph/graphics.mli index b5b3ffc31b..23d61a39aa 100644 --- a/otherlibs/graph/graphics.mli +++ b/otherlibs/graph/graphics.mli @@ -193,12 +193,12 @@ external draw_string : string -> unit = "caml_gr_draw_string" external set_font : string -> unit = "caml_gr_set_font" (** Set the font used for drawing text. - The interpretation of the argument to [set_font] + The interpretation of the argument to [set_font] is implementation-dependent. *) val set_text_size : int -> unit (** Set the character size used for drawing text. - The interpretation of the argument to [set_text_size] + The interpretation of the argument to [set_text_size] is implementation-dependent. *) external text_size : string -> int * int = "caml_gr_text_size" @@ -281,7 +281,7 @@ type status = mouse_y : int; (** Y coordinate of the mouse *) button : bool; (** true if a mouse button is pressed *) keypressed : bool; (** true if a key has been pressed *) - key : char; (** the character for the key pressed *) + key : char; (** the character for the key pressed *) } (** To report events. *) @@ -375,5 +375,3 @@ external remember_mode : bool -> unit = "caml_gr_remember_mode" unaffected by drawings. This occurs independently of drawing onto the graphics window (see the function {!Graphics.display_mode} above). Default remember mode is on. *) - - diff --git a/otherlibs/graph/graphicsX11.ml b/otherlibs/graph/graphicsX11.ml index 5b0b759fed..85f5a43605 100644 --- a/otherlibs/graph/graphicsX11.ml +++ b/otherlibs/graph/graphicsX11.ml @@ -21,7 +21,7 @@ external window_id : unit -> window_id = "caml_gr_window_id" let subwindows = Hashtbl.create 13 -external open_subwindow : int -> int -> int -> int -> window_id +external open_subwindow : int -> int -> int -> int -> window_id = "caml_gr_open_subwindow" external close_subwindow : window_id -> unit = "caml_gr_close_subwindow" @@ -31,7 +31,7 @@ let open_subwindow ~x ~y ~width ~height = Hashtbl.add subwindows wid (); wid ;; - + let close_subwindow wid = if Hashtbl.mem subwindows wid then begin close_subwindow wid; @@ -39,4 +39,3 @@ let close_subwindow wid = end else raise (Graphics.Graphic_failure ("close_subwindow: no such subwindow: " ^ wid)) ;; - diff --git a/otherlibs/graph/graphicsX11.mli b/otherlibs/graph/graphicsX11.mli index ff55adf668..1118253711 100644 --- a/otherlibs/graph/graphicsX11.mli +++ b/otherlibs/graph/graphicsX11.mli @@ -19,7 +19,7 @@ type window_id = string val window_id : unit -> window_id (** Return the unique identifier of the Caml graphics window. - The returned string is an unsigned 32 bits integer + The returned string is an unsigned 32 bits integer in decimal form. *) val open_subwindow : x:int -> y:int -> width:int -> height:int -> window_id @@ -28,4 +28,3 @@ val open_subwindow : x:int -> y:int -> width:int -> height:int -> window_id val close_subwindow : window_id -> unit (** Close the sub-window having the given identifier. *) - diff --git a/otherlibs/graph/libgraph.h b/otherlibs/graph/libgraph.h index 322a036bd6..d2df1c1ae0 100644 --- a/otherlibs/graph/libgraph.h +++ b/otherlibs/graph/libgraph.h @@ -30,7 +30,7 @@ extern Colormap caml_gr_colormap; /* The color map */ extern struct canvas caml_gr_window; /* The graphics window */ extern struct canvas caml_gr_bstore; /* The pixmap used for backing store */ extern int caml_gr_white, caml_gr_black; /* Black and white pixels for X */ -extern int caml_gr_background; /* Background color for X +extern int caml_gr_background; /* Background color for X (used for CAML color -1) */ extern Bool caml_gr_display_modeflag; /* Display-mode flag */ extern Bool caml_gr_remember_modeflag; /* Remember-mode flag */ diff --git a/otherlibs/graph/point_col.c b/otherlibs/graph/point_col.c index ffcdc2100e..473dae7d08 100644 --- a/otherlibs/graph/point_col.c +++ b/otherlibs/graph/point_col.c @@ -28,5 +28,3 @@ value caml_gr_point_color(value vx, value vy) XDestroyImage(im); return Val_int(rgb); } - - diff --git a/otherlibs/labltk/Makefile b/otherlibs/labltk/Makefile index 358de5b330..22e09ccbe8 100644 --- a/otherlibs/labltk/Makefile +++ b/otherlibs/labltk/Makefile @@ -52,7 +52,7 @@ examples_labltk: examples_camltk: cd examples_camltk; $(MAKE) all -install: +install: cd support; $(MAKE) install cd lib; $(MAKE) install cd labltk; $(MAKE) install @@ -72,7 +72,7 @@ installopt: cd frx; $(MAKE) installopt cd tkanim; $(MAKE) installopt -partialclean clean: +partialclean clean: for d in $(SUBDIRS); do \ cd $$d; $(MAKE) -f Makefile clean; cd ..; \ done diff --git a/otherlibs/labltk/Makefile.nt b/otherlibs/labltk/Makefile.nt index 45d539192a..765fabafc9 100644 --- a/otherlibs/labltk/Makefile.nt +++ b/otherlibs/labltk/Makefile.nt @@ -40,7 +40,7 @@ examples_labltk: examples_camltk: cd examples_camltk; $(MAKE) all -install: +install: cd labltk ; $(MAKEREC) install cd camltk ; $(MAKEREC) install cd lib ; $(MAKEREC) install @@ -60,5 +60,5 @@ installopt: cd frx ; $(MAKEREC) installopt cd tkanim ; $(MAKEREC) installopt -partialclean clean: +partialclean clean: for d in $(SUBDIRS); do $(MAKEREC) -C $$d clean; done diff --git a/otherlibs/labltk/README b/otherlibs/labltk/README index 6f63b4a4dd..b556d2b3e8 100644 --- a/otherlibs/labltk/README +++ b/otherlibs/labltk/README @@ -15,17 +15,17 @@ mlTk = CamlTk + LablTk ====================== There existed two parallel Tcl/Tk interfaces for O'Caml, CamlTk and LablTk. -CamlTk uses classical features only, therefore it is easy to understand for +CamlTk uses classical features only, therefore it is easy to understand for the beginners of ML. It makes many conservative O'Caml gurus also happy. -LablTk, on the other hand, uses rather newer features of O'Caml, the labeled +LablTk, on the other hand, uses rather newer features of O'Caml, the labeled optional arguments and polymorphic variants. Its syntax has much more Tcl/Tk script flavor, but provides more powerful typing than CamlTk at the same time -(i.e. less run time type checking of widgets). -Until now, these two interfaces have been distributed and maintained -independently. +(i.e. less run time type checking of widgets). +Until now, these two interfaces have been distributed and maintained +independently. mlTk unifies these libraries into one. Since mlTk provides the both API's, -both CamlTk and LablTk users can compile their applications with mlTk, +both CamlTk and LablTk users can compile their applications with mlTk, just with little fixes. REQUIREMENTS @@ -48,51 +48,51 @@ INSTALLATION 1. Compile O'Caml (= make world). If you want, also make opt. -2. Untar this mlTk distribution in the otherlibs directory, just like +2. Untar this mlTk distribution in the otherlibs directory, just like the labltk source tree. 3. change directory to otherlibs/mltk, and make (and make opt) 4. To install the library, make install (and make installopt) -To compile mlTk, you need the O'Caml source tree, since mltk/camlbrowser +To compile mlTk, you need the O'Caml source tree, since mltk/camlbrowser requires some modules of O'Caml. If you are not interested in camlbrowser, you can compile mlTk without the O'Caml source tree, but you have to modify support/Makefile.common. - + Compile your CamlTk/LablTk applications with mlTk ================================================= * General -The names of the additional libraries libjpf and libfrx are changed +The names of the additional libraries libjpf and libfrx are changed to jpflib and frxlib respectively, to avoid the library name space confusion. * LablTk users -Just change the occurrences of labltk in your Makefiles to mltk +Just change the occurrences of labltk in your Makefiles to mltk (i.e. -I +labltk => -I +mltk, labltk.cma => mltk.cma, and so on) Since the API functions are 100% compatible, you need not to change -your .ml files. +your .ml files. * CamlTk users - Makefiles : apply the same modification explained above for LablTk users. - - open Camltk : The API modules and functions are stored in the modules + - open Camltk : The API modules and functions are stored in the modules Camltk. Therefore you need to replace the module name Tk to Camltk. - For example, open Tk => open Camltk. + For example, open Tk => open Camltk. open Camltk (* instead of open Tk *) - + let t = openTk ();; let b = Button.create t [];; - - - You may also need to open the Camltk module explicitly, when your - original module source contain no open Tk phrase. Widget and the other - Tcl/Tk related types are now under Camltk. (e.g. Widget.widget is now - Camltk.Widget.widget) Add open Camltk at the beginning of .mli files, + + - You may also need to open the Camltk module explicitly, when your + original module source contain no open Tk phrase. Widget and the other + Tcl/Tk related types are now under Camltk. (e.g. Widget.widget is now + Camltk.Widget.widget) Add open Camltk at the beginning of .mli files, if these types are used: open Camltk (* added for compiling under mlTk *) @@ -101,7 +101,7 @@ your .ml files. - Eta expansion to flush optional arguments at registering callbacks. Functions with the _displayof suffix are unified with their non-displayof - versions, using optional labeled arguments. For example, Bell.ring + versions, using optional labeled arguments. For example, Bell.ring had/have the following types: before: Bell.ring : unit -> unit @@ -121,9 +121,9 @@ a widget library written in the different API from you use, you need to do it. (It will be confusing, but easier than porting the library itself from one to the other API.) -For the users who mainly use LablTk API, CamlTk API is available -in the modules start with 'C'. For example, the source file of -the CamlTk button widget functions is CButton (and exported also as +For the users who mainly use LablTk API, CamlTk API is available +in the modules start with 'C'. For example, the source file of +the CamlTk button widget functions is CButton (and exported also as Camltk.Button). For the users who mainly use CamlTk API, LablTk API modules are exported @@ -144,9 +144,8 @@ type is different from the context type, a run-time exception is raised. let t = openTk ();; (* t is LablTk widget, toplevel widget *) (* CButton.create takes [any widget]; [t] must be coerced to the type. *) - let caml_b = CButton.create (coe t) [];; + let caml_b = CButton.create (coe t) [];; (* caml_b is [any widget], must be explicitly typed as [button widget], when it is used with LablTk API functions *) let b = Labltk.button caml_b in (* recover the type [button widget] *) - ... - + ... diff --git a/otherlibs/labltk/Widgets.src b/otherlibs/labltk/Widgets.src index e59c435438..abf015a275 100644 --- a/otherlibs/labltk/Widgets.src +++ b/otherlibs/labltk/Widgets.src @@ -3,14 +3,14 @@ type Widget external % cget will probably never be implemented with verifications function (string) cgets [widget; "cget"; string] -% another version with some hack is +% another version with some hack is type options_constrs external function (string) cget [widget; "cget"; options_constrs] -% constructors of type options_constrs are of the form C<c> +% constructors of type options_constrs are of the form C<c> % where <c> is an option constructor (e.g. CBackground) %%%%% Some types for standard options of widgets -type Anchor { +type Anchor { NW ["nw"] N ["n"] NE ["ne"] W ["w"] Center ["center"] E ["e"] SW ["sw"] S ["s"] SE ["se"] @@ -44,18 +44,18 @@ variant type Image { ##endif -type Justification { +type Justification { Justify_Left ["left"] Justify_Center ["center"] Justify_Right ["right"] } -type Orientation { +type Orientation { Vertical ["vertical"] - Horizontal ["horizontal"] + Horizontal ["horizontal"] } -type Relief { +type Relief { Raised ["raised"] Sunken ["sunken"] Flat ["flat"] @@ -183,7 +183,7 @@ module Imagebitmap { %%%%% button(n) -type State { +type State { Normal ["normal"] Active ["active"] Disabled ["disabled"] @@ -222,7 +222,7 @@ widget button { option WrapLength % Widget specific options option Command ["-command"; function ()] - option Default ["-default"; State] + option Default ["-default"; State] option Height ["-height"; Units/int] option State ["-state"; State] option Width ["-width"; Units/int] @@ -258,7 +258,7 @@ type SearchSpec { Withtag ["withtag"; TagOrId] } -type ColorMode { +type ColorMode { Color ["color"] Gray ["gray"] Mono ["mono"] @@ -326,20 +326,20 @@ subtype option(image) { } % Line item configuration -type ArrowStyle { +type ArrowStyle { Arrow_None ["none"] Arrow_First ["first"] Arrow_Last ["last"] Arrow_Both ["both"] } -type CapStyle { +type CapStyle { Cap_Butt ["butt"] Cap_Projecting ["projecting"] Cap_Round ["round"] } -type JoinStyle { +type JoinStyle { Join_Bevel ["bevel"] Join_Miter ["miter"] Join_Round ["round"] @@ -379,7 +379,7 @@ subtype option(rectangle) { ##ifndef CAMLTK % Only for Labltk. CanvasTextState is unified as State in Camltk -type CanvasTextState { +type CanvasTextState { Normal ["normal"] Disabled ["disabled"] Hidden ["hidden"] @@ -545,7 +545,7 @@ widget canvas { %%%%% checkbutton(n) -widget checkbutton { +widget checkbutton { % Standard options option ActiveBackground option ActiveForeground @@ -628,7 +628,7 @@ module Dialog { ##ifndef CAMLTK % Only for Labltk. InputState is unified as State in Camltk -type InputState { +type InputState { Normal ["normal"] Disabled ["disabled"] } @@ -721,7 +721,7 @@ type slant { type fontMetrics { Ascent ["-ascent"] - Descent ["-descent"] + Descent ["-descent"] Linespace ["-linespace"] Fixed ["-fixed"] } @@ -738,25 +738,25 @@ subtype options(font) { %% Beware of the order of Compound ! Put it as the first option % Compound ["-compound"; [font list]] % Copy ["-copy"; string] -} +} module Font { - function (string) actual_family ["font"; "actual"; font; + function (string) actual_family ["font"; "actual"; font; ?displayof:["-displayof"; widget]; "-family"] - function (int) actual_size ["font"; "actual"; font; + function (int) actual_size ["font"; "actual"; font; ?displayof:["-displayof"; widget]; "-size"] - function (string) actual_weight ["font"; "actual"; font; + function (string) actual_weight ["font"; "actual"; font; ?displayof:["-displayof"; widget]; "-weight"] - function (string) actual_slant ["font"; "actual"; font; + function (string) actual_slant ["font"; "actual"; font; ?displayof:["-displayof"; widget]; "-slant"] - function (bool) actual_underline ["font"; "actual"; font; + function (bool) actual_underline ["font"; "actual"; font; ?displayof:["-displayof"; widget]; "-underline"] - function (bool) actual_overstrike ["font"; "actual"; font; + function (bool) actual_overstrike ["font"; "actual"; font; ?displayof:["-displayof"; widget]; "-overstrike"] @@ -767,22 +767,22 @@ module Font { ##endif function () delete ["font"; "delete"; font] function (string list) families ["font"; "families"; - ?displayof:["-displayof"; widget]] + ?displayof:["-displayof"; widget]] ##ifdef CAMLTK function (string list) families_displayof ["font"; "families"; "-displayof"; widget] ##endif function (int) measure ["font"; "measure"; font; string; - ?displayof:["-displayof"; widget]] + ?displayof:["-displayof"; widget]] ##ifdef CAMLTK function (int) measure_displayof ["font"; "measure"; font; "-displayof"; widget; string ] ##endif function (int) metrics ["font"; "metrics"; font; ?displayof:["-displayof"; widget]; - fontMetrics ] + fontMetrics ] ##ifdef CAMLTK - function (int) metrics_displayof ["font"; "metrics"; font; + function (int) metrics_displayof ["font"; "metrics"; font; "-displayof"; widget; fontMetrics ] ##endif @@ -800,7 +800,7 @@ type Colormap { % Visual classes are: directcolor, grayscale, greyscale, pseudocolor, % staticcolor, staticgray, staticgrey, truecolor type Visual { - ClassVisual (Clas) [[string; int]] + ClassVisual (Clas) [[string; int]] DefaultVisual ["default"] WidgetVisual (Widget) [widget] BestDepth (Bestdepth) [["best"; int]] @@ -825,7 +825,7 @@ widget frame { option Clas ["-class"; string] ##endif option Colormap ["-colormap"; Colormap] - option Container ["-container"; bool] + option Container ["-container"; bool] option Height option Visual ["-visual"; Visual] option Width @@ -862,7 +862,7 @@ module Grab { subtype option(rowcolumnconfigure) { Minsize ["-minsize"; Units/int] Weight ["-weight"; int] - Pad ["-pad"; Units/int] + Pad ["-pad"; Units/int] } subtype option(grid) { @@ -873,8 +873,8 @@ subtype option(grid) { IPadY ["-ipady"; Units/int] PadX PadY - Row ["-row"; int] - RowSpan ["-rowspan"; int] + Row ["-row"; int] + RowSpan ["-rowspan"; int] Sticky ["-sticky"; string] } @@ -885,7 +885,7 @@ module Grid { function (int,int,int,int) bbox ["grid"; "bbox"; widget] function (int,int,int,int) bbox_cell ["grid"; "bbox"; widget; column: int; row: int] function (int,int,int,int) bbox_span ["grid"; "bbox"; widget; column1: int; row1: int; column2: int; row2: int] - function () column_configure + function () column_configure ["grid"; "columnconfigure"; widget; int; option(rowcolumnconfigure) list] function () configure ["grid"; "configure"; widget list; option(grid) list] @@ -898,7 +898,7 @@ module Grid { function (int,int) location ["grid"; "location"; widget; x:Units/int; y:Units/int] function (bool) propagate_get ["grid"; "propagate"; widget] function () propagate_set ["grid"; "propagate"; widget; bool] - function () row_configure + function () row_configure ["grid"; "rowconfigure"; widget; int; option(rowcolumnconfigure) list] function (string) row_configure_get ["grid"; "rowconfigure"; widget; int] function (int,int) size ["grid"; "size"; widget] @@ -1056,7 +1056,7 @@ subtype option(menuentry) { ActiveBackground ActiveForeground Accelerator ["-accelerator"; string] - Background + Background Bitmap ColumnBreak ["-columnbreak"; bool] Command @@ -1093,7 +1093,7 @@ subtype option(menucascade) { Background Bitmap ColumnBreak Command Font Foreground HideMargin ##ifdef CAMLTK - ImageBitmap ImagePhoto + ImageBitmap ImagePhoto ##else Image ##endif @@ -1109,7 +1109,7 @@ subtype option(menuradio) { ##else Image SelectImage ##endif - IndicatorOn Label SelectColor + IndicatorOn Label SelectColor State UnderlinedChar Value Variable } @@ -1120,7 +1120,7 @@ subtype option(menucheck) { ##ifdef CAMLTK ImageBitmap SelectImageBitmap ImagePhoto SelectImagePhoto ##else - Image SelectImage + Image SelectImage ##endif IndicatorOn Label OffValue OnValue SelectColor @@ -1143,7 +1143,7 @@ type menuType { Menu_Menubar ["menubar"] Menu_Tearoff ["tearoff"] Menu_Normal ["normal"] -} +} % Separators and tearoffs don't have options @@ -1212,7 +1212,7 @@ type menubuttonDirection { Dir_Above ["above"] Dir_Below ["below"] Dir_Left ["left"] - Dir_Right ["right"] + Dir_Right ["right"] } widget menubutton { @@ -1246,7 +1246,7 @@ widget menubutton { option UnderlinedChar option WrapLength % Widget specific options - option Direction ["-direction"; menubuttonDirection ] + option Direction ["-direction"; menubuttonDirection ] option Height option IndicatorOn option Menu ["-menu"; widget(menu)] @@ -1330,14 +1330,14 @@ module Optionmenu { %%%%% pack(n) -type Side { +type Side { Side_Left ["left"] Side_Right ["right"] Side_Top ["top"] Side_Bottom ["bottom"] } -type FillMode { +type FillMode { Fill_None ["none"] Fill_X ["x"] Fill_Y ["y"] @@ -1415,7 +1415,7 @@ subtype photo(copy) { } subtype photo(put) { - ImgTo + ImgTo } subtype photo(read) { @@ -1464,8 +1464,8 @@ type BorderMode { } subtype option(place) { - In - X + In + X RelX ["-relx"; float] Y RelY ["-rely"; float] @@ -1699,15 +1699,15 @@ subtype icccm(selection_ownset) { } subtype icccm(selection_handle) { - Selection - ICCCMType + Selection + ICCCMType ICCCMFormat ["-format"; string] } module Selection { function () clear ["selection"; "clear"; icccm(selection_clear) list] function (string) get ["selection"; "get"; icccm(selection_get) list] - + % function () handle_set ["selection"; "handle"; icccm(selection_handle) list; widget; function(int,int)] external handle_set "builtin/selection_handle_set" unsafe function (widget) own_get ["selection"; "own"; icccm(selection_clear) list] @@ -1720,7 +1720,7 @@ module Selection { %%%%% send(n) type SendOption { SendDisplayOf ["-displayof"; widget] % DisplayOf is used for icccm ! - SendAsync ["-async"] + SendAsync ["-async"] } unsafe function () send ["send"; SendOption list; "--"; app: string; command: string list] @@ -1739,13 +1739,13 @@ type TabType { TabNumeric [Units/int; "numeric"] } -type WrapMode { +type WrapMode { WrapNone ["none"] WrapChar ["char"] WrapWord ["word"] } -type Comparison { +type Comparison { LT (Lt) ["<"] LE (Le) ["<="] EQ (Eq) ["=="] @@ -1802,7 +1802,7 @@ type text_dump { DumpMark ["-mark"] DumpTag ["-tag"] DumpText ["-text"] - DumpWindow ["-window"] + DumpWindow ["-window"] } widget text { @@ -1858,7 +1858,7 @@ widget text { % require result parser function (string list) dump [widget(text); "dump"; text_dump list; start: TextIndex; stop: TextIndex] function (string list) dump_char [widget(text); "dump"; text_dump list; index: TextIndex] - + function (string) get [widget(text); "get"; start: TextIndex; stop: TextIndex] function (string) get_char [widget(text); "get"; index: TextIndex] function () image_configure @@ -1874,7 +1874,7 @@ widget text { ##else function () insert [widget(text); "insert"; index: TextIndex; text: string; ?tags: [TextTag list]] ##endif - % Mark + % Mark function () mark_gravity_set [widget(text); "mark"; "gravity"; mark: TextMark; direction: MarkDirection] function (MarkDirection) mark_gravity_get [widget(text); "mark"; "gravity"; mark: TextMark] function (TextMark list) mark_names [widget(text); "mark"; "names"] @@ -1882,7 +1882,7 @@ widget text { function (TextMark) mark_previous [widget(text); "mark"; "previous"; index: TextIndex] function () mark_set [widget(text); "mark"; "set"; mark: TextMark; index: TextIndex] function () mark_unset [widget(text); "mark"; "unset"; marks: TextMark list] - % Scan + % Scan function () scan_mark [widget(text); "scan"; "mark"; x: int; y: int] function () scan_dragto [widget(text); "scan"; "dragto"; x: int; y: int] ##ifdef CAMLTK @@ -1963,7 +1963,7 @@ subtype option(texttag) { Spacing1 Spacing2 Spacing3 - Tabs + Tabs Underline ["-underline"; bool] Wrap ["-wrap"; WrapMode] } @@ -1980,9 +1980,9 @@ unsafe function () scaling_set ["tk"; "scaling"; ?displayof:["-displayof"; widge subtype option(chooseColor){ InitialColor ["-initialcolor"; Color] Parent ["-parent"; widget] - Title ["-title"; string] + Title ["-title"; string] } -function (Color) chooseColor ["tk_chooseColor"; option(chooseColor) list] +function (Color) chooseColor ["tk_chooseColor"; option(chooseColor) list] %%%%% tkwait(n) module Tkwait { @@ -2015,7 +2015,7 @@ widget toplevel { option Colormap option Container ["-container"; bool] option Height - option Menu + option Menu option Screen ["-screen"; string] option Use ["-use"; string] % must be hexadecimal "0x????" option Visual @@ -2095,7 +2095,7 @@ module Winfo { function (bool) viewable ["winfo"; "viewable"; widget] function (string) visual ["winfo"; "visual"; widget] function (int) visualid ["winfo"; "visualid"; widget] - % need special parser + % need special parser function (string) visualsavailable ["winfo"; "visualsavailable"; widget; ?includeids: [int list]] function (int) vrootheight ["winfo"; "vrootheight"; widget] function (int) vrootwidth ["winfo"; "vrootwidth"; widget] @@ -2128,7 +2128,7 @@ module Wm { function () client_set ["wm"; "client"; widget(toplevel); name: string] function (string) client_get ["wm"; "client"; widget(toplevel)] %%% WM_COLORMAP_WINDOWS - function () colormapwindows_set + function () colormapwindows_set ["wm"; "colormapwindows"; widget(toplevel); [windows: widget list]] unsafe function (widget list) colormapwindows_get ["wm"; "colormapwindows"; widget(toplevel)] @@ -2225,7 +2225,7 @@ type FilePattern external subtype option(getFile) { DefaultExtension ["-defaultextension"; string] - FileTypes ["-filetypes"; [FilePattern list]] + FileTypes ["-filetypes"; [FilePattern list]] InitialDir ["-initialdir"; string] InitialFile ["-initialfile"; string] Parent ["-parent"; widget] @@ -2247,7 +2247,7 @@ type MessageType { Ok ["ok"] OkCancel ["okcancel"] RetryCancel ["retrycancel"] - YesNo ["yesno"] + YesNo ["yesno"] YesNoCancel ["yesnocancel"] } subtype option(messageBox) { @@ -2255,12 +2255,12 @@ subtype option(messageBox) { MessageIcon ["-icon"; MessageIcon] Message ["-message"; string] Parent - Title + Title MessageType ["-type"; MessageType] } function (string) messageBox ["tk_messageBox"; option(messageBox) list] - + module Tkvars { function (string) library ["$tk_library"] function (string) patchLevel ["$tk_patchLevel"] @@ -2278,11 +2278,11 @@ module Pixmap { %%% encodings : require if you want write your application international module Encoding { - function (string) convertfrom ["encoding"; "convertfrom"; + function (string) convertfrom ["encoding"; "convertfrom"; ?encoding: [string]; string] function (string) convertto ["encoding"; "convertto"; - ?encoding: [string]; string] + ?encoding: [string]; string] function (string list) names ["encoding"; "names"] function () system_set ["encoding"; "system"; string] function (string) system_get ["encoding"; "system"] -} +} diff --git a/otherlibs/labltk/browser/.depend b/otherlibs/labltk/browser/.depend index 4912011638..4438a1dd83 100644 --- a/otherlibs/labltk/browser/.depend +++ b/otherlibs/labltk/browser/.depend @@ -1,66 +1,66 @@ editor.cmo: viewer.cmi typecheck.cmi shell.cmi setpath.cmi searchpos.cmi \ searchid.cmi mytypes.cmi lexical.cmi jg_toplevel.cmo jg_tk.cmo \ jg_text.cmi jg_message.cmi jg_menu.cmo jg_button.cmo jg_bind.cmi \ - fileselect.cmi editor.cmi + fileselect.cmi editor.cmi editor.cmx: viewer.cmx typecheck.cmx shell.cmx setpath.cmx searchpos.cmx \ searchid.cmx mytypes.cmi lexical.cmx jg_toplevel.cmx jg_tk.cmx \ jg_text.cmx jg_message.cmx jg_menu.cmx jg_button.cmx jg_bind.cmx \ - fileselect.cmx editor.cmi + fileselect.cmx editor.cmi fileselect.cmo: useunix.cmi setpath.cmi list2.cmo jg_toplevel.cmo jg_memo.cmi \ - jg_entry.cmo jg_box.cmo fileselect.cmi + jg_entry.cmo jg_box.cmo fileselect.cmi fileselect.cmx: useunix.cmx setpath.cmx list2.cmx jg_toplevel.cmx jg_memo.cmx \ - jg_entry.cmx jg_box.cmx fileselect.cmi -jg_bind.cmo: jg_bind.cmi -jg_bind.cmx: jg_bind.cmi -jg_box.cmo: jg_completion.cmi jg_bind.cmi -jg_box.cmx: jg_completion.cmx jg_bind.cmx -jg_completion.cmo: jg_completion.cmi -jg_completion.cmx: jg_completion.cmi -jg_config.cmo: jg_tk.cmo jg_config.cmi -jg_config.cmx: jg_tk.cmx jg_config.cmi -jg_entry.cmo: jg_bind.cmi -jg_entry.cmx: jg_bind.cmx -jg_memo.cmo: jg_memo.cmi -jg_memo.cmx: jg_memo.cmi + jg_entry.cmx jg_box.cmx fileselect.cmi +jg_bind.cmo: jg_bind.cmi +jg_bind.cmx: jg_bind.cmi +jg_box.cmo: jg_completion.cmi jg_bind.cmi +jg_box.cmx: jg_completion.cmx jg_bind.cmx +jg_completion.cmo: jg_completion.cmi +jg_completion.cmx: jg_completion.cmi +jg_config.cmo: jg_tk.cmo jg_config.cmi +jg_config.cmx: jg_tk.cmx jg_config.cmi +jg_entry.cmo: jg_bind.cmi +jg_entry.cmx: jg_bind.cmx +jg_memo.cmo: jg_memo.cmi +jg_memo.cmx: jg_memo.cmi jg_message.cmo: jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_bind.cmi \ - jg_message.cmi + jg_message.cmi jg_message.cmx: jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_bind.cmx \ - jg_message.cmi -jg_multibox.cmo: jg_completion.cmi jg_bind.cmi jg_multibox.cmi -jg_multibox.cmx: jg_completion.cmx jg_bind.cmx jg_multibox.cmi -jg_text.cmo: jg_toplevel.cmo jg_tk.cmo jg_button.cmo jg_bind.cmi jg_text.cmi -jg_text.cmx: jg_toplevel.cmx jg_tk.cmx jg_button.cmx jg_bind.cmx jg_text.cmi -lexical.cmo: jg_tk.cmo lexical.cmi -lexical.cmx: jg_tk.cmx lexical.cmi + jg_message.cmi +jg_multibox.cmo: jg_completion.cmi jg_bind.cmi jg_multibox.cmi +jg_multibox.cmx: jg_completion.cmx jg_bind.cmx jg_multibox.cmi +jg_text.cmo: jg_toplevel.cmo jg_tk.cmo jg_button.cmo jg_bind.cmi jg_text.cmi +jg_text.cmx: jg_toplevel.cmx jg_tk.cmx jg_button.cmx jg_bind.cmx jg_text.cmi +lexical.cmo: jg_tk.cmo lexical.cmi +lexical.cmx: jg_tk.cmx lexical.cmi main.cmo: viewer.cmi shell.cmi searchpos.cmi searchid.cmi jg_config.cmi \ - editor.cmi + editor.cmi main.cmx: viewer.cmx shell.cmx searchpos.cmx searchid.cmx jg_config.cmx \ - editor.cmx -searchid.cmo: list2.cmo searchid.cmi -searchid.cmx: list2.cmx searchid.cmi + editor.cmx +searchid.cmo: list2.cmo searchid.cmi +searchid.cmx: list2.cmx searchid.cmi searchpos.cmo: searchid.cmi lexical.cmi jg_tk.cmo jg_text.cmi jg_message.cmi \ - jg_memo.cmi jg_bind.cmi searchpos.cmi + jg_memo.cmi jg_bind.cmi searchpos.cmi searchpos.cmx: searchid.cmx lexical.cmx jg_tk.cmx jg_text.cmx jg_message.cmx \ - jg_memo.cmx jg_bind.cmx searchpos.cmi + jg_memo.cmx jg_bind.cmx searchpos.cmi setpath.cmo: useunix.cmi list2.cmo jg_toplevel.cmo jg_button.cmo jg_box.cmo \ - jg_bind.cmi setpath.cmi + jg_bind.cmi setpath.cmi setpath.cmx: useunix.cmx list2.cmx jg_toplevel.cmx jg_button.cmx jg_box.cmx \ - jg_bind.cmx setpath.cmi + jg_bind.cmx setpath.cmi shell.cmo: list2.cmo lexical.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi \ - jg_message.cmi jg_menu.cmo jg_memo.cmi fileselect.cmi dummy.cmi shell.cmi + jg_message.cmi jg_menu.cmo jg_memo.cmi fileselect.cmi dummy.cmi shell.cmi shell.cmx: list2.cmx lexical.cmx jg_toplevel.cmx jg_tk.cmx jg_text.cmx \ - jg_message.cmx jg_menu.cmx jg_memo.cmx fileselect.cmx dummy.cmi shell.cmi -typecheck.cmo: mytypes.cmi jg_tk.cmo jg_text.cmi jg_message.cmi typecheck.cmi -typecheck.cmx: mytypes.cmi jg_tk.cmx jg_text.cmx jg_message.cmx typecheck.cmi -useunix.cmo: useunix.cmi -useunix.cmx: useunix.cmi + jg_message.cmx jg_menu.cmx jg_memo.cmx fileselect.cmx dummy.cmi shell.cmi +typecheck.cmo: mytypes.cmi jg_tk.cmo jg_text.cmi jg_message.cmi typecheck.cmi +typecheck.cmx: mytypes.cmi jg_tk.cmx jg_text.cmx jg_message.cmx typecheck.cmi +useunix.cmo: useunix.cmi +useunix.cmx: useunix.cmi viewer.cmo: useunix.cmi shell.cmi setpath.cmi searchpos.cmi searchid.cmi \ mytypes.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_multibox.cmi \ jg_message.cmi jg_menu.cmo jg_entry.cmo jg_completion.cmi jg_button.cmo \ - jg_box.cmo jg_bind.cmi help.cmo viewer.cmi + jg_box.cmo jg_bind.cmi help.cmo viewer.cmi viewer.cmx: useunix.cmx shell.cmx setpath.cmx searchpos.cmx searchid.cmx \ mytypes.cmi jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_multibox.cmx \ jg_message.cmx jg_menu.cmx jg_entry.cmx jg_completion.cmx jg_button.cmx \ - jg_box.cmx jg_bind.cmx help.cmx viewer.cmi -mytypes.cmi: shell.cmi -typecheck.cmi: mytypes.cmi + jg_box.cmx jg_bind.cmx help.cmx viewer.cmi +mytypes.cmi: shell.cmi +typecheck.cmi: mytypes.cmi diff --git a/otherlibs/labltk/browser/Makefile.shared b/otherlibs/labltk/browser/Makefile.shared index c5080b7cf1..484d3d8fa8 100644 --- a/otherlibs/labltk/browser/Makefile.shared +++ b/otherlibs/labltk/browser/Makefile.shared @@ -33,7 +33,7 @@ ocamlbrowser$(EXE): $(TOPDIR)/toplevel/toplevellib.cma jglib.cma $(OBJ) \ ../support/lib$(LIBNAME).$(A) $(CAMLC) -o ocamlbrowser$(EXE) $(INCLUDES) \ $(TOPDIR)/toplevel/toplevellib.cma \ - unix.cma str.cma $(OCAMLBR) $(LIBNAME).cma jglib.cma $(OBJ) + unix.cma str.cma $(OCAMLBR) $(LIBNAME).cma jglib.cma $(OBJ) ocamlbrowser.cma: jglib.cma $(OBJ) $(CAMLC) -a -o $@ -linkall jglib.cma $(OBJ) diff --git a/otherlibs/labltk/browser/fileselect.ml b/otherlibs/labltk/browser/fileselect.ml index cc9e19ff23..22052b4237 100644 --- a/otherlibs/labltk/browser/fileselect.ml +++ b/otherlibs/labltk/browser/fileselect.ml @@ -35,7 +35,7 @@ let caml_dir path = global_replace ~!"\\\\" "/" path else path -let parse_filter s = +let parse_filter s = let s = caml_dir s in (* replace // by / *) let s = global_replace ~!"/+" "/" s in @@ -49,7 +49,7 @@ let parse_filter s = ~!"\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\.$" "" s in (* replace ^/hoge/../ by / *) let s = global_replace ~!"^\\(/\\.\\.\\)+/" "/" s in - if string_match ~!"^\\([^\\*?[]*[/:]\\)\\(.*\\)" s 0 then + if string_match ~!"^\\([^\\*?[]*[/:]\\)\\(.*\\)" s 0 then let dirs = matched_group 1 s and ptrn = matched_group 2 s in @@ -93,7 +93,7 @@ let f ~title ~action:proc ?(dir = Unix.getcwd ()) let may_prefix name = if Filename.is_relative name then concat !current_dir name else name in - + let tl = Jg_toplevel.titled title in Focus.set tl; @@ -124,7 +124,7 @@ let f ~title ~action:proc ?(dir = Unix.getcwd ()) current_pattern := pattern; let filter = if !load_in_path && usepath then pattern else dir ^ pattern in - let directories = get_directories_in_files ~path:dir + let directories = get_directories_in_files ~path:dir (get_files_in_directory dir) in let matched_files = (* get matched file by subshell call. *) if !load_in_path && usepath then @@ -140,7 +140,7 @@ let f ~title ~action:proc ?(dir = Unix.getcwd ()) ~f:(fun acc dir -> List2.exclude dir acc) in Textvariable.set filter_var filter; - Textvariable.set selection_var (dir ^ deffile); + Textvariable.set selection_var (dir ^ deffile); Listbox.delete filter_listbox ~first:(`Num 0) ~last:`End; Listbox.insert filter_listbox ~index:`End ~texts:matched_files; Jg_box.recenter filter_listbox ~index:(`Num 0); @@ -154,7 +154,7 @@ let f ~title ~action:proc ?(dir = Unix.getcwd ()) Jg_box.recenter directory_listbox ~index:(`Num 0) end in - + let selected_files = ref [] in (* used for synchronous mode *) let activate l = Grab.release tl; @@ -170,14 +170,14 @@ let f ~title ~action:proc ?(dir = Unix.getcwd ()) else List.map l ~f:may_prefix in - if sync then + if sync then begin selected_files := l; Textvariable.set sync_var "1" end - else proc l + else proc l in - + (* entries *) let fl = Label.create frm ~text:"Filter" in let sl = Label.create frm ~text:"Selection" in @@ -205,14 +205,14 @@ let f ~title ~action:proc ?(dir = Unix.getcwd ()) configure ~filter:(Textvariable.get filter_var) end and okb = Button.create cfrm ~text:"Ok" ~command: - begin fun () -> - let files = + begin fun () -> + let files = List.map (Listbox.curselection filter_listbox) ~f: begin fun x -> !current_dir ^ Listbox.get filter_listbox ~index:x end in - let files = if files = [] then [Textvariable.get selection_var] + let files = if files = [] then [Textvariable.get selection_var] else files in activate files end @@ -261,7 +261,7 @@ let f ~title ~action:proc ?(dir = Unix.getcwd ()) pack [dfr] ~side:`Right ~fill:`Both ~expand:true; pack [dfrl] ~side:`Top ~anchor:`W; pack [dfrf] ~side:`Top ~fill:`Both ~expand:true; - pack [filter_scrollbar] ~side:`Right ~fill:`Y; + pack [filter_scrollbar] ~side:`Right ~fill:`Y; pack [filter_listbox] ~side:`Left ~fill:`Both ~expand:true; (* selection *) diff --git a/otherlibs/labltk/browser/fileselect.mli b/otherlibs/labltk/browser/fileselect.mli index 75ee582aea..b723c626d5 100644 --- a/otherlibs/labltk/browser/fileselect.mli +++ b/otherlibs/labltk/browser/fileselect.mli @@ -22,7 +22,7 @@ val f : ?file:string -> ?multi:bool -> ?sync:bool -> ?usepath:bool -> unit -> unit -(* action +(* action [] means canceled if multi select is false, then the list is null or a singleton *) diff --git a/otherlibs/labltk/browser/jg_bind.ml b/otherlibs/labltk/browser/jg_bind.ml index 128a88ae55..2e3ec9870b 100644 --- a/otherlibs/labltk/browser/jg_bind.ml +++ b/otherlibs/labltk/browser/jg_bind.ml @@ -16,7 +16,7 @@ open Tk -let enter_focus w = +let enter_focus w = bind w ~events:[`Enter] ~action:(fun _ -> Focus.set w) let escape_destroy ?destroy:tl w = diff --git a/otherlibs/labltk/browser/jg_box.ml b/otherlibs/labltk/browser/jg_box.ml index ac0cb82121..681e79e0bc 100644 --- a/otherlibs/labltk/browser/jg_box.ml +++ b/otherlibs/labltk/browser/jg_box.ml @@ -52,14 +52,14 @@ let add_completion ?action ?wait ?nocase ?(double=true) lb = Jg_bind.enter_focus lb; bind lb ~events:[`KeyPress] ~fields:[`Char] ~action: - begin fun ev -> + begin fun ev -> (* consider only keys producing characters. The callback is called even if you press Shift. *) if ev.ev_Char <> "" then recenter lb ~index:(`Num (comp#add ev.ev_Char)) end; - begin match action with + begin match action with Some action -> bind lb ~events:[`KeyPressDetail "Return"] ~action:(fun _ -> action `Active); diff --git a/otherlibs/labltk/browser/jg_memo.ml b/otherlibs/labltk/browser/jg_memo.ml index c6d7634ac6..e238929a08 100644 --- a/otherlibs/labltk/browser/jg_memo.ml +++ b/otherlibs/labltk/browser/jg_memo.ml @@ -31,5 +31,3 @@ let fast ~f = let data = f key in memo := Cons(key, data, !memo); data - - diff --git a/otherlibs/labltk/browser/jg_message.ml b/otherlibs/labltk/browser/jg_message.ml index 811c52b15b..3c18f193c4 100644 --- a/otherlibs/labltk/browser/jg_message.ml +++ b/otherlibs/labltk/browser/jg_message.ml @@ -90,7 +90,7 @@ let ask ~title ?master ?(no=true) ?(cancel=true) text = and r = ref (`Cancel : [`Yes|`No|`Cancel]) in let accept = Button.create fw ~text:(if no || cancel then "Yes" else "Dismiss") - ~command:(fun () -> r := `Yes; destroy tl) + ~command:(fun () -> r := `Yes; destroy tl) and refuse = Button.create fw ~text:"No" ~command:(fun () -> r := `No; destroy tl) and cancelB = Button.create fw ~text:"Cancel" diff --git a/otherlibs/labltk/browser/jg_multibox.ml b/otherlibs/labltk/browser/jg_multibox.ml index dc905aba6c..febec8e5de 100644 --- a/otherlibs/labltk/browser/jg_multibox.ml +++ b/otherlibs/labltk/browser/jg_multibox.ml @@ -58,7 +58,7 @@ let rec split l ~len = let (cars,r) = first l ~len in let cdrs = split r ~len in List.map2 cars cdrs ~f:(fun a l -> a::l) - + open Tk @@ -168,7 +168,7 @@ let add_scrollbar (box : c) = let add_completion ?action ?wait (box : c) = let comp = new Jg_completion.timed (box#texts) ?wait in box#bind_kbd ~events:[`KeyPress] - ~action:(fun ev ~index -> + ~action:(fun ev ~index -> (* consider only keys producing characters. The callback is called * even if you press Shift. *) if ev.ev_Char <> "" then diff --git a/otherlibs/labltk/browser/jg_toplevel.ml b/otherlibs/labltk/browser/jg_toplevel.ml index c6a2b89593..64b6f54d76 100644 --- a/otherlibs/labltk/browser/jg_toplevel.ml +++ b/otherlibs/labltk/browser/jg_toplevel.ml @@ -17,7 +17,7 @@ open Tk let titled ?iconname title = - let iconname = match iconname with None -> title | Some s -> s in + let iconname = match iconname with None -> title | Some s -> s in let tl = Toplevel.create Widget.default_toplevel in Wm.title_set tl title; Wm.iconname_set tl iconname; diff --git a/otherlibs/labltk/browser/searchid.ml b/otherlibs/labltk/browser/searchid.ml index a06257b99e..2848143904 100644 --- a/otherlibs/labltk/browser/searchid.ml +++ b/otherlibs/labltk/browser/searchid.ml @@ -85,7 +85,7 @@ let rec choose n ~card:l = if n = 1 then List.map l ~f:(fun x -> [x]) else if n = 0 then [[]] else if n > len then [] else - match l with [] -> [] + match l with [] -> [] | a :: l -> List.map (choose (n-1) ~card:l) ~f:(fun l -> a :: l) @ choose n ~card:l @@ -98,7 +98,7 @@ let rec all_args ty = match ty.desc with Tarrow(l, ty1, ty2, _) -> let (tl,ty) = all_args ty2 in ((l,ty1)::tl, ty) | _ -> ([], ty) - + let rec equal ~prefix t1 t2 = match (repr t1).desc, (repr t2).desc with Tvar, Tvar -> true @@ -313,7 +313,7 @@ let search_string_type text ~mode = let start_c = l.loc_start.Lexing.pos_cnum in let end_c = l.loc_end.Lexing.pos_cnum in raise (Error (start_c - 8, end_c - 8)) - + let longident_of_string text = let exploded = ref [] and l = ref 0 in for i = 0 to String.length text - 2 do diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml index 42a3bf9d7f..7b79fff5a3 100644 --- a/otherlibs/labltk/browser/searchpos.ml +++ b/otherlibs/labltk/browser/searchpos.ml @@ -180,7 +180,7 @@ let search_pos_type_decl td ~pos ~env = search_pos_type t2 ~pos ~env end end - + let rec search_pos_signature l ~pos ~env = ignore ( List.fold_left l ~init:env ~f: @@ -205,7 +205,7 @@ let rec search_pos_signature l ~pos ~env = | Psig_exception (_, l) -> List.iter l ~f:(search_pos_type ~pos ~env); add_found_sig (`Type, Lident "exn") ~env ~loc:pt.psig_loc - | Psig_module (_, t) -> + | Psig_module (_, t) -> search_pos_module t ~pos ~env | Psig_recmodule decls -> List.iter decls ~f:(fun (_, t) -> search_pos_module t ~pos ~env) @@ -218,7 +218,7 @@ let rec search_pos_signature l ~pos ~env = | Psig_class_type l -> List.iter l ~f:(fun ci -> search_pos_class_type ci.pci_expr ~pos ~env) - (* The last cases should not happen in generated interfaces *) + (* The last cases should not happen in generated interfaces *) | Psig_open lid -> add_found_sig (`Module, lid) ~env ~loc:pt.psig_loc | Psig_include t -> search_pos_module t ~pos ~env end; @@ -237,7 +237,7 @@ and search_pos_module m ~pos ~env = search_pos_module m ~pos ~env; List.iter l ~f: begin function - _, Pwith_type t -> search_pos_type_decl t ~pos ~env + _, Pwith_type t -> search_pos_type_decl t ~pos ~env | _ -> () end end @@ -438,7 +438,7 @@ and view_signature_item sign ~path ~env = and view_module path ~env = match find_module path env with - Tmty_signature sign -> + Tmty_signature sign -> !view_defined_ref (Searchid.longident_of_path path) ~env | modtype -> let id = ident_of_path path ~default:"M" in diff --git a/otherlibs/labltk/browser/searchpos.mli b/otherlibs/labltk/browser/searchpos.mli index cea3b4602a..b2f89cd81c 100644 --- a/otherlibs/labltk/browser/searchpos.mli +++ b/otherlibs/labltk/browser/searchpos.mli @@ -75,4 +75,3 @@ val parent_path : Path.t -> Path.t option val string_of_path : Path.t -> string val string_of_longident : Longident.t -> string val lines_to_chars : int -> text:string -> int - diff --git a/otherlibs/labltk/browser/setpath.ml b/otherlibs/labltk/browser/setpath.ml index 3e7470dfc3..1a41b573b5 100644 --- a/otherlibs/labltk/browser/setpath.ml +++ b/otherlibs/labltk/browser/setpath.ml @@ -55,7 +55,7 @@ let add_to_path ~dirs ?(base="") box = if dirs = [] then [base] else List.map dirs ~f: begin function - "." -> base + "." -> base | ".." -> Filename.dirname base | x -> Filename.concat base x end @@ -129,7 +129,7 @@ let f ~dir = in bind dirbox ~events:[`KeyPressDetail "Insert"] ~action:add_paths; bind pathbox ~events:[`KeyPressDetail "Delete"] ~action:remove_paths; - + let dirlab = Label.create dirs ~text:"Directories" and pathlab = Label.create path ~text:"Load path" and addbutton = Button.create dirs ~text:"Add to path" ~command:add_paths diff --git a/otherlibs/labltk/browser/setpath.mli b/otherlibs/labltk/browser/setpath.mli index f5e70090fd..22bf5dc583 100644 --- a/otherlibs/labltk/browser/setpath.mli +++ b/otherlibs/labltk/browser/setpath.mli @@ -22,4 +22,4 @@ val exec_update_hooks : unit -> unit val set : dir:string -> unit val f : dir:string -> toplevel widget - (* edit the load path *) + (* edit the load path *) diff --git a/otherlibs/labltk/browser/useunix.ml b/otherlibs/labltk/browser/useunix.ml index 4998bbd66c..666f866f02 100644 --- a/otherlibs/labltk/browser/useunix.ml +++ b/otherlibs/labltk/browser/useunix.ml @@ -36,7 +36,7 @@ let get_files_in_directory dir = | Some x -> get_them (x::l) | None -> - closedir dirh; l + closedir dirh; l in List.sort ~cmp:compare (get_them []) @@ -63,7 +63,7 @@ let subshell ~cmd = with Some x -> it (x::l) | None -> List.rev l - in + in let answer = it [] in ignore (close_process_in rc); answer diff --git a/otherlibs/labltk/browser/viewer.ml b/otherlibs/labltk/browser/viewer.ml index 41353d8c19..fef3cbe104 100644 --- a/otherlibs/labltk/browser/viewer.ml +++ b/otherlibs/labltk/browser/viewer.ml @@ -30,7 +30,7 @@ open Searchid let list_modules ~path = List.fold_left path ~init:[] ~f: begin fun modules dir -> - let l = + let l = List.filter (Useunix.get_files_in_directory dir) ~f:(fun x -> Filename.check_suffix x ".cmi") in let l = List.map l ~f: @@ -489,7 +489,7 @@ object (self) (* Help menu *) helpmenu#add_command "Manual..." ~command:show_help; - pack [search_frame] ~fill:`X; + pack [search_frame] ~fill:`X; pack [boxes_frame] ~fill:`Both ~expand:true; pack [buttons] ~fill:`X ~side:`Bottom; pack [view] ~fill:`Both ~side:`Bottom ~expand:true; @@ -576,7 +576,7 @@ object (self) end; see_path path ~box:(self#get_box path) ~sign end - + method choose_symbol ~title ~env ?signature ?path l = let n = match path with None -> 1 diff --git a/otherlibs/labltk/builtin/builtin_FilePattern.ml b/otherlibs/labltk/builtin/builtin_FilePattern.ml index f7dd1d60e6..ea77ff98db 100644 --- a/otherlibs/labltk/builtin/builtin_FilePattern.ml +++ b/otherlibs/labltk/builtin/builtin_FilePattern.ml @@ -4,7 +4,7 @@ type filePattern = { typename : string; extensions : string list; mactypes : string list - } + } (* /type *) let cCAMLtoTKfilePattern fp = diff --git a/otherlibs/labltk/builtin/builtin_GetCursor.ml b/otherlibs/labltk/builtin/builtin_GetCursor.ml index 6c7034b166..4f7f6633fc 100644 --- a/otherlibs/labltk/builtin/builtin_GetCursor.ml +++ b/otherlibs/labltk/builtin/builtin_GetCursor.ml @@ -35,10 +35,10 @@ type color = [ (* type *) type cursor = - | XCursor of string + | XCursor of string | XCursorFg of string * color | XCursortFgBg of string * color * color - | CursorFileFg of string * color + | CursorFileFg of string * color | CursorMaskFile of string * string * color * color ;; (* /type *) @@ -58,4 +58,3 @@ type cursor = [ (* /type *) ##endif - diff --git a/otherlibs/labltk/builtin/builtin_bind.ml b/otherlibs/labltk/builtin/builtin_bind.ml index 35d0d3c1a4..752a4ba3a4 100644 --- a/otherlibs/labltk/builtin/builtin_bind.ml +++ b/otherlibs/labltk/builtin/builtin_bind.ml @@ -31,7 +31,7 @@ type xEvent = | Property | Reparent | Unmap - | Visibility + | Visibility | Virtual of string (* Virtual event. Must be without modifiers *) ;; (* /type *) @@ -54,7 +54,7 @@ type modifier = | Mod4 | Mod5 | Meta - | Alt + | Alt ;; (* /type *) @@ -95,7 +95,7 @@ type eventInfo = (* /type *) -(* To avoid collision with other constructors (Width, State), +(* To avoid collision with other constructors (Width, State), use Ev_ prefix *) (* type *) type eventField = @@ -110,7 +110,7 @@ type eventField = | Ev_OverrideRedirect | Ev_Place | Ev_State - | Ev_Time + | Ev_Time | Ev_Width | Ev_MouseX | Ev_MouseY @@ -128,7 +128,7 @@ type eventField = ;; (* /type *) -let filleventInfo ev v = function +let filleventInfo ev v = function | Ev_Above -> ev.ev_Above <- int_of_string v | Ev_ButtonNumber -> ev.ev_ButtonNumber <- int_of_string v | Ev_Count -> ev.ev_Count <- int_of_string v @@ -227,7 +227,7 @@ let rec writeeventField = function | Ev_Widget ->" %W" | Ev_RootX -> " %X" | Ev_RootY -> " %Y" - end + end ^ writeeventField rest ;; @@ -287,7 +287,7 @@ and modifier = [ | `Mod4 | `Mod5 | `Meta - | `Alt + | `Alt ] ;; (* /type *) @@ -328,7 +328,7 @@ type eventInfo = { (* /type *) -(* To avoid collision with other constructors (Width, State), +(* To avoid collision with other constructors (Width, State), use Ev_ prefix *) (* type *) type eventField = [ @@ -343,7 +343,7 @@ type eventField = [ | `OverrideRedirect | `Place | `State - | `Time + | `Time | `Width | `MouseX | `MouseY @@ -362,7 +362,7 @@ type eventField = [ ;; (* /type *) -let filleventInfo ev v : eventField -> unit = function +let filleventInfo ev v : eventField -> unit = function | `Above -> ev.ev_Above <- int_of_string v | `ButtonNumber -> ev.ev_ButtonNumber <- int_of_string v | `Count -> ev.ev_Count <- int_of_string v @@ -462,7 +462,7 @@ let rec writeeventField : eventField list -> string = function | `Widget -> " %W" | `RootX -> " %X" | `RootY -> " %Y" - end + end ^ writeeventField rest ;; diff --git a/otherlibs/labltk/builtin/builtin_bindtags.ml b/otherlibs/labltk/builtin/builtin_bindtags.ml index 4529fcdfea..35b82b9ddc 100644 --- a/otherlibs/labltk/builtin/builtin_bindtags.ml +++ b/otherlibs/labltk/builtin/builtin_bindtags.ml @@ -18,4 +18,3 @@ type bindings = [ (* /type *) ##endif - diff --git a/otherlibs/labltk/builtin/builtin_font.ml b/otherlibs/labltk/builtin/builtin_font.ml index 3425391bbf..b865cda18d 100644 --- a/otherlibs/labltk/builtin/builtin_font.ml +++ b/otherlibs/labltk/builtin/builtin_font.ml @@ -1,4 +1,3 @@ (* type *) type font = string (* /type *) - diff --git a/otherlibs/labltk/builtin/builtinf_GetPixel.ml b/otherlibs/labltk/builtin/builtinf_GetPixel.ml index 7e7c596bca..45294d58c1 100644 --- a/otherlibs/labltk/builtin/builtinf_GetPixel.ml +++ b/otherlibs/labltk/builtin/builtinf_GetPixel.ml @@ -6,7 +6,7 @@ let pixels units = [|TkToken"winfo"; TkToken"pixels"; cCAMLtoTKwidget widget_any_table default_toplevel; - cCAMLtoTKunits units|] in + cCAMLtoTKunits units|] in int_of_string res ##else @@ -17,7 +17,7 @@ let pixels units = [|TkToken"winfo"; TkToken"pixels"; cCAMLtoTKwidget default_toplevel; - cCAMLtoTKunits units|] in + cCAMLtoTKunits units|] in int_of_string res ##endif diff --git a/otherlibs/labltk/builtin/builtinf_bind.ml b/otherlibs/labltk/builtin/builtinf_bind.ml index d78541e1d0..500fd6d32b 100644 --- a/otherlibs/labltk/builtin/builtinf_bind.ml +++ b/otherlibs/labltk/builtin/builtinf_bind.ml @@ -10,7 +10,7 @@ type bindAction = (* FUNCTION - val bind: + val bind: widget -> (modifier list * xEvent) list -> bindAction -> unit /FUNCTION *) @@ -21,16 +21,16 @@ let bind widget eventsequence action = begin match action with BindRemove -> TkToken "" | BindSet (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) + let cbId = register_callback widget (wrapeventInfo f what) in TkToken ("camlcb " ^ cbId ^ (writeeventField what)) | BindSetBreakable (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) + let cbId = register_callback widget (wrapeventInfo f what) in TkToken ("camlcb " ^ cbId ^ (writeeventField what) ^ " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0") | BindExtend (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) + let cbId = register_callback widget (wrapeventInfo f what) in TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) end |] @@ -39,7 +39,7 @@ let bind widget eventsequence action = (* FUNCTION (* unsafe *) val bind_class : - string -> (modifier list * xEvent) list -> bindAction -> unit + string -> (modifier list * xEvent) list -> bindAction -> unit (* /unsafe *) /FUNCTION class arg is not constrained *) @@ -50,16 +50,16 @@ let bind_class clas eventsequence action = begin match action with BindRemove -> TkToken "" | BindSet (what, f) -> - let cbId = register_callback Widget.dummy + let cbId = register_callback Widget.dummy (wrapeventInfo f what) in TkToken ("camlcb " ^ cbId ^ (writeeventField what)) | BindSetBreakable (what, f) -> - let cbId = register_callback Widget.dummy + let cbId = register_callback Widget.dummy (wrapeventInfo f what) in TkToken ("camlcb " ^ cbId ^ (writeeventField what)^ " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0" ) | BindExtend (what, f) -> - let cbId = register_callback Widget.dummy + let cbId = register_callback Widget.dummy (wrapeventInfo f what) in TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) end |] @@ -67,8 +67,8 @@ let bind_class clas eventsequence action = (* FUNCTION (* unsafe *) - val bind_tag : - string -> (modifier list * xEvent) list -> bindAction -> unit + val bind_tag : + string -> (modifier list * xEvent) list -> bindAction -> unit (* /unsafe *) /FUNCTION *) @@ -87,7 +87,7 @@ let break = function () -> (* Legacy functions *) let tag_bind = bind_tag;; let class_bind = bind_class;; - + ##else let bind_class ~events ?(extend = false) ?(breakable = false) ?(fields = []) @@ -104,7 +104,7 @@ let bind_class ~events ?(extend = false) ?(breakable = false) ?(fields = []) let cb = if extend then "+camlcb " else "camlcb " in let cb = cb ^ cbId ^ writeeventField fields in let cb = - if breakable then + if breakable then cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}" ^ " ; set BreakBindingsSequence 0" else cb in diff --git a/otherlibs/labltk/builtin/builtini_GetBitmap.ml b/otherlibs/labltk/builtin/builtini_GetBitmap.ml index 1afa0cd91c..0c82a921d9 100644 --- a/otherlibs/labltk/builtin/builtini_GetBitmap.ml +++ b/otherlibs/labltk/builtin/builtini_GetBitmap.ml @@ -5,7 +5,7 @@ let cCAMLtoTKbitmap = function | Predefined s -> TkToken s ;; -let cTKtoCAMLbitmap s = +let cTKtoCAMLbitmap s = if s = "" then Predefined "" else if String.get s 0 = '@' then BitmapFile (String.sub s 1 (String.length s - 1)) @@ -19,7 +19,7 @@ let cCAMLtoTKbitmap : bitmap -> tkArgs = function | `Predefined s -> TkToken s ;; -let cTKtoCAMLbitmap s = +let cTKtoCAMLbitmap s = if String.get s 0 = '@' then `File (String.sub s ~pos:1 ~len:(String.length s - 1)) else `Predefined s diff --git a/otherlibs/labltk/builtin/builtini_GetCursor.ml b/otherlibs/labltk/builtin/builtini_GetCursor.ml index 8f4e3971fa..4bbab73b82 100644 --- a/otherlibs/labltk/builtin/builtini_GetCursor.ml +++ b/otherlibs/labltk/builtin/builtini_GetCursor.ml @@ -15,7 +15,7 @@ let cTKtoCAMLcolor = function s -> NamedColor s let cCAMLtoTKcursor = function XCursor s -> TkToken s - | XCursorFg (s,fg) -> + | XCursorFg (s,fg) -> TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg]) | XCursortFgBg (s,fg,bg) -> TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg]) @@ -42,7 +42,7 @@ let cTKtoCAMLcolor = function s -> `Color s let cCAMLtoTKcursor : cursor -> tkArgs = function | `Xcursor s -> TkToken s - | `Xcursorfg (s,fg) -> + | `Xcursorfg (s,fg) -> TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg]) | `Xcursorfgbg (s,fg,bg) -> TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg]) diff --git a/otherlibs/labltk/builtin/builtini_GetPixel.ml b/otherlibs/labltk/builtin/builtini_GetPixel.ml index 12e7890f45..a4709748e3 100644 --- a/otherlibs/labltk/builtin/builtini_GetPixel.ml +++ b/otherlibs/labltk/builtin/builtini_GetPixel.ml @@ -8,7 +8,7 @@ let cCAMLtoTKunits = function | Centimeters (foo) -> TkToken(Printf.sprintf "%gc" foo) ;; -let cTKtoCAMLunits str = +let cTKtoCAMLunits str = let len = String.length str in let num_part str = String.sub str 0 (len - 1) in match String.get str (pred len) with @@ -29,7 +29,7 @@ let cCAMLtoTKunits : units -> tkArgs = function | `Cm (foo) -> TkToken(Printf.sprintf "%gc" foo) ;; -let cTKtoCAMLunits str = +let cTKtoCAMLunits str = let len = String.length str in let num_part str = String.sub str ~pos:0 ~len:(len - 1) in match String.get str (pred len) with diff --git a/otherlibs/labltk/builtin/builtini_ScrollValue.ml b/otherlibs/labltk/builtin/builtini_ScrollValue.ml index 08498a00d2..7f2771c04e 100644 --- a/otherlibs/labltk/builtin/builtini_ScrollValue.ml +++ b/otherlibs/labltk/builtin/builtini_ScrollValue.ml @@ -11,7 +11,7 @@ let cCAMLtoTKscrollValue = function (* str l -> scrllv -> str l *) let cTKtoCAMLscrollValue = function - "scroll"::n::"pages"::l -> + "scroll"::n::"pages"::l -> ScrollPage (int_of_string n), l | "scroll"::n::"units"::l -> ScrollUnit (int_of_string n), l @@ -33,7 +33,7 @@ let cCAMLtoTKscrollValue : scrollValue -> tkArgs = function (* str l -> scrllv -> str l *) let cTKtoCAMLscrollValue = function - | "scroll" :: n :: "pages" :: l -> + | "scroll" :: n :: "pages" :: l -> `Page (int_of_string n), l | "scroll" :: n :: "units" :: l -> `Unit (int_of_string n), l diff --git a/otherlibs/labltk/builtin/builtini_bind.ml b/otherlibs/labltk/builtin/builtini_bind.ml index 13109cb0a9..e7f9a0bb75 100644 --- a/otherlibs/labltk/builtin/builtini_bind.ml +++ b/otherlibs/labltk/builtin/builtini_bind.ml @@ -26,7 +26,7 @@ let cCAMLtoTKxEvent = function | Property -> "Property" | Reparent -> "Reparent" | Unmap -> "Unmap" - | Visibility -> "Visibility" + | Visibility -> "Visibility" | Virtual s -> "<"^s^">" ;; @@ -55,14 +55,14 @@ exception IllegalVirtualEvent (* type event = modifier list * xEvent *) let cCAMLtoTKevent (ml, xe) = match xe with - | Virtual s -> + | Virtual s -> if ml = [] then "<<"^s^">>" else raise IllegalVirtualEvent | _ -> - "<" ^ (String.concat " " (List.map cCAMLtoTKmodifier ml)) + "<" ^ (String.concat " " (List.map cCAMLtoTKmodifier ml)) ^ (cCAMLtoTKxEvent xe) ^ ">" ;; - + (* type eventSequence == (modifier list * xEvent) list *) let cCAMLtoTKeventSequence l = TkToken(List.fold_left (^) "" (List.map cCAMLtoTKevent l)) @@ -120,7 +120,7 @@ let cCAMLtoTKevent (ev : event) = | `Reparent -> "Reparent" | `Unmap -> "Unmap" | `Visibility -> "Visibility" - | `Virtual s -> + | `Virtual s -> if !modified then raise IllegalVirtualEvent else "<"^s^">" | `Modified(ml, ev) -> modified := true; @@ -129,7 +129,7 @@ let cCAMLtoTKevent (ev : event) = in "<" ^ convert ev ^ ">" ;; -let cCAMLtoTKeventSequence (l : event list) = +let cCAMLtoTKeventSequence (l : event list) = TkToken(String.concat ~sep:"" (List.map ~f:cCAMLtoTKevent l)) ;; diff --git a/otherlibs/labltk/builtin/builtini_font.ml b/otherlibs/labltk/builtin/builtini_font.ml index 521b24d6d5..27a17501e1 100644 --- a/otherlibs/labltk/builtin/builtini_font.ml +++ b/otherlibs/labltk/builtin/builtini_font.ml @@ -1,3 +1,2 @@ let cCAMLtoTKfont (s : font) = TkToken s let cTKtoCAMLfont (s : font) = s - diff --git a/otherlibs/labltk/builtin/builtini_index.ml b/otherlibs/labltk/builtin/builtini_index.ml index 7718cab952..3baa448f42 100644 --- a/otherlibs/labltk/builtin/builtini_index.ml +++ b/otherlibs/labltk/builtin/builtini_index.ml @@ -21,7 +21,7 @@ | CEmbedded ;; -let index_any_table = +let index_any_table = [CNumber; CActiveElement; CEnd; CLast; CNoIndex; CInsert; CSelFirst; CSelLast; CAt; CAtXY; CAnchorPoint; CPattern; CLineChar; CMark; CTagFirst; CTagLast; CEmbedded] @@ -30,10 +30,10 @@ let index_any_table = let index_canvas_table = [CNumber; CEnd; CInsert; CSelFirst; CSelLast; CAtXY] ;; -let index_entry_table = +let index_entry_table = [CNumber; CAnchorPoint; CEnd; CInsert; CSelFirst; CSelLast; CAt] ;; -let index_listbox_table = +let index_listbox_table = [CNumber; CActiveElement; CAnchorPoint; CEnd; CAtXY] ;; let index_menu_table = @@ -53,14 +53,14 @@ let cCAMLtoTKindex table = function | SelFirst -> chk_sub "SelFirst" table CSelFirst; TkToken "sel.first" | SelLast -> chk_sub "SelLast" table CSelLast; TkToken "sel.last" | At n -> chk_sub "At" table CAt; TkToken ("@"^string_of_int n) - | AtXY (x,y) -> chk_sub "AtXY" table CAtXY; + | AtXY (x,y) -> chk_sub "AtXY" table CAtXY; TkToken ("@"^string_of_int x^","^string_of_int y) | AnchorPoint -> chk_sub "AnchorPoint" table CAnchorPoint; TkToken "anchor" | Pattern s -> chk_sub "Pattern" table CPattern; TkToken s | LineChar (l,c) -> chk_sub "LineChar" table CLineChar; TkToken (string_of_int l^"."^string_of_int c) | Mark s -> chk_sub "Mark" table CMark; TkToken s - | TagFirst t -> chk_sub "TagFirst" table CTagFirst; + | TagFirst t -> chk_sub "TagFirst" table CTagFirst; TkToken (t^".first") | TagLast t -> chk_sub "TagLast" table CTagLast; TkToken (t^".last") @@ -70,9 +70,9 @@ let cCAMLtoTKindex table = function let char_index c s = let rec find i = - if i >= String.length s + if i >= String.length s then raise Not_found - else if String.get s i = c then i + else if String.get s i = c then i else find (i+1) in find 0 ;; @@ -82,7 +82,7 @@ let char_index c s = let cTKtoCAMLindex s = try let p = char_index '.' s in - LineChar(int_of_string (String.sub s 0 p), + LineChar(int_of_string (String.sub s 0 p), int_of_string (String.sub s (p+1) (String.length s - p - 1))) with Not_found -> @@ -121,11 +121,11 @@ let cCAMLtoTKtext_index = (cCAMLtoTKindex : text_index -> tkArgs);; (* Assume returned values are only numerical and l.c *) -let cTKtoCAMLtext_index s = +let cTKtoCAMLtext_index s = try let p = String.index s '.' in - `Linechar (int_of_string (String.sub s ~pos:0 ~len:p), - int_of_string (String.sub s ~pos:(p + 1) + `Linechar (int_of_string (String.sub s ~pos:0 ~len:p), + int_of_string (String.sub s ~pos:(p + 1) ~len:(String.length s - p - 1))) with Not_found -> diff --git a/otherlibs/labltk/builtin/builtini_text.ml b/otherlibs/labltk/builtin/builtini_text.ml index 966c28a325..4db49c05e9 100644 --- a/otherlibs/labltk/builtin/builtini_text.ml +++ b/otherlibs/labltk/builtin/builtini_text.ml @@ -8,11 +8,11 @@ let cTKtoCAMLtextTag x = x;; (* TextModifiers are never returned by Tk *) let ppTextModifier = function - CharOffset n -> + CharOffset n -> if n > 0 then "+" ^ (string_of_int n) ^ "chars" else if n = 0 then "" else (string_of_int n) ^ "chars" - | LineOffset n -> + | LineOffset n -> if n > 0 then "+" ^ (string_of_int n) ^ "lines" else if n = 0 then "" else (string_of_int n) ^ "lines" @@ -24,13 +24,13 @@ let ppTextModifier = function let ppTextIndex = function | TextIndexNone -> "" - | TextIndex (base, ml) -> + | TextIndex (base, ml) -> match cCAMLtoTKindex index_text_table base with | TkToken ppbase -> List.fold_left (^) ppbase (List.map ppTextModifier ml) | _ -> assert false ;; -let cCAMLtoTKtextIndex i = +let cCAMLtoTKtextIndex i = TkToken (ppTextIndex i) ;; @@ -39,11 +39,11 @@ let cCAMLtoTKtextIndex i = (* TextModifiers are never returned by Tk *) let cCAMLtoTKtextIndex (i : textIndex) = let ppTextModifier = function - | `Char n -> + | `Char n -> if n > 0 then "+" ^ (string_of_int n) ^ "chars" else if n = 0 then "" else (string_of_int n) ^ "chars" - | `Line n -> + | `Line n -> if n > 0 then "+" ^ (string_of_int n) ^ "lines" else if n = 0 then "" else (string_of_int n) ^ "lines" diff --git a/otherlibs/labltk/builtin/canvas_bind.ml b/otherlibs/labltk/builtin/canvas_bind.ml index 1b46fae010..9256a74c00 100644 --- a/otherlibs/labltk/builtin/canvas_bind.ml +++ b/otherlibs/labltk/builtin/canvas_bind.ml @@ -1,7 +1,7 @@ ##ifdef CAMLTK let bind widget tag eventsequence action = - tkCommand [| + tkCommand [| cCAMLtoTKwidget widget_canvas_table widget; TkToken "bind"; cCAMLtoTKtagOrId tag; @@ -19,7 +19,7 @@ let bind widget tag eventsequence action = | BindExtend (what, f) -> let cbId = register_callback widget (wrapeventInfo f what) in TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) - end + end |] ;; @@ -40,7 +40,7 @@ let bind ~events let cb = if extend then "+camlcb " else "camlcb " in let cb = cb ^ cbId ^ writeeventField fields in let cb = - if breakable then + if breakable then cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}" ^ " ; set BreakBindingsSequence 0" else cb in diff --git a/otherlibs/labltk/builtin/canvas_bind.mli b/otherlibs/labltk/builtin/canvas_bind.mli index 39ce93e7c3..0c6c58373d 100644 --- a/otherlibs/labltk/builtin/canvas_bind.mli +++ b/otherlibs/labltk/builtin/canvas_bind.mli @@ -1,7 +1,7 @@ ##ifdef CAMLTK -val bind : widget -> tagOrId -> - (modifier list * xEvent) list -> bindAction -> unit +val bind : widget -> tagOrId -> + (modifier list * xEvent) list -> bindAction -> unit ##else @@ -11,6 +11,6 @@ val bind : ?breakable: bool -> ?fields: eventField list -> ?action: (eventInfo -> unit) -> - canvas widget -> tagOrId -> unit + canvas widget -> tagOrId -> unit ##endif diff --git a/otherlibs/labltk/builtin/dialog.mli b/otherlibs/labltk/builtin/dialog.mli index debb6ce207..532045cb2b 100644 --- a/otherlibs/labltk/builtin/dialog.mli +++ b/otherlibs/labltk/builtin/dialog.mli @@ -1,24 +1,24 @@ ##ifdef CAMLTK -val create : ?name: string -> - widget -> string -> string -> bitmap -> int -> string list -> int - (* [create ~name parent title message bitmap default button_names] +val create : ?name: string -> + widget -> string -> string -> bitmap -> int -> string list -> int + (* [create ~name parent title message bitmap default button_names] cf. tk_dialog *) val create_named : - widget -> string -> string -> string -> bitmap -> int -> string list -> int - (* [create_named parent name title message bitmap default button_names] + widget -> string -> string -> string -> bitmap -> int -> string list -> int + (* [create_named parent name title message bitmap default button_names] cf. tk_dialog *) ##else -val create : +val create : parent: 'a widget -> title: string -> message: string -> buttons: string list -> - ?name: string -> ?bitmap: bitmap -> ?default: int -> unit ->int - (* [create title message bitmap default button_names parent] + ?name: string -> ?bitmap: bitmap -> ?default: int -> unit ->int + (* [create title message bitmap default button_names parent] cf. tk_dialog *) ##endif diff --git a/otherlibs/labltk/builtin/image.ml b/otherlibs/labltk/builtin/image.ml index ac4c7238a9..a1fd2eab86 100644 --- a/otherlibs/labltk/builtin/image.ml +++ b/otherlibs/labltk/builtin/image.ml @@ -8,12 +8,12 @@ let cTKtoCAMLimage s = | _ -> raise (TkError ("unknown image type \"" ^ res ^ "\"")) ;; -let names () = +let names () = let res = tkEval [|TkToken "image"; TkToken "names"|] in let names = splitlist res in List.map cTKtoCAMLimage names ;; - + ##else let cTKtoCAMLimage s = @@ -24,10 +24,10 @@ let cTKtoCAMLimage s = | _ -> raise (TkError ("unknown image type \"" ^ res ^ "\"")) ;; -let names () = +let names () = let res = tkEval [|TkToken "image"; TkToken "names"|] in let names = splitlist res in List.map cTKtoCAMLimage names ;; - + ##endif diff --git a/otherlibs/labltk/builtin/optionmenu.ml b/otherlibs/labltk/builtin/optionmenu.ml index c0a760abae..5a17e3ffd7 100644 --- a/otherlibs/labltk/builtin/optionmenu.ml +++ b/otherlibs/labltk/builtin/optionmenu.ml @@ -6,7 +6,7 @@ open Protocol;; let create ?name parent variable values = let w = Widget.new_atom "menubutton" ~parent ?name in let mw = Widget.new_atom "menu" ~parent:w ~name:"menu" in - let res = + let res = tkEval [|TkToken "tk_optionMenu"; TkToken (Widget.name w); cCAMLtoTKtextVariable variable; @@ -20,7 +20,7 @@ let create ?name parent variable values = let create_named parent name variable values = let w = Widget.new_atom "menubutton" ~parent ~name in let mw = Widget.new_atom "menu" ~parent:w ~name: "menu" in - let res = + let res = tkEval [|TkToken "tk_optionMenu"; TkToken (Widget.name w); cCAMLtoTKtextVariable variable; @@ -38,9 +38,9 @@ open Protocol;; let create ~parent ~variable ?name values = let w = Widget.new_atom "menubutton" ~parent ?name in - let mw = Widget.new_atom "menu" ~parent:w ~name:"menu" in + let mw = Widget.new_atom "menu" ~parent:w ~name:"menu" in (* assumes .menu naming *) - let res = + let res = tkEval [|TkToken "tk_optionMenu"; TkToken (Widget.name w); cCAMLtoTKtextVariable variable; diff --git a/otherlibs/labltk/builtin/optionmenu.mli b/otherlibs/labltk/builtin/optionmenu.mli index 0c6b5c9e13..c58795796a 100644 --- a/otherlibs/labltk/builtin/optionmenu.mli +++ b/otherlibs/labltk/builtin/optionmenu.mli @@ -1,21 +1,21 @@ ##ifdef CAMLTK (* Support for tk_optionMenu *) -val create: ?name: string -> +val create: ?name: string -> widget -> textVariable -> string list -> widget * widget -(** [create ?name parent var options] creates a multi-option menubutton and - its associated menu. The option is also stored in the variable. +(** [create ?name parent var options] creates a multi-option menubutton and + its associated menu. The option is also stored in the variable. Both widgets (menubutton and menu) are returned. *) ##else (* Support for tk_optionMenu *) -val create: - parent:'a widget -> +val create: + parent:'a widget -> variable:textVariable -> ?name: string -> string list -> menubutton widget * menu widget -(** [create ~parent ~var ~name options] creates a multi-option menubutton - and its associated menu. The option is also stored in the variable. +(** [create ~parent ~var ~name options] creates a multi-option menubutton + and its associated menu. The option is also stored in the variable. Both widgets (menubutton and menu) are returned *) ##endif diff --git a/otherlibs/labltk/builtin/selection_handle_set.ml b/otherlibs/labltk/builtin/selection_handle_set.ml index fe19489a51..2dfc5763f7 100644 --- a/otherlibs/labltk/builtin/selection_handle_set.ml +++ b/otherlibs/labltk/builtin/selection_handle_set.ml @@ -5,8 +5,8 @@ let handle_set opts w cmd = tkCommand [| TkToken"selection"; TkToken"handle"; - TkTokenList - (List.map + TkTokenList + (List.map (function x -> cCAMLtoTKicccm w icccm_selection_handle_table x) opts); cCAMLtoTKwidget widget_any_table w; diff --git a/otherlibs/labltk/builtin/selection_handle_set.mli b/otherlibs/labltk/builtin/selection_handle_set.mli index 66ae6b7349..3778e274bc 100644 --- a/otherlibs/labltk/builtin/selection_handle_set.mli +++ b/otherlibs/labltk/builtin/selection_handle_set.mli @@ -6,7 +6,7 @@ val handle_set : icccm list -> widget -> (int -> int -> unit) -> unit ##else val handle_set : - command: (pos:int -> len:int -> string) -> + command: (pos:int -> len:int -> string) -> ?format: string -> ?selection:string -> ?typ: string -> 'a widget -> unit (** tk invocation: selection handle <icccm list> <widget> <command> *) diff --git a/otherlibs/labltk/builtin/selection_own_set.ml b/otherlibs/labltk/builtin/selection_own_set.ml index 253cdb5b64..9a4b1f16bb 100644 --- a/otherlibs/labltk/builtin/selection_own_set.ml +++ b/otherlibs/labltk/builtin/selection_own_set.ml @@ -5,8 +5,8 @@ let own_set v1 v2 = tkCommand [| TkToken"selection"; TkToken"own"; - TkTokenList - (List.map + TkTokenList + (List.map (function x -> cCAMLtoTKicccm v2 icccm_selection_ownset_table x) v1); cCAMLtoTKwidget widget_any_table v2 @@ -22,7 +22,7 @@ let own_set ?command = TkToken"selection"; TkToken"own"; TkTokenList opts; - cCAMLtoTKwidget w + cCAMLtoTKwidget w |]) ;; diff --git a/otherlibs/labltk/builtin/selection_own_set.mli b/otherlibs/labltk/builtin/selection_own_set.mli index 95b3de363c..868a8248be 100644 --- a/otherlibs/labltk/builtin/selection_own_set.mli +++ b/otherlibs/labltk/builtin/selection_own_set.mli @@ -1,12 +1,12 @@ ##ifdef CAMLTK -val own_set : icccm list -> widget -> unit +val own_set : icccm list -> widget -> unit (** tk invocation: selection own <icccm list> <widget> *) ##else val own_set : - ?command:(unit->unit) -> ?selection:string -> 'a widget -> unit + ?command:(unit->unit) -> ?selection:string -> 'a widget -> unit (** tk invocation: selection own <icccm list> <widget> *) ##endif diff --git a/otherlibs/labltk/builtin/text_tag_bind.ml b/otherlibs/labltk/builtin/text_tag_bind.ml index 7a1bab3a5d..72e9f04636 100644 --- a/otherlibs/labltk/builtin/text_tag_bind.ml +++ b/otherlibs/labltk/builtin/text_tag_bind.ml @@ -2,7 +2,7 @@ let tag_bind widget tag eventsequence action = check_class widget widget_text_table; - tkCommand [| + tkCommand [| cCAMLtoTKwidget widget_text_table widget; TkToken "tag"; TkToken "bind"; @@ -29,7 +29,7 @@ let tag_bind widget tag eventsequence action = let tag_bind ~tag ~events ?(extend = false) ?(breakable = false) ?(fields = []) ?action widget = - tkCommand [| + tkCommand [| cCAMLtoTKwidget widget; TkToken "tag"; TkToken "bind"; @@ -43,7 +43,7 @@ let tag_bind ~tag ~events ?(extend = false) ?(breakable = false) let cb = if extend then "+camlcb " else "camlcb " in let cb = cb ^ cbId ^ writeeventField fields in let cb = - if breakable then + if breakable then cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}" ^ " ; set BreakBindingsSequence 0" else cb in diff --git a/otherlibs/labltk/builtin/text_tag_bind.mli b/otherlibs/labltk/builtin/text_tag_bind.mli index 1f334a796c..6778e4ff11 100644 --- a/otherlibs/labltk/builtin/text_tag_bind.mli +++ b/otherlibs/labltk/builtin/text_tag_bind.mli @@ -1,13 +1,13 @@ ##ifdef CAMLTK -val tag_bind: - widget -> textTag -> (modifier list * xEvent) list -> bindAction -> unit +val tag_bind: + widget -> textTag -> (modifier list * xEvent) list -> bindAction -> unit ##else val tag_bind : tag: string -> events: event list -> ?extend: bool -> ?breakable: bool -> ?fields: eventField list -> - ?action: (eventInfo -> unit) -> text widget -> unit + ?action: (eventInfo -> unit) -> text widget -> unit ##endif diff --git a/otherlibs/labltk/camltk/Makefile.gen b/otherlibs/labltk/camltk/Makefile.gen index bedc9c5990..f25e1f7612 100644 --- a/otherlibs/labltk/camltk/Makefile.gen +++ b/otherlibs/labltk/camltk/Makefile.gen @@ -9,9 +9,9 @@ _tkgen.ml: ../Widgets.src ../compiler/tkcompiler$(EXE) cTk.ml camltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp$(EXE) #../builtin/builtin_*.ml (echo '##define CAMLTK'; \ - echo 'include Camltkwrap'; \ + echo 'include Camltkwrap'; \ echo 'open Widget'; \ - echo 'open Protocol'; \ + echo 'open Protocol'; \ echo 'open Textvariable'; \ echo ; \ cat ../builtin/report.ml; \ diff --git a/otherlibs/labltk/compiler/.depend b/otherlibs/labltk/compiler/.depend index d33149e8cf..91ee430407 100644 --- a/otherlibs/labltk/compiler/.depend +++ b/otherlibs/labltk/compiler/.depend @@ -1,28 +1,28 @@ -pplex.cmi: ppyac.cmi -ppyac.cmi: code.cmi -compile.cmo: code.cmi flags.cmo ppexec.cmo ppparse.cmo tables.cmo -compile.cmx: code.cmi flags.cmx ppexec.cmx ppparse.cmx tables.cmx -intf.cmo: code.cmi compile.cmo flags.cmo ppexec.cmo ppparse.cmo tables.cmo -intf.cmx: code.cmi compile.cmx flags.cmx ppexec.cmx ppparse.cmx tables.cmx -lexer.cmo: parser.cmi -lexer.cmx: parser.cmx +pplex.cmi: ppyac.cmi +ppyac.cmi: code.cmi +compile.cmo: code.cmi flags.cmo ppexec.cmo ppparse.cmo tables.cmo +compile.cmx: code.cmi flags.cmx ppexec.cmx ppparse.cmx tables.cmx +intf.cmo: code.cmi compile.cmo flags.cmo ppexec.cmo ppparse.cmo tables.cmo +intf.cmx: code.cmi compile.cmx flags.cmx ppexec.cmx ppparse.cmx tables.cmx +lexer.cmo: parser.cmi +lexer.cmx: parser.cmx maincompile.cmo: code.cmi compile.cmo flags.cmo intf.cmo lexer.cmo parser.cmi \ - ppexec.cmo ppparse.cmo printer.cmo tables.cmo tsort.cmo + ppexec.cmo ppparse.cmo printer.cmo tables.cmo tsort.cmo maincompile.cmx: code.cmi compile.cmx flags.cmx intf.cmx lexer.cmx parser.cmx \ - ppexec.cmx ppparse.cmx printer.cmx tables.cmx tsort.cmx -parser.cmo: flags.cmo tables.cmo parser.cmi -parser.cmx: flags.cmx tables.cmx parser.cmi -pp.cmo: ppexec.cmo ppparse.cmo -pp.cmx: ppexec.cmx ppparse.cmx -ppexec.cmo: code.cmi -ppexec.cmx: code.cmi -pplex.cmo: ppyac.cmi pplex.cmi -pplex.cmx: ppyac.cmx pplex.cmi -ppparse.cmo: pplex.cmi ppyac.cmi -ppparse.cmx: pplex.cmx ppyac.cmx -ppyac.cmo: code.cmi ppyac.cmi -ppyac.cmx: code.cmi ppyac.cmi -printer.cmo: tables.cmo -printer.cmx: tables.cmx -tables.cmo: tsort.cmo -tables.cmx: tsort.cmx + ppexec.cmx ppparse.cmx printer.cmx tables.cmx tsort.cmx +parser.cmo: flags.cmo tables.cmo parser.cmi +parser.cmx: flags.cmx tables.cmx parser.cmi +pp.cmo: ppexec.cmo ppparse.cmo +pp.cmx: ppexec.cmx ppparse.cmx +ppexec.cmo: code.cmi +ppexec.cmx: code.cmi +pplex.cmo: ppyac.cmi pplex.cmi +pplex.cmx: ppyac.cmx pplex.cmi +ppparse.cmo: pplex.cmi ppyac.cmi +ppparse.cmx: pplex.cmx ppyac.cmx +ppyac.cmo: code.cmi ppyac.cmi +ppyac.cmx: code.cmi ppyac.cmi +printer.cmo: tables.cmo +printer.cmx: tables.cmx +tables.cmo: tsort.cmo +tables.cmx: tsort.cmx diff --git a/otherlibs/labltk/compiler/compile.ml b/otherlibs/labltk/compiler/compile.ml index 529c0548eb..fd74bc173d 100644 --- a/otherlibs/labltk/compiler/compile.ml +++ b/otherlibs/labltk/compiler/compile.ml @@ -37,14 +37,14 @@ let camltk_labelstring l = if l.[0] = '?' then l ^ ":" else "" let labelstring l = - if !Flags.camltk then camltk_labelstring l - else labltk_labelstring l + if !Flags.camltk then camltk_labelstring l + else labltk_labelstring l let labltk_typelabel l = if l = "" then l else l ^ ":" let camltk_typelabel l = - if l = "" then l + if l = "" then l else if l.[0] = '?' then l ^ ":" else "" let typelabel l = @@ -58,7 +58,7 @@ let nicknames = let small = String.lowercase -let gettklabel fc = +let gettklabel fc = match fc.template with ListArg( StringArg s :: _ ) -> let s = small s in @@ -85,15 +85,15 @@ let rec types_of_template = function StringArg _ -> [] | TypeArg (l, t) -> [l, t] | ListArg l -> List.flatten (List.map ~f:types_of_template l) - | OptionalArgs (l, tl, _) -> - begin + | OptionalArgs (l, tl, _) -> + begin match List.flatten (List.map ~f:types_of_template tl) with ["", t] -> ["?" ^ l, t] | [_, _] -> raise (Failure "0 label required") | _ -> raise (Failure "0 or more than 1 args in for optionals") end -(* +(* * Pretty print a type * used to write ML type definitions *) @@ -111,9 +111,9 @@ let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) = if !Flags.camltk then "(* " ^ sub ^ " *) " ^ sup ^ " list" else begin if return then - sub ^ "_" ^ sup ^ " list" + sub ^ "_" ^ sup ^ " list" else begin - try + try let typdef = Hashtbl.find types_table sup in let fcl = List.assoc sub typdef.subtypes in let tklabels = List.map ~f:gettklabel fcl in @@ -122,13 +122,13 @@ let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) = "?" ^ begin let p = gettklabel fc in if count ~item:p tklabels > 1 then small fc.var_name else p end - ^ ":" ^ + ^ ":" ^ let l = types_of_template fc.template in match l with [] -> "unit" | [lt] -> ppMLtype (labeloff lt ~at:"ppMLtype") | l -> - "(" ^ String.concat ~sep:"*" + "(" ^ String.concat ~sep:"*" (List.map l ~f:(fun lt -> ppMLtype (labeloff lt ~at:"ppMLtype"))) ^ ")" @@ -141,20 +141,20 @@ let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) = | List ty -> (ppMLtype ty) ^ " list" | Product tyl -> "(" ^ String.concat ~sep:" * " (List.map ~f:ppMLtype tyl) ^ ")" - | Record tyl -> + | Record tyl -> String.concat ~sep:" * " (List.map tyl ~f:(fun (l, t) -> typelabel l ^ ppMLtype t)) - | Subtype ("widget", sub) -> + | Subtype ("widget", sub) -> if !Flags.camltk then "(* " ^ sub ^" *) widget" else sub ^ " widget" - | UserDefined "widget" -> + | UserDefined "widget" -> if !Flags.camltk then "widget" else begin - if any then "any widget" else - let c = String.make 1 (Char.chr(Char.code 'a' + !counter)) in + if any then "any widget" else + let c = String.make 1 (Char.chr(Char.code 'a' + !counter)) in incr counter; "'" ^ c ^ " widget" end - | UserDefined s -> + | UserDefined s -> if !Flags.camltk then s else begin (* a bit dirty hack for ImageBitmap and ImagePhoto *) @@ -163,11 +163,11 @@ let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) = if typdef.variant then if return then try "[>" ^ - String.concat ~sep:"|" + String.concat ~sep:"|" (List.map typdef.constructors ~f: begin fun c -> - "`" ^ c.var_name ^ + "`" ^ c.var_name ^ (match types_of_template c.template with [] -> "" | l -> " of " ^ ppMLtype (Product (List.map l @@ -181,17 +181,17 @@ let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) = else s with Not_found -> s end - | Subtype (s, s') -> + | Subtype (s, s') -> if !Flags.camltk then "(* " ^ s' ^ " *) " ^ s else s' ^ "_" ^ s - | Function (Product tyl) -> + | Function (Product tyl) -> raise (Failure "Function (Product tyl) ? ppMLtype") - | Function (Record tyl) -> - "(" ^ String.concat ~sep:" -> " + | Function (Record tyl) -> + "(" ^ String.concat ~sep:" -> " (List.map tyl ~f:(fun (l, t) -> typelabel l ^ ppMLtype t)) ^ " -> unit)" | Function ty -> "(" ^ (ppMLtype ty) ^ " -> unit)" - | As (t, s) -> + | As (t, s) -> if !Flags.camltk then ppMLtype t else s in @@ -242,7 +242,7 @@ let write_variant ~w {var_name = varname; template = t} = w varname; begin match types_of_template t with [] -> () - | l -> + | l -> w " of "; w (ppMLtype ~any:true ~def:true (Product (List.map l ~f:(labeloff ~at:"write_variant")))) @@ -258,7 +258,7 @@ let write_variants ~w = function write_variant ~w x end -(* Definition of a type *) +(* Definition of a type *) let labltk_write_type ~intf:w ~impl:w' name ~def:typdef = (* Only needed if no subtypes, otherwise use optionals *) if typdef.subtypes = [] then begin @@ -271,13 +271,13 @@ let labltk_write_type ~intf:w ~impl:w' name ~def:typdef = (* CamlTk: List of constructors, for runtime subtyping *) let write_constructor_set ~w ~sep = function | [] -> fatal_error "empty type" - | x::l -> + | x::l -> w ("C" ^ x.ml_name); List.iter l ~f: (function x -> w sep; w ("C" ^ x.ml_name)) -(* CamlTk: Definition of a type *) +(* CamlTk: Definition of a type *) let camltk_write_type ~intf:w ~impl:w' name ~def:typdef = (* Put markers for extraction *) w "(* type *)\n"; @@ -296,12 +296,12 @@ let camltk_write_type ~intf:w ~impl:w' name ~def:typdef = w ("(* no doc *) type "^name^"_constrs =\n") end; w " | "; - write_constructor_set ~w:w ~sep: "\n | " + write_constructor_set ~w:w ~sep: "\n | " (sort_components typdef.constructors); w "\n\n"; (* The set of all constructors *) w' ("let "^name^"_any_table = ["); - write_constructor_set ~w:w' ~sep:"; " + write_constructor_set ~w:w' ~sep:"; " (sort_components typdef.constructors); w' ("]\n\n"); (* The subset of constructors for each subtype *) @@ -312,7 +312,7 @@ let camltk_write_type ~intf:w ~impl:w' name ~def:typdef = typdef.subtypes end -let write_type ~intf:w ~impl:w' name ~def:typdef = +let write_type ~intf:w ~impl:w' name ~def:typdef = (if !Flags.camltk then camltk_write_type else labltk_write_type) ~intf:w ~impl:w' name ~def:typdef @@ -333,8 +333,8 @@ let rec converterTKtoCAML ~arg = function | Subtype ("widget", s') when not !Flags.camltk -> String.concat ~sep:" " ["(Obj.magic (cTKtoCAMLwidget "; arg; ") :"; s'; "widget)"] - | Subtype (s, s') -> - if !Flags.camltk then + | Subtype (s, s') -> + if !Flags.camltk then "cTKtoCAML" ^ s ^ " " ^ arg else "cTKtoCAML" ^ s' ^ "_" ^ s ^ " " ^ arg @@ -359,12 +359,12 @@ let rec converterTKtoCAML ~arg = function (* Wrappers *) (*******************************) let varnames ~prefix n = - let rec var i = + let rec var i = if i > n then [] else (prefix ^ string_of_int i) :: var (succ i) in var 1 -(* +(* * generate wrapper source for callbacks * transform a function ... -> unit in a function : unit -> unit * using primitives arg_ ... from the protocol @@ -384,7 +384,7 @@ let rec wrapper_code ~name ty = (* variables for each component of the product *) let vnames = varnames ~prefix:"a" (List.length tyl) in (* getting the arguments *) - let readarg = + let readarg = List.map2 vnames tyl ~f: begin fun v (l, ty) -> match type_parser_arity ty with @@ -398,8 +398,8 @@ let rec wrapper_code ~name ty = " in\n " end in String.concat ~sep:"" readarg ^ name ^ " " ^ - String.concat ~sep:" " - (List.map2 ~f:(fun v (l, _) -> + String.concat ~sep:" " + (List.map2 ~f:(fun v (l, _) -> if !Flags.camltk then v else labelstring l ^ v) vnames tyl) @@ -410,7 +410,7 @@ let rec wrapper_code ~name ty = name ^ "(" ^ converterTKtoCAML ~arg:"(List.hd args)" ty ^ ")" | ty -> begin match type_parser_arity ty with - OneToken -> + OneToken -> name ^ "(" ^ converterTKtoCAML ~arg:"(List.hd args)" ty ^ ")" | MultipleToken -> "let (v, _) = " ^ converterTKtoCAML ~arg:"args" ty ^ @@ -435,8 +435,8 @@ type parser_pieces = mutable stringpar : string list (* idem *) } -type mini_parser = - NoParser +type mini_parser = + NoParser | ParserPieces of parser_pieces let can_generate_parser constructors = @@ -446,9 +446,9 @@ let can_generate_parser constructors = let vname = if !Flags.camltk then c.ml_name else c.var_name in match c.template with ListArg [StringArg s] -> - pp.zeroary <- (s, vname) :: + pp.zeroary <- (s, vname) :: pp.zeroary; true - | ListArg [TypeArg(_, Int)] | ListArg[TypeArg(_, Float)] -> + | ListArg [TypeArg(_, Int)] | ListArg[TypeArg(_, Float)] -> if pp.intpar <> [] then false else (pp.intpar <- [vname]; true) | ListArg [TypeArg(_, String)] -> @@ -466,8 +466,8 @@ let labltk_write_TKtoCAML ~w name ~def:typdef = if typdef.parser_arity = MultipleToken then prerr_string ("You must write cTKtoCAML" ^ name ^ " : string list ->" ^ name ^ " * string list\n") - else - let write ~consts ~name = + else + let write ~consts ~name = match can_generate_parser consts with NoParser -> prerr_string @@ -482,7 +482,7 @@ let labltk_write_TKtoCAML ~w name ~def:typdef = end; w (" match n with\n"); List.iter pp.zeroary ~f: - begin fun (tk, ml) -> + begin fun (tk, ml) -> w " | \""; w tk; w "\" -> `"; w ml; w "\n" end; let final = if pp.stringpar <> [] then @@ -505,8 +505,8 @@ let camltk_write_TKtoCAML ~w name ~def:typdef = if typdef.parser_arity = MultipleToken then prerr_string ("You must write cTKtoCAML" ^ name ^ " : string list ->" ^ name ^ " * string list\n") - else - let write ~consts ~name = + else + let write ~consts ~name = match can_generate_parser consts with NoParser -> prerr_string @@ -521,7 +521,7 @@ let camltk_write_TKtoCAML ~w name ~def:typdef = end; w (" match n with\n"); List.iter pp.zeroary ~f: - begin fun (tk, ml) -> + begin fun (tk, ml) -> w " | \""; w tk; w "\" -> "; w ml; w "\n" end; let final = if pp.stringpar <> [] then @@ -558,39 +558,39 @@ let rec converterCAMLtoTK ~context_widget argname ty = | Char -> "TkToken (Char.escaped " ^ argname ^ ")" | String -> "TkToken " ^ argname | As (ty, _) -> converterCAMLtoTK ~context_widget argname ty - | UserDefined s -> + | UserDefined s -> let name = "cCAMLtoTK" ^ s ^ " " in let args = argname in - let args = + let args = if !Flags.camltk then begin if is_subtyped s then (* unconstraint subtype *) s ^ "_any_table " ^ args else args end else args in - let args = + let args = if requires_widget_context s then context_widget ^ " " ^ args else args in name ^ args | Subtype ("widget", s') -> - if !Flags.camltk then + if !Flags.camltk then let name = "cCAMLtoTKwidget " in let args = "widget_"^s'^"_table "^argname in - let args = + let args = if requires_widget_context "widget" then context_widget^" "^args else args in name^args - else begin + else begin let name = "cCAMLtoTKwidget " in let args = "(" ^ argname ^ " : " ^ s' ^ " widget)" in name ^ args end | Subtype (s, s') -> - let name = + let name = if !Flags.camltk then "cCAMLtoTK" ^ s ^ " " - else "cCAMLtoTK" ^ s' ^ "_" ^ s ^ " " + else "cCAMLtoTK" ^ s' ^ "_" ^ s ^ " " in let args = if !Flags.camltk then begin @@ -600,7 +600,7 @@ let rec converterCAMLtoTK ~context_widget argname ty = else argname end in - let args = + let args = if requires_widget_context s then context_widget ^ " " ^ args else args in name ^ args @@ -614,19 +614,19 @@ let rec converterCAMLtoTK ~context_widget argname ty = ["]"]) | List ty -> (* Just added for Imagephoto.put *) String.concat ~sep:" " - [(if !Flags.camltk then - "TkQuote (TkTokenList (List.map (fun y -> " - else - "TkQuote (TkTokenList (List.map ~f:(fun y -> "); - converterCAMLtoTK ~context_widget "y" ty; - ")"; - argname; - "))"] + [(if !Flags.camltk then + "TkQuote (TkTokenList (List.map (fun y -> " + else + "TkQuote (TkTokenList (List.map ~f:(fun y -> "); + converterCAMLtoTK ~context_widget "y" ty; + ")"; + argname; + "))"] | Function _ -> fatal_error "unexpected function type in converterCAMLtoTK" | Unit -> fatal_error "unexpected unit type in converterCAMLtoTK" | Record _ -> fatal_error "unexpected product type in converterCAMLtoTK" -(* +(* * Produce a list of arguments from a template * The idea here is to avoid allocation as much as possible * @@ -638,7 +638,7 @@ let code_of_template ~context_widget ?func:(funtemplate=false) template = let variables2 = ref [] in let varcnter = ref 0 in let optionvar = ref None in - let newvar1 l = + let newvar1 l = match !optionvar with Some v -> optionvar := None; v | None -> @@ -652,7 +652,7 @@ let code_of_template ~context_widget ?func:(funtemplate=false) template = incr varcnter; let v = "v" ^ (string_of_int !varcnter) in variables2 := (l, v) :: !variables2; v in - let newvar = ref newvar1 in + let newvar = ref newvar1 in let rec coderec = function StringArg s -> "TkToken \"" ^ s ^ "\"" | TypeArg (_, List (Subtype (sup, sub))) when not !Flags.camltk -> @@ -663,13 +663,13 @@ let code_of_template ~context_widget ?func:(funtemplate=false) template = catch_opts := (sub ^ "_" ^ sup, lbl); newvar := newvar2; "TkTokenList opts" - with Not_found -> + with Not_found -> raise (Failure (Printf.sprintf "type %s(%s) not found" sup sub)); end | TypeArg (l, List ty) -> - (if !Flags.camltk then + (if !Flags.camltk then "TkTokenList (List.map (function x -> " - else + else "TkTokenList (List.map ~f:(function x -> ") ^ converterCAMLtoTK ~context_widget "x" ty ^ ") " ^ !newvar l ^ ")" @@ -680,18 +680,18 @@ let code_of_template ~context_widget ?func:(funtemplate=false) template = | TypeArg (l, ty) -> converterCAMLtoTK ~context_widget (!newvar l) ty | ListArg l -> "TkQuote (TkTokenList [" - ^ String.concat ~sep:";\n " (List.map ~f:coderec l) ^ "])" - | OptionalArgs (l, tl, d) -> + ^ String.concat ~sep:";\n " (List.map ~f:coderec l) ^ "])" + | OptionalArgs (l, tl, d) -> let nv = !newvar ("?" ^ l) in optionvar := Some nv; (* Store *) - let argstr = String.concat ~sep:"; " (List.map ~f:coderec tl) in + let argstr = String.concat ~sep:"; " (List.map ~f:coderec tl) in let defstr = String.concat ~sep:"; " (List.map ~f:coderec d) in "TkTokenList (match " ^ nv ^ " with\n" ^ " | Some " ^ nv ^ " -> [" ^ argstr ^ "]\n" ^ " | None -> [" ^ defstr ^ "])" in - let code = - if funtemplate then + let code = + if funtemplate then match template with ListArg l -> "[|" ^ String.concat ~sep:";\n " (List.map ~f:coderec l) ^ "|]" @@ -721,7 +721,7 @@ let labltk_write_clause ~w ~context_widget comp = code_of_template ~context_widget comp.template in (* no subtype I think ... *) - if co <> "" then raise (Failure "write_clause subtype ?"); + if co <> "" then raise (Failure "write_clause subtype ?"); begin match variables with | [] -> warrow() | [x] -> w " "; w (labeloff x ~at:"write_clause"); warrow() @@ -734,19 +734,19 @@ let labltk_write_clause ~w ~context_widget comp = w code let camltk_write_clause ~w ~context_widget ~subtype comp = - let warrow () = + let warrow () = w " -> "; - if subtype then + if subtype then w ("chk_sub \""^comp.ml_name^"\" table C" ^ comp.ml_name ^ "; ") in - w comp.ml_name; (* we use ml_name, not var_name, specialized for labltk *) + w comp.ml_name; (* we use ml_name, not var_name, specialized for labltk *) let code, variables, variables2, (co, _) = code_of_template ~context_widget comp.template in (* no subtype I think ... *) - if co <> "" then raise (Failure "write_clause subtype ?"); + if co <> "" then raise (Failure "write_clause subtype ?"); begin match variables with | [] -> warrow() | [x] -> w " "; w (labeloff x ~at:"write_clause"); warrow() @@ -767,7 +767,7 @@ let write_CAMLtoTK ~w ~def:typdef ?safetype:(st = true) name = let write_one name constrs = let subtype = typdef.subtypes <> [] in w ("let cCAMLtoTK" ^ name); - let context_widget = + let context_widget = if typdef.requires_widget_context then begin w " w"; "w" end @@ -784,7 +784,7 @@ let write_CAMLtoTK ~w ~def:typdef ?safetype:(st = true) name = ~f:(fun c -> w "\n | "; write_clause ~w ~context_widget ~subtype c); w "\n\n\n" in - + let constrs = typdef.constructors in if !Flags.camltk then write_one name constrs else begin @@ -813,7 +813,7 @@ let rec write_result_parsing ~w = function w (" List.map " ^ converterTKtoCAML ~arg:"(splitlist res)" ty) else w (" List.map ~f: " ^ converterTKtoCAML ~arg:"(splitlist res)" ty) - | Product tyl -> raise (Failure "Product -> record was done. ???") + | Product tyl -> raise (Failure "Product -> record was done. ???") | Record tyl -> (* of course all the labels are "" *) let rnames = varnames ~prefix:"r" (List.length tyl) in w " let l = splitlist res in"; @@ -822,7 +822,7 @@ let rec write_result_parsing ~w = function w ("\n else "); List.iter2 rnames tyl ~f: begin fun r (l, ty) -> - if l <> "" then raise (Failure "lables in return type!!!"); + if l <> "" then raise (Failure "lables in return type!!!"); w (" let " ^ r ^ ", l = "); begin match type_parser_arity ty with OneToken -> @@ -852,7 +852,7 @@ let labltk_write_function ~w def = let code, variables, variables2, (co, lbl) = code_of_template ~func:true ~context_widget def.template in (* Arguments *) - let uv, lv, ov = + let uv, lv, ov = let rec replace_args ~u ~l ~o = function [] -> u, l, o | ("", x) :: ls -> @@ -901,7 +901,7 @@ let camltk_write_function ~w def = let code, variables, variables2, (co, lbl) = code_of_template ~func:true ~context_widget def.template in (* Arguments *) - let uv, ov = + let uv, ov = let rec replace_args ~u ~o = function [] -> u, o | ("", x) :: ls -> @@ -943,20 +943,20 @@ let camltk_write_function ~w def = (* Arguments *) begin match variables with [] -> w " () =\n" - | l -> + | l -> let has_normal_argument = ref false in - List.iter (fun (l,x) -> + List.iter (fun (l,x) -> w " "; - if l <> "" then + if l <> "" then if l.[0] = '?' then w (l ^ ":") else has_normal_argument := true else has_normal_argument := true; - w x) l; + w x) l; if not !has_normal_argument then w " ()"; w " =\n" end; begin match def.result with | Unit | As (Unit, _) -> w "tkCommand "; w code - | ty -> + | ty -> w "let res = tkEval "; w code ; w " in \n"; write_result_parsing ~w ty end; @@ -1028,10 +1028,10 @@ let write_external ~w def = let code_list = Ppparse.parse_channel ic in close_in ic; List.iter (Ppexec.exec (fun _ -> ()) w) - (if !Flags.camltk then + (if !Flags.camltk then Code.Define "CAMLTK" :: code_list else code_list ); with - | Ppparse.Error s -> + | Ppparse.Error s -> close_in ic; raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s)) with @@ -1046,7 +1046,7 @@ let write_catch_optionals ~w clas ~def:typdef = begin fun (subclass, classdefs) -> w ("let " ^ subclass ^ "_" ^ clas ^ "_optionals f = fun\n"); let tklabels = List.map ~f:gettklabel classdefs in - let l = + let l = List.map classdefs ~f: begin fun fc -> (* diff --git a/otherlibs/labltk/compiler/intf.ml b/otherlibs/labltk/compiler/intf.ml index 58955b962b..59608b3815 100644 --- a/otherlibs/labltk/compiler/intf.ml +++ b/otherlibs/labltk/compiler/intf.ml @@ -26,7 +26,7 @@ open Compile let labltk_write_create_p ~w wname = w "val create :\n ?name:string ->\n"; begin - try + try let option = Hashtbl.find types_table "options" in let classdefs = List.assoc wname option.subtypes in let tklabels = List.map ~f:gettklabel classdefs in @@ -37,7 +37,7 @@ let labltk_write_create_p ~w wname = end, fc.template end in - w (String.concat ~sep:" ->\n" + w (String.concat ~sep:" ->\n" (List.map l ~f: begin fun (s, t) -> " ?" ^ s ^ ":" @@ -58,7 +58,7 @@ let camltk_write_create_p ~w wname = w "val create : ?name: string -> widget -> options list -> widget \n"; w "(** [create ?name parent options] creates a new widget with\n"; w " parent [parent] and new patch component [name] if specified.\n"; - w " Options are restricted to the widget class subset, and checked\n"; + w " Options are restricted to the widget class subset, and checked\n"; w " dynamically. *)\n\n" ;; @@ -77,7 +77,7 @@ let labltk_write_function_type ~w def = let tys = types_of_template def.template in let rec replace_args ~u ~l ~o = function [] -> u, l, o - | (_, List(Subtype _) as x)::ls -> + | (_, List(Subtype _) as x)::ls -> replace_args ~u ~l ~o:(x::o) ls | ("", _ as x)::ls -> replace_args ~u:(x::u) ~l ~o ls @@ -144,7 +144,7 @@ let camltk_write_function_type ~w def = let have_normal_arg = ref false in List.iter tys ~f: begin fun (l, t) -> - if l <> "" then + if l <> "" then if l.[0] = '?' then w (l^":") else begin have_normal_arg := true; @@ -161,7 +161,7 @@ let camltk_write_function_type ~w def = else w "\n(* /unsafe *)\n" *) -let write_function_type ~w def = +let write_function_type ~w def = if !Flags.camltk then camltk_write_function_type ~w def else labltk_write_function_type ~w def @@ -176,12 +176,12 @@ let write_external_type ~w def = close_in ic; if not def.safe then w "(* unsafe *)\n"; List.iter (Ppexec.exec (fun _ -> ()) w) - (if !Flags.camltk then + (if !Flags.camltk then Code.Define "CAMLTK" :: code_list else code_list ); if def.safe then w "\n\n" else w "\n(* /unsafe *)\n\n" with - | Ppparse.Error s -> + | Ppparse.Error s -> close_in ic; raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s)) with diff --git a/otherlibs/labltk/compiler/lexer.mll b/otherlibs/labltk/compiler/lexer.mll index c65c9a604b..f51f0c01f3 100644 --- a/otherlibs/labltk/compiler/lexer.mll +++ b/otherlibs/labltk/compiler/lexer.mll @@ -40,7 +40,7 @@ let _ = List.iter "string", TYSTRING; "list", LIST; "as", AS; - "variant", VARIANT; + "variant", VARIANT; "widget", WIDGET; "option", OPTION; "type", TYPE; @@ -127,12 +127,12 @@ rule main = parse | "?" {QUESTION} | "/" {SLASH} | "%" { comment lexbuf; main lexbuf } - | "##line" { line lexbuf; main lexbuf } + | "##line" { line lexbuf; main lexbuf } | eof { EOF } | _ { raise (Lexical_error("illegal character")) } - + and string = parse '"' { () } @@ -160,7 +160,7 @@ and comment = parse | _ { comment lexbuf } and linenum = parse - | ['0'-'9']+ { + | ['0'-'9']+ { let next_line = int_of_string (Lexing.lexeme lexbuf) in current_line := next_line - 1 } diff --git a/otherlibs/labltk/compiler/maincompile.ml b/otherlibs/labltk/compiler/maincompile.ml index 80118fa9bd..d8c72a312d 100644 --- a/otherlibs/labltk/compiler/maincompile.ml +++ b/otherlibs/labltk/compiler/maincompile.ml @@ -24,7 +24,7 @@ open Compile open Intf let flag_verbose = ref false -let verbose_string s = +let verbose_string s = if !flag_verbose then prerr_string s let verbose_endline s = if !flag_verbose then prerr_endline s @@ -33,7 +33,7 @@ let input_name = ref "Widgets.src" let output_dir = ref "" let destfile f = Filename.concat !output_dir f -let usage () = +let usage () = prerr_string "Usage: tkcompiler input.src\n"; flush stderr; exit 1 @@ -53,15 +53,15 @@ let parse_file filename = let code_list = Ppparse.parse_channel ic in close_in ic; let buf = Buffer.create 50000 in - List.iter (Ppexec.exec + List.iter (Ppexec.exec (fun l -> Buffer.add_string buf (Printf.sprintf "##line %d\n" l)) (Buffer.add_string buf)) - (if !Flags.camltk then Code.Define "CAMLTK" :: code_list + (if !Flags.camltk then Code.Define "CAMLTK" :: code_list else code_list); Lexing.from_string (Buffer.contents buf) with - | Ppparse.Error s -> + | Ppparse.Error s -> close_in ic; raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s)) in @@ -110,9 +110,9 @@ let uniq_clauses = function let check_constr constr1 constr2 = if constr1.template <> constr2.template then begin - let code1, vars11, vars12, opts1 = + let code1, vars11, vars12, opts1 = code_of_template ~context_widget:"dummy" constr1.template in - let code2, vars12, vars22, opts2 = + let code2, vars12, vars22, opts2 = code_of_template ~context_widget:"dummy" constr2.template in let err = Printf.sprintf @@ -141,14 +141,14 @@ let option_hack oc = let hack = { parser_arity = OneToken; constructors = begin - let constrs = + let constrs = List.map typdef.constructors ~f: - begin fun c -> + begin fun c -> { component = Constructor; - ml_name = (if !Flags.camltk then "C" ^ c.ml_name + ml_name = (if !Flags.camltk then "C" ^ c.ml_name else c.ml_name); var_name = c.var_name; (* as variants *) - template = + template = begin match c.template with ListArg (x :: _) -> x | _ -> fatal_error "bogus hack" @@ -159,20 +159,20 @@ let option_hack oc = if !Flags.camltk then constrs else uniq_clauses constrs (* JPF ?? *) end; subtypes = []; - requires_widget_context = false; + requires_widget_context = false; variant = false } in write_CAMLtoTK ~w:(output_string oc) ~def:hack ~safetype:false "options_constrs" -let realname name = +let realname name = (* module name fix for camltk *) if !Flags.camltk then "c" ^ String.capitalize name else name ;; (* analize the parsed Widget.src and output source files *) -let compile () = +let compile () = verbose_endline "Creating _tkgen.ml ..."; let oc = open_out_bin (destfile "_tkgen.ml") in let oc' = open_out_bin (destfile "_tkigen.ml") in @@ -197,7 +197,7 @@ let compile () = if not !Flags.camltk then (* only for LablTk *) write_catch_optionals ~w:(output_string oc') typname ~def:typdef; verbose_endline "." - with Not_found -> + with Not_found -> if not (List.mem_assoc typname !types_external) then begin verbose_string "Type "; @@ -224,8 +224,8 @@ let compile () = let write_module wname wdef = verbose_endline (" "^wname); let modname = realname wname in - let oc = open_out_bin (destfile (modname ^ ".ml")) - and oc' = open_out_bin (destfile (modname ^ ".mli")) in + let oc = open_out_bin (destfile (modname ^ ".ml")) + and oc' = open_out_bin (destfile (modname ^ ".mli")) in Copyright.write ~w:(output_string oc); Copyright.write ~w:(output_string oc'); begin match wdef.module_type with @@ -260,11 +260,11 @@ let compile () = end | Family -> () end; - List.iter ~f:(write_function ~w:(output_string oc)) + List.iter ~f:(write_function ~w:(output_string oc)) (sort_components wdef.commands); List.iter ~f:(write_function_type ~w:(output_string oc')) (sort_components wdef.commands); - List.iter ~f:(write_external ~w:(output_string oc)) + List.iter ~f:(write_external ~w:(output_string oc)) (sort_components wdef.externals); List.iter ~f:(write_external_type ~w:(output_string oc')) (sort_components wdef.externals); @@ -276,7 +276,7 @@ let compile () = if !Flags.camltk then begin let oc = open_out_bin (destfile "camltk.ml") in Copyright.write ~w:(output_string oc); - output_string oc + output_string oc "(** This module Camltk provides the module name spaces of the CamlTk API.\n\ \n\ The users of the CamlTk API should open this module first to access\n\ @@ -319,9 +319,9 @@ module Timer = Timer;;\n\ Hashtbl.iter (fun name def -> match def.module_type with | Widget -> - output_string oc (Printf.sprintf + output_string oc (Printf.sprintf "let %s (w : any widget) =\n" name); - output_string oc (Printf.sprintf + output_string oc (Printf.sprintf " Rawwidget.check_class w widget_%s_table;\n" name); output_string oc (Printf.sprintf " (Obj.magic w : %s widget);;\n\n" name); diff --git a/otherlibs/labltk/compiler/parser.mly b/otherlibs/labltk/compiler/parser.mly index c797f4fb5b..15ced65f8d 100644 --- a/otherlibs/labltk/compiler/parser.mly +++ b/otherlibs/labltk/compiler/parser.mly @@ -31,7 +31,7 @@ open Tables %token RPAREN /* ")" */ %token COMMA /* "," */ %token SEMICOLON /* ";" */ -%token COLON /* ":" */ +%token COLON /* ":" */ %token QUESTION /* "?" */ %token LBRACKET /* "[" */ %token RBRACKET /* "]" */ @@ -86,11 +86,11 @@ Type0 : /* Camltk/Labltk types */ Type0_5: | Type0 SLASH Type0 { if !Flags.camltk then $1 else $3 } - | Type0 { $1 } + | Type0 { $1 } ; /* with subtypes */ -Type1 : +Type1 : Type0_5 { $1 } | TypeName LPAREN IDENT RPAREN @@ -141,8 +141,8 @@ FType : LPAREN RPAREN { Unit } | LPAREN Type2 RPAREN - { $2 } - | LPAREN Type_record RPAREN + { $2 } + | LPAREN Type_record RPAREN { Record $2 } ; @@ -168,7 +168,7 @@ Arg: | Type {TypeArg ("", $1) } | IDENT COLON Type - {TypeArg ($1, $3)} + {TypeArg ($1, $3)} | QUESTION IDENT COLON LBRACKET SimpleArgList RBRACKET DefaultList {OptionalArgs ( $2, $5, $7 )} | QUESTION WIDGET COLON LBRACKET SimpleArgList RBRACKET DefaultList @@ -212,14 +212,14 @@ Template : /* Constructors for type declarations */ Constructor : IDENT Template - {{ component = Constructor; + {{ component = Constructor; ml_name = $1; var_name = getvarname $1 $2; template = $2; result = Unit; safe = true }} | IDENT LPAREN IDENT RPAREN Template - {{ component = Constructor; + {{ component = Constructor; ml_name = $1; var_name = $3; template = $5; @@ -290,7 +290,7 @@ WidgetComponents : { $1 :: $2 } ; -ModuleComponents : +ModuleComponents : /* */ { [] } | Command ModuleComponents @@ -319,7 +319,7 @@ entry : { enter_subtype "options" $2 $5 $8 } | SUBTYPE ParserArity TypeName LPAREN IDENT RPAREN LBRACE AbbrevConstructors RBRACE { enter_subtype $3 $2 $5 $8 } -| Command +| Command { enter_function $1 } | WIDGET IDENT LBRACE WidgetComponents RBRACE { enter_widget $2 $4 } diff --git a/otherlibs/labltk/compiler/ppexec.ml b/otherlibs/labltk/compiler/ppexec.ml index 9946882030..71118b9601 100644 --- a/otherlibs/labltk/compiler/ppexec.ml +++ b/otherlibs/labltk/compiler/ppexec.ml @@ -32,9 +32,9 @@ let rec nop = function ;; let rec exec lp f = function - | Line line -> - if !debug then - prerr_endline (Printf.sprintf "%03d: %s" !linenum + | Line line -> + if !debug then + prerr_endline (Printf.sprintf "%03d: %s" !linenum (String.sub line 0 ((String.length line) - 1))); f line; incr linenum | Ifdef (sw, k, c1, c2o) -> @@ -48,13 +48,13 @@ let rec exec lp f = function end else begin List.iter nop c1; match c2o with - | Some c2 -> + | Some c2 -> lp !linenum; List.iter (exec lp f) c2 | None -> () end | Define k -> defined := k :: !defined - | Undef k -> + | Undef k -> defined := List.fold_right (fun k' s -> if k = k' then s else k' :: s) [] !defined ;; diff --git a/otherlibs/labltk/compiler/pplex.mll b/otherlibs/labltk/compiler/pplex.mll index 61ca9f4b4d..313d1f2dd5 100644 --- a/otherlibs/labltk/compiler/pplex.mll +++ b/otherlibs/labltk/compiler/pplex.mll @@ -18,10 +18,10 @@ open Ppyac exception Error of string let linenum = ref 1 -} +} let blank = [' ' '\013' '\009' '\012'] -let identchar = +let identchar = ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] @@ -29,10 +29,10 @@ let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] rule token = parse blank + { token lexbuf } | "##" [' ' '\t']* { directive lexbuf } -| ("#")? [^ '#' '\n']* '\n'? { +| ("#")? [^ '#' '\n']* '\n'? { begin let str = Lexing.lexeme lexbuf in - if String.length str <> 0 && str.[String.length str - 1] = '\n' then + if String.length str <> 0 && str.[String.length str - 1] = '\n' then begin incr linenum end; @@ -51,6 +51,6 @@ and directive = parse | _ { raise (Error (Printf.sprintf "unknown directive at line %d" !linenum))} and ident = parse -| lowercase identchar* | uppercase identchar* +| lowercase identchar* | uppercase identchar* { Lexing.lexeme lexbuf } | _ { raise (Error (Printf.sprintf "illegal identifier at line %d" !linenum)) } diff --git a/otherlibs/labltk/compiler/ppparse.ml b/otherlibs/labltk/compiler/ppparse.ml index 3d1ee2af4f..630d675dec 100644 --- a/otherlibs/labltk/compiler/ppparse.ml +++ b/otherlibs/labltk/compiler/ppparse.ml @@ -19,18 +19,18 @@ exception Error of string let parse_channel ic = let lexbuf = Lexing.from_channel ic in try - Ppyac.code_list Pplex.token lexbuf + Ppyac.code_list Pplex.token lexbuf with | Pplex.Error s -> - let loc_start = Lexing.lexeme_start lexbuf + let loc_start = Lexing.lexeme_start lexbuf and loc_end = Lexing.lexeme_end lexbuf in - raise (Error (Printf.sprintf "parse error at char %d, %d: %s" + raise (Error (Printf.sprintf "parse error at char %d, %d: %s" loc_start loc_end s)) | Parsing.Parse_error -> - let loc_start = Lexing.lexeme_start lexbuf + let loc_start = Lexing.lexeme_start lexbuf and loc_end = Lexing.lexeme_end lexbuf in - raise (Error (Printf.sprintf "parse error at char %d, %d" + raise (Error (Printf.sprintf "parse error at char %d, %d" loc_start loc_end)) ;; diff --git a/otherlibs/labltk/compiler/printer.ml b/otherlibs/labltk/compiler/printer.ml index 60362d17fb..be70612aa2 100644 --- a/otherlibs/labltk/compiler/printer.ml +++ b/otherlibs/labltk/compiler/printer.ml @@ -121,7 +121,7 @@ let rec print_component_type = function (* Full definition of a component *) let rec print_fullcomponent = function {component = c; ml_name = s; var_name = s0; template = t; result = m; - safe = b; + safe = b; } -> printf "@[<1>{"; printf "@[<1>component =@ "; print_component_type c; printf ";@]@ "; printf "@[<1>ml_name =@ "; print_quoted_string s; @@ -137,7 +137,7 @@ let rec print_component = function printf "@[<1>(%s@ " "Abbrev"; print_quoted_string s; printf ")@]";; (* A type definition *) -(* +(* requires_widget_context: the converter of the type MUST be passed an additional argument of type Widget. *) @@ -146,7 +146,7 @@ let rec print_parser_arity = function let rec print_type_def = function {parser_arity = p; constructors = l_f; subtypes = l_t_s_l_f; - requires_widget_context = b; variant = b0; + requires_widget_context = b; variant = b0; } -> printf "@[<1>{"; printf "@[<1>parser_arity =@ "; print_parser_arity p; printf ";@]@ "; printf "@[<1>constructors =@ "; diff --git a/otherlibs/labltk/compiler/tables.ml b/otherlibs/labltk/compiler/tables.ml index 0d395cdc2f..0663dfaadd 100644 --- a/otherlibs/labltk/compiler/tables.ml +++ b/otherlibs/labltk/compiler/tables.ml @@ -21,7 +21,7 @@ open Support (* Internal compiler errors *) -exception Compiler_Error of string +exception Compiler_Error of string let fatal_error s = raise (Compiler_Error s) @@ -68,12 +68,12 @@ let sort_components = (* components are given either in full or abbreviated *) -type component = +type component = Full of fullcomponent | Abbrev of string (* A type definition *) -(* +(* requires_widget_context: the converter of the type MUST be passed an additional argument of type Widget. *) @@ -117,7 +117,7 @@ let module_table = (Hashtbl.create 37 : (string, module_def) Hashtbl.t) (* variant name *) -let rec getvarname ml_name temp = +let rec getvarname ml_name temp = let offhypben s = let s = String.copy s in if (try String.sub s ~pos:0 ~len:1 with _ -> "") = "-" then @@ -125,7 +125,7 @@ let rec getvarname ml_name temp = else s and makecapital s = begin - try + try let cd = s.[0] in if cd >= 'a' && cd <= 'z' then s.[0] <- Char.chr (Char.code cd + (Char.code 'A' - Char.code 'a')) @@ -137,24 +137,24 @@ let rec getvarname ml_name temp = let head = makecapital (offhypben begin match temp with StringArg s -> s - | TypeArg (s,t) -> s + | TypeArg (s,t) -> s | ListArg (h::_) -> getvarname ml_name h | OptionalArgs (s,_,_) -> s | ListArg [] -> "" end) in - let varname = if head = "" then ml_name - else if head.[0] >= 'A' && head.[0] <= 'Z' then head + let varname = if head = "" then ml_name + else if head.[0] >= 'A' && head.[0] <= 'Z' then head else ml_name in varname (***** Some utilities on the various tables *****) (* Enter a new empty type *) -let new_type typname arity = +let new_type typname arity = Tsort.add_element types_order typname; let typdef = {parser_arity = arity; - constructors = []; - subtypes = []; + constructors = []; + subtypes = []; requires_widget_context = false; variant = false} in Hashtbl.add types_table typname typdef; @@ -165,23 +165,23 @@ let new_type typname arity = (* Widget is builtin and implicitly subtyped *) let is_subtyped s = s = "widget" || - try + try let typdef = Hashtbl.find types_table s in typdef.subtypes <> [] with Not_found -> false -let requires_widget_context s = - try +let requires_widget_context s = + try (Hashtbl.find types_table s).requires_widget_context with Not_found -> false -let declared_type_parser_arity s = - try +let declared_type_parser_arity s = + try (Hashtbl.find types_table s).parser_arity with - Not_found -> + Not_found -> try List.assoc s !types_external with Not_found -> @@ -225,8 +225,8 @@ let rec enter_template_types = function StringArg _ -> () | TypeArg (l,t) -> enter_argtype t | ListArg l -> List.iter ~f:enter_template_types l - | OptionalArgs (_,tl,_) -> List.iter ~f:enter_template_types tl - + | OptionalArgs (_,tl,_) -> List.iter ~f:enter_template_types tl + (* Find type dependancies on s *) let rec add_dependancies s = function @@ -253,7 +253,7 @@ let rec has_callback = function | OptionalArgs (_,tl,_) -> List.exists ~f:has_callback tl (*** Returned types ***) -let really_add ty = +let really_add ty = if List.mem ty !types_returned then () else types_returned := ty :: !types_returned @@ -266,7 +266,7 @@ let rec add_return_type = function | String -> () | List ty -> add_return_type ty | Product tyl -> List.iter ~f:add_return_type tyl - | Record tyl -> List.iter tyl ~f:(fun (l,t) -> add_return_type t) + | Record tyl -> List.iter tyl ~f:(fun (l,t) -> add_return_type t) | UserDefined s -> really_add s | Subtype (s,_) -> really_add s | Function _ -> fatal_error "unexpected return type (function)" (* whoah *) @@ -287,9 +287,9 @@ exception Invalid_implicit_constructor of string let rec check_duplicate_constr allowed c = function [] -> false (* not defined *) - | c'::rest -> + | c'::rest -> if c.ml_name = c'.ml_name then (* defined *) - if allowed then + if allowed then if c.template = c'.template then true (* same arg *) else raise (Duplicate_Definition ("constructor",c.ml_name)) else raise (Duplicate_Definition ("constructor", c.ml_name)) @@ -306,16 +306,16 @@ let enter_type typname ?(variant = false) arity constructors = if Hashtbl.mem types_table typname then raise (Duplicate_Definition ("type", typname)) else let typdef = new_type typname arity in - if variant then typdef.variant <- true; + if variant then typdef.variant <- true; List.iter constructors ~f: begin fun c -> if not (check_duplicate_constr false c typdef.constructors) - then begin + then begin typdef.constructors <- c :: typdef.constructors; add_template_dependancies typname c.template end; (* Callbacks require widget context *) - typdef.requires_widget_context <- + typdef.requires_widget_context <- typdef.requires_widget_context || has_callback c.template end @@ -323,17 +323,17 @@ let enter_type typname ?(variant = false) arity constructors = (* Enter a subtype *) let enter_subtype typ arity subtyp constructors = (* Retrieve the type if already defined, else add a new one *) - let typdef = + let typdef = try Hashtbl.find types_table typ with Not_found -> new_type typ arity in if List.mem_assoc subtyp typdef.subtypes then raise (Duplicate_Definition ("subtype", typ ^" "^subtyp)) else begin - let real_constructors = + let real_constructors = List.map constructors ~f: begin function - Full c -> + Full c -> if not (check_duplicate_constr true c typdef.constructors) then begin add_template_dependancies typ c.template; @@ -359,10 +359,10 @@ let enter_subtype typ arity subtyp constructors = let retrieve_option optname = let optiontyp = try Hashtbl.find types_table "options" - with + with Not_found -> raise (Invalid_implicit_constructor optname) in find_constructor optname optiontyp.constructors - + (* Sort components by type *) let rec add_sort l obj = match l with @@ -370,7 +370,7 @@ let rec add_sort l obj = | (s',l)::rest -> if obj.component = s' then (s',obj::l)::rest - else + else (s',l)::(add_sort rest obj) let separate_components = List.fold_left ~f:add_sort ~init:[] @@ -380,24 +380,24 @@ let enter_widget name components = raise (Duplicate_Definition ("widget/module", name)) else let sorted_components = separate_components components in List.iter sorted_components ~f: - begin function + begin function Constructor, l -> - enter_subtype "options" MultipleToken + enter_subtype "options" MultipleToken name (List.map ~f:(fun c -> Full c) l) - | Command, l -> + | Command, l -> List.iter ~f:enter_component_types l | External, _ -> () end; - let commands = + let commands = try List.assoc Command sorted_components - with Not_found -> [] - and externals = + with Not_found -> [] + and externals = try List.assoc External sorted_components with Not_found -> [] in - Hashtbl.add module_table name + Hashtbl.add module_table name {module_type = Widget; commands = commands; externals = externals} - + (******************** Functions ********************) let enter_function comp = @@ -406,22 +406,22 @@ let enter_function comp = (******************** Modules ********************) -let enter_module name components = +let enter_module name components = if Hashtbl.mem module_table name then raise (Duplicate_Definition ("widget/module", name)) else let sorted_components = separate_components components in List.iter sorted_components ~f: - begin function + begin function Constructor, l -> fatal_error "unexpected Constructor" | Command, l -> List.iter ~f:enter_component_types l | External, _ -> () end; - let commands = + let commands = try List.assoc Command sorted_components - with Not_found -> [] - and externals = + with Not_found -> [] + and externals = try List.assoc External sorted_components with Not_found -> [] in - Hashtbl.add module_table name + Hashtbl.add module_table name {module_type = Family; commands = commands; externals = externals} diff --git a/otherlibs/labltk/compiler/tsort.ml b/otherlibs/labltk/compiler/tsort.ml index a174fb3da4..6496eaae22 100644 --- a/otherlibs/labltk/compiler/tsort.ml +++ b/otherlibs/labltk/compiler/tsort.ml @@ -35,7 +35,7 @@ exception Cyclic let find_entry order node = let rec search_entry = - function + function [] -> raise Not_found | x::l -> if x.node = node then x else search_entry l in @@ -48,7 +48,7 @@ let find_entry order node = order := entry::!order; entry -let create () = ref [] +let create () = ref [] (* Inverted args because Sort.list builds list in reverse order *) let add_relation order (succ,pred) = @@ -62,28 +62,26 @@ let add_element order e = ignore (find_entry order e) let sort order = - let q = Queue.create () + let q = Queue.create () and result = ref [] in List.iter !order ~f:(function {pred_count = n} as node -> if n = 0 then Queue.add node q); - begin try + begin try while true do let t = Queue.take q in result := t.node :: !result; List.iter t.successors ~f: - begin fun s -> + begin fun s -> let n = s.pred_count - 1 in s.pred_count <- n; if n = 0 then Queue.add s q end done with - Queue.Empty -> + Queue.Empty -> List.iter !order ~f:(fun node -> if node.pred_count <> 0 then raise Cyclic) end; !result - - diff --git a/otherlibs/labltk/examples_camltk/Makefile b/otherlibs/labltk/examples_camltk/Makefile index 42613054b4..52de5cd05e 100644 --- a/otherlibs/labltk/examples_camltk/Makefile +++ b/otherlibs/labltk/examples_camltk/Makefile @@ -8,10 +8,10 @@ all: addition$(EXE) helloworld$(EXE) winskel$(EXE) fileinput$(EXE) \ eyes$(EXE) tetris$(EXE) mytext$(EXE) fileopen$(EXE) addition$(EXE): addition.cmo - $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma addition.cmo + $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma addition.cmo helloworld$(EXE): helloworld.cmo - $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma helloworld.cmo + $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma helloworld.cmo winskel$(EXE): winskel.cmo $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma winskel.cmo @@ -33,13 +33,13 @@ mytext$(EXE): mytext.cmo # graph$(EXE): graphics.cmo graphics_test.cmo # $(CAMLC) -o $@ graphics.cmo graphics_test.cmo -# +# # graphics_test.cmo: graphics.cmo fileopen$(EXE): fileopen.cmo $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma fileopen.cmo -clean : +clean : rm -f *.cm? $(EXECS) addition eyes fileinput fileopen helloworld jptest mytext tetris winskel .SUFFIXES : diff --git a/otherlibs/labltk/examples_camltk/Makefile.nt b/otherlibs/labltk/examples_camltk/Makefile.nt index d07471bc06..bc6589ca5b 100644 --- a/otherlibs/labltk/examples_camltk/Makefile.nt +++ b/otherlibs/labltk/examples_camltk/Makefile.nt @@ -11,11 +11,11 @@ all: addition.exe helloworld.exe winskel.exe socketinput.exe addition.exe: addition.cmo $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ - -o $@ addition.cmo + -o $@ addition.cmo helloworld.exe: helloworld.cmo $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ - -o $@ helloworld.cmo + -o $@ helloworld.cmo winskel.exe: winskel.cmo $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ @@ -25,7 +25,7 @@ socketinput.exe: socketinput.cmo $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) unix.cma \ -o $@ socketinput.cmo -clean : +clean : rm -f *.cm? *.exe .SUFFIXES : diff --git a/otherlibs/labltk/examples_camltk/eyes.ml b/otherlibs/labltk/examples_camltk/eyes.ml index 5666c69c55..b5195307cc 100644 --- a/otherlibs/labltk/examples_camltk/eyes.ml +++ b/otherlibs/labltk/examples_camltk/eyes.ml @@ -42,9 +42,9 @@ let _ = (BindExtend ([Ev_MouseX; Ev_MouseY], (fun e -> let nx, ny = - let xdiff = e.ev_MouseX - cx + let xdiff = e.ev_MouseX - cx and ydiff = e.ev_MouseY - cy in - let diff = sqrt ((float xdiff /. (float wx *. bnd)) ** 2.0 +. + let diff = sqrt ((float xdiff /. (float wx *. bnd)) ** 2.0 +. (float ydiff /. (float wy *. bnd)) ** 2.0) in if diff > 1.0 then truncate ((float xdiff) *. (1.0 /. diff)) + cx, @@ -61,7 +61,3 @@ let _ = pack [c] [] let _ = Printexc.print mainLoop () - - - - diff --git a/otherlibs/labltk/examples_camltk/helloworld.ml b/otherlibs/labltk/examples_camltk/helloworld.ml index b32b515ae3..bb99d9dd54 100644 --- a/otherlibs/labltk/examples_camltk/helloworld.ml +++ b/otherlibs/labltk/examples_camltk/helloworld.ml @@ -19,16 +19,16 @@ let top = opentk ();; (* Initialisation of the interface *) (* top is now the toplevel widget *) (* Widget initialisation *) -let b = Button.create top - [Text "foobar"; - Command (function () -> - print_string "foobar"; +let b = Button.create top + [Text "foobar"; + Command (function () -> + print_string "foobar"; print_newline(); flush stdout)];; (* b exists but is not yet visible *) -let q = Button.create top - [Text "quit"; +let q = Button.create top + [Text "quit"; Command closeTk];; (* q exists but is not yet visible *) diff --git a/otherlibs/labltk/examples_camltk/mytext.ml b/otherlibs/labltk/examples_camltk/mytext.ml index 0695d931aa..d4c0d00b09 100644 --- a/otherlibs/labltk/examples_camltk/mytext.ml +++ b/otherlibs/labltk/examples_camltk/mytext.ml @@ -28,15 +28,15 @@ let scrollbar = Scrollbar.create f [] (* kill buffer *) let buffer = ref "" -(* Note: for the text widgets, the insertion cursor is +(* Note: for the text widgets, the insertion cursor is not TextIndex(Insert, []), - but TextIndex(Mark "insert", []) -*) + but TextIndex(Mark "insert", []) +*) let insertMark = TextIndex(Mark "insert", []) let eol_insertMark = TextIndex(Mark "insert", [LineEnd]) let kill () = - buffer := + buffer := Text.get text insertMark eol_insertMark; prerr_endline ("Killed: " ^ !buffer); Text.delete text insertMark eol_insertMark @@ -60,4 +60,3 @@ let _ = mainLoop () ;; - diff --git a/otherlibs/labltk/examples_camltk/socketinput.ml b/otherlibs/labltk/examples_camltk/socketinput.ml index d23b8fd5e1..492fdc926f 100644 --- a/otherlibs/labltk/examples_camltk/socketinput.ml +++ b/otherlibs/labltk/examples_camltk/socketinput.ml @@ -40,4 +40,3 @@ let _ = bind entry0_w [([], KeyPressDetail "Return")] (BindSet ([], send)); pack [text0_w; entry0_w; button0_w][Side Side_Top; Fill Fill_X; Expand true]; mainLoop () - diff --git a/otherlibs/labltk/examples_camltk/tetris.ml b/otherlibs/labltk/examples_camltk/tetris.ml index 79d9e3f1a5..e8bb69e473 100644 --- a/otherlibs/labltk/examples_camltk/tetris.ml +++ b/otherlibs/labltk/examples_camltk/tetris.ml @@ -21,7 +21,7 @@ open Camltk exception Done -type cell = {mutable color : int; +type cell = {mutable color : int; tag : tagOrId * tagOrId * tagOrId} type falling_block = { @@ -50,7 +50,7 @@ let colors = [| let baseurl = "images/" -let backgrounds = +let backgrounds = List.map (fun s -> baseurl ^ s) [ "dojoji.back.gif"; "Lambda2back.gif"; @@ -105,7 +105,7 @@ let blocks = [ [ [|"0000"; "0111"; "0100"; - "0000" |]; + "0000" |]; [|"0000"; "0110"; @@ -125,7 +125,7 @@ let blocks = [ [ [|"0000"; "0100"; "0111"; - "0000" |]; + "0000" |]; [|"0000"; "0110"; @@ -223,7 +223,7 @@ let init fw = BorderWidth (Pixels cell_border); Relief Sunken; Background Black] - and r = Frame.create f [] + and r = Frame.create f [] and r' = Frame.create f [] in let nl = Label.create r [Text "Next"; Font "variable"] in @@ -231,13 +231,13 @@ let init fw = Height (Pixels (block_size * 4)); BorderWidth (Pixels cell_border); Relief Sunken; - Background Black] in + Background Black] in let scl = Label.create r [Text "Score"; Font "variable"] in let sc = Label.create r [TextVariable scorev; Font "variable"] in let lnl = Label.create r [Text "Lines"; Font "variable"] in let ln = Label.create r [TextVariable linev; Font "variable"] in let levl = Label.create r [Text "Level"; Font "variable"] in - let lev = Label.create r [TextVariable levv; Font "Variable"] in + let lev = Label.create r [TextVariable levv; Font "Variable"] in let newg = Button.create r [Text "New Game"; Font "variable"] in let exitg = Button.create r [Text "Quit"; Font "variable"] in @@ -248,15 +248,15 @@ let init fw = let cells_src = Array.create 20 (Array.create 10 ()) in let cells = Array.map (Array.map (fun () -> - {tag= + {tag= (let t1, t2, t3 = - Canvas.create_rectangle c + Canvas.create_rectangle c (Pixels (-block_size - 8)) (Pixels (-block_size - 8)) (Pixels (-9)) (Pixels (-9)) [], - Canvas.create_rectangle c + Canvas.create_rectangle c (Pixels (-block_size - 10)) (Pixels (-block_size - 10)) (Pixels (-11)) (Pixels (-11)) [], - Canvas.create_rectangle c + Canvas.create_rectangle c (Pixels (-block_size - 12)) (Pixels (-block_size - 12)) (Pixels (-13)) (Pixels (-13)) [] in @@ -267,17 +267,17 @@ let init fw = color= 0})) cells_src in let nexts_src = Array.create 4 (Array.create 4 ()) in - let nexts = + let nexts = Array.map (Array.map (fun () -> - {tag= + {tag= (let t1, t2, t3 = - Canvas.create_rectangle nc + Canvas.create_rectangle nc (Pixels (-block_size - 8)) (Pixels (-block_size - 8)) (Pixels (-9)) (Pixels (-9)) [], - Canvas.create_rectangle nc + Canvas.create_rectangle nc (Pixels (-block_size - 10)) (Pixels (-block_size - 10)) (Pixels (-11)) (Pixels (-11)) [], - Canvas.create_rectangle nc + Canvas.create_rectangle nc (Pixels (-block_size - 12)) (Pixels (-block_size - 12)) (Pixels (-13)) (Pixels (-13)) [] in @@ -290,14 +290,14 @@ let init fw = in [f; c; r; nl; nc; scl; sc; levl; lev; lnl; ln], newg, exitg, (c, cells), (nc, nexts), scorev, linev, levv, game_over - + let cell_get (c, cf) x y = (Array.get (Array.get cf y) x).color let cell_set (c, cf) x y col = let cur = Array.get (Array.get cf y) x in - let t1,t2,t3 = cur.tag in - if cur.color = col then () + let t1,t2,t3 = cur.tag in + if cur.color = col then () else if cur.color <> 0 && col = 0 then begin @@ -314,7 +314,7 @@ let cell_set (c, cf) x y col = else begin Canvas.configure_rectangle c t2 - [FillColor (Array.get colors (col - 1)); + [FillColor (Array.get colors (col - 1)); Outline (Array.get colors (col - 1))]; Canvas.configure_rectangle c t1 [FillColor Black; @@ -333,7 +333,7 @@ let cell_set (c, cf) x y col = Canvas.move c t3 (Pixels (block_size * (x+1)+10+ cell_border*2)) (Pixels (block_size * (y+1)+10+ cell_border*2)) - end + end end; cur.color <- col @@ -344,18 +344,18 @@ let draw_block field col d x y = for ix = 0 to 3 do if xd land !base <> 0 then begin - try cell_set field (ix + x) (iy + y) col with _ -> () - end + try cell_set field (ix + x) (iy + y) col with _ -> () + end else begin (* cell_set field (ix + x) (iy + y) 0 *) () end; - base := !base lsl 1 + base := !base lsl 1 done - done + done let timer_ref = (ref None : Timer.t option ref) -(* I know, this should be timer ref, but I'm not sure what should be +(* I know, this should be timer ref, but I'm not sure what should be the initial value ... *) let remove_timer () = @@ -366,13 +366,13 @@ let remove_timer () = let do_after milli f = timer_ref := Some (Timer.add milli f) -let copy_block c = +let copy_block c = { pattern= !c.pattern; bcolor= !c.bcolor; x= !c.x; y= !c.y; d= !c.d; - alive= !c.alive } + alive= !c.alive } let _ = let top = opentk () in @@ -380,7 +380,7 @@ let _ = and fw = Frame.create top [] in let set_message s = Label.configure lb [Text s] in - pack [lb; fw] [Side Side_Top]; + pack [lb; fw] [Side Side_Top]; let score = ref 0 in let line = ref 0 in let level = ref 0 in @@ -388,7 +388,7 @@ let _ = let blocks = List.map (List.map decode_block) blocks in let field = Array.create 26 0 in let widgets, newg, exitg, cell_field, next_field, - scorev, linev, levv, game_over = + scorev, linev, levv, game_over = init fw in let canvas = fst cell_field in @@ -406,11 +406,11 @@ let _ = for j = 0 to 3 do cell_set next_field j i 0 done - done + done in let draw_falling_block fb = - draw_block cell_field fb.bcolor + draw_block cell_field fb.bcolor (List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3) and erase_falling_block fb = @@ -430,21 +430,21 @@ let _ = and clear fb = let l = ref 0 in for i = 0 to 3 do - if i + fb.y >= 3 && i + fb.y <= 22 then + if i + fb.y >= 3 && i + fb.y <= 22 then if field.(i + fb.y) = line_full then begin incr l; field.(i + fb.y) <- line_empty; for j = 0 to 9 do - cell_set cell_field j (i + fb.y - 3) 0 + cell_set cell_field j (i + fb.y - 3) 0 done - end + end done; !l and fall_lines () = let eye = ref 22 (* bottom *) - and cur = ref 22 (* bottom *) + and cur = ref 22 (* bottom *) in try while !eye >= 3 do @@ -457,7 +457,7 @@ let _ = cell_set cell_field j (!cur-3) (cell_get cell_field j (!eye-3)) done; decr eye; - decr cur + decr cur done with Done -> (); for i = 3 to !cur do @@ -474,14 +474,14 @@ let _ = in let draw_next () = - draw_block next_field (!next+1) (List.hd (List.nth blocks !next)) 0 0 + draw_block next_field (!next+1) (List.hd (List.nth blocks !next)) 0 0 and erase_next () = - draw_block next_field 0 (List.hd (List.nth blocks !next)) 0 0 + draw_block next_field 0 (List.hd (List.nth blocks !next)) 0 0 in let set_nextblock () = - current := + current := { pattern= (List.nth blocks !next); bcolor= !next+1; x=6; y= 1; d= 0; alive= true}; @@ -494,11 +494,11 @@ let _ = try for i=0 to 3 do let cur = field.(i + fb.y) in - if cur land ((List.nth fb.pattern fb.d).(i) lsl fb.x) <> 0 + if cur land ((List.nth fb.pattern fb.d).(i) lsl fb.x) <> 0 then raise Done done; false - with + with Done -> true in @@ -520,27 +520,27 @@ let _ = m.x <- m.x + 1; if sub m then () else - begin + begin m.x <- m.x - 2; ignore (sub m) - end + end end else () in let image_load = - let i = Canvas.create_image canvas - (Pixels (block_size * 5 + block_size / 2)) + let i = Canvas.create_image canvas + (Pixels (block_size * 5 + block_size / 2)) (Pixels (block_size * 10 + block_size / 2)) [Anchor Center] in Canvas.lower_bot canvas i; let img = Imagephoto.create [] in fun file -> - try + try Imagephoto.configure img [File file]; Canvas.configure_image canvas i [ImagePhoto img] with - _ -> + _ -> begin Printf.eprintf "%s : No such image...\n" file; flush stderr @@ -551,14 +551,14 @@ let _ = let pline = !line in if l <> 0 then begin - line := !line + l; + line := !line + l; score := !score + l * l; set_message (Printf.sprintf "%d pts" (1 lsl ((l - 1) * 2))) - end; + end; Textvariable.set linev (string_of_int !line); - Textvariable.set scorev (string_of_int !score); + Textvariable.set scorev (string_of_int !score); - if !line /10 <> pline /10 then + if !line /10 <> pline /10 then (* update the background every 10 lines. *) begin let num_image = List.length backgrounds - 1 in @@ -567,16 +567,16 @@ let _ = let file = List.nth backgrounds n in image_load file; (* Future work: We should gain level after an image is put... *) - incr level; - Textvariable.set levv (string_of_int !level) + incr level; + Textvariable.set levv (string_of_int !level) end in - let rec newblock () = + let rec newblock () = set_message "TETRIS"; set_nextblock (); draw_falling_block !current; - if death_check !current then + if death_check !current then begin !current.alive <- false; set_message "GAME OVER"; @@ -617,7 +617,7 @@ let _ = let bind_game w = bind w [([], KeyPress)] (BindSet ([Ev_KeySymString], - fun e -> + fun e -> match e.ev_KeySymString with | "h" -> let m = copy_block current in @@ -645,7 +645,7 @@ let _ = begin let m = copy_block current and n = copy_block current in - while + while m.y <- m.y + 1; if death_check m then false else begin n.y <- m.y; true end @@ -655,7 +655,7 @@ let _ = current := n; remove_timer (); loop () - end + end | _ -> () )) in @@ -669,7 +669,7 @@ let _ = score := 0; line := 0; level := 1; - add_score 0; + add_score 0; init_field (); next := Random.int 7; set_message "Welcome to TETRIS"; diff --git a/otherlibs/labltk/examples_camltk/text.ml b/otherlibs/labltk/examples_camltk/text.ml index 0001ae75ac..35273377be 100644 --- a/otherlibs/labltk/examples_camltk/text.ml +++ b/otherlibs/labltk/examples_camltk/text.ml @@ -28,7 +28,7 @@ let scrollbar = Scrollbar.create f [] let buffer = ref "" let kill () = - buffer := + buffer := Text.get text (TextIndex (Insert, [])) (TextIndex (Insert, [LineEnd])); Text.delete text (TextIndex (Insert, [])) @@ -36,7 +36,7 @@ let kill () = ;; let yank () = - Text.insert text (TextIndex (Insert, [])) !buffer [] + Text.insert text (TextIndex (Insert, [])) !buffer [] let _ = bind text [[Control], KeyPressDetail "y"] (BindSet ([], fun _ -> yank () )) @@ -52,4 +52,3 @@ let _ = pack [f][]; mainLoop () ;; - diff --git a/otherlibs/labltk/examples_camltk/winskel.ml b/otherlibs/labltk/examples_camltk/winskel.ml index 2ca1da1745..cf68178ae1 100644 --- a/otherlibs/labltk/examples_camltk/winskel.ml +++ b/otherlibs/labltk/examples_camltk/winskel.ml @@ -18,8 +18,8 @@ open Camltk let main () = let top = opentk() in - let mbar = Frame.create top [Relief Raised; BorderWidth (Pixels 2)] - and dummy = + let mbar = Frame.create top [Relief Raised; BorderWidth (Pixels 2)] + and dummy = Frame.create top [Width (Centimeters 10.); Height (Centimeters 5.)] in pack [mbar; dummy] [Side Side_Top; Fill Fill_X]; let file = Menubutton.create mbar [Text "File"; UnderlinedChar 0] @@ -32,8 +32,8 @@ let main () = pack [help] [Side Side_Right]; (* same code as chap16-14 *) let m = Menu.create text [] in - let bold = Textvariable.create() - and italic = Textvariable.create() + let bold = Textvariable.create() + and italic = Textvariable.create() and underline = Textvariable.create() in Menu.add_checkbutton m [Label "Bold"; Variable bold]; Menu.add_checkbutton m [Label "Italic"; Variable italic]; @@ -46,13 +46,13 @@ let main () = Menu.add_radiobutton m [Label "Courier"; Variable font; Value "courier"]; Menu.add_separator m; Menu.add_command m [Label "Insert Bullet"; - Command (function () -> - print_string "Insert Bullet\n"; - flush stdout)]; + Command (function () -> + print_string "Insert Bullet\n"; + flush stdout)]; Menu.add_command m [Label "Margins and Tags..."; - Command (function () -> - print_string "margins\n"; - flush stdout)]; + Command (function () -> + print_string "margins\n"; + flush stdout)]; Menubutton.configure text [Menu m]; mainLoop() diff --git a/otherlibs/labltk/examples_labltk/Makefile.nt b/otherlibs/labltk/examples_labltk/Makefile.nt index 261bf75439..bd10e09dca 100644 --- a/otherlibs/labltk/examples_labltk/Makefile.nt +++ b/otherlibs/labltk/examples_labltk/Makefile.nt @@ -5,39 +5,39 @@ COMPFLAGS= -I ../lib -I ../labltk -I ../support LINKFLAGS= -I ../lib -I ../labltk -I ../support # Use pieces of Makefile.config -TKLINKOPT=$(LIBNAME).cma $(TKLIBS) +TKLINKOPT=$(LIBNAME).cma $(TKLIBS) all: hello.exe demo.exe eyes.exe calc.exe clock.exe tetris.exe lang.exe hello.exe: hello.cmo $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ - -o $@ hello.cmo + -o $@ hello.cmo demo.exe: demo.cmo $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ - -o $@ demo.cmo + -o $@ demo.cmo eyes.exe: eyes.cmo $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ - -o $@ eyes.cmo + -o $@ eyes.cmo calc.exe: calc.cmo $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ - -o $@ calc.cmo + -o $@ calc.cmo clock.exe: clock.cmo $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) unix.cma \ - -o $@ clock.cmo + -o $@ clock.cmo tetris.exe: tetris.cmo $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ - -o $@ tetris.cmo + -o $@ tetris.cmo lang.exe: lang.cmo $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ - -o $@ lang.cmo + -o $@ lang.cmo -clean : +clean : rm -f *.cm? *.exe .SUFFIXES : diff --git a/otherlibs/labltk/examples_labltk/demo.ml b/otherlibs/labltk/examples_labltk/demo.ml index 2ccc448b19..bd36f3f382 100644 --- a/otherlibs/labltk/examples_labltk/demo.ml +++ b/otherlibs/labltk/examples_labltk/demo.ml @@ -26,7 +26,7 @@ open Tk let _ = (* Initialize Tk *) -let top = openTk () in +let top = openTk () in (* Title setting *) Wm.title_set top "LablTk demo"; @@ -35,7 +35,7 @@ let base = Frame.create top in pack [base]; (* Menu bar *) -let bar = Frame.create ~borderwidth:2 ~relief:`Raised base in +let bar = Frame.create ~borderwidth:2 ~relief:`Raised base in pack ~fill:`X [bar]; (* Menu and Menubutton *) @@ -43,24 +43,24 @@ pack ~fill:`X [bar]; let men = Menu.create meb in Menu.add_command ~label:"Quit" ~command:(fun () -> closeTk (); exit 0) men; Menubutton.configure ~menu:men meb; - + (* Frames *) let base2 = Frame.create base in let left = Frame.create base2 in let right = Frame.create base2 in pack [base2]; pack ~side:`Left [left; right]; - + (* Widgets on left and right *) - + (* Button *) let but = Button.create ~text:"Welcome to LablTk" left in - + (* Canvas *) let can = Canvas.create ~width:100 ~height:100 ~borderwidth:1 ~relief:`Sunken left in - let oval = Canvas.create_oval ~x1: 10 ~y1: 10 + let oval = Canvas.create_oval ~x1: 10 ~y1: 10 ~x2: 90 ~y2: 90 ~fill: `Red can @@ -68,22 +68,22 @@ pack ~fill:`X [bar]; (* Check button *) let che = Checkbutton.create ~text:"Check" left in - + (* Entry *) - let ent = Entry.create ~width:10 left in - + let ent = Entry.create ~width:10 left in + (* Label *) let lab = Label.create ~text:"Welcome to LablTk" left in - + (* Listbox *) let lis = Listbox.create left in Listbox.insert lis ~index:`End ~texts:["This"; "is"; "Listbox"]; - + (* Message *) let mes = Message.create ~text: "Hello this is a message widget with very long text, but ..." left in - + (* Radio buttons *) let tv = Textvariable.create () in Textvariable.set tv "One"; @@ -91,32 +91,32 @@ pack ~fill:`X [bar]; let rads = List.map ~f:(fun t -> Radiobutton.create ~text:t ~value:t ~variable:tv radf) ["One"; "Two"; "Three"] in - + (* Scale *) let sca = Scale.create ~label:"Scale" ~length:100 ~showvalue:true right in - + (* Text and scrollbar *) - let texf = Frame.create right in - + let texf = Frame.create right in + (* Text *) let tex = Text.create ~width:20 ~height:8 texf in Text.insert ~index:(`End,[]) ~text:"This is a text widget." tex; - + (* Scrollbar *) let scr = Scrollbar.create texf in - + (* Text and Scrollbar widget link *) let scroll_link sb tx = Text.configure ~yscrollcommand:(Scrollbar.set sb) tx; Scrollbar.configure ~command:(Text.yview tx) sb in scroll_link scr tex; - + pack ~side:`Right ~fill:`Y [scr]; pack ~side:`Left ~fill:`Both ~expand:true [tex]; - + (* Pack them *) pack ~side:`Left [meb]; - pack [coe but; coe can; coe che; coe ent; coe lab; coe lis; coe mes]; + pack [coe but; coe can; coe che; coe ent; coe lab; coe lis; coe mes]; pack [coe radf; coe sca; coe texf]; pack rads; @@ -125,7 +125,7 @@ pack ~fill:`X [bar]; Wm.title_set top2 "LablTk demo control"; let defcol = `Color "#dfdfdf" in let selcol = `Color "#ffdfdf" in - let buttons = + let buttons = List.map ~f:(fun (w, t, c, a) -> let b = Button.create ~text:t ~command:c top2 in bind ~events:[`Enter] ~action:(fun _ -> a selcol) b; @@ -163,5 +163,4 @@ pack ~fill:`X [bar]; pack ~fill:`X buttons; (* Main Loop *) -Printexc.print mainLoop () - +Printexc.print mainLoop () diff --git a/otherlibs/labltk/examples_labltk/eyes.ml b/otherlibs/labltk/examples_labltk/eyes.ml index ce62159dbe..81f6aa4a2a 100644 --- a/otherlibs/labltk/examples_labltk/eyes.ml +++ b/otherlibs/labltk/examples_labltk/eyes.ml @@ -26,12 +26,12 @@ let _ = let create_eye cx cy wx wy ewx ewy bnd = let o2 = Canvas.create_oval ~x1:(cx - wx) ~y1:(cy - wy) - ~x2:(cx + wx) ~y2:(cy + wy) + ~x2:(cx + wx) ~y2:(cy + wy) ~outline: `Black ~width: 7 ~fill: `White c and o = Canvas.create_oval - ~x1:(cx - ewx) ~y1:(cy - ewy) + ~x1:(cx - ewx) ~y1:(cy - ewy) ~x2:(cx + ewx) ~y2:(cy + ewy) ~fill:`Black c in @@ -40,14 +40,14 @@ let _ = bind ~events:[`Motion] ~extend:true ~fields:[`MouseX; `MouseY] ~action:(fun e -> let nx, ny = - let xdiff = e.ev_MouseX - cx + let xdiff = e.ev_MouseX - cx and ydiff = e.ev_MouseY - cy in - let diff = sqrt ((float xdiff /. (float wx *. bnd)) ** 2.0 +. + let diff = sqrt ((float xdiff /. (float wx *. bnd)) ** 2.0 +. (float ydiff /. (float wy *. bnd)) ** 2.0) in if diff > 1.0 then truncate ((float xdiff) *. (1.0 /. diff)) + cx, truncate ((float ydiff) *. (1.0 /. diff)) + cy - else + else e.ev_MouseX, e.ev_MouseY in Canvas.move c o ~x: (nx - !curx) ~y: (ny - !cury); @@ -57,9 +57,6 @@ let _ = in create_eye 60 100 30 40 5 6 0.6; create_eye 140 100 30 40 5 6 0.6; - pack [c] + pack [c] let _ = Printexc.print mainLoop () - - - diff --git a/otherlibs/labltk/examples_labltk/hello.ml b/otherlibs/labltk/examples_labltk/hello.ml index 4a89d48062..3f39d546d2 100644 --- a/otherlibs/labltk/examples_labltk/hello.ml +++ b/otherlibs/labltk/examples_labltk/hello.ml @@ -22,7 +22,7 @@ open Tk (* initialization of Tk --- the result is a toplevel widget *) -let top = openTk () +let top = openTk () (* create a button on top *) (* Button.create : use of create function defined in button.ml *) @@ -30,7 +30,7 @@ let top = openTk () let b = Button.create ~text: "Hello, LablTk!" top (* Lack of toplevel expressions in lsl, you must use dummy let exp. *) -let _ = pack [coe b] +let _ = pack [coe b] (* Last, you must call mainLoop *) (* You can write just let _ = mainLoop () *) diff --git a/otherlibs/labltk/examples_labltk/lang.ml b/otherlibs/labltk/examples_labltk/lang.ml index e92377ecc3..cde3639918 100644 --- a/otherlibs/labltk/examples_labltk/lang.ml +++ b/otherlibs/labltk/examples_labltk/lang.ml @@ -17,14 +17,14 @@ (* language encoding using UTF-8 *) open Tk -let top = opentk () +let top = opentk () (* declare Tk that we use utf-8 to communicate *) (* problem: Text display is highly dependent on your font installation and configulation. The fonts with no-scale setting are selected only if the point sizes are exactly same??? *) -let _ = +let _ = Encoding.system_set "utf-8"; let l = Label.create top ~text: "???" in pack [l]; @@ -33,7 +33,7 @@ let _ = let create_hello lang hello = let b = Button.create t ~text: lang ~command: (fun () -> - Label.configure l ~text: hello) + Label.configure l ~text: hello) in Text.window_create t ~index: (`End,[]) ~window: b in diff --git a/otherlibs/labltk/examples_labltk/taquin.ml b/otherlibs/labltk/examples_labltk/taquin.ml index a3bcbb1bfb..2809935181 100644 --- a/otherlibs/labltk/examples_labltk/taquin.ml +++ b/otherlibs/labltk/examples_labltk/taquin.ml @@ -67,7 +67,7 @@ let remplir_taquin c nx ny tx ty pièces = if x = !trou_x && (y = !trou_y - 1 || y = !trou_y + 1) || y = !trou_y && (x = !trou_x - 1 || x = !trou_x + 1) then déplacer x y in - Canvas.bind ~events:[`ButtonPress] + Canvas.bind ~events:[`ButtonPress] ~fields:[`MouseX; `MouseY] ~action:jouer c (`Tag "pièce");; let rec permutation = function @@ -112,7 +112,7 @@ let give_help parent lines () = let ok_button = Button.create ~text:"Ok" ~command:quit_help help_frame in pack ~side:`Bottom [help_txtw]; - pack ~side:`Bottom [ok_button ]; + pack ~side:`Bottom [ok_button ]; pack [help_frame];; let taquin nom_fichier nx ny = @@ -136,8 +136,8 @@ let taquin nom_fichier nx ny = let help = Button.create ~text:"Help" ~command:(give_help fp help_lines) fp in pack ~side:`Left ~fill:`X [quit] ; - pack ~side:`Left ~fill:`X [help] ; + pack ~side:`Left ~fill:`X [help] ; mainLoop ();; - + if !Sys.interactive then () else begin taquin "Lambda2.back.gif" 4 4; exit 0 end;; diff --git a/otherlibs/labltk/examples_labltk/tetris.ml b/otherlibs/labltk/examples_labltk/tetris.ml index 9f92d2290c..4f401e5924 100644 --- a/otherlibs/labltk/examples_labltk/tetris.ml +++ b/otherlibs/labltk/examples_labltk/tetris.ml @@ -104,7 +104,7 @@ let blocks = [ [ [|"0000"; "0111"; "0100"; - "0000" |]; + "0000" |]; [|"0000"; "0110"; @@ -124,7 +124,7 @@ let blocks = [ [ [|"0000"; "0100"; "0111"; - "0000" |]; + "0000" |]; [|"0000"; "0110"; @@ -245,11 +245,11 @@ class cell t1 t2 t3 ~canvas ~x ~y = object Canvas.move canvas t3 ~x: (block_size * (x+1)+10+ cell_border*2) ~y: (block_size * (y+1)+10+ cell_border*2) - end + end end; color <- col end - + let cell_get (c, cf) x y = cf.(y).(x) #get let cell_set (c, cf) ~x ~y ~color = @@ -290,7 +290,7 @@ let init fw = let lnl = Label.create r ~text: "Lines" ~font: "variable" in let ln = Label.create r ~textvariable: linev ~font: "variable" in let levl = Label.create r ~text: "Level" ~font: "variable" in - let lev = Label.create r ~textvariable: levv ~font: "variable" in + let lev = Label.create r ~textvariable: levv ~font: "variable" in let newg = Button.create r ~text: "New Game" ~font: "variable" in pack [f]; @@ -305,11 +305,11 @@ let init fw = (Array.map ~f: begin fun (x,y) -> let t1 = - Canvas.create_rectangle c + Canvas.create_rectangle c ~x1:(-block_size - 8) ~y1:(-block_size - 8) ~x2:(-9) ~y2:(-9) and t2 = - Canvas.create_rectangle c + Canvas.create_rectangle c ~x1:(-block_size - 10) ~y1:(-block_size - 10) ~x2:(-11) ~y2:(-11) and t3 = @@ -329,15 +329,15 @@ let init fw = (Array.map ~f: begin fun (x,y) -> let t1 = - Canvas.create_rectangle nc + Canvas.create_rectangle nc ~x1:(-block_size - 8) ~y1:(-block_size - 8) ~x2:(-9) ~y2:(-9) and t2 = - Canvas.create_rectangle nc + Canvas.create_rectangle nc ~x1:(-block_size - 10) ~y1:(-block_size - 10) ~x2:(-11) ~y2:(-11) and t3 = - Canvas.create_rectangle nc + Canvas.create_rectangle nc ~x1:(-block_size - 12) ~y1:(-block_size - 12) ~x2:(-13) ~y2:(-13) in @@ -350,10 +350,10 @@ let init fw = let game_over () = () in (* What a mess ! *) - [ coe f; coe c; coe r; coe nl; coe nc; coe scl; coe sc; coe levl; coe lev; + [ coe f; coe c; coe r; coe nl; coe nc; coe scl; coe sc; coe levl; coe lev; coe lnl; coe ln ], newg, (c, cells), (nc, nexts), scorev, linev, levv, game_over - + let draw_block field ~color ~block ~x ~y = for iy = 0 to 3 do @@ -367,7 +367,7 @@ let draw_block field ~color ~block ~x ~y = done let timer_ref = (ref None : Timer.t option ref) -(* I know, this should be timer ref, but I'm not sure what should be +(* I know, this should be timer ref, but I'm not sure what should be the initial value ... *) let remove_timer () = @@ -378,13 +378,13 @@ let remove_timer () = let do_after ~ms ~callback = timer_ref := Some (Timer.add ~ms ~callback) -let copy_block c = +let copy_block c = { pattern= !c.pattern; bcolor= !c.bcolor; x= !c.x; y= !c.y; d= !c.d; - alive= !c.alive } + alive= !c.alive } let _ = let top = openTk () in @@ -392,7 +392,7 @@ let _ = and fw = Frame.create top in let set_message s = Label.configure lb ~text:s in - pack [coe lb; coe fw] ~side: `Top; + pack [coe lb; coe fw] ~side: `Top; let score = ref 0 in let line = ref 0 in let level = ref 0 in @@ -402,7 +402,7 @@ let _ = let widgets, button, cell_field, next_field, scorev, linev, levv, game_over = init fw in let canvas = fst cell_field in - + let init_field () = for i = 0 to 25 do field.(i) <- line_empty @@ -417,19 +417,19 @@ let _ = for j = 0 to 3 do cell_set next_field ~x:j ~y:i ~color:0 done - done + done in - + let draw_falling_block fb = - draw_block cell_field ~color: fb.bcolor - ~block: (List.nth fb.pattern fb.d) - ~x: (fb.x - 3) + draw_block cell_field ~color: fb.bcolor + ~block: (List.nth fb.pattern fb.d) + ~x: (fb.x - 3) ~y: (fb.y - 3) - + and erase_falling_block fb = - draw_block cell_field ~color: 0 - ~block: (List.nth fb.pattern fb.d) - ~x: (fb.x - 3) + draw_block cell_field ~color: 0 + ~block: (List.nth fb.pattern fb.d) + ~x: (fb.x - 3) ~y: (fb.y - 3) in @@ -446,21 +446,21 @@ let _ = and clear fb = let l = ref 0 in for i = 0 to 3 do - if i + fb.y >= 3 && i + fb.y <= 22 then + if i + fb.y >= 3 && i + fb.y <= 22 then if field.(i + fb.y) = line_full then begin incr l; field.(i + fb.y) <- line_empty; for j = 0 to 9 do - cell_set cell_field ~x:j ~y:(i + fb.y - 3) ~color:0 + cell_set cell_field ~x:j ~y:(i + fb.y - 3) ~color:0 done - end + end done; !l - + and fall_lines () = let eye = ref 22 (* bottom *) - and cur = ref 22 (* bottom *) + and cur = ref 22 (* bottom *) in try while !eye >= 3 do @@ -470,11 +470,11 @@ let _ = done; field.(!cur) <- field.(!eye); for j = 0 to 9 do - cell_set cell_field ~x:j ~y:(!cur-3) + cell_set cell_field ~x:j ~y:(!cur-3) ~color:(cell_get cell_field j (!eye-3)) done; decr eye; - decr cur + decr cur done with Done -> (); for i = 3 to !cur do @@ -489,20 +489,20 @@ let _ = and current = ref { pattern= [[|0;0;0;0|]]; bcolor=0; x=0; y=0; d=0; alive= false} in - + let draw_next () = - draw_block next_field ~color: (!next+1) - ~block: (List.hd (List.nth blocks !next)) - ~x: 0 ~y: 0 - + draw_block next_field ~color: (!next+1) + ~block: (List.hd (List.nth blocks !next)) + ~x: 0 ~y: 0 + and erase_next () = - draw_block next_field ~color: 0 - ~block: (List.hd (List.nth blocks !next)) - ~x: 0 ~y: 0 + draw_block next_field ~color: 0 + ~block: (List.hd (List.nth blocks !next)) + ~x: 0 ~y: 0 in let set_nextblock () = - current := + current := { pattern= (List.nth blocks !next); bcolor= !next+1; x=6; y= 1; d= 0; alive= true}; @@ -510,22 +510,22 @@ let _ = next := Random.int 7; draw_next () in - + let death_check fb = try for i=0 to 3 do let cur = field.(i + fb.y) in - if cur land ((List.nth fb.pattern fb.d).(i) lsl fb.x) <> 0 + if cur land ((List.nth fb.pattern fb.d).(i) lsl fb.x) <> 0 then raise Done done; false - with + with Done -> true in - + let try_to_move m = if !current.alive then - let sub m = + let sub m = if death_check m then false else begin @@ -536,32 +536,32 @@ let _ = end in if sub m then true - else + else begin m.x <- m.x + 1; if sub m then true else - begin + begin m.x <- m.x - 2; sub m - end + end end - else false + else false in let image_load = - let i = Canvas.create_image canvas + let i = Canvas.create_image canvas ~x: (block_size * 5 + block_size / 2) ~y: (block_size * 10 + block_size / 2) ~anchor: `Center in Canvas.lower canvas i; let img = Imagephoto.create () in fun file -> - try + try Imagephoto.configure img ~file: file; - Canvas.configure_image canvas i ~image: img + Canvas.configure_image canvas i ~image: img with - _ -> + _ -> begin Printf.eprintf "%s : No such image...\n" file; flush stderr @@ -572,14 +572,14 @@ let _ = let pline = !line in if l <> 0 then begin - line := !line + l; + line := !line + l; score := !score + l * l; set_message (Printf.sprintf "%d pts" (1 lsl ((l - 1) * 2))) - end; + end; Textvariable.set linev (string_of_int !line); - Textvariable.set scorev (string_of_int !score); + Textvariable.set scorev (string_of_int !score); - if !line /10 <> pline /10 then + if !line /10 <> pline /10 then (* update the background every 10 lines. *) begin let num_image = List.length backgrounds - 1 in @@ -587,16 +587,16 @@ let _ = let n = if n > num_image then num_image else n in let file = List.nth backgrounds n in image_load file; - incr level; - Textvariable.set levv (string_of_int !level) + incr level; + Textvariable.set levv (string_of_int !level) end in - let rec newblock () = + let rec newblock () = set_message "TETRIS"; set_nextblock (); draw_falling_block !current; - if death_check !current then + if death_check !current then begin !current.alive <- false; set_message "GAME OVER"; @@ -608,7 +608,7 @@ let _ = if !time < 60 - !level * 3 then time := 60 - !level * 3; do_after ~ms:stop_a_bit ~callback:loop end - + and loop () = let m = copy_block current in m.y <- m.y + 1; @@ -641,7 +641,7 @@ let _ = let bind_game w = bind w ~events:[`KeyPress] ~fields:[`KeySymString] ~action: - begin fun e -> + begin fun e -> match e.ev_KeySymString with | "h"|"Left" -> let m = copy_block current in @@ -669,7 +669,7 @@ let _ = begin let m = copy_block current and n = copy_block current in - while + while m.y <- m.y + 1; if death_check m then false else begin n.y <- m.y; true end @@ -679,8 +679,8 @@ let _ = current := n; remove_timer (); loop () - end - | _ -> () + end + | _ -> () end in @@ -693,9 +693,9 @@ let _ = score := 0; line := 0; level := 1; - add_score 0; + add_score 0; init_field (); - next := Random.int 7; + next := Random.int 7; set_message "Welcome to TETRIS"; set_nextblock (); draw_falling_block !current; @@ -703,7 +703,7 @@ let _ = in (* As an applet, it was required... *) (* List.iter f: bind_game widgets; *) - bind_game top; + bind_game top; Button.configure button ~command: game_init; game_init () diff --git a/otherlibs/labltk/frx/.depend b/otherlibs/labltk/frx/.depend index d815ab0eb0..9b27a76b0b 100644 --- a/otherlibs/labltk/frx/.depend +++ b/otherlibs/labltk/frx/.depend @@ -1,38 +1,38 @@ -frx_after.cmo: frx_after.cmi -frx_after.cmx: frx_after.cmi -frx_color.cmo: frx_color.cmi -frx_color.cmx: frx_color.cmi -frx_ctext.cmo: frx_fit.cmi frx_text.cmi frx_ctext.cmi -frx_ctext.cmx: frx_fit.cmx frx_text.cmx frx_ctext.cmi -frx_dialog.cmo: frx_dialog.cmi -frx_dialog.cmx: frx_dialog.cmi -frx_entry.cmo: frx_entry.cmi -frx_entry.cmx: frx_entry.cmi -frx_fillbox.cmo: frx_fillbox.cmi -frx_fillbox.cmx: frx_fillbox.cmi -frx_fit.cmo: frx_after.cmi frx_fit.cmi -frx_fit.cmx: frx_after.cmx frx_fit.cmi -frx_focus.cmo: frx_focus.cmi -frx_focus.cmx: frx_focus.cmi -frx_font.cmo: frx_misc.cmi frx_font.cmi -frx_font.cmx: frx_misc.cmx frx_font.cmi -frx_lbutton.cmo: frx_lbutton.cmi -frx_lbutton.cmx: frx_lbutton.cmi -frx_listbox.cmo: frx_listbox.cmi -frx_listbox.cmx: frx_listbox.cmi -frx_mem.cmo: frx_mem.cmi -frx_mem.cmx: frx_mem.cmi -frx_misc.cmo: frx_misc.cmi -frx_misc.cmx: frx_misc.cmi -frx_req.cmo: frx_entry.cmi frx_listbox.cmi frx_widget.cmi frx_req.cmi -frx_req.cmx: frx_entry.cmx frx_listbox.cmx frx_widget.cmx frx_req.cmi -frx_rpc.cmo: frx_rpc.cmi -frx_rpc.cmx: frx_rpc.cmi -frx_selection.cmo: frx_selection.cmi -frx_selection.cmx: frx_selection.cmi -frx_synth.cmo: frx_synth.cmi -frx_synth.cmx: frx_synth.cmi -frx_text.cmo: frx_misc.cmi frx_text.cmi -frx_text.cmx: frx_misc.cmx frx_text.cmi -frx_widget.cmo: frx_widget.cmi -frx_widget.cmx: frx_widget.cmi +frx_after.cmo: frx_after.cmi +frx_after.cmx: frx_after.cmi +frx_color.cmo: frx_color.cmi +frx_color.cmx: frx_color.cmi +frx_ctext.cmo: frx_fit.cmi frx_text.cmi frx_ctext.cmi +frx_ctext.cmx: frx_fit.cmx frx_text.cmx frx_ctext.cmi +frx_dialog.cmo: frx_dialog.cmi +frx_dialog.cmx: frx_dialog.cmi +frx_entry.cmo: frx_entry.cmi +frx_entry.cmx: frx_entry.cmi +frx_fillbox.cmo: frx_fillbox.cmi +frx_fillbox.cmx: frx_fillbox.cmi +frx_fit.cmo: frx_after.cmi frx_fit.cmi +frx_fit.cmx: frx_after.cmx frx_fit.cmi +frx_focus.cmo: frx_focus.cmi +frx_focus.cmx: frx_focus.cmi +frx_font.cmo: frx_misc.cmi frx_font.cmi +frx_font.cmx: frx_misc.cmx frx_font.cmi +frx_lbutton.cmo: frx_lbutton.cmi +frx_lbutton.cmx: frx_lbutton.cmi +frx_listbox.cmo: frx_listbox.cmi +frx_listbox.cmx: frx_listbox.cmi +frx_mem.cmo: frx_mem.cmi +frx_mem.cmx: frx_mem.cmi +frx_misc.cmo: frx_misc.cmi +frx_misc.cmx: frx_misc.cmi +frx_req.cmo: frx_entry.cmi frx_listbox.cmi frx_widget.cmi frx_req.cmi +frx_req.cmx: frx_entry.cmx frx_listbox.cmx frx_widget.cmx frx_req.cmi +frx_rpc.cmo: frx_rpc.cmi +frx_rpc.cmx: frx_rpc.cmi +frx_selection.cmo: frx_selection.cmi +frx_selection.cmx: frx_selection.cmi +frx_synth.cmo: frx_synth.cmi +frx_synth.cmx: frx_synth.cmi +frx_text.cmo: frx_misc.cmi frx_text.cmi +frx_text.cmx: frx_misc.cmx frx_text.cmi +frx_widget.cmo: frx_widget.cmi +frx_widget.cmx: frx_widget.cmi diff --git a/otherlibs/labltk/frx/Makefile b/otherlibs/labltk/frx/Makefile index 0f9c9e3fdf..192034cf5d 100644 --- a/otherlibs/labltk/frx/Makefile +++ b/otherlibs/labltk/frx/Makefile @@ -45,7 +45,7 @@ $(OBJSX): ../lib/$(LIBNAME).cmxa $(CAMLOPT) -c $(COMPFLAGS) $< -depend: +depend: $(CAMLDEP) *.mli *.ml > .depend include .depend diff --git a/otherlibs/labltk/frx/frx_color.ml b/otherlibs/labltk/frx/frx_color.ml index 4df3eb6b45..140e138792 100644 --- a/otherlibs/labltk/frx/frx_color.ml +++ b/otherlibs/labltk/frx/frx_color.ml @@ -25,7 +25,7 @@ let check s = if StringSet.mem s !available_colors then true else begin try - let f = Frame.create_named Widget.default_toplevel "frxcolorcheck" + let f = Frame.create_named Widget.default_toplevel "frxcolorcheck" [Background (NamedColor s)] in available_colors := StringSet.add s !available_colors; destroy f; diff --git a/otherlibs/labltk/frx/frx_ctext.ml b/otherlibs/labltk/frx/frx_ctext.ml index 0d4fd836ef..7d3cbb15af 100644 --- a/otherlibs/labltk/frx/frx_ctext.ml +++ b/otherlibs/labltk/frx/frx_ctext.ml @@ -23,12 +23,12 @@ let create top opts navigation = let rf = Frame.create f [] in let c = Canvas.create lf [BorderWidth (Pixels 0)] and xscroll = Scrollbar.create lf [Orient Horizontal] - and yscroll = Scrollbar.create rf [Orient Vertical] + and yscroll = Scrollbar.create rf [Orient Vertical] and secret = Frame.create_named rf "secret" [] in let t = Text.create c (BorderWidth(Pixels 0) :: opts) in if navigation then Frx_text.navigation_keys t; - + (* Make the text widget an embedded canvas object *) ignore (Canvas.create_window c (Pixels 0) (Pixels 0) @@ -50,7 +50,7 @@ let create top opts navigation = YScrollCommand (fun first last -> scroll first last; let x,y,w,h = Canvas.bbox c [Tag "main"] in - Canvas.configure c + Canvas.configure c [ScrollRegion (Pixels x, Pixels y, Pixels w, Pixels h)]) ]; diff --git a/otherlibs/labltk/frx/frx_ctext.mli b/otherlibs/labltk/frx/frx_ctext.mli index 157c0cad16..e539f5a8bc 100644 --- a/otherlibs/labltk/frx/frx_ctext.mli +++ b/otherlibs/labltk/frx/frx_ctext.mli @@ -21,5 +21,3 @@ val create : with "pixel scrolling". Based on a trick learned from Steve Ball. Returns (frame widget, text widget). *) - - diff --git a/otherlibs/labltk/frx/frx_dialog.ml b/otherlibs/labltk/frx/frx_dialog.ml index 0b65b419e3..12289de638 100644 --- a/otherlibs/labltk/frx/frx_dialog.ml +++ b/otherlibs/labltk/frx/frx_dialog.ml @@ -18,7 +18,7 @@ open Protocol let rec mapi f n l = match l with - [] -> [] + [] -> [] | x::l -> let v = f n x in v::(mapi f (succ n) l) (* Same as tk_dialog, but not sharing the tkwait variable *) @@ -29,7 +29,7 @@ let f w name title mesg bitmap def buttons = Wm.iconname_set t "Dialog"; Wm.protocol_set t "WM_DELETE_WINDOW" (function () -> ()); (* Wm.transient_set t (Winfo.toplevel w); *) - let ftop = + let ftop = Frame.create_named t "top" [Relief Raised; BorderWidth (Pixels 1)] and fbot = Frame.create_named t "bot" [Relief Raised; BorderWidth (Pixels 1)] @@ -38,37 +38,37 @@ let f w name title mesg bitmap def buttons = pack [fbot][Side Side_Bottom; Fill Fill_Both]; let l = - Label.create_named ftop "msg" + Label.create_named ftop "msg" [Justify Justify_Left; Text mesg; WrapLength (Pixels 600)] in pack [l][Side Side_Right; Expand true; Fill Fill_Both; PadX (Millimeters 3.0); PadY (Millimeters 3.0)]; begin match bitmap with Predefined "" -> () | _ -> - let b = + let b = Label.create_named ftop "bitmap" [Bitmap bitmap] in pack [b][Side Side_Left; PadX (Millimeters 3.0); PadY (Millimeters 3.0)] end; - + let waitv = Textvariable.create_temporary t in - + let buttons = mapi (fun i bname -> - let b = Button.create t - [Text bname; + let b = Button.create t + [Text bname; Command (fun () -> Textvariable.set waitv (string_of_int i))] in if i = def then begin - let f = Frame.create_named fbot "default" + let f = Frame.create_named fbot "default" [Relief Sunken; BorderWidth (Pixels 1)] in raise_window_above b f; - pack [f][Side Side_Left; Expand true; + pack [f][Side Side_Left; Expand true; PadX (Millimeters 3.0); PadY (Millimeters 2.0)]; pack [b][In f; PadX (Millimeters 2.0); PadY (Millimeters 2.0)]; bind t [[], KeyPressDetail "Return"] (BindSet ([], (fun _ -> Button.flash b; Button.invoke b))) end else - pack [b][In fbot; Side Side_Left; Expand true; + pack [b][In fbot; Side Side_Left; Expand true; PadX (Millimeters 3.0); PadY (Millimeters 2.0)]; b ) @@ -86,7 +86,7 @@ let f w name title mesg bitmap def buttons = let oldfocus = try Some (Focus.get()) with _ -> None and oldgrab = Grab.current ~displayof: t () and grabstatus = ref None in - begin match oldgrab with + begin match oldgrab with [] -> () | x::l -> grabstatus := Some(Grab.status x) end; @@ -104,7 +104,7 @@ let f w name title mesg bitmap def buttons = destroy t; begin match oldgrab with [] -> () - | x::l -> + | x::l -> try match !grabstatus with Some(GrabGlobal) -> Grab.set_global x diff --git a/otherlibs/labltk/frx/frx_dialog.mli b/otherlibs/labltk/frx/frx_dialog.mli index 2124150caa..cd256acb3e 100644 --- a/otherlibs/labltk/frx/frx_dialog.mli +++ b/otherlibs/labltk/frx/frx_dialog.mli @@ -17,6 +17,6 @@ open Camltk val f : Widget.widget -> string -> string -> string -> Camltk.bitmap -> int -> string list -> int - (* same as Dialog.create_named, but with a local variable for - synchronisation. Makes it possible to have several dialogs + (* same as Dialog.create_named, but with a local variable for + synchronisation. Makes it possible to have several dialogs simultaneously *) diff --git a/otherlibs/labltk/frx/frx_entry.ml b/otherlibs/labltk/frx/frx_entry.ml index eea7362d66..ec84221862 100644 --- a/otherlibs/labltk/frx/frx_entry.ml +++ b/otherlibs/labltk/frx/frx_entry.ml @@ -25,7 +25,7 @@ let new_label_entry parent txt action = let f = Frame.create parent [] in let m = Label.create f [Text txt] and e = Entry.create f [Relief Sunken; TextWidth 0] in - Camltk.bind e [[], KeyPressDetail "Return"] + Camltk.bind e [[], KeyPressDetail "Return"] (BindSet ([], fun _ -> action(Entry.get e))); pack [m][Side Side_Left]; pack [e][Side Side_Right; Fill Fill_X; Expand true]; @@ -38,5 +38,3 @@ let new_labelm_entry parent txt memo = pack [m][Side Side_Left]; pack [e][Side Side_Right; Fill Fill_X; Expand true]; f,e - - diff --git a/otherlibs/labltk/frx/frx_fileinput.ml b/otherlibs/labltk/frx/frx_fileinput.ml index cf59d1303b..de13686703 100644 --- a/otherlibs/labltk/frx/frx_fileinput.ml +++ b/otherlibs/labltk/frx/frx_fileinput.ml @@ -37,4 +37,3 @@ let add fd f = end let remove fd = - diff --git a/otherlibs/labltk/frx/frx_fillbox.ml b/otherlibs/labltk/frx/frx_fillbox.ml index d9e4741889..611b55a5df 100644 --- a/otherlibs/labltk/frx/frx_fillbox.ml +++ b/otherlibs/labltk/frx/frx_fillbox.ml @@ -31,8 +31,8 @@ let new_vertical parent w h = [FillColor okcolor; Outline okcolor] in c, (function - 0 -> Canvas.configure_rectangle c i [FillColor okcolor; - Outline okcolor]; + 0 -> Canvas.configure_rectangle c i [FillColor okcolor; + Outline okcolor]; Canvas.coords_set c i [Pixels 0; Pixels 0; Pixels w; Pixels 0] | -1 -> Canvas.configure_rectangle c i [FillColor kocolor; @@ -52,8 +52,8 @@ let new_horizontal parent w h = [FillColor okcolor; Outline okcolor] in c, (function - 0 -> Canvas.configure_rectangle c i [FillColor okcolor; - Outline okcolor]; + 0 -> Canvas.configure_rectangle c i [FillColor okcolor; + Outline okcolor]; Canvas.coords_set c i [Pixels 0; Pixels 0; Pixels 0; Pixels h] | -1 -> Canvas.configure_rectangle c i [FillColor kocolor; diff --git a/otherlibs/labltk/frx/frx_fit.ml b/otherlibs/labltk/frx/frx_fit.ml index 2011699ab7..c03d6997a7 100644 --- a/otherlibs/labltk/frx/frx_fit.ml +++ b/otherlibs/labltk/frx/frx_fit.ml @@ -23,26 +23,26 @@ let vert wid = and last_last = ref 0.0 in let rec resize () = pending_resize := false; - if !debug then + if !debug then (Printf.eprintf "%s Resize %d\n" (Widget.name wid) !newsize; flush stderr); Text.configure wid [TextHeight !newsize]; () - and check () = - let first, last = Text.yview_get wid in + and check () = + let first, last = Text.yview_get wid in check1 first last and check1 first last = let curheight = int_of_string (cget wid CHeight) in if !debug then begin - Printf.eprintf "%s C %d %f %f\n" + Printf.eprintf "%s C %d %f %f\n" (Widget.name wid) curheight first last; flush stderr end; if first = 0.0 && last = 1.0 then () (* Don't attempt anything if widget is not visible *) else if not (Winfo.viewable wid) then begin - if !debug then + if !debug then (Printf.eprintf "%s C notviewable\n" (Widget.name wid); flush stderr); (* Try again later *) @@ -51,7 +51,7 @@ let vert wid = check())) end else begin - let delta = + let delta = if last = 0.0 then 1 else if last = !last_last then (* it didn't change since our last resize ! *) diff --git a/otherlibs/labltk/frx/frx_focus.ml b/otherlibs/labltk/frx/frx_focus.ml index f33b9e6df1..ce855e201f 100644 --- a/otherlibs/labltk/frx/frx_focus.ml +++ b/otherlibs/labltk/frx/frx_focus.ml @@ -20,7 +20,7 @@ open Camltk (* ? use bind tag ? how about the global reference then *) let auto w = let old_focus = ref w in - bind w [[],Enter] + bind w [[],Enter] (BindSet([], fun _ -> old_focus := Focus.get (); Focus.set w)); - bind w [[],Leave] + bind w [[],Leave] (BindSet([], fun _ -> Focus.set !old_focus)) diff --git a/otherlibs/labltk/frx/frx_font.ml b/otherlibs/labltk/frx/frx_font.ml index 023470261f..3b739a6507 100644 --- a/otherlibs/labltk/frx/frx_font.ml +++ b/otherlibs/labltk/frx/frx_font.ml @@ -18,7 +18,7 @@ open Widget let version = "$Id$" -(* +(* * Finding fonts. Inspired by code in Ical by Sanjay Ghemawat. * Possibly bogus because some families use "i" for italic where others * use "o". @@ -30,7 +30,7 @@ module StringSet = Set.Make(struct type t = string let compare = compare end) let available_fonts = ref (StringSet.empty) -let get_canvas = +let get_canvas = Frx_misc.autodef (fun () -> Canvas.create Widget.default_toplevel []) @@ -41,11 +41,10 @@ let find fmly wght slant pxlsz = else let c = get_canvas() in try - let tag = Canvas.create_text c (Pixels 0) (Pixels 0) + let tag = Canvas.create_text c (Pixels 0) (Pixels 0) [Text "foo"; Font fontspec] in Canvas.delete c [tag]; available_fonts := StringSet.add fontspec !available_fonts; fontspec with _ -> raise (Invalid_argument fontspec) - diff --git a/otherlibs/labltk/frx/frx_font.mli b/otherlibs/labltk/frx/frx_font.mli index c0b7e68067..8dd9997377 100644 --- a/otherlibs/labltk/frx/frx_font.mli +++ b/otherlibs/labltk/frx/frx_font.mli @@ -14,7 +14,7 @@ (* *) (***********************************************************************) val find : string -> string -> string -> int -> string - (* [find family weight slant pxlsz] returns the X11 full name of + (* [find family weight slant pxlsz] returns the X11 full name of the font required font, if available. Raises Invalid_argument fullname otherwise. *) diff --git a/otherlibs/labltk/frx/frx_lbutton.mli b/otherlibs/labltk/frx/frx_lbutton.mli index d79431f345..60c26a5b51 100644 --- a/otherlibs/labltk/frx/frx_lbutton.mli +++ b/otherlibs/labltk/frx/frx_lbutton.mli @@ -21,4 +21,3 @@ val version : string val create : Widget -> option list -> Widget and configure : Widget -> option list -> unit - diff --git a/otherlibs/labltk/frx/frx_listbox.ml b/otherlibs/labltk/frx/frx_listbox.ml index 8bb2941c0b..17d6a3f9ae 100644 --- a/otherlibs/labltk/frx/frx_listbox.ml +++ b/otherlibs/labltk/frx/frx_listbox.ml @@ -17,20 +17,20 @@ open Camltk let version = "$Id$" -(* +(* * Link a scrollbar and a listbox *) let scroll_link sb lb = - Listbox.configure lb + Listbox.configure lb [YScrollCommand (Scrollbar.set sb)]; - Scrollbar.configure sb + Scrollbar.configure sb [ScrollCommand (Listbox.yview lb)] -(* - * Completion for listboxes, Macintosh style. +(* + * Completion for listboxes, Macintosh style. * As long as you type fast enough, the listbox is repositioned to the * first entry "greater" than the typed prefix. - * assumes: + * assumes: * sorted list (otherwise it's stupid) * fixed size, because we don't recompute size at each callback invocation *) @@ -69,9 +69,9 @@ let add_completion lb action = recenter() in - bind lb [[], KeyPress] - (BindSet([Ev_Char; Ev_Time], - (function ev -> + bind lb [[], KeyPress] + (BindSet([Ev_Char; Ev_Time], + (function ev -> (* consider only keys producing characters. The callback is called * even if you press Shift. *) @@ -84,7 +84,7 @@ let add_completion lb action = let new_scrollable_listbox top options = let f = Frame.create top [] in - let lb = Listbox.create f options + let lb = Listbox.create f options and sb = Scrollbar.create f [] in scroll_link sb lb; pack [lb] [Side Side_Left; Fill Fill_Both; Expand true]; diff --git a/otherlibs/labltk/frx/frx_mem.ml b/otherlibs/labltk/frx/frx_mem.ml index 4bab868624..37af208306 100644 --- a/otherlibs/labltk/frx/frx_mem.ml +++ b/otherlibs/labltk/frx/frx_mem.ml @@ -24,7 +24,7 @@ let wordsize = (* officially approved *) if 1 lsl 31 = 0 then 4 else 8 -let init () = +let init () = let top = Toplevel.create Widget.default_toplevel [Class "CamlGC"] in let name = Camltk.appname_get () in Wm.title_set top (name ^ " Memory Gauge"); diff --git a/otherlibs/labltk/frx/frx_misc.ml b/otherlibs/labltk/frx/frx_misc.ml index d2be009224..75c8a3e4df 100644 --- a/otherlibs/labltk/frx/frx_misc.ml +++ b/otherlibs/labltk/frx/frx_misc.ml @@ -31,12 +31,12 @@ let create_photo options = let hasopt = ref None in (* Check options *) List.iter (function - Data s -> + Data s -> begin match !hasopt with None -> hasopt := Some (Data s) | Some _ -> raise (Protocol.TkError "two data sources in options") end - | File f -> + | File f -> begin match !hasopt with None -> hasopt := Some (File f) | Some _ -> raise (Protocol.TkError "two data sources in options") @@ -51,8 +51,8 @@ let create_photo options = let oc = open_out_bin tmpfile in output_string oc s; close_out oc; - let newopts = - List.map (function + let newopts = + List.map (function | Data s -> File tmpfile | o -> o) options in diff --git a/otherlibs/labltk/frx/frx_req.ml b/otherlibs/labltk/frx/frx_req.ml index 029f4973b6..ab7308fa36 100644 --- a/otherlibs/labltk/frx/frx_req.ml +++ b/otherlibs/labltk/frx/frx_req.ml @@ -16,14 +16,14 @@ open Camltk (* - * Some standard requesters (in Amiga techspeak) or dialog boxes (in Apple + * Some standard requesters (in Amiga techspeak) or dialog boxes (in Apple * jargon). *) let version = "$Id$" (* - * Simple requester + * Simple requester * an entry field, unrestricted, with emacs-like bindings * Note: grabs focus, thus always unique at one given moment, and we * shouldn't have to worry about toplevel widget name. @@ -51,7 +51,7 @@ let open_simple title action notaction memory = let f = Frame.create t [] in let bok = Button.create f [Text "Ok"; Command activate] in let bcancel = Button.create f - [Text "Cancel"; + [Text "Cancel"; Command (fun () -> notaction(); Grab.release t; destroy t)] in bind e [[], KeyPressDetail "Escape"] @@ -76,7 +76,7 @@ let open_simple_synchronous title memory = Entry.create t [Relief Sunken; TextVariable memory; TextWidth len] in let waiting = Textvariable.create_temporary t in - + let activate _ = Grab.release t; (* because of wm *) destroy t; (* so action can call open_simple *) @@ -86,10 +86,10 @@ let open_simple_synchronous title memory = let f = Frame.create t [] in let bok = Button.create f [Text "Ok"; Command activate] in - let bcancel = + let bcancel = Button.create f - [Text "Cancel"; - Command (fun () -> + [Text "Cancel"; + Command (fun () -> Grab.release t; destroy t; Textvariable.set waiting "0")] in bind e [[], KeyPressDetail "Escape"] @@ -118,7 +118,7 @@ let open_list title elements action notaction = Wm.title_set t title; let tit = Label.create t [Text title] in - let fls = Frame.create t [Relief Sunken; BorderWidth (Pixels 2)] in + let fls = Frame.create t [Relief Sunken; BorderWidth (Pixels 2)] in let lb = Listbox.create fls [SelectMode Extended] in let sb = Scrollbar.create fls [] in Frx_listbox.scroll_link sb lb; @@ -135,12 +135,12 @@ let open_list title elements action notaction = bind lb [[Double], ButtonPressDetail 1] (BindSetBreakable ([], activate)); - Frx_listbox.add_completion lb activate; + Frx_listbox.add_completion lb activate; let f = Frame.create t [] in let bok = Button.create f [Text "Ok"; Command activate] in - let bcancel = Button.create f - [Text "Cancel"; + let bcancel = Button.create f + [Text "Cancel"; Command (fun () -> notaction(); Grab.release t; destroy t)] in pack [bok; bcancel] [Side Side_Left; Fill Fill_X; Expand true]; @@ -167,8 +167,8 @@ let open_passwd title = and fp,ep = Frx_entry.new_label_entry t "Password" (fun s -> ()) in let fb = Frame.create t [] in - let bok = Button.create fb - [Text "Ok"; Command (fun _ -> + let bok = Button.create fb + [Text "Ok"; Command (fun _ -> username := Entry.get eu; password := Entry.get ep; Grab.release t; (* because of wm *) @@ -183,8 +183,8 @@ let open_passwd title = bind eu [[], KeyPressDetail "Return"] (BindSetBreakable ([], (fun _ -> Focus.set ep; break()))); bind ep [[], KeyPressDetail "Return"] - (BindSetBreakable ([], (fun _ -> Button.flash bok; - Button.invoke bok; + (BindSetBreakable ([], (fun _ -> Button.flash bok; + Button.invoke bok; break()))); pack [bok] [Side Side_Left; Expand true]; diff --git a/otherlibs/labltk/frx/frx_req.mli b/otherlibs/labltk/frx/frx_req.mli index 815b284596..41de7df35a 100644 --- a/otherlibs/labltk/frx/frx_req.mli +++ b/otherlibs/labltk/frx/frx_req.mli @@ -25,7 +25,7 @@ val open_simple : val open_simple_synchronous : string -> Textvariable.textVariable -> bool (* [open_simple_synchronous title memory] - A synchronous dialog with a message and an entry field (with + A synchronous dialog with a message and an entry field (with memory between invocations). Returns true if the user clicks Ok or false if the user clicks Cancel. *) diff --git a/otherlibs/labltk/frx/frx_synth.ml b/otherlibs/labltk/frx/frx_synth.ml index d7acf06f7e..76b83b640f 100644 --- a/otherlibs/labltk/frx/frx_synth.ml +++ b/otherlibs/labltk/frx/frx_synth.ml @@ -22,18 +22,18 @@ open Protocol let events = Hashtbl.create 37 (* Notes: - * "cascading" events (on the same event) are not supported + * "cascading" events (on the same event) are not supported * Only one binding active at a time for each event on each widget. *) (* Get the callback table associated with <name>. Initializes if required *) let get_event name = - try Hashtbl.find events name + try Hashtbl.find events name with Not_found -> let h = Hashtbl.create 37 in Hashtbl.add events name h; - (* Initialize the callback invocation mechanism, based on + (* Initialize the callback invocation mechanism, based on variable trace *) let var = "camltk_events(" ^ name ^")" in @@ -44,9 +44,9 @@ let get_event name = begin match Textvariable.get tkvar with "all" -> (* Invoke all callbacks *) Hashtbl.iter - (fun p f -> - try - f (cTKtoCAMLwidget p) + (fun p f -> + try + f (cTKtoCAMLwidget p) with _ -> ()) h | p -> (* Invoke callback for p *) @@ -56,14 +56,14 @@ let get_event name = f w with _ -> () - end; + end; set ()(* reactivate the callback *) ) in set(); - h + h (* Remove binding for event <name> on widget <w> *) -let remove w name = +let remove w name = Hashtbl.remove (get_event name) (Widget.name w) (* Adds <f> as callback for widget <w> on event <name> *) @@ -77,7 +77,7 @@ let broadcast name = (* Sends event <name> to widget <w> *) let send name w = - Textvariable.set (Textvariable.coerce ("camltk_events(" ^ name ^")")) + Textvariable.set (Textvariable.coerce ("camltk_events(" ^ name ^")")) (Widget.name w) (* Remove all callbacks associated to widget <w> *) diff --git a/otherlibs/labltk/frx/frx_text.ml b/otherlibs/labltk/frx/frx_text.ml index 7c1f551b15..18d9961ffc 100644 --- a/otherlibs/labltk/frx/frx_text.ml +++ b/otherlibs/labltk/frx/frx_text.ml @@ -17,8 +17,8 @@ open Camltk let version = "$Id$" -(* - * convert an integer to an absolute index +(* + * convert an integer to an absolute index *) let abs_index n = TextIndex (LineChar(0,0), [CharOffset n]) @@ -35,8 +35,8 @@ let textEnd = let textBegin = TextIndex (LineChar(0,0), []) -(* - * Link a scrollbar and a text widget +(* + * Link a scrollbar and a text widget *) let scroll_link sb tx = Text.configure tx [YScrollCommand (Scrollbar.set sb)]; @@ -64,7 +64,7 @@ let navigation_keys tx = let new_scrollable_text top options navigation = let f = Frame.create top [] in - let tx = Text.create f options + let tx = Text.create f options and sb = Scrollbar.create f [] in scroll_link sb tx; (* IN THIS ORDER -- RESIZING *) @@ -85,11 +85,11 @@ let topsearch t = Wm.title_set top "Text search"; let f = Frame.create_named top "fpattern" [] in let m = Label.create_named f "search" [Text "Search pattern"] - and e = Entry.create_named f "pattern" + and e = Entry.create_named f "pattern" [Relief Sunken; TextVariable (patternv()) ] in let hgroup = Frame.create top [] and bgroup = Frame.create top [] in - let fdir = Frame.create hgroup [] + let fdir = Frame.create hgroup [] and fmisc = Frame.create hgroup [] in let direction = Textvariable.create_temporary fdir and exactv = Textvariable.create_temporary fdir @@ -101,11 +101,11 @@ let topsearch t = and exact = Checkbutton.create_named fmisc "exact" [Text "Exact match"; Variable exactv] and case = Checkbutton.create_named fmisc "case" - [Text "Fold Case"; Variable (casev())] + [Text "Fold Case"; Variable (casev())] and searchb = Button.create_named bgroup "search" [Text "Search"] and contb = Button.create_named bgroup "continue" [Text "Continue"] and dismissb = Button.create_named bgroup "dismiss" - [Text "Dismiss"; + [Text "Dismiss"; Command (fun () -> Text.tag_delete t ["search"]; destroy top)] in Radiobutton.invoke forw; @@ -131,24 +131,24 @@ let topsearch t = try let forward = Textvariable.get direction = "f" in let i = Text.search t !opts (Entry.get e) - (if cont then !current_index + (if cont then !current_index else if forward then textBegin else TextIndex(End, [CharOffset (-1)])) (* does not work with end *) - (if forward then textEnd + (if forward then textEnd else textBegin) in let found = TextIndex (i, []) in - current_index := + current_index := TextIndex(i, [CharOffset (if forward then 1 else (-1))]); Text.tag_delete t ["search"]; Text.tag_add t "search" found (TextIndex (i, [WordEnd])); - Text.tag_configure t "search" + Text.tag_configure t "search" [Relief Raised; BorderWidth (Pixels 1); Background Red]; Text.see t found with Invalid_argument _ -> Bell.ring() in - - bind e [[], KeyPressDetail "Return"] + + bind e [[], KeyPressDetail "Return"] (BindSet ([], fun _ -> search false ())); Button.configure searchb [Command (search false)]; Button.configure contb [Command (search true)]; @@ -163,10 +163,10 @@ let addsearch tx = | _ -> () (* We use Mod1 instead of Meta or Alt *) -let init () = +let init () = List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], + tag_bind "TEXT_RO" ev + (BindSetBreakable ([Ev_Widget], (fun ei -> page_up ei.ev_Widget; break())))) [ [[], KeyPressDetail "BackSpace"]; @@ -176,8 +176,8 @@ let init () = [[Mod1], KeyPressDetail "v"] ]; List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], + tag_bind "TEXT_RO" ev + (BindSetBreakable ([Ev_Widget], (fun ei -> page_down ei.ev_Widget; break())))) [ [[], KeyPressDetail "space"]; @@ -185,16 +185,16 @@ let init () = [[Control], KeyPressDetail "v"] ]; List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], + tag_bind "TEXT_RO" ev + (BindSetBreakable ([Ev_Widget], (fun ei -> line_up ei.ev_Widget; break())))) [ [[], KeyPressDetail "Up"]; [[Mod1], KeyPressDetail "z"] ]; List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], + tag_bind "TEXT_RO" ev + (BindSetBreakable ([Ev_Widget], (fun ei -> line_down ei.ev_Widget; break())))) [ [[], KeyPressDetail "Down"]; @@ -202,8 +202,8 @@ let init () = ]; List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], + tag_bind "TEXT_RO" ev + (BindSetBreakable ([Ev_Widget], (fun ei -> top ei.ev_Widget; break())))) [ [[], KeyPressDetail "Home"]; @@ -211,8 +211,8 @@ let init () = ]; List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], + tag_bind "TEXT_RO" ev + (BindSetBreakable ([Ev_Widget], (fun ei -> bottom ei.ev_Widget; break())))) [ [[], KeyPressDetail "End"]; @@ -226,4 +226,3 @@ let init () = [ [[Control], KeyPressDetail "s"] ] - diff --git a/otherlibs/labltk/frx/frx_widget.ml b/otherlibs/labltk/frx/frx_widget.ml index ab7d26112d..a81c768f01 100644 --- a/otherlibs/labltk/frx/frx_widget.ml +++ b/otherlibs/labltk/frx/frx_widget.ml @@ -21,4 +21,3 @@ let version = "$Id$" let resizeable t = update_idletasks(); (* wait until layout is computed *) Wm.minsize_set t (Winfo.width t) (Winfo.height t) - diff --git a/otherlibs/labltk/jpf/Makefile b/otherlibs/labltk/jpf/Makefile index 0d33f414fa..a79b3d5683 100644 --- a/otherlibs/labltk/jpf/Makefile +++ b/otherlibs/labltk/jpf/Makefile @@ -35,7 +35,7 @@ $(OBJSX): ../lib/$(LIBNAME).cmxa ### Tests -balloontest: balloontest.cmo +balloontest: balloontest.cmo $(CAMLC) -o balloontest -I ../support -I ../lib \ -custom $(LIBNAME).cma jpflib.cma balloontest.cmo @@ -59,7 +59,7 @@ balloontest.cmx : balloon.cmx jpflib.cmxa .ml.cmx: $(CAMLOPT) -c $(COMPFLAGS) $< -depend: +depend: mv Makefile Makefile.bak (sed -n -e '1,/^### DO NOT DELETE THIS LINE/p' Makefile.bak; \ $(CAMLDEP) *.mli *.ml) > Makefile @@ -67,11 +67,11 @@ depend: ### EVERYTHING THAT GOES BEYOND THIS COMMENT IS GENERATED ### DO NOT DELETE THIS LINE -balloon.cmo: balloon.cmi -balloon.cmx: balloon.cmi -fileselect.cmo: fileselect.cmi -fileselect.cmx: fileselect.cmi -jpf_font.cmo: shell.cmi jpf_font.cmi -jpf_font.cmx: shell.cmx jpf_font.cmi -shell.cmo: shell.cmi -shell.cmx: shell.cmi +balloon.cmo: balloon.cmi +balloon.cmx: balloon.cmi +fileselect.cmo: fileselect.cmi +fileselect.cmx: fileselect.cmi +jpf_font.cmo: shell.cmi jpf_font.cmi +jpf_font.cmx: shell.cmx jpf_font.cmi +shell.cmo: shell.cmi +shell.cmx: shell.cmi diff --git a/otherlibs/labltk/jpf/balloon.ml b/otherlibs/labltk/jpf/balloon.ml index 6b2f36d209..739a8d9ece 100644 --- a/otherlibs/labltk/jpf/balloon.ml +++ b/otherlibs/labltk/jpf/balloon.ml @@ -33,37 +33,37 @@ let debug = ref false let topw = ref default_toplevel and popupw = ref (Obj.magic dummy : message widget) -let configure_cursor w cursor = +let configure_cursor w cursor = (* DDDDDDDDDIIIIIIIRRRRRRRRTTTTTTTTYYYYYYY *) - Protocol.tkCommand [| TkToken (name w); + Protocol.tkCommand [| TkToken (name w); TkToken "configure"; TkToken "-cursor"; TkToken cursor |] -let put ~on: w ~ms: millisec mesg = +let put ~on: w ~ms: millisec mesg = let t = ref None in let cursor = ref "" in - let reset () = + let reset () = begin match !t with Some t -> Timer.remove t | _ -> () end; (* if there is a popup label, unmap it *) - if Winfo.exists !topw && Wm.state !topw <> "withdrawn" then + if Winfo.exists !topw && Wm.state !topw <> "withdrawn" then begin Wm.withdraw !topw; if Winfo.exists w then configure_cursor w !cursor end and set ev = if !flag then - t := Some (Timer.add ~ms: millisec ~callback: (fun () -> + t := Some (Timer.add ~ms: millisec ~callback: (fun () -> t := None; if !debug then prerr_endline ("Balloon: " ^ Widget.name w); update_idletasks(); - Message.configure !popupw ~text: mesg; + Message.configure !popupw ~text: mesg; raise_window !topw; Wm.geometry_set !topw (* 9 & 8 are some kind of magic... *) ("+"^(string_of_int (ev.ev_RootX + 9))^ diff --git a/otherlibs/labltk/jpf/balloontest.ml b/otherlibs/labltk/jpf/balloontest.ml index 36e6c8dbf1..60e3aded38 100644 --- a/otherlibs/labltk/jpf/balloontest.ml +++ b/otherlibs/labltk/jpf/balloontest.ml @@ -29,4 +29,3 @@ let _ = pack [b]; Balloon.put ~on: b ~ms: 1000 "Balloon"; Printexc.catch mainLoop () - diff --git a/otherlibs/labltk/jpf/fileselect.ml b/otherlibs/labltk/jpf/fileselect.ml index becfbf339b..3d42ac2dc1 100644 --- a/otherlibs/labltk/jpf/fileselect.ml +++ b/otherlibs/labltk/jpf/fileselect.ml @@ -43,7 +43,7 @@ let scroll_link sb lb = Scrollbar.configure sb ~command: (Listbox.yview lb) (* focus when enter binding *) -let bind_enter_focus w = +let bind_enter_focus w = bind w ~events:[`Enter] ~action:(fun _ -> Focus.set w);; let myentry_create p ~variable = @@ -52,13 +52,13 @@ let myentry_create p ~variable = (************************************************************* Subshell call *) -let subshell cmd = +let subshell cmd = let r,w = pipe () in match fork () with - 0 -> close r; dup2 ~src:w ~dst:stdout; + 0 -> close r; dup2 ~src:w ~dst:stdout; execv ~prog:"/bin/sh" ~args:[| "/bin/sh"; "-c"; cmd |] - | id -> - close w; + | id -> + close w; let rc = in_channel_of_descr r in let rec it l = match @@ -66,7 +66,7 @@ let subshell cmd = with Some x -> it (x::l) | None -> List.rev l - in + in let answer = it [] in close_in rc; (* because of finalize_channel *) let _ = waitpid ~mode:[] id in answer @@ -76,36 +76,36 @@ let subshell cmd = (* find directory name which doesn't contain "?*[" *) let dirget = regexp "^\\([^\\*?[]*/\\)\\(.*\\)" -let parse_filter src = +let parse_filter src = (* replace // by / *) let s = global_replace (regexp "/+") "/" src in (* replace /./ by / *) let s = global_replace (regexp "/\\./") "/" s in (* replace ????/../ by "" *) let s = global_replace - (regexp "\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\./") + (regexp "\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\./") "" s in (* replace ????/..$ by "" *) let s = global_replace - (regexp "\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\.$") + (regexp "\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\.$") "" s in (* replace ^/../../ by / *) let s = global_replace (regexp "^\\(/\\.\\.\\)+/") "/" s in - if string_match dirget s 0 then + if string_match dirget s 0 then let dirs = matched_group 1 s and ptrn = matched_group 2 s in dirs, ptrn else "", s - + let ls dir pattern = subshell ("cd " ^ dir ^ ";/bin/ls -ad " ^ pattern ^" 2>/dev/null") (*************************************************************** File System *) -let get_files_in_directory dir = +let get_files_in_directory dir = let dirh = opendir dir in let rec get_them l = match @@ -117,12 +117,12 @@ let get_files_in_directory dir = get_them (x::l) in List.sort ~cmp:compare (get_them []) - + let rec get_directories_in_files path = List.filter ~f:(fun x -> try (stat (path ^ x)).st_kind = S_DIR with _ -> false) -let remove_directories path = +let remove_directories path = List.filter ~f:(fun x -> try (stat (path ^ x)).st_kind <> S_DIR with _ -> false) @@ -184,11 +184,11 @@ let f ~title ~action:proc ~filter:deffilter ~file:deffile ~multi ~sync = let current_pattern = ref "" and current_dir = ref "" in - + (* init_completions *) let filter_init_completion = ref (fun _ -> ()) and directory_init_completion = ref (fun _ -> ()) in - + let tl = Toplevel.create default_toplevel in Focus.set tl; Wm.title_set tl title; @@ -206,7 +206,7 @@ let f ~title ~action:proc ~filter:deffilter ~file:deffile ~multi ~sync = let dflf = Frame.create dfl in let directory_listbox = Listbox.create dflf ~relief: `Sunken and directory_scrollbar = Scrollbar.create dflf in - scroll_link directory_scrollbar directory_listbox; + scroll_link directory_scrollbar directory_listbox; let dfr = Frame.create df in let dfrl = Label.create dfr ~text: "Files" in let dfrf = Frame.create dfr in @@ -227,7 +227,7 @@ let f ~title ~action:proc ~filter:deffilter ~file:deffile ~multi ~sync = (* Printf.eprintf "CURDIR %s\n" curdir; *) let filter = if string_match (regexp "^/.*") filter 0 then filter - else + else if filter = "" then !global_dir ^ "/*" else !global_dir ^ "/" ^ filter in (* Printf.eprintf "FILTER %s\n" filter; *) @@ -241,13 +241,13 @@ let f ~title ~action:proc ~filter:deffilter ~file:deffile ~multi ~sync = (* Printf.eprintf "FILTER : %s\n\n" filter; *) (* flush Pervasives.stderr; *) try - let directories = get_directories_in_files dirname + let directories = get_directories_in_files dirname (get_files_in_directory dirname) in (* get matched file by subshell call. *) - let matched_files = remove_directories dirname (ls dirname patternname) + let matched_files = remove_directories dirname (ls dirname patternname) in Textvariable.set filter_var filter; - Textvariable.set selection_var (dirname ^ deffile); + Textvariable.set selection_var (dirname ^ deffile); Listbox.delete directory_listbox ~first:(`Num 0) ~last:`End; Listbox.insert directory_listbox ~index:`End ~texts:directories; Listbox.delete filter_listbox ~first:(`Num 0) ~last:`End; @@ -255,35 +255,35 @@ let f ~title ~action:proc ~filter:deffilter ~file:deffile ~multi ~sync = !directory_init_completion directory_listbox; !filter_init_completion filter_listbox with - Unix_error (ENOENT,_,_) -> + Unix_error (ENOENT,_,_) -> (* Directory is not found (maybe) *) Bell.ring () in - + let selected_files = ref [] in (* used for synchronous mode *) let activate l () = Grab.release tl; destroy tl; - if sync then + if sync then begin selected_files := l; Textvariable.set sync_var "1" end - else + else begin - proc l; + proc l; break () - end + end in - + (* and buttons *) let okb = Button.create cfrm ~text: "OK" ~command: - begin fun () -> - let files = - List.map (Listbox.curselection filter_listbox) + begin fun () -> + let files = + List.map (Listbox.curselection filter_listbox) ~f:(fun x -> !current_dir ^ (Listbox.get filter_listbox ~index:x)) in - let files = if files = [] then [Textvariable.get selection_var] + let files = if files = [] then [Textvariable.get selection_var] else files in activate files () end @@ -295,18 +295,18 @@ let f ~title ~action:proc ~filter:deffilter ~file:deffile ~multi ~sync = (* binding *) bind selection_entry ~events:[`KeyPressDetail "Return"] ~breakable:true - ~action:(fun _ -> activate [Textvariable.get selection_var] ()); + ~action:(fun _ -> activate [Textvariable.get selection_var] ()); bind filter_entry ~events:[`KeyPressDetail "Return"] ~action:(fun _ -> configure (Textvariable.get filter_var)); - - let action _ = - let files = + + let action _ = + let files = List.map (Listbox.curselection filter_listbox) - ~f:(fun x -> !current_dir ^ (Listbox.get filter_listbox ~index:x)) + ~f:(fun x -> !current_dir ^ (Listbox.get filter_listbox ~index:x)) in - activate files () + activate files () in - bind filter_listbox ~events:[`Modified([`Double], `ButtonPressDetail 1)] + bind filter_listbox ~events:[`Modified([`Double], `ButtonPressDetail 1)] ~breakable:true ~action; if multi then Listbox.configure filter_listbox ~selectmode: `Multiple; filter_init_completion := add_completion filter_listbox action; @@ -317,7 +317,7 @@ let f ~title ~action:proc ~filter:deffilter ~file:deffile ~multi ~sync = [x] -> Listbox.get directory_listbox ~index:x | _ -> (* you must choose at least one directory. *) Bell.ring (); raise Not_selected) - (Listbox.curselection directory_listbox)) ^ "/" ^ !current_pattern) + (Listbox.curselection directory_listbox)) ^ "/" ^ !current_pattern) with _ -> () in bind directory_listbox ~events:[`Modified([`Double], `ButtonPressDetail 1)] ~breakable:true ~action; @@ -334,13 +334,13 @@ let f ~title ~action:proc ~filter:deffilter ~file:deffile ~multi ~sync = pack [dfl] ~side: `Left; pack [dfll] ~side: `Top ~anchor: `W; pack [dflf] ~side: `Top; - pack [coe directory_listbox; coe directory_scrollbar] + pack [coe directory_listbox; coe directory_scrollbar] ~side: `Left ~fill: `Y; (* files *) pack [dfr] ~side: `Right; pack [dfrl] ~side: `Top ~anchor: `W; pack [dfrf] ~side: `Top; - pack [coe filter_listbox; coe filter_scrollbar] ~side: `Left ~fill: `Y; + pack [coe filter_listbox; coe filter_scrollbar] ~side: `Left ~fill: `Y; (* selection *) pack [sl] ~side: `Top ~anchor: `W; pack [selection_entry] ~side: `Top ~fill: `X; diff --git a/otherlibs/labltk/jpf/fileselect.mli b/otherlibs/labltk/jpf/fileselect.mli index 79dc828f94..4412a41875 100644 --- a/otherlibs/labltk/jpf/fileselect.mli +++ b/otherlibs/labltk/jpf/fileselect.mli @@ -26,12 +26,12 @@ val f : action:(string list -> unit) -> filter:string -> file:string -> multi:bool -> sync:bool -> unit -(* action +(* action [] means canceled if multi select is false, then the list is null or a singleton *) -(* multi select +(* multi select if true then more than one file are selectable *) -(* sync it +(* sync it if true then in synchronous mode *) diff --git a/otherlibs/labltk/jpf/jpf_font.ml b/otherlibs/labltk/jpf/jpf_font.ml index c9c3d05267..24b87b7c06 100644 --- a/otherlibs/labltk/jpf/jpf_font.ml +++ b/otherlibs/labltk/jpf/jpf_font.ml @@ -16,7 +16,7 @@ (* find font information *) let debug = ref false -let log s = +let log s = if !debug then try prerr_endline s with _ -> () type ('s, 'i) xlfd = { @@ -35,7 +35,7 @@ type ('s, 'i) xlfd = { mutable averageWidth: 'i; mutable registry: 's; mutable encoding: 's - } + } let copy xlfd = {xlfd with foundry= xlfd.foundry} @@ -78,8 +78,8 @@ let parse_xlfd xlfd_string = let len = String.length str in let rec split beg cur = if cur >= len then [String.sub str beg (len - beg)] - else if char_sep (String.get str cur) - then + else if char_sep (String.get str cur) + then let nextw = succ cur in (String.sub str beg (cur - beg)) ::(split nextw nextw) @@ -104,7 +104,7 @@ let parse_xlfd xlfd_string = averageWidth= int_of_string averageWidth; registry= registry; encoding= encoding; - } + } | _ -> raise (Parse_Xlfd_Failure xlfd_string) type valid_xlfd = (string, int) xlfd @@ -128,7 +128,7 @@ let empty_pattern = averageWidth= None; registry= None; encoding= None; - } + } let string_of_pattern = let pat f = function @@ -148,10 +148,10 @@ let list_fonts dispname pattern = None -> "" | Some x -> "-display " ^ x in - let result = List.map parse_xlfd - (Shell.subshell ("xlsfonts "^dispopt^" -fn "^string_of_pattern pattern)) + let result = List.map parse_xlfd + (Shell.subshell ("xlsfonts "^dispopt^" -fn "^string_of_pattern pattern)) in - if result = [] then raise Not_found + if result = [] then raise Not_found else result let available_pixel_size_aux dispname pattern = @@ -162,15 +162,15 @@ let available_pixel_size_aux dispname pattern = pattern.pixelSize <- None; let xlfds = list_fonts dispname pattern in let pxszs = Hashtbl.create 107 in - List.iter (fun xlfd -> + List.iter (fun xlfd -> Hashtbl.add pxszs xlfd.pixelSize xlfd) xlfds; pxszs let extract_size_font_hash tbl = let keys = ref [] in - Hashtbl.iter (fun k _ -> + Hashtbl.iter (fun k _ -> if not (List.mem k !keys) then keys := k :: !keys) tbl; - Sort.list (fun (k1,_) (k2,_) -> k1 < k2) + Sort.list (fun (k1,_) (k2,_) -> k1 < k2) (List.map (fun k -> k, Hashtbl.find_all tbl k) !keys) let available_pixel_size dispname pattern = @@ -179,8 +179,8 @@ let available_pixel_size dispname pattern = let nearest_pixel_size dispname vector_ok pattern = (* find the font with the nearest pixel size *) - log ("\n*** "^string_of_pattern pattern); - let pxlsz = + log ("\n*** "^string_of_pattern pattern); + let pxlsz = match pattern.pixelSize with None -> raise (Failure "invalid pixelSize pattern") | Some x -> x @@ -198,16 +198,16 @@ let nearest_pixel_size dispname vector_ok pattern = end else Hashtbl.add newtbl s xlfd else if not (is_vector_font xlfd) && s <> 0 then Hashtbl.add newtbl s xlfd) tbl; - + let size_font_table = extract_size_font_hash newtbl in let diff = ref 10000 in let min = ref None in List.iter (fun (s,xlfds) -> let d = abs(s - pxlsz) in - if d < !diff then begin - min := Some (s,xlfds); - diff := d + if d < !diff then begin + min := Some (s,xlfds); + diff := d end) size_font_table; (* if it contains more than one font, just return the first *) match !min with diff --git a/otherlibs/labltk/jpf/jpf_font.mli b/otherlibs/labltk/jpf/jpf_font.mli index cd1e212297..03f705f529 100644 --- a/otherlibs/labltk/jpf/jpf_font.mli +++ b/otherlibs/labltk/jpf/jpf_font.mli @@ -40,14 +40,14 @@ val empty_pattern : pattern val copy : ('a, 'b) xlfd -> ('a, 'b) xlfd -val string_of_valid_xlfd : valid_xlfd -> string +val string_of_valid_xlfd : valid_xlfd -> string val string_of_pattern : pattern -> string val is_vector_font : valid_xlfd -> bool val list_fonts : string option -> pattern -> valid_xlfd list -val available_pixel_size : +val available_pixel_size : string option -> pattern -> (int * valid_xlfd list) list val nearest_pixel_size : diff --git a/otherlibs/labltk/jpf/shell.ml b/otherlibs/labltk/jpf/shell.ml index 03e69e4563..8b00a8f2cf 100644 --- a/otherlibs/labltk/jpf/shell.ml +++ b/otherlibs/labltk/jpf/shell.ml @@ -17,20 +17,19 @@ open Unix (************************************************************* Subshell call *) -let subshell cmd = +let subshell cmd = let r,w = pipe () in match fork () with - 0 -> close r; dup2 w stdout; + 0 -> close r; dup2 w stdout; close stderr; execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |] - | id -> - close w; + | id -> + close w; let rc = in_channel_of_descr r in - let rec it () = try + let rec it () = try let x = input_line rc in x:: it () with _ -> [] - in + in let answer = it() in close_in rc; (* because of finalize_channel *) let _ = waitpid [] id in answer - diff --git a/otherlibs/labltk/jpf/shell.mli b/otherlibs/labltk/jpf/shell.mli index be93f5f1a9..c3fec3a2e3 100644 --- a/otherlibs/labltk/jpf/shell.mli +++ b/otherlibs/labltk/jpf/shell.mli @@ -14,4 +14,3 @@ (* *) (***********************************************************************) val subshell : string -> string list - diff --git a/otherlibs/labltk/labltk/Makefile.gen b/otherlibs/labltk/labltk/Makefile.gen index d73bb34521..592ea44623 100644 --- a/otherlibs/labltk/labltk/Makefile.gen +++ b/otherlibs/labltk/labltk/Makefile.gen @@ -12,8 +12,8 @@ _tkgen.ml: ../Widgets.src ../compiler/tkcompiler$(EXE) tk.ml labltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp$(EXE) #../builtin/builtin_*.ml (echo 'open StdLabels'; \ echo 'open Widget'; \ - echo 'open Protocol'; \ - echo 'open Support'; \ + echo 'open Protocol'; \ + echo 'open Support'; \ echo 'open Textvariable'; \ cat ../builtin/report.ml; \ cat ../builtin/builtin_*.ml; \ diff --git a/otherlibs/labltk/lib/Makefile b/otherlibs/labltk/lib/Makefile index 5aec48c45f..91f477fcf2 100644 --- a/otherlibs/labltk/lib/Makefile +++ b/otherlibs/labltk/lib/Makefile @@ -4,7 +4,7 @@ all: $(LIBNAME).cma $(LIBNAME)top$(EXE) $(LIBNAME) opt: $(LIBNAME).cmxa -clean: +clean: rm -f $(LIBNAME)top$(EXE) $(LIBNAME) *.cm* *.$(A) superclean: @@ -21,8 +21,8 @@ CAMLTKOBJS=cTk.cmo $(CWIDGETOBJS) labltk.cmo camltk.cmo SUPPORT=../support/support.cmo ../support/rawwidget.cmo \ ../support/widget.cmo ../support/protocol.cmo \ - ../support/textvariable.cmo ../support/timer.cmo \ - ../support/fileevent.cmo ../support/camltkwrap.cmo + ../support/textvariable.cmo ../support/timer.cmo \ + ../support/fileevent.cmo ../support/camltkwrap.cmo TKOBJS=$(SUPPORT) $(LABLTKOBJS) $(CAMLTKOBJS) @@ -33,16 +33,16 @@ $(LIBNAME).cma: $(SUPPORT) ../Widgets.src cd ../labltk; $(MAKE) cd ../camltk; $(MAKE) $(MKLIB) -ocamlc '$(CAMLCB)' -o $(LIBNAME) \ - -I ../labltk -I ../camltk $(TKOBJS) \ - -ccopt "\"$(TK_LINK)\"" + -I ../labltk -I ../camltk $(TKOBJS) \ + -ccopt "\"$(TK_LINK)\"" $(LIBNAME).cmxa: $(SUPPORT:.cmo=.cmx) ../Widgets.src $(MAKE) superclean cd ../labltk; $(MAKE) opt cd ../camltk; $(MAKE) opt $(MKLIB) -ocamlopt '$(CAMLOPTB)' -o $(LIBNAME) -oc $(LIBNAME) \ - -I ../labltk -I ../camltk $(TKOBJS:.cmo=.cmx) \ - -ccopt "\"$(TK_LINK)\"" + -I ../labltk -I ../camltk $(TKOBJS:.cmo=.cmx) \ + -ccopt "\"$(TK_LINK)\"" $(LIBNAME)top$(EXE) : $(TOPDEPS) $(LIBNAME).cma ../support/lib$(LIBNAME).$(A) $(CAMLC) -verbose -linkall -o $(LIBNAME)top$(EXE) -I ../support \ diff --git a/otherlibs/labltk/support/.depend b/otherlibs/labltk/support/.depend index 069735befe..a7fc006a57 100644 --- a/otherlibs/labltk/support/.depend +++ b/otherlibs/labltk/support/.depend @@ -1,27 +1,27 @@ -camltkwrap.cmi: widget.cmi timer.cmi textvariable.cmi protocol.cmi -protocol.cmi: widget.cmi -textvariable.cmi: widget.cmi protocol.cmi -tkthread.cmi: widget.cmi -widget.cmi: rawwidget.cmi +camltkwrap.cmi: widget.cmi timer.cmi textvariable.cmi protocol.cmi +protocol.cmi: widget.cmi +textvariable.cmi: widget.cmi protocol.cmi +tkthread.cmi: widget.cmi +widget.cmi: rawwidget.cmi camltkwrap.cmo: timer.cmi textvariable.cmi rawwidget.cmi protocol.cmi \ - fileevent.cmi camltkwrap.cmi + fileevent.cmi camltkwrap.cmi camltkwrap.cmx: timer.cmx textvariable.cmx rawwidget.cmx protocol.cmx \ - fileevent.cmx camltkwrap.cmi -fileevent.cmo: support.cmi protocol.cmi fileevent.cmi -fileevent.cmx: support.cmx protocol.cmx fileevent.cmi -protocol.cmo: widget.cmi support.cmi protocol.cmi -protocol.cmx: widget.cmx support.cmx protocol.cmi -rawwidget.cmo: support.cmi rawwidget.cmi -rawwidget.cmx: support.cmx rawwidget.cmi -slave.cmo: widget.cmi -slave.cmx: widget.cmx -support.cmo: support.cmi -support.cmx: support.cmi -textvariable.cmo: widget.cmi support.cmi protocol.cmi textvariable.cmi -textvariable.cmx: widget.cmx support.cmx protocol.cmx textvariable.cmi -timer.cmo: support.cmi protocol.cmi timer.cmi -timer.cmx: support.cmx protocol.cmx timer.cmi -tkthread.cmo: widget.cmi timer.cmi protocol.cmi tkthread.cmi -tkthread.cmx: widget.cmx timer.cmx protocol.cmx tkthread.cmi -widget.cmo: rawwidget.cmi widget.cmi -widget.cmx: rawwidget.cmx widget.cmi + fileevent.cmx camltkwrap.cmi +fileevent.cmo: support.cmi protocol.cmi fileevent.cmi +fileevent.cmx: support.cmx protocol.cmx fileevent.cmi +protocol.cmo: widget.cmi support.cmi protocol.cmi +protocol.cmx: widget.cmx support.cmx protocol.cmi +rawwidget.cmo: support.cmi rawwidget.cmi +rawwidget.cmx: support.cmx rawwidget.cmi +slave.cmo: widget.cmi +slave.cmx: widget.cmx +support.cmo: support.cmi +support.cmx: support.cmi +textvariable.cmo: widget.cmi support.cmi protocol.cmi textvariable.cmi +textvariable.cmx: widget.cmx support.cmx protocol.cmx textvariable.cmi +timer.cmo: support.cmi protocol.cmi timer.cmi +timer.cmx: support.cmx protocol.cmx timer.cmi +tkthread.cmo: widget.cmi timer.cmi protocol.cmi tkthread.cmi +tkthread.cmx: widget.cmx timer.cmx protocol.cmx tkthread.cmi +widget.cmo: rawwidget.cmi widget.cmi +widget.cmx: rawwidget.cmx widget.cmi diff --git a/otherlibs/labltk/support/camltk.h b/otherlibs/labltk/support/camltk.h index 2cc654ef64..56cb29a68a 100644 --- a/otherlibs/labltk/support/camltk.h +++ b/otherlibs/labltk/support/camltk.h @@ -58,4 +58,3 @@ extern int cltk_slave_mode; #define RCNAME ".camltkrc" #define CAMLCB "camlcb" - diff --git a/otherlibs/labltk/support/cltkEvent.c b/otherlibs/labltk/support/cltkEvent.c index 81c9413f6c..ad9b4d9eda 100644 --- a/otherlibs/labltk/support/cltkEvent.c +++ b/otherlibs/labltk/support/cltkEvent.c @@ -52,4 +52,3 @@ CAMLprim value camltk_dooneevent(value flags) ret = Tk_DoOneEvent(convert_flag_list(flags, event_flag_table)); return Val_int(ret); } - diff --git a/otherlibs/labltk/support/cltkFile.c b/otherlibs/labltk/support/cltkFile.c index 9ea6004edf..4fbf9868e6 100644 --- a/otherlibs/labltk/support/cltkFile.c +++ b/otherlibs/labltk/support/cltkFile.c @@ -62,14 +62,14 @@ static Tcl_File tcl_filehandle(value fd) CAMLprim value camltk_add_file_input(value fd, value cbid) { CheckInit(); - Tcl_CreateFileHandler(tcl_filehandle(fd), TCL_READABLE, + Tcl_CreateFileHandler(tcl_filehandle(fd), TCL_READABLE, FileProc, (ClientData)(Long_val(cbid))); return Val_unit; } /* We have to free the Tcl handle when we are finished using it (Tcl * asks us to, and moreover it is probably dangerous to keep the same - * handle over two allocations of the same fd by the kernel). + * handle over two allocations of the same fd by the kernel). * But we don't know when we are finished with the fd, so we free it * in rem_file (it doesn't close the fd anyway). For fds for which we * repeatedly add/rem, this will cause some overhead. @@ -87,7 +87,7 @@ CAMLprim value camltk_rem_file_input(value fd, value cbid) CAMLprim value camltk_add_file_output(value fd, value cbid) { CheckInit(); - Tcl_CreateFileHandler(tcl_filehandle(fd), TCL_WRITABLE, + Tcl_CreateFileHandler(tcl_filehandle(fd), TCL_WRITABLE, FileProc, (ClientData) (Long_val(cbid))); return Val_unit; } diff --git a/otherlibs/labltk/support/cltkMisc.c b/otherlibs/labltk/support/cltkMisc.c index e9824b6e9e..23364ad112 100644 --- a/otherlibs/labltk/support/cltkMisc.c +++ b/otherlibs/labltk/support/cltkMisc.c @@ -33,7 +33,7 @@ CAMLprim value camltk_splitlist (value v) CheckInit(); - utf = caml_string_to_tcl(v); + utf = caml_string_to_tcl(v); /* argv is allocated by Tcl, to be freed by us */ result = Tcl_SplitList(cltclinterp,utf,&argc,&argv); switch(result) { @@ -60,5 +60,3 @@ char *string_to_c(value s) res[l] = '\0'; return res; } - - diff --git a/otherlibs/labltk/support/cltkTimer.c b/otherlibs/labltk/support/cltkTimer.c index 21f1b15885..e0635e8501 100644 --- a/otherlibs/labltk/support/cltkTimer.c +++ b/otherlibs/labltk/support/cltkTimer.c @@ -32,8 +32,8 @@ void TimerProc (ClientData clientdata) CAMLprim value camltk_add_timer(value milli, value cbid) { CheckInit(); - /* look at tkEvent.c , Tk_Token is an int */ - return (Val_int(Tcl_CreateTimerHandler(Int_val(milli), TimerProc, + /* look at tkEvent.c , Tk_Token is an int */ + return (Val_int(Tcl_CreateTimerHandler(Int_val(milli), TimerProc, (ClientData) (Int_val(cbid))))); } @@ -42,4 +42,3 @@ CAMLprim value camltk_rem_timer(value token) Tcl_DeleteTimerHandler((Tcl_TimerToken) Int_val(token)); return Val_unit; } - diff --git a/otherlibs/labltk/support/cltkVar.c b/otherlibs/labltk/support/cltkVar.c index 83fedbafd4..674b8e9dbb 100644 --- a/otherlibs/labltk/support/cltkVar.c +++ b/otherlibs/labltk/support/cltkVar.c @@ -39,7 +39,7 @@ CAMLprim value camltk_getvar(value var) if (s == NULL) tk_error(cltclinterp->result); - else + else return(tcl_string_to_caml(s)); } @@ -47,7 +47,7 @@ CAMLprim value camltk_setvar(value var, value contents) { char *s; char *stable_var = NULL; - char *utf_contents; + char *utf_contents; CheckInit(); /* SetVar makes a copy of the contents. */ @@ -58,14 +58,14 @@ CAMLprim value camltk_setvar(value var, value contents) s = Tcl_SetVar(cltclinterp,stable_var, utf_contents, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); stat_free(stable_var); - if( s == utf_contents ){ + if( s == utf_contents ){ tk_error("camltk_setvar: Tcl_SetVar returned strange result. Call the author of mlTk!"); } stat_free(utf_contents); if (s == NULL) tk_error(cltclinterp->result); - else + else return(Val_unit); } diff --git a/otherlibs/labltk/support/cltkWait.c b/otherlibs/labltk/support/cltkWait.c index 7c3cef53fd..a4fdab0c4d 100644 --- a/otherlibs/labltk/support/cltkWait.c +++ b/otherlibs/labltk/support/cltkWait.c @@ -23,13 +23,13 @@ #include <callback.h> #include "camltk.h" -/* The following are replacements for +/* The following are replacements for tkwait visibility tkwait window in the case where we use threads (tkwait internally calls an event loop, and thus prevents thread scheduling from taking place). - Instead, one should set up a callback, wait for a signal, and signal + Instead, one should set up a callback, wait for a signal, and signal from inside the callback */ @@ -45,7 +45,7 @@ struct WinCBData { }; static void WaitVisibilityProc(clientData, eventPtr) - ClientData clientData; + ClientData clientData; XEvent *eventPtr; /* Information about event (not used). */ { struct WinCBData *vis = clientData; diff --git a/otherlibs/labltk/support/fileevent.ml b/otherlibs/labltk/support/fileevent.ml index 9d985147c9..846a7519b8 100644 --- a/otherlibs/labltk/support/fileevent.ml +++ b/otherlibs/labltk/support/fileevent.ml @@ -48,7 +48,7 @@ let remove_fileinput ~fd = clear_callback id; Hashtbl.remove fd_table (fd, 'r'); if !Protocol.debug then begin - prerr_string "clear "; + prerr_string "clear "; Protocol.prerr_cbid id; prerr_endline " for fileinput" end; @@ -71,11 +71,10 @@ let remove_fileoutput ~fd = clear_callback id; Hashtbl.remove fd_table (fd, 'w'); if !Protocol.debug then begin - prerr_string "clear "; + prerr_string "clear "; Protocol.prerr_cbid id; prerr_endline " for fileoutput" end; rem_file_output fd id with Not_found -> () - diff --git a/otherlibs/labltk/support/protocol.ml b/otherlibs/labltk/support/protocol.ml index d7af4dbac4..26b97c0bda 100644 --- a/otherlibs/labltk/support/protocol.ml +++ b/otherlibs/labltk/support/protocol.ml @@ -45,7 +45,7 @@ external callback_init : unit -> unit = "camltk_init" external finalizeTk : unit -> unit = "camltk_finalize" - (* Finalize tcl/tk before exiting. This function will be automatically + (* Finalize tcl/tk before exiting. This function will be automatically called when you call [Pervasives.exit ()] (This is installed at [install_cleanup ()] *) @@ -66,13 +66,13 @@ let cltclinterp = ref Nativeint.zero let () = Callback.register "cltclinterp" cltclinterp (* Debugging support *) -let debug = +let debug = ref (try ignore (Sys.getenv "CAMLTKDEBUG"); true with Not_found -> false) (* This is approximative, since we don't quote what needs to be quoted *) let dump_args args = - let rec print_arg = function + let rec print_arg = function TkToken s -> prerr_string s; prerr_string " " | TkTokenList l -> List.iter print_arg l | TkQuote a -> prerr_string "{"; print_arg a; prerr_string "} " @@ -85,7 +85,7 @@ let dump_args args = * debugging support should not affect performances... *) -let tkEval args = +let tkEval args = if !debug then dump_args args; let res = tcl_direct_eval args in if !debug then begin @@ -101,7 +101,7 @@ let tkCommand args = ignore (tkEval args) *) (* LablTk only *) -let cCAMLtoTKwidget w = +let cCAMLtoTKwidget w = (* Widget.check_class w table; (* with subtyping, it is redundant *) *) TkToken (Widget.name w) @@ -109,8 +109,8 @@ let cTKtoCAMLwidget = function "" -> raise (Invalid_argument "cTKtoCAMLwidget") | s -> Widget.get_atom s -let callback_naming_table = - (Hashtbl.create 401 : (int, callback_buffer -> unit) Hashtbl.t) +let callback_naming_table = + (Hashtbl.create 401 : (int, callback_buffer -> unit) Hashtbl.t) let callback_memo_table = (Hashtbl.create 401 : (any widget, int) Hashtbl.t) @@ -126,7 +126,7 @@ let string_of_cbid = string_of_int let register_callback w ~callback:f = let id = new_function_id () in Hashtbl.add callback_naming_table id f; - if (forget_type w) <> (forget_type Widget.dummy) then + if (forget_type w) <> (forget_type Widget.dummy) then Hashtbl.add callback_memo_table (forget_type w) id; (string_of_cbid id) @@ -148,7 +148,7 @@ let remove_callbacks w = * that hooks can be set up at load time (i.e. before openTk) *) let destroy_hooks = ref [] -let add_destroy_hook f = +let add_destroy_hook f = destroy_hooks := f :: !destroy_hooks let _ = @@ -156,7 +156,7 @@ let _ = let install_cleanup () = let call_destroy_hooks = function - [wname] -> + [wname] -> let w = cTKtoCAMLwidget wname in List.iter (fun f -> f w) !destroy_hooks | _ -> raise (TkError "bad cleanup callback") in @@ -199,16 +199,16 @@ let camltk_argv = ref [] (* options for Arg.parse *) let keywords = [ - "-display", Arg.String (fun s -> + "-display", Arg.String (fun s -> camltk_argv := "-display" :: s :: !camltk_argv), "<disp> : X server to contact (CamlTk)"; - "-colormap", Arg.String (fun s -> + "-colormap", Arg.String (fun s -> camltk_argv := "-colormap" :: s :: !camltk_argv), "<colormap> : colormap to use (CamlTk)"; - "-geometry", Arg.String (fun s -> + "-geometry", Arg.String (fun s -> camltk_argv := "-geometry" :: s :: !camltk_argv), "<geom> : size and position (CamlTk)"; - "-name", Arg.String (fun s -> + "-name", Arg.String (fun s -> camltk_argv := "-name" :: s :: !camltk_argv), "<name> : application class (CamlTk)"; "-sync", Arg.Unit (fun () -> @@ -223,8 +223,8 @@ let keywords = [ "-visual", Arg.String (fun s -> camltk_argv := "-visual" :: s :: !camltk_argv), "<visual> : visual to use (CamlTk)" ] - -let opentk_with_args argv (* = [argv1;..;argvn] *) = + +let opentk_with_args argv (* = [argv1;..;argvn] *) = (* argv must be command line for wish *) let argv0 = Sys.argv.(0) in let rec find_display = function @@ -241,7 +241,7 @@ let opentk_with_args argv (* = [argv1;..;argvn] *) = | [] -> "" in default_display_name := find_display argv; - opentk_low (argv0 :: argv); + opentk_low (argv0 :: argv); install_cleanup(); Widget.default_toplevel @@ -256,7 +256,7 @@ let openTk ?(display = "") ?(clas = "LablTk") () = match display with | "" -> [] | _ -> ["-display"; display] - in + in opentk_with_args (dispopt @ ["-name"; clas]) (* Destroy all widgets, thus cleaning up table and exiting the loop *) @@ -264,13 +264,12 @@ let closeTk () = tcl_command "destroy ." let mainLoop = - tk_mainloop + tk_mainloop -(* [register tclname f] makes [f] available from Tcl with +(* [register tclname f] makes [f] available from Tcl with name [tclname] *) let register tclname ~callback = let s = register_callback Widget.default_toplevel ~callback in tcl_command (Printf.sprintf "proc %s {args} {eval {camlcb %s} $args}" tclname s) - diff --git a/otherlibs/labltk/support/protocol.mli b/otherlibs/labltk/support/protocol.mli index 2e4edc359f..9b5ae39362 100644 --- a/otherlibs/labltk/support/protocol.mli +++ b/otherlibs/labltk/support/protocol.mli @@ -22,7 +22,7 @@ open Widget exception TkError of string (* Raised by the communication functions *) -val debug : bool ref +val debug : bool ref (* When set to true, displays approximation of intermediate Tcl code *) type tkArgs = @@ -48,11 +48,11 @@ val keywords : (string * Arg.spec * string) list (* Command line parsing specification for Arg.parse, which contains the standard Tcl/Tk command line options such as "-display" and "-name". Add [keywords] to a [Arg.parse] call, then call [opentk]. - Then [opentk] can make use of these command line options + Then [opentk] can make use of these command line options to initiate applications. *) val opentk_with_args : string list -> toplevel widget - (* [opentk_with_args] is a lower level interface to initiate Tcl/Tk + (* [opentk_with_args] is a lower level interface to initiate Tcl/Tk applications. [opentk_with_args argv] initializes Tcl/Tk with the command line options given by [argv] *) @@ -64,12 +64,12 @@ val openTk : ?display:string -> ?clas:string -> unit -> toplevel widget val openTkClass: string -> toplevel widget (* [openTkClass class] is equivalent to [opentk ["-name"; class]] *) val openTkDisplayClass: string -> string -> toplevel widget - (* [openTkDisplayClass disp class] is equivalent to + (* [openTkDisplayClass disp class] is equivalent to [opentk ["-display"; disp; "-name"; class]] *) val closeTk : unit -> unit -val finalizeTk : unit -> unit - (* Finalize tcl/tk before exiting. This function will be automatically +val finalizeTk : unit -> unit + (* Finalize tcl/tk before exiting. This function will be automatically called when you call [Pervasives.exit ()] *) val mainLoop : unit -> unit diff --git a/otherlibs/labltk/support/rawwidget.ml b/otherlibs/labltk/support/rawwidget.ml index 8eba3b8b14..99b1dce1a9 100644 --- a/otherlibs/labltk/support/rawwidget.ml +++ b/otherlibs/labltk/support/rawwidget.ml @@ -75,7 +75,7 @@ let default_toplevel = (* Dummy widget to which global callbacks are associated *) (* also passed around by camltotkoption when no widget in context *) -let dummy = +let dummy = Untyped "dummy" let remove w = @@ -126,16 +126,16 @@ and widget_text_table = [ "text" ] and widget_toplevel_table = [ "toplevel" ] let new_suffix clas n = - try + try (List.assoc clas naming_scheme) ^ (string_of_int n) with Not_found -> "w" ^ (string_of_int n) - + (* The function called by generic creation *) let counter = ref 0 let new_atom ~parent ?name:nom clas = let parentpath = name parent in - let path = + let path = match nom with None -> incr counter; diff --git a/otherlibs/labltk/support/rawwidget.mli b/otherlibs/labltk/support/rawwidget.mli index 7a7857dc7e..4eda7311c7 100644 --- a/otherlibs/labltk/support/rawwidget.mli +++ b/otherlibs/labltk/support/rawwidget.mli @@ -74,7 +74,7 @@ val dummy : raw_any raw_widget (* [dummy] is a widget used as context when we don't have any. It is *not* a real widget. *) - + val new_atom : parent:'a raw_widget -> ?name: string -> string -> 'b raw_widget val get_atom : string -> raw_any raw_widget diff --git a/otherlibs/labltk/support/slave.ml b/otherlibs/labltk/support/slave.ml index b994fe17e7..51eae853bb 100644 --- a/otherlibs/labltk/support/slave.ml +++ b/otherlibs/labltk/support/slave.ml @@ -27,7 +27,7 @@ open Printf let dynload args = List.iter Dynlink.loadfile args -(* Default modules include everything from +(* Default modules include everything from let default_modules = [] *) diff --git a/otherlibs/labltk/support/support.ml b/otherlibs/labltk/support/support.ml index c8bebc2fc7..fa650e8a9e 100644 --- a/otherlibs/labltk/support/support.ml +++ b/otherlibs/labltk/support/support.ml @@ -25,11 +25,11 @@ let split_str ~pred:char_sep str = else if char_sep str.[cur] then skip_sep (succ cur) else cur in let rec split beg cur = - if cur >= len then + if cur >= len then if beg = cur then [] else [String.sub str beg (len - beg)] - else if char_sep str.[cur] - then + else if char_sep str.[cur] + then let nextw = skip_sep cur in (String.sub str beg (cur - beg)) ::(split nextw nextw) diff --git a/otherlibs/labltk/support/textvariable.ml b/otherlibs/labltk/support/textvariable.ml index 4581976b5d..ad9033d450 100644 --- a/otherlibs/labltk/support/textvariable.ml +++ b/otherlibs/labltk/support/textvariable.ml @@ -32,12 +32,12 @@ type textVariable = string (* List of handles *) let handles = Hashtbl.create 401 -let add_handle var cbid = +let add_handle var cbid = try let r = Hashtbl.find handles var in r := cbid :: !r with - Not_found -> + Not_found -> Hashtbl.add handles var (ref [cbid]) let exceptq x = @@ -92,10 +92,10 @@ let memo = Hashtbl.create 101 (* Added a variable v referenced by widget w *) let add w v = let w = Widget.forget_type w in - let r = - try Hashtbl.find memo w + let r = + try Hashtbl.find memo w with - Not_found -> + Not_found -> let r = ref StringSet.empty in Hashtbl.add memo w r; r in @@ -111,7 +111,7 @@ let freew w = try let r = Hashtbl.find memo w in StringSet.iter free !r; - Hashtbl.remove memo w + Hashtbl.remove memo w with Not_found -> () @@ -119,10 +119,10 @@ let _ = add_destroy_hook freew (* Allocate a new variable *) let counter = ref 0 -let getv () = - let v = +let getv () = + let v = if StringSet.is_empty !freelist then begin - incr counter; + incr counter; "camlv("^ string_of_int !counter ^")" end else @@ -149,4 +149,3 @@ let cCAMLtoTKtextVariable s = TkToken s let name s = s let coerce s = s - diff --git a/otherlibs/labltk/support/textvariable.mli b/otherlibs/labltk/support/textvariable.mli index 09a19148a1..dfa511a29f 100644 --- a/otherlibs/labltk/support/textvariable.mli +++ b/otherlibs/labltk/support/textvariable.mli @@ -24,7 +24,7 @@ type textVariable (* TextVariable is an abstract type *) val create : ?on: 'a widget -> unit -> textVariable - (* Allocation of a textVariable with lifetime associated to widget + (* Allocation of a textVariable with lifetime associated to widget if a widget is specified *) val set : textVariable -> string -> unit (* Setting the val of a textVariable *) diff --git a/otherlibs/labltk/support/timer.ml b/otherlibs/labltk/support/timer.ml index ada8100fd2..a6ef8c2992 100644 --- a/otherlibs/labltk/support/timer.ml +++ b/otherlibs/labltk/support/timer.ml @@ -55,4 +55,3 @@ let set ~ms ~callback = ignore (add ~ms ~callback);; let remove (tkTimer, id) = internal_rem_timer tkTimer; clear_callback id - diff --git a/otherlibs/labltk/support/tkthread.mli b/otherlibs/labltk/support/tkthread.mli index 7e871d9cd8..4f20e6140b 100644 --- a/otherlibs/labltk/support/tkthread.mli +++ b/otherlibs/labltk/support/tkthread.mli @@ -17,7 +17,7 @@ (* Helper functions for using LablTk with threads. To use, add tkthread.cmo or tkthread.cmx to your command line *) -(** Start the main loop in a new GUI thread. Do not use recursively. *) +(** Start the main loop in a new GUI thread. Do not use recursively. *) val start : unit -> Thread.t (** The actual function executed in the GUI thread *) val thread_main : unit -> unit diff --git a/otherlibs/labltk/support/widget.mli b/otherlibs/labltk/support/widget.mli index fd3b461c2b..f9c832783a 100644 --- a/otherlibs/labltk/support/widget.mli +++ b/otherlibs/labltk/support/widget.mli @@ -74,7 +74,7 @@ val dummy : any widget (* [dummy] is a widget used as context when we don't have any. It is *not* a real widget. *) - + val new_atom : parent:'a widget -> ?name: string -> string -> 'b widget val get_atom : string -> any widget diff --git a/otherlibs/labltk/tkanim/.depend b/otherlibs/labltk/tkanim/.depend index 6009347798..5f54ec3e40 100644 --- a/otherlibs/labltk/tkanim/.depend +++ b/otherlibs/labltk/tkanim/.depend @@ -1,2 +1,2 @@ -tkanim.cmo: tkanim.cmi -tkanim.cmx: tkanim.cmi +tkanim.cmo: tkanim.cmi +tkanim.cmx: tkanim.cmi diff --git a/otherlibs/labltk/tkanim/README b/otherlibs/labltk/tkanim/README index 175401f30c..65f3de081d 100644 --- a/otherlibs/labltk/tkanim/README +++ b/otherlibs/labltk/tkanim/README @@ -1,5 +1,5 @@ This ML code is an interface for Tkanim Tcl/Tk extension. Unfortunately it is still test implementation. Look example directory for an example. -The codes under this directory are mainly written by Jun Furuse +The codes under this directory are mainly written by Jun Furuse (Jun.Furuse@inria.fr). diff --git a/otherlibs/labltk/tkanim/gifanimtest.ml b/otherlibs/labltk/tkanim/gifanimtest.ml index 5b79985449..1740b8e667 100644 --- a/otherlibs/labltk/tkanim/gifanimtest.ml +++ b/otherlibs/labltk/tkanim/gifanimtest.ml @@ -27,18 +27,18 @@ let main () = \tbutton 3 quits."; let t = openTk () in - (* First of all, you must initialize the extension. *) + (* First of all, you must initialize the extension. *) Tkanim.init (); prerr_endline !file; (* Then load the animated gif. *) - let anim = Tkanim.create !file in + let anim = Tkanim.create !file in prerr_endline "load done"; (* Check it is really animated or not. *) match anim with - | Still x -> + | Still x -> (* Use whatever you want in CamlTk with this ImagePhoto. *) prerr_endline "Sorry, it is not an animated GIF." @@ -46,7 +46,7 @@ let main () = (* OK, let's animate it. *) let l = Label.create t [] in pack [l] []; - + (* animate returns an interface function. *) let f = animate l x in @@ -67,5 +67,5 @@ let main () = (* Go to the main loop. *) mainLoop () - + let _ = Printexc.print main () diff --git a/otherlibs/labltk/tkanim/tkAnimGIF.c b/otherlibs/labltk/tkanim/tkAnimGIF.c index 8a6ef52e4c..a015b04844 100644 --- a/otherlibs/labltk/tkanim/tkAnimGIF.c +++ b/otherlibs/labltk/tkanim/tkAnimGIF.c @@ -154,7 +154,7 @@ FileReadGIF(interp, f, fileName, formatString) Tcl_DStringAppend(&resultbuf, heightbuf, -1); Tcl_DStringAppend(&resultbuf, " ", -1); Tcl_DStringAppend(&resultbuf, "{", -1); - + while (1) { if (fread(buf, 1, 1, f) != 1) { /* @@ -245,7 +245,7 @@ FileReadGIF(interp, f, fileName, formatString) imageLeftPos= LM_to_uint(buf[0], buf[1]); imageTopPos= LM_to_uint(buf[2], buf[3]); - imageWidth= LM_to_uint(buf[4], buf[5]); + imageWidth= LM_to_uint(buf[4], buf[5]); imageHeight= LM_to_uint(buf[6], buf[7]); block.width = imageWidth; @@ -276,16 +276,16 @@ FileReadGIF(interp, f, fileName, formatString) argv[4] = Tcl_NewStringObj(widthbuf, -1); argv[5] = Tcl_NewStringObj("-height", -1); argv[6] = Tcl_NewStringObj(heightbuf, -1); - + for(i=0; i<7; i++){ Tcl_IncrRefCount(argv[i]); } - if( Tk_ImageObjCmd((ClientData) winPtr, interp, - /* "image create photo -width <imageWidth> + if( Tk_ImageObjCmd((ClientData) winPtr, interp, + /* "image create photo -width <imageWidth> -height <imageHeight>" */ 7, argv) == TCL_ERROR ){ return TCL_ERROR; } - + for(i=0; i<7; i++){ Tcl_DecrRefCount(argv[i]); } #else @@ -294,11 +294,11 @@ FileReadGIF(interp, f, fileName, formatString) argv[4] = widthbuf; argv[6] = heightbuf; #ifdef TKANIM_DEBUG - fprintf(stderr, "\n\t\timage creation (%s %s %s %s %s %s %s)", + fprintf(stderr, "\n\t\timage creation (%s %s %s %s %s %s %s)", argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6]); #endif - if( Tk_ImageCmd((ClientData) winPtr, interp, - /* "image create photo -width <imageWidth> + if( Tk_ImageCmd((ClientData) winPtr, interp, + /* "image create photo -width <imageWidth> -height <imageHeight>" */ 7, argv) == TCL_ERROR ){ return TCL_ERROR; @@ -318,7 +318,7 @@ FileReadGIF(interp, f, fileName, formatString) #endif if (!useGlobalColormap) { if (!ReadColorMap(f, bitPixel, localColorMap)) { - Tcl_AppendResult(interp, "error reading color map", + Tcl_AppendResult(interp, "error reading color map", (char *) NULL); goto error; } @@ -336,7 +336,7 @@ FileReadGIF(interp, f, fileName, formatString) } Tk_PhotoPutBlock( #if (TK_MAJOR_VERSION == 8 && TK_MINOR_VERSION >= 5 || TK_MAJOR_VERSION > 8) - NULL, + NULL, #endif photoHandle, &block, 0, 0, imageWidth, imageHeight #if (TK_MAJOR_VERSION == 8 && TK_MINOR_VERSION >= 4 || TK_MAJOR_VERSION > 8) @@ -347,9 +347,9 @@ photoHandle, &block, 0, 0, imageWidth, imageHeight fprintf(stderr, " Retrieving result\n"); #endif /* retrieve result */ - sprintf(newresbuf, "{%s %d %d %d %d %d} ", - imageName, imageWidth, imageHeight, imageLeftPos, imageTopPos, - delay); + sprintf(newresbuf, "{%s %d %d %d %d %d} ", + imageName, imageWidth, imageHeight, imageLeftPos, imageTopPos, + delay); #ifdef TKANIM_DEBUG fprintf(stderr, " newresbuf = %s\n", newresbuf); #endif @@ -573,16 +573,16 @@ int transparent; return TCL_ERROR; } - if (transparent!=-1 && + if (transparent!=-1 && (colStr = Tcl_GetVar(interp, "TRANSPARENT_GIF_COLOR", 0L))) { XColor *colorPtr; - colorPtr = Tk_GetColor(interp, Tk_MainWindow(interp), + colorPtr = Tk_GetColor(interp, Tk_MainWindow(interp), Tk_GetUid(colStr)); if (colorPtr) { /* - printf("color is %d %d %d\n", - colorPtr->red >> 8, - colorPtr->green >> 8, + printf("color is %d %d %d\n", + colorPtr->red >> 8, + colorPtr->green >> 8, colorPtr->blue >> 8); */ cmap[CM_RED][transparent] = colorPtr->red >> 8; @@ -827,7 +827,7 @@ int Tk_AnimationCmd(clientData, interp, argc, argv) } c = argv[1][0]; length = strlen(argv[1]); - if((c == 'c') && (length >= 2) + if((c == 'c') && (length >= 2) && (strncmp(argv[1], "create", length) == 0)) { char * realFileName; @@ -904,7 +904,7 @@ int Tkanim_Init(interp) #ifdef TKANIM_DEBUG fprintf(stderr, "Tkanim initialize..."); #endif - Tcl_CreateCommand(interp, "animation", Tk_AnimationCmd, + Tcl_CreateCommand(interp, "animation", Tk_AnimationCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) TkDeleteTkAnim); #ifdef TKANIM_DEBUG diff --git a/otherlibs/labltk/tkanim/tkAppInit.c b/otherlibs/labltk/tkanim/tkAppInit.c index 60807d9152..09c943edf1 100644 --- a/otherlibs/labltk/tkanim/tkAppInit.c +++ b/otherlibs/labltk/tkanim/tkAppInit.c @@ -13,7 +13,7 @@ /* described in file LICENSE found in the Objective Caml source tree. */ /* */ /***********************************************************************/ -/* +/* * tkAppInit.c -- * * Provides a default version of the Tcl_AppInit procedure for diff --git a/otherlibs/labltk/tkanim/tkanim.ml b/otherlibs/labltk/tkanim/tkanim.ml index d4d693f670..586d3569e4 100644 --- a/otherlibs/labltk/tkanim/tkanim.ml +++ b/otherlibs/labltk/tkanim/tkanim.ml @@ -227,4 +227,3 @@ let gifdata s = anim with e -> begin Unix.unlink fname; raise e end - diff --git a/otherlibs/labltk/tkanim/tkanim.mli b/otherlibs/labltk/tkanim/tkanim.mli index e83ceb9bd1..1d1a7f99a3 100644 --- a/otherlibs/labltk/tkanim/tkanim.mli +++ b/otherlibs/labltk/tkanim/tkanim.mli @@ -22,7 +22,7 @@ open Support type animatedGif (* This data type contains all the information of an animation of - gif89a format. It is still test implementation, so I should + gif89a format. It is still test implementation, so I should keep it abstract. --- JPF *) type imageType = @@ -35,7 +35,7 @@ type imageType = (*** Flags ***) -val debug : bool ref +val debug : bool ref (*** Library availability check ***) @@ -57,8 +57,8 @@ val create : string -> imageType (* [create file] loads a gif87 or gif89 image file and parse it, and returns [Animated animated_gif] if the image file has - more than one images. Otherwise, it returns - [Still (ImagePhoto image_photo)] *) + more than one images. Otherwise, it returns + [Still (ImagePhoto image_photo)] *) val delete : animatedGif -> unit @@ -72,7 +72,7 @@ val height : animatedGif -> int given animated gif. *) val images : animatedGif -> imagePhoto list - (* [images anim] returns the list of still images used in the + (* [images anim] returns the list of still images used in the animation *) val animate : widget -> animatedGif -> bool -> unit diff --git a/otherlibs/num/.depend.nt b/otherlibs/num/.depend.nt index fbb31b2962..a22644bab0 100644 --- a/otherlibs/num/.depend.nt +++ b/otherlibs/num/.depend.nt @@ -14,23 +14,23 @@ nat_stubs.dobj: nat_stubs.c ../../byterun/alloc.h \ ../../byterun/io.h ../../byterun/fix_code.h ../../byterun/fail.h \ ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ ../../byterun/freelist.h ../../byterun/minor_gc.h bng.h nat.h -big_int.cmi: nat.cmi -num.cmi: ratio.cmi nat.cmi big_int.cmi -ratio.cmi: nat.cmi big_int.cmi -arith_flags.cmo: arith_flags.cmi -arith_flags.cmx: arith_flags.cmi -arith_status.cmo: arith_flags.cmi arith_status.cmi -arith_status.cmx: arith_flags.cmx arith_status.cmi -big_int.cmo: nat.cmi int_misc.cmi big_int.cmi -big_int.cmx: nat.cmx int_misc.cmx big_int.cmi -int_misc.cmo: int_misc.cmi -int_misc.cmx: int_misc.cmi -nat.cmo: int_misc.cmi nat.cmi -nat.cmx: int_misc.cmx nat.cmi -num.cmo: ratio.cmi nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi num.cmi -num.cmx: ratio.cmx nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx num.cmi -ratio.cmo: nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi ratio.cmi -ratio.cmx: nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx ratio.cmi +big_int.cmi: nat.cmi +num.cmi: ratio.cmi nat.cmi big_int.cmi +ratio.cmi: nat.cmi big_int.cmi +arith_flags.cmo: arith_flags.cmi +arith_flags.cmx: arith_flags.cmi +arith_status.cmo: arith_flags.cmi arith_status.cmi +arith_status.cmx: arith_flags.cmx arith_status.cmi +big_int.cmo: nat.cmi int_misc.cmi big_int.cmi +big_int.cmx: nat.cmx int_misc.cmx big_int.cmi +int_misc.cmo: int_misc.cmi +int_misc.cmx: int_misc.cmi +nat.cmo: int_misc.cmi nat.cmi +nat.cmx: int_misc.cmx nat.cmi +num.cmo: ratio.cmi nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi num.cmi +num.cmx: ratio.cmx nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx num.cmi +ratio.cmo: nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi ratio.cmi +ratio.cmx: nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx ratio.cmi bng.sobj: bng.c bng.h ../../byterun/config.h ../../config/m.h \ ../../config/s.h ../../byterun/compatibility.h bng_ppc.c bng_digit.c bng_alpha.sobj: bng_alpha.c @@ -47,20 +47,20 @@ nat_stubs.sobj: nat_stubs.c ../../byterun/alloc.h \ ../../byterun/io.h ../../byterun/fix_code.h ../../byterun/fail.h \ ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ ../../byterun/freelist.h ../../byterun/minor_gc.h bng.h nat.h -big_int.cmi: nat.cmi -num.cmi: ratio.cmi nat.cmi big_int.cmi -ratio.cmi: nat.cmi big_int.cmi -arith_flags.cmo: arith_flags.cmi -arith_flags.cmx: arith_flags.cmi -arith_status.cmo: arith_flags.cmi arith_status.cmi -arith_status.cmx: arith_flags.cmx arith_status.cmi -big_int.cmo: nat.cmi int_misc.cmi big_int.cmi -big_int.cmx: nat.cmx int_misc.cmx big_int.cmi -int_misc.cmo: int_misc.cmi -int_misc.cmx: int_misc.cmi -nat.cmo: int_misc.cmi nat.cmi -nat.cmx: int_misc.cmx nat.cmi -num.cmo: ratio.cmi nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi num.cmi -num.cmx: ratio.cmx nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx num.cmi -ratio.cmo: nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi ratio.cmi -ratio.cmx: nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx ratio.cmi +big_int.cmi: nat.cmi +num.cmi: ratio.cmi nat.cmi big_int.cmi +ratio.cmi: nat.cmi big_int.cmi +arith_flags.cmo: arith_flags.cmi +arith_flags.cmx: arith_flags.cmi +arith_status.cmo: arith_flags.cmi arith_status.cmi +arith_status.cmx: arith_flags.cmx arith_status.cmi +big_int.cmo: nat.cmi int_misc.cmi big_int.cmi +big_int.cmx: nat.cmx int_misc.cmx big_int.cmi +int_misc.cmo: int_misc.cmi +int_misc.cmx: int_misc.cmi +nat.cmo: int_misc.cmi nat.cmi +nat.cmx: int_misc.cmx nat.cmi +num.cmo: ratio.cmi nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi num.cmi +num.cmx: ratio.cmx nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx num.cmi +ratio.cmo: nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi ratio.cmi +ratio.cmx: nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx ratio.cmi diff --git a/otherlibs/num/README b/otherlibs/num/README index d4969bfdd0..a979356d2b 100644 --- a/otherlibs/num/README +++ b/otherlibs/num/README @@ -9,11 +9,11 @@ maintenance and bug fixing. Initially, the low-level big integer operations were provided by the BigNum package developed by Bernard Serpette, Jean Vuillemin and -Jean-Claude Herve (INRIA and Digital PRL). License issues forced us to +Jean-Claude Herve (INRIA and Digital PRL). License issues forced us to replace the BigNum package. The current implementation of low-level big integer operations is due to Xavier Leroy. -This library is documented in "The CAML Numbers Reference Manual" by +This library is documented in "The CAML Numbers Reference Manual" by Valerie Menissier-Morain, technical report 141, INRIA, july 1992, available at ftp://ftp.inria.fr/INRIA/publication/RT/RT-0141.ps.gz @@ -44,7 +44,7 @@ As an example, try: PROCESSOR-SPECIFIC OPTIMIZATIONS: When compiled with GCC, the low-level primitives use "inline extended asm" -to exploit useful features of the target processor (additions and +to exploit useful features of the target processor (additions and subtractions with carry; double-width multiplication, division). Here are the processors for which such optimizations are available: IA32 (x86) (carry, dwmult, dwdiv, 64-bit ops with SSE2 if available) diff --git a/otherlibs/num/arith_flags.ml b/otherlibs/num/arith_flags.ml index 6192ba2027..00e2813e62 100644 --- a/otherlibs/num/arith_flags.ml +++ b/otherlibs/num/arith_flags.ml @@ -22,4 +22,3 @@ let normalize_ratio_when_printing_flag = ref true;; let floating_precision = ref 12;; let approx_printing_flag = ref false;; - diff --git a/otherlibs/num/arith_status.ml b/otherlibs/num/arith_status.ml index 02affd92b2..8b6fa9f727 100644 --- a/otherlibs/num/arith_status.ml +++ b/otherlibs/num/arith_status.ml @@ -16,17 +16,17 @@ open Arith_flags;; let get_error_when_null_denominator () = - !error_when_null_denominator_flag + !error_when_null_denominator_flag and set_error_when_null_denominator choice = error_when_null_denominator_flag := choice;; -let get_normalize_ratio () = !normalize_ratio_flag -and set_normalize_ratio choice = normalize_ratio_flag := choice;; +let get_normalize_ratio () = !normalize_ratio_flag +and set_normalize_ratio choice = normalize_ratio_flag := choice;; -let get_normalize_ratio_when_printing () = +let get_normalize_ratio_when_printing () = !normalize_ratio_when_printing_flag -and set_normalize_ratio_when_printing choice = - normalize_ratio_when_printing_flag := choice;; +and set_normalize_ratio_when_printing choice = + normalize_ratio_when_printing_flag := choice;; let get_floating_precision () = !floating_precision and set_floating_precision i = floating_precision := i;; diff --git a/otherlibs/num/arith_status.mli b/otherlibs/num/arith_status.mli index ec339cc422..121b4d5756 100644 --- a/otherlibs/num/arith_status.mli +++ b/otherlibs/num/arith_status.mli @@ -21,7 +21,7 @@ val arith_status: unit -> unit val get_error_when_null_denominator : unit -> bool (** See {!Arith_status.set_error_when_null_denominator}.*) val set_error_when_null_denominator : bool -> unit - (** Get or set the flag [null_denominator]. When on, attempting to + (** Get or set the flag [null_denominator]. When on, attempting to create a rational with a null denominator raises an exception. When off, rationals with null denominators are accepted. Initially: on. *) @@ -57,4 +57,3 @@ val set_floating_precision : int -> unit This parameter is the number of digits displayed when [approx_printing] is on. Initially: 12. *) - diff --git a/otherlibs/num/big_int.ml b/otherlibs/num/big_int.ml index 9c74eb4c8e..8342d52d27 100644 --- a/otherlibs/num/big_int.ml +++ b/otherlibs/num/big_int.ml @@ -346,7 +346,7 @@ let nativeint_of_big_int bi = if bi.sign >= 0 then if i >= 0n then i else failwith "nativeint_of_big_int" else - if i >= 0n || i = Nativeint.min_int + if i >= 0n || i = Nativeint.min_int then Nativeint.neg i else failwith "nativeint_of_big_int" @@ -385,7 +385,7 @@ let int64_of_big_int bi = (Int64.logand (Int64.of_nativeint (nth_digit_nat_native bi.abs_value 0)) 0xFFFFFFFFL) - (Int64.shift_left + (Int64.shift_left (Int64.of_nativeint (nth_digit_nat_native bi.abs_value 1)) 32) | _ -> failwith "int64_of_big_int" in @@ -395,7 +395,7 @@ let int64_of_big_int bi = if i >= 0L || i = Int64.min_int then Int64.neg i else failwith "int64_of_big_int" - end + end (* Coercion with nat type *) let nat_of_big_int bi = @@ -833,7 +833,3 @@ let xor_big_int a b = then zero_big_int else { sign = 1; abs_value = res } end - - - - diff --git a/otherlibs/num/big_int.mli b/otherlibs/num/big_int.mli index e6b50b1dfa..70c4c73df1 100644 --- a/otherlibs/num/big_int.mli +++ b/otherlibs/num/big_int.mli @@ -15,11 +15,11 @@ (** Operations on arbitrary-precision integers. - Big integers (type [big_int]) are signed integers of arbitrary size. + Big integers (type [big_int]) are signed integers of arbitrary size. *) - + open Nat - + type big_int (** The type of big integers. *) diff --git a/otherlibs/num/bng.c b/otherlibs/num/bng.c index f7dcd7d0a1..c95ded1d64 100644 --- a/otherlibs/num/bng.c +++ b/otherlibs/num/bng.c @@ -153,7 +153,7 @@ static bngcarry bng_generic_sub return 1; } -/* {a,alen} := {a,alen} << shift. +/* {a,alen} := {a,alen} << shift. Return the bits shifted out of the most significant digit of a. Require 0 <= shift < BITS_PER_BNGDIGIT. */ static bngdigit bng_generic_shift_left @@ -172,7 +172,7 @@ static bngdigit bng_generic_shift_left return carry; } -/* {a,alen} := {a,alen} >> shift. +/* {a,alen} := {a,alen} >> shift. Return the bits shifted out of the least significant digit of a. Require 0 <= shift < BITS_PER_BNGDIGIT. */ static bngdigit bng_generic_shift_right @@ -285,7 +285,7 @@ static bngcarry bng_generic_square_add /* Double products */ for (carry1 = 0, i = 1; i < blen; i++) { aofs = 2 * i - 1; - carry1 += bng_mult_add_digit(a + aofs, alen - aofs, + carry1 += bng_mult_add_digit(a + aofs, alen - aofs, b + i, blen - i, b[i - 1]); } /* Multiply by two */ @@ -426,7 +426,7 @@ struct bng_operations bng_ops = { #endif bng_generic_div_rem }; - + void bng_init(void) { #ifdef BNG_SETUP_OPS diff --git a/otherlibs/num/bng.h b/otherlibs/num/bng.h index 74dd1bd6e8..6d12c87cb3 100644 --- a/otherlibs/num/bng.h +++ b/otherlibs/num/bng.h @@ -52,7 +52,7 @@ struct bng_operations { bngcarry carry); #define bng_sub bng_ops.sub - /* {a,alen} := {a,alen} << shift. + /* {a,alen} := {a,alen} << shift. Return the bits shifted out of the most significant digit of a. Require 0 <= shift < BITS_PER_BNGDIGIT. */ bngdigit (*shift_left) @@ -60,7 +60,7 @@ struct bng_operations { int shift); #define bng_shift_left bng_ops.shift_left - /* {a,alen} := {a,alen} >> shift. + /* {a,alen} := {a,alen} >> shift. Return the bits shifted out of the least significant digit of a. Require 0 <= shift < BITS_PER_BNGDIGIT. */ bngdigit (*shift_right) @@ -154,4 +154,3 @@ extern int bng_compare(bng a/*[alen]*/, bngsize alen, /* Return the number of leading zero bits in digit d. */ extern int bng_leading_zero_bits(bngdigit d); - diff --git a/otherlibs/num/bng_alpha.c b/otherlibs/num/bng_alpha.c index 0360cff7bc..5bf964b582 100644 --- a/otherlibs/num/bng_alpha.c +++ b/otherlibs/num/bng_alpha.c @@ -20,4 +20,3 @@ "umulh %2, %3, %1" \ : "=&r" (resl), "=r" (resh) \ : "r" (arg1), "r" (arg2)) - diff --git a/otherlibs/num/bng_amd64.c b/otherlibs/num/bng_amd64.c index 0a0bd107f7..e829eef23e 100644 --- a/otherlibs/num/bng_amd64.c +++ b/otherlibs/num/bng_amd64.c @@ -193,4 +193,3 @@ static void bng_amd64_setup_ops(void) } #define BNG_SETUP_OPS bng_amd64_setup_ops() - diff --git a/otherlibs/num/bng_digit.c b/otherlibs/num/bng_digit.c index e46eacb6b8..20012aa53d 100644 --- a/otherlibs/num/bng_digit.c +++ b/otherlibs/num/bng_digit.c @@ -168,4 +168,3 @@ static void bng_div_aux(bngdigit * quo, bngdigit * rem, } #endif - diff --git a/otherlibs/num/bng_ia32.c b/otherlibs/num/bng_ia32.c index ff1a0a2304..bbca8e9dcd 100644 --- a/otherlibs/num/bng_ia32.c +++ b/otherlibs/num/bng_ia32.c @@ -318,7 +318,7 @@ static bngdigit bng_ia32sse2_mult_sub_digit "movd (%1), %%mm2 \n\t" /* MM2 is next digit of b */ "paddq %%mm6, %%mm1 \n\t" /* bias digit of a */ "pmuludq %%mm7, %%mm2 \n\t" /* MM2 = d * digit of b */ - /* Compute + /* Compute digit of a + ENC(carry) + 0xFFFFFFFF00000000 - 0xFFFFFFFF - product = digit of a - carry + 0xFFFFFFFF00000000 - product = digit of a - carry - productlow + (ENC(nextcarry) << 32) */ @@ -409,4 +409,3 @@ static void bng_ia32_setup_ops(void) } #define BNG_SETUP_OPS bng_ia32_setup_ops() - diff --git a/otherlibs/num/bng_mips.c b/otherlibs/num/bng_mips.c index 2b760e4b5e..f246843cb8 100644 --- a/otherlibs/num/bng_mips.c +++ b/otherlibs/num/bng_mips.c @@ -21,4 +21,3 @@ "mfhi %1" \ : "=r" (resl), "=r" (resh) \ : "r" (arg1), "r" (arg2)) - diff --git a/otherlibs/num/nat.h b/otherlibs/num/nat.h index 66a664fab0..7f67b916a1 100644 --- a/otherlibs/num/nat.h +++ b/otherlibs/num/nat.h @@ -16,4 +16,3 @@ /* Nats are represented as unstructured blocks with tag Custom_tag. */ #define Digit_val(nat,pos) (((bng) Data_custom_val(nat))[pos]) - diff --git a/otherlibs/num/nat.ml b/otherlibs/num/nat.ml index 0fb65fa28f..cda80d5d48 100644 --- a/otherlibs/num/nat.ml +++ b/otherlibs/num/nat.ml @@ -61,16 +61,16 @@ let make_nat len = (* Nat temporaries *) let a_2 = make_nat 2 -and a_1 = make_nat 1 -and b_2 = make_nat 2 +and a_1 = make_nat 1 +and b_2 = make_nat 2 let copy_nat nat off_set length = let res = create_nat (length) in - blit_nat res 0 nat off_set length; + blit_nat res 0 nat off_set length; res let is_zero_nat n off len = - compare_nat (make_nat 1) 0 1 n off (num_digits_nat n off len) = 0 + compare_nat (make_nat 1) 0 1 n off (num_digits_nat n off len) = 0 let is_nat_int nat off len = num_digits_nat nat off len = 1 && is_digit_int nat off @@ -109,15 +109,15 @@ and gt_nat nat1 off1 len1 nat2 off2 len2 = Fortunately, the carry is never used. *) (*** let square_nat nat1 off1 len1 nat2 off2 len2 = - let c = ref 0 + let c = ref 0 and trash = make_nat 1 in (* Double product *) for i = 0 to len2 - 2 do - c := !c + mult_digit_nat + c := !c + mult_digit_nat nat1 (succ (off1 + 2 * i)) (2 * (pred (len2 - i))) - nat2 + nat2 (succ (off2 + i)) (pred (len2 - i)) nat2 @@ -126,8 +126,8 @@ let square_nat nat1 off1 len1 nat2 off2 len2 = shift_left_nat nat1 0 len1 trash 0 1; (* Square of digit *) for i = 0 to len2 - 1 do - c := !c + mult_digit_nat - nat1 + c := !c + mult_digit_nat + nat1 (off1 + 2 * i) (len1 - 2 * i) nat2 @@ -139,14 +139,14 @@ let square_nat nat1 off1 len1 nat2 off2 len2 = !c ***) -let gcd_int_nat i nat off len = +let gcd_int_nat i nat off len = if i = 0 then 1 else if is_nat_int nat off len then begin set_digit_nat nat off (gcd_int (nth_digit_nat nat off) i); 0 end else begin let len_copy = succ len in - let copy = create_nat len_copy - and quotient = create_nat 1 + let copy = create_nat len_copy + and quotient = create_nat 1 and remainder = create_nat 1 in blit_nat copy 0 nat off len; set_digit_nat copy len 0; @@ -170,9 +170,9 @@ let gcd_nat nat1 off1 len1 nat2 off2 len2 = set_digit_nat !copy2 len2 0; if lt_nat !copy1 0 len1 !copy2 0 len2 then exchange copy1 copy2; - let real_len1 = + let real_len1 = ref (num_digits_nat !copy1 0 (length_nat !copy1)) - and real_len2 = + and real_len2 = ref (num_digits_nat !copy2 0 (length_nat !copy2)) in while not (is_zero_nat !copy2 0 !real_len2) do set_digit_nat !copy1 !real_len1 0; @@ -180,7 +180,7 @@ let gcd_nat nat1 off1 len1 nat2 off2 len2 = exchange copy1 copy2; real_len1 := !real_len2; real_len2 := num_digits_nat !copy2 0 !real_len2 - done; + done; blit_nat nat1 off1 !copy1 0 !real_len1; !real_len1 end @@ -205,7 +205,7 @@ let sqrt_nat rad off len = set_digit_nat res len 0; set_digit_nat res (rad_len - 1) 0; res in - let cand_len = (len + 1) / 2 in (* ceiling len / 2 *) + let cand_len = (len + 1) / 2 in (* ceiling len / 2 *) let cand_rest = rad_len - cand_len in (* Racine carrée supposée cand = "|FFFF .... |" *) let cand = make_nat cand_len in @@ -245,10 +245,10 @@ let sqrt_nat rad off len = let power_base_max = make_nat 2;; match length_of_digit with - | 64 -> + | 64 -> set_digit_nat power_base_max 0 (Int64.to_int 1000000000000000000L); ignore - (mult_digit_nat power_base_max 0 2 + (mult_digit_nat power_base_max 0 2 power_base_max 0 1 (nat_of_int 9) 0) | 32 -> set_digit_nat power_base_max 0 1000000000 | _ -> assert false @@ -275,8 +275,8 @@ let max_power_10_power_in_int = ;; let raw_string_of_digit nat off = - if is_nat_int nat off 1 - then begin string_of_int (nth_digit_nat nat off) end + if is_nat_int nat off 1 + then begin string_of_int (nth_digit_nat nat off) end else begin blit_nat b_2 0 nat off 1; div_digit_nat a_2 0 a_1 0 b_2 0 2 max_power_10_power_in_int 0; @@ -285,15 +285,15 @@ let raw_string_of_digit nat off = let len = String.length s1 in if leading_digits < 10 then begin let result = String.make (max_superscript_10_power_in_int+1) '0' in - String.set result 0 + String.set result 0 (Char.chr (48 + leading_digits)); - String.blit s1 0 + String.blit s1 0 result (String.length result - len) len; result end else begin let result = String.make (max_superscript_10_power_in_int+2) '0' in String.blit (string_of_int leading_digits) 0 result 0 2; - String.blit s1 0 + String.blit s1 0 result (String.length result - len) len; result end @@ -318,32 +318,32 @@ let string_of_digit nat = let digits = "0123456789ABCDEF" (* - make_power_base affecte power_base des puissances successives de base a + make_power_base affecte power_base des puissances successives de base a partir de la puissance 1-ieme. - A la fin de la boucle i-1 est la plus grande puissance de la base qui tient - sur un seul digit et j est la plus grande puissance de la base qui tient + A la fin de la boucle i-1 est la plus grande puissance de la base qui tient + sur un seul digit et j est la plus grande puissance de la base qui tient sur un int. *) -let make_power_base base power_base = - let i = ref 0 +let make_power_base base power_base = + let i = ref 0 and j = ref 0 in set_digit_nat power_base 0 base; while incr i; is_digit_zero power_base !i do ignore - (mult_digit_nat power_base !i 2 - power_base (pred !i) 1 + (mult_digit_nat power_base !i 2 + power_base (pred !i) 1 power_base 0) done; while !j <= !i && is_digit_int power_base !j do incr j done; (!i - 2, !j) -(* - int_to_string place la representation de l entier int en base base - dans la chaine s en le rangeant de la fin indiquee par pos vers le - debut, sur times places et affecte a pos sa nouvelle valeur. +(* + int_to_string place la representation de l entier int en base base + dans la chaine s en le rangeant de la fin indiquee par pos vers le + debut, sur times places et affecte a pos sa nouvelle valeur. *) -let int_to_string int s pos_ref base times = - let i = ref int +let int_to_string int s pos_ref base times = + let i = ref int and j = ref times in while ((!i != 0) || (!j != 0)) && (!pos_ref != -1) do String.set s !pos_ref (String.get digits (!i mod base)); @@ -354,15 +354,15 @@ let int_to_string int s pos_ref base times = (* XL: suppression de adjust_string *) -let power_base_int base i = +let power_base_int base i = if i = 0 then - nat_of_int 1 + nat_of_int 1 else if i < 0 then invalid_arg "power_base_int" else begin let power_base = make_nat (succ length_of_digit) in let (pmax, pint) = make_power_base base power_base in - let n = i / (succ pmax) + let n = i / (succ pmax) and rem = i mod (succ pmax) in if n > 0 then begin let newn = @@ -380,7 +380,7 @@ let power_base_int base i = if n land !p > 0 then begin set_to_zero_nat res 0 len; ignore - (mult_digit_nat res 0 succ_len2 + (mult_digit_nat res 0 succ_len2 res2 0 len2 power_base pmax) end else blit_nat res 0 res2 0 len2; @@ -389,11 +389,11 @@ let power_base_int base i = done; if rem > 0 then begin ignore - (mult_digit_nat res2 0 newn + (mult_digit_nat res2 0 newn res 0 n power_base (pred rem)); res2 end else res - end else + end else copy_nat power_base (pred rem) 1 end @@ -409,47 +409,47 @@ let power_base_int base i = (* Puis suppression (inutile?) *) (****** -let num_digits_max_vector = - [|0; 0; 1024; 1623; 2048; 2378; 2647; 2875; 3072; 3246; 3402; +let num_digits_max_vector = + [|0; 0; 1024; 1623; 2048; 2378; 2647; 2875; 3072; 3246; 3402; 3543; 3671; 3789; 3899; 4001; 4096|] -let num_digits_max_vector = +let num_digits_max_vector = match length_of_digit with - 16 -> [|0; 0; 2048; 3246; 4096; 4755; 5294; 5749; 6144; 6492; 6803; + 16 -> [|0; 0; 2048; 3246; 4096; 4755; 5294; 5749; 6144; 6492; 6803; 7085; 7342; 7578; 7797; 8001; 8192|] (* If really exotic machines !!!! - | 17 -> [|0; 0; 1928; 3055; 3855; 4476; 4983; 5411; 5783; 6110; 6403; + | 17 -> [|0; 0; 1928; 3055; 3855; 4476; 4983; 5411; 5783; 6110; 6403; 6668; 6910; 7133; 7339; 7530; 7710|] - | 18 -> [|0; 0; 1821; 2886; 3641; 4227; 4706; 5111; 5461; 5771; 6047; + | 18 -> [|0; 0; 1821; 2886; 3641; 4227; 4706; 5111; 5461; 5771; 6047; 6298; 6526; 6736; 6931; 7112; 7282|] - | 19 -> [|0; 0; 1725; 2734; 3449; 4005; 4458; 4842; 5174; 5467; 5729; + | 19 -> [|0; 0; 1725; 2734; 3449; 4005; 4458; 4842; 5174; 5467; 5729; 5966; 6183; 6382; 6566; 6738; 6898|] - | 20 -> [|0; 0; 1639; 2597; 3277; 3804; 4235; 4600; 4915; 5194; 5443; - 5668; 5874; 6063; 6238; 6401; 6553|] - | 21 -> [|0; 0; 1561; 2473; 3121; 3623; 4034; 4381; 4681; 4946; 5183; + | 20 -> [|0; 0; 1639; 2597; 3277; 3804; 4235; 4600; 4915; 5194; 5443; + 5668; 5874; 6063; 6238; 6401; 6553|] + | 21 -> [|0; 0; 1561; 2473; 3121; 3623; 4034; 4381; 4681; 4946; 5183; 5398; 5594; 5774; 5941; 6096; 6241|] - | 22 -> [|0; 0; 1490; 2361; 2979; 3459; 3850; 4182; 4468; 4722; 4948; + | 22 -> [|0; 0; 1490; 2361; 2979; 3459; 3850; 4182; 4468; 4722; 4948; 5153; 5340; 5512; 5671; 5819; 5958|] - | 23 -> [|0; 0; 1425; 2258; 2850; 3308; 3683; 4000; 4274; 4516; 4733; + | 23 -> [|0; 0; 1425; 2258; 2850; 3308; 3683; 4000; 4274; 4516; 4733; 4929; 5108; 5272; 5424; 5566; 5699|] - | 24 -> [|0; 0; 1366; 2164; 2731; 3170; 3530; 3833; 4096; 4328; 4536; + | 24 -> [|0; 0; 1366; 2164; 2731; 3170; 3530; 3833; 4096; 4328; 4536; 4723; 4895; 5052; 5198; 5334; 5461|] - | 25 -> [|0; 0; 1311; 2078; 2622; 3044; 3388; 3680; 3932; 4155; 4354; + | 25 -> [|0; 0; 1311; 2078; 2622; 3044; 3388; 3680; 3932; 4155; 4354; 4534; 4699; 4850; 4990; 5121; 5243|] - | 26 -> [|0; 0; 1261; 1998; 2521; 2927; 3258; 3538; 3781; 3995; 4187; + | 26 -> [|0; 0; 1261; 1998; 2521; 2927; 3258; 3538; 3781; 3995; 4187; 4360; 4518; 4664; 4798; 4924; 5041|] - | 27 -> [|0; 0; 1214; 1924; 2428; 2818; 3137; 3407; 3641; 3847; 4032; + | 27 -> [|0; 0; 1214; 1924; 2428; 2818; 3137; 3407; 3641; 3847; 4032; 4199; 4351; 4491; 4621; 4742; 4855|] - | 28 -> [|0; 0; 1171; 1855; 2341; 2718; 3025; 3286; 3511; 3710; 3888; + | 28 -> [|0; 0; 1171; 1855; 2341; 2718; 3025; 3286; 3511; 3710; 3888; 4049; 4196; 4331; 4456; 4572; 4681|] - | 29 -> [|0; 0; 1130; 1791; 2260; 2624; 2921; 3172; 3390; 3582; 3754; + | 29 -> [|0; 0; 1130; 1791; 2260; 2624; 2921; 3172; 3390; 3582; 3754; 3909; 4051; 4181; 4302; 4415; 4520|] - | 30 -> [|0; 0; 1093; 1732; 2185; 2536; 2824; 3067; 3277; 3463; 3629; + | 30 -> [|0; 0; 1093; 1732; 2185; 2536; 2824; 3067; 3277; 3463; 3629; 3779; 3916; 4042; 4159; 4267; 4369|] - | 31 -> [|0; 0; 1057; 1676; 2114; 2455; 2733; 2968; 3171; 3351; 3512; + | 31 -> [|0; 0; 1057; 1676; 2114; 2455; 2733; 2968; 3171; 3351; 3512; 3657; 3790; 3912; 4025; 4130; 4228|] *) - | 32 -> [|0; 0; 1024; 1623; 2048; 2378; 2647; 2875; 3072; 3246; 3402; + | 32 -> [|0; 0; 1024; 1623; 2048; 2378; 2647; 2875; 3072; 3246; 3402; 3543; 3671; 3789; 3899; 4001; 4096|] | n -> failwith "num_digits_max_vector" ******) @@ -466,34 +466,34 @@ let unadjusted_string_of_nat nat off len_nat = and copy2 = make_nat !len_copy and rest_digit = make_nat 2 in if len > biggest_int / (succ pmax) - then failwith "number too long" + then failwith "number too long" else let len_s = (succ pmax) * len in let s = String.make len_s '0' and pos_ref = ref len_s in - len_copy := pred !len_copy; + len_copy := pred !len_copy; blit_nat copy1 0 nat off len; set_digit_nat copy1 len 0; - while not (is_zero_nat copy1 0 !len_copy) do - div_digit_nat copy2 0 - rest_digit 0 - copy1 0 (succ !len_copy) + while not (is_zero_nat copy1 0 !len_copy) do + div_digit_nat copy2 0 + rest_digit 0 + copy1 0 (succ !len_copy) power_base_max 0; let str = raw_string_of_digit rest_digit 0 in - String.blit str 0 + String.blit str 0 s (!pos_ref - String.length str) (String.length str); (* XL: il y avait pmax a la place de String.length str mais ca ne marche pas avec le blit de Caml Light, qui ne verifie pas les debordements *) pos_ref := !pos_ref - pmax; - len_copy := num_digits_nat copy2 0 !len_copy; + len_copy := num_digits_nat copy2 0 !len_copy; blit_nat copy1 0 copy2 0 !len_copy; - set_digit_nat copy1 !len_copy 0 + set_digit_nat copy1 !len_copy 0 done; s -let string_of_nat nat = - let s = unadjusted_string_of_nat nat 0 (length_nat nat) +let string_of_nat nat = + let s = unadjusted_string_of_nat nat 0 (length_nat nat) and index = ref 0 in begin try for i = 0 to String.length s - 2 do @@ -513,11 +513,11 @@ let base_digit_of_char c base = else if n >= 65 && n <= 65 + base - 11 then n - 55 else failwith "invalid digit" -(* - La sous-chaine (s, off, len) represente un nat en base base que - on determine ici +(* + La sous-chaine (s, off, len) represente un nat en base base que + on determine ici *) -let sys_nat_of_string base s off len = +let sys_nat_of_string base s off len = let power_base = make_nat (succ length_of_digit) in let (pmax, pint) = make_power_base base power_base in let new_len = ref (1 + len / (pmax + 1)) @@ -525,33 +525,33 @@ let sys_nat_of_string base s off len = let possible_len = ref (min 2 !new_len) in let nat1 = make_nat !new_len - and nat2 = make_nat !new_len + and nat2 = make_nat !new_len - and digits_read = ref 0 + and digits_read = ref 0 and bound = off + len - 1 and int = ref 0 in for i = off to bound do - (* - on lit pint (au maximum) chiffres, on en fait un int + (* + on lit pint (au maximum) chiffres, on en fait un int et on l integre au nombre *) let c = String.get s i in - begin match c with + begin match c with ' ' | '\t' | '\n' | '\r' | '\\' -> () | _ -> int := !int * base + base_digit_of_char c base; incr digits_read end; - if (!digits_read = pint || i = bound) && not (!digits_read = 0) then + if (!digits_read = pint || i = bound) && not (!digits_read = 0) then begin set_digit_nat nat1 0 !int; let erase_len = if !new_len = !current_len then !current_len - 1 else !current_len in - for j = 1 to erase_len do + for j = 1 to erase_len do set_digit_nat nat1 j 0 done; ignore - (mult_digit_nat nat1 0 !possible_len + (mult_digit_nat nat1 0 !possible_len nat2 0 !current_len power_base (pred !digits_read)); blit_nat nat2 0 nat1 0 !possible_len; current_len := num_digits_nat nat1 0 !possible_len; @@ -560,8 +560,8 @@ let sys_nat_of_string base s off len = digits_read := 0 end done; - (* - On recadre le nat + (* + On recadre le nat *) let nat = create_nat !current_len in blit_nat nat 0 nat1 0 !current_len; diff --git a/otherlibs/num/nat.mli b/otherlibs/num/nat.mli index a220eb2210..3b32ac8dcf 100644 --- a/otherlibs/num/nat.mli +++ b/otherlibs/num/nat.mli @@ -29,7 +29,7 @@ external set_digit_nat: nat -> int -> int -> unit = "set_digit_nat" external nth_digit_nat: nat -> int -> int = "nth_digit_nat" external set_digit_nat_native: nat -> int -> nativeint -> unit = "set_digit_nat_native" external nth_digit_nat_native: nat -> int -> nativeint = "nth_digit_nat_native" -val length_nat : nat -> int +val length_nat : nat -> int external num_digits_nat: nat -> int -> int -> int = "num_digits_nat" external num_leading_zero_bits_in_digit: nat -> int -> int = "num_leading_zero_bits_in_digit" external is_digit_int: nat -> int -> bool = "is_digit_int" diff --git a/otherlibs/num/nat_stubs.c b/otherlibs/num/nat_stubs.c index 45f4521cad..cffe123741 100644 --- a/otherlibs/num/nat_stubs.c +++ b/otherlibs/num/nat_stubs.c @@ -267,7 +267,7 @@ CAMLprim value div_nat(value *argv, int argn) return div_nat_native(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); } - + value shift_right_nat_native(value nat1, value ofs1, value len1, value nat2, value ofs2, value nbits) { @@ -283,7 +283,7 @@ CAMLprim value shift_right_nat(value *argv, int argn) argv[3], argv[4], argv[5]); } -CAMLprim value compare_digits_nat(value nat1, value ofs1, +CAMLprim value compare_digits_nat(value nat1, value ofs1, value nat2, value ofs2) { bngdigit d1 = Digit_val(nat1, Long_val(ofs1)); @@ -333,7 +333,7 @@ CAMLprim value lxor_digit_nat(value nat1, value ofs1, value nat2, value ofs2) For big-endian 64-bit platforms, we need to swap the two 32-bit halves of 64-bit words to obtain the correct behavior. */ -static void serialize_nat(value nat, +static void serialize_nat(value nat, uintnat * wsize_32, uintnat * wsize_64) { diff --git a/otherlibs/num/num.ml b/otherlibs/num/num.ml index b3fb724693..52fe8cc0e8 100644 --- a/otherlibs/num/num.ml +++ b/otherlibs/num/num.ml @@ -438,8 +438,3 @@ and approx_num_exp n num = approx_ratio_exp n (ratio_of_num num) let incr_num r = r := succ_num !r and decr_num r = r := pred_num !r - - - - - diff --git a/otherlibs/num/num.mli b/otherlibs/num/num.mli index c69f3b0d4a..8bf3d4e6e7 100644 --- a/otherlibs/num/num.mli +++ b/otherlibs/num/num.mli @@ -16,7 +16,7 @@ (** Operation on arbitrary-precision numbers. Numbers (type [num]) are arbitrary-precision rational numbers, - plus the special elements [1/0] (infinity) and [0/0] (undefined). + plus the special elements [1/0] (infinity) and [0/0] (undefined). *) open Nat @@ -24,7 +24,7 @@ open Big_int open Ratio (** The type of numbers. *) -type num = +type num = Int of int | Big_int of big_int | Ratio of ratio @@ -96,7 +96,7 @@ val is_integer_num : num -> bool (** The four following functions approximate a number by an integer : *) val integer_num : num -> num -(** [integer_num n] returns the integer closest to [n]. In case of ties, +(** [integer_num n] returns the integer closest to [n]. In case of ties, rounds towards zero. *) val floor_num : num -> num @@ -168,4 +168,3 @@ val big_int_of_num : num -> big_int val ratio_of_num : num -> ratio val num_of_ratio : ratio -> num val float_of_num : num -> float - diff --git a/otherlibs/num/ratio.ml b/otherlibs/num/ratio.ml index e587efe3e7..7885df15d6 100644 --- a/otherlibs/num/ratio.ml +++ b/otherlibs/num/ratio.ml @@ -17,18 +17,18 @@ open Big_int open Arith_flags (* Definition of the type ratio : - Conventions : - - the denominator is always a positive number - - the sign of n/0 is the sign of n -These convention is automatically respected when a ratio is created with + Conventions : + - the denominator is always a positive number + - the sign of n/0 is the sign of n +These convention is automatically respected when a ratio is created with the create_ratio primitive *) -type ratio = { mutable numerator : big_int; - mutable denominator : big_int; +type ratio = { mutable numerator : big_int; + mutable denominator : big_int; mutable normalized : bool} -let failwith_zero name = +let failwith_zero name = let s = "infinite or undefined rational number" in failwith (if String.length name = 0 then s else name ^ " " ^ s) @@ -37,18 +37,18 @@ and denominator_ratio r = r.denominator let null_denominator r = sign_big_int r.denominator = 0 -let verify_null_denominator r = +let verify_null_denominator r = if sign_big_int r.denominator = 0 then (if !error_when_null_denominator_flag then (failwith_zero "") else true) else false -let sign_ratio r = sign_big_int r.numerator +let sign_ratio r = sign_big_int r.numerator (* Physical normalization of rational numbers *) (* 1/0, 0/0 and -1/0 are the normalized forms for n/0 numbers *) -let normalize_ratio r = +let normalize_ratio r = if r.normalized then r else if verify_null_denominator r then begin r.numerator <- big_int_of_int (sign_big_int r.numerator); @@ -56,12 +56,12 @@ let normalize_ratio r = r end else begin let p = gcd_big_int r.numerator r.denominator in - if eq_big_int p unit_big_int + if eq_big_int p unit_big_int then begin r.normalized <- true; r end else begin - r.numerator <- div_big_int (r.numerator) p; - r.denominator <- div_big_int (r.denominator) p; + r.numerator <- div_big_int (r.numerator) p; + r.denominator <- div_big_int (r.denominator) p; r.normalized <- true; r end end @@ -73,24 +73,24 @@ let cautious_normalize_ratio_when_printing r = if (!normalize_ratio_when_printing_flag) then (normalize_ratio r) else r let create_ratio bi1 bi2 = - match sign_big_int bi2 with + match sign_big_int bi2 with -1 -> cautious_normalize_ratio - { numerator = minus_big_int bi1; + { numerator = minus_big_int bi1; denominator = minus_big_int bi2; normalized = false } - | 0 -> if !error_when_null_denominator_flag + | 0 -> if !error_when_null_denominator_flag then (failwith_zero "create_ratio") - else cautious_normalize_ratio + else cautious_normalize_ratio { numerator = bi1; denominator = bi2; normalized = false } - | _ -> cautious_normalize_ratio + | _ -> cautious_normalize_ratio { numerator = bi1; denominator = bi2; normalized = false } let create_normalized_ratio bi1 bi2 = match sign_big_int bi2 with - -1 -> { numerator = minus_big_int bi1; - denominator = minus_big_int bi2; + -1 -> { numerator = minus_big_int bi1; + denominator = minus_big_int bi2; normalized = true } -| 0 -> if !error_when_null_denominator_flag +| 0 -> if !error_when_null_denominator_flag then failwith_zero "create_normalized_ratio" else { numerator = bi1; denominator = bi2; normalized = true } | _ -> { numerator = bi1; denominator = bi2; normalized = true } @@ -99,10 +99,10 @@ let is_normalized_ratio r = r.normalized let report_sign_ratio r bi = if sign_ratio r = -1 - then minus_big_int bi + then minus_big_int bi else bi -let abs_ratio r = +let abs_ratio r = { numerator = abs_big_int r.numerator; denominator = r.denominator; normalized = r.normalized } @@ -114,17 +114,17 @@ let is_integer_ratio r = let add_ratio r1 r2 = if !normalize_ratio_flag then begin - let p = gcd_big_int ((normalize_ratio r1).denominator) + let p = gcd_big_int ((normalize_ratio r1).denominator) ((normalize_ratio r2).denominator) in - if eq_big_int p unit_big_int then - {numerator = add_big_int (mult_big_int (r1.numerator) r2.denominator) + if eq_big_int p unit_big_int then + {numerator = add_big_int (mult_big_int (r1.numerator) r2.denominator) (mult_big_int (r2.numerator) r1.denominator); denominator = mult_big_int (r1.denominator) r2.denominator; normalized = true} else begin let d1 = div_big_int (r1.denominator) p and d2 = div_big_int (r2.denominator) p in - let n = add_big_int (mult_big_int (r1.numerator) d2) + let n = add_big_int (mult_big_int (r1.numerator) d2) (mult_big_int d1 r2.numerator) in let p' = gcd_big_int n p in { numerator = div_big_int n p'; @@ -132,7 +132,7 @@ let add_ratio r1 r2 = normalized = true } end end else - { numerator = add_big_int (mult_big_int (r1.numerator) r2.denominator) + { numerator = add_big_int (mult_big_int (r1.numerator) r2.denominator) (mult_big_int (r1.denominator) r2.numerator); denominator = mult_big_int (r1.denominator) r2.denominator; normalized = false } @@ -142,13 +142,13 @@ let minus_ratio r = denominator = r.denominator; normalized = r.normalized } -let add_int_ratio i r = +let add_int_ratio i r = ignore (cautious_normalize_ratio r); { numerator = add_big_int (mult_int_big_int i r.denominator) r.numerator; denominator = r.denominator; normalized = r.normalized } -let add_big_int_ratio bi r = +let add_big_int_ratio bi r = ignore (cautious_normalize_ratio r); { numerator = add_big_int (mult_big_int bi r.denominator) r.numerator ; denominator = r.denominator; @@ -158,15 +158,15 @@ let sub_ratio r1 r2 = add_ratio r1 (minus_ratio r2) let mult_ratio r1 r2 = if !normalize_ratio_flag then begin - let p1 = gcd_big_int ((normalize_ratio r1).numerator) - ((normalize_ratio r2).denominator) + let p1 = gcd_big_int ((normalize_ratio r1).numerator) + ((normalize_ratio r2).denominator) and p2 = gcd_big_int (r2.numerator) r1.denominator in - let (n1, d2) = - if eq_big_int p1 unit_big_int + let (n1, d2) = + if eq_big_int p1 unit_big_int then (r1.numerator, r2.denominator) else (div_big_int (r1.numerator) p1, div_big_int (r2.denominator) p1) and (n2, d1) = - if eq_big_int p2 unit_big_int + if eq_big_int p2 unit_big_int then (r2.numerator, r1.denominator) else (div_big_int r2.numerator p2, div_big_int r1.denominator p2) in { numerator = mult_big_int n1 n2; @@ -177,15 +177,15 @@ let mult_ratio r1 r2 = denominator = mult_big_int (r1.denominator) r2.denominator; normalized = false } -let mult_int_ratio i r = +let mult_int_ratio i r = if !normalize_ratio_flag then begin let p = gcd_big_int ((normalize_ratio r).denominator) (big_int_of_int i) in - if eq_big_int p unit_big_int + if eq_big_int p unit_big_int then { numerator = mult_big_int (big_int_of_int i) r.numerator; denominator = r.denominator; normalized = true } - else { numerator = mult_big_int (div_big_int (big_int_of_int i) p) + else { numerator = mult_big_int (div_big_int (big_int_of_int i) p) r.numerator; denominator = div_big_int (r.denominator) p; normalized = true } @@ -195,8 +195,8 @@ let mult_int_ratio i r = denominator = r.denominator; normalized = false } -let mult_big_int_ratio bi r = - if !normalize_ratio_flag then +let mult_big_int_ratio bi r = + if !normalize_ratio_flag then begin let p = gcd_big_int ((normalize_ratio r).denominator) bi in if eq_big_int p unit_big_int @@ -221,24 +221,24 @@ let square_ratio r = let inverse_ratio r = if !error_when_null_denominator_flag && (sign_big_int r.numerator) = 0 then failwith_zero "inverse_ratio" - else {numerator = report_sign_ratio r r.denominator; - denominator = abs_big_int r.numerator; + else {numerator = report_sign_ratio r r.denominator; + denominator = abs_big_int r.numerator; normalized = r.normalized} -let div_ratio r1 r2 = +let div_ratio r1 r2 = mult_ratio r1 (inverse_ratio r2) (* Integer part of a rational number *) (* Odd function *) -let integer_ratio r = +let integer_ratio r = if null_denominator r then failwith_zero "integer_ratio" else if sign_ratio r = 0 then zero_big_int - else report_sign_ratio r (div_big_int (abs_big_int r.numerator) + else report_sign_ratio r (div_big_int (abs_big_int r.numerator) (abs_big_int r.denominator)) (* Floor of a rational number *) (* Always less or equal to r *) -let floor_ratio r = +let floor_ratio r = ignore (verify_null_denominator r); div_big_int (r.numerator) r.denominator @@ -248,17 +248,17 @@ let round_ratio r = ignore (verify_null_denominator r); let abs_num = abs_big_int r.numerator in let bi = div_big_int abs_num r.denominator in - report_sign_ratio r - (if sign_big_int - (sub_big_int - (mult_int_big_int - 2 - (sub_big_int abs_num (mult_big_int (r.denominator) bi))) + report_sign_ratio r + (if sign_big_int + (sub_big_int + (mult_int_big_int + 2 + (sub_big_int abs_num (mult_big_int (r.denominator) bi))) r.denominator) = -1 then bi else succ_big_int bi) -let ceiling_ratio r = +let ceiling_ratio r = if (is_integer_ratio r) then r.numerator else succ_big_int (floor_ratio r) @@ -266,33 +266,33 @@ let ceiling_ratio r = (* Comparison operators on rational numbers *) let eq_ratio r1 r2 = - ignore (normalize_ratio r1); + ignore (normalize_ratio r1); ignore (normalize_ratio r2); eq_big_int (r1.numerator) r2.numerator && - eq_big_int (r1.denominator) r2.denominator + eq_big_int (r1.denominator) r2.denominator let compare_ratio r1 r2 = if verify_null_denominator r1 then let sign_num_r1 = sign_big_int r1.numerator in if (verify_null_denominator r2) - then + then let sign_num_r2 = sign_big_int r2.numerator in - if sign_num_r1 = 1 && sign_num_r2 = -1 then 1 + if sign_num_r1 = 1 && sign_num_r2 = -1 then 1 else if sign_num_r1 = -1 && sign_num_r2 = 1 then -1 else 0 else sign_num_r1 else if verify_null_denominator r2 then -(sign_big_int r2.numerator) - else match compare_int (sign_big_int r1.numerator) + else match compare_int (sign_big_int r1.numerator) (sign_big_int r2.numerator) with 1 -> 1 | -1 -> -1 - | _ -> if eq_big_int (r1.denominator) r2.denominator + | _ -> if eq_big_int (r1.denominator) r2.denominator then compare_big_int (r1.numerator) r2.numerator - else compare_big_int - (mult_big_int (r1.numerator) r2.denominator) + else compare_big_int + (mult_big_int (r1.numerator) r2.denominator) (mult_big_int (r1.denominator) r2.numerator) - + let lt_ratio r1 r2 = compare_ratio r1 r2 < 0 and le_ratio r1 r2 = compare_ratio r1 r2 <= 0 @@ -319,18 +319,18 @@ and ge_big_int_ratio bi r = compare_big_int_ratio bi r >= 0 (* Coercions *) (* Coercions with type int *) -let int_of_ratio r = +let int_of_ratio r = if ((is_integer_ratio r) && (is_int_big_int r.numerator)) then (int_of_big_int r.numerator) else failwith "integer argument required" and ratio_of_int i = - { numerator = big_int_of_int i; + { numerator = big_int_of_int i; denominator = unit_big_int; normalized = true } (* Coercions with type nat *) -let ratio_of_nat nat = +let ratio_of_nat nat = { numerator = big_int_of_nat nat; denominator = unit_big_int; normalized = true } @@ -344,27 +344,27 @@ and nat_of_ratio r = else failwith "nat_of_ratio" (* Coercions with type big_int *) -let ratio_of_big_int bi = +let ratio_of_big_int bi = { numerator = bi; denominator = unit_big_int; normalized = true } and big_int_of_ratio r = ignore (normalize_ratio r); - if is_integer_ratio r + if is_integer_ratio r then r.numerator else failwith "big_int_of_ratio" -let div_int_ratio i r = +let div_int_ratio i r = ignore (verify_null_denominator r); mult_int_ratio i (inverse_ratio r) -let div_ratio_int r i = +let div_ratio_int r i = div_ratio r (ratio_of_int i) -let div_big_int_ratio bi r = +let div_big_int_ratio bi r = ignore (verify_null_denominator r); mult_big_int_ratio bi (inverse_ratio r) -let div_ratio_big_int r bi = +let div_ratio_big_int r bi = div_ratio r (ratio_of_big_int bi) (* Functions on type string *) @@ -422,14 +422,14 @@ let approx_ratio_fix n r = (* Don't need to normalize *) if (null_denominator r) then failwith_zero "approx_ratio_fix" else - let sign_r = sign_ratio r in + let sign_r = sign_ratio r in if sign_r = 0 then "+0" (* r = 0 *) else - (* r.numerator and r.denominator are not null numbers + (* r.numerator and r.denominator are not null numbers s1 contains one more digit than desired for the round off operation *) if n >= 0 then begin - let s1 = + let s1 = string_of_nat (nat_of_big_int (div_big_int @@ -464,7 +464,7 @@ let approx_ratio_fix n r = (* Dubious; what is this code supposed to do? *) let s = string_of_big_int (div_big_int - (abs_big_int r.numerator) + (abs_big_int r.numerator) (base_power_big_int 10 (-n) r.denominator)) in let len = succ (String.length s) in @@ -475,13 +475,13 @@ let approx_ratio_fix n r = end (* Number of digits of the decimal representation of an int *) -let num_decimal_digits_int n = +let num_decimal_digits_int n = String.length (string_of_int n) (* Approximation with floating decimal point *) (* This is an odd function and the last digit is round off *) (* Format (+/-)(0. n_first_digits e msd)/(1. n_zeros e (msd+1) *) -let approx_ratio_exp n r = +let approx_ratio_exp n r = (* Don't need to normalize *) if (null_denominator r) then failwith_zero "approx_ratio_exp" else if n <= 0 then invalid_arg "approx_ratio_exp" @@ -493,22 +493,22 @@ let approx_ratio_exp n r = let s = String.make (n + 5) '0' in (String.blit "+0." 0 s 0 3); (String.blit "e0" 0 s !i 2); s - else + else let msd = msd_ratio (abs_ratio r) in let k = n - msd in - let s = + let s = (let nat = nat_of_big_int (if k < 0 - then - div_big_int (abs_big_int r.numerator) - (base_power_big_int 10 (- k) + then + div_big_int (abs_big_int r.numerator) + (base_power_big_int 10 (- k) r.denominator) - else + else div_big_int (base_power_big_int 10 k (abs_big_int r.numerator)) r.denominator) in string_of_nat nat) in - if (round_futur_last_digit s 0 (String.length s)) + if (round_futur_last_digit s 0 (String.length s)) then let m = num_decimal_digits_int (succ msd) in let str = String.make (n + m + 4) '0' in @@ -516,8 +516,8 @@ let approx_ratio_exp n r = String.set str !i ('e'); incr i; (if m = 0 - then String.set str !i '0' - else String.blit (string_of_int (succ msd)) 0 str !i m); + then String.set str !i '0' + else String.blit (string_of_int (succ msd)) 0 str !i m); str else let m = num_decimal_digits_int (succ msd) @@ -533,14 +533,14 @@ let approx_ratio_exp n r = (* String approximation of a rational with a fixed number of significant *) (* digits printed *) -let float_of_rational_string r = +let float_of_rational_string r = let s = approx_ratio_exp !floating_precision r in if String.get s 0 = '+' then (String.sub s 1 (pred (String.length s))) else s (* Coercions with type string *) -let string_of_ratio r = +let string_of_ratio r = ignore (cautious_normalize_ratio_when_printing r); if !approx_printing_flag then float_of_rational_string r @@ -566,10 +566,10 @@ let float_of_ratio r = (* XL: suppression de ratio_of_float *) -let power_ratio_positive_int r n = - create_ratio (power_big_int_positive_int (r.numerator) n) +let power_ratio_positive_int r n = + create_ratio (power_big_int_positive_int (r.numerator) n) (power_big_int_positive_int (r.denominator) n) -let power_ratio_positive_big_int r bi = - create_ratio (power_big_int_positive_big_int (r.numerator) bi) +let power_ratio_positive_big_int r bi = + create_ratio (power_big_int_positive_big_int (r.numerator) bi) (power_big_int_positive_big_int (r.denominator) bi) diff --git a/otherlibs/num/ratio.mli b/otherlibs/num/ratio.mli index 64fc6b9cdc..12621f08a2 100644 --- a/otherlibs/num/ratio.mli +++ b/otherlibs/num/ratio.mli @@ -85,4 +85,3 @@ val ratio_of_string : string -> ratio val float_of_ratio : ratio -> float val power_ratio_positive_int : ratio -> int -> ratio val power_ratio_positive_big_int : ratio -> big_int -> ratio - diff --git a/otherlibs/str/Makefile b/otherlibs/str/Makefile index bbb5107763..b6c16a0769 100644 --- a/otherlibs/str/Makefile +++ b/otherlibs/str/Makefile @@ -25,8 +25,8 @@ include ../Makefile depend: -str.cmo: str.cmi -str.cmx: str.cmi +str.cmo: str.cmi +str.cmx: str.cmi depend: gcc -MM $(CFLAGS) *.c > .depend diff --git a/otherlibs/str/Makefile.nt b/otherlibs/str/Makefile.nt index 689f0e62cd..5aeff80b25 100644 --- a/otherlibs/str/Makefile.nt +++ b/otherlibs/str/Makefile.nt @@ -24,5 +24,5 @@ include ../Makefile.nt depend: -str.cmo: str.cmi -str.cmx: str.cmi +str.cmo: str.cmi +str.cmx: str.cmi diff --git a/otherlibs/str/str.ml b/otherlibs/str/str.ml index bbbef0a270..741eaa56c6 100644 --- a/otherlibs/str/str.ml +++ b/otherlibs/str/str.ml @@ -367,14 +367,14 @@ let compile fold_case re = emit_code r; let lbl = !progpos in patch_instr pos_pushback op_PUSHBACK lbl - | Group(n, r) -> + | Group(n, r) -> if n >= 32 then failwith "too many \\(...\\) groups"; emit_instr op_BEGGROUP n; emit_code r; emit_instr op_ENDGROUP n; numgroups := max !numgroups (n+1) | Refgroup n -> - emit_instr op_REFGROUP n + emit_instr op_REFGROUP n | Bol -> emit_instr op_BOL 0 | Eol -> @@ -565,9 +565,9 @@ let quote s = done; String.sub buf 0 !pos -let regexp_string s = compile false (String s) +let regexp_string s = compile false (String s) -let regexp_string_case_fold s = compile true (String s) +let regexp_string_case_fold s = compile true (String s) (** Matching functions **) @@ -642,7 +642,7 @@ let replace_matched repl matched = let substitute_first expr repl_fun text = try let pos = search_forward expr text 0 in - String.concat "" [string_before text pos; + String.concat "" [string_before text pos; repl_fun text; string_after text (match_end())] with Not_found -> @@ -656,9 +656,9 @@ let global_substitute expr repl_fun text = let startpos = if last_was_empty then start + 1 else start in if startpos > String.length text then string_after text start :: accu - else + else match opt_search_forward expr text startpos with - | None -> + | None -> string_after text start :: accu | Some pos -> let end_pos = match_end() in @@ -671,7 +671,7 @@ let global_substitute expr repl_fun text = let global_replace expr repl text = global_substitute expr (replace_matched repl) text and replace_first expr repl text = - substitute_first expr (replace_matched repl) text + substitute_first expr (replace_matched repl) text (** Splitting *) @@ -679,7 +679,7 @@ let opt_search_forward_progress expr text start = match opt_search_forward expr text start with | None -> None | Some pos -> - if match_end() > start then + if match_end() > start then Some pos else if start < String.length text then opt_search_forward expr text (start + 1) diff --git a/otherlibs/str/str.mli b/otherlibs/str/str.mli index 097742a1e7..b63faf845a 100644 --- a/otherlibs/str/str.mli +++ b/otherlibs/str/str.mli @@ -55,7 +55,7 @@ val regexp_case_fold : string -> regexp (** Same as [regexp], but the compiled expression will match text in a case-insensitive way: uppercase and lowercase letters will be considered equivalent. *) - + val quote : string -> string (** [Str.quote s] returns a regexp string that matches exactly [s] and nothing else. *) @@ -65,10 +65,10 @@ val regexp_string : string -> regexp that matches exactly [s] and nothing else.*) val regexp_string_case_fold : string -> regexp -(** [Str.regexp_string_case_fold] is similar to {!Str.regexp_string}, +(** [Str.regexp_string_case_fold] is similar to {!Str.regexp_string}, but the regexp matches in a case-insensitive way. *) - + (** {6 String matching and searching} *) @@ -99,25 +99,25 @@ val string_partial_match : regexp -> string -> int -> bool val matched_string : string -> string (** [matched_string s] returns the substring of [s] that was matched - by the latest {!Str.string_match}, {!Str.search_forward} or + by the latest {!Str.string_match}, {!Str.search_forward} or {!Str.search_backward}. The user must make sure that the parameter [s] is the same string that was passed to the matching or searching function. *) - + val match_beginning : unit -> int (** [match_beginning()] returns the position of the first character of the substring that was matched by {!Str.string_match}, {!Str.search_forward} or {!Str.search_backward}. *) val match_end : unit -> int -(** [match_end()] returns the position of the character following the +(** [match_end()] returns the position of the character following the last character of the substring that was matched by [string_match], [search_forward] or [search_backward]. *) - + val matched_group : int -> string -> string (** [matched_group n s] returns the substring of [s] that was matched by the [n]th group [\(...\)] of the regular expression during - the latest {!Str.string_match}, {!Str.search_forward} or + the latest {!Str.string_match}, {!Str.search_forward} or {!Str.search_backward}. The user must make sure that the parameter [s] is the same string that was passed to the matching or searching function. @@ -131,7 +131,7 @@ val matched_group : int -> string -> string val group_beginning : int -> int (** [group_beginning n] returns the position of the first character of the substring that was matched by the [n]th group of - the regular expression. + the regular expression. @raise Not_found if the [n]th group of the regular expression was not matched. @raise Invalid_argument if there are fewer than [n] groups in @@ -140,7 +140,7 @@ val group_beginning : int -> int val group_end : int -> int (** [group_end n] returns the position of the character following the last character of - substring that was matched by the [n]th group of the regular expression. + substring that was matched by the [n]th group of the regular expression. @raise Not_found if the [n]th group of the regular expression was not matched. @raise Invalid_argument if there are fewer than [n] groups in @@ -168,7 +168,7 @@ val global_substitute : regexp -> (string -> string) -> string -> string have been replaced by the result of function [subst]. The function [subst] is called once for each matching substring, and receives [s] (the whole text) as argument. *) - + val substitute_first : regexp -> (string -> string) -> string -> string (** Same as {!Str.global_substitute}, except that only the first substring matching the regular expression is replaced. *) @@ -178,8 +178,8 @@ val replace_matched : string -> string -> string in which [\1], [\2], etc. have been replaced by the text matched by the corresponding groups in the most recent matching operation. [s] must be the same string that was matched during - this matching operation. *) - + this matching operation. *) + (** {6 Splitting} *) @@ -190,7 +190,7 @@ val split : regexp -> string -> string list For instance, [split (regexp "[ \t]+") s] splits [s] into blank-separated words. An occurrence of the delimiter at the beginning and at the end of the string is ignored. *) - + val bounded_split : regexp -> string -> int -> string list (** Same as {!Str.split}, but splits into at most [n] substrings, where [n] is the extra integer parameter. *) @@ -208,7 +208,7 @@ val bounded_split_delim : regexp -> string -> int -> string list delimiter at the beginning and at the end of the string are recognized and returned as empty strings in the result. *) -type split_result = +type split_result = Text of string | Delim of string @@ -234,7 +234,7 @@ val string_before : string -> int -> string (** [string_before s n] returns the substring of all characters of [s] that precede position [n] (excluding the character at position [n]). *) - + val string_after : string -> int -> string (** [string_after s n] returns the substring of all characters of [s] that follow position [n] (including the character at @@ -243,7 +243,6 @@ val string_after : string -> int -> string val first_chars : string -> int -> string (** [first_chars s n] returns the first [n] characters of [s]. This is the same function as {!Str.string_before}. *) - + val last_chars : string -> int -> string (** [last_chars s n] returns the last [n] characters of [s]. *) - diff --git a/otherlibs/str/strstubs.c b/otherlibs/str/strstubs.c index 13b5d2cc1e..ac530ef09d 100644 --- a/otherlibs/str/strstubs.c +++ b/otherlibs/str/strstubs.c @@ -65,7 +65,7 @@ enum { SIMPLESTAR, /* match a character class 0, 1 or several times */ SIMPLEPLUS, /* match a character class 1 or several times */ GOTO, /* unconditional branch */ - PUSHBACK, /* record a backtrack point -- + PUSHBACK, /* record a backtrack point -- where to jump in case of failure */ SETMARK, /* remember current position in given register # */ CHECKPROGRESS /* backtrack if no progress was made w.r.t. reg # */ @@ -116,7 +116,7 @@ static unsigned char re_word_letters[32] = { #define Is_word_letter(c) ((re_word_letters[(c) >> 3] >> ((c) & 7)) & 1) /* The bytecode interpreter for the NFA */ -static int re_match(value re, +static int re_match(value re, unsigned char * starttxt, register unsigned char * txt, register unsigned char * endtxt, @@ -196,7 +196,7 @@ static int re_match(value re, /* At beginning and end of text: no At beginning of text: OK if current char is a letter At end of text: OK if previous char is a letter - Otherwise: + Otherwise: OK if previous char is a letter and current char not a letter or previous char is not a letter and current char is a letter */ if (txt == starttxt) { @@ -290,7 +290,7 @@ static int re_match(value re, push: /* Push an item on the backtrack stack and continue with next instr */ if (sp == stack->point + BACKTRACK_STACK_BLOCK_SIZE) { - struct backtrack_stack * newstack = + struct backtrack_stack * newstack = stat_alloc(sizeof(struct backtrack_stack)); newstack->previous = stack; stack = newstack; @@ -521,4 +521,3 @@ CAMLprim value re_replacement_text(value repl, value groups, value orig) } CAMLreturn(res); } - diff --git a/otherlibs/systhreads/Makefile b/otherlibs/systhreads/Makefile index 7b19164b34..b74f9bc750 100644 --- a/otherlibs/systhreads/Makefile +++ b/otherlibs/systhreads/Makefile @@ -50,15 +50,15 @@ posix_n.o: posix.c threads.cma: $(THREAD_OBJS) $(MKLIB) -ocamlc '$(CAMLC)' -o threads $(THREAD_OBJS) \ - -cclib -lunix $(PTHREAD_LINK) + -cclib -lunix $(PTHREAD_LINK) # See remark above: force static linking of libthreadsnat.a threads.cmxa: $(THREAD_OBJS:.cmo=.cmx) $(CAMLOPT) -a -o threads.cmxa $(THREAD_OBJS:.cmo=.cmx) \ - -cclib -lthreadsnat $(PTHREAD_LINK) + -cclib -lthreadsnat $(PTHREAD_LINK) -# Note: I removed "-cclib -lunix" from the line above. -# Indeed, if we link threads.cmxa, then we must also link unix.cmxa, +# Note: I removed "-cclib -lunix" from the line above. +# Indeed, if we link threads.cmxa, then we must also link unix.cmxa, # which itself will pass -lunix to the C linker. It seems more # modular to me this way. -- Alain diff --git a/otherlibs/systhreads/Tests/Makefile b/otherlibs/systhreads/Tests/Makefile index 5911fafdba..ac8b5f7767 100644 --- a/otherlibs/systhreads/Tests/Makefile +++ b/otherlibs/systhreads/Tests/Makefile @@ -22,9 +22,9 @@ MOREPROGS=testfork.byt include ../../../config/Makefile -CAMLC=../../../boot/ocamlrun ../../../ocamlc -I .. -I ../../unix -I ../../../stdlib +CAMLC=../../../boot/ocamlrun ../../../ocamlc -I .. -I ../../unix -I ../../../stdlib -CAMLOPT=../../../boot/ocamlrun ../../../ocamlopt -I .. -I ../../unix -I ../../../stdlib +CAMLOPT=../../../boot/ocamlrun ../../../ocamlopt -I .. -I ../../unix -I ../../../stdlib all: $(PROGS) $(MOREPROGS) diff --git a/otherlibs/systhreads/Tests/Makefile.nt b/otherlibs/systhreads/Tests/Makefile.nt index d3d340ae1e..10fb9040c0 100644 --- a/otherlibs/systhreads/Tests/Makefile.nt +++ b/otherlibs/systhreads/Tests/Makefile.nt @@ -20,9 +20,9 @@ PROGS=test1.byt test2.byt test3.byt test4.byt test5.byt test6.byt \ include ../../../config/Makefile -CAMLC=../../../boot/ocamlrun ../../../ocamlc -I .. -I ../../win32unix -I ../../../stdlib +CAMLC=../../../boot/ocamlrun ../../../ocamlc -I .. -I ../../win32unix -I ../../../stdlib -CAMLOPT=../../../boot/ocamlrun ../../../ocamlopt -I .. -I ../../win32unix -I ../../../stdlib +CAMLOPT=../../../boot/ocamlrun ../../../ocamlopt -I .. -I ../../win32unix -I ../../../stdlib all: $(PROGS) diff --git a/otherlibs/systhreads/Tests/testfork.ml b/otherlibs/systhreads/Tests/testfork.ml index 8256a31eac..494b1505ce 100644 --- a/otherlibs/systhreads/Tests/testfork.ml +++ b/otherlibs/systhreads/Tests/testfork.ml @@ -1,7 +1,7 @@ (* POSIX threads and fork() *) let compute_thread c = - while true do + while true do print_char c; flush stdout; for i = 1 to 100000 do ignore(ref []) done done @@ -26,5 +26,3 @@ let main () = exit 0 let _ = main() - - diff --git a/otherlibs/systhreads/condition.mli b/otherlibs/systhreads/condition.mli index 02c108b7b1..5bc9d6740a 100644 --- a/otherlibs/systhreads/condition.mli +++ b/otherlibs/systhreads/condition.mli @@ -45,9 +45,9 @@ val wait : t -> Mutex.t -> unit The mutex [m] is locked again before [wait] returns. *) val signal : t -> unit -(** [signal c] restarts one of the processes waiting on the +(** [signal c] restarts one of the processes waiting on the condition variable [c]. *) val broadcast : t -> unit -(** [broadcast c] restarts all processes waiting on the +(** [broadcast c] restarts all processes waiting on the condition variable [c]. *) diff --git a/otherlibs/systhreads/event.ml b/otherlibs/systhreads/event.ml index bd47d6526a..74f457b06d 100644 --- a/otherlibs/systhreads/event.ml +++ b/otherlibs/systhreads/event.ml @@ -92,7 +92,7 @@ let basic_sync abort_env genev = (* Extract the result *) if abort_env = [] then (* Preserve tail recursion *) - bev.(!performed).result() + bev.(!performed).result() else begin let num = !performed in let result = bev.(num).result() in diff --git a/otherlibs/systhreads/event.mli b/otherlibs/systhreads/event.mli index 8a5991f776..08d6b0bf6b 100644 --- a/otherlibs/systhreads/event.mli +++ b/otherlibs/systhreads/event.mli @@ -16,9 +16,9 @@ (** First-class synchronous communication. This module implements synchronous inter-thread communications over - channels. As in John Reppy's Concurrent ML system, the communication + channels. As in John Reppy's Concurrent ML system, the communication events are first-class values: they can be built and combined - independently before being offered for communication. + independently before being offered for communication. *) type 'a channel @@ -31,12 +31,12 @@ type +'a event (** The type of communication events returning a result of type ['a]. *) (** [send ch v] returns the event consisting in sending the value [v] - over the channel [ch]. The result value of this event is [()]. *) + over the channel [ch]. The result value of this event is [()]. *) val send : 'a channel -> 'a -> unit event (** [receive ch] returns the event consisting in receiving a value from the channel [ch]. The result value of this event is the - value received. *) + value received. *) val receive : 'a channel -> 'a event val always : 'a -> 'a event @@ -64,7 +64,7 @@ val guard : (unit -> 'a event) -> 'a event operation. *) val sync : 'a event -> 'a -(** ``Synchronize'' on an event: offer all the communication +(** ``Synchronize'' on an event: offer all the communication possibilities specified in the event to the outside world, and block until one of the communications succeed. The result value of that communication is returned. *) @@ -74,9 +74,8 @@ val select : 'a event list -> 'a [select evl] is shorthand for [sync(choose evl)]. *) val poll : 'a event -> 'a option -(** Non-blocking version of {!Event.sync}: offer all the communication +(** Non-blocking version of {!Event.sync}: offer all the communication possibilities specified in the event to the outside world, and if one can take place immediately, perform it and return [Some r] where [r] is the result value of that communication. Otherwise, return [None] without blocking. *) - diff --git a/otherlibs/systhreads/mutex.mli b/otherlibs/systhreads/mutex.mli index 0c41c843e8..b1fe141358 100644 --- a/otherlibs/systhreads/mutex.mli +++ b/otherlibs/systhreads/mutex.mli @@ -47,4 +47,3 @@ val try_lock : t -> bool val unlock : t -> unit (** Unlock the given mutex. Other threads suspended trying to lock the mutex will restart. *) - diff --git a/otherlibs/systhreads/posix.c b/otherlibs/systhreads/posix.c index da45be06cf..f20f49adf2 100644 --- a/otherlibs/systhreads/posix.c +++ b/otherlibs/systhreads/posix.c @@ -475,7 +475,7 @@ static void * caml_thread_start(void * arg) #endif /* The thread now stops running */ return NULL; -} +} value caml_thread_new(value clos) /* ML */ { @@ -535,7 +535,7 @@ value caml_thread_new(value clos) /* ML */ caml_pthread_check(err, "Thread.create"); } End_roots(); - /* Create the tick thread if not already done. + /* Create the tick thread if not already done. Because of PR#4666, we start the tick thread late, only when we create the first additional thread in the current process*/ if (! caml_tick_thread_running) { @@ -905,7 +905,7 @@ value caml_wait_signal(value sigs) /* ML */ return Val_int(signo); #else invalid_argument("Thread.wait_signal not implemented"); - return Val_int(0); /* not reached */ + return Val_int(0); /* not reached */ #endif } @@ -927,4 +927,3 @@ static void caml_pthread_check(int retcode, char *msg) memmove (&Byte(str, msglen + 2), err, errlen); raise_sys_error(str); } - diff --git a/otherlibs/systhreads/thread.mli b/otherlibs/systhreads/thread.mli index 8394a47bc6..3c2fc01b53 100644 --- a/otherlibs/systhreads/thread.mli +++ b/otherlibs/systhreads/thread.mli @@ -74,7 +74,7 @@ val wait_timed_write : Unix.file_descr -> float -> bool on the given Unix file descriptor. Wait for at most the amount of time given as second argument (in seconds). Return [true] if the file descriptor is ready for input/output - and [false] if the timeout expired. + and [false] if the timeout expired. These functions return immediately [true] in the Win32 implementation. *) @@ -131,4 +131,3 @@ val wait_signal : int list -> int Signal handlers attached to the signals in [sigs] will not be invoked. The signals [sigs] are expected to be blocked before calling [wait_signal]. *) - diff --git a/otherlibs/systhreads/thread_posix.ml b/otherlibs/systhreads/thread_posix.ml index 69672aa9fb..9f077b3338 100644 --- a/otherlibs/systhreads/thread_posix.ml +++ b/otherlibs/systhreads/thread_posix.ml @@ -19,7 +19,7 @@ type t external thread_initialize : unit -> unit = "caml_thread_initialize" external thread_new : (unit -> unit) -> t = "caml_thread_new" -external thread_uncaught_exception : exn -> unit = +external thread_uncaught_exception : exn -> unit = "caml_thread_uncaught_exception" external yield : unit -> unit = "caml_thread_yield" diff --git a/otherlibs/systhreads/thread_win32.ml b/otherlibs/systhreads/thread_win32.ml index cdbe4c0192..324223198a 100644 --- a/otherlibs/systhreads/thread_win32.ml +++ b/otherlibs/systhreads/thread_win32.ml @@ -24,7 +24,7 @@ external yield : unit -> unit = "caml_thread_yield" external self : unit -> t = "caml_thread_self" external id : t -> int = "caml_thread_id" external join : t -> unit = "caml_thread_join" -external thread_uncaught_exception : exn -> unit = +external thread_uncaught_exception : exn -> unit = "caml_thread_uncaught_exception" (* For new, make sure the function passed to thread_new never @@ -74,4 +74,3 @@ let wait_pid p = Unix.waitpid [] p let sigmask cmd set = invalid_arg "Thread.sigmask: not implemented" let wait_signal set = invalid_arg "Thread.wait_signal: not implemented" - diff --git a/otherlibs/threads/Tests/test5.ml b/otherlibs/threads/Tests/test5.ml index 2baffe024b..3534d03b7b 100644 --- a/otherlibs/threads/Tests/test5.ml +++ b/otherlibs/threads/Tests/test5.ml @@ -17,5 +17,3 @@ let _ = Thread.create receiver "A"; receiver "B"; exit 0 - - diff --git a/otherlibs/threads/Tests/test6.ml b/otherlibs/threads/Tests/test6.ml index b846858e56..9573a66108 100644 --- a/otherlibs/threads/Tests/test6.ml +++ b/otherlibs/threads/Tests/test6.ml @@ -13,5 +13,3 @@ let _ = Thread.create (f "A") "hello"; f "B" "world"; exit 0 - - diff --git a/otherlibs/threads/Tests/test7.ml b/otherlibs/threads/Tests/test7.ml index e6bd1d810d..0ac3474287 100644 --- a/otherlibs/threads/Tests/test7.ml +++ b/otherlibs/threads/Tests/test7.ml @@ -24,5 +24,3 @@ let main () = while true do read() done let _ = Printexc.catch main () - - diff --git a/otherlibs/threads/Tests/test8.ml b/otherlibs/threads/Tests/test8.ml index cc587b0a7c..897fd09eee 100644 --- a/otherlibs/threads/Tests/test8.ml +++ b/otherlibs/threads/Tests/test8.ml @@ -42,5 +42,3 @@ let g () = let _ = Thread.create f (); g() - - diff --git a/otherlibs/threads/Tests/testA.ml b/otherlibs/threads/Tests/testA.ml index b1999b87bc..26e73ebf71 100644 --- a/otherlibs/threads/Tests/testA.ml +++ b/otherlibs/threads/Tests/testA.ml @@ -21,4 +21,3 @@ let _ = let t4 = Thread.create (process 4) "quatre" in let t5 = Thread.create (process 5) "cinq" in List.iter Thread.join [t1;t2;t3;t4;t5] - diff --git a/otherlibs/threads/Tests/testexit.ml b/otherlibs/threads/Tests/testexit.ml index 2045c25a86..4564a483c9 100644 --- a/otherlibs/threads/Tests/testexit.ml +++ b/otherlibs/threads/Tests/testexit.ml @@ -19,4 +19,3 @@ let _ = let _ = Thread.create somethread ("B", 8, false) in let _ = Thread.create somethread ("C", 11, true) in somethread ("Main", 3, false) - diff --git a/otherlibs/threads/Tests/testio.ml b/otherlibs/threads/Tests/testio.ml index 5f0ec503a0..46d61b3242 100644 --- a/otherlibs/threads/Tests/testio.ml +++ b/otherlibs/threads/Tests/testio.ml @@ -81,7 +81,7 @@ let test_trunc_line ofile = else print_string "FAILED"; print_newline() with End_of_file -> - print_string "FAILED"; print_newline() + print_string "FAILED"; print_newline() (* The test *) diff --git a/otherlibs/threads/Tests/testsocket.ml b/otherlibs/threads/Tests/testsocket.ml index d0f14cbf5b..b2f9ed2968 100644 --- a/otherlibs/threads/Tests/testsocket.ml +++ b/otherlibs/threads/Tests/testsocket.ml @@ -27,5 +27,3 @@ let main() = done let _ = Printexc.catch main (); exit 0 - - diff --git a/otherlibs/threads/Tests/token1.ml b/otherlibs/threads/Tests/token1.ml index fb0ddb2dfd..3acfc1f491 100644 --- a/otherlibs/threads/Tests/token1.ml +++ b/otherlibs/threads/Tests/token1.ml @@ -9,7 +9,7 @@ let token = ref 0 let process (n, conds, nprocs) = while true do Mutex.lock mut; - while !token <> n do + while !token <> n do (* Printf.printf "Thread %d waiting (token = %d)\n" n !token; *) Condition.wait conds.(n) mut done; diff --git a/otherlibs/threads/Tests/torture.ml b/otherlibs/threads/Tests/torture.ml index b52766dc72..cfc5783334 100644 --- a/otherlibs/threads/Tests/torture.ml +++ b/otherlibs/threads/Tests/torture.ml @@ -43,4 +43,3 @@ let main() = stdin_thread() let _ = main() - diff --git a/otherlibs/threads/condition.ml b/otherlibs/threads/condition.ml index 521711418d..e012a86e35 100644 --- a/otherlibs/threads/condition.ml +++ b/otherlibs/threads/condition.ml @@ -33,4 +33,3 @@ let broadcast cond = let w = cond.waiting in (* atomic *) cond.waiting <- []; (* atomic *) List.iter Thread.wakeup w - diff --git a/otherlibs/threads/condition.mli b/otherlibs/threads/condition.mli index 02c108b7b1..5bc9d6740a 100644 --- a/otherlibs/threads/condition.mli +++ b/otherlibs/threads/condition.mli @@ -45,9 +45,9 @@ val wait : t -> Mutex.t -> unit The mutex [m] is locked again before [wait] returns. *) val signal : t -> unit -(** [signal c] restarts one of the processes waiting on the +(** [signal c] restarts one of the processes waiting on the condition variable [c]. *) val broadcast : t -> unit -(** [broadcast c] restarts all processes waiting on the +(** [broadcast c] restarts all processes waiting on the condition variable [c]. *) diff --git a/otherlibs/threads/event.ml b/otherlibs/threads/event.ml index bd47d6526a..74f457b06d 100644 --- a/otherlibs/threads/event.ml +++ b/otherlibs/threads/event.ml @@ -92,7 +92,7 @@ let basic_sync abort_env genev = (* Extract the result *) if abort_env = [] then (* Preserve tail recursion *) - bev.(!performed).result() + bev.(!performed).result() else begin let num = !performed in let result = bev.(num).result() in diff --git a/otherlibs/threads/event.mli b/otherlibs/threads/event.mli index 8a5991f776..08d6b0bf6b 100644 --- a/otherlibs/threads/event.mli +++ b/otherlibs/threads/event.mli @@ -16,9 +16,9 @@ (** First-class synchronous communication. This module implements synchronous inter-thread communications over - channels. As in John Reppy's Concurrent ML system, the communication + channels. As in John Reppy's Concurrent ML system, the communication events are first-class values: they can be built and combined - independently before being offered for communication. + independently before being offered for communication. *) type 'a channel @@ -31,12 +31,12 @@ type +'a event (** The type of communication events returning a result of type ['a]. *) (** [send ch v] returns the event consisting in sending the value [v] - over the channel [ch]. The result value of this event is [()]. *) + over the channel [ch]. The result value of this event is [()]. *) val send : 'a channel -> 'a -> unit event (** [receive ch] returns the event consisting in receiving a value from the channel [ch]. The result value of this event is the - value received. *) + value received. *) val receive : 'a channel -> 'a event val always : 'a -> 'a event @@ -64,7 +64,7 @@ val guard : (unit -> 'a event) -> 'a event operation. *) val sync : 'a event -> 'a -(** ``Synchronize'' on an event: offer all the communication +(** ``Synchronize'' on an event: offer all the communication possibilities specified in the event to the outside world, and block until one of the communications succeed. The result value of that communication is returned. *) @@ -74,9 +74,8 @@ val select : 'a event list -> 'a [select evl] is shorthand for [sync(choose evl)]. *) val poll : 'a event -> 'a option -(** Non-blocking version of {!Event.sync}: offer all the communication +(** Non-blocking version of {!Event.sync}: offer all the communication possibilities specified in the event to the outside world, and if one can take place immediately, perform it and return [Some r] where [r] is the result value of that communication. Otherwise, return [None] without blocking. *) - diff --git a/otherlibs/threads/marshal.ml b/otherlibs/threads/marshal.ml index 6f6afae506..d31a667df8 100644 --- a/otherlibs/threads/marshal.ml +++ b/otherlibs/threads/marshal.ml @@ -53,6 +53,6 @@ let from_string buff ofs = if ofs > String.length buff - (header_size + len) then invalid_arg "Marshal.from_string" else from_string_unsafe buff ofs - end + end let from_channel = Pervasives.input_value diff --git a/otherlibs/threads/mutex.ml b/otherlibs/threads/mutex.ml index 2858a2414d..f0f6845b21 100644 --- a/otherlibs/threads/mutex.ml +++ b/otherlibs/threads/mutex.ml @@ -36,4 +36,3 @@ let unlock m = m.waiting <- []; (* atomic *) m.locked <- false; (* atomic *) List.iter Thread.wakeup w - diff --git a/otherlibs/threads/mutex.mli b/otherlibs/threads/mutex.mli index 0c41c843e8..b1fe141358 100644 --- a/otherlibs/threads/mutex.mli +++ b/otherlibs/threads/mutex.mli @@ -47,4 +47,3 @@ val try_lock : t -> bool val unlock : t -> unit (** Unlock the given mutex. Other threads suspended trying to lock the mutex will restart. *) - diff --git a/otherlibs/threads/pervasives.ml b/otherlibs/threads/pervasives.ml index 09c5381414..7cfd02505c 100644 --- a/otherlibs/threads/pervasives.ml +++ b/otherlibs/threads/pervasives.ml @@ -270,10 +270,10 @@ let rec flush oc = wait_outchan oc (-1); false in if success then () else flush oc -external out_channels_list : unit -> out_channel list +external out_channels_list : unit -> out_channel list = "caml_ml_out_channels_list" -let flush_all () = +let flush_all () = let rec iter = function [] -> () | a::l -> @@ -298,7 +298,7 @@ let rec unsafe_output oc buf pos len = unsafe_output oc buf (pos + written) (len - written) end -external output_char_blocking : out_channel -> char -> unit +external output_char_blocking : out_channel -> char -> unit = "caml_ml_output_char" external output_byte_blocking : out_channel -> int -> unit = "caml_ml_output_char" @@ -313,7 +313,7 @@ let output_string oc s = unsafe_output oc s 0 (string_length s) let output oc s ofs len = - if ofs < 0 || len < 0 || ofs > string_length s - len + if ofs < 0 || len < 0 || ofs > string_length s - len then invalid_arg "output" else unsafe_output oc s ofs len @@ -331,7 +331,7 @@ let output_binary_int oc n = output_byte oc (n asr 8); output_byte oc n -external marshal_to_string : 'a -> unit list -> string +external marshal_to_string : 'a -> unit list -> string = "caml_output_value_to_string" let output_value oc v = output_string oc (marshal_to_string v []) @@ -494,7 +494,7 @@ module LargeFile = end (* Formats *) -type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 +type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 diff --git a/otherlibs/threads/thread.ml b/otherlibs/threads/thread.ml index 31fc7f0781..723669a39d 100644 --- a/otherlibs/threads/thread.ml +++ b/otherlibs/threads/thread.ml @@ -28,7 +28,7 @@ type resumption_status = Unix.file_descr list * Unix.file_descr list * Unix.file_descr list | Resumed_wait of int * Unix.process_status -(* It is mucho important that the primitives that reschedule are called +(* It is mucho important that the primitives that reschedule are called through an ML function call, not directly. That's because when such a primitive returns, the bytecode interpreter is only semi-obedient: it takes sp from the new thread, but keeps pc from the old thread. @@ -100,7 +100,7 @@ let wait_timed_write fd delay = let wait_pid_aux pid = thread_wait_pid pid -let wait_pid pid = +let wait_pid pid = match wait_pid_aux pid with Resumed_wait(pid, status) -> (pid, status) | _ -> invalid_arg "Thread.wait_pid" diff --git a/otherlibs/threads/thread.mli b/otherlibs/threads/thread.mli index 8da968a805..9577a54eb0 100644 --- a/otherlibs/threads/thread.mli +++ b/otherlibs/threads/thread.mli @@ -101,7 +101,7 @@ val wait_signal : int list -> int until the process receives one of the signals specified in the list [sigs]. It then returns the number of the signal received. Signal handlers attached to the signals in [sigs] will not - be invoked. Do not call [wait_signal] concurrently + be invoked. Do not call [wait_signal] concurrently from several threads on the same signals. *) val yield : unit -> unit @@ -114,7 +114,7 @@ val yield : unit -> unit (** {6 Synchronization primitives} - The following primitives provide the basis for implementing + The following primitives provide the basis for implementing synchronization functions between threads. Their direct use is discouraged, as they are very low-level and prone to race conditions and deadlocks. The modules {!Mutex}, {!Condition} and {!Event} @@ -138,4 +138,3 @@ val sleep : unit -> unit val wakeup : t -> unit (** Reactivate the given thread. After the call to [wakeup], the suspended thread will resume execution at some future time. *) - diff --git a/otherlibs/threads/unix.ml b/otherlibs/threads/unix.ml index 62c18b7e46..5a8bb697da 100644 --- a/otherlibs/threads/unix.ml +++ b/otherlibs/threads/unix.ml @@ -203,7 +203,7 @@ external close : file_descr -> unit = "unix_close" external unsafe_read : file_descr -> string -> int -> int -> int = "unix_read" external unsafe_write : file_descr -> string -> int -> int -> int = "unix_write" -external unsafe_single_write : file_descr -> string -> int -> int -> int +external unsafe_single_write : file_descr -> string -> int -> int -> int = "unix_single_write" let rec read fd buf ofs len = @@ -411,13 +411,13 @@ external fork : unit -> int = "unix_fork" external _waitpid : wait_flag list -> int -> int * process_status = "unix_waitpid" -let wait_pid pid = +let wait_pid pid = match wait_pid_aux pid with Resumed_wait(pid, status) -> (pid, status) | _ -> invalid_arg "Thread.wait_pid" let wait () = wait_pid (-1) - + let waitpid flags pid = if List.mem WNOHANG flags then _waitpid flags pid @@ -571,7 +571,7 @@ let rec accept req = external bind : file_descr -> sockaddr -> unit = "unix_bind" external listen : file_descr -> int -> unit = "unix_listen" -external shutdown : file_descr -> shutdown_command -> unit = "unix_shutdown" +external shutdown : file_descr -> shutdown_command -> unit = "unix_shutdown" external getsockname : file_descr -> sockaddr = "unix_getsockname" external getpeername : file_descr -> sockaddr = "unix_getpeername" @@ -623,7 +623,7 @@ let rec send fd buf ofs len flags = with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> wait_write fd; send fd buf ofs len flags - + let rec sendto fd buf ofs len flags addr = try if ofs < 0 || len < 0 || ofs > String.length buf - len @@ -677,7 +677,7 @@ end = struct let optint = 2 let float = 3 let error = 4 - external get: ('opt, 'v) t -> file_descr -> 'opt -> 'v + external get: ('opt, 'v) t -> file_descr -> 'opt -> 'v = "unix_getsockopt" external set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit = "unix_setsockopt" @@ -763,7 +763,7 @@ let getaddrinfo_emulation node service opts = with Failure _ -> try [ty, (getservbyname service kind).s_port] - with Not_found -> [] + with Not_found -> [] in let ports = match !opt_socktype with @@ -794,7 +794,7 @@ let getaddrinfo_emulation node service opts = [] in (* Cross-product of addresses and ports *) List.flatten - (List.map + (List.map (fun (ty, port) -> List.map (fun (addr, name) -> @@ -1048,7 +1048,7 @@ let find_proc_id fun_name proc = raise(Unix_error(EBADF, fun_name, "")) let rec waitpid_non_intr pid = - try waitpid [] pid + try waitpid [] pid with Unix_error (EINTR, _, _) -> waitpid_non_intr pid let close_process_in inchan = diff --git a/otherlibs/unix/accept.c b/otherlibs/unix/accept.c index d2cb598e55..a6e80f064f 100644 --- a/otherlibs/unix/accept.c +++ b/otherlibs/unix/accept.c @@ -50,5 +50,5 @@ CAMLprim value unix_accept(value sock) CAMLprim value unix_accept(value sock) { invalid_argument("accept not implemented"); } - + #endif diff --git a/otherlibs/unix/addrofstr.c b/otherlibs/unix/addrofstr.c index 5dfcf368d9..6947d66f11 100644 --- a/otherlibs/unix/addrofstr.c +++ b/otherlibs/unix/addrofstr.c @@ -49,5 +49,5 @@ CAMLprim value unix_inet_addr_of_string(value s) CAMLprim value unix_inet_addr_of_string(value s) { invalid_argument("inet_addr_of_string not implemented"); } - + #endif diff --git a/otherlibs/unix/bind.c b/otherlibs/unix/bind.c index bec2a9123c..85cf1d28aa 100644 --- a/otherlibs/unix/bind.c +++ b/otherlibs/unix/bind.c @@ -20,7 +20,7 @@ #ifdef HAS_SOCKETS #include "socketaddr.h" - + CAMLprim value unix_bind(value socket, value address) { int ret; @@ -37,5 +37,5 @@ CAMLprim value unix_bind(value socket, value address) CAMLprim value unix_bind(value socket, value address) { invalid_argument("bind not implemented"); } - + #endif diff --git a/otherlibs/unix/connect.c b/otherlibs/unix/connect.c index 3c70d227f3..669c347f3f 100644 --- a/otherlibs/unix/connect.c +++ b/otherlibs/unix/connect.c @@ -40,5 +40,5 @@ CAMLprim value unix_connect(value socket, value address) CAMLprim value unix_connect(value socket, value address) { invalid_argument("connect not implemented"); } - + #endif diff --git a/otherlibs/unix/cstringv.c b/otherlibs/unix/cstringv.c index d7bd396412..0e37914d82 100644 --- a/otherlibs/unix/cstringv.c +++ b/otherlibs/unix/cstringv.c @@ -28,5 +28,3 @@ char ** cstringvect(value arg) res[size] = NULL; return res; } - - diff --git a/otherlibs/unix/execv.c b/otherlibs/unix/execv.c index b7cd800986..bc0330b356 100644 --- a/otherlibs/unix/execv.c +++ b/otherlibs/unix/execv.c @@ -29,4 +29,3 @@ CAMLprim value unix_execv(value path, value args) return Val_unit; /* never reached, but suppress warnings */ /* from smart compilers */ } - diff --git a/otherlibs/unix/execve.c b/otherlibs/unix/execve.c index 0f63aaef96..4d29fb55b7 100644 --- a/otherlibs/unix/execve.c +++ b/otherlibs/unix/execve.c @@ -32,4 +32,3 @@ CAMLprim value unix_execve(value path, value args, value env) return Val_unit; /* never reached, but suppress warnings */ /* from smart compilers */ } - diff --git a/otherlibs/unix/execvp.c b/otherlibs/unix/execvp.c index 960b3bfe1a..6d03a29ea4 100644 --- a/otherlibs/unix/execvp.c +++ b/otherlibs/unix/execvp.c @@ -48,4 +48,3 @@ CAMLprim value unix_execvpe(value path, value args, value env) return Val_unit; /* never reached, but suppress warnings */ /* from smart compilers */ } - diff --git a/otherlibs/unix/exit.c b/otherlibs/unix/exit.c index 26afea3393..8f1df6d532 100644 --- a/otherlibs/unix/exit.c +++ b/otherlibs/unix/exit.c @@ -22,5 +22,3 @@ CAMLprim value unix_exit(value n) return Val_unit; /* never reached, but suppress warnings */ /* from smart compilers */ } - - diff --git a/otherlibs/unix/fchmod.c b/otherlibs/unix/fchmod.c index 6378bb1980..a90de6ef1f 100644 --- a/otherlibs/unix/fchmod.c +++ b/otherlibs/unix/fchmod.c @@ -31,5 +31,5 @@ CAMLprim value unix_fchmod(value fd, value perm) CAMLprim value unix_fchmod(value fd, value perm) { invalid_argument("fchmod not implemented"); } - + #endif diff --git a/otherlibs/unix/fchown.c b/otherlibs/unix/fchown.c index 5d28596d01..29683a5c79 100644 --- a/otherlibs/unix/fchown.c +++ b/otherlibs/unix/fchown.c @@ -30,5 +30,5 @@ CAMLprim value unix_fchown(value fd, value uid, value gid) CAMLprim value unix_fchown(value fd, value uid, value gid) { invalid_argument("fchown not implemented"); } - + #endif diff --git a/otherlibs/unix/fork.c b/otherlibs/unix/fork.c index c78973474f..428137dcbb 100644 --- a/otherlibs/unix/fork.c +++ b/otherlibs/unix/fork.c @@ -23,4 +23,3 @@ CAMLprim value unix_fork(value unit) if (ret == -1) uerror("fork", Nothing); return Val_int(ret); } - diff --git a/otherlibs/unix/gethost.c b/otherlibs/unix/gethost.c index 18d3be0a98..36fdfd8ef9 100644 --- a/otherlibs/unix/gethost.c +++ b/otherlibs/unix/gethost.c @@ -176,8 +176,8 @@ CAMLprim value unix_gethostbyname(value name) CAMLprim value unix_gethostbyaddr(value name) { invalid_argument("gethostbyaddr not implemented"); } - + CAMLprim value unix_gethostbyname(value name) { invalid_argument("gethostbyname not implemented"); } - + #endif diff --git a/otherlibs/unix/getnameinfo.c b/otherlibs/unix/getnameinfo.c index b5824bcb5d..c887856993 100644 --- a/otherlibs/unix/getnameinfo.c +++ b/otherlibs/unix/getnameinfo.c @@ -46,7 +46,7 @@ CAMLprim value unix_getnameinfo(value vaddr, value vopts) get_sockaddr(vaddr, &addr, &addr_len); opts = convert_flag_list(vopts, getnameinfo_flag_table); enter_blocking_section(); - retcode = + retcode = getnameinfo((const struct sockaddr *) &addr.s_gen, addr_len, host, sizeof(host), serv, sizeof(serv), opts); leave_blocking_section(); diff --git a/otherlibs/unix/getpeername.c b/otherlibs/unix/getpeername.c index 0431e9a33c..20a837ca19 100644 --- a/otherlibs/unix/getpeername.c +++ b/otherlibs/unix/getpeername.c @@ -37,5 +37,5 @@ CAMLprim value unix_getpeername(value sock) CAMLprim value unix_getpeername(value sock) { invalid_argument("getpeername not implemented"); } - + #endif diff --git a/otherlibs/unix/getproto.c b/otherlibs/unix/getproto.c index 3444072d11..c9ca1a5c9e 100644 --- a/otherlibs/unix/getproto.c +++ b/otherlibs/unix/getproto.c @@ -63,7 +63,7 @@ CAMLprim value unix_getprotobynumber(value proto) CAMLprim value unix_getprotobynumber(value proto) { invalid_argument("getprotobynumber not implemented"); } - + CAMLprim value unix_getprotobyname(value name) { invalid_argument("getprotobyname not implemented"); } diff --git a/otherlibs/unix/getserv.c b/otherlibs/unix/getserv.c index e882e84357..e252aacb70 100644 --- a/otherlibs/unix/getserv.c +++ b/otherlibs/unix/getserv.c @@ -69,7 +69,7 @@ CAMLprim value unix_getservbyport(value port, value proto) CAMLprim value unix_getservbyport(value port, value proto) { invalid_argument("getservbyport not implemented"); } - + CAMLprim value unix_getservbyname(value name, value proto) { invalid_argument("getservbyname not implemented"); } diff --git a/otherlibs/unix/getsockname.c b/otherlibs/unix/getsockname.c index 5422236ffa..6f0b64dcd3 100644 --- a/otherlibs/unix/getsockname.c +++ b/otherlibs/unix/getsockname.c @@ -37,5 +37,5 @@ CAMLprim value unix_getsockname(value sock) CAMLprim value unix_getsockname(value sock) { invalid_argument("getsockname not implemented"); } - + #endif diff --git a/otherlibs/unix/itimer.c b/otherlibs/unix/itimer.c index 43fc4e10f2..14bac626ab 100644 --- a/otherlibs/unix/itimer.c +++ b/otherlibs/unix/itimer.c @@ -56,7 +56,7 @@ CAMLprim value unix_setitimer(value which, value newval) uerror("setitimer", Nothing); return unix_convert_itimer(&old); } - + CAMLprim value unix_getitimer(value which) { struct itimerval val; diff --git a/otherlibs/unix/lseek.c b/otherlibs/unix/lseek.c index 5dfa7e37fd..6dece9503e 100644 --- a/otherlibs/unix/lseek.c +++ b/otherlibs/unix/lseek.c @@ -54,4 +54,3 @@ CAMLprim value unix_lseek_64(value fd, value ofs, value cmd) if (ret == -1) uerror("lseek", Nothing); return Val_file_offset(ret); } - diff --git a/otherlibs/unix/open.c b/otherlibs/unix/open.c index c108f7a552..421218308c 100644 --- a/otherlibs/unix/open.c +++ b/otherlibs/unix/open.c @@ -35,7 +35,7 @@ #endif static int open_flag_table[] = { - O_RDONLY, O_WRONLY, O_RDWR, O_NONBLOCK, O_APPEND, O_CREAT, O_TRUNC, O_EXCL, + O_RDONLY, O_WRONLY, O_RDWR, O_NONBLOCK, O_APPEND, O_CREAT, O_TRUNC, O_EXCL, O_NOCTTY, O_DSYNC, O_SYNC, O_RSYNC }; diff --git a/otherlibs/unix/select.c b/otherlibs/unix/select.c index 376fcf783d..612d597014 100644 --- a/otherlibs/unix/select.c +++ b/otherlibs/unix/select.c @@ -62,7 +62,7 @@ static value fdset_to_fdlist(value fdlist, fd_set *fdset) return res; } -CAMLprim value unix_select(value readfds, value writefds, value exceptfds, +CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value timeout) { fd_set read, write, except; diff --git a/otherlibs/unix/sockopt.c b/otherlibs/unix/sockopt.c index 3e2645040a..31c95c1f55 100644 --- a/otherlibs/unix/sockopt.c +++ b/otherlibs/unix/sockopt.c @@ -126,10 +126,10 @@ static struct socket_option sockopt_int[] = { { SOL_SOCKET, SO_SNDLOWAT } }; static struct socket_option sockopt_linger[] = { - { SOL_SOCKET, SO_LINGER } + { SOL_SOCKET, SO_LINGER } }; -static struct socket_option sockopt_timeval[] = { +static struct socket_option sockopt_timeval[] = { { SOL_SOCKET, SO_RCVTIMEO }, { SOL_SOCKET, SO_SNDTIMEO } }; @@ -226,7 +226,7 @@ unix_getsockopt_aux(char * name, } } -CAMLexport value +CAMLexport value unix_setsockopt_aux(char * name, enum option_type ty, int level, int option, value socket, value val) diff --git a/otherlibs/unix/stat.c b/otherlibs/unix/stat.c index 92a752f5e7..9cd0000632 100644 --- a/otherlibs/unix/stat.c +++ b/otherlibs/unix/stat.c @@ -137,4 +137,3 @@ CAMLprim value unix_fstat_64(value fd) if (ret == -1) uerror("fstat", Nothing); return stat_aux(1, &buf); } - diff --git a/otherlibs/unix/termios.c b/otherlibs/unix/termios.c index f885544cf0..ce49d77e09 100644 --- a/otherlibs/unix/termios.c +++ b/otherlibs/unix/termios.c @@ -39,7 +39,7 @@ enum { Input, Output }; #define NFIELDS 38 /* Structure of the terminal_io record. Cf. unix.mli */ - + static long terminal_io_descr[] = { /* Input modes */ Bool, iflags, IGNBRK, @@ -314,4 +314,3 @@ CAMLprim value unix_tcflow(value fd, value action) { invalid_argument("tcflow not implemented"); } #endif - diff --git a/otherlibs/unix/unix.ml b/otherlibs/unix/unix.ml index fd1e8e2862..8de827b0c8 100644 --- a/otherlibs/unix/unix.ml +++ b/otherlibs/unix/unix.ml @@ -444,7 +444,7 @@ external accept : file_descr -> file_descr * sockaddr = "unix_accept" external bind : file_descr -> sockaddr -> unit = "unix_bind" external connect : file_descr -> sockaddr -> unit = "unix_connect" external listen : file_descr -> int -> unit = "unix_listen" -external shutdown : file_descr -> shutdown_command -> unit = "unix_shutdown" +external shutdown : file_descr -> shutdown_command -> unit = "unix_shutdown" external getsockname : file_descr -> sockaddr = "unix_getsockname" external getpeername : file_descr -> sockaddr = "unix_getpeername" @@ -521,7 +521,7 @@ end = struct let optint = 2 let float = 3 let error = 4 - external get: ('opt, 'v) t -> file_descr -> 'opt -> 'v + external get: ('opt, 'v) t -> file_descr -> 'opt -> 'v = "unix_getsockopt" external set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit = "unix_setsockopt" @@ -608,7 +608,7 @@ let getaddrinfo_emulation node service opts = with Failure _ -> try [ty, (getservbyname service kind).s_port] - with Not_found -> [] + with Not_found -> [] in let ports = match !opt_socktype with @@ -639,7 +639,7 @@ let getaddrinfo_emulation node service opts = [] in (* Cross-product of addresses and ports *) List.flatten - (List.map + (List.map (fun (ty, port) -> List.map (fun (addr, name) -> @@ -895,7 +895,7 @@ let find_proc_id fun_name proc = raise(Unix_error(EBADF, fun_name, "")) let rec waitpid_non_intr pid = - try waitpid [] pid + try waitpid [] pid with Unix_error (EINTR, _, _) -> waitpid_non_intr pid let close_process_in inchan = @@ -965,4 +965,3 @@ let establish_server server_fun sockaddr = exit 0 | id -> close s; ignore(waitpid_non_intr id) (* Reclaim the son *) done - diff --git a/otherlibs/unix/unixsupport.c b/otherlibs/unix/unixsupport.c index 8a42072f78..c6eaf706c5 100644 --- a/otherlibs/unix/unixsupport.c +++ b/otherlibs/unix/unixsupport.c @@ -252,7 +252,7 @@ value unix_error_of_code (int errcode) int errconstr; value err; - errconstr = + errconstr = cst_to_constr(errcode, error_table, sizeof(error_table)/sizeof(int), -1); if (errconstr == Val_int(-1)) { err = alloc_small(1, 0); @@ -290,4 +290,3 @@ void uerror(char *cmdname, value cmdarg) { unix_error(errno, cmdname, cmdarg); } - diff --git a/otherlibs/unix/write.c b/otherlibs/unix/write.c index 633f05fc06..9ddf74e3d5 100644 --- a/otherlibs/unix/write.c +++ b/otherlibs/unix/write.c @@ -63,7 +63,7 @@ CAMLprim value unix_write(value fd, value buf, value vofs, value vlen) This problem is avoided in unix_single_write, which is faithful to the Unix system call. */ -CAMLprim value unix_single_write(value fd, value buf, value vofs, value vlen) +CAMLprim value unix_single_write(value fd, value buf, value vofs, value vlen) { long ofs, len; int numbytes, ret; @@ -84,4 +84,3 @@ CAMLprim value unix_single_write(value fd, value buf, value vofs, value vlen) End_roots(); return Val_int(ret); } - diff --git a/otherlibs/win32graph/dib.c b/otherlibs/win32graph/dib.c index d881a02819..cbf4725a43 100644 --- a/otherlibs/win32graph/dib.c +++ b/otherlibs/win32graph/dib.c @@ -493,4 +493,3 @@ void AfficheBitmap(char *filename,HDC hDC,int x,int y) DessinerBitmap(hdib,hDC,&rc); GlobalFree(hdib); } - diff --git a/otherlibs/win32graph/draw.c b/otherlibs/win32graph/draw.c index a4d4fc93da..62710ec09d 100644 --- a/otherlibs/win32graph/draw.c +++ b/otherlibs/win32graph/draw.c @@ -32,7 +32,7 @@ static void GetCurrentPosition(HDC hDC,POINT *pt) } static value gr_draw_or_fill_arc(value vx, value vy, value vrx, value vry, - value vstart, value vend, BOOL fill); + value vstart, value vend, BOOL fill); CAMLprim value caml_gr_plot(value vx, value vy) { @@ -94,10 +94,10 @@ CAMLprim value caml_gr_draw_rect(value vx, value vy, value vw, value vh) h=Int_val(vh); pt[0].x = x; pt[0].y = y - h; - pt[1].x = x + w; pt[1].y = y - h; - pt[2].x = x + w; pt[2].y = y; - pt[3].x = x; pt[3].y = y; - pt[4].x = x; pt[4].y = y - h; + pt[1].x = x + w; pt[1].y = y - h; + pt[2].x = x + w; pt[2].y = y; + pt[3].x = x; pt[3].y = y; + pt[4].x = x; pt[4].y = y - h; if (grremember_mode) { Polyline(grwindow.gcBitmap,pt, 5); } @@ -191,7 +191,7 @@ CAMLprim value caml_gr_set_window_title(value text) CAMLprim value caml_gr_draw_arc(value *argv, int argc) { return gr_draw_or_fill_arc(argv[0], argv[1], argv[2], argv[3], - argv[4], argv[5], FALSE); + argv[4], argv[5], FALSE); } CAMLprim value caml_gr_draw_arc_nat(vx, vy, vrx, vry, vstart, vend) @@ -252,7 +252,7 @@ CAMLprim value caml_gr_set_color(value vcolor) static value gr_draw_or_fill_arc(value vx, value vy, value vrx, value vry, - value vstart, value vend, BOOL fill) + value vstart, value vend, BOOL fill) { int x, y, r_x, r_y, start, end; int x1, y1, x2, y2, x3, y3, x4, y4; @@ -418,7 +418,7 @@ CAMLprim value caml_gr_fill_poly(value vect) CAMLprim value caml_gr_fill_arc(value *argv, int argc) { return gr_draw_or_fill_arc(argv[0], argv[1], argv[2], argv[3], - argv[4], argv[5], TRUE); + argv[4], argv[5], TRUE); } CAMLprim value caml_gr_fill_arc_nat(vx, vy, vrx, vry, vstart, vend) @@ -438,7 +438,7 @@ struct image { #define Height(i) (((struct image *)Data_custom_val(i))->h) #define Data(i) (((struct image *)Data_custom_val(i))->data) #define Mask(i) (((struct image *)Data_custom_val(i))->mask) -#define Max_image_mem 500000 +#define Max_image_mem 500000 static void finalize_image (value i) { @@ -459,19 +459,19 @@ CAMLprim value caml_gr_create_image(value vw, value vh) { HBITMAP cbm; value res; - int w = Int_val(vw); - int h = Int_val(vh); + int w = Int_val(vw); + int h = Int_val(vh); if (w < 0 || h < 0) gr_fail("create_image: width and height must be positive",0); cbm = CreateCompatibleBitmap(grwindow.gc, w, h); - if (cbm == NULL) - gr_fail("create_image: cannot create bitmap", 0); + if (cbm == NULL) + gr_fail("create_image: cannot create bitmap", 0); res = alloc_custom(&image_ops, sizeof(struct image), w * h, Max_image_mem); if (res) { - Width (res) = w; + Width (res) = w; Height (res) = h; Data (res) = cbm; Mask (res) = NULL; diff --git a/otherlibs/win32graph/open.c b/otherlibs/win32graph/open.c index d2b63b0025..2797bc669a 100644 --- a/otherlibs/win32graph/open.c +++ b/otherlibs/win32graph/open.c @@ -72,7 +72,7 @@ void ResetForClose(HWND hwnd) gr_initialized = 0; } - + static LRESULT CALLBACK GraphicsWndProc(HWND hwnd,UINT msg,WPARAM wParam,LPARAM lParam) { @@ -154,7 +154,7 @@ static value gr_reset(void) grwindow.CurrentBrush = SelectObject(grwindow.gc,GetStockObject(WHITE_BRUSH)); SelectObject(grwindow.gc,grwindow.CurrentBrush); SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush); - caml_gr_set_color(Val_long(0)); + caml_gr_set_color(Val_long(0)); SelectObject(grwindow.gc,grwindow.CurrentFont); SelectObject(grwindow.gcBitmap,grwindow.CurrentFont); grdisplay_mode = grremember_mode = 1; @@ -229,11 +229,11 @@ static DWORD WINAPI gr_open_graph_internal(value arg) } gr_reset(); ShowWindow(grwindow.hwnd,SW_SHOWNORMAL); - + /* Position the current point at origin */ grwindow.grx = 0; grwindow.gry = 0; - + caml_gr_init_event_queue(); /* The global data structures are now correctly initialized. @@ -256,7 +256,7 @@ CAMLprim value caml_gr_open_graph(value arg) long tid; if (gr_initialized) return Val_unit; open_graph_event = CreateEvent(NULL, FALSE, FALSE, NULL); - threadHandle = + threadHandle = CreateThread(NULL,0, (LPTHREAD_START_ROUTINE)gr_open_graph_internal,(void **)arg, 0, @@ -270,7 +270,7 @@ CAMLprim value caml_gr_open_graph(value arg) CAMLprim value caml_gr_close_graph(void) { if (gr_initialized) { - PostMessage(grwindow.hwnd, WM_CLOSE, 0, 0); + PostMessage(grwindow.hwnd, WM_CLOSE, 0, 0); WaitForSingleObject(threadHandle, INFINITE); } return Val_unit; diff --git a/otherlibs/win32unix/.depend b/otherlibs/win32unix/.depend index 6e1130b18a..a608240cdf 100644 --- a/otherlibs/win32unix/.depend +++ b/otherlibs/win32unix/.depend @@ -1,5 +1,5 @@ -unix.cmo: unix.cmi -unix.cmx: unix.cmi -unixLabels.cmo: unix.cmi unixLabels.cmi -unixLabels.cmx: unix.cmx unixLabels.cmi -unixLabels.cmi: unix.cmi +unix.cmo: unix.cmi +unix.cmx: unix.cmi +unixLabels.cmo: unix.cmi unixLabels.cmi +unixLabels.cmx: unix.cmx unixLabels.cmi +unixLabels.cmi: unix.cmi diff --git a/otherlibs/win32unix/accept.c b/otherlibs/win32unix/accept.c index 05fd731e55..1d54b89b32 100644 --- a/otherlibs/win32unix/accept.c +++ b/otherlibs/win32unix/accept.c @@ -37,7 +37,7 @@ CAMLprim value unix_accept(sock) if (retcode == 0) { /* Set sockets to synchronous mode */ newvalue = SO_SYNCHRONOUS_NONALERT; - setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, + setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, (char *) &newvalue, sizeof(newvalue)); } addr_len = sizeof(sock_addr); @@ -47,7 +47,7 @@ CAMLprim value unix_accept(sock) leave_blocking_section(); if (retcode == 0) { /* Restore initial mode */ - setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, + setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, (char *) &oldvalue, oldvaluelen); } if (snew == INVALID_SOCKET) { @@ -63,4 +63,3 @@ CAMLprim value unix_accept(sock) End_roots(); return res; } - diff --git a/otherlibs/win32unix/bind.c b/otherlibs/win32unix/bind.c index 0a17c8d513..fca9694890 100644 --- a/otherlibs/win32unix/bind.c +++ b/otherlibs/win32unix/bind.c @@ -16,7 +16,7 @@ #include <mlvalues.h> #include "unixsupport.h" #include "socketaddr.h" - + CAMLprim value unix_bind(socket, address) value socket, address; { diff --git a/otherlibs/win32unix/channels.c b/otherlibs/win32unix/channels.c index 6e6b10139b..1c2cd2734a 100644 --- a/otherlibs/win32unix/channels.c +++ b/otherlibs/win32unix/channels.c @@ -44,7 +44,7 @@ CAMLprim value win_inchannel_of_filedescr(value handle) if (Descr_kind_val(handle) == KIND_SOCKET) chan->flags |= CHANNEL_FLAG_FROM_SOCKET; vchan = caml_alloc_channel(chan); - CAMLreturn(vchan); + CAMLreturn(vchan); } CAMLprim value win_outchannel_of_filedescr(value handle) @@ -58,7 +58,7 @@ CAMLprim value win_outchannel_of_filedescr(value handle) if (Descr_kind_val(handle) == KIND_SOCKET) chan->flags |= CHANNEL_FLAG_FROM_SOCKET; vchan = caml_alloc_channel(chan); - CAMLreturn(vchan); + CAMLreturn(vchan); } CAMLprim value win_filedescr_of_channel(value vchan) diff --git a/otherlibs/win32unix/dup.c b/otherlibs/win32unix/dup.c index de2ea74499..2668e75bf1 100644 --- a/otherlibs/win32unix/dup.c +++ b/otherlibs/win32unix/dup.c @@ -31,4 +31,3 @@ CAMLprim value unix_dup(value fd) Descr_kind_val(newfd) = kind; return newfd; } - diff --git a/otherlibs/win32unix/errmsg.c b/otherlibs/win32unix/errmsg.c index 20a8c8d58f..9ce9dddb2a 100644 --- a/otherlibs/win32unix/errmsg.c +++ b/otherlibs/win32unix/errmsg.c @@ -26,7 +26,7 @@ CAMLprim value unix_error_message(value err) { int errnum; char buffer[512]; - + errnum = Is_block(err) ? Int_val(Field(err, 0)) : error_table[Int_val(err)]; if (errnum > 0) return copy_string(strerror(errnum)); @@ -38,7 +38,6 @@ CAMLprim value unix_error_message(value err) sizeof(buffer), NULL)) return copy_string(buffer); - sprintf(buffer, "unknown error #%d", errnum); + sprintf(buffer, "unknown error #%d", errnum); return copy_string(buffer); } - diff --git a/otherlibs/win32unix/gettimeofday.c b/otherlibs/win32unix/gettimeofday.c index 0c581321a4..f1313f0617 100644 --- a/otherlibs/win32unix/gettimeofday.c +++ b/otherlibs/win32unix/gettimeofday.c @@ -31,6 +31,6 @@ CAMLprim value unix_gettimeofday(value unit) return copy_double((double) initial_time); } else { return copy_double((double) initial_time + - (double) (tickcount - initial_tickcount) * 1e-3); + (double) (tickcount - initial_tickcount) * 1e-3); } } diff --git a/otherlibs/win32unix/link.c b/otherlibs/win32unix/link.c index 26202ed986..8921434234 100644 --- a/otherlibs/win32unix/link.c +++ b/otherlibs/win32unix/link.c @@ -17,18 +17,18 @@ #include <mlvalues.h> #include <fail.h> #include "unixsupport.h" - -typedef + +typedef BOOL (WINAPI *tCreateHardLink)( LPCTSTR lpFileName, LPCTSTR lpExistingFileName, - LPSECURITY_ATTRIBUTES lpSecurityAttributes + LPSECURITY_ATTRIBUTES lpSecurityAttributes ); - + CAMLprim value unix_link(value path1, value path2) -{ +{ HMODULE hModKernel32; - tCreateHardLink pCreateHardLink; + tCreateHardLink pCreateHardLink; hModKernel32 = GetModuleHandle("KERNEL32.DLL"); pCreateHardLink = (tCreateHardLink) GetProcAddress(hModKernel32, "CreateHardLinkA"); @@ -39,4 +39,4 @@ CAMLprim value unix_link(value path1, value path2) uerror("link", path2); } return Val_unit; -} +} diff --git a/otherlibs/win32unix/lseek.c b/otherlibs/win32unix/lseek.c index 2df3a86dc0..9619fcc92a 100644 --- a/otherlibs/win32unix/lseek.c +++ b/otherlibs/win32unix/lseek.c @@ -52,7 +52,7 @@ CAMLprim value unix_lseek(value fd, value ofs, value cmd) __int64 ret; ret = caml_set_file_pointer(Handle_val(fd), Long_val(ofs), - seek_command_table[Int_val(cmd)]); + seek_command_table[Int_val(cmd)]); if (ret > Max_long) { win32_maperr(ERROR_ARITHMETIC_OVERFLOW); uerror("lseek", Nothing); @@ -65,6 +65,6 @@ CAMLprim value unix_lseek_64(value fd, value ofs, value cmd) __int64 ret; ret = caml_set_file_pointer(Handle_val(fd), Int64_val(ofs), - seek_command_table[Int_val(cmd)]); + seek_command_table[Int_val(cmd)]); return copy_int64(ret); } diff --git a/otherlibs/win32unix/rename.c b/otherlibs/win32unix/rename.c index 3bfdf47707..9ab43fca89 100644 --- a/otherlibs/win32unix/rename.c +++ b/otherlibs/win32unix/rename.c @@ -31,13 +31,13 @@ CAMLprim value unix_rename(value path1, value path2) } if (supports_MoveFileEx > 0) ok = MoveFileEx(String_val(path1), String_val(path2), - MOVEFILE_REPLACE_EXISTING | MOVEFILE_WRITE_THROUGH | - MOVEFILE_COPY_ALLOWED); + MOVEFILE_REPLACE_EXISTING | MOVEFILE_WRITE_THROUGH | + MOVEFILE_COPY_ALLOWED); else ok = MoveFile(String_val(path1), String_val(path2)); if (! ok) { win32_maperr(GetLastError()); uerror("rename", path1); - } + } return Val_unit; } diff --git a/otherlibs/win32unix/select.c b/otherlibs/win32unix/select.c index 0c7760bb7b..efe3a32e8e 100644 --- a/otherlibs/win32unix/select.c +++ b/otherlibs/win32unix/select.c @@ -29,7 +29,7 @@ * It takes the following parameters into account: * - limitation on number of objects is mostly due to limitation * a WaitForMultipleObjects - * - there is always an event "hStop" to watch + * - there is always an event "hStop" to watch * * This lead to pick the following value as the biggest possible * value @@ -115,7 +115,7 @@ typedef enum _SELECTHANDLETYPE { typedef enum _SELECTMODE { SELECT_MODE_NONE = 0, SELECT_MODE_READ, - SELECT_MODE_WRITE, + SELECT_MODE_WRITE, SELECT_MODE_EXCEPT, } SELECTMODE; @@ -188,13 +188,13 @@ LPSELECTDATA select_data_new (LPSELECTDATA lpSelectData, SELECTTYPE EType) /* Allocate the data structure */ LPSELECTDATA res; DWORD i; - + if (!HeapLock(GetProcessHeap())) { win32_maperr(GetLastError()); uerror("select", Nothing); } - res = (LPSELECTDATA)HeapAlloc(GetProcessHeap(), 0, sizeof(SELECTDATA)); + res = (LPSELECTDATA)HeapAlloc(GetProcessHeap(), 0, sizeof(SELECTDATA)); HeapUnlock(GetProcessHeap()); /* Init common data */ @@ -202,10 +202,10 @@ LPSELECTDATA select_data_new (LPSELECTDATA lpSelectData, SELECTTYPE EType) list_next_set((LPLIST)res, (LPLIST)lpSelectData); res->EType = EType; res->nResultsCount = 0; - + /* Data following are dedicated to APC like call, they - will be initialized if required. For now they are set to + will be initialized if required. For now they are set to invalid values. */ res->funcWorker = NULL; @@ -269,7 +269,7 @@ DWORD select_data_result_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, LPVOI DWORD select_data_query_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, HANDLE hFileDescr, LPVOID lpOrig) { DWORD res; - DWORD i; + DWORD i; res = 0; if (lpSelectData->nQueriesCount < MAXIMUM_SELECT_OBJECTS) @@ -286,15 +286,16 @@ DWORD select_data_query_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, HANDLE } /* Search for a job that has available query slots and that match provided type. - * If none is found, create a new one. Return the corresponding SELECTDATA, and + * If none is found, create a new one. Return the corresponding SELECTDATA, and * update provided SELECTDATA head, if required. */ -LPSELECTDATA select_data_job_search (LPSELECTDATA *lppSelectData, SELECTTYPE EType) +LPSELECTDATA select_data_job_search (LPSELECTDATA *lppSelectData, + SELECTTYPE EType) { LPSELECTDATA res; - + res = NULL; - + /* Search for job */ #ifdef DBUG dbug_print("Searching an available job for type %d", EType); @@ -303,7 +304,7 @@ LPSELECTDATA select_data_job_search (LPSELECTDATA *lppSelectData, SELECTTYPE ETy while ( res != NULL && !( - res->EType == EType + res->EType == EType && res->nQueriesCount < MAXIMUM_SELECT_OBJECTS ) ) @@ -336,7 +337,7 @@ void read_console_poll(HANDLE hStop, void *_data) DWORD n; LPSELECTDATA lpSelectData; LPSELECTQUERY lpQuery; - + #ifdef DBUG dbug_print("Waiting for data on console"); #endif @@ -350,7 +351,7 @@ void read_console_poll(HANDLE hStop, void *_data) events[0] = hStop; events[1] = lpQuery->hFileDescr; while (lpSelectData->EState == SELECT_STATE_NONE) - { + { waitRes = WaitForMultipleObjects(2, events, FALSE, INFINITE); if (waitRes == WAIT_OBJECT_0 || check_error(lpSelectData, waitRes == WAIT_FAILED)) { @@ -371,7 +372,7 @@ void read_console_poll(HANDLE hStop, void *_data) lpSelectData->EState = SELECT_STATE_SIGNALED; break; } - else + else { /* discard everything else and try again */ if (check_error(lpSelectData, ReadConsoleInput(lpQuery->hFileDescr, &record, 1, &n) == 0)) @@ -421,13 +422,13 @@ void read_pipe_poll (HANDLE hStop, void *_data) { iterQuery = &(lpSelectData->aQueries[i]); if (check_error( - lpSelectData, + lpSelectData, PeekNamedPipe( - iterQuery->hFileDescr, - NULL, - 0, - NULL, - &n, + iterQuery->hFileDescr, + NULL, + 0, + NULL, + &n, NULL) == 0)) { break; @@ -441,7 +442,7 @@ void read_pipe_poll (HANDLE hStop, void *_data) }; /* Alas, nothing except polling seems to work for pipes. - Check the state & stop_worker_event every 10 ms + Check the state & stop_worker_event every 10 ms */ if (lpSelectData->EState == SELECT_STATE_NONE) { @@ -462,17 +463,17 @@ LPSELECTDATA read_pipe_poll_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, HA { LPSELECTDATA res; LPSELECTDATA hd; - + hd = lpSelectData; /* Polling pipe is a non blocking operation by default. This means that each - worker can handle many pipe. We begin to try to find a worker that is + worker can handle many pipe. We begin to try to find a worker that is polling pipe, but for which there is under the limit of pipe per worker. */ #ifdef DBUG dbug_print("Searching an available worker handling pipe"); #endif res = select_data_job_search(&hd, SELECT_TYPE_PIPE_READ); - + /* Add a new pipe to poll */ res->funcWorker = read_pipe_poll; select_data_query_add(res, EMode, hFileDescr, lpOrig); @@ -516,22 +517,22 @@ void socket_poll (HANDLE hStop, void *_data) } check_error(lpSelectData, WSAEventSelect( - (SOCKET)(iterQuery->hFileDescr), - aEvents[nEvents], + (SOCKET)(iterQuery->hFileDescr), + aEvents[nEvents], maskEvents) == SOCKET_ERROR); } - + /* Add stop event */ aEvents[nEvents] = hStop; nEvents++; if (lpSelectData->nError == 0) { - check_error(lpSelectData, + check_error(lpSelectData, WaitForMultipleObjects( - nEvents, - aEvents, - FALSE, + nEvents, + aEvents, + FALSE, INFINITE) == WAIT_FAILED); }; @@ -568,7 +569,7 @@ LPSELECTDATA socket_poll_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, HANDL { LPSELECTDATA res; LPSELECTDATA hd; - + hd = lpSelectData; /* Polling socket can be done mulitple handle at the same time. You just need one worker to use it. Try to find if there is already a worker @@ -578,7 +579,7 @@ LPSELECTDATA socket_poll_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, HANDL dbug_print("Scanning list of worker to find one that already handle socket"); #endif res = select_data_job_search(&hd, SELECT_TYPE_SOCKET); - + /* Add a new socket to poll */ res->funcWorker = socket_poll; #ifdef DBUG @@ -601,11 +602,11 @@ LPSELECTDATA static_poll_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, HANDL { LPSELECTDATA res; LPSELECTDATA hd; - + /* Look for an already initialized static element */ hd = lpSelectData; res = select_data_job_search(&hd, SELECT_TYPE_STATIC); - + /* Add a new query/result */ select_data_query_add(res, EMode, hFileDescr, lpOrig); select_data_result_add(res, EMode, lpOrig); @@ -636,7 +637,7 @@ static SELECTHANDLETYPE get_handle_type(value fd) { switch(GetFileType(Handle_val(fd))) { - case FILE_TYPE_DISK: + case FILE_TYPE_DISK: res = SELECT_HANDLE_DISK; break; @@ -685,8 +686,8 @@ LPSELECTDATA select_data_dispatch (LPSELECTDATA lpSelectData, SELECTMODE EMode, #ifdef DBUG dbug_print("Waiting for %d on handle %x", EMode, hFileDescr); #endif - - /* There is only 2 way to have except mode: transmission of OOB data through + + /* There is only 2 way to have except mode: transmission of OOB data through a socket TCP/IP and through a strange interaction with a TTY. With windows, we only consider the TCP/IP except condition */ @@ -795,12 +796,12 @@ static DWORD caml_list_length (value lst) #define MAX(a, b) ((a) > (b) ? (a) : (b)) CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value timeout) -{ +{ /* Event associated to handle */ DWORD nEventsCount; DWORD nEventsMax; HANDLE *lpEventsDone; - + /* Data for all handles */ LPSELECTDATA lpSelectData; LPSELECTDATA iterSelectData; @@ -861,8 +862,8 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value uerror("select", Nothing); } hdsData = (HANDLE *)HeapAlloc( - GetProcessHeap(), - 0, + GetProcessHeap(), + 0, sizeof(HANDLE) * hdsMax); HeapUnlock(GetProcessHeap()); @@ -973,12 +974,12 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value /* Execute APC */ if (iterSelectData->funcWorker != NULL) { - iterSelectData->lpWorker = + iterSelectData->lpWorker = worker_job_submit( - iterSelectData->funcWorker, + iterSelectData->funcWorker, (void *)iterSelectData); #ifdef DBUG - dbug_print("Job submitted to worker %x", iterSelectData->lpWorker); + dbug_print("Job submitted to worker %x", iterSelectData->lpWorker); #endif lpEventsDone[nEventsCount] = worker_job_event_done(iterSelectData->lpWorker); nEventsCount++; @@ -1034,7 +1035,7 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value }; iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); }; - + #ifdef DBUG dbug_print("Waiting for every select worker to be done"); #endif @@ -1067,7 +1068,7 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value #ifdef DBUG dbug_print("Building result"); #endif - read_list = Val_unit; + read_list = Val_unit; write_list = Val_unit; except_list = Val_unit; @@ -1116,7 +1117,7 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value select_data_free(lpSelectData); } lpSelectData = NULL; - + /* Free allocated events/handle set array */ #ifdef DBUG dbug_print("Free local allocated resources"); diff --git a/otherlibs/win32unix/socket.c b/otherlibs/win32unix/socket.c index 079473f81f..3cd55ec29f 100644 --- a/otherlibs/win32unix/socket.c +++ b/otherlibs/win32unix/socket.c @@ -36,7 +36,7 @@ CAMLprim value unix_socket(domain, type, proto) if (retcode == 0) { /* Set sockets to synchronous mode */ newvalue = SO_SYNCHRONOUS_NONALERT; - setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, + setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, (char *) &newvalue, sizeof(newvalue)); } s = socket(socket_domain_table[Int_val(domain)], @@ -44,7 +44,7 @@ CAMLprim value unix_socket(domain, type, proto) Int_val(proto)); if (retcode == 0) { /* Restore initial mode */ - setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, + setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, (char *) &oldvalue, oldvaluelen); } if (s == INVALID_SOCKET) { diff --git a/otherlibs/win32unix/system.c b/otherlibs/win32unix/system.c index 9cf3e89cc1..51dc9bfb7b 100644 --- a/otherlibs/win32unix/system.c +++ b/otherlibs/win32unix/system.c @@ -42,6 +42,3 @@ CAMLprim value win_system(cmd) Field(st, 0) = Val_int(ret); return st; } - - - diff --git a/otherlibs/win32unix/unix.ml b/otherlibs/win32unix/unix.ml index f8d663170c..c8396d7fd4 100644 --- a/otherlibs/win32unix/unix.ml +++ b/otherlibs/win32unix/unix.ml @@ -145,7 +145,7 @@ external waitpid : wait_flag list -> int -> int * process_status external getpid : unit -> int = "unix_getpid" let fork () = invalid_arg "Unix.fork not implemented" -let wait () = invalid_arg "Unix.wait not implemented" +let wait () = invalid_arg "Unix.wait not implemented" let getppid () = invalid_arg "Unix.getppid not implemented" let nice prio = invalid_arg "Unix.nice not implemented" @@ -515,7 +515,7 @@ external accept : file_descr -> file_descr * sockaddr = "unix_accept" external bind : file_descr -> sockaddr -> unit = "unix_bind" external connect : file_descr -> sockaddr -> unit = "unix_connect" external listen : file_descr -> int -> unit = "unix_listen" -external shutdown : file_descr -> shutdown_command -> unit = "unix_shutdown" +external shutdown : file_descr -> shutdown_command -> unit = "unix_shutdown" external getsockname : file_descr -> sockaddr = "unix_getsockname" external getpeername : file_descr -> sockaddr = "unix_getpeername" @@ -592,7 +592,7 @@ end = struct let optint = 2 let float = 3 let error = 4 - external get: ('opt, 'v) t -> file_descr -> 'opt -> 'v + external get: ('opt, 'v) t -> file_descr -> 'opt -> 'v = "unix_getsockopt" external set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit = "unix_setsockopt" @@ -678,7 +678,7 @@ let getaddrinfo node service opts = with Failure _ -> try [ty, (getservbyname service kind).s_port] - with Not_found -> [] + with Not_found -> [] in let ports = match !opt_socktype with @@ -709,7 +709,7 @@ let getaddrinfo node service opts = [] in (* Cross-product of addresses and ports *) List.flatten - (List.map + (List.map (fun (ty, port) -> List.map (fun (addr, name) -> @@ -772,7 +772,7 @@ let create_process prog args fd1 fd2 fd3 = let create_process_env prog args env fd1 fd2 fd3 = win_create_process prog (make_cmdline args) (Some(String.concat "\000" (Array.to_list env) ^ "\000")) - fd1 fd2 fd3 + fd1 fd2 fd3 external system: string -> process_status = "win_system" diff --git a/otherlibs/win32unix/windbug.h b/otherlibs/win32unix/windbug.h index a0085a90f8..232bb1989e 100644 --- a/otherlibs/win32unix/windbug.h +++ b/otherlibs/win32unix/windbug.h @@ -43,8 +43,7 @@ int dbug_test (void); #define DBUG_CLEANUP dbug_cleanup() #else -#define DBUG_PRINT(fmt, ...) +#define DBUG_PRINT(fmt, ...) #define DBUG_INIT #define DBUG_CLEANUP #endif - diff --git a/otherlibs/win32unix/windir.c b/otherlibs/win32unix/windir.c index 0a681e76ce..8b96589ec9 100644 --- a/otherlibs/win32unix/windir.c +++ b/otherlibs/win32unix/windir.c @@ -77,4 +77,3 @@ CAMLprim value win_findclose(valh) } return Val_unit; } - diff --git a/otherlibs/win32unix/winworker.c b/otherlibs/win32unix/winworker.c index 7358b203c4..aa83684b2f 100644 --- a/otherlibs/win32unix/winworker.c +++ b/otherlibs/win32unix/winworker.c @@ -53,17 +53,17 @@ DWORD WINAPI worker_wait (LPVOID _data) { BOOL bExit; LPWORKER lpWorker; - + lpWorker = (LPWORKER )_data; bExit = FALSE; DBUG_PRINT("Worker %x starting", lpWorker); while ( - !bExit + !bExit && SignalObjectAndWait( - lpWorker->hWorkerReady, + lpWorker->hWorkerReady, lpWorker->hCommandReady, - INFINITE, + INFINITE, TRUE) == WAIT_OBJECT_0) { DBUG_PRINT("Worker %x running", lpWorker); @@ -111,11 +111,11 @@ LPWORKER worker_new (void) lpWorker->hCommandReady = CreateEvent(NULL, FALSE, FALSE, NULL); lpWorker->ECommand = WORKER_CMD_NONE; lpWorker->hThread = CreateThread( - NULL, - THREAD_WORKERS_MEM, - worker_wait, - (LPVOID)lpWorker, - 0, + NULL, + THREAD_WORKERS_MEM, + worker_wait, + (LPVOID)lpWorker, + 0, NULL); return lpWorker; @@ -287,7 +287,7 @@ void worker_cleanup(void) worker_free(lpWorker); }; ReleaseMutex(hWorkersMutex); - + /* Destroy associated mutex */ CloseHandle(hWorkersMutex); hWorkersMutex = INVALID_HANDLE_VALUE; diff --git a/otherlibs/win32unix/winworker.h b/otherlibs/win32unix/winworker.h index d0b8290029..06450a4ec3 100644 --- a/otherlibs/win32unix/winworker.h +++ b/otherlibs/win32unix/winworker.h @@ -18,12 +18,12 @@ #define _WIN32_WINNT 0x0400 #include <windows.h> -/* Pool of worker threads. +/* Pool of worker threads. * * These functions help to manage a pool of worker thread and submit task to * the pool. It helps to reduce the number of thread creation. * - * Each worker are started in alertable wait state and jobs are submitted as + * Each worker are started in alertable wait state and jobs are submitted as * APC (asynchronous procedure call). */ @@ -42,16 +42,16 @@ typedef WORKER *LPWORKER; */ typedef void (*WORKERFUNC) (HANDLE, void *); -/* Initialize global data structure for worker +/* Initialize global data structure for worker */ void worker_init (void); -/* Free global data structure for worker +/* Free global data structure for worker */ void worker_cleanup (void); /* Submit a job to worker. Use returned data to synchronize with the procedure - * submitted. + * submitted. */ LPWORKER worker_job_submit (WORKERFUNC f, void *data); @@ -63,7 +63,7 @@ HANDLE worker_job_event_done (LPWORKER); */ void worker_job_stop (LPWORKER); -/* End a job submitted to worker. +/* End a job submitted to worker. */ void worker_job_finish (LPWORKER); diff --git a/parsing/linenum.mll b/parsing/linenum.mll index 32f54d5ffb..91e71e972c 100644 --- a/parsing/linenum.mll +++ b/parsing/linenum.mll @@ -30,7 +30,7 @@ let parse_sharp_line s = linenum := int_of_string(String.sub s !l1 (!l2 - !l1)); let f1 = ref (!l2 + 1) in while !f1 < String.length s && s.[!f1] <> '"' do incr f1 done; - let f2 = ref (!f1 + 1) in + let f2 = ref (!f1 + 1) in while !f2 < String.length s && s.[!f2] <> '"' do incr f2 done; if !f1 < String.length s then filename := String.sub s (!f1 + 1) (!f2 - !f1 - 1) diff --git a/parsing/parse.ml b/parsing/parse.ml index ee91bea84e..7f3e4cdc02 100644 --- a/parsing/parse.ml +++ b/parsing/parse.ml @@ -53,7 +53,7 @@ let wrap parsing_fun lexbuf = raise err | Parsing.Parse_error | Syntaxerr.Escape_error -> let loc = Location.curr lexbuf in - if !Location.input_name = "" + if !Location.input_name = "" then maybe_skip_phrase lexbuf; raise(Syntaxerr.Error(Syntaxerr.Other loc)) ;; diff --git a/parsing/parse.mli b/parsing/parse.mli index 6b1a14c32d..87a09f0e2a 100644 --- a/parsing/parse.mli +++ b/parsing/parse.mli @@ -18,4 +18,3 @@ val implementation : Lexing.lexbuf -> Parsetree.structure val interface : Lexing.lexbuf -> Parsetree.signature val toplevel_phrase : Lexing.lexbuf -> Parsetree.toplevel_phrase val use_file : Lexing.lexbuf -> Parsetree.toplevel_phrase list - diff --git a/parsing/parser.mly b/parsing/parser.mly index d0d12eaade..a21fdd8590 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -1184,7 +1184,7 @@ record_pattern_end: opt_semi { Closed } | SEMI UNDERSCORE opt_semi { Open } ; - + /* Primitive declarations */ primitive_declaration: diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index ca835be10e..0307cea547 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -22,7 +22,7 @@ type core_type = { ptyp_desc: core_type_desc; ptyp_loc: Location.t } -and core_type_desc = +and core_type_desc = Ptyp_any | Ptyp_var of string | Ptyp_arrow of label * core_type * core_type diff --git a/stdlib/Makefile b/stdlib/Makefile index 76f0eac8b0..874dcf6f9e 100644 --- a/stdlib/Makefile +++ b/stdlib/Makefile @@ -32,7 +32,7 @@ installopt-noprof: rm -f $(LIBDIR)/stdlib.p.cmxa; ln -s stdlib.cmxa $(LIBDIR)/stdlib.p.cmxa rm -f $(LIBDIR)/stdlib.p.a; ln -s stdlib.a $(LIBDIR)/stdlib.p.a rm -f $(LIBDIR)/std_exit.p.cmx; \ - ln -s std_exit.cmx $(LIBDIR)/std_exit.p.cmx + ln -s std_exit.cmx $(LIBDIR)/std_exit.p.cmx rm -f $(LIBDIR)/std_exit.p.o; ln -s std_exit.o $(LIBDIR)/std_exit.p.o installopt-prof: @@ -44,16 +44,16 @@ stdlib.p.cmxa: $(OBJS:.cmo=.p.cmx) camlheader camlheader_ur: header.c ../config/Makefile if $(SHARPBANGSCRIPTS); then \ - echo '#!$(BINDIR)/ocamlrun' > camlheader && \ - echo '#!' | tr -d '\012' > camlheader_ur; \ - else \ + echo '#!$(BINDIR)/ocamlrun' > camlheader && \ + echo '#!' | tr -d '\012' > camlheader_ur; \ + else \ $(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) \ - -DRUNTIME_NAME='"$(BINDIR)/ocamlrun"' \ - header.c -o tmpheader$(EXE) && \ - strip tmpheader$(EXE) && \ + -DRUNTIME_NAME='"$(BINDIR)/ocamlrun"' \ + header.c -o tmpheader$(EXE) && \ + strip tmpheader$(EXE) && \ mv tmpheader$(EXE) camlheader && \ - cp camlheader camlheader_ur; \ - fi + cp camlheader camlheader_ur; \ + fi .PHONY: all allopt allopt-noprof allopt-prof install installopt .PHONY: installopt-default installopt-noprof installopt-prof clean depend diff --git a/stdlib/Makefile.nt b/stdlib/Makefile.nt index aae1de40ae..995a0c3fd6 100644 --- a/stdlib/Makefile.nt +++ b/stdlib/Makefile.nt @@ -29,4 +29,3 @@ camlheader camlheader_ur: headernt.c ../config/Makefile # TODO: do not call flexlink to build tmpheader.exe (we don't need # the export table) - diff --git a/stdlib/header.c b/stdlib/header.c index 0d536be18d..eda76325a6 100644 --- a/stdlib/header.c +++ b/stdlib/header.c @@ -121,7 +121,7 @@ static char * searchpath(char * name) return name; } -#endif +#endif static unsigned long read_size(char * ptr) { diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli index 7a1e68dd91..754125f9e8 100644 --- a/stdlib/pervasives.mli +++ b/stdlib/pervasives.mli @@ -93,7 +93,7 @@ external compare : 'a -> 'a -> int = "%compare" the {!List.sort} and {!Array.sort} functions. *) val min : 'a -> 'a -> 'a -(** Return the smaller of the two arguments. +(** Return the smaller of the two arguments. The result is unspecified if one of the arguments contains the float value [nan]. *) diff --git a/stdlib/printexc.ml b/stdlib/printexc.ml index 11e7d4fd6e..63da48c569 100644 --- a/stdlib/printexc.ml +++ b/stdlib/printexc.ml @@ -86,7 +86,7 @@ type loc_info = * int (* end char *) | Unknown_location of bool (*is_raise*) -external get_exception_backtrace: +external get_exception_backtrace: unit -> loc_info array option = "caml_get_exception_backtrace" let format_loc_info pos li = diff --git a/testobjects/Exemples.exp b/testobjects/Exemples.exp index 5d55e083d1..d5deafcbdf 100644 --- a/testobjects/Exemples.exp +++ b/testobjects/Exemples.exp @@ -208,7 +208,7 @@ is not compatible with type # val sort : (#comparable as 'a) list -> 'a list = <fun> # val pr : < x : int; .. > list -> unit = <fun> # val l : int_comparable list = [<obj>; <obj>; <obj>] -# 5 2 4 +# 5 2 4 - : unit = () # 2 4 5 - : unit = () diff --git a/testobjects/Exemples.ml b/testobjects/Exemples.ml index 30db53ab4f..0d98a96c13 100644 --- a/testobjects/Exemples.ml +++ b/testobjects/Exemples.ml @@ -31,19 +31,19 @@ let get_x p = p#get_x;; let set_x p = p#set_x;; List.map get_x l;; -class ref x_init = +class ref x_init = val mutable x = x_init method get = x method set y = x <- y end;; -class ref (x_init:int) = +class ref (x_init:int) = val mutable x = x_init method get = x method set y = x <- y end;; -class 'a ref x_init = +class 'a ref x_init = val mutable x = (x_init : 'a) method get = x method set y = x <- y @@ -135,7 +135,7 @@ class virtual 'a lst () as self = f self#hd; self#tl#iter f end - method print (f : 'a -> unit) = + method print (f : 'a -> unit) = print_string "("; self#iter (fun x -> f x; print_string "::"); print_string "[]"; @@ -160,8 +160,8 @@ l1#print print_int;; let l2 = l1#map (fun x -> x + 1);; l2#print print_int;; -let rec map_list f (x:'a lst) = - if x#null then new nil() +let rec map_list f (x:'a lst) = + if x#null then new nil() else new cons (f x#hd) (map_list f x#tl);; let p1 = (map_list (fun x -> new printable_color_point x "red") l1);; diff --git a/tools/DoMake b/tools/DoMake index 2afff48ae2..2fce340103 100644 --- a/tools/DoMake +++ b/tools/DoMake @@ -41,7 +41,7 @@ if "{domake_files}" == "" else set domake_main "Makefile" end - + if "`exists "{domake_main}".depend`" != "" set domake_files "-f {domake_main} -f {domake_main}.depend" else diff --git a/tools/Makefile.shared b/tools/Makefile.shared index 01c3a4d870..477ba73a2a 100644 --- a/tools/Makefile.shared +++ b/tools/Makefile.shared @@ -19,7 +19,7 @@ CAMLC=$(CAMLRUN) ../boot/ocamlc -strict-sequence -nostdlib -I ../boot CAMLOPT=$(CAMLRUN) ../ocamlopt -nostdlib -I ../stdlib CAMLLEX=$(CAMLRUN) ../boot/ocamllex INCLUDES=-I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../asmcomp \ - -I ../driver + -I ../driver COMPFLAGS= -warn-error A $(INCLUDES) LINKFLAGS=$(INCLUDES) @@ -105,13 +105,13 @@ clean:: ocamlmklib.ml: ocamlmklib.mlp ../config/Makefile echo '(* THIS FILE IS GENERATED FROM ocamlmklib.mlp *)' >ocamlmklib.ml sed -e "s|%%BINDIR%%|$(BINDIR)|" \ - -e "s|%%SUPPORTS_SHARED_LIBRARIES%%|$(SUPPORTS_SHARED_LIBRARIES)|" \ - -e "s|%%MKSHAREDLIB%%|$(MKSHAREDLIB)|" \ - -e "s|%%BYTECCRPATH%%|$(BYTECCRPATH)|" \ - -e "s|%%NATIVECCRPATH%%|$(NATIVECCRPATH)|" \ - -e "s|%%MKSHAREDLIBRPATH%%|$(MKSHAREDLIBRPATH)|" \ - -e "s|%%RANLIB%%|$(RANLIB)|" \ - ocamlmklib.mlp >> ocamlmklib.ml + -e "s|%%SUPPORTS_SHARED_LIBRARIES%%|$(SUPPORTS_SHARED_LIBRARIES)|" \ + -e "s|%%MKSHAREDLIB%%|$(MKSHAREDLIB)|" \ + -e "s|%%BYTECCRPATH%%|$(BYTECCRPATH)|" \ + -e "s|%%NATIVECCRPATH%%|$(NATIVECCRPATH)|" \ + -e "s|%%MKSHAREDLIBRPATH%%|$(MKSHAREDLIBRPATH)|" \ + -e "s|%%RANLIB%%|$(RANLIB)|" \ + ocamlmklib.mlp >> ocamlmklib.ml beforedepend:: ocamlmklib.ml @@ -213,12 +213,12 @@ opnames.ml: ../byterun/instruct.h unset LC_CTYPE || : ; \ unset LC_COLLATE LANG || : ; \ sed -e '/\/\*/d' \ - -e '/^#/d' \ - -e 's/enum \(.*\) {/let names_of_\1 = [|/' \ - -e 's/};$$/ |]/' \ - -e 's/\([A-Z][A-Z_0-9a-z]*\)/"\1"/g' \ - -e 's/,/;/g' \ - ../byterun/instruct.h > opnames.ml + -e '/^#/d' \ + -e 's/enum \(.*\) {/let names_of_\1 = [|/' \ + -e 's/};$$/ |]/' \ + -e 's/\([A-Z][A-Z_0-9a-z]*\)/"\1"/g' \ + -e 's/,/;/g' \ + ../byterun/instruct.h > opnames.ml clean:: rm -f opnames.ml diff --git a/tools/addlabels.ml b/tools/addlabels.ml index 270a4d6109..87dace563b 100644 --- a/tools/addlabels.ml +++ b/tools/addlabels.ml @@ -143,7 +143,7 @@ let rec insert_labels ~labels ~text expr = insert_labels ~labels ~text e2 | _ -> () - + let rec insert_labels_class ~labels ~text expr = match labels, expr.pcl_desc with l::labels, Pcl_fun(l', _, pat, rem) -> diff --git a/tools/cleanup-header b/tools/cleanup-header index 9c2147573c..6c320fb39c 100644 --- a/tools/cleanup-header +++ b/tools/cleanup-header @@ -11,5 +11,3 @@ d } /\/\* <private> \*\//,/\/\* <\/private> \*\//d - - diff --git a/tools/depend.ml b/tools/depend.ml index cadf0f0f10..57c9fd0172 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -230,7 +230,7 @@ and add_module bv modl = add_expr bv e and add_structure bv item_list = - List.fold_left add_struct_item bv item_list + List.fold_left add_struct_item bv item_list and add_struct_item bv item = match item.pstr_desc with @@ -253,7 +253,7 @@ and add_struct_item bv item = List.fold_right StringSet.add (List.map (fun (id,_,_) -> id) bindings) bv in List.iter - (fun (id, mty, modl) -> add_modtype bv' mty; add_module bv' modl) + (fun (id, mty, modl) -> add_modtype bv' mty; add_module bv' modl) bindings; bv' | Pstr_modtype(id, mty) -> @@ -301,4 +301,3 @@ and add_class_field bv = function and add_class_declaration bv decl = add_class_expr bv decl.pci_expr - diff --git a/tools/dumpapprox.ml b/tools/dumpapprox.ml index 3387e7e9a2..4270842f9c 100644 --- a/tools/dumpapprox.ml +++ b/tools/dumpapprox.ml @@ -95,6 +95,3 @@ let main () = exit 0 let _ = main () - - - diff --git a/tools/lexer299.mll b/tools/lexer299.mll index 03d2d8601b..9a244721df 100644 --- a/tools/lexer299.mll +++ b/tools/lexer299.mll @@ -230,7 +230,7 @@ let char_for_backslash = function let char_for_decimal_code lexbuf i = let c = 100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) + - (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in + (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in Char.chr(c land 0xFF) (* To store the position of the beginning of a string and comment *) @@ -257,7 +257,7 @@ let report_error ppf = function let blank = [' ' '\010' '\013' '\009' '\012'] let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] -let identchar = +let identchar = ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] let symbolchar = ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] diff --git a/tools/lexer301.mll b/tools/lexer301.mll index 1c19f7e524..daec549e7e 100644 --- a/tools/lexer301.mll +++ b/tools/lexer301.mll @@ -233,7 +233,7 @@ let char_for_backslash = function let char_for_decimal_code lexbuf i = let c = 100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) + - (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in + (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in Char.chr(c land 0xFF) (* To store the position of the beginning of a string and comment *) @@ -263,7 +263,7 @@ let report_error ppf = function let blank = [' ' '\010' '\013' '\009' '\012'] let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] -let identchar = +let identchar = ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] let symbolchar = ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] diff --git a/tools/profiling.ml b/tools/profiling.ml index 3527ab3da6..9c6d9dd02b 100644 --- a/tools/profiling.ml +++ b/tools/profiling.ml @@ -54,4 +54,3 @@ let dump_counters () = end let _ = at_exit dump_counters - diff --git a/tools/scrapelabels.ml b/tools/scrapelabels.ml index 26512e0a05..dc43e97b70 100644 --- a/tools/scrapelabels.ml +++ b/tools/scrapelabels.ml @@ -148,7 +148,7 @@ let convert_impl buffer = assert false with Closing last -> match token, last with - LPAREN, RPAREN + LPAREN, RPAREN | (LBRACKET|LBRACKETBAR|LBRACKETLESS), (RBRACKET|BARRBRACKET|GREATERRBRACKET) | (BEGIN|STRUCT|SIG|OBJECT), END diff --git a/toplevel/opttopdirs.ml b/toplevel/opttopdirs.ml index 5c63052262..b586bae1c8 100644 --- a/toplevel/opttopdirs.ml +++ b/toplevel/opttopdirs.ml @@ -37,10 +37,10 @@ let dir_directory s = Config.load_path := d :: !Config.load_path let _ = Hashtbl.add directive_table "directory" (Directive_string dir_directory) -let _ = Hashtbl.add directive_table "show_dirs" - (Directive_none +let _ = Hashtbl.add directive_table "show_dirs" + (Directive_none (fun () -> - List.iter print_endline !Config.load_path + List.iter print_endline !Config.load_path )) (* To change the current directory *) @@ -52,7 +52,7 @@ let _ = Hashtbl.add directive_table "cd" (Directive_string dir_cd) (* Load in-core a .cmxs file *) let load_file ppf name0 = - let name = + let name = try Some (find_in_path !Config.load_path name0) with Not_found -> None in match name with @@ -67,23 +67,23 @@ let load_file ppf name0 = else name,false in - let success = + 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 + with | Dynlink.Error err -> - fprintf ppf "Error while loading %s: %s.@." - name (Dynlink.error_message err); - false - | exn -> - print_exception_outcome ppf exn; - false + 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) @@ -126,7 +126,7 @@ let find_printer_type ppf lid = with Ctype.Unify _ -> (match_printer_type ppf desc "printer_type_old", true) in (ty_arg, path, is_old_style) - with + with | Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid; raise Exit @@ -134,7 +134,7 @@ let find_printer_type ppf lid = fprintf ppf "%a has a wrong type for a printing function.@." Printtyp.longident lid; raise Exit - + let dir_install_printer ppf lid = try let (ty_arg, path, is_old_style) = find_printer_type ppf lid in diff --git a/toplevel/opttopmain.ml b/toplevel/opttopmain.ml index 4e08353ec5..e2f5e72965 100644 --- a/toplevel/opttopmain.ml +++ b/toplevel/opttopmain.ml @@ -122,4 +122,3 @@ let main () = ]) file_argument usage; if not (prepare Format.err_formatter) then exit 2; Opttoploop.loop Format.std_formatter - diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index 9e542f4529..6516a38770 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -164,7 +164,7 @@ let find_printer_type ppf lid = with Ctype.Unify _ -> (match_printer_type ppf desc "printer_type_old", true) in (ty_arg, path, is_old_style) - with + with | Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid; raise Exit @@ -172,7 +172,7 @@ let find_printer_type ppf lid = fprintf ppf "%a has a wrong type for a printing function.@." Printtyp.longident lid; raise Exit - + let dir_install_printer ppf lid = try let (ty_arg, path, is_old_style) = find_printer_type ppf lid in @@ -230,7 +230,7 @@ let dir_trace ppf lid = | None -> (* Instrument the old closure *) traced_functions := - { path = path; + { path = path; closure = clos; actual_code = get_code_pointer clos; instrumented_fun = diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml index fc105567a9..265a70a38b 100644 --- a/toplevel/topmain.ml +++ b/toplevel/topmain.ml @@ -21,7 +21,7 @@ let preload_objects = ref [] let prepare ppf = Toploop.set_paths (); try - let res = + let res = List.for_all (Topdirs.load_file ppf) (List.rev !preload_objects) in !Toploop.toplevel_startup_hook (); res @@ -101,4 +101,3 @@ let main () = ] file_argument usage; if not (prepare Format.err_formatter) then exit 2; Toploop.loop Format.std_formatter - diff --git a/toplevel/trace.mli b/toplevel/trace.mli index ed7dc6e33a..d708361c7c 100644 --- a/toplevel/trace.mli +++ b/toplevel/trace.mli @@ -30,6 +30,6 @@ val is_traced: Obj.t -> Path.t option val get_code_pointer: Obj.t -> codeptr val set_code_pointer: Obj.t -> codeptr -> unit val instrument_closure: - Env.t -> Longident.t -> formatter -> Types.type_expr -> + Env.t -> Longident.t -> formatter -> Types.type_expr -> codeptr -> Obj.t -> Obj.t -> Obj.t val print_trace: Obj.t -> Obj.t -> Obj.t diff --git a/typing/btype.ml b/typing/btype.ml index 13c7998178..e57e760f2e 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -51,7 +51,7 @@ let rec field_kind_repr = let rec repr = function {desc = Tlink t'} -> - (* + (* We do no path compression. Path compression does not seem to improve notably efficiency, and it prevents from changing a [Tlink] into another type (for instance, for undoing a @@ -96,11 +96,11 @@ let row_repr row = row_repr_aux [] row let rec row_field tag row = let rec find = function | (tag',f) :: fields -> - if tag = tag' then row_field_repr f else find fields + if tag = tag' then row_field_repr f else find fields | [] -> - match repr row.row_more with - | {desc=Tvariant row'} -> row_field tag row' - | _ -> Rabsent + match repr row.row_more with + | {desc=Tvariant row'} -> row_field tag row' + | _ -> Rabsent in find row.row_fields let rec row_more row = @@ -264,7 +264,7 @@ let rec copy_type_desc f = function let saved_desc = ref [] (* Saved association of generic nodes with their description. *) -let save_desc ty desc = +let save_desc ty desc = saved_desc := (ty, desc)::!saved_desc let saved_kinds = ref [] (* duplicated kind variables *) @@ -381,7 +381,7 @@ let rec forget_abbrev_rec mem path = Mnil -> assert false | Mcons (_, path', _, _, rem) when Path.same path path' -> - rem + rem | Mcons (priv, path', v, v', rem) -> Mcons (priv, path', v, v', forget_abbrev_rec rem path) | Mlink mem' -> @@ -446,7 +446,7 @@ let undo_change = function | Ccommu (r, v) -> r := v | Cuniv (r, v) -> r := v -type changes = +type changes = Change of change * changes ref | Unchanged | Invalid diff --git a/typing/ctype.ml b/typing/ctype.ml index 316a8d942c..4b9e84b223 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -1840,7 +1840,7 @@ and unify_row_field env fixed1 fixed2 l f1 f2 = if e1 == e2 then () else let redo = (m1 || m2 || - !rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) && + !rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) && begin match tl1 @ tl2 with [] -> false | t1 :: tl -> if c1 || c2 then raise (Unify []); @@ -3226,15 +3226,15 @@ let rec normalize_type_rec env visited ty = begin match !nm with | None -> () | Some (n, v :: l) -> - if deep_occur ty (newgenty (Ttuple l)) then - (* The abbreviation may be hiding something, so remove it *) - set_name nm None - else let v' = repr v in + if deep_occur ty (newgenty (Ttuple l)) then + (* The abbreviation may be hiding something, so remove it *) + set_name nm None + else let v' = repr v in begin match v'.desc with | Tvar|Tunivar -> if v' != v then set_name nm (Some (n, v' :: l)) | Tnil -> - log_type ty; ty.desc <- Tconstr (n, l, ref Mnil) + log_type ty; ty.desc <- Tconstr (n, l, ref Mnil) | _ -> set_name nm None end | _ -> diff --git a/typing/datarepr.mli b/typing/datarepr.mli index eb440aba27..283dbd294a 100644 --- a/typing/datarepr.mli +++ b/typing/datarepr.mli @@ -25,7 +25,7 @@ val exception_descr: Path.t -> type_expr list -> constructor_description val label_descrs: type_expr -> (string * mutable_flag * type_expr) list -> - record_representation -> private_flag -> + record_representation -> private_flag -> (string * label_description) list exception Constr_not_found diff --git a/typing/env.ml b/typing/env.ml index a654762b14..0442479906 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -675,7 +675,7 @@ let components_of_functor_appl f p1 p2 = Hashtbl.find f.fcomp_cache p2 with Not_found -> let p = Papply(p1, p2) in - let mty = + let mty = Subst.modtype (Subst.add_module f.fcomp_param p2 Subst.identity) f.fcomp_res in let comps = components_of_module f.fcomp_env f.fcomp_subst p mty in @@ -777,7 +777,7 @@ let open_signature root sg env = (Subst.cltype_declaration sub decl) env) env sg pl in { newenv with summary = Env_open(env.summary, root) } - + (* Open a signature from a file *) let open_pers_signature name env = diff --git a/typing/ident.ml b/typing/ident.ml index 89a343c31e..c5bc09f418 100644 --- a/typing/ident.ml +++ b/typing/ident.ml @@ -63,7 +63,7 @@ let set_current_time t = currentstamp := max !currentstamp t let reinit_level = ref (-1) -let reinit () = +let reinit () = if !reinit_level < 0 then reinit_level := !currentstamp else currentstamp := !reinit_level diff --git a/typing/ident.mli b/typing/ident.mli index 486fc64082..03e2eee48d 100644 --- a/typing/ident.mli +++ b/typing/ident.mli @@ -25,7 +25,7 @@ val unique_name: t -> string val unique_toplevel_name: t -> string val persistent: t -> bool val equal: t -> t -> bool - (* Compare identifiers by name. *) + (* Compare identifiers by name. *) val same: t -> t -> bool (* Compare identifiers by binding location. Two identifiers are the same either if they are both diff --git a/typing/includeclass.ml b/typing/includeclass.ml index 007182a3d6..ca860ffc44 100644 --- a/typing/includeclass.ml +++ b/typing/includeclass.ml @@ -42,7 +42,7 @@ let include_err ppf = fprintf ppf "A class cannot be changed from virtual to concrete" | CM_Parameter_arity_mismatch (ls, lp) -> fprintf ppf - "The classes do not have the same number of type parameters" + "The classes do not have the same number of type parameters" | CM_Type_parameter_mismatch trace -> fprintf ppf "@[%a@]" (Printtyp.unification_error false trace @@ -102,6 +102,3 @@ let report_error ppf = function let print_errs ppf errs = List.iter (fun err -> fprintf ppf "@ %a" include_err err) errs in fprintf ppf "@[<v>%a%a@]" include_err err print_errs errs - - - diff --git a/typing/includecore.ml b/typing/includecore.ml index 16c048b5c3..b8911f2e5a 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -63,27 +63,27 @@ let type_manifest env ty1 params1 ty2 params2 priv2 = Ctype.equal env true (ty1::params1) (row2.row_more::params2) && (match row1.row_more with {desc=Tvar|Tconstr _} -> true | _ -> false) && let r1, r2, pairs = - Ctype.merge_row_fields row1.row_fields row2.row_fields in + Ctype.merge_row_fields row1.row_fields row2.row_fields in (not row2.row_closed || row1.row_closed && Ctype.filter_row_fields false r1 = []) && List.for_all - (fun (_,f) -> match Btype.row_field_repr f with - Rabsent | Reither _ -> true | Rpresent _ -> false) - r2 && + (fun (_,f) -> match Btype.row_field_repr f with + Rabsent | Reither _ -> true | Rpresent _ -> false) + r2 && let to_equal = ref (List.combine params1 params2) in List.for_all - (fun (_, f1, f2) -> - match Btype.row_field_repr f1, Btype.row_field_repr f2 with - Rpresent(Some t1), - (Rpresent(Some t2) | Reither(false, [t2], _, _)) -> - to_equal := (t1,t2) :: !to_equal; true - | Rpresent None, (Rpresent None | Reither(true, [], _, _)) -> true - | Reither(c1,tl1,_,_), Reither(c2,tl2,_,_) - when List.length tl1 = List.length tl2 && c1 = c2 -> - to_equal := List.combine tl1 tl2 @ !to_equal; true - | Rabsent, (Reither _ | Rabsent) -> true - | _ -> false) - pairs && + (fun (_, f1, f2) -> + match Btype.row_field_repr f1, Btype.row_field_repr f2 with + Rpresent(Some t1), + (Rpresent(Some t2) | Reither(false, [t2], _, _)) -> + to_equal := (t1,t2) :: !to_equal; true + | Rpresent None, (Rpresent None | Reither(true, [], _, _)) -> true + | Reither(c1,tl1,_,_), Reither(c2,tl2,_,_) + when List.length tl1 = List.length tl2 && c1 = c2 -> + to_equal := List.combine tl1 tl2 @ !to_equal; true + | Rabsent, (Reither _ | Rabsent) -> true + | _ -> false) + pairs && let tl1, tl2 = List.split !to_equal in Ctype.equal env true tl1 tl2 | Tobject (fi1, _), Tobject (fi2, _) @@ -95,7 +95,7 @@ let type_manifest env ty1 params1 ty2 params2 priv2 = let pairs, miss1, miss2 = Ctype.associate_fields fields1 fields2 in miss2 = [] && let tl1, tl2 = - List.split (List.map (fun (_,_,t1,_,t2) -> t1, t2) pairs) in + List.split (List.map (fun (_,_,t1,_,t2) -> t1, t2) pairs) in Ctype.equal env true (params1 @ tl1) (params2 @ tl2) | _ -> let rec check_super ty1 = @@ -137,7 +137,7 @@ let type_declarations env id decl1 decl2 = (_, None) -> Ctype.equal env true decl1.type_params decl2.type_params | (Some ty1, Some ty2) -> - type_manifest env ty1 decl1.type_params ty2 decl2.type_params + type_manifest env ty1 decl1.type_params ty2 decl2.type_params decl2.type_private | (None, Some ty2) -> let ty1 = diff --git a/typing/includemod.ml b/typing/includemod.ml index 610025e5d0..bda604a20f 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -124,14 +124,14 @@ let simplify_structure_coercion cc = then Tcoerce_none else Tcoerce_structure cc -(* Inclusion between module types. +(* Inclusion between module types. Return the restriction that transforms a value of the smaller type into a value of the bigger type. *) let rec modtypes env subst mty1 mty2 = try try_modtypes env subst mty1 mty2 - with + with Dont_match -> raise(Error[Module_types(mty1, Subst.modtype subst mty2)]) | Error reasons -> @@ -363,7 +363,7 @@ let include_err ppf = function | Modtype_permutation -> fprintf ppf "Illegal permutation of structure fields" | Interface_mismatch(impl_name, intf_name) -> - fprintf ppf "@[The implementation %s@ does not match the interface %s:" + fprintf ppf "@[The implementation %s@ does not match the interface %s:" impl_name intf_name | Class_type_declarations(id, d1, d2, reason) -> fprintf ppf diff --git a/typing/mtype.ml b/typing/mtype.ml index 50455fb508..dddc65a0e9 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -146,7 +146,7 @@ let enrich_typedecl env p decl = | None -> try let orig_decl = Env.find_type p env in - if orig_decl.type_arity <> decl.type_arity + if orig_decl.type_arity <> decl.type_arity then decl else {decl with type_manifest = Some(Btype.newgenty(Tconstr(p, decl.type_params, ref Mnil)))} @@ -197,7 +197,7 @@ let rec no_code_needed env mty = match scrape env mty with Tmty_ident p -> false | Tmty_signature sg -> no_code_needed_sig env sg - | Tmty_functor(_, _, _) -> false + | Tmty_functor(_, _, _) -> false and no_code_needed_sig env sg = match sg with diff --git a/typing/parmatch.ml b/typing/parmatch.ml index 15e6d74e34..d73f79af6a 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -31,7 +31,7 @@ let omega = make_pat Tpat_any Ctype.none Env.empty let extra_pat = make_pat (Tpat_var (Ident.create "+")) Ctype.none Env.empty - + let rec omegas i = if i <= 0 then [] else omega :: omegas (i-1) @@ -80,7 +80,7 @@ let rec compat p q = | (Tpat_any|Tpat_var _),_ -> true | _,(Tpat_any|Tpat_var _) -> true | Tpat_or (p1,p2,_),_ -> compat p1 q || compat p2 q - | _,Tpat_or (q1,q2,_) -> compat p q1 || compat p q2 + | _,Tpat_or (q1,q2,_) -> compat p q1 || compat p q2 | Tpat_constant c1, Tpat_constant c2 -> c1=c2 | Tpat_tuple ps, Tpat_tuple qs -> compats ps qs | Tpat_lazy p, Tpat_lazy q -> compat p q @@ -89,7 +89,7 @@ let rec compat p q = | Tpat_variant(l1,Some p1, r1), Tpat_variant(l2,Some p2,_) -> l1=l2 && compat p1 p2 | Tpat_variant (l1,None,r1), Tpat_variant(l2,None,_) -> - l1 = l2 + l1 = l2 | Tpat_variant (_, None, _), Tpat_variant (_,Some _, _) -> false | Tpat_variant (_, Some _, _), Tpat_variant (_, None, _) -> false | Tpat_record l1,Tpat_record l2 -> @@ -100,7 +100,7 @@ let rec compat p q = compats ps qs | _,_ -> assert false - + and compats ps qs = match ps,qs with | [], [] -> true | p::ps, q::qs -> compat p q && compats ps qs @@ -260,14 +260,14 @@ let top_pretty ppf v = let prerr_pat v = top_pretty str_formatter v ; prerr_string (flush_str_formatter ()) - + (****************************) (* Utilities for matching *) (****************************) (* Check top matching *) -let simple_match p1 p2 = +let simple_match p1 p2 = match p1.pat_desc, p2.pat_desc with | Tpat_construct(c1, _), Tpat_construct(c2, _) -> c1.cstr_tag = c2.cstr_tag @@ -385,7 +385,7 @@ let rec normalize_pat q = match q.pat_desc with let discr_pat q pss = let rec acc_pat acc pss = match pss with - ({pat_desc = Tpat_alias (p,_)}::ps)::pss -> + ({pat_desc = Tpat_alias (p,_)}::ps)::pss -> acc_pat acc ((p::ps)::pss) | ({pat_desc = Tpat_or (p1,p2,_)}::ps)::pss -> acc_pat acc ((p1::ps)::(p2::ps)::pss) @@ -483,7 +483,7 @@ and set_args_erase_mutable q r = do_set_args true q r (* filter pss acording to pattern q *) let filter_one q pss = let rec filter_rec = function - ({pat_desc = Tpat_alias(p,_)}::ps)::pss -> + ({pat_desc = Tpat_alias(p,_)}::ps)::pss -> filter_rec ((p::ps)::pss) | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss -> filter_rec ((p1::ps)::(p2::ps)::pss) @@ -501,7 +501,7 @@ let filter_one q pss = *) let filter_extra pss = let rec filter_rec = function - ({pat_desc = Tpat_alias(p,_)}::ps)::pss -> + ({pat_desc = Tpat_alias(p,_)}::ps)::pss -> filter_rec ((p::ps)::pss) | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss -> filter_rec ((p1::ps)::(p2::ps)::pss) @@ -511,7 +511,7 @@ let filter_extra pss = | [] -> [] in filter_rec pss -(* +(* Pattern p0 is the discriminating pattern, returns [(q0,pss0) ; ... ; (qn,pssn)] where the qi's are simple patterns and the pssi's are @@ -557,7 +557,7 @@ let filter_all pat0 pss = pss | _::pss -> filter_omega env pss | [] -> env in - + filter_omega (filter_rec (match pat0.pat_desc with @@ -575,7 +575,7 @@ let rec set_last a = function (* mark constructor lines for failure when they are incomplete *) let rec mark_partial = function - ({pat_desc = Tpat_alias(p,_)}::ps)::pss -> + ({pat_desc = Tpat_alias(p,_)}::ps)::pss -> mark_partial ((p::ps)::pss) | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss -> mark_partial ((p1::ps)::(p2::ps)::pss) @@ -691,17 +691,17 @@ let complete_tags nconsts nconstrs tags = for i = 0 to nconstrs-1 do if not seen_constr.(i) then r := Cstr_block i :: !r - done ; + done ; !r (* build a pattern from a constructor list *) let pat_of_constr ex_pat cstr = {ex_pat with pat_desc = Tpat_construct (cstr,omegas cstr.cstr_arity)} - + let rec pat_of_constrs ex_pat = function | [] -> raise Empty | [cstr] -> pat_of_constr ex_pat cstr -| cstr::rem -> +| cstr::rem -> {ex_pat with pat_desc= Tpat_or @@ -801,7 +801,7 @@ let build_other ext env = match env with | Tpat_constant (Const_char c) -> c | _ -> assert false) env in - + let rec find_other i imax = if i > imax then raise Not_found else @@ -870,7 +870,7 @@ let build_other ext env = match env with p.pat_type p.pat_env in try_arrays 0 | [] -> omega -| _ -> omega +| _ -> omega (* Core function : @@ -889,17 +889,17 @@ let rec has_instance p = match p.pat_desc with | Tpat_construct (_,ps) | Tpat_tuple ps | Tpat_array ps -> has_instances ps | Tpat_record lps -> has_instances (List.map snd lps) | Tpat_lazy p -> has_instance p - + and has_instances = function | [] -> true | q::rem -> has_instance q && has_instances rem - + let rec satisfiable pss qs = match pss with -| [] -> has_instances qs +| [] -> has_instances qs | _ -> match qs with | [] -> false - | {pat_desc = Tpat_or(q1,q2,_)}::qs -> + | {pat_desc = Tpat_or(q1,q2,_)}::qs -> satisfiable pss (q1::qs) || satisfiable pss (q2::qs) | {pat_desc = Tpat_alias(q,_)}::qs -> satisfiable pss (q::qs) @@ -930,7 +930,7 @@ let rec satisfiable pss qs = match pss with This function should be called for exhaustiveness check only. *) -type 'a result = +type 'a result = | Rnone (* No matching value *) | Rsome of 'a (* This matching value *) @@ -954,7 +954,7 @@ let rec exhaust ext pss n = match pss with | Rsome r -> Rsome (q0::r) | r -> r end - | constrs -> + | constrs -> let try_non_omega (p,pss) = if is_absent_pat p then Rnone @@ -1008,7 +1008,7 @@ let rec pressure_variants tdefs = function let q0 = discr_pat omega pss in begin match filter_all q0 pss with [] -> pressure_variants tdefs (filter_extra pss) - | constrs -> + | constrs -> let rec try_non_omega = function (p,pss) :: rem -> let ok = pressure_variants tdefs pss in @@ -1074,8 +1074,8 @@ let pretty_matrix pss = prerr_endline "") pss ; prerr_endline "end matrix" - -(* this row type enable column processing inside the matrix + +(* this row type enable column processing inside the matrix - left -> elements not to be processed, - right -> elements to be processed *) @@ -1131,7 +1131,7 @@ let remove r = match r.active with | [] -> assert false let remove_column rs = List.map remove rs - + (* Current column has been processed *) let push_no_or r = match r.active with | p::rem -> { r with no_ors = p::r.no_ors ; active=rem} @@ -1148,7 +1148,7 @@ and push_no_or_column rs = List.map push_no_or rs work on the current column, instead of the first column *) -let discr_pat q rs = +let discr_pat q rs = discr_pat q (List.map (fun r -> r.active) rs) let filter_one q rs = @@ -1257,7 +1257,7 @@ let rec every_satisfiables pss qs = match qs.active with then (* syntactically generated or-pats should not be expanded *) every_satisfiables (push_no_or_column pss) (push_no_or qs) - else + else (* this is a real or-pattern *) every_satisfiables (push_or_column pss) (push_or qs) | Tpat_variant (l,_,r) when is_absent l r -> (* Ah Jacques... *) @@ -1303,7 +1303,7 @@ and every_both pss qs q1 q2 = | Upartial u2 -> Upartial (u1 @ u2) end - + (* le_pat p q means, forall V, V matches q implies V matches p *) @@ -1329,7 +1329,7 @@ let rec le_pat p q = List.length ps = List.length qs && le_pats ps qs (* In all other cases, enumeration is performed *) | _,_ -> not (satisfiable [[p]] [q]) - + and le_pats ps qs = match ps,qs with p::ps, q::qs -> le_pat p q && le_pats ps qs @@ -1384,7 +1384,7 @@ let rec lub p q = match p.pat_desc,q.pat_desc with raise Empty and orlub p1 p2 q = - try + try let r1 = lub p1 q in try {q with pat_desc=(Tpat_or (r1,lub p2 q,None))} @@ -1406,12 +1406,12 @@ and record_lubs l1 l2 = else (lbl1,lub p1 p2)::lub_rec rem1 rem2 in lub_rec l1 l2 - + and lubs ps qs = match ps,qs with | p::ps, q::qs -> lub p q :: lubs ps qs | _,_ -> [] - - + + (******************************) (* Exported variant closing *) (******************************) @@ -1475,7 +1475,7 @@ let rec do_filter_var = function let do_filter_one q pss = let rec filter_rec = function - | ({pat_desc = Tpat_alias(p,_)}::ps,loc)::pss -> + | ({pat_desc = Tpat_alias(p,_)}::ps,loc)::pss -> filter_rec ((p::ps,loc)::pss) | ({pat_desc = Tpat_or(p1,p2,_)}::ps,loc)::pss -> filter_rec ((p1::ps,loc)::(p2::ps,loc)::pss) @@ -1504,7 +1504,7 @@ let rec do_match pss qs = match qs with let q0 = normalize_pat q in do_match (do_filter_one q0 pss) (simple_match_args q0 q @ qs) - + let check_partial_all v casel = try let pss = initial_all true casel in @@ -1531,7 +1531,7 @@ let do_check_partial loc casel pss = match pss with | _ -> Location.prerr_warning loc Warnings.All_clauses_guarded end ; Partial -| ps::_ -> +| ps::_ -> begin match exhaust None pss (List.length ps) with | Rnone -> Total | Rsome [v] -> @@ -1546,13 +1546,13 @@ let do_check_partial loc casel pss = match pss with (* This is 'Some loc', where loc is the location of a possibly matching clause. Forget about loc, because printing two locations - is a pain in the top-level *) + is a pain in the top-level *) Buffer.add_string buf "\n(However, some guarded clause may match this value.)" end ; Buffer.contents buf with _ -> - "" in + "" in Location.prerr_warning loc (Warnings.Partial_match errmsg) ; Partial | _ -> @@ -1598,7 +1598,7 @@ let rec collect_paths_from_pat r p = match p.pat_desc with collect_paths_from_pat (collect_paths_from_pat r p1) p2 | Tpat_lazy p -> collect_paths_from_pat r p - + (* Actual fragile check @@ -1679,7 +1679,7 @@ let check_unused tdefs casel = | Used -> () with e -> assert false end ; - + if has_guard act then do_rec pref rem else diff --git a/typing/path.ml b/typing/path.ml index 88f9aa5748..009550261c 100644 --- a/typing/path.ml +++ b/typing/path.ml @@ -46,4 +46,3 @@ let rec head = function Pident id -> id | Pdot(p, s, pos) -> head p | Papply(p1, p2) -> assert false - diff --git a/typing/predef.ml b/typing/predef.ml index ce43b5a3bb..048e2d992e 100644 --- a/typing/predef.ml +++ b/typing/predef.ml @@ -100,7 +100,7 @@ let build_initial_env add_type add_exception empty_env = type_manifest = None; type_variance = []} and decl_unit = - {type_params = []; + {type_params = []; type_arity = 0; type_kind = Type_variant(["()", []]); type_private = Public; diff --git a/typing/subst.ml b/typing/subst.ml index e31ac16c5a..971d8b295c 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -19,7 +19,7 @@ open Path open Types open Btype -type t = +type t = { types: (Ident.t, Path.t) Tbl.t; modules: (Ident.t, Path.t) Tbl.t; modtypes: (Ident.t, module_type) Tbl.t; @@ -258,7 +258,7 @@ let rec rename_bound_idents s idents = function let id' = Ident.rename id in rename_bound_idents (add_modtype id (Tmty_ident(Pident id')) s) (id' :: idents) sg - | (Tsig_value(id, _) | Tsig_exception(id, _) | + | (Tsig_value(id, _) | Tsig_exception(id, _) | Tsig_class(id, _, _) | Tsig_cltype(id, _, _)) :: sg -> let id' = Ident.rename id in rename_bound_idents s (id' :: idents) sg @@ -309,7 +309,7 @@ and modtype_declaration s = function Tmodtype_abstract -> Tmodtype_abstract | Tmodtype_manifest mty -> Tmodtype_manifest(modtype s mty) -(* Composition of substitutions: +(* Composition of substitutions: apply (compose s1 s2) x = apply s2 (apply s1 x) *) let compose s1 s2 = diff --git a/typing/subst.mli b/typing/subst.mli index 02ecf2054b..c861a57be3 100644 --- a/typing/subst.mli +++ b/typing/subst.mli @@ -53,6 +53,6 @@ val modtype: t -> module_type -> module_type val signature: t -> signature -> signature val modtype_declaration: t -> modtype_declaration -> modtype_declaration -(* Composition of substitutions: +(* Composition of substitutions: apply (compose s1 s2) x = apply s2 (apply s1 x) *) val compose: t -> t -> t diff --git a/typing/typedecl.mli b/typing/typedecl.mli index 89d73f2f23..c44f467d7a 100644 --- a/typing/typedecl.mli +++ b/typing/typedecl.mli @@ -50,7 +50,7 @@ val compute_variance_decls: cltype_declaration * ((bool * bool) list * Location.t)) list -> (type_declaration * type_declaration * class_declaration * cltype_declaration) list - + type error = Repeated_parameter | Duplicate_constructor of string diff --git a/typing/typedtree.mli b/typing/typedtree.mli index a7ea525d98..eb64937cfe 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -166,4 +166,3 @@ val rev_let_bound_idents: (pattern * expression) list -> Ident.t list (* Alpha conversion of patterns *) val alpha_pat : (Ident.t * Ident.t) list -> pattern -> pattern - diff --git a/typing/typetexp.ml b/typing/typetexp.ml index e9f0c2edad..e4c782d735 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -152,12 +152,12 @@ let rec transl_type env policy styp = newty (Ttuple(List.map (transl_type env policy) stl)) | Ptyp_constr(lid, stl) -> let (path, decl) = - let lid, env = - match lid with - | Longident.Ldot (Longident.Lident "*predef*", lid) -> - Longident.Lident lid, Env.initial - | _ -> lid, env - in + let lid, env = + match lid with + | Longident.Ldot (Longident.Lident "*predef*", lid) -> + Longident.Lident lid, Env.initial + | _ -> lid, env + in try Env.lookup_type lid env with Not_found -> @@ -349,7 +349,7 @@ let rec transl_type env policy styp = let row = Btype.row_repr row in row.row_fields | {desc=Tvar}, Some(p, _) -> - raise(Error(sty.ptyp_loc, Unbound_type_constructor_2 p)) + raise(Error(sty.ptyp_loc, Unbound_type_constructor_2 p)) | _ -> raise(Error(sty.ptyp_loc, Not_a_variant ty)) in diff --git a/utils/config.mli b/utils/config.mli index ef46b2591d..91e10a04c2 100644 --- a/utils/config.mli +++ b/utils/config.mli @@ -27,12 +27,12 @@ val ccomp_type: string "msvc" (Microsoft Visual C++) "mrc" (Macintosh MPW) *) val bytecomp_c_compiler: string - (* The C compiler to use for compiling C files + (* The C compiler to use for compiling C files with the bytecode compiler *) val bytecomp_c_libraries: string (* The C libraries to link with custom runtimes *) val native_c_compiler: string - (* The C compiler to use for compiling C files + (* The C compiler to use for compiling C files with the native-code compiler *) val native_c_libraries: string (* The C libraries to link with native-code programs *) diff --git a/utils/misc.mli b/utils/misc.mli index 9ce5e846df..87f74e2575 100644 --- a/utils/misc.mli +++ b/utils/misc.mli @@ -67,7 +67,7 @@ val copy_file_chunk: in_channel -> out_channel -> int -> unit EOF on [ic]. *) val log2: int -> int - (* [log2 n] returns [s] such that [n = 1 lsl s] + (* [log2 n] returns [s] such that [n = 1 lsl s] if [n] is a power of 2*) val align: int -> int -> int (* [align n a] rounds [n] upwards to a multiple of [a] diff --git a/yacc/defs.h b/yacc/defs.h index 6c368fbd6d..1be27d1a3f 100644 --- a/yacc/defs.h +++ b/yacc/defs.h @@ -356,4 +356,3 @@ extern void unterminated_union (int u_lineno, char *u_line, char *u_cptr); extern void used_reserved (char *s); extern void verbose (void); extern void write_section (char **section); - diff --git a/yacc/lalr.c b/yacc/lalr.c index 81be0ec0e5..f87afb1dc6 100644 --- a/yacc/lalr.c +++ b/yacc/lalr.c @@ -336,7 +336,7 @@ void initialize_F(void) if (nullable[symbol]) edge[nedges++] = map_goto(stateno, symbol); } - + if (nedges) { reads[i] = rp = NEW2(nedges + 1, short); diff --git a/yacc/mkpar.c b/yacc/mkpar.c index 0d70fb8fbe..1f9759e176 100644 --- a/yacc/mkpar.c +++ b/yacc/mkpar.c @@ -312,7 +312,7 @@ sole_reduction(int stateno) register action *p; count = 0; - ruleno = 0; + ruleno = 0; for (p = parser[stateno]; p; p = p->next) { if (p->action_code == SHIFT && p->suppressed == 0) @@ -341,7 +341,7 @@ void defreds(void) for (i = 0; i < nstates; i++) defred[i] = sole_reduction(i); } - + void free_action_row(register action *p) { register action *q; @@ -363,4 +363,3 @@ void free_parser(void) FREE(parser); } - diff --git a/yacc/output.c b/yacc/output.c index 0774666e57..00d61ac9c6 100644 --- a/yacc/output.c +++ b/yacc/output.c @@ -114,7 +114,7 @@ void output_rule_data(void) register int i; register int j; - + fprintf(output_file, "let yylhs = \""); output_short(symbol_value[start_symbol]); diff --git a/yacc/verbose.c b/yacc/verbose.c index 2d79c9a5cb..0a1850ff0f 100644 --- a/yacc/verbose.c +++ b/yacc/verbose.c @@ -347,4 +347,3 @@ void print_gotos(int stateno) fprintf(verbose_file, "\t%s goto %d\n", symbol_name[as], k); } } - |