diff options
| -rw-r--r-- | otherlibs/labltk/browser/searchid.ml | 2 | ||||
| -rw-r--r-- | parsing/ast_mapper.ml | 4 | ||||
| -rw-r--r-- | parsing/parser.mly | 12 | ||||
| -rw-r--r-- | parsing/parsetree.mli | 2 | ||||
| -rw-r--r-- | parsing/pprintast.ml | 1 | ||||
| -rw-r--r-- | parsing/printast.ml | 7 | ||||
| -rw-r--r-- | tools/depend.ml | 2 | ||||
| -rw-r--r-- | typing/typecore.ml | 6 |
8 files changed, 32 insertions, 4 deletions
diff --git a/otherlibs/labltk/browser/searchid.ml b/otherlibs/labltk/browser/searchid.ml index 0cad8ffc7..11f0fa5bc 100644 --- a/otherlibs/labltk/browser/searchid.ml +++ b/otherlibs/labltk/browser/searchid.ml @@ -428,6 +428,8 @@ let rec bound_variables pat = bound_variables pat1 @ bound_variables pat2 | Ppat_constraint (pat,_) -> bound_variables pat | Ppat_lazy pat -> bound_variables pat + | Ppat_attribute (pat, _) -> bound_variables pat + | Ppat_extension _ -> [] let search_structure str ~name ~kind ~prefix = let loc = ref 0 in diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index d5f7c246b..690e26546 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -362,6 +362,8 @@ module P = struct let type_ ?loc a = mk ?loc (Ppat_type a) let lazy_ ?loc a = mk ?loc (Ppat_lazy a) let unpack ?loc a = mk ?loc (Ppat_unpack a) + let attribute ?loc a b = mk ?loc (Ppat_attribute (a, b)) + let extension ?loc a = mk ?loc (Ppat_extension a) let map sub {ppat_desc = desc; ppat_loc = loc} = let loc = sub # location loc in @@ -381,6 +383,8 @@ module P = struct | Ppat_type s -> type_ ~loc (map_loc sub s) | Ppat_lazy p -> lazy_ ~loc (sub # pat p) | Ppat_unpack s -> unpack ~loc (map_loc sub s) + | Ppat_attribute (body, x) -> attribute ~loc (sub # pat body) (sub # attribute x) + | Ppat_extension x -> extension ~loc (sub # extension x) end module CE = struct diff --git a/parsing/parser.mly b/parsing/parser.mly index 5c0c67ec4..3d938ef74 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -1079,10 +1079,6 @@ expr: | expr attribute { mkexp (Pexp_attribute($1, $2)) } ; -opt_expr: - expr { $1 } - | { ghunit () } -; simple_expr: val_longident { mkexp(Pexp_ident (mkrhs $1 1)) } @@ -1303,6 +1299,8 @@ pattern: { expecting 3 "pattern" } | LAZY simple_pattern { mkpat(Ppat_lazy $2) } + | pattern attribute + { mkpat(Ppat_attribute($1, $2)) } ; simple_pattern: val_ident %prec below_EQUAL @@ -1349,6 +1347,8 @@ simple_pattern: { mkpat(Ppat_constraint(mkpat(Ppat_unpack (mkrhs $3 3)),ghtyp(Ptyp_package $5))) } | LPAREN MODULE UIDENT COLON package_type error { unclosed "(" 1 ")" 6 } + | extension + { mkpat(Ppat_extension $1) } ; pattern_comma_list: @@ -1900,4 +1900,8 @@ with_attribute: extension: LPARENCOLON LIDENT opt_expr RPAREN { ($2, $3) } ; +opt_expr: + expr { $1 } + | { ghunit () } +; %% diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index f1cd345fa..b7f80fe9d 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -87,6 +87,8 @@ and pattern_desc = | Ppat_type of Longident.t loc | Ppat_lazy of pattern | Ppat_unpack of string loc + | Ppat_attribute of (pattern * attribute) + | Ppat_extension of extension and expression = { pexp_desc: expression_desc; diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index 08cd939fb..bb5cbeea6 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -108,6 +108,7 @@ let rec is_irrefut_patt x = | Ppat_or (l,r) -> is_irrefut_patt l || is_irrefut_patt r | Ppat_record (ls,_) -> List.for_all (fun (_,x) -> is_irrefut_patt x) ls | Ppat_lazy p -> is_irrefut_patt p + | Ppat_extension _ | Ppat_attribute _ -> assert false | Ppat_constant _ | Ppat_construct _ | Ppat_variant _ | Ppat_array _ | Ppat_type _-> false (*conservative*) class printer ()= object(self:'self) val pipe = false diff --git a/parsing/printast.ml b/parsing/printast.ml index d4dc340d8..31d23eb6d 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -226,6 +226,13 @@ and pattern i ppf x = longident_loc i ppf li | Ppat_unpack s -> line i ppf "Ppat_unpack %a\n" fmt_string_loc s; + | Ppat_attribute (body, (s, arg)) -> + line i ppf "Ppat_attribute \"%s\"\n" s; + expression i ppf arg; + pattern i ppf body + | Ppat_extension (s, arg) -> + line i ppf "Ppat_extension \"%s\"\n" s; + expression i ppf arg and expression i ppf x = line i ppf "expression %a\n" fmt_location x.pexp_loc; diff --git a/tools/depend.ml b/tools/depend.ml index 2f6d20f08..8a964bda1 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -124,6 +124,8 @@ let rec add_pattern bv pat = | Ppat_type li -> add bv li | Ppat_lazy p -> add_pattern bv p | Ppat_unpack id -> pattern_bv := StringSet.add id.txt !pattern_bv + | Ppat_attribute (p, _) -> add_pattern bv p + | Ppat_extension _ -> () let add_pattern bv pat = pattern_bv := bv; diff --git a/typing/typecore.ml b/typing/typecore.ml index 6bd13007e..53c2f760a 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -1099,6 +1099,10 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = let (path, p,ty) = build_or_pat !env loc lid.txt in unify_pat_types loc !env ty expected_ty; { p with pat_extra = (Tpat_type (path, lid), loc) :: p.pat_extra } + | Ppat_attribute (p, _attrs) -> + type_pat p expected_ty + | Ppat_extension (s, _arg) -> + raise (Error (loc, !env, Extension s)) let type_pat ?(allow_existentials=false) ?constrs ?labels ?(lev=get_current_level()) env sp expected_ty = @@ -1699,11 +1703,13 @@ let contains_variant_either ty = let iter_ppat f p = match p.ppat_desc with | Ppat_any | Ppat_var _ | Ppat_constant _ + | Ppat_extension _ | Ppat_type _ | Ppat_unpack _ -> () | Ppat_array pats -> List.iter f pats | Ppat_or (p1,p2) -> f p1; f p2 | Ppat_variant (_, arg) | Ppat_construct (_, arg, _) -> may f arg | Ppat_tuple lst -> List.iter f lst + | Ppat_attribute (p, _) | Ppat_alias (p,_) | Ppat_constraint (p,_) | Ppat_lazy p -> f p | Ppat_record (args, flag) -> List.iter (fun (_,p) -> f p) args |