From 36d2ca90515136242e92c75721268e7a1c36cdb6 Mon Sep 17 00:00:00 2001 From: Sven Luther Date: Sat, 27 Nov 2004 11:29:32 +0000 Subject: [PATCH] Imported Upstream version 3.08.2 --- Changes | 23 +- asmrun/sparc.S | 3 +- boot/ocamlc | Bin 967058 -> 967005 bytes boot/ocamllex | Bin 152776 -> 152768 bytes byterun/Makefile | 4 +- byterun/Makefile.nt | 4 +- byterun/intern.c | 4 +- byterun/memory.h | 7 +- byterun/win32.c | 36 ++-- camlp4/CHANGES | 15 ++ camlp4/camlp4/argl.ml | 10 +- camlp4/camlp4/pcaml.ml | 6 +- camlp4/camlp4/pcaml.mli | 7 +- camlp4/etc/pa_o.ml | 29 +-- camlp4/lib/grammar.ml | 25 ++- camlp4/lib/grammar.mli | 6 +- camlp4/lib/plexer.ml | 31 ++- camlp4/lib/plexer.mli | 10 +- camlp4/meta/pa_r.ml | 9 +- camlp4/ocaml_src/camlp4/argl.ml | 24 ++- camlp4/ocaml_src/camlp4/pcaml.ml | 2 + camlp4/ocaml_src/camlp4/pcaml.mli | 5 + camlp4/ocaml_src/lib/grammar.ml | 24 ++- camlp4/ocaml_src/lib/grammar.mli | 4 + camlp4/ocaml_src/lib/plexer.ml | 50 +++-- camlp4/ocaml_src/lib/plexer.mli | 8 + camlp4/ocaml_src/meta/pa_r.ml | 16 +- camlp4/top/camlp4_top.ml | 11 +- configure | 11 +- emacs/caml-types.el | 6 +- emacs/caml-xemacs.el | 6 +- ocamldoc/Changes.txt | 4 + ocamldoc/odoc_misc.ml | 89 +++++--- ocamldoc/odoc_misc.mli | 12 +- ocamldoc/odoc_sig.ml | 344 ++++++++++++++++-------------- ocamldoc/odoc_str.ml | 53 +++-- otherlibs/threads/unix.ml | 14 +- otherlibs/unix/accept.c | 6 +- otherlibs/unix/access.c | 9 +- otherlibs/unix/bind.c | 3 +- otherlibs/unix/connect.c | 3 +- otherlibs/unix/fchmod.c | 3 +- otherlibs/unix/fchown.c | 3 +- otherlibs/unix/fcntl.c | 3 +- otherlibs/unix/ftruncate.c | 3 +- otherlibs/unix/getaddrinfo.c | 4 +- otherlibs/unix/getcwd.c | 3 +- otherlibs/unix/getgroups.c | 3 +- otherlibs/unix/gethost.c | 4 +- otherlibs/unix/gethostname.c | 5 +- otherlibs/unix/getnameinfo.c | 4 +- otherlibs/unix/getpeername.c | 3 +- otherlibs/unix/getproto.c | 4 +- otherlibs/unix/getserv.c | 4 +- otherlibs/unix/getsockname.c | 3 +- otherlibs/unix/gettimeofday.c | 3 +- otherlibs/unix/gmtime.c | 6 +- otherlibs/unix/itimer.c | 3 +- otherlibs/unix/listen.c | 3 +- otherlibs/unix/lockf.c | 3 +- otherlibs/unix/mkfifo.c | 3 +- otherlibs/unix/open.c | 7 +- otherlibs/unix/putenv.c | 3 +- otherlibs/unix/readlink.c | 3 +- otherlibs/unix/rewinddir.c | 3 +- otherlibs/unix/select.c | 3 +- otherlibs/unix/sendrecv.c | 27 +-- otherlibs/unix/setsid.c | 3 +- otherlibs/unix/shutdown.c | 3 +- otherlibs/unix/signals.c | 3 +- otherlibs/unix/socket.c | 3 +- otherlibs/unix/socketpair.c | 3 +- otherlibs/unix/sockopt.c | 3 +- otherlibs/unix/strofaddr.c | 3 +- otherlibs/unix/symlink.c | 3 +- otherlibs/unix/termios.c | 3 +- otherlibs/unix/truncate.c | 3 +- otherlibs/unix/unix.ml | 14 +- otherlibs/unix/utimes.c | 3 +- otherlibs/unix/wait.c | 11 +- stdlib/scanf.mli | 4 +- stdlib/set.ml | 4 +- stdlib/string.mli | 4 +- stdlib/sys.ml | 4 +- tools/ocamlprof.ml | 23 +- tools/profiling.ml | 5 +- tools/profiling.mli | 5 +- yacc/reader.c | 8 +- 88 files changed, 743 insertions(+), 421 deletions(-) diff --git a/Changes b/Changes index c8c2fd74..e0ce39f0 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,24 @@ +Objective Caml 3.08.2: +---------------------- + +Bug fixes: +- runtime: memory leak when unmarshalling big data structures (PR#3247) +- camlp4: incorrect line numbers in errors (PR#3188) +- emacs: xemacs-specific code, wrong call to "sit-for" +- ocamldoc: "Lexing: empty token" (PR#3173) +- unix: problem with close_process_* (PR#3191) +- unix: possible coredumps (PR#3252) +- stdlib: wrong order in Set.fold (PR#3161) +- ocamlcp: array out of bounds in profiled programs (PR#3267) +- yacc: problem with polymorphic variant types for grammar entries (PR#3033) + +Misc: +- export for caml_format_exception (PR#3080) +- clean up caml_search_exe_in_path (maybe PR#3079) +- camlp4: new function "make_lexer" for new-style locations +- unix: added missing #includes (PR#3088) + + Objective Caml 3.08.1: ---------------------- @@ -1783,4 +1804,4 @@ Caml Special Light 1.06: * First public release. -$Id: Changes,v 1.140.2.4 2004/08/19 12:52:17 doligez Exp $ +$Id: Changes,v 1.140.2.5 2004/11/19 15:36:18 doligez Exp $ diff --git a/asmrun/sparc.S b/asmrun/sparc.S index e4cc282a..2f3d457e 100644 --- a/asmrun/sparc.S +++ b/asmrun/sparc.S @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: sparc.S,v 1.24 2004/02/17 12:30:11 xleroy Exp $ */ +/* $Id: sparc.S,v 1.24.4.1 2004/10/06 09:02:36 garrigue Exp $ */ /* Asm part of the runtime system for the Sparc processor. */ /* Must be preprocessed by cpp */ @@ -382,6 +382,7 @@ Caml_callback3_exn: .data #endif .global Caml_system__frametable + .align 4 /* required for gas? */ Caml_system__frametable: .word 1 /* one descriptor */ .word L109 /* return address into callback */ diff --git a/boot/ocamlc b/boot/ocamlc index 93fa1f8875c43a8bb9583f9ab2f856a02238d204..e0a85b893ea794aa93b901e5586caacd5f0fe79b 100755 GIT binary patch delta 242 zcmbQ#Y<;)MdPCoCM()Y|yQLX#i|zFlK=T7_+BOKg*=d$TNNSSte;-0ieoQAod4hf%eB|nShuX zh*^M`6^Pk@m>q~YfS41Axqz5^`{T1bt2lXE7#R4Q85m}*XJAPBuzl8b9(HC%qwR}s z@toykQc!4L_Jn8qvM0Qb+8pfv+5Q6&`}X(zd`%k_X9P$3Ix#S?M>q#L2Qx5m%?H}e R?wpvLV`yn<8DU^x0RT%qQ-lBj delta 271 zcmccHWId_bdPCoCM&8N&yQLYqn^*5{U%i`g`|90H{eqII3=9lBKxH9`>g9c?97aY+ZWy9 zIm>Bop>qtYl~eXKPf9Yzo4?c@CncM!Y90r+8k{E X+5ZC(+xA`jd`%k}&rY{J$fp1R+ht*T diff --git a/boot/ocamllex b/boot/ocamllex index 4144bdd978c1ab3d9b90c1d9350a5d3aadfee62e..a221cfc5ef0787f10a1f5015285d0bfd0a1388ce 100755 GIT binary patch delta 455 zcmZY2y-Px26bA77T*$gzFJx#bmJTk~5;XLI(8p9;L>I2)M@tmg*wEnMAe7J`gNC~{NmC6CLH~d)5j0lt_S{Gzg7*jKeb0N&b5}QR>&A7y0kgKzh{C!lHmc`1 z5_1g?i!o?gidJct_NYiDD$@ZSQk7~XbWA67Mwb$`F&)~}G|f*-WKf=TDP=GbDX_HY zPmA{*Y1&AHyr~44l%o}|cH1^Gy1eHRmURa+(50Hi@T~W_BgT4!yy1STkfK3~lef@E z10HERaJu`FJzmpv%V|97fqm8&bWhLpBHI}}$y^#q*~%gb{Dd2wV81l8NR0;g^ Iimfkv1HGGG2><{9 delta 458 zcmZwCJ4ixN7zgnC-STnsUa^;UNiuM;v8KwPXlV@Uf|8HG2zm@I4MBkpK@LGd!q?E? zAe0E#py6)O6m1R-4Gj$qQ3Q=a4yXUoXbR4c!+CuF^PSt8c3;!3vNjo~tM)MYuJ`QY zDwWx{OwIWSDas5i!4B-gJ`~{qN^k@xP=+%&hYD2TlDL?oAWv8{YOX7aqQe4ckOdXC zxsal$CXb@9DVHJI;D$xfLErCg59SOkg6_Oplv3GF(h#pCXwub~&vaS{ za84F>;iS`ttKA3J(-b#l{Qpn3(v<)EM$9Gq)SX6#;)db*79t2AEg@RY*B0H?Y23L9 Ys^*y2Ej$9l?L5z_l>rKK(NgDr08`dtQUCw| diff --git a/byterun/Makefile b/byterun/Makefile index 969a566c..455495b4 100644 --- a/byterun/Makefile +++ b/byterun/Makefile @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile,v 1.48.4.1 2004/07/16 16:11:33 doligez Exp $ +# $Id: Makefile,v 1.48.4.2 2004/08/20 15:11:36 doligez Exp $ include ../config/Makefile @@ -35,7 +35,7 @@ PRIMS=alloc.c array.c compare.c extern.c floats.c gc_ctrl.c hash.c \ dynlink.c PUBLIC_INCLUDES=alloc.h callback.h config.h custom.h fail.h intext.h \ - memory.h misc.h mlvalues.h signals.h compatibility.h + memory.h misc.h mlvalues.h printexc.h signals.h compatibility.h all: ocamlrun$(EXE) ld.conf diff --git a/byterun/Makefile.nt b/byterun/Makefile.nt index 8c7333bb..cea968eb 100644 --- a/byterun/Makefile.nt +++ b/byterun/Makefile.nt @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.36 2004/05/04 09:03:25 xleroy Exp $ +# $Id: Makefile.nt,v 1.36.4.1 2004/08/20 15:11:36 doligez Exp $ include ../config/Makefile @@ -35,7 +35,7 @@ PRIMS=alloc.c array.c compare.c extern.c floats.c gc_ctrl.c hash.c \ dynlink.c PUBLIC_INCLUDES=alloc.h callback.h config.h custom.h fail.h intext.h \ - memory.h misc.h mlvalues.h signals.h compatibility.h + memory.h misc.h mlvalues.h printexc.h signals.h compatibility.h all: ocamlrun.exe libcamlrun.$(A) diff --git a/byterun/intern.c b/byterun/intern.c index c03166be..10465882 100644 --- a/byterun/intern.c +++ b/byterun/intern.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: intern.c,v 1.58 2004/06/19 16:02:07 xleroy Exp $ */ +/* $Id: intern.c,v 1.58.2.1 2004/11/03 19:47:20 doligez Exp $ */ /* Structured input, compact format */ @@ -381,6 +381,8 @@ static void intern_add_to_heap(mlsize_t whsize) caml_make_free_blocks ((value *) intern_dest, end_extra_block - intern_dest, 0); } + caml_allocated_words += + Wsize_bsize ((char *) intern_dest - intern_extra_block); caml_add_to_heap(intern_extra_block); } } diff --git a/byterun/memory.h b/byterun/memory.h index b03683eb..314d0541 100644 --- a/byterun/memory.h +++ b/byterun/memory.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: memory.h,v 1.50.2.1 2004/07/03 10:01:00 doligez Exp $ */ +/* $Id: memory.h,v 1.50.2.2 2004/11/22 11:16:03 doligez Exp $ */ /* Allocation macros and functions */ @@ -129,8 +129,9 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ call to [CAMLparam] for some other arguments). If you need local variables of type [value], declare them with one - or more calls to the [CAMLlocal] macros. - Use [CAMLlocalN] to declare an array of [value]s. + or more calls to the [CAMLlocal] macros at the beginning of the + function. Use [CAMLlocalN] (at the beginning of the function) to + declare an array of [value]s. Your function may raise an exception or return a [value] with the [CAMLreturn] macro. Its argument is simply the [value] returned by diff --git a/byterun/win32.c b/byterun/win32.c index b3977beb..3218f196 100644 --- a/byterun/win32.c +++ b/byterun/win32.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: win32.c,v 1.23 2004/01/08 22:28:48 doligez Exp $ */ +/* $Id: win32.c,v 1.23.6.1 2004/11/08 13:08:00 xleroy Exp $ */ /* Win32-specific stuff */ @@ -83,17 +83,29 @@ char * caml_search_in_path(struct ext_table * path, char * name) CAMLexport char * caml_search_exe_in_path(char * name) { -#define MAX_PATH_LENGTH 512 - char * fullname = caml_stat_alloc(512); - char * filepart; - - if (! SearchPath(NULL, /* use system search path */ - name, - ".exe", /* add .exe extension if needed */ - MAX_PATH_LENGTH, /* size of buffer */ - fullname, - &filepart)) - strcpy(fullname, name); + char * fullname, * filepart; + DWORD pathlen, retcode; + + pathlen = strlen(name) + 1; + if (pathlen < 256) pathlen = 256; + while (1) { + fullname = stat_alloc(pathlen); + retcode = SearchPath(NULL, /* use system search path */ + name, + ".exe", /* add .exe extension if needed */ + pathlen, + fullname, + &filepart); + if (retcode == 0) { + caml_gc_message(0x100, "%s not found in search path\n", + (unsigned long) name); + strcpy(fullname, name); + break; + } + if (retcode < pathlen) break; + stat_free(fullname); + pathlen = retcode + 1; + } return fullname; } diff --git a/camlp4/CHANGES b/camlp4/CHANGES index 17bafad3..01c486fc 100644 --- a/camlp4/CHANGES +++ b/camlp4/CHANGES @@ -1,3 +1,18 @@ +Camlp4 Version 3.08.2 +------------------------ +- [07 Oct 04] Changes in the interfaces plexer.mli and pcaml.mli: + - plexer.mli: introduced a new lexer building function `make_lexer', + similar to `gmake', but returning a triple of references in addition + (holding respectively the character number of the beginning + of the + current line, the current line number and the name of the file + being + parsed). + - pcaml.mli: a new value `position'. A global reference to a triple like + the one mentioned above. +- [07 Sep 04] Camlp4 grammars `error recovery mode' now issues a warning + when used (but this warning is disabled by default). + +Camlp4 Version 3.08.[01] +------------------------ - [05 Jul 04] creation of the `unmaintained' directory: pa_format, pa_lefteval, pa_ocamllex, pa_olabl, pa_scheme and pa_sml go there, each in its own subdir. Currently, they compile fine. diff --git a/camlp4/camlp4/argl.ml b/camlp4/camlp4/argl.ml index febbf752..030d3efc 100644 --- a/camlp4/camlp4/argl.ml +++ b/camlp4/camlp4/argl.ml @@ -1,5 +1,5 @@ (* camlp4r q_MLast.cmo *) -(* $Id: argl.ml,v 1.14.2.1 2004/06/25 07:08:00 mauny Exp $ *) +(* $Id: argl.ml,v 1.14.2.2 2004/10/07 09:18:13 mauny Exp $ *) open Printf; @@ -167,12 +167,18 @@ value rec parse_file pa getdir useast = phr } and use_file pa getdir useast s = + let (bolpos,lnum,fname) = Pcaml.position.val in let clear = let v_input_file = Pcaml.input_file.val in - fun () -> Pcaml.input_file.val := v_input_file + let (bolp,ln,fn) = (bolpos.val, lnum.val, fname.val) in + fun () -> do { + Pcaml.input_file.val := v_input_file; + bolpos.val := bolp; lnum.val := ln; fname.val := fn + } in do { Pcaml.input_file.val := s; + bolpos.val := 0; lnum.val := 1; fname.val := s; try let r = parse_file pa getdir useast in do { clear (); r } diff --git a/camlp4/camlp4/pcaml.ml b/camlp4/camlp4/pcaml.ml index 2573ad57..bc4f6baa 100644 --- a/camlp4/camlp4/pcaml.ml +++ b/camlp4/camlp4/pcaml.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: pcaml.ml,v 1.13.2.3 2004/07/12 22:33:50 mauny Exp $ *) +(* $Id: pcaml.ml,v 1.13.2.4 2004/10/07 09:18:13 mauny Exp $ *) value version = Sys.ocaml_version; @@ -479,3 +479,7 @@ value string_of pr x = ; value inter_phrases = ref None; + +value position = + ref(ref 0, ref 0, ref "") +; diff --git a/camlp4/camlp4/pcaml.mli b/camlp4/camlp4/pcaml.mli index f14a6eee..00e0c8a9 100644 --- a/camlp4/camlp4/pcaml.mli +++ b/camlp4/camlp4/pcaml.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: pcaml.mli,v 1.7.2.3 2004/07/12 22:33:51 mauny Exp $ *) +(* $Id: pcaml.mli,v 1.7.2.4 2004/10/07 09:18:13 mauny Exp $ *) (** Language grammar, entries and printers. @@ -37,6 +37,11 @@ value parse_implem : default, they use the grammars entries [implem] and [interf] defined below. *) +value position: ref (ref int * ref int * ref string); + (** References holding respectively the character number of the beginning + of the current line, the current line number and the name of the file + being parsed. *) + value gram : Grammar.g; (** Grammar variable of the OCaml language *) diff --git a/camlp4/etc/pa_o.ml b/camlp4/etc/pa_o.ml index 651b6051..62622c86 100644 --- a/camlp4/etc/pa_o.ml +++ b/camlp4/etc/pa_o.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: pa_o.ml,v 1.58.2.1 2004/08/18 11:17:37 mauny Exp $ *) +(* $Id: pa_o.ml,v 1.58.2.3 2004/10/07 09:18:13 mauny Exp $ *) open Stdpp; open Pcaml; @@ -18,10 +18,14 @@ open Pcaml; Pcaml.syntax_name.val := "OCaml"; Pcaml.no_constructors_arity.val := True; +value (lexer, pos) = + Plexer.make_lexer () +; + do { let odfa = Plexer.dollar_for_antiquotation.val in Plexer.dollar_for_antiquotation.val := False; - Grammar.Unsafe.gram_reinit gram (Plexer.gmake ()); + Grammar.Unsafe.gram_reinit gram lexer; Plexer.dollar_for_antiquotation.val := odfa; Grammar.Unsafe.clear_entry interf; Grammar.Unsafe.clear_entry implem; @@ -44,6 +48,7 @@ do { Pcaml.parse_interf.val := Grammar.Entry.parse interf; Pcaml.parse_implem.val := Grammar.Entry.parse implem; +Pcaml.position.val := pos; value o2b = fun @@ -554,7 +559,7 @@ EXTEND <:expr< let module $m$ = $mb$ in $e$ >> | "function"; OPT "|"; l = LIST1 match_case SEP "|" -> <:expr< fun [ $list:l$ ] >> - | "fun"; p = simple_patt; e = fun_def -> + | "fun"; p = patt LEVEL "simple"; e = fun_def -> <:expr< fun [$p$ -> $e$] >> | "match"; e = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" -> <:expr< match $e$ with [ $list:l$ ] >> @@ -715,7 +720,7 @@ EXTEND ; fun_binding: [ RIGHTA - [ p = simple_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> + [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >> | "="; e = expr -> <:expr< $e$ >> | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> ] ] ; @@ -738,7 +743,7 @@ EXTEND ; fun_def: [ RIGHTA - [ p = simple_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> + [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >> | "->"; e = expr -> <:expr< $e$ >> ] ] ; expr_ident: @@ -789,11 +794,7 @@ EXTEND | LEFTA [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ] | "simple" - [ p = simple_patt -> p ] ] - ; - - simple_patt: - [ [ s = LIDENT -> <:patt< $lid:s$ >> + [ s = LIDENT -> <:patt< $lid:s$ >> | s = UIDENT -> <:patt< $uid:s$ >> | s = INT -> <:patt< $int:s$ >> | s = INT32 -> MLast.PaInt32 loc s @@ -988,7 +989,7 @@ EXTEND [ [ "="; ce = class_expr -> ce | ":"; ct = class_type; "="; ce = class_expr -> <:class_expr< ($ce$ : $ct$) >> - | p = simple_patt; cfb = SELF -> + | p = patt LEVEL "simple"; cfb = SELF -> <:class_expr< fun $p$ -> $cfb$ >> ] ] ; class_type_parameters: @@ -996,11 +997,11 @@ EXTEND | "["; tpl = LIST1 type_parameter SEP ","; "]" -> (loc, tpl) ] ] ; class_fun_def: - [ [ p = simple_patt; "->"; ce = class_expr -> + [ [ p = patt LEVEL "simple"; "->"; ce = class_expr -> <:class_expr< fun $p$ -> $ce$ >> | p = labeled_patt; "->"; ce = class_expr -> <:class_expr< fun $p$ -> $ce$ >> - | p = simple_patt; cfd = SELF -> + | p = patt LEVEL "simple"; cfd = SELF -> <:class_expr< fun $p$ -> $cfd$ >> | p = labeled_patt; cfd = SELF -> <:class_expr< fun $p$ -> $cfd$ >> ] ] @@ -1223,7 +1224,7 @@ EXTEND [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ] ; labeled_patt: - [ [ i = LABEL; p = simple_patt -> + [ [ i = LABEL; p = patt LEVEL "simple" -> <:patt< ~ $i$ : $p$ >> | i = TILDEIDENT -> <:patt< ~ $i$ >> diff --git a/camlp4/lib/grammar.ml b/camlp4/lib/grammar.ml index 21ee8899..7a3de032 100644 --- a/camlp4/lib/grammar.ml +++ b/camlp4/lib/grammar.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: grammar.ml,v 1.12 2004/05/12 15:22:42 mauny Exp $ *) +(* $Id: grammar.ml,v 1.12.2.2 2004/11/22 13:41:24 mauny Exp $ *) open Stdpp; open Gramext; @@ -461,10 +461,31 @@ value do_recover parser_of_tree entry nlevn alevn bp a s son = ; value strict_parsing = ref False; +value strict_parsing_warning = ref False; value recover parser_of_tree entry nlevn alevn bp a s son strm = if strict_parsing.val then raise (Stream.Error (tree_failed entry a s son)) - else do_recover parser_of_tree entry nlevn alevn bp a s son strm + else + let _ = + if strict_parsing_warning.val then + do { + let msg = tree_failed entry a s son in + try + let (_,bp2) = floc.val bp in + let c = bp2.Lexing.pos_cnum - bp2.Lexing.pos_bol in + match (bp2.Lexing.pos_fname <> "", c > 0) with [ + (True, True) -> + Printf.eprintf "File \"%s\", line %d, character %d:\n" + bp2.Lexing.pos_fname bp2.Lexing.pos_lnum c + | (False, True) -> Printf.eprintf "Character %d:\n" c + | _ -> () ] + with [ _ -> () ]; + Printf.eprintf "Warning: trying to recover from syntax error"; + if entry.ename <> "" then Printf.eprintf " in [%s]\n" entry.ename + else Printf.eprintf "\n"; + Printf.eprintf "%s\n%!" msg + } else () in + do_recover parser_of_tree entry nlevn alevn bp a s son strm ; value token_count = ref 0; diff --git a/camlp4/lib/grammar.mli b/camlp4/lib/grammar.mli index 5fc21b23..443fcc37 100644 --- a/camlp4/lib/grammar.mli +++ b/camlp4/lib/grammar.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: grammar.mli,v 1.6 2004/05/12 15:22:42 mauny Exp $ *) +(* $Id: grammar.mli,v 1.6.2.1 2004/11/22 13:41:24 mauny Exp $ *) (** Extensible grammars. @@ -165,6 +165,10 @@ value strict_parsing : ref bool; (** Flag to apply strict parsing, without trying to recover errors; default = [False] *) +value strict_parsing_warning : ref bool; + (** Flag for displaying a warning when entering recovery mode; + default = [False] *) + value print_entry : Format.formatter -> Gramext.g_entry 'te -> unit; (** General printer for all kinds of entries (obj entries) *) diff --git a/camlp4/lib/plexer.ml b/camlp4/lib/plexer.ml index 6acc85e0..ffb9c7f6 100644 --- a/camlp4/lib/plexer.ml +++ b/camlp4/lib/plexer.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: plexer.ml,v 1.20.2.2 2004/08/18 11:17:37 mauny Exp $ *) +(* $Id: plexer.ml,v 1.20.2.4 2004/10/07 09:18:13 mauny Exp $ *) open Stdpp; open Token; @@ -316,7 +316,18 @@ value next_token_fun dfa ssd find_kwd fname lnum bolpos glexr = and string bp len = parser [ [: `'"' :] -> len - | [: `'\\'; `c; s :] ep -> string bp (store (store len '\\') c) s + | [: `'\\'; `c; s :] ep -> + let len = store len '\\' in + match c with [ + '\010' -> do { bolpos.val := ep; incr lnum; string bp (store len c) s } + | '\013' -> + let (len, ep) = + match Stream.peek s with [ + Some '\010' -> do { Stream.junk s; (store (store len '\013') '\010', ep+1) } + | _ -> (store len '\013', ep) ] in + do { bolpos.val := ep; incr lnum; string bp len s } + | c -> string bp (store len c) s + ] | [: `'\010'; s :] ep -> do { bolpos.val := ep; incr lnum; string bp (store len '\010') s } | [: `'\013'; s :] ep -> let (len, ep) = @@ -558,7 +569,8 @@ value func kwd_table glexr = let find = Hashtbl.find kwd_table in let dfa = dollar_for_antiquotation.val in let ssd = specific_space_dot.val in - Token.lexer_func_of_parser (next_token_fun dfa ssd find fname lnum bolpos glexr) + (Token.lexer_func_of_parser (next_token_fun dfa ssd find fname lnum bolpos glexr), + (bolpos, lnum, fname)) ; value rec check_keyword_stream = @@ -740,7 +752,7 @@ value tok_match = | tok -> Token.default_match tok ] ; -value gmake () = +value make_lexer () = let kwd_table = Hashtbl.create 301 in let id_table = Hashtbl.create 301 in let glexr = @@ -748,13 +760,18 @@ value gmake () = {tok_func = fun []; tok_using = fun []; tok_removing = fun []; tok_match = fun []; tok_text = fun []; tok_comm = None} in + let (f,pos) = func kwd_table glexr in let glex = - {tok_func = func kwd_table glexr; + {tok_func = f; tok_using = using_token kwd_table id_table; tok_removing = removing_token kwd_table id_table; tok_match = tok_match; tok_text = text; tok_comm = None} in - do { glexr.val := glex; glex } + do { glexr.val := glex; (glex, pos) } +; + +value gmake () = + let (p,_) = make_lexer () in p ; value tparse = @@ -777,6 +794,6 @@ value make () = {tok_func = fun []; tok_using = fun []; tok_removing = fun []; tok_match = fun []; tok_text = fun []; tok_comm = None} in - {func = func kwd_table glexr; using = using_token kwd_table id_table; + {func = fst(func kwd_table glexr); using = using_token kwd_table id_table; removing = removing_token kwd_table id_table; tparse = tparse; text = text} ; diff --git a/camlp4/lib/plexer.mli b/camlp4/lib/plexer.mli index 74106bb7..0ae1ff93 100644 --- a/camlp4/lib/plexer.mli +++ b/camlp4/lib/plexer.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: plexer.mli,v 1.7 2003/07/15 09:13:58 mauny Exp $ *) +(* $Id: plexer.mli,v 1.7.4.1 2004/10/07 09:18:13 mauny Exp $ *) (** A lexical analyzer. *) @@ -50,6 +50,14 @@ value gmake : unit -> Token.glexer Token.t; The lexer do not use global (mutable) variables: instantiations of [Plexer.gmake ()] do not perturb each other. *) +value make_lexer : + unit -> (Token.glexer Token.t * (ref int * ref int * ref string)); + (** [make_lexer] builds a lexer as [gmake does], but returns also + the triple [(bolpos, lnum, fname)] where +- [bolpos] contains the character number of the beginning of the current line, +- [lnum] contains the current line number and +- [fname] contains the name of the file being parsed. *) + value dollar_for_antiquotation : ref bool; (** When True (default), the next call to [Plexer.make ()] returns a lexer where the dollar sign is used for antiquotations. If False, diff --git a/camlp4/meta/pa_r.ml b/camlp4/meta/pa_r.ml index 169a986a..90498d81 100644 --- a/camlp4/meta/pa_r.ml +++ b/camlp4/meta/pa_r.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: pa_r.ml,v 1.59 2004/05/25 18:53:18 mauny Exp $ *) +(* $Id: pa_r.ml,v 1.59.2.1 2004/10/07 09:18:13 mauny Exp $ *) open Stdpp; open Pcaml; @@ -37,10 +37,14 @@ To avoid compilation warning use the new syntax. Pcaml.add_option "-help_seq" (Arg.Unit help_sequences) "Print explanations about new sequences and exit."; +value (lexer, pos) = + Plexer.make_lexer () +; + do { let odfa = Plexer.dollar_for_antiquotation.val in Plexer.dollar_for_antiquotation.val := False; - Grammar.Unsafe.gram_reinit gram (Plexer.gmake ()); + Grammar.Unsafe.gram_reinit gram lexer; Plexer.dollar_for_antiquotation.val := odfa; Grammar.Unsafe.clear_entry interf; Grammar.Unsafe.clear_entry implem; @@ -63,6 +67,7 @@ do { Pcaml.parse_interf.val := Grammar.Entry.parse interf; Pcaml.parse_implem.val := Grammar.Entry.parse implem; +Pcaml.position.val := pos; value o2b = fun diff --git a/camlp4/ocaml_src/camlp4/argl.ml b/camlp4/ocaml_src/camlp4/argl.ml index c85c1c3e..63d8a0d5 100644 --- a/camlp4/ocaml_src/camlp4/argl.ml +++ b/camlp4/ocaml_src/camlp4/argl.ml @@ -172,11 +172,20 @@ let rec parse_file pa getdir useast = in clear (); phr and use_file pa getdir useast s = + let (bolpos, lnum, fname) = !(Pcaml.position) in let clear = let v_input_file = !(Pcaml.input_file) in - fun () -> Pcaml.input_file := v_input_file + let (bolp, ln, fn) = !bolpos, !lnum, !fname in + fun () -> + Pcaml.input_file := v_input_file; + bolpos := bolp; + lnum := ln; + fname := fn in Pcaml.input_file := s; + bolpos := 0; + lnum := 1; + fname := s; try let r = parse_file pa getdir useast in clear (); r with e -> clear (); raise e ;; @@ -297,7 +306,14 @@ let print_usage_list l = let usage ini_sl ext_sl = eprintf "\ -Usage: camlp4 [load-options] [--] [other-options]Load options: -I directory Add directory in search patch for object files. -where Print camlp4 library directory and exit. -nolib No automatic search for object files in library directory. Load this file in Camlp4 core.Other options: Parse this file.\n"; +Usage: camlp4 [load-options] [--] [other-options] +Load options: + -I directory Add directory in search patch for object files. + -where Print camlp4 library directory and exit. + -nolib No automatic search for object files in library directory. + Load this file in Camlp4 core. +Other options: + Parse this file.\n"; print_usage_list ini_sl; begin let rec loop = @@ -317,7 +333,9 @@ Usage: camlp4 [load-options] [--] [other-options]Load options: -I directory Ad let warn_noassert () = eprintf "\ -camlp4 warning: option -noassert is obsoleteYou should give the -noassert option to the ocaml compiler instead." +camlp4 warning: option -noassert is obsolete +You should give the -noassert option to the ocaml compiler instead. +" ;; let initial_spec_list = diff --git a/camlp4/ocaml_src/camlp4/pcaml.ml b/camlp4/ocaml_src/camlp4/pcaml.ml index 9c79b10b..bf78791a 100644 --- a/camlp4/ocaml_src/camlp4/pcaml.ml +++ b/camlp4/ocaml_src/camlp4/pcaml.ml @@ -476,3 +476,5 @@ let string_of pr x = ;; let inter_phrases = ref None;; + +let position = ref (ref 0, ref 0, ref "");; diff --git a/camlp4/ocaml_src/camlp4/pcaml.mli b/camlp4/ocaml_src/camlp4/pcaml.mli index e76dac67..460284d5 100644 --- a/camlp4/ocaml_src/camlp4/pcaml.mli +++ b/camlp4/ocaml_src/camlp4/pcaml.mli @@ -37,6 +37,11 @@ val parse_implem : default, they use the grammars entries [implem] and [interf] defined below. *) +val position : (int ref * int ref * string ref) ref;; + (** References holding respectively the character number of the beginning + of the current line, the current line number and the name of the file + being parsed. *) + val gram : Grammar.g;; (** Grammar variable of the OCaml language *) diff --git a/camlp4/ocaml_src/lib/grammar.ml b/camlp4/ocaml_src/lib/grammar.ml index 3501976d..4067f507 100644 --- a/camlp4/ocaml_src/lib/grammar.ml +++ b/camlp4/ocaml_src/lib/grammar.ml @@ -464,10 +464,32 @@ let do_recover ;; let strict_parsing = ref false;; +let strict_parsing_warning = ref false;; let recover parser_of_tree entry nlevn alevn bp a s son strm = if !strict_parsing then raise (Stream.Error (tree_failed entry a s son)) - else do_recover parser_of_tree entry nlevn alevn bp a s son strm + else + let _ = + if !strict_parsing_warning then + let msg = tree_failed entry a s son in + begin try + let (_, bp2) = !floc bp in + let c = bp2.Lexing.pos_cnum - bp2.Lexing.pos_bol in + match bp2.Lexing.pos_fname <> "", c > 0 with + true, true -> + Printf.eprintf "File \"%s\", line %d, character %d:\n" + bp2.Lexing.pos_fname bp2.Lexing.pos_lnum c + | false, true -> Printf.eprintf "Character %d:\n" c + | _ -> () + with + _ -> () + end; + Printf.eprintf "Warning: trying to recover from syntax error"; + if entry.ename <> "" then Printf.eprintf " in [%s]\n" entry.ename + else Printf.eprintf "\n"; + Printf.eprintf "%s\n%!" msg + in + do_recover parser_of_tree entry nlevn alevn bp a s son strm ;; let token_count = ref 0;; diff --git a/camlp4/ocaml_src/lib/grammar.mli b/camlp4/ocaml_src/lib/grammar.mli index 34dee1b3..becf81a0 100644 --- a/camlp4/ocaml_src/lib/grammar.mli +++ b/camlp4/ocaml_src/lib/grammar.mli @@ -156,6 +156,10 @@ val strict_parsing : bool ref;; (** Flag to apply strict parsing, without trying to recover errors; default = [False] *) +val strict_parsing_warning : bool ref;; + (** Flag for displaying a warning when entering recovery mode; + default = [False] *) + val print_entry : Format.formatter -> 'te Gramext.g_entry -> unit;; (** General printer for all kinds of entries (obj entries) *) diff --git a/camlp4/ocaml_src/lib/plexer.ml b/camlp4/ocaml_src/lib/plexer.ml index 163929bd..57fe1a68 100644 --- a/camlp4/ocaml_src/lib/plexer.ml +++ b/camlp4/ocaml_src/lib/plexer.ml @@ -440,8 +440,21 @@ let next_token_fun dfa ssd find_kwd fname lnum bolpos glexr = begin match Stream.peek strm__ with Some c -> Stream.junk strm__; + let s = strm__ in let ep = Stream.count strm__ in - string bp (store (store len '\\') c) strm__ + let len = store len '\\' in + begin match c with + '\010' -> bolpos := ep; incr lnum; string bp (store len c) s + | '\013' -> + let (len, ep) = + match Stream.peek s with + Some '\010' -> + Stream.junk s; store (store len '\013') '\010', ep + 1 + | _ -> store len '\013', ep + in + bolpos := ep; incr lnum; string bp len s + | c -> string bp (store len c) s + end | _ -> raise (Stream.Error "") end | Some '\010' -> @@ -840,7 +853,8 @@ let func kwd_table glexr = let dfa = !dollar_for_antiquotation in let ssd = !specific_space_dot in Token.lexer_func_of_parser - (next_token_fun dfa ssd find fname lnum bolpos glexr) + (next_token_fun dfa ssd find fname lnum bolpos glexr), + (bolpos, lnum, fname) ;; let rec check_keyword_stream (strm__ : _ Stream.t) = @@ -1050,27 +1064,29 @@ let tok_match = | tok -> Token.default_match tok ;; -let gmake () = +let make_lexer () = let kwd_table = Hashtbl.create 301 in let id_table = Hashtbl.create 301 in let glexr = ref - {tok_func = (fun _ -> raise (Match_failure ("", 748, 17))); - tok_using = (fun _ -> raise (Match_failure ("", 748, 37))); - tok_removing = (fun _ -> raise (Match_failure ("", 748, 60))); - tok_match = (fun _ -> raise (Match_failure ("", 749, 18))); - tok_text = (fun _ -> raise (Match_failure ("", 749, 37))); + {tok_func = (fun _ -> raise (Match_failure ("", 760, 17))); + tok_using = (fun _ -> raise (Match_failure ("", 760, 37))); + tok_removing = (fun _ -> raise (Match_failure ("", 760, 60))); + tok_match = (fun _ -> raise (Match_failure ("", 761, 18))); + tok_text = (fun _ -> raise (Match_failure ("", 761, 37))); tok_comm = None} in + let (f, pos) = func kwd_table glexr in let glex = - {tok_func = func kwd_table glexr; - tok_using = using_token kwd_table id_table; + {tok_func = f; tok_using = using_token kwd_table id_table; tok_removing = removing_token kwd_table id_table; tok_match = tok_match; tok_text = text; tok_comm = None} in - glexr := glex; glex + glexr := glex; glex, pos ;; +let gmake () = let (p, _) = make_lexer () in p;; + let tparse = function "ANTIQUOT", p_prm -> @@ -1089,13 +1105,13 @@ let make () = let id_table = Hashtbl.create 301 in let glexr = ref - {tok_func = (fun _ -> raise (Match_failure ("", 777, 17))); - tok_using = (fun _ -> raise (Match_failure ("", 777, 37))); - tok_removing = (fun _ -> raise (Match_failure ("", 777, 60))); - tok_match = (fun _ -> raise (Match_failure ("", 778, 18))); - tok_text = (fun _ -> raise (Match_failure ("", 778, 37))); + {tok_func = (fun _ -> raise (Match_failure ("", 794, 17))); + tok_using = (fun _ -> raise (Match_failure ("", 794, 37))); + tok_removing = (fun _ -> raise (Match_failure ("", 794, 60))); + tok_match = (fun _ -> raise (Match_failure ("", 795, 18))); + tok_text = (fun _ -> raise (Match_failure ("", 795, 37))); tok_comm = None} in - {func = func kwd_table glexr; using = using_token kwd_table id_table; + {func = fst (func kwd_table glexr); using = using_token kwd_table id_table; removing = removing_token kwd_table id_table; tparse = tparse; text = text} ;; diff --git a/camlp4/ocaml_src/lib/plexer.mli b/camlp4/ocaml_src/lib/plexer.mli index 601c1753..b32a5806 100644 --- a/camlp4/ocaml_src/lib/plexer.mli +++ b/camlp4/ocaml_src/lib/plexer.mli @@ -50,6 +50,14 @@ val gmake : unit -> Token.t Token.glexer;; The lexer do not use global (mutable) variables: instantiations of [Plexer.gmake ()] do not perturb each other. *) +val make_lexer : + unit -> Token.t Token.glexer * (int ref * int ref * string ref);; + (** [make_lexer] builds a lexer as [gmake does], but returns also + the triple [(bolpos, lnum, fname)] where +- [bolpos] contains the character number of the beginning of the current line, +- [lnum] contains the current line number and +- [fname] contains the name of the file being parsed. *) + val dollar_for_antiquotation : bool ref;; (** When True (default), the next call to [Plexer.make ()] returns a lexer where the dollar sign is used for antiquotations. If False, diff --git a/camlp4/ocaml_src/meta/pa_r.ml b/camlp4/ocaml_src/meta/pa_r.ml index b380dbce..710d08bd 100644 --- a/camlp4/ocaml_src/meta/pa_r.ml +++ b/camlp4/ocaml_src/meta/pa_r.ml @@ -19,16 +19,27 @@ Pcaml.no_constructors_arity := false;; let help_sequences () = Printf.eprintf "\ -New syntax: do {e1; e2; ... ; en} while e do {e1; e2; ... ; en} for v = v1 to/downto v2 do {e1; e2; ... ; en}Old (discouraged) syntax: do e1; e2; ... ; en-1; return en while e do e1; e2; ... ; en; done for v = v1 to/downto v2 do e1; e2; ... ; en; doneTo avoid compilation warning use the new syntax."; +New syntax: + do {e1; e2; ... ; en} + while e do {e1; e2; ... ; en} + for v = v1 to/downto v2 do {e1; e2; ... ; en} +Old (discouraged) syntax: + do e1; e2; ... ; en-1; return en + while e do e1; e2; ... ; en; done + for v = v1 to/downto v2 do e1; e2; ... ; en; done +To avoid compilation warning use the new syntax. +"; flush stderr; exit 1 ;; Pcaml.add_option "-help_seq" (Arg.Unit help_sequences) "Print explanations about new sequences and exit.";; +let (lexer, pos) = Plexer.make_lexer ();; + let odfa = !(Plexer.dollar_for_antiquotation) in Plexer.dollar_for_antiquotation := false; -Grammar.Unsafe.gram_reinit gram (Plexer.gmake ()); +Grammar.Unsafe.gram_reinit gram lexer; Plexer.dollar_for_antiquotation := odfa; Grammar.Unsafe.clear_entry interf; Grammar.Unsafe.clear_entry implem; @@ -50,6 +61,7 @@ Grammar.Unsafe.clear_entry class_str_item;; Pcaml.parse_interf := Grammar.Entry.parse interf;; Pcaml.parse_implem := Grammar.Entry.parse implem;; +Pcaml.position := pos;; let o2b = function diff --git a/camlp4/top/camlp4_top.ml b/camlp4/top/camlp4_top.ml index 4f6931a6..e094d7fc 100644 --- a/camlp4/top/camlp4_top.ml +++ b/camlp4/top/camlp4_top.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: camlp4_top.ml,v 1.13 2004/05/12 15:22:48 mauny Exp $ *) +(* $Id: camlp4_top.ml,v 1.13.2.1 2004/10/07 09:18:13 mauny Exp $ *) open Parsetree; open Lexing; @@ -124,9 +124,16 @@ value toplevel_phrase cs = value use_file cs = let v = Pcaml.input_file.val in + let (bolpos,lnum,fname) = Pcaml.position.val in + let restore = + let (bolp,ln,fn) = (bolpos.val, lnum.val, fname.val) in + fun () -> do { + Pcaml.input_file.val := v; + bolpos.val := bolp; lnum.val := ln; fname.val := fn + } in do { Pcaml.input_file.val := Toploop.input_name.val; - let restore () = Pcaml.input_file.val := v in + bolpos.val := 0; lnum.val := 1; fname.val := Toploop.input_name.val; try let (pl0, eoi) = loop () where rec loop () = diff --git a/configure b/configure index ce500436..d30207bb 100755 --- a/configure +++ b/configure @@ -13,7 +13,7 @@ # # ######################################################################### -# $Id: configure,v 1.215.2.6 2004/08/12 16:02:00 xleroy Exp $ +# $Id: configure,v 1.215.2.8 2004/11/18 14:08:57 doligez Exp $ configure_options="$*" prefix=/usr/local @@ -1354,11 +1354,12 @@ if test $has_tk = true; then *) echo "This version is not known."; has_tk=false ;; esac else - echo "tcl.h not found." + echo "tcl.h and/or tk.h not found." has_tk=false fi fi +# FIXME redundant? if test $has_tk = true; then if sh ./hasgot $tk_x11_include $tk_defs -i tk.h; then echo "tk.h found." @@ -1558,5 +1559,9 @@ echo " use tcl/tk version ....... $tcl_version" echo " options for compiling .... $tk_defs" echo " options for linking ...... $tk_libs" else -echo "The \"labltk\" library: not found" +echo "The \"labltk\" library: not supported" fi + +echo +echo "** Objective Caml configuration completed successfully **" +echo diff --git a/emacs/caml-types.el b/emacs/caml-types.el index 6870658f..11f870de 100644 --- a/emacs/caml-types.el +++ b/emacs/caml-types.el @@ -10,7 +10,7 @@ ;(* *) ;(***********************************************************************) -;(* $Id: caml-types.el,v 1.29.6.1 2004/08/09 16:09:33 doligez Exp $ *) +;(* $Id: caml-types.el,v 1.29.6.2 2004/11/15 12:50:54 doligez Exp $ *) ; An emacs-lisp complement to the "-dtypes" option of ocamlc and ocamlopt. @@ -112,8 +112,8 @@ For the moment, the only possible keyword is \"type\"." . Even if type checking fails, you can still look at the types in the file, up to where the type checker failed. -Types are also diplayed in the buffer *caml-types*, which buffer is -display when the commande is called with Prefix argument 4. +Types are also displayed in the buffer *caml-types*, which is +displayed when the command is called with Prefix argument 4. See also `caml-types-explore' for exploration by mouse dragging. See `caml-types-location-re' for annotation file format. diff --git a/emacs/caml-xemacs.el b/emacs/caml-xemacs.el index aa5ef7f9..c066c794 100644 --- a/emacs/caml-xemacs.el +++ b/emacs/caml-xemacs.el @@ -10,7 +10,7 @@ ;(* *) ;(***********************************************************************) -;(* $Id: caml-xemacs.el,v 1.5.6.1 2004/08/09 16:09:33 doligez Exp $ *) +;(* $Id: caml-xemacs.el,v 1.5.6.2 2004/11/02 10:21:03 doligez Exp $ *) (require 'overlay) @@ -40,8 +40,8 @@ (defun caml-sit-for (sec &optional mili) - (sit-for (+ sec (if mili (* 0.001 mili))))) - + (sit-for (+ sec (if mili (* 0.001 mili) 0)))) + (defmacro caml-track-mouse (&rest body) (cons 'progn body)) diff --git a/ocamldoc/Changes.txt b/ocamldoc/Changes.txt index e7f1045b..ce6bf4e5 100644 --- a/ocamldoc/Changes.txt +++ b/ocamldoc/Changes.txt @@ -3,6 +3,10 @@ TODO: - latex: types variant polymorphes dépassent de la page quand ils sont trop longs - utilisation nouvelles infos de Xavier: "début de rec", etc. +===== +Release 3.08.2: + - fix: error "Lexing: empty token" (PR#3173) + ===== Release 3.08.1: - add: new -intf and -impl options supported (PR#3036) diff --git a/ocamldoc/odoc_misc.ml b/ocamldoc/odoc_misc.ml index e3bc664f..a8109256 100644 --- a/ocamldoc/odoc_misc.ml +++ b/ocamldoc/odoc_misc.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_misc.ml,v 1.17.4.1 2004/08/06 12:35:07 guesdon Exp $ *) +(* $Id: odoc_misc.ml,v 1.17.4.2 2004/10/01 09:43:24 guesdon Exp $ *) let input_file_as_string nom = let chanin = open_in_bin nom in @@ -79,13 +79,13 @@ let get_fields type_expr = fields let rec string_of_text t = - let rec iter t_ele = + let rec iter t_ele = match t_ele with | Odoc_types.Raw s | Odoc_types.Code s | Odoc_types.CodePre s | Odoc_types.Verbatim s -> s - | Odoc_types.Bold t + | Odoc_types.Bold t | Odoc_types.Italic t | Odoc_types.Center t | Odoc_types.Left t @@ -121,7 +121,7 @@ let rec string_of_text t = (List.map (fun s -> Odoc_types.Code s) l) ) | Odoc_types.Index_list -> - "" + "" in String.concat "" (List.map iter t) @@ -158,7 +158,7 @@ let string_of_raised_exceptions l = )^"\n" let string_of_see (see_ref, t) = - let t_ref = + let t_ref = match see_ref with Odoc_types.See_url s -> [ Odoc_types.Link (s, t) ] | Odoc_types.See_file s -> (Odoc_types.Code s) :: (Odoc_types.Raw " ") :: t @@ -190,7 +190,7 @@ let string_of_info i = None -> "" | Some d -> Odoc_messages.deprecated^"! "^(string_of_text d)^"\n")^ (match i.M.i_desc with - None -> "" + None -> "" | Some d when d = [Odoc_types.Raw ""] -> "" | Some d -> (string_of_text d)^"\n" )^ @@ -205,14 +205,14 @@ let apply_opt f v_opt = None -> None | Some v -> Some (f v) -let string_of_date ?(hour=true) d = +let string_of_date ?(hour=true) d = let add_0 s = if String.length s < 2 then "0"^s else s in let t = Unix.localtime d in (string_of_int (t.Unix.tm_year + 1900))^"-"^ (add_0 (string_of_int (t.Unix.tm_mon + 1)))^"-"^ (add_0 (string_of_int t.Unix.tm_mday))^ ( - if hour then + if hour then " "^ (add_0 (string_of_int t.Unix.tm_hour))^":"^ (add_0 (string_of_int t.Unix.tm_min)) @@ -229,14 +229,14 @@ let rec text_list_concat sep l = t @ (sep :: (text_list_concat sep q)) let rec text_no_title_no_list t = - let rec iter t_ele = + let rec iter t_ele = match t_ele with | Odoc_types.Title (_,_,t) -> text_no_title_no_list t | Odoc_types.List l - | Odoc_types.Enum l -> + | Odoc_types.Enum l -> (Odoc_types.Raw " ") :: (text_list_concat - (Odoc_types.Raw ", ") + (Odoc_types.Raw ", ") (List.map text_no_title_no_list l)) | Odoc_types.Raw _ | Odoc_types.Code _ @@ -256,7 +256,7 @@ let rec text_no_title_no_list t = | Odoc_types.Superscript t -> [Odoc_types.Superscript (text_no_title_no_list t)] | Odoc_types.Subscript t -> [Odoc_types.Subscript (text_no_title_no_list t)] | Odoc_types.Module_list l -> - list_concat (Odoc_types.Raw ", ") + list_concat (Odoc_types.Raw ", ") (List.map (fun s -> Odoc_types.Ref (s, Some Odoc_types.RK_module)) l @@ -271,7 +271,7 @@ let get_titles_in_text t = match ele with | Odoc_types.Title (n,lopt,t) -> l := (n,lopt,t) :: !l | Odoc_types.List l - | Odoc_types.Enum l -> List.iter iter_text l + | Odoc_types.Enum l -> List.iter iter_text l | Odoc_types.Raw _ | Odoc_types.Code _ | Odoc_types.CodePre _ @@ -287,17 +287,17 @@ let get_titles_in_text t = | Odoc_types.Emphasize t -> iter_text t | Odoc_types.Latex s -> () | Odoc_types.Link (_, t) - | Odoc_types.Superscript t + | Odoc_types.Superscript t | Odoc_types.Subscript t -> iter_text t | Odoc_types.Module_list _ -> () | Odoc_types.Index_list -> () - and iter_text te = + and iter_text te = List.iter iter_ele te in iter_text t; List.rev !l -let text_concat (sep : Odoc_types.text) l = +let text_concat (sep : Odoc_types.text) l = let rec iter = function [] -> [] | [last] -> last @@ -329,8 +329,8 @@ let rec first_sentence_text t = [] -> (false, [], []) | ele :: q -> let (stop, ele2, ele3_opt) = first_sentence_text_ele ele in - if stop then - (stop, [ele2], + if stop then + (stop, [ele2], match ele3_opt with None -> q | Some e -> e :: q) else let (stop2, q2, rest) = first_sentence_text q in @@ -339,11 +339,11 @@ let rec first_sentence_text t = and first_sentence_text_ele text_ele = match text_ele with - | Odoc_types.Raw s -> + | Odoc_types.Raw s -> let b, s2, s_after = get_before_dot s in (b, Odoc_types.Raw s2, Some (Odoc_types.Raw s_after)) - | Odoc_types.Code _ - | Odoc_types.CodePre _ + | Odoc_types.Code _ + | Odoc_types.CodePre _ | Odoc_types.Verbatim _ -> (false, text_ele, None) | Odoc_types.Bold t -> let (b, t2, t3) = first_sentence_text t in @@ -363,28 +363,28 @@ and first_sentence_text_ele text_ele = | Odoc_types.Emphasize t -> let (b, t2, t3) = first_sentence_text t in (b, Odoc_types.Emphasize t2, Some (Odoc_types.Emphasize t3)) - | Odoc_types.Block t -> + | Odoc_types.Block t -> let (b, t2, t3) = first_sentence_text t in (b, Odoc_types.Block t2, Some (Odoc_types.Block t3)) | Odoc_types.Title (n, l_opt, t) -> let (b, t2, t3) = first_sentence_text t in - (b, - Odoc_types.Title (n, l_opt, t2), + (b, + Odoc_types.Title (n, l_opt, t2), Some (Odoc_types.Title (n, l_opt, t3))) | Odoc_types.Newline -> (true, Odoc_types.Raw "", Some Odoc_types.Newline) | Odoc_types.List _ | Odoc_types.Enum _ | Odoc_types.Latex _ - | Odoc_types.Link _ - | Odoc_types.Ref _ - | Odoc_types.Superscript _ - | Odoc_types.Subscript _ - | Odoc_types.Module_list _ + | Odoc_types.Link _ + | Odoc_types.Ref _ + | Odoc_types.Superscript _ + | Odoc_types.Subscript _ + | Odoc_types.Module_list _ | Odoc_types.Index_list -> (false, text_ele, None) -let first_sentence_of_text t = - let (_,t2,_) = first_sentence_text t in +let first_sentence_of_text t = + let (_,t2,_) = first_sentence_text t in t2 let first_sentence_and_rest_of_text t = @@ -400,6 +400,25 @@ let remove_ending_newline s = '\n' -> String.sub s 0 (len-1) | _ -> s +let search_string_backward ~pat = + let lenp = String.length pat in + let rec iter s = + let len = String.length s in + match compare len lenp with + -1 -> raise Not_found + | 0 -> if pat = s then 0 else raise Not_found + | _ -> + let pos = len - lenp in + let s2 = String.sub s pos lenp in + if s2 = pat then + pos + else + iter (String.sub s 0 pos) + in + fun ~s -> iter s + + + (*********************************************************) let create_index_lists elements string_of_ele = @@ -436,15 +455,15 @@ let remove_option typ = | Types.Tvar | Types.Tunivar | Types.Tpoly _ - | Types.Tarrow _ - | Types.Ttuple _ + | Types.Tarrow _ + | Types.Ttuple _ | Types.Tobject _ | Types.Tfield _ - | Types.Tnil + | Types.Tnil | Types.Tvariant _ -> t | Types.Tlink t2 | Types.Tsubst t2 -> iter t2.Types.desc in { typ with Types.desc = iter typ.Types.desc } -(* eof $Id: odoc_misc.ml,v 1.17.4.1 2004/08/06 12:35:07 guesdon Exp $ *) +(* eof $Id: odoc_misc.ml,v 1.17.4.2 2004/10/01 09:43:24 guesdon Exp $ *) diff --git a/ocamldoc/odoc_misc.mli b/ocamldoc/odoc_misc.mli index eab8b0c1..0d78f2d5 100644 --- a/ocamldoc/odoc_misc.mli +++ b/ocamldoc/odoc_misc.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_misc.mli,v 1.10.4.1 2004/08/06 12:35:07 guesdon Exp $ *) +(* $Id: odoc_misc.mli,v 1.10.4.2 2004/10/01 09:43:24 guesdon Exp $ *) (** Miscelaneous functions *) @@ -69,7 +69,7 @@ val first_sentence_of_text : Odoc_types.text -> Odoc_types.text and the remaining text after. Don't stop in the middle of [Code], [Verbatim], [List], [Lnum], [Latex], [Link], or [Ref]. *) -val first_sentence_and_rest_of_text : +val first_sentence_and_rest_of_text : Odoc_types.text -> Odoc_types.text * Odoc_types.text (** Return the given [text] without any title or list. *) @@ -79,12 +79,12 @@ val text_no_title_no_list : Odoc_types.text -> Odoc_types.text the text [sep]. *) val text_concat : Odoc_types.text -> Odoc_types.text list -> Odoc_types.text -(** Return the list of titles in a [text]. +(** Return the list of titles in a [text]. A title is a title level, an optional label and a text.*) val get_titles_in_text : Odoc_types.text -> (int * string option * Odoc_types.text) list (** Take a sorted list of elements, a function to get the name - of an element and return the list of list of elements, + of an element and return the list of list of elements, where each list group elements beginning by the same letter. Since the original list is sorted, elements whose name does not begin with a letter should be in the first returned list.*) @@ -93,6 +93,10 @@ val create_index_lists : 'a list -> ('a -> string) -> 'a list list (** [remove_ending_newline s] returns [s] without the optional ending newline. *) val remove_ending_newline : string -> string +(** [search_string_backward pat s] searches backward string [pat] in string [s]. + Return position in string [s] where [pat] appears, orelse raise [Not_found]. *) +val search_string_backward : pat: string -> s: string -> int + (** Take a type and remove the option top constructor. This is useful when printing labels, we we then remove the top option contructor for optional labels.*) diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index 659874da..d02deae2 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_sig.ml,v 1.30.2.2 2004/07/02 12:59:48 guesdon Exp $ *) +(* $Id: odoc_sig.ml,v 1.30.2.3 2004/10/01 09:43:24 guesdon Exp $ *) (** Analysis of interface files. *) @@ -32,7 +32,7 @@ open Odoc_types module Signature_search = struct - type ele = + type ele = | M of string | MT of string | V of string @@ -109,7 +109,7 @@ module Signature_search = let search_attribute_type name class_sig = let (_, type_expr) = Types.Vars.find name class_sig.Types.cty_vars in type_expr - + let search_method_type name class_sig = let fields = Odoc_misc.get_fields class_sig.Types.cty_self in List.assoc name fields @@ -121,11 +121,11 @@ module type Info_retriever = val blank_line_outside_simple : string -> string -> bool val just_after_special : string -> string -> (int * Odoc_types.info option) val first_special : string -> string -> (int * Odoc_types.info option) - val get_comments : + val get_comments : (Odoc_types.text -> 'a) -> string -> string -> (Odoc_types.info option * 'a list) end -module Analyser = +module Analyser = functor (My_ir : Info_retriever) -> struct (** This variable is used to load a file as a string and retrieve characters from it.*) @@ -158,23 +158,23 @@ module Analyser = (** The function used to get the comments in a class. *) let get_comments_in_class pos_start pos_end = - My_ir.get_comments (fun t -> Class_comment t) + My_ir.get_comments (fun t -> Class_comment t) !file_name (get_string_of_file pos_start pos_end) (** The function used to get the comments in a module. *) let get_comments_in_module pos_start pos_end = - My_ir.get_comments (fun t -> Element_module_comment t) + My_ir.get_comments (fun t -> Element_module_comment t) !file_name (get_string_of_file pos_start pos_end) - let merge_infos = Odoc_merge.merge_info_opt Odoc_types.all_merge_options + let merge_infos = Odoc_merge.merge_info_opt Odoc_types.all_merge_options let name_comment_from_type_kind pos_start pos_end pos_limit tk = match tk with Parsetree.Ptype_abstract -> (0, []) - | Parsetree.Ptype_variant (cons_core_type_list_list, _) -> + | Parsetree.Ptype_variant (cons_core_type_list_list, _) -> (*of (string * core_type list) list *) let rec f acc last_pos cons_core_type_list_list = match cons_core_type_list_list with @@ -191,11 +191,13 @@ module Analyser = ([], []) -> let pos = Str.search_forward (Str.regexp_string name) !file last_pos in let pos' = pos + (String.length name) in - let pos2 = Str.search_forward (Str.regexp_string name2) !file pos' in + let pos2 = Str.search_forward + (Str.regexp ("|[ \n\t\r]*"^name2)) !file pos' + in let s = get_string_of_file pos' pos2 in let (_,comment_opt) = My_ir.just_after_special !file_name s in f (acc @ [name, comment_opt]) pos2 ((name2, core_type_list2) :: q) - + | ([], (ct2 :: _)) -> let pos = Str.search_forward (Str.regexp_string name) !file last_pos in let pos' = pos + (String.length name) in @@ -204,10 +206,13 @@ module Analyser = let s = get_string_of_file pos' pos2' in let (_,comment_opt) = My_ir.just_after_special !file_name s in f (acc @ [name, comment_opt]) pos2' ((name2, core_type_list2) :: q) - - | ((ct :: _), _) -> + + | ((ct :: _), []) -> let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in - let pos2 = Str.search_forward (Str.regexp_string name2) !file pos in + let pos2 = Str.search_forward + (Str.regexp ("|[ \n\t\r]*"^name2)) + !file pos + in let s = get_string_of_file pos pos2 in let (_,comment_opt) = My_ir.just_after_special !file_name s in let new_pos_end = @@ -216,9 +221,18 @@ module Analyser = | Some _ -> Str.search_forward (Str.regexp "*)") !file pos in f (acc @ [name, comment_opt]) new_pos_end ((name2, core_type_list2) :: q) + + | ((ct:: _), (ct2 :: _)) -> + let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in + let pos2 = ct2.Parsetree.ptyp_loc.Location.loc_start.Lexing.pos_cnum in + let pos2' = Str.search_backward (Str.regexp_string name2) !file pos2 in + let s = get_string_of_file pos pos2' in + let (_,comment_opt) = My_ir.just_after_special !file_name s in + f (acc @ [name, comment_opt]) pos2' ((name2, core_type_list2) :: q) + in f [] pos_start cons_core_type_list_list - + | Parsetree.Ptype_record (name_mutable_type_list, _) (* of (string * mutable_flag * core_type) list*) -> let rec f = function [] -> @@ -244,8 +258,8 @@ module Analyser = | Types.Type_variant (l, priv) -> let f (constructor_name, type_expr_list) = - let comment_opt = - try + let comment_opt = + try match List.assoc constructor_name name_comment_list with None -> None | Some d -> d.Odoc_types.i_desc @@ -255,14 +269,14 @@ module Analyser = vc_name = constructor_name ; vc_args = List.map (Odoc_env.subst_type env) type_expr_list ; vc_text = comment_opt - } + } in Odoc_type.Type_variant (List.map f l, priv = Asttypes.Private) | Types.Type_record (l, _, priv) -> let f (field_name, mutable_flag, type_expr) = - let comment_opt = - try + let comment_opt = + try match List.assoc field_name name_comment_list with None -> None | Some d -> d.Odoc_types.i_desc @@ -273,13 +287,13 @@ module Analyser = rf_mutable = mutable_flag = Mutable ; rf_type = Odoc_env.subst_type env type_expr ; rf_text = comment_opt - } + } in Odoc_type.Type_record (List.map f l, priv = Asttypes.Private) (** Analysis of the elements of a class, from the information in the parsetree and in the class signature. @return the couple (inherited_class list, elements).*) - let analyse_class_elements env current_class_name last_pos pos_limit + let analyse_class_elements env current_class_name last_pos pos_limit class_type_field_list class_signature = print_DEBUG "Types.Tcty_signature class_signature"; let f_DEBUG var (mutable_flag, type_exp) = print_DEBUG var in @@ -291,7 +305,7 @@ module Analyser = [] -> pos_limit | ele2 :: _ -> match ele2 with - Parsetree.Pctf_val (_, _, _, loc) + Parsetree.Pctf_val (_, _, _, loc) | Parsetree.Pctf_virt (_, _, _, loc) | Parsetree.Pctf_meth (_, _, _, loc) | Parsetree.Pctf_cstr (_, _, loc) -> loc.Location.loc_start.Lexing.pos_cnum @@ -300,7 +314,7 @@ module Analyser = in let get_method name comment_opt private_flag loc q = let complete_name = Name.concat current_class_name name in - let typ = + let typ = try Signature_search.search_method_type name class_signature with Not_found -> raise (Failure (Odoc_messages.method_type_not_found current_class_name name)) @@ -308,7 +322,7 @@ module Analyser = let subst_typ = Odoc_env.subst_type env typ in let met = { - met_value = + met_value = { val_name = complete_name ; val_info = comment_opt ; @@ -324,7 +338,7 @@ module Analyser = in let pos_limit2 = get_pos_limit2 q in let pos_end = loc.Location.loc_end.Lexing.pos_cnum in - let (maybe_more, info_after_opt) = + let (maybe_more, info_after_opt) = My_ir.just_after_special !file_name (get_string_of_file pos_end pos_limit2) @@ -356,7 +370,7 @@ module Analyser = (* of (string * mutable_flag * core_type option * Location.t)*) let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in let complete_name = Name.concat current_class_name name in - let typ = + let typ = try Signature_search.search_attribute_type name class_signature with Not_found -> raise (Failure (Odoc_messages.attribute_type_not_found current_class_name name)) @@ -364,7 +378,7 @@ module Analyser = let subst_typ = Odoc_env.subst_type env typ in let att = { - att_value = + att_value = { val_name = complete_name ; val_info = comment_opt ; @@ -375,11 +389,11 @@ module Analyser = val_loc = { loc_impl = None ; loc_inter = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum)} ; } ; att_mutable = mutable_flag = Asttypes.Mutable ; - } + } in let pos_limit2 = get_pos_limit2 q in let pos_end = loc.Location.loc_end.Lexing.pos_cnum in - let (maybe_more, info_after_opt) = + let (maybe_more, info_after_opt) = My_ir.just_after_special !file_name (get_string_of_file pos_end pos_limit2) @@ -409,36 +423,36 @@ module Analyser = let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in let (inher_l, eles) = f loc.Location.loc_end.Lexing.pos_cnum q in (inher_l, eles_comments @ eles) - + | Parsetree.Pctf_inher class_type :: q -> let loc = class_type.Parsetree.pcty_loc in - let (comment_opt, eles_comments) = + let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in let pos_limit2 = get_pos_limit2 q in let pos_end = loc.Location.loc_end.Lexing.pos_cnum in - let (maybe_more, info_after_opt) = + let (maybe_more, info_after_opt) = My_ir.just_after_special !file_name (get_string_of_file pos_end pos_limit2) in let comment_opt2 = merge_infos comment_opt info_after_opt in let text_opt = match comment_opt2 with None -> None | Some i -> i.Odoc_types.i_desc in - let inh = + let inh = match class_type.Parsetree.pcty_desc with Parsetree.Pcty_constr (longident, _) -> (*of Longident.t * core_type list*) let name = Name.from_longident longident in - let ic = + let ic = { ic_name = Odoc_env.full_class_or_class_type_name env name ; ic_class = None ; ic_text = text_opt ; - } + } in ic - - | Parsetree.Pcty_signature _ + + | Parsetree.Pcty_signature _ | Parsetree.Pcty_fun _ -> (* we don't have a name for the class signature, so we call it "object ... end" *) { @@ -476,7 +490,7 @@ module Analyser = acc_eles @ ele_comments | ele :: q -> - let (assoc_com, ele_comments) = get_comments_in_module + let (assoc_com, ele_comments) = get_comments_in_module last_pos ele.Parsetree.psig_loc.Location.loc_start.Lexing.pos_cnum in @@ -487,8 +501,8 @@ module Analyser = current_module_name ele.Parsetree.psig_loc.Location.loc_start.Lexing.pos_cnum ele.Parsetree.psig_loc.Location.loc_end.Lexing.pos_cnum - (match q with - [] -> pos_limit + (match q with + [] -> pos_limit | ele2 :: _ -> ele2.Parsetree.psig_loc.Location.loc_start.Lexing.pos_cnum ) assoc_com @@ -496,8 +510,8 @@ module Analyser = in f (acc_eles @ (ele_comments @ elements)) new_env - (ele.Parsetree.psig_loc.Location.loc_end.Lexing.pos_cnum + maybe_more) - (* for the comments of constructors in types, + (ele.Parsetree.psig_loc.Location.loc_end.Lexing.pos_cnum + maybe_more) + (* for the comments of constructors in types, which are after the constructor definition and can go beyond ele.Parsetree.psig_loc.Location.loc_end.Lexing.pos_cnum *) q @@ -506,18 +520,18 @@ module Analyser = (** Analyse the given signature_item_desc to create the corresponding module element (with the given attached comment).*) - and analyse_signature_item_desc env signat table current_module_name + and analyse_signature_item_desc env signat table current_module_name pos_start_ele pos_end_ele pos_limit comment_opt sig_item_desc = match sig_item_desc with Parsetree.Psig_value (name_pre, value_desc) -> - let type_expr = + let type_expr = try Signature_search.search_value table name_pre with Not_found -> raise (Failure (Odoc_messages.value_not_found current_module_name name_pre)) in let name = Name.parens_if_infix name_pre in let subst_typ = Odoc_env.subst_type env type_expr in - let v = + let v = { val_name = Name.concat current_module_name name ; val_info = comment_opt ; @@ -526,9 +540,9 @@ module Analyser = val_parameters = Odoc_value.dummy_parameter_list subst_typ ; val_code = None ; val_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele)} - } + } in - let (maybe_more, info_after_opt) = + let (maybe_more, info_after_opt) = My_ir.just_after_special !file_name (get_string_of_file pos_end_ele pos_limit) @@ -541,28 +555,28 @@ module Analyser = (maybe_more, new_env, [ Element_value v ]) | Parsetree.Psig_exception (name, exception_decl) -> - let types_excep_decl = - try Signature_search.search_exception table name - with Not_found -> + let types_excep_decl = + try Signature_search.search_exception table name + with Not_found -> raise (Failure (Odoc_messages.exception_not_found current_module_name name)) in let e = - { + { ex_name = Name.concat current_module_name name ; ex_info = comment_opt ; ex_args = List.map (Odoc_env.subst_type env) types_excep_decl ; ex_alias = None ; ex_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ; - ex_code = + ex_code = ( if !Odoc_args.keep_code then Some (get_string_of_file pos_start_ele pos_end_ele) else None ) ; - } + } in - let (maybe_more, info_after_opt) = + let (maybe_more, info_after_opt) = My_ir.just_after_special !file_name (get_string_of_file pos_end_ele pos_limit) @@ -574,7 +588,7 @@ module Analyser = | Parsetree.Psig_type name_type_decl_list -> (* we start by extending the environment *) let new_env = - List.fold_left + List.fold_left (fun acc_env -> fun (name, _) -> let complete_name = Name.concat current_module_name name in Odoc_env.add_type acc_env complete_name @@ -584,7 +598,7 @@ module Analyser = in let rec f ?(first=false) acc_maybe_more last_pos name_type_decl_list = match name_type_decl_list with - [] -> + [] -> (acc_maybe_more, []) | (name, type_decl) :: q -> let (assoc_com, ele_comments) = @@ -600,7 +614,7 @@ module Analyser = [] -> pos_limit | (_, td) :: _ -> td.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum in - let (maybe_more, name_comment_list) = + let (maybe_more, name_comment_list) = name_comment_from_type_kind type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum type_decl.Parsetree.ptype_loc.Location.loc_end.Lexing.pos_cnum @@ -611,8 +625,8 @@ module Analyser = let f_DEBUG (name, c_opt) = print_DEBUG ("constructor/field "^name^": "^(match c_opt with None -> "sans commentaire" | Some c -> Odoc_misc.string_of_info c)) in List.iter f_DEBUG name_comment_list; (* get the information for the type in the signature *) - let sig_type_decl = - try Signature_search.search_type table name + let sig_type_decl = + try Signature_search.search_type table name with Not_found -> raise (Failure (Odoc_messages.type_not_found current_module_name name)) in @@ -625,38 +639,38 @@ module Analyser = { ty_name = Name.concat current_module_name name ; ty_info = assoc_com ; - ty_parameters = + ty_parameters = List.map2 (fun p (co,cn,_) -> (Odoc_env.subst_type new_env p, co, cn) - ) - sig_type_decl.Types.type_params + ) + sig_type_decl.Types.type_params sig_type_decl.Types.type_variance; ty_kind = type_kind ; - ty_manifest = + ty_manifest = (match sig_type_decl.Types.type_manifest with None -> None | Some t -> Some (Odoc_env.subst_type new_env t)); - ty_loc = - { loc_impl = None ; + ty_loc = + { loc_impl = None ; loc_inter = Some (!file_name,loc_start) ; }; - ty_code = + ty_code = ( if !Odoc_args.keep_code then - Some (get_string_of_file loc_start new_end) + Some (get_string_of_file loc_start new_end) else None ) ; } in - let (maybe_more2, info_after_opt) = + let (maybe_more2, info_after_opt) = My_ir.just_after_special !file_name (get_string_of_file new_end pos_limit2) in new_type.ty_info <- merge_infos new_type.ty_info info_after_opt ; - let (new_maybe_more, eles) = f + let (new_maybe_more, eles) = f (maybe_more + maybe_more2) (new_end + maybe_more2) q @@ -665,7 +679,7 @@ module Analyser = in let (maybe_more, types) = f ~first: true 0 pos_start_ele name_type_decl_list in (maybe_more, new_env, types) - + | Parsetree.Psig_open _ -> (* A VOIR *) let ele_comments = match comment_opt with None -> [] @@ -679,13 +693,13 @@ module Analyser = | Parsetree.Psig_module (name, module_type) -> let complete_name = Name.concat current_module_name name in (* get the the module type in the signature by the module name *) - let sig_module_type = - try Signature_search.search_module table name + let sig_module_type = + try Signature_search.search_module table name with Not_found -> raise (Failure (Odoc_messages.module_not_found current_module_name name)) in let module_kind = analyse_module_kind env complete_name module_type sig_module_type in - let code_intf = + let code_intf = if !Odoc_args.keep_code then let loc = module_type.Parsetree.pmty_loc in let st = loc.Location.loc_start.Lexing.pos_cnum in @@ -694,7 +708,7 @@ module Analyser = else None in - let new_module = + let new_module = { m_name = complete_name ; m_type = sig_module_type; @@ -706,16 +720,16 @@ module Analyser = m_top_deps = [] ; m_code = None ; m_code_intf = code_intf ; - } + } in - let (maybe_more, info_after_opt) = + let (maybe_more, info_after_opt) = My_ir.just_after_special !file_name (get_string_of_file pos_end_ele pos_limit) in new_module.m_info <- merge_infos new_module.m_info info_after_opt ; let new_env = Odoc_env.add_module env new_module.m_name in - let new_env2 = + let new_env2 = match new_module.m_type with (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *) Types.Tmty_signature s -> Odoc_env.add_signature new_env new_module.m_name ~rel: (Name.simple new_module.m_name) s | _ -> new_env @@ -725,21 +739,21 @@ module Analyser = | Parsetree.Psig_recmodule decls -> (* we start by extending the environment *) let new_env = - List.fold_left + List.fold_left (fun acc_env -> fun (name, _) -> let complete_name = Name.concat current_module_name name in let e = Odoc_env.add_module acc_env complete_name in (* get the information for the module in the signature *) - let sig_module_type = - try Signature_search.search_module table name + let sig_module_type = + try Signature_search.search_module table name with Not_found -> raise (Failure (Odoc_messages.module_not_found current_module_name name)) in match sig_module_type with (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *) - Types.Tmty_signature s -> + Types.Tmty_signature s -> Odoc_env.add_signature e complete_name ~rel: name s - | _ -> + | _ -> print_DEBUG "not a Tmty_signature"; e ) @@ -748,7 +762,7 @@ module Analyser = in let rec f ?(first=false) acc_maybe_more last_pos name_mtype_list = match name_mtype_list with - [] -> + [] -> (acc_maybe_more, []) | (name, modtype) :: q -> let complete_name = Name.concat current_module_name name in @@ -768,14 +782,14 @@ module Analyser = | (_, mty) :: _ -> mty.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in (* get the information for the module in the signature *) - let sig_module_type = - try Signature_search.search_module table name + let sig_module_type = + try Signature_search.search_module table name with Not_found -> raise (Failure (Odoc_messages.module_not_found current_module_name name)) in (* associate the comments to each constructor and build the [Type.t_type] *) let module_kind = analyse_module_kind new_env complete_name modtype sig_module_type in - let code_intf = + let code_intf = if !Odoc_args.keep_code then let loc = modtype.Parsetree.pmty_loc in let st = loc.Location.loc_start.Lexing.pos_cnum in @@ -784,7 +798,7 @@ module Analyser = else None in - let new_module = + let new_module = { m_name = complete_name ; m_type = sig_module_type; @@ -796,16 +810,16 @@ module Analyser = m_top_deps = [] ; m_code = None ; m_code_intf = code_intf ; - } + } in - let (maybe_more, info_after_opt) = + let (maybe_more, info_after_opt) = My_ir.just_after_special !file_name (get_string_of_file loc_end pos_limit2) in new_module.m_info <- merge_infos new_module.m_info info_after_opt ; - let (maybe_more2, eles) = f + let (maybe_more2, eles) = f maybe_more (loc_end + maybe_more) q @@ -813,11 +827,11 @@ module Analyser = (maybe_more2, (ele_comments @ [Element_module new_module]) @ eles) in let (maybe_more, mods) = f ~first: true 0 pos_start_ele decls in - (maybe_more, new_env, mods) + (maybe_more, new_env, mods) | Parsetree.Psig_modtype (name, Parsetree.Pmodtype_abstract) -> - let sig_mtype = - try Signature_search.search_module_type table name + let sig_mtype = + try Signature_search.search_module_type table name with Not_found -> raise (Failure (Odoc_messages.module_type_not_found current_module_name name)) in @@ -831,9 +845,9 @@ module Analyser = mt_file = !file_name ; mt_kind = None ; mt_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ; - } + } in - let (maybe_more, info_after_opt) = + let (maybe_more, info_after_opt) = My_ir.just_after_special !file_name (get_string_of_file pos_end_ele pos_limit) @@ -844,8 +858,8 @@ module Analyser = | Parsetree.Psig_modtype (name, Parsetree.Pmodtype_manifest module_type) -> let complete_name = Name.concat current_module_name name in - let sig_mtype_opt = - try Signature_search.search_module_type table name + let sig_mtype_opt = + try Signature_search.search_module_type table name with Not_found -> raise (Failure (Odoc_messages.module_type_not_found current_module_name name)) in @@ -854,7 +868,7 @@ module Analyser = | Some sig_mtype -> Some (analyse_module_type_kind env complete_name module_type sig_mtype) | None -> None in - let mt = + let mt = { mt_name = complete_name ; mt_info = comment_opt ; @@ -863,9 +877,9 @@ module Analyser = mt_file = !file_name ; mt_kind = module_type_kind ; mt_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ; - } + } in - let (maybe_more, info_after_opt) = + let (maybe_more, info_after_opt) = My_ir.just_after_special !file_name (get_string_of_file pos_end_ele pos_limit) @@ -883,7 +897,7 @@ module Analyser = let rec f = function Parsetree.Pmty_ident longident -> Name.from_longident longident - | Parsetree.Pmty_signature _ -> + | Parsetree.Pmty_signature _ -> "??" | Parsetree.Pmty_functor _ -> "??" @@ -892,19 +906,19 @@ module Analyser = in let name = (f module_type.Parsetree.pmty_desc) in let full_name = Odoc_env.full_module_or_module_type_name env name in - let im = + let im = { im_name = full_name ; im_module = None ; im_info = comment_opt; - } + } in (0, env, [ Element_included_module im ]) (* A VOIR : étendre l'environnement ? avec quoi ? *) | Parsetree.Psig_class class_description_list -> (* we start by extending the environment *) let new_env = - List.fold_left + List.fold_left (fun acc_env -> fun class_desc -> let complete_name = Name.concat current_module_name class_desc.Parsetree.pci_name in Odoc_env.add_class acc_env complete_name @@ -933,13 +947,13 @@ module Analyser = in let name = class_desc.Parsetree.pci_name in let complete_name = Name.concat current_module_name name in - let sig_class_decl = + let sig_class_decl = try Signature_search.search_class table name with Not_found -> raise (Failure (Odoc_messages.class_not_found current_module_name name)) in let sig_class_type = sig_class_decl.Types.cty_type in - let (parameters, class_kind) = + let (parameters, class_kind) = analyse_class_kind new_env complete_name @@ -957,22 +971,22 @@ module Analyser = cl_kind = class_kind ; cl_parameters = parameters ; cl_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ; - } + } in - let (maybe_more, info_after_opt) = + let (maybe_more, info_after_opt) = My_ir.just_after_special !file_name (get_string_of_file pos_end pos_limit2) in new_class.cl_info <- merge_infos new_class.cl_info info_after_opt ; Odoc_class.class_update_parameters_text new_class ; - let (new_maybe_more, eles) = + let (new_maybe_more, eles) = f maybe_more (pos_end + maybe_more) q in (new_maybe_more, ele_comments @ (( Element_class new_class ) :: eles)) in - let (maybe_more, eles) = + let (maybe_more, eles) = f ~first: true 0 pos_start_ele class_description_list in (maybe_more, new_env, eles) @@ -980,7 +994,7 @@ module Analyser = | Parsetree.Psig_class_type class_type_declaration_list -> (* we start by extending the environment *) let new_env = - List.fold_left + List.fold_left (fun acc_env -> fun class_type_decl -> let complete_name = Name.concat current_module_name class_type_decl.Parsetree.pci_name in Odoc_env.add_class_type acc_env complete_name @@ -1009,7 +1023,7 @@ module Analyser = in let name = ct_decl.Parsetree.pci_name in let complete_name = Name.concat current_module_name name in - let sig_cltype_decl = + let sig_cltype_decl = try Signature_search.search_class_type table name with Not_found -> raise (Failure (Odoc_messages.class_type_not_found current_module_name name)) @@ -1017,12 +1031,12 @@ module Analyser = let sig_class_type = sig_cltype_decl.Types.clty_type in let kind = analyse_class_type_kind new_env - complete_name + complete_name ct_decl.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum ct_decl.Parsetree.pci_expr sig_class_type in - let ct = + let ct = { clt_name = complete_name ; clt_info = assoc_com ; @@ -1031,21 +1045,21 @@ module Analyser = clt_virtual = ct_decl.Parsetree.pci_virt = Asttypes.Virtual ; clt_kind = kind ; clt_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ; - } + } in - let (maybe_more, info_after_opt) = + let (maybe_more, info_after_opt) = My_ir.just_after_special !file_name (get_string_of_file pos_end pos_limit2) in ct.clt_info <- merge_infos ct.clt_info info_after_opt ; - let (new_maybe_more, eles) = + let (new_maybe_more, eles) = f maybe_more (pos_end + maybe_more) q in (new_maybe_more, ele_comments @ (( Element_class_type ct) :: eles)) in - let (maybe_more, eles) = + let (maybe_more, eles) = f ~first: true 0 pos_start_ele class_type_declaration_list in (maybe_more, new_env, eles) @@ -1054,13 +1068,13 @@ module Analyser = and analyse_module_type_kind env current_module_name module_type sig_module_type = match module_type.Parsetree.pmty_desc with Parsetree.Pmty_ident longident -> - let name = + let name = match sig_module_type with Types.Tmty_ident path -> Name.from_path path - | _ -> Name.from_longident longident + | _ -> Name.from_longident longident (* A VOIR cela arrive quand on fait module type F : functor ... -> Toto, Toto n'est pas un ident mais une structure *) in - Module_type_alias { mta_name = Odoc_env.full_module_type_name env name ; + Module_type_alias { mta_name = Odoc_env.full_module_type_name env name ; mta_module = None } | Parsetree.Pmty_signature ast -> @@ -1075,7 +1089,7 @@ module Analyser = | _ -> raise (Failure "Parsetree.Pmty_signature signature but not Types.Tmty_signature signat") ) - + | Parsetree.Pmty_functor (_,pmodule_type2, module_type2) -> ( let loc_start = pmodule_type2.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in @@ -1084,21 +1098,21 @@ module Analyser = print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code); match sig_module_type with Types.Tmty_functor (ident, param_module_type, body_module_type) -> - let mp_kind = analyse_module_type_kind env - current_module_name pmodule_type2 param_module_type + let mp_kind = analyse_module_type_kind env + current_module_name pmodule_type2 param_module_type in - let param = + let param = { mp_name = Name.from_ident ident ; mp_type = Odoc_env.subst_module_type env param_module_type ; mp_type_code = mp_type_code ; mp_kind = mp_kind ; - } + } in - let k = analyse_module_type_kind env - current_module_name - module_type2 - body_module_type + let k = analyse_module_type_kind env + current_module_name + module_type2 + body_module_type in Module_type_functor (param, k) @@ -1129,7 +1143,7 @@ module Analyser = match sig_module_type with Types.Tmty_signature signat -> Module_struct - (analyse_parsetree + (analyse_parsetree env signat current_module_name @@ -1149,24 +1163,24 @@ module Analyser = let loc_end = pmodule_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in let mp_type_code = get_string_of_file loc_start loc_end in print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code); - let mp_kind = analyse_module_type_kind env - current_module_name pmodule_type2 param_module_type + let mp_kind = analyse_module_type_kind env + current_module_name pmodule_type2 param_module_type in - let param = + let param = { mp_name = Name.from_ident ident ; mp_type = Odoc_env.subst_module_type env param_module_type ; mp_type_code = mp_type_code ; mp_kind = mp_kind ; - } + } in - let k = analyse_module_kind env - current_module_name - module_type2 - body_module_type + let k = analyse_module_kind env + current_module_name + module_type2 + body_module_type in Module_functor (param, k) - + | _ -> (* if we're here something's wrong *) raise (Failure "Parsetree.Pmty_functor _ but not Types.Tmty_functor _") @@ -1190,13 +1204,13 @@ module Analyser = print_DEBUG "Tcty_constr _"; let path_name = Name.from_path p in let name = Odoc_env.full_class_or_class_type_name env path_name in - let k = - Class_constr + let k = + Class_constr { cco_name = name ; cco_class = None ; cco_type_parameters = List.map (Odoc_env.subst_type env) typ_list - } + } in ([], k) @@ -1207,7 +1221,7 @@ module Analyser = print_DEBUG ("Type de la classe "^current_class_name^" : "); print_DEBUG (Odoc_print.string_of_type_expr class_signature.Types.cty_self); (* we get the elements of the class in class_type_field_list *) - let (inher_l, ele) = analyse_class_elements env current_class_name + let (inher_l, ele) = analyse_class_elements env current_class_name last_pos parse_class_type.Parsetree.pcty_loc.Location.loc_end.Lexing.pos_cnum class_type_field_list @@ -1215,12 +1229,12 @@ module Analyser = in ([], Class_structure (inher_l, ele)) - | (Parsetree.Pcty_fun (parse_label, _, pclass_type), Types.Tcty_fun (label, type_expr, class_type)) -> + | (Parsetree.Pcty_fun (parse_label, _, pclass_type), Types.Tcty_fun (label, type_expr, class_type)) -> (* label = string. Dans les signatures, pas de nom de paramètres à l'intérieur des tuples *) (* si label = "", pas de label. ici on a l'information pour savoir si on a un label explicite. *) if parse_label = label then ( - let new_param = Simple_name + let new_param = Simple_name { sn_name = Btype.label_name label ; sn_type = Odoc_env.subst_type env type_expr ; @@ -1234,7 +1248,7 @@ module Analyser = ( raise (Failure "Parsetree.Pcty_fun (parse_label, _, pclass_type), labels différents") ) - + | _ -> raise (Failure "analyse_class_kind pas de correspondance dans le match") @@ -1244,13 +1258,13 @@ module Analyser = (Parsetree.Pcty_constr (_, _) (*of Longident.t * core_type list *), Types.Tcty_constr (p, typ_list, _) (*of Path.t * type_expr list * class_type*)) -> print_DEBUG "Tcty_constr _"; - let k = - Class_type + let k = + Class_type { cta_name = Odoc_env.full_class_or_class_type_name env (Name.from_path p) ; cta_class = None ; cta_type_parameters = List.map (Odoc_env.subst_type env) typ_list - } + } in k @@ -1269,16 +1283,16 @@ module Analyser = in Class_signature (inher_l, ele) - | (Parsetree.Pcty_fun (parse_label, _, pclass_type), Types.Tcty_fun (label, type_expr, class_type)) -> + | (Parsetree.Pcty_fun (parse_label, _, pclass_type), Types.Tcty_fun (label, type_expr, class_type)) -> raise (Failure "analyse_class_type_kind : Parsetree.Pcty_fun (...) with Types.Tcty_fun (...)") (* | (Parsetree.Pcty_constr (longident, _) (*of Longident.t * core_type list *), Types.Tcty_signature class_signature) -> - (* A VOIR : c'est pour le cas des contraintes de classes : + (* A VOIR : c'est pour le cas des contraintes de classes : class type cons = object method m : int end - + class ['a] maxou x = (object val a = (x : 'a) @@ -1286,13 +1300,13 @@ module Analyser = end : cons ) ^^^^^^ *) - let k = - Class_type + let k = + Class_type { cta_name = Odoc_env.full_class_name env (Name.from_longident longident) ; cta_class = None ; cta_type_parameters = List.map (Odoc_env.subst_type env) typ_list (* ?? *) - } + } in ([], k) *) @@ -1300,7 +1314,7 @@ module Analyser = raise (Failure "analyse_class_type_kind pas de correspondance dans le match") let analyse_signature source_file input_file - (ast : Parsetree.signature) (signat : Types.signature) = + (ast : Parsetree.signature) (signat : Types.signature) = let complete_source_file = try let curdir = Sys.getcwd () in @@ -1318,13 +1332,13 @@ module Analyser = prepare_file complete_source_file input_file; (* We create the t_module for this file. *) let mod_name = String.capitalize - (Filename.basename (try Filename.chop_extension source_file with _ -> source_file)) + (Filename.basename (try Filename.chop_extension source_file with _ -> source_file)) in let (len,info_opt) = My_ir.first_special !file_name !file in - let elements = - analyse_parsetree Odoc_env.empty signat mod_name len (String.length !file) ast + let elements = + analyse_parsetree Odoc_env.empty signat mod_name len (String.length !file) ast in - let code_intf = + let code_intf = if !Odoc_args.keep_code then Some !file else @@ -1341,8 +1355,8 @@ module Analyser = m_top_deps = [] ; m_code = None ; m_code_intf = code_intf ; - } - + } + end -(* eof $Id: odoc_sig.ml,v 1.30.2.2 2004/07/02 12:59:48 guesdon Exp $ *) +(* eof $Id: odoc_sig.ml,v 1.30.2.3 2004/10/01 09:43:24 guesdon Exp $ *) diff --git a/ocamldoc/odoc_str.ml b/ocamldoc/odoc_str.ml index f5931805..9bde4bf8 100644 --- a/ocamldoc/odoc_str.ml +++ b/ocamldoc/odoc_str.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_str.ml,v 1.9.4.1 2004/08/06 12:35:07 guesdon Exp $ *) +(* $Id: odoc_str.ml,v 1.9.4.2 2004/11/03 08:16:49 guesdon Exp $ *) (** The functions to get a string from different kinds of elements (types, modules, ...). *) @@ -25,6 +25,14 @@ let string_of_variance t (co,cn) = | _ -> "" else "" +let rec is_arrow_type t = + match t.Types.desc with + Types.Tarrow _ -> true + | Types.Tlink t2 | Types.Tsubst t2 -> is_arrow_type t2 + | Types.Ttuple _ + | Types.Tconstr _ + | Types.Tvar | Types.Tunivar | Types.Tobject _ | Types.Tpoly _ + | Types.Tfield _ | Types.Tnil | Types.Tvariant _ -> false let raw_string_of_type_list sep type_list = let buf = Buffer.create 256 in @@ -41,7 +49,7 @@ let raw_string_of_type_list sep type_list = let print_one_type variance t = Printtyp.mark_loops t; if need_parent t then - ( + ( Format.fprintf fmt "(%s" variance; Printtyp.type_scheme_max ~b_reset_names: false fmt t; Format.fprintf fmt ")" @@ -59,8 +67,8 @@ let raw_string_of_type_list sep type_list = Format.fprintf fmt "@["; print_one_type variance ty; List.iter - (fun (variance, t) -> - Format.fprintf fmt "@,%s" sep; + (fun (variance, t) -> + Format.fprintf fmt "@,%s" sep; print_one_type variance t ) tyl; @@ -84,7 +92,7 @@ let string_of_type_list ?par sep type_list = (if par then ")" else "") let string_of_type_param_list t = - let par = + let par = match t.Odoc_type.ty_parameters with [] | [_] -> false | _ -> true @@ -92,7 +100,7 @@ let string_of_type_param_list t = Printf.sprintf "%s%s%s" (if par then "(" else "") (raw_string_of_type_list ", " - (List.map + (List.map (fun (typ, co, cn) -> (string_of_variance t (co, cn), typ)) t.Odoc_type.ty_parameters ) @@ -100,7 +108,7 @@ let string_of_type_param_list t = (if par then ")" else "") let string_of_class_type_param_list l = - let par = + let par = match l with [] | [_] -> false | _ -> true @@ -108,7 +116,7 @@ let string_of_class_type_param_list l = Printf.sprintf "%s%s%s" (if par then "[" else "") (raw_string_of_type_list ", " - (List.map + (List.map (fun typ -> ("", typ)) l ) @@ -119,21 +127,24 @@ let string_of_class_params c = let b = Buffer.create 256 in let rec iter = function Types.Tcty_fun (label, t, ctype) -> - Printf.bprintf b "%s%s -> " + 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_signature _ | Types.Tcty_constr _ -> () in iter c.Odoc_class.cl_type; @@ -143,8 +154,8 @@ let string_of_type t = let module M = Odoc_type in "type "^ (String.concat "" - (List.map - (fun (p, co, cn) -> + (List.map + (fun (p, co, cn) -> (string_of_variance t (co, cn))^ (Odoc_print.string_of_type_expr p)^" " ) @@ -157,18 +168,18 @@ let string_of_type t = | Some typ -> "= "^(Odoc_print.string_of_type_expr typ)^" " )^ (match t.M.ty_kind with - M.Type_abstract -> + M.Type_abstract -> "" | M.Type_variant (l, priv) -> "="^(if priv then " private" else "")^"\n"^ (String.concat "" - (List.map + (List.map (fun cons -> " | "^cons.M.vc_name^ (match cons.M.vc_args with - [] -> "" - | l -> - " of "^(String.concat " * " + [] -> "" + | l -> + " of "^(String.concat " * " (List.map (fun t -> "("^(Odoc_print.string_of_type_expr t)^")") l)) )^ (match cons.M.vc_text with @@ -184,7 +195,7 @@ let string_of_type t = | M.Type_record (l, priv) -> "= "^(if priv then "private " else "")^"{\n"^ (String.concat "" - (List.map + (List.map (fun record -> " "^(if record.M.rf_mutable then "mutable " else "")^ record.M.rf_name^" : "^(Odoc_print.string_of_type_expr record.M.rf_type)^";"^ @@ -210,7 +221,7 @@ let string_of_exception e = (match e.M.ex_args with [] -> "" | _ ->" : "^ - (String.concat " -> " + (String.concat " -> " (List.map (fun t -> "("^(Odoc_print.string_of_type_expr t)^")") e.M.ex_args) ) )^ @@ -255,4 +266,4 @@ let string_of_method m = None -> "" | Some i -> Odoc_misc.string_of_info i) -(* eof $Id: odoc_str.ml,v 1.9.4.1 2004/08/06 12:35:07 guesdon Exp $ *) +(* eof $Id: odoc_str.ml,v 1.9.4.2 2004/11/03 08:16:49 guesdon Exp $ *) diff --git a/otherlibs/threads/unix.ml b/otherlibs/threads/unix.ml index a17a1a4f..f684dc5f 100644 --- a/otherlibs/threads/unix.ml +++ b/otherlibs/threads/unix.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: unix.ml,v 1.16.2.1 2004/06/22 17:18:49 remy Exp $ *) +(* $Id: unix.ml,v 1.16.2.2 2004/11/06 10:14:58 xleroy Exp $ *) (* An alternate implementation of the Unix module from ../unix which is safe in conjunction with bytecode threads. *) @@ -1018,21 +1018,25 @@ let find_proc_id fun_name proc = with Not_found -> raise(Unix_error(EBADF, fun_name, "")) +let rec waitpid_non_intr pid = + try waitpid [] pid + with Unix_error (EINTR, _, _) -> waitpid_non_intr pid + let close_process_in inchan = let pid = find_proc_id "close_process_in" (Process_in inchan) in close_in inchan; - snd(waitpid [] pid) + snd(waitpid_non_intr pid) let close_process_out outchan = let pid = find_proc_id "close_process_out" (Process_out outchan) in close_out outchan; - snd(waitpid [] pid) + snd(waitpid_non_intr pid) let close_process (inchan, outchan) = let pid = find_proc_id "close_process" (Process(inchan, outchan)) in close_in inchan; begin try close_out outchan with Sys_error _ -> () end; - snd(waitpid [] pid) + snd(waitpid_non_intr pid) let close_process_full (inchan, outchan, errchan) = let pid = @@ -1041,7 +1045,7 @@ let close_process_full (inchan, outchan, errchan) = close_in inchan; begin try close_out outchan with Sys_error _ -> () end; close_in errchan; - snd(waitpid [] pid) + snd(waitpid_non_intr pid) (* High-level network functions *) diff --git a/otherlibs/unix/accept.c b/otherlibs/unix/accept.c index 870c0d35..b4d4e3fa 100644 --- a/otherlibs/unix/accept.c +++ b/otherlibs/unix/accept.c @@ -11,10 +11,11 @@ /* */ /***********************************************************************/ -/* $Id: accept.c,v 1.12 2001/12/07 13:40:24 xleroy Exp $ */ +/* $Id: accept.c,v 1.12.6.1 2004/08/23 11:31:44 doligez Exp $ */ #include #include +#include #include #include #include "unixsupport.h" @@ -47,6 +48,7 @@ CAMLprim value unix_accept(value sock) #else -CAMLprim value unix_accept(value sock) { invalid_argument("accept not implemented"); } +CAMLprim value unix_accept(value sock) +{ invalid_argument("accept not implemented"); } #endif diff --git a/otherlibs/unix/access.c b/otherlibs/unix/access.c index 1db1d2b3..93970e15 100644 --- a/otherlibs/unix/access.c +++ b/otherlibs/unix/access.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: access.c,v 1.10 2002/06/07 09:49:40 xleroy Exp $ */ +/* $Id: access.c,v 1.10.6.1 2004/11/02 16:21:25 doligez Exp $ */ #include #include @@ -42,9 +42,10 @@ static int access_permission_table[] = { CAMLprim value unix_access(value path, value perms) { - int ret; - ret = access(String_val(path), - convert_flag_list(perms, access_permission_table)); + int ret, cv_flags; + + cv_flags = convert_flag_list(perms, access_permission_table); + ret = access(String_val(path), cv_flags); if (ret == -1) uerror("access", path); return Val_unit; diff --git a/otherlibs/unix/bind.c b/otherlibs/unix/bind.c index 0696e63e..3622d491 100644 --- a/otherlibs/unix/bind.c +++ b/otherlibs/unix/bind.c @@ -11,8 +11,9 @@ /* */ /***********************************************************************/ -/* $Id: bind.c,v 1.9 2001/12/07 13:40:24 xleroy Exp $ */ +/* $Id: bind.c,v 1.9.6.1 2004/08/23 11:31:44 doligez Exp $ */ +#include #include #include "unixsupport.h" diff --git a/otherlibs/unix/connect.c b/otherlibs/unix/connect.c index 7c062310..fc76fe3b 100644 --- a/otherlibs/unix/connect.c +++ b/otherlibs/unix/connect.c @@ -11,8 +11,9 @@ /* */ /***********************************************************************/ -/* $Id: connect.c,v 1.11 2001/12/07 13:40:26 xleroy Exp $ */ +/* $Id: connect.c,v 1.11.6.1 2004/08/23 11:31:44 doligez Exp $ */ +#include #include #include #include "unixsupport.h" diff --git a/otherlibs/unix/fchmod.c b/otherlibs/unix/fchmod.c index 523b1276..86589683 100644 --- a/otherlibs/unix/fchmod.c +++ b/otherlibs/unix/fchmod.c @@ -11,10 +11,11 @@ /* */ /***********************************************************************/ -/* $Id: fchmod.c,v 1.9 2001/12/07 13:40:28 xleroy Exp $ */ +/* $Id: fchmod.c,v 1.9.6.1 2004/08/23 11:31:44 doligez Exp $ */ #include #include +#include #include #include "unixsupport.h" diff --git a/otherlibs/unix/fchown.c b/otherlibs/unix/fchown.c index 0744c098..6a99d46c 100644 --- a/otherlibs/unix/fchown.c +++ b/otherlibs/unix/fchown.c @@ -11,8 +11,9 @@ /* */ /***********************************************************************/ -/* $Id: fchown.c,v 1.8 2001/12/07 13:40:28 xleroy Exp $ */ +/* $Id: fchown.c,v 1.8.6.1 2004/08/23 11:31:44 doligez Exp $ */ +#include #include #include "unixsupport.h" diff --git a/otherlibs/unix/fcntl.c b/otherlibs/unix/fcntl.c index 459c2671..c8b4a948 100644 --- a/otherlibs/unix/fcntl.c +++ b/otherlibs/unix/fcntl.c @@ -11,8 +11,9 @@ /* */ /***********************************************************************/ -/* $Id: fcntl.c,v 1.11 2001/12/07 13:40:28 xleroy Exp $ */ +/* $Id: fcntl.c,v 1.11.6.1 2004/08/23 11:31:44 doligez Exp $ */ +#include #include #include "unixsupport.h" #ifdef HAS_UNISTD diff --git a/otherlibs/unix/ftruncate.c b/otherlibs/unix/ftruncate.c index b8b6b65e..312d22ac 100644 --- a/otherlibs/unix/ftruncate.c +++ b/otherlibs/unix/ftruncate.c @@ -11,9 +11,10 @@ /* */ /***********************************************************************/ -/* $Id: ftruncate.c,v 1.9 2002/03/02 09:16:36 xleroy Exp $ */ +/* $Id: ftruncate.c,v 1.9.6.1 2004/08/23 11:31:44 doligez Exp $ */ #include +#include #include #include #include "unixsupport.h" diff --git a/otherlibs/unix/getaddrinfo.c b/otherlibs/unix/getaddrinfo.c index a4db8e92..2611c2a8 100644 --- a/otherlibs/unix/getaddrinfo.c +++ b/otherlibs/unix/getaddrinfo.c @@ -11,13 +11,13 @@ /* */ /***********************************************************************/ -/* $Id: getaddrinfo.c,v 1.1 2004/04/09 13:25:21 xleroy Exp $ */ +/* $Id: getaddrinfo.c,v 1.1.4.1 2004/08/23 11:31:44 doligez Exp $ */ #include #include #include -#include #include +#include #include #include "unixsupport.h" #include "cst2constr.h" diff --git a/otherlibs/unix/getcwd.c b/otherlibs/unix/getcwd.c index 7cb6d699..7121b788 100644 --- a/otherlibs/unix/getcwd.c +++ b/otherlibs/unix/getcwd.c @@ -11,10 +11,11 @@ /* */ /***********************************************************************/ -/* $Id: getcwd.c,v 1.14 2001/12/07 13:40:28 xleroy Exp $ */ +/* $Id: getcwd.c,v 1.14.6.1 2004/08/23 11:31:44 doligez Exp $ */ #include #include +#include #include "unixsupport.h" #if !defined (_WIN32) && !macintosh diff --git a/otherlibs/unix/getgroups.c b/otherlibs/unix/getgroups.c index 6c6e721c..03d232ec 100644 --- a/otherlibs/unix/getgroups.c +++ b/otherlibs/unix/getgroups.c @@ -11,10 +11,11 @@ /* */ /***********************************************************************/ -/* $Id: getgroups.c,v 1.10 2001/12/07 13:40:29 xleroy Exp $ */ +/* $Id: getgroups.c,v 1.10.6.1 2004/08/23 11:31:44 doligez Exp $ */ #include #include +#include #ifdef HAS_GETGROUPS diff --git a/otherlibs/unix/gethost.c b/otherlibs/unix/gethost.c index 22f24a78..c0637ad1 100644 --- a/otherlibs/unix/gethost.c +++ b/otherlibs/unix/gethost.c @@ -11,13 +11,13 @@ /* */ /***********************************************************************/ -/* $Id: gethost.c,v 1.24 2004/04/09 13:25:21 xleroy Exp $ */ +/* $Id: gethost.c,v 1.24.2.1 2004/08/23 11:31:44 doligez Exp $ */ #include #include #include -#include #include +#include #include #include "unixsupport.h" diff --git a/otherlibs/unix/gethostname.c b/otherlibs/unix/gethostname.c index 349ca967..c297b626 100644 --- a/otherlibs/unix/gethostname.c +++ b/otherlibs/unix/gethostname.c @@ -11,13 +11,14 @@ /* */ /***********************************************************************/ -/* $Id: gethostname.c,v 1.10 2001/12/07 13:40:29 xleroy Exp $ */ +/* $Id: gethostname.c,v 1.10.6.1 2004/08/23 11:31:44 doligez Exp $ */ #include #include +#include #if defined (_WIN32) #include -#elif !macintosh +#else #include #endif #include "unixsupport.h" diff --git a/otherlibs/unix/getnameinfo.c b/otherlibs/unix/getnameinfo.c index a4f653f2..36fc9e30 100644 --- a/otherlibs/unix/getnameinfo.c +++ b/otherlibs/unix/getnameinfo.c @@ -11,13 +11,13 @@ /* */ /***********************************************************************/ -/* $Id: getnameinfo.c,v 1.1 2004/04/09 13:25:21 xleroy Exp $ */ +/* $Id: getnameinfo.c,v 1.1.4.1 2004/08/23 11:31:44 doligez Exp $ */ #include #include #include -#include #include +#include #include #include "unixsupport.h" diff --git a/otherlibs/unix/getpeername.c b/otherlibs/unix/getpeername.c index 0ce98b0a..67879c5c 100644 --- a/otherlibs/unix/getpeername.c +++ b/otherlibs/unix/getpeername.c @@ -11,8 +11,9 @@ /* */ /***********************************************************************/ -/* $Id: getpeername.c,v 1.10 2004/04/09 13:25:21 xleroy Exp $ */ +/* $Id: getpeername.c,v 1.10.2.1 2004/08/23 11:31:44 doligez Exp $ */ +#include #include #include "unixsupport.h" diff --git a/otherlibs/unix/getproto.c b/otherlibs/unix/getproto.c index 6bf78e6b..af16e38c 100644 --- a/otherlibs/unix/getproto.c +++ b/otherlibs/unix/getproto.c @@ -11,12 +11,12 @@ /* */ /***********************************************************************/ -/* $Id: getproto.c,v 1.12 2001/12/07 13:40:30 xleroy Exp $ */ +/* $Id: getproto.c,v 1.12.6.1 2004/08/23 11:31:44 doligez Exp $ */ #include #include -#include #include +#include #include "unixsupport.h" #ifdef HAS_SOCKETS diff --git a/otherlibs/unix/getserv.c b/otherlibs/unix/getserv.c index 0fbfbf57..692e5442 100644 --- a/otherlibs/unix/getserv.c +++ b/otherlibs/unix/getserv.c @@ -11,12 +11,12 @@ /* */ /***********************************************************************/ -/* $Id: getserv.c,v 1.13 2001/12/07 13:40:30 xleroy Exp $ */ +/* $Id: getserv.c,v 1.13.6.1 2004/08/23 11:31:44 doligez Exp $ */ #include #include -#include #include +#include #include "unixsupport.h" #ifdef HAS_SOCKETS diff --git a/otherlibs/unix/getsockname.c b/otherlibs/unix/getsockname.c index 8ac074cd..99026867 100644 --- a/otherlibs/unix/getsockname.c +++ b/otherlibs/unix/getsockname.c @@ -11,8 +11,9 @@ /* */ /***********************************************************************/ -/* $Id: getsockname.c,v 1.9 2001/12/07 13:40:30 xleroy Exp $ */ +/* $Id: getsockname.c,v 1.9.6.1 2004/08/23 11:31:44 doligez Exp $ */ +#include #include #include "unixsupport.h" diff --git a/otherlibs/unix/gettimeofday.c b/otherlibs/unix/gettimeofday.c index b09c828b..efd95645 100644 --- a/otherlibs/unix/gettimeofday.c +++ b/otherlibs/unix/gettimeofday.c @@ -11,10 +11,11 @@ /* */ /***********************************************************************/ -/* $Id: gettimeofday.c,v 1.7 2001/12/07 13:40:30 xleroy Exp $ */ +/* $Id: gettimeofday.c,v 1.7.6.1 2004/08/23 11:31:44 doligez Exp $ */ #include #include +#include #include "unixsupport.h" #ifdef HAS_GETTIMEOFDAY diff --git a/otherlibs/unix/gmtime.c b/otherlibs/unix/gmtime.c index 0ca8d76c..a487b086 100644 --- a/otherlibs/unix/gmtime.c +++ b/otherlibs/unix/gmtime.c @@ -11,10 +11,11 @@ /* */ /***********************************************************************/ -/* $Id: gmtime.c,v 1.16 2001/12/07 13:40:31 xleroy Exp $ */ +/* $Id: gmtime.c,v 1.16.6.1 2004/08/23 11:31:44 doligez Exp $ */ #include #include +#include #include #include "unixsupport.h" #include @@ -88,6 +89,7 @@ CAMLprim value unix_mktime(value t) #else -CAMLprim value unix_mktime(value t) { invalid_argument("mktime not implemented"); } +CAMLprim value unix_mktime(value t) +{ invalid_argument("mktime not implemented"); } #endif diff --git a/otherlibs/unix/itimer.c b/otherlibs/unix/itimer.c index c8c07978..0c42ddca 100644 --- a/otherlibs/unix/itimer.c +++ b/otherlibs/unix/itimer.c @@ -11,10 +11,11 @@ /* */ /***********************************************************************/ -/* $Id: itimer.c,v 1.13 2003/11/21 16:00:52 xleroy Exp $ */ +/* $Id: itimer.c,v 1.13.4.1 2004/08/23 11:31:44 doligez Exp $ */ #include #include +#include #include #include "unixsupport.h" diff --git a/otherlibs/unix/listen.c b/otherlibs/unix/listen.c index 3c0db344..ba7ee752 100644 --- a/otherlibs/unix/listen.c +++ b/otherlibs/unix/listen.c @@ -11,8 +11,9 @@ /* */ /***********************************************************************/ -/* $Id: listen.c,v 1.10 2001/12/07 13:40:31 xleroy Exp $ */ +/* $Id: listen.c,v 1.10.6.1 2004/08/23 11:31:44 doligez Exp $ */ +#include #include #include "unixsupport.h" diff --git a/otherlibs/unix/lockf.c b/otherlibs/unix/lockf.c index 771de995..5c05c91d 100644 --- a/otherlibs/unix/lockf.c +++ b/otherlibs/unix/lockf.c @@ -11,10 +11,11 @@ /* */ /***********************************************************************/ -/* $Id: lockf.c,v 1.13 2004/06/11 23:16:14 doligez Exp $ */ +/* $Id: lockf.c,v 1.13.2.1 2004/08/23 11:31:44 doligez Exp $ */ #include #include +#include #include #include #include "unixsupport.h" diff --git a/otherlibs/unix/mkfifo.c b/otherlibs/unix/mkfifo.c index 56d10243..9e55dbb8 100644 --- a/otherlibs/unix/mkfifo.c +++ b/otherlibs/unix/mkfifo.c @@ -11,10 +11,11 @@ /* */ /***********************************************************************/ -/* $Id: mkfifo.c,v 1.10 2001/12/07 13:40:32 xleroy Exp $ */ +/* $Id: mkfifo.c,v 1.10.6.1 2004/08/23 11:31:44 doligez Exp $ */ #include #include +#include #include #include "unixsupport.h" diff --git a/otherlibs/unix/open.c b/otherlibs/unix/open.c index c816d51b..09a1f400 100644 --- a/otherlibs/unix/open.c +++ b/otherlibs/unix/open.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: open.c,v 1.11 2003/02/11 14:30:33 xleroy Exp $ */ +/* $Id: open.c,v 1.11.6.1 2004/11/02 16:21:25 doligez Exp $ */ #include #include @@ -42,14 +42,15 @@ static int open_flag_table[] = { CAMLprim value unix_open(value path, value flags, value perm) { CAMLparam3(path, flags, perm); - int ret; + int ret, cv_flags; char * p; + cv_flags = convert_flag_list(flags, open_flag_table); p = stat_alloc(string_length(path) + 1); strcpy(p, String_val(path)); /* open on a named FIFO can block (PR#1533) */ enter_blocking_section(); - ret = open(p, convert_flag_list(flags, open_flag_table), Int_val(perm)); + ret = open(p, cv_flags, Int_val(perm)); leave_blocking_section(); stat_free(p); if (ret == -1) uerror("open", path); diff --git a/otherlibs/unix/putenv.c b/otherlibs/unix/putenv.c index 953db070..da398848 100644 --- a/otherlibs/unix/putenv.c +++ b/otherlibs/unix/putenv.c @@ -11,11 +11,12 @@ /* */ /***********************************************************************/ -/* $Id: putenv.c,v 1.8 2001/12/07 13:40:32 xleroy Exp $ */ +/* $Id: putenv.c,v 1.8.6.1 2004/08/23 11:31:44 doligez Exp $ */ #include #include +#include #include #include diff --git a/otherlibs/unix/readlink.c b/otherlibs/unix/readlink.c index 4110fd2e..cd4bb59b 100644 --- a/otherlibs/unix/readlink.c +++ b/otherlibs/unix/readlink.c @@ -11,10 +11,11 @@ /* */ /***********************************************************************/ -/* $Id: readlink.c,v 1.10 2001/12/07 13:40:32 xleroy Exp $ */ +/* $Id: readlink.c,v 1.10.6.1 2004/08/23 11:31:44 doligez Exp $ */ #include #include +#include #ifdef HAS_SYMLINK diff --git a/otherlibs/unix/rewinddir.c b/otherlibs/unix/rewinddir.c index 588ee30e..2a664caf 100644 --- a/otherlibs/unix/rewinddir.c +++ b/otherlibs/unix/rewinddir.c @@ -11,8 +11,9 @@ /* */ /***********************************************************************/ -/* $Id: rewinddir.c,v 1.11 2004/06/19 15:38:31 xleroy Exp $ */ +/* $Id: rewinddir.c,v 1.11.2.1 2004/08/23 11:31:44 doligez Exp $ */ +#include #include #include "unixsupport.h" #include diff --git a/otherlibs/unix/select.c b/otherlibs/unix/select.c index 53436592..0dd22774 100644 --- a/otherlibs/unix/select.c +++ b/otherlibs/unix/select.c @@ -11,10 +11,11 @@ /* */ /***********************************************************************/ -/* $Id: select.c,v 1.21 2002/05/07 07:37:18 xleroy Exp $ */ +/* $Id: select.c,v 1.21.6.1 2004/08/23 11:31:44 doligez Exp $ */ #include #include +#include #include #include #include "unixsupport.h" diff --git a/otherlibs/unix/sendrecv.c b/otherlibs/unix/sendrecv.c index 2d2ad339..b7e59b7d 100644 --- a/otherlibs/unix/sendrecv.c +++ b/otherlibs/unix/sendrecv.c @@ -11,11 +11,12 @@ /* */ /***********************************************************************/ -/* $Id: sendrecv.c,v 1.18 2001/12/07 13:40:33 xleroy Exp $ */ +/* $Id: sendrecv.c,v 1.18.6.2 2004/11/02 16:21:25 doligez Exp $ */ #include #include #include +#include #include #include #include "unixsupport.h" @@ -29,16 +30,16 @@ static int msg_flag_table[] = { CAMLprim value unix_recv(value sock, value buff, value ofs, value len, value flags) { - int ret; + int ret, cv_flags; long numbytes; char iobuf[UNIX_BUFFER_SIZE]; + cv_flags = convert_flag_list(flags, msg_flag_table); Begin_root (buff); numbytes = Long_val(len); if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; enter_blocking_section(); - ret = recv(Int_val(sock), iobuf, (int) numbytes, - convert_flag_list(flags, msg_flag_table)); + ret = recv(Int_val(sock), iobuf, (int) numbytes, cv_flags); leave_blocking_section(); if (ret == -1) uerror("recv", Nothing); memmove (&Byte(buff, Long_val(ofs)), iobuf, ret); @@ -48,7 +49,7 @@ CAMLprim value unix_recv(value sock, value buff, value ofs, value len, value fla CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len, value flags) { - int ret; + int ret, cv_flags; long numbytes; char iobuf[UNIX_BUFFER_SIZE]; value res; @@ -56,13 +57,13 @@ CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len, value union sock_addr_union addr; socklen_param_type addr_len; + cv_flags = convert_flag_list(flags, msg_flag_table); Begin_roots2 (buff, adr); numbytes = Long_val(len); if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; addr_len = sizeof(addr); enter_blocking_section(); - ret = recvfrom(Int_val(sock), iobuf, (int) numbytes, - convert_flag_list(flags, msg_flag_table), + ret = recvfrom(Int_val(sock), iobuf, (int) numbytes, cv_flags, &addr.s_gen, &addr_len); leave_blocking_section(); if (ret == -1) uerror("recvfrom", Nothing); @@ -77,16 +78,16 @@ CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len, value CAMLprim value unix_send(value sock, value buff, value ofs, value len, value flags) { - int ret; + int ret, cv_flags; long numbytes; char iobuf[UNIX_BUFFER_SIZE]; + cv_flags = convert_flag_list(flags, msg_flag_table); numbytes = Long_val(len); if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes); enter_blocking_section(); - ret = send(Int_val(sock), iobuf, (int) numbytes, - convert_flag_list(flags, msg_flag_table)); + ret = send(Int_val(sock), iobuf, (int) numbytes, cv_flags); leave_blocking_section(); if (ret == -1) uerror("send", Nothing); return Val_int(ret); @@ -94,19 +95,19 @@ CAMLprim value unix_send(value sock, value buff, value ofs, value len, value fla CAMLprim value unix_sendto_native(value sock, value buff, value ofs, value len, value flags, value dest) { - int ret; + int ret, cv_flags; long numbytes; char iobuf[UNIX_BUFFER_SIZE]; union sock_addr_union addr; socklen_param_type addr_len; + cv_flags = convert_flag_list(flags, msg_flag_table); get_sockaddr(dest, &addr, &addr_len); numbytes = Long_val(len); if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes); enter_blocking_section(); - ret = sendto(Int_val(sock), iobuf, (int) numbytes, - convert_flag_list(flags, msg_flag_table), + ret = sendto(Int_val(sock), iobuf, (int) numbytes, cv_flags, &addr.s_gen, addr_len); leave_blocking_section(); if (ret == -1) uerror("sendto", Nothing); diff --git a/otherlibs/unix/setsid.c b/otherlibs/unix/setsid.c index d7c5b78f..ce47b326 100644 --- a/otherlibs/unix/setsid.c +++ b/otherlibs/unix/setsid.c @@ -11,8 +11,9 @@ /* */ /***********************************************************************/ -/* $Id: setsid.c,v 1.5 2001/12/07 13:40:33 xleroy Exp $ */ +/* $Id: setsid.c,v 1.5.6.1 2004/08/23 11:31:44 doligez Exp $ */ +#include #include #include "unixsupport.h" #ifdef HAS_UNISTD diff --git a/otherlibs/unix/shutdown.c b/otherlibs/unix/shutdown.c index 82c023b8..278c1f6d 100644 --- a/otherlibs/unix/shutdown.c +++ b/otherlibs/unix/shutdown.c @@ -11,8 +11,9 @@ /* */ /***********************************************************************/ -/* $Id: shutdown.c,v 1.10 2001/12/07 13:40:35 xleroy Exp $ */ +/* $Id: shutdown.c,v 1.10.6.1 2004/08/23 11:31:44 doligez Exp $ */ +#include #include #include "unixsupport.h" diff --git a/otherlibs/unix/signals.c b/otherlibs/unix/signals.c index a5f1a551..74094066 100644 --- a/otherlibs/unix/signals.c +++ b/otherlibs/unix/signals.c @@ -11,12 +11,13 @@ /* */ /***********************************************************************/ -/* $Id: signals.c,v 1.9 2001/12/07 13:40:35 xleroy Exp $ */ +/* $Id: signals.c,v 1.9.6.1 2004/08/23 11:31:44 doligez Exp $ */ #include #include #include +#include #include #include #include diff --git a/otherlibs/unix/socket.c b/otherlibs/unix/socket.c index 9b4bbdb4..916d3241 100644 --- a/otherlibs/unix/socket.c +++ b/otherlibs/unix/socket.c @@ -11,8 +11,9 @@ /* */ /***********************************************************************/ -/* $Id: socket.c,v 1.10 2004/04/09 13:25:21 xleroy Exp $ */ +/* $Id: socket.c,v 1.10.2.1 2004/08/23 11:31:44 doligez Exp $ */ +#include #include #include "unixsupport.h" diff --git a/otherlibs/unix/socketpair.c b/otherlibs/unix/socketpair.c index 96a0fb58..50b8011c 100644 --- a/otherlibs/unix/socketpair.c +++ b/otherlibs/unix/socketpair.c @@ -11,10 +11,11 @@ /* */ /***********************************************************************/ -/* $Id: socketpair.c,v 1.11 2001/12/07 13:40:36 xleroy Exp $ */ +/* $Id: socketpair.c,v 1.11.6.1 2004/08/23 11:31:44 doligez Exp $ */ #include #include +#include #include "unixsupport.h" #ifdef HAS_SOCKETS diff --git a/otherlibs/unix/sockopt.c b/otherlibs/unix/sockopt.c index a802c63c..11e9b010 100644 --- a/otherlibs/unix/sockopt.c +++ b/otherlibs/unix/sockopt.c @@ -11,10 +11,11 @@ /* */ /***********************************************************************/ -/* $Id: sockopt.c,v 1.18 2002/10/01 12:34:58 xleroy Exp $ */ +/* $Id: sockopt.c,v 1.18.6.1 2004/08/23 11:31:44 doligez Exp $ */ #include #include +#include #include "unixsupport.h" #ifdef HAS_SOCKETS diff --git a/otherlibs/unix/strofaddr.c b/otherlibs/unix/strofaddr.c index ece84b58..bad8ef67 100644 --- a/otherlibs/unix/strofaddr.c +++ b/otherlibs/unix/strofaddr.c @@ -11,10 +11,11 @@ /* */ /***********************************************************************/ -/* $Id: strofaddr.c,v 1.9 2004/04/09 13:25:22 xleroy Exp $ */ +/* $Id: strofaddr.c,v 1.9.2.1 2004/08/23 11:31:44 doligez Exp $ */ #include #include +#include #include "unixsupport.h" #ifdef HAS_SOCKETS diff --git a/otherlibs/unix/symlink.c b/otherlibs/unix/symlink.c index ba5be9c4..bbdc709f 100644 --- a/otherlibs/unix/symlink.c +++ b/otherlibs/unix/symlink.c @@ -11,8 +11,9 @@ /* */ /***********************************************************************/ -/* $Id: symlink.c,v 1.8 2001/12/07 13:40:36 xleroy Exp $ */ +/* $Id: symlink.c,v 1.8.6.1 2004/08/23 11:31:44 doligez Exp $ */ +#include #include #include "unixsupport.h" diff --git a/otherlibs/unix/termios.c b/otherlibs/unix/termios.c index a38e6f05..0ec223fa 100644 --- a/otherlibs/unix/termios.c +++ b/otherlibs/unix/termios.c @@ -11,10 +11,11 @@ /* */ /***********************************************************************/ -/* $Id: termios.c,v 1.14 2001/12/07 13:40:36 xleroy Exp $ */ +/* $Id: termios.c,v 1.14.6.1 2004/08/23 11:31:44 doligez Exp $ */ #include #include +#include #include "unixsupport.h" #ifdef HAS_TERMIOS diff --git a/otherlibs/unix/truncate.c b/otherlibs/unix/truncate.c index e8fbafc4..ac41aa39 100644 --- a/otherlibs/unix/truncate.c +++ b/otherlibs/unix/truncate.c @@ -11,10 +11,11 @@ /* */ /***********************************************************************/ -/* $Id: truncate.c,v 1.9 2002/03/02 09:16:36 xleroy Exp $ */ +/* $Id: truncate.c,v 1.9.6.1 2004/08/23 11:31:44 doligez Exp $ */ #include #include +#include #include #include "unixsupport.h" #ifdef HAS_UNISTD diff --git a/otherlibs/unix/unix.ml b/otherlibs/unix/unix.ml index 6643be45..79ee953a 100644 --- a/otherlibs/unix/unix.ml +++ b/otherlibs/unix/unix.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: unix.ml,v 1.60.2.2 2004/07/02 09:37:17 doligez Exp $ *) +(* $Id: unix.ml,v 1.60.2.3 2004/11/06 10:14:58 xleroy Exp $ *) type error = E2BIG @@ -866,21 +866,25 @@ let find_proc_id fun_name proc = with Not_found -> raise(Unix_error(EBADF, fun_name, "")) +let rec waitpid_non_intr pid = + try waitpid [] pid + with Unix_error (EINTR, _, _) -> waitpid_non_intr pid + let close_process_in inchan = let pid = find_proc_id "close_process_in" (Process_in inchan) in close_in inchan; - snd(waitpid [] pid) + snd(waitpid_non_intr pid) let close_process_out outchan = let pid = find_proc_id "close_process_out" (Process_out outchan) in close_out outchan; - snd(waitpid [] pid) + snd(waitpid_non_intr pid) let close_process (inchan, outchan) = let pid = find_proc_id "close_process" (Process(inchan, outchan)) in close_in inchan; begin try close_out outchan with Sys_error _ -> () end; - snd(waitpid [] pid) + snd(waitpid_non_intr pid) let close_process_full (inchan, outchan, errchan) = let pid = @@ -889,7 +893,7 @@ let close_process_full (inchan, outchan, errchan) = close_in inchan; begin try close_out outchan with Sys_error _ -> () end; close_in errchan; - snd(waitpid [] pid) + snd(waitpid_non_intr pid) (* High-level network functions *) diff --git a/otherlibs/unix/utimes.c b/otherlibs/unix/utimes.c index 32abfa24..2ebe62cc 100644 --- a/otherlibs/unix/utimes.c +++ b/otherlibs/unix/utimes.c @@ -11,8 +11,9 @@ /* */ /***********************************************************************/ -/* $Id: utimes.c,v 1.9 2001/12/07 13:40:39 xleroy Exp $ */ +/* $Id: utimes.c,v 1.9.6.1 2004/08/23 11:31:44 doligez Exp $ */ +#include #include #include "unixsupport.h" diff --git a/otherlibs/unix/wait.c b/otherlibs/unix/wait.c index fef26592..b4a3ab63 100644 --- a/otherlibs/unix/wait.c +++ b/otherlibs/unix/wait.c @@ -11,10 +11,11 @@ /* */ /***********************************************************************/ -/* $Id: wait.c,v 1.17 2001/12/07 13:40:39 xleroy Exp $ */ +/* $Id: wait.c,v 1.17.6.2 2004/11/02 16:21:25 doligez Exp $ */ #include #include +#include #include #include #include "unixsupport.h" @@ -83,11 +84,11 @@ static int wait_flag_table[] = { CAMLprim value unix_waitpid(value flags, value pid_req) { - int pid, status; - + int pid, status, cv_flags; + + cv_flags = convert_flag_list(flags, wait_flag_table); enter_blocking_section(); - pid = waitpid(Int_val(pid_req), &status, - convert_flag_list(flags, wait_flag_table)); + pid = waitpid(Int_val(pid_req), &status, cv_flags); leave_blocking_section(); if (pid == -1) uerror("waitpid", Nothing); return alloc_process_status(pid, status); diff --git a/stdlib/scanf.mli b/stdlib/scanf.mli index 9370ab3c..14c8d18d 100644 --- a/stdlib/scanf.mli +++ b/stdlib/scanf.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: scanf.mli,v 1.45.6.1 2004/06/24 11:19:05 doligez Exp $ *) +(* $Id: scanf.mli,v 1.45.6.2 2004/09/09 07:44:30 weis Exp $ *) (** Formatted input functions. *) @@ -141,7 +141,7 @@ val bscanf : mentioned in the range of characters [range] (or not mentioned in it, if the range starts with [^]). Returns a [string] that can be empty, if no character in the input matches the range. Hence, - [\['0'-'9'\]] returns a string representing a decimal number or an empty + [\[0-9\]] returns a string representing a decimal number or an empty string if no decimal digit is found. If a closing bracket appears in a range, it must occur as the first character of the range (or just after the [^] in case of diff --git a/stdlib/set.ml b/stdlib/set.ml index 481ad128..6b49816a 100644 --- a/stdlib/set.ml +++ b/stdlib/set.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: set.ml,v 1.18 2004/04/23 10:01:54 xleroy Exp $ *) +(* $Id: set.ml,v 1.18.4.1 2004/11/03 21:19:49 doligez Exp $ *) (* Sets over ordered types *) @@ -290,7 +290,7 @@ module Make(Ord: OrderedType) = let rec fold f s accu = match s with Empty -> accu - | Node(l, v, r, _) -> fold f l (f v (fold f r accu)) + | Node(l, v, r, _) -> fold f r (f v (fold f l accu)) let rec for_all p = function Empty -> true diff --git a/stdlib/string.mli b/stdlib/string.mli index e0838677..281c5126 100644 --- a/stdlib/string.mli +++ b/stdlib/string.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: string.mli,v 1.36 2004/02/20 10:09:30 doligez Exp $ *) +(* $Id: string.mli,v 1.36.6.1 2004/11/03 21:17:18 doligez Exp $ *) (** String operations. *) @@ -81,7 +81,7 @@ val concat : string -> string list -> string val iter : (char -> unit) -> string -> unit (** [String.iter f s] applies function [f] in turn to all the characters of [s]. It is equivalent to - [f s.(0); f s.(1); ...; f s.(String.length s - 1); ()]. *) + [f s.[0]; f s.[1]; ...; f s.[String.length s - 1]; ()]. *) val escaped : string -> string (** Return a copy of the argument, with special characters diff --git a/stdlib/sys.ml b/stdlib/sys.ml index 0c20f087..fe83dc48 100644 --- a/stdlib/sys.ml +++ b/stdlib/sys.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: sys.ml,v 1.101.2.7 2004/08/19 12:52:17 doligez Exp $ *) +(* $Id: sys.ml,v 1.101.2.14 2004/11/22 16:25:38 doligez Exp $ *) (* System interface *) @@ -78,4 +78,4 @@ let catch_break on = (* OCaml version string, must be in the format described in sys.mli. *) -let ocaml_version = "3.08.1";; +let ocaml_version = "3.08.2";; diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml index ac34700a..53945046 100644 --- a/tools/ocamlprof.ml +++ b/tools/ocamlprof.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: ocamlprof.ml,v 1.37 2004/06/16 16:58:46 doligez Exp $ *) +(* $Id: ocamlprof.ml,v 1.37.2.1 2004/11/18 23:52:08 doligez Exp $ *) open Printf @@ -25,7 +25,6 @@ open Parsetree let idprefix = "__ocaml_prof_";; let modprefix = "OCAML__prof_";; - (* Errors specific to the profiler *) exception Profiler of string @@ -85,14 +84,11 @@ let insert_action st en = let add_incr_counter modul (kind,pos) = copy pos; match kind with - | Close -> fprintf !outchan ")"; | Open -> - fprintf !outchan - "(%sArray.set %s_cnt %d \ - (%sPervasives.succ (%sArray.get %s_cnt %d)); " - modprefix idprefix !prof_counter - modprefix modprefix idprefix !prof_counter; + fprintf !outchan "(%sProfiling.incr %s%s_cnt %d; " + modprefix idprefix modul !prof_counter; incr prof_counter; + | Close -> fprintf !outchan ")"; ;; let counters = ref (Array.create 0 0) @@ -130,14 +126,13 @@ let pos_len = ref 0 let init_rewrite modes mod_name = cur_point := 0; if !instr_mode then begin - fprintf !outchan "module %sArray = Array;; " modprefix; - fprintf !outchan "module %sPervasives = Pervasives;; " modprefix; - fprintf !outchan "let %s_cnt = Array.create 0000000" idprefix; + fprintf !outchan "module %sProfiling = Profiling;; " modprefix; + fprintf !outchan "let %s%s_cnt = Array.create 000000000" idprefix mod_name; pos_len := pos_out !outchan; fprintf !outchan " 0;; Profiling.counters := \ - (\"%s\", (\"%s\", %s_cnt)) :: !Profiling.counters;; " - mod_name modes idprefix; + (\"%s\", (\"%s\", %s%s_cnt)) :: !Profiling.counters;; " + mod_name modes idprefix mod_name; end let final_rewrite add_function = @@ -147,7 +142,7 @@ let final_rewrite add_function = copy (in_channel_length !inchan); if !instr_mode then begin let len = string_of_int !prof_counter in - if String.length len > 7 then raise (Profiler "too many counters"); + if String.length len > 9 then raise (Profiler "too many counters"); seek_out !outchan (!pos_len - String.length len); output_string !outchan len end; diff --git a/tools/profiling.ml b/tools/profiling.ml index ac5ab5ca..de2dea2e 100644 --- a/tools/profiling.ml +++ b/tools/profiling.ml @@ -12,13 +12,14 @@ (* *) (***********************************************************************) -(* $Id: profiling.ml,v 1.6 2001/12/07 13:41:01 xleroy Exp $ *) +(* $Id: profiling.ml,v 1.6.10.1 2004/11/18 23:52:08 doligez Exp $ *) (* Run-time library for profiled programs *) type profiling_counters = (string * (string * int array)) list -let counters = ref ([] : profiling_counters) +let counters = ref ([] : profiling_counters);; +let incr a i = a.(i) <- a.(i) + 1;; exception Bad_profile diff --git a/tools/profiling.mli b/tools/profiling.mli index e0abd2bc..a8f1266e 100644 --- a/tools/profiling.mli +++ b/tools/profiling.mli @@ -12,8 +12,9 @@ (* *) (***********************************************************************) -(* $Id: profiling.mli,v 1.5 2001/12/07 13:41:02 xleroy Exp $ *) +(* $Id: profiling.mli,v 1.5.10.1 2004/11/18 23:52:08 doligez Exp $ *) (* Run-time library for profiled programs *) -val counters: (string * (string * int array)) list ref +val counters: (string * (string * int array)) list ref;; +val incr: int array -> int -> unit;; diff --git a/yacc/reader.c b/yacc/reader.c index 45367c8e..8cfd663b 100644 --- a/yacc/reader.c +++ b/yacc/reader.c @@ -12,7 +12,7 @@ /* Based on public-domain code from Berkeley Yacc */ -/* $Id: reader.c,v 1.28 2004/06/12 11:59:11 xleroy Exp $ */ +/* $Id: reader.c,v 1.28.2.1 2004/08/20 15:26:02 doligez Exp $ */ #include #include "defs.h" @@ -825,13 +825,17 @@ get_tag(void) register int i; register char *s; char *t_line = dup_line(); + long bracket_depth; cinc = 0; + bracket_depth = 0; while (1) { c = *++cptr; if (c == EOF) unexpected_EOF(); if (c == '\n') syntax_error(lineno, line, cptr); - if (c == '>' && cptr[-1] != '-') break; + if (c == '>' && 0 == bracket_depth && cptr[-1] != '-') break; + if (c == '[') ++ bracket_depth; + if (c == ']') -- bracket_depth; cachec(c); } ++cptr; -- 2.30.2