aboutsummaryrefslogtreecommitdiff
path: root/pretyping
diff options
context:
space:
mode:
Diffstat (limited to 'pretyping')
-rw-r--r--pretyping/cases.ml6
-rw-r--r--pretyping/classops.ml34
-rw-r--r--pretyping/classops.mli2
-rw-r--r--pretyping/constr_matching.ml91
-rw-r--r--pretyping/constr_matching.mli23
-rw-r--r--pretyping/detyping.ml119
-rw-r--r--pretyping/detyping.mli10
-rw-r--r--pretyping/evarconv.ml12
-rw-r--r--pretyping/miscops.ml3
-rw-r--r--pretyping/nativenorm.ml4
-rw-r--r--pretyping/pretyping.ml96
-rw-r--r--pretyping/reductionops.ml160
-rw-r--r--pretyping/reductionops.mli8
-rw-r--r--pretyping/retyping.ml4
-rw-r--r--pretyping/tacred.ml4
-rw-r--r--pretyping/typeclasses.ml11
-rw-r--r--pretyping/typeclasses.mli4
-rw-r--r--pretyping/unification.ml10
-rw-r--r--pretyping/vnorm.ml2
19 files changed, 305 insertions, 298 deletions
diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index 4f3669a2b9..1207c967b5 100644
--- a/pretyping/cases.ml
+++ b/pretyping/cases.ml
@@ -1566,11 +1566,9 @@ substituer après par les initiaux *)
(* builds the matrix of equations testing that each eqn has n patterns
* and linearizing the _ patterns.
- * Syntactic correctness has already been done in astterm *)
+ * Syntactic correctness has already been done in constrintern *)
let matx_of_eqns env eqns =
- let build_eqn (loc,(ids,lpat,rhs)) =
- let initial_lpat,initial_rhs = lpat,rhs in
- let initial_rhs = rhs in
+ let build_eqn (loc,(ids,initial_lpat,initial_rhs)) =
let avoid = ids_of_named_context_val (named_context_val env) in
let avoid = List.fold_left (fun accu id -> Id.Set.add id accu) avoid ids in
let rhs =
diff --git a/pretyping/classops.ml b/pretyping/classops.ml
index c36630f5d3..6d5ee504e5 100644
--- a/pretyping/classops.ml
+++ b/pretyping/classops.ml
@@ -322,16 +322,16 @@ let coercion_value { coe_value = c; coe_type = t; coe_context = ctx;
(* pretty-print functions are now in Pretty *)
(* rajouter une coercion dans le graphe *)
-let path_printer = ref (fun _ -> str "<a class path>"
- : (Bijint.Index.t * Bijint.Index.t) * inheritance_path -> Pp.t)
+let path_printer : (env -> Evd.evar_map -> (Bijint.Index.t * Bijint.Index.t) * inheritance_path -> Pp.t) ref =
+ ref (fun _ _ _ -> str "<a class path>")
let install_path_printer f = path_printer := f
-let print_path x = !path_printer x
+let print_path env sigma x = !path_printer env sigma x
-let message_ambig l =
- (str"Ambiguous paths:" ++ spc () ++
- prlist_with_sep fnl (fun ijp -> print_path ijp) l)
+let message_ambig env sigma l =
+ str"Ambiguous paths:" ++ spc () ++
+ prlist_with_sep fnl (fun ijp -> print_path env sigma ijp) l
(* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit
coercion,source,target *)
@@ -344,8 +344,8 @@ let different_class_params i =
| CL_IND i -> Global.is_polymorphic (IndRef i)
| CL_CONST c -> Global.is_polymorphic (ConstRef c)
| _ -> false
-
-let add_coercion_in_graph (ic,source,target) =
+
+let add_coercion_in_graph env sigma (ic,source,target) =
let old_inheritance_graph = !inheritance_graph in
let ambig_paths =
(ref [] : ((cl_index * cl_index) * inheritance_path) list ref) in
@@ -387,7 +387,7 @@ let add_coercion_in_graph (ic,source,target) =
end;
let is_ambig = match !ambig_paths with [] -> false | _ -> true in
if is_ambig && not !Flags.quiet then
- Feedback.msg_info (message_ambig !ambig_paths)
+ Feedback.msg_info (message_ambig env sigma !ambig_paths)
type coercion = {
coercion_type : coe_typ;
@@ -433,13 +433,13 @@ let _ =
optread = (fun () -> !automatically_import_coercions);
optwrite = (:=) automatically_import_coercions }
-let cache_coercion (_, c) =
+let cache_coercion env sigma (_, c) =
let () = add_class c.coercion_source in
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 = Universes.fresh_global_instance (Global.env()) c.coercion_type in
- let typ = Retyping.get_type_of (Global.env ()) Evd.empty (EConstr.of_constr value) in
+ let value, ctx = Universes.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;
@@ -450,15 +450,15 @@ let cache_coercion (_, c) =
coe_is_projection = c.coercion_is_proj;
coe_param = c.coercion_params } in
let () = add_new_coercion c.coercion_type xf in
- add_coercion_in_graph (xf,is,it)
+ add_coercion_in_graph env sigma (xf,is,it)
let load_coercion _ o =
if !automatically_import_coercions then
- cache_coercion o
+ cache_coercion (Global.env ()) Evd.empty o
let open_coercion i o =
if Int.equal i 1 && not !automatically_import_coercions then
- cache_coercion o
+ cache_coercion (Global.env ()) Evd.empty o
let subst_coercion (subst, c) =
let coe = subst_coe_typ subst c.coercion_type in
@@ -497,7 +497,9 @@ let inCoercion : coercion -> obj =
declare_object {(default_object "COERCION") with
open_function = open_coercion;
load_function = load_coercion;
- cache_function = cache_coercion;
+ cache_function = (fun objn ->
+ let env = Global.env () in cache_coercion env Evd.empty objn
+ );
subst_function = subst_coercion;
classify_function = classify_coercion;
discharge_function = discharge_coercion }
diff --git a/pretyping/classops.mli b/pretyping/classops.mli
index b41d0efac5..47b41f17b2 100644
--- a/pretyping/classops.mli
+++ b/pretyping/classops.mli
@@ -96,7 +96,7 @@ val lookup_pattern_path_between :
(**/**)
(* Crade *)
val install_path_printer :
- ((cl_index * cl_index) * inheritance_path -> Pp.t) -> unit
+ (env -> evar_map -> (cl_index * cl_index) * inheritance_path -> Pp.t) -> unit
(**/**)
(** {6 This is for printing purpose } *)
diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml
index 20ef65c884..ec7c3077fb 100644
--- a/pretyping/constr_matching.ml
+++ b/pretyping/constr_matching.ml
@@ -13,7 +13,6 @@ open Util
open Names
open Globnames
open Termops
-open Reductionops
open Term
open EConstr
open Vars
@@ -207,7 +206,7 @@ let merge_binding sigma allow_bound_rels ctx n cT subst =
in
constrain sigma n c subst
-let matches_core env sigma convert allow_partial_app allow_bound_rels
+let matches_core env sigma allow_bound_rels
(binding_vars,pat) c =
let open EConstr in
let convref ref c =
@@ -216,11 +215,7 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels
| ConstRef c, Const (c',_) -> Constant.equal c c'
| IndRef i, Ind (i', _) -> Names.eq_ind i i'
| ConstructRef c, Construct (c',u) -> Names.eq_constructor c c'
- | _, _ ->
- (if convert then
- let sigma,c' = Evd.fresh_global env sigma ref in
- is_conv env sigma (EConstr.of_constr c') c
- else false)
+ | _, _ -> false
in
let rec sorec ctx env subst p t =
let cT = strip_outer_cast sigma t in
@@ -265,7 +260,7 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels
| PApp (PApp (h, a1), a2), _ ->
sorec ctx env subst (PApp(h,Array.append a1 a2)) t
- | PApp (PMeta meta,args1), App (c2,args2) when allow_partial_app ->
+ | PApp (PMeta meta,args1), App (c2,args2) ->
(let diff = Array.length args2 - Array.length args1 in
if diff >= 0 then
let args21, args22 = Array.chop diff args2 in
@@ -378,14 +373,14 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels
in
sorec [] env (Id.Map.empty, Id.Map.empty) pat c
-let matches_core_closed env sigma convert allow_partial_app pat c =
- let names, subst = matches_core env sigma convert allow_partial_app false pat c in
+let matches_core_closed env sigma pat c =
+ let names, subst = matches_core env sigma false pat c in
(names, Id.Map.map snd subst)
-let extended_matches env sigma = matches_core env sigma false true true
+let extended_matches env sigma = matches_core env sigma true
let matches env sigma pat c =
- snd (matches_core_closed env sigma false true (Id.Set.empty,pat) c)
+ snd (matches_core_closed env sigma (Id.Set.empty,pat) c)
let special_meta = (-1)
@@ -410,9 +405,9 @@ let matches_head env sigma pat c =
matches env sigma pat head
(* Tells if it is an authorized occurrence and if the instance is closed *)
-let authorized_occ env sigma partial_app closed pat c mk_ctx =
+let authorized_occ env sigma closed pat c mk_ctx =
try
- let subst = matches_core_closed env sigma false partial_app pat c in
+ let subst = matches_core_closed env sigma pat c in
if closed && Id.Map.exists (fun _ c -> not (closed0 sigma c)) (snd subst)
then (fun next -> next ())
else (fun next -> mkresult subst (mk_ctx (mkMeta special_meta)) next)
@@ -421,10 +416,10 @@ let authorized_occ env sigma partial_app closed pat c mk_ctx =
let subargs env v = Array.map_to_list (fun c -> (env, c)) v
(* Tries to match a subterm of [c] with [pat] *)
-let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c =
+let sub_match ?(closed=true) env sigma pat c =
let open EConstr in
let rec aux env c mk_ctx next =
- let here = authorized_occ env sigma partial_app closed pat c mk_ctx in
+ let here = authorized_occ env sigma closed pat c mk_ctx in
let next () = match EConstr.kind sigma c with
| Cast (c1,k,c2) ->
let next_mk_ctx = function
@@ -454,34 +449,12 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c =
let env' = EConstr.push_rel (LocalDef (x,c1,t)) env in
try_aux [(env, c1); (env', c2)] next_mk_ctx next
| App (c1,lc) ->
- let topdown = true in
- if partial_app then
- if topdown then
- let lc1 = Array.sub lc 0 (Array.length lc - 1) in
- let app = mkApp (c1,lc1) in
- let mk_ctx = function
- | [app';c] -> mk_ctx (mkApp (app',[|c|]))
- | _ -> assert false in
- try_aux [(env, app); (env, Array.last lc)] mk_ctx next
- else
- let rec aux2 app args next =
- match args with
- | [] ->
- let mk_ctx le =
- mk_ctx (mkApp (List.hd le, Array.of_list (List.tl le))) in
- let sub = (env, c1) :: subargs env lc in
- try_aux sub mk_ctx next
- | arg :: args ->
- let app = mkApp (app,[|arg|]) in
- let next () = aux2 app args next in
- let mk_ctx ce = mk_ctx (mkApp (ce, Array.of_list args)) in
- aux env app mk_ctx next in
- aux2 c1 (Array.to_list lc) next
- else
- let mk_ctx le =
- mk_ctx (mkApp (List.hd le, Array.of_list (List.tl le))) in
- let sub = (env, c1) :: subargs env lc in
- try_aux sub mk_ctx next
+ let lc1 = Array.sub lc 0 (Array.length lc - 1) in
+ let app = mkApp (c1,lc1) in
+ let mk_ctx = function
+ | [app';c] -> mk_ctx (mkApp (app',[|c|]))
+ | _ -> assert false in
+ try_aux [(env, app); (env, Array.last lc)] mk_ctx next
| Case (ci,hd,c1,lc) ->
let next_mk_ctx = function
| c1 :: hd :: lc -> mk_ctx (mkCase (ci,hd,c1,Array.of_list lc))
@@ -504,14 +477,11 @@ let sub_match ?(partial_app=false) ?(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') ->
- let next_mk_ctx le = mk_ctx (mkProj (p,List.hd le)) in
- if partial_app then
- try
- let term = Retyping.expand_projection env sigma p c' [] in
- aux env term mk_ctx next
- with Retyping.RetypeError _ -> next ()
- else
- try_aux [env, c'] next_mk_ctx next
+ begin try
+ let term = Retyping.expand_projection env sigma p c' [] in
+ aux env term mk_ctx next
+ with Retyping.RetypeError _ -> next ()
+ end
| Construct _| Ind _|Evar _|Const _ | Rel _|Meta _|Var _|Sort _ ->
next ()
in
@@ -532,13 +502,7 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c =
let result () = aux env c (fun x -> x) lempty in
IStream.thunk result
-let match_subterm env sigma pat c = sub_match env sigma (Id.Set.empty,pat) c
-
-let match_appsubterm env sigma pat c =
- sub_match ~partial_app:true env sigma (Id.Set.empty,pat) c
-
-let match_subterm_gen env sigma app pat c =
- sub_match ~partial_app:app env sigma pat c
+let match_subterm env sigma pat c = sub_match env sigma pat c
let is_matching env sigma pat c =
try let _ = matches env sigma pat c in true
@@ -550,12 +514,5 @@ let is_matching_head env sigma pat c =
let is_matching_appsubterm ?(closed=true) env sigma pat c =
let pat = (Id.Set.empty,pat) in
- let results = sub_match ~partial_app:true ~closed env sigma pat c in
+ let results = sub_match ~closed env sigma pat c in
not (IStream.is_empty results)
-
-let matches_conv env sigma p c =
- snd (matches_core_closed env sigma true false (Id.Set.empty,p) c)
-
-let is_matching_conv env sigma pat n =
- try let _ = matches_conv env sigma pat n in true
- with PatternMatchingFailure -> false
diff --git a/pretyping/constr_matching.mli b/pretyping/constr_matching.mli
index 780ccc23d1..e4d9ff9e1e 100644
--- a/pretyping/constr_matching.mli
+++ b/pretyping/constr_matching.mli
@@ -55,38 +55,19 @@ val is_matching : env -> Evd.evar_map -> constr_pattern -> constr -> bool
prefix of it matches against [pat] *)
val is_matching_head : env -> Evd.evar_map -> constr_pattern -> constr -> bool
-(** [matches_conv env sigma] matches up to conversion in environment
- [(env,sigma)] when constants in pattern are concerned; it raises
- [PatternMatchingFailure] if not matchable; bindings are given in
- increasing order based on the numbers given in the pattern *)
-val matches_conv : env -> Evd.evar_map -> constr_pattern -> constr -> patvar_map
-
(** The type of subterm matching results: a substitution + a context
(whose hole is denoted here with [special_meta]) *)
type matching_result =
{ m_sub : bound_ident_map * patvar_map;
m_ctx : EConstr.t }
-(** [match_subterm n pat c] returns the substitution and the context
- corresponding to each **closed** subterm of [c] matching [pat]. *)
-val match_subterm : env -> Evd.evar_map -> constr_pattern -> constr -> matching_result IStream.t
-
-(** [match_appsubterm pat c] returns the substitution and the context
+(** [match_subterm pat c] returns the substitution and the context
corresponding to each **closed** subterm of [c] matching [pat],
considering application contexts as well. *)
-val match_appsubterm : env -> Evd.evar_map -> constr_pattern -> constr -> matching_result IStream.t
-
-(** [match_subterm_gen] calls either [match_subterm] or [match_appsubterm] *)
-val match_subterm_gen : env -> Evd.evar_map ->
- bool (** true = with app context *) ->
+val match_subterm : env -> Evd.evar_map ->
binding_bound_vars * constr_pattern -> constr ->
matching_result IStream.t
(** [is_matching_appsubterm pat c] tells if a subterm of [c] matches
against [pat] taking partial subterms into consideration *)
val is_matching_appsubterm : ?closed:bool -> env -> Evd.evar_map -> constr_pattern -> constr -> bool
-
-(** [is_matching_conv env sigma pat c] tells if [c] matches against [pat]
- up to conversion for constants in patterns *)
-val is_matching_conv :
- env -> Evd.evar_map -> constr_pattern -> constr -> bool
diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index 0d1e401d98..23993243f4 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -252,6 +252,89 @@ let lookup_index_as_renamed env sigma t n =
in lookup n 1 t
(**********************************************************************)
+(* Factorization of match patterns *)
+
+let print_factorize_match_patterns = ref true
+
+let _ =
+ let open Goptions in
+ declare_bool_option
+ { optdepr = false;
+ optname = "factorization of \"match\" patterns in printing";
+ optkey = ["Printing";"Factorizable";"Match";"Patterns"];
+ optread = (fun () -> !print_factorize_match_patterns);
+ optwrite = (fun b -> print_factorize_match_patterns := b) }
+
+let print_allow_match_default_clause = ref true
+
+let _ =
+ let open Goptions in
+ declare_bool_option
+ { optdepr = false;
+ optname = "possible use of \"match\" default pattern in printing";
+ optkey = ["Printing";"Allow";"Match";"Default";"Clause"];
+ optread = (fun () -> !print_allow_match_default_clause);
+ optwrite = (fun b -> print_allow_match_default_clause := b) }
+
+let rec join_eqns (ids,rhs as x) patll = function
+ | (loc,(ids',patl',rhs') as eqn')::rest ->
+ if not !Flags.raw_print && !print_factorize_match_patterns &&
+ List.eq_set Id.equal ids ids' && glob_constr_eq rhs rhs'
+ then
+ join_eqns x (patl'::patll) rest
+ else
+ let eqn,rest = join_eqns x patll rest in
+ eqn, eqn'::rest
+ | [] ->
+ patll, []
+
+let number_of_patterns (_gloc,(_ids,patll,_rhs)) = List.length patll
+
+let is_default_candidate (_gloc,(ids,_patll,_rhs) ) = ids = []
+
+let rec move_more_factorized_default_candidate_to_end eqn n = function
+ | eqn' :: eqns ->
+ let set,get = set_temporary_memory () in
+ if is_default_candidate eqn' && set (number_of_patterns eqn') >= n then
+ let isbest, dft, eqns = move_more_factorized_default_candidate_to_end eqn' (get ()) eqns in
+ if isbest then false, dft, eqns else false, dft, eqn' :: eqns
+ else
+ let isbest, dft, eqns = move_more_factorized_default_candidate_to_end eqn n eqns in
+ isbest, dft, eqn' :: eqns
+ | [] -> true, Some eqn, []
+
+let rec select_default_clause = function
+ | eqn :: eqns ->
+ let set,get = set_temporary_memory () in
+ if is_default_candidate eqn && set (number_of_patterns eqn) > 1 then
+ let isbest, dft, eqns = move_more_factorized_default_candidate_to_end eqn (get ()) eqns in
+ if isbest then dft, eqns else dft, eqn :: eqns
+ else
+ let dft, eqns = select_default_clause eqns in dft, eqn :: eqns
+ | [] -> None, []
+
+let factorize_eqns eqns =
+ let rec aux found = function
+ | (loc,(ids,patl,rhs))::rest ->
+ let patll,rest = join_eqns (ids,rhs) [patl] rest in
+ aux ((loc,(ids,patll,rhs))::found) rest
+ | [] ->
+ found in
+ let eqns = aux [] (List.rev eqns) in
+ let mk_anon patl = List.map (fun _ -> DAst.make @@ PatVar Anonymous) patl in
+ if not !Flags.raw_print && !print_allow_match_default_clause && eqns <> [] then
+ match select_default_clause eqns with
+ (* At least two clauses and the last one is disjunctive with no variables *)
+ | Some (gloc,([],patl::_::_,rhs)), (_::_ as eqns) -> eqns@[gloc,([],[mk_anon patl],rhs)]
+ (* Only one clause which is disjunctive with no variables: we keep at least one constructor *)
+ (* so that it is not interpreted as a dummy "match" *)
+ | Some (gloc,([],patl::patl'::_,rhs)), [] -> [gloc,([],[patl;mk_anon patl'],rhs)]
+ | Some (_,((_::_,_,_ | _,([]|[_]),_))), _ -> assert false
+ | None, eqns -> eqns
+ else
+ eqns
+
+(**********************************************************************)
(* Fragile algorithm to reverse pattern-matching compilation *)
let update_name sigma na ((_,(e,_)),c) =
@@ -284,13 +367,12 @@ let rec decomp_branch tags nal b (avoid,env as e) sigma c =
let rec build_tree na isgoal e sigma ci cl =
let mkpat n rhs pl = DAst.make @@ PatCstr((ci.ci_ind,n+1),pl,update_name sigma na rhs) in
let cnl = ci.ci_pp_info.cstr_tags in
- let cna = ci.ci_cstr_nargs in
List.flatten
(List.init (Array.length cl)
- (fun i -> contract_branch isgoal e sigma (cnl.(i),cna.(i),mkpat i,cl.(i))))
+ (fun i -> contract_branch isgoal e sigma (cnl.(i),mkpat i,cl.(i))))
and align_tree nal isgoal (e,c as rhs) sigma = match nal with
- | [] -> [[],rhs]
+ | [] -> [Id.Set.empty,[],rhs]
| na::nal ->
match EConstr.kind sigma c with
| Case (ci,p,c,cl) when
@@ -300,19 +382,20 @@ and align_tree nal isgoal (e,c as rhs) sigma = match nal with
computable sigma p (List.length ci.ci_pp_info.ind_tags) (* FIXME: can do better *) ->
let clauses = build_tree na isgoal e sigma ci cl in
List.flatten
- (List.map (fun (pat,rhs) ->
+ (List.map (fun (ids,pat,rhs) ->
let lines = align_tree nal isgoal rhs sigma in
- List.map (fun (hd,rest) -> pat::hd,rest) lines)
+ List.map (fun (ids',hd,rest) -> Id.Set.fold Id.Set.add ids ids',pat::hd,rest) lines)
clauses)
| _ ->
- let pat = DAst.make @@ PatVar(update_name sigma na rhs) in
- let mat = align_tree nal isgoal rhs sigma in
- List.map (fun (hd,rest) -> pat::hd,rest) mat
+ let na = update_name sigma na rhs in
+ let pat = DAst.make @@ PatVar na in
+ let mat = align_tree nal isgoal rhs sigma in
+ List.map (fun (ids,hd,rest) -> Nameops.Name.fold_right Id.Set.add na ids,pat::hd,rest) mat
-and contract_branch isgoal e sigma (cdn,can,mkpat,b) =
- let nal,rhs = decomp_branch cdn [] isgoal e sigma b in
+and contract_branch isgoal e sigma (cdn,mkpat,rhs) =
+ let nal,rhs = decomp_branch cdn [] isgoal e sigma rhs in
let mat = align_tree nal isgoal rhs sigma in
- List.map (fun (hd,rhs) -> (mkpat rhs hd,rhs)) mat
+ List.map (fun (ids,hd,rhs) -> ids,mkpat rhs hd,rhs) mat
(**********************************************************************)
(* Transform internal representation of pattern-matching into list of *)
@@ -414,15 +497,17 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl =
let eqnl = detype_eqns constructs constagsl bl in
GCases (tag,pred,[tomatch,(alias,aliastyp)],eqnl)
+let detype_universe sigma u =
+ let fn (l, n) = Some (Termops.reference_of_level sigma l, n) in
+ Univ.Universe.map fn u
+
let detype_sort sigma = function
| Prop Null -> GProp
| Prop Pos -> GSet
| Type u ->
GType
(if !print_universes
- then
- let u = Pp.string_of_ppcmds (Univ.Universe.pr_with (Termops.pr_evd_level sigma) u) in
- [Loc.tag @@ Name.mk_name (Id.of_string_soft u)]
+ then detype_universe sigma u
else [])
type binder_kind = BProd | BLambda | BLetIn
@@ -434,8 +519,8 @@ let detype_anonymous = ref (fun ?loc n -> anomaly ~label:"detype" (Pp.str "index
let set_detype_anonymous f = detype_anonymous := f
let detype_level sigma l =
- let l = Pp.string_of_ppcmds (Termops.pr_evd_level sigma l) in
- GType (Some (Loc.tag @@ Name.mk_name (Id.of_string_soft l)))
+ let l = Termops.reference_of_level sigma l in
+ GType (UNamed l)
let detype_instance sigma l =
let l = EInstance.kind sigma l in
@@ -646,7 +731,7 @@ and detype_eqns d flags avoid env sigma ci computable constructs consnargsl bl =
try
if !Flags.raw_print || not (reverse_matching ()) then raise Exit;
let mat = build_tree Anonymous (snd flags) (avoid,env) sigma ci bl in
- List.map (fun (pat,((avoid,env),c)) -> Loc.tag ([],[pat],detype d flags avoid env sigma c))
+ List.map (fun (ids,pat,((avoid,env),c)) -> Loc.tag (Id.Set.elements ids,[pat],detype d flags avoid env sigma c))
mat
with e when CErrors.noncritical e ->
Array.to_list
diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli
index cb1c0d8d4b..f150cb1956 100644
--- a/pretyping/detyping.mli
+++ b/pretyping/detyping.mli
@@ -26,10 +26,20 @@ val print_universes : bool ref
(** If true, prints full local context of evars *)
val print_evar_arguments : bool ref
+(** If true, contract branches with same r.h.s. and same matching
+ variables in a disjunctive pattern *)
+val print_factorize_match_patterns : bool ref
+
+(** If true and the last non unique clause of a "match" is a
+ variable-free disjunctive pattern, turn it into a catch-call case *)
+val print_allow_match_default_clause : bool ref
+
val subst_cases_pattern : substitution -> cases_pattern -> cases_pattern
val subst_glob_constr : substitution -> glob_constr -> glob_constr
+val factorize_eqns : 'a cases_clauses_g -> 'a disjunctive_cases_clauses_g
+
(** [detype isgoal avoid ctx c] turns a closed [c], into a glob_constr
de Bruijn indexes are turned to bound names, avoiding names in [avoid]
[isgoal] tells if naming must avoid global-level synonyms as intro does
diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index 18e0c31dd6..f7a3789a21 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -218,6 +218,8 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) =
let t' = EConstr.of_constr t' in
let t' = subst_univs_level_constr subst t' in
let bs' = List.map (EConstr.of_constr %> subst_univs_level_constr subst) bs in
+ let params = List.map (fun c -> subst_univs_level_constr subst c) params in
+ let us = List.map (fun c -> subst_univs_level_constr subst c) us in
let h, _ = decompose_app_vect sigma t' in
ctx',(h, t2),c',bs',(Stack.append_app_list params Stack.empty,params1),
(Stack.append_app_list us Stack.empty,us2),(extra_args1,extra_args2),c1,
@@ -310,8 +312,6 @@ let ise_stack2 no_app env evd f sk1 sk2 =
| Success i' -> ise_stack2 true i' q1 q2
| UnifFailure _ as x -> fail x
else fail (UnifFailure (i,NotSameHead))
- | Stack.Update _ :: _, _ | Stack.Shift _ :: _, _
- | _, Stack.Update _ :: _ | _, Stack.Shift _ :: _ -> assert false
| Stack.App _ :: _, Stack.App _ :: _ ->
if no_app && deep then fail ((*dummy*)UnifFailure(i,NotSameHead)) else
begin match ise_app_stack2 env f i sk1 sk2 with
@@ -344,8 +344,6 @@ let exact_ise_stack2 env evd f sk1 sk2 =
if Constant.equal (Projection.constant p1) (Projection.constant p2)
then ise_stack2 i q1 q2
else (UnifFailure (i, NotSameHead))
- | Stack.Update _ :: _, _ | Stack.Shift _ :: _, _
- | _, Stack.Update _ :: _ | _, Stack.Shift _ :: _ -> assert false
| Stack.App _ :: _, Stack.App _ :: _ ->
begin match ise_app_stack2 env f i sk1 sk2 with
|_,(UnifFailure _ as x) -> x
@@ -457,7 +455,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
let out1 = whd_betaiota_deltazeta_for_iota_state
(fst ts) env' evd Cst_stack.empty (c'1, Stack.empty) in
let out2 = whd_nored_state evd
- (Stack.zip evd (term', sk' @ [Stack.Shift 1]), Stack.append_app [|EConstr.mkRel 1|] Stack.empty),
+ (lift 1 (Stack.zip evd (term', sk')), Stack.append_app [|EConstr.mkRel 1|] Stack.empty),
Cst_stack.empty in
if onleft then evar_eqappr_x ts env' evd CONV out1 out2
else evar_eqappr_x ts env' evd CONV out2 out1
@@ -1067,8 +1065,8 @@ let evar_conv_x ts = evar_conv_x (ts, true)
(* Profiling *)
let evar_conv_x =
if Flags.profile then
- let evar_conv_xkey = Profile.declare_profile "evar_conv_x" in
- Profile.profile6 evar_conv_xkey evar_conv_x
+ let evar_conv_xkey = CProfile.declare_profile "evar_conv_x" in
+ CProfile.profile6 evar_conv_xkey evar_conv_x
else evar_conv_x
let evar_conv_hook_get, evar_conv_hook_set = Hook.make ~default:evar_conv_x ()
diff --git a/pretyping/miscops.ml b/pretyping/miscops.ml
index bc563b46dc..f0cb8fd1f2 100644
--- a/pretyping/miscops.ml
+++ b/pretyping/miscops.ml
@@ -30,7 +30,8 @@ let smartmap_cast_type f c =
let glob_sort_eq g1 g2 = match g1, g2 with
| GProp, GProp -> true
| GSet, GSet -> true
-| GType l1, GType l2 -> List.equal (fun x y -> Names.Name.equal (snd x) (snd y)) l1 l2
+| GType l1, GType l2 ->
+ List.equal (Option.equal (fun (x,m) (y,n) -> Libnames.eq_reference x y && Int.equal m n)) l1 l2
| _ -> false
let intro_pattern_naming_eq nam1 nam2 = match nam1, nam2 with
diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml
index dafe8cb269..79e0afa72b 100644
--- a/pretyping/nativenorm.ml
+++ b/pretyping/nativenorm.ml
@@ -436,11 +436,11 @@ let stop_profiler m_pid =
match profiler_platform() with
"Unix (Linux)" -> stop_profiler_linux m_pid
| _ -> ()
-
+
let native_norm env sigma c ty =
let c = EConstr.Unsafe.to_constr c in
let ty = EConstr.Unsafe.to_constr ty in
- if Coq_config.no_native_compiler then
+ if not Coq_config.native_compiler then
user_err Pp.(str "Native_compute reduction has been disabled at configure time.")
else
let penv = Environ.pre_env env in
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index 00c254dbe2..b930c5db83 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -177,61 +177,77 @@ let _ =
optwrite = (:=) Universes.set_minimization })
(** Miscellaneous interpretation functions *)
-let interp_known_universe_level evd id =
+
+let interp_known_universe_level evd r =
+ let loc, qid = Libnames.qualid_of_reference r in
try
- let level = Evd.universe_of_name evd id in
- level
+ match r with
+ | Libnames.Ident (loc, id) -> Evd.universe_of_name evd id
+ | Libnames.Qualid _ -> raise Not_found
with Not_found ->
- let names, _ = Global.global_universe_names () in
- snd (Id.Map.find id names)
-
-let interp_universe_level_name ~anon_rigidity evd (loc, s) =
- match s with
- | Anonymous ->
- new_univ_level_variable ?loc anon_rigidity evd
- | Name id ->
- let s = Id.to_string id in
- if CString.string_contains ~where:s ~what:"." then
- match List.rev (CString.split '.' s) with
- | [] -> anomaly (str"Invalid universe name " ++ str s ++ str".")
- | n :: dp ->
- let num = int_of_string n in
- let dp = DirPath.make (List.map Id.of_string dp) in
- let level = Univ.Level.make dp num in
- let evd =
- try Evd.add_global_univ evd level
- with UGraph.AlreadyDeclared -> evd
- in evd, level
- else
- try evd, interp_known_universe_level evd id
- with Not_found ->
- if not (is_strict_universe_declarations ()) then
- new_univ_level_variable ?loc ~name:id univ_rigid evd
- else user_err ?loc ~hdr:"interp_universe_level_name"
- (Pp.(str "Undeclared universe: " ++ str s))
+ let univ, k = Nametab.locate_universe qid in
+ Univ.Level.make univ k
+
+let interp_universe_level_name ~anon_rigidity evd r =
+ try evd, interp_known_universe_level evd r
+ with Not_found ->
+ match r with (* Qualified generated name *)
+ | Libnames.Qualid (loc, qid) ->
+ let dp, i = Libnames.repr_qualid qid in
+ let num =
+ try int_of_string (Id.to_string i)
+ with Failure _ ->
+ user_err ?loc ~hdr:"interp_universe_level_name"
+ (Pp.(str "Undeclared global universe: " ++ Libnames.pr_reference r))
+ in
+ let level = Univ.Level.make dp num in
+ let evd =
+ try Evd.add_global_univ evd level
+ with UGraph.AlreadyDeclared -> evd
+ in evd, level
+ | Libnames.Ident (loc, id) -> (* Undeclared *)
+ if not (is_strict_universe_declarations ()) then
+ new_univ_level_variable ?loc ~name:id univ_rigid evd
+ else user_err ?loc ~hdr:"interp_universe_level_name"
+ (Pp.(str "Undeclared universe: " ++ Id.print id))
let interp_universe ?loc evd = function
| [] -> let evd, l = new_univ_level_variable ?loc univ_rigid evd in
evd, Univ.Universe.make l
| l ->
- List.fold_left (fun (evd, u) l ->
- (* [univ_flexible_alg] can produce algebraic universes in terms *)
- let evd', l = interp_universe_level_name ~anon_rigidity:univ_flexible evd l in
- (evd', Univ.sup u (Univ.Universe.make l)))
+ List.fold_left (fun (evd, u) l ->
+ let evd', u' =
+ match l with
+ | Some (l,n) ->
+ (* [univ_flexible_alg] can produce algebraic universes in terms *)
+ let anon_rigidity = univ_flexible in
+ let evd', l = interp_universe_level_name ~anon_rigidity evd l in
+ let u' = Univ.Universe.make l in
+ (match n with
+ | 0 -> evd', u'
+ | 1 -> evd', Univ.Universe.super u'
+ | _ ->
+ user_err ?loc ~hdr:"interp_universe"
+ (Pp.(str "Cannot interpret universe increment +" ++ int n)))
+ | None ->
+ let evd, l = new_univ_level_variable ?loc univ_flexible evd in
+ evd, Univ.Universe.make l
+ in (evd', Univ.sup u u'))
(evd, Univ.Universe.type0m) l
let interp_known_level_info ?loc evd = function
- | None | Some (_, Anonymous) ->
+ | UUnknown | UAnonymous ->
user_err ?loc ~hdr:"interp_known_level_info"
(str "Anonymous universes not allowed here.")
- | Some (loc, Name id) ->
- try interp_known_universe_level evd id
+ | UNamed ref ->
+ try interp_known_universe_level evd ref
with Not_found ->
- user_err ?loc ~hdr:"interp_known_level_info" (str "Undeclared universe " ++ Id.print id)
+ user_err ?loc ~hdr:"interp_known_level_info" (str "Undeclared universe " ++ Libnames.pr_reference ref)
let interp_level_info ?loc evd : Misctypes.level_info -> _ = function
- | None -> new_univ_level_variable ?loc univ_rigid evd
- | Some (loc,s) -> interp_universe_level_name ~anon_rigidity:univ_flexible evd (Loc.tag ?loc s)
+ | UUnknown -> new_univ_level_variable ?loc univ_rigid evd
+ | UAnonymous -> new_univ_level_variable ?loc univ_flexible evd
+ | UNamed s -> interp_universe_level_name ~anon_rigidity:univ_flexible evd s
type inference_hook = env -> evar_map -> Evar.t -> evar_map * constr
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index ba0502ca45..ac88468545 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -284,8 +284,6 @@ sig
| Proj of int * int * projection * Cst_stack.t
| Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t
| Cst of cst_member * int * int list * 'a t * Cst_stack.t
- | Shift of int
- | Update of 'a
and 'a t = 'a member list
exception IncompatibleFold2
@@ -296,12 +294,12 @@ sig
val append_app : 'a array -> 'a t -> 'a t
val decomp : 'a t -> ('a * 'a t) option
val decomp_node_last : 'a app_node -> 'a t -> ('a * 'a t)
- val equal : ('a * int -> 'a * int -> bool) -> (('a, 'a) pfixpoint * int -> ('a, 'a) pfixpoint * int -> bool)
- -> 'a t -> 'a t -> (int * int) option
+ val equal : ('a -> 'a -> bool) -> (('a, 'a) pfixpoint -> ('a, 'a) pfixpoint -> bool)
+ -> 'a t -> 'a t -> bool
val compare_shape : 'a t -> 'a t -> bool
val map : ('a -> 'a) -> 'a t -> 'a t
val fold2 : ('a -> constr -> constr -> 'a) -> 'a ->
- constr t -> constr t -> 'a * int * int
+ constr t -> constr t -> 'a
val append_app_list : 'a list -> 'a t -> 'a t
val strip_app : 'a t -> 'a t * 'a t
val strip_n_app : int -> 'a t -> ('a t * 'a * 'a t) option
@@ -343,8 +341,6 @@ struct
| Proj of int * int * projection * Cst_stack.t
| Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t
| Cst of cst_member * int * int list * 'a t * Cst_stack.t
- | Shift of int
- | Update of 'a
and 'a t = 'a member list
let rec pr_member pr_c member =
@@ -367,8 +363,6 @@ struct
++ pr_comma () ++
prlist_with_sep pr_semicolon int remains ++
pr_comma () ++ pr pr_c params ++ str ")"
- | Shift i -> str "ZShift(" ++ int i ++ str ")"
- | Update t -> str "ZUpdate(" ++ pr_c t ++ str ")"
and pr pr_c l =
let open Pp in
prlist_with_sep pr_semicolon (fun x -> hov 1 (pr_member pr_c x)) l
@@ -403,54 +397,42 @@ struct
else (l.(j), sk)
let equal f f_fix sk1 sk2 =
- let equal_cst_member x lft1 y lft2 =
+ let equal_cst_member x y =
match x, y with
| Cst_const (c1,u1), Cst_const (c2, u2) ->
- Constant.equal c1 c2 && Univ.Instance.equal u1 u2
+ Constant.equal c1 c2 && Univ.Instance.equal u1 u2
| Cst_proj p1, Cst_proj p2 ->
- Constant.equal (Projection.constant p1) (Projection.constant p2)
+ Constant.equal (Projection.constant p1) (Projection.constant p2)
| _, _ -> false
in
- let rec equal_rec sk1 lft1 sk2 lft2 =
+ let rec equal_rec sk1 sk2 =
match sk1,sk2 with
- | [],[] -> Some (lft1,lft2)
- | (Update _ :: _, _ | _, Update _ :: _) -> assert false
- | Shift k :: s1, _ -> equal_rec s1 (lft1+k) sk2 lft2
- | _, Shift k :: s2 -> equal_rec sk1 lft1 s2 (lft2+k)
+ | [],[] -> true
| App a1 :: s1, App a2 :: s2 ->
- let t1,s1' = decomp_node_last a1 s1 in
- let t2,s2' = decomp_node_last a2 s2 in
- if f (t1,lft1) (t2,lft2) then equal_rec s1' lft1 s2' lft2 else None
+ let t1,s1' = decomp_node_last a1 s1 in
+ let t2,s2' = decomp_node_last a2 s2 in
+ (f t1 t2) && (equal_rec s1' s2')
| Case (_,t1,a1,_) :: s1, Case (_,t2,a2,_) :: s2 ->
- if f (t1,lft1) (t2,lft2) && CArray.equal (fun x y -> f (x,lft1) (y,lft2)) a1 a2
- then equal_rec s1 lft1 s2 lft2
- else None
+ f t1 t2 && CArray.equal (fun x y -> f x y) a1 a2 && equal_rec s1 s2
| (Proj (n1,m1,p,_)::s1, Proj(n2,m2,p2,_)::s2) ->
- if Int.equal n1 n2 && Int.equal m1 m2
- && Constant.equal (Projection.constant p) (Projection.constant p2)
- then equal_rec s1 lft1 s2 lft2
- else None
+ Int.equal n1 n2 && Int.equal m1 m2
+ && Constant.equal (Projection.constant p) (Projection.constant p2)
+ && equal_rec s1 s2
| Fix (f1,s1,_) :: s1', Fix (f2,s2,_) :: s2' ->
- if f_fix (f1,lft1) (f2,lft2) then
- match equal_rec (List.rev s1) lft1 (List.rev s2) lft2 with
- | None -> None
- | Some (lft1',lft2') -> equal_rec s1' lft1' s2' lft2'
- else None
+ f_fix f1 f2
+ && equal_rec (List.rev s1) (List.rev s2)
+ && equal_rec s1' s2'
| Cst (c1,curr1,remains1,params1,_)::s1', Cst (c2,curr2,remains2,params2,_)::s2' ->
- if equal_cst_member c1 lft1 c2 lft2 then
- match equal_rec (List.rev params1) lft1 (List.rev params2) lft2 with
- | Some (lft1',lft2') -> equal_rec s1' lft1' s2' lft2'
- | None -> None
- else None
- | ((App _|Case _|Proj _|Fix _|Cst _)::_|[]), _ -> None
- in equal_rec (List.rev sk1) 0 (List.rev sk2) 0
+ equal_cst_member c1 c2
+ && equal_rec (List.rev params1) (List.rev params2)
+ && equal_rec s1' s2'
+ | ((App _|Case _|Proj _|Fix _|Cst _)::_|[]), _ -> false
+ in equal_rec (List.rev sk1) (List.rev sk2)
let compare_shape stk1 stk2 =
let rec compare_rec bal stk1 stk2 =
match (stk1,stk2) with
([],[]) -> Int.equal bal 0
- | ((Update _|Shift _)::s1, _) -> compare_rec bal s1 stk2
- | (_, (Update _|Shift _)::s2) -> compare_rec bal stk1 s2
| (App (i,_,j)::s1, _) -> compare_rec (bal + j + 1 - i) s1 stk2
| (_, App (i,_,j)::s2) -> compare_rec (bal - j - 1 + i) stk1 s2
| (Case(c1,_,_,_)::s1, Case(c2,_,_,_)::s2) ->
@@ -466,40 +448,29 @@ struct
exception IncompatibleFold2
let fold2 f o sk1 sk2 =
- let rec aux o lft1 sk1 lft2 sk2 =
- let fold_array =
- Array.fold_left2 (fun a x y -> f a (Vars.lift lft1 x) (Vars.lift lft2 y))
- in
+ let rec aux o sk1 sk2 =
match sk1,sk2 with
- | [], [] -> o,lft1,lft2
- | Shift n :: q1, _ -> aux o (lft1+n) q1 lft2 sk2
- | _, Shift n :: q2 -> aux o lft1 sk1 (lft2+n) q2
+ | [], [] -> o
| App n1 :: q1, App n2 :: q2 ->
- let t1,l1 = decomp_node_last n1 q1 in
- let t2,l2 = decomp_node_last n2 q2 in
- aux (f o (Vars.lift lft1 t1) (Vars.lift lft2 t2))
- lft1 l1 lft2 l2
+ let t1,l1 = decomp_node_last n1 q1 in
+ let t2,l2 = decomp_node_last n2 q2 in
+ aux (f o t1 t2) l1 l2
| Case (_,t1,a1,_) :: q1, Case (_,t2,a2,_) :: q2 ->
- aux (fold_array
- (f o (Vars.lift lft1 t1) (Vars.lift lft2 t2))
- a1 a2) lft1 q1 lft2 q2
+ aux (Array.fold_left2 f (f o t1 t2) a1 a2) q1 q2
| Proj (n1,m1,p1,_) :: q1, Proj (n2,m2,p2,_) :: q2 ->
- aux o lft1 q1 lft2 q2
+ aux o q1 q2
| Fix ((_,(_,a1,b1)),s1,_) :: q1, Fix ((_,(_,a2,b2)),s2,_) :: q2 ->
- let (o',lft1',lft2') = aux (fold_array (fold_array o b1 b2) a1 a2)
- lft1 (List.rev s1) lft2 (List.rev s2) in
- aux o' lft1' q1 lft2' q2
+ let o' = aux (Array.fold_left2 f (Array.fold_left2 f o b1 b2) a1 a2) (List.rev s1) (List.rev s2) in
+ aux o' q1 q2
| Cst (cst1,_,_,params1,_) :: q1, Cst (cst2,_,_,params2,_) :: q2 ->
- let (o',lft1',lft2') =
- aux o lft1 (List.rev params1) lft2 (List.rev params2)
- in aux o' lft1' q1 lft2' q2
- | (((Update _|App _|Case _|Proj _|Fix _| Cst _) :: _|[]), _) ->
- raise IncompatibleFold2
- in aux o 0 (List.rev sk1) 0 (List.rev sk2)
+ let o' = aux o (List.rev params1) (List.rev params2) in
+ aux o' q1 q2
+ | (((App _|Case _|Proj _|Fix _| Cst _) :: _|[]), _) ->
+ raise IncompatibleFold2
+ in aux o (List.rev sk1) (List.rev sk2)
let rec map f x = List.map (function
- | Update _ -> assert false
- | (Proj (_,_,_,_) | Shift _) as e -> e
+ | (Proj (_,_,_,_)) as e -> e
| App (i,a,j) ->
let le = j - i + 1 in
App (0,Array.map f (Array.sub a i le), le-1)
@@ -516,18 +487,15 @@ struct
let rec args_size = function
| App (i,_,j)::s -> j + 1 - i + args_size s
- | Shift(_)::s -> args_size s
- | Update(_)::s -> args_size s
| (Case _|Fix _|Proj _|Cst _)::_ | [] -> 0
let strip_app s =
let rec aux out = function
- | ( App _ | Shift _ as e) :: s -> aux (e :: out) s
+ | ( App _ as e) :: s -> aux (e :: out) s
| s -> List.rev out,s
in aux [] s
let strip_n_app n s =
let rec aux n out = function
- | Shift k as e :: s -> aux n (e :: out) s
| App (i,a,j) as e :: s ->
let nb = j - i + 1 in
if n >= nb then
@@ -552,14 +520,12 @@ struct
let list_of_app_stack s =
let rec aux = function
| App (i,a,j) :: s ->
- let (k,(args',s')) = aux s in
- let a' = Array.map (Vars.lift k) (Array.sub a i (j - i + 1)) in
- k,(Array.fold_right (fun x y -> x::y) a' args', s')
- | Shift n :: s ->
- let (k,(args',s')) = aux s in (k+n,(args', s'))
- | s -> (0,([],s)) in
- let (lft,(out,s')) = aux s in
- let init = match s' with [] when Int.equal lft 0 -> true | _ -> false in
+ let (args',s') = aux s in
+ let a' = Array.sub a i (j - i + 1) in
+ (Array.fold_right (fun x y -> x::y) a' args', s')
+ | s -> ([],s) in
+ let (out,s') = aux s in
+ let init = match s' with [] -> true | _ -> false in
Option.init init out
let assign s p c =
@@ -568,20 +534,18 @@ struct
| None -> assert false
let tail n0 s0 =
- let rec aux lft n s =
- let out s = if Int.equal lft 0 then s else Shift lft :: s in
- if Int.equal n 0 then out s else
+ let rec aux n s =
+ if Int.equal n 0 then s else
match s with
| App (i,a,j) :: s ->
let nb = j - i + 1 in
if n >= nb then
- aux lft (n - nb) s
+ aux (n - nb) s
else
let p = i+n in
if j >= p then App(p,a,j)::s else s
- | Shift k :: s' -> aux (lft+k) n s'
| _ -> raise (Invalid_argument "Reductionops.Stack.tail")
- in aux 0 n0 s0
+ in aux n0 s0
let nth s p =
match strip_n_app p s with
@@ -627,11 +591,9 @@ struct
zip (best_state sigma (constr_of_cst_member cst (params @ (append_app [|f|] s))) cst_l)
| f, (Cst (cst,_,_,params,_)::s) ->
zip (constr_of_cst_member cst (params @ (append_app [|f|] s)))
- | f, (Shift n::s) -> zip (lift n f, s)
| f, (Proj (n,m,p,cst_l)::s) when refold ->
zip (best_state sigma (mkProj (p,f),s) cst_l)
| f, (Proj (n,m,p,_)::s) -> zip (mkProj (p,f),s)
- | _, (Update _::_) -> assert false
in
zip s
@@ -868,11 +830,9 @@ let _ = Goptions.declare_bool_option {
}
let equal_stacks sigma (x, l) (y, l') =
- let f_equal (x,lft1) (y,lft2) = eq_constr sigma (Vars.lift lft1 x) (Vars.lift lft2 y) in
- let eq_fix (a,b) (c,d) = f_equal (mkFix a, b) (mkFix c, d) in
- match Stack.equal f_equal eq_fix l l' with
- | None -> false
- | Some (lft1,lft2) -> f_equal (x, lft1) (y, lft2)
+ let f_equal x y = eq_constr sigma x y in
+ let eq_fix a b = f_equal (mkFix a) (mkFix b) in
+ Stack.equal f_equal eq_fix l l' && f_equal x y
let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma =
let open Context.Named.Declaration in
@@ -1074,7 +1034,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma =
(arg,
Stack.Cst (const,next,remains',s' @ (Stack.append_app [|x'|] bef),cst_l) :: s''')
end
- |_, (Stack.App _|Stack.Update _|Stack.Shift _)::_ -> assert false
+ |_, (Stack.App _)::_ -> assert false
|_, _ -> fold ()
else fold ()
@@ -1155,7 +1115,7 @@ let local_whd_state_gen flags sigma =
|args, (Stack.Fix (f,s',cst)::s'') when use_fix ->
let x' = Stack.zip sigma (x,args) in
whrec (contract_fix sigma f, s' @ (Stack.append_app [|x'|] s''))
- |_, (Stack.App _|Stack.Update _|Stack.Shift _|Stack.Cst _)::_ -> assert false
+ |_, (Stack.App _|Stack.Cst _)::_ -> assert false
|_, _ -> s
else s
@@ -1292,11 +1252,11 @@ let nf_all env sigma =
(* Conversion *)
(********************************************************************)
(*
-let fkey = Profile.declare_profile "fhnf";;
-let fhnf info v = Profile.profile2 fkey fhnf info v;;
+let fkey = CProfile.declare_profile "fhnf";;
+let fhnf info v = CProfile.profile2 fkey fhnf info v;;
-let fakey = Profile.declare_profile "fhnf_apply";;
-let fhnf_apply info k h a = Profile.profile4 fakey fhnf_apply info k h a;;
+let fakey = CProfile.declare_profile "fhnf_apply";;
+let fhnf_apply info k h a = CProfile.profile4 fakey fhnf_apply info k h a;;
*)
let is_transparent e k =
@@ -1306,7 +1266,7 @@ let is_transparent e k =
(* Conversion utility functions *)
-type conversion_test = constraints -> constraints
+type conversion_test = Constraint.t -> Constraint.t
let pb_is_equal pb = pb == Reduction.CONV
@@ -1685,7 +1645,7 @@ let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s =
if isConstruct sigma t_o then
whrec Cst_stack.empty (Stack.nth stack_o (n+m), stack'')
else s,csts'
- |_, ((Stack.App _| Stack.Shift _|Stack.Update _|Stack.Cst _) :: _|[]) -> s,csts'
+ |_, ((Stack.App _|Stack.Cst _) :: _|[]) -> s,csts'
in whrec csts s
let find_conclusion env sigma =
diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
index db0c29aeff..a277864c92 100644
--- a/pretyping/reductionops.mli
+++ b/pretyping/reductionops.mli
@@ -82,8 +82,6 @@ module Stack : sig
| Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t
| Cst of cst_member * int (** current foccussed arg *) * int list (** remaining args *)
* 'a t * Cst_stack.t
- | Shift of int
- | Update of 'a
and 'a t = 'a member list
val pr : ('a -> Pp.t) -> 'a t -> Pp.t
@@ -102,12 +100,12 @@ module Stack : sig
@return the result and the lifts to apply on the terms
@raise IncompatibleFold2 when [sk1] and [sk2] have incompatible shapes *)
val fold2 : ('a -> constr -> constr -> 'a) -> 'a ->
- constr t -> constr t -> 'a * int * int
+ constr t -> constr t -> 'a
val map : ('a -> 'a) -> 'a t -> 'a t
val append_app_list : 'a list -> 'a t -> 'a t
(** if [strip_app s] = [(a,b)], then [s = a @ b] and [b] does not
- start by App or Shift *)
+ start by App *)
val strip_app : 'a t -> 'a t * 'a t
(** @return (the nth first elements, the (n+1)th element, the remaining stack) *)
val strip_n_app : int -> 'a t -> ('a t * 'a * 'a t) option
@@ -262,7 +260,7 @@ val is_transparent : Environ.env -> Constant.t tableKey -> bool
(** {6 Conversion Functions (uses closures, lazy strategy) } *)
-type conversion_test = constraints -> constraints
+type conversion_test = Constraint.t -> Constraint.t
val pb_is_equal : conv_pb -> bool
val pb_equal : conv_pb -> conv_pb
diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml
index f8f086fad3..00b175c486 100644
--- a/pretyping/retyping.ml
+++ b/pretyping/retyping.ml
@@ -227,8 +227,8 @@ let type_of_global_reference_knowing_conclusion env sigma c conclty =
(* let f,_,_,_ = retype ~polyprop sigma in *)
(* if lax then f env c else anomaly_on_error (f env) c *)
-(* let get_type_of_key = Profile.declare_profile "get_type_of" *)
-(* let get_type_of = Profile.profile5 get_type_of_key get_type_of *)
+(* let get_type_of_key = CProfile.declare_profile "get_type_of" *)
+(* let get_type_of = CProfile.profile5 get_type_of_key get_type_of *)
(* let get_type_of ?(polyprop=true) ?(lax=false) env sigma c = *)
(* get_type_of polyprop lax env sigma c *)
diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml
index 85383ba398..5a522e06a5 100644
--- a/pretyping/tacred.ml
+++ b/pretyping/tacred.ml
@@ -927,8 +927,8 @@ let whd_simpl_orelse_delta_but_fix_old env sigma c =
let whd_simpl_stack =
if Flags.profile then
- let key = Profile.declare_profile "whd_simpl_stack" in
- Profile.profile3 key whd_simpl_stack
+ let key = CProfile.declare_profile "whd_simpl_stack" in
+ CProfile.profile3 key whd_simpl_stack
else whd_simpl_stack
(* Same as [whd_simpl] but also reduces constants that do not hide a
diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml
index 2e213a51d7..bbb3a1bb2b 100644
--- a/pretyping/typeclasses.ml
+++ b/pretyping/typeclasses.ml
@@ -442,19 +442,20 @@ let add_class cl =
let instance_constructor (cl,u) args =
let lenpars = List.count is_local_assum (snd cl.cl_context) in
+ let open EConstr in
let pars = fst (List.chop lenpars args) in
match cl.cl_impl with
| IndRef ind ->
let ind = ind, u in
- (Some (applistc (mkConstructUi (ind, 1)) args),
- applistc (mkIndU ind) pars)
+ (Some (applist (mkConstructUi (ind, 1), args)),
+ applist (mkIndU ind, pars))
| ConstRef cst ->
let cst = cst, u in
let term = match args with
| [] -> None
| _ -> Some (List.last args)
in
- (term, applistc (mkConstU cst) pars)
+ (term, applist (mkConstU cst, pars))
| _ -> assert false
let typeclasses () = Refmap.fold (fun _ l c -> l :: c) !classes []
@@ -552,8 +553,8 @@ let solve_all_instances env evd filter unique split fail =
Hook.get get_solve_all_instances env evd filter unique split fail
(** Profiling resolution of typeclasses *)
-(* let solve_classeskey = Profile.declare_profile "solve_typeclasses" *)
-(* let solve_problem = Profile.profile5 solve_classeskey solve_problem *)
+(* let solve_classeskey = CProfile.declare_profile "solve_typeclasses" *)
+(* let solve_problem = CProfile.profile5 solve_classeskey solve_problem *)
let resolve_typeclasses ?(fast_path = true) ?(filter=no_goals) ?(unique=get_typeclasses_unique_solutions ())
?(split=true) ?(fail=true) env evd =
diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli
index 618826f3d0..8ee061330a 100644
--- a/pretyping/typeclasses.mli
+++ b/pretyping/typeclasses.mli
@@ -83,8 +83,8 @@ val is_instance : global_reference -> bool
(** Returns the term and type for the given instance of the parameters and fields
of the type class. *)
-val instance_constructor : typeclass Univ.puniverses -> constr list ->
- constr option * types
+val instance_constructor : typeclass EConstr.puniverses -> EConstr.t list ->
+ EConstr.t option * EConstr.t
(** Filter which evars to consider for resolution. *)
type evar_filter = Evar.t -> Evar_kinds.t -> bool
diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index 84ffab4260..30674fee27 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -1077,13 +1077,13 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e
in
try
let opt' = {opt with with_types = false} in
- let (substn,_,_) = Reductionops.Stack.fold2
+ let substn = Reductionops.Stack.fold2
(fun s u1 u -> unirec_rec curenvnb pb opt' s u1 (substl ks u))
(evd,ms,es) us2 us in
- let (substn,_,_) = Reductionops.Stack.fold2
+ let substn = Reductionops.Stack.fold2
(fun s u1 u -> unirec_rec curenvnb pb opt' s u1 (substl ks u))
substn params1 params in
- let (substn,_,_) = Reductionops.Stack.fold2 (fun s u1 u2 -> unirec_rec curenvnb pb opt' s u1 u2) substn ts ts1 in
+ let substn = Reductionops.Stack.fold2 (fun s u1 u2 -> unirec_rec curenvnb pb opt' s u1 u2) substn ts ts1 in
let app = mkApp (c, Array.rev_of_list ks) in
(* let substn = unirec_rec curenvnb pb b false substn t cN in *)
unirec_rec curenvnb pb opt' substn c1 app
@@ -2015,8 +2015,8 @@ let w_unify env evd cv_pb flags ty1 ty2 =
let w_unify =
if Flags.profile then
- let wunifkey = Profile.declare_profile "w_unify" in
- Profile.profile6 wunifkey w_unify
+ let wunifkey = CProfile.declare_profile "w_unify" in
+ CProfile.profile6 wunifkey w_unify
else w_unify
let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 =
diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml
index b5b8987e33..e395bdbc63 100644
--- a/pretyping/vnorm.ml
+++ b/pretyping/vnorm.ml
@@ -365,4 +365,4 @@ let vm_infer_conv ?(pb=Reduction.CUMUL) env sigma t1 t2 =
Reductionops.infer_conv_gen (fun pb ~l2r sigma ts -> Vconv.vm_conv_gen pb)
~catch_incon:true ~pb env sigma t1 t2
-let _ = Reductionops.set_vm_infer_conv vm_infer_conv
+let _ = if Coq_config.bytecode_compiler then Reductionops.set_vm_infer_conv vm_infer_conv
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-30 20:06:09 +0000