Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Attach documentation comments to Parsetree 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@16189 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Leo White 2015-06-28 13:11:50 +00:00
parent a90f0e4c63
commit 5c55e4cc08
44 changed files with 1179 additions and 394 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
.depend
View File

@ -25,9 +25,10 @@ utils/terminfo.cmx : utils/terminfo.cmi
utils/warnings.cmo : utils/warnings.cmi
utils/warnings.cmx : utils/warnings.cmi
parsing/ast_helper.cmi : parsing/parsetree.cmi parsing/longident.cmi \
parsing/location.cmi parsing/asttypes.cmi
parsing/location.cmi parsing/docstrings.cmi parsing/asttypes.cmi
parsing/ast_mapper.cmi : parsing/parsetree.cmi parsing/location.cmi
parsing/asttypes.cmi : parsing/location.cmi
parsing/docstrings.cmi : parsing/location.cmi parsing/parsetree.cmi
parsing/lexer.cmi : parsing/parser.cmi parsing/location.cmi
parsing/location.cmi : utils/warnings.cmi
parsing/longident.cmi :
@ -40,9 +41,11 @@ parsing/pprintast.cmi : parsing/parsetree.cmi parsing/longident.cmi \
parsing/printast.cmi : parsing/parsetree.cmi
parsing/syntaxerr.cmi : parsing/location.cmi
parsing/ast_helper.cmo : parsing/parsetree.cmi parsing/longident.cmi \
parsing/location.cmi parsing/asttypes.cmi parsing/ast_helper.cmi
parsing/location.cmi parsing/docstrings.cmi parsing/asttypes.cmi \
parsing/ast_helper.cmi
parsing/ast_helper.cmx : parsing/parsetree.cmi parsing/longident.cmx \
parsing/location.cmx parsing/asttypes.cmi parsing/ast_helper.cmi
parsing/location.cmx parsing/docstrings.cmx parsing/asttypes.cmi \
parsing/ast_helper.cmi
parsing/ast_mapper.cmo : parsing/parsetree.cmi utils/misc.cmi \
parsing/longident.cmi parsing/location.cmi utils/config.cmi \
utils/clflags.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \
@ -51,10 +54,14 @@ parsing/ast_mapper.cmx : parsing/parsetree.cmi utils/misc.cmx \
parsing/longident.cmx parsing/location.cmx utils/config.cmx \
utils/clflags.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \
parsing/ast_mapper.cmi
parsing/docstrings.cmo : utils/warnings.cmi parsing/location.cmi \
parsing/docstrings.cmi
parsing/docstrings.cmx : utils/warnings.cmx parsing/location.cmx \
parsing/docstrings.cmi
parsing/lexer.cmo : utils/warnings.cmi parsing/parser.cmi utils/misc.cmi \
parsing/location.cmi parsing/lexer.cmi
parsing/location.cmi parsing/docstrings.cmi parsing/lexer.cmi
parsing/lexer.cmx : utils/warnings.cmx parsing/parser.cmx utils/misc.cmx \
parsing/location.cmx parsing/lexer.cmi
parsing/location.cmx parsing/docstrings.cmx parsing/lexer.cmi
parsing/location.cmo : utils/warnings.cmi utils/terminfo.cmi \
parsing/location.cmi
parsing/location.cmx : utils/warnings.cmx utils/terminfo.cmx \
@ -62,9 +69,11 @@ parsing/location.cmx : utils/warnings.cmx utils/terminfo.cmx \
parsing/longident.cmo : utils/misc.cmi parsing/longident.cmi
parsing/longident.cmx : utils/misc.cmx parsing/longident.cmi
parsing/parse.cmo : parsing/syntaxerr.cmi parsing/parser.cmi \
parsing/location.cmi parsing/lexer.cmi parsing/parse.cmi
parsing/location.cmi parsing/lexer.cmi parsing/docstrings.cmi \
parsing/parse.cmi
parsing/parse.cmx : parsing/syntaxerr.cmx parsing/parser.cmx \
parsing/location.cmx parsing/lexer.cmx parsing/parse.cmi
parsing/location.cmx parsing/lexer.cmx parsing/docstrings.cmx \
parsing/parse.cmi
parsing/parser.cmo : parsing/syntaxerr.cmi parsing/parsetree.cmi \
parsing/longident.cmi parsing/location.cmi utils/clflags.cmi \
parsing/asttypes.cmi parsing/ast_helper.cmi parsing/parser.cmi

1
Changes
View File

@ -182,6 +182,7 @@ Compilers:
(Alain Frisch)
- GPR#159: Better locations for structure/signature items
(Leo White)
- GPR#149: Attach documentation comments to parse tree (Leo White)
Toplevel and debugger:
- PR#5958: generalized polymorphic #install_printer

4
Makefile
View File

@ -17,7 +17,7 @@ include stdlib/StdlibModules
CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot
CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib -I otherlibs/dynlink
COMPFLAGS=-strict-sequence -w +33..39+48 -warn-error A -bin-annot \
COMPFLAGS=-strict-sequence -w +33..39+48+50 -warn-error A -bin-annot \
-safe-string $(INCLUDES)
LINKFLAGS=
@ -43,7 +43,7 @@ UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \
utils/consistbl.cmo
PARSING=parsing/location.cmo parsing/longident.cmo \
parsing/ast_helper.cmo \
parsing/docstrings.cmo parsing/ast_helper.cmo \
parsing/syntaxerr.cmo parsing/parser.cmo \
parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo \
parsing/pprintast.cmo \

2
Makefile.nt
View File

@ -39,7 +39,7 @@ UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \
utils/consistbl.cmo
PARSING=parsing/location.cmo parsing/longident.cmo \
parsing/ast_helper.cmo \
parsing/docstrings.cmo parsing/ast_helper.cmo \
parsing/syntaxerr.cmo parsing/parser.cmo \
parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo \
parsing/pprintast.cmo \

2
debugger/Makefile.shared
View File

@ -32,7 +32,7 @@ OTHEROBJS=\
$(UNIXDIR)/unix.cma \
../utils/misc.cmo ../utils/config.cmo ../utils/tbl.cmo \
../utils/clflags.cmo ../utils/consistbl.cmo ../utils/warnings.cmo \
../parsing/location.cmo ../parsing/longident.cmo \
../parsing/location.cmo ../parsing/longident.cmo ../parsing/docstrings.cmo \
../parsing/ast_helper.cmo ../parsing/ast_mapper.cmo \
../typing/ident.cmo ../typing/path.cmo ../typing/types.cmo \
../typing/btype.cmo ../typing/primitive.cmo ../typing/typedtree.cmo \

1
driver/compenv.ml
View File

@ -175,6 +175,7 @@ let read_OCAMLPARAM ppf position =
| "verbose" -> set "verbose" [ verbose ] v
| "nopervasives" -> set "nopervasives" [ nopervasives ] v
| "slash" -> set "slash" [ force_slash ] v (* for ocamldep *)
| "keep-docs" -> set "keep-docs" [ Clflags.keep_docs ] v
| "keep-locs" -> set "keep-locs" [ Clflags.keep_locs ] v
| "compact" -> clear "compact" [ optimize_for_speed ] v

1
driver/main.ml
View File

@ -89,6 +89,7 @@ module Options = Main_args.Make_bytecomp_options (struct
let _impl = impl
let _intf = intf
let _intf_suffix s = Config.interface_suffix := s
let _keep_docs = set keep_docs
let _keep_locs = set keep_locs
let _labels = unset classic
let _linkall = set link_everything

7
driver/main_args.ml
View File

@ -126,6 +126,10 @@ let mk_intf_suffix_2 f =
"-intf_suffix", Arg.String f, "<string> (deprecated) same as -intf-suffix"
;;
let mk_keep_docs f =
"-keep-docs", Arg.Unit f, " Keep documentation strings in .cmi files"
;;
let mk_keep_locs f =
"-keep-locs", Arg.Unit f, " Keep locations in .cmi files"
;;
@ -524,6 +528,7 @@ module type Compiler_options = sig
val _impl : string -> unit
val _intf : string -> unit
val _intf_suffix : string -> unit
val _keep_docs : unit -> unit
val _keep_locs : unit -> unit
val _linkall : unit -> unit
val _noautolink : unit -> unit
@ -663,6 +668,7 @@ struct
mk_intf F._intf;
mk_intf_suffix F._intf_suffix;
mk_intf_suffix_2 F._intf_suffix;
mk_keep_docs F._keep_docs;
mk_keep_locs F._keep_locs;
mk_labels F._labels;
mk_linkall F._linkall;
@ -782,6 +788,7 @@ struct
mk_inline F._inline;
mk_intf F._intf;
mk_intf_suffix F._intf_suffix;
mk_keep_docs F._keep_docs;
mk_keep_locs F._keep_locs;
mk_labels F._labels;
mk_linkall F._linkall;

1
driver/main_args.mli
View File

@ -62,6 +62,7 @@ module type Compiler_options = sig
val _impl : string -> unit
val _intf : string -> unit
val _intf_suffix : string -> unit
val _keep_docs : unit -> unit
val _keep_locs : unit -> unit
val _linkall : unit -> unit
val _noautolink : unit -> unit

1
driver/optmain.ml
View File

@ -89,6 +89,7 @@ module Options = Main_args.Make_optcomp_options (struct
let _inline n = inline_threshold := n * 8
let _intf = intf
let _intf_suffix s = Config.interface_suffix := s
let _keep_docs = set keep_docs
let _keep_locs = set keep_locs
let _labels = clear classic
let _linkall = set link_everything

20
man/ocamlc.m
View File

@ -374,6 +374,9 @@ Recognize file names ending with
.I string
as interface files (instead of the default .mli).
.TP
.B \-keep-docs
Keep documentation strings in generated .cmi files.
.TP
.B \-keep-locs
Keep locations in generated .cmi files.
.TP
@ -829,6 +832,21 @@ mutually recursive types.
45
\ \ Open statement shadows an already defined label or constructor.
46
\ \ Error in environment variable.
47
\ \ Illegal attribute payload.
48
\ \ Implicit elimination of optional arguments.
49
\ \ Missing cmi file when looking up module alias.
50
\ \ Unexpected documentation comment.
The letters stand for the following sets of warnings. Any letter not
mentioned here corresponds to the empty set.
@ -882,7 +900,7 @@ mentioned here corresponds to the empty set.
.IP
The default setting is
.BR \-w\ +a\-4\-6\-7\-9\-27\-29\-32..39\-41..42\-44\-45 .
.BR \-w\ +a\-4\-6\-7\-9\-27\-29\-32..39\-41\-42\-44\-45\-48\-50 .
Note that warnings
.BR 5 \ and \ 10
are not always triggered, depending on the internals of the type checker.

3
man/ocamlopt.m
View File

@ -304,6 +304,9 @@ Recognize file names ending with
as interface files (instead of the default .mli).
.TP
.B \-keep-locs
Keep documentation strings in generated .cmi files.
.TP
.B \-keep-locs
Keep locations in generated .cmi files.
.TP
.B \-labels

1
ocamlbuild/ocaml_specific.ml
View File

@ -738,6 +738,7 @@ flag ["ocaml"; "compile"; "no_alias_deps";] (A "-no-alias-deps");;
flag ["ocaml"; "compile"; "strict_formats";] (A "-strict-formats");;
flag ["ocaml"; "native"; "compile"; "opaque";] (A "-opaque");;
flag ["ocaml"; "native"; "compile"; "no_float_const_prop";] (A "-no-float-const-prop");
flag ["ocaml"; "compile"; "keep_docs";] (A "-keep-docs");
flag ["ocaml"; "compile"; "keep_locs";] (A "-keep-locs");
flag ["ocaml"; "absname"; "compile"] (A "-absname");;
flag ["ocaml"; "absname"; "infer_interface"] (A "-absname");;

2
otherlibs/dynlink/Makefile
View File

@ -32,7 +32,7 @@ COMPILEROBJS=\
../../utils/terminfo.cmo ../../utils/warnings.cmo \
../../parsing/asttypes.cmi \
../../parsing/location.cmo ../../parsing/longident.cmo \
../../parsing/ast_helper.cmo \
../../parsing/docstrings.cmo ../../parsing/ast_helper.cmo \
../../parsing/ast_mapper.cmo \
../../typing/ident.cmo ../../typing/path.cmo \
../../typing/primitive.cmo ../../typing/types.cmo \

119
parsing/ast_helper.ml
View File

@ -14,6 +14,7 @@
open Asttypes
open Parsetree
open Docstrings
type lid = Longident.t loc
type str = string loc
@ -169,6 +170,10 @@ module Sig = struct
let class_type ?loc a = mk ?loc (Psig_class_type a)
let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs))
let attribute ?loc a = mk ?loc (Psig_attribute a)
let text txt =
List.map
(fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
txt
end
module Str = struct
@ -189,6 +194,10 @@ module Str = struct
let include_ ?loc a = mk ?loc (Pstr_include a)
let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs))
let attribute ?loc a = mk ?loc (Pstr_attribute a)
let text txt =
List.map
(fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
txt
end
module Cl = struct
@ -225,13 +234,13 @@ module Cty = struct
end
module Ctf = struct
let mk ?(loc = !default_loc) ?(attrs = []) d =
let mk ?(loc = !default_loc) ?(attrs = [])
?(docs = empty_docs) d =
{
pctf_desc = d;
pctf_loc = loc;
pctf_attributes = attrs;
pctf_attributes = add_docs_attrs docs attrs;
}
let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]}
let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a)
let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d))
@ -239,16 +248,23 @@ module Ctf = struct
let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b))
let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a)
let attribute ?loc a = mk ?loc (Pctf_attribute a)
let text txt =
List.map
(fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
txt
let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]}
end
module Cf = struct
let mk ?(loc = !default_loc) ?(attrs = []) d =
let mk ?(loc = !default_loc) ?(attrs = [])
?(docs = empty_docs) d =
{
pcf_desc = d;
pcf_loc = loc;
pcf_attributes = attrs;
pcf_attributes = add_docs_attrs docs attrs;
}
let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]}
let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c))
let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c))
@ -257,96 +273,117 @@ module Cf = struct
let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a)
let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a)
let attribute ?loc a = mk ?loc (Pcf_attribute a)
let text txt =
List.map
(fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
txt
let virtual_ ct = Cfk_virtual ct
let concrete o e = Cfk_concrete (o, e)
let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]}
end
module Val = struct
let mk ?(loc = !default_loc) ?(attrs = []) ?(prim = []) name typ =
let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
?(prim = []) name typ =
{
pval_name = name;
pval_type = typ;
pval_attributes = attrs;
pval_attributes = add_docs_attrs docs attrs;
pval_loc = loc;
pval_prim = prim;
}
end
module Md = struct
let mk ?(loc = !default_loc) ?(attrs = []) name typ =
let mk ?(loc = !default_loc) ?(attrs = [])
?(docs = empty_docs) ?(text = []) name typ =
{
pmd_name = name;
pmd_type = typ;
pmd_attributes = attrs;
pmd_attributes =
add_text_attrs text (add_docs_attrs docs attrs);
pmd_loc = loc;
}
end
module Mtd = struct
let mk ?(loc = !default_loc) ?(attrs = []) ?typ name =
let mk ?(loc = !default_loc) ?(attrs = [])
?(docs = empty_docs) ?(text = []) ?typ name =
{
pmtd_name = name;
pmtd_type = typ;
pmtd_attributes = attrs;
pmtd_attributes =
add_text_attrs text (add_docs_attrs docs attrs);
pmtd_loc = loc;
}
end
module Mb = struct
let mk ?(loc = !default_loc) ?(attrs = []) name expr =
let mk ?(loc = !default_loc) ?(attrs = [])
?(docs = empty_docs) ?(text = []) name expr =
{
pmb_name = name;
pmb_expr = expr;
pmb_attributes = attrs;
pmb_attributes =
add_text_attrs text (add_docs_attrs docs attrs);
pmb_loc = loc;
}
end
module Opn = struct
let mk ?(loc = !default_loc) ?(attrs = []) ?(override = Fresh) lid =
let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
?(override = Fresh) lid =
{
popen_lid = lid;
popen_override = override;
popen_loc = loc;
popen_attributes = attrs;
popen_attributes = add_docs_attrs docs attrs;
}
end
module Incl = struct
let mk ?(loc = !default_loc) ?(attrs = []) mexpr =
let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr =
{
pincl_mod = mexpr;
pincl_loc = loc;
pincl_attributes = attrs;
pincl_attributes = add_docs_attrs docs attrs;
}
end
module Vb = struct
let mk ?(loc = !default_loc) ?(attrs = []) pat expr =
let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
?(text = []) pat expr =
{
pvb_pat = pat;
pvb_expr = expr;
pvb_attributes = attrs;
pvb_attributes =
add_text_attrs text (add_docs_attrs docs attrs);
pvb_loc = loc;
}
end
module Ci = struct
let mk ?(loc = !default_loc) ?(attrs = []) ?(virt = Concrete) ?(params = [])
name expr =
let mk ?(loc = !default_loc) ?(attrs = [])
?(docs = empty_docs) ?(text = [])
?(virt = Concrete) ?(params = []) name expr =
{
pci_virt = virt;
pci_params = params;
pci_name = name;
pci_expr = expr;
pci_attributes = attrs;
pci_attributes =
add_text_attrs text (add_docs_attrs docs attrs);
pci_loc = loc;
}
end
module Type = struct
let mk ?(loc = !default_loc) ?(attrs = [])
?(docs = empty_docs) ?(text = [])
?(params = [])
?(cstrs = [])
?(kind = Ptype_abstract)
@ -360,65 +397,73 @@ module Type = struct
ptype_kind = kind;
ptype_private = priv;
ptype_manifest = manifest;
ptype_attributes = attrs;
ptype_attributes =
add_text_attrs text (add_docs_attrs docs attrs);
ptype_loc = loc;
}
let constructor ?(loc = !default_loc) ?(attrs = []) ?(args = Pcstr_tuple []) ?res name =
let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info)
?(args = Pcstr_tuple []) ?res name =
{
pcd_name = name;
pcd_args = args;
pcd_res = res;
pcd_loc = loc;
pcd_attributes = attrs;
pcd_attributes = add_info_attrs info attrs;
}
let field ?(loc = !default_loc) ?(attrs = []) ?(mut = Immutable) name typ =
let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info)
?(mut = Immutable) name typ =
{
pld_name = name;
pld_mutable = mut;
pld_type = typ;
pld_loc = loc;
pld_attributes = attrs;
pld_attributes = add_info_attrs info attrs;
}
end
(** Type extensions *)
module Te = struct
let mk ?(attrs = []) ?(params = []) ?(priv = Public) path constructors =
let mk ?(attrs = []) ?(docs = empty_docs)
?(params = []) ?(priv = Public) path constructors =
{
ptyext_path = path;
ptyext_params = params;
ptyext_constructors = constructors;
ptyext_private = priv;
ptyext_attributes = attrs;
ptyext_attributes = add_docs_attrs docs attrs;
}
let constructor ?(loc = !default_loc) ?(attrs = []) name kind =
let constructor ?(loc = !default_loc) ?(attrs = [])
?(docs = empty_docs) ?(info = empty_info) name kind =
{
pext_name = name;
pext_kind = kind;
pext_loc = loc;
pext_attributes = attrs;
pext_attributes = add_docs_attrs docs (add_info_attrs info attrs);
}
let decl ?(loc = !default_loc) ?(attrs = []) ?(args = Pcstr_tuple []) ?res name =
let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
?(info = empty_info) ?(args = Pcstr_tuple []) ?res name =
{
pext_name = name;
pext_kind = Pext_decl(args, res);
pext_loc = loc;
pext_attributes = attrs;
pext_attributes = add_docs_attrs docs (add_info_attrs info attrs);
}
let rebind ?(loc = !default_loc) ?(attrs = []) name lid =
let rebind ?(loc = !default_loc) ?(attrs = [])
?(docs = empty_docs) ?(info = empty_info) name lid =
{
pext_name = name;
pext_kind = Pext_rebind lid;
pext_loc = loc;
pext_attributes = attrs;
pext_attributes = add_docs_attrs docs (add_info_attrs info attrs);
}
end
end
module Csig = struct
let mk self fields =

