aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.github/PULL_REQUEST_TEMPLATE.md3
-rw-r--r--configure.ml2
-rw-r--r--doc/sphinx/proof-engine/tactics.rst17
-rw-r--r--interp/constrintern.ml15
-rw-r--r--kernel/reduction.ml45
-rw-r--r--tactics/class_tactics.ml27
-rw-r--r--tactics/hints.ml13
-rw-r--r--tactics/term_dnet.mli2
-rw-r--r--test-suite/bugs/closed/4403.v3
-rw-r--r--vernac/vernacexpr.ml4
10 files changed, 63 insertions, 68 deletions
diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md
index 86c15f6e80..4a8606a38a 100644
--- a/.github/PULL_REQUEST_TEMPLATE.md
+++ b/.github/PULL_REQUEST_TEMPLATE.md
@@ -10,6 +10,9 @@
Fixes / closes #????
+<!-- If there is a user-visible change in coqc/coqtop/coqchk/coq_makefile behavior and testing is not prohibitively expensive: -->
+<!-- (Otherwise, remove this line.) -->
+- [ ] Added / updated test-suite
<!-- If this is a feature pull request / breaks compatibility: -->
<!-- (Otherwise, remove these lines.) -->
- [ ] Corresponding documentation was added / updated (including any warning and error messages added / removed / modified).
diff --git a/configure.ml b/configure.ml
index 45c3bb67a4..933143e682 100644
--- a/configure.ml
+++ b/configure.ml
@@ -33,7 +33,7 @@ let cprintf s = cfprintf stdout s
let ceprintf s = cfprintf stderr s
let die msg = ceprintf "%s%s%s\nConfiguration script failed!" red msg reset; exit 1
-let warn s = cprintf ("%sWarning: " ^^ s ^^ "%s") yellow reset
+let warn s = kfprintf (fun oc -> cfprintf oc "%s" reset) stdout ("%sWarning: " ^^ s) yellow
let s2i = int_of_string
let i2s = string_of_int
diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst
index da4c3f9d74..051c28f910 100644
--- a/doc/sphinx/proof-engine/tactics.rst
+++ b/doc/sphinx/proof-engine/tactics.rst
@@ -879,14 +879,6 @@ quantification or an implication.
This is equivalent to :n:`clear @ident. ... clear @ident.`
-.. tacv:: clearbody @ident
- :name: clearbody
-
- This tactic expects :n:`@ident` to be a local definition then clears its
- body. Otherwise said, this tactic turns a definition into an assumption.
-
-.. exn:: @ident is not a local definition.
-
.. tacv:: clear - {+ @ident}
This tactic clears all the hypotheses except the ones depending in the
@@ -901,6 +893,15 @@ quantification or an implication.
This clears the hypothesis :n:`@ident` and all the hypotheses that depend on
it.
+.. tacv:: clearbody {+ @ident}
+ :name: clearbody
+
+ This tactic expects :n:`{+ @ident}` to be local definitions and clears their
+ respective bodies.
+ In other words, it turns the given definitions into assumptions.
+
+.. exn:: @ident is not a local definition.
+
.. tacn:: revert {+ @ident}
:name: revert
diff --git a/interp/constrintern.ml b/interp/constrintern.ml
index 1691ff6d86..848180743f 100644
--- a/interp/constrintern.ml
+++ b/interp/constrintern.ml
@@ -1141,9 +1141,18 @@ let check_number_of_pattern loc n l =
if not (Int.equal n p) then raise (InternalizationError (loc,BadPatternsNumber (n,p)))
let check_or_pat_variables loc ids idsl =
- if List.exists (fun ids' -> not (List.eq_set (fun {loc;v=id} {v=id'} -> Id.equal id id') ids ids')) idsl then
- user_err ?loc (str
- "The components of this disjunctive pattern must bind the same variables.")
+ let eq_id {v=id} {v=id'} = Id.equal id id' in
+ (* Collect remaining patterns which do not have the same variables as the first pattern *)
+ let idsl = List.filter (fun ids' -> not (List.eq_set eq_id ids ids')) idsl in
+ match idsl with
+ | ids'::_ ->
+ (* Look for an [id] which is either in [ids] and not in [ids'] or in [ids'] and not in [ids] *)
+ let ids'' = List.subtract eq_id ids ids' in
+ let ids'' = if ids'' = [] then List.subtract eq_id ids' ids else ids'' in
+ user_err ?loc
+ (strbrk "The components of this disjunctive pattern must bind the same variables (" ++
+ Id.print (List.hd ids'').v ++ strbrk " is not bound in all patterns).")
+ | [] -> ()
(** Use only when params were NOT asked to the user.
@return if letin are included *)
diff --git a/kernel/reduction.ml b/kernel/reduction.ml
index 8ca596d482..f4af313867 100644
--- a/kernel/reduction.ml
+++ b/kernel/reduction.ml
@@ -648,25 +648,24 @@ let check_leq univs u u' =
let check_sort_cmp_universes env pb s0 s1 univs =
let open Sorts in
- match (s0,s1) with
+ if not (type_in_type env) then
+ match (s0,s1) with
| (Prop c1, Prop c2) when is_cumul pb ->
begin match c1, c2 with
- | Null, _ | _, Pos -> () (* Prop <= Set *)
- | _ -> raise NotConvertible
+ | Null, _ | _, Pos -> () (* Prop <= Set *)
+ | _ -> raise NotConvertible
end
| (Prop c1, Prop c2) -> if c1 != c2 then raise NotConvertible
| (Prop c1, Type u) ->
- if not (type_in_type env) then
- let u0 = univ_of_sort s0 in
- (match pb with
- | CUMUL -> check_leq univs u0 u
- | CONV -> check_eq univs u0 u)
+ let u0 = univ_of_sort s0 in
+ (match pb with
+ | CUMUL -> check_leq univs u0 u
+ | CONV -> check_eq univs u0 u)
| (Type u, Prop c) -> raise NotConvertible
| (Type u1, Type u2) ->
- if not (type_in_type env) then
- (match pb with
- | CUMUL -> check_leq univs u1 u2
- | CONV -> check_eq univs u1 u2)
+ (match pb with
+ | CUMUL -> check_leq univs u1 u2
+ | CONV -> check_eq univs u1 u2)
let checked_sort_cmp_universes env pb s0 s1 univs =
check_sort_cmp_universes env pb s0 s1 univs; univs
@@ -699,25 +698,25 @@ let infer_leq (univs, cstrs as cuniv) u u' =
let infer_cmp_universes env pb s0 s1 univs =
let open Sorts in
- match (s0,s1) with
+ if type_in_type env then univs
+ else
+ match (s0,s1) with
| (Prop c1, Prop c2) when is_cumul pb ->
begin match c1, c2 with
- | Null, _ | _, Pos -> univs (* Prop <= Set *)
- | _ -> raise NotConvertible
+ | Null, _ | _, Pos -> univs (* Prop <= Set *)
+ | _ -> raise NotConvertible
end
| (Prop c1, Prop c2) -> if c1 == c2 then univs else raise NotConvertible
| (Prop c1, Type u) ->
let u0 = univ_of_sort s0 in
- (match pb with
- | CUMUL -> infer_leq univs u0 u
- | CONV -> infer_eq univs u0 u)
+ (match pb with
+ | CUMUL -> infer_leq univs u0 u
+ | CONV -> infer_eq univs u0 u)
| (Type u, Prop c) -> raise NotConvertible
| (Type u1, Type u2) ->
- if not (type_in_type env) then
- (match pb with
- | CUMUL -> infer_leq univs u1 u2
- | CONV -> infer_eq univs u1 u2)
- else univs
+ (match pb with
+ | CUMUL -> infer_leq univs u1 u2
+ | CONV -> infer_eq univs u1 u2)
let infer_convert_instances ~flex u u' (univs,cstrs) =
let cstrs' =
diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml
index 998efdd6da..c105116ff9 100644
--- a/tactics/class_tactics.ml
+++ b/tactics/class_tactics.ml
@@ -649,17 +649,6 @@ module Search = struct
Evd.add sigma gl evi')
sigma goals
- let fail_if_nonclass info =
- Proofview.Goal.enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
- if is_class_type sigma (Proofview.Goal.concl gl) then
- Proofview.tclUNIT ()
- else (if !typeclasses_debug > 1 then
- Feedback.msg_debug (pr_depth info.search_depth ++
- str": failure due to non-class subgoal " ++
- pr_ev sigma (Proofview.Goal.goal gl));
- Proofview.tclZERO NoApplicableEx) end
-
(** The general hint application tactic.
tac1 + tac2 .... The choice of OR or ORELSE is determined
depending on the dependencies of the goal and the unique/Prop
@@ -798,13 +787,8 @@ module Search = struct
in
if path_matches derivs [] then aux e tl
else
- let filter =
- if false (* in 8.6, still allow non-class subgoals
- info.search_only_classes *) then fail_if_nonclass info
- else Proofview.tclUNIT ()
- in
ortac
- (with_shelf (tac <*> filter) >>= fun s ->
+ (with_shelf tac >>= fun s ->
let i = !idx in incr idx; result s i None)
(fun e' ->
if CErrors.noncritical (fst e') then
@@ -868,12 +852,9 @@ module Search = struct
let search_tac_gl ?st only_classes dep hints depth i sigma gls gl :
unit Proofview.tactic =
let open Proofview in
- if false (* In 8.6, still allow non-class goals only_classes && not (is_class_type sigma (Goal.concl gl)) *) then
- Tacticals.New.tclZEROMSG (str"Not a subgoal for a class")
- else
- let dep = dep || Proofview.unifiable sigma (Goal.goal gl) gls in
- let info = make_autogoal ?st only_classes dep (cut_of_hints hints) i gl in
- search_tac hints depth 1 info
+ let dep = dep || Proofview.unifiable sigma (Goal.goal gl) gls in
+ let info = make_autogoal ?st only_classes dep (cut_of_hints hints) i gl in
+ search_tac hints depth 1 info
let search_tac ?(st=full_transparent_state) only_classes dep hints depth =
let open Proofview in
diff --git a/tactics/hints.ml b/tactics/hints.ml
index d3acb5aa53..4b77418ff4 100644
--- a/tactics/hints.ml
+++ b/tactics/hints.ml
@@ -1379,12 +1379,10 @@ let expand_constructor_hints env sigma lems =
(* builds a hint database from a constr signature *)
(* typically used with (lid, ltyp) = pf_hyps_types <some goal> *)
-let add_hint_lemmas env sigma eapply lems hint_db =
+let constructor_hints env sigma eapply lems =
let lems = expand_constructor_hints env sigma lems in
- let hintlist' =
- List.map_append (fun (poly, lem) ->
- make_resolves env sigma (eapply,true,false) empty_hint_info poly lem) lems in
- Hint_db.add_list env sigma hintlist' hint_db
+ List.map_append (fun (poly, lem) ->
+ make_resolves env sigma (eapply,true,false) empty_hint_info poly lem) lems
let make_local_hint_db env sigma ts eapply lems =
let map c = c env sigma in
@@ -1395,8 +1393,9 @@ let make_local_hint_db env sigma ts eapply lems =
| Some ts -> ts
in
let hintlist = List.map_append (make_resolve_hyp env sigma) sign in
- add_hint_lemmas env sigma eapply lems
- (Hint_db.add_list env sigma hintlist (Hint_db.empty ts false))
+ Hint_db.empty ts false
+ |> Hint_db.add_list env sigma hintlist
+ |> Hint_db.add_list env sigma (constructor_hints env sigma eapply lems)
let make_local_hint_db env sigma ?ts eapply lems =
make_local_hint_db env sigma ts eapply lems
diff --git a/tactics/term_dnet.mli b/tactics/term_dnet.mli
index 2c748f9c93..7bce577899 100644
--- a/tactics/term_dnet.mli
+++ b/tactics/term_dnet.mli
@@ -26,7 +26,7 @@ open Mod_subst
The results returned here are perfect, since post-filtering is done
inside here.
- See lib/dnet.mli for more details.
+ See tactics/dnet.mli for more details.
*)
(** Identifiers to store (right hand side of the association) *)
diff --git a/test-suite/bugs/closed/4403.v b/test-suite/bugs/closed/4403.v
new file mode 100644
index 0000000000..a80f38fe2a
--- /dev/null
+++ b/test-suite/bugs/closed/4403.v
@@ -0,0 +1,3 @@
+(* -*- coq-prog-args: ("-type-in-type"); -*- *)
+
+Definition some_prop : Prop := Type.
diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml
index 74355e1a7d..fb40f0d9ce 100644
--- a/vernac/vernacexpr.ml
+++ b/vernac/vernacexpr.ml
@@ -106,13 +106,13 @@ type comment =
type reference_or_constr = Hints.reference_or_constr =
| HintsReference of reference
| HintsConstr of constr_expr
-[@@ocaml.deprecated "Please use [Hints.hints_expr]"]
+[@@ocaml.deprecated "Please use [Hints.reference_or_constr]"]
type hint_mode = Hints.hint_mode =
| ModeInput (* No evars *)
| ModeNoHeadEvar (* No evar at the head *)
| ModeOutput (* Anything *)
-[@@ocaml.deprecated "Please use [Hints.hints_expr]"]
+[@@ocaml.deprecated "Please use [Hints.hint_mode]"]
type 'a hint_info_gen = 'a Typeclasses.hint_info_gen =
{ hint_priority : int option;
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-30 05:26:26 +0000