diff options
Diffstat (limited to 'parsing')
| -rw-r--r-- | parsing/ast_helper.ml | 6 | ||||
| -rw-r--r-- | parsing/ast_helper.mli | 7 | ||||
| -rwxr-xr-x | parsing/ast_iterator.ml | 10 | ||||
| -rwxr-xr-x | parsing/ast_iterator.mli | 1 | ||||
| -rw-r--r-- | parsing/ast_mapper.ml | 11 | ||||
| -rw-r--r-- | parsing/ast_mapper.mli | 1 | ||||
| -rwxr-xr-x | parsing/builtin_attributes.ml | 25 | ||||
| -rwxr-xr-x | parsing/builtin_attributes.mli | 2 | ||||
| -rw-r--r-- | parsing/depend.ml | 12 | ||||
| -rw-r--r-- | parsing/parser.mly | 14 | ||||
| -rw-r--r-- | parsing/parsetree.mli | 13 | ||||
| -rw-r--r-- | parsing/pprintast.ml | 5 | ||||
| -rw-r--r-- | parsing/printast.ml | 16 |
13 files changed, 94 insertions, 29 deletions
diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml index 2c28493395..f8fb81e9b0 100644 --- a/parsing/ast_helper.ml +++ b/parsing/ast_helper.ml @@ -515,6 +515,12 @@ module Te = struct ptyext_attributes = add_docs_attrs docs attrs; } + let mk_exception ?(attrs = []) ?(docs = empty_docs) constructor = + { + ptyexn_constructor = constructor; + ptyexn_attributes = add_docs_attrs docs attrs; + } + let constructor ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) ?(info = empty_info) name kind = { diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli index efc1dfcad5..42a1a57f42 100644 --- a/parsing/ast_helper.mli +++ b/parsing/ast_helper.mli @@ -206,6 +206,9 @@ module Te: ?params:(core_type * variance) list -> ?priv:private_flag -> lid -> extension_constructor list -> type_extension + val mk_exception: ?attrs:attrs -> ?docs:docs -> + extension_constructor -> type_exception + val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> str -> extension_constructor_kind -> extension_constructor @@ -261,7 +264,7 @@ module Sig: val value: ?loc:loc -> value_description -> signature_item val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item val type_extension: ?loc:loc -> type_extension -> signature_item - val exception_: ?loc:loc -> extension_constructor -> signature_item + val exception_: ?loc:loc -> type_exception -> signature_item val module_: ?loc:loc -> module_declaration -> signature_item val rec_module: ?loc:loc -> module_declaration list -> signature_item val modtype: ?loc:loc -> module_type_declaration -> signature_item @@ -284,7 +287,7 @@ module Str: val primitive: ?loc:loc -> value_description -> structure_item val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item val type_extension: ?loc:loc -> type_extension -> structure_item - val exception_: ?loc:loc -> extension_constructor -> structure_item + val exception_: ?loc:loc -> type_exception -> structure_item val module_: ?loc:loc -> module_binding -> structure_item val rec_module: ?loc:loc -> module_binding list -> structure_item val modtype: ?loc:loc -> module_type_declaration -> structure_item diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml index aa601e6419..080bde0f8c 100755 --- a/parsing/ast_iterator.ml +++ b/parsing/ast_iterator.ml @@ -61,6 +61,7 @@ type iterator = { typ: iterator -> core_type -> unit; type_declaration: iterator -> type_declaration -> unit; type_extension: iterator -> type_extension -> unit; + type_exception: iterator -> type_exception -> unit; type_kind: iterator -> type_kind -> unit; value_binding: iterator -> value_binding -> unit; value_description: iterator -> value_description -> unit; @@ -155,6 +156,10 @@ module T = struct List.iter (iter_fst (sub.typ sub)) ptyext_params; sub.attributes sub ptyext_attributes + let iter_type_exception sub {ptyexn_constructor; ptyexn_attributes} = + sub.extension_constructor sub ptyexn_constructor; + sub.attributes sub ptyexn_attributes + let iter_extension_constructor_kind sub = function Pext_decl(ctl, cto) -> iter_constructor_arguments sub ctl; iter_opt (sub.typ sub) cto @@ -243,7 +248,7 @@ module MT = struct | Psig_value vd -> sub.value_description sub vd | Psig_type (_rf, l) -> List.iter (sub.type_declaration sub) l | Psig_typext te -> sub.type_extension sub te - | Psig_exception ed -> sub.extension_constructor sub ed + | Psig_exception ed -> sub.type_exception sub ed | Psig_module x -> sub.module_declaration sub x | Psig_recmodule l -> List.iter (sub.module_declaration sub) l @@ -288,7 +293,7 @@ module M = struct | Pstr_primitive vd -> sub.value_description sub vd | Pstr_type (_rf, l) -> List.iter (sub.type_declaration sub) l | Pstr_typext te -> sub.type_extension sub te - | Pstr_exception ed -> sub.extension_constructor sub ed + | Pstr_exception ed -> sub.type_exception sub ed | Pstr_module x -> sub.module_binding sub x | Pstr_recmodule l -> List.iter (sub.module_binding sub) l | Pstr_modtype x -> sub.module_type_declaration sub x @@ -497,6 +502,7 @@ let default_iterator = type_kind = T.iter_type_kind; typ = T.iter; type_extension = T.iter_type_extension; + type_exception = T.iter_type_exception; extension_constructor = T.iter_extension_constructor; value_description = (fun this {pval_name; pval_type; pval_prim = _; pval_loc; diff --git a/parsing/ast_iterator.mli b/parsing/ast_iterator.mli index bd8e081687..0f06139d3f 100755 --- a/parsing/ast_iterator.mli +++ b/parsing/ast_iterator.mli @@ -58,6 +58,7 @@ type iterator = { typ: iterator -> core_type -> unit; type_declaration: iterator -> type_declaration -> unit; type_extension: iterator -> type_extension -> unit; + type_exception: iterator -> type_exception -> unit; type_kind: iterator -> type_kind -> unit; value_binding: iterator -> value_binding -> unit; value_description: iterator -> value_description -> unit; diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index 783d0e2eea..af2b62a6a9 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -66,6 +66,7 @@ type mapper = { typ: mapper -> core_type -> core_type; type_declaration: mapper -> type_declaration -> type_declaration; type_extension: mapper -> type_extension -> type_extension; + type_exception: mapper -> type_exception -> type_exception; type_kind: mapper -> type_kind -> type_kind; value_binding: mapper -> value_binding -> value_binding; value_description: mapper -> value_description -> value_description; @@ -162,6 +163,11 @@ module T = struct ~priv:ptyext_private ~attrs:(sub.attributes sub ptyext_attributes) + let map_type_exception sub {ptyexn_constructor; ptyexn_attributes} = + Te.mk_exception + (sub.extension_constructor sub ptyexn_constructor) + ~attrs:(sub.attributes sub ptyexn_attributes) + let map_extension_constructor_kind sub = function Pext_decl(ctl, cto) -> Pext_decl(map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto) @@ -258,7 +264,7 @@ module MT = struct | Psig_value vd -> value ~loc (sub.value_description sub vd) | Psig_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) - | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) + | Psig_exception ed -> exception_ ~loc (sub.type_exception sub ed) | Psig_module x -> module_ ~loc (sub.module_declaration sub x) | Psig_recmodule l -> rec_module ~loc (List.map (sub.module_declaration sub) l) @@ -306,7 +312,7 @@ module M = struct | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) - | Pstr_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) + | Pstr_exception ed -> exception_ ~loc (sub.type_exception sub ed) | Pstr_module x -> module_ ~loc (sub.module_binding sub x) | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) @@ -528,6 +534,7 @@ let default_mapper = type_kind = T.map_type_kind; typ = T.map; type_extension = T.map_type_extension; + type_exception = T.map_type_exception; extension_constructor = T.map_extension_constructor; value_description = (fun this {pval_name; pval_type; pval_prim; pval_loc; diff --git a/parsing/ast_mapper.mli b/parsing/ast_mapper.mli index 85b59e9c37..954e08e027 100644 --- a/parsing/ast_mapper.mli +++ b/parsing/ast_mapper.mli @@ -93,6 +93,7 @@ type mapper = { typ: mapper -> core_type -> core_type; type_declaration: mapper -> type_declaration -> type_declaration; type_extension: mapper -> type_extension -> type_extension; + type_exception: mapper -> type_exception -> type_exception; type_kind: mapper -> type_kind -> type_kind; value_binding: mapper -> value_binding -> value_binding; value_description: mapper -> value_description -> value_description; diff --git a/parsing/builtin_attributes.ml b/parsing/builtin_attributes.ml index a8eb33b607..57b5d4612d 100755 --- a/parsing/builtin_attributes.ml +++ b/parsing/builtin_attributes.ml @@ -62,11 +62,22 @@ let rec error_of_extension ext = let cat s1 s2 = if s2 = "" then s1 else s1 ^ "\n" ^ s2 -let rec deprecated_of_attrs = function +let deprecated_attr x = + match x with + | ({txt = "ocaml.deprecated"|"deprecated"; _},_) -> Some x + | _ -> None + +let rec deprecated_attrs = function | [] -> None - | ({txt = "ocaml.deprecated"|"deprecated"; _}, p) :: _ -> - Some (string_of_opt_payload p) - | _ :: tl -> deprecated_of_attrs tl + | hd :: tl -> + match deprecated_attr hd with + | Some x -> Some x + | None -> deprecated_attrs tl + +let deprecated_of_attrs l = + match deprecated_attrs l with + | None -> None + | Some (_,p) -> Some (string_of_opt_payload p) let check_deprecated loc attrs s = match deprecated_of_attrs attrs with @@ -117,6 +128,12 @@ let rec deprecated_of_str = function | _ -> None +let check_no_deprecated attrs = + match deprecated_attrs attrs with + | None -> () + | Some ({txt;loc},_) -> + Location.prerr_warning loc (Warnings.Misplaced_attribute txt) + let warning_attribute ?(ppwarning = true) = let process loc txt errflag payload = match string_of_payload payload with diff --git a/parsing/builtin_attributes.mli b/parsing/builtin_attributes.mli index 056316a697..be0de631a7 100755 --- a/parsing/builtin_attributes.mli +++ b/parsing/builtin_attributes.mli @@ -42,6 +42,8 @@ val check_deprecated_mutable_inclusion: def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes -> Parsetree.attributes -> string -> unit +val check_no_deprecated : Parsetree.attributes -> unit + val error_of_extension: Parsetree.extension -> Location.error val warning_attribute: ?ppwarning:bool -> Parsetree.attribute -> unit diff --git a/parsing/depend.ml b/parsing/depend.ml index 9e872fbc40..84cae99bef 100644 --- a/parsing/depend.ml +++ b/parsing/depend.ml @@ -160,6 +160,9 @@ let add_type_extension bv te = add bv te.ptyext_path; List.iter (add_extension_constructor bv) te.ptyext_constructors +let add_type_exception bv te = + add_extension_constructor bv te.ptyexn_constructor + let rec add_class_type bv cty = match cty.pcty_desc with Pcty_constr(l, tyl) -> @@ -350,8 +353,8 @@ and add_sig_item (bv, m) item = List.iter (add_type_declaration bv) dcls; (bv, m) | Psig_typext te -> add_type_extension bv te; (bv, m) - | Psig_exception pext -> - add_extension_constructor bv pext; (bv, m) + | Psig_exception te -> + add_type_exception bv te; (bv, m) | Psig_module pmd -> let m' = add_modtype_binding bv pmd.pmd_type in let add = StringMap.add pmd.pmd_name.txt m' in @@ -430,8 +433,9 @@ and add_struct_item (bv, m) item : _ StringMap.t * _ StringMap.t = | Pstr_typext te -> add_type_extension bv te; (bv, m) - | Pstr_exception pext -> - add_extension_constructor bv pext; (bv, m) + | Pstr_exception te -> + add_type_exception bv te; + (bv, m) | Pstr_module x -> let b = add_module_binding bv x.pmb_expr in let add = StringMap.add x.pmb_name.txt b in diff --git a/parsing/parser.mly b/parsing/parser.mly index 9ed25badac..6a6bb64b98 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -2045,18 +2045,20 @@ str_exception_declaration: | sig_exception_declaration { $1 } | EXCEPTION ext_attributes constr_ident EQUAL constr_longident attributes post_item_attributes - { let (ext,attrs) = $2 in - Te.rebind (mkrhs $3 3) (mkrhs $5 5) ~attrs:(attrs @ $6 @ $7) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext } + { let (ext,attrs) = $2 in + Te.mk_exception ~attrs:$7 + (Te.rebind (mkrhs $3 3) (mkrhs $5 5) ~attrs:(attrs @ $6) + ~loc:(symbol_rloc()) ~docs:(symbol_docs ())) + , ext } ; sig_exception_declaration: | EXCEPTION ext_attributes constr_ident generalized_constructor_arguments attributes post_item_attributes { let args, res = $4 in let (ext,attrs) = $2 in - Te.decl (mkrhs $3 3) ~args ?res ~attrs:(attrs @ $5 @ $6) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) + Te.mk_exception ~attrs:$6 + (Te.decl (mkrhs $3 3) ~args ?res ~attrs:(attrs @ $5) + ~loc:(symbol_rloc()) ~docs:(symbol_docs ())) , ext } ; let_exception_declaration: diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 9f5de197b3..2302547f03 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -466,7 +466,14 @@ and extension_constructor = pext_kind : extension_constructor_kind; pext_loc : Location.t; pext_attributes: attributes; (* C of ... [@id1] [@id2] *) - } + } + +(* exception E *) +and type_exception = + { + ptyexn_constructor: extension_constructor; + ptyexn_attributes: attributes; (* ... [@@id1] [@@id2] *) + } and extension_constructor_kind = Pext_decl of constructor_arguments * core_type option @@ -691,7 +698,7 @@ and signature_item_desc = (* type t1 = ... and ... and tn = ... *) | Psig_typext of type_extension (* type t1 += ... *) - | Psig_exception of extension_constructor + | Psig_exception of type_exception (* exception C of T *) | Psig_module of module_declaration (* module X : MT *) @@ -818,7 +825,7 @@ and structure_item_desc = (* type t1 = ... and ... and tn = ... *) | Pstr_typext of type_extension (* type t1 += ... *) - | Pstr_exception of extension_constructor + | Pstr_exception of type_exception (* exception C of T exception C = M.X *) | Pstr_module of module_binding diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index e9e0de28e4..985c002c83 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -778,8 +778,9 @@ and extension ctxt f (s, e) = and item_extension ctxt f (s, e) = pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e -and exception_declaration ctxt f ext = - pp f "@[<hov2>exception@ %a@]" (extension_constructor ctxt) ext +and exception_declaration ctxt f x = + pp f "@[<hov2>exception@ %a@]%a" (extension_constructor ctxt) x.ptyexn_constructor + (item_attributes ctxt) x.ptyexn_attributes and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} = let class_type_field f x = diff --git a/parsing/printast.ml b/parsing/printast.ml index 62ccc04b0a..df9ae8830b 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -448,6 +448,14 @@ and type_extension i ppf x = list (i+1) extension_constructor ppf x.ptyext_constructors; line i ppf "ptyext_private = %a\n" fmt_private_flag x.ptyext_private; +and type_exception i ppf x = + line i ppf "type_exception\n"; + attributes i ppf x.ptyexn_attributes; + let i = i+1 in + line i ppf "ptyext_constructor =\n"; + let i = i+1 in + extension_constructor i ppf x.ptyexn_constructor + and extension_constructor i ppf x = line i ppf "extension_constructor %a\n" fmt_location x.pext_loc; attributes i ppf x.pext_attributes; @@ -676,9 +684,9 @@ and signature_item i ppf x = | Psig_typext te -> line i ppf "Psig_typext\n"; type_extension i ppf te - | Psig_exception ext -> + | Psig_exception te -> line i ppf "Psig_exception\n"; - extension_constructor i ppf ext; + type_exception i ppf te | Psig_module pmd -> line i ppf "Psig_module %a\n" fmt_string_loc pmd.pmd_name; attributes i ppf pmd.pmd_attributes; @@ -784,9 +792,9 @@ and structure_item i ppf x = | Pstr_typext te -> line i ppf "Pstr_typext\n"; type_extension i ppf te - | Pstr_exception ext -> + | Pstr_exception te -> line i ppf "Pstr_exception\n"; - extension_constructor i ppf ext; + type_exception i ppf te | Pstr_module x -> line i ppf "Pstr_module\n"; module_binding i ppf x |