60
parsing/ast_helper.mli
View File

@ -14,6 +14,7 @@
open Parsetree
open Asttypes
open Docstrings
type lid = Longident.t loc
type str = string loc
@ -24,6 +25,7 @@ type attrs = attribute list
val default_loc: loc ref
(** Default value for all optional location arguments. *)
val with_default_loc: loc -> (unit -> 'a) -> 'a
(** Set the [default_loc] within the scope of the execution
of the provided function. *)
@ -146,27 +148,38 @@ module Exp:
(** Value declarations *)
module Val:
sig
val mk: ?loc:loc -> ?attrs:attrs -> ?prim:string list -> str -> core_type -> value_description
val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
?prim:string list -> str -> core_type -> value_description
end
(** Type declarations *)
module Type:
sig
val mk: ?loc:loc -> ?attrs:attrs -> ?params:(core_type * variance) list -> ?cstrs:(core_type * core_type * loc) list -> ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> type_declaration
val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
?params:(core_type * variance) list -> ?cstrs:(core_type * core_type * loc) list ->
?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str ->
type_declaration
val constructor: ?loc:loc -> ?attrs:attrs -> ?args:constructor_arguments -> ?res:core_type -> str -> constructor_declaration
val field: ?loc:loc -> ?attrs:attrs -> ?mut:mutable_flag -> str -> core_type -> label_declaration
val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info ->
?args:constructor_arguments -> ?res:core_type -> str -> constructor_declaration
val field: ?loc:loc -> ?attrs:attrs -> ?info:info ->
?mut:mutable_flag -> str -> core_type -> label_declaration
end
(** Type extensions *)
module Te:
sig
val mk: ?attrs:attrs -> ?params:(core_type * variance) list -> ?priv:private_flag -> lid -> extension_constructor list -> type_extension
val mk: ?attrs:attrs -> ?docs:docs ->
?params:(core_type * variance) list -> ?priv:private_flag ->
lid -> extension_constructor list -> type_extension
val constructor: ?loc:loc -> ?attrs:attrs -> str -> extension_constructor_kind -> extension_constructor
val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->
str -> extension_constructor_kind -> extension_constructor
val decl: ?loc:loc -> ?attrs:attrs -> ?args:constructor_arguments -> ?res:core_type -> str -> extension_constructor
val rebind: ?loc:loc -> ?attrs:attrs -> str -> lid -> extension_constructor
val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->
?args:constructor_arguments -> ?res:core_type -> str -> extension_constructor
val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->
str -> lid -> extension_constructor
end
(** {2 Module language} *)
@ -221,6 +234,7 @@ module Sig:
val class_type: ?loc:loc -> class_type_declaration list -> signature_item
val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item
val attribute: ?loc:loc -> attribute -> signature_item
val text: text -> signature_item list
end
(** Structure items *)
@ -243,43 +257,49 @@ module Str:
val include_: ?loc:loc -> include_declaration -> structure_item
val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item
val attribute: ?loc:loc -> attribute -> structure_item
val text: text -> structure_item list
end
(** Module declarations *)
module Md:
sig
val mk: ?loc:loc -> ?attrs:attrs -> str -> module_type -> module_declaration
val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
str -> module_type -> module_declaration
end
(** Module type declarations *)
module Mtd:
sig
val mk: ?loc:loc -> ?attrs:attrs -> ?typ:module_type -> str -> module_type_declaration
val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
?typ:module_type -> str -> module_type_declaration
end
(** Module bindings *)
module Mb:
sig
val mk: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> module_binding
val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
str -> module_expr -> module_binding
end
(* Opens *)
module Opn:
sig
val mk: ?loc: loc -> ?attrs:attrs -> ?override:override_flag -> lid -> open_description
val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs ->
?override:override_flag -> lid -> open_description
end
(* Includes *)
module Incl:
sig
val mk: ?loc: loc -> ?attrs:attrs -> 'a -> 'a include_infos
val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos
end
(** Value bindings *)
module Vb:
sig
val mk: ?loc: loc -> ?attrs:attrs -> pattern -> expression -> value_binding
val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
pattern -> expression -> value_binding
end
@ -300,7 +320,8 @@ module Cty:
(** Class type fields *)
module Ctf:
sig
val mk: ?loc:loc -> ?attrs:attrs -> class_type_field_desc -> class_type_field
val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs ->
class_type_field_desc -> class_type_field
val attr: class_type_field -> attribute -> class_type_field
val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field
@ -309,6 +330,7 @@ module Ctf:
val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> class_type_field
val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field
val attribute: ?loc:loc -> attribute -> class_type_field
val text: text -> class_type_field list
end
(** Class expressions *)
@ -332,7 +354,7 @@ module Cl:
(** Class fields *)
module Cf:
sig
val mk: ?loc:loc -> ?attrs:attrs -> class_field_desc -> class_field
val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> class_field
val attr: class_field -> attribute -> class_field
val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr -> string option -> class_field
@ -342,15 +364,19 @@ module Cf:
val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field
val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field
val attribute: ?loc:loc -> attribute -> class_field
val text: text -> class_field list
val virtual_: core_type -> class_field_kind
val concrete: override_flag -> expression -> class_field_kind
end
(** Classes *)
module Ci:
sig
val mk: ?loc:loc -> ?attrs:attrs -> ?virt:virtual_flag -> ?params:(core_type * variance) list -> str -> 'a -> 'a class_infos
val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
?virt:virtual_flag -> ?params:(core_type * variance) list ->
str -> 'a -> 'a class_infos
end
(** Class signatures *)

344
parsing/docstrings.ml Normal file
View File

@ -0,0 +1,344 @@
(***********************************************************************)
(* *)
(* OCaml *)
(* *)
(* Leo White *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the Q Public License version 1.0. *)
(* *)
(***********************************************************************)
open Location
(* Docstrings *)
(* A docstring is "attached" if it has been inserted in the AST. This
is used for generating unexpected docstring warnings. *)
type ds_attached =
| Unattached (* Not yet attached anything.*)
| Info (* Attached to a field or constructor. *)
| Docs (* Attached to an item or as floating text. *)
(* A docstring is "associated" with an item if there are no blank lines between
them. This is used for generating docstring ambiguity warnings. *)
type ds_associated =
| Zero (* Not associated with an item *)
| One (* Associated with one item *)
| Many (* Associated with multiple items (ambiguity) *)
type docstring =
{ ds_body: string;
ds_loc: Location.t;
mutable ds_attached: ds_attached;
mutable ds_associated: ds_associated; }
(* List of docstrings *)
let docstrings : docstring list ref = ref []
(* Warn for unused and ambiguous docstrings *)
let warn_bad_docstrings () =
if Warnings.is_active (Warnings.Bad_docstring true) then begin
List.iter
(fun ds ->
match ds.ds_attached with
| Info -> ()
| Unattached ->
prerr_warning ds.ds_loc (Warnings.Bad_docstring true)
| Docs ->
match ds.ds_associated with
| Zero | One -> ()
| Many ->
prerr_warning ds.ds_loc (Warnings.Bad_docstring false))
(List.rev !docstrings)
end
(* Docstring constructors and descturctors *)
let docstring body loc =
let ds =
{ ds_body = body;
ds_loc = loc;
ds_attached = Unattached;
ds_associated = Zero; }
in
docstrings := ds :: !docstrings;
ds
let docstring_body ds = ds.ds_body
let docstring_loc ds = ds.ds_loc
(* Docstrings attached to items *)
type docs =
{ docs_pre: docstring option;
docs_post: docstring option; }
let empty_docs = { docs_pre = None; docs_post = None }
let doc_loc = {txt = "ocaml.doc"; loc = Location.none}
let docs_attr ds =
let open Asttypes in
let open Parsetree in
let exp =
{ pexp_desc = Pexp_constant (Const_string(ds.ds_body, None));
pexp_loc = ds.ds_loc;
pexp_attributes = []; }
in
let item =
{ pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc }
in
(doc_loc, PStr [item])
let add_docs_attrs docs attrs =
let attrs =
match docs.docs_pre with
| None -> attrs
| Some ds -> docs_attr ds :: attrs
in
let attrs =
match docs.docs_post with
| None -> attrs
| Some ds -> attrs @ [docs_attr ds]
in
attrs
(* Docstrings attached to consturctors or fields *)
type info = docstring option
let empty_info = None
let info_attr = docs_attr
let add_info_attrs info attrs =
let attrs =
match info with
| None -> attrs
| Some ds -> attrs @ [info_attr ds]
in
attrs
(* Docstrings not attached to a specifc item *)
type text = docstring list
let empty_text = []
let text_loc = {txt = "ocaml.text"; loc = Location.none}
let text_attr ds =
let open Asttypes in
let open Parsetree in
let exp =
{ pexp_desc = Pexp_constant (Const_string(ds.ds_body, None));
pexp_loc = ds.ds_loc;
pexp_attributes = []; }
in
let item =
{ pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc }
in
(text_loc, PStr [item])
let add_text_attrs dsl attrs =
(List.map text_attr dsl) @ attrs
(* Find the first non-info docstring in a list, attach it and return it *)
let get_docstring ~info dsl =
let rec loop = function
| [] -> None
| {ds_attached = Info; _} :: rest -> loop rest
| ds :: rest ->
ds.ds_attached <- if info then Info else Docs;
Some ds
in
loop dsl
(* Find all the non-info docstrings in a list, attach them and return them *)
let get_docstrings dsl =
let rec loop acc = function
| [] -> List.rev acc
| {ds_attached = Info; _} :: rest -> loop acc rest
| ds :: rest ->
ds.ds_attached <- Docs;
loop (ds :: acc) rest
in
loop [] dsl
(* "Associate" all the docstrings in a list *)
let associate_docstrings dsl =
List.iter
(fun ds ->
match ds.ds_associated with
| Zero -> ds.ds_associated <- One
| (One | Many) -> ds.ds_associated <- Many)
dsl
(* Map from positions to pre docstrings *)
let pre_table : (Lexing.position, docstring list) Hashtbl.t =
Hashtbl.create 50
let set_pre_docstrings pos dsl =
if dsl <> [] then Hashtbl.add pre_table pos dsl
let get_pre_docs pos =
try
let dsl = Hashtbl.find pre_table pos in
associate_docstrings dsl;
get_docstring ~info:false dsl
with Not_found -> None
let mark_pre_docs pos =
try
let dsl = Hashtbl.find pre_table pos in
associate_docstrings dsl
with Not_found -> ()
(* Map from positions to post docstrings *)
let post_table : (Lexing.position, docstring list) Hashtbl.t =
Hashtbl.create 50
let set_post_docstrings pos dsl =
if dsl <> [] then Hashtbl.add post_table pos dsl
let get_post_docs pos =
try
let dsl = Hashtbl.find post_table pos in
associate_docstrings dsl;
get_docstring ~info:false dsl
with Not_found -> None
let mark_post_docs pos =
try
let dsl = Hashtbl.find post_table pos in
associate_docstrings dsl
with Not_found -> ()
let get_info pos =
try
let dsl = Hashtbl.find post_table pos in
get_docstring ~info:true dsl
with Not_found -> None
(* Map from positions to floating docstrings *)
let floating_table : (Lexing.position, docstring list) Hashtbl.t =
Hashtbl.create 50
let set_floating_docstrings pos dsl =
if dsl <> [] then Hashtbl.add floating_table pos dsl
let get_text pos =
try
let dsl = Hashtbl.find floating_table pos in
get_docstrings dsl
with Not_found -> []
(* Maps from positions to extra docstrings *)
let pre_extra_table : (Lexing.position, docstring list) Hashtbl.t =
Hashtbl.create 50
let set_pre_extra_docstrings pos dsl =
if dsl <> [] then Hashtbl.add pre_extra_table pos dsl
let get_pre_extra_text pos =
try
let dsl = Hashtbl.find pre_extra_table pos in
get_docstrings dsl
with Not_found -> []
let post_extra_table : (Lexing.position, docstring list) Hashtbl.t =
Hashtbl.create 50
let set_post_extra_docstrings pos dsl =
if dsl <> [] then Hashtbl.add post_extra_table pos dsl
let get_post_extra_text pos =
try
let dsl = Hashtbl.find post_extra_table pos in
get_docstrings dsl
with Not_found -> []
(* Docstrings from parser actions *)
let symbol_docs () =
{ docs_pre = get_pre_docs (Parsing.symbol_start_pos ());
docs_post = get_post_docs (Parsing.symbol_end_pos ()); }
let symbol_docs_lazy () =
let p1 = Parsing.symbol_start_pos () in
let p2 = Parsing.symbol_end_pos () in
lazy { docs_pre = get_pre_docs p1;
docs_post = get_post_docs p2; }
let rhs_docs pos1 pos2 =
{ docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1);
docs_post = get_post_docs (Parsing.rhs_end_pos pos2); }
let rhs_docs_lazy pos1 pos2 =
let p1 = Parsing.rhs_start_pos pos1 in
let p2 = Parsing.rhs_end_pos pos2 in
lazy { docs_pre = get_pre_docs p1;
docs_post = get_post_docs p2; }
let mark_symbol_docs () =
mark_pre_docs (Parsing.symbol_start_pos ());
mark_post_docs (Parsing.symbol_end_pos ())
let mark_rhs_docs pos1 pos2 =
mark_pre_docs (Parsing.rhs_start_pos pos1);
mark_post_docs (Parsing.rhs_end_pos pos2)
let symbol_info () =
get_info (Parsing.symbol_end_pos ())
let rhs_info pos =
get_info (Parsing.rhs_end_pos pos)
let symbol_text () =
get_text (Parsing.symbol_start_pos ())
let symbol_text_lazy () =
let pos = Parsing.symbol_start_pos () in
lazy (get_text pos)
let rhs_text pos =
get_text (Parsing.rhs_start_pos pos)
let rhs_text_lazy pos =
let pos = Parsing.rhs_start_pos pos in
lazy (get_text pos)
let symbol_pre_extra_text () =
get_pre_extra_text (Parsing.symbol_start_pos ())
let symbol_post_extra_text () =
get_post_extra_text (Parsing.symbol_end_pos ())
let rhs_pre_extra_text pos =
get_pre_extra_text (Parsing.rhs_start_pos pos)
let rhs_post_extra_text pos =
get_post_extra_text (Parsing.rhs_end_pos pos)
(* (Re)Initialise all comment state *)
let init () =
docstrings := [];
Hashtbl.reset pre_table;
Hashtbl.reset post_table;
Hashtbl.reset floating_table;
Hashtbl.reset pre_extra_table;
Hashtbl.reset post_extra_table

