+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 <caml/printexc.h> 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:
----------------------
* 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 $
/* */
/***********************************************************************/
-/* $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 */
.data
#endif
.global Caml_system__frametable
+ .align 4 /* required for gas? */
Caml_system__frametable:
.word 1 /* one descriptor */
.word L109 /* return address into callback */
# #
#########################################################################
-# $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
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
# #
#########################################################################
-# $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
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)
/* */
/***********************************************************************/
-/* $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 */
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);
}
}
/* */
/***********************************************************************/
-/* $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 */
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
/* */
/***********************************************************************/
-/* $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 */
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;
}
+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.
(* 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;
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 }
(* *)
(***********************************************************************)
-(* $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;
;
value inter_phrases = ref None;
+
+value position =
+ ref(ref 0, ref 0, ref "")
+;
(* *)
(***********************************************************************)
-(* $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.
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 *)
(* *)
(***********************************************************************)
-(* $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;
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;
Pcaml.parse_interf.val := Grammar.Entry.parse interf;
Pcaml.parse_implem.val := Grammar.Entry.parse implem;
+Pcaml.position.val := pos;
value o2b =
fun
<: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$ ] >>
;
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$) >> ] ]
;
;
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:
| 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
[ [ "="; 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:
| "["; 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$ >> ] ]
[ [ 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$ >>
(* *)
(***********************************************************************)
-(* $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;
;
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;
(* *)
(***********************************************************************)
-(* $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.
(** 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) *)
(* *)
(***********************************************************************)
-(* $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;
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) =
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 =
| 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 =
{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 =
{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}
;
(* *)
(***********************************************************************)
-(* $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. *)
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,
(* *)
(***********************************************************************)
-(* $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;
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;
Pcaml.parse_interf.val := Grammar.Entry.parse interf;
Pcaml.parse_implem.val := Grammar.Entry.parse implem;
+Pcaml.position.val := pos;
value o2b =
fun
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
;;
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. <object-file> Load this file in Camlp4 core.Other options: <file> 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.
+ <object-file> Load this file in Camlp4 core.
+Other options:
+ <file> Parse this file.\n";
print_usage_list ini_sl;
begin
let rec loop =
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 =
;;
let inter_phrases = ref None;;
+
+let position = ref (ref 0, ref 0, ref "");;
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 *)
;;
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;;
(** 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) *)
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' ->
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) =
| 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 ->
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}
;;
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,
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;
Pcaml.parse_interf := Grammar.Entry.parse interf;;
Pcaml.parse_implem := Grammar.Entry.parse implem;;
+Pcaml.position := pos;;
let o2b =
function
(* *)
(***********************************************************************)
-(* $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;
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 () =
# #
#########################################################################
-# $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
*) 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."
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
;(* *)
;(***********************************************************************)
-;(* $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.
. 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.
;(* *)
;(***********************************************************************)
-;(* $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)
(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))
- 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)
(* *)
(***********************************************************************)
-(* $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
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
(List.map (fun s -> Odoc_types.Code s) l)
)
| Odoc_types.Index_list ->
- ""
+ ""
in
String.concat "" (List.map iter t)
)^"\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
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"
)^
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))
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 _
| 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
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 _
| 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
[] -> (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
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
| 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 =
'\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 =
| 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 $ *)
(* *)
(***********************************************************************)
-(* $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 *)
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. *)
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.*)
(** [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.*)
(* *)
(***********************************************************************)
-(* $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. *)
module Signature_search =
struct
- type ele =
+ type ele =
| M of string
| MT of string
| V of string
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
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.*)
(** 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
([], []) ->
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
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 =
| 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
[] ->
| 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
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
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
[] -> 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
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))
let subst_typ = Odoc_env.subst_type env typ in
let met =
{
- met_value =
+ met_value =
{
val_name = complete_name ;
val_info = comment_opt ;
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)
(* 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))
let subst_typ = Odoc_env.subst_type env typ in
let att =
{
- att_value =
+ att_value =
{
val_name = complete_name ;
val_info = comment_opt ;
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)
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" *)
{
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
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
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
(** 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 ;
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)
(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)
| 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
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) =
[] -> 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
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
{
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
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 -> []
| 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
else
None
in
- let new_module =
+ let new_module =
{
m_name = complete_name ;
m_type = sig_module_type;
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
| 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
)
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
| (_, 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
else
None
in
- let new_module =
+ let new_module =
{
m_name = complete_name ;
m_type = sig_module_type;
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
(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
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)
| 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
| 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 ;
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)
let rec f = function
Parsetree.Pmty_ident longident ->
Name.from_longident longident
- | Parsetree.Pmty_signature _ ->
+ | Parsetree.Pmty_signature _ ->
"??"
| Parsetree.Pmty_functor _ ->
"??"
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
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
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)
| 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
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))
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 ;
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)
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 ->
| _ ->
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
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)
match sig_module_type with
Types.Tmty_signature signat ->
Module_struct
- (analyse_parsetree
+ (analyse_parsetree
env
signat
current_module_name
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 _")
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)
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
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 ;
(
raise (Failure "Parsetree.Pcty_fun (parse_label, _, pclass_type), labels différents")
)
-
+
| _ ->
raise (Failure "analyse_class_kind pas de correspondance dans le match")
(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
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)
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)
*)
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
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
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 $ *)
(* *)
(***********************************************************************)
-(* $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, ...). *)
| _ -> ""
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
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 ")"
Format.fprintf fmt "@[<hov 2>";
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;
(if par then ")" else "")
let string_of_type_param_list t =
- let par =
+ let par =
match t.Odoc_type.ty_parameters with
[] | [_] -> false
| _ -> true
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
)
(if par then ")" else "")
let string_of_class_type_param_list l =
- let par =
+ let par =
match l with
[] | [_] -> false
| _ -> true
Printf.sprintf "%s%s%s"
(if par then "[" else "")
(raw_string_of_type_list ", "
- (List.map
+ (List.map
(fun typ -> ("", typ))
l
)
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;
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)^" "
)
| 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
| 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)^";"^
(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)
)
)^
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 $ *)
(* *)
(***********************************************************************)
-(* $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. *)
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 =
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 *)
/* */
/***********************************************************************/
-/* $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 <mlvalues.h>
#include <alloc.h>
+#include <fail.h>
#include <memory.h>
#include <signals.h>
#include "unixsupport.h"
#else
-CAMLprim value unix_accept(value sock) { invalid_argument("accept not implemented"); }
+CAMLprim value unix_accept(value sock)
+{ invalid_argument("accept not implemented"); }
#endif
/* */
/***********************************************************************/
-/* $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 <mlvalues.h>
#include <alloc.h>
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;
/* */
/***********************************************************************/
-/* $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 <fail.h>
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $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 <fail.h>
#include <mlvalues.h>
#include <signals.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $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 <sys/types.h>
#include <sys/stat.h>
+#include <fail.h>
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $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 <fail.h>
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $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 <fail.h>
#include <mlvalues.h>
#include "unixsupport.h"
#ifdef HAS_UNISTD
/* */
/***********************************************************************/
-/* $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 <sys/types.h>
+#include <fail.h>
#include <mlvalues.h>
#include <io.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $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 <string.h>
#include <mlvalues.h>
#include <alloc.h>
-#include <memory.h>
#include <fail.h>
+#include <memory.h>
#include <signals.h>
#include "unixsupport.h"
#include "cst2constr.h"
/* */
/***********************************************************************/
-/* $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 <mlvalues.h>
#include <alloc.h>
+#include <fail.h>
#include "unixsupport.h"
#if !defined (_WIN32) && !macintosh
/* */
/***********************************************************************/
-/* $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 <mlvalues.h>
#include <alloc.h>
+#include <fail.h>
#ifdef HAS_GETGROUPS
/* */
/***********************************************************************/
-/* $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 <string.h>
#include <mlvalues.h>
#include <alloc.h>
-#include <memory.h>
#include <fail.h>
+#include <memory.h>
#include <signals.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $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 <mlvalues.h>
#include <alloc.h>
+#include <fail.h>
#if defined (_WIN32)
#include <winsock.h>
-#elif !macintosh
+#else
#include <sys/param.h>
#endif
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $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 <string.h>
#include <mlvalues.h>
#include <alloc.h>
-#include <memory.h>
#include <fail.h>
+#include <memory.h>
#include <signals.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $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 <fail.h>
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $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 <mlvalues.h>
#include <alloc.h>
-#include <memory.h>
#include <fail.h>
+#include <memory.h>
#include "unixsupport.h"
#ifdef HAS_SOCKETS
/* */
/***********************************************************************/
-/* $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 <mlvalues.h>
#include <alloc.h>
-#include <memory.h>
#include <fail.h>
+#include <memory.h>
#include "unixsupport.h"
#ifdef HAS_SOCKETS
/* */
/***********************************************************************/
-/* $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 <fail.h>
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $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 <mlvalues.h>
#include <alloc.h>
+#include <fail.h>
#include "unixsupport.h"
#ifdef HAS_GETTIMEOFDAY
/* */
/***********************************************************************/
-/* $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 <mlvalues.h>
#include <alloc.h>
+#include <fail.h>
#include <memory.h>
#include "unixsupport.h"
#include <time.h>
#else
-CAMLprim value unix_mktime(value t) { invalid_argument("mktime not implemented"); }
+CAMLprim value unix_mktime(value t)
+{ invalid_argument("mktime not implemented"); }
#endif
/* */
/***********************************************************************/
-/* $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 <mlvalues.h>
#include <alloc.h>
+#include <fail.h>
#include <memory.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $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 <fail.h>
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $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 <errno.h>
#include <fcntl.h>
+#include <fail.h>
#include <mlvalues.h>
#include <signals.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $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 <sys/types.h>
#include <sys/stat.h>
+#include <fail.h>
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $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 <mlvalues.h>
#include <alloc.h>
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);
/* */
/***********************************************************************/
-/* $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 <stdlib.h>
#include <string.h>
+#include <fail.h>
#include <memory.h>
#include <mlvalues.h>
/* */
/***********************************************************************/
-/* $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 <mlvalues.h>
#include <alloc.h>
+#include <fail.h>
#ifdef HAS_SYMLINK
/* */
/***********************************************************************/
-/* $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 <fail.h>
#include <mlvalues.h>
#include "unixsupport.h"
#include <errno.h>
/* */
/***********************************************************************/
-/* $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 <mlvalues.h>
#include <alloc.h>
+#include <fail.h>
#include <memory.h>
#include <signals.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $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 <string.h>
#include <mlvalues.h>
#include <alloc.h>
+#include <fail.h>
#include <memory.h>
#include <signals.h>
#include "unixsupport.h"
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);
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;
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);
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);
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);
/* */
/***********************************************************************/
-/* $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 <fail.h>
#include <mlvalues.h>
#include "unixsupport.h"
#ifdef HAS_UNISTD
/* */
/***********************************************************************/
-/* $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 <fail.h>
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $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 <errno.h>
#include <signal.h>
#include <alloc.h>
+#include <fail.h>
#include <memory.h>
#include <mlvalues.h>
#include <signals.h>
/* */
/***********************************************************************/
-/* $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 <fail.h>
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $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 <mlvalues.h>
#include <alloc.h>
+#include <fail.h>
#include "unixsupport.h"
#ifdef HAS_SOCKETS
/* */
/***********************************************************************/
-/* $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 <mlvalues.h>
#include <alloc.h>
+#include <fail.h>
#include "unixsupport.h"
#ifdef HAS_SOCKETS
/* */
/***********************************************************************/
-/* $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 <mlvalues.h>
#include <alloc.h>
+#include <fail.h>
#include "unixsupport.h"
#ifdef HAS_SOCKETS
/* */
/***********************************************************************/
-/* $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 <fail.h>
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $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 <mlvalues.h>
#include <alloc.h>
+#include <fail.h>
#include "unixsupport.h"
#ifdef HAS_TERMIOS
/* */
/***********************************************************************/
-/* $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 <sys/types.h>
#include <mlvalues.h>
+#include <fail.h>
#include <io.h>
#include "unixsupport.h"
#ifdef HAS_UNISTD
(* *)
(***********************************************************************)
-(* $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
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 =
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 *)
/* */
/***********************************************************************/
-/* $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 <fail.h>
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $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 <mlvalues.h>
#include <alloc.h>
+#include <fail.h>
#include <memory.h>
#include <signals.h>
#include "unixsupport.h"
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);
(* *)
(***********************************************************************)
-(* $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. *)
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
(* *)
(***********************************************************************)
-(* $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 *)
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
(* *)
(***********************************************************************)
-(* $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. *)
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
(* *)
(***********************************************************************)
-(* $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 *)
(* OCaml version string, must be in the format described in sys.mli. *)
-let ocaml_version = "3.08.1";;
+let ocaml_version = "3.08.2";;
(* *)
(***********************************************************************)
-(* $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
let idprefix = "__ocaml_prof_";;
let modprefix = "OCAML__prof_";;
-
(* Errors specific to the profiler *)
exception Profiler of string
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)
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 =
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;
(* *)
(***********************************************************************)
-(* $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
(* *)
(***********************************************************************)
-(* $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;;
/* 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 <string.h>
#include "defs.h"
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;
projects / ocaml.git / commitdiff