From 8625a5c6f1d1a160314cdc9e68085f1bd925836b Mon Sep 17 00:00:00 2001 From: Pierre Weis Date: Wed, 5 May 2010 20:51:54 +0000 Subject: [PATCH] Simpler implementation of error narrowing. Factorization of lid finding code. git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@10378 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- typing/typecore.ml | 107 +++++++++++++++++++++------------------------ 1 file changed, 49 insertions(+), 58 deletions(-) diff --git a/typing/typecore.ml b/typing/typecore.ml index 6043bff2c..0f55bbab6 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -306,7 +306,7 @@ let rec build_as_type env p = | Tpat_array _ | Tpat_lazy _ -> p.pat_type (* Narrowing unbound identifier errors. *) -let rec narrow_unbound_lid_error env loc lid make_error = +let rec narrow_unbound_lid_error env lid make_error = let module_is_bound mlid = ignore (Env.lookup_module mlid env) in match lid with @@ -316,7 +316,7 @@ let rec narrow_unbound_lid_error env loc lid make_error = try module_is_bound mlid; make_error lid with - | Not_found -> Error (loc, Unbound_module mlid) + | Not_found -> Unbound_module mlid end | Longident.Lapply (flid, mlid) -> begin @@ -326,24 +326,53 @@ let rec narrow_unbound_lid_error env loc lid make_error = try module_is_bound mlid; make_error lid with - | Not_found -> Error (loc, Unbound_module mlid) + | Not_found -> Unbound_module mlid end with - | Not_found -> Error (loc, Unbound_functor flid) + | Not_found -> Unbound_functor flid end ;; let unbound_lid_error env loc lid make_error = - let err = narrow_unbound_lid_error env loc lid make_error in - raise err + let err = narrow_unbound_lid_error env lid make_error in + raise (Error (loc, err)) +;; + +let find_type env loc lid = + try Env.lookup_type lid env + with Not_found -> + unbound_lid_error env loc lid + (fun lid -> + raise (Typetexp.Error (loc, Typetexp.Unbound_type_constructor lid))) +;; + +let find_constructor env loc lid = + try + match lid with + | Longident.Ldot (Longident.Lident "*predef*", s) -> + Env.lookup_constructor (Longident.Lident s) Env.initial + | _ -> Env.lookup_constructor lid env + with Not_found -> + unbound_lid_error env loc lid + (fun lid -> Unbound_constructor lid) +;; + +let find_label env loc lid = + try + Env.lookup_label lid env + with Not_found -> + unbound_lid_error env loc lid + (fun lid -> Unbound_label lid) +;; + +let find_class env loc lid = + try Env.lookup_class lid env with + | Not_found -> + unbound_lid_error env loc lid + (fun lid -> Unbound_class lid) ;; let build_or_pat env loc lid = - let path, decl = - try Env.lookup_type lid env - with Not_found -> - unbound_lid_error env loc lid - (fun lid -> - Typetexp.Error(loc, Typetexp.Unbound_type_constructor lid)) + let path, decl = find_type env loc lid in let tyl = List.map (fun _ -> newvar()) decl.type_params in let row0 = @@ -495,15 +524,7 @@ let rec type_pat env sp = pat_type = newty (Ttuple(List.map (fun p -> p.pat_type) pl)); pat_env = env } | Ppat_construct(lid, sarg, explicit_arity) -> - let constr = - try - match lid with - Longident.Ldot (Longident.Lident "*predef*", s) -> - Env.lookup_constructor (Longident.Lident s) Env.initial - | _ -> Env.lookup_constructor lid env - with Not_found -> - unbound_lid_error env loc lid - (fun lid -> Error(loc, Unbound_constructor lid)) in + let constr = find_constructor env loc lid in let sargs = match sarg with None -> [] @@ -544,12 +565,7 @@ let rec type_pat env sp = | Ppat_record(lid_sp_list, closed) -> let ty = newvar() in let type_label_pat (lid, sarg) = - let label = - try - Env.lookup_label lid env - with Not_found -> - unbound_lid_error env loc lid - (fun lid -> Error(loc, Unbound_label lid)) in + let label = find_label env loc lid in begin_def (); let (vars, ty_arg, ty_res) = instance_label false label in if vars = [] then end_def (); @@ -1089,7 +1105,7 @@ let rec type_exp env sexp = exp_env = env } with Not_found -> unbound_lid_error env loc lid - (fun lid -> Error (loc, Unbound_value lid)) + (fun lid -> Unbound_value lid) end | Pexp_constant cst -> re { @@ -1189,12 +1205,7 @@ let rec type_exp env sexp = let ty = newvar() in let num_fields = ref 0 in let type_label_exp (lid, sarg) = - let label = - try - Env.lookup_label lid env - with Not_found -> - unbound_lid_error env loc lid - (fun lid -> Error (loc, Unbound_label lid)) in + let label = find_label env loc lid in begin_def (); if !Clflags.principal then begin_def (); let (vars, ty_arg, ty_res) = instance_label true label in @@ -1265,12 +1276,7 @@ let rec type_exp env sexp = exp_env = env } | Pexp_field(sarg, lid) -> let arg = type_exp env sarg in - let label = - try - Env.lookup_label lid env - with Not_found -> - unbound_lid_error env loc lid - (fun lid -> Error (loc, Unbound_label lid)) in + let label = find_label env loc lid in let (_, ty_arg, ty_res) = instance_label false label in unify_exp env arg ty_res; re { @@ -1280,12 +1286,7 @@ let rec type_exp env sexp = exp_env = env } | Pexp_setfield(srecord, lid, snewval) -> let record = type_exp env srecord in - let label = - try - Env.lookup_label lid env - with Not_found -> - unbound_lid_error env loc lid - (fun lid -> Error (loc, Unbound_label lid)) in + let label = find_label env loc lid in if label.lbl_mut = Immutable then raise(Error(loc, Label_not_mutable lid)); begin_def (); @@ -1532,12 +1533,7 @@ let rec type_exp env sexp = raise(Error(e.pexp_loc, Undefined_method (obj.exp_type, met))) end | Pexp_new cl -> - let (cl_path, cl_decl) = - try Env.lookup_class cl env with - | Not_found -> - unbound_lid_error env loc cl - (fun lid -> Error (loc, Unbound_class lid)) - in + let (cl_path, cl_decl) = find_class env loc cl in begin match cl_decl.cty_new with None -> raise(Error(loc, Virtual_class cl)) @@ -1956,12 +1952,7 @@ and type_application env funct sargs = type_args [] [] ty ty sargs [] and type_construct env loc lid sarg explicit_arity ty_expected = - let constr = - try - Env.lookup_constructor lid env - with Not_found -> - unbound_lid_error env loc lid - (fun lid -> Error (loc, Unbound_constructor lid)) in + let constr = find_constructor env loc lid in let sargs = match sarg with None -> []