148
parsing/docstrings.mli Normal file
View File

@ -0,0 +1,148 @@
(***********************************************************************)
(* *)
(* OCaml *)
(* *)
(* Leo White *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(** (Re)Initialise all docstring state *)
val init : unit -> unit
(** Emit warnings for unattached and ambiguous docstrings *)
val warn_bad_docstrings : unit -> unit
(** {3 Docstrings} *)
(** Documentation comments *)
type docstring
(** Create a docstring *)
val docstring : string -> Location.t -> docstring
(** Get the text of a docstring *)
val docstring_body : docstring -> string
(** Get the location of a docstring *)
val docstring_loc : docstring -> Location.t
(** {3 Set functions}
These functions are used by the lexer to associate docstrings to
the locations of tokens. *)
(** Docstrings immediately preceding a token *)
val set_pre_docstrings : Lexing.position -> docstring list -> unit
(** Docstrings immediately following a token *)
val set_post_docstrings : Lexing.position -> docstring list -> unit
(** Docstrings not immediately adjacent to a token *)
val set_floating_docstrings : Lexing.position -> docstring list -> unit
(** Docstrings immediately following the token which precedes this one *)
val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit
(** Docstrings immediately preceding the token which follows this one *)
val set_post_extra_docstrings : Lexing.position -> docstring list -> unit
(** {3 Items}
The {!docs} type represents documentation attached to an item. *)
type docs =
{ docs_pre: docstring option;
docs_post: docstring option; }
val empty_docs : docs
val docs_attr : docstring -> Parsetree.attribute
(** Convert item documentation to attributes and add them to an
attribute list *)
val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes
(** Fetch the item documentation for the current symbol. This also
marks this documentation (for ambiguity warnings). *)
val symbol_docs : unit -> docs
val symbol_docs_lazy : unit -> docs Lazy.t
(** Fetch the item documentation for the symbols between two
positions. This also marks this documentation (for ambiguity
warnings). *)
val rhs_docs : int -> int -> docs
val rhs_docs_lazy : int -> int -> docs Lazy.t
(** Mark the item documentation for the current symbol (for ambiguity
warnings). *)
val mark_symbol_docs : unit -> unit
(** Mark as associated the item documentation for the symbols between
two positions (for ambiguity warnings) *)
val mark_rhs_docs : int -> int -> unit
(** {3 Fields and constructors}
The {!info} type represents documentation attached to a field or
constructor. *)
type info = docstring option
val empty_info : info
val info_attr : docstring -> Parsetree.attribute
(** Convert field info to attributes and add them to an
attribute list *)
val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes
(** Fetch the field info for the current symbol. *)
val symbol_info : unit -> info
(** Fetch the field info following the symbol at a given position. *)
val rhs_info : int -> info
(** {3 Unattached comments}
The {!text} type represents documentation which is not attached to
anything. *)
type text = docstring list
val empty_text : text
val text_attr : docstring -> Parsetree.attribute
(** Convert text to attributes and add them to an attribute list *)
val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes
(** Fetch the text preceding the current symbol. *)
val symbol_text : unit -> text
val symbol_text_lazy : unit -> text Lazy.t
(** Fetch the text preceding the symbol at the given position. *)
val rhs_text : int -> text
val rhs_text_lazy : int -> text Lazy.t
(** {3 Extra text}
There may be additional text attached to the delimiters of a block
(e.g. [struct] and [end]). This is fetched by the following
functions, which are applied to the contents of the block rather
than the delimiters. *)
(** Fetch additional text preceding the current symbol *)
val symbol_pre_extra_text : unit -> text
(** Fetch additional text following the current symbol *)
val symbol_post_extra_text : unit -> text
(** Fetch additional text preceding the symbol at the given position *)
val rhs_pre_extra_text : int -> text
(** Fetch additional text following the symbol at the given position *)
val rhs_post_extra_text : int -> text

5
parsing/lexer.mli
View File

@ -50,10 +50,7 @@ by the parser, as [preprocessor lexer lexbuf] where [lexer] is the
lexing function.
When a preprocessor is configured by calling [set_preprocessor], the lexer
changes its behavior:
- It accepts backslash-newline as a token-separating blank.
- It emits an EOL token for every newline except those preceeded by backslash
and those in strings or comments.
changes its behavior to accept backslash-newline as a token-separating blank.
*)
val set_preprocessor :

169
parsing/lexer.mll
View File

@ -134,6 +134,16 @@ let is_in_string = ref false
let in_string () = !is_in_string
let print_warnings = ref true
let with_comment_buffer comment lexbuf =
let start_loc = Location.curr lexbuf in
comment_start_loc := [start_loc];
reset_string_buffer ();
let end_loc = comment lexbuf in
let s = get_stored_string () in
reset_string_buffer ();
let loc = { start_loc with Location.loc_end = end_loc.Location.loc_end } in
s, loc
(* To translate escape sequences *)
let char_for_backslash = function
@ -220,6 +230,8 @@ let update_loc lexbuf file line absolute chars =
let preprocessor = ref None
let escaped_newlines = ref false
(* Warn about Latin-1 characters used in idents *)
let warn_latin1 lexbuf =
@ -227,6 +239,17 @@ let warn_latin1 lexbuf =
(Warnings.Deprecated "ISO-Latin1 characters in identifiers")
;;
let comment_list = ref []
let add_comment com =
comment_list := com :: !comment_list
let add_docstring_comment ds =
let com = (Docstrings.docstring_body ds, Docstrings.docstring_loc ds) in
add_comment com
let comments () = List.rev !comment_list
(* Error report *)
open Format
@ -291,19 +314,14 @@ let float_literal =
rule token = parse
| "\\" newline {
match !preprocessor with
| None ->
if not !escaped_newlines then
raise (Error(Illegal_character (Lexing.lexeme_char lexbuf 0),
Location.curr lexbuf))
| Some _ ->
update_loc lexbuf None 1 false 0;
token lexbuf }
Location.curr lexbuf));
update_loc lexbuf None 1 false 0;
token lexbuf }
| newline
{ update_loc lexbuf None 1 false 0;
match !preprocessor with
| None -> token lexbuf
| Some _ -> EOL
}
EOL }
| blank +
{ token lexbuf }
| "_"
@ -392,26 +410,27 @@ rule token = parse
raise (Error(Illegal_escape esc, Location.curr lexbuf))
}
| "(*"
{ let start_loc = Location.curr lexbuf in
comment_start_loc := [start_loc];
reset_string_buffer ();
let end_loc = comment lexbuf in
let s = get_stored_string () in
reset_string_buffer ();
COMMENT (s, { start_loc with
Location.loc_end = end_loc.Location.loc_end })
}
{ let s, loc = with_comment_buffer comment lexbuf in
COMMENT (s, loc) }
| "(**"
{ let s, loc = with_comment_buffer comment lexbuf in
DOCSTRING (Docstrings.docstring s loc) }
| "(**" ('*'+) as stars
{ let s, loc =
with_comment_buffer
(fun lexbuf ->
store_string ("*" ^ stars);
comment lexbuf)
lexbuf
in
COMMENT (s, loc) }
| "(*)"
{ let loc = Location.curr lexbuf in
if !print_warnings then
Location.prerr_warning loc Warnings.Comment_start;
comment_start_loc := [loc];
reset_string_buffer ();
let end_loc = comment lexbuf in
let s = get_stored_string () in
reset_string_buffer ();
COMMENT (s, { loc with Location.loc_end = end_loc.Location.loc_end })
}
{ if !print_warnings then
Location.prerr_warning (Location.curr lexbuf) Warnings.Comment_start;
let s, loc = with_comment_buffer comment lexbuf in
COMMENT (s, loc) }
| "(*" ('*'*) as stars "*)"
{ COMMENT (stars, Location.curr lexbuf) }
| "*)"
{ let loc = Location.curr lexbuf in
Location.prerr_warning loc Warnings.Comment_not_end;
@ -662,24 +681,98 @@ and skip_sharp_bang = parse
| None -> token lexbuf
| Some (_init, preprocess) -> preprocess token lexbuf
let last_comments = ref []
let rec token lexbuf =
match token_with_comments lexbuf with
COMMENT (s, comment_loc) ->
last_comments := (s, comment_loc) :: !last_comments;
token lexbuf
| tok -> tok
let comments () = List.rev !last_comments
type newline_state =
| NoLine (* There have been no blank lines yet. *)
| NewLine
(* There have been no blank lines, and the previous
token was a newline. *)
| BlankLine (* There have been blank lines. *)
type doc_state =
| Initial (* There have been no docstrings yet *)
| After of docstring list
(* There have been docstrings, none of which were
preceeded by a blank line *)
| Before of docstring list * docstring list * docstring list
(* There have been docstrings, some of which were
preceeded by a blank line *)
and docstring = Docstrings.docstring
let token lexbuf =
let post_pos = lexeme_end_p lexbuf in
let attach lines docs pre_pos =
let open Docstrings in
match docs, lines with
| Initial, _ -> ()
| After a, (NoLine | NewLine) ->
set_post_docstrings post_pos (List.rev a);
set_pre_docstrings pre_pos a;
| After a, BlankLine ->
set_post_docstrings post_pos (List.rev a);
set_pre_extra_docstrings pre_pos (List.rev a)
| Before(a, f, b), (NoLine | NewLine) ->
set_post_docstrings post_pos (List.rev a);
set_post_extra_docstrings post_pos
(List.rev_append f (List.rev b));
set_floating_docstrings pre_pos (List.rev f);
set_pre_extra_docstrings pre_pos (List.rev a);
set_pre_docstrings pre_pos b
| Before(a, f, b), BlankLine ->
set_post_docstrings post_pos (List.rev a);
set_post_extra_docstrings post_pos
(List.rev_append f (List.rev b));
set_floating_docstrings pre_pos
(List.rev_append f (List.rev b));
set_pre_extra_docstrings pre_pos (List.rev a)
in
let rec loop lines docs lexbuf =
match token_with_comments lexbuf with
| COMMENT (s, loc) ->
add_comment (s, loc);
let lines' =
match lines with
| NoLine -> NoLine
| NewLine -> NoLine
| BlankLine -> BlankLine
in
loop lines' docs lexbuf
| EOL ->
let lines' =
match lines with
| NoLine -> NewLine
| NewLine -> BlankLine
| BlankLine -> BlankLine
in
loop lines' docs lexbuf
| DOCSTRING doc ->
add_docstring_comment doc;
let docs' =
match docs, lines with
| Initial, (NoLine | NewLine) -> After [doc]
| Initial, BlankLine -> Before([], [], [doc])
| After a, (NoLine | NewLine) -> After (doc :: a)
| After a, BlankLine -> Before (a, [], [doc])
| Before(a, f, b), (NoLine | NewLine) -> Before(a, f, doc :: b)
| Before(a, f, b), BlankLine -> Before(a, b @ f, [doc])
in
loop NoLine docs' lexbuf
| tok ->
attach lines docs (lexeme_start_p lexbuf);
tok
in
loop NoLine Initial lexbuf
let init () =
is_in_string := false;
last_comments := [];
comment_start_loc := [];
comment_list := [];
match !preprocessor with
| None -> ()
| Some (init, _preprocess) -> init ()
let set_preprocessor init preprocess =
escaped_newlines := true;
preprocessor := Some (init, preprocess)
}

