diff --git a/parsing/parser.mly b/parsing/parser.mly index 7039f54aa..75db5b9b4 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -1027,6 +1027,8 @@ simple_pattern: { mkpat(Ppat_construct($1, None, false)) } | name_tag { mkpat(Ppat_variant($1, None)) } + | SHARP type_longident + { mkpat(Ppat_type $2) } | LBRACE lbl_pattern_list opt_semi RBRACE { mkpat(Ppat_record(List.rev $2)) } | LBRACE lbl_pattern_list opt_semi error diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 5681dded2..524ffde4a 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -68,6 +68,7 @@ and pattern_desc = | Ppat_array of pattern list | Ppat_or of pattern * pattern | Ppat_constraint of pattern * core_type + | Ppat_type of Longident.t type expression = { pexp_desc: expression_desc; diff --git a/parsing/printast.ml b/parsing/printast.ml index 2f31f4342..ca7bbd687 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -169,6 +169,9 @@ and pattern i x = line i "Ppat_constraint"; pattern i p; core_type i ct; + | Ppat_type li -> + line i "PPat_type"; + longident i li and expression i x = line i "expression %a\n" fmt_location x.pexp_loc; diff --git a/typing/typecore.ml b/typing/typecore.ml index 8929821bb..8b87aa7ab 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -53,6 +53,7 @@ type error = | Abstract_wrong_label of label * type_expr | Scoping_let_module of string * type_expr | Masked_instance_variable of Longident.t + | Not_a_variant_type of Longident.t exception Error of Location.t * error @@ -118,6 +119,57 @@ let rec extract_row_fields p = | _ -> raise Not_found +let build_or_pat env loc lid = + let path, decl = + try Env.lookup_type lid env + with Not_found -> + raise(Typetexp.Error(loc, Typetexp.Unbound_type_constructor lid)) + in + let tyl, ty = + match decl.type_manifest with + None -> raise(Error(loc, Not_a_variant_type lid)) + | Some ty -> instance_parameterized_type decl.type_params ty + in + let fields = + match (repr ty).desc with + Tvariant row when static_row row -> + (row_repr row).row_fields + | _ -> raise(Error(loc, Not_a_variant_type lid)) + in + let bound = ref [] in + let pats, fields = + List.fold_left + (fun (pats,fields) (l,f) -> + match row_field_repr f with + Rpresent None -> + (l,None) :: pats, + (l, Reither(true,[], ref None)) :: fields + | Rpresent (Some ty) -> + bound := ty :: !bound; + (l, Some{pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env; + pat_type=ty}) + :: pats, + (l, Reither(false, [ty], ref None)) :: fields + | _ -> pats, fields) + ([],[]) fields in + let row = + { row_fields = fields; row_more = newvar(); row_bound = !bound; + row_closed = false; row_name = Some (path, tyl) } + in + let ty = newty (Tvariant row) in + let pats = + List.map (fun (l,p) -> {pat_desc=Tpat_variant(l,p,row); pat_loc=loc; + pat_env=env; pat_type=ty}) + pats + in + match pats with + [] -> raise(Error(loc, Not_a_variant_type lid)) + | pat :: pats -> + List.fold_left + (fun pat pat0 -> {pat_desc=Tpat_or(pat,pat0); pat_loc=loc; + pat_env=env; pat_type=ty}) + pat pats + let rec type_pat env sp = match sp.ppat_desc with Ppat_any -> @@ -247,6 +299,8 @@ let rec type_pat env sp = let ty = Typetexp.transl_simple_type env false sty in unify_pat env p ty; p + | Ppat_type lid -> + build_or_pat env sp.ppat_loc lid let add_pattern_variables env = let pv = !pattern_variables in @@ -1316,3 +1370,6 @@ let report_error = function print_string "The instance variable "; longident lid; print_space (); print_string "cannot be accessed from the definition of another instance variable" + | Not_a_variant_type lid -> + print_string "The type "; longident lid; print_space (); + print_string "is not a variant type" diff --git a/typing/typecore.mli b/typing/typecore.mli index 38238ce98..66cb5d8f3 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -82,6 +82,7 @@ type error = | Abstract_wrong_label of label * type_expr | Scoping_let_module of string * type_expr | Masked_instance_variable of Longident.t + | Not_a_variant_type of Longident.t exception Error of Location.t * error diff --git a/utils/config.mlp b/utils/config.mlp index c7c06784a..cafaae0b6 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -12,7 +12,7 @@ (* $Id$ *) -let version = "2.99+4 (2000/02/13)" +let version = "2.99+5 (2000/02/22)" let standard_library = try