diff options
Diffstat (limited to 'pretyping')
| -rw-r--r-- | pretyping/constr_matching.ml | 7 | ||||
| -rw-r--r-- | pretyping/find_subterm.ml | 59 | ||||
| -rw-r--r-- | pretyping/find_subterm.mli | 3 | ||||
| -rw-r--r-- | pretyping/locusops.ml | 44 | ||||
| -rw-r--r-- | pretyping/locusops.mli | 35 | ||||
| -rw-r--r-- | pretyping/recordops.ml | 19 | ||||
| -rw-r--r-- | pretyping/recordops.mli | 2 | ||||
| -rw-r--r-- | pretyping/reductionops.ml | 8 | ||||
| -rw-r--r-- | pretyping/reductionops.mli | 35 | ||||
| -rw-r--r-- | pretyping/tacred.ml | 59 | ||||
| -rw-r--r-- | pretyping/unification.ml | 16 |
11 files changed, 143 insertions, 144 deletions
diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index a3f1c0b004..0e69b814c7 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -528,10 +528,9 @@ let sub_match ?(closed=true) env sigma pat c = let sub = subargs env types @ subargs env' bodies in try_aux sub next_mk_ctx next | Proj (p,c') -> - begin try - let term = Retyping.expand_projection env sigma p c' [] in - aux env term mk_ctx next - with Retyping.RetypeError _ -> next () + begin match Retyping.expand_projection env sigma p c' [] with + | term -> aux env term mk_ctx next + | exception Retyping.RetypeError _ -> next () end | Array(u, t, def, ty) -> let next_mk_ctx = function diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml index bd717e2d1f..52e3364109 100644 --- a/pretyping/find_subterm.ml +++ b/pretyping/find_subterm.ml @@ -21,42 +21,15 @@ module NamedDecl = Context.Named.Declaration (** Processing occurrences *) -type occurrence_error = - | InvalidOccurrence of int list - | IncorrectInValueOccurrence of Id.t - -let explain_invalid_occurrence l = - let l = List.sort_uniquize Int.compare l in - str ("Invalid occurrence " ^ String.plural (List.length l) "number" ^": ") - ++ prlist_with_sep spc int l ++ str "." - let explain_incorrect_in_value_occurrence id = Id.print id ++ str " has no value." -let explain_occurrence_error = function - | InvalidOccurrence l -> explain_invalid_occurrence l - | IncorrectInValueOccurrence id -> explain_incorrect_in_value_occurrence id - -let error_occurrences_error e = - user_err (explain_occurrence_error e) - -let error_invalid_occurrence occ = - error_occurrences_error (InvalidOccurrence occ) - -let check_used_occurrences nbocc (nowhere_except_in,locs) = - let rest = List.filter (fun o -> o >= nbocc) locs in - match rest with - | [] -> () - | _ -> error_occurrences_error (InvalidOccurrence rest) - let proceed_with_occurrences f occs x = match occs with | NoOccurrences -> x | occs -> - let plocs = Locusops.convert_occs occs in - assert (List.for_all (fun x -> x >= 0) (snd plocs)); - let (nbocc,x) = f 1 x in - check_used_occurrences nbocc plocs; + let (occs,x) = f (Locusops.initialize_occurrence_counter occs) x in + Locusops.check_used_occurrences occs; x (** Applying a function over a named_declaration with an hypothesis @@ -70,7 +43,7 @@ let map_named_declaration_with_hyploc f hyploc acc decl = in match decl,hyploc with | LocalAssum (id,_), InHypValueOnly -> - error_occurrences_error (IncorrectInValueOccurrence id.Context.binder_name) + user_err (explain_incorrect_in_value_occurrence id.Context.binder_name) | LocalAssum (id,typ), _ -> let acc,typ = f acc typ in acc, LocalAssum (id,typ) | LocalDef (id,body,typ), InHypTypeOnly -> @@ -101,43 +74,43 @@ type 'a testing_function = { means all occurrences except the ones in l *) let replace_term_occ_gen_modulo sigma occs like_first test bywhat cl occ t = - let (nowhere_except_in,locs) = Locusops.convert_occs occs in - let maxocc = List.fold_right max locs 0 in - let pos = ref occ in + let count = ref (Locusops.initialize_occurrence_counter occs) in let nested = ref false in - let add_subst t subst = + let add_subst pos t subst = try test.testing_state <- test.merge_fun subst test.testing_state; - test.last_found <- Some ((cl,!pos),t) + test.last_found <- Some ((cl,pos),t) with NotUnifiable e when not like_first -> let lastpos = Option.get test.last_found in - raise (SubtermUnificationError (!nested,((cl,!pos),t),lastpos,e)) in + raise (SubtermUnificationError (!nested,((cl,pos),t),lastpos,e)) in let rec substrec k t = - if nowhere_except_in && !pos > maxocc then t else + if Locusops.occurrences_done !count then t else try let subst = test.match_fun test.testing_state t in - if Locusops.is_selected !pos occs then + let selected, count' = Locusops.update_occurrence_counter !count in count := count'; + if selected then + let pos = Locusops.current_occurrence !count in (if !nested then begin (* in case it is nested but not later detected as unconvertible, as when matching "id _" in "id (id 0)" *) let lastpos = Option.get test.last_found in - raise (SubtermUnificationError (!nested,((cl,!pos),t),lastpos,None)) + raise (SubtermUnificationError (!nested,((cl,pos),t),lastpos,None)) end; - add_subst t subst; incr pos; + add_subst pos t subst; (* Check nested matching subterms *) - if not (Locusops.is_all_occurrences occs) && occs != Locus.NoOccurrences then + if Locusops.more_specific_occurrences !count then begin nested := true; ignore (subst_below k t); nested := false end; (* Do the effective substitution *) Vars.lift k (bywhat ())) else - (incr pos; subst_below k t) + subst_below k t with NotUnifiable _ -> subst_below k t and subst_below k t = map_constr_with_binders_left_to_right sigma (fun d k -> k+1) substrec k t in let t' = substrec 0 t in - (!pos, t') + (!count, t') let replace_term_occ_modulo evd occs test bywhat t = let occs',like_first = diff --git a/pretyping/find_subterm.mli b/pretyping/find_subterm.mli index 436b730a88..1ddae01e2b 100644 --- a/pretyping/find_subterm.mli +++ b/pretyping/find_subterm.mli @@ -65,6 +65,3 @@ val subst_closed_term_occ : env -> evar_map -> occurrences or_like_first -> val subst_closed_term_occ_decl : env -> evar_map -> (occurrences * hyp_location_flag) or_like_first -> constr -> named_declaration -> named_declaration * evar_map - -(** Miscellaneous *) -val error_invalid_occurrence : int list -> 'a diff --git a/pretyping/locusops.ml b/pretyping/locusops.ml index 86352eb79a..256d61a32b 100644 --- a/pretyping/locusops.ml +++ b/pretyping/locusops.ml @@ -8,6 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Util open Locus (** Utilities on or_var *) @@ -27,12 +28,43 @@ let occurrences_map f = function if l' = [] then AllOccurrences else AllOccurrencesBut l' | (NoOccurrences|AllOccurrences|AtLeastOneOccurrence) as o -> o -let convert_occs = function - | AtLeastOneOccurrence -> (false,[]) - | AllOccurrences -> (false,[]) - | AllOccurrencesBut l -> (false,l) - | NoOccurrences -> (true,[]) - | OnlyOccurrences l -> (true,l) +type occurrences_count = {current: int; remaining: int list; where: (bool * int)} + +let error_invalid_occurrence l = + CErrors.user_err Pp.(str ("Invalid occurrence " ^ String.plural (List.length l) "number" ^": ") + ++ prlist_with_sep spc int l ++ str ".") + +let initialize_occurrence_counter occs = + let (nowhere_except_in,occs) = + match occs with + | AtLeastOneOccurrence -> (false,[]) + | AllOccurrences -> (false,[]) + | AllOccurrencesBut l -> (false,List.sort_uniquize Int.compare l) + | NoOccurrences -> (true,[]) + | OnlyOccurrences l -> (true,List.sort_uniquize Int.compare l) in + let max = + match occs with + | n::_ when n <= 0 -> error_invalid_occurrence [n] + | [] -> 0 + | _ -> Util.List.last occs in + {current = 0; remaining = occs; where = (nowhere_except_in,max)} + +let update_occurrence_counter {current; remaining; where = (nowhere_except_in,_ as where)} = + let current = succ current in + match remaining with + | occ::remaining when Int.equal current occ -> (nowhere_except_in,{current;remaining;where}) + | _ -> (not nowhere_except_in,{current;remaining;where}) + +let check_used_occurrences {remaining} = + if not (Util.List.is_empty remaining) then error_invalid_occurrence remaining + +let occurrences_done {current; where = (nowhere_except_in,max)} = + nowhere_except_in && current > max + +let current_occurrence {current} = current + +let more_specific_occurrences {current; where = (_,max)} = + current <= max let is_selected occ = function | AtLeastOneOccurrence -> true diff --git a/pretyping/locusops.mli b/pretyping/locusops.mli index 911ccc1a38..748bfbc252 100644 --- a/pretyping/locusops.mli +++ b/pretyping/locusops.mli @@ -20,13 +20,44 @@ val or_var_map : ('a -> 'b) -> 'a or_var -> 'b or_var val occurrences_map : ('a list -> 'b list) -> 'a occurrences_gen -> 'b occurrences_gen -(** From occurrences to a list of positions (or complement of positions) *) -val convert_occs : occurrences -> bool * int list +(** {6 Counting occurrences} *) + +type occurrences_count + (** A counter of occurrences associated to a list of occurrences *) + +(** Three basic functions to initialize, count, and conclude a loop + browsing over subterms *) + +val initialize_occurrence_counter : occurrences -> occurrences_count + (** Initialize an occurrence_counter *) + +val update_occurrence_counter : occurrences_count -> bool * occurrences_count + (** Increase the occurrence counter by one and tell if the current occurrence is selected *) + +val check_used_occurrences : occurrences_count -> unit + (** Increase the occurrence counter and tell if the current occurrence is selected *) + +(** Auxiliary functions about occurrence counters *) + +val current_occurrence : occurrences_count -> int + (** Tell the value of the current occurrence *) + +val occurrences_done : occurrences_count -> bool + (** Tell if there are no more occurrences to select and if the loop + can be shortcut *) + +val more_specific_occurrences : occurrences_count -> bool + (** Tell if there are no more occurrences to select (or unselect) + and if an inner loop can be shortcut *) + +(** {6 Miscellaneous} *) val is_selected : int -> occurrences -> bool val is_all_occurrences : 'a occurrences_gen -> bool +val error_invalid_occurrence : int list -> 'a + (** Usual clauses *) val allHypsAndConcl : 'a clause_expr diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index b6e44265ae..aa862a912e 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -323,23 +323,32 @@ let check_and_decompose_canonical_structure env sigma ref = let lookup_canonical_conversion env (proj,pat) = assoc_pat env pat (GlobRef.Map.find proj !object_table) -let decompose_projection sigma c args = +let rec get_nth n = function +| [] -> raise Not_found +| arg :: args -> + let len = Array.length arg in + if n < len then arg.(n) + else get_nth (n - len) args + +let rec decompose_projection sigma c args = match EConstr.kind sigma c with + | Meta mv -> decompose_projection sigma (Evd.meta_value sigma mv) args + | Cast (c, _, _) -> decompose_projection sigma c args + | App (c, arg) -> decompose_projection sigma c (arg :: args) | Const (c, u) -> let n = find_projection_nparams (GlobRef.ConstRef c) in (* Check if there is some canonical projection attached to this structure *) let _ = GlobRef.Map.find (GlobRef.ConstRef c) !object_table in - let arg = Stack.nth args n in - arg + get_nth n args | Proj (p, c) -> let _ = GlobRef.Map.find (GlobRef.ConstRef (Projection.constant p)) !object_table in c | _ -> raise Not_found -let is_open_canonical_projection env sigma (c,args) = +let is_open_canonical_projection env sigma c = let open EConstr in try - let arg = decompose_projection sigma c args in + let arg = decompose_projection sigma c [] in try let arg = whd_all env sigma arg in let hd = match EConstr.kind sigma arg with App (hd, _) -> hd | _ -> arg in diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index 5b8dc8184a..83927085e9 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -94,7 +94,7 @@ val register_canonical_structure : warn:bool -> Environ.env -> Evd.evar_map -> cs -> unit val subst_canonical_structure : Mod_subst.substitution -> cs -> cs val is_open_canonical_projection : - Environ.env -> Evd.evar_map -> Reductionops.state -> bool + Environ.env -> Evd.evar_map -> EConstr.t -> bool val canonical_projections : unit -> ((GlobRef.t * cs_pattern) * obj_typ) list diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index ac6bb52a2f..9580825010 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -930,14 +930,6 @@ let stack_red_of_state_red f = let f env sigma x = EConstr.decompose_app sigma (Stack.zip sigma (f env sigma (x, Stack.empty))) in f -(* Drops the Cst_stack *) -let iterate_whd_gen flags env sigma s = - let rec aux t = - let (hd,sk) = whd_state_gen flags env sigma (t,Stack.empty) in - let whd_sk = Stack.map aux sk in - Stack.zip sigma (hd,whd_sk) - in aux s - let red_of_state_red f env sigma x = Stack.zip sigma (f env sigma (x,Stack.empty)) diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index b5471eff34..0b7f43f469 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -106,8 +106,6 @@ end (************************************************************************) -type state = constr * constr Stack.t - type reduction_function = env -> evar_map -> constr -> constr type e_reduction_function = env -> evar_map -> constr -> evar_map * constr @@ -115,11 +113,6 @@ type e_reduction_function = env -> evar_map -> constr -> evar_map * constr type stack_reduction_function = env -> evar_map -> constr -> constr * constr list -type state_reduction_function = - env -> evar_map -> state -> state - -val pr_state : env -> evar_map -> state -> Pp.t - (** {6 Reduction Function Operators } *) val strong_with_flags : @@ -127,12 +120,6 @@ val strong_with_flags : (CClosure.RedFlags.reds -> reduction_function) val strong : reduction_function -> reduction_function -val whd_state_gen : - CClosure.RedFlags.reds -> Environ.env -> Evd.evar_map -> state -> state - -val iterate_whd_gen : CClosure.RedFlags.reds -> - Environ.env -> Evd.evar_map -> constr -> constr - (** {6 Generic Optimized Reduction Function using Closures } *) val clos_norm_flags : CClosure.RedFlags.reds -> reduction_function @@ -166,24 +153,13 @@ val whd_all_stack : stack_reduction_function val whd_allnolet_stack : stack_reduction_function val whd_betalet_stack : stack_reduction_function -val whd_nored_state : state_reduction_function -val whd_beta_state : state_reduction_function -val whd_betaiota_state : state_reduction_function -val whd_betaiotazeta_state : state_reduction_function -val whd_all_state : state_reduction_function -val whd_allnolet_state : state_reduction_function -val whd_betalet_state : state_reduction_function - (** {6 Head normal forms } *) val whd_delta_stack : stack_reduction_function -val whd_delta_state : state_reduction_function val whd_delta : reduction_function val whd_betadeltazeta_stack : stack_reduction_function -val whd_betadeltazeta_state : state_reduction_function val whd_betadeltazeta : reduction_function val whd_zeta_stack : stack_reduction_function -val whd_zeta_state : state_reduction_function val whd_zeta : reduction_function val shrink_eta : Environ.env -> constr -> constr @@ -269,8 +245,17 @@ val infer_conv_gen : (conv_pb -> l2r:bool -> evar_map -> TransparentState.t -> (** {6 Heuristic for Conversion with Evar } *) +type state = constr * constr Stack.t + +type state_reduction_function = + env -> evar_map -> state -> state + +val pr_state : env -> evar_map -> state -> Pp.t + +val whd_nored_state : state_reduction_function + val whd_betaiota_deltazeta_for_iota_state : - TransparentState.t -> Environ.env -> Evd.evar_map -> state -> state + TransparentState.t -> state_reduction_function (** {6 Meta-related reduction functions } *) type meta_instance_subst diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 9cf7119709..c705ac16e7 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -1046,28 +1046,23 @@ let change_map_constr_with_binders_left_to_right g f (env, l as acc) sigma c = | _ -> map_constr_with_binders_left_to_right sigma g f acc c let e_contextually byhead (occs,c) f = begin fun env sigma t -> - let (nowhere_except_in,locs) = Locusops.convert_occs occs in - let maxocc = List.fold_right max locs 0 in - let pos = ref 1 in + let count = ref (Locusops.initialize_occurrence_counter occs) in (* FIXME: we do suspicious things with this evarmap *) let evd = ref sigma in let rec traverse nested (env,c as envc) t = - if nowhere_except_in && (!pos > maxocc) then (* Shortcut *) t + if Locusops.occurrences_done !count then (* Shortcut *) t else try let subst = if byhead then matches_head env sigma c t else Constr_matching.matches env sigma c t in - let ok = - if nowhere_except_in then Int.List.mem !pos locs - else not (Int.List.mem !pos locs) in - incr pos; + let ok, count' = Locusops.update_occurrence_counter !count in count := count'; if ok then begin if Option.has_some nested then - user_err (str "The subterm at occurrence " ++ int (Option.get nested) ++ str " overlaps with the subterm at occurrence " ++ int (!pos-1) ++ str "."); + user_err (str "The subterm at occurrence " ++ int (Option.get nested) ++ str " overlaps with the subterm at occurrence " ++ int (Locusops.current_occurrence !count) ++ str "."); (* Skip inner occurrences for stable counting of occurrences *) - if locs != [] then - ignore (traverse_below (Some (!pos-1)) envc t); + if Locusops.more_specific_occurrences !count then + ignore (traverse_below (Some (Locusops.current_occurrence !count)) envc t); let (evm, t) = (f subst) env !evd t in (evd := evm; t) end @@ -1087,7 +1082,7 @@ let e_contextually byhead (occs,c) f = begin fun env sigma t -> (traverse nested) envc sigma t in let t' = traverse None (env,c) t in - if List.exists (fun o -> o >= !pos) locs then error_invalid_occurrence locs; + Locusops.check_used_occurrences !count; (!evd, t') end @@ -1105,28 +1100,25 @@ let match_constr_evaluable_ref sigma c evref = | Var id, EvalVarRef id' when Id.equal id id' -> Some EInstance.empty | _, _ -> None -let substlin env sigma evalref n (nowhere_except_in,locs) c = - let maxocc = List.fold_right max locs 0 in - let pos = ref n in - assert (List.for_all (fun x -> x >= 0) locs); +let substlin env sigma evalref occs c = + let count = ref (Locusops.initialize_occurrence_counter occs) in let value u = value_of_evaluable_ref env evalref u in let rec substrec () c = - if nowhere_except_in && !pos > maxocc then c + if Locusops.occurrences_done !count then c else match match_constr_evaluable_ref sigma c evalref with | Some u -> - let ok = - if nowhere_except_in then Int.List.mem !pos locs - else not (Int.List.mem !pos locs) in - incr pos; - if ok then value u else c + let ok, count' = Locusops.update_occurrence_counter !count in + count := count'; + if ok then value u else c | None -> map_constr_with_binders_left_to_right sigma (fun _ () -> ()) substrec () c in let t' = substrec () c in - (!pos, t') + Locusops.check_used_occurrences !count; + (Locusops.current_occurrence !count, t') let string_of_evaluable_ref env = function | EvalVarRef id -> Id.to_string id @@ -1154,23 +1146,14 @@ let unfold env sigma name c = * at the occurrences of occ_list. If occ_list is empty, unfold all occurrences. * Performs a betaiota reduction after unfolding. *) let unfoldoccs env sigma (occs,name) c = - let unfo nowhere_except_in locs = - let (nbocc,uc) = substlin env sigma name 1 (nowhere_except_in,locs) c in - if Int.equal nbocc 1 then + match occs with + | NoOccurrences -> c + | AllOccurrences -> unfold env sigma name c + | OnlyOccurrences _ | AllOccurrencesBut _ | AtLeastOneOccurrence -> + let (occ,uc) = substlin env sigma name occs c in + if Int.equal occ 0 then user_err Pp.(str ((string_of_evaluable_ref env name)^" does not occur.")); - let rest = List.filter (fun o -> o >= nbocc) locs in - let () = match rest with - | [] -> () - | _ -> error_invalid_occurrence rest - in nf_betaiotazeta env sigma uc - in - match occs with - | NoOccurrences -> c - | AllOccurrences -> unfold env sigma name c - | OnlyOccurrences l -> unfo true l - | AllOccurrencesBut l -> unfo false l - | AtLeastOneOccurrence -> unfo false [] (* Unfold reduction tactic: *) let unfoldn loccname env sigma c = diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 1c24578a1c..3d3010d1a4 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1070,10 +1070,8 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e and canonical_projections (curenv, _ as curenvnb) pb opt cM cN (sigma,_,_ as substn) = let f1 () = if isApp_or_Proj sigma cM then - let f1l1 = whd_nored_state curenv sigma (cM,Stack.empty) in - if is_open_canonical_projection curenv sigma f1l1 then - let f2l2 = whd_nored_state curenv sigma (cN,Stack.empty) in - solve_canonical_projection curenvnb pb opt cM f1l1 cN f2l2 substn + if is_open_canonical_projection curenv sigma cM then + solve_canonical_projection curenvnb pb opt cM cN substn else error_cannot_unify (fst curenvnb) sigma (cM,cN) else error_cannot_unify (fst curenvnb) sigma (cM,cN) in @@ -1086,14 +1084,14 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e else try f1 () with e when precatchable_exception e -> if isApp_or_Proj sigma cN then - let f2l2 = whd_nored_state curenv sigma (cN, Stack.empty) in - if is_open_canonical_projection curenv sigma f2l2 then - let f1l1 = whd_nored_state curenv sigma (cM, Stack.empty) in - solve_canonical_projection curenvnb pb opt cN f2l2 cM f1l1 substn + if is_open_canonical_projection curenv sigma cN then + solve_canonical_projection curenvnb pb opt cN cM substn else error_cannot_unify (fst curenvnb) sigma (cM,cN) else error_cannot_unify (fst curenvnb) sigma (cM,cN) - and solve_canonical_projection curenvnb pb opt cM f1l1 cN f2l2 (sigma,ms,es) = + and solve_canonical_projection curenvnb pb opt cM cN (sigma,ms,es) = + let f1l1 = whd_nored_state (fst curenvnb) sigma (cM,Stack.empty) in + let f2l2 = whd_nored_state (fst curenvnb) sigma (cN,Stack.empty) in let (ctx,t,c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = try Evarconv.check_conv_record (fst curenvnb) sigma f1l1 f2l2 with Not_found -> error_cannot_unify (fst curenvnb) sigma (cM,cN) |