5
parsing/location.mli
View File

@ -29,11 +29,14 @@ type t = {
val none : t
(** An arbitrary value of type [t]; describes an empty ghost range. *)
val in_file : string -> t;;
val in_file : string -> t
(** Return an empty ghost range located in a given file. *)
val init : Lexing.lexbuf -> string -> unit
(** Set the file name and line number of the [lexbuf] to be the start
of the named file. *)
val curr : Lexing.lexbuf -> t
(** Get the location of the current token from the [lexbuf]. *)

2
parsing/parse.ml
View File

@ -34,9 +34,11 @@ let maybe_skip_phrase lexbuf =
let wrap parsing_fun lexbuf =
try
Docstrings.init ();
Lexer.init ();
let ast = parsing_fun Lexer.token lexbuf in
Parsing.clear_parser();
Docstrings.warn_bad_docstrings ();
ast
with
| Lexer.Error(Lexer.Illegal_character _, _) as err

264
parsing/parser.mly
View File

@ -18,6 +18,7 @@ open Asttypes
open Longident
open Parsetree
open Ast_helper
open Docstrings
let mktyp d = Typ.mk ~loc:(symbol_rloc()) d
let mkpat d = Pat.mk ~loc:(symbol_rloc()) d
@ -28,8 +29,10 @@ let mkmod d = Mod.mk ~loc:(symbol_rloc()) d
let mkstr d = Str.mk ~loc:(symbol_rloc()) d
let mkclass d = Cl.mk ~loc:(symbol_rloc()) d
let mkcty d = Cty.mk ~loc:(symbol_rloc()) d
let mkctf d = Ctf.mk ~loc:(symbol_rloc()) d
let mkcf d = Cf.mk ~loc:(symbol_rloc()) d
let mkctf ?attrs ?docs d =
Ctf.mk ~loc:(symbol_rloc()) ?attrs ?docs d
let mkcf ?attrs ?docs d =
Cf.mk ~loc:(symbol_rloc()) ?attrs ?docs d
let mkrhs rhs pos = mkloc rhs (rhs_loc pos)
@ -289,23 +292,30 @@ let wrap_exp_attrs body (ext, attrs) =
let mkexp_attrs d attrs =
wrap_exp_attrs (mkexp d) attrs
let mkcf_attrs d attrs =
Cf.mk ~loc:(symbol_rloc()) ~attrs d
let text_str pos = Str.text (rhs_text pos)
let text_sig pos = Sig.text (rhs_text pos)
let text_cstr pos = Cf.text (rhs_text pos)
let text_csig pos = Ctf.text (rhs_text pos)
let text_def pos = [Ptop_def (Str.text (rhs_text pos))]
let mkctf_attrs d attrs =
Ctf.mk ~loc:(symbol_rloc()) ~attrs d
let extra_text text pos items =
let pre_extras = rhs_pre_extra_text pos in
let post_extras = rhs_post_extra_text pos in
text pre_extras @ items @ text post_extras
let add_nonrec rf attrs pos =
match rf with
| Recursive -> attrs
| Nonrecursive ->
let name = { txt = "nonrec"; loc = rhs_loc pos } in
(name, PStr []) :: attrs
let extra_str pos items = extra_text Str.text pos items
let extra_sig pos items = extra_text Sig.text pos items
let extra_cstr pos items = extra_text Cf.text pos items
let extra_csig pos items = extra_text Ctf.text pos items
let extra_def pos items =
extra_text (fun txt -> [Ptop_def (Str.text txt)]) pos items
type let_binding =
{ lb_pattern: pattern;
lb_expression: expression;
lb_attributes: attributes;
lb_docs: docs Lazy.t;
lb_text: text Lazy.t;
lb_loc: Location.t; }
type let_bindings =
@ -319,6 +329,8 @@ let mklb (p, e) attrs =
{ lb_pattern = p;
lb_expression = e;
lb_attributes = attrs;
lb_docs = symbol_docs_lazy ();
lb_text = symbol_text_lazy ();
lb_loc = symbol_rloc (); }
let mklbs (ext, attrs) rf lb =
@ -342,6 +354,8 @@ let val_of_let_bindings lbs =
List.map
(fun lb ->
Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
~docs:(Lazy.force lb.lb_docs)
~text:(Lazy.force lb.lb_text)
lb.lb_pattern lb.lb_expression)
bindings
in
@ -503,6 +517,7 @@ let class_of_let_bindings lbs body =
%token WHILE
%token WITH
%token <string * Location.t> COMMENT
%token <Docstrings.docstring> DOCSTRING
%token EOL
@ -593,38 +608,52 @@ The precedences must be listed from low to high.
/* Entry points */
implementation:
structure EOF { $1 }
structure EOF { extra_str 1 $1 }
;
interface:
signature EOF { $1 }
signature EOF { extra_sig 1 $1 }
;
toplevel_phrase:
top_structure SEMISEMI { Ptop_def $1 }
top_structure SEMISEMI { Ptop_def (extra_str 1 $1) }
| toplevel_directive SEMISEMI { $1 }
| EOF { raise End_of_file }
;
top_structure:
seq_expr post_item_attributes { [mkstrexp $1 $2] }
| top_structure_tail { $1 }
seq_expr post_item_attributes
{ (text_str 1) @ [mkstrexp $1 $2] }
| top_structure_tail
{ $1 }
;
top_structure_tail:
/* empty */ { [] }
| structure_item top_structure_tail { $1 :: $2 }
| structure_item top_structure_tail { (text_str 1) @ $1 :: $2 }
;
use_file:
use_file_body { extra_def 1 $1 }
;
use_file_body:
use_file_tail { $1 }
| seq_expr post_item_attributes use_file_tail
{ Ptop_def[mkstrexp $1 $2] :: $3 }
{ (text_def 1) @ Ptop_def[mkstrexp $1 $2] :: $3 }
;
use_file_tail:
EOF { [] }
| SEMISEMI EOF { [] }
EOF
{ [] }
| SEMISEMI EOF
{ text_def 1 }
| SEMISEMI seq_expr post_item_attributes use_file_tail
{ Ptop_def[mkstrexp $2 $3] :: $4 }
| SEMISEMI structure_item use_file_tail { Ptop_def[$2] :: $3 }
| SEMISEMI toplevel_directive use_file_tail { $2 :: $3 }
| structure_item use_file_tail { Ptop_def[$1] :: $2 }
| toplevel_directive use_file_tail { $1 :: $2 }
{ mark_rhs_docs 2 3;
(text_def 1) @ (text_def 2) @ Ptop_def[mkstrexp $2 $3] :: $4 }
| SEMISEMI structure_item use_file_tail
{ (text_def 1) @ (text_def 2) @ Ptop_def[$2] :: $3 }
| SEMISEMI toplevel_directive use_file_tail
{ mark_rhs_docs 2 3;
(text_def 1) @ (text_def 2) @ $2 :: $3 }
| structure_item use_file_tail
{ (text_def 1) @ Ptop_def[$1] :: $2 }
| toplevel_directive use_file_tail
{ mark_rhs_docs 1 1;
(text_def 1) @ $1 :: $2 }
;
parse_core_type:
core_type EOF { $1 }
@ -661,7 +690,7 @@ module_expr:
mod_longident
{ mkmod(Pmod_ident (mkrhs $1 1)) }
| STRUCT structure END
{ mkmod(Pmod_structure($2)) }
{ mkmod(Pmod_structure(extra_str 2 $2)) }
| STRUCT structure error
{ unclosed "struct" 1 "end" 3 }
| FUNCTOR functor_args MINUSGREATER module_expr
@ -706,13 +735,15 @@ module_expr:
;
structure:
seq_expr post_item_attributes structure_tail { mkstrexp $1 $2 :: $3 }
seq_expr post_item_attributes structure_tail
{ mark_rhs_docs 1 2;
(text_str 1) @ mkstrexp $1 $2 :: $3 }
| structure_tail { $1 }
;
structure_tail:
/* empty */ { [] }
| SEMISEMI structure { $2 }
| structure_item structure_tail { $1 :: $2 }
| SEMISEMI structure { (text_str 1) @ $2 }
| structure_item structure_tail { (text_str 1) @ $1 :: $2 }
;
structure_item:
let_bindings
@ -741,13 +772,15 @@ structure_item:
| str_include_statement
{ mkstr(Pstr_include $1) }
| item_extension post_item_attributes
{ mkstr(Pstr_extension ($1, $2)) }
{ mkstr(Pstr_extension ($1, (add_docs_attrs (symbol_docs ()) $2))) }
| floating_attribute
{ mkstr(Pstr_attribute $1) }
{ mark_symbol_docs ();
mkstr(Pstr_attribute $1) }
;
str_include_statement:
INCLUDE module_expr post_item_attributes
{ Incl.mk $2 ~attrs:$3 ~loc:(symbol_rloc()) }
{ Incl.mk $2 ~attrs:$3
~loc:(symbol_rloc()) ~docs:(symbol_docs ()) }
;
module_binding_body:
EQUAL module_expr
@ -759,7 +792,8 @@ module_binding_body:
;
module_binding:
MODULE UIDENT module_binding_body post_item_attributes
{ Mb.mk (mkrhs $2 2) $3 ~attrs:$4 ~loc:(symbol_rloc ()) }
{ Mb.mk (mkrhs $2 2) $3 ~attrs:$4
~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) }
;
rec_module_bindings:
rec_module_binding { [$1] }
@ -767,11 +801,13 @@ rec_module_bindings:
;
rec_module_binding:
MODULE REC UIDENT module_binding_body post_item_attributes
{ Mb.mk (mkrhs $3 3) $4 ~attrs:$5 ~loc:(symbol_rloc ()) }
{ Mb.mk (mkrhs $3 3) $4 ~attrs:$5
~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) }
;
and_module_binding:
AND UIDENT module_binding_body post_item_attributes
{ Mb.mk (mkrhs $2 2) $3 ~attrs:$4 ~loc:(symbol_rloc ()) }
{ Mb.mk (mkrhs $2 2) $3 ~attrs:$4 ~loc:(symbol_rloc ())
~text:(symbol_text ()) ~docs:(symbol_docs ()) }
;
/* Module types */
@ -780,7 +816,7 @@ module_type:
mty_longident
{ mkmty(Pmty_ident (mkrhs $1 1)) }
| SIG signature END
{ mkmty(Pmty_signature $2) }
{ mkmty(Pmty_signature (extra_sig 2 $2)) }
| SIG signature error
{ unclosed "sig" 1 "end" 3 }
| FUNCTOR functor_args MINUSGREATER module_type
@ -804,8 +840,8 @@ module_type:
;
signature:
/* empty */ { [] }
| SEMISEMI signature { $2 }
| signature_item signature { $1 :: $2 }
| SEMISEMI signature { (text_sig 1) @ $2 }
| signature_item signature { (text_sig 1) @ $1 :: $2 }
;
signature_item:
value_description
@ -835,17 +871,20 @@ signature_item:
| class_type_declarations
{ mksig(Psig_class_type (List.rev $1)) }
| item_extension post_item_attributes
{ mksig(Psig_extension ($1, $2)) }
{ mksig(Psig_extension ($1, (add_docs_attrs (symbol_docs ()) $2))) }
| floating_attribute
{ mksig(Psig_attribute $1) }
{ mark_symbol_docs ();
mksig(Psig_attribute $1) }
;
open_statement:
| OPEN override_flag mod_longident post_item_attributes
{ Opn.mk (mkrhs $3 3) ~override:$2 ~attrs:$4 ~loc:(symbol_rloc()) }
{ Opn.mk (mkrhs $3 3) ~override:$2 ~attrs:$4
~loc:(symbol_rloc()) ~docs:(symbol_docs ()) }
;
sig_include_statement:
INCLUDE module_type post_item_attributes %prec below_WITH
{ Incl.mk $2 ~attrs:$3 ~loc:(symbol_rloc()) }
{ Incl.mk $2 ~attrs:$3
~loc:(symbol_rloc()) ~docs:(symbol_docs ()) }
;
module_declaration_body:
COLON module_type
@ -857,13 +896,14 @@ module_declaration_body:
;
module_declaration:
MODULE UIDENT module_declaration_body post_item_attributes
{ Md.mk (mkrhs $2 2) $3 ~attrs:$4 ~loc:(symbol_rloc()) }
{ Md.mk (mkrhs $2 2) $3 ~attrs:$4
~loc:(symbol_rloc()) ~docs:(symbol_docs ()) }
;
module_alias:
MODULE UIDENT EQUAL mod_longident post_item_attributes
{ Md.mk (mkrhs $2 2)
(Mty.alias ~loc:(rhs_loc 4) (mkrhs $4 4))
~attrs:$5 ~loc:(symbol_rloc()) }
(Mty.alias ~loc:(rhs_loc 4) (mkrhs $4 4)) ~attrs:$5
~loc:(symbol_rloc()) ~docs:(symbol_docs ()) }
;
rec_module_declarations:
rec_module_declaration { [$1] }
@ -871,11 +911,13 @@ rec_module_declarations:
;
rec_module_declaration:
MODULE REC UIDENT COLON module_type post_item_attributes
{ Md.mk (mkrhs $3 3) $5 ~attrs:$6 ~loc:(symbol_rloc()) }
{ Md.mk (mkrhs $3 3) $5 ~attrs:$6
~loc:(symbol_rloc()) ~docs:(symbol_docs ()) }
;
and_module_declaration:
AND UIDENT COLON module_type post_item_attributes
{ Md.mk (mkrhs $2 2) $4 ~attrs:$5 ~loc:(symbol_rloc()) }
{ Md.mk (mkrhs $2 2) $4 ~attrs:$5 ~loc:(symbol_rloc())
~text:(symbol_text()) ~docs:(symbol_docs()) }
;
module_type_declaration_body:
/* empty */ { None }
@ -883,7 +925,8 @@ module_type_declaration_body:
;
module_type_declaration:
MODULE TYPE ident module_type_declaration_body post_item_attributes
{ Mtd.mk (mkrhs $3 3) ?typ:$4 ~loc:(symbol_rloc()) ~attrs:$5 }
{ Mtd.mk (mkrhs $3 3) ?typ:$4 ~attrs:$5
~loc:(symbol_rloc()) ~docs:(symbol_docs ()) }
;
/* Class expressions */
@ -894,14 +937,15 @@ class_declarations:
class_declaration:
CLASS virtual_flag class_type_parameters LIDENT class_fun_binding
post_item_attributes
{ Ci.mk (mkrhs $4 4) $5 ~virt:$2 ~params:$3
~attrs:$6 ~loc:(symbol_rloc ()) }
{ Ci.mk (mkrhs $4 4) $5 ~virt:$2 ~params:$3 ~attrs:$6
~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) }
;
and_class_declaration:
AND virtual_flag class_type_parameters LIDENT class_fun_binding
post_item_attributes
{ Ci.mk (mkrhs $4 4) $5 ~virt:$2 ~params:$3
~attrs:$6 ~loc:(symbol_rloc ()) }
~attrs:$6 ~loc:(symbol_rloc ())
~text:(symbol_text ()) ~docs:(symbol_docs ()) }
;
class_fun_binding:
EQUAL class_expr
@ -941,7 +985,7 @@ class_simple_expr:
| class_longident
{ mkclass(Pcl_constr(mkrhs $1 1, [])) }
| OBJECT class_structure END
{ mkclass(Pcl_structure($2)) }
{ mkclass(Pcl_structure $2) }
| OBJECT class_structure error
{ unclosed "object" 1 "end" 3 }
| LPAREN class_expr COLON class_type RPAREN
@ -954,8 +998,8 @@ class_simple_expr:
{ unclosed "(" 1 ")" 3 }
;
class_structure:
class_self_pattern class_fields
{ Cstr.mk $1 (List.rev $2) }
| class_self_pattern class_fields
{ Cstr.mk $1 (extra_cstr 2 (List.rev $2)) }
;
class_self_pattern:
LPAREN pattern RPAREN
@ -969,23 +1013,24 @@ class_fields:
/* empty */
{ [] }
| class_fields class_field
{ $2 :: $1 }
{ $2 :: (text_cstr 2) @ $1 }
;
class_field:
| INHERIT override_flag class_expr parent_binder post_item_attributes
{ mkcf_attrs (Pcf_inherit ($2, $3, $4)) $5 }
{ mkcf (Pcf_inherit ($2, $3, $4)) ~attrs:$5 ~docs:(symbol_docs ()) }
| VAL value post_item_attributes
{ mkcf_attrs (Pcf_val $2) $3 }
{ mkcf (Pcf_val $2) ~attrs:$3 ~docs:(symbol_docs ()) }
| METHOD method_ post_item_attributes
{ mkcf_attrs (Pcf_method $2) $3 }
{ mkcf (Pcf_method $2) ~attrs:$3 ~docs:(symbol_docs ()) }
| CONSTRAINT constrain_field post_item_attributes
{ mkcf_attrs (Pcf_constraint $2) $3 }
{ mkcf (Pcf_constraint $2) ~attrs:$3 ~docs:(symbol_docs ()) }
| INITIALIZER seq_expr post_item_attributes
{ mkcf_attrs (Pcf_initializer $2) $3 }
{ mkcf (Pcf_initializer $2) ~attrs:$3 ~docs:(symbol_docs ()) }
| item_extension post_item_attributes
{ mkcf_attrs (Pcf_extension $1) $2 }
{ mkcf (Pcf_extension $1) ~attrs:$2 ~docs:(symbol_docs ()) }
| floating_attribute
{ mkcf (Pcf_attribute $1) }
{ mark_symbol_docs ();
mkcf (Pcf_attribute $1) }
;
parent_binder:
AS LIDENT
@ -1060,7 +1105,7 @@ class_signature:
;
class_sig_body:
class_self_type class_sig_fields
{ Csig.mk $1 (List.rev $2) }
{ Csig.mk $1 (extra_csig 2 (List.rev $2)) }
;
class_self_type:
LPAREN core_type RPAREN
@ -1070,24 +1115,25 @@ class_self_type:
;
class_sig_fields:
/* empty */ { [] }
| class_sig_fields class_sig_field { $2 :: $1 }
| class_sig_fields class_sig_field { $2 :: (text_csig 2) @ $1 }
;
class_sig_field:
INHERIT class_signature post_item_attributes
{ mkctf_attrs (Pctf_inherit $2) $3 }
{ mkctf (Pctf_inherit $2) ~attrs:$3 ~docs:(symbol_docs ()) }
| VAL value_type post_item_attributes
{ mkctf_attrs (Pctf_val $2) $3 }
{ mkctf (Pctf_val $2) ~attrs:$3 ~docs:(symbol_docs ()) }
| METHOD private_virtual_flags label COLON poly_type post_item_attributes
{
let (p, v) = $2 in
mkctf_attrs (Pctf_method ($3, p, v, $5)) $6
mkctf (Pctf_method ($3, p, v, $5)) ~attrs:$6 ~docs:(symbol_docs ())
}
| CONSTRAINT constrain_field post_item_attributes
{ mkctf_attrs (Pctf_constraint $2) $3 }
{ mkctf (Pctf_constraint $2) ~attrs:$3 ~docs:(symbol_docs ()) }
| item_extension post_item_attributes
{ mkctf_attrs (Pctf_extension $1) $2 }
{ mkctf (Pctf_extension $1) ~attrs:$2 ~docs:(symbol_docs ()) }
| floating_attribute
{ mkctf(Pctf_attribute $1) }
{ mark_symbol_docs ();
mkctf(Pctf_attribute $1) }
;
value_type:
VIRTUAL mutable_flag label COLON core_type
@ -1110,14 +1156,15 @@ class_descriptions:
class_description:
CLASS virtual_flag class_type_parameters LIDENT COLON class_type
post_item_attributes
{ Ci.mk (mkrhs $4 4) $6 ~virt:$2 ~params:$3
~attrs:$7 ~loc:(symbol_rloc ()) }
{ Ci.mk (mkrhs $4 4) $6 ~virt:$2 ~params:$3 ~attrs:$7
~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) }
;
and_class_description:
AND virtual_flag class_type_parameters LIDENT COLON class_type
post_item_attributes
{ Ci.mk (mkrhs $4 4) $6 ~virt:$2 ~params:$3
~attrs:$7 ~loc:(symbol_rloc ()) }
~attrs:$7 ~loc:(symbol_rloc ())
~text:(symbol_text ()) ~docs:(symbol_docs ()) }
;
class_type_declarations:
class_type_declaration { [$1] }
@ -1126,14 +1173,15 @@ class_type_declarations:
class_type_declaration:
CLASS TYPE virtual_flag class_type_parameters LIDENT EQUAL
class_signature post_item_attributes
{ Ci.mk (mkrhs $5 5) $7 ~virt:$3 ~params:$4
~attrs:$8 ~loc:(symbol_rloc ()) }
{ Ci.mk (mkrhs $5 5) $7 ~virt:$3 ~params:$4 ~attrs:$8
~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) }
;
and_class_type_declaration:
AND virtual_flag class_type_parameters LIDENT EQUAL
class_signature post_item_attributes
{ Ci.mk (mkrhs $4 4) $6 ~virt:$2 ~params:$3
~attrs:$7 ~loc:(symbol_rloc ()) }
~attrs:$7 ~loc:(symbol_rloc ())
~text:(symbol_text ()) ~docs:(symbol_docs ()) }
;
/* Core expressions */
@ -1657,7 +1705,8 @@ lbl_pattern:
value_description:
VAL val_ident COLON core_type post_item_attributes
{ Val.mk (mkrhs $2 2) $4 ~attrs:$5 ~loc:(symbol_rloc()) }
{ Val.mk (mkrhs $2 2) $4 ~attrs:$5
~loc:(symbol_rloc()) ~docs:(symbol_docs ()) }
;
/* Primitive declarations */
@ -1669,7 +1718,8 @@ primitive_declaration_body:
primitive_declaration:
EXTERNAL val_ident COLON core_type EQUAL primitive_declaration_body
post_item_attributes
{ Val.mk (mkrhs $2 2) $4 ~prim:$6 ~attrs:$7 ~loc:(symbol_rloc ()) }
{ Val.mk (mkrhs $2 2) $4 ~prim:$6 ~attrs:$7
~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) }
;
/* Type declarations */
@ -1685,15 +1735,20 @@ type_declaration:
TYPE nonrec_flag optional_type_parameters LIDENT type_kind constraints
post_item_attributes
{ let (kind, priv, manifest) = $5 in
($2, Type.mk (mkrhs $4 4) ~params:$3 ~cstrs:(List.rev $6) ~kind
~priv ?manifest ~attrs:$7 ~loc:(symbol_rloc ())) }
let ty =
Type.mk (mkrhs $4 4) ~params:$3 ~cstrs:(List.rev $6) ~kind
~priv ?manifest ~attrs:$7
~loc:(symbol_rloc ()) ~docs:(symbol_docs ())
in
($2, ty) }
;
and_type_declaration:
AND optional_type_parameters LIDENT type_kind constraints
post_item_attributes
{ let (kind, priv, manifest) = $4 in
Type.mk (mkrhs $3 3) ~params:$2 ~cstrs:(List.rev $5)
~kind ~priv ?manifest ~attrs:$6 ~loc:(symbol_rloc ()) }
~kind ~priv ?manifest ~attrs:$6 ~loc:(symbol_rloc ())
~text:(symbol_text ()) ~docs:(symbol_docs ()) }
;
constraints:
constraints CONSTRAINT constrain { $3 :: $1 }
@ -1768,29 +1823,31 @@ constructor_declaration:
| constr_ident generalized_constructor_arguments attributes
{
let args,res = $2 in
Type.constructor (mkrhs $1 1) ~args ?res ~loc:(symbol_rloc()) ~attrs:$3
Type.constructor (mkrhs $1 1) ~args ?res ~attrs:$3
~loc:(symbol_rloc()) ~info:(symbol_info ())
}
;
bar_constructor_declaration:
| BAR constr_ident generalized_constructor_arguments attributes
{
let args,res = $3 in
Type.constructor (mkrhs $2 2) ~args ?res ~loc:(symbol_rloc()) ~attrs:$4
Type.constructor (mkrhs $2 2) ~args ?res ~attrs:$4
~loc:(symbol_rloc()) ~info:(symbol_info ())
}
;
str_exception_declaration:
| sig_exception_declaration { $1 }
| EXCEPTION constr_ident EQUAL constr_longident attributes
post_item_attributes
{ Te.rebind (mkrhs $2 2) (mkrhs $4 4)
~loc:(symbol_rloc()) ~attrs:($5 @ $6) }
{ Te.rebind (mkrhs $2 2) (mkrhs $4 4) ~attrs:($5 @ $6)
~loc:(symbol_rloc()) ~docs:(symbol_docs ()) }
;
sig_exception_declaration:
| EXCEPTION constr_ident generalized_constructor_arguments attributes
post_item_attributes
{ let args, res = $3 in
Te.decl (mkrhs $2 2) ~args ?res
~loc:(symbol_rloc()) ~attrs:($4 @ $5) }
Te.decl (mkrhs $2 2) ~args ?res ~attrs:($4 @ $5)
~loc:(symbol_rloc()) ~docs:(symbol_docs ()) }
;
generalized_constructor_arguments:
/*empty*/ { (Pcstr_tuple [],None) }
@ -1813,13 +1870,20 @@ label_declarations:
label_declaration:
mutable_flag label COLON poly_type_no_attr attributes
{
Type.field (mkrhs $2 2) $4 ~mut:$1 ~attrs:$5 ~loc:(symbol_rloc())
Type.field (mkrhs $2 2) $4 ~mut:$1 ~attrs:$5
~loc:(symbol_rloc()) ~info:(symbol_info ())
}
;
label_declaration_semi:
mutable_flag label COLON poly_type_no_attr attributes SEMI
mutable_flag label COLON poly_type_no_attr attributes SEMI attributes
{
Type.field (mkrhs $2 2) $4 ~mut:$1 ~attrs:$5 ~loc:(symbol_rloc())
let info =
match rhs_info 5 with
| Some _ as info_before_semi -> info_before_semi
| None -> symbol_info ()
in
Type.field (mkrhs $2 2) $4 ~mut:$1 ~attrs:($5 @ $7)
~loc:(symbol_rloc()) ~info
}
;
@ -1829,13 +1893,15 @@ str_type_extension:
TYPE nonrec_flag optional_type_parameters type_longident
PLUSEQ private_flag str_extension_constructors post_item_attributes
{ if $2 <> Recursive then not_expecting 2 "nonrec flag";
Te.mk (mkrhs $4 4) (List.rev $7) ~params:$3 ~priv:$6 ~attrs:$8 }
Te.mk (mkrhs $4 4) (List.rev $7) ~params:$3 ~priv:$6
~attrs:$8 ~docs:(symbol_docs ()) }
;
sig_type_extension:
TYPE nonrec_flag optional_type_parameters type_longident
PLUSEQ private_flag sig_extension_constructors post_item_attributes
{ if $2 <> Recursive then not_expecting 2 "nonrec flag";
Te.mk (mkrhs $4 4) (List.rev $7) ~params:$3 ~priv:$6 ~attrs:$8 }
Te.mk (mkrhs $4 4) (List.rev $7) ~params:$3 ~priv:$6
~attrs:$8 ~docs:(symbol_docs ()) }
;
str_extension_constructors:
extension_constructor_declaration { [$1] }
@ -1856,20 +1922,24 @@ sig_extension_constructors:
extension_constructor_declaration:
| constr_ident generalized_constructor_arguments attributes
{ let args, res = $2 in
Te.decl (mkrhs $1 1) ~args ?res ~loc:(symbol_rloc()) ~attrs:$3 }
Te.decl (mkrhs $1 1) ~args ?res ~attrs:$3
~loc:(symbol_rloc()) ~info:(symbol_info ()) }
;
bar_extension_constructor_declaration:
| BAR constr_ident generalized_constructor_arguments attributes
{ let args, res = $3 in
Te.decl (mkrhs $2 2) ~args ?res ~loc:(symbol_rloc()) ~attrs:$4 }
Te.decl (mkrhs $2 2) ~args ?res ~attrs:$4
~loc:(symbol_rloc()) ~info:(symbol_info ()) }
;
extension_constructor_rebind:
| constr_ident EQUAL constr_longident attributes
{ Te.rebind (mkrhs $1 1) (mkrhs $3 3) ~loc:(symbol_rloc()) ~attrs:$4 }
{ Te.rebind (mkrhs $1 1) (mkrhs $3 3) ~attrs:$4
~loc:(symbol_rloc()) ~info:(symbol_info ()) }
;
bar_extension_constructor_rebind:
| BAR constr_ident EQUAL constr_longident attributes
{ Te.rebind (mkrhs $2 2) (mkrhs $4 4) ~loc:(symbol_rloc()) ~attrs:$5 }
{ Te.rebind (mkrhs $2 2) (mkrhs $4 4) ~attrs:$5
~loc:(symbol_rloc()) ~info:(symbol_info ()) }
;
/* "with" constraints (additional type equations over signature components) */

