diff options
Diffstat (limited to 'pretyping')
| -rw-r--r-- | pretyping/cases.ml | 6 | ||||
| -rw-r--r-- | pretyping/classops.ml | 57 | ||||
| -rw-r--r-- | pretyping/classops.mli | 18 | ||||
| -rw-r--r-- | pretyping/coercion.ml | 7 | ||||
| -rw-r--r-- | pretyping/vnorm.ml | 3 |
5 files changed, 43 insertions, 48 deletions
diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 6a63fb02f8..ad33297f0a 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -373,6 +373,11 @@ let ltac_interp_realnames lvar = function | t, IsInd (ty,ind,realnal) -> t, IsInd (ty,ind,List.map (ltac_interp_name lvar) realnal) | _ as x -> x +let is_patvar pat = + match DAst.get pat with + | PatVar _ -> true + | _ -> false + let coerce_row typing_fun evdref env lvar pats (tomatch,(na,indopt)) = let loc = loc_of_glob_constr tomatch in let tycon,realnames = find_tomatch_tycon evdref env loc indopt in @@ -381,6 +386,7 @@ let coerce_row typing_fun evdref env lvar pats (tomatch,(na,indopt)) = let typ = nf_evar !evdref j.uj_type in lvar := make_return_predicate_ltac_lvar !evdref na tomatch j.uj_val !lvar; let t = + if realnames = None && pats <> [] && List.for_all is_patvar pats then NotInd (None,typ) else try try_find_ind env !evdref typ realnames with Not_found -> unify_tomatch_with_patterns evdref env loc typ pats realnames in diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 7ac08e755e..542fb5456c 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -42,18 +42,15 @@ type coe_typ = GlobRef.t module CoeTypMap = Refmap_env type coe_info_typ = { - coe_value : constr; - coe_type : types; + coe_value : GlobRef.t; coe_local : bool; - coe_context : Univ.ContextSet.t; coe_is_identity : bool; coe_is_projection : Projection.Repr.t option; - coe_param : int } + coe_param : int; +} let coe_info_typ_equal c1 c2 = - let eq_constr c1 c2 = Termops.eq_constr Evd.empty (EConstr.of_constr c1) (EConstr.of_constr c2) in - eq_constr c1.coe_value c2.coe_value && - eq_constr c1.coe_type c2.coe_type && + GlobRef.equal c1.coe_value c2.coe_value && c1.coe_local == c2.coe_local && c1.coe_is_identity == c2.coe_is_identity && c1.coe_is_projection == c2.coe_is_projection && @@ -77,9 +74,7 @@ module IntMap = Map.Make(Int) let cl_typ_eq t1 t2 = Int.equal (cl_typ_ord t1 t2) 0 -type coe_index = coe_info_typ - -type inheritance_path = coe_index list +type inheritance_path = coe_info_typ list (* table des classes, des coercions et graphe d'heritage *) @@ -300,31 +295,25 @@ let lookup_path_to_fun_from env sigma s = let lookup_path_to_sort_from env sigma s = apply_on_class_of env sigma s lookup_path_to_sort_from_class +let mkNamed = function + | GlobRef.ConstRef c -> EConstr.mkConst c + | VarRef v -> EConstr.mkVar v + | ConstructRef c -> EConstr.mkConstruct c + | IndRef i -> EConstr.mkInd i + let get_coercion_constructor env coe = - let c, _ = - Reductionops.whd_all_stack env Evd.empty (EConstr.of_constr coe.coe_value) - in - match EConstr.kind Evd.empty (** FIXME *) c with - | Construct (cstr,u) -> - (cstr, Inductiveops.constructor_nrealargs cstr -1) - | _ -> - raise Not_found + let evd = Evd.from_env env in + let red x = fst (Reductionops.whd_all_stack env evd x) in + match EConstr.kind evd (red (mkNamed coe.coe_value)) with + | Constr.Construct (c, _) -> + c, Inductiveops.constructor_nrealargs c -1 + | _ -> raise Not_found let lookup_pattern_path_between env (s,t) = let i = inductive_class_of s in let j = inductive_class_of t in List.map (get_coercion_constructor env) (ClPairMap.find (i,j) !inheritance_graph) -(* coercion_value : coe_index -> unsafe_judgment * bool *) - -let coercion_value { coe_value = c; coe_type = t; coe_context = ctx; - coe_is_identity = b; coe_is_projection = b' } = - let subst, ctx = UnivGen.fresh_universe_context_set_instance ctx in - let c' = Vars.subst_univs_level_constr subst c - and t' = Vars.subst_univs_level_constr subst t in - (make_judge (EConstr.of_constr c') (EConstr.of_constr t'), b, b'), ctx - -(* pretty-print functions are now in Pretty *) (* rajouter une coercion dans le graphe *) let path_printer : (env -> Evd.evar_map -> (Bijint.Index.t * Bijint.Index.t) * inheritance_path -> Pp.t) ref = @@ -442,17 +431,13 @@ let cache_coercion env sigma (_, c) = let () = add_class c.coercion_target in let is, _ = class_info c.coercion_source in let it, _ = class_info c.coercion_target in - let value, ctx = UnivGen.fresh_global_instance env c.coercion_type in - let typ = Retyping.get_type_of env sigma (EConstr.of_constr value) in - let typ = EConstr.Unsafe.to_constr typ in let xf = - { coe_value = value; - coe_type = typ; - coe_context = ctx; + { coe_value = c.coercion_type; coe_local = c.coercion_local; coe_is_identity = c.coercion_is_id; coe_is_projection = c.coercion_is_proj; - coe_param = c.coercion_params } in + coe_param = c.coercion_params; + } in let () = add_new_coercion c.coercion_type xf in add_coercion_in_graph env sigma (xf,is,it) @@ -531,8 +516,6 @@ let declare_coercion coef ?(local = false) ~isid ~src:cls ~target:clt ~params:ps Lib.add_anonymous_leaf (inCoercion c) (* For printing purpose *) -let get_coercion_value v = v.coe_value - let pr_cl_index = Bijint.Index.print let classes () = Bijint.dom !class_tab diff --git a/pretyping/classops.mli b/pretyping/classops.mli index 8df085e15c..af00c0a8dc 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -39,16 +39,19 @@ type cl_info_typ = { type coe_typ = GlobRef.t (** This is the type of infos for declared coercions *) -type coe_info_typ +type coe_info_typ = { + coe_value : GlobRef.t; + coe_local : bool; + coe_is_identity : bool; + coe_is_projection : Projection.Repr.t option; + coe_param : int; +} (** [cl_index] is the type of class keys *) type cl_index -(** [coe_index] is the type of coercion keys *) -type coe_index - (** This is the type of paths from a class to another *) -type inheritance_path = coe_index list +type inheritance_path = coe_info_typ list (** {6 Access to classes infos } *) @@ -79,8 +82,6 @@ val declare_coercion : (** {6 Access to coercions infos } *) val coercion_exists : coe_typ -> bool -val coercion_value : coe_index -> (unsafe_judgment * bool * Projection.Repr.t option) Univ.in_universe_context_set - (** {6 Lookup functions for coercion paths } *) (** @raise Not_found in the following functions when no path exists *) @@ -105,10 +106,9 @@ val install_path_printer : val string_of_class : cl_typ -> string val pr_class : cl_typ -> Pp.t val pr_cl_index : cl_index -> Pp.t -val get_coercion_value : coe_index -> Constr.t val inheritance_graph : unit -> ((cl_index * cl_index) * inheritance_path) list val classes : unit -> cl_typ list -val coercions : unit -> coe_index list +val coercions : unit -> coe_info_typ list (** [hide_coercion] returns the number of params to skip if the coercion must be hidden, [None] otherwise; it raises [Not_found] if not a coercion *) diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index c6c2f57dd4..5e3821edf1 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -369,8 +369,11 @@ let apply_coercion env sigma p hj typ_cl = let j,t,evd = List.fold_left (fun (ja,typ_cl,sigma) i -> - let ((fv,isid,isproj),ctx) = coercion_value i in - let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in + let isid = i.coe_is_identity in + let isproj = i.coe_is_projection in + let sigma, c = new_global sigma i.coe_value in + let typ = Retyping.get_type_of env sigma c in + let fv = make_judge c typ in let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in let sigma, jres = apply_coercion_args env sigma true isproj argl fv diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index c944080503..255707dc7b 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -209,6 +209,9 @@ and nf_evar env sigma evk stk = | Zapp args :: stk -> (** We assume that there is no consecutive Zapp nodes in a VM stack. Is that really an invariant? *) + (** Let-bound arguments are present in the evar arguments but not in the + type, so we turn the let into a product. *) + let hyps = Context.Named.drop_bodies hyps in let fold accu d = Term.mkNamedProd_or_LetIn d accu in let t = List.fold_left fold concl hyps in let t, args = nf_args env sigma args t in |