2
stdlib/camlinternalFormat.ml
View File

@ -1872,7 +1872,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
let legacy_behavior = match legacy_behavior with
| Some flag -> flag
| None -> true
(** When this flag is enabled, the format parser tries to behave as
(* When this flag is enabled, the format parser tries to behave as
the <4.02 implementations, in particular it ignores most benine
nonsensical format. When the flag is disabled, it will reject any
format that is not accepted by the specification.

253
stdlib/format.mli
View File

@ -74,7 +74,7 @@
(** {6 Boxes} *)
val open_box : int -> unit;;
val open_box : int -> unit
(** [open_box d] opens a new pretty-printing box
with offset [d].
This box is the general purpose pretty-printing box.
@ -86,41 +86,41 @@ val open_box : int -> unit;;
When a new line is printed in the box, [d] is added to the
current indentation. *)
val close_box : unit -> unit;;
val close_box : unit -> unit
(** Closes the most recently opened pretty-printing box. *)
(** {6 Formatting functions} *)
val print_string : string -> unit;;
val print_string : string -> unit
(** [print_string str] prints [str] in the current box. *)
val print_as : int -> string -> unit;;
val print_as : int -> string -> unit
(** [print_as len str] prints [str] in the
current box. The pretty-printer formats [str] as if
it were of length [len]. *)
val print_int : int -> unit;;
val print_int : int -> unit
(** Prints an integer in the current box. *)
val print_float : float -> unit;;
val print_float : float -> unit
(** Prints a floating point number in the current box. *)
val print_char : char -> unit;;
val print_char : char -> unit
(** Prints a character in the current box. *)
val print_bool : bool -> unit;;
val print_bool : bool -> unit
(** Prints a boolean in the current box. *)
(** {6 Break hints} *)
val print_space : unit -> unit;;
val print_space : unit -> unit
(** [print_space ()] is used to separate items (typically to print
a space between two words).
It indicates that the line may be split at this
point. It either prints one space or splits the line.
It is equivalent to [print_break 1 0]. *)
val print_cut : unit -> unit;;
val print_cut : unit -> unit
(** [print_cut ()] is used to mark a good break position.
It indicates that the line may be split at this
point. It either prints nothing or splits the line.
@ -128,7 +128,7 @@ val print_cut : unit -> unit;;
point, without printing spaces or adding indentation.
It is equivalent to [print_break 0 0]. *)
val print_break : int -> int -> unit;;
val print_break : int -> int -> unit
(** Inserts a break hint in a pretty-printing box.
[print_break nspaces offset] indicates that the line may
be split (a newline character is printed) at this point,
@ -138,25 +138,25 @@ val print_break : int -> int -> unit;;
the current indentation. If the line is not split,
[nspaces] spaces are printed. *)
val print_flush : unit -> unit;;
val print_flush : unit -> unit
(** Flushes the pretty printer: all opened boxes are closed,
and all pending text is displayed. *)
val print_newline : unit -> unit;;
val print_newline : unit -> unit
(** Equivalent to [print_flush] followed by a new line. *)
val force_newline : unit -> unit;;
val force_newline : unit -> unit
(** Forces a newline in the current box. Not the normal way of
pretty-printing, you should prefer break hints. *)
val print_if_newline : unit -> unit;;
val print_if_newline : unit -> unit
(** Executes the next formatting command if the preceding line
has just been split. Otherwise, ignore the next formatting
command. *)
(** {6 Margin} *)
val set_margin : int -> unit;;
val set_margin : int -> unit
(** [set_margin d] sets the value of the right margin
to [d] (in characters): this value is used to detect line
overflows that leads to split lines.
@ -164,12 +164,12 @@ val set_margin : int -> unit;;
If [d] is too large, the right margin is set to the maximum
admissible value (which is greater than [10^9]). *)
val get_margin : unit -> int;;
val get_margin : unit -> int
(** Returns the position of the right margin. *)
(** {6 Maximum indentation limit} *)
val set_max_indent : int -> unit;;
val set_max_indent : int -> unit
(** [set_max_indent d] sets the value of the maximum
indentation limit to [d] (in characters):
once this limit is reached, boxes are rejected to the left,
@ -178,32 +178,32 @@ val set_max_indent : int -> unit;;
If [d] is too large, the limit is set to the maximum
admissible value (which is greater than [10^9]). *)
val get_max_indent : unit -> int;;
val get_max_indent : unit -> int
(** Return the value of the maximum indentation limit (in characters). *)
(** {6 Formatting depth: maximum number of boxes allowed before ellipsis} *)
val set_max_boxes : int -> unit;;
val set_max_boxes : int -> unit
(** [set_max_boxes max] sets the maximum number of boxes simultaneously
opened.
Material inside boxes nested deeper is printed as an ellipsis (more
precisely as the text returned by [get_ellipsis_text ()]).
Nothing happens if [max] is smaller than 2. *)
val get_max_boxes : unit -> int;;
val get_max_boxes : unit -> int
(** Returns the maximum number of boxes allowed before ellipsis. *)
val over_max_boxes : unit -> bool;;
val over_max_boxes : unit -> bool
(** Tests if the maximum number of boxes allowed have already been opened. *)
(** {6 Advanced formatting} *)
val open_hbox : unit -> unit;;
val open_hbox : unit -> unit
(** [open_hbox ()] opens a new pretty-printing box.
This box is 'horizontal': the line is not split in this box
(new lines may still occur inside boxes nested deeper). *)
val open_vbox : int -> unit;;
val open_vbox : int -> unit
(** [open_vbox d] opens a new pretty-printing box
with offset [d].
This box is 'vertical': every break hint inside this
@ -211,7 +211,7 @@ val open_vbox : int -> unit;;
When a new line is printed in the box, [d] is added to the
current indentation. *)
val open_hvbox : int -> unit;;
val open_hvbox : int -> unit
(** [open_hvbox d] opens a new pretty-printing box
with offset [d].
This box is 'horizontal-vertical': it behaves as an
@ -220,7 +220,7 @@ val open_hvbox : int -> unit;;
When a new line is printed in the box, [d] is added to the
current indentation. *)
val open_hovbox : int -> unit;;
val open_hovbox : int -> unit
(** [open_hovbox d] opens a new pretty-printing box
with offset [d].
This box is 'horizontal or vertical': break hints
@ -231,13 +231,13 @@ val open_hovbox : int -> unit;;
(** {6 Tabulations} *)
val open_tbox : unit -> unit;;
val open_tbox : unit -> unit
(** Opens a tabulation box. *)
val close_tbox : unit -> unit;;
val close_tbox : unit -> unit
(** Closes the most recently opened tabulation box. *)
val print_tbreak : int -> int -> unit;;
val print_tbreak : int -> int -> unit
(** Break hint in a tabulation box.
[print_tbreak spaces offset] moves the insertion point to
the next tabulation ([spaces] being added to this position).
@ -249,24 +249,24 @@ val print_tbreak : int -> int -> unit;;
If a new line is printed, [offset] is added to the current
indentation. *)
val set_tab : unit -> unit;;
val set_tab : unit -> unit
(** Sets a tabulation mark at the current insertion point. *)
val print_tab : unit -> unit;;
val print_tab : unit -> unit
(** [print_tab ()] is equivalent to [print_tbreak 0 0]. *)
(** {6 Ellipsis} *)
val set_ellipsis_text : string -> unit;;
val set_ellipsis_text : string -> unit
(** Set the text of the ellipsis printed when too many boxes
are opened (a single dot, [.], by default). *)
val get_ellipsis_text : unit -> string;;
val get_ellipsis_text : unit -> string
(** Return the text of the ellipsis. *)
(** {6:tags Semantics Tags} *)
type tag = string;;
type tag = string
(** {i Semantics tags} (or simply {e tags}) are used to decorate printed
entities for user's defined purposes, e.g. setting font and giving size
@ -315,38 +315,42 @@ type tag = string;;
Tag marking and tag printing functions are user definable and can
be set by calling [set_formatter_tag_functions]. *)
val open_tag : tag -> unit;;
val open_tag : tag -> unit
(** [open_tag t] opens the tag named [t]; the [print_open_tag]
function of the formatter is called with [t] as argument;
the tag marker [mark_open_tag t] will be flushed into the output
device of the formatter. *)
val close_tag : unit -> unit;;
val close_tag : unit -> unit
(** [close_tag ()] closes the most recently opened tag [t].
In addition, the [print_close_tag] function of the formatter is called
with [t] as argument. The marker [mark_close_tag t] will be flushed
into the output device of the formatter. *)
val set_tags : bool -> unit;;
val set_tags : bool -> unit
(** [set_tags b] turns on or off the treatment of tags (default is off). *)
val set_print_tags : bool -> unit;;
val set_mark_tags : bool -> unit;;
(** [set_print_tags b] turns on or off the printing of tags, while
[set_mark_tags b] turns on or off the output of tag markers. *)
val get_print_tags : unit -> bool;;
val get_mark_tags : unit -> bool;;
(** Return the current status of tags printing and tags marking. *)
val set_print_tags : bool -> unit
(**[set_print_tags b] turns on or off the printing of tags. *)
val set_mark_tags : bool -> unit
(** [set_mark_tags b] turns on or off the output of tag markers. *)
val get_print_tags : unit -> bool
(** Return the current status of tags printing. *)
val get_mark_tags : unit -> bool
(** Return the current status of tags marking. *)
(** {6 Redirecting the standard formatter output} *)
val set_formatter_out_channel : Pervasives.out_channel -> unit;;
val set_formatter_out_channel : Pervasives.out_channel -> unit
(** Redirect the pretty-printer output to the given channel.
(All the output functions of the standard formatter are set to the
default output functions printing to the given channel.) *)
val set_formatter_output_functions :
(string -> int -> int -> unit) -> (unit -> unit) -> unit
;;
(** [set_formatter_output_functions out flush] redirects the
pretty-printer output functions to the functions [out] and
[flush].
@ -362,7 +366,6 @@ val set_formatter_output_functions :
val get_formatter_output_functions :
unit -> (string -> int -> int -> unit) * (unit -> unit)
;;
(** Return the current output functions of the pretty-printer. *)
(** {6:meaning Changing the meaning of standard formatter pretty printing} *)
@ -378,9 +381,9 @@ type formatter_out_functions = {
out_newline : unit -> unit;
out_spaces : int -> unit;
}
;;
val set_formatter_out_functions : formatter_out_functions -> unit;;
val set_formatter_out_functions : formatter_out_functions -> unit
(** [set_formatter_out_functions f]
Redirect the pretty-printer output to the functions [f.out_string]
and [f.out_flush] as described in
@ -397,7 +400,7 @@ val set_formatter_out_functions : formatter_out_functions -> unit;;
default values for [f.out_space] and [f.out_newline] are
[f.out_string (String.make n ' ') 0 n] and [f.out_string "\n" 0 1]. *)
val get_formatter_out_functions : unit -> formatter_out_functions;;
val get_formatter_out_functions : unit -> formatter_out_functions
(** Return the current output functions of the pretty-printer,
including line breaking and indentation functions. Useful to record the
current setting and restore it afterwards. *)
@ -410,7 +413,6 @@ type formatter_tag_functions = {
print_open_tag : tag -> unit;
print_close_tag : tag -> unit;
}
;;
(** The tag handling functions specific to a formatter:
[mark] versions are the 'tag marking' functions that associate a string
marker to a tag in order for the pretty-printing engine to flush
@ -418,7 +420,7 @@ type formatter_tag_functions = {
[print] versions are the 'tag printing' functions that can perform
regular printing when a tag is closed or opened. *)
val set_formatter_tag_functions : formatter_tag_functions -> unit;;
val set_formatter_tag_functions : formatter_tag_functions -> unit
(** [set_formatter_tag_functions tag_funs] changes the meaning of
opening and closing tags to use the functions in [tag_funs].
@ -434,12 +436,12 @@ val set_formatter_tag_functions : formatter_tag_functions -> unit;;
called at tag opening and tag closing time, to output regular
material in the pretty-printer queue. *)
val get_formatter_tag_functions : unit -> formatter_tag_functions;;
val get_formatter_tag_functions : unit -> formatter_tag_functions
(** Return the current tag functions of the pretty-printer. *)
(** {6 Multiple formatted output} *)
type formatter;;
type formatter
(** Abstract data corresponding to a pretty-printer (also called a
formatter) and all its machinery.
@ -457,40 +459,39 @@ type formatter;;
(convenient to output material to strings for instance).
*)
val formatter_of_out_channel : out_channel -> formatter;;
val formatter_of_out_channel : out_channel -> formatter
(** [formatter_of_out_channel oc] returns a new formatter that
writes to the corresponding channel [oc]. *)
val std_formatter : formatter;;
val std_formatter : formatter
(** The standard formatter used by the formatting functions
above. It is defined as [formatter_of_out_channel stdout]. *)
val err_formatter : formatter;;
val err_formatter : formatter
(** A formatter to use with formatting functions below for
output to standard error. It is defined as
[formatter_of_out_channel stderr]. *)
val formatter_of_buffer : Buffer.t -> formatter;;
val formatter_of_buffer : Buffer.t -> formatter
(** [formatter_of_buffer b] returns a new formatter writing to
buffer [b]. As usual, the formatter has to be flushed at
the end of pretty printing, using [pp_print_flush] or
[pp_print_newline], to display all the pending material. *)
val stdbuf : Buffer.t;;
val stdbuf : Buffer.t
(** The string buffer in which [str_formatter] writes. *)
val str_formatter : formatter;;
val str_formatter : formatter
(** A formatter to use with formatting functions below for
output to the [stdbuf] string buffer.
[str_formatter] is defined as [formatter_of_buffer stdbuf]. *)
val flush_str_formatter : unit -> string;;
val flush_str_formatter : unit -> string
(** Returns the material printed with [str_formatter], flushes
the formatter and resets the corresponding buffer. *)
val make_formatter :
(string -> int -> int -> unit) -> (unit -> unit) -> formatter
;;
(** [make_formatter out flush] returns a new formatter that writes according
to the output function [out], and the flushing function [flush]. For
instance, a formatter to the [Pervasives.out_channel] [oc] is returned by
@ -498,67 +499,66 @@ val make_formatter :
(** {6 Basic functions to use with formatters} *)
val pp_open_hbox : formatter -> unit -> unit;;
val pp_open_vbox : formatter -> int -> unit;;
val pp_open_hvbox : formatter -> int -> unit;;
val pp_open_hovbox : formatter -> int -> unit;;
val pp_open_box : formatter -> int -> unit;;
val pp_close_box : formatter -> unit -> unit;;
val pp_open_tag : formatter -> string -> unit;;
val pp_close_tag : formatter -> unit -> unit;;
val pp_print_string : formatter -> string -> unit;;
val pp_print_as : formatter -> int -> string -> unit;;
val pp_print_int : formatter -> int -> unit;;
val pp_print_float : formatter -> float -> unit;;
val pp_print_char : formatter -> char -> unit;;
val pp_print_bool : formatter -> bool -> unit;;
val pp_print_break : formatter -> int -> int -> unit;;
val pp_print_cut : formatter -> unit -> unit;;
val pp_print_space : formatter -> unit -> unit;;
val pp_force_newline : formatter -> unit -> unit;;
val pp_print_flush : formatter -> unit -> unit;;
val pp_print_newline : formatter -> unit -> unit;;
val pp_print_if_newline : formatter -> unit -> unit;;
val pp_open_tbox : formatter -> unit -> unit;;
val pp_close_tbox : formatter -> unit -> unit;;
val pp_print_tbreak : formatter -> int -> int -> unit;;
val pp_set_tab : formatter -> unit -> unit;;
val pp_print_tab : formatter -> unit -> unit;;
val pp_set_tags : formatter -> bool -> unit;;
val pp_set_print_tags : formatter -> bool -> unit;;
val pp_set_mark_tags : formatter -> bool -> unit;;
val pp_get_print_tags : formatter -> unit -> bool;;
val pp_get_mark_tags : formatter -> unit -> bool;;
val pp_set_margin : formatter -> int -> unit;;
val pp_get_margin : formatter -> unit -> int;;
val pp_set_max_indent : formatter -> int -> unit;;
val pp_get_max_indent : formatter -> unit -> int;;
val pp_set_max_boxes : formatter -> int -> unit;;
val pp_get_max_boxes : formatter -> unit -> int;;
val pp_over_max_boxes : formatter -> unit -> bool;;
val pp_set_ellipsis_text : formatter -> string -> unit;;
val pp_get_ellipsis_text : formatter -> unit -> string;;
val pp_open_hbox : formatter -> unit -> unit
val pp_open_vbox : formatter -> int -> unit
val pp_open_hvbox : formatter -> int -> unit
val pp_open_hovbox : formatter -> int -> unit
val pp_open_box : formatter -> int -> unit
val pp_close_box : formatter -> unit -> unit
val pp_open_tag : formatter -> string -> unit
val pp_close_tag : formatter -> unit -> unit
val pp_print_string : formatter -> string -> unit
val pp_print_as : formatter -> int -> string -> unit
val pp_print_int : formatter -> int -> unit
val pp_print_float : formatter -> float -> unit
val pp_print_char : formatter -> char -> unit
val pp_print_bool : formatter -> bool -> unit
val pp_print_break : formatter -> int -> int -> unit
val pp_print_cut : formatter -> unit -> unit
val pp_print_space : formatter -> unit -> unit
val pp_force_newline : formatter -> unit -> unit
val pp_print_flush : formatter -> unit -> unit
val pp_print_newline : formatter -> unit -> unit
val pp_print_if_newline : formatter -> unit -> unit
val pp_open_tbox : formatter -> unit -> unit
val pp_close_tbox : formatter -> unit -> unit
val pp_print_tbreak : formatter -> int -> int -> unit
val pp_set_tab : formatter -> unit -> unit
val pp_print_tab : formatter -> unit -> unit
val pp_set_tags : formatter -> bool -> unit
val pp_set_print_tags : formatter -> bool -> unit
val pp_set_mark_tags : formatter -> bool -> unit
val pp_get_print_tags : formatter -> unit -> bool
val pp_get_mark_tags : formatter -> unit -> bool
val pp_set_margin : formatter -> int -> unit
val pp_get_margin : formatter -> unit -> int
val pp_set_max_indent : formatter -> int -> unit
val pp_get_max_indent : formatter -> unit -> int
val pp_set_max_boxes : formatter -> int -> unit
val pp_get_max_boxes : formatter -> unit -> int
val pp_over_max_boxes : formatter -> unit -> bool
val pp_set_ellipsis_text : formatter -> string -> unit
val pp_get_ellipsis_text : formatter -> unit -> string
val pp_set_formatter_out_channel :
formatter -> Pervasives.out_channel -> unit
;;
val pp_set_formatter_output_functions :
formatter -> (string -> int -> int -> unit) -> (unit -> unit) -> unit
;;
val pp_get_formatter_output_functions :
formatter -> unit -> (string -> int -> int -> unit) * (unit -> unit)
;;
val pp_set_formatter_tag_functions :
formatter -> formatter_tag_functions -> unit
;;
val pp_get_formatter_tag_functions :
formatter -> unit -> formatter_tag_functions
;;
val pp_set_formatter_out_functions :
formatter -> formatter_out_functions -> unit
;;
val pp_get_formatter_out_functions :
formatter -> unit -> formatter_out_functions
;;
(** These functions are the basic ones: usual functions
operating on the standard formatter are defined via partial
evaluation of these primitives. For instance,
@ -587,7 +587,7 @@ val pp_print_text : formatter -> string -> unit
(** {6 [printf] like functions for pretty-printing.} *)
val fprintf : formatter -> ('a, formatter, unit) format -> 'a;;
val fprintf : formatter -> ('a, formatter, unit) format -> 'a
(** [fprintf ff fmt arg1 ... argN] formats the arguments [arg1] to [argN]
according to the format string [fmt], and outputs the resulting string on
@ -656,13 +656,13 @@ val fprintf : formatter -> ('a, formatter, unit) format -> 'a;;
*)
val printf : ('a, formatter, unit) format -> 'a;;
val printf : ('a, formatter, unit) format -> 'a
(** Same as [fprintf] above, but output on [std_formatter]. *)
val eprintf : ('a, formatter, unit) format -> 'a;;
val eprintf : ('a, formatter, unit) format -> 'a
(** Same as [fprintf] above, but output on [err_formatter]. *)
val sprintf : ('a, unit, string) format -> 'a;;
val sprintf : ('a, unit, string) format -> 'a
(** Same as [printf] above, but instead of printing on a formatter,
returns a string containing the result of formatting the arguments.
Note that the pretty-printer queue is flushed at the end of {e each
@ -678,7 +678,7 @@ val sprintf : ('a, unit, string) format -> 'a;;
pretty-printing returns the desired string.
*)
val asprintf : ('a, formatter, unit, string) format4 -> 'a;;
val asprintf : ('a, formatter, unit, string) format4 -> 'a
(** Same as [printf] above, but instead of printing on a formatter,
returns a string containing the result of formatting the arguments.
The type of [asprintf] is general enough to interact nicely with [%a]
@ -686,7 +686,7 @@ val asprintf : ('a, formatter, unit, string) format4 -> 'a;;
@since 4.01.0
*)
val ifprintf : formatter -> ('a, formatter, unit) format -> 'a;;
val ifprintf : formatter -> ('a, formatter, unit) format -> 'a
(** Same as [fprintf] above, but does not print anything.
Useful to ignore some material when conditionally printing.
@since 3.10.0
@ -696,19 +696,17 @@ val ifprintf : formatter -> ('a, formatter, unit) format -> 'a;;
val kfprintf : (formatter -> 'a) -> formatter ->
('b, formatter, unit, 'a) format4 -> 'b
;;
(** Same as [fprintf] above, but instead of returning immediately,
passes the formatter to its first argument at the end of printing. *)
val ikfprintf : (formatter -> 'a) -> formatter ->
('b, formatter, unit, 'a) format4 -> 'b
;;
(** Same as [kfprintf] above, but does not print anything.
Useful to ignore some material when conditionally printing.
@since 3.12.0
*)
val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;;
val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b
(** Same as [sprintf] above, but instead of returning the string,
passes it to the first argument. *)
@ -716,7 +714,6 @@ val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;;
val bprintf : Buffer.t -> ('a, formatter, unit) format -> 'a
[@@ocaml.deprecated]
;;
(** @deprecated This function is error prone. Do not use it.
If you need to print to some buffer [b], you must first define a
@ -725,7 +722,6 @@ val bprintf : Buffer.t -> ('a, formatter, unit) format -> 'a
val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b
[@@ocaml.deprecated "Use Format.ksprintf instead."]
;;
(** @deprecated An alias for [ksprintf]. *)
val set_all_formatter_output_functions :
@ -735,9 +731,7 @@ val set_all_formatter_output_functions :
spaces:(int -> unit) ->
unit
[@@ocaml.deprecated "Use Format.set_formatter_out_functions instead."]
;;
(** @deprecated Subsumed by [set_formatter_out_functions].
*)
(** @deprecated Subsumed by [set_formatter_out_functions]. *)
val get_all_formatter_output_functions :
unit ->
@ -746,22 +740,17 @@ val get_all_formatter_output_functions :
(unit -> unit) *
(int -> unit)
[@@ocaml.deprecated "Use Format.get_formatter_out_functions instead."]
;;
(** @deprecated Subsumed by [get_formatter_out_functions].
*)
(** @deprecated Subsumed by [get_formatter_out_functions]. *)
val pp_set_all_formatter_output_functions :
formatter -> out:(string -> int -> int -> unit) -> flush:(unit -> unit) ->
newline:(unit -> unit) -> spaces:(int -> unit) -> unit
[@@ocaml.deprecated "Use Format.pp_set_formatter_out_functions instead."]
;;
(** @deprecated Subsumed by [pp_set_formatter_out_functions].
*)
(** @deprecated Subsumed by [pp_set_formatter_out_functions]. *)
val pp_get_all_formatter_output_functions :
formatter -> unit ->
(string -> int -> int -> unit) * (unit -> unit) * (unit -> unit) *
(int -> unit)
[@@ocaml.deprecated "Use Format.pp_get_formatter_out_functions instead."]
;;
(** @deprecated Subsumed by [pp_get_formatter_out_functions].
*)
(** @deprecated Subsumed by [pp_get_formatter_out_functions]. *)

7
stdlib/printf.mli
View File

@ -136,7 +136,7 @@ val ifprintf : 'a -> ('b, 'a, unit) format -> 'b
(** Formatted output functions with continuations. *)
val kfprintf : (out_channel -> 'a) -> out_channel ->
('b, out_channel, unit, 'a) format4 -> 'b;;
('b, out_channel, unit, 'a) format4 -> 'b
(** Same as [fprintf], but instead of returning immediately,
passes the out channel to its first argument at the end of printing.
@since 3.09.0
@ -144,20 +144,19 @@ val kfprintf : (out_channel -> 'a) -> out_channel ->
val ikfprintf : (out_channel -> 'a) -> out_channel ->
('b, out_channel, unit, 'a) format4 -> 'b
;;
(** Same as [kfprintf] above, but does not print anything.
Useful to ignore some material when conditionally printing.
@since 4.0
*)
val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;;
val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b
(** Same as [sprintf] above, but instead of returning the string,
passes it to the first argument.
@since 3.09.0
*)
val kbprintf : (Buffer.t -> 'a) -> Buffer.t ->
('b, Buffer.t, unit, 'a) format4 -> 'b;;
('b, Buffer.t, unit, 'a) format4 -> 'b
(** Same as [bprintf], but instead of returning immediately,
passes the buffer to its first argument at the end of printing.
@since 3.10.0

57
stdlib/scanf.mli
View File

@ -83,7 +83,7 @@
module Scanning : sig
type in_channel;;
type in_channel
(** The notion of input channel for the [Scanf] module:
those channels provide all the machinery necessary to read from a given
[Pervasives.in_channel] value.
@ -93,7 +93,7 @@ type in_channel;;
@since 3.12.0
*)
type scanbuf = in_channel;;
type scanbuf = in_channel
(** The type of scanning buffers. A scanning buffer is the source from which a
formatted input function gets characters. The scanning buffer holds the
current state of the scan, plus a function to get the next char from the
@ -105,7 +105,7 @@ type scanbuf = in_channel;;
character yet to be read.
*)
val stdin : in_channel;;
val stdin : in_channel
(** The standard input notion for the [Scanf] module.
[Scanning.stdin] is the formatted input channel attached to
[Pervasives.stdin].
@ -118,12 +118,12 @@ val stdin : in_channel;;
@since 3.12.0
*)
type file_name = string;;
type file_name = string
(** A convenient alias to designate a file name.
@since 4.00.0
*)
val open_in : file_name -> in_channel;;
val open_in : file_name -> in_channel
(** [Scanning.open_in fname] returns a formatted input channel for bufferized
reading in text mode from file [fname].
@ -135,31 +135,32 @@ val open_in : file_name -> in_channel;;
@since 3.12.0
*)
val open_in_bin : file_name -> in_channel;;
val open_in_bin : file_name -> in_channel
(** [Scanning.open_in_bin fname] returns a formatted input channel for
bufferized reading in binary mode from file [fname].
@since 3.12.0
*)
val close_in : in_channel -> unit;;
val close_in : in_channel -> unit
(** Closes the [Pervasives.in_channel] associated with the given
[Scanning.in_channel] formatted input channel.
@since 3.12.0
*)
val from_file : file_name -> in_channel;;
val from_file : file_name -> in_channel
(** An alias for [open_in] above. *)
val from_file_bin : string -> in_channel;;
val from_file_bin : string -> in_channel
(** An alias for [open_in_bin] above. *)
val from_string : string -> in_channel;;
val from_string : string -> in_channel
(** [Scanning.from_string s] returns a formatted input channel which reads
from the given string.
Reading starts from the first character in the string.
The end-of-input condition is set when the end of the string is reached.
*)
val from_function : (unit -> char) -> in_channel;;
val from_function : (unit -> char) -> in_channel
(** [Scanning.from_function f] returns a formatted input channel with the
given function as its reading method.
@ -169,39 +170,39 @@ val from_function : (unit -> char) -> in_channel;;
end-of-input condition by raising the exception [End_of_file].
*)
val from_channel : Pervasives.in_channel -> in_channel;;
val from_channel : Pervasives.in_channel -> in_channel
(** [Scanning.from_channel ic] returns a formatted input channel which reads
from the regular input channel [ic] argument, starting at the current
reading position.
*)
val end_of_input : in_channel -> bool;;
val end_of_input : in_channel -> bool
(** [Scanning.end_of_input ic] tests the end-of-input condition of the given
formatted input channel.
*)
val beginning_of_input : in_channel -> bool;;
val beginning_of_input : in_channel -> bool
(** [Scanning.beginning_of_input ic] tests the beginning of input condition of
the given formatted input channel.
*)
val name_of_input : in_channel -> string;;
val name_of_input : in_channel -> string
(** [Scanning.name_of_input ic] returns the name of the character source
for the formatted input channel [ic].
@since 3.09.0
*)
val stdib : in_channel;;
val stdib : in_channel
(** A deprecated alias for [Scanning.stdin], the scanning buffer reading from
[Pervasives.stdin].
*)
end;;
end
(** {6 Type of formatted input functions} *)
type ('a, 'b, 'c, 'd) scanner =
('a, Scanning.in_channel, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c;;
('a, Scanning.in_channel, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c
(** The type of formatted input scanners: [('a, 'b, 'c, 'd) scanner]
is the type of a formatted input function that reads from some
formatted input channel according to some format string; more
@ -223,14 +224,14 @@ type ('a, 'b, 'c, 'd) scanner =
@since 3.10.0
*)
exception Scan_failure of string;;
exception Scan_failure of string
(** The exception that formatted input functions raise when the input cannot
be read according to the given format.
*)
(** {6 The general formatted input function} *)
val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;;
val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner
(** [bscanf ic fmt r1 ... rN f] reads arguments for the function [f], from the
formatted input channel [ic], according to the format string [fmt], and
applies [f] to these values.
@ -453,7 +454,7 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;;
(** {6 Specialised formatted input functions} *)
val fscanf : Pervasives.in_channel -> ('a, 'b, 'c, 'd) scanner;;
val fscanf : Pervasives.in_channel -> ('a, 'b, 'c, 'd) scanner
(** Same as {!Scanf.bscanf}, but reads from the given regular input channel.
Warning: since all formatted input functions operate from a {e formatted
@ -467,17 +468,17 @@ val fscanf : Pervasives.in_channel -> ('a, 'b, 'c, 'd) scanner;;
scanning from the same regular input channel.
*)
val sscanf : string -> ('a, 'b, 'c, 'd) scanner;;
val sscanf : string -> ('a, 'b, 'c, 'd) scanner
(** Same as {!Scanf.bscanf}, but reads from the given string. *)
val scanf : ('a, 'b, 'c, 'd) scanner;;
val scanf : ('a, 'b, 'c, 'd) scanner
(** Same as {!Scanf.bscanf}, but reads from the predefined formatted input
channel {!Scanf.Scanning.stdin} that is connected to [Pervasives.stdin].
*)
val kscanf :
Scanning.in_channel -> (Scanning.in_channel -> exn -> 'd) ->
('a, 'b, 'c, 'd) scanner;;
('a, 'b, 'c, 'd) scanner
(** Same as {!Scanf.bscanf}, but takes an additional function argument
[ef] that is called in case of error: if the scanning process or
some conversion fails, the scanning function aborts and calls the
@ -501,7 +502,7 @@ val kfscanf :
val bscanf_format :
Scanning.in_channel -> ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
(('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g;;
(('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g
(** [bscanf_format ic fmt f] reads a format string token from the formatted
input channel [ic], according to the given format string [fmt], and
applies [f] to the resulting format string value.
@ -512,14 +513,14 @@ val bscanf_format :
val sscanf_format :
string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
(('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g;;
(('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g
(** Same as {!Scanf.bscanf_format}, but reads from the given string.
@since 3.09.0
*)
val format_from_string :
string ->
('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('a, 'b, 'c, 'd, 'e, 'f) format6;;
('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('a, 'b, 'c, 'd, 'e, 'f) format6
(** [format_from_string s fmt] converts a string argument to a format string,
according to the given format string [fmt].
Raise [Scan_failure] if [s], considered as a format string, does not
@ -527,7 +528,7 @@ val format_from_string :
@since 3.10.0
*)
val unescaped : string -> string;;
val unescaped : string -> string
(** Return a copy of the argument with escape sequences, following the
lexical conventions of OCaml, replaced by their corresponding
special characters. If there is no escape sequence in the

2
testsuite/tests/warnings/w50.reference
View File

@ -1,2 +0,0 @@
File "w50.ml", line 4, characters 13-37:
Warning 50: expected tailcall

2
testsuite/tests/warnings/w50_bis.reference
View File

@ -1,2 +0,0 @@
File "w50_bis.ml", line 4, characters 12-48:
Warning 50: expected tailcall

0
testsuite/tests/warnings/w50.ml → testsuite/tests/warnings/w51.ml
View File

2
testsuite/tests/warnings/w51.reference Normal file
View File

@ -0,0 +1,2 @@
File "w51.ml", line 4, characters 13-37:
Warning 51: expected tailcall

0
testsuite/tests/warnings/w50_bis.ml → testsuite/tests/warnings/w51_bis.ml
View File

2
testsuite/tests/warnings/w51_bis.reference Normal file
View File

@ -0,0 +1,2 @@
File "w51_bis.ml", line 4, characters 12-48:
Warning 51: expected tailcall

7
tools/Makefile.shared
View File

@ -35,7 +35,7 @@ opt.opt: ocamldep.opt read_cmt.opt
CAMLDEP_OBJ=depend.cmo ocamldep.cmo
CAMLDEP_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \
warnings.cmo location.cmo longident.cmo \
warnings.cmo location.cmo longident.cmo docstrings.cmo \
syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo \
ccomp.cmo ast_mapper.cmo pparse.cmo compenv.cmo
@ -65,7 +65,7 @@ install::
CSLPROF=ocamlprof.cmo
CSLPROF_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \
warnings.cmo location.cmo longident.cmo \
warnings.cmo location.cmo longident.cmo docstrings.cmo \
syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo
ocamlprof: $(CSLPROF) profiling.cmo
@ -158,7 +158,7 @@ clean::
# Insert labels following an interface file (upgrade 3.02 to 3.03)
ADDLABELS_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \
warnings.cmo location.cmo longident.cmo \
warnings.cmo location.cmo longident.cmo docstrings.cmo \
syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo
addlabels: addlabels.cmo
@ -203,6 +203,7 @@ READ_CMT= \
../utils/clflags.cmo \
../parsing/location.cmo \
../parsing/longident.cmo \
../parsing/docstrings.cmo \
../parsing/lexer.cmo \
../parsing/pprintast.cmo \
../parsing/ast_helper.cmo \

1
tools/ocamlcp.ml
View File

@ -61,6 +61,7 @@ module Options = Main_args.Make_bytecomp_options (struct
let _impl s = with_impl := true; option_with_arg "-impl" s
let _intf s = with_intf := true; option_with_arg "-intf" s
let _intf_suffix s = option_with_arg "-intf-suffix" s
let _keep_docs = option "-keep-docs"
let _keep_locs = option "-keep-locs"
let _labels = option "-labels"
let _linkall = option "-linkall"

1
tools/ocamloptp.ml
View File

@ -61,6 +61,7 @@ module Options = Main_args.Make_optcomp_options (struct
let _inline n = option_with_int "-inline" n
let _intf s = with_intf := true; option_with_arg "-intf" s
let _intf_suffix s = option_with_arg "-intf-suffix" s
let _keep_docs = option "-keep-docs"
let _keep_locs = option "-keep-locs"
let _labels = option "-labels"
let _linkall = option "-linkall"

1
toplevel/genprintval.mli
View File

@ -54,6 +54,7 @@ module type S =
unit
(** [install_generic_printer' function_path constructor_path printer]
function_path is used to remove the printer. *)
val remove_printer : Path.t -> unit
val outval_of_untyped_exception : t -> Outcometree.out_value
val outval_of_value :

1
typing/ctype.mli
View File

@ -146,6 +146,7 @@ val try_expand_once_opt: Env.t -> type_expr -> type_expr
val expand_head_opt: Env.t -> type_expr -> type_expr
(** The compiler's own version of [expand_head] necessary for type-based
optimisations. *)
val full_expand: Env.t -> type_expr -> type_expr
val extract_concrete_typedecl:
Env.t -> type_expr -> Path.t * Path.t * type_declaration

19
typing/subst.ml
View File

@ -42,11 +42,22 @@ let remove_loc =
let open Ast_mapper in
{default_mapper with location = (fun _this _loc -> Location.none)}
let attrs s x =
if s.for_saving && not !Clflags.keep_locs
then remove_loc.Ast_mapper.attributes remove_loc x
else x
let is_not_doc = function
| ({Location.txt = "ocaml.doc"}, _) -> false
| ({Location.txt = "ocaml.text"}, _) -> false
| ({Location.txt = "doc"}, _) -> false
| ({Location.txt = "text"}, _) -> false
| _ -> true
let attrs s x =
let x =
if s.for_saving && not !Clflags.keep_docs then
List.filter is_not_doc x
else x
in
if s.for_saving && not !Clflags.keep_locs
then remove_loc.Ast_mapper.attributes remove_loc x
else x
let rec module_path s = function
Pident id as p ->

8
typing/untypeast.ml
View File

@ -351,14 +351,14 @@ let expression sub exp =
List.map (sub.value_binding sub) list,
sub.expr sub exp)
(** Pexp_function can't have a label, so we split in 3 cases. *)
(** One case, no guard: It's a fun. *)
(* Pexp_function can't have a label, so we split in 3 cases. *)
(* One case, no guard: It's a fun. *)
| Texp_function (label, [{c_lhs=p; c_guard=None; c_rhs=e}], _) ->
Pexp_fun (label, None, sub.pat sub p, sub.expr sub e)
(** No label: it's a function. *)
(* No label: it's a function. *)
| Texp_function (Nolabel, cases, _) ->
Pexp_function (sub.cases sub cases)
(** Mix of both, we generate `fun ~label:$name$ -> match $name$ with ...` *)
(* Mix of both, we generate `fun ~label:$name$ -> match $name$ with ...` *)
| Texp_function (Labelled s | Optional s as label, cases, _) ->
let name = fresh_name s exp.exp_env in
Pexp_fun (label, None, Pat.var ~loc {loc;txt = name },

1
utils/clflags.ml
View File

@ -113,5 +113,6 @@ let pic_code = ref (match Config.architecture with (* -fPIC *)
let runtime_variant = ref "";; (* -runtime-variant *)
let keep_docs = ref false (* -keep-docs *)
let keep_locs = ref false (* -keep-locs *)
let unsafe_string = ref true;; (* -safe-string / -unsafe-string *)

1
utils/clflags.mli
View File

@ -93,6 +93,7 @@ val dlcode : bool ref
val pic_code : bool ref
val runtime_variant : string ref
val force_slash : bool ref
val keep_docs : bool ref
val keep_locs : bool ref
val unsafe_string : bool ref
val opaque : bool ref

18
utils/warnings.ml
View File

@ -67,7 +67,8 @@ type t =
| Attribute_payload of string * string (* 47 *)
| Eliminated_optional_arguments of string list (* 48 *)
| No_cmi_file of string (* 49 *)
| Expect_tailcall (* 50 *)
| Bad_docstring of bool (* 50 *)
| Expect_tailcall (* 51 *)
;;
(* If you remove a warning, leave a hole in the numbering. NEVER change
@ -126,10 +127,11 @@ let number = function
| Attribute_payload _ -> 47
| Eliminated_optional_arguments _ -> 48
| No_cmi_file _ -> 49
| Expect_tailcall -> 50
| Bad_docstring _ -> 50
| Expect_tailcall -> 51
;;
let last_warning_number = 50
let last_warning_number = 51
(* Must be the max number returned by the [number] function. *)
let letter = function
@ -242,7 +244,7 @@ let parse_options errflag s =
current := {error; active}
(* If you change these, don't forget to change them in man/ocamlc.m *)
let defaults_w = "+a-4-6-7-9-27-29-32..39-41..42-44-45-48";;
let defaults_w = "+a-4-6-7-9-27-29-32..39-41..42-44-45-48-50";;
let defaults_warn_error = "-a";;
let () = parse_options false defaults_w;;
@ -390,6 +392,9 @@ let message = function
(String.concat ", " sl)
| No_cmi_file s ->
"no cmi file was found in path for module " ^ s
| Bad_docstring unattached ->
if unattached then "unattached documentation comment (ignored)"
else "ambiguous documentation comment"
| Expect_tailcall ->
Printf.sprintf "expected tailcall"
;;
@ -475,8 +480,9 @@ let descriptions =
46, "Illegal environment variable.";
47, "Illegal attribute payload.";
48, "Implicit elimination of optional arguments.";
49, "Absent cmi file when looking up module alias.";
50, "Warning on non-tail calls if @tailcall present";
49, "Missing cmi file when looking up module alias.";
50, "Unexpected documentation comment.";
51, "Warning on non-tail calls if @tailcall present";
]
;;

3
utils/warnings.mli
View File

@ -62,7 +62,8 @@ type t =
| Attribute_payload of string * string (* 47 *)
| Eliminated_optional_arguments of string list (* 48 *)
| No_cmi_file of string (* 49 *)
| Expect_tailcall (* 50 *)
| Bad_docstring of bool (* 50 *)
| Expect_tailcall (* 51 *)
;;
val parse_options : bool -> string -> unit;;